Merge remote-tracking branch 'origin/release-v4.6.1'
[WRF.git] / phys / module_mp_full_sbm.F
bloba491a15f294b165ee4143abe5aa8345b3560cd0b
1 !WRF:MODEL_MP:PHYSICS
2 ! The FULL version calculates hydrometeor distributions for qc,qr,qs,qg. and qh, and three ice types,
3 ! and their number concentrations (and aerosol concentrations).
4 ! To use the FULL version of SBM, please do the following.
5 ! Set DX_BOUND to some value larger than the first inner nest, but smaller than the outer domain in meters
6 ! Set the aerosol concentration with the variables FCCNR_MAR, and FCCNR_CON, FCCNR_MIX.  
7 ! Each of the aerosol distributions are set with ACCN (concentration of ccn particles at 1% saturation), and
8 ! BCCN (the "k" coefficient; for example: FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN). 
9 ! Questions: contact barry.h.lynn@gmail.com (Barry Lynn)
12 MODULE module_mp_full_sbm
13 USE module_mp_radar
15 !-----------------------------------------------------------------------
16 ! BARRY
17       INTEGER,PRIVATE,PARAMETER :: REMSAT = 0
18       INTEGER, PRIVATE,PARAMETER :: IBREAKUP=1
19       LOGICAL, PRIVATE,PARAMETER :: CONSERV=.TRUE.
20 ! SET ONE = TRUE
21       LOGICAL, PRIVATE,PARAMETER :: ORIGINAL_MELT=.FALSE.
22       LOGICAL, PRIVATE,PARAMETER :: JIWEN_FAN_MELT=.TRUE.
23 !     LOGICAL, PRIVATE,PARAMETER :: ORIGINAL_MELT=.TRUE.
24 !     LOGICAL, PRIVATE,PARAMETER :: JIWEN_FAN_MELT=.FALSE.
25       INTEGER, PRIVATE,PARAMETER :: p_ff1i01=2, p_ff1i33=34,p_ff5i01=35,p_ff5i33=67,p_ff6i01=68,&
26      & p_ff6i33=100,p_ff8i01=101,p_ff8i33=133,p_ff2i01=134,p_ff2i33=166,p_ff3i01=167,p_ff3i33=199,&
27      & p_ff4i01=200,p_ff4i33=232,p_ff7i01=233,p_ff7i33=265
28 !p_ff1i01 =            2
29 !p_ff1i33 =           34
30 !p_ff5i01 =           35
31 !p_ff5i33 =           67
32 !p_ff6i01 =           68
33 !p_ff6i33 =          100
34 !p_ff8i01 =          101
35 !p_ff8i33 =          133
36 !p_ff2i01 =          134
37 !p_ff2i33 =          166
38 !p_ff3i01 =          167
39 !p_ff3i33 =          199
40 !p_ff4i01 =          200
41 !p_ff4i33 =          232
42 !p_ff7i01 =          233
43 !p_ff7i33 =          265
46 !     100
47 !     REAL,PRIVATE,PARAMETER :: F_AMOUNT=0.1
48 !     TEN 
49 !     REAL,PRIVATE,PARAMETER :: F_AMOUNT=0.01
50 !     ONE
51       REAL, PRIVATE,PARAMETER :: PI_MORR = 3.1415926535897932384626434
52       REAL, PRIVATE,PARAMETER ::  R_MORR = 287.15
53       REAL,PRIVATE,PARAMETER :: F_AMOUNT=0.001
54       REAL,PRIVATE,PARAMETER :: DX_BOUND=7500
55       REAL ACCN,BCCN
56       REAL,PRIVATE,PARAMETER :: ACCN_MAR=1.0000E02, BCCN_MAR=0.900E00,ROCCN0=0.1000E01
57       REAL,PRIVATE,PARAMETER :: ACCN_CON=2.00000E03, BCCN_CON=0.400E00,ROCCN03=0.1000E01
58       REAL,PRIVATE,PARAMETER :: I3POINT=1
59       INTEGER,PRIVATE,PARAMETER :: ICCN = 1
60        DOUBLE PRECISION, PRIVATE, PARAMETER ::  SCAL=1.d0
61        INTEGER, PRIVATE,PARAMETER :: ICEPROCS=1,BULKNUC=0 
62        INTEGER, PRIVATE,PARAMETER :: ICETURB=0,LIQTURB=0
63 !      INTEGER, PRIVATE,PARAMETER :: RAIN_INIT=1,GRAUPEL_INIT=1
64 !      INTEGER, PRIVATE,PARAMETER :: ICE_INIT=0,SNOW_INIT=1
66        INTEGER, PRIVATE,PARAMETER :: ICEMAX=3,NCD=33,NHYDR=5,NHYDRO=7  &
67      &        ,ifreez_down1=0,ifreez_down2=1,ifreez_top=1              &
68      &        ,K0_LL=8,KRMIN_LL=1,KRMAX_LL=19,L0_LL=6                  &
69      &        , IEPS_400=1,IEPS_800=0,IEPS_1600=0                      &
70      &        ,K0L_GL=16,K0G_GL=16                                     &
71      &        ,KRMINL_GL=1,KRMAXL_GL=24                                &
72      &        ,KRMING_GL=1,KRMAXG_GL=33                                &
73      &        ,KRDROP=18,KRBREAK=17,KRICE=18                           &
74      &        ,NKR=33,JMAX=33,NRG=2,JBREAK = 18 
75        REAL dt_coll
76 !      REAL, PRIVATE,PARAMETER ::C1_MEY=0.0033,C2_MEY=0.              &
77        REAL, PRIVATE,PARAMETER ::C1_MEY=0.00033,C2_MEY=0.              &
78 ! New CONTINENTAL
79 !      REAL, PRIVATE,PARAMETER ::C1_MEY=0.0033,C2_MEY=0.              &
80      &        ,an0_freez=10.,COL=0.23105                                
81        REAL, PRIVATE,PARAMETER :: p1=1000000.0,p2=750000.0,p3=500000.0                     
82 !      INTEGER, PRIVATE,PARAMETER :: NCOND=3
83 !      INTEGER, PRIVATE,PARAMETER :: NCOND=6
84        INTEGER, PRIVATE :: NCOND
85        INTEGER, PRIVATE,PARAMETER :: kr_icempl=9
86 !      REAL, PRIVATE, PARAMETER :: ALCR = 1.0
87 !      REAL, PRIVATE, PARAMETER :: ALCR = 2.0
88 !      REAL, PRIVATE, PARAMETER :: ALCR = 1.5
89        REAL, PRIVATE, PARAMETER :: ALCR = 2.25
90 !      REAL, PRIVATE, PARAMETER :: ALCR = 3.0
91        REAL, PRIVATE, PARAMETER :: ALCR_G = 3.0
92 !      REAL, PRIVATE, PARAMETER :: ALCR_G = 1.0
93        INTEGER,PRIVATE,PARAMETER :: icempl=1
94        REAL, PRIVATE, PARAMETER :: COEFREFLL=1.E6*36.E6*COL/3.1453/3.1453 
95        REAL, PRIVATE, PARAMETER :: COEFREFLI=1.E9*36.E3*COL/3.1453/3.1453/5.
96        REAL, PRIVATE, PARAMETER :: COEFREF00=1.E9*36.E3*COL/3.1453/3.1453       
97        REAL, PRIVATE,DIMENSION(NKR) ::COLREFLL,COLREFLI,COLREFLS,COLREFLG,COLREFLH
100 ! YWLL_1000MB(nkr,nkr) - input array of kernels for pressure 1000mb
101 ! YWLL_750MB(nkr,nkr) - input array of kernels for pressure 750mb
102 ! YWLL_500MB(nkr,nkr) - input array of kernels for pressure 500mb
103        REAL, PRIVATE, SAVE :: &
104 ! CRYSTALS 
105      &YWLI(NKR,NKR,ICEMAX) &
106 ! MIXTURES
107      &,YWIL(NKR,NKR,ICEMAX),YWII(NKR,NKR,ICEMAX,ICEMAX) &
108      &,YWIS(NKR,NKR,ICEMAX),YWIG(NKR,NKR,ICEMAX) &
109      &,YWIH(NKR,NKR,ICEMAX),YWSI(NKR,NKR,ICEMAX) &
110      &,YWGI(NKR,NKR,ICEMAX),YWHI(NKR,NKR,ICEMAX)
112       REAL,PRIVATE,DIMENSION(NKR,NKR),SAVE :: &
113      & YWLL_1000MB,YWLL_750MB,YWLL_500MB,YWLL,YWLS,YWLG,YWLH &
114 ! SNOW :
115      &,YWSL,YWSS,YWSG,YWSH &
116 ! GRAUPELS :
117      &,YWGL,YWGS,YWGG,YWGH &
118 ! HAIL :
119      &,YWHL,YWHS,YWHG,YWHH
120        REAL, PRIVATE, SAVE :: &
121      &  XI(NKR,ICEMAX) &
122      & ,RADXX(NKR,NHYDR-1),MASSXX(NKR,NHYDR-1),DENXX(NKR,NHYDR-1) &
123      & ,RADXXO(NKR,NHYDRO),MASSXXO(NKR,NHYDRO),DENXXO(NKR,NHYDRO) &
124      & ,RIEC(NKR,ICEMAX),COEFIN(NKR),SLIC(NKR,6),TLIC(NKR,2) &
125      & ,RO2BL(NKR,ICEMAX)
126        REAL, PRIVATE, SAVE :: VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR) &
127      & ,VR4(NKR),VR5(NKR),VRX(NKR),VRI(NKR)
128       REAL,PRIVATE,DIMENSION(NKR),SAVE ::  &
129      &  XL,RLEC,XX,XCCN,XS,RSEC &
130      & ,XG,RGEC,XH,RHEC,RO1BL,RO3BL,RO4BL,RO5BL &
131      & ,ROCCN,RCCN,DROPRADII
132   
133       REAL, PRIVATE,SAVE ::  FCCNR_MAR(NKR),FCCNR_CON(NKR)
134       REAL, PRIVATE,SAVE ::  FCCNR_MIX(NKR)
135       REAL, PRIVATE,SAVE ::  FCCNR(NKR)
138         REAL, PRIVATE :: C2,C3,C4
139       double precision,private,save ::  cwll(nkr,nkr)
140       double precision,private,save::  &
141      & xl_mg(0:nkr),xs_mg(0:nkr),xg_mg(0:nkr),xh_mg(0:nkr) &
142      &,xi1_mg(0:nkr),xi2_mg(0:nkr),xi3_mg(0:nkr) &
143      &,chucm(nkr,nkr),ima(nkr,nkr) &
144      &,cwll_1000mb(nkr,nkr),cwll_750mb(nkr,nkr),cwll_500mb(nkr,nkr) &
145      &,cwli_1(nkr,nkr),cwli_2(nkr,nkr),cwli_3(nkr,nkr) &
146      &,cwls(nkr,nkr),cwlg(nkr,nkr),cwlh(nkr,nkr) &
148      &,cwil_1(nkr,nkr),cwil_2(nkr,nkr),cwil_3(nkr,nkr) &
150      &,cwii_1_1(nkr,nkr),cwii_1_2(nkr,nkr),cwii_1_3(nkr,nkr) &
151      &,cwii_2_1(nkr,nkr),cwii_2_2(nkr,nkr),cwii_2_3(nkr,nkr) &
152      &,cwii_3_1(nkr,nkr),cwii_3_2(nkr,nkr),cwii_3_3(nkr,nkr) &
154      &,cwis_1(nkr,nkr),cwis_2(nkr,nkr),cwis_3(nkr,nkr) &
155      &,cwig_1(nkr,nkr),cwig_2(nkr,nkr),cwig_3(nkr,nkr) &
156      &,cwih_1(nkr,nkr),cwih_2(nkr,nkr),cwih_3(nkr,nkr) &
158      &,cwsl(nkr,nkr) &
159      &,cwsi_1(nkr,nkr),cwsi_2(nkr,nkr),cwsi_3(nkr,nkr)&
160      &,cwss(nkr,nkr),cwsg(nkr,nkr),cwsh(nkr,nkr) &
161      &,cwgl(nkr,nkr)&
162      &,cwgi_1(nkr,nkr),cwgi_2(nkr,nkr),cwgi_3(nkr,nkr)&
163      &,cwgs(nkr,nkr),cwgg(nkr,nkr),cwgh(nkr,nkr) &
165      &,cwhl(nkr,nkr) &
166      &,cwhi_1(nkr,nkr),cwhi_2(nkr,nkr),cwhi_3(nkr,nkr) &
167      &,cwhs(nkr,nkr),cwhg(nkr,nkr),cwhh(nkr,nkr) &
168      &,dlnr &
169      &,CTURBLL(KRMAX_LL,KRMAX_LL)&
170      &,CTURB_LL(K0_LL,K0_LL)&
171      &,CTURBGL(KRMAXG_GL,KRMAXL_GL)&
172      &,CTURB_GL(K0G_GL,K0L_GL)
174       DOUBLE PRECISION,private, save :: &
175      &   BRKWEIGHT(JBREAK),PKIJ(JBREAK,JBREAK,JBREAK), &
176      &   QKJ(JBREAK,JBREAK),ECOALMASSM(NKR,NKR)
184       CONTAINS
186 !-----------------------------------------------------------------------
187 !-----------------------------------------------------------------------
188       SUBROUTINE SBM (w,u,v,th_old,                                &
189      &                      chem_new,n_chem,                              &
190      &                      itimestep,DT,DX,DY,                         &
191      &                      dz8w,rho_phy,p_phy,pi_phy,th_phy,           &
192      &                      xland,ivgtyp,xlat,xlong,                           &
193      &                      QV,QC,QR,QIP,QIC,QID,QS,QG,QH,QV_OLD,                   &
194      &                      QNC,QNR,QNIP,QNIC,QNID,QNS,QNG,QNH,QNA,EFFR,ICE_EFFR,TOT_EFFR,       &
195      &                      QIC_EFFR,QIP_EFFR,QID_EFFR,       &
196      &                      height,tempc,&
197 !    &                      QRRAD,QSRAD,QGRAD,QTIRAD,QTOTRAD,           &
198 !    &                      QRRAD,QSRAD,QGRAD,                          &
199      &                      kext_ql,kext_qs,kext_qg,kext_qh,kext_qa,    &
200      &                      kext_qic,kext_qip,kext_qid,                 &
201      &                      kext_ft_qic,kext_ft_qip,kext_ft_qid,                 &
202      &                      kext_ft_qs,kext_ft_qg,                 &
203      &                      ids,ide, jds,jde, kds,kde,                  &
204      &                      ims,ime, jms,jme, kms,kme,                  &
205      &                      its,ite, jts,jte, kts,kte,                  &
206      &                      refl_10cm, diagflag, do_radar_ref,      & ! MO added for reflectivity calcs
207      &                      RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,HAILNC,HAILNCV,SR )
208 !-----------------------------------------------------------------------
209       IMPLICIT NONE
210 !-----------------------------------------------------------------------
211       INTEGER, PARAMETER :: ITLO=-60, ITHI=40
212       INTEGER NKRO,NKRE
213       INTEGER KR,IKL,ICE
215       INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
216      &                     ,IMS,IME,JMS,JME,KMS,KME                     &
217      &                     ,ITS,ITE,JTS,JTE,KTS,KTE                     &
218      &                     ,ITIMESTEP,N_CHEM
220       REAL, INTENT(IN)      :: DT,DX,DY
221    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
222           INTENT(IN   ) ::                                   &
223                                                           U, &
224                                                           V, &
225                                                           W   
226 !                                                        pi
227   REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem),INTENT(INOUT)   :: chem_new
228   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
229         INTENT(INOUT) ::                                          &
230                                                               qv, &
231                                                           qv_old, &
232                                                           th_old, &
233                                                               qc, &
234                                                               qr, &
235                                                               qip, &
236                                                               qic, &
237                                                               qid, &
238                                                               qs, &
239                                                               qg, &
240                                                               qh, &
241                                                               qnc, &
242                                                               qnr, &
243                                                               qns, &
244                                                               qnip, &
245                                                               qnic, &
246                                                               qnid, &
247                                                               qng, &
248                                                               qnh, &
249                                                               qna, &
250                                                               kext_ql, &
251                                                               kext_qs, &
252                                                               kext_qg, &
253                                                               kext_qh, &
254                                                               kext_qa, &
255                                                               kext_qic, &
256                                                               kext_qip, &
257                                                               kext_qid, &
258                                                               kext_ft_qic, &
259                                                               kext_ft_qip, &
260                                                               kext_ft_qid, &
261                                                               kext_ft_qs, &
262                                                               kext_ft_qg, &
263                                                               effr, &
264                                                               ice_effr,&
265                                                               tot_effr,&
266                                                               qic_effr,&
267                                                               qip_effr,&
268                                                               qid_effr,&
269                                                               height,  &
270                                                               tempc    
271 !                                                             effr, &
272 !                                                            qtirad, &
273 !                                                             qtotrad
277       REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN)   :: XLAND
278       LOGICAL, OPTIONAL, INTENT(IN) :: diagflag
279       INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref
281       REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT)::       &  ! GT
282                           refl_10cm
284       INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN)::   IVGTYP
285       REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )    :: XLAT, XLONG
286       REAL, INTENT(IN),     DIMENSION(ims:ime, kms:kme, jms:jme)::      &
287      &                      dz8w,p_phy,pi_phy,rho_phy
288       REAL, INTENT(INOUT),  DIMENSION(ims:ime, kms:kme, jms:jme)::      &
289      &                      th_phy
290       REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
291      &     RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,HAILNC,HAILNCV,SR
292 !     REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
293 !     REAL,                 DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
294 !    &              LIQUEXP,ICEEXP,SNOWEXP,GRAUEXP,HAILEXP
297 !-----------------------------------------------------------------------
298 !     LOCAL VARS
299 !-----------------------------------------------------------------------
301 !     NSTATS,QMAX,QTOT are diagnostic vars
303       INTEGER,DIMENSION(ITLO:ITHI,4) :: NSTATS
304 !     REAL,   DIMENSION(ITLO:ITHI,5) :: QMAX
305       REAL,   DIMENSION(ITLO:ITHI,22):: QTOT
307 !     SOME VARS WILL BE USED FOR DATA ASSIMILATION (DON'T NEED THEM NOW). 
308 !     THEY ARE TREATED AS LOCAL VARS, BUT WILL BECOME STATE VARS IN THE 
309 !     FUTURE. SO, WE DECLARED THEM AS MEMORY SIZES FOR THE FUTURE USE
311 !     TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related 
312 !     the microphysics scheme. Instead, they will be used by Eta precip 
313 !     assimilation.
315       REAL,  DIMENSION( ims:ime, kms:kme, jms:jme ) ::                  &
316      &       TLATGS_PHY,TRAIN_PHY
317       REAL,  DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC
318       REAL,  DIMENSION(its-1:ite+1, kts:kte, jts-1:jte+1):: t_new,t_old,   &
319      &                                      zcgs,       rhocgs,pcgs
321       INTEGER :: I,J,K,KFLIP
322 ! BARRY
323       INTEGER :: KRFREEZ
324 ! DATA
325        REAL Z0IN,ZMIN
326        DATA  ZMIN/2.0E5/
327        DATA  Z0IN/2.0E5 /
329 !      REAL,DIMENSION(1) :: EPSF2D, &
330        REAL EPSF2D, &
331      &        TAUR1,TAUR2,EPS_R1,EPS_R2,ANC1IN, &
332      &        PEPL,PEPI,PERL,PERI,ANC1,ANC2,PARSP, &
333      &        AFREEZMY,BFREEZMY,BFREEZMAX, &
334      &        TCRIT,TTCOAL, &
335      &        EPSF1,EPSF3,EPSF4, &
336      &        SUP2_OLD, DSUPICEXZ,TFREEZ_OLD,DTFREEZXZ, &
337      &        AA1_MY,BB1_MY,AA2_MY,BB2_MY, &
338      &        DTIME,DTCOND, &
339      &        A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
340         DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN  &
341      &      /2.53,5.42,3.41E1,6.13/
342         DATA AA1_MY,BB1_MY,AA2_MY,BB2_MY/2.53E12,5.42E3,3.41E13,6.13E3/
343 !            QSUM,ISUM,QSUM1,QSUM2,CCNSUM1,CCNSUM2
344         DATA KRFREEZ,BFREEZMAX,ANC1,ANC2,PARSP,PEPL,PEPI,PERL,PERI, &
345      &  TAUR1,TAUR2,EPS_R1,EPS_R2,TTCOAL,AFREEZMY,&
346      &  BFREEZMY,EPSF1,EPSF3,EPSF4,TCRIT/21,&
347      &  0.6600E00, &
348      &  1.0000E02,1.0000E02,0.9000E02, &
349      &  0.6000E00,0.6000E00,1.0000E-03,1.0000E-03, &
350      &  0.5000E00,0.8000E00,0.1500E09,0.1500E09, &
351      &  2.3315E02,0.3333E-04,0.6600E00, &
352      &  0.1000E-02,0.1000E-05,0.1000E-05, &
353      &  2.7015E02/
354 ! JIMY: N_CHEM,variables read in as data
355 ! SBM VARIABLES
356       REAL,DIMENSION (nkr) :: FF1IN,FF3IN,FF4IN,FF5IN,&
357      &              FF1R,FF3R,FF4R,FF5R,FCCN
358       REAL,DIMENSION (nkr,icemax) :: FF2IN,FF2R
359 !!!! NOTE: ZCGS AND OTHER VARIABLES ARE ALSO DIMENSIONED IN FALFLUXHUCM
360       DOUBLE PRECISION DEL1NR,DEL2NR,DEL12R,DEL12RD,ES1N,ES2N,EW1N,EW1PN
361       DOUBLE PRECISION DELSUP1,DELSUP2,DELDIV1,DELDIV2
362       DOUBLE PRECISION TT,QQ,TTA,QQA,PP,DPSA,DELTATEMP,DELTAQ
363       DOUBLE PRECISION DIV1,DIV2,DIV3,DIV4,DEL1IN,DEL2IN,DEL1AD,DEL2AD
364       REAL DEL_BB,DEL_BBN,DEL_BBR
365       REAL FACTZ,CONCCCN_XZ,CONCDROP
366        REAL SUPICE(KTE),AR1,AR2, &
367      & DERIVT_X,DERIVT_Y,DERIVT_Z,DERIVS_X,DERIVS_Y,DERIVS_Z, &
368      & ES2NPLSX,ES2NPLSY,EW1NPLSX,EW1NPLSY,UX,VX, &
369      & DEL2INPLSX,DEL2INPLSY,DZZ(KTE)
370        INTEGER KRR,I_START,I_END,J_START,J_END
371    
372        REAL DTFREEZ_XYZ(ITE,KTE,JTE),DSUPICE_XYZ(ITE,KTE,JTE)
374        REAL DXHUCM,DYHUCM
375        REAL FMAX1,FMAX2,FMAX3,FMAX4,FMAX5
376        INTEGER ISYM1,ISYM2,ISYM3,ISYM4,ISYM5
377        INTEGER DIFFU
378        REAL DELTAW
379        real zcgs_z(kts:kte),pcgs_z(kts:kte),rhocgs_z(kts:kte),ffx_z(kts:kte,nkr)
380        real z_full
381 ! SLOPE INTERCEPT FOR RAIN, SNOW, AND GRAUPEL                                    PARAMR.32
382 !     RON=8.E6                                                                   PARAMR.33
383 !     RON2=1.E10                                                                 23DEC04.211
384 !     RON2=1.E9                                                                  23DEC04.212
385 !     SON=2.E7                                                                   PARAMR.36
386 !     GON=5.E7                                                                   23DEC04.213
387 !     GON=4.E6
388        REAL, PARAMETER :: RON=8.E6, GON=5.E7,PI=3.14159265359
389        REAL EFF_N,EFF_D
390        REAL EFF_NI(its:ite,kts:kte,jts:jte),eff_di(its:ite,kts:kte,jts:jte)
391        REAL EFF_NQIC,eff_DQIC
392        REAL EFF_NQIP,eff_DQIP
393        REAL EFF_NQID,eff_DQID
394        real lambda,chi0,xi1,xi2,xi3,xi4,xi5,r_e,chi_3,f1,f2,volume,surface_area,xi6,ft,chi_e
395        real ft_bin
396       REAL, DIMENSION(kts:kte)::                            &
397                       qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
398       REAL, DIMENSION(kts:kte):: dBZ
399       
401        real nzero,son,nzero_less
402        parameter (son=2.E7)
403        real raddumb(nkr),massdumb(nkr)
404        real hydrosum
406        integer imax,kmax,jmax
407        real gmax
408        real tmax,qmax,divmax,rainmax
409        real qnmax,inmax,knmax
410        real hydro
411        real difmax,tdif,tt_old,w_stag,qq_old
412        real teten,es
413        integer  print_int
414        parameter (print_int=300)
415        real ft_liq(nkr)
416        data ft_liq/ 6.254894e-01,6.615571e-01,6.922125e-01,7.514451e-01,7.391191e-01,7.592261e-01,7.417122e-01&
417      &             ,7.388885e-01,7.430871e-01,7.570534e-01,7.584263e-01,7.735341e-01,7.721352e-01,7.724897e-01&
418      &             ,7.744899e-01,7.745646e-01,7.768777e-01,7.776348e-01, 7.788586e-01,7.774171e-01,7.789876e-01 &
419      &             ,7.801301e-01,7.806936e-01,7.801274e-01,7.821974e-01,7.815210e-01,7.822269e-01,7.822353e-01 &
420      &             ,7.808765e-01,7.824246e-01,7.814153e-01,7.818192e-01, 7.818231e-01/
423 ! GUY'S Variables
424        real geo_cs
425        integer t_print
426        t_print=print_int/dt
428 !      print*,'n_chem = ',n_chem
429        difmax = 0
430 !      print*,'itimestep = ',itimestep
431 !        if (itimestep.gt.150)return
432        if (itimestep.eq.1)then
433         if (iceprocs.eq.1) call wrf_message(" FULL SBM: ICE PROCESES ACTIVE ")
434         if (iceprocs.eq.0) call wrf_message(" FULL SBM: LIQUID PROCESES ONLY")
435        end if
436        tmax = 0
437 ! COAL BOTT IS EITHER CALLED EVERY TIME STEP OR TWICE
438        NCOND = 0
439 !       if (mod(dx,1000.).eq.0)then
440 !       NCOND=dx/1000
441 !       else if (mod(dx,2000.).eq.0)then
442 !       NCOND=dx/500
443 !       else if (mod(dx,3000.).eq.0)then
444 !       NCOND=dx/1000
445 !       else if (mod(dx,4000.).eq.0)then
446 !       NCOND=dx/1000
447 !       else if (mod(dx,1333.).eq.0)then
448 !       NCOND=dx/1.3333
449 !       end if
450          NCOND=nint(dx/1000)
452 !       IF (NCOND.EQ.0)NCOND=3
453        NCOND=max(NCOND,1)
454        DTCOND=DT/REAL(NCOND)
455        dt_coll=dt
456        call kernals(dt)
457 !      if (itimestep.eq.1.or.itimestep.eq.3)then
458 !            do kr = 1,nkr
459 !             print*,'xl = ',xl(kr),vr1(kr),RLEC(kr),RO1BL(kr)
460 !             print*,'xi = ',xi(kr,1),vr2(kr,1),RIEC(KR,1),RO2BL(KR,1)
461 !             print*,'xi = ',xi(kr,2),vr2(kr,2),RIEC(KR,2),RO2BL(KR,2)
462 !             print*,'xi = ',xi(kr,3),vr2(kr,3),RIEC(KR,3),RO2BL(KR,3)
463 !             print*,'xs = ',xs(kr),vr3(kr),RSEC(kr),RO3BL(kr)
464 !             print*,'xg = ',xg(kr),vr4(kr),RGEC(kr),RO4BL(kr)
465 !             print*,'xh = ',xh(kr),vr5(kr),RHEC(kr),RO5BL(kr)
466 !            end do
467 !       end if
470       DEL_BB=BB2_MY-BB1_MY
471       DEL_BBN=BB2_MYN-BB1_MYN
472       DEL_BBR=BB1_MYN/DEL_BBN
474       if (conserv)then
475       DO j = jts,jte
476       DO i = its,ite
477       DO k = kts,kte
478       rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
479       KRR=0
480       DO KR=p_ff1i01,p_ff1i33
481         KRR=KRR+1
482         chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KRR)/XL(KRR)/3.0
483       END DO
484       KRR=0
485       DO KR=p_ff5i01,p_ff5i33
486         KRR=KRR+1
487         chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3.0
488       END DO
489       KRR=0
490       DO KR=p_ff6i01,p_ff6i33
491         KRR=KRR+1
492         chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3.0
493       END DO
494 !      if (i.eq.100.and.j.eq.100)then
495 !       print*,'qna  1 = ', k,FACTZ,qna(i,k,j)
496 !      end if
497       KRR=0
498       DO KR=p_ff8i01,p_ff8i33
499         KRR=KRR+1
500 ! change by J. Fan
501 !        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/XCCN(KRR)
502         chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/1000.   ! chem_new (input) is #/kg
503       END DO
504 ! Columns
505       KRR=0
506       DO KR=p_ff2i01,p_ff2i33
507         KRR=KRR+1
508         chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XI(KRR,1)/XI(KRR,1)/3.0
509 !         if (i.eq.230.and.j.eq.146.and.k.eq.13)then
510       END DO
511 ! Plates 
512       KRR=0
513       DO KR=p_ff3i01,p_ff3i33
514         KRR=KRR+1
515 !         if (i.eq.230.and.j.eq.146.and.k.eq.13)then
516         chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XI(KRR,2)/XI(KRR,2)/3.0
517       END DO
518 ! Dendrites
519       KRR=0
520       DO KR=p_ff4i01,p_ff4i33
521         KRR=KRR+1
522         chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XI(KRR,3)/XI(KRR,3)/3.0
523       END DO
524       KRR=0
525       DO KR=p_ff7i01,p_ff7i33
526         KRR=KRR+1
527         chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XH(KRR)/XH(KRR)/3.0
528       END DO
529       END DO
530       END DO
531       END DO
532       end if
534       call kernals(dt)
536       DXHUCM=100.*DX
537       DYHUCM=100.*DY
538 !     print*,'dxhucm = ',dxhucm
539 !     print*,'dyhucm = ',dyhucm
540 !-----------------------------------------------------------------------
541 !**********************************************************************
542 !-----------------------------------------------------------------------
545 ! JIMY
546       I_START=MAX(1,ITS-1)
547       J_START=MAX(1,JTS-1)
548       I_END=MIN(IDE-1,ITE+1)
549       J_END=MIN(JDE-1,JTE+1)
550 !     print*,'ide-1 = ',ide-1
551 !     print*,'jde-1 = ',jde-1
552 !     print*,'kte = ',kte
553 !     print*,'i_start,i_end = ',i_start,i_end
554 !     print*,'j_start,j_end = ',j_start,j_end
555 !     print*,'its,ite = ',its,ite
556 !     print*,'jts,jte = ',jts,jte
557       DO j = j_start,j_end
558       DO i = i_start,i_end
559       z_full=0.
560       DO k = kts,kte
561           pcgs(I,K,J)=P_PHY(I,K,J)*10.
562           rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
563           zcgs(I,K,J)=z_full+0.5*dz8w(I,K,J)*100
564           z_full=z_full+dz8w(i,k,j)*100.
565       ENDDO
566       ENDDO
567       ENDDO
568 !!!!!
569          if (itimestep.eq.1)then
570        DO j = jts,jte
571        DO i = its,ite
572        DO k = kts,kte
573          IF (zcgs(I,K,J).LE.ZMIN)THEN
574             FACTZ=1.
575          ELSE
576             FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
577          END IF
578 !        FACTZ = 1
579          KRR=0
580          DO KR=p_ff8i01,p_ff8i33
581           KRR=KRR+1
582           if (xland(i,j).lt.1.5)then
583              chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ
584           else
585              chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
586           end if
587 !         if (xlat(i,j).ge.10.and.xlat(i,j).le.30.and.zcgs(i,k,j).le.300000)then
588 !            if (zcgs(i,k,j).le.25000)then
589 !             chem_new(I,K,J,KR)=FCCNR0(KRR)+FCCNR3(KRR)
590 !            else
591 !             chem_new(I,K,J,KR)=FCCNR3(KRR)
592 !            end if
593 !         end if
595          END DO
596        end do
597        end do
598        end do
599        end if
600        if (itimestep.ne.1.and.dx.gt.dx_bound)then
601        DO j = jts,jte
602        DO k = kts,kte
603        DO i = its,ite
604         if (i.le.5.or.i.ge.IDE-5.OR. &
605      &       j.le.5.or.j.ge.JDE-5)THEN
606          IF (zcgs(I,K,J).LE.ZMIN)THEN
607             FACTZ=1.
608          ELSE
609             FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
610          END IF
611          KRR=0
612          DO kr=p_ff8i01,p_ff8i33
613           KRR=KRR+1
614           if (xland(i,j).lt.1.5)then
615              chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ
616           else
617              chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
618           end if
619 !         if (xlat(i,j).ge.10.and.xlat(i,j).le.30.and.zcgs(i,k,j).le.300000)then
620 !            if (zcgs(i,k,j).le.25000)then
621 !             chem_new(I,K,J,KR)=FCCNR0(KRR)+FCCNR3(KRR)
622 !            else
623 !             chem_new(I,K,J,KR)=FCCNR3(KRR)
624 !            end if
625 !         end if
626          End do
627         end if
628        end do
629        end do
630        end do
631        end if
632       if (itimestep.eq.1)then
633       DO j = j_start,j_end
634       DO k = kts,kte
635       DO i = i_start,i_end
636          th_old(i,k,j)=th_phy(i,k,j)
637          qv_old(i,k,j)=qv(i,k,j)
638       END DO
639       END DO
640       END DO
641       end if
642       DO j = j_start,j_end
643       DO k = kts,kte
644       DO i = i_start,i_end
645         t_new(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j)
646         tempc(i,k,j)=t_new(i,k,j)-273.16
647         t_old(i,k,j) = th_old(i,k,j)*pi_phy(i,k,j)
648       ENDDO
649       ENDDO
650       ENDDO
655 !1         172           1           1
657 !     print*,'here at 1'
658       DO j = jts,jte
659       DO i = its,ite
660       DO k = kts,kte
661        IF(K.EQ.KTE)THEN
662         DZZ(K)=(zcgs(I,K,J)-zcgs(I,K-1,J))
663        ELSE IF(K.EQ.1)THEN
664         DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K,J))
665        ELSE
666         DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K-1,J))
667        END IF
668        ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
669        EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
670        SUPICE(K)=EW1N/ES2N-1.
671        IF(SUPICE(K).GT.0.5) SUPICE(K)=.5
673       END DO
674       DO k = kts,kte
675        IF(T_OLD(I,K,J).GE.238.15.AND.T_OLD(I,K,J).LT.274.15) THEN
676        if (k.lt.kte)then       
677         w_stag=50.*(w(i,k,j)+w(i,k+1,j)) 
678        else
679         w_stag=100*w(i,k,j)
680        end if
681              IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
682               UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
683               VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
684              ELSE
685               UX=U(I,K,J)*100.
686               VX=V(I,K,J)*100.
687              END IF  
688              IF(K.EQ.1) DERIVT_Z=(T_OLD(I,K+1,J)-T_OLD(I,K,J))/DZZ(K)
689              IF(K.EQ.KTE) DERIVT_Z=(T_OLD(I,K,J)-T_OLD(I,K-1,J))/DZZ(K)
690              IF(K.GT.1.AND.K.LT.KTE) DERIVT_Z= &
691      &        (T_OLD(I,K+1,J)-T_OLD(I,K-1,J))/DZZ(K)
692              IF (I.EQ.1)THEN
693               DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I,K,J))/(DXHUCM)
694              ELSE IF (I.EQ.IDE-1)THEN
695               DERIVT_X=(T_OLD(I,K,J)-T_OLD(I-1,K,J))/(DXHUCM)
696              ELSE
697               DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I-1,K,J))/(2.*DXHUCM)
698              END IF
699              IF (J.EQ.1)THEN
700               DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J))/(DYHUCM)
701              ELSE IF (J.EQ.JDE-1)THEN
702               DERIVT_Y=(T_OLD(I,K,J)-T_OLD(I,K,J-1))/(DYHUCM)
703              ELSE
704               DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J-1))/(2.*DYHUCM)
705              END IF
706              DTFREEZ_XYZ(I,K,J)=DT*(VX*DERIVT_Y+ &
707      &            UX*DERIVT_X+w_stag*DERIVT_Z)
708           ELSE
709              DTFREEZ_XYZ(I,K,J)=0.
710           ENDIF
711           IF(SUPICE(K).GE.0.02.AND.T_OLD(I,K,J).LT.268.15) THEN
712             IF (I.LT.IDE-1)THEN
713              ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I+1,K,J))
714              EW1NPLSX=QV_OLD(I+1,K,J)*pcgs(I+1,K,J)/ &
715      &               (0.622+0.378*QV_OLD(I+1,K,J))
716             ELSE
717              ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
718              EW1NPLSX=QV_OLD(I,K,J)*pcgs(I,K,J)/ &
719      &               (0.622+0.378*QV_OLD(I,K,J))
720             END IF
721             IF (ES2NPLSX.EQ.0)THEN
722              DEL2INPLSX=0.5
723             ELSE
724              DEL2INPLSX=EW1NPLSX/ES2NPLSX-1.
725             END IF
726             IF(DEL2INPLSX.GT.0.5) DEL2INPLSX=.5
727             IF (I.GT.1)THEN
728              ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I-1,K,J))
729              EW1N=QV_OLD(I-1,K,J)*pcgs(I-1,K,J)/(0.622+0.378*QV_OLD(I-1,K,J))
730             ELSE
731              ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
732              EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
733             END IF
734             DEL2IN=EW1N/ES2N-1.
735             IF(DEL2IN.GT.0.5) DEL2IN=.5
736             IF (I.GT.1.AND.I.LT.IDE-1)THEN
737              DERIVS_X=(DEL2INPLSX-DEL2IN)/(2.*DXHUCM)
738             ELSE
739              DERIVS_X=(DEL2INPLSX-DEL2IN)/(DXHUCM)
740             END IF
741             IF (J.LT.JDE-1)THEN
742              ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J+1))
743              EW1NPLSY=QV_OLD(I,K,J+1)*pcgs(I,K,J+1)/(0.622+0.378*QV_OLD(I,K,J+1))
744             ELSE
745              ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
746              EW1NPLSY=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
747             END IF
748             DEL2INPLSY=EW1NPLSY/ES2NPLSY-1.
749             IF(DEL2INPLSY.GT.0.5) DEL2INPLSY=.5
750             IF (J.GT.1)THEN
751              ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J-1))
752              EW1N=QV_OLD(I,K,J-1)*pcgs(I,K,J-1)/(0.622+0.378*QV_OLD(I,K,J-1))
753             ELSE
754              ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
755              EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
756             END IF
757              DEL2IN=EW1N/ES2N-1.
758             IF(DEL2IN.GT.0.5) DEL2IN=.5
759             IF (J.GT.1.AND.J.LT.JDE-1)THEN
760              DERIVS_Y=(DEL2INPLSY-DEL2IN)/(2.*DYHUCM)
761             ELSE
762              DERIVS_Y=(DEL2INPLSY-DEL2IN)/(DYHUCM)
763             END IF
765             IF (K.EQ.1)DERIVS_Z=(SUPICE(K+1)-SUPICE(K))/DZZ(K)
766             IF (K.EQ.KTE)DERIVS_Z=(SUPICE(K)-SUPICE(K-1))/DZZ(K)
767             IF(K.GT.1.and.K.LT.KTE) DERIVS_Z=(SUPICE(K+1)-SUPICE(K-1))/DZZ(K)
768             IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
769              UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
770              VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
771             ELSE
772              UX=U(I,K,J)*100.
773              VX=V(I,K,J)*100.
774             END IF  
775             DSUPICE_XYZ(I,K,J)=(UX*DERIVS_X+VX*DERIVS_Y+ &
776       &                        w_stag*DERIVS_Z)*DTCOND
777           ELSE
778             DSUPICE_XYZ(I,K,J)=0.0
779           END IF
780          END DO
781          END DO
782          END DO
783      
785       do j = jts,jte
786       do k = kts,kte
787       do i = its,ite
788 !     print*,'i,j,k = ',i,j,k
789 ! LIQUID
790 !      do kr=1,nkr
791 !       if (ff4r(kr).lt.0)then
792 !        print*,'i,k,j = ',i,k,j
793 !        print*,'ff4r 0 = ',kr,ff4r(kr)
794 !       end if
795 !      end do
796           KRR=0
797           DO kr=p_ff1i01,p_ff1i33
798            KRR=KRR+1
799            FF1R(KRR)=chem_new(I,K,J,KR)
800            IF (FF1R(KRR).LT.0)FF1R(KRR)=0.
801           END DO
802 ! CCN
803         KRR=0
804         DO kr=p_ff8i01,p_ff8i33
805           KRR=KRR+1
806           FCCN(KRR)=chem_new(I,K,J,KR)
807           if (fccn(krr).lt.0)fccn(krr)=0.
808         END DO
809         IF (ICEPROCS.EQ.1)THEN
810 ! COLUMNS!
811          KRR=0
812          DO kr=p_ff2i01,p_ff2i33
813           KRR=KRR+1
814           FF2R(KRR,1)=chem_new(I,K,J,KR)
815           if (ff2r(krr,1).lt.0)ff2r(krr,1)=0
816          END DO
817 ! PLATES!
818          KRR=0
819          DO kr=p_ff3i01,p_ff3i33
820           KRR=KRR+1
821           FF2R(KRR,2)=chem_new(I,K,J,KR)
822 !i,j,k =          230         146          13
823           if (ff2r(krr,2).lt.0)ff2r(krr,2)=0
824           
825          END DO
827 ! DENDRITES!
828          KRR=0
829          DO KR=p_ff4i01,p_ff4i33
830           KRR=KRR+1
831           FF2R(KRR,3)=chem_new(I,K,J,KR)
832           if (ff2r(krr,3).lt.0)ff2r(krr,3)=0
833          END DO
834 ! SNOW
835            KRR=0
836            DO kr=p_ff5i01,p_ff5i33
837             KRR=KRR+1
838             FF3R(KRR)=chem_new(I,K,J,KR)
839             if (ff3r(krr).lt.0)ff3r(krr)=0.
840            END DO
842 ! Graupel
843            KRR=0
844            DO kr=p_ff6i01,p_ff6i33
845             KRR=KRR+1
846             FF4R(KRR)=chem_new(I,K,J,KR)
847             IF (FF4R(KRR).LT.0)FF4R(KRR)=0.
848            END DO
850 ! Hail
851          KRR=0
852          DO kr=p_ff7i01,p_ff7i33
853           KRR=KRR+1
854           FF5R(KRR)=chem_new(I,K,J,KR)
855           if (ff5r(krr).lt.0)ff5r(krr)=0.
856          END DO
857          CALL FREEZ &
858      &     (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
859      &      T_NEW(I,K,J),DT,rhocgs(I,K,J), &
860      &      COL,AFREEZMY,BFREEZMY,BFREEZMAX, &
861      &      KRFREEZ,ICEMAX,NKR)
862          IF (ORIGINAL_MELT)THEN
863          CALL ORIG_MELT  &
864      &    (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
865      &     T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR)
866          END IF
867          IF (JIWEN_FAN_MELT) THEN
868          CALL J_W_MELT &
869      &    (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
870      &     T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR)
871          END IF
872         ENDIF
873 !       IF (T_OLD(I,K,J).GT.223)THEN     
874         IF (T_OLD(I,K,J).GT.213)THEN     
875          TT=T_OLD(I,K,J)
876          QQ=QV_OLD(I,K,J)
877  !        IF (QQ.LE.0)print*,'QQ < 0'
878          IF (QQ.LE.0)QQ=1.D-10
879          PP=pcgs(I,K,J)
880          TTA=T_NEW(I,K,J)
881          QQA=QV(I,K,J)
882          IF (QQA.LE.0) call wrf_message("WARNING: FULL SBM, QQA < 0   ")
883  !        IF (QQA.LE.0)print*,'QQA = ',qqa
884  !        IF (QQA.LE.0)print*,'i,k,j = ',i,k,j
885  !        IF (QQA.LE.0)print*,'tta = ',tta
886  !        IF (QQA.LE.0)print*,'tt = ',tt
887  !        IF (QQA.LE.0)print*,'qq = ',qq
888           IF (QQA.LE.0)QQA=1.D-10
889          ES1N=AA1_MY*DEXP(-BB1_MY/TT)
890          ES2N=AA2_MY*DEXP(-BB2_MY/TT)
891          EW1N=QQ*PP/(0.622+0.378*QQ)
892          DIV1=EW1N/ES1N
893          DEL1IN=EW1N/ES1N-1.
894          DIV2=EW1N/ES2N
895          DEL2IN=EW1N/ES2N-1.
896          ES1N=AA1_MY*DEXP(-BB1_MY/TTA)
897          ES2N=AA2_MY*DEXP(-BB2_MY/TTA)
898          EW1N=QQA*PP/(0.622+0.378*QQA)
899          DIV3=EW1N/ES1N
900          DEL1AD=EW1N/ES1N-1.
901          DIV4=EW1N/ES2N
902          DEL2AD=EW1N/ES2N-1.
903          SUP2_OLD=DEL2IN
904          DELSUP1=(DEL1AD-DEL1IN)/NCOND
905          DELSUP2=(DEL2AD-DEL2IN)/NCOND
906          DELDIV1=(DIV3-DIV1)/NCOND
907          DELDIV2=(DIV4-DIV2)/NCOND
908          DELTATEMP=0
909          DELTAQ=0
910          tt_old = TT
911          qq_old = qq
912          DIFFU=1
913          DO IKL=1,NCOND
914           IF (DIFFU.NE.0)THEN
915           DEL1IN=DEL1IN+DELSUP1
916           DEL2IN=DEL2IN+DELSUP2
917           DIV1=DIV1+DELDIV1
918           DIV2=DIV2+DELDIV2
919           END IF
920 !959       format (' ',i3,1x,f7.1,1x,f6.1,1x,f6.4,1x,f6.2,1x,f6.3)
921 !         IF (DIV1.GT.DIV2.AND.TT.LE.265)THEN
922 ! Jin-Fang Yin
923           IF ((DIV1 - DIV2) .GE. 1.0*10e-24 .AND.TT.LE.265)THEN
924 !          print*,'div1 > div2',div1,div2
925 !          print*,'delsup1, delsup2 = ',delsup1,delsup2
926 !          print*,'del1in, del2in = ',del1in,del2in
927 !          print*,'STOP'
928 !          print*,'RESET'
929 !          print*,'ikl,i,j,k = ',ikl,i,j,k
930 !          print*,'zcgs = ',zcgs(i,k,j)
931 !          print*,'tt,qq = ',tt,qq
932 !          DIV1=0.99999*DIV2
933 !          DEL1IN=0.99999*DEL2IN
934 !          STOP
935            DIFFU=0
936           END IF
937           IF (DIFFU.NE.0)THEN
938           DEL1NR=A1_MYN*(100.*DIV1)
939           DEL2NR=A2_MYN*(100.*DIV2)
940      !     IF (DEL2NR.EQ.0)PRINT*,'DEL2NR = 0'
941      !     IF (DEL2NR.EQ.0)PRINT*,'DEL2NR = 0'
942      !     IF (DEL2NR.EQ.0)PRINT*,'DELDIV2 = ',DELDIV2
943      !     IF (DEL2NR.EQ.0)PRINT*,'DIV1 = ',DIV1
944      !     IF (DEL2NR.EQ.0)PRINT*,'DIV2 = ',DIV2
945           IF (DEL2NR.EQ.0)call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL2NR.EQ.0) , model stop ")
946           DEL12R=DEL1NR/DEL2NR
947           DEL12RD=DEL12R**DEL_BBR
948           EW1PN=AA1_MY*100.*DIV1*DEL12RD/100.
949           TT=-DEL_BB/DLOG(DEL12R)
950           QQ=0.622*EW1PN/(PP-0.378*EW1PN)
952           DO KR=1,NKR
953             FF1IN(KR)=FF1R(KR)
954             DO ICE=1,ICEMAX
955              FF2IN(KR,ICE)=FF2R(KR,ICE)
956             ENDDO
957           ENDDO
958           IF (BULKNUC.eq.1)THEN
959             IF (DEL1IN.GT.0)THEN
960               IF (zcgs(I,K,J).LE.500.E2)THEN
961                 FACTZ=0.
962               ELSE
963                 FACTZ=1
964 !               FACTZ=EXP(-(zcgs(I,K,J)-2.E5)/Z0IN)
965               END IF
966              CONCCCN_XZ=FACTZ*ACCN*(100.*DEL1IN)**BCCN
968              CONCDROP=0.D0
970              DO KR=1,NKR
971                CONCDROP=CONCDROP+FF1IN(KR)*XL(KR)
972              ENDDO
974              CONCDROP=CONCDROP*3.D0*COL
975              IF(CONCCCN_XZ.GT.CONCDROP) &
976      &       FF1IN(1)=FF1IN(1)+(CONCCCN_XZ-CONCDROP)/(3.D0*COL*XL(1))
977             END IF
978           ELSE
979             IF(DEL1IN.GT.0.OR.DEL2IN.GT.0)THEN
980              CALL JERNUCL01(FF1IN,FF2IN,FCCN &
981      &       ,XL,XI,TT,QQ &
982      &       ,rhocgs(I,K,J),pcgs(I,K,J) &
983      &       ,DEL1IN,DEL2IN &
984      &       ,COL,AA1_MY, BB1_MY, AA2_MY,BB2_MY &
985      &       ,C1_MEY,C2_MEY,SUP2_OLD,DSUPICE_XYZ(I,K,J) &
986      &       ,RCCN,DROPRADII,NKR,ICEMAX,ICEPROCS)
987              IF (T_OLD(I,K,J).GT.220.AND.T_OLD(I,K,J).LE.233)THEN
988               DO KR=1,NKR
989                FF2IN(KR,2)=FF2IN(KR,2)+FF1IN(KR)
990                FF1IN(KR)=0.
991               END DO
992              END IF
993             END IF
995           END IF
996 !  
997           DO KR=1,NKR
998             FF1R(KR)=FF1IN(KR)
999             DO ICE=1,ICEMAX
1000              FF2R(KR,ICE)=FF2IN(KR,ICE)
1001             ENDDO
1002           ENDDO
1003           FMAX1=0.
1004           FMAX2=0.
1005           FMAX3=0.
1006           FMAX4=0.
1007           FMAX5=0.
1008           DO KR=1,NKR
1009             FF1IN(KR)=FF1R(KR)
1010             FMAX1=AMAX1(FF1R(KR),FMAX1)
1011             FF3IN(KR)=FF3R(KR)
1012             FMAX3=AMAX1(FF3R(KR),FMAX3)
1013             FF4IN(KR)=FF4R(KR)
1014             FMAX4=AMAX1(FF4R(KR),FMAX4)
1015             FF5IN(KR)=FF5R(KR)
1016             FMAX5=AMAX1(FF5R(KR),FMAX5)
1017             DO ICE=1,ICEMAX
1018              FF2IN(KR,ICE)=FF2R(KR,ICE)
1019              FMAX2=AMAX1(FF2R(KR,ICE),FMAX2)
1020             END DO
1021           END DO
1022           ISYM1=0
1023           ISYM2=0
1024           ISYM3=0
1025           ISYM4=0
1026           ISYM5=0
1027           IF(FMAX1.GT.0)ISYM1=1
1028           IF (ICEPROCS.EQ.1)THEN
1029            IF(FMAX2.GT.1.E-4)ISYM2=1
1030            IF(FMAX3.GT.1.E-4)ISYM3=1
1031            IF(FMAX4.GT.1.E-4)ISYM4=1
1032            IF(FMAX5.GT.1.E-4)ISYM5=1
1033           END IF
1034 ! Avoid Diffusional Growth
1035 !         IF (T_OLD(I,K,J).GE.237)THEN     
1036 ! Same temperature range as above.
1037           IF (T_OLD(I,K,J).GT.233)THEN
1038           IF(ISYM1.EQ.1.AND.((TT-273.15).GT.-0.187.OR. &
1039      &     (ISYM2.EQ.0.AND. &
1040      &     ISYM3.EQ.0.AND.ISYM4.EQ.0.AND.ISYM5.EQ.0)))THEN
1041            IF (T_OLD(I,K,J).GT.233)THEN     
1042            CALL ONECOND1(TT,QQ,PP,rhocgs(I,K,J) &
1043      &      ,VR1,pcgs(I,K,J) &
1044      &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
1045      &      ,FF1R,FF1IN,XL,RLEC,RO1BL &
1046      &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
1047      &      ,C1_MEY,C2_MEY &
1048      &      ,COL,DTCOND,ICEMAX,NKR)
1049            END IF
1050           ELSE IF(ISYM1.EQ.0.AND.(TT-273.15).LE.-0.187.AND. &
1051      &     (ISYM2.EQ.1.OR.ISYM3.EQ.1.OR.ISYM4.EQ.1.OR.ISYM5.EQ.1))THEN
1052            IF (T_OLD(I,K,J).GT.233)THEN     
1053            CALL ONECOND2(TT,QQ,PP,rhocgs(I,K,J) &
1054      &      ,VR2,VR3,VR4,VR5,pcgs(I,K,J) &
1055      &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
1056      &      ,FF2R,FF2IN,XI,RIEC,RO2BL &
1057      &      ,FF3R,FF3IN,XS,RSEC,RO3BL &
1058      &      ,FF4R,FF4IN,XG,RGEC,RO4BL &
1059      &      ,FF5R,FF5IN,XH,RHEC,RO5BL &
1060      &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
1061      &      ,C1_MEY,C2_MEY &
1062      &      ,COL,DTCOND,ICEMAX,NKR &
1063      &      ,ISYM2,ISYM3,ISYM4,ISYM5)
1064            END IF
1065           ELSE IF(ISYM1.EQ.1.AND.(TT-273.15).LE.-0.187.AND. &
1066      &     (ISYM2.EQ.1.OR.ISYM3.EQ.1.OR.ISYM4.EQ.1 &
1067      &     .OR.ISYM5.EQ.1))THEN
1068            CALL ONECOND3(TT,QQ,PP,rhocgs(I,K,J) &
1069      &      ,VR1,VR2,VR3,VR4,VR5,pcgs(I,K,J) &
1070      &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
1071      &      ,FF1R,FF1IN,XL,RLEC,RO1BL &
1072      &      ,FF2R,FF2IN,XI,RIEC,RO2BL &
1073      &      ,FF3R,FF3IN,XS,RSEC,RO3BL &
1074      &      ,FF4R,FF4IN,XG,RGEC,RO4BL &
1075      &      ,FF5R,FF5IN,XH,RHEC,RO5BL &
1076      &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
1077      &      ,C1_MEY,C2_MEY &
1078      &      ,COL,DTCOND,ICEMAX,NKR &
1079      &      ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
1080           END IF
1081           END IF
1082           END IF
1083              IF (IKL.EQ.NCOND)CALL COAL_BOTT_NEW(FF1R,FF2R,FF3R, &
1084      &       FF4R,FF5R,TT,QQ,PP,rhocgs(I,K,J),dt_coll,TCRIT,TTCOAL)
1085          END DO
1086          IF (DIFFU.EQ.0)THEN
1087          th_phy(i,k,j) = tt_old/pi_phy(i,k,j)
1088          qv(i,k,j)=qq_old
1089 !        print*,'problem calculating diffusion in sbm'
1090 !        print*,'tt_old = ',tt_old
1091 !        print*,'qq_old = ',qq_old
1092          ELSE
1093          th_phy(i,k,j) = tt/pi_phy(i,k,j)
1094          qv(i,k,j)=qq
1095          END IF
1096         END IF
1097 ! LIQIUD
1098         IF (REMSAT.EQ.1)THEN
1099         DO KR=1,NKR
1100          FF1R(KR)=0.
1101          FCCN(KR)=0
1102          IF (ICEPROCS.EQ.1)THEN
1103           FF2R(KR,1)=0.
1104           FF2R(KR,2)=0.
1105           FF2R(KR,3)=0.
1106           FF3R(KR)=0.
1107           FF4R(KR)=0.
1108           FF5R(KR)=0.
1109          END IF
1110         END DO
1111         END IF
1112 !Liquid Water
1113 !Alex is not responsible the "2" below.
1114 !Alex is responsible fo rthe geo_cs formulas.
1115         kext_ql(i,k,j)=0.
1116         krr=0
1117         DO kr=p_ff1i01,p_ff1i33
1118           KRR=KRR+1
1119           chem_new(I,K,J,KR)=FF1R(KRR)
1120           geo_cs=3.1415*(3.*xl(krr)/(4.*3.1415*1.))**(2./3.)
1121           ft=0.
1122           kext_ql(i,k,j)=kext_ql(i,k,j)+(1.-ft_liq(krr))*2.*geo_cs*(100.*col*3.*xl(krr))*ff1r(krr)
1123 !         if (i.eq.ime/2.and.j.eq.jme/2.and.k.eq.10)then
1124 !         if (krr.eq.1)write(6,*)'ft_bin_water information'
1125 !            geo_cs=3.1415*(3.*xl(krr)/(4.*3.1415*1.))**(2./3.)
1126 !           write(6,901)krr,xl(krr),ro1bl(krr),RADXXO(krr,1),geo_cs
1127 !         end if
1129         END DO   
1130 ! He wants per meter, so we multiply by 100 above
1131 ! CCN
1132         KRR=0
1133         kext_qa(i,k,j)=0.
1134         DO kr=p_ff8i01,p_ff8i33
1135           KRR=KRR+1
1136           chem_new(I,K,J,KR)=FCCN(KRR)
1137            geo_cs=3.1415*(3*XCCN(krr)/(4*3.1415*0.4))**(2./3.)
1138            kext_qa(i,k,j)=kext_qa(i,k,j)+2.*geo_cs*fccn(krr)
1140         END DO
1141         IF (ICEPROCS.EQ.1)THEN
1142 !SNOW
1143          EFF_NI(i,k,j)=0.
1144          eff_di(i,k,j)=0.
1145          EFF_NQIC=0
1146          EFF_DQIC=0
1147          EFF_NQIP=0
1148          EFF_DQIP=0
1149          EFF_NQID=0
1150          EFF_DQID=0
1151          KRR=0
1152          kext_qs(i,k,j)=0.
1153          kext_ft_qs(i,k,j)=0.
1154          lambda = 0.55
1155          chi0 = 0.00000
1156          xi1 = 0.12534e-2
1157          xi2 = 0.38929e-2
1158          xi3 = 0.36593
1159          xi4 = 0.38827e-1
1160          xi5 = 0.87616
1161          DO kr=p_ff5i01,p_ff5i33
1162           KRR=KRR+1
1163           chem_new(I,K,J,KR)=FF3R(KRR)
1164           geo_cs=3.1415*(xs(krr)/(1.2*3.1415*ro3bl(krr)))**(2./3.)
1165           volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XS(KRR)
1166           surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XS(KRR)
1167           if (surface_area.ne.0.and.volume.ne.0)then
1168           r_e = 3.0/4.0*volume/surface_area
1169           chi_e = 2.0*pi*(r_e*1.E4)/lambda
1171           f1 = (1.0 - xi1)* &
1172      &         (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
1173           f2 = (1.0 - xi3)* &
1174      &         (1.0 - exp(-xi4*(chi_e - chi0)))
1175           if(chi_e.le.chi0) then 
1176              ft = 0
1177           else 
1178            ft = (1.0 - xi5)*f1 + xi5*f2
1179           end if
1180           else 
1181           ft=0.
1182           end if
1183           ft=0.
1184           kext_qs(i,k,j)=kext_qs(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3.*xs(krr))*ff3r(krr)
1185          END DO
1187 ! HERE
1188 ! Graupel
1189          KRR=0
1190          kext_qg(i,k,j)=0.
1191          kext_ft_qg(i,k,j)=0.
1192        lambda = 0.55
1193        chi0 = 0.00000
1194        xi1 = 0.39026e-1
1195        xi2 = 0.94264e-5
1196        xi3 = 0.11281e-2
1197        xi4 = 0.35218e-1
1198        xi5 = 0.51453
1199          DO kr=p_ff6i01,p_ff6i33
1200           KRR=KRR+1
1201           chem_new(I,K,J,KR)=FF4R(KRR)
1202           geo_cs=3.1415*(3.*xg(krr)/(4.*3.1415*0.4))**(2./3.)
1203           volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XG(KRR)
1204           surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XG(KRR)
1205           if (surface_area.ne.0.and.volume.ne.0)then
1206           r_e = 3.0/4.0*volume/surface_area
1207           chi_e = 2.0*pi*(r_e*1.E4)/lambda
1209           f1 = (1.0 - xi1)* &
1210      &         (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
1211           f2 = (1.0 - xi3)* &
1212      &         (1.0 - exp(-xi4*(chi_e - chi0)))
1213           if(chi_e.le.chi0) then 
1214              ft = 0
1215           else 
1216            ft = (1.0 - xi5)*f1 + xi5*f2
1217           end if
1218           else 
1219           ft=0.
1220           end if
1221           ft=0.
1222           kext_qg(i,k,j)=kext_qg(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3.*xg(krr))*ff4r(krr)
1223          END DO
1225 ! Columns
1226          KRR=0
1227          kext_qic(i,k,j)=0.
1228          kext_ft_qic(i,k,j)=0.
1229        lambda = 0.55
1230        chi0 = 0.00000
1231        xi1 = 0.60202
1232        xi2 = 0.85513e-3
1233        xi3 = 0.97065e-1
1234        xi4 = 0.21320e-1
1235        xi5 = 0.66985
1236          DO kr=p_ff2i01,p_ff2i33
1237           KRR=KRR+1
1238           chem_new(I,K,J,KR)=FF2R(KRR,1)
1239           geo_cs=0.26*(xi(krr,1)/(ro2bl(krr,1)*0.2))**1.28
1240           volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,1)
1241           surface_area=sqrt(geo_cs/3.1415)**2.*chem_new(i,k,j,KR)*XI(KRR,1)
1242           if (surface_area.ne.0.and.volume.ne.0)then
1243           r_e = 3.0/4.0*volume/surface_area
1244           chi_e = 2.0*pi*(r_e*1.E4)/lambda
1246           f1 = (1.0 - xi1)* &
1247      &         (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
1248           f2 = (1.0 - xi3)* &
1249      &         (1.0 - exp(-xi4*(chi_e - chi0)))
1250           if(chi_e.le.chi0) then 
1251              ft = 0
1252           else 
1253            ft = (1.0 - xi5)*f1 + xi5*f2
1254           end if
1255           else
1256           ft=0.
1257           end if
1258           ft=0.
1259           kext_qic(i,k,j)=kext_qic(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3.*xi(krr,1))*ff2r(krr,1)
1260           EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,1)+EFF_NI(i,k,j)
1261           eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,1)+eff_di(i,k,j)
1262           EFF_NQIC=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,1)+EFF_NQIC
1263           eff_dqic=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,1)+eff_dqic
1264          END DO
1265          IF (EFF_DQIC.NE.0)THEN
1266          QIC_EFFR(I,K,J)=EFF_NQIC/EFF_DQIC
1267          ELSE
1268          QIC_EFFR(I,K,J)=0.
1269          END IF
1270          krr=0
1272 901      format(' ',i3,1x,f12.9,1x,3(f12.9,1x),f12.6,f12.3,1x,10(f12.8,1x))
1274 ! Plates
1275          KRR=0
1276          kext_qip(i,k,j)=0.
1277        lambda = 0.55
1278        chi0 = 0.00000
1279        xi1 = 0.23397e-2
1280        xi2 = 0.19513e-2
1281        xi3 = 0.51912e-4
1282        xi4 = 0.15159e-1
1283        xi5 = 0.81012
1284          DO kr=p_ff3i01,p_ff3i33
1285           KRR=KRR+1
1286           chem_new(I,K,J,KR)=FF2R(KRR,2)
1287           geo_cs=(3.1415/4)*(xi(krr,2)/(ro2bl(krr,2)*0.108))**0.72
1288           volume=sqrt(geo_cs/3.1415)**3.*chem_new(i,k,j,KR)*XI(KRR,2)
1289           surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,2)
1290           if (surface_area.ne.0.and.volume.ne.0)then
1291           r_e = 3.0/4.0*volume/surface_area
1292           chi_e = 2.0*pi*(r_e*1.E4)/lambda
1294           f1 = (1.0 - xi1)* &
1295      &         (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
1296           f2 = (1.0 - xi3)* &
1297      &         (1.0 - exp(-xi4*(chi_e - chi0)))
1298           if(chi_e.le.chi0) then 
1299              ft = 0
1300           else 
1301            ft = (1.0 - xi5)*f1 + xi5*f2
1302           end if
1303           else 
1304            ft=0.
1305           end if
1306           ft=0.
1307           kext_qip(i,k,j)=kext_qip(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3*xi(krr,2))*ff2r(krr,2)
1308           EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,2)+EFF_NI(i,k,j)
1309           eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,2)+eff_di(i,k,j)
1310           EFF_NQIP=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,2)+EFF_NQIP
1311           eff_dqiP=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,2)+eff_dqip
1312          END DO
1313          IF (EFF_DQIP.NE.0)THEN
1314          QIP_EFFR(I,K,J)=EFF_NQIP/EFF_DQIP
1315          ELSE
1316          QIP_EFFR(I,K,J)=0.
1317          END IF
1321 !             s=(3.1415/4)*0.097**(-0.72)*(m(nkr))**0.72^M
1322 ! Dendrites
1323          KRR=0
1324          kext_qid(i,k,j)=0.
1325          lambda = 0.55
1326          chi0 = 0.00000
1327          xi1 = 0.14875
1328          xi2 = 0.49514e-2
1329          xi3 = 0.36201
1330          xi4 = 0.36993e-1
1331          xi5 = 0.87020
1332          DO KR=p_ff4i01,p_ff4i33
1333           KRR=KRR+1
1334           chem_new(I,K,J,KR)=FF2R(KRR,3)
1335           geo_cs=(3.1415/4)*(xi(krr,3)/(ro2bl(krr,3)*7.8E-3))**0.828
1336           volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,3)
1337           surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,3)
1338           if (surface_area.ne.0.and.volume.ne.0)then
1339           r_e = 3.0/4.0*volume/surface_area
1340           chi_e = 2.0*pi*(r_e*1.E4)/lambda
1342           f1 = (1.0 - xi1)* &
1343      &         (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
1344           f2 = (1.0 - xi3)* &
1345      &         (1.0 - exp(-xi4*(chi_e - chi0)))
1346           if(chi_e.le.chi0) then 
1347              ft = 0
1348           else 
1349            ft = (1.0 - xi5)*f1 + xi5*f2
1350           end if
1351           else
1352            ft=0.
1353           end if
1354           ft=0.
1355           kext_qid(i,k,j)=kext_qid(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3*xi(krr,3))*ff2r(krr,3)
1356           EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,3)+EFF_NI(i,k,j)
1357           eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,3)+eff_di(i,k,j)
1358           EFF_NQID=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,3)+EFF_NQID
1359           eff_dqiD=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,3)+eff_dqiD
1360          END DO
1361          IF (EFF_DQID.NE.0)THEN
1362          QID_EFFR(I,K,J)=EFF_NQID/EFF_DQID
1363          ELSE
1364          QID_EFFR(I,K,J)=0.
1365          END IF
1367 !s=(3.1415/4)*(4.6*(10**(-3.377)))**(-0.98)*(m(nkr))**0.98
1368 ! HAIL
1369          KRR=0
1370          kext_qh(i,k,j)=0.
1371          DO KR=p_ff7i01,p_ff7i33
1372           KRR=KRR+1
1373           chem_new(I,K,J,KR)=FF5R(KRR)
1374           geo_cs=3.1415*(3*xh(krr)/(4*3.1415*0.9))**(2./3.)
1375           kext_qh(i,k,j)=kext_qh(i,k,j)+2.*geo_cs*(100.*col*3*xh(krr))*ff5r(krr)
1376           EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XH(KRR)+EFF_NI(i,k,j)
1377           eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XH(KRR)+eff_di(i,k,j)
1378          END DO
1380         END IF
1381       END DO
1382       END DO
1383       END DO
1385       NKRO=1
1386       NKRE=NKR
1387       DO j = jts,jte
1388       DO i = its,ite
1389       DO k = kts,kte
1390       rhocgs_z(k)=rhocgs(i,k,j)
1391       pcgs_z(k)=pcgs(i,k,j)
1392       zcgs_z(k)=zcgs(i,k,j)
1393       krr=0
1394       do kr=p_ff1i01,p_ff1i33
1395        krr=krr+1
1396        ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
1397       end do
1398       end do
1399       CALL FALFLUXHUCM(ffx_z,VR1,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
1400       DO k = kts,kte
1401       krr=0
1402       do kr=p_ff1i01,p_ff1i33
1403        krr=krr+1
1404        chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
1405       end do
1406       end do
1407       if (iceprocs.eq.1)then
1408       DO k = kts,kte
1409       rhocgs_z(k)=rhocgs(i,k,j)
1410       pcgs_z(k)=pcgs(i,k,j)
1411       zcgs_z(k)=zcgs(i,k,j)
1412       krr=0
1413       do kr=p_ff5i01,p_ff5i33
1414        krr=krr+1
1415        ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
1416       end do
1417       end do
1418       CALL FALFLUXHUCM(ffx_z,VR3,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
1419       DO k = kts,kte
1420       krr=0
1421       do kr=p_ff5i01,p_ff5i33
1422        krr=krr+1
1423        chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
1424       end do
1425       end do
1426       DO k = kts,kte
1427       rhocgs_z(k)=rhocgs(i,k,j)
1428       pcgs_z(k)=pcgs(i,k,j)
1429       zcgs_z(k)=zcgs(i,k,j)
1430       krr=0
1431       do kr=p_ff6i01,p_ff6i33
1432        krr=krr+1
1433        ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
1434       end do
1435       end do
1436       CALL FALFLUXHUCM(ffx_z,VR4,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
1437       DO k = kts,kte
1438       krr=0
1439       do kr=p_ff6i01,p_ff6i33
1440        krr=krr+1
1441        chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
1442       end do
1443       end do
1444 !    &     ims,ime,jms,jme,kms,kme)
1445       DO k = kts,kte
1446       rhocgs_z(k)=rhocgs(i,k,j)
1447       pcgs_z(k)=pcgs(i,k,j)
1448       zcgs_z(k)=zcgs(i,k,j)
1449       krr=0
1450       do kr=p_ff2i01,p_ff2i33
1451        krr=krr+1
1452        ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
1453        vri(krr)=vr2(krr,1)
1454       end do
1455       end do
1456       CALL FALFLUXHUCM(ffx_z,VRI,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
1457       DO k = kts,kte
1458       krr=0
1459       do kr=p_ff2i01,p_ff2i33
1460        krr=krr+1
1461        chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
1462       end do
1463       end do
1464       DO k = kts,kte
1465       rhocgs_z(k)=rhocgs(i,k,j)
1466       pcgs_z(k)=pcgs(i,k,j)
1467       zcgs_z(k)=zcgs(i,k,j)
1468       krr=0
1469       do kr=p_ff3i01,p_ff3i33
1470        krr=krr+1
1471        ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
1472        vri(krr)=vr2(krr,2)
1473       end do
1474       end do
1475       CALL FALFLUXHUCM(ffx_z,VRI,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
1476       DO k = kts,kte
1477       krr=0
1478       do kr=p_ff3i01,p_ff3i33
1479        krr=krr+1
1480        chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
1481       end do
1482       end do
1483       DO k = kts,kte
1484       rhocgs_z(k)=rhocgs(i,k,j)
1485       pcgs_z(k)=pcgs(i,k,j)
1486       zcgs_z(k)=zcgs(i,k,j)
1487       krr=0
1488       do kr=p_ff4i01,p_ff4i33
1489        krr=krr+1
1490        ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
1491        vri(krr)=vr2(krr,3)
1492       end do
1493       end do
1494       CALL FALFLUXHUCM(ffx_z,VRI,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
1495       DO k = kts,kte
1496       krr=0
1497       do kr=p_ff4i01,p_ff4i33
1498        krr=krr+1
1499        chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
1500       end do
1501       end do
1502       DO k = kts,kte
1503       rhocgs_z(k)=rhocgs(i,k,j)
1504       pcgs_z(k)=pcgs(i,k,j)
1505       zcgs_z(k)=zcgs(i,k,j)
1506       krr=0
1507       do kr=p_ff7i01,p_ff7i33
1508        krr=krr+1
1509        ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
1510       end do
1511       end do
1512       CALL FALFLUXHUCM(ffx_z,VR5,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
1513       DO k = kts,kte
1514       krr=0
1515       do kr=p_ff7i01,p_ff7i33
1516        krr=krr+1
1517        chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
1518       end do
1519       end do
1520       end if
1521       end do 
1522       end do 
1524       gmax=0
1525       qmax=0
1526       imax=0
1527       kmax=0
1528       qnmax=0
1529       inmax=0
1530       knmax=0
1531       DO j = jts,jte
1532       DO k = kts,kte
1533       DO i = its,ite
1534       QC(I,K,J)=0
1535       QR(I,K,J)=0
1536       QIC(I,K,J)=0
1537       QIP(I,K,J)=0
1538       QID(I,K,J)=0
1539       QS(I,K,J)=0
1540       QG(I,K,J)=0
1541       QH(I,K,J)=0
1542       QNC(I,K,J)=0
1543       QNR(I,K,J)=0
1544       QNIP(I,K,J)=0
1545       QNIC(I,K,J)=0
1546       QNID(I,K,J)=0
1547       QNS(I,K,J)=0
1548       QNG(I,K,J)=0
1549       QNH(I,K,J)=0
1550       QNA(I,K,J)=0
1551       tt= th_phy(i,k,j)*pi_phy(i,k,j)
1552       DO KR=1,NKR
1553       COLREFLL(KR)=COEFREFLL
1554       COLREFLI(KR)=COEFREFLI
1555         IF(TT.GE.271.15.AND.TT.LE.273.15) THEN
1556                COLREFLS(KR)=COEFREF00/0.09
1557                COLREFLG(KR)=COEFREF00/RO4BL(KR)/RO4BL(KR)
1558                COLREFLH(KR)=COEFREF00/RO5BL(KR)/RO5BL(KR)
1559         ELSE
1560                COLREFLS(KR)=COEFREFLI
1561                COLREFLG(KR)=COEFREFLI
1562                COLREFLH(KR)=COEFREFLI
1563         ENDIF
1564       END DO
1565 !     END IF
1566       EFF_N=0.
1567       EFF_D=0.
1568       KRR=0
1569       DO KR = p_ff1i01,p_ff1i33
1570         KRR=KRR+1
1571         IF (KRR.LT.KRDROP)THEN
1572           EFF_N=DROPRADII(KRR)**3*chem_new(i,k,j,KR)*XL(KRR)+EFF_N
1573           EFF_D=DROPRADII(KRR)**2*chem_new(i,k,j,KR)*XL(KRR)+EFF_D
1574           QC(I,K,J)=QC(I,K,J) &
1575      &      +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3
1576 !          QNC(I,K,J)=QNC(I,K,J) &
1577 ! J. Fan
1578 !     &      +COL*chem_new(I,K,J,KR)*XL(KR)*3
1579            QNC(I,K,J)=QNC(I,K,J) &
1580     &       +COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg
1581         ELSE
1582           QR(I,K,J)=QR(I,K,J) &
1583      &      +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3
1584           QNR(I,K,J)=QNR(I,K,J) &
1585 !     &      +COL*chem_new(I,K,J,KR)*XL(KR)*3
1586      &      +COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
1587         END IF
1588       END DO
1589       IF(QC(I,K,J).GT.1.E-6.and.EFF_D.GT.0)THEN
1590           EFFR(I,K,J)=EFF_N/EFF_D
1591       ELSE
1592           EFFR(I,K,J)=0.
1593       END IF
1594       KRR=0
1595       IF (ICEPROCS.EQ.1)THEN
1596        KRR=0
1597        DO  KR=p_ff5i01,p_ff5i33
1598         KRR=KRR+1
1599 !       if (KRR.LE.KRICE)THEN
1600 !       QI(I,K,J)=QI(I,K,J) &
1601 !    &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3
1602 !       ELSE
1603         QS(I,K,J)=QS(I,K,J) &
1604      &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3
1605 !       END IF
1606         QNS(I,K,J)=QNS(I,K,J) &
1607      &   +COL*chem_new(I,K,J,KR)*XS(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
1608        END DO
1609        KRR=0
1610        DO  KR=p_ff6i01,p_ff6i33
1611         KRR=KRR+1
1612         QG(I,K,J)=QG(I,K,J) &
1613      &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XG(KRR)*XG(KRR)*3
1614         QNG(I,K,J)=QNG(I,K,J) &
1615 !     &   +1000*COL*chem_new(I,K,J,KR)*XG(KRR)*3
1616      &   +COL*chem_new(I,K,J,KR)*XG(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
1617        END DO
1618        KRR=0
1619        DO  KR=p_ff2i01,p_ff2i33
1620         KRR=KRR+1
1621         QIC(I,K,J)=QIC(I,K,J) &
1622      &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XI(KRR,1)*XI(KRR,1)*3
1623         QNIC(I,K,J)=QNIC(I,K,J) &
1624      &   +COL*chem_new(I,K,J,KR)*XI(KRR,1)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
1625        END DO
1626        KRR=0
1627        DO  KR=p_ff3i01,p_ff3i33
1628         KRR=KRR+1
1629         QIP(I,K,J)=QIP(I,K,J) &
1630      &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XI(KRR,2)*XI(KRR,2)*3
1631         QNIP(I,K,J)=QNIP(I,K,J) &
1632      &   +COL*chem_new(I,K,J,KR)*XI(KRR,2)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
1633        END DO
1634        KRR=0
1635        DO  KR=p_ff4i01,p_ff4i33
1636         KRR=KRR+1
1637         QID(I,K,J)=QID(I,K,J) &
1638      &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XI(KRR,3)*XI(KRR,3)*3
1639         QNID(I,K,J)=QNID(I,K,J) &
1640      &   +COL*chem_new(I,K,J,KR)*XI(KRR,3)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
1641        END DO
1642          IF((QIP(I,K,J).GT.1.E-6.OR.QIC(I,K,J).GT.1.E-6.OR.QID(I,K,J).GT.1.E-6)&
1643      &   .and.eff_di(i,k,j).GT.0)THEN
1644           ICE_EFFR(I,K,J)=EFF_NI(i,k,j)/eff_di(i,k,j)
1645          ELSE
1646           ICE_EFFR(I,K,J)=0.
1647          END IF
1648       END IF
1649        KRR=0
1650        DO  KR=p_ff8i01,p_ff8i33
1651         KRR=KRR+1
1652         QNA(I,K,J)=QNA(I,K,J) &
1653 !     &   +COL*chem_new(I,K,J,KR)*3
1654 !  change by J.Fan
1655      &   +COL*chem_new(I,K,J,KR)/rhocgs(I,K,J)*1000.   ! #/kg
1656        END DO
1657 !       if (i.eq.100.and.j.eq.100)then
1658 !       print*,'qna = ', k,qna(i,k,j)
1659 !       end if
1660        KRR=0
1661        DO  KR=p_ff7i01,p_ff7i33
1662         KRR=KRR+1
1663         QH(I,K,J)=QH(I,K,J) &
1664      &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XH(KRR)*XH(KRR)*3
1665         QNH(I,K,J)=QNH(I,K,J) &
1666      &   +COL*chem_new(I,K,J,KR)*XH(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
1667        END DO
1668       END DO
1669       END DO
1670       END DO
1675 998   format(' ',10(f10.1,1x))
1676       DO j = jts,jte
1677       DO i = its,ite
1678        krr=0
1679        RAINNCV(I,J)=0.
1680        SNOWNCV(I,J)=0.
1681        GRAUPELNCV(I,J)=0.
1682        HAILNCV(I,J)=0.
1683        DO KR=p_ff1i01,p_ff1i33
1684         krr=krr+1
1685         DELTAW=VR1(KRR)
1686         RAINNC(I,J)=RAINNC(I,J) &
1687      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1688      &           chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
1689         RAINNCV(I,J)= RAINNCV(I,J) &
1690      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1691      &           chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
1692        END DO
1693        KRR=0
1694        DO KR=p_ff5i01,p_ff5i33
1695         KRR=KRR+1
1696         DELTAW=VR3(KRR)
1697         RAINNC(I,J)=RAINNC(I,J) &
1698      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1699      &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
1700         RAINNCV(I,J)=RAINNCV(I,J) &
1701      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1702      &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
1703         SNOWNC(I,J)=SNOWNC(I,J) &
1704      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1705      &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
1706         SNOWNCV(I,J)= SNOWNCV(I,J) &
1707      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1708      &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
1709        END DO
1710        KRR=0
1711        DO KR=p_ff6i01,p_ff6i33
1712         KRR=KRR+1
1713         DELTAW=VR4(KRR)
1714         RAINNC(I,J)=RAINNC(I,J) &
1715      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1716      &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
1717         RAINNCV(I,J)=RAINNCV(I,J) &
1718      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1719      &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
1720         GRAUPELNC(I,J)=GRAUPELNC(I,J) &
1721      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1722      &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
1723         GRAUPELNCV(I,J)=  GRAUPELNCV(I,J) &
1724      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1725      &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
1726        END DO
1727        KRR=0
1728        DO KR=p_ff2i01,p_ff2i33
1729         KRR=KRR+1
1730         DELTAW=VR2(KRR,1)
1731         RAINNC(I,J)=RAINNC(I,J) &
1732      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1733      &           chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
1734         RAINNCV(I,J)=RAINNCV(I,J) &
1735      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1736      &           chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
1737         SNOWNC(I,J)=SNOWNC(I,J) &
1738      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1739      &           chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
1740         SNOWNCV(I,J)=SNOWNCV(I,J) &
1741      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1742      &           chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
1743        END DO
1744        KRR=0
1745        DO KR=p_ff3i01,p_ff3i33
1746         KRR=KRR+1
1747         DELTAW=VR2(KRR,2)
1748         RAINNC(I,J)=RAINNC(I,J) &
1749      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1750      &           chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
1751         RAINNCV(I,J)=RAINNCV(I,J) &
1752      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1753      &           chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
1754         SNOWNC(I,J)=SNOWNC(I,J) &
1755      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1756      &           chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
1757         SNOWNCV(I,J)=SNOWNCV(I,J) &
1758      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1759      &           chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
1760        END DO
1761        KRR=0
1762        DO KR=p_ff4i01,p_ff4i33
1763         KRR=KRR+1
1764         DELTAW=VR2(KRR,3)
1765         RAINNC(I,J)=RAINNC(I,J) &
1766      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1767      &           chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
1768         RAINNCV(I,J)=RAINNCV(I,J) &
1769      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1770      &           chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
1771         SNOWNC(I,J)=SNOWNC(I,J) &
1772      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1773      &           chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
1774         SNOWNCV(I,J)=SNOWNCV(I,J) &
1775      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1776      &           chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
1777        END DO
1778        KRR=0
1779        DO KR=p_ff7i01,p_ff7i33
1780         KRR=KRR+1
1781         DELTAW=VR5(KRR)
1782         RAINNC(I,J)=RAINNC(I,J) &
1783      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1784      &           chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
1785         RAINNCV(I,J)=RAINNCV(I,J) &
1786      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1787      &           chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
1788         HAILNC(I,J)=HAILNC(I,J) &
1789      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1790      &           chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
1791         HAILNCV(I,J)= HAILNCV(I,J) &
1792      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
1793      &           chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
1794        END DO
1795 !     print*, i,j,rainnc(i,j)
1796   ! Transfer 1D arrays back into 3D arrays
1797    !
1798       do k=kts,kte
1801           qv1d(k)=qv(i,k,j)
1802           qr1d(k)=qr(i,k,j)
1803           nr1d(k)=qnr(i,k,j)
1804           qs1d(k)=qs(i,k,j)
1805           ns1d(k)=qns(i,k,j)
1806           qg1d(k)=qg(i,k,j)+qh(i,k,j)
1807           ng1d(k)=qng(i,k,j)+qnh(i,k,j)
1808           t1d(k)=th_phy(i,k,j)*pi_phy(i,k,j)
1809           p1d(k)=P_PHY(I,K,J)
1810        end do
1811 ! wrf-chem
1813 !+---+-----------------------------------------------------------------+
1814          IF ( PRESENT (diagflag) ) THEN
1815          if (diagflag .and. do_radar_ref == 1) then
1816           call refl10cm_hm (qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d,   &
1817                       t1d, p1d, dBZ, kts, kte, i, j)
1818           do k = kts, kte
1819              refl_10cm(i,k,j) = MAX(-35., dBZ(k))
1820           enddo
1821          endif
1822          ENDIF
1823          SR(I,J) = (SNOWNCV(I,J)+GRAUPELNCV(I,J)+HAILNCV(I,J))/(RAINNCV(I,J)+1.e-12)
1825       END DO
1826       END DO
1829 !     print*,'here 7'
1830       do j=jts,jte
1831       do k=kts,kte
1832       do i=its,ite
1833 !        th_old_2(i,k,j)=th_phy(i,k,j)
1834 !        qv_old_2(i,k,j)=qv(i,k,j)
1835          th_old(i,k,j)=th_phy(i,k,j)
1836          qv_old(i,k,j)=qv(i,k,j)
1837 !     if(i.eq.64.and.j.eq.2.and.k.eq.16)then
1838 !        print*,'th_phy(I,K,J),tt = ',th_phy(I,K,J),tt
1839 !        print*,'qv(I,K,J) = ',qv(I,K,J)
1840 !     end if
1841       end do
1842       end do
1843       end do
1844 !     stop
1845 !     print*,'here 8'
1846       if (conserv)then
1847       DO j = jts,jte
1848       DO i = its,ite
1849       DO k = kts,kte
1850       rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
1851       krr=0
1852       DO KR=p_ff1i01,p_ff1i33
1853         krr=krr+1
1854        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XL(KRR)*XL(KRR)*3.0
1855        if (qc(i,k,j)+qr(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
1856       END DO
1857       KRR=0
1858       DO KR=p_ff5i01,p_ff5i33
1859        KRR=KRR+1
1860        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XS(KRR)*XS(KRR)*3.0
1861        if (qs(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
1862       END DO
1863       KRR=0
1864       DO KR=p_ff6i01,p_ff6i33
1865        KRR=KRR+1
1866        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XG(KRR)*XG(KRR)*3.0
1867        if (qg(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
1868       END DO
1869       KRR=0
1870 !      if (i.eq.100.and.j.eq.100)then
1871 !       print*,'qna 3 = ', k,qna(i,k,j)
1872 !      end if
1873       DO KR=p_ff8i01,p_ff8i33
1874        KRR=KRR+1
1875 ! change by Fan
1876 !       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*XCCN(KRR)
1877        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*1000.          ! #/kg; remember chem_new for CCN is #/cm3, not #/(gcm-3)
1878       END DO
1879 !      if (i.eq.100.and.j.eq.100)then
1880 !       print*,'qna  4 = ', k,qna(i,k,j)
1881 !      end if
1882       KRR=0
1883       DO KR=p_ff2i01,p_ff2i33
1884        KRR=KRR+1
1885        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XI(KRR,1)*XI(KRR,1)*3.0
1886        if (qic(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
1887       END DO
1888       KRR=0
1889       DO KR=p_ff3i01,p_ff3i33
1890        KRR=KRR+1
1891        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XI(KRR,2)*XI(KRR,2)*3.0
1892        if (qip(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
1893       END DO
1894       KRR=0
1895       DO KR=p_ff4i01,p_ff4i33
1896        KRR=KRR+1
1897        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XI(KRR,3)*XI(KRR,3)*3.0
1898        if (qid(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
1899       END DO
1900       KRR=0
1901       DO KR=p_ff7i01,p_ff7i33
1902        KRR=KRR+1
1903        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XH(KRR)*XH(KRR)*3.0
1904        if (qh(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
1905       END DO
1906       END DO
1907       END DO
1908       END DO
1909       END IF
1910      
1911 !     print*,'here 9'
1912       RETURN
1913   END SUBROUTINE SBM
1914       SUBROUTINE FALFLUXHUCM(chem_new,VR1,RHOCGS,PCGS,ZCGS,DT, &
1915      &     kts,kte,nkr)
1916       IMPLICIT NONE
1917       INTEGER I,J,K,KR
1918       INTEGER    kts,kte,nkr
1919       REAL TFALL,DTFALL,VFALL(KTE),DWFLUX(KTE)
1920       REAL DT
1921       INTEGER IFALL,N,NSUB
1922       REAL, DIMENSION( kts:kte,nkr ) :: chem_new 
1923       REAL,  DIMENSION(kts:kte) :: rhocgs,pcgs,zcgs
1924       REAL VR1(NKR)
1926 ! FALLING FLUXES FOR EACH KIND OF CLOUD PARTICLES: C.G.S. UNIT
1927 ! ADAPTED FROM GSFC CODE FOR HUCM
1928 !  The flux at k=1 is assumed to be the ground so FLUX(1) is the
1929 ! flux into the ground. DWFLUX(1) is at the lowest half level where
1930 ! Q(1) etc are defined. The formula for FLUX(1) uses Q(1) etc which
1931 ! is actually half a grid level above it. This is what is meant by
1932 ! an upstream method. Upstream in this case is above because the
1933 ! velocity is downwards.      
1934 ! USE UPSTREAM METHOD (VFALL IS POSITIVE)                 
1935 !        print*,'pcgs(i,k,j) = ',pcgs(100,10,1)
1936 !        print*,'pcgs(i,k,j) = ',pcgs(100,1,1)
1937 !      read(5,*)
1938 !        print*,'pcgs(i,k,j) = ',zcgs(100,10,1)
1939 !        print*,'pcgs(i,k,j) = ',zcgs(100,1,1)
1940 !      read(5,*)
1941       DO KR=1,NKR
1942        IFALL=0
1943        DO k = kts,kte
1944           IF(chem_new(K,KR).GE.1.E-10)IFALL=1
1945        END DO 
1946        IF (IFALL.EQ.1)THEN
1947         TFALL=1.E10                
1948         DO K=kts,kte
1949          VFALL(K) = VR1(KR)*SQRT(1.E6/PCGS(K))
1950 !        if (krr.eq.20.or.krr.eq.33)then
1951 !        if (k.eq.5.or.k.eq.10.or.k.eq.20)then
1952 !        print*,'vr1(krr) = ',krr,vr1(krr)
1953 !        print*, 'SQRT(1.E6/PCGS(I,K,J)) = ',i,k,SQRT(1.E6/PCGS(I,K,J))
1954 !        print*,'vfall(k) = ',i,k,vfall(k)
1955 !        print*,'zcgs(k) = ',i,k,zcgs(i,k,j)
1956 !        read(5,*)
1957 !        end if
1958 !        end if
1959          TFALL=AMIN1(TFALL,ZCGS(K)/(VFALL(K)+1.E-20))    
1960 !        print*,'tfall = ',i,k,tfall
1961 !        if (krr.eq.5.or.krr.eq.10.or.krr.eq.20.or.krr.eq.33)read(5,*)
1962         END DO                                                 
1963         IF(TFALL.GE.1.E10) call wrf_error_fatal("fatal error in module_mp_full_sbm (TFALL.GE.1.E10), model stop")
1964         NSUB=(INT(2.0*DT/TFALL)+1)                           
1965         DTFALL=DT/NSUB                                      
1967         DO N=1,NSUB                                    
1968           DO K=KTS,KTE-1                               
1969            DWFLUX(K)=-(RHOCGS(K)*VFALL(K)*chem_new(k,kr)- &
1970      &     RHOCGS(K+1)* &
1971      &     VFALL(K+1)*chem_new(K+1,KR))/(RHOCGS(K)*(ZCGS(K+1)- &
1972      &      ZCGS(K)))    
1973           END DO    
1974 ! NO Z ABOVE TOP, SO USE THE SAME DELTAZ
1975           DWFLUX(KTE)=-(RHOCGS(KTE)*VFALL(KTE)* & 
1976      &       chem_new(kte,kr))/(RHOCGS(KTE)*(ZCGS(KTE)-ZCGS(KTE-1)))         
1977           DO K=kts,kte                                         
1978            chem_new(k,kr)=chem_new(k,kr)+DWFLUX(K)*DTFALL
1979           END DO  
1980         END DO  
1981        END IF
1982       END DO  
1983       RETURN                                                                  
1984       END SUBROUTINE FALFLUXHUCM                                                                    
1985       SUBROUTINE FULL_HUCMINIT(DT)
1986       IMPLICIT NONE
1987       INTEGER IKERN_0,IKERN_Z,L0_REAL,L0_INTEGER,INEWMEY,INEST
1988       INTEGER I,J,K,KR
1989       REAL DT
1990       INTEGER :: hujisbm_unit1
1991       LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
1992       LOGICAL :: opened 
1993       LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
1994       CHARACTER*80 errmess
1995       REAL PI
1996       double precision ax
1997       data pi/3.141592654/
1998 ! dtime - timestep of integration (calculated in main program) :
1999 ! ax - coefficient used for masses calculation 
2000 ! ima(i,j) - k-category number, c(i,j) - courant number 
2002         REAL C1(NKR,NKR)
2003 ! DON'T NEED ALL THESE VARIABLES: STILL NEED EDITING
2004        INTEGER ICE,KGRAN,IPRINT01
2005        REAL TWSIN,TWCIN,TWNUC,XF5,XF4,XF3,CONCHIN,CONCGIN,CONCSIN, &
2006      & CONCCLIN,TWHIN,RADH,RADS,RADG,RADL,CONCLIN,A1_MY,A2,A2_MY,XLK, &
2007      & A1N,A3_MY,A3,A1_MYN,R0CCN,X0DROP,DEG01,CONTCCNIN,CONCCCNIN, &
2008      & A,B,X0CCN,S_KR,RCCNKR,R0,X0,TWCALLIN,A1,RCCNKR_CM,SUMIIN,TWGIN, &
2009      & XF1N,XF1,WC1N,RF1N,WNUC,RNUC,WC5,RF5, &
2010      & WC4,RF4,WC3,RF3,WC1,RF1,SMAX
2011        REAL TWIIN(ICEMAX)
2012        REAL RO_SOLUTE      
2013        REAL A_FALL,B_FALL
2014        real graupel_fall(nkr)
2015        data graupel_fall/0.36840E-01,0.57471E-01,0.88417E-01,0.13999E+00,&
2016      &  0.22841E+00,0.36104E+00,0.56734E+00, 0.88417E+00, 0.13999E+01,&
2017      &  0.22104E+01, 0.35367E+01, 0.54524E+01, 0.81049E+01,0.12526E+02,&
2018      &  0.19157E+02, 0.27262E+02, 0.34627E+02, 0.39776E+02,0.45690E+02,& 
2019      &  0.52485E+02, 0.60289E+02, 0.69254E+02, 0.10000E+03, 0.15429E+03,&
2020      &  0.18561E+03, 0.22329E+03, 0.26863E+03,  0.32316E+03,0.38877E+03,& 
2021      &  0.46770E+03, 0.56266E+03, 0.67690E+03,  0.81432E+03/
2023        INTEGER  KZ_MIN,KZ_MAX
2024        PARAMETER (RO_SOLUTE=2.16)
2025        INTEGER KR_MIN,KR_MIN1,KR_MAX
2026        REAL RADCCN_MIN,RADCCN_MIN1,RADCCN_MAX
2027        REAL FR_CON,FR_MAR
2028      REAL  ::      RHOSU       ! STANDARD AIR DENSITY AT 850 MB
2029      REAL ::      RHOW        ! DENSITY OF LIQUID WATER
2030      REAL ::      RHOI        ! BULK DENSITY OF CLOUD ICE
2031      REAL ::      RHOSN       ! BULK DENSITY OF SNOW
2032      REAL ::      RHOG        ! BULK DENSITY OF GRAUPEL
2033      REAL ::      CI,DI,CS,DS,CG,DG ! SIZE DISTRIBUTION PARAMETERS FOR CLOUD ICE, SNOW, GRAUPE
2034        FR_MAR=1.0
2035 !      FR_CON=1-FR_MAR
2036        FR_CON=1.0
2038 !      KZ_MIN=16
2039 !      KZ_MAX=21
2043         call wrf_message(" FULL SBM: INITIALIZING HUCM ")
2044         call wrf_message(" FULL SBM: ****** HUCM ******* ")
2045 !        PRINT*, 'INITIALIZING HUCM'  
2046 !       print *, ' ****** HUCM *******'
2048 ! INPUT :
2049         dlnr=dlog(2.d0)/(3.d0*scal)
2050 !     print*,'here in hucmint 1'
2052 !--- Read in various lookup tables
2054 !        print*,'wrf_dm_on_monitor() =',wrf_dm_on_monitor() 
2055         IF ( wrf_dm_on_monitor() ) THEN
2056           DO i = 31,99
2057             INQUIRE ( i , OPENED = opened )
2058             IF ( .NOT. opened ) THEN
2059               hujisbm_unit1 = i
2060               GOTO 2061
2061             ENDIF
2062           ENDDO
2063           hujisbm_unit1 = -1
2064  2061     CONTINUE
2065         ENDIF
2067 !     print*,'here in hucmint 2',hujisbm_unit1
2068         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2069 !     print*,'here in hucmint 3',hujisbm_unit1
2071         IF ( hujisbm_unit1 < 0 ) THEN
2072           CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
2073         ENDIF
2075 !       print*,'here at 1'
2076 !      print*,'here in hucmint 4'
2077         IF ( wrf_dm_on_monitor() ) THEN
2078           OPEN(UNIT=hujisbm_unit1,FILE="capacity.asc",                  &
2079      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2081   900   FORMAT(6E13.5)
2082         READ(hujisbm_unit1,900) RLEC,RIEC,RSEC,RGEC,RHEC
2083         CLOSE(hujisbm_unit1)
2084 !     print*,'here in hucmint 5'
2085         END IF
2086         CALL wrf_dm_bcast_bytes ( RLEC , size ( RLEC ) * RWORDSIZE )
2087         CALL wrf_dm_bcast_bytes ( RIEC , size ( RIEC ) * RWORDSIZE )
2088         CALL wrf_dm_bcast_bytes ( RSEC , size ( RSEC ) * RWORDSIZE )
2089         CALL wrf_dm_bcast_bytes ( RGEC , size ( RGEC ) * RWORDSIZE )
2090         CALL wrf_dm_bcast_bytes ( RHEC , size ( RHEC ) * RWORDSIZE )
2091 ! MASSES :
2092         IF ( wrf_dm_on_monitor() ) THEN
2093           DO i = 31,99
2094             INQUIRE ( i , OPENED = opened )
2095             IF ( .NOT. opened ) THEN
2096               hujisbm_unit1 = i
2097               GOTO 2062
2098             ENDIF
2099           ENDDO
2100           hujisbm_unit1 = -1
2101  2062     CONTINUE
2102         ENDIF
2104         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2106         IF ( hujisbm_unit1 < 0 ) THEN
2107           CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
2108         ENDIF
2110         IF ( wrf_dm_on_monitor() ) THEN
2111           OPEN(UNIT=hujisbm_unit1,FILE="masses.asc",                  &
2112      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2113         READ(hujisbm_unit1,900) XL,XI,XS,XG,XH          
2114         CLOSE(hujisbm_unit1)
2115 !       print *, ' ***** file2: succesfull *******'
2116         call wrf_message(" FULL SBM: ****** file2: succesfull  ******* ")
2117         ENDIF
2118         CALL wrf_dm_bcast_bytes ( XL , size ( XL ) * RWORDSIZE )
2119         CALL wrf_dm_bcast_bytes ( XI , size ( XI ) * RWORDSIZE )
2120         CALL wrf_dm_bcast_bytes ( XS , size ( XS ) * RWORDSIZE )
2121         CALL wrf_dm_bcast_bytes ( XG , size ( XG ) * RWORDSIZE )
2122         CALL wrf_dm_bcast_bytes ( XH , size ( XH ) * RWORDSIZE )
2123 ! TERMINAL VELOSITY :
2124         IF ( wrf_dm_on_monitor() ) THEN
2125           DO i = 31,99
2126             INQUIRE ( i , OPENED = opened )
2127             IF ( .NOT. opened ) THEN
2128               hujisbm_unit1 = i
2129               GOTO 2063
2130             ENDIF
2131           ENDDO
2132           hujisbm_unit1 = -1
2133  2063     CONTINUE
2134         ENDIF
2136         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2138         IF ( hujisbm_unit1 < 0 ) THEN
2139           CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
2140         ENDIF
2142         IF ( wrf_dm_on_monitor() ) THEN
2143           OPEN(UNIT=hujisbm_unit1,FILE="termvels.asc",                  &
2144      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2145         READ(hujisbm_unit1,900) VR1,VR2,VR3,VR4,VR5     
2146         CLOSE(hujisbm_unit1)
2147 !       print *, ' ***** file3: succesfull *******'
2148         call wrf_message(" FULL SBM: ****** file3: succesfull  ******* ")
2149         ENDIF
2150         CALL wrf_dm_bcast_bytes ( VR1 , size ( VR1 ) * RWORDSIZE )
2151         CALL wrf_dm_bcast_bytes ( VR2 , size ( VR2 ) * RWORDSIZE )
2152         CALL wrf_dm_bcast_bytes ( VR3 , size ( VR3 ) * RWORDSIZE )
2153         CALL wrf_dm_bcast_bytes ( VR4 , size ( VR4 ) * RWORDSIZE )
2154         CALL wrf_dm_bcast_bytes ( VR5 , size ( VR5 ) * RWORDSIZE )
2155 ! CHANGE FALL VELOCITY OF GRAUPEL
2156         DO KR=1,NKR
2157 !        A=RADXXO(KR,6)
2158 !        B=RADXXO(KR,7)
2159          if (kr.le.17)then
2160           A_FALL=1
2161           B_FALL=0
2162          else
2163           B_FALL=1
2164           A_FALL=0
2165          end if
2166   
2167 !        VR4(KR)=A_FALL*VR4(KR)+B_FALL*VR5(KR)
2168 !        print*,'vr4,vr5,graupel_fall=',vr3(kr),vr5(kr),graupel_fall(kr)
2169 !        VR4(KR)=graupel_fall(kr)
2170         END DO
2172 ! CONSTANTS :
2173         IF ( wrf_dm_on_monitor() ) THEN
2174           DO i = 31,99
2175             INQUIRE ( i , OPENED = opened )
2176             IF ( .NOT. opened ) THEN
2177               hujisbm_unit1 = i
2178               GOTO 2065
2179             ENDIF
2180           ENDDO
2181           hujisbm_unit1 = -1
2182  2065     CONTINUE
2183         ENDIF
2185         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2187         IF ( hujisbm_unit1 < 0 ) THEN
2188           CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
2189         ENDIF
2191         IF ( wrf_dm_on_monitor() ) THEN
2192           OPEN(UNIT=hujisbm_unit1,FILE="constants.asc",                  &
2193      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2194         READ(hujisbm_unit1,900) SLIC,TLIC,COEFIN,C2,C3,C4
2195         CLOSE(hujisbm_unit1)
2196 !       print *, ' ***** file4: succesfull *******'
2197         call wrf_message(" FULL SBM: ****** file4: succesfull  ******* ")
2198         END IF
2199         CALL wrf_dm_bcast_bytes ( SLIC , size ( SLIC ) * RWORDSIZE )
2200         CALL wrf_dm_bcast_bytes ( TLIC , size ( TLIC ) * RWORDSIZE )
2201         CALL wrf_dm_bcast_bytes ( COEFIN , size ( COEFIN ) * RWORDSIZE )
2202 !       CALL wrf_dm_bcast_bytes ( C2 , size ( C2 ) * RWORDSIZE )
2203 !       CALL wrf_dm_bcast_bytes ( C3 , size ( C3 ) * RWORDSIZE )
2204 !       CALL wrf_dm_bcast_bytes ( C4 , size ( C4 ) * RWORDSIZE )
2205 ! CONSTANTS :
2206 ! KERNELS DEPENDING ON PRESSURE :
2207         IF ( wrf_dm_on_monitor() ) THEN
2208           DO i = 31,99
2209             INQUIRE ( i , OPENED = opened )
2210             IF ( .NOT. opened ) THEN
2211               hujisbm_unit1 = i
2212               GOTO 2066
2213             ENDIF
2214           ENDDO
2215           hujisbm_unit1 = -1
2216  2066     CONTINUE
2217         ENDIF
2219         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2221         IF ( hujisbm_unit1 < 0 ) THEN
2222           CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
2223         ENDIF
2225         IF ( wrf_dm_on_monitor() ) THEN
2226           OPEN(UNIT=hujisbm_unit1,FILE="kernels_z.asc",                  &
2227      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2228         READ(hujisbm_unit1,900)  &
2229      &  YWLL_1000MB,YWLL_750MB,YWLL_500MB
2230         CLOSE(hujisbm_unit1)
2231         END IF
2232         CALL wrf_dm_bcast_bytes ( YWLL_1000MB , size ( YWLL_1000MB ) * RWORDSIZE )
2233         CALL wrf_dm_bcast_bytes ( YWLL_750MB , size ( YWLL_750MB ) * RWORDSIZE )
2234         CALL wrf_dm_bcast_bytes ( YWLL_500MB , size ( YWLL_500MB ) * RWORDSIZE )
2235         IF ( wrf_dm_on_monitor() ) THEN
2236           DO i = 31,99
2237             INQUIRE ( i , OPENED = opened )
2238             IF ( .NOT. opened ) THEN
2239               hujisbm_unit1 = i
2240               GOTO 2067
2241             ENDIF
2242           ENDDO
2243           hujisbm_unit1 = -1
2244  2067     CONTINUE
2245         ENDIF
2247         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2249         IF ( hujisbm_unit1 < 0 ) THEN
2250           CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
2251         ENDIF
2253         IF ( wrf_dm_on_monitor() ) THEN
2254           OPEN(UNIT=hujisbm_unit1,FILE="kernels.asc_s_0_03_0_9",                  &
2255      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2256 ! KERNELS NOT DEPENDING ON PRESSURE :
2257         READ(hujisbm_unit1,900) &
2258      &  YWLL,YWLI,YWLS,YWLG,YWLH, &
2259      &  YWIL,YWII,YWIS,YWIG,YWIH, &
2260      &  YWSL,YWSI,YWSS,YWSG,YWSH, &
2261      &  YWGL,YWGI,YWGS,YWGG,YWGH, &
2262      &  YWHL,YWHI,YWHS,YWHG,YWHH
2263        close (hujisbm_unit1)
2264         END IF
2265         CALL wrf_dm_bcast_bytes ( YWLL , size ( YWLL ) * RWORDSIZE )
2266         CALL wrf_dm_bcast_bytes ( YWLI , size ( YWLI ) * RWORDSIZE )
2267         CALL wrf_dm_bcast_bytes ( YWLS , size ( YWLS ) * RWORDSIZE )
2268         CALL wrf_dm_bcast_bytes ( YWLG , size ( YWLG ) * RWORDSIZE )
2269         CALL wrf_dm_bcast_bytes ( YWLH , size ( YWLH ) * RWORDSIZE )
2270         CALL wrf_dm_bcast_bytes ( YWIL , size ( YWIL ) * RWORDSIZE )
2271         CALL wrf_dm_bcast_bytes ( YWII , size ( YWII ) * RWORDSIZE )
2272         CALL wrf_dm_bcast_bytes ( YWIS , size ( YWIS ) * RWORDSIZE )
2273         CALL wrf_dm_bcast_bytes ( YWIG , size ( YWIG ) * RWORDSIZE )
2274         CALL wrf_dm_bcast_bytes ( YWIH , size ( YWIH ) * RWORDSIZE )
2275         CALL wrf_dm_bcast_bytes ( YWSL , size ( YWSL ) * RWORDSIZE )
2276         CALL wrf_dm_bcast_bytes ( YWSI , size ( YWSI ) * RWORDSIZE )
2277         CALL wrf_dm_bcast_bytes ( YWSS , size ( YWSS ) * RWORDSIZE )
2278         CALL wrf_dm_bcast_bytes ( YWSG , size ( YWSG ) * RWORDSIZE )
2279         CALL wrf_dm_bcast_bytes ( YWSH , size ( YWSH ) * RWORDSIZE )
2280         CALL wrf_dm_bcast_bytes ( YWGL , size ( YWGL ) * RWORDSIZE )
2281         CALL wrf_dm_bcast_bytes ( YWGI , size ( YWGI ) * RWORDSIZE )
2282         CALL wrf_dm_bcast_bytes ( YWGS , size ( YWGS ) * RWORDSIZE )
2283         CALL wrf_dm_bcast_bytes ( YWGG , size ( YWGG ) * RWORDSIZE )
2284         CALL wrf_dm_bcast_bytes ( YWGH , size ( YWGH ) * RWORDSIZE )
2285         CALL wrf_dm_bcast_bytes ( YWHL , size ( YWHL ) * RWORDSIZE )
2286         CALL wrf_dm_bcast_bytes ( YWHI , size ( YWHI ) * RWORDSIZE )
2287         CALL wrf_dm_bcast_bytes ( YWHS , size ( YWHS ) * RWORDSIZE )
2288         CALL wrf_dm_bcast_bytes ( YWHG , size ( YWHG ) * RWORDSIZE )
2289         CALL wrf_dm_bcast_bytes ( YWHH , size ( YWHH ) * RWORDSIZE )
2290 ! BULKDENSITY :
2291         IF ( wrf_dm_on_monitor() ) THEN
2292           DO i = 31,99
2293             INQUIRE ( i , OPENED = opened )
2294             IF ( .NOT. opened ) THEN
2295               hujisbm_unit1 = i
2296               GOTO 2068
2297             ENDIF
2298           ENDDO
2299           hujisbm_unit1 = -1
2300  2068     CONTINUE
2301         ENDIF
2303         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2305         IF ( hujisbm_unit1 < 0 ) THEN
2306           CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
2307         ENDIF
2309         IF ( wrf_dm_on_monitor() ) THEN
2310           OPEN(UNIT=hujisbm_unit1,FILE="bulkdens.asc_s_0_03_0_9",         & 
2311      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2312         READ(hujisbm_unit1,900) RO1BL,RO2BL,RO3BL,RO4BL,RO5BL
2313         CLOSE(hujisbm_unit1)
2314 !       print *, ' ***** file6: succesfull *******'
2315         call wrf_message(" FULL SBM: ****** file6: succesfull  ******* ")
2316         END IF
2317         CALL wrf_dm_bcast_bytes (RO1BL  , size ( RO1BL ) * RWORDSIZE )
2318         CALL wrf_dm_bcast_bytes (RO2BL  , size ( RO2BL ) * RWORDSIZE )
2319         CALL wrf_dm_bcast_bytes (RO3BL  , size ( RO3BL ) * RWORDSIZE )
2320         CALL wrf_dm_bcast_bytes (RO4BL  , size ( RO4BL ) * RWORDSIZE )
2321         CALL wrf_dm_bcast_bytes (RO5BL  , size ( RO5BL ) * RWORDSIZE )
2322 ! BULKRADIUS
2323         IF ( wrf_dm_on_monitor() ) THEN
2324           DO i = 31,99
2325             INQUIRE ( i , OPENED = opened )
2326             IF ( .NOT. opened ) THEN
2327               hujisbm_unit1 = i
2328               GOTO 2069
2329             ENDIF
2330           ENDDO
2331           hujisbm_unit1 = -1
2332  2069     CONTINUE
2333         ENDIF
2335         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2337         IF ( hujisbm_unit1 < 0 ) THEN
2338           CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
2339         ENDIF
2341         IF ( wrf_dm_on_monitor() ) THEN
2342           OPEN(UNIT=hujisbm_unit1,FILE="bulkradii.asc_s_0_03_0_9",         & 
2343      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2344         READ(hujisbm_unit1,*) RADXXO
2345         CLOSE(hujisbm_unit1)
2346 !       print *, ' ***** file7: succesfull *******'
2347         call wrf_message(" FULL SBM: ****** file7: succesfull  ******* ")
2348 !       PRINT *, '******* Hebrew Univ Cloud model-HUCM *******'
2349         call wrf_message(" FULL SBM: Hebrew Univ Cloud model-HUCM ")
2351         END IF
2352         CALL wrf_dm_bcast_bytes (RADXXO  , size ( RADXXO ) * RWORDSIZE )
2353 ! calculation of the mass(in mg) for categories boundaries :
2354         ax=2.d0**(1.0/scal)
2355         xl_mg(1)=0.3351d-7
2356         do i=2,nkr
2357            xl_mg(i)=ax*xl_mg(i-1)
2358 !        if (i.eq.22)print*,'printing xl_mg = ',xl_mg(22)
2359         enddo
2360         do i=1,nkr
2361            xs_mg(i)=xs(i)*1.e3
2362            xg_mg(i)=xg(i)*1.e3
2363            xh_mg(i)=xh(i)*1.e3
2364            xi1_mg(i)=xi(i,1)*1.e3
2365            xi2_mg(i)=xi(i,2)*1.e3
2366            xi3_mg(i)=xi(i,3)*1.e3
2367         enddo
2368 ! calculation of c(i,j) and ima(i,j) :
2369 ! ima(i,j) - k-category number, c(i,j) - courant number 
2370 !       print*, 'calling courant_bott'
2371         call courant_bott
2372 !       print*, 'called courant_bott'
2375         DEG01=1./3.
2377 !------------------------------------------------------------------
2379 !       print*,'XL(ICCN) = ',ICCN,XL
2380         X0DROP=XL(ICCN)
2381 !       print*,'X0DROP = ',X0DROP
2382         X0CCN =X0DROP/(2.**(NKR-1))
2383         R0CCN =(3.*X0CCN/4./3.141593/ROCCN0)**DEG01
2384 !------------------------------------------------------------------
2385 ! THIS TEXT FROM TWOINITM.F_203
2386 !------------------------------------------------------------------
2387 ! TEMPERATURA IN SURFACE LAYER EQUAL 15 Celsius(288.15 K)  
2388         A=3.3E-05/288.15
2389         B=2.*4.3/(22.9+35.5)
2390         B=B*(4./3.)*3.14*RO_SOLUTE
2391         A1=2.*(A/3.)**1.5/SQRT(B)
2392         A2=A1*100.
2393 !------------------------------------------------------------------
2394         CONCCCNIN=0.
2395         CONTCCNIN=0.
2396         DO KR=1,NKR
2397            DROPRADII(KR)=(3.*XL(KR)/4./3.141593/1.)**DEG01
2398         ENDDO
2399         DO KR=1,NKR
2400 !          print*,'ROCCN0 = ',ROCCN0
2401 !          print*, 'X0CCN = ',X0CCN 
2402 !          print*, 'DEG01 = ',DEG01
2403            ROCCN(KR)=ROCCN0
2404            X0=X0CCN*2.**(KR-1)
2405            R0=(3.*X0/4./3.141593/ROCCN(KR))**DEG01
2406            XCCN(KR)=X0
2407            RCCN(KR)=R0
2408 !          print*,'RCCN(KR)= ', KR,RCCN(KR)
2409            RCCNKR_CM=R0
2410 ! CCN SPECTRUM 
2412            S_KR=A2/RCCNKR_CM**1.5
2413            ACCN=ACCN_CON
2414            BCCN=BCCN_CON
2415 !          print*,'accn, bccn,S_KR = ',accn,bccn,S_KR
2416 !  CONTINENTAL
2417            FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN
2418            FCCNR_CON(KR)=FCCNR(KR)
2419 !  MARITIME
2420            ACCN=ACCN_MAR
2421            BCCN=BCCN_MAR
2422            FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN
2423            FCCNR_MAR(KR)=FCCNR(KR)
2425              CONTCCNIN=CONTCCNIN+COL*FCCNR(KR)*R0*R0*R0
2426              CONCCCNIN=CONCCCNIN+COL*FCCNR(KR)
2427         ENDDO
2428 !       PRINT *, '********* MAR CCN CONCENTRATION & MASS *******'
2429 !        call wrf_message(" FULL SBM: MAR CCN CONCENTRATION & MASS ")
2430 !       PRINT 200, CONCCCNIN,CONTCCNIN
2431 ! CALCULATION OF FINAL MARITIME
2432 !RCCN(KR)=            1  1.2303877E-07
2433 !RCCN(KR)=            2  1.5501914E-07
2434 !RCCN(KR)=            3  1.9531187E-07
2435 !RCCN(KR)=           16  3.9372408E-06
2436 !RCCN(KR)=           21  1.2499960E-05
2437 !RCCN(KR)=           33  1.9999935E-04
2438         RADCCN_MAX=RCCN(NKR)
2439         RADCCN_MIN=0.005E-4         
2440         RADCCN_MIN1=0.02E-4         
2441 !       print*,'ALOG(RADCCN_MIN) = ',ALOG(RADCCN_MIN)
2442 !       print*,'ALOG(RCCN(1) = ',ALOG(RCCN(1))
2443 !       print*,'ALOG(RADCCN_MAX) = ',ALOG(RADCCN_MAX)
2444 !       KR_MIN=(ALOG(RADCCN_MIN)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
2445 !       KR_MIN1=(ALOG(RADCCN_MIN1)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
2446         KR_MIN=1.+ 3*(ALOG(RADCCN_MIN)- ALOG(R0CCN))/ALOG(2.)
2447         KR_MIN1=1.+3*(ALOG(RADCCN_MIN1)- ALOG(R0CCN))/ALOG(2.)
2448 !       KR_MAX=(ALOG(RADCCN_MAX)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
2449         KR_MAX=1.+3.*(ALOG(RADCCN_MAX)- ALOG(R0CCN))/ALOG(2.)
2450         KR_MIN=MAX(KR_MIN,1)
2451         KR_MIN1=MAX(KR_MIN,KR_MIN1)
2452         KR_MAX=MIN(NKR,KR_MAX)
2453 !       print*,'kr_min,kr_min1 = ',kr_min,kr_min1
2454 !       print*,'kr_max = ',kr_max
2455 ! Interpolation
2456         DO KR=1,NKR
2457         IF (kr.ge.kr_min.and.kr.lt.kr_min1)then
2458            FCCNR_MAR(KR)=FCCNR_MAR(KR_MIN1)* &
2459      &      (ALOG(RCCN(KR))-ALOG(RCCN(KR_MIN)))/ &
2460      &      (ALOG(RCCN(KR_MIN1))-ALOG(RCCN(KR_MIN)))
2462         END IF
2463         IF (KR.GT.KR_MAX.OR.KR.LT.KR_MIN)FCCNR_MAR(KR)=0
2464 !          print*,'FCCNR_MAR(KR) = ',KR,FCCNR_MAR(KR)
2465         END DO
2466 ! CALCULATION OF FINAL CONTINENTAL
2467         RADCCN_MAX=0.6E-4
2468         RADCCN_MIN=0.005E-4         
2469         RADCCN_MIN1=0.02E-4         
2470 !       KR_MIN=(ALOG(RADCCN_MIN)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
2471 !       KR_MIN1=(ALOG(RADCCN_MIN1)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
2472         KR_MIN=1.+ 3*(ALOG(RADCCN_MIN)- ALOG(R0CCN))/ALOG(2.)
2473         KR_MIN1=1.+3*(ALOG(RADCCN_MIN1)- ALOG(R0CCN))/ALOG(2.)
2474 !       KR_MAX=(ALOG(RADCCN_MAX)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
2475         KR_MAX=1.+3.*(ALOG(RADCCN_MAX)- ALOG(R0CCN))/ALOG(2.)
2476         KR_MIN=MAX(KR_MIN,1)
2477         KR_MIN1=MAX(KR_MIN,KR_MIN1)
2478         KR_MAX=MIN(NKR,KR_MAX)
2479 !       print*,'contin kr_min,kr_min1 = ',kr_min,kr_min1
2480 !       print*,'kr_max = ',kr_max
2481 ! Interpolation
2482         DO KR=1,NKR
2483         IF (kr.ge.kr_min.and.kr.lt.kr_min1)then
2484            FCCNR_CON(KR)=FCCNR_CON(KR_MIN1)* &
2485      &      (ALOG(RCCN(KR))-ALOG(RCCN(KR_MIN)))/ &
2486      &      (ALOG(RCCN(KR_MIN1))-ALOG(RCCN(KR_MIN)))
2487         END IF
2488         IF (KR.GT.KR_MAX.OR.KR.LT.KR_MIN)FCCNR_CON(KR)=0
2489 !          print*,'FCCNR_CON(KR) = ',KR,FCCNR_CON(KR)
2490         END DO
2491 ! CALCULATION OF MIXTURE
2492         DO KR=1,NKR
2493          FCCNR_MIX(KR)=FR_CON*FCCNR_CON(KR)+FR_MAR*FCCNR_MAR(KR)
2494 !        print*,'FCCNR_MIX(KR) = ',FCCNR_MIX(KR)
2495         END DO
2496 !        STOP
2497          CALL BREAKINIT
2498 !        CALL TWOINITMXVAR
2500 ! IN CASE : IPRINT01.NE.0
2503   100   FORMAT(10I4)
2504   101   FORMAT(3X,F7.5,E13.5)
2505   102   FORMAT(4E12.4)
2506   105   FORMAT(A48)
2507   106   FORMAT(A80)
2508   123   FORMAT(3E12.4,3I4)
2509   200   FORMAT(6E13.5)
2510   201   FORMAT(6D13.5)
2511   300   FORMAT(8E14.6) 
2512   301   FORMAT(3X,F8.3,3X,E13.5)
2513   302   FORMAT(5E13.5)
2514 !       if (IFREST)THEN
2515 !       dtime=dt*0.5
2516 !       else
2517 !       END IF
2518         call kernals(dt)
2519 !+---+-----------------------------------------------------------------+
2520 ! from morr_two_moment
2521 !..Set these variables needed for computing radar reflectivity.  These
2522 !.. get used within radar_init to create other variables used in the
2523 !.. radar module.
2524 ! SIZE DISTRIBUTION PARAMETERS
2525          RHOW = 997.
2526          RHOI = 500.
2527          RHOSN = 100.
2528 !        IF (IHAIL.EQ.0) THEN
2529 !        RHOG = 400.
2530 !        ELSE
2531 !        RHOG = 900.
2532 !        END IF
2533          RHOG=450
2536          CI = RHOI*PI_MORR/6.
2537          DI = 3.
2538          CS = RHOSN*PI_MORR/6.
2539          DS = 3.
2540          CG = RHOG*PI_MORR/6.
2541          DG = 3.
2544          xam_r = PI_MORR*RHOW/6.
2545          xbm_r = 3.
2546          xmu_r = 0.
2547          xam_s = CS
2548          xbm_s = DS
2549          xmu_s = 0.
2550          xam_g = CG
2551          xbm_g = DG
2552          xmu_g = 0.
2554          call radar_init
2555 !+---+-----------------------------------------------------------------+
2557         return
2558 2070  continue
2559       WRITE( errmess , '(A,I4)' )                                        &
2560        'module_mp_full_sbm: error opening hujisbm_DATA on unit '          &
2561      &, hujisbm_unit1
2562       CALL wrf_error_fatal(errmess)
2563         end  subroutine full_hucminit
2564       SUBROUTINE BREAKINIT
2565       IMPLICIT NONE
2566       INTEGER :: hujisbm_unit1
2567       LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
2568       LOGICAL :: opened 
2569       LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
2570       CHARACTER*80 errmess
2571 !.....INPUT VARIABLES
2573 !     GT    : MASS DISTRIBUTION FUNCTION
2574 !     XT_MG : MASS OF BIN IN MG
2575 !     JMAX  : NUMBER OF BINS
2578 !.....LOCAL VARIABLES
2580       INTEGER AP,IE,JE,KE
2582       PARAMETER (AP = 1)
2584       INTEGER I,J,K,JDIFF
2585       REAL  RPKIJ(JBREAK,JBREAK,JBREAK),RQKJ(JBREAK,JBREAK)
2588       REAL PI,D0,HLP
2589       DOUBLE PRECISION M(0:JBREAK),ALM
2590       REAL DBREAK(JBREAK),GAIN,LOSS
2591 !     REAL ECOALMASS
2592 !     REAL XL(JMAX)
2595 !.....DECLARATIONS FOR INIT
2597       INTEGER IP,KP,JP,KQ,JQ
2598       REAL XTJ
2600       CHARACTER*20 FILENAME_P,FILENAME_Q
2602       FILENAME_P = 'coeff_p.asc'
2603       FILENAME_Q = 'coeff_q.asc'
2605       IE = JBREAK
2606       JE = JBREAK
2607       KE = JBREAK
2608       PI    = 3.1415927
2609       D0    = 0.0101593
2610       M(1)  = PI/6.0 * D0**3
2612 !.....IN CGS
2615 !.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID
2617       JDIFF = JMAX - JBREAK
2619 !.....INITIALIZATION
2621 !     IF (FIRSTCALL.NE.1) THEN
2623 !........CALCULATING THE BREAKUP GRID
2624 !        ALM  = 2.**(1./FLOAT(AP))
2625          ALM  = 2.d0
2626          M(0)  = M(1)/ALM
2627          DO K=1,KE-1
2628             M(K+1) = M(K)*ALM
2629          ENDDO
2630          DO K=1,KE
2631             BRKWEIGHT(K) = 2./(M(K)**2 - M(K-1)**2)
2632 !           print*,'m(k) = ',m(k)
2633 !           print*,'m(k-1) = ',m(k-1)
2634 !           print*, 'MWEIGHT = ',BRKWEIGHT(K)
2635          ENDDO
2637 !........OUTPUT
2639          WRITE (*,*) 'COLL_BREAKUP_INI: COAGULATION AND BREAKUP GRID'
2640          WRITE (*,'(2A5,5A15)') 'ICOAG','IBREAK', &
2641      &        'XCOAG','DCOAG', &
2642      &        'XBREAK','DBREAK','MWEIGHT'
2644 !........READ DER BREAKUP COEFFICIENTS FROM INPUT FILE
2646 !        WRITE (*,*) 'COLL_BREAKUP: READ THE BREAKUP COEFFS'
2647 !        WRITE (*,*) '              FILE PKIJ: ', FILENAME_P
2648         IF ( wrf_dm_on_monitor() ) THEN
2649           DO i = 31,99
2650             INQUIRE ( i , OPENED = opened )
2651             IF ( .NOT. opened ) THEN
2652               hujisbm_unit1 = i
2653               GOTO 2061
2654             ENDIF
2655           ENDDO
2656           hujisbm_unit1 = -1
2657  2061     CONTINUE
2658         ENDIF
2660         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2662         IF ( hujisbm_unit1 < 0 ) THEN
2663           CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
2664         ENDIF
2666         IF ( wrf_dm_on_monitor() ) THEN
2667           OPEN(UNIT=hujisbm_unit1,FILE="coeff_p.asc",                  &
2668      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2670 !         print*,'here at 3'
2671          DO K=1,KE
2672             DO I=1,IE
2673                DO J=1,I
2674                   READ(hujisbm_unit1,'(3I6,1E16.8)') KP,IP,JP,PKIJ(KP,IP,JP)
2675 !                 WRITE(6,*)'PKIJ(KP,IP,JP) =', &
2676 !    &               KP,IP,JP,PKIJ(KP,IP,JP)
2677 !                 IF(RPKIJ(KP,IP,JP).EQ.0) THEN
2678 !    *             PKIJ(KP,IP,JP)=INT(RPKIJ(KP,IP,JP))
2679 !                 ELSE
2680 !                  PKIJ(KP,IP,JP)=RPKIJ(KP,IP,JP)
2681 !                 END IF
2682 !                 WRITE(6,*)'RPKIJ(KP,IP,JP) =',
2683 !    *               KP,IP,JP,RPKIJ(KP,IP,JP),
2684 !    *               PKIJ(KP,IP,JP)
2685                ENDDO
2686             ENDDO
2687 !           READ(6,*)
2688          ENDDO
2689         CLOSE(hujisbm_unit1)
2690 !        WRITE (*,*) '              FILE QKJ:  ', FILENAME_Q
2691         END IF
2692         CALL wrf_dm_bcast_bytes (PKIJ  , size ( PKIJ ) * DWORDSIZE )
2693         IF ( wrf_dm_on_monitor() ) THEN
2694           DO i = 31,99
2695             INQUIRE ( i , OPENED = opened )
2696             IF ( .NOT. opened ) THEN
2697               hujisbm_unit1 = i
2698               GOTO 2062
2699             ENDIF
2700           ENDDO
2701           hujisbm_unit1 = -1
2702  2062     CONTINUE
2703         ENDIF
2705         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2707         IF ( hujisbm_unit1 < 0 ) THEN
2708           CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
2709         ENDIF
2711         IF ( wrf_dm_on_monitor() ) THEN
2712           OPEN(UNIT=hujisbm_unit1,FILE="coeff_q.asc",                  &
2713      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2715          DO K=1,KE
2716             DO J=1,JE
2717                READ(hujisbm_unit1,'(2I6,1E16.8)') KQ,JQ,QKJ(KQ,JQ)
2718 !              WRITE(6,*) KQ,JQ,QKJ(KQ,JQ)
2719 !              QKJ(KQ,JQ) = RQKJ(KQ,JQ)
2720 !              IF(QKJ(KQ,JQ).LE.1E-35)QKJ(KQ,JQ)=0.D0
2721             ENDDO
2722          ENDDO
2723          CLOSE(hujisbm_unit1)
2725          WRITE (*,*) 'COLL_BREAKUP READ: ... OK'
2726          END IF
2727         CALL wrf_dm_bcast_bytes (QKJ  , size ( QKJ ) * DWORDSIZE )
2728 !     ENDIF
2729 !        DO K=1,KE
2730 !           DO J=1,JE
2731 !              WRITE(6,*) 'After Broadcast, QKJ = ',K,J,QKJ(K,J)
2732 !           ENDDO
2733 !        ENDDO
2734 !        DO K=1,KE
2735 !           DO I=1,IE
2736 !              DO J=1,I
2737 !                 WRITE(6,*)'After Broadcast PKIJ(K,I,J) =', &
2738 !    &               K,I,J,PKIJ(K,I,J)
2739 !              ENDDO
2740 !           ENDDO
2741 !        ENDDO
2742       DO I=1,JMAX
2743          DO J=1,JMAX
2744               ECOALMASSM(I,J)=1.0D0
2745          ENDDO
2746       ENDDO
2748       DO I=1,JMAX
2749          DO J=1,JMAX
2750            ECOALMASSM(I,J)=ECOALMASS(XL(I),XL(J))
2751          ENDDO
2752       ENDDO
2753       RETURN
2754 2070  continue
2755       WRITE( errmess , '(A,I4)' )                                        &
2756        'module_mp_full: error opening hujisbm_DATA on unit '          &
2757      &, hujisbm_unit1
2758       CALL wrf_error_fatal(errmess)
2759       END SUBROUTINE BREAKINIT
2761       REAL FUNCTION ECOALMASS(ETA,KSI)
2762       IMPLICIT NONE
2763 !     REAL ECOALMASS
2764       REAL PI
2765       PARAMETER (PI = 3.1415927)
2767       REAL ETA,KSI
2768       REAL KPI,RHO
2769       REAL DETA,DKSI
2771       PARAMETER (RHO  = 1.0)
2773 !     REAL ECOALDIAM
2774 !     EXTERNAL ECOALDIAM
2776       KPI = 6./PI
2778       DETA = (KPI*ETA/RHO)**(1./3.)
2779       DKSI = (KPI*KSI/RHO)**(1./3.)
2781       ECOALMASS = ECOALDIAM(DETA,DKSI)
2783       RETURN
2784       END FUNCTION ECOALMASS
2787 !------------------------------------------------
2788 !     COALESCENCE EFFICIENCY AS FUNC OF DIAMETERS
2789 !------------------------------------------------
2791       REAL FUNCTION ECOALDIAM(DETA,DKSI)
2792 !     IMPLICIT NONE
2794       INTEGER N
2795       REAL DETA,DKSI
2796       REAL DGR,DKL,RGR,RKL,P,Q,E,X,Y,QMIN,QMAX
2797       REAL ZERO,ONE,EPS,PI
2799       PARAMETER (ZERO = 0.0)
2800       PARAMETER (ONE  = 1.0)
2801       PARAMETER (EPS  = 1.0E-30)
2802       PARAMETER (PI   = 3.1415927)
2804 !     REAL   ECOALLOWLIST,ECOALOCHS
2805 !     EXTERNAL ECOALLOWLIST,ECOALOCHS
2807       DGR = MAX(DETA,DKSI)
2808       DKL = MIN(DETA,DKSI)
2810       RGR = 0.5*DGR
2811       RKL = 0.5*DKL
2813       P = (RKL / RGR)
2814       Q = (RKL * RGR)**0.5
2815       Q = 0.5 * (RKL + RGR)
2817       qmin = 250e-4
2818       qmax = 400e-4        
2819       if (q.lt.qmin) then
2820          e = max(ecoalOchs(Dgr,Dkl),ecoalBeard(Dgr,Dkl)) 
2821       elseif (q.ge.qmin.and.q.lt.qmax) then
2822          x = (q - qmin) / (qmax - qmin)
2823          e = sin(pi/2.0*x)**2 * ecoalLowList(Dgr,Dkl) &
2824      &     + sin(pi/2.0*(1 - x))**2 * ecoalOchs(Dgr,Dkl)
2825       elseif (q.ge.qmax) then
2826          e = ecoalLowList(Dgr,Dkl)
2827       else
2828          e  = 1.0
2829       endif
2831       ECOALDIAM  = MAX(MIN(ONE,E),EPS)
2833       RETURN
2834       END FUNCTION  ECOALDIAM
2836 !--------------------------------------------------
2837 !     COALESCENCE EFFICIENCY (LOW&LIST)
2838 !--------------------------------------------------
2840       REAL FUNCTION ECOALLOWLIST(DGR,DKL)
2841       IMPLICIT NONE
2842 !     REAL ecoallowlist
2843       REAL PI,SIGMA,KA,KB,EPSI
2844       REAL DGR,DKL,RGR,RKL,X
2845       REAL ST,SC,ET,DSTSC,CKE,W1,W2,DC,ECL
2846       REAL QQ0,QQ1,QQ2
2848       PARAMETER (EPSI=1.E-20)
2850       PI = 3.1415927
2851       SIGMA = 72.8
2852       KA = 0.778
2853       KB = 2.61E-4
2855       RGR = 0.5*DGR
2856       RKL = 0.5*DKL
2858       CALL COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC)
2860       DSTSC = ST-SC
2861       ET = CKE+DSTSC
2862       IF (ET .LT. 50.0) THEN
2863          QQ0=1.0+(DKL/DGR)
2864          QQ1=KA/QQ0**2
2865          QQ2=KB*SIGMA*(ET**2)/(SC+EPSI)
2866          ECL=QQ1*EXP(-QQ2)
2867       ELSE
2868          ECL=0.0
2869       ENDIF
2871       ECOALLOWLIST = ECL
2873       RETURN
2874       END FUNCTION ECOALLOWLIST
2876 !--------------------------------------------------
2877 !     COALESCENCE EFFICIENCY (BEARD AND OCHS)
2878 !--------------------------------------------------
2880       REAL FUNCTION ECOALOCHS(D_L,D_S)
2881       IMPLICIT NONE
2882 !     real ecoalochs
2883       REAL D_L,D_S
2884       REAL PI,SIGMA,N_W,R_S,R_L,DV,P,G,X,E
2885 !      REAL VTBEARD,EPSF,FPMIN
2886       REAL EPSF,FPMIN
2888 !     EXTERNAL VTBEARD
2889       PARAMETER (EPSF  = 1.E-30)
2890       PARAMETER (FPMIN = 1.E-30)
2892       PI = 3.1415927
2893       SIGMA = 72.8
2895       R_S = 0.5 * D_S
2896       R_L = 0.5 * D_L
2897       P   = R_S / R_L
2899       DV  = ABS(VTBEARD(D_L) - VTBEARD(D_S))
2900       IF (DV.LT.FPMIN) DV = FPMIN
2901       N_W = R_S * DV**2 / SIGMA
2902       G   = 2**(3./2.)/(6.*PI) * P**4 * (1.+ P) / ((1.+P**2)*(1.+P**3))
2903       X   = N_W**(0.5) * G
2904       E   = 0.767 - 10.14 * X
2906       ECOALOCHS = E
2908       RETURN
2909       END FUNCTION ECOALOCHS
2911 !-----------------------------------------
2912 !     CALCULATING THE COLLISION ENERGY
2913 !-----------------------------------------
2915       SUBROUTINE COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC)
2916 !     IMPLICIT NONE
2918       REAL DGR,DKL,DC
2919       REAL K10,PI,SIGMA,RHO
2920       REAL CKE,W1,W2,ST,SC
2921       REAL DGKA3,DGKB3,DGKA2
2922       REAL V1,V2,DV
2923 !     REAL VTBEARD,EPSF,FPMIN
2924       REAL EPSF,FPMIN
2926 !     EXTERNAL VTBEARD
2927       PARAMETER (EPSF  = 1.E-30)
2928       PARAMETER (FPMIN = 1.E-30)
2930       PI    = 3.1415927
2931       RHO   = 1.0
2932       SIGMA = 72.8
2934       K10=RHO*PI/12.0D0
2936       DGR = MAX(DGR,EPSF)
2937       DKL = MAX(DKL,EPSF)
2939       DGKA2=(DGR**2)+(DKL**2)
2941       DGKA3=(DGR**3)+(DKL**3)
2943       IF (DGR.NE.DKL) THEN
2944          V1 = VTBEARD(DGR)
2945          V2 = VTBEARD(DKL)
2946          DV = (V1-V2)
2947          IF (DV.LT.FPMIN) DV = FPMIN
2948          DV = DV**2
2949          IF (DV.LT.FPMIN) DV = FPMIN
2950          DGKB3=(DGR**3)*(DKL**3)
2951          CKE = K10 * DV * DGKB3/DGKA3
2952       ELSE
2953          CKE = 0.0D0
2954       ENDIF
2955       ST = PI*SIGMA*DGKA2
2956       SC = PI*SIGMA*DGKA3**(2./3.)
2958       W1=CKE/(SC+EPSF)
2959       W2=CKE/(ST+EPSF)
2961       DC=DGKA3**(1./3.)
2963       RETURN
2964       END SUBROUTINE COLLENERGY
2966 !--------------------------------------------------
2967 !     CALCULATING TERMINAL VELOCITY (BEARD-FORMULA)
2968 !--------------------------------------------------
2970       REAL FUNCTION VTBEARD(DIAM)
2971       IMPLICIT NONE
2972 !     REAL VTBEARD
2974       REAL DIAM,AA
2975       REAL ROP,RU,AMT,PP,RL,TT,ETA,DENS,CD,D,A
2976       REAL ALA,GR,SI,BOND,PART,XX,YY,RE,VT
2977       REAL B00,B11,B22,B33,B44,B55,B0,B1,B2,B3,B4,B5,B6
2978       INTEGER ID
2980       DATA B00,B11,B22,B33,B44,B55,B0,B1,B2,B3,B4,B5,B6/-5.00015, &
2981      &5.23778,-2.04914,.475294,-.0542819,.00238449,-3.18657,.992696, &
2982      &-.153193E-2,-.987059E-3,-.578878E-3,.855176E-4,-.327815E-5/
2984       AA   = DIAM/2.0
2985       ROP  = 1.0
2986       RU   = 8.3144E+7
2987       AMT  = 28.9644
2988       ID   = 10000
2989       PP   = FLOAT(ID)*100.
2990       RL   = RU/AMT
2991       TT   = 283.15
2992       ETA  = (1.718+.0049*(TT-273.15))*1.E-4
2993       DENS = PP/TT/RL
2994       ALA  = 6.6E-6*1.01325E+6/PP*TT/293.15
2995       GR   = 979.69
2996       SI   = 76.1-.155*(TT-273.15)
2998       IF (AA.GT.500.E-4) THEN
2999          BOND = GR*(ROP-DENS)*AA*AA/SI
3000          PART = (SI**3*DENS*DENS/(ETA**4*GR*(ROP-DENS)))**(1./6.)
3001          XX = LOG(16./3.*BOND*PART)
3002          YY = B00+B11*XX+B22*XX*XX+B33*XX**3+B44*XX**4+B55*XX**5
3003          RE = PART*EXP(YY)
3004          VT = ETA*RE/2./DENS/AA
3005       ELSEIF (AA.GT.1.E-3) THEN
3006          CD = 32.*AA*AA*AA*(ROP-DENS)*DENS*GR/3./ETA/ETA
3007          XX = LOG(CD)
3008          RE = EXP(B0+B1*XX+B2*XX*XX+B3*XX**3+B4*XX**4+B5*XX**5+B6*XX**6)
3009          D  = CD/RE/24.-1.
3010          VT = ETA*RE/2./DENS/AA
3011       ELSE
3012          A  = 1.+1.26*ALA/AA
3013          A  = A*2.*AA*AA*GR*(ROP-DENS)/9./ETA
3014          CD = 12*ETA/A/AA/DENS
3015          VT = A
3016       ENDIF
3018       VTBEARD = VT
3020       RETURN
3021       END FUNCTION VTBEARD
3024       
3025 !-------------------------------------------------- 
3026 !     Function f. Coalescence-Efficiency 
3027 !     Eq. (7) of Beard and Ochs (1995)
3028 !--------------------------------------------------      
3030       REAL FUNCTION ecoalBeard(D_l,D_s) 
3031        
3032       IMPLICIT NONE 
3033 !     REAL ecoalBeard
3034 !     REAL ECOALMASS
3035       REAL            D_l,D_s
3036       REAL            R_s,R_l
3037       REAL            rcoeff
3038       REAL epsf
3039       PARAMETER (epsf  = 1.e-30) 
3041       INTEGER its
3042       COMPLEX acoeff(4),x
3044       R_s = 0.5 * D_s
3045       R_l = 0.5 * D_l      
3047       rcoeff = 5.07 - log(R_s*1e4) - log(R_l*1e4/200.0)
3049       acoeff(1) = CMPLX(rcoeff)
3050       acoeff(2) = CMPLX(-5.94)
3051       acoeff(3) = CMPLX(+7.27)
3052       acoeff(4) = CMPLX(-5.29)
3054       x = (0.50,0)
3056       CALL LAGUER(acoeff,3,x,its)
3058       EcoalBeard = REAL(x)
3060       RETURN 
3061       END FUNCTION ecoalBeard 
3063 !--------------------------------------------------       
3065       SUBROUTINE laguer(a,m,x,its)
3066       INTEGER m,its,MAXIT,MR,MT
3067       REAL EPSS
3068       COMPLEX a(m+1),x
3069       PARAMETER (EPSS=2.e-7,MR=8,MT=10,MAXIT=MT*MR)
3070       INTEGER iter,j
3071       REAL abx,abp,abm,err,frac(MR)
3072       COMPLEX dx,x1,b,d,f,g,h,sq,gp,gm,g2
3073       SAVE frac
3074       DATA frac /.5,.25,.75,.13,.38,.62,.88,1./
3075       do 12 iter=1,MAXIT
3076         its=iter
3077         b=a(m+1)
3078         err=abs(b)
3079         d=cmplx(0.,0.)
3080         f=cmplx(0.,0.)
3081         abx=abs(x)
3082         do 11 j=m,1,-1
3083           f=x*f+d
3084           d=x*d+b
3085           b=x*b+a(j)
3086           err=abs(b)+abx*err
3087 11      continue
3088         err=EPSS*err
3089         if(abs(b).le.err) then
3090           return
3091         else
3092           g=d/b
3093           g2=g*g
3094           h=g2-2.*f/b
3095           sq=sqrt((m-1)*(m*h-g2))
3096           gp=g+sq
3097           gm=g-sq
3098           abp=abs(gp)
3099           abm=abs(gm)
3100           if(abp.lt.abm) gp=gm
3101           if (max(abp,abm).gt.0.) then
3102             dx=m/gp
3103           else
3104             dx=exp(cmplx(log(1.+abx),float(iter)))
3105           endif
3106         endif
3107         x1=x-dx
3108         if(x.eq.x1)return
3109         if (mod(iter,MT).ne.0) then
3110           x=x1
3111         else
3112           x=x-dx*frac(iter/MT)
3113         endif
3114 12    continue
3115       pause 'too many iterations in laguer'
3116       return
3117       END SUBROUTINE laguer
3122       subroutine courant_bott
3123       implicit none
3124       integer k,kk,j,i
3125       double precision x0
3126 ! ima(i,j) - k-category number,
3127 ! chucm(i,j)   - courant number :
3128 ! logarithmic grid distance(dlnr) :
3131 !================================================================
3132 ! BARRY     
3133 !     print*,'dlnr in courant_bott = ',dlnr
3134       xl_mg(0)=xl_mg(1)/2
3135 ! BARRY
3136       do i=1,nkr
3137          do j=i,nkr
3138             x0=xl_mg(i)+xl_mg(j)
3139             do k=j,nkr
3140                kk=k
3141 !              if (k.eq.1)then
3142 !                  print*,'xl_mg(k) = ',xl_mg(k)
3143 !                  print*,'x0 = ',x0
3144 ! xl_mg(k) =   3.351000000000000E-008
3145 !  x0 =   6.702000000000000E-008
3146 !                  read (6,*)
3147 !              end if
3148                if(xl_mg(k).ge.x0.and.xl_mg(k-1).lt.x0) then
3149                  chucm(i,j)=dlog(x0/xl_mg(k-1))/(3.d0*dlnr)
3150  102             continue
3151                  if(chucm(i,j).gt.1.-1.d-08) then
3152                    chucm(i,j)=0.
3153                    kk=kk+1
3154                  endif
3155                  ima(i,j)=min(nkr-1,kk-1)
3157                  goto 2000
3158                endif
3159             enddo
3160  2000       continue
3161 !            if(i.eq.nkr.or.j.eq.nkr) ima(i,j)=nkr
3162             chucm(j,i)=chucm(i,j)
3163             ima(j,i)=ima(i,j)
3164          enddo
3165       enddo
3166       return
3167       end subroutine courant_bott
3170       SUBROUTINE KERNALS(DTIME)
3171 ! KHAIN30/07/99
3172       IMPLICIT NONE
3173       INTEGER I,J
3174       REAL PI
3175 !******************************************************************
3176       data pi/3.141592654/
3177 ! dtime - timestep of integration (calculated in main program) :
3178 ! dlnr - logarithmic grid distance
3179 ! ima(i,j) - k-category number, c(i,j) - courant number 
3180 ! cw*(i,j) (in cm**3) - multiply help kernel with constant 
3181 ! timestep(dt) and logarithmic grid distance(dlnr) :
3182         REAL DTIME
3183 ! logarithmic grid distance(dlnr) :
3184 !       dlnr=dlog(2.d0)/(3.d0*scal)
3185 ! scal is micro.prm file parameter(scal=1.d0 for x(k+1)=x(k)*2)
3186 ! calculation of cw*(i,j) (in cm**3) - multiply help kernel 
3187 ! with constant timestep(dtime) and logarithmic grid distance(dlnr) :
3188 !     print*,'dlnr in kernal = ',dlnr,dtime
3189         DO I=1,NKR
3190            DO J=1,NKR
3191               CWLL_1000MB(I,J)=DTIME*DLNR*YWLL_1000MB(I,J)
3192               CWLL_750MB(I,J)=DTIME*DLNR*YWLL_750MB(I,J)
3193               CWLL_500MB(I,J)=DTIME*DLNR*YWLL_500MB(I,J)
3195               CWLL(I,J)=DTIME*DLNR*YWLL(I,J)
3196               CWLG(I,J)=DTIME*DLNR*YWLG(I,J)
3197               CWLH(I,J)=DTIME*DLNR*YWLH(I,J)
3199 ! barry
3200               if (i.le.16.and.j.le.16)then
3201               CWSL(I,J)=0.d0
3202 !             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
3203               CWSL(i,j)=DTIME*DLNR*YWIL(I,J,2)
3204               CWLS(I,J)=0.d0
3205 !             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
3206               CWLS(I,J)=DTIME*DLNR*YWLI(I,J,2)
3207               else
3208               CWSL(I,J)=DTIME*DLNR*YWSL(I,J)
3209               CWLS(I,J)=DTIME*DLNR*YWLS(I,J)
3210               end if
3211               CWSS(I,J)=DTIME*DLNR*YWSS(I,J)
3212               CWSG(I,J)=DTIME*DLNR*YWSG(I,J)
3213               CWSH(I,J)=DTIME*DLNR*YWSH(I,J)
3215               CWGL(I,J)=0.8*DTIME*DLNR*YWGL(I,J)
3216               IF(RADXXO(I,6).LT.2.0D-2) THEN
3217                 IF(RADXXO(J,1).LT.1.0D-3) THEN
3218                   IF(RADXXO(J,1).GE.7.0D-4) THEN
3219                     CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/1.5D0
3220                   ELSE
3221                     CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/3.0D0
3222                   ENDIF
3223                 ENDIF
3224               ENDIF
3225               IF(I.LE.14.AND.J.LE.7) CWGL(I,J)=0.0D0
3226 !             IF(I.LE.17.AND.J.LE.7) CWGL(I,J)=0.0D0
3227 !             IF(I.LE.14.AND.J.LE.14) CWGL(I,J)=0.0D0
3228               CWGS(I,J)=DTIME*DLNR*YWGS(I,J)
3229               CWGG(I,J)=DTIME*DLNR*YWGG(I,J)
3230               CWGH(I,J)=DTIME*DLNR*YWGH(I,J)
3232               CWHL(I,J)=DTIME*DLNR*YWHL(I,J)
3233               CWHS(I,J)=DTIME*DLNR*YWHS(I,J)
3234               CWHG(I,J)=DTIME*DLNR*YWHG(I,J)
3235               CWHH(I,J)=DTIME*DLNR*YWHH(I,J)
3237               CWLI_1(I,J)=DTIME*DLNR*YWLI(I,J,1)
3238               CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
3239               CWLI_3(I,J)=DTIME*DLNR*YWLI(I,J,3)
3240               
3241               CWIL_1(I,J)=DTIME*DLNR*YWIL(I,J,1)
3242               CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
3243               CWIL_3(I,J)=DTIME*DLNR*YWIL(I,J,3)
3245               CWIS_1(I,J)=DTIME*DLNR*YWIS(I,J,1)
3246               CWIS_2(I,J)=DTIME*DLNR*YWIS(I,J,2)
3247               CWIS_3(I,J)=DTIME*DLNR*YWIS(I,J,3)
3249               CWSI_1(I,J)=DTIME*DLNR*YWSI(I,J,1)
3250               CWSI_2(I,J)=DTIME*DLNR*YWSI(I,J,2)
3251               CWSI_3(I,J)=DTIME*DLNR*YWSI(I,J,3)
3253               CWIG_1(I,J)=DTIME*DLNR*YWIG(I,J,1)
3254               CWIG_2(I,J)=DTIME*DLNR*YWIG(I,J,2)
3255               CWIG_3(I,J)=DTIME*DLNR*YWIG(I,J,3)
3257               CWGI_1(I,J)=DTIME*DLNR*YWGI(I,J,1)
3258               CWGI_2(I,J)=DTIME*DLNR*YWGI(I,J,2)
3259               CWGI_3(I,J)=DTIME*DLNR*YWGI(I,J,3)
3261               CWIH_1(I,J)=DTIME*DLNR*YWIH(I,J,1)
3262               CWIH_2(I,J)=DTIME*DLNR*YWIH(I,J,2)
3263               CWIH_3(I,J)=DTIME*DLNR*YWIH(I,J,3)
3265               CWHI_1(I,J)=DTIME*DLNR*YWHI(I,J,1)
3266               CWHI_2(I,J)=DTIME*DLNR*YWHI(I,J,2)
3267               CWHI_3(I,J)=DTIME*DLNR*YWHI(I,J,3)
3268 ! barry
3269               if (i.lt.12.and.j.lt.12)then
3271                CWII_1_1(I,J)=0.D0
3272                CWII_1_2(I,J)=0.D0
3273                CWII_1_3(I,J)=0.D0
3275                CWII_2_1(I,J)=0.D0
3276                CWII_2_2(I,J)=0.D0
3277                CWII_2_3(I,J)=0.D0
3279                CWII_3_1(I,J)=0.D0
3280                CWII_3_2(I,J)=0.D0
3281                CWII_3_3(I,J)=0.D0
3282 !barry
3283               else
3284                CWII_1_1(I,J)=DTIME*DLNR*YWII(I,J,1,1)
3285                CWII_1_2(I,J)=DTIME*DLNR*YWII(I,J,1,2)
3286                CWII_1_3(I,J)=DTIME*DLNR*YWII(I,J,1,3)
3288                CWII_2_1(I,J)=DTIME*DLNR*YWII(I,J,2,1)
3289                CWII_2_2(I,J)=DTIME*DLNR*YWII(I,J,2,2)
3290                CWII_2_3(I,J)=DTIME*DLNR*YWII(I,J,2,3)
3292                CWII_3_1(I,J)=DTIME*DLNR*YWII(I,J,3,1)
3293                CWII_3_2(I,J)=DTIME*DLNR*YWII(I,J,3,2)
3294                CWII_3_3(I,J)=DTIME*DLNR*YWII(I,J,3,3)
3295               end if
3296            ENDDO
3297         ENDDO
3298 !       GO TO 88
3299 ! NEW CHANGES 2.06.01 (BEGIN)
3300         CALL TURBCOEF
3301         DO J=1,7
3302            DO I=15,24-J
3303               CWGL(I,J)=0.0D0
3304            ENDDO
3305         ENDDO
3306 ! NEW CHANGES 2.06.01 (END)
3307 ! NEW CHANGES 3.02.01 (BEGIN)
3308         DO I=1,NKR
3309            DO J=1,NKR
3310               CWLG(J,I)=CWGL(I,J)
3311            ENDDO
3312         ENDDO
3313 !       print*, 'ICETURB = ',ICETURB
3314           DO I=KRMING_GL,KRMAXG_GL
3315              DO J=KRMINL_GL,KRMAXL_GL
3316                IF (ICETURB.EQ.1)THEN
3317                 CWGL(I,J)=CTURBGL(I,J)*CWGL(I,J)
3318                ELSE
3319                 CWGL(I,J)=CWGL(I,J)
3320                END IF
3321              ENDDO
3322           ENDDO
3323           DO I=KRMING_GL,KRMAXG_GL
3324              DO J=KRMINL_GL,KRMAXL_GL
3325                 CWLG(J,I)=CWGL(I,J)
3326              ENDDO
3327           ENDDO
3329 88     CONTINUE
3330         RETURN
3331         END SUBROUTINE KERNALS
3333       SUBROUTINE KERNALS_IN(DTIME)
3334 ! KHAIN30/07/99
3335       IMPLICIT NONE
3336       INTEGER I,J
3337       REAL PI
3338 !******************************************************************
3339       data pi/3.141592654/
3340 ! dtime - timestep of integration (calculated in main program) :
3341 ! dlnr - logarithmic grid distance
3342 ! ima(i,j) - k-category number, c(i,j) - courant number 
3343 ! cw*(i,j) (in cm**3) - multiply help kernel with constant 
3344 ! timestep(dt) and logarithmic grid distance(dlnr) :
3345         REAL DTIME
3346 ! logarithmic grid distance(dlnr) :
3347 !       dlnr=dlog(2.d0)/(3.d0*scal)
3348 ! scal is micro.prm file parameter(scal=1.d0 for x(k+1)=x(k)*2)
3349 ! calculation of cw*(i,j) (in cm**3) - multiply help kernel 
3350 ! with constant timestep(dtime) and logarithmic grid distance(dlnr) :
3351 !     print*,'dlnr in kernal = ',dlnr,dtime
3352         DO I=1,NKR
3353            DO J=1,NKR
3354               CWLL_1000MB(I,J)=DTIME*DLNR*YWLL_1000MB(I,J)
3355               CWLL_750MB(I,J)=DTIME*DLNR*YWLL_750MB(I,J)
3356               CWLL_500MB(I,J)=DTIME*DLNR*YWLL_500MB(I,J)
3358               CWLL(I,J)=DTIME*DLNR*YWLL(I,J)
3359               CWLG(I,J)=DTIME*DLNR*YWLG(I,J)
3360 !             CWLH(I,J)=DTIME*DLNR*YWLH(I,J)
3362 ! barry
3363               if (i.le.16.and.j.le.16)then
3364               CWSL(I,J)=0.d0
3365 !             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
3366               CWSL(i,j)=DTIME*DLNR*YWIL(I,J,2)
3367               CWLS(I,J)=0.d0
3368 !             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
3369               CWLS(I,J)=DTIME*DLNR*YWLI(I,J,2)
3370               else
3371               CWSL(I,J)=DTIME*DLNR*YWSL(I,J)
3372               CWLS(I,J)=DTIME*DLNR*YWLS(I,J)
3373               end if
3374               CWSS(I,J)=DTIME*DLNR*YWSS(I,J)
3375               CWSG(I,J)=DTIME*DLNR*YWSG(I,J)
3376 !             CWSH(I,J)=DTIME*DLNR*YWSH(I,J)
3378               CWGL(I,J)=0.8*DTIME*DLNR*YWGL(I,J)
3379               IF(RADXXO(I,6).LT.2.0D-2) THEN
3380                 IF(RADXXO(J,1).LT.1.0D-3) THEN
3381                   IF(RADXXO(J,1).GE.7.0D-4) THEN
3382                     CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/1.5D0
3383                   ELSE
3384                     CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/3.0D0
3385                   ENDIF
3386                 ENDIF
3387               ENDIF
3388               IF(I.LE.14.AND.J.LE.7) CWGL(I,J)=0.0D0
3389 !             IF(I.LE.17.AND.J.LE.7) CWGL(I,J)=0.0D0
3390 !             IF(I.LE.14.AND.J.LE.14) CWGL(I,J)=0.0D0
3391               CWGS(I,J)=DTIME*DLNR*YWGS(I,J)
3392               CWGG(I,J)=DTIME*DLNR*YWGG(I,J)
3393 !             CWGH(I,J)=DTIME*DLNR*YWGH(I,J)
3395 !             CWHL(I,J)=DTIME*DLNR*YWHL(I,J)
3396 !             CWHS(I,J)=DTIME*DLNR*YWHS(I,J)
3397 !             CWHG(I,J)=DTIME*DLNR*YWHG(I,J)
3398 !             CWHH(I,J)=DTIME*DLNR*YWHH(I,J)
3400 !             CWLI_1(I,J)=DTIME*DLNR*YWLI(I,J,1)
3401 !             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
3402 !             CWLI_3(I,J)=DTIME*DLNR*YWLI(I,J,3)
3403               
3404 !             CWIL_1(I,J)=DTIME*DLNR*YWIL(I,J,1)
3405 !             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
3406 !             CWIL_3(I,J)=DTIME*DLNR*YWIL(I,J,3)
3408 !             CWIS_1(I,J)=DTIME*DLNR*YWIS(I,J,1)
3409 !             CWIS_2(I,J)=DTIME*DLNR*YWIS(I,J,2)
3410 !             CWIS_3(I,J)=DTIME*DLNR*YWIS(I,J,3)
3412 !             CWSI_1(I,J)=DTIME*DLNR*YWSI(I,J,1)
3413 !             CWSI_2(I,J)=DTIME*DLNR*YWSI(I,J,2)
3414 !             CWSI_3(I,J)=DTIME*DLNR*YWSI(I,J,3)
3416 !             CWIG_1(I,J)=DTIME*DLNR*YWIG(I,J,1)
3417 !             CWIG_2(I,J)=DTIME*DLNR*YWIG(I,J,2)
3418 !             CWIG_3(I,J)=DTIME*DLNR*YWIG(I,J,3)
3420 !             CWGI_1(I,J)=DTIME*DLNR*YWGI(I,J,1)
3421 !             CWGI_2(I,J)=DTIME*DLNR*YWGI(I,J,2)
3422 !             CWGI_3(I,J)=DTIME*DLNR*YWGI(I,J,3)
3424 !             CWIH_1(I,J)=DTIME*DLNR*YWIH(I,J,1)
3425 !             CWIH_2(I,J)=DTIME*DLNR*YWIH(I,J,2)
3426 !             CWIH_3(I,J)=DTIME*DLNR*YWIH(I,J,3)
3428 !             CWHI_1(I,J)=DTIME*DLNR*YWHI(I,J,1)
3429 !             CWHI_2(I,J)=DTIME*DLNR*YWHI(I,J,2)
3430 !             CWHI_3(I,J)=DTIME*DLNR*YWHI(I,J,3)
3431 ! barry
3432               if (i.lt.12.and.j.lt.12)then
3434 !              CWII_1_1(I,J)=0.D0
3435 !              CWII_1_2(I,J)=0.D0
3436 !              CWII_1_3(I,J)=0.D0
3438 !              CWII_2_1(I,J)=0.D0
3439 !              CWII_2_2(I,J)=0.D0
3440 !              CWII_2_3(I,J)=0.D0
3442 !              CWII_3_1(I,J)=0.D0
3443 !              CWII_3_2(I,J)=0.D0
3444 !              CWII_3_3(I,J)=0.D0
3445 !barry
3446               else
3447 !              CWII_1_1(I,J)=DTIME*DLNR*YWII(I,J,1,1)
3448 !              CWII_1_2(I,J)=DTIME*DLNR*YWII(I,J,1,2)
3449 !              CWII_1_3(I,J)=DTIME*DLNR*YWII(I,J,1,3)
3451 !              CWII_2_1(I,J)=DTIME*DLNR*YWII(I,J,2,1)
3452 !              CWII_2_2(I,J)=DTIME*DLNR*YWII(I,J,2,2)
3453 !              CWII_2_3(I,J)=DTIME*DLNR*YWII(I,J,2,3)
3455 !              CWII_3_1(I,J)=DTIME*DLNR*YWII(I,J,3,1)
3456 !              CWII_3_2(I,J)=DTIME*DLNR*YWII(I,J,3,2)
3457 !              CWII_3_3(I,J)=DTIME*DLNR*YWII(I,J,3,3)
3458               end if
3459            ENDDO
3460         ENDDO
3461 !       GO TO 88
3462 ! NEW CHANGES 2.06.01 (BEGIN)
3463         CALL TURBCOEF
3464         DO J=1,7
3465            DO I=15,24-J
3466               CWGL(I,J)=0.0D0
3467            ENDDO
3468         ENDDO
3469 ! NEW CHANGES 2.06.01 (END)
3470 ! NEW CHANGES 3.02.01 (BEGIN)
3471         DO I=1,NKR
3472            DO J=1,NKR
3473               CWLG(J,I)=CWGL(I,J)
3474            ENDDO
3475         ENDDO
3476 !       print*, 'ICETURB = ',ICETURB
3477           DO I=KRMING_GL,KRMAXG_GL
3478              DO J=KRMINL_GL,KRMAXL_GL
3479                IF (ICETURB.EQ.1)THEN
3480                 CWGL(I,J)=CTURBGL(I,J)*CWGL(I,J)
3481                ELSE
3482                 CWGL(I,J)=CWGL(I,J)
3483                END IF
3484              ENDDO
3485           ENDDO
3486           DO I=KRMING_GL,KRMAXG_GL
3487              DO J=KRMINL_GL,KRMAXL_GL
3488                 CWLG(J,I)=CWGL(I,J)
3489              ENDDO
3490           ENDDO
3492 88     CONTINUE
3493         RETURN
3494         END SUBROUTINE KERNALS_IN
3495         SUBROUTINE TURBCOEF
3496         IMPLICIT NONE
3497         INTEGER I,J
3498 !       DOUBLE PRECISION X_KERN,Y_KERN,F
3499         DOUBLE PRECISION X_KERN,Y_KERN
3500         DOUBLE PRECISION RL_LL(K0_LL),RL_GL(K0L_GL),RG_GL(K0G_GL)
3501           RL_LL(1)=RADXXO(KRMIN_LL,1)*1.E4
3502           RL_LL(2)=10.0D0
3503           RL_LL(3)=20.0D0
3504           RL_LL(4)=30.0D0
3505           RL_LL(5)=40.0D0
3506           RL_LL(6)=50.0D0
3507           RL_LL(7)=60.0D0
3508           RL_LL(8)=RADXXO(KRMAX_LL,1)*1.E4
3509           DO J=1,K0_LL
3510              DO I=1,K0_LL
3511                 CTURB_LL(I,J)=1.0D0
3512              ENDDO
3513           ENDDO 
3514           CTURB_LL(1,1)=4.50D0
3515           CTURB_LL(1,2)=4.50D0
3516           CTURB_LL(1,3)=3.00D0
3517           CTURB_LL(1,4)=2.25D0
3518           CTURB_LL(1,5)=1.95D0
3519           CTURB_LL(1,6)=1.40D0
3520           CTURB_LL(1,7)=1.40D0
3521           CTURB_LL(1,8)=1.40D0
3523           CTURB_LL(2,1)=4.50D0
3524           CTURB_LL(2,2)=4.50D0
3525           CTURB_LL(2,3)=3.00D0
3526           CTURB_LL(2,4)=2.25D0
3527           CTURB_LL(2,5)=1.95D0
3528           CTURB_LL(2,6)=1.40D0
3529           CTURB_LL(2,7)=1.40D0
3530           CTURB_LL(2,8)=1.40D0
3532           CTURB_LL(3,1)=3.00D0
3533           CTURB_LL(3,2)=3.00D0
3534           CTURB_LL(3,3)=2.70D0
3535           CTURB_LL(3,4)=2.25D0
3536           CTURB_LL(3,5)=1.65D0
3537           CTURB_LL(3,6)=1.40D0
3538           CTURB_LL(3,7)=1.40D0
3539           CTURB_LL(3,8)=1.40D0
3541           CTURB_LL(4,1)=2.25D0
3542           CTURB_LL(4,2)=2.25D0
3543           CTURB_LL(4,3)=2.25D0
3544           CTURB_LL(4,4)=1.95D0
3545           CTURB_LL(4,5)=1.65D0
3546           CTURB_LL(4,6)=1.40D0
3547           CTURB_LL(4,7)=1.40D0
3548           CTURB_LL(4,8)=1.40D0
3550           CTURB_LL(5,1)=1.95D0
3551           CTURB_LL(5,2)=1.95D0
3552           CTURB_LL(5,3)=1.65D0
3553           CTURB_LL(5,4)=1.65D0
3554           CTURB_LL(5,5)=1.65D0
3555           CTURB_LL(5,6)=1.40D0
3556           CTURB_LL(5,7)=1.40D0
3557           CTURB_LL(5,8)=1.40D0
3559           CTURB_LL(6,1)=1.40D0
3560           CTURB_LL(6,2)=1.40D0
3561           CTURB_LL(6,3)=1.40D0
3562           CTURB_LL(6,4)=1.40D0
3563           CTURB_LL(6,5)=1.40D0
3564           CTURB_LL(6,6)=1.40D0
3565           CTURB_LL(6,7)=1.40D0
3566           CTURB_LL(6,8)=1.40D0
3568           CTURB_LL(7,1)=1.40D0
3569           CTURB_LL(7,2)=1.40D0
3570           CTURB_LL(7,3)=1.40D0
3571           CTURB_LL(7,4)=1.40D0
3572           CTURB_LL(7,5)=1.40D0
3573           CTURB_LL(7,6)=1.40D0
3574           CTURB_LL(7,7)=1.40D0
3575           CTURB_LL(7,8)=1.40D0
3577           CTURB_LL(8,1)=1.40D0
3578           CTURB_LL(8,2)=1.40D0
3579           CTURB_LL(8,3)=1.40D0
3580           CTURB_LL(8,4)=1.40D0
3581           CTURB_LL(8,5)=1.40D0
3582           CTURB_LL(8,6)=1.40D0
3583           CTURB_LL(8,7)=1.40D0
3584           CTURB_LL(8,8)=1.40D0
3585           DO J=1,K0_LL
3586              DO I=1,K0_LL
3587                 CTURB_LL(I,J)=(CTURB_LL(I,J)-1.0D0)/1.5D0+1.0D0
3588              ENDDO
3589           ENDDO
3590           DO I=KRMIN_LL,KRMAX_LL
3591              DO J=KRMIN_LL,KRMAX_LL
3592                 CTURBLL(I,J)=1.0D0
3593              ENDDO
3594           ENDDO
3595           DO I=KRMIN_LL,KRMAX_LL
3596              X_KERN=RADXXO(I,1)*1.0D4
3597              IF(X_KERN.LT.RL_LL(1)) X_KERN=RL_LL(1)
3598              IF(X_KERN.GT.RL_LL(K0_LL)) X_KERN=RL_LL(K0_LL) 
3599              DO J=KRMIN_LL,KRMAX_LL
3600                 Y_KERN=RADXXO(J,1)*1.0D4
3601                 IF(Y_KERN.LT.RL_LL(1)) Y_KERN=RL_LL(1)
3602                 IF(Y_KERN.GT.RL_LL(K0_LL)) Y_KERN=RL_LL(K0_LL)
3603                 CTURBLL(I,J)=F(X_KERN,Y_KERN,RL_LL,RL_LL,CTURB_LL &
3604      &                      ,K0_LL,K0_LL)                                
3605              ENDDO
3606           ENDDO
3607           RL_GL(1) = RADXXO(1,1)*1.E4 
3608           RL_GL(2) = 8.0D0
3609           RL_GL(3) = 10.0D0
3610           RL_GL(4) = 16.0D0
3611           RL_GL(5) = 20.0D0
3612           RL_GL(6) = 30.0D0
3613           RL_GL(7) = 40.0D0
3614           RL_GL(8) = 50.0D0
3615           RL_GL(9) = 60.0D0
3616           RL_GL(10)= 70.0D0
3617           RL_GL(11)= 80.0D0
3618           RL_GL(12)= 90.0D0
3619           RL_GL(13)=100.0D0
3620           RL_GL(14)=200.0D0
3621           RL_GL(15)=300.0D0
3622           RL_GL(16)=RADXXO(24,1)*1.0D4
3623 ! TURBULENCE GRAUPEL BULK RADII IN MKM
3624           RG_GL(1) = RADXXO(1,6)*1.0D4 
3625           RG_GL(2) = 30.0D0  
3626           RG_GL(3) = 60.0D0 
3627           RG_GL(4) = 100.0D0 
3628           RG_GL(5) = 200.0D0 
3629           RG_GL(6) = 300.0D0
3630           RG_GL(7) = 400.0D0
3631           RG_GL(8) = 500.0D0
3632           RG_GL(9) = 600.0D0
3633           RG_GL(10)= 700.0D0
3634           RG_GL(11)= 800.0D0
3635           RG_GL(12)= 900.0D0
3636           RG_GL(13)=1000.0D0
3637           RG_GL(14)=2000.0D0
3638           RG_GL(15)=3000.0D0
3639           RG_GL(16)=RADXXO(33,6)*1.0D4
3640           DO I=KRMING_GL,KRMAXG_GL
3641              DO J=KRMINL_GL,KRMAXL_GL
3642                 CTURBGL(I,J)=1.0D0
3643              ENDDO
3644           ENDDO
3645           DO I=1,K0G_GL
3646              DO J=1,K0L_GL
3647                 CTURB_GL(I,J)=1.0D0
3648              ENDDO
3649           ENDDO 
3650           IF(IEPS_400.EQ.1) THEN
3651             CTURB_GL(1,1)=0.0D0
3652             CTURB_GL(1,2)=0.0D0
3653             CTURB_GL(1,3)=1.2D0
3654             CTURB_GL(1,4)=1.3D0
3655             CTURB_GL(1,5)=1.4D0
3656             CTURB_GL(1,6)=1.5D0
3657             CTURB_GL(1,7)=1.5D0
3658             CTURB_GL(1,8)=1.5D0
3659             CTURB_GL(1,9)=1.5D0
3660             CTURB_GL(1,10)=1.5D0
3661             CTURB_GL(1,11)=1.5D0
3662             CTURB_GL(1,12)=1.0D0
3663             CTURB_GL(1,13)=1.0D0
3664             CTURB_GL(1,14)=1.0D0
3665             CTURB_GL(1,15)=1.0D0
3666         
3667             CTURB_GL(2,1)=1.0D0
3668             CTURB_GL(2,2)=1.4D0
3669             CTURB_GL(2,3)=1.8D0
3670             CTURB_GL(2,4)=2.2D0
3671             CTURB_GL(2,5)=2.6D0
3672             CTURB_GL(2,6)=3.0D0
3673             CTURB_GL(2,7)=2.85D0
3674             CTURB_GL(2,8)=2.7D0
3675             CTURB_GL(2,9)=2.55D0
3676             CTURB_GL(2,10)=2.4D0
3677             CTURB_GL(2,11)=2.25D0
3678             CTURB_GL(2,12)=1.0D0
3679             CTURB_GL(2,13)=1.0D0
3680             CTURB_GL(2,14)=1.0D0
3682             CTURB_GL(3,1)=7.5D0
3683             CTURB_GL(3,2)=7.5D0
3684             CTURB_GL(3,3)=4.5D0 
3685             CTURB_GL(3,4)=4.5D0 
3686             CTURB_GL(3,5)=4.65D0        
3687             CTURB_GL(3,6)=4.65D0        
3688             CTURB_GL(3,7)=4.5D0 
3689             CTURB_GL(3,8)=4.5D0 
3690             CTURB_GL(3,9)=4.0D0 
3691             CTURB_GL(3,10)=3.0D0        
3692             CTURB_GL(3,11)=2.0D0        
3693             CTURB_GL(3,12)=1.5D0        
3694             CTURB_GL(3,13)=1.3D0        
3695             CTURB_GL(3,14)=1.0D0        
3696     
3697             CTURB_GL(4,1)=5.5D0
3698             CTURB_GL(4,2)=5.5D0
3699             CTURB_GL(4,3)=4.5D0
3700             CTURB_GL(4,4)=4.5D0
3701             CTURB_GL(4,5)=4.65D0
3702             CTURB_GL(4,6)=4.65D0
3703             CTURB_GL(4,7)=4.5D0
3704             CTURB_GL(4,8)=4.5D0
3705             CTURB_GL(4,9)=4.0D0
3706             CTURB_GL(4,10)=3.0D0
3707             CTURB_GL(4,11)=2.0D0
3708             CTURB_GL(4,12)=1.5D0
3709             CTURB_GL(4,13)=1.35D0
3710             CTURB_GL(4,14)=1.0D0
3711          
3712             CTURB_GL(5,1)=4.5D0
3713             CTURB_GL(5,2)=4.5D0
3714             CTURB_GL(5,3)=3.3D0 
3715             CTURB_GL(5,4)=3.3D0 
3716             CTURB_GL(5,5)=3.3D0 
3717             CTURB_GL(5,6)=3.4D0 
3718             CTURB_GL(5,7)=3.8D0 
3719             CTURB_GL(5,8)=3.8D0 
3720             CTURB_GL(5,9)=3.8D0 
3721             CTURB_GL(5,10)=3.6D0
3722             CTURB_GL(5,11)=2.5D0        
3723             CTURB_GL(5,12)=2.0D0        
3724             CTURB_GL(5,13)=1.4D0        
3725             CTURB_GL(5,14)=1.0D0        
3726                                         
3727             CTURB_GL(6,1)=4.0D0
3728             CTURB_GL(6,2)=4.0D0
3729             CTURB_GL(6,3)=2.8D0
3730             CTURB_GL(6,4)=2.8D0
3731             CTURB_GL(6,5)=2.85D0
3732             CTURB_GL(6,6)=2.9D0
3733             CTURB_GL(6,7)=3.0D0
3734             CTURB_GL(6,8)=3.1D0
3735             CTURB_GL(6,9)=2.9D0
3736             CTURB_GL(6,10)=2.6D0
3737             CTURB_GL(6,11)=2.5D0
3738             CTURB_GL(6,12)=2.0D0
3739             CTURB_GL(6,13)=1.3D0
3740             CTURB_GL(6,14)=1.1D0
3742             CTURB_GL(7,1)=3.5D0
3743             CTURB_GL(7,2)=3.5D0
3744             CTURB_GL(7,3)=2.5D0
3745             CTURB_GL(7,4)=2.5D0
3746             CTURB_GL(7,5)=2.6D0
3747             CTURB_GL(7,6)=2.7D0
3748             CTURB_GL(7,7)=2.8D0
3749             CTURB_GL(7,8)=2.8D0
3750             CTURB_GL(7,9)=2.8D0
3751             CTURB_GL(7,10)=2.6D0
3752             CTURB_GL(7,11)=2.3D0
3753             CTURB_GL(7,12)=2.0D0
3754             CTURB_GL(7,13)=1.3D0
3755             CTURB_GL(7,14)=1.1D0
3757             CTURB_GL(8,1)=3.25D0
3758             CTURB_GL(8,2)=3.25D0
3759             CTURB_GL(8,3)=2.3D0
3760             CTURB_GL(8,4)=2.3D0
3761             CTURB_GL(8,5)=2.35D0
3762             CTURB_GL(8,6)=2.37D0
3763             CTURB_GL(8,7)=2.55D0
3764             CTURB_GL(8,8)=2.55D0
3765             CTURB_GL(8,9)=2.55D0
3766             CTURB_GL(8,10)=2.3D0
3767             CTURB_GL(8,11)=2.1D0
3768             CTURB_GL(8,12)=1.9D0
3769             CTURB_GL(8,13)=1.3D0
3770             CTURB_GL(8,14)=1.1D0
3772             CTURB_GL(9,1)=3.0D0
3773             CTURB_GL(9,2)=3.0D0
3774             CTURB_GL(9,3)=3.1D0
3775             CTURB_GL(9,4)=2.2D0
3776             CTURB_GL(9,5)=2.2D0
3777             CTURB_GL(9,6)=2.2D0
3778             CTURB_GL(9,7)=2.3D0
3779             CTURB_GL(9,8)=2.3D0
3780             CTURB_GL(9,9)=2.5D0
3781             CTURB_GL(9,10)=2.5D0
3782             CTURB_GL(9,11)=2.2D0
3783             CTURB_GL(9,12)=1.8D0
3784             CTURB_GL(9,13)=1.25D0
3785             CTURB_GL(9,14)=1.1D0
3787             CTURB_GL(10,1)=2.75D0
3788             CTURB_GL(10,2)=2.75D0
3789             CTURB_GL(10,3)=2.0D0
3790             CTURB_GL(10,4)=2.0D0
3791             CTURB_GL(10,5)=2.0D0
3792             CTURB_GL(10,6)=2.1D0
3793             CTURB_GL(10,7)=2.2D0
3794             CTURB_GL(10,8)=2.2D0
3795             CTURB_GL(10,9)=2.3D0
3796             CTURB_GL(10,10)=2.3D0
3797             CTURB_GL(10,11)=2.3D0
3798             CTURB_GL(10,12)=1.8D0
3799             CTURB_GL(10,13)=1.2D0
3800             CTURB_GL(10,14)=1.1D0
3802             CTURB_GL(11,1)=2.6D0
3803             CTURB_GL(11,2)=2.6D0
3804             CTURB_GL(11,3)=1.95D0
3805             CTURB_GL(11,4)=1.95D0
3806             CTURB_GL(11,5)=1.95D0
3807             CTURB_GL(11,6)=2.05D0
3808             CTURB_GL(11,7)=2.15D0
3809             CTURB_GL(11,8)=2.15D0
3810             CTURB_GL(11,9)=2.25D0
3811             CTURB_GL(11,10)=2.25D0
3812             CTURB_GL(11,11)=1.9D0
3813             CTURB_GL(11,12)=1.8D0
3814             CTURB_GL(11,13)=1.2D0
3815             CTURB_GL(11,14)=1.1D0
3817             CTURB_GL(12,1)=2.4D0
3818             CTURB_GL(12,2)=2.4D0
3819             CTURB_GL(12,3)=1.85D0
3820             CTURB_GL(12,4)=1.85D0
3821             CTURB_GL(12,5)=1.85D0
3822             CTURB_GL(12,6)=1.75D0
3823             CTURB_GL(12,7)=1.85D0
3824             CTURB_GL(12,8)=1.85D0
3825             CTURB_GL(12,9)=2.1D0
3826             CTURB_GL(12,10)=2.1D0
3827             CTURB_GL(12,11)=1.9D0
3828             CTURB_GL(12,12)=1.8D0 
3829             CTURB_GL(12,13)=1.3D0
3830             CTURB_GL(12,14)=1.1D0
3832             CTURB_GL(13,1)=1.67D0
3833             CTURB_GL(13,2)=1.67D0
3834             CTURB_GL(13,3)=1.75D0
3835             CTURB_GL(13,4)=1.83D0
3836             CTURB_GL(13,5)=1.87D0
3837             CTURB_GL(13,6)=2.0D0
3838             CTURB_GL(13,7)=2.1D0
3839             CTURB_GL(13,8)=2.12D0
3840             CTURB_GL(13,9)=2.15D0
3841             CTURB_GL(13,10)=2.18D0
3842             CTURB_GL(13,11)=2.19D0
3843             CTURB_GL(13,12)=1.67D0
3844             CTURB_GL(13,13)=1.28D0
3845             CTURB_GL(13,14)=1.0D0
3847             CTURB_GL(14,1)=1.3D0
3848             CTURB_GL(14,2)=1.3D0
3849             CTURB_GL(14,3)=1.35D0
3850             CTURB_GL(14,4)=1.4D0
3851             CTURB_GL(14,5)=1.6D0
3852             CTURB_GL(14,6)=1.7D0
3853             CTURB_GL(14,7)=1.7D0
3854             CTURB_GL(14,8)=1.7D0
3855             CTURB_GL(14,9)=1.7D0
3856             CTURB_GL(14,10)=1.7D0
3857             CTURB_GL(14,11)=1.7D0
3858             CTURB_GL(14,12)=1.4D0
3859             CTURB_GL(14,13)=1.25D0
3860             CTURB_GL(14,14)=1.0D0
3862             CTURB_GL(15,1)=1.17D0
3863             CTURB_GL(15,2)=1.17D0
3864             CTURB_GL(15,3)=1.17D0
3865             CTURB_GL(15,4)=1.25D0
3866             CTURB_GL(15,5)=1.3D0
3867             CTURB_GL(15,6)=1.35D0
3868             CTURB_GL(15,7)=1.4D0
3869             CTURB_GL(15,8)=1.4D0
3870             CTURB_GL(15,9)=1.45D0
3871             CTURB_GL(15,10)=1.47D0
3872             CTURB_GL(15,11)=1.44D0
3873             CTURB_GL(15,12)=1.3D0
3874             CTURB_GL(15,13)=1.12D0
3875             CTURB_GL(15,14)=1.0D0
3877             CTURB_GL(16,1)=1.17D0
3878             CTURB_GL(16,2)=1.17D0
3879             CTURB_GL(16,3)=1.17D0
3880             CTURB_GL(16,4)=1.25D0
3881             CTURB_GL(16,5)=1.3D0
3882             CTURB_GL(16,6)=1.35D0
3883             CTURB_GL(16,7)=1.4D0
3884             CTURB_GL(16,8)=1.45D0
3885             CTURB_GL(16,9)=1.45D0
3886             CTURB_GL(16,10)=1.47D0
3887             CTURB_GL(16,11)=1.44D0
3888             CTURB_GL(16,12)=1.3D0
3889             CTURB_GL(16,13)=1.12D0
3890             CTURB_GL(16,14)=1.0D0
3891           ENDIF
3892           IF(IEPS_800.EQ.1) THEN
3893             CTURB_GL(1,1) =0.00D0
3894             CTURB_GL(1,2) =0.00D0
3895             CTURB_GL(1,3) =1.00D0
3896             CTURB_GL(1,4) =1.50D0
3897             CTURB_GL(1,5) =1.40D0
3898             CTURB_GL(1,6) =1.30D0
3899             CTURB_GL(1,7) =1.20D0
3900             CTURB_GL(1,8) =1.10D0
3901             CTURB_GL(1,9) =1.00D0
3902             CTURB_GL(1,10)=1.00D0
3903             CTURB_GL(1,11)=1.00D0
3904             CTURB_GL(1,12)=1.00D0
3905             CTURB_GL(1,13)=1.00D0
3906             CTURB_GL(1,14)=1.00D0
3907             CTURB_GL(1,15)=1.00D0
3908             CTURB_GL(1,16)=1.00D0
3910             CTURB_GL(2,1) =0.00D0
3911             CTURB_GL(2,2) =0.00D0
3912             CTURB_GL(2,3) =1.00D0
3913             CTURB_GL(2,4) =2.00D0
3914             CTURB_GL(2,5) =1.80D0
3915             CTURB_GL(2,6) =1.70D0
3916             CTURB_GL(2,7) =1.60D0
3917             CTURB_GL(2,8) =1.50D0
3918             CTURB_GL(2,9) =1.50D0
3919             CTURB_GL(2,10)=1.50D0
3920             CTURB_GL(2,11)=1.50D0
3921             CTURB_GL(2,12)=1.50D0
3922             CTURB_GL(2,13)=1.50D0
3923             CTURB_GL(2,14)=1.00D0
3924             CTURB_GL(2,15)=1.00D0
3925             CTURB_GL(2,16)=1.00D0
3927             CTURB_GL(3,1) =0.00D0
3928             CTURB_GL(3,2) =0.00D0
3929             CTURB_GL(3,3) =4.00D0
3930             CTURB_GL(3,4) =7.65D0
3931             CTURB_GL(3,5) =7.65D0
3932             CTURB_GL(3,6) =8.00D0
3933             CTURB_GL(3,7) =8.00D0
3934             CTURB_GL(3,8) =7.50D0
3935             CTURB_GL(3,9) =6.50D0
3936             CTURB_GL(3,10)=6.00D0
3937             CTURB_GL(3,11)=5.00D0
3938             CTURB_GL(3,12)=4.50D0
3939             CTURB_GL(3,13)=4.00D0
3940             CTURB_GL(3,14)=2.00D0
3941             CTURB_GL(3,15)=1.30D0
3942             CTURB_GL(3,16)=1.00D0
3944             CTURB_GL(4,1) =7.50D0
3945             CTURB_GL(4,2) =7.50D0
3946             CTURB_GL(4,3) =7.50D0
3947             CTURB_GL(4,4) =7.65D0       
3948             CTURB_GL(4,5) =7.65D0       
3949             CTURB_GL(4,6) =8.00D0       
3950             CTURB_GL(4,7) =8.00D0       
3951             CTURB_GL(4,8) =7.50D0       
3952             CTURB_GL(4,9) =6.50D0       
3953             CTURB_GL(4,10)=6.00D0       
3954             CTURB_GL(4,11)=5.00D0       
3955             CTURB_GL(4,12)=4.50D0       
3956             CTURB_GL(4,13)=4.00D0       
3957             CTURB_GL(4,14)=2.00D0       
3958             CTURB_GL(4,15)=1.30D0       
3959             CTURB_GL(4,16)=1.00D0       
3960     
3961             CTURB_GL(5,1) =5.50D0
3962             CTURB_GL(5,2) =5.50D0
3963             CTURB_GL(5,3) =5.50D0
3964             CTURB_GL(5,4) =5.75D0
3965             CTURB_GL(5,5) =5.75D0
3966             CTURB_GL(5,6) =6.00D0
3967             CTURB_GL(5,7) =6.25D0
3968             CTURB_GL(5,8) =6.17D0
3969             CTURB_GL(5,9) =5.75D0
3970             CTURB_GL(5,10)=5.25D0
3971             CTURB_GL(5,11)=4.75D0
3972             CTURB_GL(5,12)=4.25D0
3973             CTURB_GL(5,13)=4.00D0
3974             CTURB_GL(5,14)=2.00D0
3975             CTURB_GL(5,15)=1.35D0
3976             CTURB_GL(5,16)=1.00D0
3977          
3978             CTURB_GL(6,1) =4.50D0
3979             CTURB_GL(6,2) =4.50D0
3980             CTURB_GL(6,3) =4.50D0
3981             CTURB_GL(6,4) =4.75D0       
3982             CTURB_GL(6,5) =4.75D0       
3983             CTURB_GL(6,6) =5.00D0       
3984             CTURB_GL(6,7) =5.25D0       
3985             CTURB_GL(6,8) =5.25D0       
3986             CTURB_GL(6,9) =5.00D0       
3987             CTURB_GL(6,10)=4.75D0       
3988             CTURB_GL(6,11)=4.50D0       
3989             CTURB_GL(6,12)=4.00D0       
3990             CTURB_GL(6,13)=3.75D0       
3991             CTURB_GL(6,14)=2.00D0       
3992             CTURB_GL(6,15)=1.40D0       
3993             CTURB_GL(6,16)=1.00D0       
3994                                         
3995             CTURB_GL(7,1) =4.00D0
3996             CTURB_GL(7,2) =4.00D0
3997             CTURB_GL(7,3) =4.00D0
3998             CTURB_GL(7,4) =4.00D0
3999             CTURB_GL(7,5) =4.00D0
4000             CTURB_GL(7,6) =4.25D0
4001             CTURB_GL(7,7) =4.50D0
4002             CTURB_GL(7,8) =4.67D0
4003             CTURB_GL(7,9) =4.50D0
4004             CTURB_GL(7,10)=4.30D0
4005             CTURB_GL(7,11)=4.10D0
4006             CTURB_GL(7,12)=3.80D0
4007             CTURB_GL(7,13)=3.50D0
4008             CTURB_GL(7,14)=2.00D0
4009             CTURB_GL(7,15)=1.30D0
4010             CTURB_GL(7,16)=1.10D0
4012             CTURB_GL(8,1) =3.50D0
4013             CTURB_GL(8,2) =3.50D0
4014             CTURB_GL(8,3) =3.50D0
4015             CTURB_GL(8,4) =3.65D0
4016             CTURB_GL(8,5) =3.65D0
4017             CTURB_GL(8,6) =3.80D0
4018             CTURB_GL(8,7) =4.1D02
4019             CTURB_GL(8,8) =4.17D0
4020             CTURB_GL(8,9) =4.17D0
4021             CTURB_GL(8,10)=4.00D0
4022             CTURB_GL(8,11)=3.80D0
4023             CTURB_GL(8,12)=3.67D0
4024             CTURB_GL(8,13)=3.40D0
4025             CTURB_GL(8,14)=2.00D0
4026             CTURB_GL(8,15)=1.30D0
4027             CTURB_GL(8,16)=1.10D0
4029             CTURB_GL(9,1) =3.25D0
4030             CTURB_GL(9,2) =3.25D0
4031             CTURB_GL(9,3) =3.25D0
4032             CTURB_GL(9,4) =3.25D0
4033             CTURB_GL(9,5) =3.25D0
4034             CTURB_GL(9,6) =3.50D0
4035             CTURB_GL(9,7) =3.75D0
4036             CTURB_GL(9,8) =3.75D0
4037             CTURB_GL(9,9) =3.75D0
4038             CTURB_GL(9,10)=3.75D0
4039             CTURB_GL(9,11)=3.60D0
4040             CTURB_GL(9,12)=3.40D0
4041             CTURB_GL(9,13)=3.25D0
4042             CTURB_GL(9,14)=2.00D0
4043             CTURB_GL(9,15)=1.30D0
4044             CTURB_GL(9,16)=1.10D0
4045             
4046             CTURB_GL(10,1) =3.00D0
4047             CTURB_GL(10,2) =3.00D0
4048             CTURB_GL(10,3) =3.00D0
4049             CTURB_GL(10,4) =3.10D0
4050             CTURB_GL(10,5) =3.10D0
4051             CTURB_GL(10,6) =3.25D0
4052             CTURB_GL(10,7) =3.40D0
4053             CTURB_GL(10,8) =3.50D0
4054             CTURB_GL(10,9) =3.50D0
4055             CTURB_GL(10,10)=3.50D0
4056             CTURB_GL(10,11)=3.40D0
4057             CTURB_GL(10,12)=3.25D0
4058             CTURB_GL(10,13)=3.15D0
4059             CTURB_GL(10,14)=1.90D0
4060             CTURB_GL(10,15)=1.30D0
4061             CTURB_GL(10,16)=1.10D0
4063             CTURB_GL(11,1) =2.75D0
4064             CTURB_GL(11,2) =2.75D0
4065             CTURB_GL(11,3) =2.75D0
4066             CTURB_GL(11,4) =2.75D0
4067             CTURB_GL(11,5) =2.75D0
4068             CTURB_GL(11,6) =3.00D0
4069             CTURB_GL(11,7) =3.25D0
4070             CTURB_GL(11,8) =3.25D0
4071             CTURB_GL(11,9) =3.25D0
4072             CTURB_GL(11,10)=3.25D0
4073             CTURB_GL(11,11)=3.25D0
4074             CTURB_GL(11,12)=3.15D0
4075             CTURB_GL(11,13)=3.00D0
4076             CTURB_GL(11,14)=1.80D0
4077             CTURB_GL(11,15)=1.30D0
4078             CTURB_GL(11,16)=1.10D0
4080             CTURB_GL(12,1) =2.60D0
4081             CTURB_GL(12,2) =2.60D0
4082             CTURB_GL(12,3) =2.60D0
4083             CTURB_GL(12,4) =2.67D0
4084             CTURB_GL(12,5) =2.67D0
4085             CTURB_GL(12,6) =2.75D0
4086             CTURB_GL(12,7) =3.00D0
4087             CTURB_GL(12,8) =3.17D0
4088             CTURB_GL(12,9) =3.17D0
4089             CTURB_GL(12,10)=3.17D0
4090             CTURB_GL(12,11)=3.10D0
4091             CTURB_GL(12,12)=2.90D0
4092             CTURB_GL(12,13)=2.80D0
4093             CTURB_GL(12,14)=1.87D0
4094             CTURB_GL(12,15)=1.37D0
4095             CTURB_GL(12,16)=1.10D0
4097             CTURB_GL(13,1) =2.40D0
4098             CTURB_GL(13,2) =2.40D0
4099             CTURB_GL(13,3) =2.40D0
4100             CTURB_GL(13,4) =2.50D0
4101             CTURB_GL(13,5) =2.50D0
4102             CTURB_GL(13,6) =2.67D0
4103             CTURB_GL(13,7) =2.83D0
4104             CTURB_GL(13,8) =2.90D0
4105             CTURB_GL(13,9) =3.00D0
4106             CTURB_GL(13,10)=2.90D0
4107             CTURB_GL(13,11)=2.85D0
4108             CTURB_GL(13,12)=2.80D0
4109             CTURB_GL(13,13)=2.75D0
4110             CTURB_GL(13,14)=1.83D0
4111             CTURB_GL(13,15)=1.30D0
4112             CTURB_GL(13,16)=1.10D0
4114             CTURB_GL(14,1) =1.67D0
4115             CTURB_GL(14,2) =1.67D0
4116             CTURB_GL(14,3) =1.67D0
4117             CTURB_GL(14,4) =1.75D0
4118             CTURB_GL(14,5) =1.75D0
4119             CTURB_GL(14,6) =1.83D0
4120             CTURB_GL(14,7) =1.87D0
4121             CTURB_GL(14,8) =2.00D0
4122             CTURB_GL(14,9) =2.10D0
4123             CTURB_GL(14,10)=2.12D0
4124             CTURB_GL(14,11)=2.15D0
4125             CTURB_GL(14,12)=2.18D0
4126             CTURB_GL(14,13)=2.19D0
4127             CTURB_GL(14,14)=1.67D0
4128             CTURB_GL(14,15)=1.28D0
4129             CTURB_GL(14,16)=1.00D0
4131             CTURB_GL(15,1) =1.30D0
4132             CTURB_GL(15,2) =1.30D0
4133             CTURB_GL(15,3) =1.30D0
4134             CTURB_GL(15,4) =1.35D0
4135             CTURB_GL(15,5) =1.35D0
4136             CTURB_GL(15,6) =1.40D0
4137             CTURB_GL(15,7) =1.60D0
4138             CTURB_GL(15,8) =1.70D0
4139             CTURB_GL(15,9) =1.70D0
4140             CTURB_GL(15,10)=1.70D0
4141             CTURB_GL(15,11)=1.70D0
4142             CTURB_GL(15,12)=1.70D0
4143             CTURB_GL(15,13)=1.70D0
4144             CTURB_GL(15,14)=1.40D0
4145             CTURB_GL(15,15)=1.25D0
4146             CTURB_GL(15,16)=1.00D0
4148             CTURB_GL(16,1) =1.17D0
4149             CTURB_GL(16,2) =1.17D0
4150             CTURB_GL(16,3) =1.17D0
4151             CTURB_GL(16,4) =1.17D0
4152             CTURB_GL(16,5) =1.17D0
4153             CTURB_GL(16,6) =1.25D0
4154             CTURB_GL(16,7) =1.30D0
4155             CTURB_GL(16,8) =1.35D0
4156             CTURB_GL(16,9) =1.40D0
4157             CTURB_GL(16,10)=1.45D0
4158             CTURB_GL(16,11)=1.45D0
4159             CTURB_GL(16,12)=1.47D0
4160             CTURB_GL(16,13)=1.44D0
4161             CTURB_GL(16,14)=1.30D0
4162             CTURB_GL(16,15)=1.12D0
4163             CTURB_GL(16,16)=1.00D0
4164           ENDIF
4165           IF(IEPS_800.EQ.1.AND.IEPS_1600.EQ.1) THEN
4166             DO I=1,K0G_GL
4167                DO J=1,K0L_GL
4168                   CTURB_GL(I,J)=CTURB_GL(I,J)*1.7D0
4169                ENDDO
4170             ENDDO 
4171           ENDIF
4172           DO J=1,K0L_GL
4173              DO I=1,K0G_GL
4174                 CTURB_GL(I,J)=(CTURB_GL(I,J)-1.0D0)/1.5D0+1.0D0
4175              ENDDO
4176           ENDDO
4177           DO I=KRMING_GL,KRMAXG_GL
4178              DO J=KRMINL_GL,KRMAXL_GL
4179                 CTURBGL(I,J)=1.
4180              ENDDO
4181           ENDDO
4182           DO I=KRMING_GL,KRMAXG_GL                   
4183              X_KERN=RADXXO(I,6)*1.0D4
4184              IF(X_KERN.LT.RG_GL(1)) X_KERN=RG_GL(1)
4185              IF(X_KERN.GT.RG_GL(K0G_GL)) X_KERN=RG_GL(K0G_GL) 
4186              DO J=KRMINL_GL,KRMAXL_GL
4187                 Y_KERN=RADXXO(J,1)*1.0D4
4188                 IF(Y_KERN.LT.RL_GL(1)) Y_KERN=RL_GL(1)
4189                 IF(Y_KERN.GT.RL_GL(K0L_GL)) Y_KERN=RL_GL(K0L_GL)
4190                 CTURBGL(I,J)=F(X_KERN,Y_KERN,RG_GL,RL_GL,CTURB_GL &
4191      &                      ,K0G_GL,K0L_GL)           
4192              ENDDO
4193           ENDDO
4194           IF(IEPS_800.EQ.1) THEN
4195             DO I=KRMING_GL,15
4196                DO J=KRMINL_GL,13
4197                   IF(CTURBGL(I,J).LT.3.0D0) CTURBGL(I,J)=3.0D0
4198                ENDDO
4199             ENDDO
4200           ENDIF
4201           IF(IEPS_1600.EQ.1) THEN
4202             DO I=KRMING_GL,15
4203                DO J=KRMINL_GL,13
4204                   IF(CTURBGL(I,J).LT.5.1D0) CTURBGL(I,J)=5.1D0
4205                ENDDO
4206             ENDDO
4207           ENDIF
4208           DO I=1,33
4209              DO J=1,24
4210                 IF(I.LE.14.AND.J.EQ.8) CTURBGL(I,J)=1.0D0
4211                 IF(I.GT.14.AND.J.LE.8) CTURBGL(I,J)=1.2D0
4212              ENDDO
4213           ENDDO                       
4214         RETURN
4215         END SUBROUTINE TURBCOEF
4216 !===================================================================
4217 ! QUESTION
4218         real * 8 function f(x,y,x0,y0,table,k0,kk0)
4219 ! two-dimensional linear interpolation of the collision efficiency
4220 ! with help table(k0,kk0)
4222        implicit none
4223        integer k0,kk0,k,ir,kk,iq
4224        double precision x,y,p,q,ec,ek
4225 !      double precision x,y,p,q,ec,ek,f
4226        double precision x0(k0),y0(kk0),table(k0,kk0)
4229         do k=2,k0
4230            if(x.le.x0(k).and.x.ge.x0(k-1)) then
4231              ir=k     
4232            elseif(x.gt.x0(k0)) then
4233              ir=k0+1
4234            elseif(x.lt.x0(1)) then
4235              ir=1
4236            endif
4237         enddo
4238         do kk=2,kk0
4239            if(y.le.y0(kk).and.y.ge.y0(kk-1)) iq=kk
4240         enddo
4241         if(ir.lt.k0+1) then
4242           if(ir.ge.2) then
4243             p =(x-x0(ir-1))/(x0(ir)-x0(ir-1))
4244             q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
4245             ec=(1.d0-p)*(1.d0-q)*table(ir-1,iq-1)+ &
4246      &              p*(1.d0-q)*table(ir,iq-1)+ &
4247      &              q*(1.d0-p)*table(ir-1,iq)+ &
4248      &                   p*q*table(ir,iq)    
4249           else
4250             q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
4251             ec=(1.d0-q)*table(1,iq-1)+q*table(1,iq)    
4252           endif
4253         else
4254           q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
4255           ek=(1.d0-q)*table(k0,iq-1)+q*table(k0,iq)
4256           ec=min(ek,1.d0) 
4257         endif
4258         f=ec
4259         return
4260         end function f
4261 ! function f
4262                                                                             
4264                                                                             
4266 !======================================================================
4267         SUBROUTINE FREEZ(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
4268      &,TIN,DT,RO,COL,AFREEZMY,BFREEZMY,BFREEZMAX,KRFREEZ,ICEMAX,NKR)       
4269       IMPLICIT NONE 
4270       INTEGER KR,ICE,ICE_TYPE
4271       REAL COL,AFREEZMY,BFREEZMY,BFREEZMAX
4272       INTEGER KRFREEZ,ICEMAX,NKR
4273       REAL DT,RO,YKK,PF,PF_1,DEL_T,TT_DROP,ARG_1,YK2,DF1,BF,ARG_M, & 
4274      & TT_DROP_AFTER_FREEZ,CFREEZ,SUM_ICE,TIN,TTIN,AF,FF_MAX,F1_MAX, &
4275      & F2_MAX,F3_MAX,F4_MAX,F5_MAX
4278         REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX) &
4279      &           ,XI(NKR,ICEMAX),FF3(NKR),XS(NKR),FF4(NKR) &
4280      &           ,XG(NKR),FF5(NKR),XH(NKR)
4284         TTIN=TIN
4285         DEL_T   =TTIN-273.15
4286         ICE_TYPE=2
4287         F1_MAX=0.
4288         F2_MAX=0.
4289         F3_MAX=0.
4290         F4_MAX=0.
4291         F5_MAX=0.
4292         DO 1 KR=1,NKR
4293         F1_MAX=AMAX1(F1_MAX,FF1(KR))
4294         F3_MAX=AMAX1(F3_MAX,FF3(KR))
4295         F4_MAX=AMAX1(F4_MAX,FF4(KR))
4296         F5_MAX=AMAX1(F5_MAX,FF5(KR))
4297         DO 1 ICE=1,ICEMAX
4298         F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
4299     1   CONTINUE
4300         FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
4302 !******************************* FREEZING ****************************
4304         IF(DEL_T.LT.0.AND.F1_MAX.NE.0) THEN
4305         SUM_ICE=0.
4306         AF      =AFREEZMY
4307         CFREEZ  =(BFREEZMAX-BFREEZMY)/XL(NKR)
4309 !***************************** MASS LOOP **************************
4311          DO  KR =1,NKR
4312          ARG_M  =XL(KR)
4313          BF     =BFREEZMY+CFREEZ*ARG_M
4314          PF_1   =AF*EXP(-BF*DEL_T)
4315          PF     =ARG_M*PF_1
4316          YKK    =EXP(-PF*DT)
4317          DF1    =FF1(KR)*(1.-YKK)
4318          YK2    =DF1
4319          FF1(KR)=FF1(KR)*YKK
4320          IF(KR.LE.KRFREEZ)  THEN
4321          FF2(KR,ICE_TYPE)=FF2(KR,ICE_TYPE)+YK2
4322                             ELSE
4323           FF5(KR)       =FF5(KR)+YK2
4324          ENDIF
4325          SUM_ICE=SUM_ICE+YK2*3.*XL(KR)*XL(KR)*COL
4327 !************************ END OF "MASS LOOP" **************************
4329          ENDDO
4331 !************************** NEW TEMPERATURE *************************
4332 !       
4333         ARG_1   =333.*SUM_ICE/RO
4334         TT_DROP_AFTER_FREEZ=TTIN+ARG_1
4335         TIN     =TT_DROP_AFTER_FREEZ
4337 !************************** END OF "FREEZING" ****************************
4339         ENDIF
4341         RETURN                                                           
4342         END SUBROUTINE FREEZ                                                             
4344         SUBROUTINE ORIG_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
4345      &                           ,TIN,DT,RO,COL,ICEMAX,NKR)
4346       IMPLICIT NONE
4347       INTEGER KR,ICE,ICE_TYPE
4348       INTEGER ICEMAX,NKR
4349       REAL COL
4350       REAL ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DT,DF1,DN,DN0, &
4351      & RO,A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, &
4352      & DEL_T,TIN
4353         REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX),XI(NKR,ICEMAX) &
4354      &           ,FF3(NKR),XS(NKR),FF4(NKR) &
4355      &           ,XG(NKR),FF5(NKR),XH(NKR)
4358 !       gamma=4.4
4359         DEL_T   =TIN-273.15
4360         ICE_TYPE=2
4361         F1_MAX=0.
4362         F2_MAX=0.
4363         F3_MAX=0.
4364         F4_MAX=0.
4365         F5_MAX=0.
4366         DO 1 KR=1,NKR
4367         F1_MAX=AMAX1(F1_MAX,FF1(KR))
4368         F3_MAX=AMAX1(F3_MAX,FF3(KR))
4369         F4_MAX=AMAX1(F4_MAX,FF4(KR))
4370         F5_MAX=AMAX1(F5_MAX,FF5(KR))
4371         DO 1 ICE=1,ICEMAX
4372         F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
4373     1   CONTINUE
4374         FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
4375 ! MELTING :
4376         IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN
4377           SUM_ICE=0.
4378 ! MASS LOOP :
4379           DO KR=1,NKR
4380              ARG_M=FF3(KR)+FF4(KR)+FF5(KR)
4381              DO ICE=1,ICEMAX
4382                 ARG_M=ARG_M+FF2(KR,ICE)
4383                 FF2(KR,ICE)=0.
4384              ENDDO
4385              FF1(KR)=FF1(KR)+ARG_M
4386              FF3(KR)=0.
4387              FF4(KR)=0.
4388              FF5(KR)=0.
4389              SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL
4390 ! END OF "MASS LOOP"
4391           ENDDO
4392 ! CYCLE BY KR
4393 ! NEW TEMPERATURE :
4394           ARG_1=333.*SUM_ICE/RO 
4395           TIN=TIN-ARG_1
4396 ! END OF MELTING
4397 ! IN CASE DEL_T.GE.0.AND.FF_MAX.NE.0
4398         ENDIF
4399         RETURN                                                           
4400         END SUBROUTINE ORIG_MELT                                                             
4401 !===========================
4402        SUBROUTINE J_W_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
4403      &                           ,TIN,DT,RO,COL,ICEMAX,NKR)
4404       IMPLICIT NONE
4405       INTEGER KR,ICE,ICE_TYPE
4406       INTEGER ICEMAX,NKR
4407       REAL COL
4408       REAL ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DT,DF1,DN,DN0, &
4409      & RO,A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, &
4410      & DEL_T,TIN,meltrate
4411         REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX),XI(NKR,ICEMAX) &
4412      &           ,FF3(NKR),XS(NKR),FF4(NKR) &
4413      &           ,XG(NKR),FF5(NKR),XH(NKR)
4416 !       gamma=4.4
4417         DEL_T   =TIN-273.15
4418         F1_MAX=0.
4419         F2_MAX=0.
4420         F3_MAX=0.
4421         F4_MAX=0.
4422         F5_MAX=0.
4423         DO 1 KR=1,NKR
4424         F1_MAX=AMAX1(F1_MAX,FF1(KR))
4425         F3_MAX=AMAX1(F3_MAX,FF3(KR))
4426         F4_MAX=AMAX1(F4_MAX,FF4(KR))
4427         F5_MAX=AMAX1(F5_MAX,FF5(KR))
4428         DO 1 ICE=1,ICEMAX
4429         F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
4430     1   CONTINUE
4431         FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
4432 ! MELTING :
4433         SUM_ICE=0.
4434         IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN
4435 ! Fan's "MASS LOOP"
4436           DO KR = 1,NKR
4437           ARG_M = 0.
4438             DO ICE = 1,ICEMAX
4439              IF (ICE ==1) THEN
4440                  IF (KR .le. 10) THEN
4441                      ARG_M = ARG_M+FF2(KR,ICE)
4442                      FF2(KR,ICE)=0.
4443                  ELSEIF (KR .gt. 10 .and. KR .lt. 18) THEN
4444                      meltrate = 0.5/50.
4445                      ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
4446                      FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
4447                  ELSE
4448                      meltrate = 0.683/120.
4449                      ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
4450                      FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
4451                  ENDIF
4452              ENDIF
4453              IF (ICE ==2 .or. ICE ==3) THEN
4454                 IF (kr .le. 12) THEN
4455                     ARG_M = ARG_M+FF2(KR,ICE)
4456                     FF2(KR,ICE)=0.
4457                 ELSEIF (kr .gt. 12 .and. kr .lt. 20) THEN
4458                     meltrate = 0.5/50.
4459                     ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
4460                     FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
4461                  ELSE
4462                     meltrate = 0.683/120.
4463                     ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
4464                     FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
4465                  ENDIF
4466              ENDIF
4467             ENDDO  ! Do ice
4468 ! snow
4469                  IF (kr .le. 14) THEN
4470                     ARG_M = ARG_M+FF3(KR)
4471                     FF3(KR)=0.
4472                  ELSEIF (kr .gt. 14 .and. kr .lt. 22) THEN
4473                     meltrate = 0.5/50.
4474                     ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
4475                     FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
4476                  ELSE
4477                     meltrate = 0.683/120.
4478                     ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
4479                     FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
4480                  ENDIF
4481 ! graupel/hail
4482                  IF (kr .le. 13) then
4483                      ARG_M = ARG_M+FF4(KR)+FF5(KR)
4484                      FF4(KR)=0.
4485                      FF5(KR)=0.
4486                  ELSEIF (kr .gt. 13 .and. kr .lt. 23) THEN
4487                      meltrate = 0.5/50.
4488                      ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
4489                      FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
4490                      FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
4491                  ELSE
4492                     meltrate = 0.683/120.
4493                     ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
4494                     FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
4495                     FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
4496                  ENDIF
4498                    FF1(KR)=FF1(KR)+ARG_M
4500                    SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL
4501 ! END OF Fan'a "MASS LOOP"
4502        ENDDO
4503 ! CYCLE BY KR
4504 ! NEW TEMPERATURE :
4505         ARG_1=333.*SUM_ICE/RO
4506         TIN=TIN-ARG_1
4507 ! END OF MELTING
4509         ENDIF
4510         RETURN                                                           
4511         END SUBROUTINE J_W_MELT                                                             
4512 !===================================================================
4513       SUBROUTINE JERNUCL01(PSI1,PSI2,FCCNR &
4514      &                    ,X1,X2,DTT,DQQ,ROR,PP,DSUP1,DSUP2 &
4515      &  ,COL,AA1_MY, BB1_MY, AA2_MY, BB2_MY &
4516      &  ,C1_MEY,C2_MEY,SUP2_OLD,DSUPICEXZ &
4517      &  ,RCCN,DROPRADII,NKR,ICEMAX,ICEPROCS)
4518       IMPLICIT NONE 
4520       INTEGER ICEMAX,NKR
4521       INTEGER ICEPROCS
4522       REAL COL,AA1_MY, BB1_MY, AA2_MY, BB2_MY, &
4523      &  C1_MEY,C2_MEY,SUP2_OLD,DSUPICEXZ, &
4524      &  RCCN(NKR),DROPRADII(NKR),FCCNR(NKR)
4526       INTEGER KR,ICE,ITYPE,NRGI,ICORR,II,JJ,KK,NKRDROP,NCRITI
4527        DOUBLE PRECISION DTT,DQQ,DSUP1,DSUP2
4528        REAL TT,QQ,              &
4529      & DX,BMASS,CONCD,C2,CONCDF,DELTACD,CONCDIN,ROR, &
4530      & DELTAF,DELMASSL,FMASS,HELEK1,DEL2NN,FF1BN, &
4531      & HELEK2,TPCC,PP,ADDF,DSUP2N,FACT,EW1N,ES2N,ES1N,FNEW, &
4532      & C1,SUP1N,SUP2N,QPN,TPN,TPC,SUP1,SUP2,DEL1N,DEL2N,AL1,AL2, &
4533      & TEMP1,TEMP2,TEMP3,A1,B1,A2,B2 
4536 !********************************************************************
4538 ! NEW MEYERS IN JERNUCL01 SUBROUTINE 
4542 !********************************************************************
4546       REAL PSI1(NKR),X1(NKR),DROPCONCN(NKR) &
4547      &     ,PSI2(NKR,ICEMAX),X2(NKR,ICEMAX)
4548       
4550       DATA A1,B1,A2,B2/-0.639,0.1296,-2.8,0.262/
4551       DATA TEMP1,TEMP2,TEMP3/-5.,-2.,-20./
4552       DATA AL1/2500./,AL2/2834./
4553       SUP1=DSUP1
4554       SUP2=DSUP2
4557       TT=DTT
4558       QQ=DQQ
4559 ! DROPLETS NUCLEATION (BEGIN)
4561         TPN=TT
4562         QPN=QQ
4564         DEL1N=100.*SUP1
4565         TPC=TT-273.15
4567         IF(DEL1N.GT.0.AND.TPC.GT.-73.16) THEN
4568          CALL WATER_NUCL (PSI1,FCCNR,X1,TT,SUP1  &
4569      &        ,COL,RCCN,DROPRADII,NKR,ICEMAX)
4570         ENDIF
4571 ! DROPLETS NUCLEATION (END)
4572 ! drop nucleation                                               (end)
4573 ! nucleation of crystals                                      (begin)
4575        IF (ICEPROCS.EQ.1)THEN
4576         DEL2N=100.*SUP2
4577         IF(TPC.LT.0..AND.TPC.GE.-73.16.AND.DEL2N.GT.0.) THEN
4579               CALL ICE_NUCL (PSI2,X2,TT,ROR,SUP2,SUP2_OLD &
4580      &                      ,C1_MEY,C2_MEY,COL,DSUPICEXZ &
4581      &                      ,NKR,ICEMAX)
4582         ENDIF
4583        ENDIF
4584 ! nucleation of crystals                                        (end)
4585 ! new change in drop nucleation                               (begin)
4586 ! no sink of water vapour by nucleation
4587       RETURN
4588       END SUBROUTINE JERNUCL01
4590 ! SUBROUTINE JERNUCL01
4591 !======================================================================      
4592       SUBROUTINE WATER_NUCL (PSI1,FCCNR,X1,TT,SUP1 &
4593      &,COL,RCCN,DROPRADII,NKR,ICEMAX)
4594       IMPLICIT NONE
4595       INTEGER NDROPMAX,KR,ICEMAX,NKR
4596       REAL PSI1(NKR),FCCNR(NKR),X1(NKR)
4597       REAL DROPCONCN(NKR)
4598       REAL RCCN(NKR),DROPRADII(NKR)
4599       REAL TT,SUP1,DX,COL
4602       CALL NUCLEATION (SUP1,TT,FCCNR,DROPCONCN  &
4603      &,NDROPMAX,COL,RCCN,DROPRADII,NKR,ICEMAX)
4605 ! NEW WATER SIZE DISTRIBUTION FUNCTION (BEGIN)
4606         DO KR=1,NDROPMAX
4607            DX=3.*COL*X1(KR)
4608 ! new changes 25.06.01                                        (begin)
4609            PSI1(KR)=PSI1(KR)+DROPCONCN(KR)/DX
4610 ! new changes 25.06.01                                          (end)
4611         ENDDO
4613       RETURN
4614       END SUBROUTINE WATER_NUCL
4615       SUBROUTINE ICE_NUCL (PSI2,X2,TT,ROR,SUP2,SUP2_OLD &
4616      &                      ,C1_MEY,C2_MEY,COL,DSUPICEXZ &
4617      &                      ,NKR,ICEMAX)
4618         IMPLICIT NONE
4619         INTEGER ITYPE,KR,ICE,NRGI,ICEMAX,NKR
4620         REAL DEL2N,SUP2,C1,C2,C1_MEY,C2_MEY,TPC,TT,ROR
4621         REAL DX,COL,BMASS,BFMASS,FMASS
4622         REAL HELEK1,HELEK2,TPCC,DEL2NN,FF1BN,DSUPICEXZ
4623         REAL FACT,DSUP2N,SUP2_OLD,DELTACD,DELTAF,ADDF,FNEW
4624         REAL X2(NKR,ICEMAX),PSI2(NKR,ICEMAX)
4626         REAL A1,B1,A2,B2
4627         DATA A1,B1,A2,B2/-0.639,0.1296,-2.8,0.262/
4628 !       DATA A1,B1,A2,B2/-0.639,0.15,-2.8,0.262/
4629         REAL TEMP1,TEMP2,TEMP3
4630         DATA TEMP1,TEMP2,TEMP3/-5.,-2.,-20./
4631         REAL ICE_CON
4633         C1=C1_MEY
4634         C2=C2_MEY
4635 ! TYPE OF ICE WITH NUCLEATION (BEGIN)
4637         TPC=TT-273.15
4638         ITYPE=0
4640         IF((TPC.GT.-4.0).OR.(TPC.LE.-8.1.AND.TPC.GT.-12.7).OR.&
4641      &  (TPC.LE.-17.8.AND.TPC.GT.-22.4)) THEN
4642           ITYPE=2
4643         ELSE
4644           IF((TPC.LE.-4.0.AND.TPC.GT.-8.1).OR.(TPC.LE.-22.4)) THEN
4645             ITYPE=1
4646           ELSE
4647             ITYPE=3
4648           ENDIF
4649         ENDIF
4653 ! NEW CRYSTAL SIZE DISTRIBUTION FUNCTION                      (BEGIN)
4655         ICE=ITYPE
4657         NRGI=2
4658         IF(TPC.LT.TEMP1) THEN
4659           DEL2N=100.*SUP2
4660           DEL2NN=DEL2N
4661           IF(DEL2N.GT.50.0) DEL2NN=50.
4662           HELEK1=C1*EXP(A1+B1*DEL2NN)
4663         ELSE
4664           HELEK1=0.
4665         ENDIF
4667         IF(TPC.LT.TEMP2) THEN
4668           TPCC=TPC
4669           IF(TPCC.LT.TEMP3) TPCC=TEMP3
4670           HELEK2=C2*EXP(A2-B2*TPCC)
4671         ELSE
4672           HELEK2=0.
4673         ENDIF
4675         FF1BN=HELEK1+HELEK2
4677         FACT=1.
4678         DSUP2N=(SUP2-SUP2_OLD+DSUPICEXZ)*100.
4680         SUP2_OLD=SUP2
4682         IF(DSUP2N.GT.50.) DSUP2N=50.
4684         DELTACD=FF1BN*B1*DSUP2N
4686         IF(DELTACD.GE.FF1BN) DELTACD=FF1BN
4688         IF(DELTACD.GT.0.) THEN
4689           ICE_CON=0.
4690           DO KR=1,NRGI-1
4691              DX=3.*X2(KR,ICE)*COL
4692              ICE_CON=ICE_CON+DX*PSI2(KR,ICE)
4693           ENDDO
4694           IF(ICE_CON.GT.HELEK1)THEN
4695 !           CONTINUE
4696           ELSE 
4697            DELTAF=DELTACD*FACT
4698            DO KR=1,NRGI-1
4699              DX=3.*X2(KR,ICE)*COL
4700              ADDF=DELTAF/DX
4701              PSI2(KR,ICE)=PSI2(KR,ICE)+ADDF
4702            ENDDO
4703           END IF
4704         ENDIF
4705 ! NEW CRYSTAL SIZE DISTRIBUTION FUNCTION                        (END)
4706        RETURN
4707        END SUBROUTINE ICE_NUCL
4713       SUBROUTINE NUCLEATION (SUP1,TT,FCCNR,DROPCONCN  &
4714      &,NDROPMAX,COL,RCCN,DROPRADII,NKR,ICEMAX)
4715 ! DROPCONCN(KR), 1/cm^3 - drop bin concentrations, KR=1,...,NKR
4717 ! determination of new size spectra due to drop nucleation
4719       IMPLICIT NONE
4720       INTEGER NDROPMAX,IDROP,ICCN,INEXT,ISMALL,KR,NCRITI
4721       INTEGER ICEMAX,IMIN,IMAX,NKR,I,II,I0,I1
4722       REAL &
4723      &  SUP1,TT,RACTMAX,XKOE,R03,SUPCRITI,AKOE23,RCRITI,BKOE, &
4724      &  AKOE,CONCCCNIN,DEG01,ALN_IP
4725       REAL CCNCONC(NKR)
4726       REAL CCNCONC_BFNUCL
4729       REAL COL
4730       REAL RCCN(NKR),DROPRADII(NKR),FCCNR(NKR)
4731       REAL RACT(NKR),DROPCONC(NKR),DROPCONCN(NKR)
4732       REAL DLN1,DLN2,FOLD_IP
4736         DEG01=1./3.
4739 ! calculation initial value of NDROPMAX - maximal number of drop bin
4740 ! which is activated
4742 ! initial value of NDROPMAX
4744         NDROPMAX=0
4746         DO KR=1,NKR
4747 ! initialization of bin radii of activated drops
4748            RACT(KR)=0.
4749 ! initialization of aerosol(CCN) bin concentrations
4750            CCNCONC(KR)=0.
4751 ! initialization of drop bin concentrations
4752            DROPCONCN(KR)=0.
4753         ENDDO
4756 ! CCNCONC_BFNUCL - concentration of aerosol particles before
4757 !                  nucleation
4759         CCNCONC_BFNUCL=0.
4760         DO I=1,NKR
4761            CCNCONC_BFNUCL=CCNCONC_BFNUCL+FCCNR(I)
4762         ENDDO
4764         CCNCONC_BFNUCL=CCNCONC_BFNUCL*COL
4766         IF(CCNCONC_BFNUCL.EQ.0.) THEN
4767            RETURN    
4768         ELSE
4769            CALL BOUNDARY(IMIN,IMAX,FCCNR,NKR)
4770            CALL CRITICAL (AKOE,BKOE,TT,RCRITI,SUP1,DEG01)
4771            IF(RCRITI.GE.RCCN(IMAX))  RETURN
4772         END IF
4774 ! calculation of CCNCONC(I) - aerosol(CCN) bin concentrations;
4775 !                             I=IMIN,...,IMAX
4776 ! determination of NCRITI - number bin in which is located RCRITI
4777         IF (IMIN.EQ.1)THEN
4778          CALL CCNIMIN(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
4779      &       FCCNR,NKR)
4780          CALL CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
4781      &       FCCNR,NKR)
4782         ELSE
4783          CALL CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
4784      &       FCCNR,NKR)
4785         END IF
4788 ! calculation CCNCONC_AFNUCL - ccn concentration after nucleation
4790 !       CCNCONC_AFNUCL=0.
4792 !       DO I=IMIN,IMAX
4793 !          CCNCONC_AFNUCL=CCNCONC_AFNUCL+FCCNR(I)
4794 !       ENDDO
4796 !       CCNCONC_AFNUCL=CCNCONC_AFNUCL*COL
4798 ! calculation DEL_CCNCONC
4800 !       DEL_CCNCONC=CCNCONC_BFNUCL-CCNCONC_AFNUCL
4801         CALL ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT,RACTMAX,NKR)
4805         CALL DROPMAX(DROPRADII,RACTMAX,NDROPMAX,NKR)
4806 ! put nucleated droplets into the drop bin according to radius
4807 ! change in drop concentration due to activation DROPCONCN(IDROP)
4808         ISMALL=NCRITI
4810         INEXT=ISMALL
4811 !       ISMALL=1
4813 !       INEXT=ISMALL
4815         DO IDROP=1,NDROPMAX
4816            DROPCONCN(IDROP)=0.
4817            DO I=ISMALL,IMAX
4818               IF(RACT(I).LE.DROPRADII(IDROP)) THEN
4819                 DROPCONCN(IDROP)=DROPCONCN(IDROP)+CCNCONC(I)
4820                 INEXT=I+1
4821               ENDIF
4822            ENDDO
4823            ISMALL=INEXT
4824         ENDDO
4826 !999    CONTINUE
4829         RETURN
4830         END SUBROUTINE NUCLEATION
4834         SUBROUTINE BOUNDARY(IMIN,IMAX,FCCNR,NKR)
4835 ! IMIN - left CCN spectrum boundary
4836         IMPLICIT NONE
4837         INTEGER I,IMIN,IMAX,NKR
4838         REAL FCCNR(NKR)
4840         IMIN=0
4842         DO I=1,NKR
4843            IF(FCCNR(I).NE.0.) THEN
4844              IMIN=I
4845              GOTO 40
4846            ENDIF
4847         ENDDO
4849  40     CONTINUE
4851 ! IMAX - right CCN spectrum boundary
4853         IMAX=0
4855         DO I=NKR,1,-1
4856            IF(FCCNR(I).NE.0.) THEN
4857              IMAX=I
4858              GOTO 41
4859            ENDIF
4860         ENDDO
4862  41     CONTINUE
4863         RETURN
4864         END  SUBROUTINE BOUNDARY
4866         SUBROUTINE CRITICAL (AKOE,BKOE,TT,RCRITI,SUP1,DEG01)
4867 ! AKOE & BKOE - constants in Koehler equation
4868         IMPLICIT NONE
4869         REAL AKOE,BKOE,TT,RCRITI,SUP1,DEG01
4870         REAL RO_SOLUTE
4871         PARAMETER (RO_SOLUTE=2.16)
4873          
4875         AKOE=3.3E-05/TT
4876         BKOE=2.*4.3/(22.9+35.5)
4877 ! new change 21.07.02                                         (begin)
4878         BKOE=BKOE*(4./3.)*3.141593*RO_SOLUTE                  
4879 ! new change 21.07.02                                           (end)
4880         
4882 ! table of critical aerosol radii
4884 !       GOTO 992
4886 ! SUP1_TEST(I), %
4887 !       SUP1_TEST(1)=0.01
4888 !       DO I=1,99
4889 !          SUP1_TEST(I+1)=SUP1_TEST(I)+0.01
4890 !          SUP1_I=SUP1_TEST(I)*0.01
4891 !          RCRITI_TEST(I)=(AKOE/3.)*(4./BKOE/SUP1_I/SUP1_I)**DEG01
4892 !       ENDDO
4894 ! RCRITI, cm - critical radius of "dry" aerosol
4896         RCRITI=(AKOE/3.)*(4./BKOE/SUP1/SUP1)**DEG01
4897         RETURN
4898         END  SUBROUTINE CRITICAL
4899             
4900         SUBROUTINE CCNIMIN(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
4901      &       FCCNR,NKR)
4902 ! FOR    IMIN=1
4903         IMPLICIT NONE
4904         INTEGER IMIN,II,IMAX,NCRITI,NKR
4905         REAL RCRITI,COL
4906         REAL RCCN(NKR),FCCNR(NKR),CCNCONC(NKR)
4907         REAL RCCN_MIN
4908         REAL DLN1,DLN2,FOLD_IP
4909 ! rccn_min - minimum aerosol(ccn) radius
4910         RCCN_MIN=RCCN(1)/10000.
4911 ! calculation of ccnconc(ii)=fccnr(ii)*col - aerosol(ccn) bin
4912 !                                            concentrations,
4913 !                                            ii=imin,...,imax
4914 ! determination of ncriti   - number bin in which is located rcriti
4915 ! calculation of ccnconc(ncriti)=fccnr(ncriti)*dln1/(dln1+dln2),
4916 ! where,    
4917 ! dln1=Ln(rcriti)-Ln(rccn_min)
4918 ! dln2=Ln(rccn(1)-Ln(rcriti)
4919 ! calculation of new value of fccnr(ncriti)
4921 !       IF(IMIN.EQ.1) THEN
4922           IF(RCRITI.LE.RCCN_MIN) THEN
4923             NCRITI=1
4924             DO II=NCRITI+1,IMAX
4925                CCNCONC(II)=COL*FCCNR(II)     
4926                FCCNR(II)=0.                  
4927             ENDDO
4928             GOTO 42
4929           ENDIF
4930           IF(RCRITI.GT.RCCN_MIN.AND.RCRITI.LT.RCCN(IMIN)) THEN
4931             NCRITI=1
4932             DO II=NCRITI+1,IMAX
4933                CCNCONC(II)=COL*FCCNR(II)
4934                FCCNR(II)=0.
4935             ENDDO
4936             DLN1=ALOG(RCRITI)-ALOG(RCCN_MIN)
4937             DLN2=ALOG(RCCN(1))-ALOG(RCRITI)
4938             CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
4939             FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/(DLN1+DLN2)
4940             GOTO 42
4941 ! in case RCRITI.GT.RCCN_MIN.AND.RCRITI.LT.RCCN(IMIN)
4942           ENDIF
4943 ! in case IMIN.EQ.1
4944 42       CONTINUE
4945      
4946          RETURN
4947          END SUBROUTINE CCNIMIN
4948         SUBROUTINE CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
4949      &       FCCNR,NKR)
4950         IMPLICIT NONE
4951          INTEGER I,IMIN,IMAX,NKR,II,NCRITI
4952          REAL COL
4953          REAL RCRITI,RCCN(NKR),CCNCONC(NKR),FCCNR(NKR)
4954          REAL DLN1,DLN2,FOLD_IP
4955         IF(IMIN.GT.1) THEN
4956           IF(RCRITI.LE.RCCN(IMIN-1)) THEN
4957             NCRITI=IMIN
4958             DO II=NCRITI,IMAX
4959                CCNCONC(II)=COL*FCCNR(II)
4960                FCCNR(II)=0.
4961             ENDDO
4962             GOTO 42
4963           ENDIF
4964           IF(RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)) &
4965      &    THEN
4966 ! this line eliminates bug you found (when IMIN=IMAX)
4967             NCRITI=IMIN
4968             
4969             DO II=NCRITI+1,IMAX
4970                CCNCONC(II)=COL*FCCNR(II)
4971                FCCNR(II)=0.
4972             ENDDO
4973             DLN1=ALOG(RCRITI)-ALOG(RCCN(IMIN-1))
4974             DLN2=COL-DLN1
4975             CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
4976             FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/COL
4977             GOTO 42
4978 ! in case RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)
4979           ENDIF
4980 ! in case IMIN.GT.1
4981         ENDIF
4982         
4983 ! END of part of interest. so in case
4984 !RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)
4985 !we go to 42 and avoid the next loop
4987       
4989          DO I=IMIN,IMAX-1
4990            IF(RCRITI.EQ.RCCN(I)) THEN
4991              NCRITI=I+1
4992              DO II=I+1,IMAX
4993                 CCNCONC(II)=COL*FCCNR(II)
4994                 FCCNR(II)=0.
4995              ENDDO
4996              GOTO 42
4997            ENDIF
4998            IF(RCRITI.GT.RCCN(I).AND.RCRITI.LT.RCCN(I+1)) THEN
4999              NCRITI=I+1
5000              IF(I.NE.IMAX-1) THEN
5001                DO II=NCRITI+1,IMAX
5002                   CCNCONC(II)=COL*FCCNR(II)
5003                   FCCNR(II)=0.
5004                ENDDO
5005              ENDIF
5006              DLN1=ALOG(RCRITI)-ALOG(RCCN(I))
5007              DLN2=COL-DLN1
5008              CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
5009              FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/COL
5010              GOTO 42
5011 ! in case RCRITI.GT.RCCN(I).AND.RCRITI.LT.RCCN(I+1)
5012            END IF
5013       
5015          ENDDO
5016 ! cycle by I, I=IMIN,...,IMAX-1
5018   42    CONTINUE
5019         RETURN
5020         END  SUBROUTINE CCNLOOP
5021        SUBROUTINE ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT,RACTMAX,NKR)
5022        IMPLICIT NONE
5024        INTEGER IMIN,IMAX,NKR
5025        INTEGER I,I0,I1
5026        REAL RCCN(NKR)
5027         REAL  R03,SUPCRITI,RACT(NKR),XKOE
5028         REAL AKOE,BKOE,AKOE23,RACTMAX
5029 ! Spectrum of activated drops                                 (begin) 
5030         DO I=IMIN,IMAX
5032 ! critical water supersaturations appropriating CCN radii
5034            XKOE=(4./27.)*(AKOE**3/BKOE)
5035            AKOE23=AKOE*2./3.
5036            R03=RCCN(I)**3
5037            SUPCRITI=SQRT(XKOE/R03)
5039 ! RACT(I) - radii of activated drops, I=IMIN,...,IMAX
5041            IF(RCCN(I).LE.(0.3E-5)) &
5042      &     RACT(I)=AKOE23/SUPCRITI
5043            IF(RCCN(I).GT.(0.3E-5))&
5044      &     RACT(I)=5.*RCCN(I)
5045         ENDDO
5046 ! cycle by I
5048 ! calculation of I0
5050         I0=IMIN
5052         DO I=IMIN,IMAX-1
5053            IF(RACT(I+1).LT.RACT(I)) THEN
5054              I0=I+1
5055              GOTO 45
5056            ENDIF
5057         ENDDO
5059  45     CONTINUE
5060 ! new changes 9.04.02                                         (begin)
5061         I1=I0-1
5062 ! new changes 9.04.02                                           (end)
5064         IF(I0.EQ.IMIN) GOTO 47
5066 ! new changes 9.04.02                                         (begin)
5068         IF(I0.EQ.IMAX) THEN
5069           RACT(IMAX)=RACT(IMAX-1)
5070           GOTO 47
5071         ENDIF
5073         IF(RACT(IMAX).LE.RACT(I0-1)) THEN
5074           DO I=I0,IMAX
5075              RACT(I)=RACT(I0-1)
5076           ENDDO
5077           GOTO 47
5078         ENDIF
5080 ! new changes 9.04.02                                           (end)
5084 ! calculation of I1
5086         DO I=I0+1,IMAX
5087            IF(RACT(I).GE.RACT(I0-1)) THEN
5088              I1=I
5089              GOTO 46
5090            ENDIF
5091         ENDDO
5092  46     CONTINUE
5094 ! spectrum of activated drops                                   (end)
5097 ! line interpolation RACT(I) for I=I0,...,I1
5099         DO I=I0,I1
5100            RACT(I)=RACT(I0-1)+(I-I0+1)*(RACT(I1)-RACT(I0-1)) &
5101      &                       /(I1-I0+1)
5102         ENDDO
5105   47    CONTINUE
5109         RACTMAX=0.
5111         DO I=IMIN,IMAX
5112            RACTMAX=AMAX1(RACTMAX,RACT(I))
5113         ENDDO
5114         RETURN
5116         END SUBROUTINE ACTIVATE
5117         SUBROUTINE DROPMAX(DROPRADII,RACTMAX,NDROPMAX,NKR)
5118         IMPLICIT NONE
5119         INTEGER IDROP,NKR,NDROPMAX
5120         REAL RACTMAX,DROPRADII(NKR)
5121 ! calculation of NDROPMAX - maximal number of drop bin which
5122 ! is activated
5124         NDROPMAX=1
5126         DO IDROP=1,NKR
5127            IF(RACTMAX.LE.DROPRADII(IDROP)) THEN
5128              NDROPMAX=IDROP
5129              GOTO 44
5130            ENDIF
5131         ENDDO
5132  44     CONTINUE
5133         RETURN
5134         END  SUBROUTINE DROPMAX
5137         SUBROUTINE ONECOND1 &
5138      & (TT,QQ,PP,ROR &
5139      & ,VR1,PSINGLE &
5140      & ,DEL1N,DEL2N,DIV1,DIV2 &
5141      & ,FF1,PSI1,R1,RLEC,RO1BL &
5142      & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
5143      & ,C1_MEY,C2_MEY &
5144      & ,COL,DTCOND,ICEMAX,NKR)
5146        IMPLICIT NONE
5149       INTEGER NKR,ICEMAX
5150       REAL    COL,VR1(NKR),PSINGLE &
5151      &       ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
5152      &       ,DTCOND
5154       REAL C1_MEY,C2_MEY
5155       INTEGER I_ABERGERON,I_BERGERON, &
5156      & KR,ICE,ITIME,KCOND,NR,NRM, &
5157      & KLIMIT, &
5158      & KM,KLIMITL  
5159       REAL AL1,AL2,D,GAM,POD, &
5160      & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
5161      & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
5162      & TPC1, TPC2, TPC3, TPC4, TPC5, &
5163      & EPSDEL, EPSDEL2,DT0L, DT0I,&
5164      & ROR, &
5165      & CWHUCM,B6,B8L,B8I, &
5166      & DEL1,DEL2,DEL1S,DEL2S, &
5167      & TIMENEW,TIMEREV,SFN11,SFN12, &
5168      & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,RW,RI,QW,PW, &
5169      & PI,QI,DEL1N0,DEL2N0,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
5170      & DEL_R1,DT0L0,DT0I0, &
5171      & DTNEWL0, &
5172      & DTNEWL2 
5173        REAL DT_WATER_COND,DT_WATER_EVAP
5175        INTEGER K
5176 ! NEW ALGORITHM OF CONDENSATION (12.01.00)
5178       REAL  FF1_OLD(NKR),SUPINTW(NKR)
5179       DOUBLE PRECISION DSUPINTW(NKR),DD1N,DB11_MY,DAL1,DAL2
5180       DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
5181      &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
5182      &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
5183      &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
5184      &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
5185      &                  ,ES1N,ES2N,EW1N,ARGEXP &
5186      &                  ,TT,QQ,PP &
5187      &                  ,DEL1N,DEL2N,DIV1,DIV2 &
5188      &                  ,OPER2,OPER3,AR1,AR2
5190        DOUBLE PRECISION DELMASSL1
5192 ! DROPLETS 
5193                                                                        
5194         REAL R1(NKR) &
5195      &           ,RLEC(NKR),RO1BL(NKR) &
5196      &           ,FI1(NKR),FF1(NKR),PSI1(NKR) &
5197      &           ,B11_MY(NKR),B12_MY(NKR)
5199 ! WORK ARRAYS 
5201 ! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION
5203        
5204         REAL DTIMEO(NKR),DTIMEL(NKR) &
5205      &           ,TIMESTEPD(NKR)
5207 ! NEW ALGORITHM (NO TYPE OF ICE)
5211         OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
5212         OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
5214         DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
5215      &      ,GAM /1.E-4/, POD /10./ 
5216            
5217         DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
5218      &      /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/
5220         DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
5221      &      /2.53,5.42,3.41E1,6.13/
5223         DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
5224      &      /-4.0,-8.1,-12.7,-17.8,-22.4/ 
5227         DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/  
5228     
5229         DATA DT0L, DT0I /1.E20,1.E20/
5231 ! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
5234 ! CONTROL OF TIMESTEP ITERATIONS IN MIXED PHASE: EVAPORATION
5235         
5236         I_ABERGERON=0
5237         I_BERGERON=0
5238         COL3=3.0*COL
5239         ITIME=0
5240         KCOND=0
5241         DT_WATER_COND=0.4
5242         DT_WATER_EVAP=0.4
5243         ITIME=0
5244         KCOND=0
5245         DT0LREF=0.2
5246         DTLREF=0.4
5248         NR=NKR
5249         NRM=NKR-1
5250         DT=DTCOND
5251         DTT=DTCOND
5252         XRAD=0.
5254 !     BARRY
5255         CWHUCM=0.
5256         XRAD=0.
5257         B6=CWHUCM*GAM-XRAD
5258         B8L=1./ROR
5259         B8I=1./ROR
5260         RORI=1./ROR
5262 ! INITIALIZATION OF SOME ARRAYS
5263 !       print*, 'got to here 0'
5265 !       BARRY: REMOVE RS2 LOOP
5266         DO KR=1,NKR
5267            FF1_OLD(KR)=FF1(KR)
5268            SUPINTW(KR)=0.
5269            DSUPINTW(KR)=0.
5270         ENDDO
5271 ! OLD TREATMENT OF "T" & "Q" 
5272 !DEL12RD=DEL12R**DEL_BBR
5273 ! BARRY
5274 !       EW1PN=AA1_MY*(100.+DEL1IN*100.)*DEL12RD/100.
5275 !       QQIN=OPER4(EW1PN,PP)
5276         TPN=TT
5277         QPN=QQ
5278         DO 19 KR=1,NKR
5279               FI1(KR)=FF1(KR)
5280 19     CONTINUE
5281 ! WARM OR NO ICE (BEGIN)
5282 ! ONLY WATER (CONDENSATION OR EVAPORATION) (BEGIN)
5283               TIMENEW=0.
5284               ITIME=0
5285 ! NEW CHANGES 10.01.01 (BEGIN)
5286               TOLD=TPN
5287               QOLD=QPN
5288 ! NEW CHANGES 10.01.01 (END)
5289    56         ITIME=ITIME+1
5290               TIMEREV=DT-TIMENEW
5291               TIMEREV=DT-TIMENEW
5292               DEL1=DEL1N
5293               DEL2=DEL2N
5294               DEL1S=DEL1N
5295               DEL2S=DEL2N
5296               TPS=TPN
5297               QPS=QPN
5298 ! NO QPS IN JERRATE
5299               CALL JERRATE(R1,TPS,PP,ROR,VR1,PSINGLE &
5300      &                    ,RLEC,RO1BL,B11_MY,B12_MY,1,1,ICEMAX,NKR)
5302 ! INTEGRALS IN DELTA EQUATION (ONLY WATER)
5304 ! CONTROL OF DROP SPECRUM IN SUBROUTINE ONECOND
5307 ! CALL JERTIMESC WATER - 1 (ONLY WATER)
5309               CALL JERTIMESC(FI1,R1,SFN11,SFN12 &
5310      &                      ,B11_MY,B12_MY,RLEC,B8L,1,COL,NKR)        
5313               SFNL=SFN11+SFN12
5314               SFNI=0.       
5316 ! SOME CONSTANTS 
5317               B5L=BB1_MY/TPS/TPS
5318               B5I=BB2_MY/TPS/TPS
5319               B7L=B5L*B6                                                     
5320               B7I=B5I*B6
5321               DOPL=1.+DEL1S                                                     
5322               DOPI=1.+DEL2S                                                     
5323               RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL                                                 
5324               RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
5325               QW=B7L*DOPL
5326               PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
5327               PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
5328               QI=B7I*DOPI
5330 ! SOLVING FOR TIMEZERO
5334               KCOND=10
5336               IF(DEL1.GT.0) KCOND=11
5338 ! PROCESS'S TYPE 
5340               IF(KCOND.EQ.11) THEN
5341 ! NEW TIME STEP IN CONDENSATION (ONLY WATER) (BEGIN)
5342                 IF (DEL1N.EQ.0)THEN
5343                    DTNEWL=DT
5344                 ELSE
5345                  DTNEWL=ABS(R1(ITIME)/(B11_MY(ITIME)*DEL1N &
5346      &                               -B12_MY(ITIME)))
5347                  IF(DTNEWL.GT.DT) DTNEWL=DT
5348                 END IF
5349                 IF(ITIME.GE.NKR) THEN
5350                 call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
5351                 ENDIF
5352                 TIMESTEPD(ITIME)=DTNEWL
5354 ! NEW TIME STEP (ONLY WATER: CONDENSATION)
5357                 IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  & 
5358      &          DTNEWL=DT-TIMENEW
5359                 IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
5361                 TIMESTEPD(ITIME)=DTNEWL
5363                 TIMENEW=TIMENEW+DTNEWL
5365                 DTT=DTNEWL
5367 ! SOLVING FOR SUPERSATURATION 
5369 ! CALL JERSUPSAT - 2 (NEW TIMESTEP - ONLY WATER)
5372                 CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
5373      &                        ,RW,PW,RI,PI,QW,QI &
5374      &                        ,DTT,D1N,D2N,DT0L,DT0I)
5376 ! END OF "NEW SUPERSATURATION"
5378 ! DROPLETS 
5380 ! DROPLET DISTRIBUTION FUNCTION 
5381                                                          
5382 ! CALL JERDFUN WATER - 1 (ONLY WATER: CONDENSATION)
5383                   CALL JERDFUN(R1,B11_MY,B12_MY &
5384      &                        ,FI1,PSI1,D1N &
5385      &                        ,1,1,COL,NKR,TPN)
5387                 IF((DEL1.GT.0.AND.DEL1N.LT.0) &
5388      &         .AND.ABS(DEL1N).GT.EPSDEL) THEN
5389                 call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL1.GT.0.AND.DEL1N.LT.0), model stop")
5390                 ENDIF
5392 ! IN CASE : KCOND.EQ.11
5394               ELSE
5396 ! EVAPORATION - ONLY WATER 
5398 ! IN CASE : KCOND.NE.11
5399                IF (DEL1N.EQ.0)THEN
5400                 DTIMEO(1)=DT
5401                 DO KR=2,NKR
5402                    DTIMEO(KR)=DT
5403                 ENDDO
5404                ELSE
5405                 DTIMEO(1)=-R1(1)/(B11_MY(1)*DEL1N-B12_MY(1))
5407                 DO KR=2,NKR
5408                    KM=KR-1
5409                    DTIMEO(KR)=(R1(KM)-R1(KR))/(B11_MY(KR)*DEL1N &
5410      &                                       -B12_MY(KR))
5411                 ENDDO
5412                END IF
5414                 KLIMIT=1
5416                 DO KR=1,NKR
5417                    IF(DTIMEO(KR).GT.TIMEREV) GOTO 55
5418                    KLIMIT=KR
5419                 ENDDO
5421    55           KLIMIT=KLIMIT-1
5423                 IF(KLIMIT.LT.1) KLIMIT=1
5425 ! BARRY THIS LINE CAUSED A PROBLEM BECAUSE DTNEWL GOES FROM
5426 ! LARGE TO SMALL
5427                 DTNEWL1=AMIN1(DTIMEO(3),TIMEREV)
5428                 IF(DTNEWL1.LT.DTLREF) DTNEWL1=AMIN1(DTLREF,TIMEREV)
5429                 DTNEWL=DTNEWL1
5430                 IF(ITIME.GE.NKR) THEN
5431                 call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
5432                 ENDIF
5434                 TIMESTEPD(ITIME)=DTNEWL
5436 ! NEW TIME STEP (ONLY_WATER: EVAPORATION)
5438                 IF(DTNEWL.GT.DT) DTNEWL=DT
5439                 IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
5440      &          DTNEWL=DT-TIMENEW
5441                 IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
5443                 TIMESTEPD(ITIME)=DTNEWL
5445                 TIMENEW=TIMENEW+DTNEWL
5447                 DTT=DTNEWL
5449 ! SOLVING FOR SUPERSATURATION 
5452 ! CALL JERSUPSAT - 3 (ONLY_WATER: EVAPORATION)
5454                 CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
5455      &                        ,RW,PW,RI,PI,QW,QI &
5456      &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
5457 ! END OF "NEW SUPERSATURATION"
5460 ! DROPLETS 
5463 ! DROPLET DISTRIBUTION FUNCTION (ONLY_WATER: EVAPORATION)
5464                                                          
5465 ! CALL JERDFUN WATER - 2 (ONLY_WATER: EVAPORATION)
5466              
5467                   CALL JERDFUN(R1,B11_MY,B12_MY &
5468      &                        ,FI1,PSI1,D1N &
5469      &                        ,1,1,COL,NKR,TPN)
5471 ! IN CASE : ISYML.NE.0 (ENDING OF 
5472 ! "DROPLET DISTRIBUTION FUNCTION" (ONLY WATER: EVAPORATION)
5474 !        ENDIF
5476                 IF((DEL1.LT.0.AND.DEL1N.GT.0) &
5477      &         .AND.ABS(DEL1N).GT.EPSDEL) THEN
5478                 call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL1.LT.0.AND.DEL1N.GT.0), model stop")
5479                 ENDIF
5481 ! END OF "PROCESS'S TYPE" 
5483 ! IN CASE : KCOND.NE.11 (ONLY WATER: EVAPORATION)
5485               ENDIF
5487 ! IN CASES : KCOND.EQ.11 OR KCOND.NE.11 (BOTH CONDENSATION AND
5488 ! EVAPORATION : ONLY WATER)
5490 ! CONCENTRATION & MASS (ONLY WATER) 
5492       RMASSLBB=0.
5493       RMASSLAA=0.
5495 ! BEFORE JERNEWF (ONLY WATER) 
5497               DO K=1,NKR
5498                  FI1_K=FI1(K)
5499                  R1_K=R1(K)
5500                  FI1R1=FI1_K*R1_K*R1_K
5501                  RMASSLBB=RMASSLBB+FI1R1
5502               ENDDO
5503               RMASSLBB=RMASSLBB*COL3*RORI
5504 ! NEW CHANGE RMASSLBB
5505               IF(RMASSLBB.LE.0.) RMASSLBB=0.
5506               DO K=1,NKR
5507                  FI1_K=PSI1(K)
5508                  R1_K=R1(K)
5509                  FI1R1=FI1_K*R1_K*R1_K
5510                  RMASSLAA=RMASSLAA+FI1R1
5511               ENDDO
5512               RMASSLAA=RMASSLAA*COL3*RORI
5513               IF(RMASSLAA.LE.0.) RMASSLAA=0.
5514 ! NEW TREATMENT OF "T" & "Q" (ONLY WATER)
5515               DELMASSL1=RMASSLAA-RMASSLBB
5516               QPN=QPS-DELMASSL1
5517               DAL1=AL1
5518               TPN=TPS+DAL1*DELMASSL1
5519 ! SUPERSATURATION (ONLY WATER)
5520               ARGEXP=-BB1_MY/TPN
5521               ES1N=AA1_MY*DEXP(ARGEXP)
5522               ARGEXP=-BB2_MY/TPN
5523               ES2N=AA2_MY*DEXP(ARGEXP)
5524               EW1N=OPER3(QPN,PP)
5525               IF(ES1N.EQ.0)THEN
5526                DEL1N=0.5
5527                DIV1=1.5
5528               ELSE
5529                DIV1=EW1N/ES1N
5530                DEL1N=EW1N/ES1N-1.
5531               END IF
5532               IF(ES2N.EQ.0)THEN
5533                DEL2N=0.5
5534                DIV2=1.5
5535               ELSE
5536                DEL2N=EW1N/ES2N-1.
5537                DIV2=EW1N/ES2N
5538               END IF
5539               DO KR=1,NKR
5540                 SUPINTW(KR)=SUPINTW(KR)+B11_MY(KR)*D1N
5541                 DD1N=D1N
5542                 DB11_MY=B11_MY(KR)
5543                 DSUPINTW(KR)=DSUPINTW(KR)+DB11_MY*DD1N
5544               ENDDO
5545 ! REPEATE TIME STEP (ONLY WATER: CONDENSATION OR EVAPORATION) 
5546               IF(TIMENEW.LT.DT) GOTO 56
5547 57            CONTINUE
5548               CALL JERDFUN_NEW(R1,DSUPINTW &
5549      &                        ,FF1_OLD,PSI1,D1N &
5550      &                        ,1,1,COL,NKR,TPN)
5551               RMASSLAA=0.0
5552               RMASSLBB=0.0
5553 ! BEFORE JERNEWF
5554               DO K=1,NKR
5555                  FI1_K=FF1_OLD(K)
5556                  R1_K=R1(K)
5557                  FI1R1=FI1_K*R1_K*R1_K
5558                  RMASSLBB=RMASSLBB+FI1R1
5559               ENDDO
5560               RMASSLBB=RMASSLBB*COL3*RORI
5561 ! NEW CHANGE RMASSLBB
5562               IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
5563 ! AFTER  JERNEWF
5564               DO K=1,NKR
5565                  FI1_K=PSI1(K)
5566                  R1_K=R1(K)
5567                  FI1R1=FI1_K*R1_K*R1_K
5568                  RMASSLAA=RMASSLAA+FI1R1
5569               ENDDO
5570               RMASSLAA=RMASSLAA*COL3*RORI
5571 ! NEW CHANGE RMASSLAA
5572               IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
5573               IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
5574 ! NEW TREATMENT OF "T" & "Q"
5575               DELMASSL1=RMASSLAA-RMASSLBB
5576 ! NEW CHANGES 10.01.01 (BEGIN)
5577               QPN=QOLD-DELMASSL1
5578               DAL1 = AL1
5579               TPN=TOLD+DAL1*DELMASSL1
5580 ! NEW CHANGES 10.01.01 (END)
5581 ! SUPERSATURATION
5582               ARGEXP=-BB1_MY/TPN
5583               ES1N=AA1_MY*DEXP(ARGEXP)
5584               ARGEXP=-BB2_MY/TPN
5585               ES2N=AA2_MY*DEXP(ARGEXP)
5586               EW1N=OPER3(QPN,PP)
5587               IF(ES1N.EQ.0)THEN
5588                DEL1N=0.5
5589                DIV1=1.5
5590               call wrf_error_fatal("fatal error in module_mp_full_sbm (ES1N.EQ.0), model stop")
5591               ELSE
5592                DIV1=EW1N/ES1N
5593                DEL1N=EW1N/ES1N-1.
5594               END IF
5595               IF(ES2N.EQ.0)THEN
5596                DEL2N=0.5
5597                DIV2=1.5
5598               call wrf_error_fatal("fatal error in module_mp_full_sbm (ES2N.EQ.0), model stop")
5599               ELSE
5600                DEL2N=EW1N/ES2N-1.
5601                DIV2=EW1N/ES2N
5602               END IF
5603         TT=TPN
5604         QQ=QPN
5605         DO KR=1,NKR
5606            FF1(KR)=PSI1(KR)
5607         ENDDO
5612        RETURN
5613 !      END 
5615   END SUBROUTINE ONECOND1
5616 !==================================================================
5620 !BARRY
5621         SUBROUTINE JERDFUN(R2,B21_MY,B22_MY &
5622      &                    ,FI2,PSI2,DEL2N &
5623      &                    ,IND,ITYPE,COL,NKR,TPN)
5624        IMPLICIT NONE
5626 ! CRYSTALS 
5627        REAL COL,DEL2N
5628                                                                        
5629       INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,NKR,IDROP
5630        REAL &
5631      &       R2(NKR,IND),R2N(NKR,IND) &
5632      &      ,FI2(NKR,IND),PSI2(NKR,IND) &
5633      &      ,B21_MY(NKR,IND),B22_MY(NKR,IND) &
5634      &      ,DEL_R2M(NKR,IND)
5635         DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
5636         DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND),DDEL2N, &
5637      &     DB21_MY(NKR,IND)
5638        DOUBLE PRECISION CHECK,TPN
5639           CHECK=0.D0
5640            DO KR=1,NKR
5641              CHECK=B21_MY(1,1)*B21_MY(KR,1)
5642              IF (CHECK.LT.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (CHECK.LT.0), model stop")
5643            END DO
5645         IF(IND.NE.1) THEN
5646           ITYP=ITYPE
5647         ELSE
5648           ITYP=1
5649         ENDIF
5651            DDEL2N=DEL2N
5652         DO KR=1,NKR
5653            PSI2R(KR)=FI2(KR,ITYP)
5654            FI2R(KR)=FI2(KR,ITYP)
5655            DR2(KR,ITYP)=R2(KR,ITYP)
5656            DB21_MY(KR,ITYP)=B21_MY(KR,ITYP)
5657         ENDDO
5659 !Q2=0.
5660         NR=NKR
5661         NRM=NKR-1
5663 ! NEW DISTRIBUTION FUNCTION 
5665           DO 8 ICE=1,IND
5666                IF(ITYP.EQ.ICE) THEN
5667                   DO KR=1,NKR
5668                     DR2N(KR,ICE)=DR2(KR,ICE)+DDEL2N*DB21_MY(KR,ICE)
5669                     R2N(KR,ICE)=DR2N(KR,ICE)
5670 !                   IF (D1N.LT.0)THEN
5671 !                    if (DR2N(KR,ICE).EQ.DR2(KR,ICE))THEN
5672 !                       KK=NKR-KR+1
5673 !                       DR2N(KR,ICE)=R2N(KR,ICE)-2.E-15/2**KK
5674 !                    end if
5675 !                   END IF
5677                   ENDDO
5678                 ENDIF
5679     8     CONTINUE
5680 ! CRYSTAL DISTRIBUTION FUNCTION 
5681                                                           
5682           DO ICE=1,IND
5684 ! ICE_TYPE 
5685              IF(ITYP.EQ.ICE) THEN
5686 !       Q2=20.*ITYPE+ICE
5687                DO 5 KR=1,NKR
5688                     R2R(KR)=DR2(KR,ICE)
5689                     R2NR(KR)=DR2N(KR,ICE)               
5690     5         continue
5691 ! Andrei's new change 1.12.09                                 (start)
5692 !            IDROP=1
5693 !            IDROP=0
5694              IF(IND.EQ.1.AND.ITYPE.EQ.1) IDROP=1
5695 ! Andrei's new change 1.12.09                                   (end)
5696              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR &
5697 ! Andrei's new change 1.12.09                                 (start)
5698      &                   ,IDROP,TPN)
5699 ! Andrei's new change 1.12.09                                   (end)
5703 !              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
5704                DO KR=1,NKR                              
5705                   PSI2(KR,ICE)=PSI2R(KR)
5706                ENDDO
5709 ! END OF "ICE_TYPE" 
5711              ENDIF
5713 ! END OF "CRYSTAL DISTRIBUTION FUNCTION" 
5714                                                           
5715           ENDDO
5717 ! END OF "NEW DISTRIBUTION FUNCTION"
5720         RETURN
5721         END SUBROUTINE JERDFUN
5722 !===================================================================
5723         SUBROUTINE JERDFUN_NEW(R2,B21_MY &
5724      &                    ,FI2,PSI2,DEL2N &
5725      &                    ,IND,ITYPE,COL,NKR,TPN)
5726        IMPLICIT NONE
5728 ! CRYSTALS 
5729        REAL COL,DEL2N
5730                                                                        
5731       INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,KK,NKR,IDROP
5732        REAL &
5733      &       R2(NKR,IND),R2N(NKR,IND) &
5734      &      ,FI2(NKR,IND),PSI2(NKR,IND)
5735        DOUBLE PRECISION TPN
5736        DOUBLE PRECISION  B21_MY(NKR,IND)
5737         DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
5738         DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND),DDEL2N, &
5739      &     DB21_MY(NKR,IND)
5740         IF(IND.NE.1) THEN
5741           ITYP=ITYPE
5742         ELSE
5743           ITYP=1
5744         ENDIF
5746            DDEL2N=DEL2N
5747         DO KR=1,NKR
5748            PSI2R(KR)=FI2(KR,ITYP)
5749            FI2R(KR)=FI2(KR,ITYP)
5750            DR2(KR,ITYP)=R2(KR,ITYP)
5751         ENDDO
5753 !Q2=0.
5754         NR=NKR
5755         NRM=NKR-1
5757 ! NEW DISTRIBUTION FUNCTION 
5759 ! CRYSTAL DISTRIBUTION FUNCTION 
5760           DO ICE=1,IND
5761 ! ICE_TYPE 
5762              IF(ITYP.EQ.ICE) THEN
5763                DO 5 KR=1,NKR
5764                     R2R(KR)=DR2(KR,ICE)
5765                     R2NR(KR)=DR2(KR,ICE)+B21_MY(KR,ICE)
5766                     R2N(KR,ICE)=R2NR(KR)
5767 !                   IF (D1N.LT.0)THEN
5768 !                        if (R2NR(KR).EQ.R2R(KR))THEN
5769 !                        KK=NKR-KR+1
5770 !                       R2NR(KR)=R2R(KR)-2.E-15/2**KK
5771 !                     end if
5772 !                   END IF
5773     5         continue
5774 ! Andrei's new change 1.12.09                                 (start)
5775              IDROP=1
5776 !            IDROP=0
5777              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR &
5778      &                   ,IDROP,TPN)
5779 ! Andrei's new change 1.12.09                                   (end)
5782 !              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
5783                DO KR=1,NKR                              
5784                   PSI2(KR,ICE)=PSI2R(KR)
5785                ENDDO
5787 ! END OF "ICE_TYPE" 
5789              ENDIF
5791 ! END OF "CRYSTAL DISTRIBUTION FUNCTION" 
5792                                                           
5793           ENDDO
5795 ! END OF "NEW DISTRIBUTION FUNCTION"
5798         RETURN
5799         END SUBROUTINE JERDFUN_NEW
5800 ! SUBROUTINE JERDFUN_NEW (NEW ALGORITHM OF CONDENSATION, 12.01.00)
5802 ! new change 30.01.06                                         (start)
5803 !       SUBROUTINE JERNEWF(NRX,NRM,RR,FI,PSI,RN,COL,NKR)
5805         SUBROUTINE JERNEWF &
5806        (NRX,NRM,RR,FI_OLD,PSI,RN,COL,NKR, &
5807 ! Andrei's new change 1.12.09                                 (start)           
5808         IDROP,TPN)
5809 ! Andrei's new change 1.12.09                                   (end)   
5811         IMPLICIT NONE
5812         
5813 ! Andrei's new change 1.12.09                                 (start)
5815         INTEGER &
5816         KRDROP_REMAP_MIN,KRDROP_REMAP_MAX,IDROP,KMAX
5817         INTEGER NRX
5818         
5819         DOUBLE PRECISION &
5820         COEFF_REMAP,TPN
5821         
5822         DOUBLE PRECISION & 
5823         CDROP(NRX),DELTA_CDROP(NRX)
5824                 
5825 ! Andrei's new change 1.12.09                                   (end)                           
5827         INTEGER  & 
5828         I,K,KM,NRXP,IM,IP,IFIN,IIN,ISYM,NKR
5830         REAL & 
5831         COL
5833         DOUBLE PRECISION &
5834         AOLDCON,ANEWCON,AOLDMASS,ANEWMASS
5836         DOUBLE PRECISION &
5837         RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, &
5838         GN1,GN1P,GN2,GN3,GMAT2
5840         DOUBLE PRECISION &
5841         DRP,FNEW,FIK,PSINEW,DRM,GMAT,R1,R2,R3,DMASS,CONCL,RRI,RNK
5843         INTEGER NRM
5845         DOUBLE PRECISION & 
5846         RR(NRX),FI(NRX),PSI(NRX),RN(NRX) &
5847        ,RRS(NKR+1),RNS(NKR+1),PSIN(NKR+1),FIN(NKR+1)
5849         DOUBLE PRECISION & 
5850         FI_OLD(NRX)
5851 ! ANDREI                                                      (start) 
5852 ! new change 7.02.06                                          (start)
5853         DOUBLE PRECISION & 
5854         PSI_IM,PSI_I,PSI_IP
5855 ! ANDREI                                                        (end) 
5856 ! new change 7.02.06                                            (end)
5858 ! Andrei's new change 1.12.09                                 (start)           
5860        IF(TPN.LT.273.15-7.0D0) IDROP=0
5861 ! LEAVE REMAPPING ON
5862 !      IDROP=0
5864 ! VALUES FOR SOME REMAPING VARIABLES
5866         KRDROP_REMAP_MIN=8
5867         KRDROP_REMAP_MAX=13 
5868         
5869         COEFF_REMAP=1.0D0/150.0D0 
5870                 
5871 ! Andrei's new change 1.12.09                                   (end)                      
5872         
5873 ! INITIAL VALUES FOR SOME VARIABLES
5875         NRXP=NRX+1
5877         DO K=1,NRX
5878            FI(K)=FI_OLD(K)
5879         ENDDO
5881         DO K=1,NRX
5882            PSI(K)=0.0D0
5883         ENDDO
5884 ! ANDREI                                                      (start) 
5885 ! new change 7.02.06                                          (start)
5887         IF(RN(NRX).NE.RR(NRX)) THEN
5889 ! Kovetz-Olund method                                         (start)
5891 ! ANDREI                                                        (end) 
5892 ! new change 7.02.06                                            (end)
5894           ISYM=1
5896           IF(RN(1).LT.RR(1)) ISYM=-1
5898 ! CALCULATION OF DISTRIBUTION FUNCTION 
5900           IF(ISYM.GT.0) THEN
5901         
5902 ! CONDENSATION 
5904             RNS(NRXP)=1024.0D0*RR(NRX)
5905             RRS(NRXP)=1024.0D0*RR(NRX)
5907             PSIN(NRXP)=0.0D0
5908             FIN(NRXP)=0.0D0
5910             DO K=1,NRX
5911                RNS(K)=RN(K)
5912                RRS(K)=RR(K)
5913                PSIN(K)=0.0D0
5914 ! FIN(K) - initial(before condensation) concentration of hydrometeors
5915                FIN(K)=3.0D0*FI(K)*RR(K)*COL
5916             ENDDO
5918 ! NUMBER OF NEW RADII POSITION IN REGULAR GRID 
5920 ! RNK - new first bin mass(after condensation)
5922             RNK=RNS(1)
5924             DO I=1,NRX
5925                RRI=RRS(I)
5926                IF(RRI.GT.RNK) GOTO 3
5927             ENDDO
5929     3       IIN=I-1
5931             IFIN=NRX
5933             CONCL=0.0D0
5934             DMASS=0.0D0
5935                         
5936             DO 6 I=IIN,IFIN
5938                  IP=I+1
5939                                                                                 
5940                  IM=MAX(1,I-1)
5942                  R1=RRS(IM)
5943                  R2=RRS(I)
5944                  R3=RRS(IP)
5946                  DRM=R2-R1
5947                  DRP=R3-R2
5949                  FNEW=0.0D0
5951                  DO 7 K=1,I
5952                  
5953                       FIK=FIN(K)
5955                       IF(FIK.NE.0.0D0) THEN
5957                         KM=K-1
5959 ! RNK - new bin mass(after condensation)
5961                         RNK=RNS(K)
5963                         IF(RNK.NE.R2) THEN
5964                           GMAT=0.0D0
5965                           IF(RNK.GT.R1.AND.RNK.LT.R3) THEN
5966                             IF(RNK.LT.R2) THEN
5967                               GMAT=(RNK-R1)/DRM
5968                             ELSE
5969                               GMAT=(R3-RNK)/DRP
5970                             ENDIF
5971                           ENDIF
5972                         ELSE
5973                           GMAT=1.0D0
5974                         ENDIF
5976                         FNEW=FNEW+FIK*GMAT
5977 ! in case FIK.NE.0.0D0
5978                       ENDIF
5979                  
5980    7             CONTINUE
5982                  CONCL=CONCL+FNEW
5984                  DMASS=DMASS+FNEW*R2
5986 ! PSIN(I)) - new concentration of hydrometeors after condensation
5988                  PSIN(I)=FNEW
5989                                 
5990    6        CONTINUE
5992 ! NEW VALUES OF DISTRIBUTION FUNCTION
5994 ! PSI(K) - new size distribution function of hydrometeors after 
5995 !          condensation, K=1,...,NRX=NKR
5997             DO K=1,NRX
5998                PSI(K)=PSIN(K)/3./RR(K)/COL
5999             ENDDO
6001 ! IN CASE: ISYM.GT.0 (CONDENSATION)
6002         
6003           ELSE
6005 ! IN CASE: ISYM.LE.0 (EVAPORATION)
6007             RNS(1)=0.0D0
6008             RRS(1)=0.0D0
6009             FIN(1)=0.0D0
6010             PSIN(1)=0.0D0
6012 ! FIN(K) - initial(before evaporation) concentration of hydrometeors
6014             DO K=2,NRXP
6015                KM=K-1
6016                RNS(K)=RN(KM)
6017                RRS(K)=RR(KM)
6018                PSIN(K)=0.0D0
6019                FIN(K)=3.0D0*FI(KM)*RR(KM)*COL
6020             ENDDO
6022             DO I=1,NRXP
6024                IM=MAX(I-1,1)
6025                IP=MIN(I+1,NRXP)
6027                R1=RRS(IP)
6028                R2=RRS(I)
6029                R3=RRS(IM)
6031                DRM=R1-R2
6032                DRP=R2-R3
6034                FNEW=0.0D0
6036                DO K=I,NRXP
6037                   RNK=RNS(K)
6038                   IF(RNK.GE.R1) GOTO 4321
6039                   IF(RNK.GT.R3)THEN
6040                     IF(RNK.GT.R2) THEN
6041                       FNEW=FNEW+FIN(K)*(R1-RNK)/DRM
6042                     ELSE
6043                       FNEW=FNEW+FIN(K)*(RNK-R3)/DRP
6044                     ENDIF
6045                   ENDIF
6046                ENDDO
6048  4321          CONTINUE
6050 ! PSIN(I) - new concentration of hydrometeors after evaporation
6052                PSIN(I)=FNEW
6053         
6054             ENDDO
6055 ! cycle by I
6057 ! NEW VALUES OF DISTRIBUTION FUNCTION                         (start)
6059 ! PSI(K), 1/g/cm^3 - new size distribution function of hydrometeors 
6060 !                    after evaporation, K=1,...,NRX
6061             DO K=2,NRXP
6062                KM=K-1
6063                R1=PSIN(K)*RR(KM)
6064                PSINEW=PSIN(K)/3.0D0/RR(KM)/COL
6065                IF(R1.LT.1.0D-20) PSINEW=0.0D0
6066                PSI(KM)=PSINEW
6067             ENDDO
6069 ! NEW VALUES OF DISTRIBUTION FUNCTION                           (end)
6071 ! IN CASE: ISYM.LE.0 (EVAPORATION)
6073           ENDIF
6074         
6075 ! Andrei's new change 1.12.09                                 (start)
6076           IF(I3POINT.NE.0.AND.ISYM.GT.0) THEN
6077 ! DIFFERENCE
6078 !         IF(I3POINT.NE.0) THEN
6079 ! Andrei's new change 1.12.09                                   (end)                      
6081             DO K=1,NKR
6082                RRS(K)=RR(K)
6083             ENDDO
6085             RRS(NKR+1)=RRS(NKR)*1024.0D0
6087             DO I=1,NKR
6089                PSI(I)=PSI(I)*RR(I)
6091 ! PSI(I) - concenration hydrometeors after KO divided on COL*3.0D0
6092 ! RN(I), g - new masses after condensation or evaporation
6094                IF(RN(I).LT.0.0D0) THEN 
6095                  RN(I)=1.0D-50
6096                  FI(I)=0.0D0
6097                ENDIF
6099             ENDDO
6101             DO K=1,NKR
6103                IF(FI(K).NE.0.0D0) THEN
6105                  IF(RRS(2).LT.RN(K)) THEN
6107                    I=2
6109                    DO  WHILE &
6110                      (.NOT.(RRS(I).LT.RN(K).AND.RRS(I+1).GT.RN(K)) &
6111                       .AND.I.LT.NKR)
6112                        I=I+1
6113                    ENDDO
6114 ! ANDREI                                                      (start) 
6115 ! new change 7.02.06                                          (start)
6116                    IF(I.LT.NKR-2) THEN
6117 ! new change 7.02.06                                            (end)
6118 ! ANDREI                                                        (end)
6119                      RNTMP=RN(K)
6121                      RRTMP=RRS(I)
6122                      RRP=RRS(I+1)
6123                      RRM=RRS(I-1)
6125                      RNTMP2=RN(K+1)
6127                      RRTMP2=RRS(I+1)
6128                      RRP2=RRS(I+2)
6129                      RRM2=RRS(I)
6131                      GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ &
6132                        (RRTMP-RRM)
6134                      GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ &
6135                         (RRP2-RRM2)/(RRTMP2-RRM2)
6137                      GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ &
6138                        (RRTMP-RRM)
6140                      GMAT=(RRP-RNTMP)/(RRP-RRTMP)
6141 ! ANDREI                                                      (start) 
6142 ! new change 7.02.06                                          (start)
6143                      GN3=(RRTMP-RNTMP)*(RRM-RNTMP)/(RRP-RRM)/ &
6144                                                  (RRP-RRTMP)
6145                      GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
6147                      PSI_IM=PSI(I-1)+GN1*FI(K)*RR(K)
6148 ! Andrei's new change 1.12.09                                 (start)           
6149 !                    PSI_I=PSI(I)+(GN1P+GN2-GMAT)*FI(K+1)*RR(K+1)
6151                      PSI_I=PSI(I)+GN1P*FI(K+1)*RR(K+1)+&
6152                                  (GN2-GMAT)*FI(K)*RR(K)
6153 ! Andrei's new change 1.12.09                                   (end)           
6154                      PSI_IP=PSI(I+1)+(GN3-GMAT2)*FI(K)*RR(K)
6155                     
6156                      IF(PSI_IM.GT.0.0D0) THEN
6158                        IF(PSI_IP.GT.0.0D0) THEN
6160                          IF(I.GT.2) THEN
6161 ! smoothing criteria
6162                            IF(PSI_IM.GT.PSI(I-2).AND.PSI_IM.LT.PSI_I &
6163                           .AND.PSI(I-2).LT.PSI(I).OR.PSI(I-2) &
6164                           .GE.PSI(I)) THEN
6166                              PSI(I-1)=PSI_IM
6168                              PSI(I)=PSI(I)+FI(K)*RR(K)*(GN2-GMAT)
6170                              PSI(I+1)=PSI_IP
6172 ! in case smoothing criteria
6174                            ENDIF 
6175 ! in case I.GT.2
6176                          ENDIF
6178 ! in case PSI_IP.GT.0.0D0
6180                        ENDIF
6182 ! in case PSI_IM.GT.0.0D0
6184                      ENDIF
6186 ! in case I.LT.NKR-2
6188                    ENDIF
6189 ! new change 7.02.06                                            (end)
6190 ! ANDREI                                                        (end)
6191 ! in case RRS(2).LT.RN(K)
6193                  ENDIF
6195 ! in case FI(K).NE.0.0D0
6197                ENDIF
6199  1000          CONTINUE
6201             ENDDO
6202 ! cycle by K
6203             AOLDCON=0.0D0
6204             ANEWCON=0.0D0
6205             AOLDMASS=0.0D0
6206             ANEWMASS=0.0D0
6208             DO K=1,NKR
6209                AOLDCON=AOLDCON+FI(K)*RR(K)
6210                ANEWCON=ANEWCON+PSI(K)
6211                AOLDMASS=AOLDMASS+FI(K)*RR(K)*RN(K)
6212                ANEWMASS=ANEWMASS+PSI(K)*RR(K)
6213             ENDDO
6215 ! new change 8.02.06                                          (start)
6216 ! ANDREI                                                      (start)
6218 ! PSI(K) - new hydrometeor size distribution function(sdf)
6220             DO K=1,NKR
6221                PSI(K)=PSI(K)/RR(K)
6222             ENDDO
6223           
6224 ! new change 8.02.06                                            (end)          
6225 ! ANDREI                                                        (end)
6227 ! 3 point method                                                (end)          
6228                                                                                
6229 ! in case I3POINT.NE.0.AND.ISYM.GT.0                                                             
6230                                                                                     
6231           ENDIF
6233 ! Andrei's new change 1.12.09                                 (start)           
6235           IF(IDROP.NE.0.AND.ISYM.GT.0) THEN
6236           
6237             DO K=KRDROP_REMAP_MIN,KRDROP_REMAP_MAX
6238                CDROP(K)=3.0D0*COL*PSI(K)*RR(K)
6239             ENDDO
6240                                                                                  
6241 ! KMAX - right boundary of drop sdf spectrum
6242 !(KRDROP_REMAP_MIN =< KMAX =< KRDROP_REMAP_MAX)
6244             DO K=KRDROP_REMAP_MAX,KRDROP_REMAP_MIN,-1
6245                KMAX=K
6246                IF(PSI(K).GT.0.0D0) GOTO 2011
6247             ENDDO
6249  2011       CONTINUE
6251 ! Andrei start
6252 !           DO K=KMAX-1,1,-1
6253 ! Andre end
6254 !Alex, Andrei, Barry
6255             DO K=KMAX-1,KRDROP_REMAP_MIN,-1
6256 !Alex, Andrei, Barry
6257                IF(CDROP(K).GT.1.d-20) THEN
6258                  DELTA_CDROP(K)=CDROP(K+1)/CDROP(K)
6259                  IF(DELTA_CDROP(K).LT.COEFF_REMAP) THEN
6260                    CDROP(K)=CDROP(K)+CDROP(K+1)
6261                    CDROP(K+1)=0.0D0
6262                  ENDIF
6263                ENDIF
6264             ENDDO
6265             
6266             DO K=KRDROP_REMAP_MIN,KMAX
6267                PSI(K)=CDROP(K)/(3.0D0*COL*RR(K))
6268             ENDDO
6269             
6270 ! in case IDROP.NE.0.AND.ISYM.GT.0
6271                       
6272           ENDIF
6273                   
6274 ! Andrei's new change 1.12.09                                   (end)           
6275 ! ANDREI                                                      (start) 
6276 ! new change 8.02.06                                          (start)
6278 ! in case RN(NRX).NE.RR(NRX)
6280         ELSE
6282 ! in case RN(NRX).EQ.RR(NRX)
6284           DO K=1,NKR
6285              PSI(K)=FI(K)
6286           ENDDO
6288         ENDIF
6290 ! new change 8.02.06                                            (end)           
6291 ! ANDREI                                            
6293         RETURN 
6295 ! SUBROUTINE JERNEWF
6296         END SUBROUTINE JERNEWF
6298 ! BARRY REMOVED QP,ROR
6299         SUBROUTINE JERRATEOLD(R1S,TP,PP,ROR,VR1,PSINGLE,RIEC,RO1BL &
6300      &                    ,B11_MY,B12_MY,ID,IN,ICEMAX,NKR)
6301        IMPLICIT NONE
6302        INTEGER ID,IN,KR,ICE,NRM,ICEMAX,NKR
6303       DOUBLE PRECISION TP,PP
6304       REAL DETL,FACTPL,VENTPL,VR1K,CONSTL,RO1,RVT,D_MY, &
6305      & CONST
6306        REAL VR1(NKR,ID),PSINGLE,ROR
6307         REAL       &
6308      & R1S(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
6309      &,RO1BL(NKR,ID),RIEC(NKR,ID) &
6310      &,VR1KL(NKR,ICEMAX),VENTRL(NKR,ICEMAX) &
6311      &,FD1(NKR,ICEMAX),FK1(NKR,ICEMAX),FACTRL(NKR,ICEMAX) &
6312      &,R11_MY(NKR,ICEMAX),R12_MY(NKR,ICEMAX) &
6313      &,R1_MY1(NKR,ICEMAX),R1_MY2(NKR,ICEMAX),R1_MY3(NKR,ICEMAX) &
6314      &,AL1(2),AL1_MY(2),A1_MY(2),BB1_MY(2),ESAT1(2),CONSTLI(ICEMAX)
6315       DOUBLE PRECISION TZERO
6316       REAL PZERO,CF_MY,D_MYIN,RV_MY
6317       PARAMETER (TZERO=273.150,PZERO=1.013E6)
6318       DATA AL1/2500.,2833./
6319         CONST=12.566372
6320         AL1_MY(1)=2.5E10
6321         AL1_MY(2)=2.834E10
6322         A1_MY(1)=2.53E12
6323         A1_MY(2)=3.41E13
6324         BB1_MY(1)=5.42E3
6325         BB1_MY(2)=6.13E3
6326         CF_MY=2.4E3
6327         D_MYIN=0.221
6328         RV_MY=461.5E4
6329         NRM=NKR-1
6331 ! RHS FOR "MAXWELL" EQUATION 
6333         D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94
6334         RVT=RV_MY*TP
6335         ESAT1(IN)=A1_MY(IN)*EXP(-BB1_MY(IN)/TP)
6337         DO 1 ICE=1,ID
6338              DO 1 KR=1,NKR
6339              RO1=RO1BL(KR,ICE)
6340              CONSTL=CONST*RIEC(KR,ICE)
6341              CONSTLI(ICE)=CONSTL
6342              VR1K=0.
6343              VR1KL(KR,ICE)=VR1K
6344              VENTPL=1.
6345              VENTRL(KR,ICE)=VENTPL
6346              FACTPL=1.
6347              FACTRL(KR,ICE)=FACTPL
6348              FD1(KR,ICE)=RVT/D_MY/ESAT1(IN)/FACTPL
6349              FK1(KR,ICE)=(AL1_MY(IN)/RVT-1.)*AL1_MY(IN)/CF_MY/TP
6350              R1_MY1(KR,ICE)=VENTPL*CONSTL
6351              R11_MY(KR,ICE)=R1_MY1(KR,ICE)
6352 !BARRY
6353 !     R1_MY2(KR,ICE)=VENTPL*CONSTL*0.
6354 !     R1_MY3(KR,ICE)=VENTPL*CONSTL*0.
6355 !     R12_MY(KR,ICE)=R1_MY2(KR,ICE)-R1_MY3(KR,ICE)
6356 !BARRY
6357 ! GROWTH RATE
6359              DETL=FK1(KR,ICE)+FD1(KR,ICE)
6360              B11_MY(KR,ICE)=R11_MY(KR,ICE)/DETL
6361 !BARRY     B12_MY(KR,ICE)=R12_MY(KR,ICE)/DETL
6362            B12_MY(KR,ICE)=0                       
6363     1   CONTINUE
6365         RETURN
6366         END SUBROUTINE JERRATEOLD
6368 ! SUBROUTINE JERRATE
6369 !========================================================================
6370 !BARRY    CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N
6371 !    *                        ,RW,PW,RI,PI,QW,QI
6372 ! SUBROUTINE JERNEWF
6373 !=========================================================================
6374 ! BARRY REMOVED QP
6375         SUBROUTINE JERRATE(R1S,TP,PP,ROR,VR1,PSINGLE,RIEC,RO1BL &
6376      &                    ,B11_MY,B12_MY,ID,IN,ICEMAX,NKR)
6377        IMPLICIT NONE
6378        INTEGER ID,IN,KR,ICE,NRM,ICEMAX,NKR
6379       DOUBLE PRECISION TP,PP
6380       REAL DETL,FACTPL,VENTPL,VR1K,CONSTL,RO1,RVT,D_MY, &
6381      & CONST
6382         REAL VR1(NKR,ID),PSINGLE &
6383      &,R1S(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
6384      &,RO1BL(NKR,ID),RIEC(NKR,ID) &
6385      &,VR1KL(NKR,ICEMAX),VENTRL(NKR,ICEMAX) &
6386      &,FD1(NKR,ICEMAX),FK1(NKR,ICEMAX),FACTRL(NKR,ICEMAX) &
6387      &,R11_MY(NKR,ICEMAX),R12_MY(NKR,ICEMAX) &
6388      &,R1_MY1(NKR,ICEMAX),R1_MY2(NKR,ICEMAX),R1_MY3(NKR,ICEMAX) &
6389      &,AL1(2),AL1_MY(2),A1_MY(2),BB1_MY(2),ESAT1(2),CONSTLI(ICEMAX)
6390       DOUBLE PRECISION TZERO
6391       REAL PZERO,CF_MY,D_MYIN,RV_MY,DEG01,DEG03
6392       REAL COEFF_VISCOUS,SHMIDT_NUMBER,A,B
6393       REAL REINOLDS_NUMBER,RESHM,ROR
6394       PARAMETER (TZERO=273.150,PZERO=1.013E6)
6395       DATA AL1/2500.,2833./
6396         DEG01=1./3.     
6397         DEG03=1./3.     
6398         CONST=12.566372
6399         AL1_MY(1)=2.5E10
6400         AL1_MY(2)=2.834E10
6401         A1_MY(1)=2.53E12
6402         A1_MY(2)=3.41E13
6403         BB1_MY(1)=5.42E3
6404         BB1_MY(2)=6.13E3
6405         CF_MY=2.4E3
6406         D_MYIN=0.221
6407         RV_MY=461.5E4
6408         NRM=NKR-1
6409 ! rhs for "maxwell" equation
6410 ! coefficient of diffusion
6411         D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94
6412 ! new change 20.04.02
6413 ! coefficient of viscousity
6414         COEFF_VISCOUS=1.72E-2*SQRT(TP/273.)*393./(TP-120.)/ROR
6415 ! Shmidt number
6416         SHMIDT_NUMBER=COEFF_VISCOUS/D_MY
6417 ! Constants used for calculation of Reinolds number
6418         A=2.*(3./4./3.141593)**DEG01
6419         B=A/COEFF_VISCOUS
6420         
6421         RVT=RV_MY*TP
6422         ESAT1(IN)=A1_MY(IN)*EXP(-BB1_MY(IN)/TP)
6423         DO ICE=1,ID
6424            DO KR=1,NKR
6425 ! Reinolds numbers
6426               REINOLDS_NUMBER= &
6427      &        B*VR1(KR,ICE)*SQRT(1.E6/PSINGLE)* &
6428      &        (R1S(KR,ICE)/RO1BL(KR,ICE))**DEG03
6429               RESHM=SQRT(REINOLDS_NUMBER)*SHMIDT_NUMBER**DEG03
6430               IF(REINOLDS_NUMBER.LT.2.5) THEN
6431                 VENTPL=1.+0.108*RESHM*RESHM
6432               ELSE
6433                 VENTPL=0.78+0.308*RESHM
6434               ENDIF
6435 ! new change 20.04.02                                           (end)
6436               CONSTL=CONST*RIEC(KR,ICE)                         
6437               CONSTLI(ICE)=CONSTL
6438 !             VR1K=0.
6439 !             VR1KL(KR,ICE)=VR1K
6440 ! new change 20.04.02                                         (begin)
6441 !             VENTPL=1.                                       
6442 !             VENTRL(KR,ICE)=VENTPL                           
6443 ! new change 20.04.02                                           (end)
6444               FACTPL=1.                                         
6445               FACTRL(KR,ICE)=FACTPL                             
6446               FD1(KR,ICE)=RVT/D_MY/ESAT1(IN)/FACTPL             
6447               FK1(KR,ICE)=(AL1_MY(IN)/RVT-1.)*AL1_MY(IN)/CF_MY/TP
6448               R1_MY1(KR,ICE)=VENTPL*CONSTL
6449 !             R1_MY2(KR,ICE)=VENTPL*CONSTL*0.
6450 !             R1_MY3(KR,ICE)=VENTPL*CONSTL*0.
6451               R11_MY(KR,ICE)=R1_MY1(KR,ICE)
6452 !BARRY        R12_MY(KR,ICE)=R1_MY2(KR,ICE)-R1_MY3(KR,ICE)
6453 ! growth rate 
6454               DETL=FK1(KR,ICE)+FD1(KR,ICE)
6455               B11_MY(KR,ICE)=R11_MY(KR,ICE)/DETL
6456 !BARRY        B12_MY(KR,ICE)=R12_MY(KR,ICE)/DETL
6457               B12_MY(KR,ICE)=0.
6458            ENDDO
6459         ENDDO
6462         RETURN
6463         END SUBROUTINE JERRATE
6465 ! SUBROUTINE JERRATE
6466 !========================================================================
6467 !BARRY    CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N
6468 !    *                        ,RW,PW,RI,PI,QW,QI
6469 !    *                        ,DTT,D1N,D2N,DT0L,DT0I)
6470         SUBROUTINE JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
6471      &                      ,RW,PW,RI,PI,QW,QI &
6472      &                      ,DT,DEL1INT,DEL2INT,DT0L,DT0I)
6473       IMPLICIT NONE
6474    
6475       INTEGER ITYPE
6476       REAL DEL1,DEL2,RW,PW,RI,PI,QW,QI, &
6477      &  DT,DEL1INT,DEL2INT,DT0L,DT0I,DTLIN,DTIIN
6478       REAL DETER,DBLRW,DBLPW,DBLPI,DBLRI, &
6479      &  DBLDEL1,DBLDEL2,DBLDEL1INT,DBLDTLIN,DBLDTIIN, &
6480      &  EXPM,EXPP,ALFAMX,ALFAPX,X,ALFA,DELX,DBLDEL2INT, &
6481      &  R1RES,R2RES,R1,R2,R3,R4,R21,R11,R10,R41,R31,R30,DBLDT, &
6482      &  DBLDEL1N,DBLDEL2N
6483       DOUBLE PRECISION DEL1N,DEL2N
6485         DOUBLE PRECISION DEL1N_2P,DEL1INT_2P,DEL2N_2P,DEL2INT_2P 
6486         DOUBLE PRECISION EXPP_2P,EXPM_2P,ARGEXP     
6487 ! BARRY
6488       DOUBLE PRECISION RW_DP,PW_DP,PI_DP,RI_DP,X_DP,ALFA_DP
6489 !    * ,ALFAPX_DP
6490 ! Andrei's new change 9.03.10                                 (start)
6491       DOUBLE PRECISION  EXPM1
6492       EXPM1(x_dp)= &
6493      &x_dp+x_dp*x_dp/2.0D0+x_dp*x_dp*x_dp/6.0D0+x_dp*x_dp*x_dp*x_dp/24.0D0+x_dp*x_dp*x_dp*x_dp*x_dp/120.0D0
6494       DOUBLE PRECISION  DETER_MIN
6495 ! Andrei's new change 9.03.10                                 (start)
6497       DOUBLE PRECISION EXP1, EXP2
6499 ! Andrei's new change 9.03.10                                   (end)
6500         DTLIN=1000.E17
6501         DTIIN=1000.E17
6502 ! Andrei's new change 9.03.10                                 (start)
6503       DETER=RW*PI-PW*RI
6504 !     DETER_MIN=1.0D-20
6505 ! Andrei's new change 9.03.10                                 (end)
6506 ! SOLUTION  
6507 !IF(DETER.EQ.0)  THEN
6508        IF(RW.EQ.0.AND.RI.EQ.0) THEN
6509 ! NO CLOUD: WITHOUT WATER & ICE
6510             DEL1N_2P=DEL1
6511             DEL2N_2P=DEL2
6512             DEL1INT_2P=DEL1*DT
6513             DEL2INT_2P=DEL2*DT
6514 ! IN CASE: RW.NE.0 OR RI.NE.0 (WATER OR ICE) 
6515        ELSE IF(RW.NE.0.AND.RI*1.E5.LT.RW) THEN
6516 ! ONLY WATER
6517               ARGEXP=-RW*DT
6519               DEL1N_2P=DEL1*DEXP(ARGEXP)+QW*(1.-DEXP(ARGEXP))
6520               DEL1INT_2P=(DEL1-DEL1N_2P)/RW
6521               DEL2N_2P=DEL2-PW*DEL1INT_2P
6522               DEL2INT_2P= &
6523      &       (DEL2N_2P-PW*DEL1N_2P/RW)*DT+PW*DEL1INT_2P/RW
6524         ELSE IF(RI.NE.0.AND.RW*1.E5.LT.RI) THEN
6525 ! IN CASE: RW.EQ.0
6526 ! ONLY ICE 
6527               ARGEXP=-PI*DT
6529               DEL2N_2P=DEL2*DEXP(ARGEXP)+QI*(1.-DEXP(ARGEXP))
6530               DEL2INT_2P=(DEL2-DEL2N_2P)/PI
6531               DEL1N_2P=DEL1-RI*DEL2INT_2P
6532               DEL1INT_2P= &
6533      &       (DEL1N_2P-RI*DEL2N_2P/PI)*DT+RI*DEL2INT_2P/PI
6534 !             GOTO 100
6535 ! IN CASE: RW.NE.0 OR RI.NE.0 (WATER OR ICE)
6536 ! IN CASE: DETER.EQ.0
6537         ELSE
6538 ! IN CASE: DETER.NE.0
6539 ! COMPLETE SOLUTION 
6540 !  ALFA=SQRT((RW-PI)*(RW-PI)+4.*PW*RI)
6541 !  X=RW+PI
6542 !  ALFAPX=.5*(ALFA+X)
6543 ! BARRY 
6544           RW_DP=RW
6545           RI_DP=RI
6546           PI_DP=PI
6547           PW_DP=PW
6548           IF (RW.LE.0)PRINT*,'RW = ',RW
6549           IF (PW.LE.0)PRINT*,'PW = ',PW
6550           IF (RI.LE.0)PRINT*,'RI = ',RI
6551           IF (PI.LE.0)PRINT*,'PI = ',PI
6552           IF (RW.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (RW.LE.0), model stop")
6553           IF (PW.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (PW.LE.0), model stop")
6554           IF (RI.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (RI.LE.0), model stop")
6555           IF (PI.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (PI.LE.0), model stop")
6556           ALFA_DP=SQRT((RW_DP-PI_DP)*(RW_DP-PI_DP)+4.*PW_DP*RI_DP) 
6557           X_DP=RW_DP+PI_DP
6558           ALFAPX=.5*(ALFA_DP+X_DP)
6559           IF (ALFAPX.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (ALFAPX.LE.0), model stop") 
6560           ALFAMX=.5*(ALFA_DP-X_DP)
6563           ARGEXP=-ALFAPX*DT
6564 ! Andrei 11/04/10
6565           EXPP_2P=DEXP(ARGEXP)
6566           IF(DABS(ARGEXP).LE.1.0E-6) THEN
6567                EXP1=EXPM1(ARGEXP)
6568           ELSE
6569                EXP1=EXPP_2P-1.0D0
6570           ENDIF
6572           ARGEXP=ALFAMX*DT
6573 !Andre 11/04/10
6574           EXPM_2P=DEXP(ARGEXP)
6575               IF(DABS(ARGEXP).LE.1.0E-6) THEN
6576                 EXP2=EXPM1(ARGEXP)
6577               ELSE
6578                 EXP2=EXPM_2P-1.0D0
6579               ENDIF
6581 ! DROPLETS 
6582           R10=RW*DEL1+RI*DEL2
6583           R11=R10-ALFAPX*DEL1
6584           R21=R10+ALFAMX*DEL1
6585           DEL1N_2P=(R21*EXPP_2P-R11*EXPM_2P)/ALFA_DP
6586 ! BARRY
6587           IF(ALFAMX.NE.0) THEN
6588             R1=-R11/ALFAMX
6589             R2=R21/ALFAPX
6590 !    DEL1INT_2P=(R1*(EXPM_2P-1.)-R2*(EXPP_2P-1.))/ALFA_DP
6591             DEL1INT_2P=(R1*EXP2-R2*EXP1)/ALFA_DP
6592           ELSE
6593             DEL1INT_2P = 0.
6594           ENDIF
6595 ! BARRY
6596           R1RES=0.
6597           IF(R11.NE.0) R1RES=R21/R11
6598           IF(R1RES.GT.0) DTLIN=ALOG(R1RES)/ALFA_DP
6599 ! ICE 
6600           R30=PW*DEL1+PI*DEL2
6601           R31=R30-ALFAPX*DEL2
6602           R41=R30+ALFAMX*DEL2
6603 ! BARRY
6604           DEL2N_2P=(R41*EXPP_2P-R31*EXPM_2P)/ALFA_DP
6605           IF(ALFAMX.NE.0.AND.ALFAPX.NE.0) THEN
6606             R3=-R31/ALFAMX
6607             R4=R41/ALFAPX
6608 !           DEL2INT_2P=(R3*(EXPM_2P-1.)-R4*(EXPP_2P-1.))/ALFA_DP
6609             DEL2INT_2P=(R3*EXP2-R4*EXP1)/ALFA_DP
6610           ELSE
6611             DEL2INT_2P=0.
6612           ENDIF
6613           R2RES=0.
6614           IF(R31.NE.0) R2RES=R41/R31
6615           IF(R2RES.GT.0) DTIIN=ALOG(R2RES)/ALFA_DP
6616 ! IN CASE: DETER.NE.0
6617 ! END OF COMPLETE SOLUTION
6618         ENDIF
6619 ! IN CASES: DETER.EQ.0 OR DETER.NE.0
6620  100    CONTINUE
6621         DEL1N=DEL1N_2P
6622         DEL2N=DEL2N_2P
6623        
6624 ! BARRY
6625         DEL1INT=DEL1INT_2P
6626         DEL2INT=DEL2INT_2P
6627         DT0L=DTLIN
6628         IF(DT0L.LT.0) DT0L=1.E20
6629         DT0I=DTIIN
6630         IF(DT0I.LT.0) DT0I=1.E20
6631         RETURN
6632         END SUBROUTINE JERSUPSAT
6633 !==========================================================================
6634         SUBROUTINE JERTIMESC(FI1,X1,SFN11,SFN12 &
6635      &                      ,B11_MY,B12_MY,RIEC,CF,ID,COL,NKR)        
6636       IMPLICIT NONE
6637        INTEGER NRM,KR,ICE,ID,NKR
6638       REAL B12,B11,FUN,DELM,FK,CF,SFN12S,SFN11S
6639         REAL  COL, &
6640      & X1(NKR,ID),FI1(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
6641      &,RIEC(NKR,ID),SFN11,SFN12
6643         NRM=NKR-1
6644         DO 1 ICE=1,ID  
6645              SFN11S=0.                              
6646              SFN12S=0.
6647              SFN11=CF*SFN11S    
6648              SFN12=CF*SFN12S
6649              DO KR=1,NRM
6650 ! VALUE OF DISTRIBUTION FUNCTION
6651                 FK=FI1(KR,ICE)
6652 ! DELTA-M 
6653                 DELM=X1(KR,ICE)*3.*COL
6654 ! INTEGRAL'S EXPRESSION 
6655                 FUN=FK*DELM
6656 ! VALUES OF INTEGRALS
6657                 B11=B11_MY(KR,ICE)
6658                 B12=B12_MY(KR,ICE)
6659                 SFN11S=SFN11S+FUN*B11                               
6660                 SFN12S=SFN12S+FUN*B12
6661              ENDDO
6662 ! CORRECTION 
6663              SFN11=CF*SFN11S
6664              SFN12=CF*SFN12S
6665     1   CONTINUE
6666 ! END 
6667         RETURN
6668         END SUBROUTINE JERTIMESC
6670         SUBROUTINE JERTIMESC_ICE(FI1,X1,SFN11,SFN12 &
6671      &                      ,B11_MY,B12_MY,RIEC,CF,ID,COL,NKR)        
6672       IMPLICIT NONE
6673        INTEGER NRM,KR,ICE,ID,NKR
6674       REAL B12,B11,FUN,DELM,FK,CF,SFN12S,SFN11S
6675         REAL  COL, &
6676      & X1(NKR,ID),FI1(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
6677      &,RIEC(NKR,ID),SFN11(ID),SFN12(ID)
6679         NRM=NKR-1
6680         DO 1 ICE=1,ID  
6681              SFN11S=0.                              
6682              SFN12S=0.
6683              SFN11(ICE)=CF*SFN11S       
6684              SFN12(ICE)=CF*SFN12S
6685              DO KR=1,NRM
6686 ! VALUE OF DISTRIBUTION FUNCTION
6687                 FK=FI1(KR,ICE)
6688 ! DELTA-M 
6689                 DELM=X1(KR,ICE)*3.*COL
6690 ! INTEGRAL'S EXPRESSION 
6691                 FUN=FK*DELM
6692 ! VALUES OF INTEGRALS
6693                 B11=B11_MY(KR,ICE)
6694                 B12=B12_MY(KR,ICE)
6695                 SFN11S=SFN11S+FUN*B11                               
6696                 SFN12S=SFN12S+FUN*B12
6697              ENDDO
6698 ! CORRECTION 
6699              SFN11(ICE)=CF*SFN11S
6700              SFN12(ICE)=CF*SFN12S
6701     1   CONTINUE
6702 ! END 
6703         RETURN
6704         END SUBROUTINE JERTIMESC_ICE
6707         SUBROUTINE ONECOND2 &
6708      & (TT,QQ,PP,ROR  &
6709      & ,VR2,VR3,VR4,VR5,PSINGLE &
6710      & ,DEL1N,DEL2N,DIV1,DIV2 &
6711      & ,FF2,PSI2,R2,RIEC,RO2BL &
6712      & ,FF3,PSI3,R3,RSEC,RO3BL &
6713      & ,FF4,PSI4,R4,RGEC,RO4BL &
6714      & ,FF5,PSI5,R5,RHEC,RO5BL &
6715      & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
6716      & ,C1_MEY,C2_MEY &
6717      & ,COL,DTCOND,ICEMAX,NKR &
6718      & ,ISYM2,ISYM3,ISYM4,ISYM5)
6720        IMPLICIT NONE
6722       INTEGER NKR,ICEMAX
6723       REAL    COL,VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
6724      &           ,VR5(NKR),PSINGLE &
6725      &       ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
6726      &       ,DTCOND
6728       REAL C1_MEY,C2_MEY
6729       INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON, &
6730      & KR,ICE,ITIME,ICM,KCOND,NR,NRM,INUC, &
6731      & ISYM2,ISYM3,ISYM4,ISYM5,KP,KLIMIT, &
6732      & KM,ITER,KLIMITL,KLIMITG,KLIMITH,KLIMITI_1,KLIMITI_2,KLIMITI_3, &
6733      & NCRITI
6734       REAL AL1,AL2,D,GAM,POD, &
6735      & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
6736      & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
6737      & TPC1, TPC2, TPC3, TPC4, TPC5, &
6738      & EPSDEL, DT0L, DT0I, &
6739      & ROR, &
6740      & DEL1NUC,DEL2NUC, &
6741      & CWHUCM,B6,B8L,B8I,RMASSGL,RMASSGI, &
6742      & DEL1,DEL2,DEL1S,DEL2S, &
6743      & TIMENEW,TIMEREV,SFN11,SFN12, &
6744      & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,OPERQ,RW,RI,QW,PW, &
6745      & PI,QI,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
6746      & DEL_R1,DT0L0,DT0I0,SFN31,SFN32,SFN52, &
6747      & SFNII1,SFN21,SFN22,DTNEWI3,DTNEWI4,DTNEWI5,DTNEWI2_1, &
6748      & DTNEWI2_2,DTNEWI1,DEL_R2,DEL_R4,DEL_R5,SFN41,SFN42, &
6749      & SNF51,DTNEWI2_3,DTNEWI2,DTNEWI_1,DTNEWI_2, &
6750      & DTNEWL0,DTNEWG1,DTNEWH1,DTNEWI_3, &
6751      & DTNEWL2,SFN51,SFNII2,DEL_R3,DTNEWI  
6752        REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
6753      &  DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON
6755        INTEGER K
6757 ! NEW ALGORITHM OF CONDENSATION (12.01.00)
6759       DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
6760       DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
6761      &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
6762      &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
6763      &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
6764      &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
6765      &                  ,ES1N,ES2N,EW1N,ARGEXP &
6766      &                  ,TT,QQ,PP &
6767      &                  ,DEL1N,DEL2N,DIV1,DIV2 &
6768      &                  ,OPER2,OPER3,AR1,AR2  
6770        DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
6772 ! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
6774         CHARACTER*70 CPRINT
6782 ! CRYSTALS
6783                                                                        
6784         REAL R2(NKR,ICEMAX) &
6785      &           ,RIEC(NKR,ICEMAX) &
6786      &           ,RO2BL(NKR,ICEMAX) &
6787      &           ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
6788      &           ,FF2(NKR,ICEMAX) &
6789      &           ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX)
6791 ! SNOW                                                                          
6792         REAL R3(NKR) &
6793      &           ,RSEC(NKR),RO3BL(NKR) &
6794      &           ,FI3(NKR),FF3(NKR),PSI3(NKR) &
6795      &           ,B31_MY(NKR),B32_MY(NKR)
6797 ! GRAUPELS 
6798                                                                        
6799         REAL R4(NKR) &
6800      &           ,RGEC(NKR),RO4BL(NKR) &
6801      &           ,FI4(NKR),FF4(NKR),PSI4(NKR) &
6802      &           ,B41_MY(NKR),B42_MY(NKR)  
6804 ! HAIL                                                                          
6805         REAL R5(NKR) &
6806      &           ,RHEC(NKR),RO5BL(NKR) &
6807      &           ,FI5(NKR),FF5(NKR),PSI5(NKR) &
6808      &           ,B51_MY(NKR),B52_MY(NKR)  
6810 ! CCN                                                                       
6812 ! WORK ARRAYS 
6814 ! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION
6816         REAL DTIMEG(NKR),DTIMEH(NKR) 
6817        
6818         REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
6820 ! NEW ALGORITHM (NO TYPE OF ICE)
6822      &           ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR) &
6823      &           ,SFNI1(ICEMAX),SFNI2(ICEMAX) &
6824      &           ,TIMESTEPD(NKR) &
6825      &           ,FI1REF(NKR),PSI1REF(NKR) &
6826      &           ,FI2REF(NKR,ICEMAX),PSI2REF(NKR,ICEMAX)&
6827      &           ,FCCNRREF(NKR)
6830         OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
6831         OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
6833         DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
6834      &      ,GAM /1.E-4/, POD /10./ 
6835            
6836         DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
6837      &      /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/
6839         DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
6840      &      /2.53,5.42,3.41E1,6.13/
6842         DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
6843      &      /-4.0,-8.1,-12.7,-17.8,-22.4/ 
6846         DATA EPSDEL/0.1E-03/
6847     
6848         DATA DT0L, DT0I /1.E20,1.E20/
6850 ! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
6853 ! CONTROL OF TIMESTEP ITERATIONS IN MIXED PHASE: EVAPORATION
6854         
6855         I_MIXCOND=0
6856         I_MIXEVAP=0
6857         I_ABERGERON=0
6858         I_BERGERON=0
6859 ! SOME CONSTANTS 
6860         COL3=3.0*COL
6861         ICM=ICEMAX
6862         ITIME=0
6863         KCOND=0
6864         DT_WATER_COND=0.4
6865         DT_WATER_EVAP=0.4
6866         DT_ICE_COND=0.4
6867         DT_ICE_EVAP=0.4
6868         DT_MIX_COND=0.4
6869         DT_MIX_EVAP=0.4
6870         DT_MIX_BERGERON=0.4
6871         DT_MIX_ANTIBERGERON=0.4
6872         ICM=ICEMAX
6873         ITIME=0
6874         KCOND=0
6875         DT0LREF=0.2
6876         DTLREF=0.4
6878         NR=NKR
6879         NRM=NKR-1
6880         DT=DTCOND
6881         DTT=DTCOND
6882         XRAD=0.
6884 !     BARRY
6885         CWHUCM=0.
6886         XRAD=0.
6887         B6=CWHUCM*GAM-XRAD
6888         B8L=1./ROR
6889         B8I=1./ROR
6890         RORI=1./ROR
6892 ! INITIALIZATION OF SOME ARRAYS
6894 !       BARRY
6895         TPN=TT
6896         QPN=QQ
6899 ! TYPE OF ICE IN DIFFUSIONAL GROWTH 
6901               DO ICE=1,ICEMAX
6902                  SFNI1(ICE)=0.
6903                  SFNI2(ICE)=0.
6904                  DEL2D(ICE)=0.
6905               ENDDO
6907 ! TIME SPLITTING 
6909               TIMENEW=0.
6910               ITIME=0
6912 ! ONLY ICE (CONDENSATION OR EVAPORATION) :
6914    46         ITIME=ITIME+1
6916               TIMEREV=DT-TIMENEW
6918               DEL1=DEL1N
6919               DEL2=DEL2N
6920               DEL1S=DEL1N
6921               DEL2S=DEL2N
6922               DEL2D(1)=DEL2N
6923               DEL2D(2)=DEL2N
6924               DEL2D(3)=DEL2N
6925               TPS=TPN
6926               QPS=QPN
6927               DO KR=1,NKR
6928                  FI3(KR)=PSI3(KR)
6929                  FI4(KR)=PSI4(KR)
6930                  FI5(KR)=PSI5(KR)
6931                  DO ICE=1,ICEMAX
6932                     FI2(KR,ICE)=PSI2(KR,ICE)
6933                  ENDDO
6934               ENDDO
6935 ! TIME-STEP GROWTH RATE: 
6936 ! ONLY ICE (CONDENSATION OR EVAPORATION)
6937               CALL JERRATE(R2,TPS,PP,ROR,VR2,PSINGLE &
6938      &                    ,RIEC,RO2BL,B21_MY,B22_MY,3,2,ICEMAX,NKR)   
6939               CALL JERRATE(R3,TPS,PP,ROR,VR3,PSINGLE &
6940      &                    ,RSEC,RO3BL,B31_MY,B32_MY,1,2,ICEMAX,NKR)
6941               CALL JERRATE(R4,TPS,PP,ROR,VR4,PSINGLE &
6942      &                    ,RGEC,RO4BL,B41_MY,B42_MY,1,2,ICEMAX,NKR)
6943               CALL JERRATE(R5,TPS,PP,ROR,VR5,PSINGLE &
6944      &                    ,RHEC,RO5BL,B51_MY,B52_MY,1,2,ICEMAX,NKR)
6947 ! INTEGRALS IN DELTA EQUATION
6949 ! CALL JERTIMESC CRYSTAL - 1 (ONLY ICE)
6950               CALL JERTIMESC_ICE  &
6951      &       (FI2,R2,SFNI1,SFNI2,B21_MY,B22_MY,RIEC,B8I,ICM,COL,NKR) 
6952               CALL JERTIMESC &
6953      &       (FI3,R3,SFN31,SFN32,B31_MY,B32_MY,RSEC,B8I,1,COL,NKR)  
6954               CALL JERTIMESC &
6955      &       (FI4,R4,SFN41,SFN42,B41_MY,B42_MY,RGEC,B8I,1,COL,NKR) 
6956               CALL JERTIMESC &
6957      &       (FI5,R5,SFN51,SFN52,B51_MY,B52_MY,RHEC,B8I,1,COL,NKR)
6958               SFNII1=SFNI1(1)+SFNI1(2)+SFNI1(3)
6959               SFNII2=SFNI2(1)+SFNI2(2)+SFNI2(3)
6960               SFN21=SFNII1+SFN31+SFN41+SFN51        
6961               SFN22=SFNII2+SFN32+SFN42+SFN52 
6962               SFNL=0.
6963               SFNI=SFN21+SFN22       
6964 ! SOME CONSTANTS 
6965               B5L=BB1_MY/TPS/TPS
6966               B5I=BB2_MY/TPS/TPS
6967               B7L=B5L*B6                                                     
6968               B7I=B5I*B6
6969               DOPL=1.+DEL1S                                                     
6970               DOPI=1.+DEL2S                                                     
6971               OPERQ=OPER2(QPS)  
6972               RW=(OPERQ+B5L*AL1)*DOPL*SFNL                                      
6973               QW=B7L*DOPL
6974               PW=(OPERQ+B5I*AL1)*DOPI*SFNL
6975               RI=(OPERQ+B5L*AL2)*DOPL*SFNI
6976               PI=(OPERQ+B5I*AL2)*DOPI*SFNI
6977               QI=B7I*DOPI
6978               KCOND=20
6979               IF(DEL2.GT.0) KCOND=21
6981 ! PROCESS'S TYPE (ONLY ICE) 
6983               IF(KCOND.EQ.21)  THEN
6985 ! ONLY_ICE: CONDENSATION
6987               
6988                 DT0I=1.E20
6989                 DTNEWI1=DTCOND
6990                 DTNEWL=DTNEWI1
6991                 IF(ITIME.GE.NKR) THEN
6992                 call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
6993                 ENDIF
6994                 TIMESTEPD(ITIME)=DTNEWL
6995 ! NEW TIME STEP (ONLY_ICE: CONDENSATION)
6996                 IF(DTNEWL.GT.DT) DTNEWL=DT
6997                 IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
6998      &          DTNEWL=DT-TIMENEW
6999                 IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
7000                 TIMESTEPD(ITIME)=DTNEWL
7001                 TIMENEW=TIMENEW+DTNEWL
7002                 DTT=DTNEWL
7003 ! SOLVING FOR SUPERSATURATION (ONLY ICE: CONDENSATION) 
7005 ! CALL JERSUPSAT - 4 (ONLY ICE: CONDENSATION)
7007                 CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
7008      &                        ,RW,PW,RI,PI,QW,QI &
7009      &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
7011 ! END OF "NEW SUPERSATURATION" (ONLY ICE: CONDENSATION)
7014 ! CRYSTALS (ONLY ICE: CONDENSATION) 
7016                 IF(ISYM2.NE.0) THEN
7018 ! CRYSTAL DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
7020 ! CALL JERDFUN CRYSTAL - 1 (ONLY ICE: CONDENSATION)
7022 ! NEW ALGORITHM (NO TYPE ICE)
7023                   CALL JERDFUN(R2,B21_MY,B22_MY &
7024      &                        ,FI2,PSI2,D2N &
7025      &                        ,ICM,1,COL,NKR,TPN)
7027                   CALL JERDFUN(R2,B21_MY,B22_MY &
7028      &                        ,FI2,PSI2,D2N &
7029      &                        ,ICM,2,COL,NKR,TPN)
7031                   CALL JERDFUN(R2,B21_MY,B22_MY &
7032      &                        ,FI2,PSI2,D2N &
7033      &                        ,ICM,3,COL,NKR,TPN)
7034 ! IN CASE : ISYM2.NE.0
7036                 ENDIF
7037 ! SNOW 
7038                 IF(ISYM3.NE.0) THEN
7040 ! SNOW DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
7041                                                          
7043 ! CALL JERDFUN SNOW - 1 (ONLY ICE: CONDENSATION)
7044                   CALL JERDFUN(R3,B31_MY,B32_MY &
7045      &                        ,FI3,PSI3,D2N &
7046      &                        ,1,3,COL,NKR,TPN)
7048                 ENDIF
7049 ! IN CASE : ISYM4.NE.0
7050 ! GRAUPELS (ONLY_ICE: EVAPORATION)
7052                 IF(ISYM4.NE.0) THEN
7054 ! GRAUPEL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION)
7056                   CALL JERDFUN(R4,B41_MY,B42_MY &
7057      &                        ,FI4,PSI4,D2N &
7058      &                        ,1,4,COL,NKR,TPN)
7059 ! IN CASE : ISYM4.NE.0
7061                 ENDIF
7065 ! HAIL (ONLY ICE: CONDENSATION) 
7067                 IF(ISYM5.NE.0) THEN
7069 ! HAIL DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
7070                                                          
7071 ! CALL JERDFUN HAIL - 1 (ONLY ICE: CONDENSATION) 
7072                   CALL JERDFUN(R5,B51_MY,B52_MY &
7073      &                        ,FI5,PSI5,D2N &
7074      &                        ,1,5,COL,NKR,TPN)
7075 ! IN CASE : ISYM5.NE.0
7077                 ENDIF
7079                 IF((DEL2.GT.0.AND.DEL2N.LT.0) &
7080      &         .AND.ABS(DEL2N).GT.EPSDEL) THEN
7081                 call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL2.GT.0.AND.DEL2N.LT.0), model stop")
7082                 ENDIF
7084               ELSE
7086 ! IN CASE KCOND.NE.21 
7088 ! ONLY ICE: EVAPORATION  
7090 ! NEW TREATMENT OF TIME STEP (ONLY ICE: EVAPORATION) 
7092                 DT0I=1.E20
7093                 IF (DEL2N.EQ.0)THEN
7094                   DTNEWL=DT
7095                 ELSE
7096                  DTNEWI3=-R3(3)/(B31_MY(3)*DEL2N-B32_MY(3))
7097                  DTNEWI4=-R4(3)/(B41_MY(3)*DEL2N-B42_MY(3))
7098                  DTNEWI5=-R5(3)/(B51_MY(3)*DEL2N-B52_MY(3))
7099 ! NEW ALGORITHM (NO TYPE OF ICE)
7100                  DTNEWI2_1=-R2(3,1)/(B21_MY(1,1)*DEL2N-B22_MY(1,1))
7101                  DTNEWI2_2=-R2(3,2)/(B21_MY(1,2)*DEL2N-B22_MY(1,2))
7102                  DTNEWI2_3=-R2(3,3)/(B21_MY(1,3)*DEL2N-B22_MY(1,3))
7103                  DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
7104                  DTNEWI1=AMIN1(DTNEWI2,DTNEWI3,DTNEWI4 &
7105      &                       ,DTNEWI5,DT0I,TIMEREV)
7106                  DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I,TIMEREV)
7107                  DTNEWL=DTNEWI1
7108                  IF(DTNEWL.LT.DTLREF) DTNEWL=AMIN1(DTLREF,TIMEREV)
7109                 END IF
7110                 IF(ITIME.GE.NKR) THEN
7111                 call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
7112                 ENDIF
7113                 TIMESTEPD(ITIME)=DTNEWL
7115 ! NEW TIME STEP (ONLY_ICE: EVAPORATION)
7117                 IF(DTNEWL.GT.DT) DTNEWL=DT
7118                 IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
7119      &          DTNEWL=DT-TIMENEW
7120                 IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
7121                 TIMENEW=TIMENEW+DTNEWL
7122                 TIMESTEPD(ITIME)=DTNEWL
7123                 DTT=DTNEWL
7124 ! SOLVING FOR SUPERSATURATION (ONLY_ICE: EVAPORATION) 
7125                 CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
7126      &                        ,RW,PW,RI,PI,QW,QI &
7127      &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
7128 ! END OF "NEW SUPERSATURATION" (ONLY_ICE: EVAPORATION) 
7130 ! CRYSTALS
7131                 IF(ISYM2.NE.0) THEN
7133 ! CRYSTAL DISTRIBUTION FUNCTION 
7135 ! NEW ALGORITHM (NO TYPE ICE) 
7137                   CALL JERDFUN(R2,B21_MY,B22_MY &
7138      &                         ,FI2,PSI2,D2N &
7139      &                         ,ICM,1,COL,NKR,TPN)
7141                   CALL JERDFUN(R2,B21_MY,B22_MY &
7142      &                         ,FI2,PSI2,D2N &
7143      &                         ,ICM,2,COL,NKR,TPN)
7145                   CALL JERDFUN(R2,B21_MY,B22_MY &
7146      &                         ,FI2,PSI2,D2N &
7147      &                         ,ICM,3,COL,NKR,TPN)
7148                 ENDIF
7149 ! SNOW 
7150                 IF(ISYM3.NE.0) THEN
7152 ! SNOW DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
7153                                                          
7155 ! CALL JERDFUN - SNOW - 2 (ONLY_ICE: EVAPORATION)
7157                   CALL JERDFUN(R3,B31_MY,B32_MY &
7158      &                        ,FI3,PSI3,D2N &
7159      &                        ,1,3,COL,NKR,TPN)
7165 ! IN CASE : ISYM3.NE.0
7167                 ENDIF
7169 ! GRAUPELS (ONLY_ICE: EVAPORATION) 
7171                 IF(ISYM4.NE.0) THEN
7173 ! GRAUPEL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
7174                                                          
7175                   CALL JERDFUN(R4,B41_MY,B42_MY &
7176      &                        ,FI4,PSI4,D2N &
7177      &                        ,1,4,COL,NKR,TPN)
7178 ! IN CASE : ISYM4.NE.0
7180                 ENDIF
7182 ! HAIL (ONLY_ICE: EVAPORATION) 
7184                 IF(ISYM5.NE.0) THEN
7186 ! HAIL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
7187                                                          
7188                   CALL JERDFUN(R5,B51_MY,B52_MY &
7189      &                        ,FI5,PSI5,D2N &
7190      &                        ,1,5,COL,NKR,TPN)
7191 ! IN CASE : ISYM5.NE.0
7193                 ENDIF
7195                 IF((DEL2.LT.0.AND.DEL2N.GT.0) &
7196      &         .AND.ABS(DEL2N).GT.EPSDEL) THEN
7197                 call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL2.LT.0.AND.DEL2N.GT.0), model stop")
7198                 ENDIF
7200 ! IN CASE : KCOND.NE.21
7202               ENDIF
7204 ! IN CASES : KCOND = 21 OR KCOND.NE.21
7206 ! END OF "PROCESS'S TYPE" 
7208 ! MASSES
7209               RMASSIBB=0.0
7210               RMASSIAA=0.0
7211 ! BEFORE JERNEWF
7212               DO K=1,NKR
7213                  DO ICE =1,ICEMAX
7214                     FI2_K=FI2(K,ICE)
7215                     R2_K=R2(K,ICE)
7216                     FI2R2=FI2_K*R2_K*R2_K
7217                     RMASSIBB=RMASSIBB+FI2R2
7218                  ENDDO
7219                  FI3_K=FI3(K)
7220                  FI4_K=FI4(K)
7221                  FI5_K=FI5(K)
7222                  R3_K=R3(K)
7223                  R4_K=R4(K)
7224                  R5_K=R5(K)
7225                  FI3R3=FI3_K*R3_K*R3_K
7226                  FI4R4=FI4_K*R4_K*R4_K
7227                  FI5R5=FI5_K*R5_K*R5_K
7228                  RMASSIBB=RMASSIBB+FI3R3
7229                  RMASSIBB=RMASSIBB+FI4R4
7230                  RMASSIBB=RMASSIBB+FI5R5
7231               ENDDO
7232               RMASSIBB=RMASSIBB*COL3*RORI
7233 ! NEW CHANGE RMASSIBB
7234               IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
7235 ! AFTER JERNEWF
7236               DO K=1,NKR
7237                  DO ICE =1,ICEMAX
7238                     FI2_K=PSI2(K,ICE)
7239                     R2_K=R2(K,ICE)
7240                     FI2R2=FI2_K*R2_K*R2_K
7241                     RMASSIAA=RMASSIAA+FI2R2
7242                  ENDDO
7243                  FI3_K=PSI3(K)
7244                  FI4_K=PSI4(K)
7245                  FI5_K=PSI5(K)
7246                  R3_K=R3(K)
7247                  R4_K=R4(K)
7248                  R5_K=R5(K)
7249                  FI3R3=FI3_K*R3_K*R3_K
7250                  FI4R4=FI4_K*R4_K*R4_K
7251                  FI5R5=FI5_K*R5_K*R5_K
7252                  RMASSIAA=RMASSIAA+FI3R3
7253                  RMASSIAA=RMASSIAA+FI4R4
7254                  RMASSIAA=RMASSIAA+FI5R5
7255               ENDDO
7256               RMASSIAA=RMASSIAA*COL3*RORI
7257 ! NEW CHANGE RMASSIAA
7258               IF(RMASSIAA.LT.0.0) RMASSIAA=0.0
7259 ! NEW TREATMENT OF "T" & "Q"
7260               DELMASSI1=RMASSIAA-RMASSIBB
7261               QPN=QPS-DELMASSI1
7262               DAL2=AL2
7263               TPN=TPS+DAL2*DELMASSI1
7264 ! SUPERSATURATION
7265               ARGEXP=-BB1_MY/TPN
7266               ES1N=AA1_MY*DEXP(ARGEXP)
7267               ARGEXP=-BB2_MY/TPN
7268               ES2N=AA2_MY*DEXP(ARGEXP)
7269               EW1N=OPER3(QPN,PP)
7270               IF(ES1N.EQ.0)THEN
7271                DEL1N=0.5
7272                DIV1=1.5
7273                call wrf_error_fatal("fatal error in module_mp_full_sbm (ES1N.EQ.0), model stop")
7274               ELSE
7275                DIV1=EW1N/ES1N
7276                DEL1N=EW1N/ES1N-1.
7277               END IF
7278               IF(ES2N.EQ.0)THEN
7279                DEL2N=0.5
7280                DIV2=1.5
7281                call wrf_error_fatal("fatal error in module_mp_full_sbm (ES2N.EQ.0), model stop")
7282               ELSE
7283                DEL2N=EW1N/ES2N-1.
7284                DIV2=EW1N/ES2N
7285               END IF
7287 !  END OF TIME SPLITTING 
7288 ! (ONLY ICE: CONDENSATION OR EVAPORATION) 
7289               IF(TIMENEW.LT.DT) GOTO 46
7290         TT=TPN
7291         QQ=QPN
7292         DO KR=1,NKR
7293            DO ICE=1,ICEMAX
7294               FF2(KR,ICE)=PSI2(KR,ICE)
7295            ENDDO
7296            FF3(KR)=PSI3(KR)
7297            FF4(KR)=PSI4(KR)
7298            FF5(KR)=PSI5(KR)
7299         ENDDO
7302 ! GO TO "CONDENSATION AND VAPORATION"
7305         RETURN                                          
7306         END SUBROUTINE ONECOND2
7307 !==================================================================
7309         SUBROUTINE ONECOND3 &
7310      & (TT,QQ,PP,ROR &
7311      & ,VR1,VR2,VR3,VR4,VR5,PSINGLE &
7312      & ,DEL1N,DEL2N,DIV1,DIV2 &
7313      & ,FF1,PSI1,R1,RLEC,RO1BL &
7314      & ,FF2,PSI2,R2,RIEC,RO2BL &
7315      & ,FF3,PSI3,R3,RSEC,RO3BL &
7316      & ,FF4,PSI4,R4,RGEC,RO4BL &
7317      & ,FF5,PSI5,R5,RHEC,RO5BL &
7318      & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
7319      & ,C1_MEY,C2_MEY &
7320      & ,COL,DTCOND,ICEMAX,NKR &
7321      & ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
7322        IMPLICIT NONE
7323        INTEGER ICEMAX,NKR,KR,ITIME,ICE,KCOND,K &
7324      &           ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5
7325        INTEGER KLIMITL,KLIMITG,KLIMITH,KLIMITI_1, &
7326      &  KLIMITI_2,KLIMITI_3
7327        INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON  
7328        REAL ROR,VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
7329      &           ,VR5(NKR),PSINGLE &
7330      &           ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
7331      &           ,C1_MEY,C2_MEY &
7332      &           ,COL,DTCOND
7334 ! DROPLETS 
7335                                                                        
7336         REAL R1(NKR)&
7337      &           ,RLEC(NKR),RO1BL(NKR) &
7338      &           ,FI1(NKR),FF1(NKR),PSI1(NKR) &
7339      &           ,B11_MY(NKR),B12_MY(NKR)
7341 ! CRYSTALS
7342                                                                        
7343         REAL R2(NKR,ICEMAX) &
7344      &           ,RIEC(NKR,ICEMAX) &
7345      &           ,RO2BL(NKR,ICEMAX) &
7346      &           ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
7347      &           ,FF2(NKR,ICEMAX) &
7348      &           ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX) &
7349      &           ,RATE2(NKR,ICEMAX),DEL_R2M(NKR,ICEMAX)
7351 ! SNOW                                                                          
7352         REAL R3(NKR) &
7353      &           ,RSEC(NKR),RO3BL(NKR) &
7354      &           ,FI3(NKR),FF3(NKR),PSI3(NKR) &
7355      &           ,B31_MY(NKR),B32_MY(NKR) &
7356      &           ,DEL_R3M(NKR)  
7358 ! GRAUPELS 
7359                                                                        
7360         REAL R4(NKR),R4N(NKR) &
7361      &           ,RGEC(NKR),RO4BL(NKR) &
7362      &           ,FI4(NKR),FF4(NKR),PSI4(NKR) &
7363      &           ,B41_MY(NKR),B42_MY(NKR) &
7364      &           ,DEL_R4M(NKR)
7366 ! HAIL                                                                          
7367         REAL R5(NKR),R5N(NKR) &
7368      &           ,RHEC(NKR),RO5BL(NKR) &
7369      &           ,FI5(NKR),FF5(NKR),PSI5(NKR) &
7370      &           ,B51_MY(NKR),B52_MY(NKR) &
7371      &           ,DEL_R5M(NKR)
7373       DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
7374       DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
7375      &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
7376      &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
7377      &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
7378      &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
7379      &                  ,ES1N,ES2N,EW1N,ARGEXP &
7380      &                  ,TT,QQ,PP,DEL1N0,DEL2N0 &
7381      &                  ,DEL1N,DEL2N,DIV1,DIV2 &
7382      &                  ,OPER2,OPER3,AR1,AR2
7384        DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
7386        REAL A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
7387         DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
7388      &      /2.53,5.42,3.41E1,6.13/
7389        REAL B8L,B8I,SFN11,SFN12,SFNL,SFNI
7390        REAL B5L,B5I,B7L,B7I,B6,DOPL,DEL1S,DEL2S,DOPI,RW,QW,PW, &
7391      &  RI,PI,QI,SFNI1(ICEMAX),SFNI2(ICEMAX),AL1,AL2
7392        REAL D1N,D2N,DT0L, DT0I,D1N0,D2N0
7393        REAL SFN21,SFN22,SFNII1,SFNII2,SFN31,SFN32,SFN41,SFN42,SFN51, &
7394      &  SFN52
7395        REAL DEL1,DEL2
7396        REAL  TIMEREV,DT,DTT,TIMENEW
7397        REAL DTIMEG(NKR),DTIMEH(NKR)
7399        REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
7400      &           ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR)
7401        REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
7402      &  DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON
7403        REAL DTNEWL0,DTNEWL1,DTNEWI1,DTNEWI2_1,DTNEWI2_2,DTNEWI2_3, &
7404      & DTNEWI2,DTNEWI_1,DTNEWI_2,DTNEWI3,DTNEWI4,DTNEWI5, &
7405      & DTNEWL,DTNEWL2,DTNEWG1,DTNEWH1
7406        REAL TIMESTEPD(NKR)
7408        DATA AL1 /2500./, AL2 /2834./
7409        REAL EPSDEL,EPSDEL2
7410        DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/
7411        OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
7412        OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
7413       
7414 ! BELOW
7416         DT_WATER_COND=0.4
7417         DT_WATER_EVAP=0.4
7418         DT_ICE_COND=0.4
7419         DT_ICE_EVAP=0.4
7420         DT_MIX_COND=0.4
7421         DT_MIX_EVAP=0.4
7422         DT_MIX_BERGERON=0.4
7423         DT_MIX_ANTIBERGERON=0.4
7425         I_MIXCOND=0
7426         I_MIXEVAP=0
7427         I_ABERGERON=0
7428         I_BERGERON=0
7430        ITIME = 0
7431        TIMENEW=0.
7432        DT=DTCOND
7433        DTT=DTCOND
7435        B6=0.
7436        B8L=1./ROR
7437        B8I=1./ROR
7438 ! NEW CHANGES 19.04.01 (BEGIN)
7439         RORI=1.D0/ROR
7440 ! NEW CHANGES 19.04.01 (END)
7441 ! NEW CHANGES 19.04.01 (BEGIN)
7442         COL3=3.D0*COL
7443 ! NEW CHANGES 19.04.01 (END)
7447 ! BARRY:DIV
7448         TPN=TT
7449         QPN=QQ
7450 ! HERE
7451    16         ITIME=ITIME+1
7452 ! BARRY
7453 !             TPC_NEW=TPN-273.15
7454               IF((TPN-273.15).GE.-0.187) GO TO 17
7455               TIMEREV=DT-TIMENEW
7456               DEL1=DEL1N
7457               DEL2=DEL2N
7458               DEL1S=DEL1N
7459               DEL2S=DEL2N
7460 ! NEW ALGORITHM (NO TYPE ICE)
7461               DEL2D(1)=DEL2N
7462               DEL2D(2)=DEL2N
7463               DEL2D(3)=DEL2N
7464               TPS=TPN
7465               QPS=QPN
7466               DO KR=1,NKR
7467                  FI1(KR)=PSI1(KR)
7468                  FI3(KR)=PSI3(KR)
7469                  FI4(KR)=PSI4(KR)
7470                  FI5(KR)=PSI5(KR)
7471                  DO ICE=1,ICEMAX
7472                     FI2(KR,ICE)=PSI2(KR,ICE)
7473                  ENDDO
7474               ENDDO
7475 ! TIME-STEP GROWTH RATE
7476 ! HERE
7477               CALL JERRATE(R1,TPS,PP,ROR,VR1,PSINGLE &
7478      &                    ,RLEC,RO1BL,B11_MY,B12_MY,1,1,ICEMAX,NKR)
7479               CALL JERRATE(R2,TPS,PP,ROR,VR2,PSINGLE &
7480      &                    ,RIEC,RO2BL,B21_MY,B22_MY,3,2,ICEMAX,NKR)
7481               CALL JERRATE(R3,TPS,PP,ROR,VR3,PSINGLE &
7482      &                    ,RSEC,RO3BL,B31_MY,B32_MY,1,2,ICEMAX,NKR)
7483               CALL JERRATE(R4,TPS,PP,ROR,VR4,PSINGLE &
7484      &                    ,RGEC,RO4BL,B41_MY,B42_MY,1,2,ICEMAX,NKR)
7485               CALL JERRATE(R5,TPS,PP,ROR,VR5,PSINGLE &
7486      &                    ,RHEC,RO5BL,B51_MY,B52_MY,1,2,ICEMAX,NKR)
7487               CALL JERTIMESC(FI1,R1,SFN11,SFN12 &
7488      &                      ,B11_MY,B12_MY,RLEC,B8L,1,COL,NKR)
7489               CALL JERTIMESC_ICE(FI2,R2,SFNI1,SFNI2 &
7490      &                      ,B21_MY,B22_MY,RIEC,B8I,ICEMAX,COL,NKR)
7491               CALL JERTIMESC(FI3,R3,SFN31,SFN32 &
7492      &                      ,B31_MY,B32_MY,RSEC,B8I,1,COL,NKR)
7493               CALL JERTIMESC(FI4,R4,SFN41,SFN42 &
7494      &                      ,B41_MY,B42_MY,RGEC,B8I,1,COL,NKR)
7495               CALL JERTIMESC(FI5,R5,SFN51,SFN52 &
7496      &                      ,B51_MY,B52_MY,RHEC,B8I,1,COL,NKR)
7497 ! NEW ALGORITHM (NO TYPE ICE)
7498               SFNII1=SFNI1(1)+SFNI1(2)+SFNI1(3)
7499               SFNII2=SFNI2(1)+SFNI2(2)+SFNI2(3)
7500               SFN21=SFNII1+SFN31+SFN41+SFN51
7501               SFN22=SFNII2+SFN32+SFN42+SFN52
7502               SFNL=SFN11+SFN12
7503               SFNI=SFN21+SFN22
7504 ! SOME CONSTANTS (QW,QI=0,since B6=0.)
7505               B5L=BB1_MY/TPS/TPS
7506               B5I=BB2_MY/TPS/TPS
7507               B7L=B5L*B6
7508               B7I=B5I*B6
7509               DOPL=1.+DEL1S
7510               DOPI=1.+DEL2S
7511               RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL
7512               QW=B7L*DOPL
7513               PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
7514               RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
7515               PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
7516               QI=B7I*DOPI
7517 ! SOLVING FOR TIMEZERO
7518               CALL JERSUPSAT(DEL1,DEL2,DEL1N0,DEL2N0 &
7519      &                      ,RW,PW,RI,PI,QW,QI &
7520      &                      ,DTT,D1N0,D2N0,DT0L,DT0I)
7521 ! DEL1 > 0, DEL2 < 0    (ANTIBERGERON MIXED PHASE - KCOND=50)
7522 ! DEL1 < 0 AND DEL2 < 0 (EVAPORATION MIXED_PHASE - KCOND=30)
7523 ! DEL1 > 0 AND DEL2 > 0 (CONDENSATION MIXED PHASE - KCOND=31)
7524 ! DEL1 < 0, DEL2 > 0    (BERGERON MIXED PHASE - KCOND=32)
7525               KCOND=50
7527               IF(DEL1.LT.0.AND.DEL2.LT.0) KCOND=30
7528               IF(DEL1.GT.0.AND.DEL2.GT.0) KCOND=31
7529               IF(DEL1.LT.0.AND.DEL2.GT.0) KCOND=32
7530               IF(KCOND.EQ.50) THEN 
7531                 I_ABERGERON=I_ABERGERON+1
7532                 IF(DT0L.EQ.0) THEN
7533                   DTNEWL=DT
7534                 ELSE
7535                   DTNEWL=AMIN1(DT,DT0L)
7536                 ENDIF
7537 ! NEW TIME STEP (ANTIBERGERON MIXED PHASE)
7538                 IF(DTNEWL.GT.DT) DTNEWL=DT
7539                 IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
7540      &          DTNEWL=DT-TIMENEW
7541                 IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
7542                 TIMENEW=TIMENEW+DTNEWL
7543                 DTT=DTNEWL
7544                 IF(ITIME.GE.NKR) THEN
7545                 call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
7546                 ENDIF
7547                 TIMESTEPD(ITIME)=DTNEWL
7548 ! ANTIBERGERON MIXED PHASE (BEGIN)
7549 ! IN CASE : KCOND = 50
7550               ENDIF
7551               IF(KCOND.EQ.31) THEN
7552 ! CONDENSATION MIXED PHASE (BEGIN)
7553 ! CONTROL OF TIMESTEP ITERATIONS
7554                 I_MIXCOND=I_MIXCOND+1
7555                IF (DEL1N.EQ.0)THEN
7556                 DTNEWL0=DT
7557                ELSE
7558                 DTNEWL0=ABS(R1(ITIME)/(B11_MY(ITIME)*DEL1N- &
7559      &                                 B12_MY(ITIME)))
7560                END IF
7561 ! NEW ALGORITHM (NO TYPE OF ICE)
7563                IF (DEL2N.EQ.0)THEN
7564                 DTNEWI2_1=DT
7565                 DTNEWI2_2=DT
7566                 DTNEWI2_3=DT
7567                 DTNEWI3=DT
7568                 DTNEWI4=DT
7569                 DTNEWI5=DT
7570                ELSE
7571                 DTNEWI2_1=ABS(R2(ITIME,1)/ &
7572      &         (B21_MY(ITIME,1)*DEL2N-B22_MY(ITIME,1)))
7573                 DTNEWI2_2=ABS(R2(ITIME,2)/ &
7574      &         (B21_MY(ITIME,2)*DEL2N-B22_MY(ITIME,2))) 
7575                 DTNEWI2_3=ABS(R2(ITIME,3)/ &
7576      &         (B21_MY(ITIME,3)*DEL2N-B22_MY(ITIME,3)))  
7577                 DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
7579                 DTNEWI3=ABS(R3(ITIME)/(B31_MY(ITIME)*DEL2N- &
7580      &                                 B32_MY(ITIME)))
7581                 DTNEWI4=ABS(R4(ITIME)/(B41_MY(ITIME)*DEL2N- &
7582      &                                 B42_MY(ITIME)))
7583                 DTNEWI5=ABS(R5(ITIME)/(B51_MY(ITIME)*DEL2N- &
7584      &                                 B52_MY(ITIME)))
7585                END IF
7586                 DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I)
7587                 IF(DT0L.NE.0) THEN
7588                   IF(ABS(DT0L).LT.DT_MIX_COND) THEN
7589                     DTNEWL1=AMIN1(DT_MIX_COND,DTNEWL0)
7590                   ELSE
7591                     DTNEWL1=AMIN1(DT0L,DTNEWL0)
7592                   ENDIF
7593                 ELSE
7594                   DTNEWL1=DTNEWL0
7595                 ENDIF
7596                 DTNEWL=AMIN1(DTNEWL1,DTNEWI1)
7597                 IF(ITIME.GE.NKR) THEN
7598                 call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
7599                 ENDIF
7600                 TIMESTEPD(ITIME)=DTNEWL
7601 ! NEW TIME STEP (CONDENSATION MIXED PHASE)
7602                 IF(DTNEWL.GT.DT) DTNEWL=DT
7603                 IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
7604      &          DTNEWL=DT-TIMENEW
7605                 IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
7606                 TIMENEW=TIMENEW+DTNEWL
7607                 TIMESTEPD(ITIME)=DTNEWL
7608                 DTT=DTNEWL
7609 ! CONDENSATION MIXED PHASE (END)
7610 ! IN CASE : KCOND = 31
7611               ENDIF
7612               IF(KCOND.EQ.30) THEN
7613 ! EVAPORATION MIXED PHASE (BEGIN)
7614 ! CONTROL OF TIMESTEP ITERATIONS
7615                 I_MIXEVAP=I_MIXEVAP+1
7616                 DO KR=1,NKR
7617                    DTIMEL(KR)=0.
7618                    DTIMEG(KR)=0.
7619                    DTIMEH(KR)=0.
7620 ! NEW ALGORITHM (NO TYPE ICE)
7621                    DTIMEI_1(KR)=0.
7622                    DTIMEI_2(KR)=0.
7623                    DTIMEI_3(KR)=0.
7624                 ENDDO
7625                 DO KR=1,NKR
7626                  IF (DEL1N.EQ.0) THEN
7627                    DTIMEL(KR)=DT
7628                    DTIMEG(KR)=DT
7629                    DTIMEH(KR)=DT
7630                  ELSE
7631                    DTIMEL(KR)=-R1(KR)/(B11_MY(KR)*DEL1N- &
7632      &                                 B12_MY(KR))
7633                    DTIMEG(KR)=-R4(KR)/(B41_MY(KR)*DEL1N- &
7634      &                                 B42_MY(KR))
7635                    DTIMEH(KR)=-R5(KR)/(B51_MY(KR)*DEL1N- &
7636      &                             B52_MY(KR))
7637 ! NEW ALGORITHM (NO TYPE OF ICE)
7638                  END IF
7639                  IF (DEL2N.EQ.0) THEN
7640                    DTIMEI_1(KR)=DT
7641                    DTIMEI_2(KR)=DT
7642                    DTIMEI_3(KR)=DT
7643                  ELSE
7644                    DTIMEI_1(KR)=-R2(KR,1)/ &
7645      &               (B21_MY(KR,1)*DEL2N-B22_MY(KR,1))
7646                    DTIMEI_2(KR)=-R2(KR,2)/ &
7647      &               (B21_MY(KR,2)*DEL2N-B22_MY(KR,2))
7648                    DTIMEI_3(KR)=-R2(KR,3)/ &
7649      &               (B21_MY(KR,3)*DEL2N-B22_MY(KR,3))
7650                  END IF
7651                 ENDDO
7652 ! WATER
7653                 KLIMITL=1
7654                 DO KR=1,NKR
7655                    IF(DTIMEL(KR).GT.TIMEREV) GOTO 355
7656                    KLIMITL=KR
7657                 ENDDO
7658   355           KLIMITL=KLIMITL-1
7659                 IF(KLIMITL.LT.1) KLIMITL=1
7660                 DTNEWL1=AMIN1(DTIMEL(KLIMITL),DT0L,TIMEREV)
7661 ! GRAUPELS
7662                 KLIMITG=1
7663                 DO KR=1,NKR
7664                    IF(DTIMEG(KR).GT.TIMEREV) GOTO 455
7665                    KLIMITG=KR
7666                 ENDDO
7667   455           KLIMITG=KLIMITG-1
7668                 IF(KLIMITG.LT.1) KLIMITG=1
7669                 DTNEWG1=AMIN1(DTIMEG(KLIMITG),TIMEREV)
7670 ! HAIL
7671                 KLIMITH=1
7672                 DO KR=1,NKR
7673                    IF(DTIMEH(KR).GT.TIMEREV) GOTO 555
7674                    KLIMITH=KR
7675                 ENDDO
7676   555           KLIMITH=KLIMITH-1
7677                 IF(KLIMITH.LT.1) KLIMITH=1
7678                 DTNEWH1=AMIN1(DTIMEH(KLIMITH),TIMEREV)
7679 ! ICE CRYSTALS
7680 ! NEW ALGORITHM (NO TYPE OF ICE) (BEGIN)
7681                 KLIMITI_1=1
7682                 KLIMITI_2=1
7683                 KLIMITI_3=1
7684                 DO KR=1,NKR
7685                    IF(DTIMEI_1(KR).GT.TIMEREV) GOTO 655
7686                    KLIMITI_1=KR
7687                 ENDDO
7688   655           CONTINUE
7689                 DO KR=1,NKR
7690                    IF(DTIMEI_2(KR).GT.TIMEREV) GOTO 656
7691                    KLIMITI_2=KR
7692                 ENDDO
7693   656           CONTINUE
7694                 DO KR=1,NKR
7695                    IF(DTIMEI_3(KR).GT.TIMEREV) GOTO 657
7696                    KLIMITI_3=KR
7697                 ENDDO
7698   657           CONTINUE
7699                 KLIMITI_1=KLIMITI_1-1
7700                 IF(KLIMITI_1.LT.1) KLIMITI_1=1
7701                 DTNEWI2_1=AMIN1(DTIMEI_1(KLIMITI_1),TIMEREV)
7702                 KLIMITI_2=KLIMITI_2-1
7703                 IF(KLIMITI_2.LT.1) KLIMITI_2=1
7704                 DTNEWI2_2=AMIN1(DTIMEI_2(KLIMITI_2),TIMEREV)
7705                 KLIMITI_3=KLIMITI_3-1
7706                 IF(KLIMITI_3.LT.1) KLIMITI_3=1
7707                 DTNEWI2_3=AMIN1(DTIMEI_3(KLIMITI_3),TIMEREV)
7708                 DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
7709 ! NEW ALGORITHM (NO TYPE OF ICE) (END)
7710                 DTNEWI1=AMIN1(DTNEWI2,DTNEWG1,DTNEWH1,DT0I)
7711                 IF(ABS(DEL2N).LT.EPSDEL2) &
7712      &          DTNEWI1=AMIN1(DTNEWI2,DTNEWG1,DTNEWH1)
7713                 DTNEWL2=AMIN1(DTNEWL1,DTNEWI1)
7714                 DTNEWL=DTNEWL2
7715                 IF(DTNEWL.LT.DT_MIX_EVAP) &
7716      &          DTNEWL=AMIN1(DT_MIX_EVAP,TIMEREV)  
7717                 IF(ITIME.GE.NKR) THEN
7718                 call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
7719                 ENDIF
7720                 TIMESTEPD(ITIME)=DTNEWL
7721 ! NEW TIME STEP (EVAPORATION MIXED PHASE)
7722                 IF(DTNEWL.GT.DT) DTNEWL=DT
7723                 IF((TIMENEW+DTNEWL).GT.DT &
7724      &         .AND.ITIME.LT.(NKR-1)) &
7725      &          DTNEWL=DT-TIMENEW
7726                 IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
7727                 TIMESTEPD(ITIME)=DTNEWL
7728                 TIMENEW=TIMENEW+DTNEWL
7729                 DTT=DTNEWL
7730 ! EVAPORATION MIXED PHASE (END)
7731 ! IN CASE : KCOND = 30
7732               ENDIF
7733               IF(KCOND.EQ.32) THEN
7734 ! BERGERON MIXED PHASE (BEGIN)
7735 ! CONTROL OF TIMESTEP ITERATIONS
7736                 I_BERGERON=I_BERGERON+1
7737 ! NEW TREATMENT OF TIME STEP (BERGERON MIXED PHASE)
7738                IF (DEL1N.EQ.0)THEN
7739                 DTNEWL0=DT
7740                ELSE
7741                 DTNEWL0=-R1(1)/(B11_MY(1)*DEL1N-B12_MY(1))
7742                END IF
7743 ! NEW ALGORITHM (NO TYPE ICE)
7744                IF (DEL2N.EQ.0)THEN
7745                 DTNEWI2_1=DT
7746                 DTNEWI2_2=DT
7747                 DTNEWI2_3=DT
7748                ELSE
7749                 DTNEWI2_1=R2(1,1)/(B21_MY(1,1)*DEL2N-B22_MY(1,1))
7750                 DTNEWI2_2=R2(1,2)/(B21_MY(1,2)*DEL2N-B22_MY(1,2))
7751                 DTNEWI2_3=R2(1,3)/(B21_MY(1,3)*DEL2N-B22_MY(1,3))
7752                END IF
7753                DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
7754                IF (DEL2N.EQ.0)THEN
7755                 DTNEWI3=DT
7756                 DTNEWI4=DT
7757                 DTNEWI5=DT
7758                ELSE
7759                 DTNEWI3=R3(1)/(B31_MY(1)*DEL2N-B32_MY(1))
7760                 DTNEWI4=R4(1)/(B41_MY(1)*DEL2N-B42_MY(1))
7761                 DTNEWI5=R5(1)/(B51_MY(1)*DEL2N-B52_MY(1))
7762                END IF
7763                 DTNEWL1=AMIN1(DTNEWL0,DT0L,TIMEREV)
7764                 DTNEWI1=AMIN1(DTNEWI2,DTNEWI3,DTNEWI4 &
7765      &                       ,DTNEWI5,DT0I,TIMEREV)
7766                 DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I,TIMEREV)
7767                 DTNEWL=AMIN1(DTNEWL1,DTNEWI1)
7768 ! NEW CHANGES 23.04.01 (BEGIN)
7769                 IF(DTNEWL.LT.DT_MIX_BERGERON) &
7770      &          DTNEWL=AMIN1(DT_MIX_BERGERON,TIMEREV)
7771                 TIMESTEPD(ITIME)=DTNEWL
7772 ! NEW TIME STEP (BERGERON MIXED PHASE)
7773                 IF(DTNEWL.GT.DT) DTNEWL=DT
7774                 IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
7775      &          DTNEWL=DT-TIMENEW
7776                 IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
7777                 TIMESTEPD(ITIME)=DTNEWL
7778                 TIMENEW=TIMENEW+DTNEWL
7779                 DTT=DTNEWL
7780 ! BERGERON MIXED PHASE (END)
7781 ! IN CASE : KCOND = 32
7782               ENDIF
7783 ! SOLVING FOR SUPERSATURATION 
7784 ! CALL JERSUPSAT - 7 (MIXED_PHASE)
7785          
7786               CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
7787      &                      ,RW,PW,RI,PI,QW,QI &
7788      &                      ,DTT,D1N,D2N,DT0L,DT0I)
7789 ! END OF "NEW SUPERSATURATION" 
7791 ! DROPLETS 
7792               IF(ISYM1.NE.0) THEN
7794 ! DROPLET DISTRIBUTION FUNCTION 
7796                                                          
7797 ! CALL JERDFUN - 3
7798                 CALL JERDFUN(R1,B11_MY,B12_MY &
7799      &                      ,FI1,PSI1,D1N &
7800      &                      ,1,1,COL,NKR,TPN)
7801 ! END OF "DROPLET DISTRIBUTION FUNCTION" 
7803 ! IN CASE ISYM1.NE.0
7805               ENDIF                     
7806 ! CRYSTALS 
7807               IF(ISYM2.NE.0) THEN
7809 ! CRYSTAL DISTRIBUTION FUNCTION 
7811                 CALL JERDFUN(R2,B21_MY,B22_MY &
7812      &                      ,FI2,PSI2,D2N &
7813      &                      ,ICEMAX,1,COL,NKR,TPN)
7815                 CALL JERDFUN(R2,B21_MY,B22_MY &
7816      &                      ,FI2,PSI2,D2N &
7817      &                      ,ICEMAX,2,COL,NKR,TPN)
7819                 CALL JERDFUN(R2,B21_MY,B22_MY &
7820      &                      ,FI2,PSI2,D2N &
7821      &                      ,ICEMAX,3,COL,NKR,TPN)
7822 ! IN CASE ISYM2.NE.0
7824               ENDIF
7825 ! SNOW 
7826               IF(ISYM3.NE.0) THEN
7828 ! SNOW DISTRIBUTION FUNCTION 
7829                                                          
7831 ! CALL JERDFUN - SNOW - 3
7833                 CALL JERDFUN(R3,B31_MY,B32_MY &
7834      &                      ,FI3,PSI3,D2N &
7835      &                      ,1,3,COL,NKR,TPN)
7838 ! IN CASE ISYM3.NE.0
7840               ENDIF
7842 ! GRAUPELS 
7844               IF(ISYM4.NE.0) THEN
7846 ! GRAUPEL DISTRIBUTION FUNCTION
7847                                                          
7848                 CALL JERDFUN(R4,B41_MY,B42_MY &
7849      &                      ,FI4,PSI4,D2N &
7850      &                      ,1,4,COL,NKR,TPN)
7851 ! IN CASE ISYM4.NE.0
7853               ENDIF
7854 ! HAIL 
7855               IF(ISYM5.NE.0) THEN
7857 ! HAIL DISTRIBUTION FUNCTION 
7858                                                          
7859                 CALL JERDFUN(R5,B51_MY,B52_MY &
7860      &                      ,FI5,PSI5,D2N &
7861      &                      ,1,5,COL,NKR,TPN)
7862 ! IN CASE ISYM5.NE.0
7864               ENDIF
7865 ! MASSES
7866               RMASSLBB=0.D0
7867               RMASSIBB=0.D0
7868               RMASSLAA=0.D0
7869               RMASSIAA=0.D0
7870 ! BEFORE JERNEWF
7871               DO K=1,NKR
7872                  FI1_K=FI1(K)
7873                  R1_K=R1(K)
7874                  FI1R1=FI1_K*R1_K*R1_K
7875                  RMASSLBB=RMASSLBB+FI1R1
7876                  DO ICE =1,ICEMAX
7877                     FI2_K=FI2(K,ICE)
7878                     R2_K=R2(K,ICE)
7879                     FI2R2=FI2_K*R2_K*R2_K
7880                     RMASSIBB=RMASSIBB+FI2R2
7881                  ENDDO
7882                  FI3_K=FI3(K)
7883                  FI4_K=FI4(K)
7884                  FI5_K=FI5(K)
7885                  R3_K=R3(K)
7886                  R4_K=R4(K)
7887                  R5_K=R5(K)
7888                  FI3R3=FI3_K*R3_K*R3_K
7889                  FI4R4=FI4_K*R4_K*R4_K
7890                  FI5R5=FI5_K*R5_K*R5_K
7891                  RMASSIBB=RMASSIBB+FI3R3
7892                  RMASSIBB=RMASSIBB+FI4R4
7893                  RMASSIBB=RMASSIBB+FI5R5
7894               ENDDO
7895               RMASSIBB=RMASSIBB*COL3*RORI
7896 ! NEW CHANGE RMASSIBB
7897               IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
7898               RMASSLBB=RMASSLBB*COL3*RORI
7899 ! NEW CHANGE RMASSLBB
7900               IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
7901 ! AFTER  JERNEWF
7902               DO K=1,NKR
7903                  FI1_K=PSI1(K)
7904                  R1_K=R1(K)
7905                  FI1R1=FI1_K*R1_K*R1_K
7906                  RMASSLAA=RMASSLAA+FI1R1
7907                  DO ICE =1,ICEMAX
7908                     FI2(K,ICE)=PSI2(K,ICE)
7909                     FI2_K=FI2(K,ICE)
7910                     R2_K=R2(K,ICE)
7911                     FI2R2=FI2_K*R2_K*R2_K
7912                     RMASSIAA=RMASSIAA+FI2R2
7913                  ENDDO
7914                  FI3_K=PSI3(K)
7915                  FI4_K=PSI4(K)
7916                  FI5_K=PSI5(K)
7917                  R3_K=R3(K)
7918                  R4_K=R4(K)
7919                  R5_K=R5(K)
7920                  FI3R3=FI3_K*R3_K*R3_K
7921                  FI4R4=FI4_K*R4_K*R4_K
7922                  FI5R5=FI5_K*R5_K*R5_K
7923                  RMASSIAA=RMASSIAA+FI3R3
7924                  RMASSIAA=RMASSIAA+FI4R4
7925                  RMASSIAA=RMASSIAA+FI5R5
7926               ENDDO
7927               RMASSIAA=RMASSIAA*COL3*RORI
7928 ! NEW CHANGE RMASSIAA
7929               IF(RMASSIAA.LE.0.0) RMASSIAA=0.0
7930               RMASSLAA=RMASSLAA*COL3*RORI
7931 ! NEW CHANGE RMASSLAA
7932               IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
7933 ! NEW TREATMENT OF "T" & "Q"
7934               DELMASSL1=RMASSLAA-RMASSLBB
7935               DELMASSI1=RMASSIAA-RMASSIBB
7936               DELTAQ1=DELMASSL1+DELMASSI1
7937 !             QPN=QPS-DELTAQ1-CWQ*DTT
7938               QPN=QPS-DELTAQ1
7939               DAL1=AL1
7940               DAL2=AL2
7941 !             TPN=TPS+DAL1*DELMASSL1+AL2*DELMASSI1-CWQ*DTT
7942               TPN=TPS+DAL1*DELMASSL1+DAL2*DELMASSI1
7943 ! SUPERSATURATION
7944               ARGEXP=-BB1_MY/TPN
7945               ES1N=AA1_MY*DEXP(ARGEXP)
7946               ARGEXP=-BB2_MY/TPN
7947               ES2N=AA2_MY*DEXP(ARGEXP)
7948               EW1N=OPER3(QPN,PP)
7949               IF(ES1N.EQ.0)THEN
7950                DEL1N=0.5
7951                DIV1=1.5
7952                print*,'es1n onecond3 = 0'
7953 !              stop
7954               ELSE
7955                DIV1=EW1N/ES1N
7956                DEL1N=EW1N/ES1N-1.
7957               END IF
7958               IF(ES2N.EQ.0)THEN
7959                DEL2N=0.5
7960                DIV2=1.5
7961                print*,'es2n onecond3 = 0'
7962 !              stop
7963               ELSE
7964                DEL2N=EW1N/ES2N-1.
7965                DIV2=EW1N/ES2N
7966               END IF
7967 ! END OF TIME SPLITTING
7969 ! HERE
7971         IF(TIMENEW.LT.DT) GOTO 16
7972 17      CONTINUE
7974         TT=TPN
7975         QQ=QPN
7976         DO KR=1,NKR
7977            FF1(KR)=PSI1(KR)
7978            DO ICE=1,ICEMAX
7979               FF2(KR,ICE)=PSI2(KR,ICE)
7980            ENDDO
7981            FF3(KR)=PSI3(KR)
7982            FF4(KR)=PSI4(KR)
7983            FF5(KR)=PSI5(KR)
7984         ENDDO
7987         RETURN                                          
7988         END SUBROUTINE ONECOND3
7990         SUBROUTINE COAL_BOTT_NEW(FF1R,FF2R,FF3R, &
7991      &   FF4R,FF5R,TT,QQ,PP,RHO,dt_coll,TCRIT,TTCOAL)
7992        implicit none
7993        INTEGER KR,ICE
7994        INTEGER icol_drop,icol_snow,icol_graupel,icol_hail, &
7995      & icol_column,icol_plate,icol_dendrite,icol_drop_brk
7996        double precision  g1(nkr),g2(nkr,icemax),g3(nkr),g4(nkr),g5(nkr)
7997        double precision gdumb(JMAX),xl_dumb(0:nkr),g_orig(nkr)
7998        double precision g2_1(nkr),g2_2(nkr),g2_3(nkr)
7999        real cont_fin_drop,dconc,conc_icempl,deldrop,t_new, &
8000      & delt_new,cont_fin_ice,conc_old,conc_new,cont_init_ice, &
8001      & cont_init_drop,ALWC
8002        REAL    FF1R(NKR),FF2R(NKR,ICEMAX),FF3R(NKR),FF4R(NKR),FF5R(NKR)
8003        REAL dt_coll
8004        REAL TCRIT,TTCOAL
8005        real tt_no_coll
8006        parameter (tt_no_coll=273.16)
8009        
8010    
8011 ! SHARED
8012        INTEGER I,J,IT,NDIV
8013        REAL RHO
8014        DOUBLE PRECISION break_drop_bef,break_drop_aft,dtbreakup
8015        DOUBLE PRECISION break_drop_per
8016        DOUBLE PRECISION TT,QQ,PP,prdkrn,prdkrn1
8017        parameter (prdkrn1=1.d0)
8018 !     print*,'tcrit = ',tcrit
8019 !     print*,'ttcoal = ',ttcoal
8020 !     print*,'col = ',col
8021 !     print*,'p1,p2,p3 = ',p1,p2,p3
8022 !     print*,'icempl,kr_icempl  = ',icempl,kr_icempl
8023 !     print*,'dt_coll = ',dt_coll
8024       icol_drop_brk=0
8025       icol_drop=0
8026       icol_snow=0
8027       icol_graupel=0
8028       icol_hail=0
8029       icol_column=0
8030       icol_plate=0
8031       icol_dendrite=0
8034        t_new=tt
8035          CALL MISC1(PP,cwll_1000mb,cwll_750mb,cwll_500mb, &
8036      &    cwll,nkr)
8037 ! THIS IS FOR BREAKUP
8038          DO I=1,NKR
8039             DO J=1,NKR
8040                CWLL(I,J)=ECOALMASSM(I,J)*CWLL(I,J)
8041             ENDDO
8042          ENDDO
8044 ! THIS IS FOR TURBULENCE
8045         IF (LIQTURB.EQ.1)THEN
8046          DO I=1,KRMAX_LL
8047            DO J=1,KRMAX_LL
8048                CWLL(I,J)=CTURBLL(I,J)*CWLL(I,J)
8049            END DO
8050          END DO
8051         END IF
8052          CALL MODKRN(TT,QQ,PP,PRDKRN,TTCOAL)
8053         DO 13 KR=1,NKR
8054          G1(KR)=FF1R(KR)*3.*XL(KR)*XL(KR)*1.E3
8055          G2(KR,1)=FF2R(KR,1)*3*xi(KR,1)*XI(KR,1)*1.e3
8056          G2(KR,2)=FF2R(KR,2)*3.*xi(KR,2)*XI(KR,2)*1.e3
8057          G2(KR,3)=FF2R(KR,3)*3.*xi(KR,3)*XI(KR,3)*1.e3
8058          G3(KR)=FF3R(KR)*3.*xs(kr)*xs(kr)*1.e3
8059          G4(KR)=FF4R(KR)*3.*xg(kr)*xg(kr)*1.e3
8060          G5(KR)=FF5R(KR)*3.*xh(kr)*xh(kr)*1.e3
8061          g2_1(kr)=g2(KR,1)
8062          g2_2(KR)=g2(KR,2)
8063          g2_3(KR)=g2(KR,3)
8064          if(kr.gt.(nkr-jbreak).and.g1(kr).gt.1.e-17)icol_drop_brk=1
8065 !        icol_drop_brk=0
8066          IF (IBREAKUP.NE.1)icol_drop_brk=0 
8067          if(g1(kr).gt.1.e-10)icol_drop=1
8068          if (tt.le.tt_no_coll)then
8069          if(g2_1(kr).gt.1.e-10)icol_column=1
8070          if(g2_2(kr).gt.1.e-10)icol_plate=1
8071          if(g2_3(kr).gt.1.e-10)icol_dendrite=1
8072          if(g3(kr).gt.1.e-10)icol_snow=1
8073          if(g4(kr).gt.1.e-10)icol_graupel=1
8074          if(g5(kr).gt.1.e-10)icol_hail=1
8075          end if
8076 13     CONTINUE 
8077 ! calculation of initial hydromteors content in g/cm**3 :
8078       cont_init_drop=0.
8079       cont_init_ice=0.
8080       do kr=1,nkr
8081          cont_init_drop=cont_init_drop+g1(kr)
8082          cont_init_ice=cont_init_ice+g3(kr)+g4(kr)+g5(kr)
8083          do ice=1,icemax
8084             cont_init_ice=cont_init_ice+g2(kr,ice)
8085          enddo
8086       enddo
8087       cont_init_drop=col*cont_init_drop*1.e-3
8088       cont_init_ice=col*cont_init_ice*1.e-3
8089 ! calculation of alwc in g/m**3
8090       alwc=cont_init_drop*1.e6
8091 ! calculation interactions :
8092 ! droplets - droplets and droplets - ice :
8093 ! water-water = water
8095       if (icol_drop.eq.1)then 
8096 ! break-up
8098        call coll_xxx (G1,CWLL,XL_MG,CHUCM,IMA,NKR)
8099 ! breakup!
8100        if(icol_drop_brk.eq.1)then
8101        ndiv=1
8102 10     continue
8103        do it = 1,ndiv
8104          if (ndiv.gt.1024)print*,'ndiv in coal_bott_new = ',ndiv
8105          if (ndiv.gt.10000) call wrf_error_fatal("fatal error in module_mp_full_sbm (ndiv.gt.10000), model stop")
8106          dtbreakup = dt_coll/ndiv
8107          if (it.eq.1)then
8108 !         do kr=1,nkr
8109           do kr=1,JMAX
8110            gdumb(kr)= g1(kr)*1.D-3
8111            xl_dumb(kr)=xl_mg(KR)*1.D-3
8112           end do
8113           break_drop_bef=0.d0
8114 !         do kr=1,nkr
8115           do kr=1,JMAX
8116             break_drop_bef=break_drop_bef+g1(kr)*1.D-3
8117           enddo
8118          end if
8119          call breakup(gdumb,xl_dumb,dtbreakup,brkweight, &
8120      &        pkij,qkj,JMAX,jbreak)
8121        end do
8122        break_drop_aft=0.0d0
8123        do kr=1,JMAX
8124            break_drop_aft=break_drop_aft+gdumb(kr)
8125        enddo
8126        break_drop_per=break_drop_aft/break_drop_bef
8127        if (break_drop_per.gt.1.001)then
8128            ndiv=ndiv*2
8129            GO TO 10
8130        else
8131            do kr=1,JMAX
8132             g1(kr)=gdumb(kr)*1.D3
8133            end do
8134        end if
8135        end if
8136       end if
8137        if (icol_snow.eq.1)then 
8138          call coll_xyz (g1,g3,g4,cwls,xl_mg,xs_mg, &
8139      &                chucm,ima,prdkrn1,nkr,0)
8140          if(alwc.lt.alcr) then
8141          call coll_xyx (g3,g1,cwsl,xs_mg,xl_mg, &
8142      &                chucm,ima,prdkrn1,nkr,1)
8143          endif
8144          if(alwc.ge.alcr) then
8145 !        call coll_xyz (g3,g1,g4,cwsl,xs_mg,xl_mg, &
8146 !    &                chucm,ima,prdkrn1,nkr,1)
8147             call coll_xyxz_h (g3,g1,g4,cwsl,xs_mg,xl_mg, &
8148      &                chucm,ima,prdkrn1,nkr,1)
8149          endif
8150 ! in case : icolxz_snow.ne.0
8151        end if
8152 ! interactions between water and  graupel (begin)
8153 ! water - graupel = graupel (t < tcrit ; xl_mg ge xg_mg)
8154 ! graupel - water = graupel (t < tcrit ; xg_mg > xl_mg)
8155 ! water - graupel = hail (t ge tcrit ; xl_mg ge xg_mg)
8156 ! graupel - water = hail (t ge tcrit ; xg_mg > xl_mg)
8157        if (icol_graupel.eq.1)then 
8158 ! water-graupel
8159 ! included kp_bound = 25
8160          call coll_xyyz_h (g1,g4,g5,cwlg,xl_mg,xg_mg, &
8161        &                chucm,ima,prdkrn1,nkr,1)
8162 ! for ice multiplication
8163           conc_old=0.
8164           conc_new=0.
8165           do kr=kr_icempl,nkr
8166                conc_old=conc_old+col*g1(kr)/xl_mg(kr)
8167           enddo
8168 ! graupel-water
8169            if(alwc.lt.alcr_g) then
8170 ! water-graupel
8171 ! TEST
8172             call coll_xyy (g1,g4,cwlg,xl_mg,xg_mg, &
8173      &               chucm,ima,prdkrn1,nkr,0)
8174             call coll_xyx (g4,g1,cwgl,xg_mg,xl_mg, &
8175      &          chucm,ima,prdkrn1,nkr,1)
8176 ! TEST
8177            else
8178             call coll_xyxz_h (g4,g1,g5,cwgl,xg_mg,xl_mg, &
8179      &                chucm,ima,prdkrn1,nkr,1)
8180            end if
8181 ! interactions between water and  graupels (end)
8183          if(icempl.eq.1) then
8184           if(tt.ge.265.15.and.tt.le.tcrit) then
8185 ! ice-multiplication :
8186             do kr=kr_icempl,nkr
8187                conc_new=conc_new+col*g1(kr)/xl_mg(kr)
8188             enddo
8189             dconc=conc_old-conc_new
8190             if(tt.le.268.15) then
8191               conc_icempl=dconc*4.e-3*(265.15-tt)/(265.15-268.15)
8192             endif
8193             if(tt.gt.268.15) then
8194              conc_icempl=dconc*4.e-3*(tcrit-tt)/(tcrit-268.15)
8195             endif
8196 !CHANGE FOR FOUR BIN SCHEME           g2_2(1)=g2_2(1)+conc_icempl*xi2_mg(1)/col
8197             g2_2(1)=g2_2(1)+conc_icempl*xi2_mg(1)/col
8198 !           g3(1)=g3(1)+conc_icempl*xs_mg(1)/col
8199 ! in case t.ge.265.15 :
8200           endif
8201 ! in case icempl=1
8202          endif
8203 ! interactions between water and  graupels (end)
8204 ! in case icolxz_graup.ne.0
8205        endif
8206 ! water - hail = hail (xl_mg ge xh_mg)                      (kxyy=2)
8207 ! hail - water = hail (xh_mg > xl_mg)                       (kxyx=3)
8208        if(icol_hail.eq.1) then
8209         call coll_xyy (g1,g5,cwlh,xl_mg,xh_mg, &
8210      &               chucm,ima,prdkrn1,nkr,0)
8211         call coll_xyx (g5,g1,cwhl,xh_mg,xl_mg, &
8212      &               chucm,ima,prdkrn1,nkr,1)
8213 ! in case icolxz_hail.ne.0
8214        endif
8215 ! interactions between water and hail (end)
8216 ! interactions between water and crystals :
8217 ! interactions between water and columns :
8218 ! water - columns = graupel (t < tcrit ; xl_mg ge xi_mg)    (kxyz=6)
8219 ! water - columns = hail (t ge tcrit ; xl_mg ge xi_mg)      (kxyz=7)
8220 ! columns - water = columns/graupel (xi_mg > xl_mg)             (kxyx=4); kxyxz=2)
8221 ! now: columns - water = columns (xi_mg > xl_mg)             (kxyx=4); kxyxz=2)
8222        if(icol_column.eq.1) then
8223         if(tt.lt.tcrit) then
8224          call coll_xyz (g1,g2_1,g4,cwli_1,xl_mg,xi1_mg, &
8225      &                 chucm,ima,prdkrn,nkr,0)
8226         endif
8227         if(tt.ge.tcrit) then
8228          call coll_xyz (g1,g2_1,g5,cwli_1,xl_mg,xi1_mg, &
8229      &                 chucm,ima,prdkrn,nkr,0)
8230         endif
8231         call coll_xyxz (g2_1,g1,g4,cwil_1,xi1_mg,xl_mg, &
8232      &                 chucm,ima,prdkrn,nkr,1)
8233         call coll_xyx (g2_1,g1,cwil_1,xi1_mg,xl_mg, &
8234      &                 chucm,ima,prdkrn,nkr,1)
8235 ! in case icolxz_column.ne.0
8236        endif
8238 !     if(icolxz_plate.ne.0) then
8239 ! interactions between water and plates :
8240 ! water - plates = graupel (t < tcrit ; xl_mg ge xi2_mg)    (kxyz=8)
8241 ! water - plates = hail (t ge tcrit ; xl_mg ge xi2_mg)      (kxyz=9)
8242 ! plates - water = plates/graupel (xi2_mg > xl_mg)              (kxyx=5; kxyxz=3)
8243 !now: plates - water = plates (xi2_mg > xl_mg)              (kxyx=5; kxyxz=3)
8244        if(icol_plate.eq.1) then
8245         if(tt.lt.tcrit) then
8246          call coll_xyz (g1,g2_2,g4,cwli_2,xl_mg,xi2_mg, &
8247      &                 chucm,ima,prdkrn,nkr,0)
8248         endif
8249         if(tt.ge.tcrit) then
8250          call coll_xyz (g1,g2_2,g5,cwli_2,xl_mg,xi2_mg, &
8251      &                 chucm,ima,prdkrn,nkr,0)
8252         endif
8253         call coll_xyxz (g2_2,g1,g4,cwil_2,xi2_mg,xl_mg, &
8254      &                 chucm,ima,prdkrn,nkr,1)
8255         call coll_xyx (g2_2,g1,cwil_2,xi2_mg,xl_mg, &
8256      &                 chucm,ima,prdkrn,nkr,1)
8257 ! in case icolxz_plate.ne.0
8258        endif
8260 ! interactions between water and dendrites :
8261 ! water - dendrites = graupel (t < tcrit ; xl_mg ge xi3_mg) (kxyz=10)
8262 ! water - dendrites = hail (t ge tcrit ; xl_mg ge xi3_mg)   (kxyz=11)
8263 ! dendrites - water = dendrites/graupel (xi3_mg > xl_mg)         (kxyx=6; kxyxz=4)
8264 !now dendrites - water = dendrites (xi3_mg > xl_mg)         (kxyx=6; kxyxz=4)
8265        if(icol_dendrite.eq.1) then
8266         if(tt.lt.tcrit) then
8267          call coll_xyz (g1,g2_3,g4,cwli_3,xl_mg,xi3_mg, &
8268      &                 chucm,ima,prdkrn,nkr,0)
8269         endif
8270         if(tt.ge.tcrit) then
8271          call coll_xyz (g1,g2_3,g5,cwli_3,xl_mg,xi3_mg, &
8272      &                 chucm,ima,prdkrn,nkr,0)
8273         endif
8274         call coll_xyxz (g2_3,g1,g4,cwil_3,xi3_mg,xl_mg, &
8275      &                 chucm,ima,prdkrn,nkr,1)
8276         call coll_xyx (g2_3,g1,cwil_3,xi3_mg,xl_mg, &
8277      &                 chucm,ima,prdkrn,nkr,1)
8278 ! in case icolxz_dendr.ne.0
8279        endif
8280 ! interactions between water and dendrites (end)
8281 ! in case icolxz_drop.ne.0
8282 !     endif
8283 ! interactions between water and crystals (end)
8285 ! interactions between crystals :
8286 ! if(t.le.TTCOAL) - no interactions between crystals
8287       if(tt.gt.TTCOAL) then
8288 ! interactions between columns and other particles (begin)
8289        if(icol_column.eq.1) then
8290 ! columns - columns = snow
8291         call coll_xxy (g2_1,g3,cwii_1_1,xi1_mg, &
8292      &                 chucm,ima,prdkrn,nkr)
8293 ! interactions between columns and plates :
8294 ! columns - plates = snow (xi1_mg ge xi2_mg)                (kxyz=12)
8295 ! plates - columns = snow (xi2_mg > xi1_mg)                 (kxyz=13)
8296         if(icol_plate.eq.1) then     
8297          call coll_xyz (g2_1,g2_2,g3,cwii_1_2,xi1_mg,xi2_mg, &
8298      &                 chucm,ima,prdkrn,nkr,0)
8299          call coll_xyz (g2_2,g2_1,g3,cwii_2_1,xi2_mg,xi1_mg, &
8300      &                 chucm,ima,prdkrn,nkr,1)
8301         end if
8302 ! interactions between columns and dendrites :
8303 ! columns - dendrites = snow (xi1_mg ge xi3_mg)             (kxyz=14)
8304 ! dendrites - columns = snow (xi3_mg > xi1_mg)              (kxyz=15)
8305         if(icol_dendrite.eq.1) then
8306            call coll_xyz (g2_1,g2_3,g3,cwii_1_3,xi1_mg,xi3_mg, &
8307      &                 chucm,ima,prdkrn,nkr,0)
8308            call coll_xyz (g2_3,g2_1,g3,cwii_3_1,xi3_mg,xi1_mg, &
8309      &                 chucm,ima,prdkrn,nkr,1)
8310         end if
8311 ! interactions between columns and snow :
8312 ! columns - snow = snow (xi1_mg ge xs_mg)                   (kxyy=3)
8313 ! snow - columns = snow (xs_mg > xi1_mg)                    (kxyx=7)
8314 ! ALEX?
8315         if(icol_snow.eq.1) then
8316          call coll_xyy (g2_1,g3,cwis_1,xi1_mg,xs_mg, &
8317      &                 chucm,ima,prdkrn,nkr,0)
8318          call coll_xyx (g3,g2_1,cwsi_1,xs_mg,xi1_mg, &
8319      &                 chucm,ima,prdkrn,nkr,1)
8320         endif          
8321 ! in case icolxz_column.ne.0
8322        endif
8323 ! interactions between columns and other particles (end)
8324 ! interactions between plates and other particles (begin)
8325 ! plates - plates = snow
8326        if(icol_plate.eq.1) then
8327         call coll_xxy (g2_2,g3,cwii_2_2,xi2_mg, &
8328      &                 chucm,ima,prdkrn,nkr)
8329 ! interactions between plates and dendrites :
8330 ! plates - dendrites = snow (xi2_mg ge xi3_mg)              (kxyz=17)
8331 ! dendrites - plates = snow (xi3_mg > xi2_mg)               (kxyz=18)
8332         if(icol_dendrite.eq.1) then
8333          call coll_xyz (g2_2,g2_3,g3,cwii_2_3,xi2_mg,xi3_mg, &
8334      &                 chucm,ima,prdkrn,nkr,0)
8335          call coll_xyz (g2_3,g2_2,g3,cwii_3_2,xi3_mg,xi2_mg, &
8336      &                 chucm,ima,prdkrn,nkr,1)
8337         end if
8338 ! interactions between plates and snow :
8339 ! plates - snow = snow (xi2_mg ge xs_mg)                    (kxyy=4)
8340 ! snow - plates = snow (xs_mg > xi2_mg)                     (kxyx=12)
8341         if(icol_snow.eq.1) then
8342 ! ALEX
8343          call coll_xyy (g2_2,g3,cwis_2,xi2_mg,xs_mg, &
8344      &                 chucm,ima,prdkrn,nkr,0)
8345           call coll_xyx (g3,g2_2,cwsi_2,xs_mg,xi2_mg, &
8346      &                 chucm,ima,prdkrn,nkr,1)
8347          end if
8348 ! in case icolxz_plate.ne.0
8349        endif
8350 ! interactions between plates and others particles (end)
8351 ! interactions between dendrites and other hydrometeors (begin)
8352 ! dendrites - dendrites = snow
8353        if(icol_dendrite.eq.1) then
8354          call coll_xxy (g2_3,g3,cwii_3_3,xi3_mg, &
8355       &                  chucm,ima,prdkrn,nkr)
8356 ! interactions between dendrites and snow :
8357 ! dendrites - snow = snow (xi3_mg ge xs_mg)                 (kxyy=5)
8358 ! snow - dendrites = snow (xs_mg > xi3_mg)                  (kxyx=17)
8359         if(icol_snow.eq.1) then
8360 ! ALEX
8361          call coll_xyy (g2_3,g3,cwis_3,xi3_mg,xs_mg,  &
8362      &                 chucm,ima,prdkrn,nkr,0)
8363           call coll_xyx (g3,g2_3,cwsi_3,xs_mg,xi3_mg, &
8364      &                 chucm,ima,prdkrn,nkr,1)
8365         end if
8366 ! in case icolxz_dendr.ne.0
8367        endif
8368 ! interactions between dendrites and other hydrometeors (end)
8369 ! interactions between snowflakes and other hydromteors (begin)
8370         if(icol_snow.ne.0) then
8371 ! interactions between snowflakes
8372 ! snow - snow = snow
8373          call coll_xxx_prd (g3,cwss,xs_mg,chucm,ima,prdkrn,nkr)
8374 ! interactions between snowflakes and graupels :
8375 ! snow - graupel = snow (xs_mg > xg_mg)                     (kxyx=22)
8376 ! graupel - snow = graupel (xg_mg ge xs_mg)                 (kxyx=23)
8377          if(icol_graupel.eq.1) then
8378            call coll_xyx (g3,g4,cwsg,xs_mg,xg_mg, &
8379      &                chucm,ima,prdkrn,nkr,1)
8380 ! in case icolxz_graup.ne.0
8381          endif
8382 ! in case icolxz_snow.ne.0
8383         endif
8384 ! interactions between snowflakes and other hydromteors (end)
8385 ! in case : t > TTCOAL
8386       endif
8387 ! in case : t > TTCOAL or t.le.TTCOAL
8388 ! calculation of finish hydrometeors contents in g/cm**3 :
8389       cont_fin_drop=0.
8390       cont_fin_ice=0.
8391       do kr=1,nkr
8392          g2(kr,1)=g2_1(kr)
8393          g2(kr,2)=g2_2(kr)
8394          g2(kr,3)=g2_3(kr)
8395          cont_fin_drop=cont_fin_drop+g1(kr)
8396          cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)+g5(kr)
8397 !        cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)
8398          do ice=1,icemax
8399             cont_fin_ice=cont_fin_ice+g2(kr,ice)
8400          enddo
8401       enddo
8402       cont_fin_drop=col*cont_fin_drop*1.e-3
8403       cont_fin_ice=col*cont_fin_ice*1.e-3
8404       deldrop=cont_init_drop-cont_fin_drop
8405 ! deldrop in g/cm**3
8406 ! resulted value of temperature (rob in g/cm**3) :
8407       if(t_new.le.273.15) then
8408         if(deldrop.ge.0.) then
8409           t_new=t_new+320.*deldrop/rho
8410         else
8411 ! if deldrop < 0
8412           if(abs(deldrop).gt.cont_init_drop*0.05) then
8413             call wrf_error_fatal("fatal error in module_mp_full_sbm (abs(deldrop).gt.cont_init_drop), model stop")
8414           endif
8415         endif
8416        endif
8418 61    continue
8419 ! recalculation of density function f1,f2,f3,f4,f5 in 1/(g*cm**3) :  
8420         DO 15 KR=1,NKR
8421          FF1R(KR)=G1(KR)/(3.*XL(KR)*XL(KR)*1.E3)
8422          FF2R(KR,1)=G2(KR,1)/(3*xi(KR,1)*XI(KR,1)*1.e3)
8423          FF2R(KR,2)=G2(KR,2)/(3.*xi(KR,2)*XI(KR,2)*1.e3)
8424          FF2R(KR,3)=G2(KR,3)/(3.*xi(KR,3)*XI(KR,3)*1.e3)
8425          FF3R(KR)=G3(KR)/(3.*xs(kr)*xs(kr)*1.e3)
8426          FF4R(KR)=G4(KR)/(3.*xg(kr)*xg(kr)*1.e3)
8427          FF5R(KR)=G5(KR)/(3.*xh(kr)*xh(kr)*1.e3)
8428 15     CONTINUE 
8429       tt=t_new
8430       RETURN
8431       END SUBROUTINE COAL_BOTT_NEW
8432       SUBROUTINE MISC1(PP,cwll_1000mb,cwll_750mb,cwll_500mb, &
8433      &      cwll,nkr)
8434       IMPLICIT NONE
8435       INTEGER kr1,kr2,NKR
8436       DOUBLE PRECISION PP
8437       REAL P_Z
8438       double precision cwll(nkr,nkr),cwll_1,cwll_2,cwll_3 &
8439      &,cwll_1000mb(nkr,nkr),cwll_750mb(nkr,nkr),cwll_500mb(nkr,nkr)
8440       P_Z=PP
8441               do 12 kr1=1,nkr
8442               do 12 kr2=1,nkr
8443                cwll_1=cwll_1000mb(kr1,kr2)
8444                cwll_2=cwll_750mb(kr1,kr2)
8445                cwll_3=cwll_500mb(kr1,kr2)
8446                if(p_z.ge.p1) cwll(kr1,kr2)=cwll_1
8447                if(p_z.eq.p2) cwll(kr1,kr2)=cwll_2
8448                if(p_z.eq.p3) cwll(kr1,kr2)=cwll_3
8449                if(p_z.lt.p1.and.p_z.gt.p2) &
8450      &         cwll(kr1,kr2)=cwll_2+ &
8451      &         (cwll_1-cwll_2)*(p_z-p2)/(p1-p2) 
8452                if(p_z.lt.p2.and.p_z.gt.p3) &
8453      &         cwll(kr1,kr2)=cwll_3+ &
8454      &         (cwll_2-cwll_3)*(p_z-p3)/(p2-p3)
8455                if(p_z.lt.p3) cwll(kr1,kr2)=cwll_3
8456 12            CONTINUE 
8457       RETURN
8458       END SUBROUTINE  MISC1
8460         subroutine coll_xxx (g,ckxx,x,chucm,ima,nkr)
8461         implicit double precision (a-h,o-z)
8462         dimension g(nkr),ckxx(nkr,nkr),x(0:nkr)
8463         dimension chucm(nkr,nkr)
8464         double precision ima(nkr,nkr)
8465         gmin=1.d-60
8466 !       gmin=1.d-15
8467 ! lower and upper integration limit ix0,ix1
8468         do i=1,nkr-1
8469            ix0=i
8470            if(g(i).gt.gmin) goto 2000
8471         enddo
8472  2000   continue
8473         if(ix0.eq.nkr-1) goto 2020
8474         do i=nkr-1,1,-1
8475            ix1=i
8476            if(g(i).gt.gmin) goto 2010
8477         enddo
8478  2010   continue
8479 ! J. Dudhia gave reasons why this can't be looped with a
8480 ! multiprocessor.
8481 ! BARRY
8482 !       do i=ix0,ix1
8483 !          do j=i,ix1
8484         do i=ix0,ix1-1
8485            do j=i+1,ix1
8487               k=ima(i,j)
8488               kp=k+1
8489               x0=ckxx(i,j)*g(i)*g(j)
8490               x0=min(x0,g(i)*x(j))
8491               if(j.ne.k) then
8492                 x0=min(x0,g(j)*x(i))
8493               endif
8494               gsi=x0/x(j)
8495               gsj=x0/x(i)
8496               gsk=gsi+gsj
8497               g(i)=g(i)-gsi
8498               if(g(i).lt.0.d0) g(i)=0.d0
8499               g(j)=g(j)-gsj
8500               gk=g(k)+gsk
8501               if(g(j).lt.0.d0.and.gk.lt.gmin) then
8502                 g(j)=0.d0
8503                 g(k)=g(k)+gsi
8504               endif
8505               flux=0.d0
8507 ! BARRY
8508               if(gk.gt.gmin) then
8509                 x1=dlog(g(kp)/gk+1.d-15)
8510                if (x1.eq.0)then
8511                 flux=0  
8512                else
8513                 flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
8514                 flux=min(flux,gsk)
8515                end if
8517 ! new changes 23.01.01 (end)
8518                 g(k)=gk-flux
8519                 if(g(k).lt.0.d0) g(k)=0.d0
8520                 g(kp)=g(kp)+flux
8521 ! in case gk > gmin :
8522               endif
8523             end do
8524         end do
8525  2020   continue
8526         return
8527         end subroutine coll_xxx
8528         subroutine coll_xxx_prd (g,ckxx,x,chucm,ima,prdkrn,nkr)
8529         implicit double precision (a-h,o-z)
8530         dimension g(nkr),ckxx(nkr,nkr),x(0:nkr)
8531         dimension chucm(nkr,nkr)
8532         double precision ima(nkr,nkr)
8533 ! this is character values containes adresses of temporary files      
8534         gmin=1.d-60
8535 !       gmin=1.d-15
8536 ! lower and upper integration limit ix0,ix1
8537         do i=1,nkr-1
8538            ix0=i
8539            if(g(i).gt.gmin) goto 2000
8540         enddo
8541  2000   continue
8542         if(ix0.eq.nkr-1) goto 2020
8543         do i=nkr-1,1,-1
8544            ix1=i
8545            if(g(i).gt.gmin) goto 2010
8546         enddo
8547  2010   continue
8548 ! J. Dudhia gave reasons why this can't be looped with a
8549 ! multiprocessor.
8550 ! BARRY
8551 !       do i=ix0,ix1
8552 !          do j=i,ix1
8553         do i=ix0,ix1-1
8554            do j=i+1,ix1
8556               k=ima(i,j)
8557               kp=k+1
8558               x0=ckxx(i,j)*g(i)*g(j)*prdkrn
8559               x0=min(x0,g(i)*x(j))
8560               if(j.ne.k) then
8561                 x0=min(x0,g(j)*x(i))
8562               endif
8563               gsi=x0/x(j)
8564               gsj=x0/x(i)
8565               gsk=gsi+gsj
8566               g(i)=g(i)-gsi
8567               if(g(i).lt.0.d0) g(i)=0.d0
8568               g(j)=g(j)-gsj
8569               gk=g(k)+gsk
8570               if(g(j).lt.0.d0.and.gk.lt.gmin) then
8571                 g(j)=0.d0
8572                 g(k)=g(k)+gsi
8573               endif
8574               flux=0.d0
8576 ! BARRY
8577               if(gk.gt.gmin) then
8578                 x1=dlog(g(kp)/gk+1.d-15)
8579                if (x1.eq.0)then
8580                 flux=0  
8581                else
8582                 flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
8583                 flux=min(flux,gsk)
8584                end if
8586 ! new changes 23.01.01 (end)
8587                 g(k)=gk-flux
8588                 if(g(k).lt.0.d0) g(k)=0.d0
8589                 g(kp)=g(kp)+flux
8590 ! in case gk > gmin :
8591               endif
8592             end do
8593         end do
8594  2020   continue
8595         return
8596         end subroutine coll_xxx_prd 
8597       subroutine modkrn(TT,QQ,PP,PRDKRN,TTCOAL)
8598       implicit none
8599       real epsf,tc,ttt1,ttt,factor,qs2,qq1,dele,f,factor_t
8600       double precision TT,QQ,PP,satq2,t,p
8601       double precision prdkrn
8602       REAL at,bt,ct,dt,temp,a,b,c,d,tc_min,tc_max
8603        real factor_max,factor_min
8604       REAL TTCOAL
8605         data at,bt,ct,dt/0.88333,0.0931878,0.0034793,4.5185186e-05/
8606         satq2(t,p)=3.80e3*(10**(9.76421-2667.1/t))/p
8607         temp(a,b,c,d,tc)=d*tc*tc*tc+c*tc*tc+b*tc+a
8608         IF (QQ.LE.0)QQ=1.E-12
8609         epsf    =.5
8610         tc      =tt-273.15
8611         factor=1  !mchen add 
8612         if(tc.le.0) then
8613 ! in case tc.le.0
8614           ttt1  =temp(at,bt,ct,dt,tc)
8615           ttt   =ttt1
8616           qs2   =satq2(tt,pp)
8617           qq1   =qq*(0.622+0.378*qs2)/(0.622+0.378*qq)/qs2
8618           dele  =ttt*qq1
8619 ! new change 27.06.00
8620           if(tc.ge.-6.) then
8621             factor = dele
8622             if(factor.lt.epsf) factor=epsf
8623             if(factor.gt.1.) factor=1.
8624 ! in case : tc.ge.-6.
8625           endif                        
8626           factor_t=factor
8627           if(tc.ge.-12.5.and.tc.lt.-6.) factor_t=0.5
8628           if(tc.ge.-17.0.and.tc.lt.-12.5) factor_t=1.
8629           if(tc.ge.-20.0.and.tc.lt.-17.) factor_t=0.4
8630           if(tc.lt.-20.) then
8631             tc_min=ttcoal-273.15
8632             tc_max=-20.
8633             factor_max=0.25
8634             factor_min=0.
8635             f=factor_min+(tc-tc_min)*(factor_max-factor_min)/  &
8636      &                               (tc_max-tc_min)
8637             factor_t=f
8638           endif
8639 ! BARRY
8640           if (factor_t.lt.0)factor_t=0.01
8641           prdkrn=factor_t
8642       else
8643           prdkrn=1.d0
8644       end if
8645       RETURN
8646       END SUBROUTINE modkrn 
8647            
8650         subroutine coll_xxy(gx,gy,ckxx,x,chucm,ima,prdkrn,nkr)
8651         implicit double precision (a-h,o-z)
8652         dimension chucm(nkr,nkr)
8653         double precision ima(nkr,nkr)
8654         dimension  &
8655      &  gx(nkr),gy(nkr),ckxx(nkr,nkr),x(0:nkr)
8656         gmin=1.d-60
8657 ! lower and upper integration limit ix0,ix1
8658         do i=1,nkr-1
8659            ix0=i
8660            if(gx(i).gt.gmin) goto 2000
8661         enddo
8662         if(ix0.eq.nkr-1) goto 2020
8663  2000   continue
8664         do i=nkr-1,1,-1
8665            ix1=i
8666            if(gx(i).gt.gmin) goto 2010
8667         enddo
8668  2010   continue
8669 ! collisions
8670         do i=ix0,ix1
8671            do j=i,ix1
8672               k=ima(i,j)
8673               kp=k+1
8674               x0=ckxx(i,j)*gx(i)*gx(j)*prdkrn
8675               x0=min(x0,gx(i)*x(j))
8676               x0=min(x0,gx(j)*x(i))
8677               gsi=x0/x(j)
8678               gsj=x0/x(i)
8679               gsk=gsi+gsj
8680               gx(i)=gx(i)-gsi
8681               if(gx(i).lt.0.d0) gx(i)=0.d0
8682               gx(j)=gx(j)-gsj
8683               if(gx(j).lt.0.d0) gx(j)=0.d0
8684               gk=gy(k)+gsk
8685               flux=0.d0
8686 ! BARRY
8687               if(gk.gt.gmin) then
8688 ! new changes 13.01.01 (begin)
8689                 x1=dlog(gy(kp)/gk+1.d-15)
8690 ! BARRY
8691 !               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
8692 ! new changes 23.01.01 (begin)
8693 !               flux=min(flux,gk)
8694 !               flux=min(flux,gsk)
8695 ! new changes 23.01.01 (end)
8696 ! new changes 13.01.01 (end)
8697 ! BARRY
8698                if (x1.eq.0)then
8699                 flux=0  
8700                else
8701                 flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
8702                 flux=min(flux,gsk)
8703                end if
8704                 gy(k)=gk-flux
8705                 if(gy(k).lt.0.d0) gy(k)=0.d0
8706                 gy(kp)=gy(kp)+flux
8707 ! in case gk > gmin :
8708               endif
8709            enddo
8710         enddo
8711  2020   continue
8712         return
8713         end subroutine coll_xxy
8714 !====================================================================
8715         subroutine coll_xyy(gx,gy,ckxy,x,y,chucm,ima, &
8716      &     prdkrn,nkr,indc)
8717         implicit double precision (a-h,o-z)
8718         dimension  &
8719      &  gy(nkr),gx(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
8720         dimension chucm(nkr,nkr)
8721         double precision ima(nkr,nkr)
8722         gmin=1.d-60
8723 ! lower and upper integration limit ix0,ix1
8724         do i=1,nkr-1
8725            ix0=i
8726            if(gx(i).gt.gmin) go to 2000
8727         enddo
8728  2000   continue
8729         if(ix0.eq.nkr-1) goto 2020
8730         do i=nkr-1,1,-1
8731            ix1=i
8732            if(gx(i).gt.gmin) go to 2010
8733         enddo
8734  2010   continue
8735 ! lower and upper integration limit iy0,iy1
8736         do i=1,nkr-1
8737            iy0=i
8738            if(gy(i).gt.gmin) go to 2001
8739         enddo
8740  2001   continue
8741         if(iy0.eq.nkr-1) goto 2020
8742         do i=nkr-1,1,-1
8743            iy1=i
8744            if(gy(i).gt.gmin) go to 2011
8745         enddo
8746  2011   continue
8747 ! collisions :
8748         do i=iy0,iy1
8749            jmin=i
8750            if(jmin.eq.(nkr-1)) goto 2020
8751            if(i.lt.ix0) jmin=ix0-indc
8752            do j=jmin+indc,ix1         
8753               k=ima(i,j)
8754               kp=k+1
8755               x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
8756               x0=min(x0,gy(i)*x(j))
8757               x0=min(x0,gx(j)*y(i))
8758               gsi=x0/x(j)
8759               gsj=x0/y(i)
8760               gsk=gsi+gsj
8761               gy(i)=gy(i)-gsi
8762               if(gy(i).lt.0.d0) gy(i)=0.d0
8763               gx(j)=gx(j)-gsj
8764               if(gx(j).lt.0.d0) gx(j)=0.d0
8765               gk=gy(k)+gsk
8766               flux=0.d0
8767 ! BARRY
8768               if(gk.gt.gmin) then
8769                 x1=dlog(gy(kp)/gk+1.d-15)
8770 ! BARRY
8771 !               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
8772 ! new changes 23.01.01 (begin)
8773 !               flux=min(flux,gk)
8774 !               flux=min(flux,gsk)
8775 ! BARRY
8776                if (x1.eq.0)then
8777                 flux=0  
8778                else
8779                 flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
8780                 flux=min(flux,gsk)
8781                end if
8782 ! new changes 23.01.01 (end)
8783                 gy(k)=gk-flux
8784                 if(gy(k).lt.0.d0) gy(k)=0.d0
8785                 gy(kp)=gy(kp)+flux
8786 ! in case gk > gmin :
8787               endif
8788 ! in case gk > gmin or gk.le.gmin
8789            enddo
8790         enddo
8791  2020   continue
8792         return
8793         end subroutine coll_xyy
8794 !=================================================================
8795         subroutine coll_xyx(gx,gy,ckxy,x,y,chucm,ima, &
8796      &    prdkrn,nkr,indc)
8797         implicit double precision (a-h,o-z)
8798         dimension gy(nkr),gx(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
8799         dimension chucm(nkr,nkr)
8800         double precision ima(nkr,nkr)
8801         gmin=1.d-60
8802 ! lower and upper integration limit ix0,ix1
8803         do i=1,nkr-1
8804            ix0=i
8805            if(gx(i).gt.gmin) go to 2000
8806         enddo
8807  2000   continue
8808         if(ix0.eq.nkr-1) goto 2020
8809         do i=nkr-1,1,-1
8810            ix1=i
8811            if(gx(i).gt.gmin) go to 2010
8812         enddo
8813  2010   continue
8814 ! lower and upper integration limit iy0,iy1
8815         do i=1,nkr-1
8816            iy0=i
8817            if(gy(i).gt.gmin) go to 2001
8818         enddo
8819  2001   continue
8820         if(iy0.eq.nkr-1) goto 2020
8821         do i=nkr-1,1,-1
8822            iy1=i
8823            if(gy(i).gt.gmin) go to 2011
8824         enddo
8825  2011   continue
8826 ! collisions :
8827         do i=iy0,iy1
8828            jmin=i
8829            if(jmin.eq.(nkr-1)) goto 2020
8830            if(i.lt.ix0) jmin=ix0-indc
8831            do j=jmin+indc,ix1
8832               k=ima(i,j)
8833               kp=k+1
8834               x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
8835               x0=min(x0,gy(i)*x(j))
8836               if(j.ne.k) then
8837                 x0=min(x0,gx(j)*y(i))
8838               endif
8839               gsi=x0/x(j)
8840               gsj=x0/y(i)
8841               gsk=gsi+gsj
8842               gy(i)=gy(i)-gsi
8843               if(gy(i).lt.0.d0) gy(i)=0.d0
8844               gx(j)=gx(j)-gsj
8845               gk=gx(k)+gsk
8846 ! BARRY
8847 !             if(gx(j).lt.0.d0)then
8848 !                gy(i)=gy(i)+gsi
8849 !                gx(j)=gx(j)+gsj
8850 !                go to 10
8851 !             end if
8852               if(gx(j).lt.0.d0.and.gk.lt.gmin) then
8853                 gx(j)=0.d0
8854                 gx(k)=gx(k)+gsi
8855               endif
8856               flux=0.d0            
8857 ! BARRY
8858               if(gk.gt.gmin) then
8859                 x1=dlog(gx(kp)/gk+1.d-15)
8860 ! BARRY
8861 !               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
8862 ! new changes 23.01.01 (begin)
8863 !               flux=min(flux,gk)
8864 !               flux=min(flux,gsk)
8865 ! BARRY
8866                if (x1.eq.0)then
8867                 flux=0  
8868                else
8869                 flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
8870                 flux=min(flux,gsk)
8871                end if
8872 ! new changes 23.01.01 (end)
8873                 gx(k)=gk-flux
8874                 if(gx(k).lt.0.d0) gx(k)=0.d0
8875                 gx(kp)=gx(kp)+flux
8876 ! in case gk > gmin :
8877               endif
8878 ! in case gk > gmin or gk.le.gmin
8879 ! BARRY
8880 10         continue
8881            enddo
8882         enddo
8883  2020   continue
8884         return
8885         end subroutine coll_xyx
8886 !=====================================================================
8887         subroutine coll_xyxz(gx,gy,gz,ckxy,x,y,chucm,ima, &
8888      &    prdkrn,nkr,indc)
8889         implicit double precision (a-h,o-z)
8890       dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
8891         dimension chucm(nkr,nkr)
8892         double precision ima(nkr,nkr)
8893         gmin=1.d-60
8894 ! lower and upper integration limit ix0,ix1
8895         do i=1,nkr-1
8896            ix0=i
8897            if(gx(i).gt.gmin) go to 2000
8898         enddo
8899  2000   continue
8900         if(ix0.eq.nkr-1) goto 2020
8901         do i=nkr-1,1,-1
8902            ix1=i
8903            if(gx(i).gt.gmin) go to 2010
8904         enddo
8905  2010   continue
8906 ! lower and upper integration limit iy0,iy1
8907         do i=1,nkr-1
8908            iy0=i
8909            if(gy(i).gt.gmin) go to 2001
8910         enddo
8911  2001   continue
8912         if(iy0.eq.nkr-1) goto 2020
8913         do i=nkr-1,1,-1
8914            iy1=i
8915            if(gy(i).gt.gmin) go to 2011
8916         enddo
8917  2011   continue
8918 ! collisions :
8919         do i=iy0,iy1
8920            jmin=i
8921            if(jmin.eq.(nkr-1)) goto 2020
8922            if(i.lt.ix0) jmin=ix0-indc
8923            do j=jmin+indc,ix1
8924               k=ima(i,j)
8925               kp=k+1
8926               x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
8927               x0=min(x0,gy(i)*x(j))
8928               if(j.ne.k) then
8929                 x0=min(x0,gx(j)*y(i))
8930               endif
8931               gsi=x0/x(j)
8932               gsj=x0/y(i)
8933               gsk=gsi+gsj
8934               gy(i)=gy(i)-gsi
8935               if(gy(i).lt.0.d0) gy(i)=0.d0
8936               gx(j)=gx(j)-gsj
8937               gk=gx(k)+gsk
8938               if(gx(j).lt.0.d0.and.gk.lt.gmin) then
8939                 gx(j)=0.d0
8940                 gx(k)=gx(k)+gsi
8941               endif
8942               flux=0.d0
8943 ! BARRY
8944               if(kp.lt.17) gkp=gx(kp)
8945               if(kp.ge.17) gkp=gz(kp)
8946               if(gk.gt.gmin) then
8947                 x1=dlog(gkp/gk+1.d-15)
8948 ! BARRY
8949 !               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
8950 ! new changes 23.01.01 (begin)
8951 !               flux=min(flux,gk)
8952 !               flux=min(flux,gsk)
8953 ! BARRY
8954                if (x1.eq.0)then
8955                 flux=0  
8956                else
8957                 flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
8958                 flux=min(flux,gsk)
8959                end if
8960 ! new changes 23.01.01 (end)
8961                 gx(k)=gk-flux
8962                 if(gx(k).lt.0.d0) gx(k)=0.d0
8963                 if(kp.lt.17) gx(kp)=gkp+flux
8964                 if(kp.ge.17) gz(kp)=gkp+flux
8965 ! ALEX 15 11 2005
8966 !               if(kp.ge.17) gx(kp)=gkp+flux
8967 ! in case gk > gmin :
8968               endif
8969 ! in case gk > gmin or gk.le.gmin
8970            enddo
8971         enddo
8972  2020   continue
8973         return
8974         end subroutine coll_xyxz
8975 !=====================================================================
8976         subroutine coll_xyxz_h(gx,gy,gz,ckxy,x,y,chucm,ima, &
8977      &    prdkrn,nkr,indc)
8978         implicit double precision (a-h,o-z)
8979       dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
8980         dimension chucm(nkr,nkr)
8981         double precision ima(nkr,nkr)
8982         gmin=1.d-60
8983 ! lower and upper integration limit ix0,ix1
8984         do i=1,nkr-1
8985            ix0=i
8986            if(gx(i).gt.gmin) go to 2000
8987         enddo
8988  2000   continue
8989         if(ix0.eq.nkr-1) goto 2020
8990         do i=nkr-1,1,-1
8991            ix1=i
8992            if(gx(i).gt.gmin) go to 2010
8993         enddo
8994  2010   continue
8995 ! lower and upper integration limit iy0,iy1
8996         do i=1,nkr-1
8997            iy0=i
8998            if(gy(i).gt.gmin) go to 2001
8999         enddo
9000  2001   continue
9001         if(iy0.eq.nkr-1) goto 2020
9002         do i=nkr-1,1,-1
9003            iy1=i
9004            if(gy(i).gt.gmin) go to 2011
9005         enddo
9006  2011   continue
9007 ! collisions :
9008         do i=iy0,iy1
9009            jmin=i
9010            if(jmin.eq.(nkr-1)) goto 2020
9011            if(i.lt.ix0) jmin=ix0-indc
9012            do j=jmin+indc,ix1
9013               k=ima(i,j)
9014               kp=k+1
9015               x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
9016               x0=min(x0,gy(i)*x(j))
9017               if(j.ne.k) then
9018                 x0=min(x0,gx(j)*y(i))
9019               endif
9020               gsi=x0/x(j)
9021               gsj=x0/y(i)
9022               gsk=gsi+gsj
9023               gy(i)=gy(i)-gsi
9024               if(gy(i).lt.0.d0) gy(i)=0.d0
9025               gx(j)=gx(j)-gsj
9026               gk=gx(k)+gsk
9027               if(gx(j).lt.0.d0.and.gk.lt.gmin) then
9028                 gx(j)=0.d0
9029                 gx(k)=gx(k)+gsi
9030               endif
9031               flux=0.d0
9032 ! BARRY
9033               if(kp.lt.22) gkp=gx(kp)
9034               if(kp.ge.22) gkp=gz(kp)
9035               if(gk.gt.gmin) then
9036                 x1=dlog(gkp/gk+1.d-15)
9037 ! BARRY
9038 !               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
9039 ! new changes 23.01.01 (begin)
9040 !               flux=min(flux,gk)
9041 !               flux=min(flux,gsk)
9042 ! BARRY
9043                if (x1.eq.0)then
9044                 flux=0  
9045                else
9046                 flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
9047                 flux=min(flux,gsk)
9048                end if
9049 ! new changes 23.01.01 (end)
9050                 gx(k)=gk-flux
9051                 if(gx(k).lt.0.d0) gx(k)=0.d0
9052                 if(kp.lt.22) gx(kp)=gkp+flux
9053                 if(kp.ge.22) gz(kp)=gkp+flux
9054 ! ALEX 15 11 2005
9055 !               if(kp.ge.25) gx(kp)=gkp+flux
9056 ! in case gk > gmin :
9057               endif
9058 ! in case gk > gmin or gk.le.gmin
9059            enddo
9060         enddo
9061  2020   continue
9062         return
9063         end subroutine coll_xyxz_h
9064 !=====================================================================
9065         subroutine coll_xyz(gx,gy,gz,ckxy,x,y,chucm,ima, &
9066      &                      prdkrn,nkr,indc)
9067         implicit double precision (a-h,o-z)
9068       dimension gx(nkr),gy(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
9069         dimension chucm(nkr,nkr)
9070         double precision ima(nkr,nkr)
9071         gmin=1.d-60
9072 ! lower and upper integration limit ix0,ix1
9073         do i=1,nkr-1
9074            ix0=i
9075            if(gx(i).gt.gmin) go to 2000
9076         enddo
9077  2000   continue
9078         if(ix0.eq.nkr-1) goto 2020
9079         do i=nkr-1,1,-1
9080            ix1=i
9081            if(gx(i).gt.gmin) go to 2010
9082         enddo
9083  2010   continue
9084 ! lower and upper integration limit iy0,iy1
9085         do i=1,nkr-1
9086            iy0=i
9087            if(gy(i).gt.gmin) go to 2001
9088         enddo
9089  2001   continue
9090         if(iy0.eq.nkr-1) goto 2020
9091         do i=nkr-1,1,-1
9092            iy1=i
9093            if(gy(i).gt.gmin) go to 2011
9094         enddo
9095  2011   continue
9096 ! collisions :
9097         do i=iy0,iy1
9098            jmin=i
9099            if(jmin.eq.(nkr-1)) goto 2020
9100            if(i.lt.ix0) jmin=ix0-indc
9101            do j=jmin+indc,ix1         
9102               k=ima(i,j)
9103               kp=k+1
9104               x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
9105               x0=min(x0,gy(i)*x(j))
9106               x0=min(x0,gx(j)*y(i))
9107               gsi=x0/x(j)
9108               gsj=x0/y(i)
9109               gsk=gsi+gsj
9110               gy(i)=gy(i)-gsi
9111               if(gy(i).lt.0.d0) gy(i)=0.d0
9112               gx(j)=gx(j)-gsj
9113               if(gx(j).lt.0.d0) gx(j)=0.d0
9114               gk=gz(k)+gsk
9115               flux=0.d0
9116 ! BARRY
9117               if(gk.gt.gmin) then
9118                 x1=dlog(gz(kp)/gk+1.d-15)
9119 ! BARRY
9120                if (x1.eq.0)then
9121                 flux=0  
9122                else
9123                 flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
9124                 flux=min(flux,gsk)
9125                end if
9126 ! new changes 23.01.01 (end)
9127                 gz(k)=gk-flux
9128                 if(gz(k).lt.0.d0) gz(k)=0.d0
9129                 gz(kp)=gz(kp)+flux
9130 ! in case gk > gmin :
9131               endif
9132            enddo
9133         enddo
9134  2020   continue
9135         return
9136         end subroutine coll_xyz
9138         subroutine coll_xyyz_h(gx,gy,gz,ckxy,x,y,chucm,ima, &
9139      &    prdkrn,nkr,indc)
9140         implicit double precision (a-h,o-z)
9141       dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
9142         dimension chucm(nkr,nkr)
9143         double precision ima(nkr,nkr)
9144         gmin=1.d-60
9145 ! lower and upper integration limit ix0,ix1
9146         do i=1,nkr-1
9147            ix0=i
9148            if(gx(i).gt.gmin) go to 2000
9149         enddo
9150  2000   continue
9151         if(ix0.eq.nkr-1) goto 2020
9152         do i=nkr-1,1,-1
9153            ix1=i
9154            if(gx(i).gt.gmin) go to 2010
9155         enddo
9156  2010   continue
9157 ! lower and upper integration limit iy0,iy1
9158         do i=1,nkr-1
9159            iy0=i
9160            if(gy(i).gt.gmin) go to 2001
9161         enddo
9162  2001   continue
9163         if(iy0.eq.nkr-1) goto 2020
9164         do i=nkr-1,1,-1
9165            iy1=i
9166            if(gy(i).gt.gmin) go to 2011
9167         enddo
9168  2011   continue
9169 ! collisions :
9170         do i=iy0,iy1
9171            jmin=i
9172            if(jmin.eq.(nkr-1)) goto 2020
9173            if(i.lt.ix0) jmin=ix0-indc
9174            do j=jmin+indc,ix1
9175               k=ima(i,j)
9176               kp=k+1
9177               x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
9178               x0=min(x0,gy(i)*x(j))
9179               if(j.ne.k) then
9180                 x0=min(x0,gx(j)*y(i))
9181               endif
9182               gsi=x0/x(j)
9183               gsj=x0/y(i)
9184               gsk=gsi+gsj
9185               gy(i)=gy(i)-gsi
9186               if(gy(i).lt.0.d0) gy(i)=0.d0
9187               gx(j)=gx(j)-gsj
9188               gk=gx(k)+gsk
9189               if(gx(j).lt.0.d0.and.gk.lt.gmin) then
9190                 gx(j)=0.d0
9191                 gx(k)=gx(k)+gsi
9192               endif
9193               flux=0.d0
9194 ! BARRY
9195               if(kp.lt.25) gkp=gy(kp)
9196               if(kp.ge.25) gkp=gz(kp)
9197               if(gk.gt.gmin) then
9198                 x1=dlog(gkp/gk+1.d-15)
9199 ! BARRY
9200 !               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
9201 ! new changes 23.01.01 (begin)
9202 !               flux=min(flux,gk)
9203 !               flux=min(flux,gsk)
9204 ! BARRY
9205                if (x1.eq.0)then
9206                 flux=0
9207                else
9208                 flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
9209                 flux=min(flux,gsk)
9210                end if
9211 ! new changes 23.01.01 (end)
9212                 gx(k)=gk-flux
9213                 if(gx(k).lt.0.d0) gx(k)=0.d0
9214                 if(kp.lt.25) gy(kp)=gkp+flux
9215                 if(kp.ge.25) gz(kp)=gkp+flux
9216 ! ALEX 15 11 2005
9217 !               if(kp.ge.25) gx(kp)=gkp+flux
9218 ! in case gk > gmin :
9219               endif
9220 ! in case gk > gmin or gk.le.gmin
9221            enddo
9222         enddo
9223  2020   continue
9224         return
9225         end subroutine coll_xyyz_h
9226 !===============================================================
9227 !****************************************************************
9228 ! SEE /include/microhucm.incl for setting of krdrop and krbreak
9229 !****************************************************************
9230       SUBROUTINE BREAKUP(GT_MG,XT_MG,DT,BRKWEIGHT, &
9231      &           PKIJ,QKJ,JMAX,JBREAK)
9232 !     SUBROUTINE BREAKUP(GT_MG,DT,JMAX,JBREAK)
9233 !     implicit double precision (a-h,o-z)
9235 !.....INPUT VARIABLES
9237 !     GT    : MASS DISTRIBUTION FUNCTION
9238 !     XT_MG : MASS OF BIN IN MG
9239 !     JMAX  : NUMBER OF BINS
9240 !     DT    : TIMESTEP IN S
9242       INTEGER JMAX
9244 !.....LOCAL VARIABLES
9246       LOGICAL LTHAN
9247       INTEGER JBREAK,AP,IA,JA,KA,IE,JE,KE
9248       DOUBLE PRECISION EPS,NEGSUM
9250       PARAMETER (AP = 1)
9251       PARAMETER (IA = 1)
9252       PARAMETER (JA = 1)
9253       PARAMETER (KA = 1)
9254       PARAMETER (EPS = 1.D-20)
9256       INTEGER I,J,K,JJ,JDIFF
9257       DOUBLE PRECISION GT_MG(JMAX),XT_MG(0:JMAX),DT
9258 !     xl_mg(0:nkr)
9259       DOUBLE PRECISION BRKWEIGHT(JBREAK),PKIJ(JBREAK,JBREAK,JBREAK), &
9260      &    QKJ(JBREAK,JBREAK)
9261       DOUBLE PRECISION D0,ALM,HLP(JMAX)
9262       DOUBLE PRECISION FT(JMAX),FA(JMAX)
9263       DOUBLE PRECISION DG(JMAX),DF(JMAX),DBREAK(JBREAK),GAIN,LOSS
9264       REAL PI
9265       PARAMETER (PI = 3.1415927)
9266       INTEGER IP,KP,JP,KQ,JQ
9267       IE = JBREAK
9268       JE = JBREAK
9269       KE = JBREAK
9277 !.....IN CGS
9279 !     DO J=1,JMAX
9280 !        XT(J) = XT_MG(J) * 1E-3
9281 !        GT_MG(J) = GT_MG(J)* 1E-3
9282 !     ENDDO
9284 !.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID
9286       JDIFF = JMAX - JBREAK
9287 !       14  =  33  - 19
9289 !.....INITIALIZATION
9291 !.....TRANSFORMATION FROM G(LN X) = X**2 F(X) TO F(X)
9292       DO J=1,JMAX
9293          FT(J) = GT_MG(J) / XT_MG(J)**2
9294       ENDDO
9296 !.....SHIFT TO BREAKUP GRID
9298       DO K=1,KE
9299          FA(K) = FT(K+JDIFF)
9300       ENDDO
9302 !.....BREAKUP: BLECK'S FIRST ORDER METHOD
9304 !     PKIJ: GAIN COEFFICIENTS
9305 !     QKJ : LOSS COEFFICIENTS
9308       DO K=1,KE
9309          GAIN = 0.0
9310          DO I=1,IE
9311             DO J=1,I
9312                GAIN = GAIN + FA(I)*FA(J)*PKIJ(K,I,J)
9313             ENDDO
9314          ENDDO
9315          LOSS = 0.0
9316          DO J=1,JE
9317             LOSS = LOSS + FA(J)*QKJ(K,J)
9318          ENDDO
9319          DBREAK(K) = BRKWEIGHT(K) * (GAIN - FA(K)*LOSS)
9320       ENDDO
9322 !.....SHIFT RATE TO COAGULATION GRID
9324       DO J=1,JDIFF
9325          DF(J) = 0.0
9326       ENDDO
9327       DO J=1,KE
9328          DF(J+JDIFF) = DBREAK(J)
9329       ENDDO
9330 !.....TRANSFORMATION TO MASS DISTRIBUTION FUNCTION G(LN X)
9332       DO J=1,JMAX
9333          DG(J) = DF(J) * XT_MG(J)**2
9334       ENDDO
9336 !.....TIME INTEGRATION
9338       DO J=1,JMAX
9339       HLP(J) = 0.0
9340       NEGSUM = 0.0
9341          GT_MG(J) = GT_MG(J) + DG(J) * DT
9342          IF (GT_MG(J).LT.0) THEN
9343             HLP(J) = MIN(GT_MG(J),HLP(J))
9344             GT_MG(J) = EPS
9345 !           NEGSUM = NEGSUM+GT_MG(J)
9346 !           GT_MG(J) = 0.D0
9347          ENDIF
9348       ENDDO
9349 !     DO J=1,JMAX
9350 !      IF (HLP(J).LT.0.) THEN
9351 !        GT_MG(J-1)=GT_MG(J-1)-NEGSUM -EPS
9352 !      END IF
9353 !      GO TO 10
9354 !     END DO
9355 !10    CONTINUE
9356 !     IF (HLP.LT.-1E-7) THEN
9357 ! BARRY
9358 !     LTHAN=.FALSE.
9359 !     DO J=1,JMAX
9360 !      IF (HLP(J).LT.0.OR.LTHAN) THEN
9361 !        WRITE (*,'(1X,A,E10.4)')
9362 !    F        'COLL_BREAKUP: WARNING! G(J) < 0, MIN = ' 
9363 !        IF(HLP(J).LT.0.OR.LTHAN)WRITE(6,*)
9364 !    F      'J,G(J)  = ',J,HLP(J),GT_MG(J)
9365 !        LTHAN=.TRUE.  C     ENDIF
9366 !     END DO
9368 !     DO J=1,JMAX
9369 !        GT_MG(J) = GT_MG(J) * 1E3
9370 !     ENDDO
9372 !.....THAT'S IT
9373       RETURN
9375       END SUBROUTINE BREAKUP
9377       SUBROUTINE BOUNDNUM(MASSMM5,FCONC,RHOX,COL,NZERO, &
9378      &       RADXX,MASSXX,HYDROSUM, &
9379      &       NKR)
9380       IMPLICIT NONE
9381      
9382       INTEGER NKR,NKRI,KRBEG,KREND,IP,IPCNT
9383       REAL NZERO,LAMBDAHYD,MASSMM5,RHOX,HYDROMASS,COL
9384       REAL RADXX(NKR),MASSXX(NKR)
9385       REAL TERM1,TERM2A,TERM2B,TERM2C
9386       REAL FCONC(NKR),HYDROSUM 
9387       DOUBLE PRECISION D1,D2,D3,D4,D5,D6,D7A,D7B 
9388       DOUBLE PRECISION VAR1,VAR2,VAR3,VAR4,VAR5,VAR6
9389 !     HYDROMASS IN kg/kg
9390 !     VAR1=NZERO           
9391 !     VAR2=RHOX            
9392 !     VAR3=MASSXX(1,IHYDR)
9393 !     VAR4=RADXX(1,IHYDR)
9394 !     VAR5=MASSMM5       
9395 !     VAR6=(6.*VAR1/VAR2)*VAR3/(8.*VAR4**3)*(1./VAR5)
9396 !     var6 =sqrt(sqrt(var6))
9397 !     print*,'radxx(1) = ',RADXX(1)
9398 !     print*,'rhox = ',rhox
9399 !     print*,'massmm5 = ',massmm5
9400 !     print*,'nzero = ',nzerO
9401 !     print*,'massxx = ',MASSXX(1)
9402       LAMBDAHYD=(6.*NZERO/RHOX)*MASSXX(1)/(8.*RADXX(1)**3) &
9403      &     *(1./MASSMM5)
9404       LAMBDAHYD=SQRT(SQRT(LAMBDAHYD))
9405       HYDROSUM  =0
9406       TERM1=(NZERO/RHOX)*(MASSXX(1)/(8.*RADXX(1)**3))
9407       DO NKRI=1,NKR
9408        IF(NKRI.EQ.1)THEN
9409         D1=LAMBDAHYD*2.*RADXX(NKRI)
9410         D2=0
9411        ELSE
9412         D1=LAMBDAHYD*2.*RADXX(NKRI)
9413         D2=LAMBDAHYD*2.*RADXX(NKRI-1)
9414        END IF
9415        D3=DEXP(-D1)
9416        D4=DEXP(-D2)
9417        D5 = (1./LAMBDAHYD**4)
9418        D6=TERM1
9419        IF (NKRI.EQ.1)THEN
9420         D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
9421         D7B=-6.*D5
9422        ELSE
9423         D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
9424         D7B= -D5*D4*(D2**3+3.*D2**2+6.*D2+6)
9425        END IF
9426        HYDROMASS= D6*(D7A-D7B)
9427        HYDROSUM=HYDROSUM+HYDROMASS   
9428        FCONC(NKRI)=HYDROMASS*RHOX/(COL  &
9429      &          *MASSXX(NKRI)*MASSXX(NKRI)*3)
9430         IF (HYDROMASS .LT.0)THEN
9431         call wrf_error_fatal("fatal error in module_mp_full_sbm (HYDROMASS.LT.0), model stop")
9432         END IF
9433       END DO
9434 !     print*, 'massmm5,hydrosum  =',massmm5,hydrosum  
9435       IF (HYDROSUM.LT.MASSMM5)THEN
9436        D1=LAMBDAHYD*2.*RADXX(NKR)
9437        D2=LAMBDAHYD*2.*RADXX(NKR-1)
9438        D3=DEXP(-D1)
9439        D4=DEXP(-D2)
9440        D5 = (1./LAMBDAHYD**4)
9441        D6=TERM1
9442        D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
9443        D7B= -D5*D4*(D2**3+3.*D2**2+6.*D2+6)
9444        HYDROMASS= D6*(D7A-D7B)+(MASSMM5-HYDROSUM)
9445        FCONC(NKR)=HYDROMASS*RHOX/(COL &
9446      &          *MASSXX(NKR)*MASSXX(NKR)*3)
9447        HYDROSUM=HYDROSUM+(MASSMM5-HYDROSUM)
9448       END IF
9449 !     print*, 'massmm5,hydrosum adj  =',massmm5,hydrosum  
9450       RETURN
9451       END SUBROUTINE BOUNDNUM
9452 ! NEW (OLD) MELTING CODE
9453 !====================================================================
9454 ! Version of 23.08.04 
9456 SUBROUTINE MELTING &
9458 (ihucm_flag &
9460 ,FF1,XL,VTL &
9461 ,FF2,XI,V2,VTC,FLIQFR_I,RHO_I &
9462 ,FF3,XS,V3,VTS,FLIQFR_S,RHO_S &
9463 ,FF4,XG,V4,VTG,FLIQFR_G,RHO_G &
9464 ,FF5,XH,V5,VTH,FLIQFR_H,RHO_H &
9465 ,XI_MELT,XS_MELT,XG_MELT,XH_MELT &
9466 ,TIN,rhoa,pres,DT,QQV)
9468 !===============================================!
9469 ! EXPLICIT MELTING SCHEME                       !
9470 ! Author: Vaughan T.J. PHILLIPS, August 2004    !
9471 ! at Princeton University (AOS program)         !
9472 ! and GFDL, NOAA/OAR, USA                       !
9473 !===============================================!
9475 implicit double precision (a-h,o-z)
9477 ! new change 27.03.07                                         (start)
9479 !PARAMETER(NKR=33, NK=129, ICEMAX=3)
9481 ! new change 27.03.07                                           (end)
9483 ! new change 12.02.07                                         (start)
9485 PARAMETER(CP=1004.7D0, RV=461.51D0, RD=287.039D0, &
9486           EPS=RD/RV, FJOULES_IN_A_CAL=4.187D0, PI=3.141592654D0, &
9487           AR_LIM=2.D0, GRAV=9.8D0, RHO_ICE=920.D0, &
9488           RHO_WATER=1000.D0, FLIQFRAC_LIM=0.9D0, &
9489           PETIT_PARAMETRE=1.D-10)
9490 PARAMETER (ivt_G_H_interpol=0)
9492 ! new change 12.02.07                                           (end)
9494 ! new change 12.02.07                                         (start)
9496 PARAMETER(ISHEDDING_ON=1, IVT_ADJUST=1, IPRINTING=0, &
9497           ITEMP_ADJUST=1, IEVAP_ADJUST=1, ISUBLIME_ADJUST=1)
9499 ! new change 12.02.07                                           (end)
9501 ! control in main program & others subroutines
9504 ! new change 29.10.08                                         (start)           
9507 ! new change 29.10.08                                           (end)
9512 DIMENSION FF1(NKR), XL(NKR), VTL(NKR)
9514 DIMENSION FF2(NKR,ICEMAX),XI(NKR,ICEMAX),V2(NKR,ICEMAX), &
9515           VTC(NKR,ICEMAX),FLIQFR_I(NKR,ICEMAX),RHO_I(NKR,ICEMAX)
9517 DIMENSION FF3(NKR),XS(NKR),V3(NKR), &
9518           VTS(NKR),FLIQFR_S(NKR),RHO_S(NKR)
9520 DIMENSION FF4(NKR),XG(NKR),V4(NKR), &
9521           VTG(NKR),FLIQFR_G(NKR),RHO_G(NKR)
9523 DIMENSION FF5(NKR),XH(NKR),V5(NKR), &
9524           VTH(NKR),FLIQFR_H(NKR),RHO_H(NKR)
9526 DIMENSION FF1_SI(NKR), XL_SI(NKR), VTL_SI(NKR)
9528 DIMENSION FF2_SI(NKR,ICEMAX),XI_SI(NKR,ICEMAX),V2_SI(NKR,ICEMAX), &
9529           VTC_SI(NKR,ICEMAX),RHO_I_SI(NKR,ICEMAX)
9531 DIMENSION FF3_SI(NKR),XS_SI(NKR),V3_SI(NKR), &
9532           VTS_SI(NKR), RHO_S_SI(NKR)
9533           
9534 DIMENSION FF4_SI(NKR),XG_SI(NKR),V4_SI(NKR), &
9535           VTG_SI(NKR), RHO_G_SI(NKR)
9537 DIMENSION FF5_SI(NKR),XH_SI(NKR),V5_SI(NKR), &
9538           VTH_SI(NKR), RHO_H_SI(NKR)
9539 DIMENSION &
9540 XI_MELT(NKR,ICEMAX),XS_MELT(NKR),XG_MELT(NKR),XH_MELT(NKR)
9542 DIMENSION &
9543 XI_MELT_SI(NKR,ICEMAX),XS_MELT_SI(NKR),XG_MELT_SI(NKR),XH_MELT_SI(NKR)
9545 INTRINSIC SUM
9547 If(TIN <= 273.15D0) then
9548   RETURN
9549 ENDIF
9551 if(SUM(FF2) <= 0.D0.and.SUM(FF3) <= 0.D0.and.SUM(FF4) <= 0.D0.and. &
9552 SUM(FF5) <= 0.D0) then
9553   return
9554 endif
9556 !=============================================================
9557 !       UNIT CONVERSION OF ALL INPUTS to SI
9558 !=============================================================
9560 if(ihucm_flag == 1) then
9562 RHO_I_SI = RHO_I*1000.D0
9563 RHO_S_SI = RHO_S*1000.D0
9564 RHO_G_SI = RHO_G*1000.D0
9565 RHO_H_SI = RHO_H*1000.D0
9567 XL_SI = XL/1000.D0
9568 XI_SI = XI/1000.D0
9569 XS_SI = XS/1000.D0
9570 XG_SI = XG/1000.D0
9571 XH_SI = XH/1000.D0
9573 XI_MELT_SI = XI_SI
9574 XS_MELT_SI = XS_SI
9575 XG_MELT_SI = XG_SI
9576 XH_MELT_SI = XH_SI
9578 VTL_SI = VTL/100.D0
9579 VTC_SI = VTC/100.D0
9580 VTS_SI = VTS/100.D0
9581 !do kr=1,nkr
9582 ! print*,'vts within = ',vts(kr)
9583 !end do
9584 VTG_SI = VTG/100.D0
9585 VTH_SI = VTH/100.D0
9587 V2_SI = V2/100.D0
9588 V3_SI = V3/100.D0
9589 V4_SI = V4/100.D0
9590 V5_SI = V5/100.D0
9592 FF1_SI = 1.E9*FF1
9593 FF2_SI = 1.E9*FF2
9594 FF3_SI = 1.E9*FF3
9595 FF4_SI = 1.E9*FF4
9596 FF5_SI = 1.E9*FF5
9598 pres_SI = pres/10.D0
9599 rhoa_SI = rhoa*1000.D0
9601 ! in case ihucm_flag == 1
9603 else
9605 ! in case ihucm_flag.NE.1
9607 RHO_I_SI = RHO_I
9608 RHO_S_SI = RHO_S
9609 RHO_G_SI = RHO_G
9610 RHO_H_SI = RHO_H
9612 XL_SI = XL
9613 XI_SI = XI
9614 XS_SI = XS
9615 XG_SI = XG
9616 XH_SI = XH
9618 XI_MELT_SI = XI_SI
9619 XS_MELT_SI = XS_SI
9620 XG_MELT_SI = XG_SI
9621 XH_MELT_SI = XH_SI
9623 VTL_SI = VTL
9624 VTC_SI = VTC
9625 VTS_SI = VTS
9626 VTG_SI = VTG
9627 VTH_SI = VTH
9629 V2_SI = V2
9630 V3_SI = V3
9631 V4_SI = V4
9632 V5_SI = V5
9634 FF1_SI = FF1
9635 FF2_SI = FF2
9636 FF3_SI = FF3
9637 FF4_SI = FF4
9638 FF5_SI = FF5
9640 pres_SI = pres
9641 rhoa_SI = rhoa
9643 ! in case ihucm_flag.NE.1
9644 endif
9647 !=============================================================
9648 !       INITIALISATION
9649 !=============================================================
9651 V2_SI(:,:) = VTC_SI(:,:)
9652 V3_SI(:) = VTS_SI(:)
9653 V4_SI(:) = VTG_SI(:)
9654 V5_SI(:) = VTH_SI(:)
9656 ee = QQV*pres_SI/(EPS + QQV)
9658 es_zero = 611.21D0
9660 if(pres_SI > 200000.D0.or.pres_SI < 10000.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (PSI is wrong), model stop")
9662 D_V=0.211D0*((TIN/273.15D0)**1.94D0)*(101325.D0/pres_SI)/1.D4
9664 ! D_V = 2.21D-5
9665 ! FK_a = 2.40D-2
9667 FK_a =(5.69D0+0.017D0*(TIN-273.15D0))*1.0D-3*4.187D0
9669 ! XLV = 2.50D6
9670 ! XLF = 2.83D6 - XLV
9672 ! The expressions for latent heats used by R&H, 1987,
9673 ! seem more applicable to
9674 ! T > 0degC than
9675 ! those by P & K 1997, and more modern
9677 ! XLV=597.3D0*((273.15D0/TIN)**(0.167D0+3.67D-4*TIN))
9679 XLV = 597.3D0
9680 XLV = XLV*FJOULES_IN_A_CAL*1000.D0
9681 XLS = 2.83D6
9683 !XLF=79.7+0.485D0*(TIN-273.15D0)-2.5D-3*(TIN-273.15D0)*(TIN-273.15D0)
9685 XLF = 79.7D0
9686 XLF = XLF*FJOULES_IN_A_CAL*1000.D0
9688 ! FNSC=0.632D0
9690 etaa = (1.718D0 + 0.0049D0*(TIN-273.15D0) - &
9691         1.2D-5*(TIN-273.15D0)*(TIN-273.15D0))*1.D-5
9693 ! etaa/rhoa_SI = kinematic viscosity
9695 FNSC = etaa/(rhoa_SI*D_V)
9697 ! FNPR=0.71D0
9699 ALPHA_H = FK_a/(CP*rhoa_SI)
9700 FNPR = etaa/(rhoa_SI*ALPHA_H)
9701 RHO_CRIT = 910.D0
9703 !if(IPRINTING==1) print *, &
9704 !                'FNSC,FNPR,XLF,XLV = ', FNSC, FNPR, XLF, XLV
9706 if(rhoa_SI > 2.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (rhoa_SI>2), model stop 111")
9708 if(rhoa_SI < 0.1D0) then
9709   call wrf_error_fatal("fatal error in module_mp_full_sbm (rhoa_SI<0.1), model stop 112")
9710 endif
9712 if(RHO_H_SI(1) < 1.D0) then
9713   call wrf_error_fatal("fatal error in module_mp_full_sbm (RHO_H_SI(1) < 1.D0kg/m3), model stop 113")
9714 endif
9717 ! new changes 23.08.04                                        (start)
9719 TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), 1.D0, XLS, RV)
9720 if(TS > 273.15D0) TS = 273.15D0
9722 ! new changes 23.08.04                                          (end)
9723       
9724 !=============================================================
9725 !       CRYSTALS
9726 !=============================================================
9729 DO I = 1, ICEMAX
9731    I_MELT=I
9733 DO IK = 1, NKR
9735    IK_MELT=IK
9737 if(TIN > 273.15D0) then
9739 IF(FLIQFR_I(IK,I).GE.1.D0.OR.FF2_SI(IK,I).LE.PETIT_PARAMETRE.OR. &
9740 TIN <= 273.15D0) THEN
9741   IF(FLIQFR_I(IK,I) > 1.D0) FLIQFR_I(IK,I) = 1.D0
9742   CYCLE
9743 ENDIF
9745 rho_p=RHO_I_SI(IK,I)+FLIQFR_I(IK,I)*(RHO_WATER-RHO_I_SI(IK,I))
9746 fm_i = XI_SI(IK,I)*(1.D0 - FLIQFR_I(IK,I))
9747 fm_w = XI_SI(IK,I)*FLIQFR_I(IK,I)
9748 V_p = (fm_i+fm_w)/rho_p
9749 V_i = V_p
9750 rhoi = fm_i/V_i
9752 ! COLUMN (Heymsfield 1972) AR = 2 to 5
9754 IF(I.eq.1) then
9756   AR_izero = column_AR(XI_SI(IK,I), RHO_I_SI(IK,I))
9757   AR_i = AR_izero + FLIQFR_I(IK,I)*(1.D0 - AR_izero)
9758   if(AR_i < AR_LIM) AR_i = AR_LIM
9759   CAP_izero = COLUMN_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
9761   vt_R = VTL_SI(IK)
9762   vt_start = VTC_SI(IK,I)
9763   vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
9765   fnre = vt *FL_star*rhoa_SI/etaa
9766   fv = COLUMN_VENTILATION_COEF(fnre, FNSC)
9768 ! in case I.eq.1
9769 endif
9771 ! PLATE C1g type (see P1a in p52 in P&K)
9773 IF(I.eq.2) then
9775   AR_izero = PLATE_AR(XI_SI(IK,I))
9776   AR_i = AR_izero + FLIQFR_I(IK,I)*(1.D0 - AR_izero)
9777   if(AR_i > 1.D0/AR_LIM) AR_i = 1.D0/AR_LIM
9779   CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
9781   vt_R = VTL_SI(IK)
9782   vt_start = VTC_SI(IK,I)
9783   vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
9785   fnre = vt * FL_star*rhoa_SI/etaa
9786   fv = PLATE_VENTILATION_COEF(fnre, FNSC)
9788 ! in case I.eq.2
9789 endif
9791 ! DENDRITES P1c type (see P1c in p52 in P&K)
9793 IF(I.eq.3) then
9795   AR_izero = DENDRITE_AR(XI_SI(IK,I))
9796   AR_i = AR_izero + FLIQFR_I(IK,I)*(1.D0 - AR_izero)
9797   if(AR_i > 1./AR_LIM) AR_i = 1.D0/AR_LIM
9799   CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
9801         vt_R = VTL_SI(IK)
9802         vt_start = VTC_SI(IK,I)
9803         vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
9805         fnre = vt * FL_star*rhoa_SI/etaa
9806         fv = DENDRITE_VENTILATION_COEF(fnre, FNSC)
9808 ! in case I.eq.3
9809 endif
9811 ! CAP = V**(1./3.)
9813 V2_SI(IK,I) = vt
9814 CAP = CAP_izero*(0.8D0 + FLIQFR_I(IK,I)*0.2D0)
9816 FICEMASS = XI_SI(IK,I) * (1.D0 - FLIQFR_I(IK,I))
9817 DMELT = DT * ( 4.D0*PI*CAP*fv/XLF) * &
9818 (FK_a*(TIN - 273.15D0) + (D_V*XLV/RV) * &
9819 (ee/TIN - es_zero/273.15D0))
9821 ! new changes 23.08.04                                        (start)
9823 if(TS < 273.15D0 .and. FLIQFR_I(IK,I) <= 0.D0) DMELT = 0.D0
9825 ! new changes 23.08.04                                          (end)
9827 call fmass_limits(DMELT, FICEMASS, fm_w, XI_SI(IK,I))
9829 if(ITEMP_ADJUST == 1) then
9831   call thermodynamical_limits &
9832  (FF2_SI(IK,I), XI_SI(IK,I), rhoa_SI, XLF/CP, TIN, DMELT)
9835 ! in case ITEMP_ADJUST == 1
9837 endif
9839 FICEMASS = FICEMASS - DMELT
9841 ! DMELT > 0 for melting
9843 FLIQFR_I(IK,I) = (XI_SI(IK,I) - FICEMASS)/XI_SI(IK,I)
9845 if(FLIQFR_I(IK,I) < 0.D0) FLIQFR_I(IK,I) = 0.D0
9847 if(FLIQFR_I(IK,I) > 0.D0) then
9849   if(IEVAP_ADJUST == 1 ) then
9851     if(FLIQFR_I(IK,I) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (FLIQFR_I > 1), model stop 114")
9853 ! HEAT_EVAP = Joules of latent heat absorbed (released) 
9854 ! by FMASS_EVAP, kg
9855 ! of water evaporating (condensation)
9856 ! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
9858     HEAT_EVAP=-DMELT*XLF+DT*(4.D0*PI*CAP*fv)*FK_a*(TIN-273.15D0)
9860 ! new changes 24.08.04                                        (start)
9862     IF(HEAT_EVAP.LT.0.D0) THEN
9864 !      PRINT*, 'HEAT_EVAP < 0'
9866 !      PRINT*, 'CRYSTAL'
9868 !      PRINT*, 'I_MELT' 
9869 !      PRINT*,  I_MELT 
9870       
9871 !      PRINT*, 'IJK,KX,KZ,IK'
9872 !      PRINT*,  IJK,KX,KZ,IK_MELT
9874 !      HEAT_EVAP=0.D0
9877 ! in case HEAT_EVAP.LT.0.D0
9879     ENDIF
9880     
9881 ! new changes 24.08.04                                          (end)
9883     FMASS_EVAP = HEAT_EVAP/XLV
9885     if(FMASS_EVAP > FLIQFR_I(IK,I) * XI_SI(IK,I)) then
9886       FMASS_EVAP = FLIQFR_I(IK,I) * XI_SI(IK,I)
9887     endif
9889     Q_EVAP=FMASS_EVAP*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
9892     CALL EVAP_MELTWATER &
9893    (XI_SI(IK,I),rhoa_SI,Q_EVAP,FLIQFR_I(IK,I),FF2_SI(IK,I))
9895    XI_MELT_SI(IK,I)=XX_MELT
9897 ! I assume that, during the period before the RH-dependent onset
9898 ! of melting is reached, the loss of mass of water
9899 ! by evaporation is as negligible as the source of mass
9900 ! of meltwater from melting itself
9901 !(see Rasmussen and Pruppacher 1982; P & K 1997)
9903     TIN=TIN-XLV/CP*Q_EVAP
9905     QQV=QQV+Q_EVAP
9907 ! new changes 24.08.04                                        (start)
9909     ee = QQV*pres_SI/(EPS + QQV)
9911 ! new changes 24.08.04                                          (end)
9913     if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
9914     if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
9916 ! in case IEVAP_ADJUST == 1
9917   endif
9919 ! in case FLIQFR_I(IK,I) > 0.D0
9921 else
9923 ! in case FLIQFR_I(IK,I).LE.0.D0
9925   if(ISUBLIME_ADJUST == 1 ) then
9927 ! new changes 24.08.04                                        (start)
9929     if(TS > 273.16) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 13655")
9930     sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
9931     sub_fac = sub_fac + RV*TIN/((100.D0*GGESI(TS))*D_V)
9932     DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
9934 ! new changes 24.08.04                                          (end)
9936     if(DSUB >  XI_SI(IK,I)) then
9937       DSUB = XI_SI(IK,I)
9938     endif
9940     Q_SUBL = DSUB*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
9943     CALL SUBLIME_ICE &
9944    (XI_SI(IK,I),rhoa_SI,Q_SUBL,FF2_SI(IK,I))
9946     XI_MELT_SI(IK,I)=XX_MELT
9948     TIN=TIN-XLS/CP*Q_SUBL
9949     QQV=QQV+Q_SUBL
9951 ! new changes 24.08.04                                        (start)
9953     ee = QQV*pres_SI/(EPS + QQV)
9955 ! new changes 24.08.04                                          (end)
9957     if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (QQV < 0), model stop ")
9958     if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm ( TIN < 150) , model stop ")
9961 ! in case ISUBLIME_ADJUST == 1
9962   endif
9964 ! in case FLIQFR_I(IK,I).LE.0.D0
9965 endif
9967 if(FLIQFR_I(IK,I) < 0.D0) then
9968   FLIQFR_I(IK,I) = 0.D0
9969 endif
9971 IF(FLIQFR_I(IK,I) > FLIQFRAC_LIM) then
9973   if(XL_SI(IK).NE.XI_SI(IK,I)) call wrf_error_fatal("fatal error in module_mp_full_sbm (QQV < 0), model stop 7011")
9975   if(ITEMP_ADJUST == 1) then
9978     Q_ICE_MELTED= &
9979     FICEMASS*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
9981     TIN=TIN-XLF/CP*Q_ICE_MELTED
9984 ! in case ITEMP_ADJUST == 1
9985   endif
9987   FF1_SI(IK) = FF1_SI(IK) + FF2_SI(IK,I)
9989 !  FLIQFR_I(IK,I) = 0.
9991   FLIQFR_I(IK,I) = 1.D0
9993   FF2_SI(IK,I) = 0.D0
9995 ! in case FLIQFR_I(IK,I) > FLIQFRAC_LIM
9997 ENDIF
9999 ! in case TIN > 273.15D0
10001 endif
10003 ENDDO
10004 ! cycle by IK
10006 ENDDO
10007 ! cycle by I
10009 !=============================================================
10010 !       SNOW
10011 !=============================================================
10014 DO IK = 1, NKR
10016    IK_MELT=IK
10017    I_MELT=0
10019 if(TIN > 273.15D0) then
10021 IF(FLIQFR_S(IK).GE.1.D0.OR.FF3_SI(IK).LE.PETIT_PARAMETRE.OR. &
10022 TIN <= 273.15D0) THEN
10023   IF(FLIQFR_S(IK) > 1.D0) FLIQFR_S(IK) = 1.D0
10024 CYCLE
10025 ENDIF
10027 rho_p = RHO_S_SI(IK) + FLIQFR_S(IK)* &
10028        (RHO_WATER - RHO_S_SI(IK))
10030 fm_i = XS_SI(IK)*(1.D0 - FLIQFR_S(IK))
10031 fm_w = XS_SI(IK)*FLIQFR_S(IK)
10032 V_p = (fm_i + fm_w)/rho_p
10033 V_i = V_p
10034 rhoi = fm_i/V_i
10036 ! Based on Mitra et al. (1990)/Matsuo and Sasyo (1981)
10037 ! V_p = (4/3) PI AR a_i**3
10039 ! ASSUME:- (1) snowflakes have an ice skeleton structure that
10040 ! is incollapsable,
10041 ! but of varing AR, until completion of melting;
10042 ! (2) melting occurs only at snowflake exterior surface and water
10043 ! then penetrates inside
10045 ! fm_i in the text of Mitra et al is the mass of the ice component
10046 ! a_i (b_i) are the major (minor) axes of the ice skeleton
10047 ! AR = b_i/a_i
10049 AR_p = 0.3D0 + 0.7D0 * FLIQFR_S(IK)
10051 ! new change 26.07.04                                         (start)
10053 ! the rest of the HUCM seems to assume that snow is spherical 
10054 !(see JERRATE)
10055 ! AR_p = 1.
10057 ! new change 26.07.04                                           (end)
10059 AR_i = AR_p
10061 CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
10062 CAP = CAP_izero*(0.8D0 + FLIQFR_S(IK)*0.2D0)
10064 vt_R = VTL_SI(IK)
10065 vt_start = VTS_SI(IK)
10066 vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
10067 fnre = FL_star * vt*rhoa_SI/etaa
10069 ! new change 24.08.04                                         (start)
10071 fv = SNOW_VENTILATION_COEF(fnre, FNSC, AR_i)
10073 ! new change 24.08.04                                           (end)
10075 V3_SI(IK) = vt
10077 FICEMASS = XS_SI(IK) * (1.D0 - FLIQFR_S(IK))
10079 DMELT = DT * ( 4.D0*PI*CAP*fv/XLF) * &
10080 (FK_a*(TIN - 273.15D0) + (D_V*XLV/RV) * &
10081 (ee/TIN - es_zero/273.15D0))
10083 ! new change 24.08.04                                         (start) 
10085 if(TS < 273.15D0 .and. FLIQFR_S(IK) <= 0.D0) DMELT = 0.D0
10087 ! new change 24.08.04                                           (end) 
10089 call fmass_limits(DMELT, FICEMASS, fm_w, XS_SI(IK))
10091 if(ITEMP_ADJUST == 1) then
10094   call thermodynamical_limits &
10095  (FF3_SI(IK), XS_SI(IK), rhoa_SI, XLF/CP, TIN, DMELT)
10098 ! in case ITEMP_ADJUST == 1
10099 endif
10101 FICEMASS = FICEMASS - DMELT
10103 FLIQFR_S(IK) = (XS_SI(IK) - FICEMASS)/XS_SI(IK)
10105 if(FLIQFR_S(IK) < 0.D0) then
10106   FLIQFR_S(IK) = 0.D0
10107 endif
10109 if(FLIQFR_S(IK) > 0.D0) then
10111   if(IEVAP_ADJUST == 1) then
10113     if(FLIQFR_S(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 905")
10115 ! HEAT_EVAP = Joules of latent heat absorbed by FMASS_EVAP kg
10116 ! of water evaporating
10117 ! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
10119     HEAT_EVAP=-DMELT*XLF+ DT*(4.D0*PI*CAP*fv)*FK_a*(TIN-273.15D0)
10121 ! new change 24.08.04                                         (start)
10123     IF(HEAT_EVAP.LT.0.D0) THEN
10124       
10125 !      PRINT*, 'HEAT_EVAP < 0'
10127 !      PRINT*, 'SNOW'
10129 !      PRINT*, 'IJK,KX,KZ,IK'
10130 !      PRINT*,  IJK,KX,KZ,IK_MELT
10132 !      HEAT_EVAP=0.D0
10135     ENDIF
10136     
10137 ! new change 24.08.04                                           (end)
10139     FMASS_EVAP = HEAT_EVAP/XLV
10141     if(FMASS_EVAP > FLIQFR_S(IK) * XS_SI(IK)) then
10142       FMASS_EVAP = FLIQFR_S(IK) * XS_SI(IK)
10143     endif
10145     Q_EVAP= FMASS_EVAP*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
10148     CALL EVAP_MELTWATER &
10149    (XS_SI(IK),rhoa_SI,Q_EVAP,FLIQFR_S(IK),FF3_SI(IK))
10151     XS_MELT_SI(IK)=XX_MELT
10153     TIN=TIN-XLV/CP*Q_EVAP
10154     QQV=QQV+Q_EVAP
10156 ! new change 24.08.04                                         (start)
10158     ee = QQV*pres_SI/(EPS + QQV)
10160 ! new change 24.08.04                                           (end)
10162     if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 915")
10163     if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 916")
10166 ! in case IEVAP_ADJUST == 1
10167   endif
10169 ! in case FLIQFR_S(IK) > 0.D0
10171 else
10173 ! in case FLIQFR_S(IK).LE.0.D0
10175   if(ISUBLIME_ADJUST == 1) then
10177     sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
10179 ! new change 24.08.04                                         (start)
10181     sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
10183     DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
10185 ! new change 24.08.04                                           (end)
10187     if(DSUB >  XS_SI(IK)) then
10188       DSUB = XS_SI(IK)
10189     endif
10191     Q_SUBL = DSUB*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
10194     CALL SUBLIME_ICE(XS_SI(IK),rhoa_SI,Q_SUBL,FF3_SI(IK))
10196     XS_MELT_SI(IK)=XX_MELT
10198     TIN=TIN-XLS/CP*Q_SUBL
10199     QQV=QQV+Q_SUBL
10201 ! new change 24.08.04                                         (start)
10203     ee = QQV*pres_SI/(EPS + QQV)
10205 ! new change 24.08.04                                           (end)
10207     if(QQV < 0.) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
10208     if(TIN < 150.) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
10211 ! in case ISUBLIME_ADJUST == 1
10212   endif
10214 ! in case FLIQFR_S(IK).LE.0.D0
10215 endif
10217 if(FLIQFR_S(IK) < 0.D0) then
10218         FLIQFR_S(IK) = 0.D0
10219 endif
10221 IF(FLIQFR_S(IK) > FLIQFRAC_LIM) then
10223   if(XL_SI(IK).NE.XS_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7012")
10225   if(ITEMP_ADJUST == 1) then
10228     Q_ICE_MELTED=FICEMASS*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
10230     TIN=TIN-XLF/CP*Q_ICE_MELTED
10234 ! in case ITEMP_ADJUST == 1
10236   endif
10238   FF1_SI(IK) = FF1_SI(IK) + FF3_SI(IK)
10240 !  FLIQFR_S(IK) = 0.D0
10242   FLIQFR_S(IK) = 1.D0
10244   FF3_SI(IK) = 0.D0
10246 ! in case FLIQFR_S(IK) > FLIQFRAC_LIM
10247 ENDIF
10249 ! in case TIN > 273.15D0
10250 endif
10252 ENDDO
10253 ! cycle by IK
10255 !=============================================================
10256 !               GRAUPEL (assumed to be spheres)
10257 !=============================================================
10260 DO IK = 1, NKR
10262    IK_MELT=IK
10263    I_MELT=0
10265 if(TIN > 273.15D0) then
10267 IF(FLIQFR_G(IK).GE.1.D0.OR.FF4_SI(IK).LE.PETIT_PARAMETRE.OR. &
10268 TIN <= 273.15D0) THEN
10269   IF(FLIQFR_G(IK) > 1.D0) FLIQFR_G(IK) = 1.D0
10270 CYCLE
10271 ENDIF
10273 vt_start = 0.D0
10274 vt_end = 0.D0
10276 rhoi = RHO_G_SI(IK)
10277 fm_i = XG_SI(IK)*(1.D0 - FLIQFR_G(IK))
10278 V_i = fm_i/rhoi
10279 fm_w = XG_SI(IK)*FLIQFR_G(IK)
10280 V_w = fm_w/RHO_WATER
10282 if(rhoi < RHO_CRIT) then
10283   V_soakable = V_i - fm_i/RHO_ICE
10284 else
10285   V_soakable = 0.D0
10286 endif
10288 a_i = rad_sphere(V_i)
10289 a_izero = rad_sphere(XG_SI(IK)/rhoi)
10290 fnre_dry = VTG_SI(IK) * 2.D0*rhoa_SI*a_izero/etaa
10292 ! FIND RE (ie. CD) OF SMOOTH SPHERE OF SAME MASS
10293 !(fnre_smooth is invariant during melting)
10295 X_Best = 8.D0 * XG_SI(IK) * rhoa_SI * GRAV / (PI * etaa * etaa)
10296 fnre_smooth = fnre_sphere(X_Best)
10298 if(V_w < V_soakable) then
10300   a_d = a_i
10301   vt=VT_LOW_DENSITY_SOAKING &
10302     (fnre_dry,fnre_smooth,VTG_SI(IK),a_i,a_izero,etaa,rhoa_SI)
10304 ! in case V_w < V_soakable
10306 else
10308 ! in case V_w >= V_soakable
10310   a_d = rad_sphere(V_i + (V_w - V_soakable))
10311   fm_w_soaked = RHO_WATER* V_soakable
10312   fm_w_crit = (0.268D0 + (fm_i + fm_w_soaked) * 1.D3 * 0.1389D0)
10313   fm_w_crit = fm_w_crit* 1.D-3
10314   a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
10316   if(rhoi < RHO_CRIT) then
10317     vt_start = VT_LOW_DENSITY_TRANS &
10318               (fnre_dry, fnre_smooth, &
10319                VTG_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XG_SI(IK))
10320   else
10321     vt_start=VT_HIGH_DENSITY_TRANS &
10322             (fnre_dry,fnre_smooth,VTG_SI(IK),a_izero,etaa,rhoa_SI)
10323   endif
10325   vt_end=equilibrium_fallspeed &
10326         (fm_i+fm_w_soaked,fm_w_crit, &
10327          XG(:),VTL_SI(:),rhoa_SI,etaa,a_crit)
10329   frac_eqm=(fm_w-fm_w_soaked)/fm_w_crit
10331   if(frac_eqm < 0.D0) frac_eqm = 0.D0
10332   if(frac_eqm > 1.D0) frac_eqm = 1.D0
10334   vt = vt_start + (vt_end - vt_start) * frac_eqm
10336   if(vt < 0.D0) vt = 0.D0
10338 ! in case V_w >= V_soakable
10340 endif
10342 ! new changes 23.01.08                                        (start)
10344 ! new changes 3.02.08                                         (start)
10346 if(ivt_G_H_interpol.ne.0) then
10348   vt=VTG_SI(IK)+FLIQFR_G(IK)*(VTL_SI(IK) - VTG_SI(IK))
10350 endif
10352 ! new changes 3.02.08                                          (end)
10354 ! new changes 23.01.08                                          (end)
10356 V4_SI(IK) = vt
10358 fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
10360 ! new change 5.02.07                                          (start)
10362 fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
10363 fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
10365 ! new change 5.02.07                                            (end)
10367 ! new change 24.08.04                                         (start)
10369 if(FLIQFR_G(IK) <= 0.D0) then
10370   TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
10371 else
10372   TS = 273.15D0
10373 endif
10375 if(TS > 273.15D0) TS = 273.15D0
10377 ! new change 24.08.04                                           (end)
10379 if(fnre < 6000.D0) then
10380   CAP = a_d
10381 else
10382   CAP = a_i
10383 endif
10385 FICEMASS = XG_SI(IK) * (1.D0 - FLIQFR_G(IK))
10387 DMELT = DT*(4.D0*PI*CAP/XLF) * &
10388 (FK_a*(TIN-273.15D0)*fh+(D_V*XLV/RV)*fv*(ee/TIN - es_zero/273.15D0))
10390 ! new change 24.08.04                                         (start)
10392 if(TS < 273.15D0 .and. FLIQFR_G(IK) <= 0.) DMELT = 0.D0
10394 ! new change 24.08.04                                           (end)
10397 call fmass_limits(DMELT, FICEMASS, fm_w, XG_SI(IK))
10399 if(ITEMP_ADJUST == 1) then
10402   call thermodynamical_limits &
10403  (FF4_SI(IK), XG_SI(IK), rhoa_SI, XLF/CP, TIN, DMELT)
10406 ! in case ITEMP_ADJUST == 1
10408 endif
10410 FICEMASS = FICEMASS - DMELT
10412 FLIQFR_G(IK) = (XG_SI(IK) - FICEMASS)/XG_SI(IK)
10414 if(FLIQFR_G(IK) < 0.D0) then
10415   FLIQFR_G(IK) = 0.D0
10416 endif
10418 if(FLIQFR_G(IK) > 0.D0) then
10420   if(IEVAP_ADJUST == 1) then
10422     if(FLIQFR_G(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 901")
10424 ! HEAT_EVAP = Joules of latent heat absorbed by FMASS_EVAP kg
10425 ! of water evaporating
10426 ! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
10428     HEAT_EVAP=-DMELT*XLF+ DT*(4.D0*PI*CAP)*FK_a*(TIN-273.15D0)*fh
10430 ! new changes 24.08.04                                        (start)
10432     IF(HEAT_EVAP.LT.0.D0) THEN
10433       
10434 !      PRINT*, 'HEAT_EVAP < 0'
10436 !      PRINT*, 'GRAUPEL'
10438 !      PRINT*, 'IJK,KX,KZ,IK'
10439 !      PRINT*,  IJK,KX,KZ,IK_MELT
10441 !      HEAT_EVAP=0.D0
10444     ENDIF
10446 ! new change 24.08.04                                           (end)
10448     FMASS_EVAP=HEAT_EVAP/XLV
10450     if(FMASS_EVAP > FLIQFR_G(IK)*XG_SI(IK)) then
10451       FMASS_EVAP = FLIQFR_G(IK)*XG_SI(IK)
10452     endif
10454     Q_EVAP =  FMASS_EVAP * FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
10457 ! in case IEVAP_ADJUST == 1
10458   endif
10460 ! in case FLIQFR_G(IK) > 0.D0
10462 else
10464 ! in case FLIQFR_G(IK) <= 0.D0
10466   if(ISUBLIME_ADJUST == 1)then
10468     sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
10470 ! new change 24.08.04                                         (start)
10472     sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
10474     DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
10475     
10476 ! new change 24.08.04                                           (end)
10478     if(DSUB >  XG_SI(IK)) then
10479       DSUB = XG_SI(IK)
10480     endif
10482     Q_SUBL = DSUB*FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
10485     CALL SUBLIME_ICE( XG_SI(IK), rhoa_SI, Q_SUBL, FF4_SI(IK))
10487     XG_MELT_SI(IK)=XX_MELT
10489     TIN = TIN - XLS/CP*Q_SUBL
10490     QQV = QQV + Q_SUBL
10492 ! new change 24.08.04                                         (start)
10494     ee = QQV*pres_SI/(EPS + QQV)
10496 ! new change 24.08.04                                           (end)
10498     if(QQV < 0.D0)  call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
10499     if(TIN < 150.D0)   call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
10502 ! in case ISUBLIME_ADJUST == 1
10504   endif
10506 ! in case FLIQFR_G(IK) <= 0.D0
10508 endif
10510 IF(FLIQFR_G(IK) > FLIQFRAC_LIM) then
10512   if(XL_SI(IK).NE.XG_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7013")
10514   if(ITEMP_ADJUST == 1) then
10517     Q_ICE_MELTED = FICEMASS *FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
10519     TIN = TIN - XLF/CP*Q_ICE_MELTED
10522 ! in case ITEMP_ADJUST == 1
10524   endif
10526   FF1_SI(IK) = FF1_SI(IK) + FF4_SI(IK)
10528 !  FLIQFR_G(IK) = 0.D0
10530   FLIQFR_G(IK) = 1.D0
10532   FF4_SI(IK) = 0.D0
10534 ! in case FLIQFR_G(IK) > FLIQFRAC_LIM
10536 ENDIF
10538 ! in case TIN > 273.15D0
10540 endif
10542 ENDDO
10543 ! cycle by IK
10545 !=============================================================
10546 !               HAIL (assumed to be spheres)
10547 !=============================================================
10550 DO IK = 1, NKR
10552    IK_MELT=IK
10553    I_MELT=0
10555 if(TIN > 273.15D0) then
10557 IF(FLIQFR_H(IK).GE.1.D0.OR.FF5_SI(IK).LE.PETIT_PARAMETRE.OR. &
10558 TIN <= 273.15D0) THEN
10559   IF(FLIQFR_H(IK) > 1.D0) FLIQFR_H(IK) = 1.D0
10560 CYCLE
10561 ENDIF
10563 vt_start = 0.D0
10564 vt_end = 0.D0
10566 rhoi  = RHO_H_SI(IK)
10567 fm_i = XH_SI(IK)*(1.D0 - FLIQFR_H(IK))
10568 V_i = fm_i/rhoi
10569 fm_w = XH_SI(IK)*FLIQFR_H(IK)
10570 V_w = fm_w/RHO_WATER
10572 if(rhoi < RHO_CRIT) then
10573   V_soakable = V_i - fm_i/RHO_ICE
10574 else
10575   V_soakable = 0.D0
10576 endif
10578 a_i = rad_sphere(V_i)
10579 a_izero = rad_sphere(XH_SI(IK)/rhoi)
10581 ! FIND RE OF SMOOTH SPHERE OF SAME MASS
10582 ! (fnre_smooth is invariant during melting)
10584 if(IPRINTING == 1) print *, 'fnre_dry = ', fnre_dry
10586 fnre_dry=VTH_SI(IK)*2.D0*rhoa_SI*a_izero/etaa
10587 X_Best=8.D0*XH_SI(IK)*rhoa_SI*GRAV/(PI * etaa * etaa)
10588 fnre_smooth=fnre_sphere(X_Best)
10590 vt_justwet = 0.D0
10591 vt_justsoaked = 0.D0
10593 if(V_w < V_soakable) then
10595 ! SOAKING OF WATER
10597   a_d = a_i
10598   vt=VT_LOW_DENSITY_SOAKING &
10599     (fnre_dry,fnre_smooth,VTH_SI(IK),a_i,a_izero,etaa,rhoa_SI)
10601 ! in case V_w < V_soakable
10603 else
10605 ! in case V_w >= V_soakable
10607   a_d = rad_sphere(V_i + (V_w - V_soakable))
10608   fm_w_soaked = RHO_WATER* V_soakable
10609   fm_w_crit=(0.268D0+(fm_i+fm_w_soaked)*1.D3*0.1389D0)
10610   fm_w_crit = fm_w_crit* 1.D-3
10611   a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
10613 !RH87: Just-wet terminal velocity - look at history
10614 !of same particle passing 0oC
10615 !(ie. 'just-wet' means when 0degC is just reached
10616 !by surface and melting commences):
10618   if(rhoi < RHO_CRIT) then
10620     vt_start = VT_LOW_DENSITY_TRANS &
10621               (fnre_dry,fnre_smooth, &
10622                VTH_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XH_SI(IK))
10623   else
10625     vt_start = VT_HIGH_DENSITY_TRANS(fnre_dry, fnre_smooth, &
10626     VTH_SI(IK), a_izero, etaa, rhoa_SI)
10628   endif
10630     vt_end=equilibrium_fallspeed &
10631           (fm_i + fm_w_soaked, fm_w_crit, XH(:), &
10632            VTL_SI(:), rhoa_SI, etaa, a_crit)
10634 ! RH87: Interpolation based on fraction of equilibrium water
10635 ! on surface
10637     frac_eqm = (fm_w - fm_w_soaked)/fm_w_crit
10638     if(frac_eqm < 0.D0) frac_eqm = 0.D0
10639     if(frac_eqm > 1.D0) frac_eqm = 1.D0
10641     vt = vt_start + (vt_end - vt_start) * frac_eqm
10643     if(vt < 0.D0) then
10644       if(IPRINTING == 1) print *, 'WARNING: vt < 0', vt
10645       vt = 0.D0
10646     endif
10648     if(IPRINTING == 1) print *, &
10649    'HERE 2:: vt_start,vt_end,a_izero/a_i= ', &
10650              vt_start,vt_end,a_izero/a_i
10652     if(IPRINTING == 1) print *, &
10653    'HERE 2:: fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet', &
10654              fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet
10656 ! in case V_w >= V_soakable
10658 endif
10660 ! new changes 23.01.08                                      (start)
10662 ! new changes 3.02.08                                       (start)
10664 if(ivt_G_H_interpol.ne.0) then
10666   vt=VTH_SI(IK)+FLIQFR_H(IK)*(VTL_SI(IK) - VTH_SI(IK))
10667   
10668 endif
10670 ! new changes 3.02.08                                         (end)
10671   
10672 ! new changes 23.01.08                                        (end)
10674 V5_SI(IK) = vt
10676 if(IPRINTING == 1) print *, 'HERE 2: VT,LIQUID FRACTION,IK', &
10677                                      V5_SI(IK),FLIQFR_H(IK),IK
10678 fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
10680 ! new change 5.02.07                                          (start)
10682 fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
10683 fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
10685 ! new change 5.02.07                                            (end)
10687 ! new change 24.08.04                                         (start)
10689 if(FLIQFR_H(IK) <= 0.D0) then
10690   TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
10691 else
10692   TS = 273.15D0
10693 endif
10695 if(TS > 273.15D0) TS = 273.15D0
10697 ! new change 24.08.04                                           (end)
10700 if(fnre < 6000.D0) then
10701   CAP = a_d
10702 else
10703   CAP = a_i
10704 endif
10707 FICEMASS = XH_SI(IK) * (1.D0 - FLIQFR_H(IK))
10709 DMELT = DT*4.D0*PI*CAP/XLF* &
10710 (FK_a*(TIN-273.15D0)*fh+D_V*XLV/RV*fv*(ee/TIN-es_zero/273.15D0))
10712 ! new change 24.08.04                                         (start)
10714 if(TS < 273.15D0 .and. FLIQFR_H(IK) <= 0.) DMELT = 0.D0
10716 ! new change 24.08.04                                           (end)
10720 call fmass_limits (DMELT,FICEMASS,fm_w,XH_SI(IK))
10723 if(ITEMP_ADJUST == 1) then
10726   call thermodynamical_limits &
10727  (FF5_SI(IK),XH_SI(IK),rhoa_SI,XLF/CP,TIN,DMELT)
10730 ! in case ITEMP_ADJUST == 1
10732 endif
10734 FICEMASS = FICEMASS - DMELT
10736 FLIQFR_H(IK) = (XH_SI(IK) - FICEMASS)/XH_SI(IK)
10740 if(FLIQFR_H(IK) < 0.D0) then
10741   FLIQFR_H(IK) = 0.D0
10742 endif
10744 if(FLIQFR_H(IK) > 0.D0) then
10746   if(IEVAP_ADJUST == 1) then
10748     if( FLIQFR_H(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 906")
10750 ! HEAT_EVAP = Joules of latent heat absorbed by FMASS_EVAP kg
10751 ! of water evaporating
10753 ! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
10755     HEAT_EVAP=-DMELT*XLF+DT*(4.D0*PI*CAP)*FK_a*(TIN-273.15D0)*fh
10757 ! new changes 24.08.04                                        (start)
10759     IF(HEAT_EVAP.LT.0.D0) THEN
10760       
10761 !      PRINT*, 'HEAT_EVAP < 0'
10763 !      PRINT*, 'GRAUPEL'
10765 !      PRINT*, 'IJK,KX,KZ,IK'
10766 !      PRINT*,  IJK,KX,KZ,IK_MELT
10768 !      HEAT_EVAP=0.D0
10771     ENDIF
10773 ! new change 24.08.04                                           (end)
10775     FMASS_EVAP = HEAT_EVAP/XLV
10777     if(FMASS_EVAP > FLIQFR_H(IK) * XH_SI(IK)) then
10778       FMASS_EVAP = FLIQFR_H(IK) * XH_SI(IK)
10779     endif
10781     Q_EVAP=FMASS_EVAP*FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
10784     CALL EVAP_MELTWATER &
10785    (XH_SI(IK),rhoa_SI,Q_EVAP,FLIQFR_H(IK),FF5_SI(IK))
10787     XH_MELT_SI(IK)=XX_MELT
10789     TIN = TIN - XLV/CP*Q_EVAP
10790     QQV = QQV + Q_EVAP
10792 ! new change 24.08.04                                         (start)
10794     ee = QQV*pres_SI/(EPS + QQV)
10796 ! new change 24.08.04                                           (end)
10798     if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
10799     if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
10802 ! in case IEVAP_ADJUST == 1
10804   endif
10806 ! in case FLIQFR_H(IK) > 0.D0
10808 else
10810 ! in case FLIQFR_H(IK) <= 0.D0
10812   if(ISUBLIME_ADJUST == 1) then
10814     sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
10816 ! new change 24.08.04                                         (start)
10818     sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
10820     DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
10822 ! new change 24.08.04                                           (end)
10824     if(DSUB > XH_SI(IK)) then
10825       DSUB = XH_SI(IK)
10826     endif
10828     Q_SUBL = DSUB*FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
10831     CALL SUBLIME_ICE(XH_SI(IK),rhoa_SI,Q_SUBL,FF5_SI(IK))
10833     XH_MELT_SI(IK)=XX_MELT
10835     TIN = TIN - XLS/CP*Q_SUBL
10836     QQV = QQV + Q_SUBL
10838 ! new change 24.08.04                                         (start)
10840     ee = QQV*pres_SI/(EPS + QQV)
10842 ! new change 24.08.04                                           (end)
10844     if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
10845     if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
10848 ! in case ISUBLIME_ADJUST == 1
10849   endif
10851 ! in case FLIQFR_H(IK) <= 0.D0
10853 endif
10855 if(FLIQFR_H(IK) < 0.D0) then
10856   FLIQFR_H(IK) = 0.D0
10857 endif
10859 IF(FLIQFR_H(IK) > FLIQFRAC_LIM) then
10861   if(XL_SI(IK).NE.XH_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7014")
10863   if(ITEMP_ADJUST == 1) then
10866     Q_ICE_MELTED = FICEMASS *FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
10868     TIN = TIN - XLF/CP*Q_ICE_MELTED
10869     
10871 ! in case ITEMP_ADJUST == 1
10873   endif
10875   FF1_SI(IK) = FF1_SI(IK) + FF5_SI(IK)
10877 !  FLIQFR_H(IK) = 0.D0
10879   FLIQFR_H(IK) = 1.D0
10881   FF5_SI(IK) = 0.D0
10883 ! in case FLIQFR_H(IK) > FLIQFRAC_LIM
10885 ENDIF
10887 ! in case TIN > 273.15D0
10889 endif
10891 ENDDO
10892 ! cycle by IK
10894 !=============================================================
10895 !       UNIT CONVERSION OF ALL OUTPUTS from SI
10896 !=============================================================
10898 if(ihucm_flag == 1) then
10900   if(IVT_ADJUST == 1) then
10901     V2 = 100.D0 * V2_SI
10902     V3 = 100.D0 * V3_SI
10903     V4 = 100.D0 * V4_SI
10904     V5 = 100.D0 * V5_SI
10905   endif
10907   FF1 = 1.D-9*FF1_SI
10908   FF2 = 1.D-9*FF2_SI
10909   FF3 = 1.D-9*FF3_SI
10910   FF4 = 1.D-9*FF4_SI
10911   FF5 = 1.D-9*FF5_SI
10913   XI_MELT = XI_MELT_SI*1000.D0
10914   XS_MELT = XS_MELT_SI*1000.D0
10915   XG_MELT = XG_MELT_SI*1000.D0
10916   XH_MELT = XH_MELT_SI*1000.D0
10918 ! in case ihucm_flag == 1
10920 else
10922 ! in case ihucm_flag.NE.1
10924   if(IVT_ADJUST == 1) then
10925     V2 = V2_SI
10926     V3 = V3_SI
10927     V4 = V4_SI
10928     V5 = V5_SI
10929   endif
10930   
10931   FF1 = FF1_SI
10932   FF2 = FF2_SI
10933   FF3 = FF3_SI
10934   FF4 = FF4_SI
10935   FF5 = FF5_SI
10937   XI_MELT = XI_MELT_SI
10938   XS_MELT = XS_MELT_SI
10939   XG_MELT = XG_MELT_SI
10940   XH_MELT = XH_MELT_SI
10942 ! in case ihucm_flag.NE.1
10944 endif
10946  101 FORMAT(1X,D13.5)
10947  102 FORMAT(1X,2D13.5)
10948  103 FORMAT(1X,3D13.5)
10949  104 FORMAT(1X,4D13.5)
10950  105 FORMAT(1X,5D13.5)
10951  106 FORMAT(1X,6D13.5)
10952  107 FORMAT(1X,7D13.5)
10953  201 FORMAT(1X,I2,D13.5)
10954  202 FORMAT(1X,I2,2D13.5)
10955  203 FORMAT(1X,I2,3D13.5)
10956  204 FORMAT(1X,I2,4D13.5)
10958 END SUBROUTINE MELTING
10960 ! end of melting subroutine
10961 SUBROUTINE EVAP_MELTWATER(XX,rhoax,Q_EVAPX,FLIQFRX,FFX)
10963 implicit double precision (a-h,o-z)
10965 PARAMETER(COL=0.23105D0)
10967 ! control in main program & others subroutines
10969 ! new change 29.10.08                                         (start)           
10972 ! new change 29.10.08                                           (end)
10977 total_mass= XX*FFX*XX*3.D0*COL/rhoax
10978 total_mass_ice=(1.D0-FLIQFRX)*total_mass
10979 total_mass_liq=FLIQFRX*total_mass
10982 if(Q_EVAPX > total_mass_liq) Q_EVAPX = total_mass_liq
10983 if(Q_EVAPX > total_mass) Q_EVAPX = total_mass
10985 total_mass_liq = total_mass_liq - Q_EVAPX
10986 total_mass = total_mass - Q_EVAPX
10988 XX_MELT=total_mass*rhoax/(3.D0*XX*FFX*COL)
10990 FFX = total_mass/(XX*XX*3.D0*COL/rhoax)
10992 if(FFX < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 136")
10994 if(total_mass_liq < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 137")
10995 if(total_mass_ice < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 140")
10996 if(total_mass < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 141")
10998 IF(total_mass.EQ.0.D0) THEN
10999   FLIQFRX =1.D0
11000 ELSE
11001   FLIQFRX = (total_mass - total_mass_ice)/total_mass
11002 ENDIF
11004 if(FLIQFRX < 0.D0) FLIQFRX = 0.D0
11005 if(FLIQFRX > 1.D0) FLIQFRX = 1.D0
11007 101 FORMAT(1X,D13.5)
11008 102 FORMAT(1X,2D13.5)
11009 103 FORMAT(1X,3D13.5)
11010 104 FORMAT(1X,4D13.5)
11011 105 FORMAT(1X,5D13.5)
11012 106 FORMAT(1X,6D13.5)
11014 END SUBROUTINE evap_meltwater
11016 ! end of evap_meltwater subroutine
11017 !====================================================================
11018 SUBROUTINE SUBLIME_ICE (XX,rhoax,Q_SUBLX,FFX)
11020 implicit double precision (a-h,o-z)
11022 PARAMETER(COL = 0.23105D0)
11024 ! new change 24.08.04                                         (start)
11027 ! new change 24.08.04                                           (end)
11029 total_mass =  XX*FFX*XX*3.D0*COL/rhoax
11031 if(Q_SUBLX > total_mass) Q_SUBLX = total_mass
11033 total_mass = total_mass - Q_SUBLX
11035 ! new change 20.06.04                                         (start)
11037 XX_MELT=total_mass*rhoax/(3.D0*FFX*XX*COL)
11039 ! new change 20.06.04                                           (end)
11041 FFX = total_mass/(XX*XX*3.D0*COL/rhoax)
11043 if(FFX < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 140")
11045 if(total_mass < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 141")
11047 END SUBROUTINE sublime_ice
11049 ! end of sublime_ice subroutine
11050 !====================================================================
11051 FUNCTION VT_LOW_DENSITY_SOAKING &
11052 (fnre_dryx,fnre_smoothx,vt_dryx,a_ix,a_izerox,etaax,rhoax)
11054 implicit double precision (a-h,o-z)
11057 ! During melting, Re is constant (see RH87, Appendix B)
11058 ! but size changes
11060 ! Same as for just-wet case, except we use the current ice size
11062 if(fnre_dryx > 4000.D0) then
11064   vtx = vt_dryx * a_izerox/a_ix
11067 ! in case fnre_dryx > 4000.D0
11069 else
11071 ! in case fnre_dryx <= 4000.D0
11073   vtx = fnre_smoothx * etaax/(2.D0 * a_ix * rhoax)
11076 ! in case fnre_dryx <= 4000.D0
11077 endif
11079 VT_LOW_DENSITY_SOAKING = vtx
11081 RETURN
11082 END FUNCTION VT_LOW_DENSITY_SOAKING 
11084 ! end of vt_low_density_soaking function
11085 !====================================================================
11086 FUNCTION VT_LOW_DENSITY_TRANS &
11087 (fnre_dryx,fnre_smoothx,vt_dryx,a_izerox,etaax,rhoax,rhoix,fm_tot)
11089 implicit double precision (a-h,o-z)
11091 PARAMETER(RHO_WATER=1000.D0, RHO_ICE=920.D0, PI = 3.141592654D0)
11093 fm_ijustsoaked=fm_tot/(1.D0+RHO_WATER/rhoix-RHO_WATER/RHO_ICE)
11094 a_ijustsoaked=rad_sphere(fm_ijustsoaked/rhoix)
11096 if(fnre_dryx <=  4000.D0.or.rhoix < 800.D0) then
11097   vt_justsoaked=fnre_smoothx*etaax/(2.D0*a_ijustsoaked*rhoax)
11098 else
11099   vt_justsoaked=vt_dryx*a_izerox/a_ijustsoaked
11100 endif
11102 vtx = vt_justsoaked
11104 VT_LOW_DENSITY_TRANS = vtx
11106 RETURN
11107 END FUNCTION VT_LOW_DENSITY_TRANS
11109 ! end of function vt_low_density_trans
11110 !====================================================================
11111 FUNCTION VT_HIGH_DENSITY_TRANS &
11112 (fnre_dryx,fnre_smoothx,vt_dryx,a_izerox,etaax,rhoax)
11114 implicit double precision (a-h,o-z)
11116 PARAMETER(RHO_WATER=1000.D0, RHO_ICE=920.D0, PI = 3.141592654D0)
11118 ! Just-wet size = a_izero
11120 if(fnre_dryx > 4000.D0) then
11121   vt_justwet=vt_dryx
11122 else
11123   vt_justwet=fnre_smoothx*etaax/(2.D0*a_izerox*rhoax)
11124 endif
11126 vtx = vt_justwet
11128 VT_HIGH_DENSITY_TRANS = vtx
11130 RETURN
11131 END FUNCTION VT_HIGH_DENSITY_TRANS
11133 ! end of function vt_high_density_trans
11134 !====================================================================
11135 ! new change 5.02.07                                          (start)
11137 FUNCTION HAIL_VENTILATION_COEF (fnrex, fnumber, KR)
11139 ! new change 5.02.07                                            (end)
11141 implicit double precision (a-h,o-z)
11143 ! new change 29.10.08                                         (start)           
11146 ! new change 29.10.08                                           (end)
11148 if(fnrex < 6000.D0) then
11150   X_F = (fnrex**0.5D0)*(fnumber**(1.D0/3.D0))
11152   IF(X_F < 1.4D0) then
11153     fx = 1.D0 + 0.108D0*X_F*X_F
11154   ELSE
11155     fx = 0.78D0 + 0.308D0*X_F
11156   ENDIF
11158   if(fnrex < 250.D0) then
11159     fx = fx*2.D0
11160   endif
11162 ! in case fnrex < 6000.D0
11164 else
11166 ! in case fnrex >= 6000.D0
11168   if(fnrex < 20000.D0) then
11169     chi_fr = 0.76D0
11170   else
11171     chi_fr = 0.57 + fnrex*9.D-6
11172   endif
11174   fx = chi_fr*(fnrex**0.5D0)*(fnumber**(1.D0/3.D0))/2.D0
11176 ! in case fnrex >= 6000.D0
11178 endif
11180 if(fx < 1.D0) then
11181   fx = 1.D0
11182 endif
11184 ! new change 5.02.07                                          (start)
11186 !if(fx > 100.D0) stop 99991
11187 if(fx > 100.D0) then
11188 !  print*,   'IJK,KX,KZ,KR'
11189 !  print*,    IJK,KX,KZ,KR
11190 !  print*,   'chi_fr,fnrex,fnumber,fx'
11191 !  print 204, chi_fr,fnrex,fnumber,fx
11192 !  print*,   'stop 99991 : fx > 100.D0'
11193 ! stop 99991
11194   fx=100.D0
11195 endif
11197 ! new change 5.02.07                                            (end)
11199 HAIL_VENTILATION_COEF = fx
11201   201   FORMAT(E13.5)
11202   202   FORMAT(2E13.5)
11203   203   FORMAT(3E13.5)
11204   204   FORMAT(4E13.5)
11205   205   FORMAT(5E13.5)
11206   206   FORMAT(6E13.5)
11207   207   FORMAT(7E13.5)
11209 return
11210 end function HAIL_VENTILATION_COEF
11212 ! end of hail_ventilation_coef function
11213 !====================================================================
11214 ! new change 24.08.04                                          (start)
11216       FUNCTION GGESI(T)
11218 implicit double precision (a-h,o-z)
11220 intrinsic DLOG10
11222 !     SATURATION VAPOR PRESSURE OVER ICE
11223 !      (GOFF AND GRATCH)
11225 !     ESI     SATURATION VAPOR PRESSURE  (MB)
11226 !     T       TEMP  (KELVIN)
11228       DATA C1_MELT/-9.09718D0/C2_MELT/-3.56654D0/C3_MELT/0.876793D0/C4_MELT/0.78583503D0/
11230       A = 273.16D0/T
11231       B = C1_MELT*(A-1.0D0)+C2_MELT*DLOG10(A)+C3_MELT*(1.0D0-1.0D0/A)+C4_MELT
11232       GGESI = 10.0D0**B
11234       RETURN
11235       END FUNCTION GGESI
11237 ! ending of GGESI function
11239 ! new change 24.08.04                                           (end)
11240 !====================================================================
11241 ! new change 24.08.04                                         (start)
11243 FUNCTION SNOW_VENTILATION_COEF(fnrex,fnumber, ARx)
11245 ! new change 24.08.04                                           (end)
11247 implicit double precision (a-h,o-z)
11249 X_F = (fnrex**0.5D0) * (fnumber**(1.D0/3.D0))
11251 ! new change 24.08.04                                         (start)
11253 if(ARx == 1.D0) then
11255 ! real snow is not spherical, so this should not be used
11257   IF(X_F < 1.4D0) then
11258     fx = 1.D0 + 0.108D0*X_F*X_F
11259   ELSE
11260     fx = 0.78D0 + 0.308D0*X_F
11261   ENDIF
11263 else
11265 ! this is the correct formula for real snow
11267 ! new change 24.08.04                                           (end)
11269 if(X_F.le.1.D0) then
11270   fx=1.D0 + 0.14D0*X_F*X_F
11271 else
11272   fx = 0.86D0 + 0.28D0*X_F
11273 endif
11275 endif
11277 if(fx < 1.D0) then
11278   fx = 1.D0
11279 endif
11281 if(fx > 100.D0) then
11283 print *,'99992 stop:',fx,X_F,fnrex,fnumber, ARx
11284 fx = 100.D0
11285 !stop 99992
11286 endif
11288 SNOW_VENTILATION_COEF = fx
11290 return
11291 end function SNOW_VENTILATION_COEF
11293 ! ending of SNOW_VENTILATION_COEF function
11294 !====================================================================
11295 ! new change 24.08.04                                         (start)
11297 !REAL FUNCTION SURFACE_TEMP(eex, tempK, factor_vap, fvofh, XLS, RV)
11299 FUNCTION SURFACE_TEMP(eex, tempK, factor_vap, fvofh, XLS, RV)
11301 ! new change 24.08.04                                           (end)
11303 implicit double precision (a-h,o-z)
11305 intrinsic  DEXP, DABS
11307 tsxold = 269.D0
11309 tsx = 270.D0
11311 tdiff = 1.D0
11313 ilj = 0
11315 alpha_ts = factor_vap*fvofh
11317 beta_ts = alpha_ts*eex/tempK
11319 do while(tdiff > 1.D-6)
11321 ! esix_check=611.21D0*(DEXP((tsx-273.15)*XLS /(RV * tsx * 273.15)))
11323    esix = 100.D0*GGESI(tsx)
11325 ! print *, 'E_si = ', esix, ' Pa', ilj, esix_check
11327   f_tsx = tempK - tsx - alpha_ts*esix/tsx + beta_ts
11329   f_tsxold= &
11330   tempK-tsxold-alpha_ts*100.D0*GGESI(tsxold)/tsxold+beta_ts
11332   tsxnew = tsx - f_tsx*(tsx - tsxold)/(f_tsx - f_tsxold)
11334   tsxold = tsx
11335   tsx = tsxnew
11337   tdiff = DABS(tsx - tsxold)
11339   ilj = ilj + 1
11341   if(ilj > 1e6) then
11342     print *, &
11343    'SURFACE_TEMP not converging', tsx,tempK,tdiff,fvofh,eex,esix
11344     tsx = tempK
11345     exit
11346   endif
11348 enddo
11350 SURFACE_TEMP = tsx
11352 return
11353 END FUNCTION SURFACE_TEMP
11355 ! ending of SURFACE_TEMP function
11357 ! new change 24.08.04                                           (end)
11358 !====================================================================
11359 FUNCTION COLUMN_VENTILATION_COEF(fnrex, fnumber)
11361 implicit double precision (a-h,o-z)
11363 if(fnrex < 50.D0) then
11364   X_F = (fnrex**0.5D0) * (fnumber**(1.D0/3.D0))
11365 else
11366   X_F = (50.D0**0.5D0) * (fnumber**(1.D0/3.D0))
11367 endif
11369 fx=1.D0-0.00668D0*X_F/4.D0+2.39402D0*((X_F/4.D0)**2.D0)+ &
11370    0.73409D0*((X_F/4.D0)**3.D0)-0.73911D0*((X_F/4.D0)**4.D0)
11372 if(fx < 1.D0) then
11373   fx = 1.D0
11374 endif
11376 if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99993")
11378 COLUMN_VENTILATION_COEF = fx
11380 return
11381 end function COLUMN_VENTILATION_COEF
11383 ! end of column_ventilation_coef function
11384 !====================================================================
11385 FUNCTION PLATE_VENTILATION_COEF(fnrex, fnumber)
11387 implicit double precision (a-h,o-z)
11389 if(fnrex < 150.D0) then
11390   X_F = fnrex**0.5D0 * fnumber**(1.D0/3.D0)
11391 else
11392   X_F = 150.D0**0.5D0 * fnumber**(1.D0/3.D0)
11393 endif
11395 fx=1.D0-0.06042D0*X_F/10.D0+2.79820D0*((X_F/10.D0)**2.D0) - &
11396    0.31933D0*((X_F/10.D0)**3.D0)-0.06247D0*((X_F/10.D0)**4.D0)
11398 if(fx < 1.D0) then
11399   fx = 1.D0
11400 endif
11402 if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99994")
11404 PLATE_VENTILATION_COEF = fx
11406 return
11407 end function PLATE_VENTILATION_COEF
11409 ! end of plate_ventilation_coef function
11410 !====================================================================
11411 FUNCTION DENDRITE_VENTILATION_COEF(fnrex, fnumber)
11413 implicit double precision (a-h,o-z)
11415 if(fnrex < 150.D0) then
11416   X_F = (fnrex**0.5D0) * (fnumber**(1.D0/3.D0))
11417 else
11418   X_F = (150.D0**0.5D0) * (fnumber**(1.D0/3.D0))
11419 endif
11421 fx=1.D0+0.35463D0*X_F/10.D0+3.55338D0*((X_F/10.D0)**2.D0)
11423 if(fx < 1.D0) then
11424   fx = 1.D0
11425 endif
11427 if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99995")
11429 DENDRITE_VENTILATION_COEF = fx
11431 return
11432 end function DENDRITE_VENTILATION_COEF
11434 ! end of dendrite_ventilation_coef function
11435 !====================================================================
11436 FUNCTION chi_fra(fra)
11438 implicit double precision (a-h,o-z)
11440 DIMENSION xxa(14), yya(14)
11442 pc = 100.D0 * fra
11444 if(pc.le.0.D0) then
11445   chi_fra = 0.D0
11446   return
11447 endif
11449 if(pc.ge.100.D0) then
11450   chi_fra = 1.D0
11451   return
11452 endif
11454 xxa(1) = 0.D0
11455 yya(1) = 0.D0
11456 xxa(2) = 10.D0
11457 yya(2) = 1.25D0
11458 xxa(3) = 20.D0
11459 yya(3) = 3.12D0
11460 xxa(4) = 30.D0
11461 yya(4) = 5.D0
11462 xxa(5) = 40.D0
11463 yya(5) = 8.12D0
11464 xxa(6) = 50.D0
11465 yya(6) = 11.87D0
11466 xxa(7) = 60.D0
11467 yya(7) = 17.49D0
11468 xxa(8) = 70.D0
11469 yya(8) = 24.36D0
11470 xxa(9) = 75.D0
11471 yya(9) = 28.73D0
11472 xxa(10) = 80.D0
11473 yya(10) = 34.98D0
11474 xxa(11) = 85.D0
11475 yya(11) = 43.72D0
11476 xxa(12) = 90.D0
11477 yya(12) = 56.84D0
11478 xxa(13) = 95.D0
11479 yya(13) = 73.08D0
11480 xxa(14) = 100.D0
11481 yya(14) = 100.D0
11483 ix_max = 14
11485 ix = 0
11487 pc_hi = 0.D0
11489 DO WHILE(pc_hi < pc)
11491 ix = ix + 1
11493 if(ix > ix_max) then
11494 ix = ix - 1
11495 exit
11496 endif
11498 pc_hi = xxa(ix)
11500 ENDDO
11502 ! new change 24.08.04                                         (start)
11504 if(ix -1 < 1) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 42567")
11505 if(ix  > ix_max) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 42568")
11507 ! new change 24.08.04                                           (end)
11509 chi_fra=yya(ix-1)+ &
11510 (pc-xxa(ix-1))*(yya(ix)-yya(ix-1))/(xxa(ix)-xxa(ix-1))
11512 chi_fra = chi_fra/100.D0
11514 if(chi_fra  < 0.D0) chi_fra  = 0.D0
11515 if(chi_fra  > 1.D0) chi_fra  = 1.D0
11517 ! new change 24.08.04                                         (start)
11519 if(chi_fra > 0.3D0 .and. pc < 75.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 1478")
11520 if(chi_fra > 0.6D0 .and. pc < 90.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 1477")
11522 ! new change 24.08.04                                           (end)
11524 RETURN
11525 END FUNCTION chi_fra
11527 ! end of chi_fra function
11528 !====================================================================
11529 function fnre_sphere(xd)
11531 implicit double precision (a-h,o-z)
11533 INTRINSIC DLOG10
11535 ww1 = dlog10(xd)
11537 ww2 = ww1 * ww1
11538 ww3 = ww1 * ww1* ww1
11540 fnre_sphere = 0.d0
11542 if(xd < 73.D0) then
11543   fnre_sphere = xd/24.D0
11544 endif
11546 if(xd < 562.D0.and.xd >= 73.D0) then
11547   fnre_sphere = - 1.7095D0 + 1.33438D0*ww1 - 0.11591D0*ww2
11548   fnre_sphere = 10.D0**fnre_sphere
11549 endif
11551 if(xd < 1.83D3.and.xd >= 562.D0) then
11552   fnre_sphere= &
11553   -1.81391D0 + 1.34671D0*ww1 - 0.12427D0*ww2 + 0.0063D0*ww3
11554   fnre_sphere = 10.D0**fnre_sphere
11555 endif
11557 if(xd < 5.4D10.and.xd >= 1.83D3) then
11558   fnre_sphere= &
11559   0.003567D0*ww3 - 0.089620D0*ww2 + 1.225713D0*ww1 - 1.706026D0
11560   fnre_sphere = 10.D0**fnre_sphere
11561 endif
11563 if(xd >= 5.4D10) then
11564   fnre_sphere = (xd/0.1D0)**0.5D0
11565 endif
11567 end function fnre_sphere
11569 ! end of fnre_sphere function
11570 !====================================================================
11571 function equilibrium_fallspeed (fm_s, fm_w_critx, XXL, vt_rain, &
11572                                 rhoax, etaax, a_eqm)
11573 implicit double precision (a-h,o-z)
11575 !PARAMETER(PI = 3.141592654D0, NKR = 43, GRAV = 9.8D0)
11576 PARAMETER(PI = 3.141592654D0, GRAV = 9.8D0)
11578 DIMENSION XXL(NKR), vt_rain(NKR)
11580 fnre_shed = 4800.D0 + 4831.5D0*1000.D0*fm_s
11582 if(fnre_shed >= 5000.D0.and.fnre_shed <= 2.5D4) then
11584 ! a_d or a_eqm here?
11586 ! new change 21.06.04                                         (start)
11588   vt_eqm = 1.5D-5* fnre_shed/(2.D0*a_eqm)
11589   
11590 ! new change 21.06.04                                           (end)
11592   vt_eqm = vt_eqm* ((1.20D0/rhoax)**0.5D0)
11594   if(vt_eqm > 100.D0) then
11595   !  print *, 'WARNING: vt_eqm exceeding 100 m/s', vt_eqm
11596   !  print *, 'fnre_shed, etaax, rhoax, a_eqm ::', &
11597   !  fnre_shed, etaax, rhoax, a_eqm
11598   call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9999")
11599   endif
11601 ! in case fnre_shed >= 5000.D0.and.fnre_shed <= 2.5D4
11603 else
11605 ! in case fnre_shed < 5000.D0.or.fnre_shed > 2.5D4
11607   if(fnre_shed > 2.5D4) then
11609     X_Best_crit=8.D0*(fm_s+fm_w_critx)*rhoax*GRAV/(PI*etaax*etaax)
11610     fnre_fast=(X_Best_crit/0.6D0)**0.5D0
11611     vt_eqm=fnre_fast*etaax/(2.D0*a_eqm*rhoax)
11613 ! in case fnre_shed > 2.5D4
11615   else
11617 ! in case fnre_shed < 5000.D0
11619     ILIQ = IFIND_IK (fm_s + fm_w_critx, XXL, finter_frac)
11621     if(ILIQ < NKR ) then
11622       vt_eqm = &
11623       vt_rain(ILIQ)+finter_frac*(vt_rain(ILIQ+1)-vt_rain(ILIQ))
11624     else
11625       vt_eqm = vt_rain(NKR)
11626     endif
11628 ! in case fnre_shed < 5000.D0
11629   endif
11631 ! in case fnre_shed < 5000.D0.or.fnre_shed > 2.5D4
11632 endif
11634 equilibrium_fallspeed = vt_eqm
11636 end function equilibrium_fallspeed
11638 ! end of equilibrium_fallspeed function
11639 !====================================================================
11640 FUNCTION IFIND_IK (fmass_target, fmass_array, fraction)
11642 implicit double precision (a-h,o-z)
11644 !PARAMETER(NKR = 43)
11646 DIMENSION fmass_array(NKR)
11648 IKX = 2
11650 DO WHILE(fmass_array(IKX) < fmass_target)
11651    if(IKX > NKR - 1) exit
11652    IKX = IKX + 1
11653 ENDDO
11655 IKX = IKX - 1
11657 fraction= &
11658 (fmass_target-fmass_array(IKX))/(fmass_array(IKX+1)-fmass_array(IKX))
11659 if(fraction < 0.D0) fraction = 0.D0
11660 if(fraction > 1.D0) fraction = 1.D0
11662 if(IKX > NKR.or.IKX < 1) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99999")
11664 IFIND_IK = IKX
11666 END FUNCTION IFIND_IK
11668 ! end of ifind_ik function
11669 !====================================================================
11670 FUNCTION COLUMN_AR (fmassx, rhoix)
11672 implicit double precision (a-h,o-z)
11674 parameter (PI = 3.141592654D0)
11676 ! estimate equivalent diameter (mm)
11678 d_equiv = (fmassx/rhoix)/(4.D0*PI/3.D0)
11679 d_equiv = d_equiv**(1.D0/3.D0)
11680 d_equiv = 2.D0*d_equiv*1000.D0
11682 ! apply Table 1 from Heymsfield (1972)
11684 if(d_equiv < 0.3D0) then
11685   shape = 2.D0
11686 else
11687   shape = d_equiv/(0.1973D0*(d_equiv**0.414D0))
11688 endif
11690 ! Now improve the estimate of AR
11692 FL_i = 4.D0*shape*shape*(fmassx/rhoix)/PI
11693 FL_i = FL_i**(1.D0/3.D0)
11694 FL_i = FL_i* 1000.D0
11696 if(FL_i < 0.3D0) then
11697   COLUMN_AR = 2.D0
11698 else
11699   COLUMN_AR = FL_i/(0.1973D0*(FL_i**0.414D0))
11700 endif
11702 if(COLUMN_AR > 5.D0) COLUMN_AR = 5.D0
11704 return
11705 end function COLUMN_AR
11707 ! end of COLUMN_AR function
11708 !====================================================================
11709 FUNCTION PLATE_AR (fmassx)
11711 implicit double precision (a-h,o-z)
11713 d_i = (fmassx/1.d-3)/0.03760d0
11714 d_i = d_i**(1.d0/3.31d0)
11715 d_i = d_i/100.d0
11716 h_i = 0.0141d0*( (d_i*100.d0)**0.474d0)
11717 h_i = h_i/100.d0
11719 PLATE_AR = h_i/d_i
11721 return
11722 end function  PLATE_AR
11724 ! end of plate_ar function
11725 !====================================================================
11726 FUNCTION DENDRITE_AR(fmassx)
11728 implicit double precision (a-h,o-z)
11730 d_i = (fmassx/1.d-3)/0.00376D0
11731 d_i = d_i**(1.D0/2.79D0)
11732 d_i = d_i/100.D0
11733 h_i = 0.00996D0*((d_i*100.D0)** 0.415D0)
11734 h_i = h_i/100.D0
11736 DENDRITE_AR = h_i/d_i
11738 return
11739 end function DENDRITE_AR
11741 ! end of dendrite_ar function
11742 !====================================================================
11743 FUNCTION COLUMN_CAP_ZERO (fm_ice, AR_ice, rho_ice, FLstar)
11745 implicit double precision (a-h,o-z)
11747 PARAMETER(PI = 3.141592654D0)
11749 INTRINSIC DLOG
11751 a_ix = (fm_ice/rho_ice)/(4.D0*PI*AR_ice/3.D0)
11752 a_ix = a_ix**(1.D0/3.D0)
11753 b_i = AR_ice*a_ix
11755 if(AR_ice < 0.D0.or.AR_ice < 1.D0) then
11756 call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9011")
11757 endif
11759 epsil_i = b_i*b_i - a_ix*a_ix
11761 if(epsil_i.le.0.D0) then
11762 !  print*, a_ix, b_i , fm_ice, AR_ice
11763 call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9044")
11764 endif
11766 epsil_i = epsil_i**0.5D0
11768 COLUMN_CAP_ZERO= (b_i+epsil_i)/a_ix
11769 COLUMN_CAP_ZERO = epsil_i /(DLOG(COLUMN_CAP_ZERO))
11771 omega_i = 2.D0*(PI*a_ix*a_ix) + 4.D0*b_i*a_ix
11773 P_i = 2.D0*PI*a_ix
11775 FLstar = omega_i/P_i
11777 return
11778 end function COLUMN_CAP_ZERO
11780 ! end of column_cap_zero function
11781 !====================================================================
11782 FUNCTION PLANAR_CAP_ZERO (fm_ice, AR_ice, rho_ice, FLstar)
11784 implicit double precision (a-h,o-z)
11786 PARAMETER(PI = 3.141592654D0)
11788 ! new change 29.06.04                                         (start)
11790 !INTRINSIC DLOG, DSIN
11791 INTRINSIC DLOG, DASIN
11793 ! new change 29.06.04                                           (end)
11795 a_ix = (fm_ice/rho_ice)/(4.D0*PI*AR_ice/3.D0)
11796 a_ix = a_ix**(1.D0/3.D0)
11798 if(AR_ice < 0.D0.or.AR_ice > 1.D0) then
11799  call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9022")
11800 endif
11802 epsil_i = 1.D0 - AR_ice*AR_ice
11804 if( epsil_i < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9086")
11806 epsil_i = epsil_i**0.5D0
11808 if(epsil_i > 0.D0) then
11810 ! new change 29.06.04                                         (start)
11812 !  PLANAR_CAP_ZERO = a_ix*epsil_i/DSIN(epsil_i)
11813   PLANAR_CAP_ZERO = a_ix*epsil_i/DASIN(epsil_i)
11815 ! new change 29.06.04                                           (end)
11817   if((1.D0+epsil_i)/(1.D0-epsil_i).le.0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9054")
11819   omega_i = DLOG((1.D0+ epsil_i)/( 1.D0- epsil_i))
11820   omega_i = 2.D0 + PI*AR_ice*(1.D0/epsil_i)*omega_i
11821   omega_i = PI*a_ix*a_ix*omega_i
11823   P_i = 2.D0*PI*a_ix
11824   FLstar = omega_i/P_i
11826 else
11828   PLANAR_CAP_ZERO = a_ix
11829   FLstar = 2.D0*a_ix
11831 endif
11833 return
11834 end function PLANAR_CAP_ZERO
11836 ! end of planar_cap_zero function
11837 !====================================================================
11838 FUNCTION rad_sphere (volume)
11840 implicit double precision (a-h,o-z)
11842 PARAMETER(PI = 3.141592654D0)
11844 rad_sphere = volume/(4.D0*PI/3.D0)
11845 rad_sphere = rad_sphere**(1.D0/3.D0)
11847 return
11848 end FUNCTION rad_sphere
11850 ! end of rad_sphere function
11851 !====================================================================
11852 SUBROUTINE thermodynamical_limits &
11853 (FFX, fm_tot, rhoax, XLFOCP, tempx, dmeltx)
11855 implicit double precision (a-h,o-z)
11857 PARAMETER (COL=0.23105D0)
11859 ! control in main program & others subroutines
11861 ! new change 29.10.08                                         (start)           
11864 ! new change 29.10.08                                           (end)
11868 ! PROBLEMS HERE: is "fnumber_MR" correct
11869 ! for the particle number mixing ratio ( /m3) ?
11873 fnumber_MR = 3.D0*FFX*fm_tot*COL/rhoax
11875 Q_ICE_MELTED = dmeltx*fnumber_MR
11877 temp_star = tempx - XLFOCP*Q_ICE_MELTED
11879 if(temp_star < 273.15D0) then
11881   Q_ICE_MELTED = (tempx - 273.15D0)/XLFOCP
11882   dmeltx = Q_ICE_MELTED / fnumber_MR
11883   tempx = 273.15D0
11885 ! in case temp_star < 273.15D0
11887 else
11889 ! in case temp_star >= 273.15D0
11891   tempx = temp_star
11894 endif
11896 101 FORMAT(1X,D13.5)
11897 102 FORMAT(1X,2D13.5)
11898 103 FORMAT(1X,3D13.5)
11899 104 FORMAT(1X,4D13.5)
11900 105 FORMAT(1X,5D13.5)
11901 106 FORMAT(1X,6D13.5)
11903 END SUBROUTINE thermodynamical_limits
11905 ! end of thermodynamical_limits subroutine
11906 !====================================================================
11907 SUBROUTINE fmass_limits (dmeltx, ficemassx, fm_water, fm_tot)
11909 implicit double precision (a-h,o-z)
11911 INTRINSIC DABS
11913 ! new change 29.10.08                                         (start)           
11916 ! new change 29.10.08                                           (end)
11918 if(dmeltx > ficemassx) then
11919   dmeltx = ficemassx
11920 endif
11922 if(dmeltx < 0.D0.and.DABS(dmeltx) > fm_water) then
11923         dmeltx = - fm_water
11924 endif
11926 if(ficemassx - dmeltx > fm_tot) then
11927   dmeltx = ficemassx - fm_tot
11928 endif
11931 101 FORMAT(1X,D13.5)
11932 102 FORMAT(1X,2D13.5)
11933 103 FORMAT(1X,3D13.5)
11934 104 FORMAT(1X,4D13.5)
11935 105 FORMAT(1X,5D13.5)
11936 106 FORMAT(1X,6D13.5)
11938 end subroutine fmass_limits
11940 ! end of fmass_limits subroutine
11941 ! Version of 3.06.04
11943 ! new size distribution functions after evaporation
11945         SUBROUTINE JERDFUN_MELT &
11947      & (R2,R2N&
11948      & ,FI2,PSI2&
11949      & ,FL2_OLD,FL2_NEW&
11950      & ,IND,ITYPE)
11951 ! new change 29.09.10                                          (end)
11952        implicit none     
11953 !       implicit double precision (a-h,o-z)
11954        REAL DEL2N
11956       INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,IDROP
11957       INTEGER NRX,I_3POINT,ICE_TYPE
11958      
11960 ! include file
11962 !INCLUDE 'MICRO.PRM'
11964  REAL &
11965      &  R2(NKR,IND),R2N(NKR,IND) &
11966      & ,FI2(NKR,IND),PSI2(NKR,IND) &
11967      & ,FL2_OLD(NKR,IND),FL2_NEW(NKR,IND)
11969 ! work arrays
11970 !      DOUBLE PRECISION TPN
11971 !      DOUBLE PRECISION  B21_MY(NKR,IND)
11972         DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
11973         DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND)
11975         DOUBLE PRECISION FL2R_OLD(NKR),FL2R_NEW(NKR)
11977         NRX=NKR
11979         IF(IND.NE.1) THEN
11980           ITYP=ITYPE
11981         ELSE
11982           ITYP=1
11983         ENDIF
11985 ! recalculation of size distribution functions                (start)
11987         DO ICE_TYPE=1,IND
11989            IF(ITYP.EQ.ICE_TYPE) THEN
11991              DO KR=1,NKR
11993                 R2R(KR)=R2(KR,ICE_TYPE)
11994                 R2NR(KR)=R2N(KR,ICE_TYPE)               
11995                 FI2R(KR)=FI2(KR,ICE_TYPE)
11996                 PSI2R(KR)=FI2R(KR)
11997                 FL2R_OLD(KR)=FL2_OLD(KR,ICE_TYPE)
11998                 FL2R_NEW(KR)=FL2R_OLD(KR)
11999                 
12000              ENDDO
12003 ! new size distribution functions after evaporatiion          (start)
12005 ! new change 12.06.06                                         (start)
12006              I_3POINT=0
12007 ! new change 12.06.06                                           (end)
12008              CALL JERNEWF_MELT(NRX,R2R,R2NR,FI2R,PSI2R,FL2R_OLD,FL2R_NEW,I_3POINT)
12010              DO KR=1,NKR                              
12011                 PSI2(KR,ICE_TYPE)=PSI2R(KR)
12012                 FL2_NEW(KR,ICE_TYPE)=FL2R_NEW(KR)
12013              ENDDO
12016 ! in case ITYP.EQ.ICE_TYPE
12018            ENDIF
12020         ENDDO
12022 ! cycle by ICE_TYPE
12024 ! recalculation of size distribution functions                  (end)
12026 ! new size distribution functions                               (end)
12028  128    FORMAT(1X,I2,2D13.5) 
12030         RETURN
12031         END SUBROUTINE JERDFUN_MELT
12033 ! end of SUBROUTINE JERDFUN_MELT
12034         SUBROUTINE JERNEWF_MELT &
12035 ! new change 27.10.08                                         (start)
12036        (NRX,RR,RN,FI,PSI,FL_OLD,FL_NEW,I3POINT)
12038         IMPLICIT NONE
12040         INTEGER & 
12041         KR
12044         INTEGER & 
12045         I,K,NRXP,I3POINT
12047 ! new change 10.06.06                                         (start)
12048         INTEGER & 
12049         ISIGN_DIFFUSIONAL_GROWTH
12050 ! new change 10.06.06                                           (end)
12052         DOUBLE PRECISION &
12053         AOLDCON,ANEWCON,AOLDMASS,ANEWMASS
12055         DOUBLE PRECISION &
12056         RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, &
12057         GN1,GN2,GN3,GN1P,GMAT,GMAT2
12059         INTEGER & 
12060         NRX
12062         DOUBLE PRECISION & 
12063         RR(NRX),FI(NRX),PSI(NRX),RN(NRX) &
12064 ! new change 12.06.06                                         (start)
12065        ,RRS(NRX+1),PSINEW(NRX+1)
12066 ! new change 12.06.06                                           (end)
12068         DOUBLE PRECISION & 
12069         FL_OLD(NRX),FL_NEW(NRX)
12071         DOUBLE PRECISION & 
12072 ! new change 12.06.06                                         (start)
12073         DROPMASS(NRX+1)
12074 ! new change 12.06.06                                           (end)
12076         DOUBLE PRECISION & 
12077         PSI_IM,PSI_I,PSI_IP
12079 ! INITIAL VALUES FOR SOME VARIABLES
12081         NRXP=NRX+1
12083         DO I=1,NRX
12085 ! RN(I), g - new masses after condensation or evaporation
12087            IF(RN(I).LT.0.0D0) THEN 
12088              RN(I)=1.0D-50
12089              FI(I)=0.0D0
12090            ENDIF
12092         ENDDO
12094         DO K=1,NRX
12095            PSI(K)=0.0D0
12096 ! new change 12.06.06                                         (start)
12097            PSINEW(K)=0.0D0
12098 ! new change 12.06.06                                           (end)
12099            RRS(K)=RR(K)
12100            DROPMASS(K)=0.0D0
12101         ENDDO
12102         
12103         RRS(NRXP)=RRS(NRX)*1024.0D0
12104 ! new change 12.06.06                                         (start)
12105         PSINEW(NRXP)=0.0D0
12106 ! new change 12.06.06                                           (end)
12108 ! new change 7.05.07                                         (start)
12109         DROPMASS(NRXP)=0.0D0
12110 ! new change 7.05.07                                           (end)
12112 ! new change 10.06.06                                         (start)
12114         ISIGN_DIFFUSIONAL_GROWTH=0
12116         DO K=1,NRX
12117            IF(RN(K).NE.RR(K)) THEN
12118               ISIGN_DIFFUSIONAL_GROWTH=1
12119               GOTO 2000
12120            ENDIF
12121         ENDDO
12123  2000   CONTINUE
12124        
12125         IF(ISIGN_DIFFUSIONAL_GROWTH.NE.0) THEN
12127 ! new change 10.06.06                                           (end)
12129 ! Kovetz-Olund method                                         (start)
12131           DO K=1,NRX
12133              IF(FI(K).NE.0.0D0) THEN
12135                I=1
12137                DO WHILE &
12138 ! new change 12.06.06                                         (start)
12139                 (.NOT.(RRS(I).LE.RN(K).AND.RRS(I+1).GT.RN(K)) &
12140 ! new change 12.06.06                                           (end)
12141                  .AND.I.LT.NRX)
12142                   I=I+1
12143                ENDDO
12145                IF(RN(K).LT.RRS(1)) THEN
12147                  RNTMP=RN(K)
12148                  RRTMP=0.0D0
12149                  RRP=RRS(1)
12150                  GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
12151 ! new change 13.06.06                                         (start)
12152                  PSINEW(1)=PSINEW(1)+FI(K)*RR(K)*GMAT2
12153                  DROPMASS(1)= &
12154                  DROPMASS(1)+FL_OLD(K)*RR(1)*FI(K)*RR(K)*GMAT2
12155 ! new change 13.06.06                                           (end)
12157                ELSE
12159                  RNTMP=RN(K)
12160                  RRTMP=RRS(I)
12161                  RRP=RRS(I+1)
12162                  GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
12163                  GMAT=(RRP-RNTMP)/(RRP-RRTMP)
12164 ! new change 13.06.06                                         (start)
12165                  PSINEW(I)=PSINEW(I)+FI(K)*RR(K)*GMAT
12166                  PSINEW(I+1)=PSINEW(I+1)+FI(K)*RR(K)*GMAT2
12168                  DROPMASS(I)= &
12169                  DROPMASS(I)+FL_OLD(K)*RR(I)*FI(K)*RR(K)*GMAT
12170 ! new change 7.05.07                                         (start)
12171 !                 DROPMASS(I+1)= &
12172 !                 DROPMASS(I+1)+FL_OLD(K)*RR(I+1)*FI(K)*RR(K)*GMAT2
12173                  DROPMASS(I+1)= &
12174                  DROPMASS(I+1)+FL_OLD(K)*RRS(I+1)*FI(K)*RR(K)*GMAT2
12175 ! new change 7.05.07                                         (start)
12176 ! new change 13.06.06                                           (end)
12178                ENDIF
12180 ! in case FI(K).NE.0.0D0
12182              ENDIF
12184           ENDDO
12186 ! cycle by K
12188           DO I=1,NRX
12189 ! new change 12.06.06                                         (start)
12190              PSI(I)=PSINEW(I)
12191 ! new change 12.06.06                                           (end)
12192              IF(PSI(I).NE.0.D0) THEN
12193                FL_NEW(I)=DROPMASS(I)/RR(I)/PSI(I)
12194              ELSE
12195 ! new change 19.03.08                                         (start)
12196 !               FL_NEW(I)=1.0D0
12197                FL_NEW(I)=0.0D0
12198 ! new change 19.03.08                                           (end)
12199              ENDIF
12200           ENDDO
12201                
12202 ! Kovetz-Olund method                                           (end)
12204 ! calculation both new total drop concentrations(after KO) and new 
12205 ! total drop masses (after KO)
12207           AOLDCON=0.0D0
12208           ANEWCON=0.0D0
12209           AOLDMASS=0.0D0
12210           ANEWMASS=0.0D0
12211         
12212           DO K=1,NRX
12213              AOLDCON=AOLDCON+FI(K)*RR(K)
12214              ANEWCON=ANEWCON+PSI(K)
12215              AOLDMASS=AOLDMASS+FI(K)*RR(K)*RN(K)
12216              ANEWMASS=ANEWMASS+PSI(K)*RR(K)
12217           ENDDO
12218           
12219 ! new change 29.04.08                                         (start)                     
12220 !          IF(I3POINT.NE.0) THEN
12221           IF(I3POINT.NE.0) GOTO 2001
12222 ! new change 29.04.08                                           (end)
12224             DO K=1,NRX
12226                IF(FI(K).NE.0.0D0) THEN
12228                  IF(RRS(2).LT.RN(K)) THEN
12230                    I=2
12232                    DO  WHILE &
12233                      (.NOT.(RRS(I).LT.RN(K).AND.RRS(I+1).GT.RN(K)) &
12234                       .AND.I.LT.NRX)
12235                        I=I+1
12236                    ENDDO
12238                    IF(I.LT.NRX-2) THEN
12240                      RNTMP=RN(K)
12242                      RRTMP=RRS(I)
12243                      RRP=RRS(I+1)
12244                      RRM=RRS(I-1)
12246                      RNTMP2=RN(K+1)
12248                      RRTMP2=RRS(I+1)
12249                      RRP2=RRS(I+2)
12250                      RRM2=RRS(I)
12252                      GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ &
12253                          (RRTMP-RRM)
12255                      GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ &
12256                           (RRP2-RRM2)/(RRTMP2-RRM2)
12258                      GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ &
12259                          (RRTMP-RRM)
12261                      GMAT=(RRP-RNTMP)/(RRP-RRTMP)
12263                      GN3=(RRTMP-RNTMP)*(RRM-RNTMP)/(RRP-RRM)/ &
12264                                                  (RRP-RRTMP)
12265                      GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
12267                      PSI_IM=PSI(I-1)+GN1*FI(K)*RR(K)
12268                      PSI_I=PSI(I)+(GN1P+GN2-GMAT)*FI(K+1)*RR(K+1)
12269                      PSI_IP=PSI(I+1)+(GN3-GMAT2)*FI(K)*RR(K)
12270                     
12271                      IF(PSI_IM.GT.0.0D0) THEN
12273                        IF(PSI_IP.GT.0.0D0) THEN
12275                          IF(I.GT.2) THEN
12276 ! smoothing criteria
12277                            IF(PSI_IM.GT.PSI(I-2) &
12278                           .AND.PSI_IM.LT.PSI_I &
12279                           .AND.PSI(I-2).LT.PSI(I) &
12280                           .OR.PSI(I-2).GE.PSI(I)) THEN
12282                              PSI(I-1)=PSI_IM
12284                              PSI(I)=PSI(I)+FI(K)*RR(K)*(GN2-GMAT)
12286                              PSI(I+1)=PSI_IP
12287 ! in case smoothing criteria
12288                            ENDIF 
12289 ! in case I.GT.2
12290                          ENDIF
12292 ! in case PSI_IP.GT.0.0D0
12294                        ENDIF
12296 ! in case PSI_IM.GT.0.0D0
12298                      ENDIF
12299 ! in case I.LT.NRX-2
12300                    ENDIF
12302 ! in case RRS(2).LT.RN(K)
12304                  ENDIF
12306 ! in case FI(K).NE.0.0D0
12308                ENDIF
12310  1000          CONTINUE
12312             ENDDO
12313 ! cycle by K
12314             AOLDCON=0.0D0
12315             ANEWCON=0.0D0
12316             AOLDMASS=0.0D0
12317             ANEWMASS=0.0D0
12319             DO K=1,NRX
12320                AOLDCON=AOLDCON+FI(K)*RR(K)
12321                ANEWCON=ANEWCON+PSI(K)
12322                AOLDMASS=AOLDMASS+FI(K)*RR(K)*RN(K)
12323                ANEWMASS=ANEWMASS+PSI(K)*RR(K)
12324             ENDDO
12326 ! 3 point method                                                (end)
12328 ! new change 29.04.08                                         (start)                     
12330 ! in case I3POINT.NE.0
12332 !         ENDIF
12334  2001     CONTINUE
12336 ! new change 29.04.08                                           (end)
12338 ! PSI(K) - new hydrometeor size distribution function
12340           DO K=1,NRX
12341              PSI(K)=PSI(K)/RR(K)
12342           ENDDO
12344 ! new change 10.06.06                                         (start)
12346 ! in case ISIGN_DIFFUSIONAL_GROWTH.NE.0
12348         ELSE
12350 ! in case ISIGN_DIFFUSIONAL_GROWTH.EQ.0
12352 ! new change 10.06.06                                           (end)
12354           DO K=1,NRX
12355              PSI(K)=FI(K)
12356           ENDDO
12358         ENDIF
12361   201   FORMAT(1X,D13.5)
12362   202   FORMAT(1X,2D13.5)
12363   203   FORMAT(1X,3D13.5)
12364   204   FORMAT(1X,4D13.5)
12365   205   FORMAT(1X,5D13.5)
12366   206   FORMAT(1X,6D13.5)
12367   301   FORMAT(1X,I2,2X,D13.5)
12368   302   FORMAT(1X,I2,2X,2D13.5)
12369   303   FORMAT(1X,I2,2X,3D13.5)
12370   304   FORMAT(1X,I2,2X,4D13.5)
12371   305   FORMAT(1X,I2,2X,5D13.5)
12372   306   FORMAT(1X,I2,2X,6D13.5)
12374         RETURN 
12375         END SUBROUTINE JERNEWF_MELT
12377 ! SUBROUTINE JERNEWF_MELT
12378 ! Version of 10.02.08 
12380 ! new changes 10.02.08                                       (start)
12382 SUBROUTINE SHEDDING &
12384 (ihucm_flag&
12386 ,FF1,XL,VTL &
12387 ,FF4,XG,V4,VTG,FLIQFR_G,RHO_G &
12388 ,FF5,XH,V5,VTH,FLIQFR_H,RHO_H &
12389 ,TIN,rhoa,pres,DT,QQV)
12390 ! new changes 25.01.08                                         (end)
12392 ! new changes 10.02.08                                         (end)
12394 !===============================================!
12395 ! EXPLICIT MELTING SCHEME                       !
12396 ! Author: Vaughan T.J. PHILLIPS, August 2004    !
12397 ! at Princeton University (AOS program)         !
12398 ! and GFDL, NOAA/OAR, USA                       !
12399 !===============================================!
12401 implicit double precision (a-h,o-z)
12403 !PARAMETER(NKR=33, NK=129, ICEMAX=3)
12405 ! new changes 25.01.08                                       (start)
12407 PARAMETER(COL=0.23105D0, CP=1004.7D0, RV=461.51D0, RD=287.039D0, &
12408           EPS=RD/RV, FJOULES_IN_A_CAL=4.187D0, PI=3.141592654D0, &
12409           AR_LIM=2.D0, GRAV=9.8D0, RHO_ICE=920.D0, &
12410           RHO_WATER=1000.D0, FLIQFRAC_LIM=0.9D0, &
12411           PETIT_PARAMETRE=1.D-10)
12412           
12413 ! new changes 12.02.08                                       (start)
12414 PARAMETER(ISHEDDING_ON=1, IVT_ADJUST=1, IPRINTING=0, &
12415           ITEMP_ADJUST=1, IEVAP_ADJUST=1, ISUBLIME_ADJUST=1)
12416 ! new changes 12.02.08                                         (end)
12418 ! new changes 25.01.08                                         (end)
12420 ! control in main program & others subroutines
12422 ! new changes 12.02.08                                       (start)
12424 DIMENSION FF1(NKR), XL(NKR), VTL(NKR)
12426 ! new changes 10.02.08                                         (end)
12428 DIMENSION FF4(NKR),XG(NKR),V4(NKR), &
12429           VTG(NKR),FLIQFR_G(NKR),RHO_G(NKR)
12431 DIMENSION FF5(NKR),XH(NKR),V5(NKR), &
12432           VTH(NKR),FLIQFR_H(NKR),RHO_H(NKR)
12434 DIMENSION FF1_SI(NKR), XL_SI(NKR), & 
12435           VTL_SI(NKR)
12437 DIMENSION FF4_SI(NKR),XG_SI(NKR),V4_SI(NKR), &
12438           VTG_SI(NKR), RHO_G_SI(NKR)
12440 DIMENSION FF5_SI(NKR),XH_SI(NKR),V5_SI(NKR), &
12441           VTH_SI(NKR), RHO_H_SI(NKR)
12442           
12443 INTRINSIC SUM
12446 If(TIN <= 273.15D0) then
12447   RETURN
12448 ENDIF
12450 if(SUM(FF4) <= 0.D0.and.SUM(FF5) <= 0.D0) then
12452   return
12453   
12454 endif
12456 !=============================================================
12457 !       UNIT CONVERSION OF ALL INPUTS to SI
12458 !=============================================================
12460 if(ihucm_flag == 1) then
12462 RHO_G_SI = RHO_G*1000.D0
12463 RHO_H_SI = RHO_H*1000.D0
12465 XL_SI = XL/1000.D0
12466 XG_SI = XG/1000.D0
12467 XH_SI = XH/1000.D0
12470 VTL_SI = VTL/100.D0
12471 VTG_SI = VTG/100.D0
12472 VTH_SI = VTH/100.D0
12474 V4_SI = V4/100.D0
12475 V5_SI = V5/100.D0
12477 FF1_SI = 1.E9*FF1
12478 FF4_SI = 1.E9*FF4
12479 FF5_SI = 1.E9*FF5
12481 pres_SI = pres/10.D0
12482 rhoa_SI = rhoa*1000.D0
12484 ! in case ihucm_flag == 1
12486 else
12488 ! in case ihucm_flag.NE.1
12490 RHO_G_SI = RHO_G
12491 RHO_H_SI = RHO_H
12494 XL_SI = XL
12495 XG_SI = XG
12496 XH_SI = XH
12498 VTL_SI = VTL
12499 VTG_SI = VTG
12500 VTH_SI = VTH
12502 V4_SI = V4
12503 V5_SI = V5
12505 FF1_SI = FF1
12506 FF4_SI = FF4
12507 FF5_SI = FF5
12509 pres_SI = pres
12510 rhoa_SI = rhoa
12512 ! in case ihucm_flag.NE.1
12514 endif
12516 !=============================================================
12517 !       INITIALISATION
12518 !=============================================================
12520 V4_SI(:) = VTG_SI(:)
12521 V5_SI(:) = VTH_SI(:)
12523 ee = QQV*pres_SI/(EPS + QQV)
12525 es_zero = 611.21D0
12527 if(pres_SI > 200000.D0.or.pres_SI < 10000.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9071")
12529 D_V=0.211D0*((TIN/273.15D0)**1.94D0)*(101325.D0/pres_SI)/1.D4
12531 ! D_V = 2.21D-5
12532 ! FK_a = 2.40D-2
12534 FK_a =(5.69D0+0.017D0*(TIN-273.15D0))*1.0D-3*4.187D0
12536 ! XLV = 2.50D6
12537 ! XLF = 2.83D6 - XLV
12539 ! The expressions for latent heats used by R&H, 1987,
12540 ! seem more applicable to
12541 ! T > 0degC than
12542 ! those by P & K 1997, and more modern
12544 ! XLV=597.3D0*((273.15D0/TIN)**(0.167D0+3.67D-4*TIN))
12546 XLV = 597.3D0
12547 XLV = XLV*FJOULES_IN_A_CAL*1000.D0
12548 XLS = 2.83D6
12550 !XLF=79.7+0.485D0*(TIN-273.15D0)-2.5D-3*(TIN-273.15D0)*(TIN-273.15D0)
12552 XLF = 79.7D0
12553 XLF = XLF*FJOULES_IN_A_CAL*1000.D0
12555 ! FNSC=0.632D0
12557 etaa = (1.718D0 + 0.0049D0*(TIN-273.15D0) - &
12558         1.2D-5*(TIN-273.15D0)*(TIN-273.15D0))*1.D-5
12560 ! etaa/rhoa_SI = kinematic viscosity
12562 FNSC = etaa/(rhoa_SI*D_V)
12564 ! FNPR=0.71D0
12566 ALPHA_H = FK_a/(CP*rhoa_SI)
12567 FNPR = etaa/(rhoa_SI*ALPHA_H)
12568 RHO_CRIT = 910.D0
12570 if(rhoa_SI > 2.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 111")
12572 if(rhoa_SI < 0.1D0) then
12573 !  print*, &
12574 ! 'rhoa_SI < 0.1D0 kg/m3::TIN,rhoa_SI,PRES,DT,QQV = ', &
12575 !  TIN,rhoa_SI,pres_SI,DT,QQV
12576   call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 112")
12577 endif
12579 if(RHO_H_SI(1) < 1.D0) then
12580  ! print *, 'RHO_H_SI(1) < 1.D0kg/m3'
12581   call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 113")
12582 endif
12584 TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), 1.D0, XLS, RV)
12585 if(TS > 273.15D0) TS = 273.15D0
12587 !=============================================================
12588 !               GRAUPEL (assumed to be spheres)
12589 !=============================================================
12591 ISIGN_GRAUPEL=1
12592 ISIGN_HAIL=0
12594 DO IK = 1, NKR
12596    IK_MELT=IK
12597    I_MELT=0
12599 if(TIN > 273.15D0) then
12601 IF(FLIQFR_G(IK).GE.1.D0.OR.FF4_SI(IK).LE.PETIT_PARAMETRE.OR. &
12602 TIN <= 273.15D0) THEN
12603   IF(FLIQFR_G(IK) > 1.D0) FLIQFR_G(IK) = 1.D0
12604 CYCLE
12605 ENDIF
12607 vt_start = 0.D0
12608 vt_end = 0.D0
12610 rhoi = RHO_G_SI(IK)
12611 fm_i = XG_SI(IK)*(1.D0 - FLIQFR_G(IK))
12612 V_i = fm_i/rhoi
12614 fm_w = XG_SI(IK)*FLIQFR_G(IK)
12615 V_w = fm_w/RHO_WATER
12617 if(rhoi < RHO_CRIT) then
12618   V_soakable = V_i - fm_i/RHO_ICE
12619 else
12620   V_soakable = 0.D0
12621 endif
12623 a_i = rad_sphere(V_i)
12624 a_izero = rad_sphere(XG_SI(IK)/rhoi)
12625 fnre_dry = VTG_SI(IK) * 2.D0*rhoa_SI*a_izero/etaa
12627 ! FIND RE (ie. CD) OF SMOOTH SPHERE OF SAME MASS
12628 !(fnre_smooth is invariant during melting)
12630 X_Best = 8.D0 * XG_SI(IK) * rhoa_SI * GRAV / (PI * etaa * etaa)
12631 fnre_smooth = fnre_sphere(X_Best)
12633 if(V_w < V_soakable) then
12635   a_d = a_i
12636   vt=VT_LOW_DENSITY_SOAKING &
12637     (fnre_dry,fnre_smooth,VTG_SI(IK),a_i,a_izero,etaa,rhoa_SI)
12639 ! in case V_w < V_soakable
12641 else
12643 ! in case V_w >= V_soakable
12645   a_d = rad_sphere(V_i + (V_w - V_soakable))
12646   fm_w_soaked = RHO_WATER* V_soakable
12647   fm_w_crit = (0.268D0 + (fm_i + fm_w_soaked) * 1.D3 * 0.1389D0)
12648   fm_w_crit = fm_w_crit* 1.D-3
12649   a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
12651   if(rhoi < RHO_CRIT) then
12652     vt_start = VT_LOW_DENSITY_TRANS &
12653               (fnre_dry, fnre_smooth, &
12654                VTG_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XG_SI(IK))
12655   else
12656     vt_start=VT_HIGH_DENSITY_TRANS &
12657             (fnre_dry,fnre_smooth,VTG_SI(IK),a_izero,etaa,rhoa_SI)
12658   endif
12660   vt_end=equilibrium_fallspeed &
12661         (fm_i+fm_w_soaked,fm_w_crit, &
12662          XG(:),VTL_SI(:),rhoa_SI,etaa,a_crit)
12664   frac_eqm=(fm_w-fm_w_soaked)/fm_w_crit
12666   if(frac_eqm < 0.D0) frac_eqm = 0.D0
12667   if(frac_eqm > 1.D0) frac_eqm = 1.D0
12669   vt = vt_start + (vt_end - vt_start) * frac_eqm
12671   if(vt < 0.D0) vt = 0.D0
12673 ! in case V_w >= V_soakable
12675 endif
12677 ! new changes 3.02.08                                        (start)
12679 if(ivt_G_H_interpol.ne.0) then
12681   vt=VTG_SI(IK)+FLIQFR_G(IK)*(VTL_SI(IK) - VTG_SI(IK))
12682   
12683 endif
12685 ! new changes 3.02.08                                          (end)
12687 V4_SI(IK) = vt
12689 fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
12691 fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
12692 fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
12694 ! new change 10.02.08                                        (start)
12696 if(FLIQFR_G(IK) <= 0.D0) then
12697   TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
12698 else
12699   TS = 273.15D0
12700 endif
12702 ! new change 10.02.08                                          (end)
12704 if(TS > 273.15D0) TS = 273.15D0
12706 if(fnre < 6000.D0) then
12707   CAP = a_d
12708 else
12709   CAP = a_i
12710 endif
12712 if(FLIQFR_G(IK) <= FLIQFRAC_LIM) then
12714   if(ISHEDDING_ON.eq.1) then
12716     if(IPRINTING == 1) print *,' SHEDDING CODE(GRAUPEL)  '
12718     CALL SHED_MELTWATER &
12719    (fnre,rhoi,RHO_CRIT,XG_SI,FF4_SI,FLIQFR_G,XL_SI,FF1_SI,IK)
12721   endif
12722   
12723 ! in case FLIQFR_G(IK) <= FLIQFRAC_LIM
12725 endif
12727 ! in case TIN > 273.15D0
12729 endif
12731 ENDDO
12732 ! cycle by IK
12734 !=============================================================
12735 !               HAIL (assumed to be spheres)
12736 !=============================================================
12738 ISIGN_GRAUPEL=0
12739 ISIGN_HAIL=1
12741 DO IK = 1, NKR
12743    IK_MELT=IK
12744    I_MELT=0
12746 if(TIN > 273.15D0) then
12748 IF(FLIQFR_H(IK).GE.1.D0.OR.FF5_SI(IK).LE.PETIT_PARAMETRE.OR. &
12749 TIN <= 273.15D0) THEN
12750   IF(FLIQFR_H(IK) > 1.D0) FLIQFR_H(IK) = 1.D0
12751 CYCLE
12752 ENDIF
12754 vt_start = 0.D0
12755 vt_end = 0.D0
12757 rhoi  = RHO_H_SI(IK)
12758 fm_i = XH_SI(IK)*(1.D0 - FLIQFR_H(IK))
12759 V_i = fm_i/rhoi
12761 fm_w = XH_SI(IK)*FLIQFR_H(IK)
12762 V_w = fm_w/RHO_WATER
12764 if(rhoi < RHO_CRIT) then
12765   V_soakable = V_i - fm_i/RHO_ICE
12766 else
12767   V_soakable = 0.D0
12768 endif
12770 a_i = rad_sphere(V_i)
12771 a_izero = rad_sphere(XH_SI(IK)/rhoi)
12773 ! FIND RE OF SMOOTH SPHERE OF SAME MASS
12774 ! (fnre_smooth is invariant during melting)
12776 if(IPRINTING == 1) print *, 'fnre_dry = ', fnre_dry
12778 fnre_dry=VTH_SI(IK)*2.D0*rhoa_SI*a_izero/etaa
12779 X_Best=8.D0*XH_SI(IK)*rhoa_SI*GRAV/(PI * etaa * etaa)
12780 fnre_smooth=fnre_sphere(X_Best)
12782 vt_justwet = 0.D0
12783 vt_justsoaked = 0.D0
12785 if(V_w < V_soakable) then
12787 ! SOAKING OF WATER
12789   a_d = a_i
12790   vt=VT_LOW_DENSITY_SOAKING &
12791     (fnre_dry,fnre_smooth,VTH_SI(IK),a_i,a_izero,etaa,rhoa_SI)
12793 ! in case V_w < V_soakable
12795 else
12797 ! in case V_w >= V_soakable
12799   a_d = rad_sphere(V_i + (V_w - V_soakable))
12800   fm_w_soaked = RHO_WATER* V_soakable
12801   fm_w_crit=(0.268D0+(fm_i+fm_w_soaked)*1.D3*0.1389D0)
12802   fm_w_crit = fm_w_crit* 1.D-3
12803   a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
12805 !RH87: Just-wet terminal velocity - look at history
12806 !of same particle passing 0oC
12807 !(ie. 'just-wet' means when 0degC is just reached
12808 !by surface and melting commences):
12810   if(rhoi < RHO_CRIT) then
12812     vt_start = VT_LOW_DENSITY_TRANS &
12813               (fnre_dry,fnre_smooth, &
12814                VTH_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XH_SI(IK))
12815   else
12817     vt_start = VT_HIGH_DENSITY_TRANS(fnre_dry, fnre_smooth, &
12818     VTH_SI(IK), a_izero, etaa, rhoa_SI)
12820   endif
12822     vt_end=equilibrium_fallspeed &
12823           (fm_i + fm_w_soaked, fm_w_crit, XH(:), &
12824            VTL_SI(:), rhoa_SI, etaa, a_crit)
12826 ! RH87: Interpolation based on fraction of equilibrium water
12827 ! on surface
12829     frac_eqm = (fm_w - fm_w_soaked)/fm_w_crit
12830     if(frac_eqm < 0.D0) frac_eqm = 0.D0
12831     if(frac_eqm > 1.D0) frac_eqm = 1.D0
12833     vt = vt_start + (vt_end - vt_start) * frac_eqm
12835     if(vt < 0.D0) then
12836       if(IPRINTING == 1) print *, 'WARNING: vt < 0', vt
12837       vt = 0.D0
12838     endif
12840     if(IPRINTING == 1) print *, &
12841    'HERE 2:: vt_start,vt_end,a_izero/a_i= ', &
12842              vt_start,vt_end,a_izero/a_i
12844     if(IPRINTING == 1) print *, &
12845    'HERE 2:: fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet', &
12846              fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet
12848 ! in case V_w >= V_soakable
12850 endif
12852 ! new changes 3.02.08                                        (start)
12854 if(ivt_G_H_interpol.ne.0) then
12856   vt=VTH_SI(IK)+FLIQFR_H(IK)*(VTL_SI(IK) - VTH_SI(IK))
12857   
12858 endif
12859   
12860 ! new changes 3.02.08                                          (end)
12862 V5_SI(IK) = vt
12864 fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
12866 ! new change 5.02.07                                          (start)
12868 fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
12869 fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
12871 ! new change 10.02.08                                         (start)
12873 if(FLIQFR_H(IK) <= 0.D0) then
12874   TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
12875 else
12876   TS = 273.15D0
12877 endif
12879 ! new change 10.02.08                                           (end)
12881 if(TS > 273.15D0) TS = 273.15D0
12883 if(fnre < 6000.D0) then
12884   CAP = a_d
12885 else
12886   CAP = a_i
12887 endif
12889 if(FLIQFR_H(IK) <= FLIQFRAC_LIM) then
12891   if(ISHEDDING_ON.eq.1) then
12893     CALL SHED_MELTWATER &
12894    (fnre,rhoi,RHO_CRIT,XH_SI,FF5_SI,FLIQFR_H,XL_SI,FF1_SI,IK)
12896 ! in case ISHEDDING_ON.eq.1
12898   endif
12899   
12900 ! in case FLIQFR_H(IK) <= FLIQFRAC_LIM
12902 endif
12904 ! in case TIN > 273.15D0
12906 endif
12908 ENDDO
12909 ! cycle by IK
12911 !=============================================================
12912 !       UNIT CONVERSION OF ALL OUTPUTS from SI
12913 !=============================================================
12915 if(ihucm_flag == 1) then
12917   if(IVT_ADJUST == 1) then
12918     V4 = 100.D0 * V4_SI
12919     V5 = 100.D0 * V5_SI
12920   endif
12922   FF1 = 1.D-9*FF1_SI
12923   FF4 = 1.D-9*FF4_SI
12924   FF5 = 1.D-9*FF5_SI
12925   
12926 ! in case ihucm_flag == 1
12928 else
12930 ! in case ihucm_flag.NE.1
12932   if(IVT_ADJUST == 1) then
12933     V4 = V4_SI
12934     V5 = V5_SI
12935   endif
12937   FF1 = FF1_SI
12938   FF4 = FF4_SI
12939   FF5 = FF5_SI
12940   
12941 ! in case ihucm_flag.NE.1
12943 endif
12945  101 FORMAT(1X,D13.5)
12946  102 FORMAT(1X,2D13.5)
12947  103 FORMAT(1X,3D13.5)
12948  104 FORMAT(1X,4D13.5)
12949  105 FORMAT(1X,5D13.5)
12950  106 FORMAT(1X,6D13.5)
12951  107 FORMAT(1X,7D13.5)
12952  201 FORMAT(1X,I2,D13.5)
12953  202 FORMAT(1X,I2,2D13.5)
12954  203 FORMAT(1X,I2,3D13.5)
12955  204 FORMAT(1X,I2,4D13.5)
12957 END SUBROUTINE
12959 ! end of shedding subroutine
12960 !====================================================================
12961 SUBROUTINE SHED_MELTWATER &
12962 (fnrex,rhoix,RHO_CRITX,XX,FFX,FLIQFR_X,XL_SI,FF1_SI,INK)
12964 implicit double precision (a-h,o-z)
12966 ! new change 27.03.07                                         (start)
12968 !PARAMETER(NKR=33, &
12969 PARAMETER(PI=3.141592654D0, RHO_ICE=920D0, RHO_WATER=1000.D0, &
12971 ! new change 27.03.07                                           (end)
12973 ! new change 27.08.04                                         (start)
12975 IPRINTING=0, & 
12976 !IPRINTING=1, & 
12978 COL=0.23105D0, FMAX_DROP_MASS_FRACTION=0.5D0)
12980 ! new change 27.08.04                                           (end)
12982 ! new change 21.06.04                                         (start)
12984 ! new change 30.10.04                                         (start)
12985 DIMENSION XX(NKR), XL_SI(NKR)
12986 DIMENSION FFX(NKR), FF1_SI(NKR), FLIQFR_X(NKR)
12988 DIMENSION fmass_ice(NKR), fmass_X(NKR)
12990 INTRINSIC DABS, SUM
12992 fm_i = XX(INK)*(1.D0 - FLIQFR_X(INK))
12994 V_i = fm_i/rhoix
12996 fm_w = XX(INK)*FLIQFR_X(INK)
12998 V_w = fm_w/RHO_WATER
13000 if(rhoix < RHO_CRITX) then
13001   V_soakable = V_i - fm_i/RHO_ICE
13002 else
13003   V_soakable = 0.D0
13004 endif
13006 if(V_w > V_soakable) then
13008 ! new change 21.06.04                                         (start)
13010 ! new change 21.06.04                                           (end)
13012   fm_w_soaked = RHO_WATER*V_soakable
13013   fm_w_crit=(0.268D0+(fm_i+fm_w_soaked)*1.D3*0.1389D0)
13014   fm_w_crit = fm_w_crit*1.D-3
13016 ! new change 22.06.04                                         (start)
13018 ! new change 22.06.04                                           (end)
13020   if(fm_w - fm_w_soaked > fm_w_crit) then
13022 ! new change 21.06.04                                         (start)
13024 ! new change 21.06.04                                           (end)
13026     if(fnrex > 1.5D4) then
13027       melting_mode = 2
13028     else
13029       if(fnrex > 1.D4 ) then
13030         melting_mode = 3
13031       else
13032         melting_mode = 4
13033       endif
13034     endif
13036     select case (melting_mode)
13038        case(2)
13039        d_w_shed = 1.5D-3
13041        case(3)
13042        d_w_shed = 3.D-3
13044        case(4)
13045        d_w_shed = 4.5E-3
13047        case default
13049  call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9999")
13051     end select
13053     drop_mass = RHO_WATER*(PI/6.D0)*(d_w_shed**3.D0)
13055     if(drop_mass > fm_w_crit*FMAX_DROP_MASS_FRACTION) &
13056     drop_mass = fm_w_crit*FMAX_DROP_MASS_FRACTION
13058     fm_w_save=fm_w
13060     if(melting_mode == 2) then
13062       if(fnrex > 2.5D4) then
13064 ! all melt-water on sfc is shed
13066         fm_w = fm_w_soaked
13068       else
13070 ! small drops shed continuously
13072         fm_w = fm_w_crit + fm_w_soaked
13074       endif
13076 ! in case melting_mode == 2
13078     else
13080 ! in case melting_mode.ne.2
13082 ! intermittent shedding of up to FMAX_DROP_MASS_FRACTION
13083 ! of exterior meltwater
13085       fm_w =  fm_w - drop_mass
13087 ! in case melting_mode.ne.2
13089     endif
13091     if(fm_w - fm_w_soaked > fm_w_crit) fm_w = fm_w_crit + fm_w_soaked
13093     if(fm_w < fm_w_soaked) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9065")
13095     fm_w_shed = fm_w_save - fm_w
13097     ILIQ = IFIND_IK(drop_mass, XL_SI, frac_liq)
13099     INEW = IFIND_IK(fm_w + fm_i, XX, frac)
13101     if(INEW < INK) then
13103 ! new change 21.06.04                                         (start)
13105 ! new change 21.06.04                                           (end)
13107       fmass_X(:)=FFX(:)*XX(:)*XX(:)*3.D0*COL
13108       fmass_ice(:)=FFX(:)*XX(:)*(1.D0-FLIQFR_X(:))*XX(:)*3.D0*COL
13109       fm_X_before = SUM(fmass_X)
13110       fm_ice_before = SUM(fmass_ice)
13112 ! take mass of water shed out of mass_X(IK) and place
13113 ! in temporary reservoir 1
13115       res_mass_shed =  FFX(INK) * fm_w_shed * XX(INK)*3.D0*COL
13116       fmass_X(INK) = fmass_X(INK) - res_mass_shed
13118       if(fmass_X(INK) < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8020")
13119       if(res_mass_shed < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8021")
13121 ! take all remaining water out of mass_X/mass_ice and place
13122 ! in temporary reservoirs 2 and 3
13124       res_mass_X = fmass_X(INK)
13125       fmass_X(INK) = 0.D0
13126       res_mass_ice = fmass_ice(INK)
13127       fmass_ice(INK) = 0.D0
13129 ! transfer water of reservoir 2 into the two size-bins adjacent
13130 ! to fm_w+m_i
13132       fmass_X(INEW)=fmass_X(INEW )+(1.D0-frac)*res_mass_X
13133       fmass_X(INEW+1)=fmass_X(INEW+1)+frac*res_mass_X
13134       res_mass_X = 0.D0
13136 ! transfer ice of reservoir 3 into the two size-bins adjacent
13137 ! to fm_w+m_i
13139       fmass_ice(INEW)=fmass_ice(INEW)+(1.D0-frac)*res_mass_ice
13140       fmass_ice(INEW+1)=fmass_ice(INEW+1)+frac*res_mass_ice
13141       res_mass_ice=0.D0
13143 ! transfer shed water of reservoir 1 into liquid bins
13145       FF1_SI(ILIQ)=FF1_SI(ILIQ)+ &
13146       res_mass_shed/(XL_SI(ILIQ)*XL_SI(ILIQ)*3.D0*COL)
13148       FFX(INEW)=fmass_X (INEW)/(XX(INEW)*XX(INEW)*3.D0*COL)
13149       FFX(INEW+1)=fmass_X (INEW+1)/(XX(INEW+1)*XX(INEW+1)*3.D0*COL)
13150       FFX(INK)=fmass_X (INK)/(XX(INK)*XX(INK)*3.D0*COL)
13152       if(FFX(INEW) > 0.D0) then
13153       
13154         FLIQFR_X(INEW)= &
13155         1.D0-fmass_ice (INEW)/(XX(INEW)*FFX(INEW)*XX(INEW)*3.D0*COL)
13156         
13157 ! new change 9.12.07                                          (start)
13158         if(DABS(FLIQFR_X(INEW)) < 1.0D-3) FLIQFR_X(INEW)= 0.0D0 
13159 ! new change 9.12.07                                            (end)
13161       else
13163         FLIQFR_X(INEW) = 1.D0
13165       endif
13167       if(FFX(INEW+1) > 0.D0) then
13169         FLIQFR_X(INEW+1)=1.D0 - &
13170                          fmass_ice(INEW+1)/ &
13171                         (XX(INEW+1)*FFX(INEW+1)*XX(INEW+1)*3.D0*COL)
13172 ! new change 9.12.07                                          (start)
13173         if(DABS(FLIQFR_X(INEW+1)) < 1.0D-3) FLIQFR_X(INEW+1)= 0.0D0 
13174 ! new change 9.12.07                                            (end)
13176       else
13178         FLIQFR_X(INEW+1) = 1.D0
13180       endif
13182       if(FFX(INK) > 0.D0) then
13184         FLIQFR_X(INK)=1.D0 - fmass_ice(INK)/ &
13185                             (XX(INK)*FFX(INK)*XX(INK)*3.D0*COL)
13186 ! new change 9.12.07                                          (start)
13187         if(DABS(FLIQFR_X(INK)) < 1.0D-3) FLIQFR_X(INK)= 0.0D0 
13188 ! new change 9.12.07                                            (end)
13190       else
13192         FLIQFR_X(INK) = 1.D0
13194       endif
13196 ! new change 21.06.04                                         (start)
13198 ! new change 21.06.04                                           (end)
13200 ! new change 9.12.07                                          (start)
13202 !      if(FLIQFR_X(INEW) < 0.D0.or.FLIQFR_X(INEW) > 1.D0) stop 8003
13204       if(FLIQFR_X(INEW) < 0.D0.or.FLIQFR_X(INEW) > 1.D0) THEN
13205       
13206       !  PRINT*, 'IJK,KX,KZ,INK,INEW'
13207       !  PRINT*,  IJK,KX,KZ,INK,INEW
13208 !       
13209 !        PRINT*,   'FLIQFR_X(INEW)'
13210 !        PRINT 106, FLIQFR_X(INEW)
13211 !       
13212 !        PRINT*,   'XX(INEW),FFX(INEW),fmass_ice(INEW)'
13213 !        PRINT 106, XX(INEW),FFX(INEW),fmass_ice(INEW)
13214 !       
13215 !       PRINT*, &
13216 !       'STOP 8003: FLIQFR_X(INEW) < 0.D0.or.FLIQFR_X(INEW) > 1.D0'
13217        
13218           call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8003")
13219         
13220       endif
13221         
13222 ! new change 9.12.07                                            (end)
13224       if(FLIQFR_X(INEW+1) < 0.D0.or.FLIQFR_X(INEW+1) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8004")
13225       if(FLIQFR_X(INK) < 0.D0.or.FLIQFR_X(INK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8005")
13227       fmass_X(:)=FFX(:)*XX(:)*XX(:)*3.D0*COL
13228       fmass_ice(:)=FFX(:)*XX(:)*(1.D0-FLIQFR_X(:))*XX(:)*3.D0*COL
13230       fm_X_after = SUM(fmass_X)
13231       fm_ice_after = SUM(fmass_ice)
13233       if(fm_ice_before > 0.D0) then
13235         fjunk = (fm_ice_after/fm_ice_before-1.D0)*100.D0
13237 ! new change 9.12.07                                          (start)
13239 ! new change 21.06.04                                           (end)
13241 !       if(DABS(fjunk) > 1.D0) stop 8011
13243 ! in case fm_ice_before > 0.D0
13245       endif
13247       if(fm_X_before > 0.D0) then
13249         fjunk=((fm_X_after+res_mass_shed)/fm_X_before-1.D0)*100.D0
13251 ! new change 21.06.04                                         (start)
13252 ! new change 21.06.04                                           (end)
13254 !       if(DABS(fjunk) > 1.D0) stop 8012
13256 ! in case fm_X_before > 0.D0
13258       endif
13260 ! new change 21.06.04                                         (start)
13262 ! new change 21.06.04                                           (end)
13264 ! in case INEW < INK
13266     else
13268 ! in case INEW >= INK
13270 ! new change 21.06.04                                          (start)
13272    !   print*, & 
13274  !'STOP: drop_mass is too large compared to total mass of particle'
13276  !     print*,   'INEW >= INK'
13278  !     print*,   'INEW,INK'
13279  !     print*,    INEW,INK 
13281  !     print*,   'drop_mass,fm_i+fm_w' 
13282  !     print 106, drop_mass,fm_i+fm_w
13284        call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9089")
13285       
13286 ! new change 21.06.04                                            (end)
13288 ! in case INEW >= INK
13290     endif
13292 ! in case fm_w - fm_w_soaked > fm_w_crit
13294   endif
13296 ! in case V_w > V_soakable
13298 endif
13300 ! new change 21.06.04                                          (start)
13302 106 FORMAT(1X,6D13.5)
13304 ! new change 21.06.04                                            (end)
13306 END SUBROUTINE
13308 ! end of shed_meltwater subroutine
13309 !====================================================================
13310 ! from module_mp_morr_two_moment.F
13311       subroutine refl10cm_hm (qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, &
13312                       t1d, p1d, dBZ, kts, kte, ii, jj)
13314       IMPLICIT NONE
13316 !..Sub arguments
13317       INTEGER, INTENT(IN):: kts, kte, ii, jj
13318       REAL, DIMENSION(kts:kte), INTENT(IN)::                            &
13319                       qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
13320       REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ
13322 !..Local variables
13323       REAL, DIMENSION(kts:kte):: temp, pres, qv, rho
13324       REAL, DIMENSION(kts:kte):: rr, nr, rs, ns, rg, ng
13326       DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, ilams
13327       DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_g, N0_s
13328       DOUBLE PRECISION:: lamr, lamg, lams
13329       LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg
13331       REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel
13332       DOUBLE PRECISION:: fmelt_s, fmelt_g
13333       DOUBLE PRECISION:: cback, x, eta, f_d
13335       INTEGER:: i, k, k_0, kbot, n
13336       LOGICAL:: melti
13338 !+---+
13340       do k = kts, kte
13341          dBZ(k) = -35.0
13342       enddo
13344 !+---+-----------------------------------------------------------------+
13345 !..Put column of data into local arrays.
13346 !+---+-----------------------------------------------------------------+
13347       do k = kts, kte
13348          temp(k) = t1d(k)
13349          qv(k) = MAX(1.E-10, qv1d(k))
13350          pres(k) = p1d(k)
13351          rho(k) = 0.622*pres(k)/(R_MORR*temp(k)*(qv(k)+0.622))
13353          if (qr1d(k) .gt. 1.E-9) then
13354             rr(k) = qr1d(k)*rho(k)
13355             nr(k) = nr1d(k)*rho(k)
13356             lamr = (xam_r*xcrg(3)*xorg2*nr(k)/rr(k))**xobmr
13357             ilamr(k) = 1./lamr
13358             N0_r(k) = nr(k)*xorg2*lamr**xcre(2)
13359             L_qr(k) = .true.
13360          else
13361             rr(k) = 1.E-12
13362             nr(k) = 1.E-12
13363             L_qr(k) = .false.
13364          endif
13366          if (qs1d(k) .gt. 1.E-9) then
13367             rs(k) = qs1d(k)*rho(k)
13368             ns(k) = ns1d(k)*rho(k)
13369             lams = (xam_s*xcsg(3)*xosg2*ns(k)/rs(k))**xobms
13370             ilams(k) = 1./lams
13371             N0_s(k) = ns(k)*xosg2*lams**xcse(2)
13372             L_qs(k) = .true.
13373          else
13374             rs(k) = 1.E-12
13375             ns(k) = 1.E-12
13376             L_qs(k) = .false.
13377          endif
13379          if (qg1d(k) .gt. 1.E-9) then
13380             rg(k) = qg1d(k)*rho(k)
13381             ng(k) = ng1d(k)*rho(k)
13382             lamg = (xam_g*xcgg(3)*xogg2*ng(k)/rg(k))**xobmg
13383             ilamg(k) = 1./lamg
13384             N0_g(k) = ng(k)*xogg2*lamg**xcge(2)
13385             L_qg(k) = .true.
13386          else
13387             rg(k) = 1.E-12
13388             ng(k) = 1.E-12
13389             L_qg(k) = .false.
13390          endif
13391       enddo
13393 !+---+-----------------------------------------------------------------+
13394 !..Locate K-level of start of melting (k_0 is level above).
13395 !+---+-----------------------------------------------------------------+
13396       melti = .false.
13397       k_0 = kts
13398       do k = kte-1, kts, -1
13399          if ( (temp(k).gt.273.15) .and. L_qr(k)                         &
13400                                   .and. (L_qs(k+1).or.L_qg(k+1)) ) then
13401             k_0 = MAX(k+1, k_0)
13402             melti=.true.
13403             goto 195
13404          endif
13405       enddo
13406  195  continue
13408 !+---+-----------------------------------------------------------------+
13409 !..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps)
13410 !.. and non-water-coated snow and graupel when below freezing are
13411 !.. simple. Integrations of m(D)*m(D)*N(D)*dD.
13412 !+---+-----------------------------------------------------------------+
13414       do k = kts, kte
13415          ze_rain(k) = 1.e-22
13416          ze_snow(k) = 1.e-22
13417          ze_graupel(k) = 1.e-22
13418          if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4)
13419          if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI_MORR)*(6.0/PI_MORR)     &
13420                                  * (xam_s/900.0)*(xam_s/900.0)          &
13421                                  * N0_s(k)*xcsg(4)*ilams(k)**xcse(4)
13422          if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI_MORR)*(6.0/PI_MORR)  &
13423                                     * (xam_g/900.0)*(xam_g/900.0)       &
13424                                     * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4)
13425       enddo
13427 !+---+-----------------------------------------------------------------+
13428 !..Special case of melting ice (snow/graupel) particles.  Assume the
13429 !.. ice is surrounded by the liquid water.  Fraction of meltwater is
13430 !.. extremely simple based on amount found above the melting level.
13431 !.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting
13432 !.. routines).
13433 !+---+-----------------------------------------------------------------+
13435       if (melti .and. k_0.ge.kts+1) then
13436        do k = k_0-1, kts, -1
13438 !..Reflectivity contributed by melting snow
13439           if (L_qs(k) .and. L_qs(k_0) ) then
13440            fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0))
13441            eta = 0.d0
13442            lams = 1./ilams(k)
13443            do n = 1, nrbins
13444               x = xam_s * xxDs(n)**xbm_s
13445               call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), &
13446                     fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, &
13447                     CBACK, mixingrulestring_s, matrixstring_s,          &
13448                     inclusionstring_s, hoststring_s,                    &
13449                     hostmatrixstring_s, hostinclusionstring_s)
13450               f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n))
13451               eta = eta + f_d * CBACK * simpson(n) * xdts(n)
13452            enddo
13453            ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
13454           endif
13457 !..Reflectivity contributed by melting graupel
13459           if (L_qg(k) .and. L_qg(k_0) ) then
13460            fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0))
13461            eta = 0.d0
13462            lamg = 1./ilamg(k)
13463            do n = 1, nrbins
13464               x = xam_g * xxDg(n)**xbm_g
13465               call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), &
13466                     fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, &
13467                     CBACK, mixingrulestring_g, matrixstring_g,          &
13468                     inclusionstring_g, hoststring_g,                    &
13469                     hostmatrixstring_g, hostinclusionstring_g)
13470               f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n))
13471               eta = eta + f_d * CBACK * simpson(n) * xdtg(n)
13472            enddo
13473            ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
13474           endif
13476        enddo
13477       endif
13479       do k = kte, kts, -1
13480          dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18)
13481       enddo
13484       end subroutine refl10cm_hm
13486       END MODULE module_mp_full_sbm