phys/module_mp_full_sbm.F

   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)
  10
  11 !
  12 MODULE module_mp_full_sbm
  13 USE module_mp_radar
  14 !
  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
  44
  45
  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
  65
  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
  98
  99
 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)
 111 !
 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)
 136
 137
 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) &
 147
 148      &,cwil_1(nkr,nkr),cwil_2(nkr,nkr),cwil_3(nkr,nkr) &
 149
 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) &
 153
 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) &
 157
 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) &
 164
 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)
 173
 174       DOUBLE PRECISION,private, save :: &
 175      &   BRKWEIGHT(JBREAK),PKIJ(JBREAK,JBREAK,JBREAK), &
 176      &   QKJ(JBREAK,JBREAK),ECOALMASSM(NKR,NKR)
 177
 178
 179
 180
 181
 182 !
 183 !
 184       CONTAINS
 185
 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
 214
 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
 219
 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
 274
 275
 276
 277       REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN)   :: XLAND
 278       LOGICAL, OPTIONAL, INTENT(IN) :: diagflag
 279       INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref
 280
 281       REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT)::       &  ! GT
 282                           refl_10cm
 283
 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
 295 !
 296
 297 !-----------------------------------------------------------------------
 298 !     LOCAL VARS
 299 !-----------------------------------------------------------------------
 300
 301 !     NSTATS,QMAX,QTOT are diagnostic vars
 302
 303       INTEGER,DIMENSION(ITLO:ITHI,4) :: NSTATS
 304 !     REAL,   DIMENSION(ITLO:ITHI,5) :: QMAX
 305       REAL,   DIMENSION(ITLO:ITHI,22):: QTOT
 306
 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
 310
 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.
 314
 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
 320
 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 /
 328
 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)
 373
 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
 400
 401        real nzero,son,nzero_less
 402        parameter (son=2.E7)
 403        real raddumb(nkr),massdumb(nkr)
 404        real hydrosum
 405
 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/
 421 !
 422 !
 423 ! GUY'S Variables
 424        real geo_cs
 425        integer t_print
 426        t_print=print_int/dt
 427
 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)
 451
 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
 468
 469 !
 470       DEL_BB=BB2_MY-BB1_MY
 471       DEL_BBN=BB2_MYN-BB1_MYN
 472       DEL_BBR=BB1_MYN/DEL_BBN
 473 !
 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
 533
 534       call kernals(dt)
 535
 536       DXHUCM=100.*DX
 537       DYHUCM=100.*DY
 538 !     print*,'dxhucm = ',dxhucm
 539 !     print*,'dyhucm = ',dyhucm
 540 !-----------------------------------------------------------------------
 541 !**********************************************************************
 542 !-----------------------------------------------------------------------
 543 !
 544 !
 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
 594
 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
 651
 652
 653
 654
 655 !1         172           1           1
 656
 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
 672
 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
 764 !
 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
 784
 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
 826
 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
 841
 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
 849
 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)
 951
 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
 967
 968              CONCDROP=0.D0
 969
 970              DO KR=1,NKR
 971                CONCDROP=CONCDROP+FF1IN(KR)*XL(KR)
 972              ENDDO
 973
 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
 994
 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
1128
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)
1139
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
1170
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
1186
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
1208
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
1224
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
1245
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
1271
1272 901      format(' ',i3,1x,f12.9,1x,3(f12.9,1x),f12.6,f12.3,1x,10(f12.8,1x))
1273
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
1293
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
1318
1319
1320
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
1341
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
1366
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
1379
1380         END IF
1381       END DO
1382       END DO
1383       END DO
1384
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
1523
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
1671
1672
1673
1674
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
1799
1800
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
1812
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)
1824
1825       END DO
1826       END DO
1827
1828
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)
1925
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
1966
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
2001
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/
2022
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
2037
2038 !      KZ_MIN=16
2039 !      KZ_MAX=21
2040
2041
2042
2043         call wrf_message(" FULL SBM: INITIALIZING HUCM ")
2044         call wrf_message(" FULL SBM: ****** HUCM ******* ")
2045 !        PRINT*, 'INITIALIZING HUCM'
2046 !       print *, ' ****** HUCM *******'
2047
2048 ! INPUT :
2049         dlnr=dlog(2.d0)/(3.d0*scal)
2050 !     print*,'here in hucmint 1'
2051 !
2052 !--- Read in various lookup tables
2053 !
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
2066 !
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
2070 !
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
2074 !
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)
2080
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
2103 !
2104         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2105 !
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
2109 !
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
2135 !
2136         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2137 !
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
2141 !
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
2171
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
2184 !
2185         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2186 !
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
2190 !
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
2218 !
2219         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2220 !
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
2224 !
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
2246 !
2247         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2248 !
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
2252 !
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
2302 !
2303         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2304 !
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
2308 !
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
2334 !
2335         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2336 !
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
2340 !
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 ")
2350
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'
2373
2374
2375         DEG01=1./3.
2376
2377 !------------------------------------------------------------------
2378
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
2411
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)
2424
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)))
2461
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
2499
2500 ! IN CASE : IPRINT01.NE.0
2501
2502
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
2534
2535
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.
2542
2543
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.
2553
2554          call radar_init
2555 !+---+-----------------------------------------------------------------+
2556
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
2572 !
2573 !     GT    : MASS DISTRIBUTION FUNCTION
2574 !     XT_MG : MASS OF BIN IN MG
2575 !     JMAX  : NUMBER OF BINS
2576
2577
2578 !.....LOCAL VARIABLES
2579
2580       INTEGER AP,IE,JE,KE
2581
2582       PARAMETER (AP = 1)
2583
2584       INTEGER I,J,K,JDIFF
2585       REAL  RPKIJ(JBREAK,JBREAK,JBREAK),RQKJ(JBREAK,JBREAK)
2586
2587
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)
2593
2594
2595 !.....DECLARATIONS FOR INIT
2596
2597       INTEGER IP,KP,JP,KQ,JQ
2598       REAL XTJ
2599
2600       CHARACTER*20 FILENAME_P,FILENAME_Q
2601
2602       FILENAME_P = 'coeff_p.asc'
2603       FILENAME_Q = 'coeff_q.asc'
2604
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
2611
2612 !.....IN CGS
2613
2614
2615 !.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID
2616
2617       JDIFF = JMAX - JBREAK
2618
2619 !.....INITIALIZATION
2620
2621 !     IF (FIRSTCALL.NE.1) THEN
2622
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
2636
2637 !........OUTPUT
2638
2639          WRITE (*,*) 'COLL_BREAKUP_INI: COAGULATION AND BREAKUP GRID'
2640          WRITE (*,'(2A5,5A15)') 'ICOAG','IBREAK', &
2641      &        'XCOAG','DCOAG', &
2642      &        'XBREAK','DBREAK','MWEIGHT'
2643
2644 !........READ DER BREAKUP COEFFICIENTS FROM INPUT FILE
2645
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
2659 !
2660         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2661 !
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
2665 !
2666         IF ( wrf_dm_on_monitor() ) THEN
2667           OPEN(UNIT=hujisbm_unit1,FILE="coeff_p.asc",                  &
2668      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2669
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
2704 !
2705         CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
2706 !
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
2710 !
2711         IF ( wrf_dm_on_monitor() ) THEN
2712           OPEN(UNIT=hujisbm_unit1,FILE="coeff_q.asc",                  &
2713      &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
2714
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)
2724
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
2747
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
2760
2761       REAL FUNCTION ECOALMASS(ETA,KSI)
2762       IMPLICIT NONE
2763 !     REAL ECOALMASS
2764       REAL PI
2765       PARAMETER (PI = 3.1415927)
2766
2767       REAL ETA,KSI
2768       REAL KPI,RHO
2769       REAL DETA,DKSI
2770
2771       PARAMETER (RHO  = 1.0)
2772
2773 !     REAL ECOALDIAM
2774 !     EXTERNAL ECOALDIAM
2775
2776       KPI = 6./PI
2777
2778       DETA = (KPI*ETA/RHO)**(1./3.)
2779       DKSI = (KPI*KSI/RHO)**(1./3.)
2780
2781       ECOALMASS = ECOALDIAM(DETA,DKSI)
2782
2783       RETURN
2784       END FUNCTION ECOALMASS
2785
2786
2787 !------------------------------------------------
2788 !     COALESCENCE EFFICIENCY AS FUNC OF DIAMETERS
2789 !------------------------------------------------
2790
2791       REAL FUNCTION ECOALDIAM(DETA,DKSI)
2792 !     IMPLICIT NONE
2793
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
2798
2799       PARAMETER (ZERO = 0.0)
2800       PARAMETER (ONE  = 1.0)
2801       PARAMETER (EPS  = 1.0E-30)
2802       PARAMETER (PI   = 3.1415927)
2803
2804 !     REAL   ECOALLOWLIST,ECOALOCHS
2805 !     EXTERNAL ECOALLOWLIST,ECOALOCHS
2806
2807       DGR = MAX(DETA,DKSI)
2808       DKL = MIN(DETA,DKSI)
2809
2810       RGR = 0.5*DGR
2811       RKL = 0.5*DKL
2812
2813       P = (RKL / RGR)
2814       Q = (RKL * RGR)**0.5
2815       Q = 0.5 * (RKL + RGR)
2816
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
2830
2831       ECOALDIAM  = MAX(MIN(ONE,E),EPS)
2832
2833       RETURN
2834       END FUNCTION  ECOALDIAM
2835
2836 !--------------------------------------------------
2837 !     COALESCENCE EFFICIENCY (LOW&LIST)
2838 !--------------------------------------------------
2839
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
2847
2848       PARAMETER (EPSI=1.E-20)
2849
2850       PI = 3.1415927
2851       SIGMA = 72.8
2852       KA = 0.778
2853       KB = 2.61E-4
2854
2855       RGR = 0.5*DGR
2856       RKL = 0.5*DKL
2857
2858       CALL COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC)
2859
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
2870
2871       ECOALLOWLIST = ECL
2872
2873       RETURN
2874       END FUNCTION ECOALLOWLIST
2875
2876 !--------------------------------------------------
2877 !     COALESCENCE EFFICIENCY (BEARD AND OCHS)
2878 !--------------------------------------------------
2879
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
2887
2888 !     EXTERNAL VTBEARD
2889       PARAMETER (EPSF  = 1.E-30)
2890       PARAMETER (FPMIN = 1.E-30)
2891
2892       PI = 3.1415927
2893       SIGMA = 72.8
2894
2895       R_S = 0.5 * D_S
2896       R_L = 0.5 * D_L
2897       P   = R_S / R_L
2898
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
2905
2906       ECOALOCHS = E
2907
2908       RETURN
2909       END FUNCTION ECOALOCHS
2910
2911 !-----------------------------------------
2912 !     CALCULATING THE COLLISION ENERGY
2913 !-----------------------------------------
2914
2915       SUBROUTINE COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC)
2916 !     IMPLICIT NONE
2917
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
2925
2926 !     EXTERNAL VTBEARD
2927       PARAMETER (EPSF  = 1.E-30)
2928       PARAMETER (FPMIN = 1.E-30)
2929
2930       PI    = 3.1415927
2931       RHO   = 1.0
2932       SIGMA = 72.8
2933
2934       K10=RHO*PI/12.0D0
2935
2936       DGR = MAX(DGR,EPSF)
2937       DKL = MAX(DKL,EPSF)
2938
2939       DGKA2=(DGR**2)+(DKL**2)
2940
2941       DGKA3=(DGR**3)+(DKL**3)
2942
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.)
2957
2958       W1=CKE/(SC+EPSF)
2959       W2=CKE/(ST+EPSF)
2960
2961       DC=DGKA3**(1./3.)
2962
2963       RETURN
2964       END SUBROUTINE COLLENERGY
2965
2966 !--------------------------------------------------
2967 !     CALCULATING TERMINAL VELOCITY (BEARD-FORMULA)
2968 !--------------------------------------------------
2969
2970       REAL FUNCTION VTBEARD(DIAM)
2971       IMPLICIT NONE
2972 !     REAL VTBEARD
2973
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
2979
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/
2983
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)
2997
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
3017
3018       VTBEARD = VT
3019
3020       RETURN
3021       END FUNCTION VTBEARD
3022
3023
3024
3025 !--------------------------------------------------
3026 !     Function f. Coalescence-Efficiency
3027 !     Eq. (7) of Beard and Ochs (1995)
3028 !--------------------------------------------------
3029
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)
3040
3041       INTEGER its
3042       COMPLEX acoeff(4),x
3043
3044       R_s = 0.5 * D_s
3045       R_l = 0.5 * D_l
3046
3047       rcoeff = 5.07 - log(R_s*1e4) - log(R_l*1e4/200.0)
3048
3049       acoeff(1) = CMPLX(rcoeff)
3050       acoeff(2) = CMPLX(-5.94)
3051       acoeff(3) = CMPLX(+7.27)
3052       acoeff(4) = CMPLX(-5.29)
3053
3054       x = (0.50,0)
3055
3056       CALL LAGUER(acoeff,3,x,its)
3057
3058       EcoalBeard = REAL(x)
3059
3060       RETURN
3061       END FUNCTION ecoalBeard
3062
3063 !--------------------------------------------------
3064
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
3118
3119
3120
3121
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) :
3129
3130
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)
3156
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
3168
3169
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)
3194
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)
3198
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)
3214
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)
3231
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)
3236
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)
3244
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)
3248
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)
3252
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)
3256
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)
3260
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)
3264
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
3270
3271                CWII_1_1(I,J)=0.D0
3272                CWII_1_2(I,J)=0.D0
3273                CWII_1_3(I,J)=0.D0
3274
3275                CWII_2_1(I,J)=0.D0
3276                CWII_2_2(I,J)=0.D0
3277                CWII_2_3(I,J)=0.D0
3278
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)
3287
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)
3291
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
3328
3329 88     CONTINUE
3330         RETURN
3331         END SUBROUTINE KERNALS
3332
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)
3357
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)
3361
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)
3377
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)
3394
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)
3399
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)
3407
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)
3411
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)
3415
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)
3419
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)
3423
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)
3427
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
3433
3434 !              CWII_1_1(I,J)=0.D0
3435 !              CWII_1_2(I,J)=0.D0
3436 !              CWII_1_3(I,J)=0.D0
3437
3438 !              CWII_2_1(I,J)=0.D0
3439 !              CWII_2_2(I,J)=0.D0
3440 !              CWII_2_3(I,J)=0.D0
3441
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)
3450
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)
3454
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
3491
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
3522
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
3531
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
3540
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
3549
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
3558
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
3567
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
3576
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
3681
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
3741
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
3756
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
3771
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
3786
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
3801
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
3816
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
3831
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
3846
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
3861
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
3876
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
3909
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
3926
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
3943
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
4011
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
4028
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
4062
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
4079
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
4096
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
4113
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
4130
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
4147
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)
4221
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)
4227
4228
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
4263
4264
4265
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
4276
4277
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)
4281
4282
4283
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)
4301 !
4302 !******************************* FREEZING ****************************
4303 !
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)
4308 !
4309 !***************************** MASS LOOP **************************
4310 !
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
4326 !
4327 !************************ END OF "MASS LOOP" **************************
4328 !
4329          ENDDO
4330 !
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
4336 !
4337 !************************** END OF "FREEZING" ****************************
4338 !
4339         ENDIF
4340 !
4341         RETURN
4342         END SUBROUTINE FREEZ
4343
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)
4356
4357
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)
4414
4415
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
4497
4498                    FF1(KR)=FF1(KR)+ARG_M
4499
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
4508
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
4519 !
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)
4525 !
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
4534 !
4535
4536 !********************************************************************
4537
4538 ! NEW MEYERS IN JERNUCL01 SUBROUTINE
4539
4540
4541
4542 !********************************************************************
4543
4544
4545
4546       REAL PSI1(NKR),X1(NKR),DROPCONCN(NKR) &
4547      &     ,PSI2(NKR,ICEMAX),X2(NKR,ICEMAX)
4548
4549
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
4555
4556
4557       TT=DTT
4558       QQ=DQQ
4559 ! DROPLETS NUCLEATION (BEGIN)
4560
4561         TPN=TT
4562         QPN=QQ
4563
4564         DEL1N=100.*SUP1
4565         TPC=TT-273.15
4566
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)
4574
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
4578
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
4589
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
4600
4601
4602       CALL NUCLEATION (SUP1,TT,FCCNR,DROPCONCN  &
4603      &,NDROPMAX,COL,RCCN,DROPRADII,NKR,ICEMAX)
4604
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
4612
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)
4625
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
4632
4633         C1=C1_MEY
4634         C2=C2_MEY
4635 ! TYPE OF ICE WITH NUCLEATION (BEGIN)
4636
4637         TPC=TT-273.15
4638         ITYPE=0
4639
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
4650
4651
4652
4653 ! NEW CRYSTAL SIZE DISTRIBUTION FUNCTION                      (BEGIN)
4654
4655         ICE=ITYPE
4656
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
4666
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
4674
4675         FF1BN=HELEK1+HELEK2
4676
4677         FACT=1.
4678         DSUP2N=(SUP2-SUP2_OLD+DSUPICEXZ)*100.
4679
4680         SUP2_OLD=SUP2
4681
4682         IF(DSUP2N.GT.50.) DSUP2N=50.
4683
4684         DELTACD=FF1BN*B1*DSUP2N
4685
4686         IF(DELTACD.GE.FF1BN) DELTACD=FF1BN
4687
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
4708
4709
4710
4711
4712
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
4716
4717 ! determination of new size spectra due to drop nucleation
4718
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
4727
4728
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
4733
4734
4735
4736         DEG01=1./3.
4737
4738
4739 ! calculation initial value of NDROPMAX - maximal number of drop bin
4740 ! which is activated
4741
4742 ! initial value of NDROPMAX
4743
4744         NDROPMAX=0
4745
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
4754
4755
4756 ! CCNCONC_BFNUCL - concentration of aerosol particles before
4757 !                  nucleation
4758
4759         CCNCONC_BFNUCL=0.
4760         DO I=1,NKR
4761            CCNCONC_BFNUCL=CCNCONC_BFNUCL+FCCNR(I)
4762         ENDDO
4763
4764         CCNCONC_BFNUCL=CCNCONC_BFNUCL*COL
4765
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
4773
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
4786
4787
4788 ! calculation CCNCONC_AFNUCL - ccn concentration after nucleation
4789
4790 !       CCNCONC_AFNUCL=0.
4791
4792 !       DO I=IMIN,IMAX
4793 !          CCNCONC_AFNUCL=CCNCONC_AFNUCL+FCCNR(I)
4794 !       ENDDO
4795
4796 !       CCNCONC_AFNUCL=CCNCONC_AFNUCL*COL
4797
4798 ! calculation DEL_CCNCONC
4799
4800 !       DEL_CCNCONC=CCNCONC_BFNUCL-CCNCONC_AFNUCL
4801         CALL ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT,RACTMAX,NKR)
4802
4803
4804
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
4809
4810         INEXT=ISMALL
4811 !       ISMALL=1
4812
4813 !       INEXT=ISMALL
4814
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
4825
4826 !999    CONTINUE
4827
4828
4829         RETURN
4830         END SUBROUTINE NUCLEATION
4831
4832
4833
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)
4839
4840         IMIN=0
4841
4842         DO I=1,NKR
4843            IF(FCCNR(I).NE.0.) THEN
4844              IMIN=I
4845              GOTO 40
4846            ENDIF
4847         ENDDO
4848
4849  40     CONTINUE
4850
4851 ! IMAX - right CCN spectrum boundary
4852
4853         IMAX=0
4854
4855         DO I=NKR,1,-1
4856            IF(FCCNR(I).NE.0.) THEN
4857              IMAX=I
4858              GOTO 41
4859            ENDIF
4860         ENDDO
4861
4862  41     CONTINUE
4863         RETURN
4864         END  SUBROUTINE BOUNDARY
4865
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)
4872
4873
4874
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
4881
4882 ! table of critical aerosol radii
4883
4884 !       GOTO 992
4885
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
4893
4894 ! RCRITI, cm - critical radius of "dry" aerosol
4895
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)
4920
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
4986
4987
4988
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
5014
5015          ENDDO
5016 ! cycle by I, I=IMIN,...,IMAX-1
5017
5018   42    CONTINUE
5019         RETURN
5020         END  SUBROUTINE CCNLOOP
5021        SUBROUTINE ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT,RACTMAX,NKR)
5022        IMPLICIT NONE
5023
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
5031
5032 ! critical water supersaturations appropriating CCN radii
5033
5034            XKOE=(4./27.)*(AKOE**3/BKOE)
5035            AKOE23=AKOE*2./3.
5036            R03=RCCN(I)**3
5037            SUPCRITI=SQRT(XKOE/R03)
5038
5039 ! RACT(I) - radii of activated drops, I=IMIN,...,IMAX
5040
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
5047
5048 ! calculation of I0
5049
5050         I0=IMIN
5051
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
5058
5059  45     CONTINUE
5060 ! new changes 9.04.02                                         (begin)
5061         I1=I0-1
5062 ! new changes 9.04.02                                           (end)
5063
5064         IF(I0.EQ.IMIN) GOTO 47
5065
5066 ! new changes 9.04.02                                         (begin)
5067
5068         IF(I0.EQ.IMAX) THEN
5069           RACT(IMAX)=RACT(IMAX-1)
5070           GOTO 47
5071         ENDIF
5072
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
5079
5080 ! new changes 9.04.02                                           (end)
5081
5082
5083
5084 ! calculation of I1
5085
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
5093
5094 ! spectrum of activated drops                                   (end)
5095
5096
5097 ! line interpolation RACT(I) for I=I0,...,I1
5098
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
5103
5104
5105   47    CONTINUE
5106
5107
5108
5109         RACTMAX=0.
5110
5111         DO I=IMIN,IMAX
5112            RACTMAX=AMAX1(RACTMAX,RACT(I))
5113         ENDDO
5114         RETURN
5115
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
5123
5124         NDROPMAX=1
5125
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
5135
5136
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)
5145
5146        IMPLICIT NONE
5147
5148
5149       INTEGER NKR,ICEMAX
5150       REAL    COL,VR1(NKR),PSINGLE &
5151      &       ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
5152      &       ,DTCOND
5153
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
5174
5175        INTEGER K
5176 ! NEW ALGORITHM OF CONDENSATION (12.01.00)
5177
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
5189
5190        DOUBLE PRECISION DELMASSL1
5191
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)
5198
5199 ! WORK ARRAYS
5200
5201 ! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION
5202
5203
5204         REAL DTIMEO(NKR),DTIMEL(NKR) &
5205      &           ,TIMESTEPD(NKR)
5206
5207 ! NEW ALGORITHM (NO TYPE OF ICE)
5208
5209
5210
5211         OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
5212         OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
5213
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/
5219
5220         DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
5221      &      /2.53,5.42,3.41E1,6.13/
5222
5223         DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
5224      &      /-4.0,-8.1,-12.7,-17.8,-22.4/
5225
5226
5227         DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/
5228
5229         DATA DT0L, DT0I /1.E20,1.E20/
5230
5231 ! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
5232
5233
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
5247
5248         NR=NKR
5249         NRM=NKR-1
5250         DT=DTCOND
5251         DTT=DTCOND
5252         XRAD=0.
5253
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
5261
5262 ! INITIALIZATION OF SOME ARRAYS
5263 !       print*, 'got to here 0'
5264
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)
5301
5302 ! INTEGRALS IN DELTA EQUATION (ONLY WATER)
5303
5304 ! CONTROL OF DROP SPECRUM IN SUBROUTINE ONECOND
5305
5306
5307 ! CALL JERTIMESC WATER - 1 (ONLY WATER)
5308
5309               CALL JERTIMESC(FI1,R1,SFN11,SFN12 &
5310      &                      ,B11_MY,B12_MY,RLEC,B8L,1,COL,NKR)
5311
5312
5313               SFNL=SFN11+SFN12
5314               SFNI=0.
5315
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
5329
5330 ! SOLVING FOR TIMEZERO
5331
5332
5333
5334               KCOND=10
5335
5336               IF(DEL1.GT.0) KCOND=11
5337
5338 ! PROCESS'S TYPE
5339
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
5353
5354 ! NEW TIME STEP (ONLY WATER: CONDENSATION)
5355
5356
5357                 IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
5358      &          DTNEWL=DT-TIMENEW
5359                 IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
5360
5361                 TIMESTEPD(ITIME)=DTNEWL
5362
5363                 TIMENEW=TIMENEW+DTNEWL
5364
5365                 DTT=DTNEWL
5366
5367 ! SOLVING FOR SUPERSATURATION
5368
5369 ! CALL JERSUPSAT - 2 (NEW TIMESTEP - ONLY WATER)
5370
5371
5372                 CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
5373      &                        ,RW,PW,RI,PI,QW,QI &
5374      &                        ,DTT,D1N,D2N,DT0L,DT0I)
5375
5376 ! END OF "NEW SUPERSATURATION"
5377
5378 ! DROPLETS
5379
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)
5386
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
5391
5392 ! IN CASE : KCOND.EQ.11
5393
5394               ELSE
5395
5396 ! EVAPORATION - ONLY WATER
5397
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))
5406
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
5413
5414                 KLIMIT=1
5415
5416                 DO KR=1,NKR
5417                    IF(DTIMEO(KR).GT.TIMEREV) GOTO 55
5418                    KLIMIT=KR
5419                 ENDDO
5420
5421    55           KLIMIT=KLIMIT-1
5422
5423                 IF(KLIMIT.LT.1) KLIMIT=1
5424
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
5433
5434                 TIMESTEPD(ITIME)=DTNEWL
5435
5436 ! NEW TIME STEP (ONLY_WATER: EVAPORATION)
5437
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
5442
5443                 TIMESTEPD(ITIME)=DTNEWL
5444
5445                 TIMENEW=TIMENEW+DTNEWL
5446
5447                 DTT=DTNEWL
5448
5449 ! SOLVING FOR SUPERSATURATION
5450
5451
5452 ! CALL JERSUPSAT - 3 (ONLY_WATER: EVAPORATION)
5453
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"
5458
5459
5460 ! DROPLETS
5461
5462
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)
5470
5471 ! IN CASE : ISYML.NE.0 (ENDING OF
5472 ! "DROPLET DISTRIBUTION FUNCTION" (ONLY WATER: EVAPORATION)
5473
5474 !        ENDIF
5475
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
5480
5481 ! END OF "PROCESS'S TYPE"
5482
5483 ! IN CASE : KCOND.NE.11 (ONLY WATER: EVAPORATION)
5484
5485               ENDIF
5486
5487 ! IN CASES : KCOND.EQ.11 OR KCOND.NE.11 (BOTH CONDENSATION AND
5488 ! EVAPORATION : ONLY WATER)
5489
5490 ! CONCENTRATION & MASS (ONLY WATER)
5491
5492       RMASSLBB=0.
5493       RMASSLAA=0.
5494
5495 ! BEFORE JERNEWF (ONLY WATER)
5496
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
5608
5609
5610
5611
5612        RETURN
5613 !      END
5614
5615   END SUBROUTINE ONECOND1
5616 !==================================================================
5617
5618
5619
5620 !BARRY
5621         SUBROUTINE JERDFUN(R2,B21_MY,B22_MY &
5622      &                    ,FI2,PSI2,DEL2N &
5623      &                    ,IND,ITYPE,COL,NKR,TPN)
5624        IMPLICIT NONE
5625
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
5644
5645         IF(IND.NE.1) THEN
5646           ITYP=ITYPE
5647         ELSE
5648           ITYP=1
5649         ENDIF
5650
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
5658 !
5659 !Q2=0.
5660         NR=NKR
5661         NRM=NKR-1
5662
5663 ! NEW DISTRIBUTION FUNCTION
5664
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
5676
5677                   ENDDO
5678                 ENDIF
5679     8     CONTINUE
5680 ! CRYSTAL DISTRIBUTION FUNCTION
5681
5682           DO ICE=1,IND
5683
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)
5700
5701
5702
5703 !              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
5704                DO KR=1,NKR
5705                   PSI2(KR,ICE)=PSI2R(KR)
5706                ENDDO
5707
5708
5709 ! END OF "ICE_TYPE"
5710
5711              ENDIF
5712
5713 ! END OF "CRYSTAL DISTRIBUTION FUNCTION"
5714
5715           ENDDO
5716
5717 ! END OF "NEW DISTRIBUTION FUNCTION"
5718
5719
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
5727
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
5745
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
5752 !
5753 !Q2=0.
5754         NR=NKR
5755         NRM=NKR-1
5756
5757 ! NEW DISTRIBUTION FUNCTION
5758
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)
5780
5781
5782 !              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
5783                DO KR=1,NKR
5784                   PSI2(KR,ICE)=PSI2R(KR)
5785                ENDDO
5786
5787 ! END OF "ICE_TYPE"
5788
5789              ENDIF
5790
5791 ! END OF "CRYSTAL DISTRIBUTION FUNCTION"
5792
5793           ENDDO
5794
5795 ! END OF "NEW DISTRIBUTION FUNCTION"
5796
5797
5798         RETURN
5799         END SUBROUTINE JERDFUN_NEW
5800 ! SUBROUTINE JERDFUN_NEW (NEW ALGORITHM OF CONDENSATION, 12.01.00)
5801
5802 ! new change 30.01.06                                         (start)
5803 !       SUBROUTINE JERNEWF(NRX,NRM,RR,FI,PSI,RN,COL,NKR)
5804
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)
5810
5811         IMPLICIT NONE
5812
5813 ! Andrei's new change 1.12.09                                 (start)
5814
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)
5826
5827         INTEGER  &
5828         I,K,KM,NRXP,IM,IP,IFIN,IIN,ISYM,NKR
5829
5830         REAL &
5831         COL
5832
5833         DOUBLE PRECISION &
5834         AOLDCON,ANEWCON,AOLDMASS,ANEWMASS
5835
5836         DOUBLE PRECISION &
5837         RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, &
5838         GN1,GN1P,GN2,GN3,GMAT2
5839
5840         DOUBLE PRECISION &
5841         DRP,FNEW,FIK,PSINEW,DRM,GMAT,R1,R2,R3,DMASS,CONCL,RRI,RNK
5842
5843         INTEGER NRM
5844
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)
5848
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)
5857
5858 ! Andrei's new change 1.12.09                                 (start)
5859
5860        IF(TPN.LT.273.15-7.0D0) IDROP=0
5861 ! LEAVE REMAPPING ON
5862 !      IDROP=0
5863
5864 ! VALUES FOR SOME REMAPING VARIABLES
5865
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
5874
5875         NRXP=NRX+1
5876
5877         DO K=1,NRX
5878            FI(K)=FI_OLD(K)
5879         ENDDO
5880
5881         DO K=1,NRX
5882            PSI(K)=0.0D0
5883         ENDDO
5884 ! ANDREI                                                      (start)
5885 ! new change 7.02.06                                          (start)
5886
5887         IF(RN(NRX).NE.RR(NRX)) THEN
5888
5889 ! Kovetz-Olund method                                         (start)
5890
5891 ! ANDREI                                                        (end)
5892 ! new change 7.02.06                                            (end)
5893
5894           ISYM=1
5895
5896           IF(RN(1).LT.RR(1)) ISYM=-1
5897
5898 ! CALCULATION OF DISTRIBUTION FUNCTION
5899
5900           IF(ISYM.GT.0) THEN
5901
5902 ! CONDENSATION
5903
5904             RNS(NRXP)=1024.0D0*RR(NRX)
5905             RRS(NRXP)=1024.0D0*RR(NRX)
5906
5907             PSIN(NRXP)=0.0D0
5908             FIN(NRXP)=0.0D0
5909
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
5917
5918 ! NUMBER OF NEW RADII POSITION IN REGULAR GRID
5919
5920 ! RNK - new first bin mass(after condensation)
5921
5922             RNK=RNS(1)
5923
5924             DO I=1,NRX
5925                RRI=RRS(I)
5926                IF(RRI.GT.RNK) GOTO 3
5927             ENDDO
5928
5929     3       IIN=I-1
5930
5931             IFIN=NRX
5932
5933             CONCL=0.0D0
5934             DMASS=0.0D0
5935
5936             DO 6 I=IIN,IFIN
5937
5938                  IP=I+1
5939
5940                  IM=MAX(1,I-1)
5941
5942                  R1=RRS(IM)
5943                  R2=RRS(I)
5944                  R3=RRS(IP)
5945
5946                  DRM=R2-R1
5947                  DRP=R3-R2
5948
5949                  FNEW=0.0D0
5950
5951                  DO 7 K=1,I
5952
5953                       FIK=FIN(K)
5954
5955                       IF(FIK.NE.0.0D0) THEN
5956
5957                         KM=K-1
5958
5959 ! RNK - new bin mass(after condensation)
5960
5961                         RNK=RNS(K)
5962
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
5975
5976                         FNEW=FNEW+FIK*GMAT
5977 ! in case FIK.NE.0.0D0
5978                       ENDIF
5979
5980    7             CONTINUE
5981
5982                  CONCL=CONCL+FNEW
5983
5984                  DMASS=DMASS+FNEW*R2
5985
5986 ! PSIN(I)) - new concentration of hydrometeors after condensation
5987
5988                  PSIN(I)=FNEW
5989
5990    6        CONTINUE
5991
5992 ! NEW VALUES OF DISTRIBUTION FUNCTION
5993
5994 ! PSI(K) - new size distribution function of hydrometeors after
5995 !          condensation, K=1,...,NRX=NKR
5996
5997             DO K=1,NRX
5998                PSI(K)=PSIN(K)/3./RR(K)/COL
5999             ENDDO
6000
6001 ! IN CASE: ISYM.GT.0 (CONDENSATION)
6002
6003           ELSE
6004
6005 ! IN CASE: ISYM.LE.0 (EVAPORATION)
6006
6007             RNS(1)=0.0D0
6008             RRS(1)=0.0D0
6009             FIN(1)=0.0D0
6010             PSIN(1)=0.0D0
6011
6012 ! FIN(K) - initial(before evaporation) concentration of hydrometeors
6013
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
6021
6022             DO I=1,NRXP
6023
6024                IM=MAX(I-1,1)
6025                IP=MIN(I+1,NRXP)
6026
6027                R1=RRS(IP)
6028                R2=RRS(I)
6029                R3=RRS(IM)
6030
6031                DRM=R1-R2
6032                DRP=R2-R3
6033
6034                FNEW=0.0D0
6035
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
6047
6048  4321          CONTINUE
6049
6050 ! PSIN(I) - new concentration of hydrometeors after evaporation
6051
6052                PSIN(I)=FNEW
6053
6054             ENDDO
6055 ! cycle by I
6056
6057 ! NEW VALUES OF DISTRIBUTION FUNCTION                         (start)
6058
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
6068
6069 ! NEW VALUES OF DISTRIBUTION FUNCTION                           (end)
6070
6071 ! IN CASE: ISYM.LE.0 (EVAPORATION)
6072
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)
6080
6081             DO K=1,NKR
6082                RRS(K)=RR(K)
6083             ENDDO
6084
6085             RRS(NKR+1)=RRS(NKR)*1024.0D0
6086
6087             DO I=1,NKR
6088
6089                PSI(I)=PSI(I)*RR(I)
6090
6091 ! PSI(I) - concenration hydrometeors after KO divided on COL*3.0D0
6092 ! RN(I), g - new masses after condensation or evaporation
6093
6094                IF(RN(I).LT.0.0D0) THEN
6095                  RN(I)=1.0D-50
6096                  FI(I)=0.0D0
6097                ENDIF
6098
6099             ENDDO
6100
6101             DO K=1,NKR
6102
6103                IF(FI(K).NE.0.0D0) THEN
6104
6105                  IF(RRS(2).LT.RN(K)) THEN
6106
6107                    I=2
6108
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)
6120
6121                      RRTMP=RRS(I)
6122                      RRP=RRS(I+1)
6123                      RRM=RRS(I-1)
6124
6125                      RNTMP2=RN(K+1)
6126
6127                      RRTMP2=RRS(I+1)
6128                      RRP2=RRS(I+2)
6129                      RRM2=RRS(I)
6130
6131                      GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ &
6132                        (RRTMP-RRM)
6133
6134                      GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ &
6135                         (RRP2-RRM2)/(RRTMP2-RRM2)
6136
6137                      GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ &
6138                        (RRTMP-RRM)
6139
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)
6146
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)
6150
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
6157
6158                        IF(PSI_IP.GT.0.0D0) THEN
6159
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
6165
6166                              PSI(I-1)=PSI_IM
6167
6168                              PSI(I)=PSI(I)+FI(K)*RR(K)*(GN2-GMAT)
6169
6170                              PSI(I+1)=PSI_IP
6171
6172 ! in case smoothing criteria
6173
6174                            ENDIF
6175 ! in case I.GT.2
6176                          ENDIF
6177
6178 ! in case PSI_IP.GT.0.0D0
6179
6180                        ENDIF
6181
6182 ! in case PSI_IM.GT.0.0D0
6183
6184                      ENDIF
6185
6186 ! in case I.LT.NKR-2
6187
6188                    ENDIF
6189 ! new change 7.02.06                                            (end)
6190 ! ANDREI                                                        (end)
6191 ! in case RRS(2).LT.RN(K)
6192
6193                  ENDIF
6194
6195 ! in case FI(K).NE.0.0D0
6196
6197                ENDIF
6198
6199  1000          CONTINUE
6200
6201             ENDDO
6202 ! cycle by K
6203             AOLDCON=0.0D0
6204             ANEWCON=0.0D0
6205             AOLDMASS=0.0D0
6206             ANEWMASS=0.0D0
6207
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
6214
6215 ! new change 8.02.06                                          (start)
6216 ! ANDREI                                                      (start)
6217
6218 ! PSI(K) - new hydrometeor size distribution function(sdf)
6219
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)
6226
6227 ! 3 point method                                                (end)
6228
6229 ! in case I3POINT.NE.0.AND.ISYM.GT.0
6230
6231           ENDIF
6232
6233 ! Andrei's new change 1.12.09                                 (start)
6234
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)
6243
6244             DO K=KRDROP_REMAP_MAX,KRDROP_REMAP_MIN,-1
6245                KMAX=K
6246                IF(PSI(K).GT.0.0D0) GOTO 2011
6247             ENDDO
6248
6249  2011       CONTINUE
6250
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)
6277
6278 ! in case RN(NRX).NE.RR(NRX)
6279
6280         ELSE
6281
6282 ! in case RN(NRX).EQ.RR(NRX)
6283
6284           DO K=1,NKR
6285              PSI(K)=FI(K)
6286           ENDDO
6287
6288         ENDIF
6289
6290 ! new change 8.02.06                                            (end)
6291 ! ANDREI
6292
6293         RETURN
6294
6295 ! SUBROUTINE JERNEWF
6296         END SUBROUTINE JERNEWF
6297
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
6330
6331 ! RHS FOR "MAXWELL" EQUATION
6332
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)
6336
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
6358
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
6364
6365         RETURN
6366         END SUBROUTINE JERRATEOLD
6367
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
6460
6461
6462         RETURN
6463         END SUBROUTINE JERRATE
6464
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
6484
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)
6496
6497       DOUBLE PRECISION EXP1, EXP2
6498
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
6518
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
6528
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)
6561 !
6562 !
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
6571 !
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
6580 !
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
6642
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
6669 !
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)
6678
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
6705
6706
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)
6719
6720        IMPLICIT NONE
6721
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
6727
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
6754
6755        INTEGER K
6756
6757 ! NEW ALGORITHM OF CONDENSATION (12.01.00)
6758
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
6769
6770        DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
6771
6772 ! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
6773
6774         CHARACTER*70 CPRINT
6775
6776
6777
6778
6779
6780
6781
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)
6790
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)
6796
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)
6803
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)
6809
6810 ! CCN
6811
6812 ! WORK ARRAYS
6813
6814 ! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION
6815
6816         REAL DTIMEG(NKR),DTIMEH(NKR)
6817
6818         REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
6819
6820 ! NEW ALGORITHM (NO TYPE OF ICE)
6821
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)
6828
6829
6830         OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
6831         OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
6832
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/
6838
6839         DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
6840      &      /2.53,5.42,3.41E1,6.13/
6841
6842         DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
6843      &      /-4.0,-8.1,-12.7,-17.8,-22.4/
6844
6845
6846         DATA EPSDEL/0.1E-03/
6847
6848         DATA DT0L, DT0I /1.E20,1.E20/
6849
6850 ! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
6851
6852
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
6877
6878         NR=NKR
6879         NRM=NKR-1
6880         DT=DTCOND
6881         DTT=DTCOND
6882         XRAD=0.
6883
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
6891
6892 ! INITIALIZATION OF SOME ARRAYS
6893
6894 !       BARRY
6895         TPN=TT
6896         QPN=QQ
6897
6898
6899 ! TYPE OF ICE IN DIFFUSIONAL GROWTH
6900
6901               DO ICE=1,ICEMAX
6902                  SFNI1(ICE)=0.
6903                  SFNI2(ICE)=0.
6904                  DEL2D(ICE)=0.
6905               ENDDO
6906
6907 ! TIME SPLITTING
6908
6909               TIMENEW=0.
6910               ITIME=0
6911
6912 ! ONLY ICE (CONDENSATION OR EVAPORATION) :
6913
6914    46         ITIME=ITIME+1
6915
6916               TIMEREV=DT-TIMENEW
6917
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)
6945
6946
6947 ! INTEGRALS IN DELTA EQUATION
6948
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
6980
6981 ! PROCESS'S TYPE (ONLY ICE)
6982
6983               IF(KCOND.EQ.21)  THEN
6984
6985 ! ONLY_ICE: CONDENSATION
6986
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)
7004
7005 ! CALL JERSUPSAT - 4 (ONLY ICE: CONDENSATION)
7006
7007                 CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
7008      &                        ,RW,PW,RI,PI,QW,QI &
7009      &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
7010
7011 ! END OF "NEW SUPERSATURATION" (ONLY ICE: CONDENSATION)
7012
7013
7014 ! CRYSTALS (ONLY ICE: CONDENSATION)
7015
7016                 IF(ISYM2.NE.0) THEN
7017
7018 ! CRYSTAL DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION)
7019
7020 ! CALL JERDFUN CRYSTAL - 1 (ONLY ICE: CONDENSATION)
7021
7022 ! NEW ALGORITHM (NO TYPE ICE)
7023                   CALL JERDFUN(R2,B21_MY,B22_MY &
7024      &                        ,FI2,PSI2,D2N &
7025      &                        ,ICM,1,COL,NKR,TPN)
7026
7027                   CALL JERDFUN(R2,B21_MY,B22_MY &
7028      &                        ,FI2,PSI2,D2N &
7029      &                        ,ICM,2,COL,NKR,TPN)
7030
7031                   CALL JERDFUN(R2,B21_MY,B22_MY &
7032      &                        ,FI2,PSI2,D2N &
7033      &                        ,ICM,3,COL,NKR,TPN)
7034 ! IN CASE : ISYM2.NE.0
7035
7036                 ENDIF
7037 ! SNOW
7038                 IF(ISYM3.NE.0) THEN
7039
7040 ! SNOW DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION)
7041
7042
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)
7047
7048                 ENDIF
7049 ! IN CASE : ISYM4.NE.0
7050 ! GRAUPELS (ONLY_ICE: EVAPORATION)
7051
7052                 IF(ISYM4.NE.0) THEN
7053
7054 ! GRAUPEL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION)
7055
7056                   CALL JERDFUN(R4,B41_MY,B42_MY &
7057      &                        ,FI4,PSI4,D2N &
7058      &                        ,1,4,COL,NKR,TPN)
7059 ! IN CASE : ISYM4.NE.0
7060
7061                 ENDIF
7062
7063
7064
7065 ! HAIL (ONLY ICE: CONDENSATION)
7066
7067                 IF(ISYM5.NE.0) THEN
7068
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
7076
7077                 ENDIF
7078
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
7083
7084               ELSE
7085
7086 ! IN CASE KCOND.NE.21
7087
7088 ! ONLY ICE: EVAPORATION
7089
7090 ! NEW TREATMENT OF TIME STEP (ONLY ICE: EVAPORATION)
7091
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
7114
7115 ! NEW TIME STEP (ONLY_ICE: EVAPORATION)
7116
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)
7129
7130 ! CRYSTALS
7131                 IF(ISYM2.NE.0) THEN
7132
7133 ! CRYSTAL DISTRIBUTION FUNCTION
7134
7135 ! NEW ALGORITHM (NO TYPE ICE)
7136
7137                   CALL JERDFUN(R2,B21_MY,B22_MY &
7138      &                         ,FI2,PSI2,D2N &
7139      &                         ,ICM,1,COL,NKR,TPN)
7140
7141                   CALL JERDFUN(R2,B21_MY,B22_MY &
7142      &                         ,FI2,PSI2,D2N &
7143      &                         ,ICM,2,COL,NKR,TPN)
7144
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
7151
7152 ! SNOW DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION)
7153
7154
7155 ! CALL JERDFUN - SNOW - 2 (ONLY_ICE: EVAPORATION)
7156
7157                   CALL JERDFUN(R3,B31_MY,B32_MY &
7158      &                        ,FI3,PSI3,D2N &
7159      &                        ,1,3,COL,NKR,TPN)
7160
7161
7162
7163
7164
7165 ! IN CASE : ISYM3.NE.0
7166
7167                 ENDIF
7168
7169 ! GRAUPELS (ONLY_ICE: EVAPORATION)
7170
7171                 IF(ISYM4.NE.0) THEN
7172
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
7179
7180                 ENDIF
7181
7182 ! HAIL (ONLY_ICE: EVAPORATION)
7183
7184                 IF(ISYM5.NE.0) THEN
7185
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
7192
7193                 ENDIF
7194
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
7199
7200 ! IN CASE : KCOND.NE.21
7201
7202               ENDIF
7203
7204 ! IN CASES : KCOND = 21 OR KCOND.NE.21
7205
7206 ! END OF "PROCESS'S TYPE"
7207 !
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
7286
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
7300
7301
7302 ! GO TO "CONDENSATION AND VAPORATION"
7303
7304
7305         RETURN
7306         END SUBROUTINE ONECOND2
7307 !==================================================================
7308
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
7333
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)
7340
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)
7350
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)
7357
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)
7365
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)
7372
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
7383
7384        DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
7385
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)
7398
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)
7407
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
7415 !
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
7424
7425         I_MIXCOND=0
7426         I_MIXEVAP=0
7427         I_ABERGERON=0
7428         I_BERGERON=0
7429
7430        ITIME = 0
7431        TIMENEW=0.
7432        DT=DTCOND
7433        DTT=DTCOND
7434
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)
7444
7445
7446
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
7526
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)
7562
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)
7578
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"
7790
7791 ! DROPLETS
7792               IF(ISYM1.NE.0) THEN
7793
7794 ! DROPLET DISTRIBUTION FUNCTION
7795
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"
7802
7803 ! IN CASE ISYM1.NE.0
7804
7805               ENDIF
7806 ! CRYSTALS
7807               IF(ISYM2.NE.0) THEN
7808
7809 ! CRYSTAL DISTRIBUTION FUNCTION
7810
7811                 CALL JERDFUN(R2,B21_MY,B22_MY &
7812      &                      ,FI2,PSI2,D2N &
7813      &                      ,ICEMAX,1,COL,NKR,TPN)
7814
7815                 CALL JERDFUN(R2,B21_MY,B22_MY &
7816      &                      ,FI2,PSI2,D2N &
7817      &                      ,ICEMAX,2,COL,NKR,TPN)
7818
7819                 CALL JERDFUN(R2,B21_MY,B22_MY &
7820      &                      ,FI2,PSI2,D2N &
7821      &                      ,ICEMAX,3,COL,NKR,TPN)
7822 ! IN CASE ISYM2.NE.0
7823
7824               ENDIF
7825 ! SNOW
7826               IF(ISYM3.NE.0) THEN
7827
7828 ! SNOW DISTRIBUTION FUNCTION
7829
7830
7831 ! CALL JERDFUN - SNOW - 3
7832
7833                 CALL JERDFUN(R3,B31_MY,B32_MY &
7834      &                      ,FI3,PSI3,D2N &
7835      &                      ,1,3,COL,NKR,TPN)
7836
7837
7838 ! IN CASE ISYM3.NE.0
7839
7840               ENDIF
7841
7842 ! GRAUPELS
7843
7844               IF(ISYM4.NE.0) THEN
7845
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
7852
7853               ENDIF
7854 ! HAIL
7855               IF(ISYM5.NE.0) THEN
7856
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
7863
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
7968
7969 ! HERE
7970
7971         IF(TIMENEW.LT.DT) GOTO 16
7972 17      CONTINUE
7973
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
7985
7986
7987         RETURN
7988         END SUBROUTINE ONECOND3
7989
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)
8007
8008
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
8032
8033
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
8043 !
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
8094
8095       if (icol_drop.eq.1)then
8096 ! break-up
8097
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)
8182
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
8237
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
8259
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)
8284
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
8417
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
8459
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
8486
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
8506 !
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
8516
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
8555
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
8575 !
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
8585
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
8648
8649
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
9137
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)
9234
9235 !.....INPUT VARIABLES
9236 !
9237 !     GT    : MASS DISTRIBUTION FUNCTION
9238 !     XT_MG : MASS OF BIN IN MG
9239 !     JMAX  : NUMBER OF BINS
9240 !     DT    : TIMESTEP IN S
9241
9242       INTEGER JMAX
9243
9244 !.....LOCAL VARIABLES
9245
9246       LOGICAL LTHAN
9247       INTEGER JBREAK,AP,IA,JA,KA,IE,JE,KE
9248       DOUBLE PRECISION EPS,NEGSUM
9249
9250       PARAMETER (AP = 1)
9251       PARAMETER (IA = 1)
9252       PARAMETER (JA = 1)
9253       PARAMETER (KA = 1)
9254       PARAMETER (EPS = 1.D-20)
9255
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
9270
9271
9272
9273
9274
9275
9276
9277 !.....IN CGS
9278
9279 !     DO J=1,JMAX
9280 !        XT(J) = XT_MG(J) * 1E-3
9281 !        GT_MG(J) = GT_MG(J)* 1E-3
9282 !     ENDDO
9283
9284 !.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID
9285
9286       JDIFF = JMAX - JBREAK
9287 !       14  =  33  - 19
9288
9289 !.....INITIALIZATION
9290
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
9295
9296 !.....SHIFT TO BREAKUP GRID
9297
9298       DO K=1,KE
9299          FA(K) = FT(K+JDIFF)
9300       ENDDO
9301
9302 !.....BREAKUP: BLECK'S FIRST ORDER METHOD
9303 !
9304 !     PKIJ: GAIN COEFFICIENTS
9305 !     QKJ : LOSS COEFFICIENTS
9306 !
9307
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
9321
9322 !.....SHIFT RATE TO COAGULATION GRID
9323
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)
9331
9332       DO J=1,JMAX
9333          DG(J) = DF(J) * XT_MG(J)**2
9334       ENDDO
9335
9336 !.....TIME INTEGRATION
9337
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
9367
9368 !     DO J=1,JMAX
9369 !        GT_MG(J) = GT_MG(J) * 1E3
9370 !     ENDDO
9371
9372 !.....THAT'S IT
9373       RETURN
9374
9375       END SUBROUTINE BREAKUP
9376
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
9455
9456 SUBROUTINE MELTING &
9457
9458 (ihucm_flag &
9459
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)
9467
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 !===============================================!
9474
9475 implicit double precision (a-h,o-z)
9476
9477 ! new change 27.03.07                                         (start)
9478
9479 !PARAMETER(NKR=33, NK=129, ICEMAX=3)
9480
9481 ! new change 27.03.07                                           (end)
9482
9483 ! new change 12.02.07                                         (start)
9484
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)
9491
9492 ! new change 12.02.07                                           (end)
9493
9494 ! new change 12.02.07                                         (start)
9495
9496 PARAMETER(ISHEDDING_ON=1, IVT_ADJUST=1, IPRINTING=0, &
9497           ITEMP_ADJUST=1, IEVAP_ADJUST=1, ISUBLIME_ADJUST=1)
9498
9499 ! new change 12.02.07                                           (end)
9500
9501 ! control in main program & others subroutines
9502
9503
9504 ! new change 29.10.08                                         (start)
9505
9506
9507 ! new change 29.10.08                                           (end)
9508
9509
9510
9511
9512 DIMENSION FF1(NKR), XL(NKR), VTL(NKR)
9513
9514 DIMENSION FF2(NKR,ICEMAX),XI(NKR,ICEMAX),V2(NKR,ICEMAX), &
9515           VTC(NKR,ICEMAX),FLIQFR_I(NKR,ICEMAX),RHO_I(NKR,ICEMAX)
9516
9517 DIMENSION FF3(NKR),XS(NKR),V3(NKR), &
9518           VTS(NKR),FLIQFR_S(NKR),RHO_S(NKR)
9519
9520 DIMENSION FF4(NKR),XG(NKR),V4(NKR), &
9521           VTG(NKR),FLIQFR_G(NKR),RHO_G(NKR)
9522
9523 DIMENSION FF5(NKR),XH(NKR),V5(NKR), &
9524           VTH(NKR),FLIQFR_H(NKR),RHO_H(NKR)
9525
9526 DIMENSION FF1_SI(NKR), XL_SI(NKR), VTL_SI(NKR)
9527
9528 DIMENSION FF2_SI(NKR,ICEMAX),XI_SI(NKR,ICEMAX),V2_SI(NKR,ICEMAX), &
9529           VTC_SI(NKR,ICEMAX),RHO_I_SI(NKR,ICEMAX)
9530
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)
9536
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)
9541
9542 DIMENSION &
9543 XI_MELT_SI(NKR,ICEMAX),XS_MELT_SI(NKR),XG_MELT_SI(NKR),XH_MELT_SI(NKR)
9544
9545 INTRINSIC SUM
9546
9547 If(TIN <= 273.15D0) then
9548   RETURN
9549 ENDIF
9550
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
9555
9556 !=============================================================
9557 !       UNIT CONVERSION OF ALL INPUTS to SI
9558 !=============================================================
9559
9560 if(ihucm_flag == 1) then
9561
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
9566
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
9572
9573 XI_MELT_SI = XI_SI
9574 XS_MELT_SI = XS_SI
9575 XG_MELT_SI = XG_SI
9576 XH_MELT_SI = XH_SI
9577
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
9586
9587 V2_SI = V2/100.D0
9588 V3_SI = V3/100.D0
9589 V4_SI = V4/100.D0
9590 V5_SI = V5/100.D0
9591
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
9597
9598 pres_SI = pres/10.D0
9599 rhoa_SI = rhoa*1000.D0
9600
9601 ! in case ihucm_flag == 1
9602
9603 else
9604
9605 ! in case ihucm_flag.NE.1
9606
9607 RHO_I_SI = RHO_I
9608 RHO_S_SI = RHO_S
9609 RHO_G_SI = RHO_G
9610 RHO_H_SI = RHO_H
9611
9612 XL_SI = XL
9613 XI_SI = XI
9614 XS_SI = XS
9615 XG_SI = XG
9616 XH_SI = XH
9617
9618 XI_MELT_SI = XI_SI
9619 XS_MELT_SI = XS_SI
9620 XG_MELT_SI = XG_SI
9621 XH_MELT_SI = XH_SI
9622
9623 VTL_SI = VTL
9624 VTC_SI = VTC
9625 VTS_SI = VTS
9626 VTG_SI = VTG
9627 VTH_SI = VTH
9628
9629 V2_SI = V2
9630 V3_SI = V3
9631 V4_SI = V4
9632 V5_SI = V5
9633
9634 FF1_SI = FF1
9635 FF2_SI = FF2
9636 FF3_SI = FF3
9637 FF4_SI = FF4
9638 FF5_SI = FF5
9639
9640 pres_SI = pres
9641 rhoa_SI = rhoa
9642
9643 ! in case ihucm_flag.NE.1
9644 endif
9645
9646
9647 !=============================================================
9648 !       INITIALISATION
9649 !=============================================================
9650 !
9651 V2_SI(:,:) = VTC_SI(:,:)
9652 V3_SI(:) = VTS_SI(:)
9653 V4_SI(:) = VTG_SI(:)
9654 V5_SI(:) = VTH_SI(:)
9655
9656 ee = QQV*pres_SI/(EPS + QQV)
9657
9658 es_zero = 611.21D0
9659
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")
9661
9662 D_V=0.211D0*((TIN/273.15D0)**1.94D0)*(101325.D0/pres_SI)/1.D4
9663
9664 ! D_V = 2.21D-5
9665 ! FK_a = 2.40D-2
9666
9667 FK_a =(5.69D0+0.017D0*(TIN-273.15D0))*1.0D-3*4.187D0
9668
9669 ! XLV = 2.50D6
9670 ! XLF = 2.83D6 - XLV
9671
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
9676
9677 ! XLV=597.3D0*((273.15D0/TIN)**(0.167D0+3.67D-4*TIN))
9678
9679 XLV = 597.3D0
9680 XLV = XLV*FJOULES_IN_A_CAL*1000.D0
9681 XLS = 2.83D6
9682
9683 !XLF=79.7+0.485D0*(TIN-273.15D0)-2.5D-3*(TIN-273.15D0)*(TIN-273.15D0)
9684
9685 XLF = 79.7D0
9686 XLF = XLF*FJOULES_IN_A_CAL*1000.D0
9687
9688 ! FNSC=0.632D0
9689
9690 etaa = (1.718D0 + 0.0049D0*(TIN-273.15D0) - &
9691         1.2D-5*(TIN-273.15D0)*(TIN-273.15D0))*1.D-5
9692
9693 ! etaa/rhoa_SI = kinematic viscosity
9694
9695 FNSC = etaa/(rhoa_SI*D_V)
9696
9697 ! FNPR=0.71D0
9698
9699 ALPHA_H = FK_a/(CP*rhoa_SI)
9700 FNPR = etaa/(rhoa_SI*ALPHA_H)
9701 RHO_CRIT = 910.D0
9702
9703 !if(IPRINTING==1) print *, &
9704 !                'FNSC,FNPR,XLF,XLV = ', FNSC, FNPR, XLF, XLV
9705
9706 if(rhoa_SI > 2.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (rhoa_SI>2), model stop 111")
9707
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
9711
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
9715
9716
9717 ! new changes 23.08.04                                        (start)
9718
9719 TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), 1.D0, XLS, RV)
9720 if(TS > 273.15D0) TS = 273.15D0
9721
9722 ! new changes 23.08.04                                          (end)
9723
9724 !=============================================================
9725 !       CRYSTALS
9726 !=============================================================
9727
9728
9729 DO I = 1, ICEMAX
9730
9731    I_MELT=I
9732
9733 DO IK = 1, NKR
9734
9735    IK_MELT=IK
9736
9737 if(TIN > 273.15D0) then
9738
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
9744
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
9751
9752 ! COLUMN (Heymsfield 1972) AR = 2 to 5
9753
9754 IF(I.eq.1) then
9755
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)
9760
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))
9764
9765   fnre = vt *FL_star*rhoa_SI/etaa
9766   fv = COLUMN_VENTILATION_COEF(fnre, FNSC)
9767
9768 ! in case I.eq.1
9769 endif
9770
9771 ! PLATE C1g type (see P1a in p52 in P&K)
9772
9773 IF(I.eq.2) then
9774
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
9778
9779   CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
9780
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))
9784
9785   fnre = vt * FL_star*rhoa_SI/etaa
9786   fv = PLATE_VENTILATION_COEF(fnre, FNSC)
9787
9788 ! in case I.eq.2
9789 endif
9790
9791 ! DENDRITES P1c type (see P1c in p52 in P&K)
9792
9793 IF(I.eq.3) then
9794
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
9798
9799   CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
9800
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))
9804
9805         fnre = vt * FL_star*rhoa_SI/etaa
9806         fv = DENDRITE_VENTILATION_COEF(fnre, FNSC)
9807
9808 ! in case I.eq.3
9809 endif
9810
9811 ! CAP = V**(1./3.)
9812
9813 V2_SI(IK,I) = vt
9814 CAP = CAP_izero*(0.8D0 + FLIQFR_I(IK,I)*0.2D0)
9815
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))
9820
9821 ! new changes 23.08.04                                        (start)
9822
9823 if(TS < 273.15D0 .and. FLIQFR_I(IK,I) <= 0.D0) DMELT = 0.D0
9824
9825 ! new changes 23.08.04                                          (end)
9826
9827 call fmass_limits(DMELT, FICEMASS, fm_w, XI_SI(IK,I))
9828
9829 if(ITEMP_ADJUST == 1) then
9830
9831   call thermodynamical_limits &
9832  (FF2_SI(IK,I), XI_SI(IK,I), rhoa_SI, XLF/CP, TIN, DMELT)
9833
9834
9835 ! in case ITEMP_ADJUST == 1
9836
9837 endif
9838
9839 FICEMASS = FICEMASS - DMELT
9840
9841 ! DMELT > 0 for melting
9842
9843 FLIQFR_I(IK,I) = (XI_SI(IK,I) - FICEMASS)/XI_SI(IK,I)
9844
9845 if(FLIQFR_I(IK,I) < 0.D0) FLIQFR_I(IK,I) = 0.D0
9846
9847 if(FLIQFR_I(IK,I) > 0.D0) then
9848
9849   if(IEVAP_ADJUST == 1 ) then
9850
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")
9852
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
9857
9858     HEAT_EVAP=-DMELT*XLF+DT*(4.D0*PI*CAP*fv)*FK_a*(TIN-273.15D0)
9859
9860 ! new changes 24.08.04                                        (start)
9861
9862     IF(HEAT_EVAP.LT.0.D0) THEN
9863
9864 !      PRINT*, 'HEAT_EVAP < 0'
9865
9866 !      PRINT*, 'CRYSTAL'
9867
9868 !      PRINT*, 'I_MELT'
9869 !      PRINT*,  I_MELT
9870
9871 !      PRINT*, 'IJK,KX,KZ,IK'
9872 !      PRINT*,  IJK,KX,KZ,IK_MELT
9873
9874 !      HEAT_EVAP=0.D0
9875
9876
9877 ! in case HEAT_EVAP.LT.0.D0
9878
9879     ENDIF
9880
9881 ! new changes 24.08.04                                          (end)
9882
9883     FMASS_EVAP = HEAT_EVAP/XLV
9884
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
9888
9889     Q_EVAP=FMASS_EVAP*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
9890
9891
9892     CALL EVAP_MELTWATER &
9893    (XI_SI(IK,I),rhoa_SI,Q_EVAP,FLIQFR_I(IK,I),FF2_SI(IK,I))
9894
9895    XI_MELT_SI(IK,I)=XX_MELT
9896
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)
9902
9903     TIN=TIN-XLV/CP*Q_EVAP
9904
9905     QQV=QQV+Q_EVAP
9906
9907 ! new changes 24.08.04                                        (start)
9908
9909     ee = QQV*pres_SI/(EPS + QQV)
9910
9911 ! new changes 24.08.04                                          (end)
9912
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")
9915
9916 ! in case IEVAP_ADJUST == 1
9917   endif
9918
9919 ! in case FLIQFR_I(IK,I) > 0.D0
9920
9921 else
9922
9923 ! in case FLIQFR_I(IK,I).LE.0.D0
9924
9925   if(ISUBLIME_ADJUST == 1 ) then
9926
9927 ! new changes 24.08.04                                        (start)
9928
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
9933
9934 ! new changes 24.08.04                                          (end)
9935
9936     if(DSUB >  XI_SI(IK,I)) then
9937       DSUB = XI_SI(IK,I)
9938     endif
9939
9940     Q_SUBL = DSUB*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
9941
9942
9943     CALL SUBLIME_ICE &
9944    (XI_SI(IK,I),rhoa_SI,Q_SUBL,FF2_SI(IK,I))
9945
9946     XI_MELT_SI(IK,I)=XX_MELT
9947
9948     TIN=TIN-XLS/CP*Q_SUBL
9949     QQV=QQV+Q_SUBL
9950
9951 ! new changes 24.08.04                                        (start)
9952
9953     ee = QQV*pres_SI/(EPS + QQV)
9954
9955 ! new changes 24.08.04                                          (end)
9956
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 ")
9959
9960
9961 ! in case ISUBLIME_ADJUST == 1
9962   endif
9963
9964 ! in case FLIQFR_I(IK,I).LE.0.D0
9965 endif
9966
9967 if(FLIQFR_I(IK,I) < 0.D0) then
9968   FLIQFR_I(IK,I) = 0.D0
9969 endif
9970
9971 IF(FLIQFR_I(IK,I) > FLIQFRAC_LIM) then
9972
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")
9974
9975   if(ITEMP_ADJUST == 1) then
9976
9977
9978     Q_ICE_MELTED= &
9979     FICEMASS*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
9980
9981     TIN=TIN-XLF/CP*Q_ICE_MELTED
9982
9983
9984 ! in case ITEMP_ADJUST == 1
9985   endif
9986
9987   FF1_SI(IK) = FF1_SI(IK) + FF2_SI(IK,I)
9988
9989 !  FLIQFR_I(IK,I) = 0.
9990
9991   FLIQFR_I(IK,I) = 1.D0
9992
9993   FF2_SI(IK,I) = 0.D0
9994
9995 ! in case FLIQFR_I(IK,I) > FLIQFRAC_LIM
9996
9997 ENDIF
9998
9999 ! in case TIN > 273.15D0
10000
10001 endif
10002
10003 ENDDO
10004 ! cycle by IK
10005
10006 ENDDO
10007 ! cycle by I
10008
10009 !=============================================================
10010 !       SNOW
10011 !=============================================================
10012
10013
10014 DO IK = 1, NKR
10015
10016    IK_MELT=IK
10017    I_MELT=0
10018
10019 if(TIN > 273.15D0) then
10020
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
10026
10027 rho_p = RHO_S_SI(IK) + FLIQFR_S(IK)* &
10028        (RHO_WATER - RHO_S_SI(IK))
10029
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
10035 !
10036 ! Based on Mitra et al. (1990)/Matsuo and Sasyo (1981)
10037 ! V_p = (4/3) PI AR a_i**3
10038 !
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
10044 !
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
10048
10049 AR_p = 0.3D0 + 0.7D0 * FLIQFR_S(IK)
10050
10051 ! new change 26.07.04                                         (start)
10052
10053 ! the rest of the HUCM seems to assume that snow is spherical
10054 !(see JERRATE)
10055 ! AR_p = 1.
10056
10057 ! new change 26.07.04                                           (end)
10058
10059 AR_i = AR_p
10060
10061 CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
10062 CAP = CAP_izero*(0.8D0 + FLIQFR_S(IK)*0.2D0)
10063
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
10068
10069 ! new change 24.08.04                                         (start)
10070
10071 fv = SNOW_VENTILATION_COEF(fnre, FNSC, AR_i)
10072
10073 ! new change 24.08.04                                           (end)
10074
10075 V3_SI(IK) = vt
10076
10077 FICEMASS = XS_SI(IK) * (1.D0 - FLIQFR_S(IK))
10078
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))
10082
10083 ! new change 24.08.04                                         (start)
10084
10085 if(TS < 273.15D0 .and. FLIQFR_S(IK) <= 0.D0) DMELT = 0.D0
10086
10087 ! new change 24.08.04                                           (end)
10088
10089 call fmass_limits(DMELT, FICEMASS, fm_w, XS_SI(IK))
10090
10091 if(ITEMP_ADJUST == 1) then
10092
10093
10094   call thermodynamical_limits &
10095  (FF3_SI(IK), XS_SI(IK), rhoa_SI, XLF/CP, TIN, DMELT)
10096
10097
10098 ! in case ITEMP_ADJUST == 1
10099 endif
10100
10101 FICEMASS = FICEMASS - DMELT
10102
10103 FLIQFR_S(IK) = (XS_SI(IK) - FICEMASS)/XS_SI(IK)
10104
10105 if(FLIQFR_S(IK) < 0.D0) then
10106   FLIQFR_S(IK) = 0.D0
10107 endif
10108
10109 if(FLIQFR_S(IK) > 0.D0) then
10110
10111   if(IEVAP_ADJUST == 1) then
10112
10113     if(FLIQFR_S(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 905")
10114
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
10118
10119     HEAT_EVAP=-DMELT*XLF+ DT*(4.D0*PI*CAP*fv)*FK_a*(TIN-273.15D0)
10120
10121 ! new change 24.08.04                                         (start)
10122
10123     IF(HEAT_EVAP.LT.0.D0) THEN
10124
10125 !      PRINT*, 'HEAT_EVAP < 0'
10126
10127 !      PRINT*, 'SNOW'
10128
10129 !      PRINT*, 'IJK,KX,KZ,IK'
10130 !      PRINT*,  IJK,KX,KZ,IK_MELT
10131
10132 !      HEAT_EVAP=0.D0
10133
10134
10135     ENDIF
10136
10137 ! new change 24.08.04                                           (end)
10138
10139     FMASS_EVAP = HEAT_EVAP/XLV
10140
10141     if(FMASS_EVAP > FLIQFR_S(IK) * XS_SI(IK)) then
10142       FMASS_EVAP = FLIQFR_S(IK) * XS_SI(IK)
10143     endif
10144
10145     Q_EVAP= FMASS_EVAP*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
10146
10147
10148     CALL EVAP_MELTWATER &
10149    (XS_SI(IK),rhoa_SI,Q_EVAP,FLIQFR_S(IK),FF3_SI(IK))
10150
10151     XS_MELT_SI(IK)=XX_MELT
10152
10153     TIN=TIN-XLV/CP*Q_EVAP
10154     QQV=QQV+Q_EVAP
10155
10156 ! new change 24.08.04                                         (start)
10157
10158     ee = QQV*pres_SI/(EPS + QQV)
10159
10160 ! new change 24.08.04                                           (end)
10161
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")
10164
10165
10166 ! in case IEVAP_ADJUST == 1
10167   endif
10168
10169 ! in case FLIQFR_S(IK) > 0.D0
10170
10171 else
10172
10173 ! in case FLIQFR_S(IK).LE.0.D0
10174
10175   if(ISUBLIME_ADJUST == 1) then
10176
10177     sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
10178
10179 ! new change 24.08.04                                         (start)
10180
10181     sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
10182
10183     DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
10184
10185 ! new change 24.08.04                                           (end)
10186
10187     if(DSUB >  XS_SI(IK)) then
10188       DSUB = XS_SI(IK)
10189     endif
10190
10191     Q_SUBL = DSUB*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
10192
10193
10194     CALL SUBLIME_ICE(XS_SI(IK),rhoa_SI,Q_SUBL,FF3_SI(IK))
10195
10196     XS_MELT_SI(IK)=XX_MELT
10197
10198     TIN=TIN-XLS/CP*Q_SUBL
10199     QQV=QQV+Q_SUBL
10200
10201 ! new change 24.08.04                                         (start)
10202
10203     ee = QQV*pres_SI/(EPS + QQV)
10204
10205 ! new change 24.08.04                                           (end)
10206
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")
10209
10210
10211 ! in case ISUBLIME_ADJUST == 1
10212   endif
10213
10214 ! in case FLIQFR_S(IK).LE.0.D0
10215 endif
10216
10217 if(FLIQFR_S(IK) < 0.D0) then
10218         FLIQFR_S(IK) = 0.D0
10219 endif
10220
10221 IF(FLIQFR_S(IK) > FLIQFRAC_LIM) then
10222
10223   if(XL_SI(IK).NE.XS_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7012")
10224
10225   if(ITEMP_ADJUST == 1) then
10226
10227
10228     Q_ICE_MELTED=FICEMASS*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
10229
10230     TIN=TIN-XLF/CP*Q_ICE_MELTED
10231
10232
10233
10234 ! in case ITEMP_ADJUST == 1
10235
10236   endif
10237
10238   FF1_SI(IK) = FF1_SI(IK) + FF3_SI(IK)
10239
10240 !  FLIQFR_S(IK) = 0.D0
10241
10242   FLIQFR_S(IK) = 1.D0
10243
10244   FF3_SI(IK) = 0.D0
10245
10246 ! in case FLIQFR_S(IK) > FLIQFRAC_LIM
10247 ENDIF
10248
10249 ! in case TIN > 273.15D0
10250 endif
10251
10252 ENDDO
10253 ! cycle by IK
10254 !
10255 !=============================================================
10256 !               GRAUPEL (assumed to be spheres)
10257 !=============================================================
10258
10259
10260 DO IK = 1, NKR
10261
10262    IK_MELT=IK
10263    I_MELT=0
10264
10265 if(TIN > 273.15D0) then
10266
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
10272 !
10273 vt_start = 0.D0
10274 vt_end = 0.D0
10275 !
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
10281
10282 if(rhoi < RHO_CRIT) then
10283   V_soakable = V_i - fm_i/RHO_ICE
10284 else
10285   V_soakable = 0.D0
10286 endif
10287
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
10291
10292 ! FIND RE (ie. CD) OF SMOOTH SPHERE OF SAME MASS
10293 !(fnre_smooth is invariant during melting)
10294
10295 X_Best = 8.D0 * XG_SI(IK) * rhoa_SI * GRAV / (PI * etaa * etaa)
10296 fnre_smooth = fnre_sphere(X_Best)
10297
10298 if(V_w < V_soakable) then
10299
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)
10303
10304 ! in case V_w < V_soakable
10305
10306 else
10307
10308 ! in case V_w >= V_soakable
10309
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)
10315
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
10324
10325   vt_end=equilibrium_fallspeed &
10326         (fm_i+fm_w_soaked,fm_w_crit, &
10327          XG(:),VTL_SI(:),rhoa_SI,etaa,a_crit)
10328
10329   frac_eqm=(fm_w-fm_w_soaked)/fm_w_crit
10330
10331   if(frac_eqm < 0.D0) frac_eqm = 0.D0
10332   if(frac_eqm > 1.D0) frac_eqm = 1.D0
10333
10334   vt = vt_start + (vt_end - vt_start) * frac_eqm
10335
10336   if(vt < 0.D0) vt = 0.D0
10337
10338 ! in case V_w >= V_soakable
10339
10340 endif
10341
10342 ! new changes 23.01.08                                        (start)
10343
10344 ! new changes 3.02.08                                         (start)
10345
10346 if(ivt_G_H_interpol.ne.0) then
10347
10348   vt=VTG_SI(IK)+FLIQFR_G(IK)*(VTL_SI(IK) - VTG_SI(IK))
10349
10350 endif
10351
10352 ! new changes 3.02.08                                          (end)
10353
10354 ! new changes 23.01.08                                          (end)
10355
10356 V4_SI(IK) = vt
10357
10358 fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
10359
10360 ! new change 5.02.07                                          (start)
10361
10362 fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
10363 fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
10364
10365 ! new change 5.02.07                                            (end)
10366
10367 ! new change 24.08.04                                         (start)
10368
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
10374
10375 if(TS > 273.15D0) TS = 273.15D0
10376
10377 ! new change 24.08.04                                           (end)
10378
10379 if(fnre < 6000.D0) then
10380   CAP = a_d
10381 else
10382   CAP = a_i
10383 endif
10384
10385 FICEMASS = XG_SI(IK) * (1.D0 - FLIQFR_G(IK))
10386
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))
10389
10390 ! new change 24.08.04                                         (start)
10391
10392 if(TS < 273.15D0 .and. FLIQFR_G(IK) <= 0.) DMELT = 0.D0
10393
10394 ! new change 24.08.04                                           (end)
10395
10396
10397 call fmass_limits(DMELT, FICEMASS, fm_w, XG_SI(IK))
10398
10399 if(ITEMP_ADJUST == 1) then
10400
10401
10402   call thermodynamical_limits &
10403  (FF4_SI(IK), XG_SI(IK), rhoa_SI, XLF/CP, TIN, DMELT)
10404
10405
10406 ! in case ITEMP_ADJUST == 1
10407
10408 endif
10409
10410 FICEMASS = FICEMASS - DMELT
10411
10412 FLIQFR_G(IK) = (XG_SI(IK) - FICEMASS)/XG_SI(IK)
10413
10414 if(FLIQFR_G(IK) < 0.D0) then
10415   FLIQFR_G(IK) = 0.D0
10416 endif
10417
10418 if(FLIQFR_G(IK) > 0.D0) then
10419
10420   if(IEVAP_ADJUST == 1) then
10421
10422     if(FLIQFR_G(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 901")
10423
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
10427
10428     HEAT_EVAP=-DMELT*XLF+ DT*(4.D0*PI*CAP)*FK_a*(TIN-273.15D0)*fh
10429
10430 ! new changes 24.08.04                                        (start)
10431
10432     IF(HEAT_EVAP.LT.0.D0) THEN
10433
10434 !      PRINT*, 'HEAT_EVAP < 0'
10435
10436 !      PRINT*, 'GRAUPEL'
10437
10438 !      PRINT*, 'IJK,KX,KZ,IK'
10439 !      PRINT*,  IJK,KX,KZ,IK_MELT
10440
10441 !      HEAT_EVAP=0.D0
10442
10443
10444     ENDIF
10445
10446 ! new change 24.08.04                                           (end)
10447
10448     FMASS_EVAP=HEAT_EVAP/XLV
10449
10450     if(FMASS_EVAP > FLIQFR_G(IK)*XG_SI(IK)) then
10451       FMASS_EVAP = FLIQFR_G(IK)*XG_SI(IK)
10452     endif
10453
10454     Q_EVAP =  FMASS_EVAP * FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
10455
10456
10457 ! in case IEVAP_ADJUST == 1
10458   endif
10459
10460 ! in case FLIQFR_G(IK) > 0.D0
10461
10462 else
10463
10464 ! in case FLIQFR_G(IK) <= 0.D0
10465
10466   if(ISUBLIME_ADJUST == 1)then
10467
10468     sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
10469
10470 ! new change 24.08.04                                         (start)
10471
10472     sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
10473
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)
10477
10478     if(DSUB >  XG_SI(IK)) then
10479       DSUB = XG_SI(IK)
10480     endif
10481
10482     Q_SUBL = DSUB*FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
10483
10484
10485     CALL SUBLIME_ICE( XG_SI(IK), rhoa_SI, Q_SUBL, FF4_SI(IK))
10486
10487     XG_MELT_SI(IK)=XX_MELT
10488 !
10489     TIN = TIN - XLS/CP*Q_SUBL
10490     QQV = QQV + Q_SUBL
10491
10492 ! new change 24.08.04                                         (start)
10493
10494     ee = QQV*pres_SI/(EPS + QQV)
10495
10496 ! new change 24.08.04                                           (end)
10497
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")
10500
10501
10502 ! in case ISUBLIME_ADJUST == 1
10503
10504   endif
10505
10506 ! in case FLIQFR_G(IK) <= 0.D0
10507
10508 endif
10509
10510 IF(FLIQFR_G(IK) > FLIQFRAC_LIM) then
10511
10512   if(XL_SI(IK).NE.XG_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7013")
10513
10514   if(ITEMP_ADJUST == 1) then
10515
10516
10517     Q_ICE_MELTED = FICEMASS *FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
10518
10519     TIN = TIN - XLF/CP*Q_ICE_MELTED
10520
10521
10522 ! in case ITEMP_ADJUST == 1
10523
10524   endif
10525
10526   FF1_SI(IK) = FF1_SI(IK) + FF4_SI(IK)
10527
10528 !  FLIQFR_G(IK) = 0.D0
10529
10530   FLIQFR_G(IK) = 1.D0
10531
10532   FF4_SI(IK) = 0.D0
10533
10534 ! in case FLIQFR_G(IK) > FLIQFRAC_LIM
10535
10536 ENDIF
10537
10538 ! in case TIN > 273.15D0
10539
10540 endif
10541
10542 ENDDO
10543 ! cycle by IK
10544 !
10545 !=============================================================
10546 !               HAIL (assumed to be spheres)
10547 !=============================================================
10548
10549
10550 DO IK = 1, NKR
10551
10552    IK_MELT=IK
10553    I_MELT=0
10554
10555 if(TIN > 273.15D0) then
10556
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
10562
10563 vt_start = 0.D0
10564 vt_end = 0.D0
10565
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
10571
10572 if(rhoi < RHO_CRIT) then
10573   V_soakable = V_i - fm_i/RHO_ICE
10574 else
10575   V_soakable = 0.D0
10576 endif
10577
10578 a_i = rad_sphere(V_i)
10579 a_izero = rad_sphere(XH_SI(IK)/rhoi)
10580
10581 ! FIND RE OF SMOOTH SPHERE OF SAME MASS
10582 ! (fnre_smooth is invariant during melting)
10583
10584 if(IPRINTING == 1) print *, 'fnre_dry = ', fnre_dry
10585
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)
10589
10590 vt_justwet = 0.D0
10591 vt_justsoaked = 0.D0
10592
10593 if(V_w < V_soakable) then
10594
10595 ! SOAKING OF WATER
10596
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)
10600
10601 ! in case V_w < V_soakable
10602
10603 else
10604
10605 ! in case V_w >= V_soakable
10606
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)
10612
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):
10617
10618   if(rhoi < RHO_CRIT) then
10619
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
10624
10625     vt_start = VT_HIGH_DENSITY_TRANS(fnre_dry, fnre_smooth, &
10626     VTH_SI(IK), a_izero, etaa, rhoa_SI)
10627
10628   endif
10629
10630     vt_end=equilibrium_fallspeed &
10631           (fm_i + fm_w_soaked, fm_w_crit, XH(:), &
10632            VTL_SI(:), rhoa_SI, etaa, a_crit)
10633
10634 ! RH87: Interpolation based on fraction of equilibrium water
10635 ! on surface
10636
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
10640
10641     vt = vt_start + (vt_end - vt_start) * frac_eqm
10642
10643     if(vt < 0.D0) then
10644       if(IPRINTING == 1) print *, 'WARNING: vt < 0', vt
10645       vt = 0.D0
10646     endif
10647
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
10651
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
10655
10656 ! in case V_w >= V_soakable
10657
10658 endif
10659
10660 ! new changes 23.01.08                                      (start)
10661
10662 ! new changes 3.02.08                                       (start)
10663
10664 if(ivt_G_H_interpol.ne.0) then
10665
10666   vt=VTH_SI(IK)+FLIQFR_H(IK)*(VTL_SI(IK) - VTH_SI(IK))
10667
10668 endif
10669
10670 ! new changes 3.02.08                                         (end)
10671
10672 ! new changes 23.01.08                                        (end)
10673
10674 V5_SI(IK) = vt
10675
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
10679
10680 ! new change 5.02.07                                          (start)
10681
10682 fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
10683 fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
10684
10685 ! new change 5.02.07                                            (end)
10686
10687 ! new change 24.08.04                                         (start)
10688
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
10694
10695 if(TS > 273.15D0) TS = 273.15D0
10696
10697 ! new change 24.08.04                                           (end)
10698
10699
10700 if(fnre < 6000.D0) then
10701   CAP = a_d
10702 else
10703   CAP = a_i
10704 endif
10705
10706
10707 FICEMASS = XH_SI(IK) * (1.D0 - FLIQFR_H(IK))
10708
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))
10711
10712 ! new change 24.08.04                                         (start)
10713
10714 if(TS < 273.15D0 .and. FLIQFR_H(IK) <= 0.) DMELT = 0.D0
10715
10716 ! new change 24.08.04                                           (end)
10717
10718
10719 !
10720 call fmass_limits (DMELT,FICEMASS,fm_w,XH_SI(IK))
10721
10722 !
10723 if(ITEMP_ADJUST == 1) then
10724
10725
10726   call thermodynamical_limits &
10727  (FF5_SI(IK),XH_SI(IK),rhoa_SI,XLF/CP,TIN,DMELT)
10728
10729
10730 ! in case ITEMP_ADJUST == 1
10731
10732 endif
10733
10734 FICEMASS = FICEMASS - DMELT
10735
10736 FLIQFR_H(IK) = (XH_SI(IK) - FICEMASS)/XH_SI(IK)
10737
10738
10739
10740 if(FLIQFR_H(IK) < 0.D0) then
10741   FLIQFR_H(IK) = 0.D0
10742 endif
10743
10744 if(FLIQFR_H(IK) > 0.D0) then
10745
10746   if(IEVAP_ADJUST == 1) then
10747
10748     if( FLIQFR_H(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 906")
10749
10750 ! HEAT_EVAP = Joules of latent heat absorbed by FMASS_EVAP kg
10751 ! of water evaporating
10752
10753 ! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
10754
10755     HEAT_EVAP=-DMELT*XLF+DT*(4.D0*PI*CAP)*FK_a*(TIN-273.15D0)*fh
10756
10757 ! new changes 24.08.04                                        (start)
10758
10759     IF(HEAT_EVAP.LT.0.D0) THEN
10760
10761 !      PRINT*, 'HEAT_EVAP < 0'
10762
10763 !      PRINT*, 'GRAUPEL'
10764
10765 !      PRINT*, 'IJK,KX,KZ,IK'
10766 !      PRINT*,  IJK,KX,KZ,IK_MELT
10767
10768 !      HEAT_EVAP=0.D0
10769
10770
10771     ENDIF
10772
10773 ! new change 24.08.04                                           (end)
10774
10775     FMASS_EVAP = HEAT_EVAP/XLV
10776
10777     if(FMASS_EVAP > FLIQFR_H(IK) * XH_SI(IK)) then
10778       FMASS_EVAP = FLIQFR_H(IK) * XH_SI(IK)
10779     endif
10780
10781     Q_EVAP=FMASS_EVAP*FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
10782
10783
10784     CALL EVAP_MELTWATER &
10785    (XH_SI(IK),rhoa_SI,Q_EVAP,FLIQFR_H(IK),FF5_SI(IK))
10786
10787     XH_MELT_SI(IK)=XX_MELT
10788
10789     TIN = TIN - XLV/CP*Q_EVAP
10790     QQV = QQV + Q_EVAP
10791
10792 ! new change 24.08.04                                         (start)
10793
10794     ee = QQV*pres_SI/(EPS + QQV)
10795
10796 ! new change 24.08.04                                           (end)
10797
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")
10800
10801
10802 ! in case IEVAP_ADJUST == 1
10803
10804   endif
10805
10806 ! in case FLIQFR_H(IK) > 0.D0
10807
10808 else
10809
10810 ! in case FLIQFR_H(IK) <= 0.D0
10811
10812   if(ISUBLIME_ADJUST == 1) then
10813
10814     sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
10815
10816 ! new change 24.08.04                                         (start)
10817
10818     sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
10819
10820     DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
10821
10822 ! new change 24.08.04                                           (end)
10823
10824     if(DSUB > XH_SI(IK)) then
10825       DSUB = XH_SI(IK)
10826     endif
10827
10828     Q_SUBL = DSUB*FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
10829
10830
10831     CALL SUBLIME_ICE(XH_SI(IK),rhoa_SI,Q_SUBL,FF5_SI(IK))
10832
10833     XH_MELT_SI(IK)=XX_MELT
10834
10835     TIN = TIN - XLS/CP*Q_SUBL
10836     QQV = QQV + Q_SUBL
10837
10838 ! new change 24.08.04                                         (start)
10839
10840     ee = QQV*pres_SI/(EPS + QQV)
10841
10842 ! new change 24.08.04                                           (end)
10843
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")
10846
10847
10848 ! in case ISUBLIME_ADJUST == 1
10849   endif
10850
10851 ! in case FLIQFR_H(IK) <= 0.D0
10852
10853 endif
10854
10855 if(FLIQFR_H(IK) < 0.D0) then
10856   FLIQFR_H(IK) = 0.D0
10857 endif
10858
10859 IF(FLIQFR_H(IK) > FLIQFRAC_LIM) then
10860
10861   if(XL_SI(IK).NE.XH_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7014")
10862
10863   if(ITEMP_ADJUST == 1) then
10864
10865
10866     Q_ICE_MELTED = FICEMASS *FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
10867
10868     TIN = TIN - XLF/CP*Q_ICE_MELTED
10869
10870
10871 ! in case ITEMP_ADJUST == 1
10872
10873   endif
10874
10875   FF1_SI(IK) = FF1_SI(IK) + FF5_SI(IK)
10876
10877 !  FLIQFR_H(IK) = 0.D0
10878
10879   FLIQFR_H(IK) = 1.D0
10880
10881   FF5_SI(IK) = 0.D0
10882
10883 ! in case FLIQFR_H(IK) > FLIQFRAC_LIM
10884
10885 ENDIF
10886
10887 ! in case TIN > 273.15D0
10888
10889 endif
10890
10891 ENDDO
10892 ! cycle by IK
10893
10894 !=============================================================
10895 !       UNIT CONVERSION OF ALL OUTPUTS from SI
10896 !=============================================================
10897 !
10898 if(ihucm_flag == 1) then
10899
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
10906
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
10912
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
10917
10918 ! in case ihucm_flag == 1
10919
10920 else
10921
10922 ! in case ihucm_flag.NE.1
10923
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
10936
10937   XI_MELT = XI_MELT_SI
10938   XS_MELT = XS_MELT_SI
10939   XG_MELT = XG_MELT_SI
10940   XH_MELT = XH_MELT_SI
10941
10942 ! in case ihucm_flag.NE.1
10943
10944 endif
10945
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)
10957
10958 END SUBROUTINE MELTING
10959
10960 ! end of melting subroutine
10961 SUBROUTINE EVAP_MELTWATER(XX,rhoax,Q_EVAPX,FLIQFRX,FFX)
10962
10963 implicit double precision (a-h,o-z)
10964
10965 PARAMETER(COL=0.23105D0)
10966
10967 ! control in main program & others subroutines
10968
10969 ! new change 29.10.08                                         (start)
10970
10971
10972 ! new change 29.10.08                                           (end)
10973
10974
10975
10976
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
10980
10981
10982 if(Q_EVAPX > total_mass_liq) Q_EVAPX = total_mass_liq
10983 if(Q_EVAPX > total_mass) Q_EVAPX = total_mass
10984
10985 total_mass_liq = total_mass_liq - Q_EVAPX
10986 total_mass = total_mass - Q_EVAPX
10987
10988 XX_MELT=total_mass*rhoax/(3.D0*XX*FFX*COL)
10989
10990 FFX = total_mass/(XX*XX*3.D0*COL/rhoax)
10991
10992 if(FFX < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 136")
10993
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")
10997
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
11003
11004 if(FLIQFRX < 0.D0) FLIQFRX = 0.D0
11005 if(FLIQFRX > 1.D0) FLIQFRX = 1.D0
11006
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)
11013
11014 END SUBROUTINE evap_meltwater
11015
11016 ! end of evap_meltwater subroutine
11017 !====================================================================
11018 SUBROUTINE SUBLIME_ICE (XX,rhoax,Q_SUBLX,FFX)
11019
11020 implicit double precision (a-h,o-z)
11021
11022 PARAMETER(COL = 0.23105D0)
11023
11024 ! new change 24.08.04                                         (start)
11025
11026
11027 ! new change 24.08.04                                           (end)
11028
11029 total_mass =  XX*FFX*XX*3.D0*COL/rhoax
11030
11031 if(Q_SUBLX > total_mass) Q_SUBLX = total_mass
11032
11033 total_mass = total_mass - Q_SUBLX
11034
11035 ! new change 20.06.04                                         (start)
11036
11037 XX_MELT=total_mass*rhoax/(3.D0*FFX*XX*COL)
11038
11039 ! new change 20.06.04                                           (end)
11040
11041 FFX = total_mass/(XX*XX*3.D0*COL/rhoax)
11042
11043 if(FFX < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 140")
11044
11045 if(total_mass < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 141")
11046
11047 END SUBROUTINE sublime_ice
11048
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)
11053
11054 implicit double precision (a-h,o-z)
11055
11056
11057 ! During melting, Re is constant (see RH87, Appendix B)
11058 ! but size changes
11059
11060 ! Same as for just-wet case, except we use the current ice size
11061
11062 if(fnre_dryx > 4000.D0) then
11063
11064   vtx = vt_dryx * a_izerox/a_ix
11065
11066
11067 ! in case fnre_dryx > 4000.D0
11068
11069 else
11070
11071 ! in case fnre_dryx <= 4000.D0
11072
11073   vtx = fnre_smoothx * etaax/(2.D0 * a_ix * rhoax)
11074
11075
11076 ! in case fnre_dryx <= 4000.D0
11077 endif
11078
11079 VT_LOW_DENSITY_SOAKING = vtx
11080
11081 RETURN
11082 END FUNCTION VT_LOW_DENSITY_SOAKING
11083
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)
11088
11089 implicit double precision (a-h,o-z)
11090
11091 PARAMETER(RHO_WATER=1000.D0, RHO_ICE=920.D0, PI = 3.141592654D0)
11092
11093 fm_ijustsoaked=fm_tot/(1.D0+RHO_WATER/rhoix-RHO_WATER/RHO_ICE)
11094 a_ijustsoaked=rad_sphere(fm_ijustsoaked/rhoix)
11095
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
11101
11102 vtx = vt_justsoaked
11103
11104 VT_LOW_DENSITY_TRANS = vtx
11105
11106 RETURN
11107 END FUNCTION VT_LOW_DENSITY_TRANS
11108
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)
11113
11114 implicit double precision (a-h,o-z)
11115
11116 PARAMETER(RHO_WATER=1000.D0, RHO_ICE=920.D0, PI = 3.141592654D0)
11117
11118 ! Just-wet size = a_izero
11119
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
11125
11126 vtx = vt_justwet
11127
11128 VT_HIGH_DENSITY_TRANS = vtx
11129
11130 RETURN
11131 END FUNCTION VT_HIGH_DENSITY_TRANS
11132
11133 ! end of function vt_high_density_trans
11134 !====================================================================
11135 ! new change 5.02.07                                          (start)
11136
11137 FUNCTION HAIL_VENTILATION_COEF (fnrex, fnumber, KR)
11138
11139 ! new change 5.02.07                                            (end)
11140
11141 implicit double precision (a-h,o-z)
11142
11143 ! new change 29.10.08                                         (start)
11144
11145
11146 ! new change 29.10.08                                           (end)
11147
11148 if(fnrex < 6000.D0) then
11149
11150   X_F = (fnrex**0.5D0)*(fnumber**(1.D0/3.D0))
11151
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
11157
11158   if(fnrex < 250.D0) then
11159     fx = fx*2.D0
11160   endif
11161
11162 ! in case fnrex < 6000.D0
11163
11164 else
11165
11166 ! in case fnrex >= 6000.D0
11167
11168   if(fnrex < 20000.D0) then
11169     chi_fr = 0.76D0
11170   else
11171     chi_fr = 0.57 + fnrex*9.D-6
11172   endif
11173
11174   fx = chi_fr*(fnrex**0.5D0)*(fnumber**(1.D0/3.D0))/2.D0
11175
11176 ! in case fnrex >= 6000.D0
11177
11178 endif
11179
11180 if(fx < 1.D0) then
11181   fx = 1.D0
11182 endif
11183
11184 ! new change 5.02.07                                          (start)
11185
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
11196
11197 ! new change 5.02.07                                            (end)
11198
11199 HAIL_VENTILATION_COEF = fx
11200
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)
11208
11209 return
11210 end function HAIL_VENTILATION_COEF
11211
11212 ! end of hail_ventilation_coef function
11213 !====================================================================
11214 ! new change 24.08.04                                          (start)
11215
11216       FUNCTION GGESI(T)
11217
11218 implicit double precision (a-h,o-z)
11219
11220 intrinsic DLOG10
11221 !
11222 !     SATURATION VAPOR PRESSURE OVER ICE
11223 !      (GOFF AND GRATCH)
11224 !
11225 !     ESI     SATURATION VAPOR PRESSURE  (MB)
11226 !     T       TEMP  (KELVIN)
11227 !
11228       DATA C1_MELT/-9.09718D0/C2_MELT/-3.56654D0/C3_MELT/0.876793D0/C4_MELT/0.78583503D0/
11229 !
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
11233
11234       RETURN
11235       END FUNCTION GGESI
11236
11237 ! ending of GGESI function
11238
11239 ! new change 24.08.04                                           (end)
11240 !====================================================================
11241 ! new change 24.08.04                                         (start)
11242
11243 FUNCTION SNOW_VENTILATION_COEF(fnrex,fnumber, ARx)
11244
11245 ! new change 24.08.04                                           (end)
11246
11247 implicit double precision (a-h,o-z)
11248
11249 X_F = (fnrex**0.5D0) * (fnumber**(1.D0/3.D0))
11250
11251 ! new change 24.08.04                                         (start)
11252
11253 if(ARx == 1.D0) then
11254
11255 ! real snow is not spherical, so this should not be used
11256
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
11262
11263 else
11264
11265 ! this is the correct formula for real snow
11266
11267 ! new change 24.08.04                                           (end)
11268
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
11274
11275 endif
11276
11277 if(fx < 1.D0) then
11278   fx = 1.D0
11279 endif
11280
11281 if(fx > 100.D0) then
11282
11283 print *,'99992 stop:',fx,X_F,fnrex,fnumber, ARx
11284 fx = 100.D0
11285 !stop 99992
11286 endif
11287
11288 SNOW_VENTILATION_COEF = fx
11289
11290 return
11291 end function SNOW_VENTILATION_COEF
11292
11293 ! ending of SNOW_VENTILATION_COEF function
11294 !====================================================================
11295 ! new change 24.08.04                                         (start)
11296
11297 !REAL FUNCTION SURFACE_TEMP(eex, tempK, factor_vap, fvofh, XLS, RV)
11298
11299 FUNCTION SURFACE_TEMP(eex, tempK, factor_vap, fvofh, XLS, RV)
11300
11301 ! new change 24.08.04                                           (end)
11302
11303 implicit double precision (a-h,o-z)
11304
11305 intrinsic  DEXP, DABS
11306
11307 tsxold = 269.D0
11308
11309 tsx = 270.D0
11310
11311 tdiff = 1.D0
11312
11313 ilj = 0
11314
11315 alpha_ts = factor_vap*fvofh
11316
11317 beta_ts = alpha_ts*eex/tempK
11318
11319 do while(tdiff > 1.D-6)
11320
11321 ! esix_check=611.21D0*(DEXP((tsx-273.15)*XLS /(RV * tsx * 273.15)))
11322
11323    esix = 100.D0*GGESI(tsx)
11324
11325 ! print *, 'E_si = ', esix, ' Pa', ilj, esix_check
11326
11327   f_tsx = tempK - tsx - alpha_ts*esix/tsx + beta_ts
11328
11329   f_tsxold= &
11330   tempK-tsxold-alpha_ts*100.D0*GGESI(tsxold)/tsxold+beta_ts
11331
11332   tsxnew = tsx - f_tsx*(tsx - tsxold)/(f_tsx - f_tsxold)
11333
11334   tsxold = tsx
11335   tsx = tsxnew
11336
11337   tdiff = DABS(tsx - tsxold)
11338
11339   ilj = ilj + 1
11340
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
11347
11348 enddo
11349
11350 SURFACE_TEMP = tsx
11351
11352 return
11353 END FUNCTION SURFACE_TEMP
11354
11355 ! ending of SURFACE_TEMP function
11356
11357 ! new change 24.08.04                                           (end)
11358 !====================================================================
11359 FUNCTION COLUMN_VENTILATION_COEF(fnrex, fnumber)
11360
11361 implicit double precision (a-h,o-z)
11362
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
11368
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)
11371
11372 if(fx < 1.D0) then
11373   fx = 1.D0
11374 endif
11375
11376 if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99993")
11377
11378 COLUMN_VENTILATION_COEF = fx
11379
11380 return
11381 end function COLUMN_VENTILATION_COEF
11382
11383 ! end of column_ventilation_coef function
11384 !====================================================================
11385 FUNCTION PLATE_VENTILATION_COEF(fnrex, fnumber)
11386
11387 implicit double precision (a-h,o-z)
11388
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
11394
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)
11397
11398 if(fx < 1.D0) then
11399   fx = 1.D0
11400 endif
11401
11402 if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99994")
11403
11404 PLATE_VENTILATION_COEF = fx
11405
11406 return
11407 end function PLATE_VENTILATION_COEF
11408
11409 ! end of plate_ventilation_coef function
11410 !====================================================================
11411 FUNCTION DENDRITE_VENTILATION_COEF(fnrex, fnumber)
11412
11413 implicit double precision (a-h,o-z)
11414
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
11420
11421 fx=1.D0+0.35463D0*X_F/10.D0+3.55338D0*((X_F/10.D0)**2.D0)
11422
11423 if(fx < 1.D0) then
11424   fx = 1.D0
11425 endif
11426
11427 if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99995")
11428
11429 DENDRITE_VENTILATION_COEF = fx
11430
11431 return
11432 end function DENDRITE_VENTILATION_COEF
11433
11434 ! end of dendrite_ventilation_coef function
11435 !====================================================================
11436 FUNCTION chi_fra(fra)
11437
11438 implicit double precision (a-h,o-z)
11439
11440 DIMENSION xxa(14), yya(14)
11441
11442 pc = 100.D0 * fra
11443
11444 if(pc.le.0.D0) then
11445   chi_fra = 0.D0
11446   return
11447 endif
11448
11449 if(pc.ge.100.D0) then
11450   chi_fra = 1.D0
11451   return
11452 endif
11453
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
11482
11483 ix_max = 14
11484
11485 ix = 0
11486
11487 pc_hi = 0.D0
11488
11489 DO WHILE(pc_hi < pc)
11490
11491 ix = ix + 1
11492
11493 if(ix > ix_max) then
11494 ix = ix - 1
11495 exit
11496 endif
11497
11498 pc_hi = xxa(ix)
11499
11500 ENDDO
11501
11502 ! new change 24.08.04                                         (start)
11503
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")
11506
11507 ! new change 24.08.04                                           (end)
11508
11509 chi_fra=yya(ix-1)+ &
11510 (pc-xxa(ix-1))*(yya(ix)-yya(ix-1))/(xxa(ix)-xxa(ix-1))
11511
11512 chi_fra = chi_fra/100.D0
11513
11514 if(chi_fra  < 0.D0) chi_fra  = 0.D0
11515 if(chi_fra  > 1.D0) chi_fra  = 1.D0
11516
11517 ! new change 24.08.04                                         (start)
11518
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")
11521
11522 ! new change 24.08.04                                           (end)
11523
11524 RETURN
11525 END FUNCTION chi_fra
11526
11527 ! end of chi_fra function
11528 !====================================================================
11529 function fnre_sphere(xd)
11530
11531 implicit double precision (a-h,o-z)
11532
11533 INTRINSIC DLOG10
11534
11535 ww1 = dlog10(xd)
11536
11537 ww2 = ww1 * ww1
11538 ww3 = ww1 * ww1* ww1
11539
11540 fnre_sphere = 0.d0
11541
11542 if(xd < 73.D0) then
11543   fnre_sphere = xd/24.D0
11544 endif
11545
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
11550
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
11556
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
11562
11563 if(xd >= 5.4D10) then
11564   fnre_sphere = (xd/0.1D0)**0.5D0
11565 endif
11566
11567 end function fnre_sphere
11568
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)
11574
11575 !PARAMETER(PI = 3.141592654D0, NKR = 43, GRAV = 9.8D0)
11576 PARAMETER(PI = 3.141592654D0, GRAV = 9.8D0)
11577
11578 DIMENSION XXL(NKR), vt_rain(NKR)
11579
11580 fnre_shed = 4800.D0 + 4831.5D0*1000.D0*fm_s
11581
11582 if(fnre_shed >= 5000.D0.and.fnre_shed <= 2.5D4) then
11583
11584 ! a_d or a_eqm here?
11585
11586 ! new change 21.06.04                                         (start)
11587
11588   vt_eqm = 1.5D-5* fnre_shed/(2.D0*a_eqm)
11589
11590 ! new change 21.06.04                                           (end)
11591
11592   vt_eqm = vt_eqm* ((1.20D0/rhoax)**0.5D0)
11593
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
11600
11601 ! in case fnre_shed >= 5000.D0.and.fnre_shed <= 2.5D4
11602
11603 else
11604
11605 ! in case fnre_shed < 5000.D0.or.fnre_shed > 2.5D4
11606
11607   if(fnre_shed > 2.5D4) then
11608
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)
11612
11613 ! in case fnre_shed > 2.5D4
11614
11615   else
11616
11617 ! in case fnre_shed < 5000.D0
11618
11619     ILIQ = IFIND_IK (fm_s + fm_w_critx, XXL, finter_frac)
11620
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
11627
11628 ! in case fnre_shed < 5000.D0
11629   endif
11630
11631 ! in case fnre_shed < 5000.D0.or.fnre_shed > 2.5D4
11632 endif
11633
11634 equilibrium_fallspeed = vt_eqm
11635
11636 end function equilibrium_fallspeed
11637
11638 ! end of equilibrium_fallspeed function
11639 !====================================================================
11640 FUNCTION IFIND_IK (fmass_target, fmass_array, fraction)
11641
11642 implicit double precision (a-h,o-z)
11643
11644 !PARAMETER(NKR = 43)
11645
11646 DIMENSION fmass_array(NKR)
11647
11648 IKX = 2
11649
11650 DO WHILE(fmass_array(IKX) < fmass_target)
11651    if(IKX > NKR - 1) exit
11652    IKX = IKX + 1
11653 ENDDO
11654
11655 IKX = IKX - 1
11656
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
11661
11662 if(IKX > NKR.or.IKX < 1) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99999")
11663
11664 IFIND_IK = IKX
11665
11666 END FUNCTION IFIND_IK
11667
11668 ! end of ifind_ik function
11669 !====================================================================
11670 FUNCTION COLUMN_AR (fmassx, rhoix)
11671
11672 implicit double precision (a-h,o-z)
11673
11674 parameter (PI = 3.141592654D0)
11675
11676 ! estimate equivalent diameter (mm)
11677
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
11681
11682 ! apply Table 1 from Heymsfield (1972)
11683
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
11689
11690 ! Now improve the estimate of AR
11691
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
11695
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
11701
11702 if(COLUMN_AR > 5.D0) COLUMN_AR = 5.D0
11703
11704 return
11705 end function COLUMN_AR
11706
11707 ! end of COLUMN_AR function
11708 !====================================================================
11709 FUNCTION PLATE_AR (fmassx)
11710
11711 implicit double precision (a-h,o-z)
11712
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
11718
11719 PLATE_AR = h_i/d_i
11720
11721 return
11722 end function  PLATE_AR
11723
11724 ! end of plate_ar function
11725 !====================================================================
11726 FUNCTION DENDRITE_AR(fmassx)
11727
11728 implicit double precision (a-h,o-z)
11729
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
11735
11736 DENDRITE_AR = h_i/d_i
11737
11738 return
11739 end function DENDRITE_AR
11740
11741 ! end of dendrite_ar function
11742 !====================================================================
11743 FUNCTION COLUMN_CAP_ZERO (fm_ice, AR_ice, rho_ice, FLstar)
11744
11745 implicit double precision (a-h,o-z)
11746
11747 PARAMETER(PI = 3.141592654D0)
11748
11749 INTRINSIC DLOG
11750
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
11754
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
11758
11759 epsil_i = b_i*b_i - a_ix*a_ix
11760
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
11765
11766 epsil_i = epsil_i**0.5D0
11767
11768 COLUMN_CAP_ZERO= (b_i+epsil_i)/a_ix
11769 COLUMN_CAP_ZERO = epsil_i /(DLOG(COLUMN_CAP_ZERO))
11770
11771 omega_i = 2.D0*(PI*a_ix*a_ix) + 4.D0*b_i*a_ix
11772
11773 P_i = 2.D0*PI*a_ix
11774
11775 FLstar = omega_i/P_i
11776
11777 return
11778 end function COLUMN_CAP_ZERO
11779
11780 ! end of column_cap_zero function
11781 !====================================================================
11782 FUNCTION PLANAR_CAP_ZERO (fm_ice, AR_ice, rho_ice, FLstar)
11783
11784 implicit double precision (a-h,o-z)
11785
11786 PARAMETER(PI = 3.141592654D0)
11787
11788 ! new change 29.06.04                                         (start)
11789
11790 !INTRINSIC DLOG, DSIN
11791 INTRINSIC DLOG, DASIN
11792
11793 ! new change 29.06.04                                           (end)
11794
11795 a_ix = (fm_ice/rho_ice)/(4.D0*PI*AR_ice/3.D0)
11796 a_ix = a_ix**(1.D0/3.D0)
11797
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
11801
11802 epsil_i = 1.D0 - AR_ice*AR_ice
11803
11804 if( epsil_i < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9086")
11805
11806 epsil_i = epsil_i**0.5D0
11807
11808 if(epsil_i > 0.D0) then
11809
11810 ! new change 29.06.04                                         (start)
11811
11812 !  PLANAR_CAP_ZERO = a_ix*epsil_i/DSIN(epsil_i)
11813   PLANAR_CAP_ZERO = a_ix*epsil_i/DASIN(epsil_i)
11814
11815 ! new change 29.06.04                                           (end)
11816
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")
11818
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
11822
11823   P_i = 2.D0*PI*a_ix
11824   FLstar = omega_i/P_i
11825
11826 else
11827
11828   PLANAR_CAP_ZERO = a_ix
11829   FLstar = 2.D0*a_ix
11830
11831 endif
11832
11833 return
11834 end function PLANAR_CAP_ZERO
11835
11836 ! end of planar_cap_zero function
11837 !====================================================================
11838 FUNCTION rad_sphere (volume)
11839
11840 implicit double precision (a-h,o-z)
11841
11842 PARAMETER(PI = 3.141592654D0)
11843
11844 rad_sphere = volume/(4.D0*PI/3.D0)
11845 rad_sphere = rad_sphere**(1.D0/3.D0)
11846
11847 return
11848 end FUNCTION rad_sphere
11849
11850 ! end of rad_sphere function
11851 !====================================================================
11852 SUBROUTINE thermodynamical_limits &
11853 (FFX, fm_tot, rhoax, XLFOCP, tempx, dmeltx)
11854
11855 implicit double precision (a-h,o-z)
11856
11857 PARAMETER (COL=0.23105D0)
11858
11859 ! control in main program & others subroutines
11860
11861 ! new change 29.10.08                                         (start)
11862
11863
11864 ! new change 29.10.08                                           (end)
11865
11866
11867
11868 ! PROBLEMS HERE: is "fnumber_MR" correct
11869 ! for the particle number mixing ratio ( /m3) ?
11870
11871
11872
11873 fnumber_MR = 3.D0*FFX*fm_tot*COL/rhoax
11874
11875 Q_ICE_MELTED = dmeltx*fnumber_MR
11876
11877 temp_star = tempx - XLFOCP*Q_ICE_MELTED
11878
11879 if(temp_star < 273.15D0) then
11880
11881   Q_ICE_MELTED = (tempx - 273.15D0)/XLFOCP
11882   dmeltx = Q_ICE_MELTED / fnumber_MR
11883   tempx = 273.15D0
11884
11885 ! in case temp_star < 273.15D0
11886
11887 else
11888
11889 ! in case temp_star >= 273.15D0
11890
11891   tempx = temp_star
11892
11893
11894 endif
11895
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)
11902
11903 END SUBROUTINE thermodynamical_limits
11904
11905 ! end of thermodynamical_limits subroutine
11906 !====================================================================
11907 SUBROUTINE fmass_limits (dmeltx, ficemassx, fm_water, fm_tot)
11908
11909 implicit double precision (a-h,o-z)
11910
11911 INTRINSIC DABS
11912
11913 ! new change 29.10.08                                         (start)
11914
11915
11916 ! new change 29.10.08                                           (end)
11917
11918 if(dmeltx > ficemassx) then
11919   dmeltx = ficemassx
11920 endif
11921
11922 if(dmeltx < 0.D0.and.DABS(dmeltx) > fm_water) then
11923         dmeltx = - fm_water
11924 endif
11925
11926 if(ficemassx - dmeltx > fm_tot) then
11927   dmeltx = ficemassx - fm_tot
11928 endif
11929
11930
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)
11937
11938 end subroutine fmass_limits
11939
11940 ! end of fmass_limits subroutine
11941 ! Version of 3.06.04
11942
11943 ! new size distribution functions after evaporation
11944
11945         SUBROUTINE JERDFUN_MELT &
11946
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
11955
11956       INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,IDROP
11957       INTEGER NRX,I_3POINT,ICE_TYPE
11958
11959
11960 ! include file
11961
11962 !INCLUDE 'MICRO.PRM'
11963
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)
11968
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)
11974
11975         DOUBLE PRECISION FL2R_OLD(NKR),FL2R_NEW(NKR)
11976
11977         NRX=NKR
11978
11979         IF(IND.NE.1) THEN
11980           ITYP=ITYPE
11981         ELSE
11982           ITYP=1
11983         ENDIF
11984
11985 ! recalculation of size distribution functions                (start)
11986
11987         DO ICE_TYPE=1,IND
11988
11989            IF(ITYP.EQ.ICE_TYPE) THEN
11990
11991              DO KR=1,NKR
11992
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
12001
12002
12003 ! new size distribution functions after evaporatiion          (start)
12004
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)
12009
12010              DO KR=1,NKR
12011                 PSI2(KR,ICE_TYPE)=PSI2R(KR)
12012                 FL2_NEW(KR,ICE_TYPE)=FL2R_NEW(KR)
12013              ENDDO
12014
12015
12016 ! in case ITYP.EQ.ICE_TYPE
12017
12018            ENDIF
12019
12020         ENDDO
12021
12022 ! cycle by ICE_TYPE
12023
12024 ! recalculation of size distribution functions                  (end)
12025
12026 ! new size distribution functions                               (end)
12027
12028  128    FORMAT(1X,I2,2D13.5)
12029
12030         RETURN
12031         END SUBROUTINE JERDFUN_MELT
12032
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)
12037
12038         IMPLICIT NONE
12039
12040         INTEGER &
12041         KR
12042
12043
12044         INTEGER &
12045         I,K,NRXP,I3POINT
12046
12047 ! new change 10.06.06                                         (start)
12048         INTEGER &
12049         ISIGN_DIFFUSIONAL_GROWTH
12050 ! new change 10.06.06                                           (end)
12051
12052         DOUBLE PRECISION &
12053         AOLDCON,ANEWCON,AOLDMASS,ANEWMASS
12054
12055         DOUBLE PRECISION &
12056         RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, &
12057         GN1,GN2,GN3,GN1P,GMAT,GMAT2
12058
12059         INTEGER &
12060         NRX
12061
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)
12067
12068         DOUBLE PRECISION &
12069         FL_OLD(NRX),FL_NEW(NRX)
12070
12071         DOUBLE PRECISION &
12072 ! new change 12.06.06                                         (start)
12073         DROPMASS(NRX+1)
12074 ! new change 12.06.06                                           (end)
12075
12076         DOUBLE PRECISION &
12077         PSI_IM,PSI_I,PSI_IP
12078
12079 ! INITIAL VALUES FOR SOME VARIABLES
12080
12081         NRXP=NRX+1
12082
12083         DO I=1,NRX
12084
12085 ! RN(I), g - new masses after condensation or evaporation
12086
12087            IF(RN(I).LT.0.0D0) THEN
12088              RN(I)=1.0D-50
12089              FI(I)=0.0D0
12090            ENDIF
12091
12092         ENDDO
12093
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)
12107
12108 ! new change 7.05.07                                         (start)
12109         DROPMASS(NRXP)=0.0D0
12110 ! new change 7.05.07                                           (end)
12111
12112 ! new change 10.06.06                                         (start)
12113
12114         ISIGN_DIFFUSIONAL_GROWTH=0
12115
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
12122
12123  2000   CONTINUE
12124
12125         IF(ISIGN_DIFFUSIONAL_GROWTH.NE.0) THEN
12126
12127 ! new change 10.06.06                                           (end)
12128
12129 ! Kovetz-Olund method                                         (start)
12130
12131           DO K=1,NRX
12132
12133              IF(FI(K).NE.0.0D0) THEN
12134
12135                I=1
12136
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
12144
12145                IF(RN(K).LT.RRS(1)) THEN
12146
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)
12156
12157                ELSE
12158
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
12167
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)
12177
12178                ENDIF
12179
12180 ! in case FI(K).NE.0.0D0
12181
12182              ENDIF
12183
12184           ENDDO
12185
12186 ! cycle by K
12187
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)
12203
12204 ! calculation both new total drop concentrations(after KO) and new
12205 ! total drop masses (after KO)
12206
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)
12223
12224             DO K=1,NRX
12225
12226                IF(FI(K).NE.0.0D0) THEN
12227
12228                  IF(RRS(2).LT.RN(K)) THEN
12229
12230                    I=2
12231
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
12237
12238                    IF(I.LT.NRX-2) THEN
12239
12240                      RNTMP=RN(K)
12241
12242                      RRTMP=RRS(I)
12243                      RRP=RRS(I+1)
12244                      RRM=RRS(I-1)
12245
12246                      RNTMP2=RN(K+1)
12247
12248                      RRTMP2=RRS(I+1)
12249                      RRP2=RRS(I+2)
12250                      RRM2=RRS(I)
12251
12252                      GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ &
12253                          (RRTMP-RRM)
12254
12255                      GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ &
12256                           (RRP2-RRM2)/(RRTMP2-RRM2)
12257
12258                      GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ &
12259                          (RRTMP-RRM)
12260
12261                      GMAT=(RRP-RNTMP)/(RRP-RRTMP)
12262
12263                      GN3=(RRTMP-RNTMP)*(RRM-RNTMP)/(RRP-RRM)/ &
12264                                                  (RRP-RRTMP)
12265                      GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
12266
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
12272
12273                        IF(PSI_IP.GT.0.0D0) THEN
12274
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
12281
12282                              PSI(I-1)=PSI_IM
12283
12284                              PSI(I)=PSI(I)+FI(K)*RR(K)*(GN2-GMAT)
12285
12286                              PSI(I+1)=PSI_IP
12287 ! in case smoothing criteria
12288                            ENDIF
12289 ! in case I.GT.2
12290                          ENDIF
12291
12292 ! in case PSI_IP.GT.0.0D0
12293
12294                        ENDIF
12295
12296 ! in case PSI_IM.GT.0.0D0
12297
12298                      ENDIF
12299 ! in case I.LT.NRX-2
12300                    ENDIF
12301
12302 ! in case RRS(2).LT.RN(K)
12303
12304                  ENDIF
12305
12306 ! in case FI(K).NE.0.0D0
12307
12308                ENDIF
12309
12310  1000          CONTINUE
12311
12312             ENDDO
12313 ! cycle by K
12314             AOLDCON=0.0D0
12315             ANEWCON=0.0D0
12316             AOLDMASS=0.0D0
12317             ANEWMASS=0.0D0
12318
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
12325
12326 ! 3 point method                                                (end)
12327
12328 ! new change 29.04.08                                         (start)
12329
12330 ! in case I3POINT.NE.0
12331
12332 !         ENDIF
12333
12334  2001     CONTINUE
12335
12336 ! new change 29.04.08                                           (end)
12337
12338 ! PSI(K) - new hydrometeor size distribution function
12339
12340           DO K=1,NRX
12341              PSI(K)=PSI(K)/RR(K)
12342           ENDDO
12343
12344 ! new change 10.06.06                                         (start)
12345
12346 ! in case ISIGN_DIFFUSIONAL_GROWTH.NE.0
12347
12348         ELSE
12349
12350 ! in case ISIGN_DIFFUSIONAL_GROWTH.EQ.0
12351
12352 ! new change 10.06.06                                           (end)
12353
12354           DO K=1,NRX
12355              PSI(K)=FI(K)
12356           ENDDO
12357
12358         ENDIF
12359
12360
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)
12373
12374         RETURN
12375         END SUBROUTINE JERNEWF_MELT
12376
12377 ! SUBROUTINE JERNEWF_MELT
12378 ! Version of 10.02.08
12379
12380 ! new changes 10.02.08                                       (start)
12381
12382 SUBROUTINE SHEDDING &
12383
12384 (ihucm_flag&
12385
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)
12391
12392 ! new changes 10.02.08                                         (end)
12393
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 !===============================================!
12400
12401 implicit double precision (a-h,o-z)
12402
12403 !PARAMETER(NKR=33, NK=129, ICEMAX=3)
12404
12405 ! new changes 25.01.08                                       (start)
12406
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)
12417
12418 ! new changes 25.01.08                                         (end)
12419
12420 ! control in main program & others subroutines
12421
12422 ! new changes 12.02.08                                       (start)
12423
12424 DIMENSION FF1(NKR), XL(NKR), VTL(NKR)
12425
12426 ! new changes 10.02.08                                         (end)
12427
12428 DIMENSION FF4(NKR),XG(NKR),V4(NKR), &
12429           VTG(NKR),FLIQFR_G(NKR),RHO_G(NKR)
12430
12431 DIMENSION FF5(NKR),XH(NKR),V5(NKR), &
12432           VTH(NKR),FLIQFR_H(NKR),RHO_H(NKR)
12433
12434 DIMENSION FF1_SI(NKR), XL_SI(NKR), &
12435           VTL_SI(NKR)
12436
12437 DIMENSION FF4_SI(NKR),XG_SI(NKR),V4_SI(NKR), &
12438           VTG_SI(NKR), RHO_G_SI(NKR)
12439
12440 DIMENSION FF5_SI(NKR),XH_SI(NKR),V5_SI(NKR), &
12441           VTH_SI(NKR), RHO_H_SI(NKR)
12442
12443 INTRINSIC SUM
12444
12445
12446 If(TIN <= 273.15D0) then
12447   RETURN
12448 ENDIF
12449
12450 if(SUM(FF4) <= 0.D0.and.SUM(FF5) <= 0.D0) then
12451
12452   return
12453
12454 endif
12455
12456 !=============================================================
12457 !       UNIT CONVERSION OF ALL INPUTS to SI
12458 !=============================================================
12459
12460 if(ihucm_flag == 1) then
12461
12462 RHO_G_SI = RHO_G*1000.D0
12463 RHO_H_SI = RHO_H*1000.D0
12464
12465 XL_SI = XL/1000.D0
12466 XG_SI = XG/1000.D0
12467 XH_SI = XH/1000.D0
12468
12469
12470 VTL_SI = VTL/100.D0
12471 VTG_SI = VTG/100.D0
12472 VTH_SI = VTH/100.D0
12473
12474 V4_SI = V4/100.D0
12475 V5_SI = V5/100.D0
12476
12477 FF1_SI = 1.E9*FF1
12478 FF4_SI = 1.E9*FF4
12479 FF5_SI = 1.E9*FF5
12480
12481 pres_SI = pres/10.D0
12482 rhoa_SI = rhoa*1000.D0
12483
12484 ! in case ihucm_flag == 1
12485
12486 else
12487
12488 ! in case ihucm_flag.NE.1
12489
12490 RHO_G_SI = RHO_G
12491 RHO_H_SI = RHO_H
12492
12493
12494 XL_SI = XL
12495 XG_SI = XG
12496 XH_SI = XH
12497
12498 VTL_SI = VTL
12499 VTG_SI = VTG
12500 VTH_SI = VTH
12501
12502 V4_SI = V4
12503 V5_SI = V5
12504
12505 FF1_SI = FF1
12506 FF4_SI = FF4
12507 FF5_SI = FF5
12508
12509 pres_SI = pres
12510 rhoa_SI = rhoa
12511
12512 ! in case ihucm_flag.NE.1
12513
12514 endif
12515
12516 !=============================================================
12517 !       INITIALISATION
12518 !=============================================================
12519 !
12520 V4_SI(:) = VTG_SI(:)
12521 V5_SI(:) = VTH_SI(:)
12522
12523 ee = QQV*pres_SI/(EPS + QQV)
12524
12525 es_zero = 611.21D0
12526
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")
12528
12529 D_V=0.211D0*((TIN/273.15D0)**1.94D0)*(101325.D0/pres_SI)/1.D4
12530
12531 ! D_V = 2.21D-5
12532 ! FK_a = 2.40D-2
12533
12534 FK_a =(5.69D0+0.017D0*(TIN-273.15D0))*1.0D-3*4.187D0
12535
12536 ! XLV = 2.50D6
12537 ! XLF = 2.83D6 - XLV
12538
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
12543
12544 ! XLV=597.3D0*((273.15D0/TIN)**(0.167D0+3.67D-4*TIN))
12545
12546 XLV = 597.3D0
12547 XLV = XLV*FJOULES_IN_A_CAL*1000.D0
12548 XLS = 2.83D6
12549
12550 !XLF=79.7+0.485D0*(TIN-273.15D0)-2.5D-3*(TIN-273.15D0)*(TIN-273.15D0)
12551
12552 XLF = 79.7D0
12553 XLF = XLF*FJOULES_IN_A_CAL*1000.D0
12554
12555 ! FNSC=0.632D0
12556
12557 etaa = (1.718D0 + 0.0049D0*(TIN-273.15D0) - &
12558         1.2D-5*(TIN-273.15D0)*(TIN-273.15D0))*1.D-5
12559
12560 ! etaa/rhoa_SI = kinematic viscosity
12561
12562 FNSC = etaa/(rhoa_SI*D_V)
12563
12564 ! FNPR=0.71D0
12565
12566 ALPHA_H = FK_a/(CP*rhoa_SI)
12567 FNPR = etaa/(rhoa_SI*ALPHA_H)
12568 RHO_CRIT = 910.D0
12569
12570 if(rhoa_SI > 2.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 111")
12571
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
12578
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
12583
12584 TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), 1.D0, XLS, RV)
12585 if(TS > 273.15D0) TS = 273.15D0
12586
12587 !=============================================================
12588 !               GRAUPEL (assumed to be spheres)
12589 !=============================================================
12590
12591 ISIGN_GRAUPEL=1
12592 ISIGN_HAIL=0
12593
12594 DO IK = 1, NKR
12595
12596    IK_MELT=IK
12597    I_MELT=0
12598
12599 if(TIN > 273.15D0) then
12600
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
12606 !
12607 vt_start = 0.D0
12608 vt_end = 0.D0
12609 !
12610 rhoi = RHO_G_SI(IK)
12611 fm_i = XG_SI(IK)*(1.D0 - FLIQFR_G(IK))
12612 V_i = fm_i/rhoi
12613
12614 fm_w = XG_SI(IK)*FLIQFR_G(IK)
12615 V_w = fm_w/RHO_WATER
12616
12617 if(rhoi < RHO_CRIT) then
12618   V_soakable = V_i - fm_i/RHO_ICE
12619 else
12620   V_soakable = 0.D0
12621 endif
12622
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
12626
12627 ! FIND RE (ie. CD) OF SMOOTH SPHERE OF SAME MASS
12628 !(fnre_smooth is invariant during melting)
12629
12630 X_Best = 8.D0 * XG_SI(IK) * rhoa_SI * GRAV / (PI * etaa * etaa)
12631 fnre_smooth = fnre_sphere(X_Best)
12632
12633 if(V_w < V_soakable) then
12634
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)
12638
12639 ! in case V_w < V_soakable
12640
12641 else
12642
12643 ! in case V_w >= V_soakable
12644
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)
12650
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
12659
12660   vt_end=equilibrium_fallspeed &
12661         (fm_i+fm_w_soaked,fm_w_crit, &
12662          XG(:),VTL_SI(:),rhoa_SI,etaa,a_crit)
12663
12664   frac_eqm=(fm_w-fm_w_soaked)/fm_w_crit
12665
12666   if(frac_eqm < 0.D0) frac_eqm = 0.D0
12667   if(frac_eqm > 1.D0) frac_eqm = 1.D0
12668
12669   vt = vt_start + (vt_end - vt_start) * frac_eqm
12670
12671   if(vt < 0.D0) vt = 0.D0
12672
12673 ! in case V_w >= V_soakable
12674
12675 endif
12676
12677 ! new changes 3.02.08                                        (start)
12678
12679 if(ivt_G_H_interpol.ne.0) then
12680
12681   vt=VTG_SI(IK)+FLIQFR_G(IK)*(VTL_SI(IK) - VTG_SI(IK))
12682
12683 endif
12684
12685 ! new changes 3.02.08                                          (end)
12686
12687 V4_SI(IK) = vt
12688
12689 fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
12690
12691 fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
12692 fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
12693
12694 ! new change 10.02.08                                        (start)
12695
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
12701
12702 ! new change 10.02.08                                          (end)
12703
12704 if(TS > 273.15D0) TS = 273.15D0
12705
12706 if(fnre < 6000.D0) then
12707   CAP = a_d
12708 else
12709   CAP = a_i
12710 endif
12711
12712 if(FLIQFR_G(IK) <= FLIQFRAC_LIM) then
12713
12714   if(ISHEDDING_ON.eq.1) then
12715
12716     if(IPRINTING == 1) print *,' SHEDDING CODE(GRAUPEL)  '
12717
12718     CALL SHED_MELTWATER &
12719    (fnre,rhoi,RHO_CRIT,XG_SI,FF4_SI,FLIQFR_G,XL_SI,FF1_SI,IK)
12720
12721   endif
12722
12723 ! in case FLIQFR_G(IK) <= FLIQFRAC_LIM
12724
12725 endif
12726
12727 ! in case TIN > 273.15D0
12728
12729 endif
12730
12731 ENDDO
12732 ! cycle by IK
12733 !
12734 !=============================================================
12735 !               HAIL (assumed to be spheres)
12736 !=============================================================
12737
12738 ISIGN_GRAUPEL=0
12739 ISIGN_HAIL=1
12740
12741 DO IK = 1, NKR
12742
12743    IK_MELT=IK
12744    I_MELT=0
12745
12746 if(TIN > 273.15D0) then
12747
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
12753
12754 vt_start = 0.D0
12755 vt_end = 0.D0
12756
12757 rhoi  = RHO_H_SI(IK)
12758 fm_i = XH_SI(IK)*(1.D0 - FLIQFR_H(IK))
12759 V_i = fm_i/rhoi
12760
12761 fm_w = XH_SI(IK)*FLIQFR_H(IK)
12762 V_w = fm_w/RHO_WATER
12763
12764 if(rhoi < RHO_CRIT) then
12765   V_soakable = V_i - fm_i/RHO_ICE
12766 else
12767   V_soakable = 0.D0
12768 endif
12769
12770 a_i = rad_sphere(V_i)
12771 a_izero = rad_sphere(XH_SI(IK)/rhoi)
12772
12773 ! FIND RE OF SMOOTH SPHERE OF SAME MASS
12774 ! (fnre_smooth is invariant during melting)
12775
12776 if(IPRINTING == 1) print *, 'fnre_dry = ', fnre_dry
12777
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)
12781
12782 vt_justwet = 0.D0
12783 vt_justsoaked = 0.D0
12784
12785 if(V_w < V_soakable) then
12786
12787 ! SOAKING OF WATER
12788
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)
12792
12793 ! in case V_w < V_soakable
12794
12795 else
12796
12797 ! in case V_w >= V_soakable
12798
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)
12804
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):
12809
12810   if(rhoi < RHO_CRIT) then
12811
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
12816
12817     vt_start = VT_HIGH_DENSITY_TRANS(fnre_dry, fnre_smooth, &
12818     VTH_SI(IK), a_izero, etaa, rhoa_SI)
12819
12820   endif
12821
12822     vt_end=equilibrium_fallspeed &
12823           (fm_i + fm_w_soaked, fm_w_crit, XH(:), &
12824            VTL_SI(:), rhoa_SI, etaa, a_crit)
12825
12826 ! RH87: Interpolation based on fraction of equilibrium water
12827 ! on surface
12828
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
12832
12833     vt = vt_start + (vt_end - vt_start) * frac_eqm
12834
12835     if(vt < 0.D0) then
12836       if(IPRINTING == 1) print *, 'WARNING: vt < 0', vt
12837       vt = 0.D0
12838     endif
12839
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
12843
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
12847
12848 ! in case V_w >= V_soakable
12849
12850 endif
12851
12852 ! new changes 3.02.08                                        (start)
12853
12854 if(ivt_G_H_interpol.ne.0) then
12855
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)
12861
12862 V5_SI(IK) = vt
12863
12864 fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
12865
12866 ! new change 5.02.07                                          (start)
12867
12868 fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
12869 fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
12870
12871 ! new change 10.02.08                                         (start)
12872
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
12878
12879 ! new change 10.02.08                                           (end)
12880
12881 if(TS > 273.15D0) TS = 273.15D0
12882
12883 if(fnre < 6000.D0) then
12884   CAP = a_d
12885 else
12886   CAP = a_i
12887 endif
12888
12889 if(FLIQFR_H(IK) <= FLIQFRAC_LIM) then
12890
12891   if(ISHEDDING_ON.eq.1) then
12892
12893     CALL SHED_MELTWATER &
12894    (fnre,rhoi,RHO_CRIT,XH_SI,FF5_SI,FLIQFR_H,XL_SI,FF1_SI,IK)
12895
12896 ! in case ISHEDDING_ON.eq.1
12897
12898   endif
12899
12900 ! in case FLIQFR_H(IK) <= FLIQFRAC_LIM
12901
12902 endif
12903
12904 ! in case TIN > 273.15D0
12905
12906 endif
12907
12908 ENDDO
12909 ! cycle by IK
12910
12911 !=============================================================
12912 !       UNIT CONVERSION OF ALL OUTPUTS from SI
12913 !=============================================================
12914 !
12915 if(ihucm_flag == 1) then
12916
12917   if(IVT_ADJUST == 1) then
12918     V4 = 100.D0 * V4_SI
12919     V5 = 100.D0 * V5_SI
12920   endif
12921
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
12927
12928 else
12929
12930 ! in case ihucm_flag.NE.1
12931
12932   if(IVT_ADJUST == 1) then
12933     V4 = V4_SI
12934     V5 = V5_SI
12935   endif
12936
12937   FF1 = FF1_SI
12938   FF4 = FF4_SI
12939   FF5 = FF5_SI
12940
12941 ! in case ihucm_flag.NE.1
12942
12943 endif
12944
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)
12956
12957 END SUBROUTINE
12958
12959 ! end of shedding subroutine
12960 !====================================================================
12961 SUBROUTINE SHED_MELTWATER &
12962 (fnrex,rhoix,RHO_CRITX,XX,FFX,FLIQFR_X,XL_SI,FF1_SI,INK)
12963
12964 implicit double precision (a-h,o-z)
12965
12966 ! new change 27.03.07                                         (start)
12967
12968 !PARAMETER(NKR=33, &
12969 PARAMETER(PI=3.141592654D0, RHO_ICE=920D0, RHO_WATER=1000.D0, &
12970
12971 ! new change 27.03.07                                           (end)
12972
12973 ! new change 27.08.04                                         (start)
12974
12975 IPRINTING=0, &
12976 !IPRINTING=1, &
12977
12978 COL=0.23105D0, FMAX_DROP_MASS_FRACTION=0.5D0)
12979
12980 ! new change 27.08.04                                           (end)
12981
12982 ! new change 21.06.04                                         (start)
12983
12984 ! new change 30.10.04                                         (start)
12985 DIMENSION XX(NKR), XL_SI(NKR)
12986 DIMENSION FFX(NKR), FF1_SI(NKR), FLIQFR_X(NKR)
12987
12988 DIMENSION fmass_ice(NKR), fmass_X(NKR)
12989
12990 INTRINSIC DABS, SUM
12991
12992 fm_i = XX(INK)*(1.D0 - FLIQFR_X(INK))
12993
12994 V_i = fm_i/rhoix
12995
12996 fm_w = XX(INK)*FLIQFR_X(INK)
12997
12998 V_w = fm_w/RHO_WATER
12999
13000 if(rhoix < RHO_CRITX) then
13001   V_soakable = V_i - fm_i/RHO_ICE
13002 else
13003   V_soakable = 0.D0
13004 endif
13005
13006 if(V_w > V_soakable) then
13007
13008 ! new change 21.06.04                                         (start)
13009
13010 ! new change 21.06.04                                           (end)
13011
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
13015
13016 ! new change 22.06.04                                         (start)
13017
13018 ! new change 22.06.04                                           (end)
13019
13020   if(fm_w - fm_w_soaked > fm_w_crit) then
13021
13022 ! new change 21.06.04                                         (start)
13023
13024 ! new change 21.06.04                                           (end)
13025
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
13035
13036     select case (melting_mode)
13037
13038        case(2)
13039        d_w_shed = 1.5D-3
13040
13041        case(3)
13042        d_w_shed = 3.D-3
13043
13044        case(4)
13045        d_w_shed = 4.5E-3
13046
13047        case default
13048
13049  call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9999")
13050
13051     end select
13052
13053     drop_mass = RHO_WATER*(PI/6.D0)*(d_w_shed**3.D0)
13054
13055     if(drop_mass > fm_w_crit*FMAX_DROP_MASS_FRACTION) &
13056     drop_mass = fm_w_crit*FMAX_DROP_MASS_FRACTION
13057
13058     fm_w_save=fm_w
13059
13060     if(melting_mode == 2) then
13061
13062       if(fnrex > 2.5D4) then
13063
13064 ! all melt-water on sfc is shed
13065
13066         fm_w = fm_w_soaked
13067
13068       else
13069
13070 ! small drops shed continuously
13071
13072         fm_w = fm_w_crit + fm_w_soaked
13073
13074       endif
13075
13076 ! in case melting_mode == 2
13077
13078     else
13079
13080 ! in case melting_mode.ne.2
13081
13082 ! intermittent shedding of up to FMAX_DROP_MASS_FRACTION
13083 ! of exterior meltwater
13084
13085       fm_w =  fm_w - drop_mass
13086
13087 ! in case melting_mode.ne.2
13088
13089     endif
13090
13091     if(fm_w - fm_w_soaked > fm_w_crit) fm_w = fm_w_crit + fm_w_soaked
13092
13093     if(fm_w < fm_w_soaked) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9065")
13094
13095     fm_w_shed = fm_w_save - fm_w
13096
13097     ILIQ = IFIND_IK(drop_mass, XL_SI, frac_liq)
13098
13099     INEW = IFIND_IK(fm_w + fm_i, XX, frac)
13100
13101     if(INEW < INK) then
13102
13103 ! new change 21.06.04                                         (start)
13104
13105 ! new change 21.06.04                                           (end)
13106
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)
13111
13112 ! take mass of water shed out of mass_X(IK) and place
13113 ! in temporary reservoir 1
13114
13115       res_mass_shed =  FFX(INK) * fm_w_shed * XX(INK)*3.D0*COL
13116       fmass_X(INK) = fmass_X(INK) - res_mass_shed
13117
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")
13120
13121 ! take all remaining water out of mass_X/mass_ice and place
13122 ! in temporary reservoirs 2 and 3
13123
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
13128
13129 ! transfer water of reservoir 2 into the two size-bins adjacent
13130 ! to fm_w+m_i
13131
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
13135
13136 ! transfer ice of reservoir 3 into the two size-bins adjacent
13137 ! to fm_w+m_i
13138
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
13142
13143 ! transfer shed water of reservoir 1 into liquid bins
13144
13145       FF1_SI(ILIQ)=FF1_SI(ILIQ)+ &
13146       res_mass_shed/(XL_SI(ILIQ)*XL_SI(ILIQ)*3.D0*COL)
13147
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)
13151
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)
13160
13161       else
13162
13163         FLIQFR_X(INEW) = 1.D0
13164
13165       endif
13166
13167       if(FFX(INEW+1) > 0.D0) then
13168
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)
13175
13176       else
13177
13178         FLIQFR_X(INEW+1) = 1.D0
13179
13180       endif
13181
13182       if(FFX(INK) > 0.D0) then
13183
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)
13189
13190       else
13191
13192         FLIQFR_X(INK) = 1.D0
13193
13194       endif
13195
13196 ! new change 21.06.04                                         (start)
13197
13198 ! new change 21.06.04                                           (end)
13199
13200 ! new change 9.12.07                                          (start)
13201
13202 !      if(FLIQFR_X(INEW) < 0.D0.or.FLIQFR_X(INEW) > 1.D0) stop 8003
13203
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)
13223
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")
13226
13227       fmass_X(:)=FFX(:)*XX(:)*XX(:)*3.D0*COL
13228       fmass_ice(:)=FFX(:)*XX(:)*(1.D0-FLIQFR_X(:))*XX(:)*3.D0*COL
13229
13230       fm_X_after = SUM(fmass_X)
13231       fm_ice_after = SUM(fmass_ice)
13232
13233       if(fm_ice_before > 0.D0) then
13234
13235         fjunk = (fm_ice_after/fm_ice_before-1.D0)*100.D0
13236
13237 ! new change 9.12.07                                          (start)
13238
13239 ! new change 21.06.04                                           (end)
13240
13241 !       if(DABS(fjunk) > 1.D0) stop 8011
13242
13243 ! in case fm_ice_before > 0.D0
13244
13245       endif
13246
13247       if(fm_X_before > 0.D0) then
13248
13249         fjunk=((fm_X_after+res_mass_shed)/fm_X_before-1.D0)*100.D0
13250
13251 ! new change 21.06.04                                         (start)
13252 ! new change 21.06.04                                           (end)
13253
13254 !       if(DABS(fjunk) > 1.D0) stop 8012
13255
13256 ! in case fm_X_before > 0.D0
13257
13258       endif
13259
13260 ! new change 21.06.04                                         (start)
13261
13262 ! new change 21.06.04                                           (end)
13263
13264 ! in case INEW < INK
13265
13266     else
13267
13268 ! in case INEW >= INK
13269
13270 ! new change 21.06.04                                          (start)
13271
13272    !   print*, &
13273
13274  !'STOP: drop_mass is too large compared to total mass of particle'
13275
13276  !     print*,   'INEW >= INK'
13277
13278  !     print*,   'INEW,INK'
13279  !     print*,    INEW,INK
13280
13281  !     print*,   'drop_mass,fm_i+fm_w'
13282  !     print 106, drop_mass,fm_i+fm_w
13283
13284        call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9089")
13285
13286 ! new change 21.06.04                                            (end)
13287
13288 ! in case INEW >= INK
13289
13290     endif
13291
13292 ! in case fm_w - fm_w_soaked > fm_w_crit
13293
13294   endif
13295
13296 ! in case V_w > V_soakable
13297
13298 endif
13299
13300 ! new change 21.06.04                                          (start)
13301
13302 106 FORMAT(1X,6D13.5)
13303
13304 ! new change 21.06.04                                            (end)
13305
13306 END SUBROUTINE
13307
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)
13313
13314       IMPLICIT NONE
13315
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
13321
13322 !..Local variables
13323       REAL, DIMENSION(kts:kte):: temp, pres, qv, rho
13324       REAL, DIMENSION(kts:kte):: rr, nr, rs, ns, rg, ng
13325
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
13330
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
13334
13335       INTEGER:: i, k, k_0, kbot, n
13336       LOGICAL:: melti
13337
13338 !+---+
13339
13340       do k = kts, kte
13341          dBZ(k) = -35.0
13342       enddo
13343
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))
13352
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
13365
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
13378
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
13392
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
13407
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 !+---+-----------------------------------------------------------------+
13413
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
13426
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 !+---+-----------------------------------------------------------------+
13434
13435       if (melti .and. k_0.ge.kts+1) then
13436        do k = k_0-1, kts, -1
13437
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
13455
13456
13457 !..Reflectivity contributed by melting graupel
13458
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
13475
13476        enddo
13477       endif
13478
13479       do k = kte, kts, -1
13480          dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18)
13481       enddo
13482
13483
13484       end subroutine refl10cm_hm
13485
13486       END MODULE module_mp_full_sbm