!WRF:MODEL_MP:PHYSICS
! The fast version calculates hydrometeor distributions for qc,qr,qs,qg, and their number concentrations
! (including aerosol concentrations).
! To use the FAST version of SBM, please do the following.
! Set DX_BOUND to some value larger than the first inner nest, but smaller than the outer domain in meters
! Set the aerosol concentration with the variables FCCNR_MAR, and FCCNR_CON, FCCNR_MIX.  
! Each of the aerosol distributions are set with ACCN (concentration of ccn particles at 1% saturation), and
! BCCN (the "k" coefficient; for example: FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN). 
! Questions: contact barry.h.lynn@gmail.com (Barry Lynn)
!
MODULE module_mp_fast_sbm
USE module_mp_radar
!      USE module_state_description
!
!-----------------------------------------------------------------------
! BARRY
      INTEGER,PRIVATE,PARAMETER :: REMSAT = 0
!     LOGICAL, PRIVATE,PARAMETER : : ICEPROCS=.FALSE.,BULKNUC=.TRUE.  
      INTEGER, PRIVATE,PARAMETER :: IBREAKUP=1
      INTEGER, PRIVATE,PARAMETER :: p_ff1i01=2, p_ff1i33=34,p_ff5i01=35,p_ff5i33=67,p_ff6i01=68,&
     & p_ff6i33=100,p_ff8i01=101,p_ff8i33=133

      LOGICAL, PRIVATE,PARAMETER :: CONSERV=.TRUE.
! SET ONE = TRUE
!     LOGICAL, PRIVATE,PARAMETER :: ORIGINAL_MELT=.FALSE.
!     LOGICAL, PRIVATE,PARAMETER :: JIWEN_FAN_MELT=.TRUE.
      LOGICAL, PRIVATE,PARAMETER :: ORIGINAL_MELT=.TRUE.
      LOGICAL, PRIVATE,PARAMETER :: JIWEN_FAN_MELT=.FALSE.
      REAL, PRIVATE,PARAMETER :: PI_MORR = 3.1415926535897932384626434
      REAL, PRIVATE,PARAMETER ::  R_MORR = 287.15



      REAL,PRIVATE,PARAMETER :: DX_BOUND=7500.
      REAL ACCN,BCCN
      REAL,PRIVATE,PARAMETER :: ACCN_MAR=1.0000E02, BCCN_MAR=0.900E00,ROCCN0=0.1000E01
      REAL,PRIVATE,PARAMETER :: ACCN_CON=4.00000E03, BCCN_CON=0.400E00,ROCCN03=0.1000E01
      REAL,PRIVATE,PARAMETER :: I3POINT=1
      INTEGER,PRIVATE,PARAMETER :: ICCN = 1
       DOUBLE PRECISION, PRIVATE, PARAMETER ::  SCAL=1.d0
       INTEGER, PRIVATE,PARAMETER :: ICEPROCS=1,BULKNUC=0 
       INTEGER, PRIVATE,PARAMETER :: ICETURB=0,LIQTURB=0
!      INTEGER, PRIVATE,PARAMETER :: RAIN_INIT=1,GRAUPEL_INIT=1
!      INTEGER, PRIVATE,PARAMETER :: ICE_INIT=0,SNOW_INIT=1

       INTEGER, PRIVATE,PARAMETER :: ICEMAX=3,NCD=33,NHYDR=5,NHYDRO=7  &
     &        ,ifreez_down1=0,ifreez_down2=1,ifreez_top=1              &
     &        ,K0_LL=8,KRMIN_LL=1,KRMAX_LL=19,L0_LL=6                  &
     &        , IEPS_400=1,IEPS_800=0,IEPS_1600=0                      &
     &        ,K0L_GL=16,K0G_GL=16                                     &
     &        ,KRMINL_GL=1,KRMAXL_GL=24                                &
     &        ,KRMING_GL=1,KRMAXG_GL=33                                &
     &        ,KRDROP=18,KRBREAK=17,KRICE=18                           &
     &        ,NKR=33,JMAX=33,NRG=2,JBREAK = 18 
       REAL dt_coll
       REAL, PRIVATE,PARAMETER ::C1_MEY=0.00033,C2_MEY=0.              &
! New CONTINENTAL
!      REAL, PRIVATE,PARAMETER ::C1_MEY=0.0033,C2_MEY=0.              &
     &        ,an0_freez=10.,COL=0.23105                                
       REAL, PRIVATE,PARAMETER :: p1=1000000.0,p2=750000.0,p3=500000.0                     
!      INTEGER, PRIVATE,PARAMETER :: NCOND=3
!      INTEGER, PRIVATE,PARAMETER :: NCOND=6
       INTEGER, PRIVATE :: NCOND
       INTEGER, PRIVATE,PARAMETER :: kr_icempl=9
!      REAL, PRIVATE, PARAMETER :: ALCR = 1.0
!      REAL, PRIVATE, PARAMETER :: ALCR = 2.0
!      REAL, PRIVATE, PARAMETER :: ALCR = 1.5
       REAL, PRIVATE, PARAMETER :: ALCR = 2.25
!      REAL, PRIVATE, PARAMETER :: ALCR = 3.0
       REAL, PRIVATE, PARAMETER :: ALCR_G = 3.0
!      REAL, PRIVATE, PARAMETER :: ALCR_G = 1.0
       INTEGER,PRIVATE,PARAMETER :: icempl=1
       REAL, PRIVATE, PARAMETER :: COEFREFLL=1.E6*36.E6*COL/3.1453/3.1453 
       REAL, PRIVATE, PARAMETER :: COEFREFLI=1.E9*36.E3*COL/3.1453/3.1453/5.
       REAL, PRIVATE, PARAMETER :: COEFREF00=1.E9*36.E3*COL/3.1453/3.1453       
       REAL, PRIVATE,DIMENSION(NKR) ::COLREFLL,COLREFLI,COLREFLS,COLREFLG,COLREFLH


! YWLL_1000MB(nkr,nkr) - input array of kernels for pressure 1000mb
! YWLL_750MB(nkr,nkr) - input array of kernels for pressure 750mb
! YWLL_500MB(nkr,nkr) - input array of kernels for pressure 500mb
       REAL, PRIVATE, SAVE :: &
! CRYSTALS 
     &YWLI(NKR,NKR,ICEMAX) &
! MIXTURES
     &,YWIL(NKR,NKR,ICEMAX),YWII(NKR,NKR,ICEMAX,ICEMAX) &
     &,YWIS(NKR,NKR,ICEMAX),YWIG(NKR,NKR,ICEMAX) &
     &,YWIH(NKR,NKR,ICEMAX),YWSI(NKR,NKR,ICEMAX) &
     &,YWGI(NKR,NKR,ICEMAX),YWHI(NKR,NKR,ICEMAX)
!
      REAL,PRIVATE,DIMENSION(NKR,NKR),SAVE :: &
     & YWLL_1000MB,YWLL_750MB,YWLL_500MB,YWLL,YWLS,YWLG,YWLH &
! SNOW :
     &,YWSL,YWSS,YWSG,YWSH &
! GRAUPELS :
     &,YWGL,YWGS,YWGG,YWGH &
! HAIL :
     &,YWHL,YWHS,YWHG,YWHH
       REAL, PRIVATE, SAVE :: &
     &  XI(NKR,ICEMAX) &
     & ,RADXX(NKR,NHYDR-1),MASSXX(NKR,NHYDR-1),DENXX(NKR,NHYDR-1) &
     & ,RADXXO(NKR,NHYDRO),MASSXXO(NKR,NHYDRO),DENXXO(NKR,NHYDRO) &
     & ,RIEC(NKR,ICEMAX),COEFIN(NKR),SLIC(NKR,6),TLIC(NKR,2) &
     & ,RO2BL(NKR,ICEMAX)
       REAL, PRIVATE, SAVE :: VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR) &
     & ,VR4(NKR),VR5(NKR),VRX(NKR)
      REAL,PRIVATE,DIMENSION(NKR),SAVE ::  &
     &  XL,RLEC,XX,XCCN,XS,RSEC &
     & ,XG,RGEC,XH,RHEC,RO1BL,RO3BL,RO4BL,RO5BL &
     & ,ROCCN,RCCN,DROPRADII
  
      REAL, PRIVATE,SAVE ::  FCCNR_MAR(NKR),FCCNR_CON(NKR)
      REAL, PRIVATE,SAVE ::  FCCNR_MIX(NKR)
      REAL, PRIVATE,SAVE ::  FCCNR(NKR)

        REAL, PRIVATE :: C2,C3,C4
      double precision,private,save ::  cwll(nkr,nkr)
      double precision,private,save::  &
     & xl_mg(0:nkr),xs_mg(0:nkr),xg_mg(0:nkr),xh_mg(0:nkr) &
     &,xi1_mg(0:nkr),xi2_mg(0:nkr),xi3_mg(0:nkr) &
     &,chucm(nkr,nkr),ima(nkr,nkr) &
     &,cwll_1000mb(nkr,nkr),cwll_750mb(nkr,nkr),cwll_500mb(nkr,nkr) &
     &,cwli_1(nkr,nkr),cwli_2(nkr,nkr),cwli_3(nkr,nkr) &
     &,cwls(nkr,nkr),cwlg(nkr,nkr),cwlh(nkr,nkr) &

     &,cwil_1(nkr,nkr),cwil_2(nkr,nkr),cwil_3(nkr,nkr) &

     &,cwii_1_1(nkr,nkr),cwii_1_2(nkr,nkr),cwii_1_3(nkr,nkr) &
     &,cwii_2_1(nkr,nkr),cwii_2_2(nkr,nkr),cwii_2_3(nkr,nkr) &
     &,cwii_3_1(nkr,nkr),cwii_3_2(nkr,nkr),cwii_3_3(nkr,nkr) &

     &,cwis_1(nkr,nkr),cwis_2(nkr,nkr),cwis_3(nkr,nkr) &
     &,cwig_1(nkr,nkr),cwig_2(nkr,nkr),cwig_3(nkr,nkr) &
     &,cwih_1(nkr,nkr),cwih_2(nkr,nkr),cwih_3(nkr,nkr) &

     &,cwsl(nkr,nkr) &
     &,cwsi_1(nkr,nkr),cwsi_2(nkr,nkr),cwsi_3(nkr,nkr)&
     &,cwss(nkr,nkr),cwsg(nkr,nkr),cwsh(nkr,nkr) &
     &,cwgl(nkr,nkr)&
     &,cwgi_1(nkr,nkr),cwgi_2(nkr,nkr),cwgi_3(nkr,nkr)&
     &,cwgs(nkr,nkr),cwgg(nkr,nkr),cwgh(nkr,nkr) &

     &,cwhl(nkr,nkr) &
     &,cwhi_1(nkr,nkr),cwhi_2(nkr,nkr),cwhi_3(nkr,nkr) &
     &,cwhs(nkr,nkr),cwhg(nkr,nkr),cwhh(nkr,nkr) &
     &,dlnr &
     &,CTURBLL(KRMAX_LL,KRMAX_LL)&
     &,CTURB_LL(K0_LL,K0_LL)&
     &,CTURBGL(KRMAXG_GL,KRMAXL_GL)&
     &,CTURB_GL(K0G_GL,K0L_GL)

      DOUBLE PRECISION,private, save :: &
     &   BRKWEIGHT(JBREAK),PKIJ(JBREAK,JBREAK,JBREAK), &
     &   QKJ(JBREAK,JBREAK),ECOALMASSM(NKR,NKR)

 



!
!
      CONTAINS

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
      SUBROUTINE FAST_SBM (w,u,v,th_old,                                &
     &                      chem_new,n_chem,                              &
     &                      itimestep,DT,DX,DY,                         &
     &                      dz8w,rho_phy,p_phy,pi_phy,th_phy,           &
     &                      xland,ivgtyp,xlat,xlong,                           &
     &                      QV,QC,QR,QI,QS,QG,QV_OLD,                   &
     &                      QNC,QNR,QNS,QNG,QNA,                        &
     &                      ids,ide, jds,jde, kds,kde,		        &
     &                      ims,ime, jms,jme, kms,kme,		        &
     &                      its,ite, jts,jte, kts,kte,                  &
     &                      refl_10cm, diagflag, do_radar_ref,      & ! GT added for reflectivity calcs
     &                      RAINNC                             )
!-----------------------------------------------------------------------
      IMPLICIT NONE
!-----------------------------------------------------------------------
      INTEGER, PARAMETER :: ITLO=-60, ITHI=40
      INTEGER NKRO,NKRE
      INTEGER KR,IKL,ICE

      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
     &                     ,ITS,ITE,JTS,JTE,KTS,KTE                     &
     &                     ,ITIMESTEP,N_CHEM

      REAL, INTENT(IN) 	    :: DT,DX,DY
   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
          INTENT(IN   ) ::                                   &
                                                          U, &
                                                          V, &
                                                          W   
!                                                        pi
  REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem),INTENT(INOUT)   :: chem_new
  REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
        INTENT(INOUT) ::                                          &
                                                              qv, &
                                                          qv_old, &
                                                          th_old, &
                                                              qc, &
                                                              qr, &
                                                              qi, &
                                                              qs, &
                                                              qg, &
                                                              qnc, &
                                                              qnr, &
                                                              qns, &
                                                              qng, &
                                                              qna



      REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN)   :: XLAND
      LOGICAL, OPTIONAL, INTENT(IN) :: diagflag
      INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref

      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT)::       &  
                          refl_10cm

      INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN)::   IVGTYP
      REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )    :: XLAT, XLONG
      REAL, INTENT(IN),     DIMENSION(ims:ime, kms:kme, jms:jme)::      &
     &                      dz8w,p_phy,pi_phy,rho_phy
      REAL, INTENT(INOUT),  DIMENSION(ims:ime, kms:kme, jms:jme)::      &
     &                      th_phy
      REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
     &                                                   RAINNC
!     REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
!     REAL,                 DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
!    &              LIQUEXP,ICEEXP,SNOWEXP,GRAUEXP,HAILEXP
!

!-----------------------------------------------------------------------
!     LOCAL VARS
!-----------------------------------------------------------------------

!     NSTATS,QMAX,QTOT are diagnostic vars

      INTEGER,DIMENSION(ITLO:ITHI,4) :: NSTATS
!     REAL,   DIMENSION(ITLO:ITHI,5) :: QMAX
      REAL,   DIMENSION(ITLO:ITHI,22):: QTOT

!     SOME VARS WILL BE USED FOR DATA ASSIMILATION (DON'T NEED THEM NOW). 
!     THEY ARE TREATED AS LOCAL VARS, BUT WILL BECOME STATE VARS IN THE 
!     FUTURE. SO, WE DECLARED THEM AS MEMORY SIZES FOR THE FUTURE USE

!     TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related 
!     the microphysics scheme. Instead, they will be used by Eta precip 
!     assimilation.

      REAL,  DIMENSION( ims:ime, kms:kme, jms:jme ) ::                  &
     &       TLATGS_PHY,TRAIN_PHY
      REAL,  DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC
      REAL,  DIMENSION(its-1:ite+1, kts:kte, jts-1:jte+1):: t_new,t_old,   &
     &                                      zcgs,       rhocgs,pcgs

      INTEGER :: I,J,K,KFLIP
! BARRY
      INTEGER :: KRFREEZ
! DATA
       REAL Z0IN,ZMIN
       DATA  ZMIN/2.0E5/
       DATA  Z0IN/2.0E5 /

!      REAL,DIMENSION(1) :: EPSF2D, &
       REAL EPSF2D, &
     &        TAUR1,TAUR2,EPS_R1,EPS_R2,ANC1IN, &
     &        PEPL,PEPI,PERL,PERI,ANC1,ANC2,PARSP, &
     &        AFREEZMY,BFREEZMY,BFREEZMAX, &
     &        TCRIT,TTCOAL, &
     &        EPSF1,EPSF3,EPSF4, &
     &        SUP2_OLD, DSUPICEXZ,TFREEZ_OLD,DTFREEZXZ, &
     &        AA1_MY,BB1_MY,AA2_MY,BB2_MY, &
     &        DTIME,DTCOND, &
     &        A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
        DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN  &
     &      /2.53,5.42,3.41E1,6.13/
        DATA AA1_MY,BB1_MY,AA2_MY,BB2_MY/2.53E12,5.42E3,3.41E13,6.13E3/
!            QSUM,ISUM,QSUM1,QSUM2,CCNSUM1,CCNSUM2
        DATA KRFREEZ,BFREEZMAX,ANC1,ANC2,PARSP,PEPL,PEPI,PERL,PERI, &
     &  TAUR1,TAUR2,EPS_R1,EPS_R2,TTCOAL,AFREEZMY,&
     &  BFREEZMY,EPSF1,EPSF3,EPSF4,TCRIT/21,&
     &  0.6600E00, &
     &  1.0000E02,1.0000E02,0.9000E02, &
     &  0.6000E00,0.6000E00,1.0000E-03,1.0000E-03, &
     &  0.5000E00,0.8000E00,0.1500E09,0.1500E09, &
     &  2.3315E02,0.3333E-04,0.6600E00, &
     &  0.1000E-02,0.1000E-05,0.1000E-05, &
     &  2.7015E02/
! JIMY: N_CHEM,variables read in as data
! SBM VARIABLES
      REAL,DIMENSION (nkr) :: FF1IN,FF3IN,FF4IN,FF5IN,&
     &              FF1R,FF3R,FF4R,FF5R,FCCN
      REAL,DIMENSION (nkr,icemax) :: FF2IN,FF2R
!!!! NOTE: ZCGS AND OTHER VARIABLES ARE ALSO DIMENSIONED IN FALFLUXHUCM
      DOUBLE PRECISION DEL1NR,DEL2NR,DEL12R,DEL12RD,ES1N,ES2N,EW1N,EW1PN
      DOUBLE PRECISION DELSUP1,DELSUP2,DELDIV1,DELDIV2
      DOUBLE PRECISION TT,QQ,TTA,QQA,PP,DPSA,DELTATEMP,DELTAQ
      DOUBLE PRECISION DIV1,DIV2,DIV3,DIV4,DEL1IN,DEL2IN,DEL1AD,DEL2AD
      REAL DEL_BB,DEL_BBN,DEL_BBR
      REAL FACTZ,CONCCCN_XZ,CONCDROP
       REAL SUPICE(KTE),AR1,AR2, &
     & DERIVT_X,DERIVT_Y,DERIVT_Z,DERIVS_X,DERIVS_Y,DERIVS_Z, &
     & ES2NPLSX,ES2NPLSY,EW1NPLSX,EW1NPLSY,UX,VX, &
     & DEL2INPLSX,DEL2INPLSY,DZZ(KTE)
       INTEGER KRR,I_START,I_END,J_START,J_END
   
       REAL DTFREEZ_XYZ(ITE,KTE,JTE),DSUPICE_XYZ(ITE,KTE,JTE)

       REAL DXHUCM,DYHUCM
       REAL FMAX1,FMAX2,FMAX3,FMAX4,FMAX5
       INTEGER ISYM1,ISYM2,ISYM3,ISYM4,ISYM5
       INTEGER DIFFU
       REAL DELTAW
       real zcgs_z(kts:kte),pcgs_z(kts:kte),rhocgs_z(kts:kte),ffx_z(kts:kte,nkr)
       real z_full
! SLOPE INTERCEPT FOR RAIN, SNOW, AND GRAUPEL                                    PARAMR.32
!     RON=8.E6                                                                   PARAMR.33
!     RON2=1.E10                                                                 23DEC04.211
!     RON2=1.E9                                                                  23DEC04.212
!     SON=2.E7                                                                   PARAMR.36
!     GON=5.E7                                                                   23DEC04.213
!     GON=4.E6
       REAL, PARAMETER :: RON=8.E6, GON=5.E7
       REAL EFF_N,EFF_D
       real nzero,son,nzero_less
       parameter (son=2.E7)
       real raddumb(nkr),massdumb(nkr)
       real hydrosum

       integer imax,kmax,jmax
       real gmax
       real tmax,qmax,divmax,rainmax
       real qnmax,inmax,knmax
       real hydro
       real difmax,tdif,tt_old,w_stag,qq_old
       real teten,es
      REAL, DIMENSION(kts:kte)::                            &
                      qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
      REAL, DIMENSION(kts:kte):: dBZ

       integer  print_int
       parameter (print_int=300)

       integer t_print,xlong10
       t_print=print_int/dt

       difmax = 0
!      print*,'itimestep = ',itimestep
!        if (itimestep.gt.150)return
        if (itimestep.eq.1)then
         if (iceprocs.eq.1) call wrf_message("SBM FAST: ICE PROCESES ACTIVE")
         if (iceprocs.eq.0) call wrf_message("SBM FAST: LIQUID PROCESES ONLY")
        print*,'num_chem = ',n_chem
        end if
       tmax = 0
! COAL BOTT IS EITHER CALLED EVERY TIME STEP OR TWICE
       NCOND = 0
!       if (mod(dx,1000.).eq.0)then
!       NCOND=dx/1000
!       else if (mod(dx,2000.).eq.0)then
!       NCOND=dx/500
!       else if (mod(dx,3000.).eq.0)then
!       NCOND=dx/1000
!       else if (mod(dx,4000.).eq.0)then
!       NCOND=dx/1000
!       else if (mod(dx,1333.).eq.0)then
!       NCOND=dx/1.3333
!       end if
       NCOND=nint(dx/1000)

 !      IF (NCOND.EQ.0)NCOND=3
       NCOND=max(NCOND,1)
       DTCOND=DT/NCOND
       dt_coll=dt
       call kernals(dt)
!      if (itimestep.eq.1.or.itimestep.eq.3)then
!            do kr = 1,nkr
!             print*,'xl = ',xl(kr),vr1(kr),RLEC(kr),RO1BL(kr)
!             print*,'xi = ',xi(kr,1),vr2(kr,1),RIEC(KR,1),RO2BL(KR,1)
!             print*,'xi = ',xi(kr,2),vr2(kr,2),RIEC(KR,2),RO2BL(KR,2)
!             print*,'xi = ',xi(kr,3),vr2(kr,3),RIEC(KR,3),RO2BL(KR,3)
!             print*,'xs = ',xs(kr),vr3(kr),RSEC(kr),RO3BL(kr)
!             print*,'xg = ',xg(kr),vr4(kr),RGEC(kr),RO4BL(kr)
!             print*,'xh = ',xh(kr),vr5(kr),RHEC(kr),RO5BL(kr)
!            end do
!       end if

!
      DEL_BB=BB2_MY-BB1_MY
      DEL_BBN=BB2_MYN-BB1_MYN
      DEL_BBR=BB1_MYN/DEL_BBN
!
      if (conserv)then
      DO j = jts,jte
      DO i = its,ite
      DO k = kts,kte
      rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
      KRR=0
      DO kr=p_ff1i01,p_ff1i33
      KRR=KRR+1
        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KRR)/XL(KRR)/3.0
      END DO
      KRR=0
      DO KR=p_ff5i01,p_ff5i33
        KRR=KRR+1
        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3.0
      END DO
      KRR=0
      DO KR=p_ff6i01,p_ff6i33
        KRR=KRR+1
        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3.0
      END DO
      KRR=0
      DO KR=p_ff8i01,p_ff8i33
        KRR=KRR+1
! change by J. Fan
!        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/XCCN(KRR)
        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/1000.   ! chem_new (input) is #/kg
      END DO
      END DO
      END DO
      END DO
      end if

      call kernals(dt)

      DXHUCM=100.*DX
      DYHUCM=100.*DY

! JIMY
      I_START=MAX(1,ITS-1)
      J_START=MAX(1,JTS-1)
      I_END=MIN(IDE-1,ITE+1)
      J_END=MIN(JDE-1,JTE+1)
!     print*,'ide-1 = ',ide-1
!     print*,'jde-1 = ',jde-1
!     print*,'kte = ',kte
!     print*,'i_start,i_end = ',i_start,i_end
!     print*,'j_start,j_end = ',j_start,j_end
!     print*,'its,ite = ',its,ite
!     print*,'jts,jte = ',jts,jte
      if (itimestep.eq.1)then
      DO j = j_start,j_end
      DO k = kts,kte
      DO i = i_start,i_end
         th_old(i,k,j)=th_phy(i,k,j)
         qv_old(i,k,j)=qv(i,k,j)
      END DO
      END DO
      END DO
      end if
      DO j = j_start,j_end
      DO k = kts,kte
      DO i = i_start,i_end
        t_new(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j)
        t_old(i,k,j) = th_old(i,k,j)*pi_phy(i,k,j)
      ENDDO
      ENDDO
      ENDDO
      DO j = j_start,j_end
      DO i = i_start,i_end
      z_full=0.
      DO k = kts,kte
          pcgs(I,K,J)=P_PHY(I,K,J)*10.
          rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
          zcgs(I,K,J)=z_full+0.5*dz8w(I,K,J)*100
          z_full=z_full+dz8w(i,k,j)*100.
      ENDDO
      ENDDO
      ENDDO
 
!!!!!
         if (itimestep.eq.1)then
!      DO j = j_start,j_end
!      DO i = i_start,i_end
       DO j = jts,jte
       DO i = its,ite
       DO k = kts,kte
         IF (zcgs(I,K,J).LE.ZMIN)THEN
            FACTZ=1.
         ELSE
            FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
         END IF
!        FACTZ = 1
         KRR=0
         DO KR=p_ff8i01,p_ff8i33
          KRR=KRR+1
          if (xland(i,j).eq.1.and.(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.1))then
             chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ
          else
             chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
          end if
!         if (dx.ge.4500)then
!         if (xlat(i,j).ge.10.and.xlat(i,j).le.30.and.zcgs(i,k,j).le.300000)then
!             chem_new(I,K,J,KR)=FCCNR_MIX(KRR)
!         end if
!         end if

         END DO
       end do
       end do
       end do
         end if
       if (itimestep.ne.1.and.dx.gt.dx_bound)then  
       DO j = jts,jte
       DO k = kts,kte
       DO i = its,ite
        if (i.le.5.or.i.ge.IDE-5.OR. &
     &       j.le.5.or.j.ge.JDE-5)THEN
         IF (zcgs(I,K,J).LE.ZMIN)THEN
            FACTZ=1.
         ELSE
            FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
         END IF
         KRR=0
         DO kr=p_ff8i01,p_ff8i33
          KRR=KRR+1
          if (xland(i,j).eq.1.and.(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.1))then
             chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ
          else
             chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
          end if
         End do
        end if
       end do
       end do
       end do
       end if

!     print*,'dxhucm = ',dxhucm
!     print*,'dyhucm = ',dyhucm
!
!-----------------------------------------------------------------------
!**********************************************************************
!-----------------------------------------------------------------------
!
!
!     print*,'here at 1'
      DO j = jts,jte
      DO i = its,ite
      DO k = kts,kte
       IF(K.EQ.KTE)THEN
        DZZ(K)=(zcgs(I,K,J)-zcgs(I,K-1,J))
       ELSE IF(K.EQ.1)THEN
        DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K,J))
       ELSE
        DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K-1,J))
       END IF
       ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
       EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
       SUPICE(K)=EW1N/ES2N-1.
       IF(SUPICE(K).GT.0.5) SUPICE(K)=.5
 
      END DO
      DO k = kts,kte
       IF(T_OLD(I,K,J).GE.238.15.AND.T_OLD(I,K,J).LT.274.15) THEN
       if (k.lt.kte)then       
        w_stag=50.*(w(i,k,j)+w(i,k+1,j)) 
       else
        w_stag=100*w(i,k,j)
       end if
             IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
              UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
              VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
             ELSE
              UX=U(I,K,J)*100.
              VX=V(I,K,J)*100.
             END IF  
             IF(K.EQ.1) DERIVT_Z=(T_OLD(I,K+1,J)-T_OLD(I,K,J))/DZZ(K)
             IF(K.EQ.KTE) DERIVT_Z=(T_OLD(I,K,J)-T_OLD(I,K-1,J))/DZZ(K)
             IF(K.GT.1.AND.K.LT.KTE) DERIVT_Z= &
     &        (T_OLD(I,K+1,J)-T_OLD(I,K-1,J))/DZZ(K)
             IF (I.EQ.1)THEN
              DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I,K,J))/(DXHUCM)
             ELSE IF (I.EQ.IDE-1)THEN
              DERIVT_X=(T_OLD(I,K,J)-T_OLD(I-1,K,J))/(DXHUCM)
             ELSE
              DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I-1,K,J))/(2.*DXHUCM)
             END IF
             IF (J.EQ.1)THEN
              DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J))/(DYHUCM)
             ELSE IF (J.EQ.JDE-1)THEN
              DERIVT_Y=(T_OLD(I,K,J)-T_OLD(I,K,J-1))/(DYHUCM)
             ELSE
              DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J-1))/(2.*DYHUCM)
             END IF
             DTFREEZ_XYZ(I,K,J)=DT*(VX*DERIVT_Y+ &
     &            UX*DERIVT_X+w_stag*DERIVT_Z)
          ELSE
             DTFREEZ_XYZ(I,K,J)=0.
          ENDIF
          IF(SUPICE(K).GE.0.02.AND.T_OLD(I,K,J).LT.268.15) THEN
            IF (I.LT.IDE-1)THEN
             ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I+1,K,J))
             EW1NPLSX=QV_OLD(I+1,K,J)*pcgs(I+1,K,J)/ &
     &               (0.622+0.378*QV_OLD(I+1,K,J))
            ELSE
             ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
             EW1NPLSX=QV_OLD(I,K,J)*pcgs(I,K,J)/ &
     &               (0.622+0.378*QV_OLD(I,K,J))
            END IF
            IF (ES2NPLSX.EQ.0)THEN
             DEL2INPLSX=0.5
            ELSE
             DEL2INPLSX=EW1NPLSX/ES2NPLSX-1.
            END IF
            IF(DEL2INPLSX.GT.0.5) DEL2INPLSX=.5
            IF (I.GT.1)THEN
             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I-1,K,J))
             EW1N=QV_OLD(I-1,K,J)*pcgs(I-1,K,J)/(0.622+0.378*QV_OLD(I-1,K,J))
            ELSE
             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
             EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
            END IF
            DEL2IN=EW1N/ES2N-1.
            IF(DEL2IN.GT.0.5) DEL2IN=.5
            IF (I.GT.1.AND.I.LT.IDE-1)THEN
             DERIVS_X=(DEL2INPLSX-DEL2IN)/(2.*DXHUCM)
            ELSE
             DERIVS_X=(DEL2INPLSX-DEL2IN)/(DXHUCM)
            END IF
            IF (J.LT.JDE-1)THEN
             ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J+1))
             EW1NPLSY=QV_OLD(I,K,J+1)*pcgs(I,K,J+1)/(0.622+0.378*QV_OLD(I,K,J+1))
            ELSE
             ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
             EW1NPLSY=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
            END IF
            DEL2INPLSY=EW1NPLSY/ES2NPLSY-1.
            IF(DEL2INPLSY.GT.0.5) DEL2INPLSY=.5
            IF (J.GT.1)THEN
             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J-1))
             EW1N=QV_OLD(I,K,J-1)*pcgs(I,K,J-1)/(0.622+0.378*QV_OLD(I,K,J-1))
            ELSE
             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
             EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
            END IF
             DEL2IN=EW1N/ES2N-1.
            IF(DEL2IN.GT.0.5) DEL2IN=.5
            IF (J.GT.1.AND.J.LT.JDE-1)THEN
             DERIVS_Y=(DEL2INPLSY-DEL2IN)/(2.*DYHUCM)
            ELSE
             DERIVS_Y=(DEL2INPLSY-DEL2IN)/(DYHUCM)
            END IF
!
            IF (K.EQ.1)DERIVS_Z=(SUPICE(K+1)-SUPICE(K))/DZZ(K)
            IF (K.EQ.KTE)DERIVS_Z=(SUPICE(K)-SUPICE(K-1))/DZZ(K)
            IF(K.GT.1.and.K.LT.KTE) DERIVS_Z=(SUPICE(K+1)-SUPICE(K-1))/DZZ(K)
            IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
             UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
             VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
            ELSE
             UX=U(I,K,J)*100.
             VX=V(I,K,J)*100.
            END IF  
            DSUPICE_XYZ(I,K,J)=(UX*DERIVS_X+VX*DERIVS_Y+ &
      &                        w_stag*DERIVS_Z)*DTCOND
          ELSE
            DSUPICE_XYZ(I,K,J)=0.0
          END IF
         END DO
         END DO
         END DO
     

      do j = jts,jte
      do i = its,ite
      do k = kts,kte
!     if (i.eq.214.and.j.eq.60.and.k.eq.14)then
!     if (i.eq.214.and.j.eq.60)then
!     print*,'i,j = ',i,j,k
!     end if
!     print*,'i,j = ',i,j,k
!     print*,'i,j,k = ',i,j,k
! LIQUID
!      do kr=1,nkr
!       if (ff4r(kr).lt.0)then
!        print*,'i,k,j = ',i,k,j
!        print*,'ff4r 0 = ',kr,ff4r(kr)
!       end if
!      end do

          KRR=0
          DO KR=p_ff1i01,p_ff1i33
          KRR=KRR+1
!          FF1R(KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KR)/XL(KR)/3
           FF1R(KRR)=chem_new(I,K,J,KR)
           IF (FF1R(KRR).LT.0)FF1R(KRR)=0.
          END DO
!        DO KR=1,NKR
!          FF1R(KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KR)/XL(KR)/3
!          IF (FF1R(KR).LT.0)FF1R(KR)=0.
!         END DO   
! CCN
        KRR=0
        DO KR=p_ff8i01,p_ff8i33
          KRR=KRR+1
!         FCCN(KRR)=chem_new(I,K,J,KR)
!         FCCN(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/XCCN(KRR)
          FCCN(KRR)=chem_new(I,K,J,KR)
          if (fccn(krr).lt.0)fccn(krr)=0.
        END DO
        IF (ICEPROCS.EQ.1)THEN
! COLUMNS!
         KRR=0
         DO KR=NKR+1,NKR*2
          KRR=KRR+1
          FF2R(KRR,1)=0.
         END DO
! PLATES!
         KRR=0
         DO KR=NKR*2+1,NKR*3
          KRR=KRR+1
          FF2R(KRR,2)=0.
         END DO
! DENDRITES!
         KRR=0
         DO KR=NKR*3+1,NKR*4
          KRR=KRR+1
          FF2R(KRR,3)=0.
         END DO
! SNOW
           KRR=0
           DO KR=p_ff5i01,p_ff5i33
            KRR=KRR+1
!           FF3R(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3
            FF3R(KRR)=chem_new(I,K,J,KR)
            if (ff3r(krr).lt.0)ff3r(krr)=0.
           END DO

!          KRR=0
!          DO KR=NKR*1+1,NKR*2
!           KRR=KRR+1
!           FF3R(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3
!           if (ff3r(krr).lt.0)ff3r(krr)=0.
!          END DO
! Graupel
           KRR=0
           DO KR=p_ff6i01,p_ff6i33
            KRR=KRR+1
!           FF4R(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3
            FF4R(KRR)=chem_new(I,K,J,KR)
            IF (FF4R(KRR).LT.0)FF4R(KRR)=0.
           END DO

!          KRR=0
!          DO KR=NKR*2+1,NKR*3
!           KRR=KRR+1
!           FF4R(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3
!           IF (FF4R(KRR).LT.0)FF4R(KRR)=0.
!          END DO   
! Hail
         KRR=0
         DO KR=NKR*6+1,NKR*7
          KRR=KRR+1
          FF5R(KRR)=0.
          if (ff5r(krr).lt.0)ff5r(krr)=0.
         END DO
!
!     if (i.eq.43.and.k.eq.6.and.j.eq.41)then
!      print*,'here 2'
!     end if

!      do kr=1,nkr
!       if (ff4r(kr).lt.0)then
!        print*,'i,k,j = ',i,k,j
!        print*,'ff4r 1 = ',kr,ff4r(kr)
!       end if
!      end do
         CALL FREEZ &
     &     (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
     &      T_NEW(I,K,J),DT,rhocgs(I,K,J), &
     &      COL,AFREEZMY,BFREEZMY,BFREEZMAX, &
     &      KRFREEZ,ICEMAX,NKR)
          DO KR=1,NKR
            DO ICE=1,ICEMAX
             FF3R(KR)=FF2IN(KR,ICE)+FF3R(KR)
             FF2IN(KR,ICE)=0
             FF2R(KR,ICE)=0
             FF4R(KR)=FF5R(KR)+FF4R(KR)
             FF5R(KR)=0
            ENDDO
          END DO
         IF (ORIGINAL_MELT)THEN
         CALL ORIG_MELT  &
     &    (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
     &     T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR)
         END IF
         IF (JIWEN_FAN_MELT) THEN
         CALL J_W_MELT &
     &    (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
     &     T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR)
         END IF

        ENDIF
!      do kr=1,nkr
!       if (ff4r(kr).lt.0)then
!        print*,'i,k,j = ',i,k,j
!        print*,'ff4r 2 = ',ff4r(kr)
!       end if
!       end do
!     if(i.eq.64.and.j.eq.2.and.k.eq.16)then
!        print*,'T_NEW(I,K,J) = ',T_NEW(I,K,J)
!        print*,'T_OLD(I,K,J) = ',T_OLD(I,K,J)
!     end if
        DO KR=1,NKR
         DO ICE=1,ICEMAX
             FF3R(KR)=FF3R(KR)+FF2R(KR,ICE)
             FF2R(KR,ICE)=0.
         ENDDO
         FF4R(KR)=FF4R(KR)+FF5R(KR)
         FF5R(KR)=0.
        END DO
!      do kr=1,nkr
!       if (ff4r(kr).lt.0)then
!        print*,'i,k,j = ',i,k,j
!        print*,'ff4r 3 = ',ff4r(kr)
!       end if
!       end do
        IF (T_OLD(I,K,J).GT.233)THEN     
         TT=T_OLD(I,K,J)
         QQ=QV_OLD(I,K,J)
         IF (QQ.LE.0)  call wrf_message("WARNING : SBM FAST: QQ < 0")
         IF (QQ.LE.0)QQ=1.D-10
         PP=pcgs(I,K,J)
         TTA=T_NEW(I,K,J)
         QQA=QV(I,K,J)
         IF (QQA.LE.0) call wrf_message("WARNING : SBM FAST: QQA < 0")
    !     IF (QQA.LE.0)print*,'QQA = ',qqa
    !     IF (QQA.LE.0)print*,'i,k,j = ',i,k,j
    !     IF (QQA.LE.0)print*,'tta = ',tta
    !     IF (QQA.LE.0)print*,'tt = ',tt
    !     IF (QQA.LE.0)print*,'qq = ',qq
         IF (QQA.LE.0)QQA=1.D-10
         ES1N=AA1_MY*DEXP(-BB1_MY/TT)
         ES2N=AA2_MY*DEXP(-BB2_MY/TT)
         EW1N=QQ*PP/(0.622+0.378*QQ)
         DIV1=EW1N/ES1N
!     if(i.eq.64.and.j.eq.2.and.k.eq.16)then
!        print*,'T_NEW(I,K,J) = ',T_NEW(I,K,J)
!        print*,'tt = ',tt
!        print*,'qq = ',qq
!        print*,'tta = ',tta
!        print*,'qqa = ',qqa
!        print*,'ES1N = ',ES1N
!        print*,'ES2N = ',ES2N
!        print*,'EW1N = ',EW1N
!        print*,'DIV1 = ',DIV1
!        print*,'pp = ',pp
!        print*,'zcgs = ',zcgs(i,k,j)
!     end if

         DEL1IN=EW1N/ES1N-1.
         DIV2=EW1N/ES2N
         DEL2IN=EW1N/ES2N-1.
         ES1N=AA1_MY*DEXP(-BB1_MY/TTA)
         ES2N=AA2_MY*DEXP(-BB2_MY/TTA)
         EW1N=QQA*PP/(0.622+0.378*QQA)
         DIV3=EW1N/ES1N
         DEL1AD=EW1N/ES1N-1.
         DIV4=EW1N/ES2N
         DEL2AD=EW1N/ES2N-1.
         SUP2_OLD=DEL2IN
         DELSUP1=(DEL1AD-DEL1IN)/NCOND
         DELSUP2=(DEL2AD-DEL2IN)/NCOND
         DELDIV1=(DIV3-DIV1)/NCOND
         DELDIV2=(DIV4-DIV2)/NCOND
         DELTATEMP=0
         DELTAQ=0
         tt_old = TT
         qq_old = qq
!     if (i.eq.43.and.k.eq.6.and.j.eq.41)then
!      print*,'here 4'
!     end if
         DIFFU=1
         DO IKL=1,NCOND
          IF (DIFFU.NE.0)THEN
          DEL1IN=DEL1IN+DELSUP1
          DEL2IN=DEL2IN+DELSUP2
          DIV1=DIV1+DELDIV1
          DIV2=DIV2+DELDIV2
          END IF
!959       format (' ',i3,1x,f7.1,1x,f6.1,1x,f6.4,1x,f6.2,1x,f6.3)
          IF (DIV1.GT.DIV2.AND.TT.LE.265)THEN
           call wrf_error_fatal("fatal error in module_mp_fast_sbm (DIV1>DIV2), model stop")
           DIFFU=0
          END IF
          IF (DIFFU.NE.0)THEN
          DEL1NR=A1_MYN*(100.*DIV1)
          DEL2NR=A2_MYN*(100.*DIV2)
 !         IF (DEL2NR.EQ.0) PRINT*,'DEL2NR = 0'
          IF (DEL2NR.EQ.0)call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL2NR.EQ.0), model stop")
          DEL12R=DEL1NR/DEL2NR
          DEL12RD=DEL12R**DEL_BBR
          EW1PN=AA1_MY*100.*DIV1*DEL12RD/100.
!          IF (DEL12R.EQ.0)PRINT*,'DEL12R = 0'
          IF (DEL12R.EQ.0)call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL12R.EQ.0), model stop")
          TT=-DEL_BB/DLOG(DEL12R)
          QQ=0.622*EW1PN/(PP-0.378*EW1PN)
          DO KR=1,NKR
            FF1IN(KR)=FF1R(KR)
            DO ICE=1,ICEMAX
             FF2IN(KR,ICE)=FF2R(KR,ICE)
            ENDDO
          ENDDO
          IF (BULKNUC.eq.1)THEN
            IF (DEL1IN.GT.0)THEN
              IF (zcgs(I,K,J).LE.500.E2)THEN
                FACTZ=0.
              ELSE
                FACTZ=1
!               FACTZ=EXP(-(zcgs(I,K,J)-2.E5)/Z0IN)
              END IF
             CONCCCN_XZ=FACTZ*ACCN*(100.*DEL1IN)**BCCN

             CONCDROP=0.D0

             DO KR=1,NKR
               CONCDROP=CONCDROP+FF1IN(KR)*XL(KR)
             ENDDO

             CONCDROP=CONCDROP*3.D0*COL
             IF(CONCCCN_XZ.GT.CONCDROP) &
     &       FF1IN(1)=FF1IN(1)+(CONCCCN_XZ-CONCDROP)/(3.D0*COL*XL(1))
            END IF
          ELSE
            IF(DEL1IN.GT.0.OR.DEL2IN.GT.0)THEN
             CALL JERNUCL01(FF1IN,FF2IN,FCCN &
     &       ,XL,XI,TT,QQ &
     &       ,rhocgs(I,K,J),pcgs(I,K,J) &
     &       ,DEL1IN,DEL2IN &
     &       ,COL,AA1_MY, BB1_MY, AA2_MY,BB2_MY &
     &       ,C1_MEY,C2_MEY,SUP2_OLD,DSUPICE_XYZ(I,K,J) &
     &       ,RCCN,DROPRADII,NKR,ICEMAX,ICEPROCS)
            END IF
          END IF
          DO KR=1,NKR
            DO ICE=1,ICEMAX
             FF3R(KR)=FF3R(KR)+FF2IN(KR,ICE)
             FF2IN(KR,ICE)=0.
             FF2R(KR,ICE)=0.
            END DO
          END DO
          DO KR=1,NKR
            FF1R(KR)=FF1IN(KR)
!           DO ICE=1,ICEMAX
!            FF2R(KR,ICE)=FF2IN(KR,ICE)
!           ENDDO
          ENDDO
          FMAX1=0.
          FMAX2=0.
          FMAX3=0.
          FMAX4=0.
          FMAX5=0.
          DO KR=1,NKR
            FF1IN(KR)=FF1R(KR)
            FMAX1=AMAX1(FF1R(KR),FMAX1)
            FF3IN(KR)=FF3R(KR)
            FMAX3=AMAX1(FF3R(KR),FMAX3)
            FF4IN(KR)=FF4R(KR)
            FMAX4=AMAX1(FF4R(KR),FMAX4)
            FF5IN(KR)=FF5R(KR)
            FMAX5=AMAX1(FF5R(KR),FMAX5)
            DO ICE=1,ICEMAX
             FF2IN(KR,ICE)=FF2R(KR,ICE)
             FMAX2=AMAX1(FF2R(KR,ICE),FMAX2)
            END DO
          END DO
          ISYM1=0
          ISYM2=0
          ISYM3=0
          ISYM4=0
          ISYM5=0
          IF(FMAX1.GT.0)ISYM1=1
          IF (ICEPROCS.EQ.1)THEN
           IF(FMAX2.GT.1.E-4)ISYM2=1
           IF(FMAX3.GT.1.E-4)ISYM3=1
           IF(FMAX4.GT.1.E-4)ISYM4=1
           IF(FMAX5.GT.1.E-4)ISYM5=1
          END IF
! Avoid Diffusional Growth
!         IF (T_OLD(I,K,J).GE.237)THEN     
! Same temperature range as above.
          IF (T_OLD(I,K,J).GT.233)THEN     
          IF(ISYM1.EQ.1.AND.((TT-273.15).GT.-0.187.OR. &
     &     (ISYM2.EQ.0.AND. &
     &     ISYM3.EQ.0.AND.ISYM4.EQ.0.AND.ISYM5.EQ.0)))THEN
           CALL ONECOND1(TT,QQ,PP,rhocgs(I,K,J) &
     &      ,VR1,pcgs(I,K,J) &
     &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
     &      ,FF1R,FF1IN,XL,RLEC,RO1BL &
     &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
     &      ,C1_MEY,C2_MEY &
     &      ,COL,DTCOND,ICEMAX,NKR)
          ELSE IF(ISYM1.EQ.0.AND.(TT-273.15).LE.-0.187.AND. &
     &     (ISYM2.EQ.1.OR.ISYM3.EQ.1.OR.ISYM4.EQ.1.OR.ISYM5.EQ.1))THEN
           CALL ONECOND2(TT,QQ,PP,rhocgs(I,K,J) &
     &      ,VR2,VR3,VR4,VR5,pcgs(I,K,J) &
     &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
     &      ,FF2R,FF2IN,XI,RIEC,RO2BL &
     &      ,FF3R,FF3IN,XS,RSEC,RO3BL &
     &      ,FF4R,FF4IN,XG,RGEC,RO4BL &
     &      ,FF5R,FF5IN,XH,RHEC,RO5BL &
     &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
     &      ,C1_MEY,C2_MEY &
     &      ,COL,DTCOND,ICEMAX,NKR &
     &      ,ISYM2,ISYM3,ISYM4,ISYM5)
          ELSE IF(ISYM1.EQ.1.AND.(TT-273.15).LE.-0.187.AND. &
     &     (ISYM2.EQ.1.OR.ISYM3.EQ.1.OR.ISYM4.EQ.1 &
     &     .OR.ISYM5.EQ.1))THEN
           CALL ONECOND3(TT,QQ,PP,rhocgs(I,K,J) &
     &      ,VR1,VR2,VR3,VR4,VR5,pcgs(I,K,J) &
     &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
     &      ,FF1R,FF1IN,XL,RLEC,RO1BL &
     &      ,FF2R,FF2IN,XI,RIEC,RO2BL &
     &      ,FF3R,FF3IN,XS,RSEC,RO3BL &
     &      ,FF4R,FF4IN,XG,RGEC,RO4BL &
     &      ,FF5R,FF5IN,XH,RHEC,RO5BL &
     &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
     &      ,C1_MEY,C2_MEY &
     &      ,COL,DTCOND,ICEMAX,NKR &
     &      ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
          END IF
          DO KR=1,NKR
            DO ICE=1,ICEMAX
             FF3R(KR)=FF3R(KR)+FF2R(KR,ICE)
             FF2R(KR,ICE)=0
            END DO
            FF4R(KR)=FF4R(KR)+FF5R(KR)
            FF5R(KR)=0
          END DO
          END IF
          END IF
             IF (IKL.EQ.NCOND)CALL COAL_BOTT_NEW(FF1R,FF2R,FF3R, &
     &       FF4R,FF5R,TT,QQ,PP,rhocgs(I,K,J),dt_coll,TCRIT,TTCOAL)
         END DO
         IF (DIFFU.EQ.0)THEN
         th_phy(i,k,j) = tt_old/pi_phy(i,k,j)
         qv(i,k,j)=qq_old
    !     print*,'tt_old = ',tt_old
    !     print*,'qq_old = ',qq_old
         ELSE
         th_phy(i,k,j) = tt/pi_phy(i,k,j)
         qv(i,k,j)=qq
         END IF
        END IF
! LIQIUD
        IF (REMSAT.EQ.1)THEN
        DO KR=1,NKR
         FF1R(KR)=0.
         FCCN(KR)=0
         IF (ICEPROCS.EQ.1)THEN
          FF2R(KR,1)=0.
          FF2R(KR,2)=0.
          FF2R(KR,3)=0.
          FF3R(KR)=0.
          FF4R(KR)=0.
          FF5R(KR)=0.
         END IF
        END DO
        END IF
        KRR=0
        DO KR=p_ff1i01,p_ff1i33
          KRR=KRR+1
          chem_new(I,K,J,KR)=FF1R(KRR)
        END DO   
! CCN
        KRR=0
        DO KR=p_ff8i01,p_ff8i33
          KRR=KRR+1
!         chem_new(I,K,J,KR)=FCCN(KRR)
!         chem_new(I,K,J,KR)=FCCN(KRR)/RHOCGS(I,K,J)*XCCN(KRR)
          chem_new(I,K,J,KR)=FCCN(KRR)
        END DO
        IF (ICEPROCS.EQ.1)THEN
         KRR=0
         DO KR=p_ff5i01,p_ff5i33
          KRR=KRR+1
!         chem_new(I,K,J,KR)=FF3R(KRR)
!         chem_new(I,K,J,KR)=FF3R(KRR)*(1./RHOCGS(I,K,J))*COL*XS(KRR)*XS(KRR)*3
          chem_new(I,K,J,KR)=FF3R(KRR)
         END DO
! Graupel
         KRR=0
         DO KR=p_ff6i01,p_ff6i33
          KRR=KRR+1
!         chem_new(I,K,J,KR)=FF4R(KRR)
!         chem_new(I,K,J,KR)=FF4R(KRR)*(1./RHOCGS(I,K,J))*COL*XG(KRR)*XG(KRR)*3
          chem_new(I,K,J,KR)=FF4R(KRR)
         END DO
        END IF
      END DO
      END DO
      END DO
      NKRO=1
      NKRE=NKR
      DO j = jts,jte
      DO i = its,ite
      DO k = kts,kte
      rhocgs_z(k)=rhocgs(i,k,j)
      pcgs_z(k)=pcgs(i,k,j)
      zcgs_z(k)=zcgs(i,k,j)
      krr=0
      do kr=p_ff1i01,p_ff1i33
       krr=krr+1
       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
      end do
      end do
      CALL FALFLUXHUCM(ffx_z,VR1,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
      DO k = kts,kte
      krr=0
      do kr=p_ff1i01,p_ff1i33
       krr=krr+1
       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
      end do
      end do
      if (iceprocs.eq.1)then
      DO k = kts,kte
      rhocgs_z(k)=rhocgs(i,k,j)
      pcgs_z(k)=pcgs(i,k,j)
      zcgs_z(k)=zcgs(i,k,j)
      krr=0
      do kr=p_ff5i01,p_ff5i33
       krr=krr+1
       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
      end do
      end do
      CALL FALFLUXHUCM(ffx_z,VR3,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
      DO k = kts,kte
      krr=0
      do kr=p_ff5i01,p_ff5i33
       krr=krr+1
       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
      end do
      end do
      DO k = kts,kte
      rhocgs_z(k)=rhocgs(i,k,j)
      pcgs_z(k)=pcgs(i,k,j)
      zcgs_z(k)=zcgs(i,k,j)
      krr=0
      do kr=p_ff6i01,p_ff6i33
       krr=krr+1
       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
      end do
      end do
      CALL FALFLUXHUCM(ffx_z,VR4,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
      DO k = kts,kte
      krr=0
      do kr=p_ff6i01,p_ff6i33
       krr=krr+1
       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
      end do
      end do
!    &     ims,ime,jms,jme,kms,kme)
      end if
     end do 
     end do 

      gmax=0
      qmax=0
      imax=0
      kmax=0
      qnmax=0
      inmax=0
      knmax=0
      DO j = jts,jte
      DO i = its,ite
      DO k = kts,kte
      QC(I,K,J)=0
      QR(I,K,J)=0
!     QI(I,K,J)=0
!     QIC(I,K,J)=0
!     QIP(I,K,J)=0
!     QID(I,K,J)=0
      QI(I,K,J)=0
      QS(I,K,J)=0
      QG(I,K,J)=0
      QNC(I,K,J)=0
      QNR(I,K,J)=0
      QNS(I,K,J)=0
      QNG(I,K,J)=0
      QNA(I,K,J)=0
!     EFFR(I,K,J)=0
!     if (mod(itimestep,t_print).eq.0)then
      tt= th_phy(i,k,j)*pi_phy(i,k,j)
      DO KR=1,NKR
      COLREFLL(KR)=COEFREFLL
      COLREFLI(KR)=COEFREFLI
        IF(TT.GE.271.15.AND.TT.LE.273.15) THEN
               COLREFLS(KR)=COEFREF00/0.09
               COLREFLG(KR)=COEFREF00/RO4BL(KR)/RO4BL(KR)
               COLREFLH(KR)=COEFREF00/RO5BL(KR)/RO5BL(KR)
        ELSE
               COLREFLS(KR)=COEFREFLI
               COLREFLG(KR)=COEFREFLI
               COLREFLH(KR)=COEFREFLI
        ENDIF
      END DO
!     END IF
      EFF_N=0.
      EFF_D=0.
      krr=0
      DO kr= p_ff1i01,p_ff1i33
          KRR=KRR+1
        IF (KRR.LT.KRDROP)THEN
          EFF_N=DROPRADII(KRR)**3*chem_new(i,k,j,KR)*XL(KRR)+EFF_N
          EFF_D=DROPRADII(KRR)**2*chem_new(i,k,j,KR)*XL(KRR)+EFF_D
          QC(I,K,J)=QC(I,K,J) &
     &      +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3
!          QNC(I,K,J)=QNC(I,K,J) &
! J. Fan
!     &      +COL*chem_new(I,K,J,KR)*XL(KR)*3
           QNC(I,K,J)=QNC(I,K,J) &
    &       +COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg
        ELSE
          QR(I,K,J)=QR(I,K,J) &
     &      +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3
          QNR(I,K,J)=QNR(I,K,J) &
     &      +COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
        END IF
      END DO
!     IF(QC(I,K,J).GT.1.E-6.and.EFF_D.GT.0)THEN
!         EFFR(I,K,J)=EFF_N/EFF_D
!     END IF
      KRR=0
      IF (ICEPROCS.EQ.1)THEN
       KRR=0
       DO  KR=p_ff5i01,p_ff5i33
        KRR=KRR+1
        if (KRR.LE.KRICE)THEN
        QI(I,K,J)=QI(I,K,J) &
     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3
        ELSE
        QS(I,K,J)=QS(I,K,J) &
     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3
        END IF
        QNS(I,K,J)=QNS(I,K,J) &
!     &   +1000*COL*chem_new(I,K,J,KR)*XS(KRR)*3
     &   +COL*chem_new(I,K,J,KR)*XS(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
       END DO
       KRR=0
       DO  KR=p_ff6i01,p_ff6i33
        KRR=KRR+1
        QG(I,K,J)=QG(I,K,J) &
     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XG(KRR)*XG(KRR)*3
        QNG(I,K,J)=QNG(I,K,J) &
!     &   +1000*COL*chem_new(I,K,J,KR)*XG(KRR)*3
     &   +COL*chem_new(I,K,J,KR)*XG(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
       END DO
      END IF
       KRR=0
       DO  KR=p_ff8i01,p_ff8i33
        KRR=KRR+1
        QNA(I,K,J)=QNA(I,K,J) &
!     &   +COL*chem_new(I,K,J,KR)*3
!  change by J.Fan
     &   +COL*chem_new(I,K,J,KR)/rhocgs(I,K,J)*1000.   ! #/kg
       END DO

      END DO
      END DO
      END DO



998   format(' ',10(f10.1,1x))
      DO j = jts,jte
      DO i = its,ite
       krr=0
       DO KR=p_ff1i01,p_ff1i33
        krr=krr+1
        DELTAW=VR1(KRR)
        RAINNC(I,J)=RAINNC(I,J) &
     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
     &           chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
       END DO
       KRR=0
       DO KR= p_ff5i01,p_ff5i33
        KRR=KRR+1
        DELTAW=VR3(KRR)
        RAINNC(I,J)=RAINNC(I,J) &
     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
     &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
       END DO
       KRR=0
       DO KR=p_ff6i01,p_ff6i33
        KRR=KRR+1
        DELTAW=VR4(KRR)
        RAINNC(I,J)=RAINNC(I,J) &
     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
     &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
       END DO
      do k=kts,kte


          qv1d(k)=qv(i,k,j)
          qr1d(k)=qr(i,k,j)
          nr1d(k)=qnr(i,k,j)
          qs1d(k)=qs(i,k,j)
          ns1d(k)=qns(i,k,j)
          qg1d(k)=qg(i,k,j)
          ng1d(k)=qng(i,k,j)
          t1d(k)=th_phy(i,k,j)*pi_phy(i,k,j)
          p1d(k)=P_PHY(I,K,J)
       end do
! wrf-chem

!+---+-----------------------------------------------------------------+
         IF ( PRESENT (diagflag) ) THEN
         if (diagflag .and. do_radar_ref == 1) then
          call refl10cm_hm (qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d,   &
                      t1d, p1d, dBZ, kts, kte, i, j)
          do k = kts, kte
             refl_10cm(i,k,j) = MAX(-35., dBZ(k))
          enddo
         endif
         ENDIF

!     print*, i,j,rainnc(i,j)
      END DO
      END DO


      do j=jts,jte
      do k=kts,kte
      do i=its,ite
         th_old(i,k,j)=th_phy(i,k,j)
         qv_old(i,k,j)=qv(i,k,j)
      end do
      end do
      end do
      if (conserv)then
      DO j = jts,jte
      DO i = its,ite
      DO k = kts,kte
      rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
      krr=0
      DO KR=p_ff1i01,p_ff1i33
        krr=krr+1
       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XL(KRR)*XL(KRR)*3.0
      END DO
      KRR=0
      DO KR=p_ff5i01,p_ff5i33
       KRR=KRR+1
       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XS(KRR)*XS(KRR)*3.0
      END DO
      KRR=0
      DO KR=p_ff6i01,p_ff6i33
       KRR=KRR+1
       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XG(KRR)*XG(KRR)*3.0
      END DO
      KRR=0
      DO KR=p_ff8i01,p_ff8i33
       KRR=KRR+1
! change by Fan
!       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*XCCN(KRR)
       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)
      END DO
      END DO
      END DO
      END DO
      END IF
     
      RETURN
  END SUBROUTINE FAST_SBM
      SUBROUTINE FALFLUXHUCM(chem_new,VR1,RHOCGS,PCGS,ZCGS,DT, &
     &     kts,kte,nkr)
      IMPLICIT NONE
      INTEGER I,J,K,KR
      INTEGER    kts,kte,nkr
      REAL TFALL,DTFALL,VFALL(KTE),DWFLUX(KTE)
      REAL DT
      INTEGER IFALL,N,NSUB
      REAL, DIMENSION( kts:kte,nkr ) :: chem_new 
      REAL,  DIMENSION(kts:kte) :: rhocgs,pcgs,zcgs
      REAL VR1(NKR)

! FALLING FLUXES FOR EACH KIND OF CLOUD PARTICLES: C.G.S. UNIT
! ADAPTED FROM GSFC CODE FOR HUCM
!  The flux at k=1 is assumed to be the ground so FLUX(1) is the
! flux into the ground. DWFLUX(1) is at the lowest half level where
! Q(1) etc are defined. The formula for FLUX(1) uses Q(1) etc which
! is actually half a grid level above it. This is what is meant by
! an upstream method. Upstream in this case is above because the
! velocity is downwards.      
! USE UPSTREAM METHOD (VFALL IS POSITIVE)                 
!        print*,'pcgs(i,k,j) = ',pcgs(100,10,1)
!        print*,'pcgs(i,k,j) = ',pcgs(100,1,1)
!      read(5,*)
!        print*,'pcgs(i,k,j) = ',zcgs(100,10,1)
!        print*,'pcgs(i,k,j) = ',zcgs(100,1,1)
!      read(5,*)
      DO KR=1,NKR
       IFALL=0
       DO k = kts,kte
          IF(chem_new(K,KR).GE.1.E-10)IFALL=1
       END DO 
       IF (IFALL.EQ.1)THEN
        TFALL=1.E10                
        DO K=kts,kte
         VFALL(K) = VR1(KR)*SQRT(1.E6/PCGS(K))
!        if (krr.eq.20.or.krr.eq.33)then
!        if (k.eq.5.or.k.eq.10.or.k.eq.20)then
!        print*,'vr1(krr) = ',krr,vr1(krr)
!        print*, 'SQRT(1.E6/PCGS(I,K,J)) = ',i,k,SQRT(1.E6/PCGS(I,K,J))
!        print*,'vfall(k) = ',i,k,vfall(k)
!        print*,'zcgs(k) = ',i,k,zcgs(i,k,j)
!        read(5,*)
!        end if
!        end if
         TFALL=AMIN1(TFALL,ZCGS(K)/(VFALL(K)+1.E-20))    
!        print*,'tfall = ',i,k,tfall
!        if (krr.eq.5.or.krr.eq.10.or.krr.eq.20.or.krr.eq.33)read(5,*)
        END DO                                                 
        IF(TFALL.GE.1.E10)call wrf_error_fatal("fatal error in module_mp_fast_sbm (TFALL.GE.1.E10), model stop")
        NSUB=(INT(2.0*DT/TFALL)+1)                           
        DTFALL=DT/NSUB                                      

        DO N=1,NSUB                                    
          DO K=KTS,KTE-1                               
           DWFLUX(K)=-(RHOCGS(K)*VFALL(K)*chem_new(k,kr)- &
     &     RHOCGS(K+1)* &
     &     VFALL(K+1)*chem_new(K+1,KR))/(RHOCGS(K)*(ZCGS(K+1)- &
     &      ZCGS(K)))    
          END DO    
! NO Z ABOVE TOP, SO USE THE SAME DELTAZ
          DWFLUX(KTE)=-(RHOCGS(KTE)*VFALL(KTE)* & 
     &       chem_new(kte,kr))/(RHOCGS(KTE)*(ZCGS(KTE)-ZCGS(KTE-1)))         
          DO K=kts,kte                                         
           chem_new(k,kr)=chem_new(k,kr)+DWFLUX(K)*DTFALL
          END DO  
        END DO  
       END IF
      END DO  
      RETURN                                                                  
      END SUBROUTINE FALFLUXHUCM                                                                    
      SUBROUTINE FAST_HUCMINIT(DT)
      IMPLICIT NONE
      INTEGER IKERN_0,IKERN_Z,L0_REAL,L0_INTEGER,INEWMEY,INEST
      INTEGER I,J,K,KR
      REAL DT
      INTEGER :: hujisbm_unit1
      LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
      LOGICAL :: opened 
      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
      CHARACTER*80 errmess
      REAL PI
      double precision ax
      data pi/3.141592654/
! dtime - timestep of integration (calculated in main program) :
! ax - coefficient used for masses calculation 
! ima(i,j) - k-category number, c(i,j) - courant number 

        REAL C1(NKR,NKR)
! DON'T NEED ALL THESE VARIABLES: STILL NEED EDITING
       INTEGER ICE,KGRAN,IPRINT01
       REAL TWSIN,TWCIN,TWNUC,XF5,XF4,XF3,CONCHIN,CONCGIN,CONCSIN, &
     & CONCCLIN,TWHIN,RADH,RADS,RADG,RADL,CONCLIN,A1_MY,A2,A2_MY,XLK, &
     & A1N,A3_MY,A3,A1_MYN,R0CCN,X0DROP,DEG01,CONTCCNIN,CONCCCNIN, &
     & A,B,X0CCN,S_KR,RCCNKR,R0,X0,TWCALLIN,A1,RCCNKR_CM,SUMIIN,TWGIN, &
     & XF1N,XF1,WC1N,RF1N,WNUC,RNUC,WC5,RF5, &
     & WC4,RF4,WC3,RF3,WC1,RF1,SMAX
       REAL TWIIN(ICEMAX)
       REAL RO_SOLUTE      
       REAL A_FALL,B_FALL
       real graupel_fall(nkr)
       data graupel_fall/0.36840E-01,0.57471E-01,0.88417E-01,0.13999E+00,&
     &  0.22841E+00,0.36104E+00,0.56734E+00, 0.88417E+00, 0.13999E+01,&
     &  0.22104E+01, 0.35367E+01, 0.54524E+01, 0.81049E+01,0.12526E+02,&
     &  0.19157E+02, 0.27262E+02, 0.34627E+02, 0.39776E+02,0.45690E+02,& 
     &  0.52485E+02, 0.60289E+02, 0.69254E+02, 0.10000E+03, 0.15429E+03,&
     &  0.18561E+03, 0.22329E+03, 0.26863E+03,  0.32316E+03,0.38877E+03,& 
     &  0.46770E+03, 0.56266E+03, 0.67690E+03,  0.81432E+03/

       PARAMETER (RO_SOLUTE=2.16)
       INTEGER KR_MIN,KR_MIN1,KR_MAX
       REAL RADCCN_MIN,RADCCN_MIN1,RADCCN_MAX
     REAL  ::      RHOSU       ! STANDARD AIR DENSITY AT 850 MB
     REAL ::      RHOW        ! DENSITY OF LIQUID WATER
     REAL ::      RHOI        ! BULK DENSITY OF CLOUD ICE
     REAL ::      RHOSN       ! BULK DENSITY OF SNOW
     REAL ::      RHOG        ! BULK DENSITY OF GRAUPEL
     REAL ::      CI,DI,CS,DS,CG,DG ! SIZE DISTRIBUTION PARAMETERS FOR CLOUD ICE, SNOW, GRAUPE

       REAL FR_CON,FR_MAR
       FR_MAR=1.0
!      FR_CON=1-FR_MAR
       FR_CON=1.0
 !       PRINT*, 'INITIALIZING HUCM'  
!	print *, ' ****** HUCM *******'
       call wrf_message("SBM FAST: INITIALIZING HUCM")

! INPUT :
        dlnr=dlog(2.d0)/(3.d0*scal)
!     print*,'here in hucmint 1'
!
!--- Read in various lookup tables
!
    !    print*,'wrf_dm_on_monitor() =',wrf_dm_on_monitor() 
        IF ( wrf_dm_on_monitor() ) THEN
          DO i = 31,99
            INQUIRE ( i , OPENED = opened )
            IF ( .NOT. opened ) THEN
              hujisbm_unit1 = i
              GOTO 2061
            ENDIF
          ENDDO
          hujisbm_unit1 = -1
 2061     CONTINUE
        ENDIF
!
!     print*,'here in hucmint 2',hujisbm_unit1
        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!     print*,'here in hucmint 3',hujisbm_unit1
!
        IF ( hujisbm_unit1 < 0 ) THEN
          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
        ENDIF
!
!       print*,'here at 1'
!      print*,'here in hucmint 4'
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(UNIT=hujisbm_unit1,FILE="capacity.asc",                  &
     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)

  900	FORMAT(6E13.5)
	READ(hujisbm_unit1,900) RLEC,RIEC,RSEC,RGEC,RHEC
	CLOSE(hujisbm_unit1)
!     print*,'here in hucmint 5'
        END IF
        CALL wrf_dm_bcast_bytes ( RLEC , size ( RLEC ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( RIEC , size ( RIEC ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( RSEC , size ( RSEC ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( RGEC , size ( RGEC ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( RHEC , size ( RHEC ) * RWORDSIZE )
! MASSES :
        IF ( wrf_dm_on_monitor() ) THEN
          DO i = 31,99
            INQUIRE ( i , OPENED = opened )
            IF ( .NOT. opened ) THEN
              hujisbm_unit1 = i
              GOTO 2062
            ENDIF
          ENDDO
          hujisbm_unit1 = -1
 2062     CONTINUE
        ENDIF
!
        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
        IF ( hujisbm_unit1 < 0 ) THEN
          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
        ENDIF
!
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(UNIT=hujisbm_unit1,FILE="masses.asc",                  &
     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
	READ(hujisbm_unit1,900) XL,XI,XS,XG,XH          
	CLOSE(hujisbm_unit1)
!	print *, ' ***** file2: succesfull *******'
        call wrf_message("SBM FAST: file2: succesfull")
        ENDIF
        CALL wrf_dm_bcast_bytes ( XL , size ( XL ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( XI , size ( XI ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( XS , size ( XS ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( XG , size ( XG ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( XH , size ( XH ) * RWORDSIZE )
! TERMINAL VELOSITY :
        IF ( wrf_dm_on_monitor() ) THEN
          DO i = 31,99
            INQUIRE ( i , OPENED = opened )
            IF ( .NOT. opened ) THEN
              hujisbm_unit1 = i
              GOTO 2063
            ENDIF
          ENDDO
          hujisbm_unit1 = -1
 2063     CONTINUE
        ENDIF
!
        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
        IF ( hujisbm_unit1 < 0 ) THEN
          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
        ENDIF
!
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(UNIT=hujisbm_unit1,FILE="termvels.asc",                  &
     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
	READ(hujisbm_unit1,900) VR1,VR2,VR3,VR4,VR5     
	CLOSE(hujisbm_unit1)
!	print *, ' ***** file3: succesfull *******'
        call wrf_message("SBM FAST: file3: succesfull")
        ENDIF
        CALL wrf_dm_bcast_bytes ( VR1 , size ( VR1 ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( VR2 , size ( VR2 ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( VR3 , size ( VR3 ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( VR4 , size ( VR4 ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( VR5 , size ( VR5 ) * RWORDSIZE )
! CHANGE FALL VELOCITY OF GRAUPEL
        DO KR=1,NKR
!        A=RADXXO(KR,6)
!        B=RADXXO(KR,7)
         if (kr.le.17)then
          A_FALL=1
          B_FALL=0
         else
          B_FALL=1
          A_FALL=0
         end if
  
!        VR4(KR)=A_FALL*VR4(KR)+B_FALL*VR5(KR)
!        print*,'vr4,vr5,graupel_fall=',vr3(kr),vr5(kr),graupel_fall(kr)
         VR4(KR)=graupel_fall(kr)
        END DO
 
! CONSTANTS :
        IF ( wrf_dm_on_monitor() ) THEN
          DO i = 31,99
            INQUIRE ( i , OPENED = opened )
            IF ( .NOT. opened ) THEN
              hujisbm_unit1 = i
              GOTO 2065
            ENDIF
          ENDDO
          hujisbm_unit1 = -1
 2065     CONTINUE
        ENDIF
!
        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
        IF ( hujisbm_unit1 < 0 ) THEN
          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
        ENDIF
!
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(UNIT=hujisbm_unit1,FILE="constants.asc",                  &
     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
	READ(hujisbm_unit1,900) SLIC,TLIC,COEFIN,C2,C3,C4
	CLOSE(hujisbm_unit1)
!	print *, ' ***** file4: succesfull *******'
        call wrf_message("SBM FAST: file4: succesfull")
        END IF
        CALL wrf_dm_bcast_bytes ( SLIC , size ( SLIC ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( TLIC , size ( TLIC ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( COEFIN , size ( COEFIN ) * RWORDSIZE )
!       CALL wrf_dm_bcast_bytes ( C2 , size ( C2 ) * RWORDSIZE )
!       CALL wrf_dm_bcast_bytes ( C3 , size ( C3 ) * RWORDSIZE )
!       CALL wrf_dm_bcast_bytes ( C4 , size ( C4 ) * RWORDSIZE )
! CONSTANTS :
! KERNELS DEPENDING ON PRESSURE :
        IF ( wrf_dm_on_monitor() ) THEN
          DO i = 31,99
            INQUIRE ( i , OPENED = opened )
            IF ( .NOT. opened ) THEN
              hujisbm_unit1 = i
              GOTO 2066
            ENDIF
          ENDDO
          hujisbm_unit1 = -1
 2066     CONTINUE
        ENDIF
!
        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
        IF ( hujisbm_unit1 < 0 ) THEN
          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
        ENDIF
!
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(UNIT=hujisbm_unit1,FILE="kernels_z.asc",                  &
     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
        READ(hujisbm_unit1,900)  &
     &  YWLL_1000MB,YWLL_750MB,YWLL_500MB
	CLOSE(hujisbm_unit1)
        END IF
        CALL wrf_dm_bcast_bytes ( YWLL_1000MB , size ( YWLL_1000MB ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWLL_750MB , size ( YWLL_750MB ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWLL_500MB , size ( YWLL_500MB ) * RWORDSIZE )
        IF ( wrf_dm_on_monitor() ) THEN
          DO i = 31,99
            INQUIRE ( i , OPENED = opened )
            IF ( .NOT. opened ) THEN
              hujisbm_unit1 = i
              GOTO 2067
            ENDIF
          ENDDO
          hujisbm_unit1 = -1
 2067     CONTINUE
        ENDIF
!
        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
        IF ( hujisbm_unit1 < 0 ) THEN
          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
        ENDIF
!
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(UNIT=hujisbm_unit1,FILE="kernels.asc_s_0_03_0_9",                  &
     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
! KERNELS NOT DEPENDING ON PRESSURE :
	READ(hujisbm_unit1,900) &
     &  YWLL,YWLI,YWLS,YWLG,YWLH, &
     &  YWIL,YWII,YWIS,YWIG,YWIH, &
     &  YWSL,YWSI,YWSS,YWSG,YWSH, &
     &  YWGL,YWGI,YWGS,YWGG,YWGH, &
     &  YWHL,YWHI,YWHS,YWHG,YWHH
       close (hujisbm_unit1)
        END IF
        CALL wrf_dm_bcast_bytes ( YWLL , size ( YWLL ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWLI , size ( YWLI ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWLS , size ( YWLS ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWLG , size ( YWLG ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWLH , size ( YWLH ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWIL , size ( YWIL ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWII , size ( YWII ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWIS , size ( YWIS ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWIG , size ( YWIG ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWIH , size ( YWIH ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWSL , size ( YWSL ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWSI , size ( YWSI ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWSS , size ( YWSS ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWSG , size ( YWSG ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWSH , size ( YWSH ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWGL , size ( YWGL ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWGI , size ( YWGI ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWGS , size ( YWGS ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWGG , size ( YWGG ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWGH , size ( YWGH ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWHL , size ( YWHL ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWHI , size ( YWHI ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWHS , size ( YWHS ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWHG , size ( YWHG ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes ( YWHH , size ( YWHH ) * RWORDSIZE )
! BULKDENSITY :
        IF ( wrf_dm_on_monitor() ) THEN
          DO i = 31,99
            INQUIRE ( i , OPENED = opened )
            IF ( .NOT. opened ) THEN
              hujisbm_unit1 = i
              GOTO 2068
            ENDIF
          ENDDO
          hujisbm_unit1 = -1
 2068     CONTINUE
        ENDIF
!
        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
        IF ( hujisbm_unit1 < 0 ) THEN
          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
        ENDIF
!
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(UNIT=hujisbm_unit1,FILE="bulkdens.asc_s_0_03_0_9",         & 
     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
	READ(hujisbm_unit1,900) RO1BL,RO2BL,RO3BL,RO4BL,RO5BL
	CLOSE(hujisbm_unit1)
!	print *, ' ***** file6: succesfull *******'
        call wrf_message("SBM FAST: file6: succesfull")
        END IF
        CALL wrf_dm_bcast_bytes (RO1BL  , size ( RO1BL ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes (RO2BL  , size ( RO2BL ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes (RO3BL  , size ( RO3BL ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes (RO4BL  , size ( RO4BL ) * RWORDSIZE )
        CALL wrf_dm_bcast_bytes (RO5BL  , size ( RO5BL ) * RWORDSIZE )
! BULKRADIUS
        IF ( wrf_dm_on_monitor() ) THEN
          DO i = 31,99
            INQUIRE ( i , OPENED = opened )
            IF ( .NOT. opened ) THEN
              hujisbm_unit1 = i
              GOTO 2069
            ENDIF
          ENDDO
          hujisbm_unit1 = -1
 2069     CONTINUE
        ENDIF
!
        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
        IF ( hujisbm_unit1 < 0 ) THEN
          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
        ENDIF
!
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(UNIT=hujisbm_unit1,FILE="bulkradii.asc_s_0_03_0_9",         & 
     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
	READ(hujisbm_unit1,*) RADXXO
	CLOSE(hujisbm_unit1)
!	print *, ' ***** file7: succesfull *******'
        call wrf_message("SBM FAST: file7: succesfull")
!	PRINT *, '******* Hebrew Univ Cloud model-HUCM *******'
        call wrf_message("SBM FAST: Hebrew Univ Cloud model-HUCM")

        END IF
        CALL wrf_dm_bcast_bytes (RADXXO  , size ( RADXXO ) * RWORDSIZE )
! calculation of the mass(in mg) for categories boundaries :
        ax=2.d0**(1.0/scal)
        xl_mg(1)=0.3351d-7
	do i=2,nkr
           xl_mg(i)=ax*xl_mg(i-1)
!        if (i.eq.22)print*,'printing xl_mg = ',xl_mg(22)
        enddo
	do i=1,nkr
           xs_mg(i)=xs(i)*1.e3
           xg_mg(i)=xg(i)*1.e3
           xh_mg(i)=xh(i)*1.e3
           xi1_mg(i)=xi(i,1)*1.e3
           xi2_mg(i)=xi(i,2)*1.e3
           xi3_mg(i)=xi(i,3)*1.e3
        enddo
! calculation of c(i,j) and ima(i,j) :
! ima(i,j) - k-category number, c(i,j) - courant number 
!       print*, 'calling courant_bott'
        call courant_bott
!       print*, 'called courant_bott'
 

	DEG01=1./3.

!------------------------------------------------------------------

!       print*,'XL(ICCN) = ',ICCN,XL
	X0DROP=XL(ICCN)
!       print*,'X0DROP = ',X0DROP
	X0CCN =X0DROP/(2.**(NKR-1))
	R0CCN =(3.*X0CCN/4./3.141593/ROCCN0)**DEG01
!------------------------------------------------------------------
! THIS TEXT FROM TWOINITM.F_203
!------------------------------------------------------------------
! TEMPERATURA IN SURFACE LAYER EQUAL 15 Celsius(288.15 K)  
        A=3.3E-05/288.15
        B=2.*4.3/(22.9+35.5)
        B=B*(4./3.)*3.14*RO_SOLUTE
        A1=2.*(A/3.)**1.5/SQRT(B)
        A2=A1*100.
!------------------------------------------------------------------
	CONCCCNIN=0.
	CONTCCNIN=0.
	DO KR=1,NKR
           DROPRADII(KR)=(3.*XL(KR)/4./3.141593/1.)**DEG01
        ENDDO
	DO KR=1,NKR
!          print*,'ROCCN0 = ',ROCCN0
!          print*, 'X0CCN = ',X0CCN 
!          print*, 'DEG01 = ',DEG01
	   ROCCN(KR)=ROCCN0
	   X0=X0CCN*2.**(KR-1)
	   R0=(3.*X0/4./3.141593/ROCCN(KR))**DEG01
	   XCCN(KR)=X0
	   RCCN(KR)=R0
!          print*,'RCCN(KR)= ', KR,RCCN(KR)
           RCCNKR_CM=R0
! CCN SPECTRUM 

           S_KR=A2/RCCNKR_CM**1.5
           ACCN=ACCN_CON
           BCCN=BCCN_CON
!          print*,'accn, bccn,S_KR = ',accn,bccn,S_KR
!  CONTINENTAL
           FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN
           FCCNR_CON(KR)=FCCNR(KR)
!  MARITIME
           ACCN=ACCN_MAR
           BCCN=BCCN_MAR
           FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN
           FCCNR_MAR(KR)=FCCNR(KR)

	     CONTCCNIN=CONTCCNIN+COL*FCCNR(KR)*R0*R0*R0
             CONCCCNIN=CONCCCNIN+COL*FCCNR(KR)
	ENDDO
!PRINT *, '********* MAR CCN CONCENTRATION & MASS *******'
!	PRINT 200, CONCCCNIN,CONTCCNIN
! CALCULATION OF FINAL MARITIME
!RCCN(KR)=            1  1.2303877E-07
!RCCN(KR)=            2  1.5501914E-07
!RCCN(KR)=            3  1.9531187E-07
!RCCN(KR)=           16  3.9372408E-06
!RCCN(KR)=           21  1.2499960E-05
!RCCN(KR)=           33  1.9999935E-04
        RADCCN_MAX=RCCN(NKR)
        RADCCN_MIN=0.005E-4         
        RADCCN_MIN1=0.02E-4         
!       print*,'ALOG(RADCCN_MIN) = ',ALOG(RADCCN_MIN)
!       print*,'ALOG(RCCN(1) = ',ALOG(RCCN(1))
!       print*,'ALOG(RADCCN_MAX) = ',ALOG(RADCCN_MAX)
!       KR_MIN=(ALOG(RADCCN_MIN)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
!       KR_MIN1=(ALOG(RADCCN_MIN1)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
        KR_MIN=1.+ 3*(ALOG(RADCCN_MIN)- ALOG(R0CCN))/ALOG(2.)
        KR_MIN1=1.+3*(ALOG(RADCCN_MIN1)- ALOG(R0CCN))/ALOG(2.)
!       KR_MAX=(ALOG(RADCCN_MAX)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
        KR_MAX=1.+3.*(ALOG(RADCCN_MAX)- ALOG(R0CCN))/ALOG(2.)
        KR_MIN=MAX(KR_MIN,1)
        KR_MIN1=MAX(KR_MIN,KR_MIN1)
        KR_MAX=MIN(NKR,KR_MAX)
!       print*,'kr_min,kr_min1 = ',kr_min,kr_min1
!       print*,'kr_max = ',kr_max
! Interpolation
        DO KR=1,NKR
        IF (kr.ge.kr_min.and.kr.lt.kr_min1)then
           FCCNR_MAR(KR)=FCCNR_MAR(KR_MIN1)* &
     &      (ALOG(RCCN(KR))-ALOG(RCCN(KR_MIN)))/ &
     &      (ALOG(RCCN(KR_MIN1))-ALOG(RCCN(KR_MIN)))

        END IF
        IF (KR.GT.KR_MAX.OR.KR.LT.KR_MIN)FCCNR_MAR(KR)=0
!          print*,'FCCNR_MAR(KR) = ',KR,FCCNR_MAR(KR)
        END DO
! CALCULATION OF FINAL CONTINENTAL
        RADCCN_MAX=0.6E-4
        RADCCN_MIN=0.005E-4         
        RADCCN_MIN1=0.02E-4         
!       KR_MIN=(ALOG(RADCCN_MIN)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
!       KR_MIN1=(ALOG(RADCCN_MIN1)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
        KR_MIN=1.+ 3*(ALOG(RADCCN_MIN)- ALOG(R0CCN))/ALOG(2.)
        KR_MIN1=1.+3*(ALOG(RADCCN_MIN1)- ALOG(R0CCN))/ALOG(2.)
!       KR_MAX=(ALOG(RADCCN_MAX)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
        KR_MAX=1.+3.*(ALOG(RADCCN_MAX)- ALOG(R0CCN))/ALOG(2.)
        KR_MIN=MAX(KR_MIN,1)
        KR_MIN1=MAX(KR_MIN,KR_MIN1)
        KR_MAX=MIN(NKR,KR_MAX)
!       print*,'contin kr_min,kr_min1 = ',kr_min,kr_min1
!       print*,'kr_max = ',kr_max
! Interpolation
        DO KR=1,NKR
        IF (kr.ge.kr_min.and.kr.lt.kr_min1)then
           FCCNR_CON(KR)=FCCNR_CON(KR_MIN1)* &
     &      (ALOG(RCCN(KR))-ALOG(RCCN(KR_MIN)))/ &
     &      (ALOG(RCCN(KR_MIN1))-ALOG(RCCN(KR_MIN)))
        END IF
        IF (KR.GT.KR_MAX.OR.KR.LT.KR_MIN)FCCNR_CON(KR)=0
!          print*,'FCCNR_CON(KR) = ',KR,FCCNR_CON(KR)
        END DO
! CALCULATION OF MIXTURE
        DO KR=1,NKR
         FCCNR_MIX(KR)=FR_CON*FCCNR_CON(KR)+FR_MAR*FCCNR_MAR(KR)
!        print*,'FCCNR_MIX(KR) = ',FCCNR_MIX(KR)
        END DO


         CALL BREAKINIT
!        CALL TWOINITMXVAR

!	PRINT *, '**** MIN CCN RADIUS,MASS & DENSITY ***'
!	PRINT 200, R0CCN,X0CCN,ROCCN0
!	PRINT *, '*********  CONT CCN CONCENTRATION & MASS *******'
!	PRINT 200, CONCCCNIN,CONTCCNIN
!	PRINT *, '*********  DROP RADII *******'
!	PRINT 200, DROPRADII
!	PRINT *, '*********  CCN RADII *******'
!	PRINT 200, RCCN
!	PRINT *, '********* CCN MASSES *******'
!	PRINT 200, XCCN
!	PRINT *, '********* INITIAL CCN DISTRIBUTION *******'
        
     

!	IF(IPRINT01.NE.0) THEN

!  PRINT *, '******** INITIAL: TWC,TWI(ICEMAX),TWS ********'
!  PRINT 300, TWCIN,TWIIN,TWSIN
!  PRINT *, '******** INITIAL: CONCLIN ********'
!  PRINT 300, CONCLIN

! IN CASE : IPRINT01.NE.0

!	ENDIF

  100	FORMAT(10I4)
  101   FORMAT(3X,F7.5,E13.5)
  102	FORMAT(4E12.4)
  105	FORMAT(A48)
  106	FORMAT(A80)
  123	FORMAT(3E12.4,3I4)
  200	FORMAT(6E13.5)
  201   FORMAT(6D13.5)
  300	FORMAT(8E14.6) 
  301   FORMAT(3X,F8.3,3X,E13.5)
  302   FORMAT(5E13.5)
!       if (IFREST)THEN
!       dtime=dt*0.5
!       else
!       END IF
        call kernals(dt)
! from morr_two_moment
!..Set these variables needed for computing radar reflectivity.  These
!.. get used within radar_init to create other variables used in the
!.. radar module.
! SIZE DISTRIBUTION PARAMETERS
         RHOW = 997.
         RHOI = 500.
         RHOSN = 100.
!        IF (IHAIL.EQ.0) THEN
!        RHOG = 400.
!        ELSE
!        RHOG = 900.
!        END IF
         RHOG=450


         CI = RHOI*PI_MORR/6.
         DI = 3.
         CS = RHOSN*PI_MORR/6.
         DS = 3.
         CG = RHOG*PI_MORR/6.
         DG = 3.


         xam_r = PI_MORR*RHOW/6.
         xbm_r = 3.
         xmu_r = 0.
         xam_s = CS
         xbm_s = DS
         xmu_s = 0.
         xam_g = CG
         xbm_g = DG
         xmu_g = 0.

         call radar_init

        return
2070  continue
      WRITE( errmess , '(A,I4)' )                                        &
       'module_mp_fast_sbm: error opening hujisbm_DATA on unit '          &
     &, hujisbm_unit1
      CALL wrf_error_fatal(errmess)
        end  subroutine fast_hucminit
      SUBROUTINE BREAKINIT
      IMPLICIT NONE
      INTEGER :: hujisbm_unit1
      LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
      LOGICAL :: opened 
      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
      CHARACTER*80 errmess
!.....INPUT VARIABLES
!
!     GT    : MASS DISTRIBUTION FUNCTION
!     XT_MG : MASS OF BIN IN MG
!     JMAX  : NUMBER OF BINS


!.....LOCAL VARIABLES

      INTEGER AP,IE,JE,KE

      PARAMETER (AP = 1)

      INTEGER I,J,K,JDIFF
      REAL  RPKIJ(JBREAK,JBREAK,JBREAK),RQKJ(JBREAK,JBREAK)


      REAL PI,D0,HLP
      DOUBLE PRECISION M(0:JBREAK),ALM
      REAL DBREAK(JBREAK),GAIN,LOSS
!     REAL ECOALMASS
!     REAL XL(JMAX)


!.....DECLARATIONS FOR INIT

      INTEGER IP,KP,JP,KQ,JQ
      REAL XTJ

      CHARACTER*20 FILENAME_P,FILENAME_Q

      FILENAME_P = 'coeff_p.asc'
      FILENAME_Q = 'coeff_q.asc'

      IE = JBREAK
      JE = JBREAK
      KE = JBREAK
      PI    = 3.1415927
      D0    = 0.0101593
      M(1)  = PI/6.0 * D0**3

!.....IN CGS


!.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID

      JDIFF = JMAX - JBREAK

!.....INITIALIZATION

!     IF (FIRSTCALL.NE.1) THEN

!........CALCULATING THE BREAKUP GRID
!        ALM  = 2.**(1./FLOAT(AP))
         ALM  = 2.d0
         M(0)  = M(1)/ALM
         DO K=1,KE-1
            M(K+1) = M(K)*ALM
         ENDDO
         DO K=1,KE
            BRKWEIGHT(K) = 2./(M(K)**2 - M(K-1)**2)
!           print*,'m(k) = ',m(k)
!           print*,'m(k-1) = ',m(k-1)
!           print*, 'MWEIGHT = ',BRKWEIGHT(K)
         ENDDO

!........OUTPUT

         WRITE (*,*) 'COLL_BREAKUP_INI: COAGULATION AND BREAKUP GRID'
         WRITE (*,'(2A5,5A15)') 'ICOAG','IBREAK', &
     &        'XCOAG','DCOAG', &
     &        'XBREAK','DBREAK','MWEIGHT'

!........READ DER BREAKUP COEFFICIENTS FROM INPUT FILE

         WRITE (*,*) 'COLL_BREAKUP: READ THE BREAKUP COEFFS'
         WRITE (*,*) '              FILE PKIJ: ', FILENAME_P
        IF ( wrf_dm_on_monitor() ) THEN
          DO i = 31,99
            INQUIRE ( i , OPENED = opened )
            IF ( .NOT. opened ) THEN
              hujisbm_unit1 = i
              GOTO 2061
            ENDIF
          ENDDO
          hujisbm_unit1 = -1
 2061     CONTINUE
        ENDIF
!
        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
        IF ( hujisbm_unit1 < 0 ) THEN
          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
        ENDIF
!
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(UNIT=hujisbm_unit1,FILE="coeff_p.asc",                  &
     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)

!         print*,'here at 3'
         DO K=1,KE
            DO I=1,IE
               DO J=1,I
                  READ(hujisbm_unit1,'(3I6,1E16.8)') KP,IP,JP,PKIJ(KP,IP,JP)
!                 WRITE(6,*)'PKIJ(KP,IP,JP) =', &
!    &               KP,IP,JP,PKIJ(KP,IP,JP)
!                 IF(RPKIJ(KP,IP,JP).EQ.0) THEN
!    *             PKIJ(KP,IP,JP)=INT(RPKIJ(KP,IP,JP))
!                 ELSE
!                  PKIJ(KP,IP,JP)=RPKIJ(KP,IP,JP)
!                 END IF
!                 WRITE(6,*)'RPKIJ(KP,IP,JP) =',
!    *               KP,IP,JP,RPKIJ(KP,IP,JP),
!    *               PKIJ(KP,IP,JP)
               ENDDO
            ENDDO
!           READ(6,*)
         ENDDO
	CLOSE(hujisbm_unit1)
         WRITE (*,*) '              FILE QKJ:  ', FILENAME_Q
        END IF
        CALL wrf_dm_bcast_bytes (PKIJ  , size ( PKIJ ) * DWORDSIZE )
        IF ( wrf_dm_on_monitor() ) THEN
          DO i = 31,99
            INQUIRE ( i , OPENED = opened )
            IF ( .NOT. opened ) THEN
              hujisbm_unit1 = i
              GOTO 2062
            ENDIF
          ENDDO
          hujisbm_unit1 = -1
 2062     CONTINUE
        ENDIF
!
        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
!
        IF ( hujisbm_unit1 < 0 ) THEN
          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
        ENDIF
!
        IF ( wrf_dm_on_monitor() ) THEN
          OPEN(UNIT=hujisbm_unit1,FILE="coeff_q.asc",                  &
     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)

         DO K=1,KE
            DO J=1,JE
               READ(hujisbm_unit1,'(2I6,1E16.8)') KQ,JQ,QKJ(KQ,JQ)
!              WRITE(6,*) KQ,JQ,QKJ(KQ,JQ)
!              QKJ(KQ,JQ) = RQKJ(KQ,JQ)
!              IF(QKJ(KQ,JQ).LE.1E-35)QKJ(KQ,JQ)=0.D0
            ENDDO
         ENDDO
         CLOSE(hujisbm_unit1)

         WRITE (*,*) 'COLL_BREAKUP READ: ... OK'
         END IF
        CALL wrf_dm_bcast_bytes (QKJ  , size ( QKJ ) * DWORDSIZE )
!     ENDIF
!        DO K=1,KE
!           DO J=1,JE
!              WRITE(6,*) 'After Broadcast, QKJ = ',K,J,QKJ(K,J)
!           ENDDO
!        ENDDO
!        DO K=1,KE
!           DO I=1,IE
!              DO J=1,I
!                 WRITE(6,*)'After Broadcast PKIJ(K,I,J) =', &
!    &               K,I,J,PKIJ(K,I,J)
!              ENDDO
!           ENDDO
!        ENDDO
      DO I=1,JMAX
         DO J=1,JMAX
              ECOALMASSM(I,J)=1.0D0
         ENDDO
      ENDDO

      DO I=1,JMAX
         DO J=1,JMAX
           ECOALMASSM(I,J)=ECOALMASS(XL(I),XL(J))
         ENDDO
      ENDDO
      RETURN
2070  continue
      WRITE( errmess , '(A,I4)' )                                        &
       'module_mp_fast: error opening hujisbm_DATA on unit '          &
     &, hujisbm_unit1
      CALL wrf_error_fatal(errmess)
      END SUBROUTINE BREAKINIT

      REAL FUNCTION ECOALMASS(ETA,KSI)
      IMPLICIT NONE
!     REAL ECOALMASS
      REAL PI
      PARAMETER (PI = 3.1415927)

      REAL ETA,KSI
      REAL KPI,RHO
      REAL DETA,DKSI

      PARAMETER (RHO  = 1.0)

!     REAL ECOALDIAM
!     EXTERNAL ECOALDIAM

      KPI = 6./PI

      DETA = (KPI*ETA/RHO)**(1./3.)
      DKSI = (KPI*KSI/RHO)**(1./3.)

      ECOALMASS = ECOALDIAM(DETA,DKSI)

      RETURN
      END FUNCTION ECOALMASS


!------------------------------------------------
!     COALESCENCE EFFICIENCY AS FUNC OF DIAMETERS
!------------------------------------------------

      REAL FUNCTION ECOALDIAM(DETA,DKSI)
!     IMPLICIT NONE

      INTEGER N
      REAL DETA,DKSI
      REAL DGR,DKL,RGR,RKL,P,Q,E,X,Y,QMIN,QMAX
      REAL ZERO,ONE,EPS,PI

      PARAMETER (ZERO = 0.0)
      PARAMETER (ONE  = 1.0)
      PARAMETER (EPS  = 1.0E-30)
      PARAMETER (PI   = 3.1415927)

!     REAL   ECOALLOWLIST,ECOALOCHS
!     EXTERNAL ECOALLOWLIST,ECOALOCHS

      DGR = MAX(DETA,DKSI)
      DKL = MIN(DETA,DKSI)

      RGR = 0.5*DGR
      RKL = 0.5*DKL

      P = (RKL / RGR)
      Q = (RKL * RGR)**0.5
      Q = 0.5 * (RKL + RGR)

      qmin = 250e-4
      qmax = 400e-4        
      if (q.lt.qmin) then
         e = max(ecoalOchs(Dgr,Dkl),ecoalBeard(Dgr,Dkl)) 
      elseif (q.ge.qmin.and.q.lt.qmax) then
         x = (q - qmin) / (qmax - qmin)
         e = sin(pi/2.0*x)**2 * ecoalLowList(Dgr,Dkl) &
     &     + sin(pi/2.0*(1 - x))**2 * ecoalOchs(Dgr,Dkl)
      elseif (q.ge.qmax) then
         e = ecoalLowList(Dgr,Dkl)
      else
         e  = 1.0
      endif

      ECOALDIAM  = MAX(MIN(ONE,E),EPS)

      RETURN
      END FUNCTION  ECOALDIAM

!--------------------------------------------------
!     COALESCENCE EFFICIENCY (LOW&LIST)
!--------------------------------------------------

      REAL FUNCTION ECOALLOWLIST(DGR,DKL)
      IMPLICIT NONE
!     REAL ecoallowlist
      REAL PI,SIGMA,KA,KB,EPSI
      REAL DGR,DKL,RGR,RKL,X
      REAL ST,SC,ET,DSTSC,CKE,W1,W2,DC,ECL
      REAL QQ0,QQ1,QQ2

      PARAMETER (EPSI=1.E-20)

      PI = 3.1415927
      SIGMA = 72.8
      KA = 0.778
      KB = 2.61E-4

      RGR = 0.5*DGR
      RKL = 0.5*DKL

      CALL COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC)

      DSTSC = ST-SC
      ET = CKE+DSTSC
      IF (ET .LT. 50.0) THEN
         QQ0=1.0+(DKL/DGR)
         QQ1=KA/QQ0**2
         QQ2=KB*SIGMA*(ET**2)/(SC+EPSI)
         ECL=QQ1*EXP(-QQ2)
      ELSE
         ECL=0.0
      ENDIF

      ECOALLOWLIST = ECL

      RETURN
      END FUNCTION ECOALLOWLIST

!--------------------------------------------------
!     COALESCENCE EFFICIENCY (BEARD AND OCHS)
!--------------------------------------------------

      REAL FUNCTION ECOALOCHS(D_L,D_S)
      IMPLICIT NONE
!     real ecoalochs
      REAL D_L,D_S
      REAL PI,SIGMA,N_W,R_S,R_L,DV,P,G,X,E
!      REAL VTBEARD,EPSF,FPMIN
      REAL EPSF,FPMIN

!     EXTERNAL VTBEARD
      PARAMETER (EPSF  = 1.E-30)
      PARAMETER (FPMIN = 1.E-30)

      PI = 3.1415927
      SIGMA = 72.8

      R_S = 0.5 * D_S
      R_L = 0.5 * D_L
      P   = R_S / R_L

      DV  = ABS(VTBEARD(D_L) - VTBEARD(D_S))
      IF (DV.LT.FPMIN) DV = FPMIN
      N_W = R_S * DV**2 / SIGMA
      G   = 2**(3./2.)/(6.*PI) * P**4 * (1.+ P) / ((1.+P**2)*(1.+P**3))
      X   = N_W**(0.5) * G
      E   = 0.767 - 10.14 * X

      ECOALOCHS = E

      RETURN
      END FUNCTION ECOALOCHS

!-----------------------------------------
!     CALCULATING THE COLLISION ENERGY
!-----------------------------------------

      SUBROUTINE COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC)
!     IMPLICIT NONE

      REAL DGR,DKL,DC
      REAL K10,PI,SIGMA,RHO
      REAL CKE,W1,W2,ST,SC
      REAL DGKA3,DGKB3,DGKA2
      REAL V1,V2,DV
!     REAL VTBEARD,EPSF,FPMIN
      REAL EPSF,FPMIN

!     EXTERNAL VTBEARD
      PARAMETER (EPSF  = 1.E-30)
      PARAMETER (FPMIN = 1.E-30)

      PI    = 3.1415927
      RHO   = 1.0
      SIGMA = 72.8

      K10=RHO*PI/12.0D0

      DGR = MAX(DGR,EPSF)
      DKL = MAX(DKL,EPSF)

      DGKA2=(DGR**2)+(DKL**2)

      DGKA3=(DGR**3)+(DKL**3)

      IF (DGR.NE.DKL) THEN
         V1 = VTBEARD(DGR)
         V2 = VTBEARD(DKL)
         DV = (V1-V2)
         IF (DV.LT.FPMIN) DV = FPMIN
         DV = DV**2
         IF (DV.LT.FPMIN) DV = FPMIN
         DGKB3=(DGR**3)*(DKL**3)
         CKE = K10 * DV * DGKB3/DGKA3
      ELSE
         CKE = 0.0D0
      ENDIF
      ST = PI*SIGMA*DGKA2
      SC = PI*SIGMA*DGKA3**(2./3.)

      W1=CKE/(SC+EPSF)
      W2=CKE/(ST+EPSF)

      DC=DGKA3**(1./3.)

      RETURN
      END SUBROUTINE COLLENERGY

!--------------------------------------------------
!     CALCULATING TERMINAL VELOCITY (BEARD-FORMULA)
!--------------------------------------------------

      REAL FUNCTION VTBEARD(DIAM)
      IMPLICIT NONE
!     REAL VTBEARD

      REAL DIAM,AA
      REAL ROP,RU,AMT,PP,RL,TT,ETA,DENS,CD,D,A
      REAL ALA,GR,SI,BOND,PART,XX,YY,RE,VT
      REAL B00,B11,B22,B33,B44,B55,B0,B1,B2,B3,B4,B5,B6
      INTEGER ID

      DATA B00,B11,B22,B33,B44,B55,B0,B1,B2,B3,B4,B5,B6/-5.00015, &
     &5.23778,-2.04914,.475294,-.0542819,.00238449,-3.18657,.992696, &
     &-.153193E-2,-.987059E-3,-.578878E-3,.855176E-4,-.327815E-5/

      AA   = DIAM/2.0
      ROP  = 1.0
      RU   = 8.3144E+7
      AMT  = 28.9644
      ID   = 10000
      PP   = FLOAT(ID)*100.
      RL   = RU/AMT
      TT   = 283.15
      ETA  = (1.718+.0049*(TT-273.15))*1.E-4
      DENS = PP/TT/RL
      ALA  = 6.6E-6*1.01325E+6/PP*TT/293.15
      GR   = 979.69
      SI   = 76.1-.155*(TT-273.15)

      IF (AA.GT.500.E-4) THEN
         BOND = GR*(ROP-DENS)*AA*AA/SI
         PART = (SI**3*DENS*DENS/(ETA**4*GR*(ROP-DENS)))**(1./6.)
         XX = LOG(16./3.*BOND*PART)
         YY = B00+B11*XX+B22*XX*XX+B33*XX**3+B44*XX**4+B55*XX**5
         RE = PART*EXP(YY)
         VT = ETA*RE/2./DENS/AA
      ELSEIF (AA.GT.1.E-3) THEN
         CD = 32.*AA*AA*AA*(ROP-DENS)*DENS*GR/3./ETA/ETA
         XX = LOG(CD)
         RE = EXP(B0+B1*XX+B2*XX*XX+B3*XX**3+B4*XX**4+B5*XX**5+B6*XX**6)
         D  = CD/RE/24.-1.
         VT = ETA*RE/2./DENS/AA
      ELSE
         A  = 1.+1.26*ALA/AA
         A  = A*2.*AA*AA*GR*(ROP-DENS)/9./ETA
         CD = 12*ETA/A/AA/DENS
         VT = A
      ENDIF

      VTBEARD = VT

      RETURN
      END FUNCTION VTBEARD


      
!-------------------------------------------------- 
!     Function f. Coalescence-Efficiency 
!     Eq. (7) of Beard and Ochs (1995)
!--------------------------------------------------      
 
      REAL FUNCTION ecoalBeard(D_l,D_s) 
       
      IMPLICIT NONE 
!     REAL ecoalBeard
!     REAL ECOALMASS
      REAL            D_l,D_s
      REAL            R_s,R_l
      REAL            rcoeff
      REAL epsf
      PARAMETER (epsf  = 1.e-30) 

      INTEGER its
      COMPLEX acoeff(4),x

      R_s = 0.5 * D_s
      R_l = 0.5 * D_l      

      rcoeff = 5.07 - log(R_s*1e4) - log(R_l*1e4/200.0)

      acoeff(1) = CMPLX(rcoeff)
      acoeff(2) = CMPLX(-5.94)
      acoeff(3) = CMPLX(+7.27)
      acoeff(4) = CMPLX(-5.29)

      x = (0.50,0)

      CALL LAGUER(acoeff,3,x,its)

      EcoalBeard = REAL(x)

      RETURN 
      END FUNCTION ecoalBeard 

!--------------------------------------------------       

      SUBROUTINE laguer(a,m,x,its)
      INTEGER m,its,MAXIT,MR,MT
      REAL EPSS
      COMPLEX a(m+1),x
      PARAMETER (EPSS=2.e-7,MR=8,MT=10,MAXIT=MT*MR)
      INTEGER iter,j
      REAL abx,abp,abm,err,frac(MR)
      COMPLEX dx,x1,b,d,f,g,h,sq,gp,gm,g2
      SAVE frac
      DATA frac /.5,.25,.75,.13,.38,.62,.88,1./
      do 12 iter=1,MAXIT
        its=iter
        b=a(m+1)
        err=abs(b)
        d=cmplx(0.,0.)
        f=cmplx(0.,0.)
        abx=abs(x)
        do 11 j=m,1,-1
          f=x*f+d
          d=x*d+b
          b=x*b+a(j)
          err=abs(b)+abx*err
11      continue
        err=EPSS*err
        if(abs(b).le.err) then
          return
        else
          g=d/b
          g2=g*g
          h=g2-2.*f/b
          sq=sqrt((m-1)*(m*h-g2))
          gp=g+sq
          gm=g-sq
          abp=abs(gp)
          abm=abs(gm)
          if(abp.lt.abm) gp=gm
          if (max(abp,abm).gt.0.) then
            dx=m/gp
          else
            dx=exp(cmplx(log(1.+abx),float(iter)))
          endif
        endif
        x1=x-dx
        if(x.eq.x1)return
        if (mod(iter,MT).ne.0) then
          x=x1
        else
          x=x-dx*frac(iter/MT)
        endif
12    continue
      pause 'too many iterations in laguer'
      return
      END SUBROUTINE laguer




      subroutine courant_bott
      implicit none
      integer k,kk,j,i
      double precision x0
! ima(i,j) - k-category number,
! chucm(i,j)   - courant number :
! logarithmic grid distance(dlnr) :


!================================================================
! BARRY     
!     print*,'dlnr in courant_bott = ',dlnr
      xl_mg(0)=xl_mg(1)/2
! BARRY
      do i=1,nkr
         do j=i,nkr
            x0=xl_mg(i)+xl_mg(j)
            do k=j,nkr
               kk=k
               if (k.eq.1)then
!                  print*,'xl_mg(k) = ',xl_mg(k)
!                  print*,'x0 = ',x0
! xl_mg(k) =   3.351000000000000E-008
!  x0 =   6.702000000000000E-008
!		   read (6,*)
               end if
               if(xl_mg(k).ge.x0.and.xl_mg(k-1).lt.x0) then
                 chucm(i,j)=dlog(x0/xl_mg(k-1))/(3.d0*dlnr)
 102             continue
                 if(chucm(i,j).gt.1.-1.d-08) then
                   chucm(i,j)=0.
                   kk=kk+1
                 endif
                 ima(i,j)=min(nkr-1,kk-1)

                 goto 2000
               endif
            enddo
 2000       continue
!            if(i.eq.nkr.or.j.eq.nkr) ima(i,j)=nkr
            chucm(j,i)=chucm(i,j)
            ima(j,i)=ima(i,j)
         enddo
      enddo
      return
      end subroutine courant_bott


      SUBROUTINE KERNALS(DTIME)
! KHAIN30/07/99
      IMPLICIT NONE
      INTEGER I,J
      REAL PI
!******************************************************************
      data pi/3.141592654/
! dtime - timestep of integration (calculated in main program) :
! dlnr - logarithmic grid distance
! ima(i,j) - k-category number, c(i,j) - courant number 
! cw*(i,j) (in cm**3) - multiply help kernel with constant 
! timestep(dt) and logarithmic grid distance(dlnr) :
        REAL DTIME
! logarithmic grid distance(dlnr) :
!       dlnr=dlog(2.d0)/(3.d0*scal)
! scal is micro.prm file parameter(scal=1.d0 for x(k+1)=x(k)*2)
! calculation of cw*(i,j) (in cm**3) - multiply help kernel 
! with constant timestep(dtime) and logarithmic grid distance(dlnr) :
!     print*,'dlnr in kernal = ',dlnr,dtime
        DO I=1,NKR
           DO J=1,NKR
              CWLL_1000MB(I,J)=DTIME*DLNR*YWLL_1000MB(I,J)
              CWLL_750MB(I,J)=DTIME*DLNR*YWLL_750MB(I,J)
              CWLL_500MB(I,J)=DTIME*DLNR*YWLL_500MB(I,J)

              CWLL(I,J)=DTIME*DLNR*YWLL(I,J)
              CWLG(I,J)=DTIME*DLNR*YWLG(I,J)
              CWLH(I,J)=DTIME*DLNR*YWLH(I,J)

! barry
              if (i.le.16.and.j.le.16)then
              CWSL(I,J)=0.d0
!             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
              CWSL(i,j)=DTIME*DLNR*YWIL(I,J,2)
              CWLS(I,J)=0.d0
!             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
              CWLS(I,J)=DTIME*DLNR*YWLI(I,J,2)
              else
              CWSL(I,J)=DTIME*DLNR*YWSL(I,J)
              CWLS(I,J)=DTIME*DLNR*YWLS(I,J)
              end if
              CWSS(I,J)=DTIME*DLNR*YWSS(I,J)
              CWSG(I,J)=DTIME*DLNR*YWSG(I,J)
              CWSH(I,J)=DTIME*DLNR*YWSH(I,J)

              CWGL(I,J)=0.8*DTIME*DLNR*YWGL(I,J)
              IF(RADXXO(I,6).LT.2.0D-2) THEN
                IF(RADXXO(J,1).LT.1.0D-3) THEN
                  IF(RADXXO(J,1).GE.7.0D-4) THEN
                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/1.5D0
                  ELSE
                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/3.0D0
                  ENDIF
                ENDIF
              ENDIF
              IF(I.LE.14.AND.J.LE.7) CWGL(I,J)=0.0D0
!             IF(I.LE.17.AND.J.LE.7) CWGL(I,J)=0.0D0
!             IF(I.LE.14.AND.J.LE.14) CWGL(I,J)=0.0D0
              CWGS(I,J)=DTIME*DLNR*YWGS(I,J)
              CWGG(I,J)=DTIME*DLNR*YWGG(I,J)
              CWGH(I,J)=DTIME*DLNR*YWGH(I,J)

              CWHL(I,J)=DTIME*DLNR*YWHL(I,J)
              CWHS(I,J)=DTIME*DLNR*YWHS(I,J)
              CWHG(I,J)=DTIME*DLNR*YWHG(I,J)
              CWHH(I,J)=DTIME*DLNR*YWHH(I,J)

              CWLI_1(I,J)=DTIME*DLNR*YWLI(I,J,1)
              CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
              CWLI_3(I,J)=DTIME*DLNR*YWLI(I,J,3)
              
              CWIL_1(I,J)=DTIME*DLNR*YWIL(I,J,1)
              CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
              CWIL_3(I,J)=DTIME*DLNR*YWIL(I,J,3)

              CWIS_1(I,J)=DTIME*DLNR*YWIS(I,J,1)
              CWIS_2(I,J)=DTIME*DLNR*YWIS(I,J,2)
              CWIS_3(I,J)=DTIME*DLNR*YWIS(I,J,3)

              CWSI_1(I,J)=DTIME*DLNR*YWSI(I,J,1)
              CWSI_2(I,J)=DTIME*DLNR*YWSI(I,J,2)
              CWSI_3(I,J)=DTIME*DLNR*YWSI(I,J,3)

              CWIG_1(I,J)=DTIME*DLNR*YWIG(I,J,1)
              CWIG_2(I,J)=DTIME*DLNR*YWIG(I,J,2)
              CWIG_3(I,J)=DTIME*DLNR*YWIG(I,J,3)

              CWGI_1(I,J)=DTIME*DLNR*YWGI(I,J,1)
              CWGI_2(I,J)=DTIME*DLNR*YWGI(I,J,2)
              CWGI_3(I,J)=DTIME*DLNR*YWGI(I,J,3)

              CWIH_1(I,J)=DTIME*DLNR*YWIH(I,J,1)
              CWIH_2(I,J)=DTIME*DLNR*YWIH(I,J,2)
              CWIH_3(I,J)=DTIME*DLNR*YWIH(I,J,3)

              CWHI_1(I,J)=DTIME*DLNR*YWHI(I,J,1)
              CWHI_2(I,J)=DTIME*DLNR*YWHI(I,J,2)
              CWHI_3(I,J)=DTIME*DLNR*YWHI(I,J,3)
! barry
              if (i.lt.12.and.j.lt.12)then

               CWII_1_1(I,J)=0.D0
               CWII_1_2(I,J)=0.D0
               CWII_1_3(I,J)=0.D0

               CWII_2_1(I,J)=0.D0
               CWII_2_2(I,J)=0.D0
               CWII_2_3(I,J)=0.D0

               CWII_3_1(I,J)=0.D0
               CWII_3_2(I,J)=0.D0
               CWII_3_3(I,J)=0.D0
!barry
              else
               CWII_1_1(I,J)=DTIME*DLNR*YWII(I,J,1,1)
               CWII_1_2(I,J)=DTIME*DLNR*YWII(I,J,1,2)
               CWII_1_3(I,J)=DTIME*DLNR*YWII(I,J,1,3)

               CWII_2_1(I,J)=DTIME*DLNR*YWII(I,J,2,1)
               CWII_2_2(I,J)=DTIME*DLNR*YWII(I,J,2,2)
               CWII_2_3(I,J)=DTIME*DLNR*YWII(I,J,2,3)

               CWII_3_1(I,J)=DTIME*DLNR*YWII(I,J,3,1)
               CWII_3_2(I,J)=DTIME*DLNR*YWII(I,J,3,2)
               CWII_3_3(I,J)=DTIME*DLNR*YWII(I,J,3,3)
              end if
           ENDDO
        ENDDO
!       GO TO 88
! NEW CHANGES 2.06.01 (BEGIN)
        CALL TURBCOEF
        DO J=1,7
           DO I=15,24-J
              CWGL(I,J)=0.0D0
           ENDDO
        ENDDO
! NEW CHANGES 2.06.01 (END)
! NEW CHANGES 3.02.01 (BEGIN)
        DO I=1,NKR
           DO J=1,NKR
              CWLG(J,I)=CWGL(I,J)
           ENDDO
        ENDDO
!       print*, 'ICETURB = ',ICETURB
          DO I=KRMING_GL,KRMAXG_GL
             DO J=KRMINL_GL,KRMAXL_GL
               IF (ICETURB.EQ.1)THEN
                CWGL(I,J)=CTURBGL(I,J)*CWGL(I,J)
               ELSE
                CWGL(I,J)=CWGL(I,J)
               END IF
             ENDDO
          ENDDO
          DO I=KRMING_GL,KRMAXG_GL
             DO J=KRMINL_GL,KRMAXL_GL
                CWLG(J,I)=CWGL(I,J)
             ENDDO
          ENDDO

88     CONTINUE
	RETURN
	END SUBROUTINE KERNALS

      SUBROUTINE KERNALS_IN(DTIME)
! KHAIN30/07/99
      IMPLICIT NONE
      INTEGER I,J
      REAL PI
!******************************************************************
      data pi/3.141592654/
! dtime - timestep of integration (calculated in main program) :
! dlnr - logarithmic grid distance
! ima(i,j) - k-category number, c(i,j) - courant number 
! cw*(i,j) (in cm**3) - multiply help kernel with constant 
! timestep(dt) and logarithmic grid distance(dlnr) :
        REAL DTIME
! logarithmic grid distance(dlnr) :
!       dlnr=dlog(2.d0)/(3.d0*scal)
! scal is micro.prm file parameter(scal=1.d0 for x(k+1)=x(k)*2)
! calculation of cw*(i,j) (in cm**3) - multiply help kernel 
! with constant timestep(dtime) and logarithmic grid distance(dlnr) :
!     print*,'dlnr in kernal = ',dlnr,dtime
        DO I=1,NKR
           DO J=1,NKR
              CWLL_1000MB(I,J)=DTIME*DLNR*YWLL_1000MB(I,J)
              CWLL_750MB(I,J)=DTIME*DLNR*YWLL_750MB(I,J)
              CWLL_500MB(I,J)=DTIME*DLNR*YWLL_500MB(I,J)

              CWLL(I,J)=DTIME*DLNR*YWLL(I,J)
              CWLG(I,J)=DTIME*DLNR*YWLG(I,J)
!             CWLH(I,J)=DTIME*DLNR*YWLH(I,J)

! barry
              if (i.le.16.and.j.le.16)then
              CWSL(I,J)=0.d0
!             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
              CWSL(i,j)=DTIME*DLNR*YWIL(I,J,2)
              CWLS(I,J)=0.d0
!             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
              CWLS(I,J)=DTIME*DLNR*YWLI(I,J,2)
              else
              CWSL(I,J)=DTIME*DLNR*YWSL(I,J)
              CWLS(I,J)=DTIME*DLNR*YWLS(I,J)
              end if
              CWSS(I,J)=DTIME*DLNR*YWSS(I,J)
              CWSG(I,J)=DTIME*DLNR*YWSG(I,J)
!             CWSH(I,J)=DTIME*DLNR*YWSH(I,J)

              CWGL(I,J)=0.8*DTIME*DLNR*YWGL(I,J)
              IF(RADXXO(I,6).LT.2.0D-2) THEN
                IF(RADXXO(J,1).LT.1.0D-3) THEN
                  IF(RADXXO(J,1).GE.7.0D-4) THEN
                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/1.5D0
                  ELSE
                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/3.0D0
                  ENDIF
                ENDIF
              ENDIF
              IF(I.LE.14.AND.J.LE.7) CWGL(I,J)=0.0D0
!             IF(I.LE.17.AND.J.LE.7) CWGL(I,J)=0.0D0
!             IF(I.LE.14.AND.J.LE.14) CWGL(I,J)=0.0D0
              CWGS(I,J)=DTIME*DLNR*YWGS(I,J)
              CWGG(I,J)=DTIME*DLNR*YWGG(I,J)
!             CWGH(I,J)=DTIME*DLNR*YWGH(I,J)

!             CWHL(I,J)=DTIME*DLNR*YWHL(I,J)
!             CWHS(I,J)=DTIME*DLNR*YWHS(I,J)
!             CWHG(I,J)=DTIME*DLNR*YWHG(I,J)
!             CWHH(I,J)=DTIME*DLNR*YWHH(I,J)

!             CWLI_1(I,J)=DTIME*DLNR*YWLI(I,J,1)
!             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
!             CWLI_3(I,J)=DTIME*DLNR*YWLI(I,J,3)
              
!             CWIL_1(I,J)=DTIME*DLNR*YWIL(I,J,1)
!             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
!             CWIL_3(I,J)=DTIME*DLNR*YWIL(I,J,3)

!             CWIS_1(I,J)=DTIME*DLNR*YWIS(I,J,1)
!             CWIS_2(I,J)=DTIME*DLNR*YWIS(I,J,2)
!             CWIS_3(I,J)=DTIME*DLNR*YWIS(I,J,3)

!             CWSI_1(I,J)=DTIME*DLNR*YWSI(I,J,1)
!             CWSI_2(I,J)=DTIME*DLNR*YWSI(I,J,2)
!             CWSI_3(I,J)=DTIME*DLNR*YWSI(I,J,3)

!             CWIG_1(I,J)=DTIME*DLNR*YWIG(I,J,1)
!             CWIG_2(I,J)=DTIME*DLNR*YWIG(I,J,2)
!             CWIG_3(I,J)=DTIME*DLNR*YWIG(I,J,3)

!             CWGI_1(I,J)=DTIME*DLNR*YWGI(I,J,1)
!             CWGI_2(I,J)=DTIME*DLNR*YWGI(I,J,2)
!             CWGI_3(I,J)=DTIME*DLNR*YWGI(I,J,3)

!             CWIH_1(I,J)=DTIME*DLNR*YWIH(I,J,1)
!             CWIH_2(I,J)=DTIME*DLNR*YWIH(I,J,2)
!             CWIH_3(I,J)=DTIME*DLNR*YWIH(I,J,3)

!             CWHI_1(I,J)=DTIME*DLNR*YWHI(I,J,1)
!             CWHI_2(I,J)=DTIME*DLNR*YWHI(I,J,2)
!             CWHI_3(I,J)=DTIME*DLNR*YWHI(I,J,3)
! barry
              if (i.lt.12.and.j.lt.12)then

!              CWII_1_1(I,J)=0.D0
!              CWII_1_2(I,J)=0.D0
!              CWII_1_3(I,J)=0.D0

!              CWII_2_1(I,J)=0.D0
!              CWII_2_2(I,J)=0.D0
!              CWII_2_3(I,J)=0.D0

!              CWII_3_1(I,J)=0.D0
!              CWII_3_2(I,J)=0.D0
!              CWII_3_3(I,J)=0.D0
!barry
              else
!              CWII_1_1(I,J)=DTIME*DLNR*YWII(I,J,1,1)
!              CWII_1_2(I,J)=DTIME*DLNR*YWII(I,J,1,2)
!              CWII_1_3(I,J)=DTIME*DLNR*YWII(I,J,1,3)

!              CWII_2_1(I,J)=DTIME*DLNR*YWII(I,J,2,1)
!              CWII_2_2(I,J)=DTIME*DLNR*YWII(I,J,2,2)
!              CWII_2_3(I,J)=DTIME*DLNR*YWII(I,J,2,3)

!              CWII_3_1(I,J)=DTIME*DLNR*YWII(I,J,3,1)
!              CWII_3_2(I,J)=DTIME*DLNR*YWII(I,J,3,2)
!              CWII_3_3(I,J)=DTIME*DLNR*YWII(I,J,3,3)
              end if
           ENDDO
        ENDDO
!       GO TO 88
! NEW CHANGES 2.06.01 (BEGIN)
        CALL TURBCOEF
        DO J=1,7
           DO I=15,24-J
              CWGL(I,J)=0.0D0
           ENDDO
        ENDDO
! NEW CHANGES 2.06.01 (END)
! NEW CHANGES 3.02.01 (BEGIN)
        DO I=1,NKR
           DO J=1,NKR
              CWLG(J,I)=CWGL(I,J)
           ENDDO
        ENDDO
!       print*, 'ICETURB = ',ICETURB
          DO I=KRMING_GL,KRMAXG_GL
             DO J=KRMINL_GL,KRMAXL_GL
               IF (ICETURB.EQ.1)THEN
                CWGL(I,J)=CTURBGL(I,J)*CWGL(I,J)
               ELSE
                CWGL(I,J)=CWGL(I,J)
               END IF
             ENDDO
          ENDDO
          DO I=KRMING_GL,KRMAXG_GL
             DO J=KRMINL_GL,KRMAXL_GL
                CWLG(J,I)=CWGL(I,J)
             ENDDO
          ENDDO

88     CONTINUE
	RETURN
	END SUBROUTINE KERNALS_IN
        SUBROUTINE TURBCOEF
        IMPLICIT NONE
        INTEGER I,J
!       DOUBLE PRECISION X_KERN,Y_KERN,F
        DOUBLE PRECISION X_KERN,Y_KERN
	DOUBLE PRECISION RL_LL(K0_LL),RL_GL(K0L_GL),RG_GL(K0G_GL)
          RL_LL(1)=RADXXO(KRMIN_LL,1)*1.E4
          RL_LL(2)=10.0D0
          RL_LL(3)=20.0D0
          RL_LL(4)=30.0D0
          RL_LL(5)=40.0D0
          RL_LL(6)=50.0D0
          RL_LL(7)=60.0D0
          RL_LL(8)=RADXXO(KRMAX_LL,1)*1.E4
          DO J=1,K0_LL
             DO I=1,K0_LL
                CTURB_LL(I,J)=1.0D0
             ENDDO
          ENDDO 
	  CTURB_LL(1,1)=4.50D0
	  CTURB_LL(1,2)=4.50D0
	  CTURB_LL(1,3)=3.00D0
	  CTURB_LL(1,4)=2.25D0
	  CTURB_LL(1,5)=1.95D0
	  CTURB_LL(1,6)=1.40D0
	  CTURB_LL(1,7)=1.40D0
	  CTURB_LL(1,8)=1.40D0

	  CTURB_LL(2,1)=4.50D0
	  CTURB_LL(2,2)=4.50D0
	  CTURB_LL(2,3)=3.00D0
	  CTURB_LL(2,4)=2.25D0
	  CTURB_LL(2,5)=1.95D0
	  CTURB_LL(2,6)=1.40D0
	  CTURB_LL(2,7)=1.40D0
	  CTURB_LL(2,8)=1.40D0

	  CTURB_LL(3,1)=3.00D0
	  CTURB_LL(3,2)=3.00D0
	  CTURB_LL(3,3)=2.70D0
	  CTURB_LL(3,4)=2.25D0
	  CTURB_LL(3,5)=1.65D0
	  CTURB_LL(3,6)=1.40D0
	  CTURB_LL(3,7)=1.40D0
	  CTURB_LL(3,8)=1.40D0

	  CTURB_LL(4,1)=2.25D0
	  CTURB_LL(4,2)=2.25D0
	  CTURB_LL(4,3)=2.25D0
	  CTURB_LL(4,4)=1.95D0
	  CTURB_LL(4,5)=1.65D0
	  CTURB_LL(4,6)=1.40D0
	  CTURB_LL(4,7)=1.40D0
	  CTURB_LL(4,8)=1.40D0

	  CTURB_LL(5,1)=1.95D0
	  CTURB_LL(5,2)=1.95D0
	  CTURB_LL(5,3)=1.65D0
	  CTURB_LL(5,4)=1.65D0
	  CTURB_LL(5,5)=1.65D0
	  CTURB_LL(5,6)=1.40D0
	  CTURB_LL(5,7)=1.40D0
	  CTURB_LL(5,8)=1.40D0

	  CTURB_LL(6,1)=1.40D0
	  CTURB_LL(6,2)=1.40D0
	  CTURB_LL(6,3)=1.40D0
	  CTURB_LL(6,4)=1.40D0
	  CTURB_LL(6,5)=1.40D0
	  CTURB_LL(6,6)=1.40D0
	  CTURB_LL(6,7)=1.40D0
	  CTURB_LL(6,8)=1.40D0

	  CTURB_LL(7,1)=1.40D0
	  CTURB_LL(7,2)=1.40D0
	  CTURB_LL(7,3)=1.40D0
	  CTURB_LL(7,4)=1.40D0
	  CTURB_LL(7,5)=1.40D0
	  CTURB_LL(7,6)=1.40D0
	  CTURB_LL(7,7)=1.40D0
	  CTURB_LL(7,8)=1.40D0

	  CTURB_LL(8,1)=1.40D0
	  CTURB_LL(8,2)=1.40D0
	  CTURB_LL(8,3)=1.40D0
	  CTURB_LL(8,4)=1.40D0
	  CTURB_LL(8,5)=1.40D0
	  CTURB_LL(8,6)=1.40D0
	  CTURB_LL(8,7)=1.40D0
	  CTURB_LL(8,8)=1.40D0
          DO J=1,K0_LL
             DO I=1,K0_LL
                CTURB_LL(I,J)=(CTURB_LL(I,J)-1.0D0)/1.5D0+1.0D0
             ENDDO
          ENDDO
	  DO I=KRMIN_LL,KRMAX_LL
             DO J=KRMIN_LL,KRMAX_LL
                CTURBLL(I,J)=1.0D0
             ENDDO
          ENDDO
          DO I=KRMIN_LL,KRMAX_LL
             X_KERN=RADXXO(I,1)*1.0D4
             IF(X_KERN.LT.RL_LL(1)) X_KERN=RL_LL(1)
             IF(X_KERN.GT.RL_LL(K0_LL)) X_KERN=RL_LL(K0_LL) 
             DO J=KRMIN_LL,KRMAX_LL
                Y_KERN=RADXXO(J,1)*1.0D4
                IF(Y_KERN.LT.RL_LL(1)) Y_KERN=RL_LL(1)
                IF(Y_KERN.GT.RL_LL(K0_LL)) Y_KERN=RL_LL(K0_LL)
                CTURBLL(I,J)=F(X_KERN,Y_KERN,RL_LL,RL_LL,CTURB_LL &
     &                      ,K0_LL,K0_LL)	                         
             ENDDO
          ENDDO
          RL_GL(1) = RADXXO(1,1)*1.E4 
          RL_GL(2) = 8.0D0
          RL_GL(3) = 10.0D0
	  RL_GL(4) = 16.0D0
          RL_GL(5) = 20.0D0
          RL_GL(6) = 30.0D0
          RL_GL(7) = 40.0D0
          RL_GL(8) = 50.0D0
          RL_GL(9) = 60.0D0
          RL_GL(10)= 70.0D0
          RL_GL(11)= 80.0D0
	  RL_GL(12)= 90.0D0
	  RL_GL(13)=100.0D0
	  RL_GL(14)=200.0D0
	  RL_GL(15)=300.0D0
	  RL_GL(16)=RADXXO(24,1)*1.0D4
! TURBULENCE GRAUPEL BULK RADII IN MKM
          RG_GL(1) = RADXXO(1,6)*1.0D4 
          RG_GL(2) = 30.0D0  
          RG_GL(3) = 60.0D0 
          RG_GL(4) = 100.0D0 
          RG_GL(5) = 200.0D0 
	  RG_GL(6) = 300.0D0
	  RG_GL(7) = 400.0D0
	  RG_GL(8) = 500.0D0
	  RG_GL(9) = 600.0D0
	  RG_GL(10)= 700.0D0
	  RG_GL(11)= 800.0D0
	  RG_GL(12)= 900.0D0
	  RG_GL(13)=1000.0D0
	  RG_GL(14)=2000.0D0
	  RG_GL(15)=3000.0D0
	  RG_GL(16)=RADXXO(33,6)*1.0D4
	  DO I=KRMING_GL,KRMAXG_GL
             DO J=KRMINL_GL,KRMAXL_GL
                CTURBGL(I,J)=1.0D0
             ENDDO
          ENDDO
          DO I=1,K0G_GL
             DO J=1,K0L_GL
                CTURB_GL(I,J)=1.0D0
             ENDDO
          ENDDO 
          IF(IEPS_400.EQ.1) THEN
	    CTURB_GL(1,1)=0.0D0
	    CTURB_GL(1,2)=0.0D0
	    CTURB_GL(1,3)=1.2D0
	    CTURB_GL(1,4)=1.3D0
	    CTURB_GL(1,5)=1.4D0
	    CTURB_GL(1,6)=1.5D0
	    CTURB_GL(1,7)=1.5D0
	    CTURB_GL(1,8)=1.5D0
	    CTURB_GL(1,9)=1.5D0
	    CTURB_GL(1,10)=1.5D0
	    CTURB_GL(1,11)=1.5D0
	    CTURB_GL(1,12)=1.0D0
	    CTURB_GL(1,13)=1.0D0
	    CTURB_GL(1,14)=1.0D0
	    CTURB_GL(1,15)=1.0D0
	
	    CTURB_GL(2,1)=1.0D0
	    CTURB_GL(2,2)=1.4D0
	    CTURB_GL(2,3)=1.8D0
	    CTURB_GL(2,4)=2.2D0
	    CTURB_GL(2,5)=2.6D0
	    CTURB_GL(2,6)=3.0D0
	    CTURB_GL(2,7)=2.85D0
	    CTURB_GL(2,8)=2.7D0
	    CTURB_GL(2,9)=2.55D0
	    CTURB_GL(2,10)=2.4D0
	    CTURB_GL(2,11)=2.25D0
	    CTURB_GL(2,12)=1.0D0
	    CTURB_GL(2,13)=1.0D0
	    CTURB_GL(2,14)=1.0D0

	    CTURB_GL(3,1)=7.5D0
	    CTURB_GL(3,2)=7.5D0
	    CTURB_GL(3,3)=4.5D0	
	    CTURB_GL(3,4)=4.5D0	
	    CTURB_GL(3,5)=4.65D0	
	    CTURB_GL(3,6)=4.65D0	
	    CTURB_GL(3,7)=4.5D0	
	    CTURB_GL(3,8)=4.5D0	
	    CTURB_GL(3,9)=4.0D0	
	    CTURB_GL(3,10)=3.0D0	
	    CTURB_GL(3,11)=2.0D0	
	    CTURB_GL(3,12)=1.5D0	
	    CTURB_GL(3,13)=1.3D0	
	    CTURB_GL(3,14)=1.0D0	
    
	    CTURB_GL(4,1)=5.5D0
	    CTURB_GL(4,2)=5.5D0
	    CTURB_GL(4,3)=4.5D0
	    CTURB_GL(4,4)=4.5D0
	    CTURB_GL(4,5)=4.65D0
	    CTURB_GL(4,6)=4.65D0
	    CTURB_GL(4,7)=4.5D0
	    CTURB_GL(4,8)=4.5D0
	    CTURB_GL(4,9)=4.0D0
	    CTURB_GL(4,10)=3.0D0
	    CTURB_GL(4,11)=2.0D0
	    CTURB_GL(4,12)=1.5D0
	    CTURB_GL(4,13)=1.35D0
	    CTURB_GL(4,14)=1.0D0
	 
	    CTURB_GL(5,1)=4.5D0
	    CTURB_GL(5,2)=4.5D0
	    CTURB_GL(5,3)=3.3D0	
	    CTURB_GL(5,4)=3.3D0	
	    CTURB_GL(5,5)=3.3D0	
	    CTURB_GL(5,6)=3.4D0	
	    CTURB_GL(5,7)=3.8D0	
	    CTURB_GL(5,8)=3.8D0	
	    CTURB_GL(5,9)=3.8D0	
	    CTURB_GL(5,10)=3.6D0
	    CTURB_GL(5,11)=2.5D0	
	    CTURB_GL(5,12)=2.0D0	
	    CTURB_GL(5,13)=1.4D0	
	    CTURB_GL(5,14)=1.0D0	
			 		
	    CTURB_GL(6,1)=4.0D0
	    CTURB_GL(6,2)=4.0D0
	    CTURB_GL(6,3)=2.8D0
	    CTURB_GL(6,4)=2.8D0
	    CTURB_GL(6,5)=2.85D0
	    CTURB_GL(6,6)=2.9D0
	    CTURB_GL(6,7)=3.0D0
	    CTURB_GL(6,8)=3.1D0
	    CTURB_GL(6,9)=2.9D0
	    CTURB_GL(6,10)=2.6D0
	    CTURB_GL(6,11)=2.5D0
	    CTURB_GL(6,12)=2.0D0
	    CTURB_GL(6,13)=1.3D0
	    CTURB_GL(6,14)=1.1D0

	    CTURB_GL(7,1)=3.5D0
	    CTURB_GL(7,2)=3.5D0
	    CTURB_GL(7,3)=2.5D0
	    CTURB_GL(7,4)=2.5D0
	    CTURB_GL(7,5)=2.6D0
	    CTURB_GL(7,6)=2.7D0
	    CTURB_GL(7,7)=2.8D0
	    CTURB_GL(7,8)=2.8D0
	    CTURB_GL(7,9)=2.8D0
	    CTURB_GL(7,10)=2.6D0
	    CTURB_GL(7,11)=2.3D0
	    CTURB_GL(7,12)=2.0D0
	    CTURB_GL(7,13)=1.3D0
	    CTURB_GL(7,14)=1.1D0

	    CTURB_GL(8,1)=3.25D0
	    CTURB_GL(8,2)=3.25D0
	    CTURB_GL(8,3)=2.3D0
	    CTURB_GL(8,4)=2.3D0
	    CTURB_GL(8,5)=2.35D0
	    CTURB_GL(8,6)=2.37D0
	    CTURB_GL(8,7)=2.55D0
	    CTURB_GL(8,8)=2.55D0
	    CTURB_GL(8,9)=2.55D0
	    CTURB_GL(8,10)=2.3D0
	    CTURB_GL(8,11)=2.1D0
	    CTURB_GL(8,12)=1.9D0
	    CTURB_GL(8,13)=1.3D0
	    CTURB_GL(8,14)=1.1D0

	    CTURB_GL(9,1)=3.0D0
	    CTURB_GL(9,2)=3.0D0
	    CTURB_GL(9,3)=3.1D0
	    CTURB_GL(9,4)=2.2D0
	    CTURB_GL(9,5)=2.2D0
	    CTURB_GL(9,6)=2.2D0
	    CTURB_GL(9,7)=2.3D0
	    CTURB_GL(9,8)=2.3D0
	    CTURB_GL(9,9)=2.5D0
	    CTURB_GL(9,10)=2.5D0
	    CTURB_GL(9,11)=2.2D0
	    CTURB_GL(9,12)=1.8D0
	    CTURB_GL(9,13)=1.25D0
	    CTURB_GL(9,14)=1.1D0

	    CTURB_GL(10,1)=2.75D0
	    CTURB_GL(10,2)=2.75D0
	    CTURB_GL(10,3)=2.0D0
	    CTURB_GL(10,4)=2.0D0
	    CTURB_GL(10,5)=2.0D0
	    CTURB_GL(10,6)=2.1D0
	    CTURB_GL(10,7)=2.2D0
	    CTURB_GL(10,8)=2.2D0
	    CTURB_GL(10,9)=2.3D0
	    CTURB_GL(10,10)=2.3D0
	    CTURB_GL(10,11)=2.3D0
	    CTURB_GL(10,12)=1.8D0
	    CTURB_GL(10,13)=1.2D0
	    CTURB_GL(10,14)=1.1D0

	    CTURB_GL(11,1)=2.6D0
	    CTURB_GL(11,2)=2.6D0
	    CTURB_GL(11,3)=1.95D0
	    CTURB_GL(11,4)=1.95D0
	    CTURB_GL(11,5)=1.95D0
	    CTURB_GL(11,6)=2.05D0
	    CTURB_GL(11,7)=2.15D0
	    CTURB_GL(11,8)=2.15D0
	    CTURB_GL(11,9)=2.25D0
	    CTURB_GL(11,10)=2.25D0
	    CTURB_GL(11,11)=1.9D0
	    CTURB_GL(11,12)=1.8D0
	    CTURB_GL(11,13)=1.2D0
	    CTURB_GL(11,14)=1.1D0

	    CTURB_GL(12,1)=2.4D0
	    CTURB_GL(12,2)=2.4D0
	    CTURB_GL(12,3)=1.85D0
	    CTURB_GL(12,4)=1.85D0
	    CTURB_GL(12,5)=1.85D0
	    CTURB_GL(12,6)=1.75D0
	    CTURB_GL(12,7)=1.85D0
	    CTURB_GL(12,8)=1.85D0
	    CTURB_GL(12,9)=2.1D0
	    CTURB_GL(12,10)=2.1D0
	    CTURB_GL(12,11)=1.9D0
	    CTURB_GL(12,12)=1.8D0 
	    CTURB_GL(12,13)=1.3D0
	    CTURB_GL(12,14)=1.1D0

	    CTURB_GL(13,1)=1.67D0
	    CTURB_GL(13,2)=1.67D0
	    CTURB_GL(13,3)=1.75D0
	    CTURB_GL(13,4)=1.83D0
	    CTURB_GL(13,5)=1.87D0
	    CTURB_GL(13,6)=2.0D0
	    CTURB_GL(13,7)=2.1D0
	    CTURB_GL(13,8)=2.12D0
	    CTURB_GL(13,9)=2.15D0
	    CTURB_GL(13,10)=2.18D0
	    CTURB_GL(13,11)=2.19D0
	    CTURB_GL(13,12)=1.67D0
	    CTURB_GL(13,13)=1.28D0
	    CTURB_GL(13,14)=1.0D0

	    CTURB_GL(14,1)=1.3D0
	    CTURB_GL(14,2)=1.3D0
	    CTURB_GL(14,3)=1.35D0
	    CTURB_GL(14,4)=1.4D0
	    CTURB_GL(14,5)=1.6D0
	    CTURB_GL(14,6)=1.7D0
	    CTURB_GL(14,7)=1.7D0
	    CTURB_GL(14,8)=1.7D0
	    CTURB_GL(14,9)=1.7D0
	    CTURB_GL(14,10)=1.7D0
	    CTURB_GL(14,11)=1.7D0
	    CTURB_GL(14,12)=1.4D0
	    CTURB_GL(14,13)=1.25D0
	    CTURB_GL(14,14)=1.0D0

	    CTURB_GL(15,1)=1.17D0
	    CTURB_GL(15,2)=1.17D0
	    CTURB_GL(15,3)=1.17D0
	    CTURB_GL(15,4)=1.25D0
	    CTURB_GL(15,5)=1.3D0
	    CTURB_GL(15,6)=1.35D0
	    CTURB_GL(15,7)=1.4D0
	    CTURB_GL(15,8)=1.4D0
	    CTURB_GL(15,9)=1.45D0
	    CTURB_GL(15,10)=1.47D0
	    CTURB_GL(15,11)=1.44D0
	    CTURB_GL(15,12)=1.3D0
	    CTURB_GL(15,13)=1.12D0
	    CTURB_GL(15,14)=1.0D0

	    CTURB_GL(16,1)=1.17D0
	    CTURB_GL(16,2)=1.17D0
	    CTURB_GL(16,3)=1.17D0
	    CTURB_GL(16,4)=1.25D0
	    CTURB_GL(16,5)=1.3D0
	    CTURB_GL(16,6)=1.35D0
	    CTURB_GL(16,7)=1.4D0
	    CTURB_GL(16,8)=1.45D0
	    CTURB_GL(16,9)=1.45D0
	    CTURB_GL(16,10)=1.47D0
	    CTURB_GL(16,11)=1.44D0
	    CTURB_GL(16,12)=1.3D0
	    CTURB_GL(16,13)=1.12D0
	    CTURB_GL(16,14)=1.0D0
          ENDIF
          IF(IEPS_800.EQ.1) THEN
	    CTURB_GL(1,1) =0.00D0
	    CTURB_GL(1,2) =0.00D0
	    CTURB_GL(1,3) =1.00D0
            CTURB_GL(1,4) =1.50D0
	    CTURB_GL(1,5) =1.40D0
	    CTURB_GL(1,6) =1.30D0
	    CTURB_GL(1,7) =1.20D0
	    CTURB_GL(1,8) =1.10D0
	    CTURB_GL(1,9) =1.00D0
	    CTURB_GL(1,10)=1.00D0
	    CTURB_GL(1,11)=1.00D0
	    CTURB_GL(1,12)=1.00D0
	    CTURB_GL(1,13)=1.00D0
	    CTURB_GL(1,14)=1.00D0
	    CTURB_GL(1,15)=1.00D0
	    CTURB_GL(1,16)=1.00D0

	    CTURB_GL(2,1) =0.00D0
	    CTURB_GL(2,2) =0.00D0
	    CTURB_GL(2,3) =1.00D0
	    CTURB_GL(2,4) =2.00D0
	    CTURB_GL(2,5) =1.80D0
	    CTURB_GL(2,6) =1.70D0
	    CTURB_GL(2,7) =1.60D0
	    CTURB_GL(2,8) =1.50D0
	    CTURB_GL(2,9) =1.50D0
	    CTURB_GL(2,10)=1.50D0
	    CTURB_GL(2,11)=1.50D0
	    CTURB_GL(2,12)=1.50D0
	    CTURB_GL(2,13)=1.50D0
	    CTURB_GL(2,14)=1.00D0
	    CTURB_GL(2,15)=1.00D0
	    CTURB_GL(2,16)=1.00D0

	    CTURB_GL(3,1) =0.00D0
	    CTURB_GL(3,2) =0.00D0
	    CTURB_GL(3,3) =4.00D0
	    CTURB_GL(3,4) =7.65D0
	    CTURB_GL(3,5) =7.65D0
	    CTURB_GL(3,6) =8.00D0
	    CTURB_GL(3,7) =8.00D0
	    CTURB_GL(3,8) =7.50D0
	    CTURB_GL(3,9) =6.50D0
	    CTURB_GL(3,10)=6.00D0
	    CTURB_GL(3,11)=5.00D0
	    CTURB_GL(3,12)=4.50D0
	    CTURB_GL(3,13)=4.00D0
	    CTURB_GL(3,14)=2.00D0
	    CTURB_GL(3,15)=1.30D0
	    CTURB_GL(3,16)=1.00D0

	    CTURB_GL(4,1) =7.50D0
	    CTURB_GL(4,2) =7.50D0
	    CTURB_GL(4,3) =7.50D0
	    CTURB_GL(4,4) =7.65D0	
	    CTURB_GL(4,5) =7.65D0	
	    CTURB_GL(4,6) =8.00D0	
	    CTURB_GL(4,7) =8.00D0	
	    CTURB_GL(4,8) =7.50D0	
	    CTURB_GL(4,9) =6.50D0	
	    CTURB_GL(4,10)=6.00D0	
	    CTURB_GL(4,11)=5.00D0	
	    CTURB_GL(4,12)=4.50D0	
	    CTURB_GL(4,13)=4.00D0	
	    CTURB_GL(4,14)=2.00D0	
	    CTURB_GL(4,15)=1.30D0	
	    CTURB_GL(4,16)=1.00D0	
    
	    CTURB_GL(5,1) =5.50D0
	    CTURB_GL(5,2) =5.50D0
	    CTURB_GL(5,3) =5.50D0
	    CTURB_GL(5,4) =5.75D0
	    CTURB_GL(5,5) =5.75D0
	    CTURB_GL(5,6) =6.00D0
	    CTURB_GL(5,7) =6.25D0
	    CTURB_GL(5,8) =6.17D0
	    CTURB_GL(5,9) =5.75D0
	    CTURB_GL(5,10)=5.25D0
	    CTURB_GL(5,11)=4.75D0
	    CTURB_GL(5,12)=4.25D0
	    CTURB_GL(5,13)=4.00D0
	    CTURB_GL(5,14)=2.00D0
	    CTURB_GL(5,15)=1.35D0
	    CTURB_GL(5,16)=1.00D0
	 
	    CTURB_GL(6,1) =4.50D0
	    CTURB_GL(6,2) =4.50D0
	    CTURB_GL(6,3) =4.50D0
	    CTURB_GL(6,4) =4.75D0	
	    CTURB_GL(6,5) =4.75D0	
	    CTURB_GL(6,6) =5.00D0	
	    CTURB_GL(6,7) =5.25D0	
	    CTURB_GL(6,8) =5.25D0	
	    CTURB_GL(6,9) =5.00D0	
	    CTURB_GL(6,10)=4.75D0	
	    CTURB_GL(6,11)=4.50D0	
	    CTURB_GL(6,12)=4.00D0	
	    CTURB_GL(6,13)=3.75D0	
	    CTURB_GL(6,14)=2.00D0	
	    CTURB_GL(6,15)=1.40D0	
	    CTURB_GL(6,16)=1.00D0	
			 		
	    CTURB_GL(7,1) =4.00D0
	    CTURB_GL(7,2) =4.00D0
	    CTURB_GL(7,3) =4.00D0
	    CTURB_GL(7,4) =4.00D0
	    CTURB_GL(7,5) =4.00D0
	    CTURB_GL(7,6) =4.25D0
	    CTURB_GL(7,7) =4.50D0
	    CTURB_GL(7,8) =4.67D0
	    CTURB_GL(7,9) =4.50D0
	    CTURB_GL(7,10)=4.30D0
	    CTURB_GL(7,11)=4.10D0
	    CTURB_GL(7,12)=3.80D0
	    CTURB_GL(7,13)=3.50D0
	    CTURB_GL(7,14)=2.00D0
	    CTURB_GL(7,15)=1.30D0
	    CTURB_GL(7,16)=1.10D0

	    CTURB_GL(8,1) =3.50D0
	    CTURB_GL(8,2) =3.50D0
	    CTURB_GL(8,3) =3.50D0
	    CTURB_GL(8,4) =3.65D0
	    CTURB_GL(8,5) =3.65D0
	    CTURB_GL(8,6) =3.80D0
	    CTURB_GL(8,7) =4.1D02
	    CTURB_GL(8,8) =4.17D0
	    CTURB_GL(8,9) =4.17D0
	    CTURB_GL(8,10)=4.00D0
	    CTURB_GL(8,11)=3.80D0
	    CTURB_GL(8,12)=3.67D0
	    CTURB_GL(8,13)=3.40D0
	    CTURB_GL(8,14)=2.00D0
	    CTURB_GL(8,15)=1.30D0
	    CTURB_GL(8,16)=1.10D0

	    CTURB_GL(9,1) =3.25D0
	    CTURB_GL(9,2) =3.25D0
	    CTURB_GL(9,3) =3.25D0
	    CTURB_GL(9,4) =3.25D0
	    CTURB_GL(9,5) =3.25D0
	    CTURB_GL(9,6) =3.50D0
	    CTURB_GL(9,7) =3.75D0
	    CTURB_GL(9,8) =3.75D0
	    CTURB_GL(9,9) =3.75D0
	    CTURB_GL(9,10)=3.75D0
	    CTURB_GL(9,11)=3.60D0
	    CTURB_GL(9,12)=3.40D0
	    CTURB_GL(9,13)=3.25D0
	    CTURB_GL(9,14)=2.00D0
	    CTURB_GL(9,15)=1.30D0
	    CTURB_GL(9,16)=1.10D0
	    
	    CTURB_GL(10,1) =3.00D0
	    CTURB_GL(10,2) =3.00D0
	    CTURB_GL(10,3) =3.00D0
	    CTURB_GL(10,4) =3.10D0
	    CTURB_GL(10,5) =3.10D0
	    CTURB_GL(10,6) =3.25D0
	    CTURB_GL(10,7) =3.40D0
	    CTURB_GL(10,8) =3.50D0
	    CTURB_GL(10,9) =3.50D0
	    CTURB_GL(10,10)=3.50D0
	    CTURB_GL(10,11)=3.40D0
	    CTURB_GL(10,12)=3.25D0
	    CTURB_GL(10,13)=3.15D0
	    CTURB_GL(10,14)=1.90D0
	    CTURB_GL(10,15)=1.30D0
	    CTURB_GL(10,16)=1.10D0

	    CTURB_GL(11,1) =2.75D0
	    CTURB_GL(11,2) =2.75D0
	    CTURB_GL(11,3) =2.75D0
	    CTURB_GL(11,4) =2.75D0
	    CTURB_GL(11,5) =2.75D0
	    CTURB_GL(11,6) =3.00D0
	    CTURB_GL(11,7) =3.25D0
	    CTURB_GL(11,8) =3.25D0
	    CTURB_GL(11,9) =3.25D0
	    CTURB_GL(11,10)=3.25D0
	    CTURB_GL(11,11)=3.25D0
	    CTURB_GL(11,12)=3.15D0
	    CTURB_GL(11,13)=3.00D0
	    CTURB_GL(11,14)=1.80D0
	    CTURB_GL(11,15)=1.30D0
	    CTURB_GL(11,16)=1.10D0

	    CTURB_GL(12,1) =2.60D0
	    CTURB_GL(12,2) =2.60D0
	    CTURB_GL(12,3) =2.60D0
	    CTURB_GL(12,4) =2.67D0
	    CTURB_GL(12,5) =2.67D0
	    CTURB_GL(12,6) =2.75D0
	    CTURB_GL(12,7) =3.00D0
	    CTURB_GL(12,8) =3.17D0
	    CTURB_GL(12,9) =3.17D0
	    CTURB_GL(12,10)=3.17D0
	    CTURB_GL(12,11)=3.10D0
	    CTURB_GL(12,12)=2.90D0
	    CTURB_GL(12,13)=2.80D0
	    CTURB_GL(12,14)=1.87D0
	    CTURB_GL(12,15)=1.37D0
	    CTURB_GL(12,16)=1.10D0

	    CTURB_GL(13,1) =2.40D0
	    CTURB_GL(13,2) =2.40D0
	    CTURB_GL(13,3) =2.40D0
	    CTURB_GL(13,4) =2.50D0
	    CTURB_GL(13,5) =2.50D0
	    CTURB_GL(13,6) =2.67D0
	    CTURB_GL(13,7) =2.83D0
	    CTURB_GL(13,8) =2.90D0
	    CTURB_GL(13,9) =3.00D0
	    CTURB_GL(13,10)=2.90D0
	    CTURB_GL(13,11)=2.85D0
	    CTURB_GL(13,12)=2.80D0
	    CTURB_GL(13,13)=2.75D0
	    CTURB_GL(13,14)=1.83D0
	    CTURB_GL(13,15)=1.30D0
	    CTURB_GL(13,16)=1.10D0

	    CTURB_GL(14,1) =1.67D0
	    CTURB_GL(14,2) =1.67D0
	    CTURB_GL(14,3) =1.67D0
	    CTURB_GL(14,4) =1.75D0
	    CTURB_GL(14,5) =1.75D0
	    CTURB_GL(14,6) =1.83D0
	    CTURB_GL(14,7) =1.87D0
	    CTURB_GL(14,8) =2.00D0
	    CTURB_GL(14,9) =2.10D0
	    CTURB_GL(14,10)=2.12D0
	    CTURB_GL(14,11)=2.15D0
	    CTURB_GL(14,12)=2.18D0
	    CTURB_GL(14,13)=2.19D0
	    CTURB_GL(14,14)=1.67D0
	    CTURB_GL(14,15)=1.28D0
	    CTURB_GL(14,16)=1.00D0

	    CTURB_GL(15,1) =1.30D0
	    CTURB_GL(15,2) =1.30D0
	    CTURB_GL(15,3) =1.30D0
	    CTURB_GL(15,4) =1.35D0
	    CTURB_GL(15,5) =1.35D0
	    CTURB_GL(15,6) =1.40D0
	    CTURB_GL(15,7) =1.60D0
	    CTURB_GL(15,8) =1.70D0
	    CTURB_GL(15,9) =1.70D0
	    CTURB_GL(15,10)=1.70D0
	    CTURB_GL(15,11)=1.70D0
	    CTURB_GL(15,12)=1.70D0
	    CTURB_GL(15,13)=1.70D0
	    CTURB_GL(15,14)=1.40D0
	    CTURB_GL(15,15)=1.25D0
	    CTURB_GL(15,16)=1.00D0

	    CTURB_GL(16,1) =1.17D0
	    CTURB_GL(16,2) =1.17D0
	    CTURB_GL(16,3) =1.17D0
	    CTURB_GL(16,4) =1.17D0
	    CTURB_GL(16,5) =1.17D0
	    CTURB_GL(16,6) =1.25D0
	    CTURB_GL(16,7) =1.30D0
	    CTURB_GL(16,8) =1.35D0
	    CTURB_GL(16,9) =1.40D0
	    CTURB_GL(16,10)=1.45D0
	    CTURB_GL(16,11)=1.45D0
	    CTURB_GL(16,12)=1.47D0
	    CTURB_GL(16,13)=1.44D0
	    CTURB_GL(16,14)=1.30D0
	    CTURB_GL(16,15)=1.12D0
	    CTURB_GL(16,16)=1.00D0
          ENDIF
          IF(IEPS_800.EQ.1.AND.IEPS_1600.EQ.1) THEN
            DO I=1,K0G_GL
               DO J=1,K0L_GL
                  CTURB_GL(I,J)=CTURB_GL(I,J)*1.7D0
               ENDDO
            ENDDO 
          ENDIF
          DO J=1,K0L_GL
             DO I=1,K0G_GL
                CTURB_GL(I,J)=(CTURB_GL(I,J)-1.0D0)/1.5D0+1.0D0
             ENDDO
          ENDDO
	  DO I=KRMING_GL,KRMAXG_GL
             DO J=KRMINL_GL,KRMAXL_GL
                CTURBGL(I,J)=1.
             ENDDO
          ENDDO
          DO I=KRMING_GL,KRMAXG_GL                   
             X_KERN=RADXXO(I,6)*1.0D4
             IF(X_KERN.LT.RG_GL(1)) X_KERN=RG_GL(1)
             IF(X_KERN.GT.RG_GL(K0G_GL)) X_KERN=RG_GL(K0G_GL) 
             DO J=KRMINL_GL,KRMAXL_GL
                Y_KERN=RADXXO(J,1)*1.0D4
                IF(Y_KERN.LT.RL_GL(1)) Y_KERN=RL_GL(1)
                IF(Y_KERN.GT.RL_GL(K0L_GL)) Y_KERN=RL_GL(K0L_GL)
                CTURBGL(I,J)=F(X_KERN,Y_KERN,RG_GL,RL_GL,CTURB_GL &
     &                      ,K0G_GL,K0L_GL)	      
             ENDDO
          ENDDO
          IF(IEPS_800.EQ.1) THEN
            DO I=KRMING_GL,15
               DO J=KRMINL_GL,13
                  IF(CTURBGL(I,J).LT.3.0D0) CTURBGL(I,J)=3.0D0
               ENDDO
            ENDDO
          ENDIF
          IF(IEPS_1600.EQ.1) THEN
            DO I=KRMING_GL,15
               DO J=KRMINL_GL,13
                  IF(CTURBGL(I,J).LT.5.1D0) CTURBGL(I,J)=5.1D0
               ENDDO
            ENDDO
          ENDIF
	  DO I=1,33
             DO J=1,24
                IF(I.LE.14.AND.J.EQ.8) CTURBGL(I,J)=1.0D0
                IF(I.GT.14.AND.J.LE.8) CTURBGL(I,J)=1.2D0
	     ENDDO
          ENDDO                       
	RETURN
	END SUBROUTINE TURBCOEF
!===================================================================
! QUESTION
        real * 8 function f(x,y,x0,y0,table,k0,kk0)
! two-dimensional linear interpolation of the collision efficiency
! with help table(k0,kk0)

       implicit none
       integer k0,kk0,k,ir,kk,iq
       double precision x,y,p,q,ec,ek
!      double precision x,y,p,q,ec,ek,f
       double precision x0(k0),y0(kk0),table(k0,kk0)


        do k=2,k0
           if(x.le.x0(k).and.x.ge.x0(k-1)) then
             ir=k     
           elseif(x.gt.x0(k0)) then
             ir=k0+1
           elseif(x.lt.x0(1)) then
             ir=1
           endif
        enddo
        do kk=2,kk0
           if(y.le.y0(kk).and.y.ge.y0(kk-1)) iq=kk
        enddo
        if(ir.lt.k0+1) then
          if(ir.ge.2) then
            p =(x-x0(ir-1))/(x0(ir)-x0(ir-1))
            q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
            ec=(1.d0-p)*(1.d0-q)*table(ir-1,iq-1)+ &
     &              p*(1.d0-q)*table(ir,iq-1)+ &
     &              q*(1.d0-p)*table(ir-1,iq)+ &
     &                   p*q*table(ir,iq)    
          else
            q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
            ec=(1.d0-q)*table(1,iq-1)+q*table(1,iq)    
          endif
        else
          q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
          ek=(1.d0-q)*table(k0,iq-1)+q*table(k0,iq)
          ec=min(ek,1.d0) 
        endif
        f=ec
        return
        end function f
! function f
                                                                            

                                                                            

!======================================================================
        SUBROUTINE FREEZ(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
     &,TIN,DT,RO,COL,AFREEZMY,BFREEZMY,BFREEZMAX,KRFREEZ,ICEMAX,NKR)       
      IMPLICIT NONE 
      INTEGER KR,ICE,ICE_TYPE
      REAL COL,AFREEZMY,BFREEZMY,BFREEZMAX
      INTEGER KRFREEZ,ICEMAX,NKR
      REAL DT,RO,YKK,PF,PF_1,DEL_T,TT_DROP,ARG_1,YK2,DF1,BF,ARG_M, & 
     & TT_DROP_AFTER_FREEZ,CFREEZ,SUM_ICE,TIN,TTIN,AF,FF_MAX,F1_MAX, &
     & F2_MAX,F3_MAX,F4_MAX,F5_MAX


	REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX) &
     &           ,XI(NKR,ICEMAX),FF3(NKR),XS(NKR),FF4(NKR) &
     &           ,XG(NKR),FF5(NKR),XH(NKR)



	TTIN=TIN
        DEL_T	=TTIN-273.15
	ICE_TYPE=2
	F1_MAX=0.
	F2_MAX=0.
	F3_MAX=0.
	F4_MAX=0.
	F5_MAX=0.
	DO 1 KR=1,NKR
	F1_MAX=AMAX1(F1_MAX,FF1(KR))
	F3_MAX=AMAX1(F3_MAX,FF3(KR))
	F4_MAX=AMAX1(F4_MAX,FF4(KR))
	F5_MAX=AMAX1(F5_MAX,FF5(KR))
	DO 1 ICE=1,ICEMAX
     	F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
    1   CONTINUE
    	FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
!
!******************************* FREEZING ****************************
!
        IF(DEL_T.LT.0.AND.F1_MAX.NE.0) THEN
	SUM_ICE=0.
	AF	=AFREEZMY
	CFREEZ	=(BFREEZMAX-BFREEZMY)/XL(NKR)
!
!***************************** MASS LOOP **************************
!
         DO  KR	=1,NKR
	 ARG_M	=XL(KR)
	 BF	=BFREEZMY+CFREEZ*ARG_M
         PF_1	=AF*EXP(-BF*DEL_T)
         PF	=ARG_M*PF_1
	 YKK	=EXP(-PF*DT)
         DF1	=FF1(KR)*(1.-YKK)
	 YK2	=DF1
         FF1(KR)=FF1(KR)*YKK
	 IF(KR.LE.KRFREEZ)  THEN
	 FF2(KR,ICE_TYPE)=FF2(KR,ICE_TYPE)+YK2
			    ELSE
	  FF5(KR)	=FF5(KR)+YK2
	 ENDIF
         SUM_ICE=SUM_ICE+YK2*3.*XL(KR)*XL(KR)*COL
!
!************************ END OF "MASS LOOP" **************************
!
	 ENDDO
!
!************************** NEW TEMPERATURE *************************
!	
	ARG_1	=333.*SUM_ICE/RO
      	TT_DROP_AFTER_FREEZ=TTIN+ARG_1
	TIN	=TT_DROP_AFTER_FREEZ
!
!************************** END OF "FREEZING" ****************************
!
	ENDIF
!
   	RETURN                                                           
      	END SUBROUTINE FREEZ                                                             

        SUBROUTINE ORIG_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
     &                           ,TIN,DT,RO,COL,ICEMAX,NKR)
      IMPLICIT NONE
      INTEGER KR,ICE,ICE_TYPE
      INTEGER ICEMAX,NKR
      REAL COL
      REAL ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DT,DF1,DN,DN0, &
     & RO,A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, &
     & DEL_T,gamma,TIN
        REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX),XI(NKR,ICEMAX) &
     &           ,FF3(NKR),XS(NKR),FF4(NKR) &
     &           ,XG(NKR),FF5(NKR),XH(NKR)


        gamma=4.4
        DEL_T	=TIN-273.15
	ICE_TYPE=2
	F1_MAX=0.
	F2_MAX=0.
	F3_MAX=0.
	F4_MAX=0.
	F5_MAX=0.
	DO 1 KR=1,NKR
	F1_MAX=AMAX1(F1_MAX,FF1(KR))
	F3_MAX=AMAX1(F3_MAX,FF3(KR))
	F4_MAX=AMAX1(F4_MAX,FF4(KR))
	F5_MAX=AMAX1(F5_MAX,FF5(KR))
	DO 1 ICE=1,ICEMAX
     	F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
    1	CONTINUE
    	FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
! MELTING :
	IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN
	  SUM_ICE=0.
! MASS LOOP :
  	  DO KR=1,NKR
	     ARG_M=FF3(KR)+FF4(KR)+FF5(KR)
	     DO ICE=1,ICEMAX
	        ARG_M=ARG_M+FF2(KR,ICE)
      	        FF2(KR,ICE)=0.
 	     ENDDO
      	     FF1(KR)=FF1(KR)+ARG_M
      	     FF3(KR)=0.
             FF4(KR)=0.
      	     FF5(KR)=0.
	     SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL
! END OF "MASS LOOP"
	  ENDDO
! CYCLE BY KR
! NEW TEMPERATURE :
	  ARG_1=333.*SUM_ICE/RO	
	  TIN=TIN-ARG_1
! END OF MELTING
! IN CASE DEL_T.GE.0.AND.FF_MAX.NE.0
	ENDIF
   	RETURN                                                           
      	END SUBROUTINE ORIG_MELT                                                             
!===================================================================
       SUBROUTINE J_W_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
     &                           ,TIN,DT,RO,COL,ICEMAX,NKR)
      IMPLICIT NONE
      INTEGER KR,ICE,ICE_TYPE
      INTEGER ICEMAX,NKR
      REAL COL
      REAL ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DT,DF1,DN,DN0, &
     & RO,A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, &
     & DEL_T,TIN,meltrate
        REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX),XI(NKR,ICEMAX) &
     &           ,FF3(NKR),XS(NKR),FF4(NKR) &
     &           ,XG(NKR),FF5(NKR),XH(NKR)


!       gamma=4.4
        DEL_T	=TIN-273.15
	F1_MAX=0.
	F2_MAX=0.
	F3_MAX=0.
	F4_MAX=0.
	F5_MAX=0.
	DO 1 KR=1,NKR
	F1_MAX=AMAX1(F1_MAX,FF1(KR))
	F3_MAX=AMAX1(F3_MAX,FF3(KR))
	F4_MAX=AMAX1(F4_MAX,FF4(KR))
	F5_MAX=AMAX1(F5_MAX,FF5(KR))
	DO 1 ICE=1,ICEMAX
     	F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
    1	CONTINUE
    	FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
! MELTING :
	SUM_ICE=0.
	IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN
! Fan's "MASS LOOP"
          DO KR = 1,NKR
          ARG_M = 0.
            DO ICE = 1,ICEMAX
             IF (ICE ==1) THEN
                 IF (KR .le. 10) THEN
                     ARG_M = ARG_M+FF2(KR,ICE)
                     FF2(KR,ICE)=0.
                 ELSEIF (KR .gt. 10 .and. KR .lt. 18) THEN
                     meltrate = 0.5/50.
                     ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
                     FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
                 ELSE
                     meltrate = 0.683/120.
                     ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
                     FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
                 ENDIF
             ENDIF
             IF (ICE ==2 .or. ICE ==3) THEN
                IF (kr .le. 12) THEN
                    ARG_M = ARG_M+FF2(KR,ICE)
                    FF2(KR,ICE)=0.
                ELSEIF (kr .gt. 12 .and. kr .lt. 20) THEN
                    meltrate = 0.5/50.
                    ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
                    FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
                 ELSE
                    meltrate = 0.683/120.
                    ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
                    FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
                 ENDIF
             ENDIF
            ENDDO  ! Do ice
! snow
                 IF (kr .le. 14) THEN
                    ARG_M = ARG_M+FF3(KR)
                    FF3(KR)=0.
                 ELSEIF (kr .gt. 14 .and. kr .lt. 22) THEN
                    meltrate = 0.5/50.
                    ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
                    FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
                 ELSE
                    meltrate = 0.683/120.
                    ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
                    FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
                 ENDIF
! graupel/hail
                 IF (kr .le. 13) then
                     ARG_M = ARG_M+FF4(KR)+FF5(KR)
                     FF4(KR)=0.
                     FF5(KR)=0.
                 ELSEIF (kr .gt. 13 .and. kr .lt. 23) THEN
                     meltrate = 0.5/50.
                     ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
                     FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
                     FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
                 ELSE
                    meltrate = 0.683/120.
                    ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
                    FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
                    FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
                 ENDIF

                   FF1(KR)=FF1(KR)+ARG_M

                   SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL
! END OF Fan'a "MASS LOOP"
       ENDDO
! CYCLE BY KR
! NEW TEMPERATURE :
        ARG_1=333.*SUM_ICE/RO
        TIN=TIN-ARG_1
! END OF MELTING

	ENDIF
   	RETURN                                                           
      	END SUBROUTINE J_W_MELT                                                             
!===================================================================
      SUBROUTINE JERNUCL01(PSI1,PSI2,FCCNR &
     &                    ,X1,X2,DTT,DQQ,ROR,PP,DSUP1,DSUP2 &
     &  ,COL,AA1_MY, BB1_MY, AA2_MY, BB2_MY &
     &  ,C1_MEY,C2_MEY,SUP2_OLD,DSUPICEXZ &
     &  ,RCCN,DROPRADII,NKR,ICEMAX,ICEPROCS)
      IMPLICIT NONE 
!
      INTEGER ICEMAX,NKR
      INTEGER ICEPROCS
      REAL COL,AA1_MY, BB1_MY, AA2_MY, BB2_MY, &
     &  C1_MEY,C2_MEY,SUP2_OLD,DSUPICEXZ, &
     &  RCCN(NKR),DROPRADII(NKR),FCCNR(NKR)
!
      INTEGER KR,ICE,ITYPE,NRGI,ICORR,II,JJ,KK,NKRDROP,NCRITI
       DOUBLE PRECISION DTT,DQQ,DSUP1,DSUP2
       REAL TT,QQ,              &
     & DX,BMASS,CONCD,C2,CONCDF,DELTACD,CONCDIN,ROR, &
     & DELTAF,DELMASSL,FMASS,HELEK1,DEL2NN,FF1BN, &
     & HELEK2,TPCC,PP,ADDF,DSUP2N,FACT,EW1N,ES2N,ES1N,FNEW, &
     & C1,SUP1N,SUP2N,QPN,TPN,TPC,SUP1,SUP2,DEL1N,DEL2N,AL1,AL2, &
     & TEMP1,TEMP2,TEMP3,A1,B1,A2,B2 
!

!********************************************************************

! NEW MEYERS IN JERNUCL01 SUBROUTINE 



!********************************************************************



      REAL PSI1(NKR),X1(NKR),DROPCONCN(NKR) &
     &     ,PSI2(NKR,ICEMAX),X2(NKR,ICEMAX)
      

      DATA A1,B1,A2,B2/-0.639,0.1296,-2.8,0.262/
      DATA TEMP1,TEMP2,TEMP3/-5.,-2.,-20./
      DATA AL1/2500./,AL2/2834./
      SUP1=DSUP1
      SUP2=DSUP2


      TT=DTT
      QQ=DQQ
! DROPLETS NUCLEATION (BEGIN)

        TPN=TT
        QPN=QQ

        DEL1N=100.*SUP1
        TPC=TT-273.15

        IF(DEL1N.GT.0.AND.TPC.GT.-30.) THEN
         CALL WATER_NUCL (PSI1,FCCNR,X1,TT,SUP1  &
     &        ,COL,RCCN,DROPRADII,NKR,ICEMAX)
        ENDIF
! DROPLETS NUCLEATION (END)
! drop nucleation                                               (end)
! nucleation of crystals                                      (begin)

       IF (ICEPROCS.EQ.1)THEN
        DEL2N=100.*SUP2
        IF(TPC.LT.0..AND.TPC.GE.-35..AND.DEL2N.GT.0.) THEN

              CALL ICE_NUCL (PSI2,X2,TT,ROR,SUP2,SUP2_OLD &
     &                      ,C1_MEY,C2_MEY,COL,DSUPICEXZ &
     &                      ,NKR,ICEMAX)
        ENDIF
       ENDIF
! nucleation of crystals                                        (end)
! new change in drop nucleation                               (begin)
! no sink of water vapour by nucleation
      RETURN
      END SUBROUTINE JERNUCL01

! SUBROUTINE JERNUCL01
!======================================================================      
      SUBROUTINE WATER_NUCL (PSI1,FCCNR,X1,TT,SUP1 &
     &,COL,RCCN,DROPRADII,NKR,ICEMAX)
      IMPLICIT NONE
      INTEGER NDROPMAX,KR,ICEMAX,NKR
      REAL PSI1(NKR),FCCNR(NKR),X1(NKR)
      REAL DROPCONCN(NKR)
      REAL RCCN(NKR),DROPRADII(NKR)
      REAL TT,SUP1,DX,COL


      CALL NUCLEATION (SUP1,TT,FCCNR,DROPCONCN  &
     &,NDROPMAX,COL,RCCN,DROPRADII,NKR,ICEMAX)

! NEW WATER SIZE DISTRIBUTION FUNCTION (BEGIN)
        DO KR=1,NDROPMAX
           DX=3.*COL*X1(KR)
! new changes 25.06.01                                        (begin)
           PSI1(KR)=PSI1(KR)+DROPCONCN(KR)/DX
! new changes 25.06.01                                          (end)
        ENDDO

      RETURN
      END SUBROUTINE WATER_NUCL
      SUBROUTINE ICE_NUCL (PSI2,X2,TT,ROR,SUP2,SUP2_OLD &
     &                      ,C1_MEY,C2_MEY,COL,DSUPICEXZ &
     &                      ,NKR,ICEMAX)
        IMPLICIT NONE
        INTEGER ITYPE,KR,ICE,NRGI,ICEMAX,NKR
        REAL DEL2N,SUP2,C1,C2,C1_MEY,C2_MEY,TPC,TT,ROR
        REAL DX,COL,BMASS,BFMASS,FMASS
        REAL HELEK1,HELEK2,TPCC,DEL2NN,FF1BN,DSUPICEXZ
        REAL FACT,DSUP2N,SUP2_OLD,DELTACD,DELTAF,ADDF,FNEW
        REAL X2(NKR,ICEMAX),PSI2(NKR,ICEMAX)

        REAL A1,B1,A2,B2
        DATA A1,B1,A2,B2/-0.639,0.1296,-2.8,0.262/
        REAL TEMP1,TEMP2,TEMP3
        DATA TEMP1,TEMP2,TEMP3/-5.,-2.,-20./

        C1=C1_MEY
        C2=C2_MEY
! TYPE OF ICE WITH NUCLEATION (BEGIN)

        TPC=TT-273.15
        ITYPE=0

        IF((TPC.GT.-4.0).OR.(TPC.LE.-8.1.AND.TPC.GT.-12.7).OR.&
     &  (TPC.LE.-17.8.AND.TPC.GT.-22.4)) THEN
          ITYPE=2
        ELSE
          IF((TPC.LE.-4.0.AND.TPC.GT.-8.1).OR.(TPC.LE.-22.4)) THEN
            ITYPE=1
          ELSE
            ITYPE=3
          ENDIF
        ENDIF



! NEW CRYSTAL SIZE DISTRIBUTION FUNCTION                      (BEGIN)

        ICE=ITYPE

        NRGI=2
        IF(TPC.LT.TEMP1) THEN
          DEL2N=100.*SUP2
          DEL2NN=DEL2N
          IF(DEL2N.GT.50.0) DEL2NN=50.
          HELEK1=C1*EXP(A1+B1*DEL2NN)
        ELSE
          HELEK1=0.
        ENDIF

        IF(TPC.LT.TEMP2) THEN
          TPCC=TPC
          IF(TPCC.LT.TEMP3) TPCC=TEMP3
          HELEK2=C2*EXP(A2-B2*TPCC)
        ELSE
          HELEK2=0.
        ENDIF

        FF1BN=HELEK1+HELEK2

        FACT=1.
        DSUP2N=(SUP2-SUP2_OLD+DSUPICEXZ)*100.

        SUP2_OLD=SUP2

        IF(DSUP2N.GT.50.) DSUP2N=50.

        DELTACD=FF1BN*B1*DSUP2N

        IF(DELTACD.GE.FF1BN) DELTACD=FF1BN

        IF(DELTACD.GT.0.) THEN
          DELTAF=DELTACD*FACT
          DO KR=1,NRGI-1
             DX=3.*X2(KR,ICE)*COL
             ADDF=DELTAF/DX
             PSI2(KR,ICE)=PSI2(KR,ICE)+ADDF
          ENDDO
        ENDIF
! NEW CRYSTAL SIZE DISTRIBUTION FUNCTION                        (END)
       RETURN
       END SUBROUTINE ICE_NUCL





      SUBROUTINE NUCLEATION (SUP1,TT,FCCNR,DROPCONCN  &
     &,NDROPMAX,COL,RCCN,DROPRADII,NKR,ICEMAX)
! DROPCONCN(KR), 1/cm^3 - drop bin concentrations, KR=1,...,NKR

! determination of new size spectra due to drop nucleation

      IMPLICIT NONE
      INTEGER NDROPMAX,IDROP,ICCN,INEXT,ISMALL,KR,NCRITI
      INTEGER ICEMAX,IMIN,IMAX,NKR,I,II,I0,I1
      REAL &
     &  SUP1,TT,RACTMAX,XKOE,R03,SUPCRITI,AKOE23,RCRITI,BKOE, &
     &  AKOE,CONCCCNIN,DEG01,ALN_IP
      REAL CCNCONC(NKR)
      REAL CCNCONC_BFNUCL


      REAL COL
      REAL RCCN(NKR),DROPRADII(NKR),FCCNR(NKR)
      REAL RACT(NKR),DROPCONC(NKR),DROPCONCN(NKR)
      REAL DLN1,DLN2,FOLD_IP



        DEG01=1./3.


! calculation initial value of NDROPMAX - maximal number of drop bin
! which is activated

! initial value of NDROPMAX

        NDROPMAX=0

        DO KR=1,NKR
! initialization of bin radii of activated drops
           RACT(KR)=0.
! initialization of aerosol(CCN) bin concentrations
           CCNCONC(KR)=0.
! initialization of drop bin concentrations
           DROPCONCN(KR)=0.
        ENDDO


! CCNCONC_BFNUCL - concentration of aerosol particles before
!                  nucleation

        CCNCONC_BFNUCL=0.
        DO I=1,NKR
           CCNCONC_BFNUCL=CCNCONC_BFNUCL+FCCNR(I)
        ENDDO

        CCNCONC_BFNUCL=CCNCONC_BFNUCL*COL

        IF(CCNCONC_BFNUCL.EQ.0.) THEN
           RETURN    
        ELSE
           CALL BOUNDARY(IMIN,IMAX,FCCNR,NKR)
           CALL CRITICAL (AKOE,BKOE,TT,RCRITI,SUP1,DEG01)
           IF(RCRITI.GE.RCCN(IMAX))  RETURN
        END IF

! calculation of CCNCONC(I) - aerosol(CCN) bin concentrations;
!                             I=IMIN,...,IMAX
! determination of NCRITI - number bin in which is located RCRITI
        IF (IMIN.EQ.1)THEN
         CALL CCNIMIN(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
     &       FCCNR,NKR)
         CALL CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
     &       FCCNR,NKR)
        ELSE
         CALL CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
     &       FCCNR,NKR)
        END IF


! calculation CCNCONC_AFNUCL - ccn concentration after nucleation

!       CCNCONC_AFNUCL=0.

!       DO I=IMIN,IMAX
!          CCNCONC_AFNUCL=CCNCONC_AFNUCL+FCCNR(I)
!       ENDDO

!       CCNCONC_AFNUCL=CCNCONC_AFNUCL*COL

! calculation DEL_CCNCONC

!       DEL_CCNCONC=CCNCONC_BFNUCL-CCNCONC_AFNUCL
        CALL ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT,RACTMAX,NKR)



        CALL DROPMAX(DROPRADII,RACTMAX,NDROPMAX,NKR)
! put nucleated droplets into the drop bin according to radius
! change in drop concentration due to activation DROPCONCN(IDROP)
        ISMALL=NCRITI

        INEXT=ISMALL
!       ISMALL=1

!       INEXT=ISMALL

        DO IDROP=1,NDROPMAX
           DROPCONCN(IDROP)=0.
           DO I=ISMALL,IMAX
              IF(RACT(I).LE.DROPRADII(IDROP)) THEN
                DROPCONCN(IDROP)=DROPCONCN(IDROP)+CCNCONC(I)
                INEXT=I+1
              ENDIF
           ENDDO
           ISMALL=INEXT
        ENDDO

!999    CONTINUE


        RETURN
        END SUBROUTINE NUCLEATION



        SUBROUTINE BOUNDARY(IMIN,IMAX,FCCNR,NKR)
! IMIN - left CCN spectrum boundary
        IMPLICIT NONE
        INTEGER I,IMIN,IMAX,NKR
        REAL FCCNR(NKR)

        IMIN=0

        DO I=1,NKR
           IF(FCCNR(I).NE.0.) THEN
             IMIN=I
             GOTO 40
           ENDIF
        ENDDO

 40     CONTINUE

! IMAX - right CCN spectrum boundary

        IMAX=0

        DO I=NKR,1,-1
           IF(FCCNR(I).NE.0.) THEN
             IMAX=I
             GOTO 41
           ENDIF
        ENDDO

 41     CONTINUE
        RETURN
        END  SUBROUTINE BOUNDARY

        SUBROUTINE CRITICAL (AKOE,BKOE,TT,RCRITI,SUP1,DEG01)
! AKOE & BKOE - constants in Koehler equation
        IMPLICIT NONE
        REAL AKOE,BKOE,TT,RCRITI,SUP1,DEG01
        REAL RO_SOLUTE
        PARAMETER (RO_SOLUTE=2.16)

         

        AKOE=3.3E-05/TT
        BKOE=2.*4.3/(22.9+35.5)
! new change 21.07.02                                         (begin)
        BKOE=BKOE*(4./3.)*3.141593*RO_SOLUTE                  
! new change 21.07.02                                           (end)
        

! table of critical aerosol radii

!	GOTO 992

! SUP1_TEST(I), %
!       SUP1_TEST(1)=0.01
!       DO I=1,99
!          SUP1_TEST(I+1)=SUP1_TEST(I)+0.01
!          SUP1_I=SUP1_TEST(I)*0.01
!          RCRITI_TEST(I)=(AKOE/3.)*(4./BKOE/SUP1_I/SUP1_I)**DEG01
!       ENDDO

! RCRITI, cm - critical radius of "dry" aerosol

        RCRITI=(AKOE/3.)*(4./BKOE/SUP1/SUP1)**DEG01
        RETURN
        END  SUBROUTINE CRITICAL
            
        SUBROUTINE CCNIMIN(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
     &       FCCNR,NKR)
! FOR    IMIN=1
        IMPLICIT NONE
        INTEGER IMIN,II,IMAX,NCRITI,NKR
        REAL RCRITI,COL
        REAL RCCN(NKR),FCCNR(NKR),CCNCONC(NKR)
        REAL RCCN_MIN
        REAL DLN1,DLN2,FOLD_IP
! rccn_min - minimum aerosol(ccn) radius
        RCCN_MIN=RCCN(1)/10000.
! calculation of ccnconc(ii)=fccnr(ii)*col - aerosol(ccn) bin
!                                            concentrations,
!                                            ii=imin,...,imax
! determination of ncriti   - number bin in which is located rcriti
! calculation of ccnconc(ncriti)=fccnr(ncriti)*dln1/(dln1+dln2),
! where,    
! dln1=Ln(rcriti)-Ln(rccn_min)
! dln2=Ln(rccn(1)-Ln(rcriti)
! calculation of new value of fccnr(ncriti)

!       IF(IMIN.EQ.1) THEN
          IF(RCRITI.LE.RCCN_MIN) THEN
            NCRITI=1
            DO II=NCRITI+1,IMAX
               CCNCONC(II)=COL*FCCNR(II)     
               FCCNR(II)=0.                  
            ENDDO
            GOTO 42
          ENDIF
          IF(RCRITI.GT.RCCN_MIN.AND.RCRITI.LT.RCCN(IMIN)) THEN
            NCRITI=1
            DO II=NCRITI+1,IMAX
               CCNCONC(II)=COL*FCCNR(II)
               FCCNR(II)=0.
            ENDDO
            DLN1=ALOG(RCRITI)-ALOG(RCCN_MIN)
            DLN2=ALOG(RCCN(1))-ALOG(RCRITI)
            CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
            FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/(DLN1+DLN2)
            GOTO 42
! in case RCRITI.GT.RCCN_MIN.AND.RCRITI.LT.RCCN(IMIN)
          ENDIF
! in case IMIN.EQ.1
42       CONTINUE
     
         RETURN
         END SUBROUTINE CCNIMIN
        SUBROUTINE CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
     &       FCCNR,NKR)
        IMPLICIT NONE
         INTEGER I,IMIN,IMAX,NKR,II,NCRITI
         REAL COL
         REAL RCRITI,RCCN(NKR),CCNCONC(NKR),FCCNR(NKR)
         REAL DLN1,DLN2,FOLD_IP
        IF(IMIN.GT.1) THEN
          IF(RCRITI.LE.RCCN(IMIN-1)) THEN
            NCRITI=IMIN
            DO II=NCRITI,IMAX
               CCNCONC(II)=COL*FCCNR(II)
               FCCNR(II)=0.
            ENDDO
            GOTO 42
          ENDIF
          IF(RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)) &
     &    THEN
! this line eliminates bug you found (when IMIN=IMAX)
            NCRITI=IMIN
            
            DO II=NCRITI+1,IMAX
               CCNCONC(II)=COL*FCCNR(II)
               FCCNR(II)=0.
            ENDDO
            DLN1=ALOG(RCRITI)-ALOG(RCCN(IMIN-1))
            DLN2=COL-DLN1
            CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
            FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/COL
            GOTO 42
! in case RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)
          ENDIF
! in case IMIN.GT.1
        ENDIF
        
! END of part of interest. so in case
!RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)
!we go to 42 and avoid the next loop

      

         DO I=IMIN,IMAX-1
           IF(RCRITI.EQ.RCCN(I)) THEN
             NCRITI=I+1
             DO II=I+1,IMAX
                CCNCONC(II)=COL*FCCNR(II)
                FCCNR(II)=0.
             ENDDO
             GOTO 42
           ENDIF
           IF(RCRITI.GT.RCCN(I).AND.RCRITI.LT.RCCN(I+1)) THEN
             NCRITI=I+1
             IF(I.NE.IMAX-1) THEN
               DO II=NCRITI+1,IMAX
                  CCNCONC(II)=COL*FCCNR(II)
                  FCCNR(II)=0.
               ENDDO
             ENDIF
             DLN1=ALOG(RCRITI)-ALOG(RCCN(I))
             DLN2=COL-DLN1
             CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
             FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/COL
             GOTO 42
! in case RCRITI.GT.RCCN(I).AND.RCRITI.LT.RCCN(I+1)
           END IF
      

         ENDDO
! cycle by I, I=IMIN,...,IMAX-1

  42    CONTINUE
        RETURN
        END  SUBROUTINE CCNLOOP
       SUBROUTINE ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT, RACTMAX,NKR)
       IMPLICIT NONE

       INTEGER IMIN,IMAX,NKR
       INTEGER I,I0,I1
       REAL RCCN(NKR)
        REAL  R03,SUPCRITI,RACT(NKR),XKOE
        REAL AKOE,BKOE,AKOE23,RACTMAX
! Spectrum of activated drops                                 (begin) 
        DO I=IMIN,IMAX

! critical water supersaturations appropriating CCN radii

           XKOE=(4./27.)*(AKOE**3/BKOE)
           AKOE23=AKOE*2./3.
           R03=RCCN(I)**3
           SUPCRITI=SQRT(XKOE/R03)

! RACT(I) - radii of activated drops, I=IMIN,...,IMAX

           IF(RCCN(I).LE.(0.3E-5)) &
     &     RACT(I)=AKOE23/SUPCRITI
           IF(RCCN(I).GT.(0.3E-5))&
     &     RACT(I)=5.*RCCN(I)
        ENDDO
! cycle by I

! calculation of I0

        I0=IMIN

        DO I=IMIN,IMAX-1
           IF(RACT(I+1).LT.RACT(I)) THEN
             I0=I+1
             GOTO 45
           ENDIF
        ENDDO

 45     CONTINUE
! new changes 9.04.02                                         (begin)
        I1=I0-1
! new changes 9.04.02                                           (end)

        IF(I0.EQ.IMIN) GOTO 47

! new changes 9.04.02                                         (begin)

        IF(I0.EQ.IMAX) THEN
          RACT(IMAX)=RACT(IMAX-1)
          GOTO 47
        ENDIF

        IF(RACT(IMAX).LE.RACT(I0-1)) THEN
          DO I=I0,IMAX
             RACT(I)=RACT(I0-1)
          ENDDO
          GOTO 47
        ENDIF

! new changes 9.04.02                                           (end)



! calculation of I1

        DO I=I0+1,IMAX
           IF(RACT(I).GE.RACT(I0-1)) THEN
             I1=I
             GOTO 46
           ENDIF
        ENDDO
 46     CONTINUE

! spectrum of activated drops                                   (end)


! line interpolation RACT(I) for I=I0,...,I1

        DO I=I0,I1
           RACT(I)=RACT(I0-1)+(I-I0+1)*(RACT(I1)-RACT(I0-1)) &
     &                       /(I1-I0+1)
        ENDDO


  47    CONTINUE



        RACTMAX=0.

        DO I=IMIN,IMAX
           RACTMAX=AMAX1(RACTMAX,RACT(I))
	ENDDO
        RETURN

        END SUBROUTINE ACTIVATE
        SUBROUTINE DROPMAX(DROPRADII,RACTMAX,NDROPMAX,NKR)
        IMPLICIT NONE
        INTEGER IDROP,NKR,NDROPMAX
        REAL RACTMAX,DROPRADII(NKR)
! calculation of NDROPMAX - maximal number of drop bin which
! is activated

        NDROPMAX=1

        DO IDROP=1,NKR
           IF(RACTMAX.LE.DROPRADII(IDROP)) THEN
             NDROPMAX=IDROP
             GOTO 44
           ENDIF
        ENDDO
 44     CONTINUE
        RETURN
        END  SUBROUTINE DROPMAX


        SUBROUTINE ONECOND1 &
     & (TT,QQ,PP,ROR &
     & ,VR1,PSINGLE &
     & ,DEL1N,DEL2N,DIV1,DIV2 &
     & ,FF1,PSI1,R1,RLEC,RO1BL &
     & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
     & ,C1_MEY,C2_MEY &
     & ,COL,DTCOND,ICEMAX,NKR)

       IMPLICIT NONE


      INTEGER NKR,ICEMAX
      REAL    COL,VR1(NKR),PSINGLE &
     &       ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
     &       ,DTCOND

      REAL C1_MEY,C2_MEY
      INTEGER I_ABERGERON,I_BERGERON, &
     & KR,ICE,ITIME,KCOND,NR,NRM, &
     & KLIMIT, &
     & KM,KLIMITL  
      REAL AL1,AL2,D,GAM,POD, &
     & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
     & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
     & TPC1, TPC2, TPC3, TPC4, TPC5, &
     & EPSDEL, EPSDEL2,DT0L, DT0I,&
     & ROR, &
     & CWHUCM,B6,B8L,B8I, &
     & DEL1,DEL2,DEL1S,DEL2S, &
     & TIMENEW,TIMEREV,SFN11,SFN12, &
     & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,RW,RI,QW,PW, &
     & PI,QI,DEL1N0,DEL2N0,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
     & DEL_R1,DT0L0,DT0I0, &
     & DTNEWL0, &
     & DTNEWL2 
       REAL DT_WATER_COND,DT_WATER_EVAP

       INTEGER K
! NEW ALGORITHM OF CONDENSATION (12.01.00)

      REAL  FF1_OLD(NKR),SUPINTW(NKR)
      DOUBLE PRECISION DSUPINTW(NKR),DD1N,DB11_MY,DAL1,DAL2
      DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
     &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
     &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
     &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
     &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
     &                  ,ES1N,ES2N,EW1N,ARGEXP &
     &                  ,TT,QQ,PP &
     &                  ,DEL1N,DEL2N,DIV1,DIV2 &
     &                  ,OPER2,OPER3,AR1,AR2

       DOUBLE PRECISION DELMASSL1

! DROPLETS 
                                                                       
        REAL R1(NKR) &
     &           ,RLEC(NKR),RO1BL(NKR) &
     &           ,FI1(NKR),FF1(NKR),PSI1(NKR) &
     &           ,B11_MY(NKR),B12_MY(NKR)

! WORK ARRAYS 

! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION

       
	REAL DTIMEO(NKR),DTIMEL(NKR) &
     &           ,TIMESTEPD(NKR)

! NEW ALGORITHM (NO TYPE OF ICE)



	OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
	OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)

        DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
     &      ,GAM /1.E-4/, POD /10./ 
           
	DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
     &      /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/

	DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
     &      /2.53,5.42,3.41E1,6.13/

	DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
     &      /-4.0,-8.1,-12.7,-17.8,-22.4/ 


        DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/  
    
	DATA DT0L, DT0I /1.E20,1.E20/

! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND


! CONTROL OF TIMESTEP ITERATIONS IN MIXED PHASE: EVAPORATION
        
        I_ABERGERON=0
        I_BERGERON=0
        COL3=3.0*COL
        ITIME=0
        KCOND=0
        DT_WATER_COND=0.4
        DT_WATER_EVAP=0.4
	ITIME=0
	KCOND=0
        DT0LREF=0.2
        DTLREF=0.4

	NR=NKR
	NRM=NKR-1
	DT=DTCOND
	DTT=DTCOND
	XRAD=0.

!     BARRY
	CWHUCM=0.
	XRAD=0.
	B6=CWHUCM*GAM-XRAD
	B8L=1./ROR
	B8I=1./ROR
        RORI=1./ROR

! INITIALIZATION OF SOME ARRAYS
!       print*, 'got to here 0'

!       BARRY: REMOVE RS2 LOOP
        DO KR=1,NKR
           FF1_OLD(KR)=FF1(KR)
           SUPINTW(KR)=0.
           DSUPINTW(KR)=0.
        ENDDO
! OLD TREATMENT OF "T" & "Q" 
!DEL12RD=DEL12R**DEL_BBR
! BARRY
!       EW1PN=AA1_MY*(100.+DEL1IN*100.)*DEL12RD/100.
! 	QQIN=OPER4(EW1PN,PP)
        TPN=TT
        QPN=QQ
        DO 19 KR=1,NKR
              FI1(KR)=FF1(KR)
19     CONTINUE
! WARM OR NO ICE (BEGIN)
! ONLY WATER (CONDENSATION OR EVAPORATION) (BEGIN)
              TIMENEW=0.
              ITIME=0
! NEW CHANGES 10.01.01 (BEGIN)
              TOLD=TPN
              QOLD=QPN
! NEW CHANGES 10.01.01 (END)
   56         ITIME=ITIME+1
              TIMEREV=DT-TIMENEW
              TIMEREV=DT-TIMENEW
              DEL1=DEL1N
              DEL2=DEL2N
              DEL1S=DEL1N
              DEL2S=DEL2N
              TPS=TPN
              QPS=QPN
! NO QPS IN JERRATE
              CALL JERRATE(R1,TPS,PP,ROR,VR1,PSINGLE &
     &                    ,RLEC,RO1BL,B11_MY,B12_MY,1,1,ICEMAX,NKR)

! INTEGRALS IN DELTA EQUATION (ONLY WATER)

! CONTROL OF DROP SPECRUM IN SUBROUTINE ONECOND


! CALL JERTIMESC WATER - 1 (ONLY WATER)

              CALL JERTIMESC(FI1,R1,SFN11,SFN12 &
     &                      ,B11_MY,B12_MY,RLEC,B8L,1,COL,NKR)        


	      SFNL=SFN11+SFN12
	      SFNI=0.       

! SOME CONSTANTS 
	      B5L=BB1_MY/TPS/TPS
	      B5I=BB2_MY/TPS/TPS
              B7L=B5L*B6                                                     
              B7I=B5I*B6
	      DOPL=1.+DEL1S                                                     
	      DOPI=1.+DEL2S                                                     
              RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL                                                 
              RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
	      QW=B7L*DOPL
	      PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
              PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
              QI=B7I*DOPI

! SOLVING FOR TIMEZERO



	      KCOND=10

	      IF(DEL1.GT.0) KCOND=11

! PROCESS'S TYPE 

	      IF(KCOND.EQ.11) THEN
! NEW TIME STEP IN CONDENSATION (ONLY WATER) (BEGIN)
                IF (DEL1N.EQ.0)THEN
	           DTNEWL=DT
                ELSE
                 DTNEWL=ABS(R1(ITIME)/(B11_MY(ITIME)*DEL1N &
     &                               -B12_MY(ITIME)))
	         IF(DTNEWL.GT.DT) DTNEWL=DT
                END IF
                IF(ITIME.GE.NKR) THEN
                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
                ENDIF
                TIMESTEPD(ITIME)=DTNEWL

! NEW TIME STEP (ONLY WATER: CONDENSATION)


	        IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  & 
     &          DTNEWL=DT-TIMENEW
                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW

	        TIMESTEPD(ITIME)=DTNEWL

	        TIMENEW=TIMENEW+DTNEWL

	        DTT=DTNEWL

! SOLVING FOR SUPERSATURATION 

! CALL JERSUPSAT - 2 (NEW TIMESTEP - ONLY WATER)


	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
     &                        ,RW,PW,RI,PI,QW,QI &
     &                        ,DTT,D1N,D2N,DT0L,DT0I)

! END OF "NEW SUPERSATURATION"

! DROPLETS 

! DROPLET DISTRIBUTION FUNCTION 
                                                         
! CALL JERDFUN WATER - 1 (ONLY WATER: CONDENSATION)
	          CALL JERDFUN(R1,B11_MY,B12_MY &
     &                        ,FI1,PSI1,D1N &
     &                        ,1,1,COL,NKR,TPN)

	        IF((DEL1.GT.0.AND.DEL1N.LT.0) &
     &         .AND.ABS(DEL1N).GT.EPSDEL) THEN
             call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL1.GT.0.AND.DEL1N.LT.0), model stop")
	        ENDIF

! IN CASE : KCOND.EQ.11

	      ELSE

! EVAPORATION - ONLY WATER 

! IN CASE : KCOND.NE.11
               IF (DEL1N.EQ.0)THEN
                DTIMEO(1)=DT
	        DO KR=2,NKR
	           DTIMEO(KR)=DT
	        ENDDO
               ELSE
	        DTIMEO(1)=-R1(1)/(B11_MY(1)*DEL1N-B12_MY(1))

	        DO KR=2,NKR
	           KM=KR-1
	           DTIMEO(KR)=(R1(KM)-R1(KR))/(B11_MY(KR)*DEL1N &
     &                                       -B12_MY(KR))
	        ENDDO
               END IF

	        KLIMIT=1

	        DO KR=1,NKR
	           IF(DTIMEO(KR).GT.TIMEREV) GOTO 55
	           KLIMIT=KR
	        ENDDO

   55           KLIMIT=KLIMIT-1

	        IF(KLIMIT.LT.1) KLIMIT=1

! BARRY THIS LINE CAUSED A PROBLEM BECAUSE DTNEWL GOES FROM
! LARGE TO SMALL
  	        DTNEWL1=AMIN1(DTIMEO(3),TIMEREV)
                IF(DTNEWL1.LT.DTLREF) DTNEWL1=AMIN1(DTLREF,TIMEREV)
	        DTNEWL=DTNEWL1
	        IF(ITIME.GE.NKR) THEN
           call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
	        ENDIF

	        TIMESTEPD(ITIME)=DTNEWL

! NEW TIME STEP (ONLY_WATER: EVAPORATION)

	        IF(DTNEWL.GT.DT) DTNEWL=DT
                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
     &          DTNEWL=DT-TIMENEW
                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW

	        TIMESTEPD(ITIME)=DTNEWL

	        TIMENEW=TIMENEW+DTNEWL

	        DTT=DTNEWL

! SOLVING FOR SUPERSATURATION 


! CALL JERSUPSAT - 3 (ONLY_WATER: EVAPORATION)

	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
     &                        ,RW,PW,RI,PI,QW,QI &
     &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
! END OF "NEW SUPERSATURATION"


! DROPLETS 


! DROPLET DISTRIBUTION FUNCTION (ONLY_WATER: EVAPORATION)
                                                         
! CALL JERDFUN WATER - 2 (ONLY_WATER: EVAPORATION)
             
 	          CALL JERDFUN(R1,B11_MY,B12_MY &
     &                        ,FI1,PSI1,D1N &
     &                        ,1,1,COL,NKR,TPN)

! IN CASE : ISYML.NE.0 (ENDING OF 
! "DROPLET DISTRIBUTION FUNCTION" (ONLY WATER: EVAPORATION)

!        ENDIF

	        IF((DEL1.LT.0.AND.DEL1N.GT.0) &
     &         .AND.ABS(DEL1N).GT.EPSDEL) THEN
            call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL1.LT.0.AND.DEL1N.GT.0), model stop")
	        ENDIF

! END OF "PROCESS'S TYPE" 

! IN CASE : KCOND.NE.11 (ONLY WATER: EVAPORATION)

              ENDIF

! IN CASES : KCOND.EQ.11 OR KCOND.NE.11 (BOTH CONDENSATION AND
! EVAPORATION : ONLY WATER)

! CONCENTRATION & MASS (ONLY WATER) 

      RMASSLBB=0.
      RMASSLAA=0.

! BEFORE JERNEWF (ONLY WATER) 

              DO K=1,NKR
                 FI1_K=FI1(K)
                 R1_K=R1(K)
                 FI1R1=FI1_K*R1_K*R1_K
                 RMASSLBB=RMASSLBB+FI1R1
              ENDDO
              RMASSLBB=RMASSLBB*COL3*RORI
! NEW CHANGE RMASSLBB
              IF(RMASSLBB.LE.0.) RMASSLBB=0.
              DO K=1,NKR
                 FI1_K=PSI1(K)
                 R1_K=R1(K)
                 FI1R1=FI1_K*R1_K*R1_K
                 RMASSLAA=RMASSLAA+FI1R1
              ENDDO
              RMASSLAA=RMASSLAA*COL3*RORI
              IF(RMASSLAA.LE.0.) RMASSLAA=0.
! NEW TREATMENT OF "T" & "Q" (ONLY WATER)
              DELMASSL1=RMASSLAA-RMASSLBB
              QPN=QPS-DELMASSL1
              DAL1=AL1
              TPN=TPS+DAL1*DELMASSL1
! SUPERSATURATION (ONLY WATER)
              ARGEXP=-BB1_MY/TPN
              ES1N=AA1_MY*DEXP(ARGEXP)
              ARGEXP=-BB2_MY/TPN
              ES2N=AA2_MY*DEXP(ARGEXP)
              EW1N=OPER3(QPN,PP)
              IF(ES1N.EQ.0)THEN
               DEL1N=0.5
               DIV1=1.5
              ELSE
               DIV1=EW1N/ES1N
               DEL1N=EW1N/ES1N-1.
              END IF
              IF(ES2N.EQ.0)THEN
               DEL2N=0.5
               DIV2=1.5
              ELSE
               DEL2N=EW1N/ES2N-1.
               DIV2=EW1N/ES2N
              END IF
              DO KR=1,NKR
                SUPINTW(KR)=SUPINTW(KR)+B11_MY(KR)*D1N
                DD1N=D1N
                DB11_MY=B11_MY(KR)
                DSUPINTW(KR)=DSUPINTW(KR)+DB11_MY*DD1N
              ENDDO
! REPEATE TIME STEP (ONLY WATER: CONDENSATION OR EVAPORATION) 
	      IF(TIMENEW.LT.DT) GOTO 56
57            CONTINUE
              CALL JERDFUN_NEW(R1,DSUPINTW &
     &                        ,FF1_OLD,PSI1,D1N &
     &                        ,1,1,COL,NKR,TPN)
              RMASSLAA=0.0
              RMASSLBB=0.0
! BEFORE JERNEWF
              DO K=1,NKR
                 FI1_K=FF1_OLD(K)
                 R1_K=R1(K)
                 FI1R1=FI1_K*R1_K*R1_K
                 RMASSLBB=RMASSLBB+FI1R1
              ENDDO
              RMASSLBB=RMASSLBB*COL3*RORI
! NEW CHANGE RMASSLBB
              IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
! AFTER  JERNEWF
              DO K=1,NKR
                 FI1_K=PSI1(K)
                 R1_K=R1(K)
                 FI1R1=FI1_K*R1_K*R1_K
                 RMASSLAA=RMASSLAA+FI1R1
              ENDDO
              RMASSLAA=RMASSLAA*COL3*RORI
! NEW CHANGE RMASSLAA
              IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
              IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
! NEW TREATMENT OF "T" & "Q"
              DELMASSL1=RMASSLAA-RMASSLBB
! NEW CHANGES 10.01.01 (BEGIN)
              QPN=QOLD-DELMASSL1
              DAL1 = AL1
              TPN=TOLD+DAL1*DELMASSL1
! NEW CHANGES 10.01.01 (END)
! SUPERSATURATION
              ARGEXP=-BB1_MY/TPN
              ES1N=AA1_MY*DEXP(ARGEXP)
              ARGEXP=-BB2_MY/TPN
              ES2N=AA2_MY*DEXP(ARGEXP)
              EW1N=OPER3(QPN,PP)
              IF(ES1N.EQ.0)THEN
               DEL1N=0.5
               DIV1=1.5
   call wrf_error_fatal("fatal error in module_mp_fast_sbm (ES1N.EQ.0), model stop")
              ELSE
               DIV1=EW1N/ES1N
               DEL1N=EW1N/ES1N-1.
              END IF
              IF(ES2N.EQ.0)THEN
               DEL2N=0.5
               DIV2=1.5
   call wrf_error_fatal("fatal error in module_mp_fast_sbm (ES2N.EQ.0), model stop")
              ELSE
               DEL2N=EW1N/ES2N-1.
               DIV2=EW1N/ES2N
              END IF
        TT=TPN
        QQ=QPN
	DO KR=1,NKR
	   FF1(KR)=PSI1(KR)
	ENDDO




       RETURN
!      END 

  END SUBROUTINE ONECOND1
!==================================================================



!BARRY
        SUBROUTINE JERDFUN(R2,B21_MY,B22_MY &
     &                    ,FI2,PSI2,DEL2N &
     &                    ,IND,ITYPE,COL,NKR,TPN)
       IMPLICIT NONE

! CRYSTALS 
       REAL COL,DEL2N
                                                                       
      INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,NKR,IDROP
       REAL &
     &       R2(NKR,IND),R2N(NKR,IND) &
     &      ,FI2(NKR,IND),PSI2(NKR,IND) &
     &      ,B21_MY(NKR,IND),B22_MY(NKR,IND) &
     &      ,DEL_R2M(NKR,IND)
        DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
        DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND),DDEL2N, &
     &     DB21_MY(NKR,IND)
       DOUBLE PRECISION CHECK,TPN
          CHECK=0.D0
           DO KR=1,NKR
             CHECK=B21_MY(1,1)*B21_MY(KR,1)
             IF (CHECK.LT.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (CHECK.LT.0), model stop") 
           END DO

	IF(IND.NE.1) THEN
	  ITYP=ITYPE
        ELSE
	  ITYP=1
	ENDIF

           DDEL2N=DEL2N
	DO KR=1,NKR
	   PSI2R(KR)=FI2(KR,ITYP)
	   FI2R(KR)=FI2(KR,ITYP)
           DR2(KR,ITYP)=R2(KR,ITYP)
           DB21_MY(KR,ITYP)=B21_MY(KR,ITYP)
	ENDDO
!
!Q2=0.
	NR=NKR
	NRM=NKR-1

! NEW DISTRIBUTION FUNCTION 

	  DO 8 ICE=1,IND
	       IF(ITYP.EQ.ICE) THEN
	          DO KR=1,NKR
                    DR2N(KR,ICE)=DR2(KR,ICE)+DDEL2N*DB21_MY(KR,ICE)
                    R2N(KR,ICE)=DR2N(KR,ICE)
!                   IF (D1N.LT.0)THEN
!	             if (DR2N(KR,ICE).EQ.DR2(KR,ICE))THEN
!		        KK=NKR-KR+1
!	       		DR2N(KR,ICE)=R2N(KR,ICE)-2.E-15/2**KK
!                    end if
!                   END IF

	          ENDDO
	        ENDIF
    8	  CONTINUE
! CRYSTAL DISTRIBUTION FUNCTION 
                                                          
	  DO ICE=1,IND

! ICE_TYPE 
	     IF(ITYP.EQ.ICE) THEN
!       Q2=20.*ITYPE+ICE
               DO 5 KR=1,NKR
	            R2R(KR)=DR2(KR,ICE)
	            R2NR(KR)=DR2N(KR,ICE)               
    5         continue
! Andrei's new change 1.12.09                                 (start)
!            IDROP=1
!            IDROP=0
             IF(IND.EQ.1.AND.ITYPE.EQ.1) IDROP=1
! Andrei's new change 1.12.09                                   (end)
             CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR &
! Andrei's new change 1.12.09                                 (start)
     &                   ,IDROP,TPN)
! Andrei's new change 1.12.09                                   (end)



!              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
	       DO KR=1,NKR                              
	          PSI2(KR,ICE)=PSI2R(KR)
	       ENDDO


! END OF "ICE_TYPE" 

	     ENDIF

! END OF "CRYSTAL DISTRIBUTION FUNCTION" 
                                                          
	  ENDDO

! END OF "NEW DISTRIBUTION FUNCTION"


	RETURN
	END SUBROUTINE JERDFUN
!===================================================================
        SUBROUTINE JERDFUN_NEW(R2,B21_MY &
     &                    ,FI2,PSI2,DEL2N &
     &                    ,IND,ITYPE,COL,NKR,TPN)
       IMPLICIT NONE

! CRYSTALS 
       REAL COL,DEL2N
                                                                       
      INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,KK,NKR,IDROP
       REAL &
     &       R2(NKR,IND),R2N(NKR,IND) &
     &      ,FI2(NKR,IND),PSI2(NKR,IND)
       DOUBLE PRECISION TPN
       DOUBLE PRECISION  B21_MY(NKR,IND)
        DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
        DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND),DDEL2N, &
     &     DB21_MY(NKR,IND)
	IF(IND.NE.1) THEN
	  ITYP=ITYPE
        ELSE
	  ITYP=1
	ENDIF

           DDEL2N=DEL2N
	DO KR=1,NKR
	   PSI2R(KR)=FI2(KR,ITYP)
	   FI2R(KR)=FI2(KR,ITYP)
           DR2(KR,ITYP)=R2(KR,ITYP)
	ENDDO
!
!Q2=0.
	NR=NKR
	NRM=NKR-1

! NEW DISTRIBUTION FUNCTION 

! CRYSTAL DISTRIBUTION FUNCTION 
	  DO ICE=1,IND
! ICE_TYPE 
	     IF(ITYP.EQ.ICE) THEN
               DO 5 KR=1,NKR
	            R2R(KR)=DR2(KR,ICE)
	            R2NR(KR)=DR2(KR,ICE)+B21_MY(KR,ICE)
                    R2N(KR,ICE)=R2NR(KR)
!                   IF (D1N.LT.0)THEN
!	            	 if (R2NR(KR).EQ.R2R(KR))THEN
!	       		 KK=NKR-KR+1
!		        R2NR(KR)=R2R(KR)-2.E-15/2**KK
!		      end if
!	            END IF
    5         continue
! Andrei's new change 1.12.09                                 (start)
             IDROP=1
!            IDROP=0
             CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR &
     &                   ,IDROP,TPN)
! Andrei's new change 1.12.09                                   (end)


!              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
	       DO KR=1,NKR                              
	          PSI2(KR,ICE)=PSI2R(KR)
	       ENDDO

! END OF "ICE_TYPE" 

	     ENDIF

! END OF "CRYSTAL DISTRIBUTION FUNCTION" 
                                                          
	  ENDDO

! END OF "NEW DISTRIBUTION FUNCTION"


	RETURN
	END SUBROUTINE JERDFUN_NEW
! SUBROUTINE JERDFUN_NEW (NEW ALGORITHM OF CONDENSATION, 12.01.00)

! new change 30.01.06                                         (start)
!       SUBROUTINE JERNEWF(NRX,NRM,RR,FI,PSI,RN,COL,NKR)

        SUBROUTINE JERNEWF &
       (NRX,NRM,RR,FI_OLD,PSI,RN,COL,NKR, &
! Andrei's new change 1.12.09                                 (start)           
        IDROP,TPN)
! Andrei's new change 1.12.09                                   (end)	
 
        IMPLICIT NONE
        INTEGER  & 
        I,K,KM,NRXP,IM,IP,IFIN,IIN,ISYM,NKR
	
! Andrei's new change 1.12.09                                 (start)

        INTEGER &
	KRDROP_REMAP_MIN,KRDROP_REMAP_MAX,IDROP,KMAX
	
        DOUBLE PRECISION &
	COEFF_REMAP,TPN
	
        DOUBLE PRECISION & 
        CDROP(NRX),DELTA_CDROP(NRX)
		
! Andrei's new change 1.12.09                                   (end)                      	

 
        REAL & 
        COL

        DOUBLE PRECISION &
	AOLDCON,ANEWCON,AOLDMASS,ANEWMASS

        DOUBLE PRECISION &
        RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, &
        GN1,GN1P,GN2,GN3,GMAT2

        DOUBLE PRECISION &
        DRP,FNEW,FIK,PSINEW,DRM,GMAT,R1,R2,R3,DMASS,CONCL,RRI,RNK

        INTEGER NRX,NRM

        DOUBLE PRECISION & 
        RR(NRX),FI(NRX),PSI(NRX),RN(NRX) &
       ,RRS(NKR+1),RNS(NKR+1),PSIN(NKR+1),FIN(NKR+1)

        DOUBLE PRECISION & 
        FI_OLD(NRX)
! ANDREI                                                      (start) 
! new change 7.02.06                                          (start)
        DOUBLE PRECISION & 
        PSI_IM,PSI_I,PSI_IP
! ANDREI                                                        (end) 
! new change 7.02.06                                            (end)

! Andrei's new change 1.12.09                                 (start)           

       IF(TPN.LT.273.15-7.0D0) IDROP=0
! LEAVE REMAPPING ON
!      IDROP=0
 
! VALUES FOR SOME REMAPING VARIABLES

        KRDROP_REMAP_MIN=8
	KRDROP_REMAP_MAX=13 
	
        COEFF_REMAP=1.0D0/150.0D0 
	       	
! Andrei's new change 1.12.09                                   (end)                      
	
! INITIAL VALUES FOR SOME VARIABLES

	NRXP=NRX+1

	DO K=1,NRX
	   FI(K)=FI_OLD(K)
        ENDDO
 
	DO K=1,NRX
	   PSI(K)=0.0D0
        ENDDO
! ANDREI                                                      (start) 
! new change 7.02.06                                          (start)

	IF(RN(NRX).NE.RR(NRX)) THEN

! Kovetz-Olund method                                         (start)

! ANDREI                                                        (end) 
! new change 7.02.06                                            (end)

	  ISYM=1

	  IF(RN(1).LT.RR(1)) ISYM=-1

! CALCULATION OF DISTRIBUTION FUNCTION 

	  IF(ISYM.GT.0) THEN
	
! CONDENSATION 

	    RNS(NRXP)=1024.0D0*RR(NRX)
	    RRS(NRXP)=1024.0D0*RR(NRX)

  	    PSIN(NRXP)=0.0D0
	    FIN(NRXP)=0.0D0

	    DO K=1,NRX
	       RNS(K)=RN(K)
	       RRS(K)=RR(K)
	       PSIN(K)=0.0D0
! FIN(K) - initial(before condensation) concentration of hydrometeors
	       FIN(K)=3.0D0*FI(K)*RR(K)*COL
	    ENDDO

! NUMBER OF NEW RADII POSITION IN REGULAR GRID 

! RNK - new first bin mass(after condensation)

	    RNK=RNS(1)

	    DO I=1,NRX
	       RRI=RRS(I)
	       IF(RRI.GT.RNK) GOTO 3
            ENDDO

    3	    IIN=I-1

	    IFIN=NRX

	    CONCL=0.0D0
            DMASS=0.0D0
                        
            DO 6 I=IIN,IFIN

                 IP=I+1
                                                                                
                 IM=MAX(1,I-1)

	         R1=RRS(IM)
	         R2=RRS(I)
	         R3=RRS(IP)

	         DRM=R2-R1
	         DRP=R3-R2

	         FNEW=0.0D0

	         DO 7 K=1,I
                 
	              FIK=FIN(K)

	              IF(FIK.NE.0.0D0) THEN

	                KM=K-1

! RNK - new bin mass(after condensation)

	                RNK=RNS(K)

	                IF(RNK.NE.R2) THEN
	                  GMAT=0.0D0
	                  IF(RNK.GT.R1.AND.RNK.LT.R3) THEN
	                    IF(RNK.LT.R2) THEN
	                      GMAT=(RNK-R1)/DRM
		            ELSE
	                      GMAT=(R3-RNK)/DRP
	                    ENDIF
	                  ENDIF
	                ELSE
	                  GMAT=1.0D0
	                ENDIF

                        FNEW=FNEW+FIK*GMAT
! in case FIK.NE.0.0D0
	              ENDIF
                 
   7	         CONTINUE

	         CONCL=CONCL+FNEW

	         DMASS=DMASS+FNEW*R2

! PSIN(I)) - new concentration of hydrometeors after condensation

    	         PSIN(I)=FNEW
                        	
   6        CONTINUE

! NEW VALUES OF DISTRIBUTION FUNCTION
 
! PSI(K) - new size distribution function of hydrometeors after 
!          condensation, K=1,...,NRX=NKR

	    DO K=1,NRX
	       PSI(K)=PSIN(K)/3./RR(K)/COL
	    ENDDO

! IN CASE: ISYM.GT.0 (CONDENSATION)
	
          ELSE

! IN CASE: ISYM.LE.0 (EVAPORATION)

	    RNS(1)=0.0D0
	    RRS(1)=0.0D0
	    FIN(1)=0.0D0
	    PSIN(1)=0.0D0

! FIN(K) - initial(before evaporation) concentration of hydrometeors

	    DO K=2,NRXP
	       KM=K-1
	       RNS(K)=RN(KM)
	       RRS(K)=RR(KM)
	       PSIN(K)=0.0D0
	       FIN(K)=3.0D0*FI(KM)*RR(KM)*COL
	    ENDDO

	    DO I=1,NRXP

               IM=MAX(I-1,1)
               IP=MIN(I+1,NRXP)

   	       R1=RRS(IP)
	       R2=RRS(I)
	       R3=RRS(IM)

               DRM=R1-R2
               DRP=R2-R3

	       FNEW=0.0D0

	       DO K=I,NRXP
	          RNK=RNS(K)
                  IF(RNK.GE.R1) GOTO 4321
                  IF(RNK.GT.R3)THEN
                    IF(RNK.GT.R2) THEN
                      FNEW=FNEW+FIN(K)*(R1-RNK)/DRM
                    ELSE
                      FNEW=FNEW+FIN(K)*(RNK-R3)/DRP
	            ENDIF
	          ENDIF
               ENDDO

 4321          CONTINUE

! PSIN(I) - new concentration of hydrometeors after evaporation

    	       PSIN(I)=FNEW
	
            ENDDO
! cycle by I

! NEW VALUES OF DISTRIBUTION FUNCTION                         (start)

! PSI(K), 1/g/cm^3 - new size distribution function of hydrometeors 
!                    after evaporation, K=1,...,NRX
	    DO K=2,NRXP
	       KM=K-1
	       R1=PSIN(K)*RR(KM)
	       PSINEW=PSIN(K)/3.0D0/RR(KM)/COL
	       IF(R1.LT.1.0D-20) PSINEW=0.0D0
	       PSI(KM)=PSINEW
	    ENDDO

! NEW VALUES OF DISTRIBUTION FUNCTION                           (end)

! IN CASE: ISYM.LE.0 (EVAPORATION)

	  ENDIF
	
! Andrei's new change 1.12.09                                 (start)
          IF(I3POINT.NE.0.AND.ISYM.GT.0) THEN
! DIFFERENCE
!         IF(I3POINT.NE.0) THEN
! Andrei's new change 1.12.09                                   (end)                      

	    DO K=1,NKR
	       RRS(K)=RR(K)
	    ENDDO

            RRS(NKR+1)=RRS(NKR)*1024.0D0

	    DO I=1,NKR
 
               PSI(I)=PSI(I)*RR(I)

! PSI(I) - concenration hydrometeors after KO divided on COL*3.0D0
! RN(I), g - new masses after condensation or evaporation

               IF(RN(I).LT.0.0D0) THEN 
                 RN(I)=1.0D-50
	         FI(I)=0.0D0
               ENDIF

            ENDDO
 
	    DO K=1,NKR

               IF(FI(K).NE.0.0D0) THEN

                 IF(RRS(2).LT.RN(K)) THEN
 
                   I=2

                   DO  WHILE &
                     (.NOT.(RRS(I).LT.RN(K).AND.RRS(I+1).GT.RN(K)) &
                      .AND.I.LT.NKR)
                       I=I+1
	           ENDDO
! ANDREI                                                      (start) 
! new change 7.02.06                                          (start)
                   IF(I.LT.NKR-2) THEN
! new change 7.02.06                                            (end)
! ANDREI                                                        (end)
                     RNTMP=RN(K)

                     RRTMP=RRS(I)
                     RRP=RRS(I+1)
                     RRM=RRS(I-1)
 
                     RNTMP2=RN(K+1)

                     RRTMP2=RRS(I+1)
                     RRP2=RRS(I+2)
                     RRM2=RRS(I)
 
                     GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ &
                       (RRTMP-RRM)

                     GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ &
                        (RRP2-RRM2)/(RRTMP2-RRM2)

                     GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ &
                       (RRTMP-RRM)
 
	             GMAT=(RRP-RNTMP)/(RRP-RRTMP)
! ANDREI                                                      (start) 
! new change 7.02.06                                          (start)
                     GN3=(RRTMP-RNTMP)*(RRM-RNTMP)/(RRP-RRM)/ &
                                                 (RRP-RRTMP)
	             GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)

                     PSI_IM=PSI(I-1)+GN1*FI(K)*RR(K)
! Andrei's new change 1.12.09                                 (start)           
!                    PSI_I=PSI(I)+(GN1P+GN2-GMAT)*FI(K+1)*RR(K+1)

                     PSI_I=PSI(I)+GN1P*FI(K+1)*RR(K+1)+&
	                         (GN2-GMAT)*FI(K)*RR(K)
! Andrei's new change 1.12.09                                   (end)           
                     PSI_IP=PSI(I+1)+(GN3-GMAT2)*FI(K)*RR(K)
                    
                     IF(PSI_IM.GT.0.0D0) THEN

                       IF(PSI_IP.GT.0.0D0) THEN

                         IF(I.GT.2) THEN
! smoothing criteria
                           IF(PSI_IM.GT.PSI(I-2).AND.PSI_IM.LT.PSI_I &
                          .AND.PSI(I-2).LT.PSI(I).OR.PSI(I-2) &
                          .GE.PSI(I)) THEN

                             PSI(I-1)=PSI_IM

                             PSI(I)=PSI(I)+FI(K)*RR(K)*(GN2-GMAT)

                             PSI(I+1)=PSI_IP

! in case smoothing criteria

                           ENDIF 
! in case I.GT.2
                         ENDIF

! in case PSI_IP.GT.0.0D0

	               ENDIF

! in case PSI_IM.GT.0.0D0

	             ENDIF

! in case I.LT.NKR-2

                   ENDIF
! new change 7.02.06                                            (end)
! ANDREI                                                        (end)
! in case RRS(2).LT.RN(K)

                 ENDIF
 
! in case FI(K).NE.0.0D0

               ENDIF

 1000          CONTINUE

	    ENDDO
! cycle by K
	    AOLDCON=0.0D0
	    ANEWCON=0.0D0
	    AOLDMASS=0.0D0
	    ANEWMASS=0.0D0

	    DO K=1,NKR
	       AOLDCON=AOLDCON+FI(K)*RR(K)
	       ANEWCON=ANEWCON+PSI(K)
	       AOLDMASS=AOLDMASS+FI(K)*RR(K)*RN(K)
	       ANEWMASS=ANEWMASS+PSI(K)*RR(K)
	    ENDDO

! new change 8.02.06                                          (start)
! ANDREI                                                      (start)

! PSI(K) - new hydrometeor size distribution function(sdf)

	    DO K=1,NKR
	       PSI(K)=PSI(K)/RR(K)
            ENDDO
	  
! new change 8.02.06                                            (end)	       
! ANDREI                                                        (end)

! 3 point method                                                (end)	       
								     	       
! in case I3POINT.NE.0.AND.ISYM.GT.0						     		 
								     		    
	  ENDIF

! Andrei's new change 1.12.09                                 (start)           

          IF(IDROP.NE.0.AND.ISYM.GT.0) THEN
	  
	    DO K=KRDROP_REMAP_MIN,KRDROP_REMAP_MAX
	       CDROP(K)=3.0D0*COL*PSI(K)*RR(K)
	    ENDDO
								     		 
! KMAX - right boundary of drop sdf spectrum
!(KRDROP_REMAP_MIN =< KMAX =< KRDROP_REMAP_MAX)

            DO K=KRDROP_REMAP_MAX,KRDROP_REMAP_MIN,-1
               KMAX=K
               IF(PSI(K).GT.0.0D0) GOTO 2011
            ENDDO

 2011       CONTINUE
 
! Andrei start
!           DO K=KMAX-1,1,-1
! Andre end
!Alex, Andrei, Barry
            DO K=KMAX-1,KRDROP_REMAP_MIN,-1
!Alex, Andrei, Barry
	       IF(CDROP(K).GT.1.d-20) THEN
                 DELTA_CDROP(K)=CDROP(K+1)/CDROP(K)
	         IF(DELTA_CDROP(K).LT.COEFF_REMAP) THEN
	           CDROP(K)=CDROP(K)+CDROP(K+1)
		   CDROP(K+1)=0.0D0
	         ENDIF
	       ENDIF
            ENDDO
	    
	    DO K=KRDROP_REMAP_MIN,KMAX
	       PSI(K)=CDROP(K)/(3.0D0*COL*RR(K))
	    ENDDO
	    
! in case IDROP.NE.0.AND.ISYM.GT.0
		      
	  ENDIF
	    	  
! Andrei's new change 1.12.09                                   (end)           
! ANDREI                                                      (start) 
! new change 8.02.06                                          (start)

! in case RN(NRX).NE.RR(NRX)

        ELSE

! in case RN(NRX).EQ.RR(NRX)

	  DO K=1,NKR
	     PSI(K)=FI(K)
	  ENDDO

        ENDIF

! new change 8.02.06                                            (end)           
! ANDREI                                            

        RETURN 

! SUBROUTINE JERNEWF
        END SUBROUTINE JERNEWF

! BARRY REMOVED QP,ROR
        SUBROUTINE JERRATEOLD(R1S,TP,PP,ROR,VR1,PSINGLE,RIEC,RO1BL &
     &                    ,B11_MY,B12_MY,ID,IN,ICEMAX,NKR)
       IMPLICIT NONE
       INTEGER ID,IN,KR,ICE,NRM,ICEMAX,NKR
      DOUBLE PRECISION TP,PP
      REAL DETL,FACTPL,VENTPL,VR1K,CONSTL,RO1,RVT,D_MY, &
     & CONST
       REAL VR1(NKR,ID),PSINGLE,ROR
        REAL       &
     & R1S(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
     &,RO1BL(NKR,ID),RIEC(NKR,ID) &
     &,VR1KL(NKR,ICEMAX),VENTRL(NKR,ICEMAX) &
     &,FD1(NKR,ICEMAX),FK1(NKR,ICEMAX),FACTRL(NKR,ICEMAX) &
     &,R11_MY(NKR,ICEMAX),R12_MY(NKR,ICEMAX) &
     &,R1_MY1(NKR,ICEMAX),R1_MY2(NKR,ICEMAX),R1_MY3(NKR,ICEMAX) &
     &,AL1(2),AL1_MY(2),A1_MY(2),BB1_MY(2),ESAT1(2),CONSTLI(ICEMAX)
      DOUBLE PRECISION TZERO
      REAL PZERO,CF_MY,D_MYIN,RV_MY
      PARAMETER (TZERO=273.150,PZERO=1.013E6)
      DATA AL1/2500.,2833./
	CONST=12.566372
        AL1_MY(1)=2.5E10
        AL1_MY(2)=2.834E10
        A1_MY(1)=2.53E12
        A1_MY(2)=3.41E13
        BB1_MY(1)=5.42E3
        BB1_MY(2)=6.13E3
        CF_MY=2.4E3
        D_MYIN=0.221
        RV_MY=461.5E4
	NRM=NKR-1

! RHS FOR "MAXWELL" EQUATION 

	D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94
	RVT=RV_MY*TP
	ESAT1(IN)=A1_MY(IN)*EXP(-BB1_MY(IN)/TP)

	DO 1 ICE=1,ID
	     DO 1 KR=1,NKR
	     RO1=RO1BL(KR,ICE)
	     CONSTL=CONST*RIEC(KR,ICE)
	     CONSTLI(ICE)=CONSTL
	     VR1K=0.
	     VR1KL(KR,ICE)=VR1K
	     VENTPL=1.
	     VENTRL(KR,ICE)=VENTPL
	     FACTPL=1.
	     FACTRL(KR,ICE)=FACTPL
	     FD1(KR,ICE)=RVT/D_MY/ESAT1(IN)/FACTPL
	     FK1(KR,ICE)=(AL1_MY(IN)/RVT-1.)*AL1_MY(IN)/CF_MY/TP
	     R1_MY1(KR,ICE)=VENTPL*CONSTL
	     R11_MY(KR,ICE)=R1_MY1(KR,ICE)
!BARRY
!     R1_MY2(KR,ICE)=VENTPL*CONSTL*0.
!     R1_MY3(KR,ICE)=VENTPL*CONSTL*0.
!     R12_MY(KR,ICE)=R1_MY2(KR,ICE)-R1_MY3(KR,ICE)
!BARRY
! GROWTH RATE

	     DETL=FK1(KR,ICE)+FD1(KR,ICE)
	     B11_MY(KR,ICE)=R11_MY(KR,ICE)/DETL
!BARRY     B12_MY(KR,ICE)=R12_MY(KR,ICE)/DETL
           B12_MY(KR,ICE)=0                       
    1	CONTINUE

	RETURN
	END SUBROUTINE JERRATEOLD

! SUBROUTINE JERRATE
!========================================================================
!BARRY    CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N
!    *                        ,RW,PW,RI,PI,QW,QI
! SUBROUTINE JERNEWF
!=========================================================================
! BARRY REMOVED QP
        SUBROUTINE JERRATE(R1S,TP,PP,ROR,VR1,PSINGLE,RIEC,RO1BL &
     &                    ,B11_MY,B12_MY,ID,IN,ICEMAX,NKR)
       IMPLICIT NONE
       INTEGER ID,IN,KR,ICE,NRM,ICEMAX,NKR
      DOUBLE PRECISION TP,PP
      REAL DETL,FACTPL,VENTPL,VR1K,CONSTL,RO1,RVT,D_MY, &
     & CONST
        REAL VR1(NKR,ID),PSINGLE &
     &,R1S(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
     &,RO1BL(NKR,ID),RIEC(NKR,ID) &
     &,VR1KL(NKR,ICEMAX),VENTRL(NKR,ICEMAX) &
     &,FD1(NKR,ICEMAX),FK1(NKR,ICEMAX),FACTRL(NKR,ICEMAX) &
     &,R11_MY(NKR,ICEMAX),R12_MY(NKR,ICEMAX) &
     &,R1_MY1(NKR,ICEMAX),R1_MY2(NKR,ICEMAX),R1_MY3(NKR,ICEMAX) &
     &,AL1(2),AL1_MY(2),A1_MY(2),BB1_MY(2),ESAT1(2),CONSTLI(ICEMAX)
      DOUBLE PRECISION TZERO
      REAL PZERO,CF_MY,D_MYIN,RV_MY,DEG01,DEG03
      REAL COEFF_VISCOUS,SHMIDT_NUMBER,A,B
      REAL REINOLDS_NUMBER,RESHM,ROR
      PARAMETER (TZERO=273.150,PZERO=1.013E6)
      DATA AL1/2500.,2833./
        DEG01=1./3.     
        DEG03=1./3.     
	CONST=12.566372
        AL1_MY(1)=2.5E10
        AL1_MY(2)=2.834E10
        A1_MY(1)=2.53E12
        A1_MY(2)=3.41E13
        BB1_MY(1)=5.42E3
        BB1_MY(2)=6.13E3
        CF_MY=2.4E3
        D_MYIN=0.221
        RV_MY=461.5E4
	NRM=NKR-1
! rhs for "maxwell" equation
! coefficient of diffusion
        D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94
! new change 20.04.02
! coefficient of viscousity
        COEFF_VISCOUS=1.72E-2*SQRT(TP/273.)*393./(TP-120.)/ROR
! Shmidt number
        SHMIDT_NUMBER=COEFF_VISCOUS/D_MY
! Constants used for calculation of Reinolds number
        A=2.*(3./4./3.141593)**DEG01
        B=A/COEFF_VISCOUS
        
        RVT=RV_MY*TP
        ESAT1(IN)=A1_MY(IN)*EXP(-BB1_MY(IN)/TP)
        DO ICE=1,ID
           DO KR=1,NKR
! Reinolds numbers
              REINOLDS_NUMBER= &
     &        B*VR1(KR,ICE)*SQRT(1.E6/PSINGLE)* &
     &        (R1S(KR,ICE)/RO1BL(KR,ICE))**DEG03
              RESHM=SQRT(REINOLDS_NUMBER)*SHMIDT_NUMBER**DEG03
              IF(REINOLDS_NUMBER.LT.2.5) THEN
                VENTPL=1.+0.108*RESHM*RESHM
              ELSE
                VENTPL=0.78+0.308*RESHM
              ENDIF
! new change 20.04.02                                           (end)
              CONSTL=CONST*RIEC(KR,ICE)                         
              CONSTLI(ICE)=CONSTL
!             VR1K=0.
!             VR1KL(KR,ICE)=VR1K
! new change 20.04.02                                         (begin)
!             VENTPL=1.                                       
!             VENTRL(KR,ICE)=VENTPL                           
! new change 20.04.02                                           (end)
              FACTPL=1.                                         
              FACTRL(KR,ICE)=FACTPL                             
              FD1(KR,ICE)=RVT/D_MY/ESAT1(IN)/FACTPL             
              FK1(KR,ICE)=(AL1_MY(IN)/RVT-1.)*AL1_MY(IN)/CF_MY/TP
              R1_MY1(KR,ICE)=VENTPL*CONSTL
!             R1_MY2(KR,ICE)=VENTPL*CONSTL*0.
!             R1_MY3(KR,ICE)=VENTPL*CONSTL*0.
              R11_MY(KR,ICE)=R1_MY1(KR,ICE)
!BARRY        R12_MY(KR,ICE)=R1_MY2(KR,ICE)-R1_MY3(KR,ICE)
! growth rate 
              DETL=FK1(KR,ICE)+FD1(KR,ICE)
              B11_MY(KR,ICE)=R11_MY(KR,ICE)/DETL
!BARRY        B12_MY(KR,ICE)=R12_MY(KR,ICE)/DETL
              B12_MY(KR,ICE)=0.
           ENDDO
        ENDDO


	RETURN
	END SUBROUTINE JERRATE

! SUBROUTINE JERRATE
!========================================================================
!BARRY    CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N
!    *                        ,RW,PW,RI,PI,QW,QI
!    *                        ,DTT,D1N,D2N,DT0L,DT0I)
	SUBROUTINE JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
     &                      ,RW,PW,RI,PI,QW,QI &
     &                      ,DT,DEL1INT,DEL2INT,DT0L,DT0I)
      IMPLICIT NONE
   
      INTEGER ITYPE
      REAL DEL1,DEL2,RW,PW,RI,PI,QW,QI, &
     &  DT,DEL1INT,DEL2INT,DT0L,DT0I,DTLIN,DTIIN
      REAL DETER,DBLRW,DBLPW,DBLPI,DBLRI, &
     &  DBLDEL1,DBLDEL2,DBLDEL1INT,DBLDTLIN,DBLDTIIN, &
     &  EXPM,EXPP,ALFAMX,ALFAPX,X,ALFA,DELX,DBLDEL2INT, &
     &  R1RES,R2RES,R1,R2,R3,R4,R21,R11,R10,R41,R31,R30,DBLDT, &
     &  DBLDEL1N,DBLDEL2N
      DOUBLE PRECISION DEL1N,DEL2N

        DOUBLE PRECISION DEL1N_2P,DEL1INT_2P,DEL2N_2P,DEL2INT_2P 
        DOUBLE PRECISION EXPP_2P,EXPM_2P,ARGEXP     
! BARRY
      DOUBLE PRECISION RW_DP,PW_DP,PI_DP,RI_DP,X_DP,ALFA_DP
!    * ,ALFAPX_DP
! Andrei's new change 9.03.10                                 (start)
      DOUBLE PRECISION  EXPM1
      EXPM1(x_dp)= &
     &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
      DOUBLE PRECISION  DETER_MIN
! Andrei's new change 9.03.10                                 (start)

      DOUBLE PRECISION EXP1, EXP2

! Andrei's new change 9.03.10                                   (end)
	DTLIN=1000.E17
	DTIIN=1000.E17
! Andrei's new change 9.03.10                                 (start)
      DETER=RW*PI-PW*RI
!     DETER_MIN=1.0D-20
! Andrei's new change 9.03.10                                 (end)
! SOLUTION  
!IF(DETER.EQ.0)  THEN
       IF(RW.EQ.0.AND.RI.EQ.0) THEN
! NO CLOUD: WITHOUT WATER & ICE
	    DEL1N_2P=DEL1
	    DEL2N_2P=DEL2
	    DEL1INT_2P=DEL1*DT
	    DEL2INT_2P=DEL2*DT
! IN CASE: RW.NE.0 OR RI.NE.0 (WATER OR ICE) 
       ELSE IF(RW.NE.0.AND.RI*1.E5.LT.RW) THEN
! ONLY WATER
              ARGEXP=-RW*DT

	      DEL1N_2P=DEL1*DEXP(ARGEXP)+QW*(1.-DEXP(ARGEXP))
	      DEL1INT_2P=(DEL1-DEL1N_2P)/RW
	      DEL2N_2P=DEL2-PW*DEL1INT_2P
	      DEL2INT_2P= &
     &       (DEL2N_2P-PW*DEL1N_2P/RW)*DT+PW*DEL1INT_2P/RW
	ELSE IF(RI.NE.0.AND.RW*1.E5.LT.RI) THEN
! IN CASE: RW.EQ.0
! ONLY ICE 
              ARGEXP=-PI*DT

	      DEL2N_2P=DEL2*DEXP(ARGEXP)+QI*(1.-DEXP(ARGEXP))
	      DEL2INT_2P=(DEL2-DEL2N_2P)/PI
	      DEL1N_2P=DEL1-RI*DEL2INT_2P
	      DEL1INT_2P= &
     &       (DEL1N_2P-RI*DEL2N_2P/PI)*DT+RI*DEL2INT_2P/PI
!             GOTO 100
! IN CASE: RW.NE.0 OR RI.NE.0 (WATER OR ICE)
! IN CASE: DETER.EQ.0
        ELSE
! IN CASE: DETER.NE.0
! COMPLETE SOLUTION 
!  ALFA=SQRT((RW-PI)*(RW-PI)+4.*PW*RI)
!  X=RW+PI
!  ALFAPX=.5*(ALFA+X)
! BARRY 
          RW_DP=RW
          RI_DP=RI
          PI_DP=PI
          PW_DP=PW
          IF (RW.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (RW.LE.0), model stop")
          IF (PW.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (PW.LE.0), model stop")
          IF (RI.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (RI.LE.0), model stop")
          IF (PI.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (PI.LE.0), model stop")
          ALFA_DP=SQRT((RW_DP-PI_DP)*(RW_DP-PI_DP)+4.*PW_DP*RI_DP) 
	  X_DP=RW_DP+PI_DP
	  ALFAPX=.5*(ALFA_DP+X_DP)
          IF (ALFAPX.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (CHECK.LT.0), model stop")
	  ALFAMX=.5*(ALFA_DP-X_DP)
!
! 
          ARGEXP=-ALFAPX*DT
! Andrei 11/04/10
	  EXPP_2P=DEXP(ARGEXP)
          IF(DABS(ARGEXP).LE.1.0E-6) THEN
               EXP1=EXPM1(ARGEXP)
          ELSE
               EXP1=EXPP_2P-1.0D0
          ENDIF
!
          ARGEXP=ALFAMX*DT
!Andre 11/04/10
	  EXPM_2P=DEXP(ARGEXP)
              IF(DABS(ARGEXP).LE.1.0E-6) THEN
                EXP2=EXPM1(ARGEXP)
              ELSE
                EXP2=EXPM_2P-1.0D0
              ENDIF
!
! DROPLETS 
	  R10=RW*DEL1+RI*DEL2
	  R11=R10-ALFAPX*DEL1
	  R21=R10+ALFAMX*DEL1
	  DEL1N_2P=(R21*EXPP_2P-R11*EXPM_2P)/ALFA_DP
! BARRY
	  IF(ALFAMX.NE.0) THEN
	    R1=-R11/ALFAMX
	    R2=R21/ALFAPX
!    DEL1INT_2P=(R1*(EXPM_2P-1.)-R2*(EXPP_2P-1.))/ALFA_DP
            DEL1INT_2P=(R1*EXP2-R2*EXP1)/ALFA_DP
	  ELSE
            DEL1INT_2P = 0.
	  ENDIF
! BARRY
	  R1RES=0.
	  IF(R11.NE.0) R1RES=R21/R11
	  IF(R1RES.GT.0) DTLIN=ALOG(R1RES)/ALFA_DP
! ICE 
	  R30=PW*DEL1+PI*DEL2
	  R31=R30-ALFAPX*DEL2
	  R41=R30+ALFAMX*DEL2
! BARRY
	  DEL2N_2P=(R41*EXPP_2P-R31*EXPM_2P)/ALFA_DP
	  IF(ALFAMX.NE.0.AND.ALFAPX.NE.0) THEN
	    R3=-R31/ALFAMX
	    R4=R41/ALFAPX
!           DEL2INT_2P=(R3*(EXPM_2P-1.)-R4*(EXPP_2P-1.))/ALFA_DP
            DEL2INT_2P=(R3*EXP2-R4*EXP1)/ALFA_DP
          ELSE
	    DEL2INT_2P=0.
	  ENDIF
	  R2RES=0.
	  IF(R31.NE.0) R2RES=R41/R31
	  IF(R2RES.GT.0) DTIIN=ALOG(R2RES)/ALFA_DP
! IN CASE: DETER.NE.0
! END OF COMPLETE SOLUTION
	ENDIF
! IN CASES: DETER.EQ.0 OR DETER.NE.0
 100    CONTINUE
        DEL1N=DEL1N_2P
        DEL2N=DEL2N_2P
       
! BARRY
        DEL1INT=DEL1INT_2P
        DEL2INT=DEL2INT_2P
	DT0L=DTLIN
	IF(DT0L.LT.0) DT0L=1.E20
	DT0I=DTIIN
	IF(DT0I.LT.0) DT0I=1.E20
	RETURN
	END SUBROUTINE JERSUPSAT
!==========================================================================
        SUBROUTINE JERTIMESC(FI1,X1,SFN11,SFN12 &
     &                      ,B11_MY,B12_MY,RIEC,CF,ID,COL,NKR)        
      IMPLICIT NONE
       INTEGER NRM,KR,ICE,ID,NKR
      REAL B12,B11,FUN,DELM,FK,CF,SFN12S,SFN11S
	REAL  COL, &
     & X1(NKR,ID),FI1(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
     &,RIEC(NKR,ID),SFN11,SFN12

	NRM=NKR-1
	DO 1 ICE=1,ID  
             SFN11S=0.                              
             SFN12S=0.
	     SFN11=CF*SFN11S	
	     SFN12=CF*SFN12S
             DO KR=1,NRM
! VALUE OF DISTRIBUTION FUNCTION
	        FK=FI1(KR,ICE)
! DELTA-M 
	        DELM=X1(KR,ICE)*3.*COL
! INTEGRAL'S EXPRESSION 
	        FUN=FK*DELM
! VALUES OF INTEGRALS
	        B11=B11_MY(KR,ICE)
        	B12=B12_MY(KR,ICE)
                SFN11S=SFN11S+FUN*B11                               
                SFN12S=SFN12S+FUN*B12
	     ENDDO
! CORRECTION 
	     SFN11=CF*SFN11S
             SFN12=CF*SFN12S
    1   CONTINUE
! END 
	RETURN
	END SUBROUTINE JERTIMESC
!
        SUBROUTINE JERTIMESC_ICE(FI1,X1,SFN11,SFN12 &
     &                      ,B11_MY,B12_MY,RIEC,CF,ID,COL,NKR)        
      IMPLICIT NONE
       INTEGER NRM,KR,ICE,ID,NKR
      REAL B12,B11,FUN,DELM,FK,CF,SFN12S,SFN11S
	REAL  COL, &
     & X1(NKR,ID),FI1(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
     &,RIEC(NKR,ID),SFN11(ID),SFN12(ID)

	NRM=NKR-1
	DO 1 ICE=1,ID  
             SFN11S=0.                              
             SFN12S=0.
	     SFN11(ICE)=CF*SFN11S	
	     SFN12(ICE)=CF*SFN12S
             DO KR=1,NRM
! VALUE OF DISTRIBUTION FUNCTION
	        FK=FI1(KR,ICE)
! DELTA-M 
	        DELM=X1(KR,ICE)*3.*COL
! INTEGRAL'S EXPRESSION 
	        FUN=FK*DELM
! VALUES OF INTEGRALS
	        B11=B11_MY(KR,ICE)
        	B12=B12_MY(KR,ICE)
                SFN11S=SFN11S+FUN*B11                               
                SFN12S=SFN12S+FUN*B12
	     ENDDO
! CORRECTION 
	     SFN11(ICE)=CF*SFN11S
             SFN12(ICE)=CF*SFN12S
    1   CONTINUE
! END 
	RETURN
	END SUBROUTINE JERTIMESC_ICE


        SUBROUTINE ONECOND2 &
     & (TT,QQ,PP,ROR  &
     & ,VR2,VR3,VR4,VR5,PSINGLE &
     & ,DEL1N,DEL2N,DIV1,DIV2 &
     & ,FF2,PSI2,R2,RIEC,RO2BL &
     & ,FF3,PSI3,R3,RSEC,RO3BL &
     & ,FF4,PSI4,R4,RGEC,RO4BL &
     & ,FF5,PSI5,R5,RHEC,RO5BL &
     & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
     & ,C1_MEY,C2_MEY &
     & ,COL,DTCOND,ICEMAX,NKR &
     & ,ISYM2,ISYM3,ISYM4,ISYM5)

       IMPLICIT NONE

      INTEGER NKR,ICEMAX
      REAL    COL,VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
     &           ,VR5(NKR),PSINGLE &
     &       ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
     &       ,DTCOND

      REAL C1_MEY,C2_MEY
      INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON, &
     & KR,ICE,ITIME,ICM,KCOND,NR,NRM,INUC, &
     & ISYM2,ISYM3,ISYM4,ISYM5,KP,KLIMIT, &
     & KM,ITER,KLIMITL,KLIMITG,KLIMITH,KLIMITI_1,KLIMITI_2,KLIMITI_3, &
     & NCRITI
      REAL AL1,AL2,D,GAM,POD, &
     & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
     & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
     & TPC1, TPC2, TPC3, TPC4, TPC5, &
     & EPSDEL, DT0L, DT0I, &
     & ROR, &
     & DEL1NUC,DEL2NUC, &
     & CWHUCM,B6,B8L,B8I,RMASSGL,RMASSGI, &
     & DEL1,DEL2,DEL1S,DEL2S, &
     & TIMENEW,TIMEREV,SFN11,SFN12, &
     & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,OPERQ,RW,RI,QW,PW, &
     & PI,QI,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
     & DEL_R1,DT0L0,DT0I0,SFN31,SFN32,SFN52, &
     & SFNII1,SFN21,SFN22,DTNEWI3,DTNEWI4,DTNEWI5,DTNEWI2_1, &
     & DTNEWI2_2,DTNEWI1,DEL_R2,DEL_R4,DEL_R5,SFN41,SFN42, &
     & SNF51,DTNEWI2_3,DTNEWI2,DTNEWI_1,DTNEWI_2, &
     & DTNEWL0,DTNEWG1,DTNEWH1,DTNEWI_3, &
     & DTNEWL2,SFN51,SFNII2,DEL_R3,DTNEWI  
       REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
     &  DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON

       INTEGER K

! NEW ALGORITHM OF CONDENSATION (12.01.00)

      DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
      DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
     &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
     &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
     &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
     &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
     &                  ,ES1N,ES2N,EW1N,ARGEXP &
     &                  ,TT,QQ,PP &
     &                  ,DEL1N,DEL2N,DIV1,DIV2 &
     &                  ,OPER2,OPER3,AR1,AR2  

       DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1

! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND

        CHARACTER*70 CPRINT







! CRYSTALS
                                                                       
	REAL R2(NKR,ICEMAX) &
     &           ,RIEC(NKR,ICEMAX) &
     &           ,RO2BL(NKR,ICEMAX) &
     &           ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
     &           ,FF2(NKR,ICEMAX) &
     &           ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX)

! SNOW                                                                          
        REAL R3(NKR) &
     &           ,RSEC(NKR),RO3BL(NKR) &
     &           ,FI3(NKR),FF3(NKR),PSI3(NKR) &
     &           ,B31_MY(NKR),B32_MY(NKR)

! GRAUPELS 
                                                                       
        REAL R4(NKR) &
     &           ,RGEC(NKR),RO4BL(NKR) &
     &           ,FI4(NKR),FF4(NKR),PSI4(NKR) &
     &           ,B41_MY(NKR),B42_MY(NKR)  

! HAIL                                                                          
        REAL R5(NKR) &
     &           ,RHEC(NKR),RO5BL(NKR) &
     &           ,FI5(NKR),FF5(NKR),PSI5(NKR) &
     &           ,B51_MY(NKR),B52_MY(NKR)  

! CCN                                                                       

! WORK ARRAYS 

! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION

	REAL DTIMEG(NKR),DTIMEH(NKR) 
       
	REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &

! NEW ALGORITHM (NO TYPE OF ICE)

     &           ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR) &
     &           ,SFNI1(ICEMAX),SFNI2(ICEMAX) &
     &           ,TIMESTEPD(NKR) &
     &           ,FI1REF(NKR),PSI1REF(NKR) &
     &           ,FI2REF(NKR,ICEMAX),PSI2REF(NKR,ICEMAX)&
     &           ,FCCNRREF(NKR)


	OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
	OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)

        DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
     &      ,GAM /1.E-4/, POD /10./ 
           
	DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
     &      /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/

	DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
     &      /2.53,5.42,3.41E1,6.13/

	DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
     &      /-4.0,-8.1,-12.7,-17.8,-22.4/ 


        DATA EPSDEL/0.1E-03/
    
	DATA DT0L, DT0I /1.E20,1.E20/

! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND


! CONTROL OF TIMESTEP ITERATIONS IN MIXED PHASE: EVAPORATION
        
        I_MIXCOND=0
        I_MIXEVAP=0
        I_ABERGERON=0
        I_BERGERON=0
! SOME CONSTANTS 
        COL3=3.0*COL
        ICM=ICEMAX
        ITIME=0
        KCOND=0
        DT_WATER_COND=0.4
        DT_WATER_EVAP=0.4
        DT_ICE_COND=0.4
        DT_ICE_EVAP=0.4
        DT_MIX_COND=0.4
        DT_MIX_EVAP=0.4
        DT_MIX_BERGERON=0.4
        DT_MIX_ANTIBERGERON=0.4
	ICM=ICEMAX
	ITIME=0
	KCOND=0
        DT0LREF=0.2
        DTLREF=0.4

	NR=NKR
	NRM=NKR-1
	DT=DTCOND
	DTT=DTCOND
	XRAD=0.

!     BARRY
	CWHUCM=0.
	XRAD=0.
	B6=CWHUCM*GAM-XRAD
	B8L=1./ROR
	B8I=1./ROR
        RORI=1./ROR

! INITIALIZATION OF SOME ARRAYS

!       BARRY
        TPN=TT
        QPN=QQ


! TYPE OF ICE IN DIFFUSIONAL GROWTH 

	      DO ICE=1,ICEMAX
	         SFNI1(ICE)=0.
	         SFNI2(ICE)=0.
	         DEL2D(ICE)=0.
	      ENDDO

! TIME SPLITTING 

	      TIMENEW=0.
	      ITIME=0

! ONLY ICE (CONDENSATION OR EVAPORATION) :

   46         ITIME=ITIME+1

	      TIMEREV=DT-TIMENEW

	      DEL1=DEL1N
	      DEL2=DEL2N
	      DEL1S=DEL1N
	      DEL2S=DEL2N
	      DEL2D(1)=DEL2N
	      DEL2D(2)=DEL2N
	      DEL2D(3)=DEL2N
	      TPS=TPN
	      QPS=QPN
              DO KR=1,NKR
                 FI3(KR)=PSI3(KR)
                 FI4(KR)=PSI4(KR)
                 FI5(KR)=PSI5(KR)
                 DO ICE=1,ICEMAX
                    FI2(KR,ICE)=PSI2(KR,ICE)
                 ENDDO
              ENDDO
! TIME-STEP GROWTH RATE: 
! ONLY ICE (CONDENSATION OR EVAPORATION)
              CALL JERRATE(R2,TPS,PP,ROR,VR2,PSINGLE &
     &                    ,RIEC,RO2BL,B21_MY,B22_MY,3,2,ICEMAX,NKR)   
              CALL JERRATE(R3,TPS,PP,ROR,VR3,PSINGLE &
     &                    ,RSEC,RO3BL,B31_MY,B32_MY,1,2,ICEMAX,NKR)
              CALL JERRATE(R4,TPS,PP,ROR,VR4,PSINGLE &
     &                    ,RGEC,RO4BL,B41_MY,B42_MY,1,2,ICEMAX,NKR)
              CALL JERRATE(R5,TPS,PP,ROR,VR5,PSINGLE &
     &                    ,RHEC,RO5BL,B51_MY,B52_MY,1,2,ICEMAX,NKR)


! INTEGRALS IN DELTA EQUATION

! CALL JERTIMESC CRYSTAL - 1 (ONLY ICE)
              CALL JERTIMESC_ICE  &
     &       (FI2,R2,SFNI1,SFNI2,B21_MY,B22_MY,RIEC,B8I,ICM,COL,NKR) 
              CALL JERTIMESC &
     &       (FI3,R3,SFN31,SFN32,B31_MY,B32_MY,RSEC,B8I,1,COL,NKR)  
              CALL JERTIMESC &
     &       (FI4,R4,SFN41,SFN42,B41_MY,B42_MY,RGEC,B8I,1,COL,NKR) 
              CALL JERTIMESC &
     &       (FI5,R5,SFN51,SFN52,B51_MY,B52_MY,RHEC,B8I,1,COL,NKR)
	      SFNII1=SFNI1(1)+SFNI1(2)+SFNI1(3)
	      SFNII2=SFNI2(1)+SFNI2(2)+SFNI2(3)
	      SFN21=SFNII1+SFN31+SFN41+SFN51        
	      SFN22=SFNII2+SFN32+SFN42+SFN52 
	      SFNL=0.
	      SFNI=SFN21+SFN22       
! SOME CONSTANTS 
	      B5L=BB1_MY/TPS/TPS
	      B5I=BB2_MY/TPS/TPS
              B7L=B5L*B6                                                     
              B7I=B5I*B6
	      DOPL=1.+DEL1S                                                     
	      DOPI=1.+DEL2S                                                     
	      OPERQ=OPER2(QPS)  
              RW=(OPERQ+B5L*AL1)*DOPL*SFNL                                      
              QW=B7L*DOPL
              PW=(OPERQ+B5I*AL1)*DOPI*SFNL
              RI=(OPERQ+B5L*AL2)*DOPL*SFNI
              PI=(OPERQ+B5I*AL2)*DOPI*SFNI
              QI=B7I*DOPI
	      KCOND=20
	      IF(DEL2.GT.0) KCOND=21

! PROCESS'S TYPE (ONLY ICE) 

	      IF(KCOND.EQ.21)  THEN

! ONLY_ICE: CONDENSATION

	      
                DT0I=1.E20
	        DTNEWI1=DTCOND
	        DTNEWL=DTNEWI1
	        IF(ITIME.GE.NKR) THEN
                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
	        ENDIF
	        TIMESTEPD(ITIME)=DTNEWL
! NEW TIME STEP (ONLY_ICE: CONDENSATION)
	        IF(DTNEWL.GT.DT) DTNEWL=DT
	        IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
     &          DTNEWL=DT-TIMENEW
                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
	        TIMESTEPD(ITIME)=DTNEWL
	        TIMENEW=TIMENEW+DTNEWL
	        DTT=DTNEWL
! SOLVING FOR SUPERSATURATION (ONLY ICE: CONDENSATION) 

! CALL JERSUPSAT - 4 (ONLY ICE: CONDENSATION)

	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
     &                        ,RW,PW,RI,PI,QW,QI &
     &                        ,DTT,D1N,D2N,DT0L0,DT0I0)

! END OF "NEW SUPERSATURATION" (ONLY ICE: CONDENSATION)


! CRYSTALS (ONLY ICE: CONDENSATION) 

	        IF(ISYM2.NE.0) THEN

! CRYSTAL DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
 
! CALL JERDFUN CRYSTAL - 1 (ONLY ICE: CONDENSATION)

! NEW ALGORITHM (NO TYPE ICE)
	          CALL JERDFUN(R2,B21_MY,B22_MY &
     &                        ,FI2,PSI2,D2N &
     &                        ,ICM,1,COL,NKR,TPN)

	          CALL JERDFUN(R2,B21_MY,B22_MY &
     &                        ,FI2,PSI2,D2N &
     &                        ,ICM,2,COL,NKR,TPN)

	          CALL JERDFUN(R2,B21_MY,B22_MY &
     &                        ,FI2,PSI2,D2N &
     &                        ,ICM,3,COL,NKR,TPN)
! IN CASE : ISYM2.NE.0

	        ENDIF
! SNOW 
	        IF(ISYM3.NE.0) THEN

! SNOW DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
                                                         

! CALL JERDFUN SNOW - 1 (ONLY ICE: CONDENSATION)
                  CALL JERDFUN(R3,B31_MY,B32_MY &
     &                        ,FI3,PSI3,D2N &
     &                        ,1,3,COL,NKR,TPN)

	        ENDIF
! IN CASE : ISYM4.NE.0
! GRAUPELS (ONLY_ICE: EVAPORATION)

                IF(ISYM4.NE.0) THEN

! GRAUPEL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION)

                  CALL JERDFUN(R4,B41_MY,B42_MY &
     &                        ,FI4,PSI4,D2N &
     &                        ,1,4,COL,NKR,TPN)
! IN CASE : ISYM4.NE.0

                ENDIF



! HAIL (ONLY ICE: CONDENSATION) 

	        IF(ISYM5.NE.0) THEN

! HAIL DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
                                                         
! CALL JERDFUN HAIL - 1 (ONLY ICE: CONDENSATION) 
	          CALL JERDFUN(R5,B51_MY,B52_MY &
     &                        ,FI5,PSI5,D2N &
     &                        ,1,5,COL,NKR,TPN)
! IN CASE : ISYM5.NE.0

	        ENDIF

	        IF((DEL2.GT.0.AND.DEL2N.LT.0) &
     &         .AND.ABS(DEL2N).GT.EPSDEL) THEN
               call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL2.GT.0.AND.DEL2N.LT.0), model stop")
                ENDIF

	      ELSE

! IN CASE KCOND.NE.21 

! ONLY ICE: EVAPORATION  

! NEW TREATMENT OF TIME STEP (ONLY ICE: EVAPORATION) 

	        DT0I=1.E20
                IF (DEL2N.EQ.0)THEN
	          DTNEWL=DT
                ELSE
	         DTNEWI3=-R3(3)/(B31_MY(3)*DEL2N-B32_MY(3))
	         DTNEWI4=-R4(3)/(B41_MY(3)*DEL2N-B42_MY(3))
	         DTNEWI5=-R5(3)/(B51_MY(3)*DEL2N-B52_MY(3))
! NEW ALGORITHM (NO TYPE OF ICE)
	         DTNEWI2_1=-R2(3,1)/(B21_MY(1,1)*DEL2N-B22_MY(1,1))
	         DTNEWI2_2=-R2(3,2)/(B21_MY(1,2)*DEL2N-B22_MY(1,2))
	         DTNEWI2_3=-R2(3,3)/(B21_MY(1,3)*DEL2N-B22_MY(1,3))
                 DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
	         DTNEWI1=AMIN1(DTNEWI2,DTNEWI3,DTNEWI4 &
     &                       ,DTNEWI5,DT0I,TIMEREV)
	         DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I,TIMEREV)
	         DTNEWL=DTNEWI1
	         IF(DTNEWL.LT.DTLREF) DTNEWL=AMIN1(DTLREF,TIMEREV)
                END IF
	        IF(ITIME.GE.NKR) THEN
                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
                ENDIF
	        TIMESTEPD(ITIME)=DTNEWL

! NEW TIME STEP (ONLY_ICE: EVAPORATION)

	        IF(DTNEWL.GT.DT) DTNEWL=DT
	        IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
     &          DTNEWL=DT-TIMENEW
                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
	        TIMENEW=TIMENEW+DTNEWL
	        TIMESTEPD(ITIME)=DTNEWL
	        DTT=DTNEWL
! SOLVING FOR SUPERSATURATION (ONLY_ICE: EVAPORATION) 
	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
     &                        ,RW,PW,RI,PI,QW,QI &
     &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
! END OF "NEW SUPERSATURATION" (ONLY_ICE: EVAPORATION) 

! CRYSTALS
	        IF(ISYM2.NE.0) THEN

! CRYSTAL DISTRIBUTION FUNCTION 

! NEW ALGORITHM (NO TYPE ICE) 

	          CALL JERDFUN(R2,B21_MY,B22_MY &
     &                         ,FI2,PSI2,D2N &
     &                         ,ICM,1,COL,NKR,TPN)

	          CALL JERDFUN(R2,B21_MY,B22_MY &
     &                         ,FI2,PSI2,D2N &
     &                         ,ICM,2,COL,NKR,TPN)

	          CALL JERDFUN(R2,B21_MY,B22_MY &
     &                         ,FI2,PSI2,D2N &
     &                         ,ICM,3,COL,NKR,TPN)
	        ENDIF
! SNOW 
	        IF(ISYM3.NE.0) THEN

! SNOW DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
                                                         

! CALL JERDFUN - SNOW - 2 (ONLY_ICE: EVAPORATION)

	          CALL JERDFUN(R3,B31_MY,B32_MY &
     &                        ,FI3,PSI3,D2N &
     &                        ,1,3,COL,NKR,TPN)





! IN CASE : ISYM3.NE.0

	        ENDIF

! GRAUPELS (ONLY_ICE: EVAPORATION) 

	        IF(ISYM4.NE.0) THEN

! GRAUPEL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
                                                         
	          CALL JERDFUN(R4,B41_MY,B42_MY &
     &                        ,FI4,PSI4,D2N &
     &                        ,1,4,COL,NKR,TPN)
! IN CASE : ISYM4.NE.0

	        ENDIF

! HAIL (ONLY_ICE: EVAPORATION) 

	        IF(ISYM5.NE.0) THEN

! HAIL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
                                                         
	          CALL JERDFUN(R5,B51_MY,B52_MY &
     &                        ,FI5,PSI5,D2N &
     &                        ,1,5,COL,NKR,TPN)
! IN CASE : ISYM5.NE.0

	        ENDIF

	        IF((DEL2.LT.0.AND.DEL2N.GT.0) &
     &         .AND.ABS(DEL2N).GT.EPSDEL) THEN
                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ABS(DEL2N).GT.EPSDEL), model stop")
	        ENDIF

! IN CASE : KCOND.NE.21
 
	      ENDIF

! IN CASES : KCOND = 21 OR KCOND.NE.21

! END OF "PROCESS'S TYPE" 
!
! MASSES
              RMASSIBB=0.0
              RMASSIAA=0.0
! BEFORE JERNEWF
              DO K=1,NKR
                 DO ICE =1,ICEMAX
                    FI2_K=FI2(K,ICE)
                    R2_K=R2(K,ICE)
                    FI2R2=FI2_K*R2_K*R2_K
                    RMASSIBB=RMASSIBB+FI2R2
                 ENDDO
                 FI3_K=FI3(K)
                 FI4_K=FI4(K)
                 FI5_K=FI5(K)
                 R3_K=R3(K)
                 R4_K=R4(K)
                 R5_K=R5(K)
                 FI3R3=FI3_K*R3_K*R3_K
                 FI4R4=FI4_K*R4_K*R4_K
                 FI5R5=FI5_K*R5_K*R5_K
                 RMASSIBB=RMASSIBB+FI3R3
                 RMASSIBB=RMASSIBB+FI4R4
                 RMASSIBB=RMASSIBB+FI5R5
              ENDDO
              RMASSIBB=RMASSIBB*COL3*RORI
! NEW CHANGE RMASSIBB
              IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
! AFTER JERNEWF
              DO K=1,NKR
                 DO ICE =1,ICEMAX
                    FI2_K=PSI2(K,ICE)
                    R2_K=R2(K,ICE)
                    FI2R2=FI2_K*R2_K*R2_K
                    RMASSIAA=RMASSIAA+FI2R2
                 ENDDO
                 FI3_K=PSI3(K)
                 FI4_K=PSI4(K)
                 FI5_K=PSI5(K)
                 R3_K=R3(K)
                 R4_K=R4(K)
                 R5_K=R5(K)
                 FI3R3=FI3_K*R3_K*R3_K
                 FI4R4=FI4_K*R4_K*R4_K
                 FI5R5=FI5_K*R5_K*R5_K
                 RMASSIAA=RMASSIAA+FI3R3
                 RMASSIAA=RMASSIAA+FI4R4
                 RMASSIAA=RMASSIAA+FI5R5
              ENDDO
              RMASSIAA=RMASSIAA*COL3*RORI
! NEW CHANGE RMASSIAA
              IF(RMASSIAA.LT.0.0) RMASSIAA=0.0
! NEW TREATMENT OF "T" & "Q"
              DELMASSI1=RMASSIAA-RMASSIBB
              QPN=QPS-DELMASSI1
              DAL2=AL2
              TPN=TPS+DAL2*DELMASSI1
! SUPERSATURATION
              ARGEXP=-BB1_MY/TPN
              ES1N=AA1_MY*DEXP(ARGEXP)
              ARGEXP=-BB2_MY/TPN
              ES2N=AA2_MY*DEXP(ARGEXP)
              EW1N=OPER3(QPN,PP)
              IF(ES1N.EQ.0)THEN
               DEL1N=0.5
               DIV1=1.5
              call wrf_error_fatal("fatal error in module_mp_fast_sbm (ES1N.EQ.0), model stop")
              ELSE
               DIV1=EW1N/ES1N
               DEL1N=EW1N/ES1N-1.
              END IF
              IF(ES2N.EQ.0)THEN
               DEL2N=0.5
               DIV2=1.5
              call wrf_error_fatal("fatal error in module_mp_fast_sbm (ES2N.EQ.0), model stop")
              ELSE
               DEL2N=EW1N/ES2N-1.
               DIV2=EW1N/ES2N
              END IF

!  END OF TIME SPLITTING 
! (ONLY ICE: CONDENSATION OR EVAPORATION) 
	      IF(TIMENEW.LT.DT) GOTO 46
        TT=TPN
        QQ=QPN
	DO KR=1,NKR
	   DO ICE=1,ICEMAX
	      FF2(KR,ICE)=PSI2(KR,ICE)
	   ENDDO
	   FF3(KR)=PSI3(KR)
	   FF4(KR)=PSI4(KR)
	   FF5(KR)=PSI5(KR)
	ENDDO


! GO TO "CONDENSATION AND VAPORATION"


        RETURN                                          
        END SUBROUTINE ONECOND2
!==================================================================

        SUBROUTINE ONECOND3 &
     & (TT,QQ,PP,ROR &
     & ,VR1,VR2,VR3,VR4,VR5,PSINGLE &
     & ,DEL1N,DEL2N,DIV1,DIV2 &
     & ,FF1,PSI1,R1,RLEC,RO1BL &
     & ,FF2,PSI2,R2,RIEC,RO2BL &
     & ,FF3,PSI3,R3,RSEC,RO3BL &
     & ,FF4,PSI4,R4,RGEC,RO4BL &
     & ,FF5,PSI5,R5,RHEC,RO5BL &
     & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
     & ,C1_MEY,C2_MEY &
     & ,COL,DTCOND,ICEMAX,NKR &
     & ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
       IMPLICIT NONE
       INTEGER ICEMAX,NKR,KR,ITIME,ICE,KCOND,K &
     &           ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5
       INTEGER KLIMITL,KLIMITG,KLIMITH,KLIMITI_1, &
     &  KLIMITI_2,KLIMITI_3
       INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON  
       REAL ROR,VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
     &           ,VR5(NKR),PSINGLE &
     &           ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
     &           ,C1_MEY,C2_MEY &
     &           ,COL,DTCOND

! DROPLETS 
                                                                       
        REAL R1(NKR)&
     &           ,RLEC(NKR),RO1BL(NKR) &
     &           ,FI1(NKR),FF1(NKR),PSI1(NKR) &
     &           ,B11_MY(NKR),B12_MY(NKR)

! CRYSTALS
                                                                       
	REAL R2(NKR,ICEMAX) &
     &           ,RIEC(NKR,ICEMAX) &
     &           ,RO2BL(NKR,ICEMAX) &
     &           ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
     &           ,FF2(NKR,ICEMAX) &
     &           ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX) &
     &           ,RATE2(NKR,ICEMAX),DEL_R2M(NKR,ICEMAX)

! SNOW                                                                          
        REAL R3(NKR) &
     &           ,RSEC(NKR),RO3BL(NKR) &
     &           ,FI3(NKR),FF3(NKR),PSI3(NKR) &
     &           ,B31_MY(NKR),B32_MY(NKR) &
     &           ,DEL_R3M(NKR)  

! GRAUPELS 
                                                                       
        REAL R4(NKR),R4N(NKR) &
     &           ,RGEC(NKR),RO4BL(NKR) &
     &           ,FI4(NKR),FF4(NKR),PSI4(NKR) &
     &           ,B41_MY(NKR),B42_MY(NKR) &
     &           ,DEL_R4M(NKR)

! HAIL                                                                          
        REAL R5(NKR),R5N(NKR) &
     &           ,RHEC(NKR),RO5BL(NKR) &
     &           ,FI5(NKR),FF5(NKR),PSI5(NKR) &
     &           ,B51_MY(NKR),B52_MY(NKR) &
     &           ,DEL_R5M(NKR)

      DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
      DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
     &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
     &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
     &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
     &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
     &                  ,ES1N,ES2N,EW1N,ARGEXP &
     &                  ,TT,QQ,PP,DEL1N0,DEL2N0 &
     &                  ,DEL1N,DEL2N,DIV1,DIV2 &
     &                  ,OPER2,OPER3,AR1,AR2

       DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1

       REAL A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
        DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
     &      /2.53,5.42,3.41E1,6.13/
       REAL B8L,B8I,SFN11,SFN12,SFNL,SFNI
       REAL B5L,B5I,B7L,B7I,B6,DOPL,DEL1S,DEL2S,DOPI,RW,QW,PW, &
     &  RI,PI,QI,SFNI1(ICEMAX),SFNI2(ICEMAX),AL1,AL2
       REAL D1N,D2N,DT0L, DT0I,D1N0,D2N0
       REAL SFN21,SFN22,SFNII1,SFNII2,SFN31,SFN32,SFN41,SFN42,SFN51, &
     &  SFN52
       REAL DEL1,DEL2
       REAL  TIMEREV,DT,DTT,TIMENEW
       REAL DTIMEG(NKR),DTIMEH(NKR)

       REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
     &           ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR)
       REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
     &  DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON
       REAL DTNEWL0,DTNEWL1,DTNEWI1,DTNEWI2_1,DTNEWI2_2,DTNEWI2_3, &
     & DTNEWI2,DTNEWI_1,DTNEWI_2,DTNEWI3,DTNEWI4,DTNEWI5, &
     & DTNEWL,DTNEWL2,DTNEWG1,DTNEWH1
       REAL TIMESTEPD(NKR)

       DATA AL1 /2500./, AL2 /2834./
       REAL EPSDEL,EPSDEL2
       DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/
       OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
       OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
      
! BELOW
!
        DT_WATER_COND=0.4
        DT_WATER_EVAP=0.4
        DT_ICE_COND=0.4
        DT_ICE_EVAP=0.4
        DT_MIX_COND=0.4
        DT_MIX_EVAP=0.4
        DT_MIX_BERGERON=0.4
        DT_MIX_ANTIBERGERON=0.4

        I_MIXCOND=0
        I_MIXEVAP=0
        I_ABERGERON=0
        I_BERGERON=0

       ITIME = 0
       TIMENEW=0.
       DT=DTCOND
       DTT=DTCOND

       B6=0.
       B8L=1./ROR
       B8I=1./ROR
! NEW CHANGES 19.04.01 (BEGIN)
        RORI=1.D0/ROR
! NEW CHANGES 19.04.01 (END)
! NEW CHANGES 19.04.01 (BEGIN)
        COL3=3.D0*COL
! NEW CHANGES 19.04.01 (END)



! BARRY:DIV
        TPN=TT
        QPN=QQ
! HERE
   16         ITIME=ITIME+1
! BARRY
!             TPC_NEW=TPN-273.15
              IF((TPN-273.15).GE.-0.187) GO TO 17
              TIMEREV=DT-TIMENEW
              DEL1=DEL1N
              DEL2=DEL2N
              DEL1S=DEL1N
              DEL2S=DEL2N
! NEW ALGORITHM (NO TYPE ICE)
              DEL2D(1)=DEL2N
              DEL2D(2)=DEL2N
              DEL2D(3)=DEL2N
              TPS=TPN
              QPS=QPN
              DO KR=1,NKR
                 FI1(KR)=PSI1(KR)
                 FI3(KR)=PSI3(KR)
                 FI4(KR)=PSI4(KR)
                 FI5(KR)=PSI5(KR)
                 DO ICE=1,ICEMAX
                    FI2(KR,ICE)=PSI2(KR,ICE)
                 ENDDO
              ENDDO
! TIME-STEP GROWTH RATE
! HERE
              CALL JERRATE(R1,TPS,PP,ROR,VR1,PSINGLE &
     &                    ,RLEC,RO1BL,B11_MY,B12_MY,1,1,ICEMAX,NKR)
              CALL JERRATE(R2,TPS,PP,ROR,VR2,PSINGLE &
     &                    ,RIEC,RO2BL,B21_MY,B22_MY,3,2,ICEMAX,NKR)
              CALL JERRATE(R3,TPS,PP,ROR,VR3,PSINGLE &
     &                    ,RSEC,RO3BL,B31_MY,B32_MY,1,2,ICEMAX,NKR)
              CALL JERRATE(R4,TPS,PP,ROR,VR4,PSINGLE &
     &                    ,RGEC,RO4BL,B41_MY,B42_MY,1,2,ICEMAX,NKR)
              CALL JERRATE(R5,TPS,PP,ROR,VR5,PSINGLE &
     &                    ,RHEC,RO5BL,B51_MY,B52_MY,1,2,ICEMAX,NKR)
              CALL JERTIMESC(FI1,R1,SFN11,SFN12 &
     &                      ,B11_MY,B12_MY,RLEC,B8L,1,COL,NKR)
              CALL JERTIMESC_ICE(FI2,R2,SFNI1,SFNI2 &
     &                      ,B21_MY,B22_MY,RIEC,B8I,ICEMAX,COL,NKR)
              CALL JERTIMESC(FI3,R3,SFN31,SFN32 &
     &                      ,B31_MY,B32_MY,RSEC,B8I,1,COL,NKR)
              CALL JERTIMESC(FI4,R4,SFN41,SFN42 &
     &                      ,B41_MY,B42_MY,RGEC,B8I,1,COL,NKR)
              CALL JERTIMESC(FI5,R5,SFN51,SFN52 &
     &                      ,B51_MY,B52_MY,RHEC,B8I,1,COL,NKR)
! NEW ALGORITHM (NO TYPE ICE)
              SFNII1=SFNI1(1)+SFNI1(2)+SFNI1(3)
              SFNII2=SFNI2(1)+SFNI2(2)+SFNI2(3)
              SFN21=SFNII1+SFN31+SFN41+SFN51
              SFN22=SFNII2+SFN32+SFN42+SFN52
              SFNL=SFN11+SFN12
              SFNI=SFN21+SFN22
! SOME CONSTANTS (QW,QI=0,since B6=0.)
              B5L=BB1_MY/TPS/TPS
              B5I=BB2_MY/TPS/TPS
              B7L=B5L*B6
              B7I=B5I*B6
              DOPL=1.+DEL1S
              DOPI=1.+DEL2S
              RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL
              QW=B7L*DOPL
              PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
              RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
              PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
              QI=B7I*DOPI
! SOLVING FOR TIMEZERO
              CALL JERSUPSAT(DEL1,DEL2,DEL1N0,DEL2N0 &
     &                      ,RW,PW,RI,PI,QW,QI &
     &                      ,DTT,D1N0,D2N0,DT0L,DT0I)
! DEL1 > 0, DEL2 < 0    (ANTIBERGERON MIXED PHASE - KCOND=50)
! DEL1 < 0 AND DEL2 < 0 (EVAPORATION MIXED_PHASE - KCOND=30)
! DEL1 > 0 AND DEL2 > 0 (CONDENSATION MIXED PHASE - KCOND=31)
! DEL1 < 0, DEL2 > 0    (BERGERON MIXED PHASE - KCOND=32)
              KCOND=50

              IF(DEL1.LT.0.AND.DEL2.LT.0) KCOND=30
              IF(DEL1.GT.0.AND.DEL2.GT.0) KCOND=31
              IF(DEL1.LT.0.AND.DEL2.GT.0) KCOND=32
              IF(KCOND.EQ.50) THEN 
                I_ABERGERON=I_ABERGERON+1
                IF(DT0L.EQ.0) THEN
                  DTNEWL=DT
                ELSE
                  DTNEWL=AMIN1(DT,DT0L)
                ENDIF
! NEW TIME STEP (ANTIBERGERON MIXED PHASE)
                IF(DTNEWL.GT.DT) DTNEWL=DT
                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
     &          DTNEWL=DT-TIMENEW
                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
                TIMENEW=TIMENEW+DTNEWL
                DTT=DTNEWL
                IF(ITIME.GE.NKR) THEN
                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
                ENDIF
                TIMESTEPD(ITIME)=DTNEWL
! ANTIBERGERON MIXED PHASE (BEGIN)
! IN CASE : KCOND = 50
              ENDIF
              IF(KCOND.EQ.31) THEN
! CONDENSATION MIXED PHASE (BEGIN)
! CONTROL OF TIMESTEP ITERATIONS
                I_MIXCOND=I_MIXCOND+1
               IF (DEL1N.EQ.0)THEN
                DTNEWL0=DT
               ELSE
                DTNEWL0=ABS(R1(ITIME)/(B11_MY(ITIME)*DEL1N- &
     &                                 B12_MY(ITIME)))
               END IF
! NEW ALGORITHM (NO TYPE OF ICE)

               IF (DEL2N.EQ.0)THEN
                DTNEWI2_1=DT
                DTNEWI2_2=DT
                DTNEWI2_3=DT
                DTNEWI3=DT
                DTNEWI4=DT
                DTNEWI5=DT
               ELSE
                DTNEWI2_1=ABS(R2(ITIME,1)/ &
     &         (B21_MY(ITIME,1)*DEL2N-B22_MY(ITIME,1)))
                DTNEWI2_2=ABS(R2(ITIME,2)/ &
     &         (B21_MY(ITIME,2)*DEL2N-B22_MY(ITIME,2))) 
                DTNEWI2_3=ABS(R2(ITIME,3)/ &
     &         (B21_MY(ITIME,3)*DEL2N-B22_MY(ITIME,3)))  
                DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)

                DTNEWI3=ABS(R3(ITIME)/(B31_MY(ITIME)*DEL2N- &
     &                                 B32_MY(ITIME)))
                DTNEWI4=ABS(R4(ITIME)/(B41_MY(ITIME)*DEL2N- &
     &                                 B42_MY(ITIME)))
                DTNEWI5=ABS(R5(ITIME)/(B51_MY(ITIME)*DEL2N- &
     &                                 B52_MY(ITIME)))
               END IF
                DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I)
                IF(DT0L.NE.0) THEN
                  IF(ABS(DT0L).LT.DT_MIX_COND) THEN
                    DTNEWL1=AMIN1(DT_MIX_COND,DTNEWL0)
                  ELSE
                    DTNEWL1=AMIN1(DT0L,DTNEWL0)
                  ENDIF
                ELSE
                  DTNEWL1=DTNEWL0
                ENDIF
                DTNEWL=AMIN1(DTNEWL1,DTNEWI1)
                IF(ITIME.GE.NKR) THEN
                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
                ENDIF
                TIMESTEPD(ITIME)=DTNEWL
! NEW TIME STEP (CONDENSATION MIXED PHASE)
                IF(DTNEWL.GT.DT) DTNEWL=DT
                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
     &          DTNEWL=DT-TIMENEW
                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
                TIMENEW=TIMENEW+DTNEWL
                TIMESTEPD(ITIME)=DTNEWL
                DTT=DTNEWL
! CONDENSATION MIXED PHASE (END)
! IN CASE : KCOND = 31
              ENDIF
              IF(KCOND.EQ.30) THEN
! EVAPORATION MIXED PHASE (BEGIN)
! CONTROL OF TIMESTEP ITERATIONS
                I_MIXEVAP=I_MIXEVAP+1
                DO KR=1,NKR
                   DTIMEL(KR)=0.
                   DTIMEG(KR)=0.
                   DTIMEH(KR)=0.
! NEW ALGORITHM (NO TYPE ICE)
                   DTIMEI_1(KR)=0.
                   DTIMEI_2(KR)=0.
                   DTIMEI_3(KR)=0.
                ENDDO
                DO KR=1,NKR
                 IF (DEL1N.EQ.0) THEN
                   DTIMEL(KR)=DT
                   DTIMEG(KR)=DT
                   DTIMEH(KR)=DT
                 ELSE
                   DTIMEL(KR)=-R1(KR)/(B11_MY(KR)*DEL1N- &
     &                                 B12_MY(KR))
                   DTIMEG(KR)=-R4(KR)/(B41_MY(KR)*DEL1N- &
     &                                 B42_MY(KR))
                   DTIMEH(KR)=-R5(KR)/(B51_MY(KR)*DEL1N- &
     &                             B52_MY(KR))
! NEW ALGORITHM (NO TYPE OF ICE)
                 END IF
                 IF (DEL2N.EQ.0) THEN
                   DTIMEI_1(KR)=DT
                   DTIMEI_2(KR)=DT
                   DTIMEI_3(KR)=DT
                 ELSE
                   DTIMEI_1(KR)=-R2(KR,1)/ &
     &               (B21_MY(KR,1)*DEL2N-B22_MY(KR,1))
                   DTIMEI_2(KR)=-R2(KR,2)/ &
     &               (B21_MY(KR,2)*DEL2N-B22_MY(KR,2))
                   DTIMEI_3(KR)=-R2(KR,3)/ &
     &               (B21_MY(KR,3)*DEL2N-B22_MY(KR,3))
                 END IF
                ENDDO
! WATER
                KLIMITL=1
                DO KR=1,NKR
                   IF(DTIMEL(KR).GT.TIMEREV) GOTO 355
                   KLIMITL=KR
                ENDDO
  355           KLIMITL=KLIMITL-1
                IF(KLIMITL.LT.1) KLIMITL=1
                DTNEWL1=AMIN1(DTIMEL(KLIMITL),DT0L,TIMEREV)
! GRAUPELS
                KLIMITG=1
                DO KR=1,NKR
                   IF(DTIMEG(KR).GT.TIMEREV) GOTO 455
                   KLIMITG=KR
                ENDDO
  455           KLIMITG=KLIMITG-1
                IF(KLIMITG.LT.1) KLIMITG=1
                DTNEWG1=AMIN1(DTIMEG(KLIMITG),TIMEREV)
! HAIL
                KLIMITH=1
                DO KR=1,NKR
                   IF(DTIMEH(KR).GT.TIMEREV) GOTO 555
                   KLIMITH=KR
                ENDDO
  555           KLIMITH=KLIMITH-1
                IF(KLIMITH.LT.1) KLIMITH=1
                DTNEWH1=AMIN1(DTIMEH(KLIMITH),TIMEREV)
! ICE CRYSTALS
! NEW ALGORITHM (NO TYPE OF ICE) (BEGIN)
                KLIMITI_1=1
                KLIMITI_2=1
                KLIMITI_3=1
                DO KR=1,NKR
                   IF(DTIMEI_1(KR).GT.TIMEREV) GOTO 655
                   KLIMITI_1=KR
                ENDDO
  655           CONTINUE
                DO KR=1,NKR
                   IF(DTIMEI_2(KR).GT.TIMEREV) GOTO 656
                   KLIMITI_2=KR
                ENDDO
  656           CONTINUE
                DO KR=1,NKR
                   IF(DTIMEI_3(KR).GT.TIMEREV) GOTO 657
                   KLIMITI_3=KR
                ENDDO
  657           CONTINUE
                KLIMITI_1=KLIMITI_1-1
                IF(KLIMITI_1.LT.1) KLIMITI_1=1
                DTNEWI2_1=AMIN1(DTIMEI_1(KLIMITI_1),TIMEREV)
                KLIMITI_2=KLIMITI_2-1
                IF(KLIMITI_2.LT.1) KLIMITI_2=1
                DTNEWI2_2=AMIN1(DTIMEI_2(KLIMITI_2),TIMEREV)
                KLIMITI_3=KLIMITI_3-1
                IF(KLIMITI_3.LT.1) KLIMITI_3=1
                DTNEWI2_3=AMIN1(DTIMEI_3(KLIMITI_3),TIMEREV)
                DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
! NEW ALGORITHM (NO TYPE OF ICE) (END)
                DTNEWI1=AMIN1(DTNEWI2,DTNEWG1,DTNEWH1,DT0I)
                IF(ABS(DEL2N).LT.EPSDEL2) &
     &          DTNEWI1=AMIN1(DTNEWI2,DTNEWG1,DTNEWH1)
                DTNEWL2=AMIN1(DTNEWL1,DTNEWI1)
                DTNEWL=DTNEWL2
                IF(DTNEWL.LT.DT_MIX_EVAP) &
     &          DTNEWL=AMIN1(DT_MIX_EVAP,TIMEREV)  
                IF(ITIME.GE.NKR) THEN
                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
                ENDIF
                TIMESTEPD(ITIME)=DTNEWL
! NEW TIME STEP (EVAPORATION MIXED PHASE)
                IF(DTNEWL.GT.DT) DTNEWL=DT
                IF((TIMENEW+DTNEWL).GT.DT &
     &         .AND.ITIME.LT.(NKR-1)) &
     &          DTNEWL=DT-TIMENEW
                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
                TIMESTEPD(ITIME)=DTNEWL
                TIMENEW=TIMENEW+DTNEWL
                DTT=DTNEWL
! EVAPORATION MIXED PHASE (END)
! IN CASE : KCOND = 30
              ENDIF
              IF(KCOND.EQ.32) THEN
! BERGERON MIXED PHASE (BEGIN)
! CONTROL OF TIMESTEP ITERATIONS
                I_BERGERON=I_BERGERON+1
! NEW TREATMENT OF TIME STEP (BERGERON MIXED PHASE)
               IF (DEL1N.EQ.0)THEN
                DTNEWL0=DT
               ELSE
                DTNEWL0=-R1(1)/(B11_MY(1)*DEL1N-B12_MY(1))
               END IF
! NEW ALGORITHM (NO TYPE ICE)
               IF (DEL2N.EQ.0)THEN
                DTNEWI2_1=DT
                DTNEWI2_2=DT
                DTNEWI2_3=DT
               ELSE
                DTNEWI2_1=R2(1,1)/(B21_MY(1,1)*DEL2N-B22_MY(1,1))
                DTNEWI2_2=R2(1,2)/(B21_MY(1,2)*DEL2N-B22_MY(1,2))
                DTNEWI2_3=R2(1,3)/(B21_MY(1,3)*DEL2N-B22_MY(1,3))
               END IF
               DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
               IF (DEL2N.EQ.0)THEN
                DTNEWI3=DT
                DTNEWI4=DT
                DTNEWI5=DT
               ELSE
                DTNEWI3=R3(1)/(B31_MY(1)*DEL2N-B32_MY(1))
                DTNEWI4=R4(1)/(B41_MY(1)*DEL2N-B42_MY(1))
                DTNEWI5=R5(1)/(B51_MY(1)*DEL2N-B52_MY(1))
               END IF
                DTNEWL1=AMIN1(DTNEWL0,DT0L,TIMEREV)
                DTNEWI1=AMIN1(DTNEWI2,DTNEWI3,DTNEWI4 &
     &                       ,DTNEWI5,DT0I,TIMEREV)
                DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I,TIMEREV)
                DTNEWL=AMIN1(DTNEWL1,DTNEWI1)
! NEW CHANGES 23.04.01 (BEGIN)
                IF(DTNEWL.LT.DT_MIX_BERGERON) &
     &          DTNEWL=AMIN1(DT_MIX_BERGERON,TIMEREV)
                TIMESTEPD(ITIME)=DTNEWL
! NEW TIME STEP (BERGERON MIXED PHASE)
                IF(DTNEWL.GT.DT) DTNEWL=DT
                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
     &          DTNEWL=DT-TIMENEW
                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
                TIMESTEPD(ITIME)=DTNEWL
                TIMENEW=TIMENEW+DTNEWL
                DTT=DTNEWL
! BERGERON MIXED PHASE (END)
! IN CASE : KCOND = 32
              ENDIF
! SOLVING FOR SUPERSATURATION 
! CALL JERSUPSAT - 7 (MIXED_PHASE)
         
	      CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
     &                      ,RW,PW,RI,PI,QW,QI &
     &                      ,DTT,D1N,D2N,DT0L,DT0I)
! END OF "NEW SUPERSATURATION" 

! DROPLETS 
	      IF(ISYM1.NE.0) THEN

! DROPLET DISTRIBUTION FUNCTION 

                                                         
! CALL JERDFUN - 3
	        CALL JERDFUN(R1,B11_MY,B12_MY &
     &                      ,FI1,PSI1,D1N &
     &                      ,1,1,COL,NKR,TPN)
! END OF "DROPLET DISTRIBUTION FUNCTION" 
 
! IN CASE ISYM1.NE.0

 	      ENDIF                     
! CRYSTALS 
	      IF(ISYM2.NE.0) THEN

! CRYSTAL DISTRIBUTION FUNCTION 
 
	        CALL JERDFUN(R2,B21_MY,B22_MY &
     &                      ,FI2,PSI2,D2N &
     &                      ,ICEMAX,1,COL,NKR,TPN)

	        CALL JERDFUN(R2,B21_MY,B22_MY &
     &                      ,FI2,PSI2,D2N &
     &                      ,ICEMAX,2,COL,NKR,TPN)

	        CALL JERDFUN(R2,B21_MY,B22_MY &
     &                      ,FI2,PSI2,D2N &
     &                      ,ICEMAX,3,COL,NKR,TPN)
! IN CASE ISYM2.NE.0

	      ENDIF
! SNOW 
	      IF(ISYM3.NE.0) THEN

! SNOW DISTRIBUTION FUNCTION 
                                                         

! CALL JERDFUN - SNOW - 3

 	        CALL JERDFUN(R3,B31_MY,B32_MY &
     &                      ,FI3,PSI3,D2N &
     &                      ,1,3,COL,NKR,TPN)


! IN CASE ISYM3.NE.0

  	      ENDIF

! GRAUPELS 

	      IF(ISYM4.NE.0) THEN

! GRAUPEL DISTRIBUTION FUNCTION
                                                         
	        CALL JERDFUN(R4,B41_MY,B42_MY &
     &                      ,FI4,PSI4,D2N &
     &                      ,1,4,COL,NKR,TPN)
! IN CASE ISYM4.NE.0

	      ENDIF
! HAIL 
	      IF(ISYM5.NE.0) THEN

! HAIL DISTRIBUTION FUNCTION 
                                                         
	        CALL JERDFUN(R5,B51_MY,B52_MY &
     &                      ,FI5,PSI5,D2N &
     &                      ,1,5,COL,NKR,TPN)
! IN CASE ISYM5.NE.0

	      ENDIF
! MASSES
              RMASSLBB=0.D0
              RMASSIBB=0.D0
              RMASSLAA=0.D0
              RMASSIAA=0.D0
! BEFORE JERNEWF
              DO K=1,NKR
                 FI1_K=FI1(K)
                 R1_K=R1(K)
                 FI1R1=FI1_K*R1_K*R1_K
                 RMASSLBB=RMASSLBB+FI1R1
                 DO ICE =1,ICEMAX
                    FI2_K=FI2(K,ICE)
                    R2_K=R2(K,ICE)
                    FI2R2=FI2_K*R2_K*R2_K
                    RMASSIBB=RMASSIBB+FI2R2
                 ENDDO
                 FI3_K=FI3(K)
                 FI4_K=FI4(K)
                 FI5_K=FI5(K)
                 R3_K=R3(K)
                 R4_K=R4(K)
                 R5_K=R5(K)
                 FI3R3=FI3_K*R3_K*R3_K
                 FI4R4=FI4_K*R4_K*R4_K
                 FI5R5=FI5_K*R5_K*R5_K
                 RMASSIBB=RMASSIBB+FI3R3
                 RMASSIBB=RMASSIBB+FI4R4
                 RMASSIBB=RMASSIBB+FI5R5
              ENDDO
              RMASSIBB=RMASSIBB*COL3*RORI
! NEW CHANGE RMASSIBB
              IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
              RMASSLBB=RMASSLBB*COL3*RORI
! NEW CHANGE RMASSLBB
              IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
! AFTER  JERNEWF
              DO K=1,NKR
                 FI1_K=PSI1(K)
                 R1_K=R1(K)
                 FI1R1=FI1_K*R1_K*R1_K
                 RMASSLAA=RMASSLAA+FI1R1
                 DO ICE =1,ICEMAX
                    FI2(K,ICE)=PSI2(K,ICE)
                    FI2_K=FI2(K,ICE)
                    R2_K=R2(K,ICE)
                    FI2R2=FI2_K*R2_K*R2_K
                    RMASSIAA=RMASSIAA+FI2R2
                 ENDDO
                 FI3_K=PSI3(K)
                 FI4_K=PSI4(K)
                 FI5_K=PSI5(K)
                 R3_K=R3(K)
                 R4_K=R4(K)
                 R5_K=R5(K)
                 FI3R3=FI3_K*R3_K*R3_K
                 FI4R4=FI4_K*R4_K*R4_K
                 FI5R5=FI5_K*R5_K*R5_K
                 RMASSIAA=RMASSIAA+FI3R3
                 RMASSIAA=RMASSIAA+FI4R4
                 RMASSIAA=RMASSIAA+FI5R5
              ENDDO
              RMASSIAA=RMASSIAA*COL3*RORI
! NEW CHANGE RMASSIAA
              IF(RMASSIAA.LE.0.0) RMASSIAA=0.0
              RMASSLAA=RMASSLAA*COL3*RORI
! NEW CHANGE RMASSLAA
              IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
! NEW TREATMENT OF "T" & "Q"
              DELMASSL1=RMASSLAA-RMASSLBB
              DELMASSI1=RMASSIAA-RMASSIBB
              DELTAQ1=DELMASSL1+DELMASSI1
!             QPN=QPS-DELTAQ1-CWQ*DTT
              QPN=QPS-DELTAQ1
              DAL1=AL1
              DAL2=AL2
!             TPN=TPS+DAL1*DELMASSL1+AL2*DELMASSI1-CWQ*DTT
              TPN=TPS+DAL1*DELMASSL1+DAL2*DELMASSI1
! SUPERSATURATION
              ARGEXP=-BB1_MY/TPN
              ES1N=AA1_MY*DEXP(ARGEXP)
              ARGEXP=-BB2_MY/TPN
              ES2N=AA2_MY*DEXP(ARGEXP)
              EW1N=OPER3(QPN,PP)
              IF(ES1N.EQ.0)THEN
               DEL1N=0.5
               DIV1=1.5
!              print*,'es1n onecond3 = 0'
!              stop
              ELSE
               DIV1=EW1N/ES1N
               DEL1N=EW1N/ES1N-1.
              END IF
              IF(ES2N.EQ.0)THEN
               DEL2N=0.5
               DIV2=1.5
!              print*,'es2n onecond3 = 0'
!              stop
              ELSE
               DEL2N=EW1N/ES2N-1.
               DIV2=EW1N/ES2N
              END IF
! END OF TIME SPLITTING

! HERE

        IF(TIMENEW.LT.DT) GOTO 16
17      CONTINUE

        TT=TPN
        QQ=QPN
        DO KR=1,NKR
           FF1(KR)=PSI1(KR)
           DO ICE=1,ICEMAX
              FF2(KR,ICE)=PSI2(KR,ICE)
           ENDDO
           FF3(KR)=PSI3(KR)
           FF4(KR)=PSI4(KR)
           FF5(KR)=PSI5(KR)
        ENDDO


        RETURN                                          
        END SUBROUTINE ONECOND3
        SUBROUTINE COAL_BOTT_NEW(FF1R,FF2R,FF3R, &
     &   FF4R,FF5R,TT,QQ,PP,RHO,dt_coll,TCRIT,TTCOAL)
       implicit none
       INTEGER KR,ICE
       INTEGER icol_drop,icol_snow,icol_graupel,icol_hail, &
     & icol_column,icol_plate,icol_dendrite,icol_drop_brk
       double precision  g1(nkr),g2(nkr,icemax),g3(nkr),g4(nkr),g5(nkr)
       double precision gdumb(JMAX),xl_dumb(0:nkr),g_orig(nkr)
       double precision g2_1(nkr),g2_2(nkr),g2_3(nkr)
       real cont_fin_drop,dconc,conc_icempl,deldrop,t_new, &
     & delt_new,cont_fin_ice,conc_old,conc_new,cont_init_ice, &
     & cont_init_drop,ALWC
       REAL    FF1R(NKR),FF2R(NKR,ICEMAX),FF3R(NKR),FF4R(NKR),FF5R(NKR)
       REAL dt_coll
       REAL TCRIT,TTCOAL
       real tt_no_coll
       parameter (tt_no_coll=273.16)


       
   
! SHARED
       INTEGER I,J,IT,NDIV
       REAL RHO
       DOUBLE PRECISION break_drop_bef,break_drop_aft,dtbreakup
       DOUBLE PRECISION break_drop_per
       DOUBLE PRECISION TT,QQ,PP,prdkrn,prdkrn1
       parameter (prdkrn1=1.d0)
!     print*,'tcrit = ',tcrit
!     print*,'ttcoal = ',ttcoal
!     print*,'col = ',col
!     print*,'p1,p2,p3 = ',p1,p2,p3
!     print*,'icempl,kr_icempl  = ',icempl,kr_icempl
!     print*,'dt_coll = ',dt_coll
      icol_drop_brk=0
      icol_drop=0
      icol_snow=0
      icol_graupel=0
      icol_hail=0
      icol_column=0
      icol_plate=0
      icol_dendrite=0


       t_new=tt
         CALL MISC1(PP,cwll_1000mb,cwll_750mb,cwll_500mb, &
     &    cwll,nkr)
! THIS IS FOR BREAKUP
         DO I=1,NKR
            DO J=1,NKR
               CWLL(I,J)=ECOALMASSM(I,J)*CWLL(I,J)
            ENDDO
         ENDDO
!
! THIS IS FOR TURBULENCE
        IF (LIQTURB.EQ.1)THEN
         DO I=1,KRMAX_LL
           DO J=1,KRMAX_LL
               CWLL(I,J)=CTURBLL(I,J)*CWLL(I,J)
           END DO
         END DO
        END IF
         CALL MODKRN(TT,QQ,PP,PRDKRN,TTCOAL)
        DO 13 KR=1,NKR
         G1(KR)=FF1R(KR)*3.*XL(KR)*XL(KR)*1.E3
         G2(KR,1)=FF2R(KR,1)*3*xi(KR,1)*XI(KR,1)*1.e3
         G2(KR,2)=FF2R(KR,2)*3.*xi(KR,2)*XI(KR,2)*1.e3
         G2(KR,3)=FF2R(KR,3)*3.*xi(KR,3)*XI(KR,3)*1.e3
         G3(KR)=FF3R(KR)*3.*xs(kr)*xs(kr)*1.e3
         G4(KR)=FF4R(KR)*3.*xg(kr)*xg(kr)*1.e3
         G5(KR)=FF5R(KR)*3.*xh(kr)*xh(kr)*1.e3
         g2_1(kr)=g2(KR,1)
         g2_2(KR)=g2(KR,2)
         g2_3(KR)=g2(KR,3)
         if(kr.gt.(nkr-jbreak).and.g1(kr).gt.1.e-17)icol_drop_brk=1
!        icol_drop_brk=0
         IF (IBREAKUP.NE.1)icol_drop_brk=0 
         if(g1(kr).gt.1.e-10)icol_drop=1
         if (tt.le.tt_no_coll)then
         if(g2_1(kr).gt.1.e-10)icol_column=1
         if(g2_2(kr).gt.1.e-10)icol_plate=1
         if(g2_3(kr).gt.1.e-10)icol_dendrite=1
         if(g3(kr).gt.1.e-10)icol_snow=1
         if(g4(kr).gt.1.e-10)icol_graupel=1
         if(g5(kr).gt.1.e-10)icol_hail=1
         end if
13     CONTINUE 
! calculation of initial hydromteors content in g/cm**3 :
      cont_init_drop=0.
      cont_init_ice=0.
      do kr=1,nkr
         cont_init_drop=cont_init_drop+g1(kr)
         cont_init_ice=cont_init_ice+g3(kr)+g4(kr)+g5(kr)
         do ice=1,icemax
            cont_init_ice=cont_init_ice+g2(kr,ice)
         enddo
      enddo
      cont_init_drop=col*cont_init_drop*1.e-3
      cont_init_ice=col*cont_init_ice*1.e-3
! calculation of alwc in g/m**3
      alwc=cont_init_drop*1.e6
! calculation interactions :
! droplets - droplets and droplets - ice :
! water-water = water

      if (icol_drop.eq.1)then 
! break-up

       call coll_xxx (G1,CWLL,XL_MG,CHUCM,IMA,NKR)
! breakup!
       if(icol_drop_brk.eq.1)then
       ndiv=1
10     continue
       do it = 1,ndiv
         if (ndiv.gt.10000) call wrf_error_fatal("fatal error in module_mp_fast_sbm (ndiv.gt.10000), model stop")
         dtbreakup = dt_coll/ndiv
         if (it.eq.1)then
!         do kr=1,nkr
          do kr=1,JMAX
           gdumb(kr)= g1(kr)*1.D-3
           xl_dumb(kr)=xl_mg(KR)*1.D-3
          end do
          break_drop_bef=0.d0
!         do kr=1,nkr
          do kr=1,JMAX
            break_drop_bef=break_drop_bef+g1(kr)*1.D-3
          enddo
         end if
         call breakup(gdumb,xl_dumb,dtbreakup,brkweight, &
     &        pkij,qkj,JMAX,jbreak)
       end do
       break_drop_aft=0.0d0
       do kr=1,JMAX
           break_drop_aft=break_drop_aft+gdumb(kr)
       enddo
       break_drop_per=break_drop_aft/break_drop_bef
       if (break_drop_per.gt.1.001)then
           ndiv=ndiv*2
           GO TO 10
       else
           do kr=1,JMAX
            g1(kr)=gdumb(kr)*1.D3
           end do
       end if
       end if
      end if
       if (icol_snow.eq.1)then 
         call coll_xyz (g1,g3,g4,cwls,xl_mg,xs_mg, &
     &                chucm,ima,prdkrn1,nkr,0)
         if(alwc.lt.alcr) then
         call coll_xyx (g3,g1,cwsl,xs_mg,xl_mg, &
     &                chucm,ima,prdkrn1,nkr,1)
         endif
         if(alwc.ge.alcr) then
!        call coll_xyz (g3,g1,g4,cwsl,xs_mg,xl_mg, &
!    &                chucm,ima,prdkrn1,nkr,1)
            call coll_xyxz_h (g3,g1,g4,cwsl,xs_mg,xl_mg, &
     &                chucm,ima,prdkrn1,nkr,1)
         endif
! in case : icolxz_snow.ne.0
       end if
! interactions between water and  graupel (begin)
! water - graupel = graupel (t < tcrit ; xl_mg ge xg_mg)
! graupel - water = graupel (t < tcrit ; xg_mg > xl_mg)
! water - graupel = hail (t ge tcrit ; xl_mg ge xg_mg)
! graupel - water = hail (t ge tcrit ; xg_mg > xl_mg)
       if (icol_graupel.eq.1)then 
! water-graupel
! included kp_bound = 25
!!         call coll_xyyz_h (g1,g4,g5,cwlg,xl_mg,xg_mg, &
!!     &                chucm,ima,prdkrn1,nkr,1)
! for ice multiplication
          conc_old=0.
          conc_new=0.
          do kr=kr_icempl,nkr
               conc_old=conc_old+col*g1(kr)/xl_mg(kr)
          enddo
! graupel-water
!          if(alwc.lt.alcr_g) then
! water-graupel
! TEST
            call coll_xyy (g1,g4,cwlh,xl_mg,xg_mg, &
     &               chucm,ima,prdkrn1,nkr,0)
            call coll_xyx (g4,g1,cwhl,xg_mg,xl_mg, &
     &          chucm,ima,prdkrn1,nkr,1)
! TEST
!          else
!!          call coll_xyxz_h (g4,g1,g5,cwgl,xg_mg,xl_mg, &
!!   &                chucm,ima,prdkrn1,nkr,1)
!          end if
! interactions between water and  graupels (end)

         if(icempl.eq.1) then
          if(tt.ge.265.15.and.tt.le.tcrit) then
! ice-multiplication :
            do kr=kr_icempl,nkr
               conc_new=conc_new+col*g1(kr)/xl_mg(kr)
            enddo
            dconc=conc_old-conc_new
            if(tt.le.268.15) then
              conc_icempl=dconc*4.e-3*(265.15-tt)/(265.15-268.15)
            endif
            if(tt.gt.268.15) then
             conc_icempl=dconc*4.e-3*(tcrit-tt)/(tcrit-268.15)
            endif
!CHANGE FOR FOUR BIN SCHEME           g2_2(1)=g2_2(1)+conc_icempl*xi2_mg(1)/col
            g3(1)=g3(1)+conc_icempl*xs_mg(1)/col
! in case t.ge.265.15 :
          endif
! in case icempl=1
         endif
! interactions between water and  graupels (end)
! in case icolxz_graup.ne.0
       endif
! water - hail = hail (xl_mg ge xh_mg)                      (kxyy=2)
! hail - water = hail (xh_mg > xl_mg)                       (kxyx=3)
!      if(icol_hail.eq.1) then
!       call coll_xyy (g1,g5,cwlh,xl_mg,xh_mg, &
!    &               chucm,ima,prdkrn1,nkr,0)
!       call coll_xyx (g5,g1,cwhl,xh_mg,xl_mg, &
!    &               chucm,ima,prdkrn1,nkr,1)
! in case icolxz_hail.ne.0
!      endif
! interactions between water and hail (end)
! interactions between water and crystals :
! interactions between water and columns :
! water - columns = graupel (t < tcrit ; xl_mg ge xi_mg)    (kxyz=6)
! water - columns = hail (t ge tcrit ; xl_mg ge xi_mg)      (kxyz=7)
! columns - water = columns/graupel (xi_mg > xl_mg)             (kxyx=4); kxyxz=2)
! now: columns - water = columns (xi_mg > xl_mg)             (kxyx=4); kxyxz=2)
!      if(icol_column.eq.1) then
!       if(tt.lt.tcrit) then
!        call coll_xyz (g1,g2_1,g4,cwli_1,xl_mg,xi1_mg, &
!    &                 chucm,ima,prdkrn,nkr,0)
!       endif
!       if(tt.ge.tcrit) then
!        call coll_xyz (g1,g2_1,g5,cwli_1,xl_mg,xi1_mg, &
!    &                 chucm,ima,prdkrn,nkr,0)
!       endif
!       call coll_xyxz (g2_1,g1,g4,cwil_1,xi1_mg,xl_mg, &
!    &                 chucm,ima,prdkrn,nkr,1)
!       call coll_xyx (g2_1,g1,cwil_1,xi1_mg,xl_mg, &
!    &                 chucm,ima,prdkrn,nkr,1)
! in case icolxz_column.ne.0
!      endif

!     if(icolxz_plate.ne.0) then
! interactions between water and plates :
! water - plates = graupel (t < tcrit ; xl_mg ge xi2_mg)    (kxyz=8)
! water - plates = hail (t ge tcrit ; xl_mg ge xi2_mg)      (kxyz=9)
! plates - water = plates/graupel (xi2_mg > xl_mg)              (kxyx=5; kxyxz=3)
!now: plates - water = plates (xi2_mg > xl_mg)              (kxyx=5; kxyxz=3)
!      if(icol_plate.eq.1) then
!       if(tt.lt.tcrit) then
!        call coll_xyz (g1,g2_2,g4,cwli_2,xl_mg,xi2_mg, &
!    &                 chucm,ima,prdkrn,nkr,0)
!       endif
!       if(tt.ge.tcrit) then
!        call coll_xyz (g1,g2_2,g5,cwli_2,xl_mg,xi2_mg, &
!    &                 chucm,ima,prdkrn,nkr,0)
!       endif
!       call coll_xyxz (g2_2,g1,g4,cwil_2,xi2_mg,xl_mg, &
!    &                 chucm,ima,prdkrn,nkr,1)
!       call coll_xyx (g2_2,g1,cwil_2,xi2_mg,xl_mg, &
!    &                 chucm,ima,prdkrn,nkr,1)
! in case icolxz_plate.ne.0
!      endif

! interactions between water and dendrites :
! water - dendrites = graupel (t < tcrit ; xl_mg ge xi3_mg) (kxyz=10)
! water - dendrites = hail (t ge tcrit ; xl_mg ge xi3_mg)   (kxyz=11)
! dendrites - water = dendrites/graupel (xi3_mg > xl_mg)         (kxyx=6; kxyxz=4)
!now dendrites - water = dendrites (xi3_mg > xl_mg)         (kxyx=6; kxyxz=4)
!      if(icol_dendrite.eq.1) then
!       if(tt.lt.tcrit) then
!        call coll_xyz (g1,g2_3,g4,cwli_3,xl_mg,xi3_mg, &
!    &                 chucm,ima,prdkrn,nkr,0)
!       endif
!       if(tt.ge.tcrit) then
!        call coll_xyz (g1,g2_3,g5,cwli_3,xl_mg,xi3_mg, &
!    &                 chucm,ima,prdkrn,nkr,0)
!       endif
!       call coll_xyxz (g2_3,g1,g4,cwil_3,xi3_mg,xl_mg, &
!    &                 chucm,ima,prdkrn,nkr,1)
!       call coll_xyx (g2_3,g1,cwil_3,xi3_mg,xl_mg, &
!    &                 chucm,ima,prdkrn,nkr,1)
! in case icolxz_dendr.ne.0
!      endif
! interactions between water and dendrites (end)
! in case icolxz_drop.ne.0
!     endif
! interactions between water and crystals (end)

! interactions between crystals :
! if(t.le.TTCOAL) - no interactions between crystals
!     if(tt.gt.TTCOAL) then
! interactions between columns and other particles (begin)
!      if(icol_column.eq.1) then
! columns - columns = snow
!       call coll_xxy (g2_1,g3,cwii_1_1,xi1_mg, &
!    &                 chucm,ima,prdkrn,nkr)
! interactions between columns and plates :
! columns - plates = snow (xi1_mg ge xi2_mg)                (kxyz=12)
! plates - columns = snow (xi2_mg > xi1_mg)                 (kxyz=13)
!       if(icol_plate.eq.1) then     
!        call coll_xyz (g2_1,g2_2,g3,cwii_1_2,xi1_mg,xi2_mg, &
!    &                 chucm,ima,prdkrn,nkr,0)
!        call coll_xyz (g2_2,g2_1,g3,cwii_2_1,xi2_mg,xi1_mg, &
!    &                 chucm,ima,prdkrn,nkr,1)
!       end if
! interactions between columns and dendrites :
! columns - dendrites = snow (xi1_mg ge xi3_mg)             (kxyz=14)
! dendrites - columns = snow (xi3_mg > xi1_mg)              (kxyz=15)
!       if(icol_dendrite.eq.1) then
!          call coll_xyz (g2_1,g2_3,g3,cwii_1_3,xi1_mg,xi3_mg, &
!    &                 chucm,ima,prdkrn,nkr,0)
!          call coll_xyz (g2_3,g2_1,g3,cwii_3_1,xi3_mg,xi1_mg, &
!    &                 chucm,ima,prdkrn,nkr,1)
!       end if
! interactions between columns and snow :
! columns - snow = snow (xi1_mg ge xs_mg)                   (kxyy=3)
! snow - columns = snow (xs_mg > xi1_mg)                    (kxyx=7)
! ALEX?
!       if(icol_snow.eq.1) then
!B       call coll_xyy (g2_1,g3,cwis_1,xi1_mg,xs_mg,
!B   1                 chucm,ima,prdkrn,nkr,0)
!!        call coll_xyx (g3,g2_1,cwsi_1,xs_mg,xi1_mg, &
!!    &                 chucm,ima,prdkrn,nkr,1)
!       endif          
! in case icolxz_column.ne.0
!      endif
! interactions between columns and other particles (end)
! interactions between plates and other particles (begin)
! plates - plates = snow
!      if(icol_plate.eq.1) then
!       call coll_xxy (g2_2,g3,cwii_2_2,xi2_mg, &
!    &                 chucm,ima,prdkrn,nkr)
! interactions between plates and dendrites :
! plates - dendrites = snow (xi2_mg ge xi3_mg)              (kxyz=17)
! dendrites - plates = snow (xi3_mg > xi2_mg)               (kxyz=18)
!       if(icol_dendrite.eq.1) then
!        call coll_xyz (g2_2,g2_3,g3,cwii_2_3,xi2_mg,xi3_mg, &
!    &                 chucm,ima,prdkrn,nkr,0)
!        call coll_xyz (g2_3,g2_2,g3,cwii_3_2,xi3_mg,xi2_mg, &
!    &                 chucm,ima,prdkrn,nkr,1)
!       end if
! interactions between plates and snow :
! plates - snow = snow (xi2_mg ge xs_mg)                    (kxyy=4)
! snow - plates = snow (xs_mg > xi2_mg)                     (kxyx=12)
!       if(icol_snow.eq.1) then
! ALEX
!B       call coll_xyy (g2_2,g3,cwis_2,xi2_mg,xs_mg,
!B   1                 chucm,ima,prdkrn,nkr,0)
!!        call coll_xyx (g3,g2_2,cwsi_2,xs_mg,xi2_mg, &
!!     &                 chucm,ima,prdkrn,nkr,1)
!        end if
! in case icolxz_plate.ne.0
!      endif
! interactions between plates and others particles (end)
! interactions between dendrites and other hydrometeors (begin)
! dendrites - dendrites = snow
!      if(icol_dendrite.eq.1) then
!!       call coll_xxy (g2_3,g3,cwii_3_3,xi3_mg, &
!!    &                  chucm,ima,prdkrn,nkr)
! interactions between dendrites and snow :
! dendrites - snow = snow (xi3_mg ge xs_mg)                 (kxyy=5)
! snow - dendrites = snow (xs_mg > xi3_mg)                  (kxyx=17)
!       if(icol_snow.eq.1) then
! ALEX
!B       call coll_xyy (g2_3,g3,cwis_3,xi3_mg,xs_mg,
!B   1                 chucm,ima,prdkrn,nkr,0)
!!        call coll_xyx (g3,g2_3,cwsi_3,xs_mg,xi3_mg, &
!!   &                 chucm,ima,prdkrn,nkr,1)
!       end if
! in case icolxz_dendr.ne.0
!      endif
! interactions between dendrites and other hydrometeors (end)
! interactions between snowflakes and other hydromteors (begin)
!       if(icol_snow.ne.0) then
! interactions between snowflakes
! snow - snow = snow
         call coll_xxx_prd (g3,cwss,xs_mg,chucm,ima,prdkrn,nkr)
! interactions between snowflakes and graupels :
! snow - graupel = snow (xs_mg > xg_mg)                     (kxyx=22)
! graupel - snow = graupel (xg_mg ge xs_mg)                 (kxyx=23)
!        if(icol_graupel.eq.1) then
!!         call coll_xyx (g3,g4,cwsg,xs_mg,xg_mg, &
!!   &                chucm,ima,prdkrn,nkr,1)
! in case icolxz_graup.ne.0
!        endif
! in case icolxz_snow.ne.0
!       endif
! interactions between snowflakes and other hydromteors (end)
! in case : t > TTCOAL
!     endif
! in case : t > TTCOAL or t.le.TTCOAL
! calculation of finish hydrometeors contents in g/cm**3 :
      cont_fin_drop=0.
      cont_fin_ice=0.
      do kr=1,nkr
!        g2(kr,1)=g2_1(kr)
!        g2(kr,2)=g2_2(kr)
!        g2(kr,3)=g2_3(kr)
         cont_fin_drop=cont_fin_drop+g1(kr)
!        cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)+g5(kr)
         cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)
!        do ice=1,icemax
!           cont_fin_ice=cont_fin_ice+g2(kr,ice)
!        enddo
      enddo
      cont_fin_drop=col*cont_fin_drop*1.e-3
      cont_fin_ice=col*cont_fin_ice*1.e-3
      deldrop=cont_init_drop-cont_fin_drop
! deldrop in g/cm**3
! resulted value of temperature (rob in g/cm**3) :
      if(t_new.le.273.15) then
        if(deldrop.ge.0.) then
          t_new=t_new+320.*deldrop/rho
        else
! if deldrop < 0
          if(abs(deldrop).gt.cont_init_drop*0.05) then
            call wrf_error_fatal("fatal error in module_mp_fast_sbm, abs(deldrop).gt.cont_init_drop, model stop")
          endif
        endif
       endif

61    continue
! recalculation of density function f1,f2,f3,f4,f5 in 1/(g*cm**3) :  
        DO 15 KR=1,NKR
         FF1R(KR)=G1(KR)/(3.*XL(KR)*XL(KR)*1.E3)
!        FF2R(KR,1)=G2(KR,1)/(3*xi(KR,1)*XI(KR,1)*1.e3)
!        FF2R(KR,2)=G2(KR,2)/(3.*xi(KR,2)*XI(KR,2)*1.e3)
!        FF2R(KR,3)=G2(KR,3)/(3.*xi(KR,3)*XI(KR,3)*1.e3)
         FF3R(KR)=G3(KR)/(3.*xs(kr)*xs(kr)*1.e3)
         FF4R(KR)=G4(KR)/(3.*xg(kr)*xg(kr)*1.e3)
!        FF5R(KR)=G5(KR)/(3.*xh(kr)*xh(kr)*1.e3)
15     CONTINUE 
      tt=t_new
      RETURN
      END SUBROUTINE COAL_BOTT_NEW

      SUBROUTINE MISC1(PP,cwll_1000mb,cwll_750mb,cwll_500mb, &
     &      cwll,nkr)
      IMPLICIT NONE
      INTEGER kr1,kr2,NKR
      DOUBLE PRECISION PP
      REAL P_Z
      double precision cwll(nkr,nkr),cwll_1,cwll_2,cwll_3 &
     &,cwll_1000mb(nkr,nkr),cwll_750mb(nkr,nkr),cwll_500mb(nkr,nkr)
      P_Z=PP
              do 12 kr1=1,nkr
              do 12 kr2=1,nkr
               cwll_1=cwll_1000mb(kr1,kr2)
               cwll_2=cwll_750mb(kr1,kr2)
               cwll_3=cwll_500mb(kr1,kr2)
               if(p_z.ge.p1) cwll(kr1,kr2)=cwll_1
               if(p_z.eq.p2) cwll(kr1,kr2)=cwll_2
               if(p_z.eq.p3) cwll(kr1,kr2)=cwll_3
               if(p_z.lt.p1.and.p_z.gt.p2) &
     &         cwll(kr1,kr2)=cwll_2+ &
     &         (cwll_1-cwll_2)*(p_z-p2)/(p1-p2) 
               if(p_z.lt.p2.and.p_z.gt.p3) &
     &         cwll(kr1,kr2)=cwll_3+ &
     &         (cwll_2-cwll_3)*(p_z-p3)/(p2-p3)
               if(p_z.lt.p3) cwll(kr1,kr2)=cwll_3
12            CONTINUE 
      RETURN
      END SUBROUTINE  MISC1

        subroutine coll_xxx (g,ckxx,x,chucm,ima,nkr)
        implicit double precision (a-h,o-z)
        dimension g(nkr),ckxx(nkr,nkr),x(0:nkr)
        dimension chucm(nkr,nkr)
        double precision ima(nkr,nkr)
        gmin=1.d-60
!       gmin=1.d-15
! lower and upper integration limit ix0,ix1
        do i=1,nkr-1
           ix0=i
           if(g(i).gt.gmin) goto 2000
        enddo
 2000   continue
        if(ix0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           ix1=i
           if(g(i).gt.gmin) goto 2010
        enddo
 2010   continue
! J. Dudhia gave reasons why this can't be looped with a
! multiprocessor.
! BARRY
!       do i=ix0,ix1
!          do j=i,ix1
        do i=ix0,ix1-1
           do j=i+1,ix1

              k=ima(i,j)
              kp=k+1
              x0=ckxx(i,j)*g(i)*g(j)
              x0=min(x0,g(i)*x(j))
              if(j.ne.k) then
                x0=min(x0,g(j)*x(i))
              endif
              gsi=x0/x(j)
              gsj=x0/x(i)
              gsk=gsi+gsj
              g(i)=g(i)-gsi
              if(g(i).lt.0.d0) g(i)=0.d0
              g(j)=g(j)-gsj
              gk=g(k)+gsk
              if(g(j).lt.0.d0.and.gk.lt.gmin) then
                g(j)=0.d0
                g(k)=g(k)+gsi
              endif
              flux=0.d0
!
! BARRY
              if(gk.gt.gmin) then
                x1=dlog(g(kp)/gk+1.d-15)
               if (x1.eq.0)then
                flux=0  
               else
                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
                flux=min(flux,gsk)
               end if

! new changes 23.01.01 (end)
                g(k)=gk-flux
                if(g(k).lt.0.d0) g(k)=0.d0
                g(kp)=g(kp)+flux
! in case gk > gmin :
              endif
            end do
        end do
 2020   continue
        return
        end subroutine coll_xxx
        subroutine coll_xxx_prd (g,ckxx,x,chucm,ima,prdkrn,nkr)
        implicit double precision (a-h,o-z)
        dimension g(nkr),ckxx(nkr,nkr),x(0:nkr)
        dimension chucm(nkr,nkr)
        double precision ima(nkr,nkr)
! this is character values containes adresses of temporary files      
        gmin=1.d-60
!       gmin=1.d-15
! lower and upper integration limit ix0,ix1
        do i=1,nkr-1
           ix0=i
           if(g(i).gt.gmin) goto 2000
        enddo
 2000   continue
        if(ix0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           ix1=i
           if(g(i).gt.gmin) goto 2010
        enddo
 2010   continue
! J. Dudhia gave reasons why this can't be looped with a
! multiprocessor.
! BARRY
!       do i=ix0,ix1
!          do j=i,ix1
        do i=ix0,ix1-1
           do j=i+1,ix1

              k=ima(i,j)
              kp=k+1
              x0=ckxx(i,j)*g(i)*g(j)*prdkrn
              x0=min(x0,g(i)*x(j))
              if(j.ne.k) then
                x0=min(x0,g(j)*x(i))
              endif
              gsi=x0/x(j)
              gsj=x0/x(i)
              gsk=gsi+gsj
              g(i)=g(i)-gsi
              if(g(i).lt.0.d0) g(i)=0.d0
              g(j)=g(j)-gsj
              gk=g(k)+gsk
              if(g(j).lt.0.d0.and.gk.lt.gmin) then
                g(j)=0.d0
                g(k)=g(k)+gsi
              endif
              flux=0.d0
!
! BARRY
              if(gk.gt.gmin) then
                x1=dlog(g(kp)/gk+1.d-15)
               if (x1.eq.0)then
                flux=0  
               else
                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
                flux=min(flux,gsk)
               end if

! new changes 23.01.01 (end)
                g(k)=gk-flux
                if(g(k).lt.0.d0) g(k)=0.d0
                g(kp)=g(kp)+flux
! in case gk > gmin :
              endif
            end do
        end do
 2020   continue
        return
        end subroutine coll_xxx_prd 
      subroutine modkrn(TT,QQ,PP,PRDKRN,TTCOAL)
      implicit none
      real epsf,tc,ttt1,ttt,factor,qs2,qq1,dele,f,factor_t
      double precision TT,QQ,PP,satq2,t,p
      double precision prdkrn
      REAL at,bt,ct,dt,temp,a,b,c,d,tc_min,tc_max
       real factor_max,factor_min
      REAL TTCOAL
	data at,bt,ct,dt/0.88333,0.0931878,0.0034793,4.5185186e-05/
        satq2(t,p)=3.80e3*(10**(9.76421-2667.1/t))/p
        temp(a,b,c,d,tc)=d*tc*tc*tc+c*tc*tc+b*tc+a
        IF (QQ.LE.0)QQ=1.E-12
        epsf    =.5
        tc      =tt-273.15
        factor=0 ! mchen add temporarily
        if(tc.le.0) then
! in case tc.le.0
          ttt1  =temp(at,bt,ct,dt,tc)
          ttt   =ttt1
          qs2   =satq2(tt,pp)
          qq1   =qq*(0.622+0.378*qs2)/(0.622+0.378*qq)/qs2
          dele  =ttt*qq1
! new change 27.06.00
          if(tc.ge.-6.) then
            factor = dele
            if(factor.lt.epsf) factor=epsf
            if(factor.gt.1.) factor=1.
! in case : tc.ge.-6.
          endif                        
          factor_t=factor
          if(tc.ge.-12.5.and.tc.lt.-6.) factor_t=0.5
          if(tc.ge.-17.0.and.tc.lt.-12.5) factor_t=1.
          if(tc.ge.-20.0.and.tc.lt.-17.) factor_t=0.4
          if(tc.lt.-20.) then
            tc_min=ttcoal-273.15
            tc_max=-20.
            factor_max=0.25
            factor_min=0.
            f=factor_min+(tc-tc_min)*(factor_max-factor_min)/  &
     &                               (tc_max-tc_min)
            factor_t=f
          endif
! BARRY
          if (factor_t.lt.0)factor_t=0.01
          prdkrn=factor_t
      else
          prdkrn=1.d0
      end if
      RETURN
      END SUBROUTINE modkrn 
           


        subroutine coll_xxy(gx,gy,ckxx,x,chucm,ima,prdkrn,nkr)
        implicit double precision (a-h,o-z)
        dimension chucm(nkr,nkr)
        double precision ima(nkr,nkr)
        dimension  &
     &  gx(nkr),gy(nkr),ckxx(nkr,nkr),x(0:nkr)
        gmin=1.d-60
! lower and upper integration limit ix0,ix1
        do i=1,nkr-1
           ix0=i
           if(gx(i).gt.gmin) goto 2000
        enddo
        if(ix0.eq.nkr-1) goto 2020
 2000   continue
        do i=nkr-1,1,-1
           ix1=i
           if(gx(i).gt.gmin) goto 2010
        enddo
 2010   continue
! collisions
        do i=ix0,ix1
           do j=i,ix1
              k=ima(i,j)
              kp=k+1
              x0=ckxx(i,j)*gx(i)*gx(j)*prdkrn
              x0=min(x0,gx(i)*x(j))
              x0=min(x0,gx(j)*x(i))
              gsi=x0/x(j)
              gsj=x0/x(i)
              gsk=gsi+gsj
              gx(i)=gx(i)-gsi
              if(gx(i).lt.0.d0) gx(i)=0.d0
              gx(j)=gx(j)-gsj
              if(gx(j).lt.0.d0) gx(j)=0.d0
              gk=gy(k)+gsk
              flux=0.d0
! BARRY
              if(gk.gt.gmin) then
! new changes 13.01.01 (begin)
                x1=dlog(gy(kp)/gk+1.d-15)
! BARRY
!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
! new changes 23.01.01 (begin)
!               flux=min(flux,gk)
!               flux=min(flux,gsk)
! new changes 23.01.01 (end)
! new changes 13.01.01 (end)
! BARRY
               if (x1.eq.0)then
                flux=0  
               else
                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
                flux=min(flux,gsk)
               end if
                gy(k)=gk-flux
                if(gy(k).lt.0.d0) gy(k)=0.d0
                gy(kp)=gy(kp)+flux
! in case gk > gmin :
              endif
           enddo
        enddo
 2020   continue
        return
        end subroutine coll_xxy
!====================================================================
        subroutine coll_xyy(gx,gy,ckxy,x,y,chucm,ima, &
     &     prdkrn,nkr,indc)
        implicit double precision (a-h,o-z)
        dimension  &
     &  gy(nkr),gx(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
        dimension chucm(nkr,nkr)
        double precision ima(nkr,nkr)
        gmin=1.d-60
! lower and upper integration limit ix0,ix1
        do i=1,nkr-1
           ix0=i
           if(gx(i).gt.gmin) go to 2000
        enddo
 2000   continue
        if(ix0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           ix1=i
           if(gx(i).gt.gmin) go to 2010
        enddo
 2010   continue
! lower and upper integration limit iy0,iy1
        do i=1,nkr-1
           iy0=i
           if(gy(i).gt.gmin) go to 2001
        enddo
 2001   continue
        if(iy0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           iy1=i
           if(gy(i).gt.gmin) go to 2011
        enddo
 2011   continue
! collisions :
        do i=iy0,iy1
           jmin=i
           if(jmin.eq.(nkr-1)) goto 2020
           if(i.lt.ix0) jmin=ix0-indc
	   do j=jmin+indc,ix1         
              k=ima(i,j)
              kp=k+1
              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
              x0=min(x0,gy(i)*x(j))
              x0=min(x0,gx(j)*y(i))
              gsi=x0/x(j)
              gsj=x0/y(i)
              gsk=gsi+gsj
              gy(i)=gy(i)-gsi
              if(gy(i).lt.0.d0) gy(i)=0.d0
              gx(j)=gx(j)-gsj
              if(gx(j).lt.0.d0) gx(j)=0.d0
              gk=gy(k)+gsk
              flux=0.d0
! BARRY
              if(gk.gt.gmin) then
                x1=dlog(gy(kp)/gk+1.d-15)
! BARRY
!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
! new changes 23.01.01 (begin)
!               flux=min(flux,gk)
!               flux=min(flux,gsk)
! BARRY
               if (x1.eq.0)then
                flux=0  
               else
                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
                flux=min(flux,gsk)
               end if
! new changes 23.01.01 (end)
                gy(k)=gk-flux
                if(gy(k).lt.0.d0) gy(k)=0.d0
                gy(kp)=gy(kp)+flux
! in case gk > gmin :
              endif
! in case gk > gmin or gk.le.gmin
           enddo
        enddo
 2020   continue
        return
        end subroutine coll_xyy
!=================================================================
        subroutine coll_xyx(gx,gy,ckxy,x,y,chucm,ima, &
     &    prdkrn,nkr,indc)
        implicit double precision (a-h,o-z)
        dimension gy(nkr),gx(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
        dimension chucm(nkr,nkr)
        double precision ima(nkr,nkr)
        gmin=1.d-60
! lower and upper integration limit ix0,ix1
        do i=1,nkr-1
           ix0=i
           if(gx(i).gt.gmin) go to 2000
        enddo
 2000   continue
        if(ix0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           ix1=i
           if(gx(i).gt.gmin) go to 2010
        enddo
 2010   continue
! lower and upper integration limit iy0,iy1
        do i=1,nkr-1
           iy0=i
           if(gy(i).gt.gmin) go to 2001
        enddo
 2001   continue
        if(iy0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           iy1=i
           if(gy(i).gt.gmin) go to 2011
        enddo
 2011   continue
! collisions :
        do i=iy0,iy1
           jmin=i
           if(jmin.eq.(nkr-1)) goto 2020
           if(i.lt.ix0) jmin=ix0-indc
	   do j=jmin+indc,ix1
              k=ima(i,j)
              kp=k+1
              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
              x0=min(x0,gy(i)*x(j))
              if(j.ne.k) then
                x0=min(x0,gx(j)*y(i))
              endif
              gsi=x0/x(j)
              gsj=x0/y(i)
              gsk=gsi+gsj
              gy(i)=gy(i)-gsi
              if(gy(i).lt.0.d0) gy(i)=0.d0
              gx(j)=gx(j)-gsj
              gk=gx(k)+gsk
! BARRY
!             if(gx(j).lt.0.d0)then
!                gy(i)=gy(i)+gsi
!                gx(j)=gx(j)+gsj
!                go to 10
!             end if
              if(gx(j).lt.0.d0.and.gk.lt.gmin) then
                gx(j)=0.d0
                gx(k)=gx(k)+gsi
              endif
              flux=0.d0            
! BARRY
              if(gk.gt.gmin) then
                x1=dlog(gx(kp)/gk+1.d-15)
! BARRY
!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
! new changes 23.01.01 (begin)
!               flux=min(flux,gk)
!               flux=min(flux,gsk)
! BARRY
               if (x1.eq.0)then
                flux=0  
               else
                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
                flux=min(flux,gsk)
               end if
! new changes 23.01.01 (end)
                gx(k)=gk-flux
                if(gx(k).lt.0.d0) gx(k)=0.d0
                gx(kp)=gx(kp)+flux
! in case gk > gmin :
              endif
! in case gk > gmin or gk.le.gmin
! BARRY
10         continue
           enddo
        enddo
 2020   continue
        return
        end subroutine coll_xyx
!=====================================================================
        subroutine coll_xyxz(gx,gy,gz,ckxy,x,y,chucm,ima, &
     &    prdkrn,nkr,indc)
        implicit double precision (a-h,o-z)
      dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
        dimension chucm(nkr,nkr)
        double precision ima(nkr,nkr)
        gmin=1.d-60
! lower and upper integration limit ix0,ix1
        do i=1,nkr-1
           ix0=i
           if(gx(i).gt.gmin) go to 2000
        enddo
 2000   continue
        if(ix0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           ix1=i
           if(gx(i).gt.gmin) go to 2010
        enddo
 2010   continue
! lower and upper integration limit iy0,iy1
        do i=1,nkr-1
           iy0=i
           if(gy(i).gt.gmin) go to 2001
        enddo
 2001   continue
        if(iy0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           iy1=i
           if(gy(i).gt.gmin) go to 2011
        enddo
 2011   continue
! collisions :
        do i=iy0,iy1
           jmin=i
           if(jmin.eq.(nkr-1)) goto 2020
           if(i.lt.ix0) jmin=ix0-indc
	   do j=jmin+indc,ix1
              k=ima(i,j)
              kp=k+1
              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
              x0=min(x0,gy(i)*x(j))
              if(j.ne.k) then
                x0=min(x0,gx(j)*y(i))
              endif
              gsi=x0/x(j)
              gsj=x0/y(i)
              gsk=gsi+gsj
              gy(i)=gy(i)-gsi
              if(gy(i).lt.0.d0) gy(i)=0.d0
              gx(j)=gx(j)-gsj
              gk=gx(k)+gsk
              if(gx(j).lt.0.d0.and.gk.lt.gmin) then
                gx(j)=0.d0
                gx(k)=gx(k)+gsi
              endif
              flux=0.d0
! BARRY
              if(kp.lt.17) gkp=gx(kp)
              if(kp.ge.17) gkp=gz(kp)
              if(gk.gt.gmin) then
                x1=dlog(gkp/gk+1.d-15)
! BARRY
!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
! new changes 23.01.01 (begin)
!               flux=min(flux,gk)
!               flux=min(flux,gsk)
! BARRY
               if (x1.eq.0)then
                flux=0  
               else
                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
                flux=min(flux,gsk)
               end if
! new changes 23.01.01 (end)
                gx(k)=gk-flux
                if(gx(k).lt.0.d0) gx(k)=0.d0
                if(kp.lt.17) gx(kp)=gkp+flux
                if(kp.ge.17) gz(kp)=gkp+flux
! ALEX 15 11 2005
!               if(kp.ge.17) gx(kp)=gkp+flux
! in case gk > gmin :
              endif
! in case gk > gmin or gk.le.gmin
           enddo
        enddo
 2020   continue
        return
        end subroutine coll_xyxz
!=====================================================================
        subroutine coll_xyxz_h(gx,gy,gz,ckxy,x,y,chucm,ima, &
     &    prdkrn,nkr,indc)
        implicit double precision (a-h,o-z)
      dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
        dimension chucm(nkr,nkr)
        double precision ima(nkr,nkr)
        gmin=1.d-60
! lower and upper integration limit ix0,ix1
        do i=1,nkr-1
           ix0=i
           if(gx(i).gt.gmin) go to 2000
        enddo
 2000   continue
        if(ix0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           ix1=i
           if(gx(i).gt.gmin) go to 2010
        enddo
 2010   continue
! lower and upper integration limit iy0,iy1
        do i=1,nkr-1
           iy0=i
           if(gy(i).gt.gmin) go to 2001
        enddo
 2001   continue
        if(iy0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           iy1=i
           if(gy(i).gt.gmin) go to 2011
        enddo
 2011   continue
! collisions :
        do i=iy0,iy1
           jmin=i
           if(jmin.eq.(nkr-1)) goto 2020
           if(i.lt.ix0) jmin=ix0-indc
	   do j=jmin+indc,ix1
              k=ima(i,j)
              kp=k+1
              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
              x0=min(x0,gy(i)*x(j))
              if(j.ne.k) then
                x0=min(x0,gx(j)*y(i))
              endif
              gsi=x0/x(j)
              gsj=x0/y(i)
              gsk=gsi+gsj
              gy(i)=gy(i)-gsi
              if(gy(i).lt.0.d0) gy(i)=0.d0
              gx(j)=gx(j)-gsj
              gk=gx(k)+gsk
              if(gx(j).lt.0.d0.and.gk.lt.gmin) then
                gx(j)=0.d0
                gx(k)=gx(k)+gsi
              endif
              flux=0.d0
! BARRY
              if(kp.lt.22) gkp=gx(kp)
              if(kp.ge.22) gkp=gz(kp)
              if(gk.gt.gmin) then
                x1=dlog(gkp/gk+1.d-15)
! BARRY
!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
! new changes 23.01.01 (begin)
!               flux=min(flux,gk)
!               flux=min(flux,gsk)
! BARRY
               if (x1.eq.0)then
                flux=0  
               else
                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
                flux=min(flux,gsk)
               end if
! new changes 23.01.01 (end)
                gx(k)=gk-flux
                if(gx(k).lt.0.d0) gx(k)=0.d0
                if(kp.lt.22) gx(kp)=gkp+flux
                if(kp.ge.22) gz(kp)=gkp+flux
! ALEX 15 11 2005
!               if(kp.ge.25) gx(kp)=gkp+flux
! in case gk > gmin :
              endif
! in case gk > gmin or gk.le.gmin
           enddo
        enddo
 2020   continue
        return
        end subroutine coll_xyxz_h
!=====================================================================
        subroutine coll_xyz(gx,gy,gz,ckxy,x,y,chucm,ima, &
     &                      prdkrn,nkr,indc)
        implicit double precision (a-h,o-z)
      dimension gx(nkr),gy(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
        dimension chucm(nkr,nkr)
        double precision ima(nkr,nkr)
        gmin=1.d-60
! lower and upper integration limit ix0,ix1
        do i=1,nkr-1
           ix0=i
           if(gx(i).gt.gmin) go to 2000
        enddo
 2000   continue
        if(ix0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           ix1=i
           if(gx(i).gt.gmin) go to 2010
        enddo
 2010   continue
! lower and upper integration limit iy0,iy1
        do i=1,nkr-1
           iy0=i
           if(gy(i).gt.gmin) go to 2001
        enddo
 2001   continue
        if(iy0.eq.nkr-1) goto 2020
        do i=nkr-1,1,-1
           iy1=i
           if(gy(i).gt.gmin) go to 2011
        enddo
 2011   continue
! collisions :
        do i=iy0,iy1
           jmin=i
           if(jmin.eq.(nkr-1)) goto 2020
           if(i.lt.ix0) jmin=ix0-indc
	   do j=jmin+indc,ix1         
              k=ima(i,j)
              kp=k+1
              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
              x0=min(x0,gy(i)*x(j))
              x0=min(x0,gx(j)*y(i))
              gsi=x0/x(j)
              gsj=x0/y(i)
              gsk=gsi+gsj
              gy(i)=gy(i)-gsi
              if(gy(i).lt.0.d0) gy(i)=0.d0
              gx(j)=gx(j)-gsj
              if(gx(j).lt.0.d0) gx(j)=0.d0
              gk=gz(k)+gsk
              flux=0.d0
! BARRY
              if(gk.gt.gmin) then
                x1=dlog(gz(kp)/gk+1.d-15)
! BARRY
               if (x1.eq.0)then
                flux=0  
               else
                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
                flux=min(flux,gsk)
               end if
! new changes 23.01.01 (end)
                gz(k)=gk-flux
                if(gz(k).lt.0.d0) gz(k)=0.d0
                gz(kp)=gz(kp)+flux
! in case gk > gmin :
              endif
           enddo
        enddo
 2020   continue
        return
        end subroutine coll_xyz
!===============================================================
!****************************************************************
! SEE /include/microhucm.incl for setting of krdrop and krbreak
!****************************************************************
      SUBROUTINE BREAKUP(GT_MG,XT_MG,DT,BRKWEIGHT, &
     &           PKIJ,QKJ,JMAX,JBREAK)
!     SUBROUTINE BREAKUP(GT_MG,DT,JMAX,JBREAK)
!     implicit double precision (a-h,o-z)

!.....INPUT VARIABLES
!
!     GT    : MASS DISTRIBUTION FUNCTION
!     XT_MG : MASS OF BIN IN MG
!     JMAX  : NUMBER OF BINS
!     DT    : TIMESTEP IN S

      INTEGER JMAX

!.....LOCAL VARIABLES

      LOGICAL LTHAN
      INTEGER JBREAK,AP,IA,JA,KA,IE,JE,KE
      DOUBLE PRECISION EPS,NEGSUM

      PARAMETER (AP = 1)
      PARAMETER (IA = 1)
      PARAMETER (JA = 1)
      PARAMETER (KA = 1)
      PARAMETER (EPS = 1.D-20)

      INTEGER I,J,K,JJ,JDIFF
      DOUBLE PRECISION GT_MG(JMAX),XT_MG(0:JMAX),DT
!     xl_mg(0:nkr)
      DOUBLE PRECISION BRKWEIGHT(JBREAK),PKIJ(JBREAK,JBREAK,JBREAK), &
     &    QKJ(JBREAK,JBREAK)
      DOUBLE PRECISION D0,ALM,HLP(JMAX)
      DOUBLE PRECISION FT(JMAX),FA(JMAX)
      DOUBLE PRECISION DG(JMAX),DF(JMAX),DBREAK(JBREAK),GAIN,LOSS
      REAL PI
      PARAMETER (PI = 3.1415927)
      INTEGER IP,KP,JP,KQ,JQ
      IE = JBREAK
      JE = JBREAK
      KE = JBREAK







!.....IN CGS

!     DO J=1,JMAX
!        XT(J) = XT_MG(J) * 1E-3
!        GT_MG(J) = GT_MG(J)* 1E-3
!     ENDDO

!.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID

      JDIFF = JMAX - JBREAK
!       14  =  33  - 19

!.....INITIALIZATION

!.....TRANSFORMATION FROM G(LN X) = X**2 F(X) TO F(X)
      DO J=1,JMAX
         FT(J) = GT_MG(J) / XT_MG(J)**2
      ENDDO

!.....SHIFT TO BREAKUP GRID

      DO K=1,KE
         FA(K) = FT(K+JDIFF)
      ENDDO

!.....BREAKUP: BLECK'S FIRST ORDER METHOD
!
!     PKIJ: GAIN COEFFICIENTS
!     QKJ : LOSS COEFFICIENTS
!

      DO K=1,KE
         GAIN = 0.0
         DO I=1,IE
            DO J=1,I
               GAIN = GAIN + FA(I)*FA(J)*PKIJ(K,I,J)
            ENDDO
         ENDDO
         LOSS = 0.0
         DO J=1,JE
            LOSS = LOSS + FA(J)*QKJ(K,J)
         ENDDO
         DBREAK(K) = BRKWEIGHT(K) * (GAIN - FA(K)*LOSS)
      ENDDO

!.....SHIFT RATE TO COAGULATION GRID

      DO J=1,JDIFF
         DF(J) = 0.0
      ENDDO
      DO J=1,KE
         DF(J+JDIFF) = DBREAK(J)
      ENDDO
!.....TRANSFORMATION TO MASS DISTRIBUTION FUNCTION G(LN X)

      DO J=1,JMAX
         DG(J) = DF(J) * XT_MG(J)**2
      ENDDO

!.....TIME INTEGRATION

      DO J=1,JMAX
      HLP(J) = 0.0
      NEGSUM = 0.0
         GT_MG(J) = GT_MG(J) + DG(J) * DT
         IF (GT_MG(J).LT.0) THEN
            HLP(J) = MIN(GT_MG(J),HLP(J))
            GT_MG(J) = EPS
!           NEGSUM = NEGSUM+GT_MG(J)
!           GT_MG(J) = 0.D0
         ENDIF
      ENDDO
!     DO J=1,JMAX
!      IF (HLP(J).LT.0.) THEN
!        GT_MG(J-1)=GT_MG(J-1)-NEGSUM -EPS
!      END IF
!      GO TO 10
!     END DO
!10    CONTINUE
!     IF (HLP.LT.-1E-7) THEN
! BARRY
!     LTHAN=.FALSE.
!     DO J=1,JMAX
!      IF (HLP(J).LT.0.OR.LTHAN) THEN
!        WRITE (*,'(1X,A,E10.4)')
!    F        'COLL_BREAKUP: WARNING! G(J) < 0, MIN = ' 
!        IF(HLP(J).LT.0.OR.LTHAN)WRITE(6,*)
!    F      'J,G(J)  = ',J,HLP(J),GT_MG(J)
!        LTHAN=.TRUE.  C     ENDIF
!     END DO

!     DO J=1,JMAX
!        GT_MG(J) = GT_MG(J) * 1E3
!     ENDDO

!.....THAT'S IT
      RETURN

      END SUBROUTINE BREAKUP

      SUBROUTINE BOUNDNUM(MASSMM5,FCONC,RHOX,COL,NZERO, &
     &       RADXX,MASSXX,HYDROSUM, &
     &       NKR)
      IMPLICIT NONE
     
      INTEGER NKR,NKRI,KRBEG,KREND,IP,IPCNT
      REAL NZERO,LAMBDAHYD,MASSMM5,RHOX,HYDROMASS,COL
      REAL RADXX(NKR),MASSXX(NKR)
      REAL TERM1,TERM2A,TERM2B,TERM2C
      REAL FCONC(NKR),HYDROSUM 
      DOUBLE PRECISION D1,D2,D3,D4,D5,D6,D7A,D7B 
      DOUBLE PRECISION VAR1,VAR2,VAR3,VAR4,VAR5,VAR6
!     HYDROMASS IN kg/kg
!     VAR1=NZERO           
!     VAR2=RHOX            
!     VAR3=MASSXX(1,IHYDR)
!     VAR4=RADXX(1,IHYDR)
!     VAR5=MASSMM5       
!     VAR6=(6.*VAR1/VAR2)*VAR3/(8.*VAR4**3)*(1./VAR5)
!     var6 =sqrt(sqrt(var6))
!     print*,'radxx(1) = ',RADXX(1)
!     print*,'rhox = ',rhox
!     print*,'massmm5 = ',massmm5
!     print*,'nzero = ',nzerO
!     print*,'massxx = ',MASSXX(1)
      LAMBDAHYD=(6.*NZERO/RHOX)*MASSXX(1)/(8.*RADXX(1)**3) &
     &     *(1./MASSMM5)
      LAMBDAHYD=SQRT(SQRT(LAMBDAHYD))
      HYDROSUM  =0
      TERM1=(NZERO/RHOX)*(MASSXX(1)/(8.*RADXX(1)**3))
      DO NKRI=1,NKR
       IF(NKRI.EQ.1)THEN
        D1=LAMBDAHYD*2.*RADXX(NKRI)
        D2=0
       ELSE
        D1=LAMBDAHYD*2.*RADXX(NKRI)
        D2=LAMBDAHYD*2.*RADXX(NKRI-1)
       END IF
       D3=DEXP(-D1)
       D4=DEXP(-D2)
       D5 = (1./LAMBDAHYD**4)
       D6=TERM1
       IF (NKRI.EQ.1)THEN
        D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
        D7B=-6.*D5
       ELSE
        D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
        D7B= -D5*D4*(D2**3+3.*D2**2+6.*D2+6)
       END IF
       HYDROMASS= D6*(D7A-D7B)
       HYDROSUM=HYDROSUM+HYDROMASS   
       FCONC(NKRI)=HYDROMASS*RHOX/(COL  &
     &          *MASSXX(NKRI)*MASSXX(NKRI)*3)
        IF (HYDROMASS .LT.0)THEN
        call wrf_error_fatal("fatal error in module_mp_fast_sbm,(HYDROMASS.LT.0) , model stop")
        END IF
      END DO
!     print*, 'massmm5,hydrosum  =',massmm5,hydrosum  
      IF (HYDROSUM.LT.MASSMM5)THEN
       D1=LAMBDAHYD*2.*RADXX(NKR)
       D2=LAMBDAHYD*2.*RADXX(NKR-1)
       D3=DEXP(-D1)
       D4=DEXP(-D2)
       D5 = (1./LAMBDAHYD**4)
       D6=TERM1
       D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
       D7B= -D5*D4*(D2**3+3.*D2**2+6.*D2+6)
       HYDROMASS= D6*(D7A-D7B)+(MASSMM5-HYDROSUM)
       FCONC(NKR)=HYDROMASS*RHOX/(COL &
     &          *MASSXX(NKR)*MASSXX(NKR)*3)
       HYDROSUM=HYDROSUM+(MASSMM5-HYDROSUM)
      END IF
!     print*, 'massmm5,hydrosum adj  =',massmm5,hydrosum  
      RETURN
      END SUBROUTINE BOUNDNUM

! from module_mp_morr_two_moment.F
      subroutine refl10cm_hm (qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, &
                      t1d, p1d, dBZ, kts, kte, ii, jj)

      IMPLICIT NONE

!..Sub arguments
      INTEGER, INTENT(IN):: kts, kte, ii, jj
      REAL, DIMENSION(kts:kte), INTENT(IN)::                            &
                      qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
      REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ

!..Local variables
      REAL, DIMENSION(kts:kte):: temp, pres, qv, rho
      REAL, DIMENSION(kts:kte):: rr, nr, rs, ns, rg, ng

      DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, ilams
      DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_g, N0_s
      DOUBLE PRECISION:: lamr, lamg, lams
      LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg

      REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel
      DOUBLE PRECISION:: fmelt_s, fmelt_g
      DOUBLE PRECISION:: cback, x, eta, f_d

      INTEGER:: i, k, k_0, kbot, n
      LOGICAL:: melti

!+---+

      do k = kts, kte
         dBZ(k) = -35.0
      enddo

!+---+-----------------------------------------------------------------+
!..Put column of data into local arrays.
!+---+-----------------------------------------------------------------+
      do k = kts, kte
         temp(k) = t1d(k)
         qv(k) = MAX(1.E-10, qv1d(k))
         pres(k) = p1d(k)
         rho(k) = 0.622*pres(k)/(R_MORR*temp(k)*(qv(k)+0.622))

         if (qr1d(k) .gt. 1.E-9) then
            rr(k) = qr1d(k)*rho(k)
            nr(k) = nr1d(k)*rho(k)
            lamr = (xam_r*xcrg(3)*xorg2*nr(k)/rr(k))**xobmr
            ilamr(k) = 1./lamr
            N0_r(k) = nr(k)*xorg2*lamr**xcre(2)
            L_qr(k) = .true.
         else
            rr(k) = 1.E-12
            nr(k) = 1.E-12
            L_qr(k) = .false.
         endif

         if (qs1d(k) .gt. 1.E-9) then
            rs(k) = qs1d(k)*rho(k)
            ns(k) = ns1d(k)*rho(k)
            lams = (xam_s*xcsg(3)*xosg2*ns(k)/rs(k))**xobms
            ilams(k) = 1./lams
            N0_s(k) = ns(k)*xosg2*lams**xcse(2)
            L_qs(k) = .true.
         else
            rs(k) = 1.E-12
            ns(k) = 1.E-12
            L_qs(k) = .false.
         endif

         if (qg1d(k) .gt. 1.E-9) then
            rg(k) = qg1d(k)*rho(k)
            ng(k) = ng1d(k)*rho(k)
            lamg = (xam_g*xcgg(3)*xogg2*ng(k)/rg(k))**xobmg
            ilamg(k) = 1./lamg
            N0_g(k) = ng(k)*xogg2*lamg**xcge(2)
            L_qg(k) = .true.
         else
            rg(k) = 1.E-12
            ng(k) = 1.E-12
            L_qg(k) = .false.
         endif
      enddo

!+---+-----------------------------------------------------------------+
!..Locate K-level of start of melting (k_0 is level above).
!+---+-----------------------------------------------------------------+
      melti = .false.
      k_0 = kts
      do k = kte-1, kts, -1
         if ( (temp(k).gt.273.15) .and. L_qr(k)                         &
                                  .and. (L_qs(k+1).or.L_qg(k+1)) ) then
            k_0 = MAX(k+1, k_0)
            melti=.true.
            goto 195
         endif
      enddo
 195  continue

!+---+-----------------------------------------------------------------+
!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps)
!.. and non-water-coated snow and graupel when below freezing are
!.. simple. Integrations of m(D)*m(D)*N(D)*dD.
!+---+-----------------------------------------------------------------+

      do k = kts, kte
         ze_rain(k) = 1.e-22
         ze_snow(k) = 1.e-22
         ze_graupel(k) = 1.e-22
         if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4)
         if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI_MORR)*(6.0/PI_MORR)     &
                                 * (xam_s/900.0)*(xam_s/900.0)          &
                                 * N0_s(k)*xcsg(4)*ilams(k)**xcse(4)
         if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI_MORR)*(6.0/PI_MORR)  &
                                    * (xam_g/900.0)*(xam_g/900.0)       &
                                    * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4)
      enddo

!+---+-----------------------------------------------------------------+
!..Special case of melting ice (snow/graupel) particles.  Assume the
!.. ice is surrounded by the liquid water.  Fraction of meltwater is
!.. extremely simple based on amount found above the melting level.
!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting
!.. routines).
!+---+-----------------------------------------------------------------+

      if (melti .and. k_0.ge.kts+1) then
       do k = k_0-1, kts, -1

!..Reflectivity contributed by melting snow
          if (L_qs(k) .and. L_qs(k_0) ) then
           fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0))
           eta = 0.d0
           lams = 1./ilams(k)
           do n = 1, nrbins
              x = xam_s * xxDs(n)**xbm_s
              call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), &
                    fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, &
                    CBACK, mixingrulestring_s, matrixstring_s,          &
                    inclusionstring_s, hoststring_s,                    &
                    hostmatrixstring_s, hostinclusionstring_s)
              f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n))
              eta = eta + f_d * CBACK * simpson(n) * xdts(n)
           enddo
           ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
          endif


!..Reflectivity contributed by melting graupel

          if (L_qg(k) .and. L_qg(k_0) ) then
           fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0))
           eta = 0.d0
           lamg = 1./ilamg(k)
           do n = 1, nrbins
              x = xam_g * xxDg(n)**xbm_g
              call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), &
                    fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, &
                    CBACK, mixingrulestring_g, matrixstring_g,          &
                    inclusionstring_g, hoststring_g,                    &
                    hostmatrixstring_g, hostinclusionstring_g)
              f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n))
              eta = eta + f_d * CBACK * simpson(n) * xdtg(n)
           enddo
           ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
          endif

       enddo
      endif

      do k = kte, kts, -1
         dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18)
      enddo


      end subroutine refl10cm_hm
      END MODULE module_mp_fast_sbm
