wrftladj/module_mp_wsm6r_ad.F

   1 !        Generated by TAPENADE     (INRIA, Ecuador team)
   2 !  Tapenade 3.16 (master) -  9 Oct 2020 17:47
   3 !
   4 MODULE A_MODULE_MP_WSM6R
   5   IMPLICIT NONE
   6 !
   7 ! parameters
   8   REAL, PARAMETER :: dtcldcr=120.
   9   REAL, PARAMETER :: n0r=8.e6
  10   REAL, PARAMETER :: n0g=4.e6
  11   REAL, PARAMETER :: avtr=841.9
  12   REAL, PARAMETER :: bvtr=0.8
  13 ! 8 microm  in contrast to 10 micro m
  14   REAL, PARAMETER :: r0=.8e-5
  15 ! collection efficiency
  16   REAL, PARAMETER :: peaut=.55
  17 ! maritime cloud in contrast to 3.e8 in tc80
  18   REAL, PARAMETER :: xncr=3.e8
  19 ! the dynamic viscosity kgm-1s-1
  20   REAL, PARAMETER :: xmyu=1.718e-5
  21   REAL, PARAMETER :: avts=11.72
  22   REAL, PARAMETER :: bvts=.41
  23   REAL, PARAMETER :: avtg=330.
  24   REAL, PARAMETER :: bvtg=0.8
  25   REAL, PARAMETER :: deng=500.
  26 ! t                                                       = -90C unlimited
  27   REAL, PARAMETER :: n0smax=1.e11
  28 !   REAL, PARAMETER :: betai     = .6
  29 !   REAL, PARAMETER :: xn0       = 1.e-2
  30 !   REAL, PARAMETER :: dicon     = 11.9
  31 !   REAL, PARAMETER :: di0       = 12.9e-6
  32   REAL, PARAMETER :: dimax=500.e-6
  33 ! temperature dependent n0s
  34   REAL, PARAMETER :: n0s=2.e6
  35 ! .122 exponen factor for n0s
  36   REAL, PARAMETER :: alpha=.12
  37   REAL, PARAMETER :: pfrz1=100.
  38   REAL, PARAMETER :: pfrz2=0.66
  39   REAL, PARAMETER :: t40c=233.16
  40 ! Esc
  41   REAL, PARAMETER :: eacrc=1.0
  42 ! Erc
  43   REAL, PARAMETER :: eacrr=1.0
  44   REAL, PARAMETER :: dens=100.0
  45 ! pgaut
  46   REAL, PARAMETER :: qs0=6.e-4
  47 !                                                         = 9.81
  48   REAL, PARAMETER :: g=9.81
  49 ! gas constant for dry air (J/kg/K)                       = 287
  50   REAL, PARAMETER :: rd=287.
  51 ! gas constant for water vapor (J/kg/K)
  52   REAL, PARAMETER :: rv=461.6
  53 !                                                         = 273.15
  54   REAL, PARAMETER :: t0c=273.15
  55 ! density of 0 degree air      (kg/m^3)
  56   REAL, PARAMETER :: den0=1.28
  57 ! heat capacity at constant pressure for dry air (J/kg/K) = 7.*rd/2.
  58   REAL, PARAMETER :: cpd=1004.5
  59 ! heat capacity at constant pressure for vapor  (J/kg/K)  = 4.*r_v
  60   REAL, PARAMETER :: cpv=1846.4
  61 !   REAL, PARAMETER :: ep1       = 0.6083624 !                                                         = rv/rd-1.
  62 !                                                         = rd/rv
  63   REAL, PARAMETER :: ep2=0.6217504
  64   REAL, PARAMETER :: qcrmin=1.e-9
  65 ! epsilon                                                 = 1.E-15
  66   REAL, PARAMETER :: qmin=1.e-15
  67 ! latent heat of sublimation   (J/kg)                     = 2.85E6
  68   REAL, PARAMETER :: xls=2.85e6
  69 ! latent heat of vaporization  (J/kg)                     = 3.15E6
  70   REAL, PARAMETER :: xlv0=2.5e6
  71 ! latent heat of melting       (J/kg)                     = 3.50E5
  72   REAL, PARAMETER :: xlf0=3.50e5
  73 !                                                         = 4190.
  74   REAL, PARAMETER :: cliq=4190.
  75 !                                                         = 2106
  76   REAL, PARAMETER :: cice=2106.
  77 !                                                         = 610.78
  78   REAL, PARAMETER :: psat=610.78
  79 ! water density                                           = 1000 (kg/m^3)
  80   REAL, PARAMETER :: denr=1000.
  81   REAL, SAVE :: pi, qc0, qck1, bvtr1, bvtr2, bvtr3, bvtr4, bvtr6, g1pbr&
  82 & , g3pbr, g4pbr, g5pbro2, g6pbr, pvtr, bvts1, bvts2, bvts3, bvts4, &
  83 & g1pbs, g3pbs, g4pbs, g5pbso2, pvts, bvtg1, bvtg2, bvtg3, bvtg4, g1pbg&
  84 & , g3pbg, g4pbg, g5pbgo2, pvtg, roqimax, pidn0r, pidn0s, pidn0g, xlv1, &
  85 & vt2i, vt2r, vt2s, vt2g, egs, egi, vt2r_a, vt2s_a, vt2g_a, vt2i_a, &
  86 & fallr_a, falls_a, fallg_a, falli_a, pgfrz_a, diffac_a, diffac_b, &
  87 & pidep_a, pgacs_a, pgacs_b, pgacs_c, pgacs_d, pgacr_a, pgacr_b, pgacr_c&
  88 & , pgacr_d, psacr_a, psacr_b, psacr_c, psacr_d, pracs_a, pracs_b, &
  89 & pracs_c, pracs_d, pgaci_a, pgaci_b, pgaci_c, pgaci_d, psevp_a, psevp_b&
  90 & , pgevp_a
  91   REAL, SAVE :: pgevp_b, psmlt_a, psmlt_b, pgmlt_a, pgmlt_b, prevp_a, &
  92 & prevp_b, psdep_a, psdep_b, pgdep_a, pgdep_b, praci_a, praci_b, praci_c&
  93 & , praci_d, psaci_a, psaci_b, psaci_c, psaci_d, pracw_a, piacr_a, &
  94 & psacw_a, pgacw_a
  95   REAL, SAVE :: a_vt2i, a_vt2r, a_vt2s, a_vt2g
  96
  97 CONTAINS
  98 !  Differentiation of wsm6r in reverse (adjoint) mode (with options r8):
  99 !   gradient     of useful results: th qc qg qi q qr qs rain rainncv
 100 !   with respect to varying inputs: th qc qg qi p q qr qs delz
 101 !                den rain rainncv pii
 102 !   RW status of diff variables: vt2g:(loc) vt2i:(loc) vt2r:(loc)
 103 !                vt2s:(loc) th:in-out qc:in-out qg:in-out qi:in-out
 104 !                p:out q:in-out qr:in-out qs:in-out delz:out den:out
 105 !                rain:in-out rainncv:in-out pii:out
 106 !=======================================================================
 107 !
 108 !=======================================================================
 109   SUBROUTINE A_WSM6R(th, a_th, q, a_q, qc, a_qc, qr, a_qr, qi, a_qi, qs&
 110 &   , a_qs, qg, a_qg, den, a_den, pii, a_pii, p, a_p, delz, a_delz, delt&
 111 &   , rain, a_rain, rainncv, a_rainncv, ids, ide, jds, jde, kds, kde, &
 112 &   ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
 113     IMPLICIT NONE
 114 !-------------------------------------------------------------------
 115     INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 116 &   jme, kms, kme, its, ite, jts, jte, kts, kte
 117     REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: th, q, &
 118 &   qc, qi, qr, qs, qg
 119     REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: a_th, &
 120 &   a_q, a_qc, a_qi, a_qr, a_qs, a_qg
 121     REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: den, pii, &
 122 &   p, delz
 123     REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: a_den, a_pii, a_p, &
 124 &   a_delz
 125     REAL, INTENT(IN) :: delt
 126     REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rain, rainncv
 127     REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: a_rain, &
 128 &   a_rainncv
 129 ! LOCAL VAR
 130     REAL, DIMENSION(its:ite, kts:kte) :: t
 131     REAL, DIMENSION(its:ite, kts:kte) :: a_t
 132     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
 133     REAL, DIMENSION(its:ite, kts:kte, 2) :: a_qci
 134     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
 135     REAL, DIMENSION(its:ite, kts:kte, 3) :: a_qrs
 136     REAL, DIMENSION(ims:ime, kms:kme) :: q2d, den2d, p2d, delz2d
 137     REAL, DIMENSION(ims:ime, kms:kme) :: a_q2d, a_den2d, a_p2d, a_delz2d
 138     REAL, DIMENSION(ims:ime) :: r1d, rcv1d
 139     REAL, DIMENSION(ims:ime) :: a_r1d, a_rcv1d
 140     REAL :: delt1
 141     INTEGER :: i, j, k, ierr
 142     REAL :: a_temp
 143     delt1 = delt
 144     DO j=jts,jte
 145       DO i=its,ite
 146         r1d(i) = rain(i, j)
 147         DO k=kts,kte
 148           CALL PUSHREAL8(t(i, k))
 149           t(i, k) = th(i, k, j)*pii(i, k, j)
 150           qci(i, k, 1) = qc(i, k, j)
 151           qci(i, k, 2) = qi(i, k, j)
 152           qrs(i, k, 1) = qr(i, k, j)
 153           qrs(i, k, 2) = qs(i, k, j)
 154           qrs(i, k, 3) = qg(i, k, j)
 155           q2d(i, k) = q(i, k, j)
 156           CALL PUSHREAL8(den2d(i, k))
 157           den2d(i, k) = den(i, k, j)
 158           CALL PUSHREAL8(p2d(i, k))
 159           p2d(i, k) = p(i, k, j)
 160           CALL PUSHREAL8(delz2d(i, k))
 161           delz2d(i, k) = delz(i, k, j)
 162         END DO
 163       END DO
 164 !  Sending array starting locations of optional variables may cause
 165 !  troubles, so we explicitly change the call.
 166       CALL PUSHREAL8ARRAY(r1d, ime - ims + 1)
 167       CALL PUSHREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 168       CALL PUSHREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 169       CALL PUSHREAL8ARRAY(q2d, (ime-ims+1)*(kme-kms+1))
 170       CALL PUSHREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 171       CALL WSM62D(t, q2d, qci, qrs, den2d, p2d, delz2d, delt1, r1d, &
 172 &           rcv1d, ims, ime, kms, kme, its, ite, kts, kte)
 173     END DO
 174     a_p = 0.0_8
 175     a_delz = 0.0_8
 176     a_den = 0.0_8
 177     a_pii = 0.0_8
 178     a_t = 0.0_8
 179     a_rcv1d = 0.0_8
 180     a_qrs = 0.0_8
 181     a_q2d = 0.0_8
 182     a_delz2d = 0.0_8
 183     a_den2d = 0.0_8
 184     a_qci = 0.0_8
 185     a_r1d = 0.0_8
 186     a_p2d = 0.0_8
 187     DO j=jte,jts,-1
 188       DO i=ite,its,-1
 189         DO k=kte,kts,-1
 190           a_q2d(i, k) = a_q2d(i, k) + a_q(i, k, j)
 191           a_q(i, k, j) = 0.0_8
 192           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_qg(i, k, j)
 193           a_qg(i, k, j) = 0.0_8
 194           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_qs(i, k, j)
 195           a_qs(i, k, j) = 0.0_8
 196           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_qr(i, k, j)
 197           a_qr(i, k, j) = 0.0_8
 198           a_qci(i, k, 2) = a_qci(i, k, 2) + a_qi(i, k, j)
 199           a_qi(i, k, j) = 0.0_8
 200           a_qci(i, k, 1) = a_qci(i, k, 1) + a_qc(i, k, j)
 201           a_qc(i, k, j) = 0.0_8
 202           a_temp = a_th(i, k, j)/pii(i, k, j)
 203           a_th(i, k, j) = 0.0_8
 204           a_t(i, k) = a_t(i, k) + a_temp
 205           a_pii(i, k, j) = a_pii(i, k, j) - t(i, k)*a_temp/pii(i, k, j)
 206         END DO
 207         a_rcv1d(i) = a_rcv1d(i) + a_rainncv(i, j)
 208         a_rainncv(i, j) = 0.0_8
 209         a_r1d(i) = a_r1d(i) + a_rain(i, j)
 210         a_rain(i, j) = 0.0_8
 211       END DO
 212       CALL POPREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 213       CALL POPREAL8ARRAY(q2d, (ime-ims+1)*(kme-kms+1))
 214       CALL POPREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 215       CALL POPREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 216       CALL POPREAL8ARRAY(r1d, ime - ims + 1)
 217       CALL A_WSM62D(t, a_t, q2d, a_q2d, qci, a_qci, qrs, a_qrs, den2d, &
 218 &             a_den2d, p2d, a_p2d, delz2d, a_delz2d, delt1, r1d, a_r1d, &
 219 &             rcv1d, a_rcv1d, ims, ime, kms, kme, its, ite, kts, kte)
 220       DO i=ite,its,-1
 221         DO k=kte,kts,-1
 222           CALL POPREAL8(delz2d(i, k))
 223           a_delz(i, k, j) = a_delz(i, k, j) + a_delz2d(i, k)
 224           a_delz2d(i, k) = 0.0_8
 225           CALL POPREAL8(p2d(i, k))
 226           a_p(i, k, j) = a_p(i, k, j) + a_p2d(i, k)
 227           a_p2d(i, k) = 0.0_8
 228           CALL POPREAL8(den2d(i, k))
 229           a_den(i, k, j) = a_den(i, k, j) + a_den2d(i, k)
 230           a_den2d(i, k) = 0.0_8
 231           a_q(i, k, j) = a_q(i, k, j) + a_q2d(i, k)
 232           a_q2d(i, k) = 0.0_8
 233           a_qg(i, k, j) = a_qg(i, k, j) + a_qrs(i, k, 3)
 234           a_qrs(i, k, 3) = 0.0_8
 235           a_qs(i, k, j) = a_qs(i, k, j) + a_qrs(i, k, 2)
 236           a_qrs(i, k, 2) = 0.0_8
 237           a_qr(i, k, j) = a_qr(i, k, j) + a_qrs(i, k, 1)
 238           a_qrs(i, k, 1) = 0.0_8
 239           a_qi(i, k, j) = a_qi(i, k, j) + a_qci(i, k, 2)
 240           a_qci(i, k, 2) = 0.0_8
 241           a_qc(i, k, j) = a_qc(i, k, j) + a_qci(i, k, 1)
 242           a_qci(i, k, 1) = 0.0_8
 243           CALL POPREAL8(t(i, k))
 244           a_th(i, k, j) = a_th(i, k, j) + pii(i, k, j)*a_t(i, k)
 245           a_pii(i, k, j) = a_pii(i, k, j) + th(i, k, j)*a_t(i, k)
 246           a_t(i, k) = 0.0_8
 247         END DO
 248         a_rainncv(i, j) = a_rainncv(i, j) + a_rcv1d(i)
 249         a_rcv1d(i) = 0.0_8
 250         a_rain(i, j) = a_rain(i, j) + a_r1d(i)
 251         a_r1d(i) = 0.0_8
 252       END DO
 253     END DO
 254   END SUBROUTINE A_WSM6R
 255
 256 !=======================================================================
 257 !
 258 !=======================================================================
 259   SUBROUTINE WSM6R(th, q, qc, qr, qi, qs, qg, den, pii, p, delz, delt, &
 260 &   rain, rainncv, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms&
 261 &   , kme, its, ite, jts, jte, kts, kte)
 262     IMPLICIT NONE
 263 !-------------------------------------------------------------------
 264     INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 265 &   jme, kms, kme, its, ite, jts, jte, kts, kte
 266     REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: th, q, &
 267 &   qc, qi, qr, qs, qg
 268     REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: den, pii, &
 269 &   p, delz
 270     REAL, INTENT(IN) :: delt
 271     REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rain, rainncv
 272 !  LOCAL VAR
 273     REAL, DIMENSION(its:ite, kts:kte) :: t
 274     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
 275     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
 276     REAL, DIMENSION(ims:ime, kms:kme) :: q2d, den2d, p2d, delz2d
 277     REAL, DIMENSION(ims:ime) :: r1d, rcv1d
 278     REAL :: delt1
 279     INTEGER :: i, j, k, ierr
 280     delt1 = delt
 281     DO j=jts,jte
 282       DO i=its,ite
 283         r1d(i) = rain(i, j)
 284         rcv1d(i) = rainncv(i, j)
 285         DO k=kts,kte
 286           t(i, k) = th(i, k, j)*pii(i, k, j)
 287           qci(i, k, 1) = qc(i, k, j)
 288           qci(i, k, 2) = qi(i, k, j)
 289           qrs(i, k, 1) = qr(i, k, j)
 290           qrs(i, k, 2) = qs(i, k, j)
 291           qrs(i, k, 3) = qg(i, k, j)
 292           q2d(i, k) = q(i, k, j)
 293           den2d(i, k) = den(i, k, j)
 294           p2d(i, k) = p(i, k, j)
 295           delz2d(i, k) = delz(i, k, j)
 296         END DO
 297       END DO
 298 !  Sending array starting locations of optional variables may cause
 299 !  troubles, so we explicitly change the call.
 300       CALL WSM62D(t, q2d, qci, qrs, den2d, p2d, delz2d, delt1, r1d, &
 301 &           rcv1d, ims, ime, kms, kme, its, ite, kts, kte)
 302       DO i=its,ite
 303         rain(i, j) = r1d(i)
 304         rainncv(i, j) = rcv1d(i)
 305         DO k=kts,kte
 306           th(i, k, j) = t(i, k)/pii(i, k, j)
 307           qc(i, k, j) = qci(i, k, 1)
 308           qi(i, k, j) = qci(i, k, 2)
 309           qr(i, k, j) = qrs(i, k, 1)
 310           qs(i, k, j) = qrs(i, k, 2)
 311           qg(i, k, j) = qrs(i, k, 3)
 312           q(i, k, j) = q2d(i, k)
 313         END DO
 314       END DO
 315     END DO
 316   END SUBROUTINE WSM6R
 317
 318 !  Differentiation of wsm62d in reverse (adjoint) mode (with options r8):
 319 !   gradient     of useful results: p q t delz den qrs rain qci
 320 !                rainncv
 321 !   with respect to varying inputs: p q t delz den qrs rain qci
 322 !                rainncv
 323 !=======================================================================
 324 !
 325 !=======================================================================
 326   SUBROUTINE A_WSM62D(t, a_t, q, a_q, qci, a_qci, qrs, a_qrs, den, a_den&
 327 &   , p, a_p, delz, a_delz, delt, rain, a_rain, rainncv, a_rainncv, ims&
 328 &   , ime, kms, kme, its, ite, kts, kte)
 329     IMPLICIT NONE
 330 ! big loops
 331 !
 332 !-------------------------------------------------------------------
 333     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
 334     REAL, DIMENSION(its:ite, kts:kte), INTENT(INOUT) :: t
 335     REAL, DIMENSION(its:ite, kts:kte), INTENT(INOUT) :: a_t
 336     REAL, DIMENSION(its:ite, kts:kte, 2), INTENT(INOUT) :: qci
 337     REAL, DIMENSION(its:ite, kts:kte, 2), INTENT(INOUT) :: a_qci
 338     REAL, DIMENSION(its:ite, kts:kte, 3), INTENT(INOUT) :: qrs
 339     REAL, DIMENSION(its:ite, kts:kte, 3), INTENT(INOUT) :: a_qrs
 340     REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT) :: q
 341     REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT) :: a_q
 342     REAL, DIMENSION(ims:ime, kms:kme), INTENT(IN) :: den, p, delz
 343     REAL, DIMENSION(ims:ime, kms:kme) :: a_den, a_p, a_delz
 344     REAL, INTENT(IN) :: delt
 345     REAL, DIMENSION(ims:ime), INTENT(INOUT) :: rain, rainncv
 346     REAL, DIMENSION(ims:ime), INTENT(INOUT) :: a_rain, a_rainncv
 347 !  LOCAL VAR
 348     REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, rslope, rslope2, &
 349 &   rslope3, rslopeb, falk, fall, work1
 350     REAL, DIMENSION(its:ite, kts:kte, 3) :: a_rh, a_qs, a_falk, a_fall
 351     REAL, DIMENSION(its:ite, kts:kte) :: pracw, psacw, pgacw, pgacr, &
 352 &   pgacs, psaci, praci, piacr, pracs, psacr, pgaci, pseml, pgeml, fallc&
 353 &   , praut, psaut, pgaut, prevp, psdep, pgdep
 354     REAL, DIMENSION(its:ite, kts:kte) :: a_pracw, a_psacw, a_pgacw, &
 355 &   a_pgacr, a_pgacs, a_psaci, a_praci, a_piacr, a_pracs, a_psacr, &
 356 &   a_pgaci, a_pseml, a_pgeml, a_fallc, a_praut, a_psaut, a_pgaut, &
 357 &   a_prevp, a_psdep, a_pgdep
 358     REAL, DIMENSION(its:ite, kts:kte) :: pigen, pidep, pcond, xl, cpm, &
 359 &   psevp, xni, pgevp, n0sfac, work2
 360     REAL, DIMENSION(its:ite, kts:kte) :: a_pigen, a_pidep, a_xl, a_cpm, &
 361 &   a_psevp, a_pgevp
 362 !   LOGICAL, DIMENSION( its:ite ) :: flgcld
 363     REAL :: dtcld, temp, temp0, supcol, supsat, satdt, eacrs, xmi, &
 364 &   diameter, delta2, delta3
 365     INTEGER :: i, k, loop, loops
 366     REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, &
 367 &   qs10, qs11, qs20, qs21
 368     REAL :: fq, fqc, fqi, fqr, fqs, fqg, fallsum
 369     INTRINSIC MAX
 370     INTRINSIC NINT
 371     INTEGER :: x1
 372     INTEGER :: branch
 373 !=================================================================
 374 !
 375     CALL WSM6RINIT()
 376 !----------------------------------------------------------------
 377 !  paddint 0 for negative values generated by dynamics
 378 !
 379     DO k=kts,kte
 380       DO i=its,ite
 381         IF (q(i, k) .LT. 0.) THEN
 382           q(i, k) = 0.
 383           CALL PUSHCONTROL1B(0)
 384         ELSE
 385           CALL PUSHCONTROL1B(1)
 386           q(i, k) = q(i, k)
 387         END IF
 388         IF (qci(i, k, 1) .LT. 0.) THEN
 389           qci(i, k, 1) = 0.
 390           CALL PUSHCONTROL1B(0)
 391         ELSE
 392           CALL PUSHCONTROL1B(1)
 393           qci(i, k, 1) = qci(i, k, 1)
 394         END IF
 395         IF (qrs(i, k, 1) .LT. 0.) THEN
 396           qrs(i, k, 1) = 0.
 397           CALL PUSHCONTROL1B(0)
 398         ELSE
 399           CALL PUSHCONTROL1B(1)
 400           qrs(i, k, 1) = qrs(i, k, 1)
 401         END IF
 402         IF (qci(i, k, 2) .LT. 0.) THEN
 403           qci(i, k, 2) = 0.
 404           CALL PUSHCONTROL1B(0)
 405         ELSE
 406           CALL PUSHCONTROL1B(1)
 407           qci(i, k, 2) = qci(i, k, 2)
 408         END IF
 409         IF (qrs(i, k, 2) .LT. 0.) THEN
 410           qrs(i, k, 2) = 0.
 411           CALL PUSHCONTROL1B(0)
 412         ELSE
 413           CALL PUSHCONTROL1B(1)
 414           qrs(i, k, 2) = qrs(i, k, 2)
 415         END IF
 416         IF (qrs(i, k, 3) .LT. 0.) THEN
 417           qrs(i, k, 3) = 0.
 418           CALL PUSHCONTROL1B(0)
 419         ELSE
 420           CALL PUSHCONTROL1B(1)
 421           qrs(i, k, 3) = qrs(i, k, 3)
 422         END IF
 423       END DO
 424     END DO
 425     x1 = NINT(delt/dtcldcr)
 426     IF (x1 .LT. 1) THEN
 427       loops = 1
 428     ELSE
 429       loops = x1
 430     END IF
 431     dtcld = delt/loops
 432     IF (delt .LE. dtcldcr) dtcld = delt
 433 !
 434     DO loop=1,loops
 435 !
 436 !----------------------------------------------------------------
 437 !     initialize the variables for microphysical physics
 438       CALL PUSHREAL8ARRAY(fallc, (ite-its+1)*(kte-kts+1))
 439       CALL PUSHREAL8ARRAY(fall, (ite-its+1)*(kte-kts+1)*3)
 440       CALL INIMP(prevp, psdep, pgdep, praut, psaut, pgaut, pracw, praci&
 441 &          , piacr, psaci, psacw, pracs, psacr, pgacw, pgaci, pgacr, &
 442 &          pgacs, pigen, pidep, pcond, pseml, pgeml, psevp, pgevp, falk&
 443 &          , fall, fallc, xni, kts, kte, its, ite)
 444 !----------------------------------------------------------------
 445 !     compute the fallout term:
 446 !     first, vertical terminal velosity for minor loops
 447       CALL PUSHREAL8ARRAY(falk, (ite-its+1)*(kte-kts+1)*3)
 448       CALL PUSHREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 449       CALL PUSHREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 450       CALL PUSHREAL8ARRAY(cpm, (ite-its+1)*(kte-kts+1))
 451       CALL FALLK(cpm, t, p, q, den, qrs, delz, dtcld, falk, fall, kte, &
 452 &          kts, its, ite, kme, kms, ims, ime)
 453       CALL PUSHREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 454       CALL FALLKC(qci, fallc, den, delz, dtcld, kte, kts, its, ite, kme&
 455 &           , kms, ims, ime)
 456       CALL PUSHREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 457       CALL PUSHREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 458       CALL PUSHREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 459       CALL RAINSC(fall, fallc, xl, t, q, qci, cpm, den, qrs, delz, rain&
 460 &           , rainncv, dtcld, kte, kts, its, ite, kme, kms, ims, ime)
 461       CALL PUSHREAL8ARRAY(qs, (ite-its+1)*(kte-kts+1)*3)
 462       CALL PUSHREAL8ARRAY(rh, (ite-its+1)*(kte-kts+1)*3)
 463       CALL PUSHREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 464       CALL PUSHREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 465       CALL PUSHREAL8ARRAY(q, (ime-ims+1)*(kme-kms+1))
 466       CALL PUSHREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 467       CALL WARMR(t, q, qci, qrs, den, p, dtcld, xl, rh, qs, praut, pracw&
 468 &          , prevp, ims, ime, kms, kme, its, ite, kts, kte)
 469 !
 470 ! cold rain processes
 471 !
 472 !
 473       CALL PUSHREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 474       CALL PUSHREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 475       CALL PUSHREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 476       CALL ACCRET1(qci, den, qrs, t, q, dtcld, praci, piacr, psaci, &
 477 &            pgaci, psacw, pgacw, ims, ime, kms, kme, its, ite, kts, kte&
 478 &           )
 479       CALL PUSHREAL8ARRAY(pgacw, (ite-its+1)*(kte-kts+1))
 480       CALL PUSHREAL8ARRAY(psacw, (ite-its+1)*(kte-kts+1))
 481       CALL PUSHREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 482       CALL PUSHREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 483       CALL ACCRET2(qrs, t, q, den, dtcld, psacw, pgacw, pracs, psacr, &
 484 &            pgacr, pgacs, pseml, pgeml, ims, ime, kms, kme, its, ite, &
 485 &            kts, kte)
 486       CALL PUSHREAL8ARRAY(qs, (ite-its+1)*(kte-kts+1)*3)
 487       CALL PUSHREAL8ARRAY(q, (ime-ims+1)*(kme-kms+1))
 488       CALL PUSHREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 489       CALL PUSHREAL8ARRAY(rh, (ite-its+1)*(kte-kts+1)*3)
 490       CALL PUSHREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 491       CALL PUSHREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 492       CALL ACCRET3(qrs, qci, rh, t, p, den, dtcld, q, qs, psdep, pgdep, &
 493 &            pigen, psaut, pgaut, psevp, pgevp, pidep, ims, ime, kms, &
 494 &            kme, its, ite, kts, kte)
 495       CALL PUSHREAL8ARRAY(cpm, (ite-its+1)*(kte-kts+1))
 496       CALL PUSHREAL8ARRAY(qs, (ite-its+1)*(kte-kts+1)*3)
 497       CALL PUSHREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 498       CALL PUSHREAL8ARRAY(q, (ime-ims+1)*(kme-kms+1))
 499       CALL PUSHREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 500       CALL PCONADD(t, p, q, qci, qs, xl, cpm, dtcld, kte, kts, its, ite&
 501 &            , kme, kms, ims, ime)
 502     END DO
 503     a_fallc = 0.0_8
 504     a_piacr = 0.0_8
 505     a_psaci = 0.0_8
 506     a_pgaci = 0.0_8
 507     a_psacr = 0.0_8
 508     a_praci = 0.0_8
 509     a_qs = 0.0_8
 510     a_cpm = 0.0_8
 511     a_psacw = 0.0_8
 512     a_pgacr = 0.0_8
 513     a_pgacs = 0.0_8
 514     a_pracs = 0.0_8
 515     a_xl = 0.0_8
 516     a_pgacw = 0.0_8
 517     a_pigen = 0.0_8
 518     a_pracw = 0.0_8
 519     a_rh = 0.0_8
 520     a_psevp = 0.0_8
 521     a_pidep = 0.0_8
 522     a_falk = 0.0_8
 523     a_fall = 0.0_8
 524     a_pgevp = 0.0_8
 525     a_prevp = 0.0_8
 526     a_psdep = 0.0_8
 527     a_pseml = 0.0_8
 528     a_pgdep = 0.0_8
 529     a_pgeml = 0.0_8
 530     a_psaut = 0.0_8
 531     a_pgaut = 0.0_8
 532     a_praut = 0.0_8
 533     DO loop=loops,1,-1
 534       CALL POPREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 535       CALL POPREAL8ARRAY(q, (ime-ims+1)*(kme-kms+1))
 536       CALL POPREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 537       CALL POPREAL8ARRAY(qs, (ite-its+1)*(kte-kts+1)*3)
 538       CALL POPREAL8ARRAY(cpm, (ite-its+1)*(kte-kts+1))
 539       CALL A_PCONADD(t, a_t, p, a_p, q, a_q, qci, a_qci, qs, a_qs, xl, &
 540 &              a_xl, cpm, a_cpm, dtcld, kte, kts, its, ite, kme, kms, &
 541 &              ims, ime)
 542       CALL POPREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 543       CALL POPREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 544       CALL POPREAL8ARRAY(rh, (ite-its+1)*(kte-kts+1)*3)
 545       CALL POPREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 546       CALL POPREAL8ARRAY(q, (ime-ims+1)*(kme-kms+1))
 547       CALL POPREAL8ARRAY(qs, (ite-its+1)*(kte-kts+1)*3)
 548       CALL A_ACCRET3(qrs, a_qrs, qci, a_qci, rh, a_rh, t, a_t, p, a_p, &
 549 &              den, a_den, dtcld, q, a_q, qs, a_qs, psdep, a_psdep, &
 550 &              pgdep, a_pgdep, pigen, a_pigen, psaut, a_psaut, pgaut, &
 551 &              a_pgaut, psevp, a_psevp, pgevp, a_pgevp, pidep, a_pidep, &
 552 &              ims, ime, kms, kme, its, ite, kts, kte)
 553       CALL POPREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 554       CALL POPREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 555       CALL POPREAL8ARRAY(psacw, (ite-its+1)*(kte-kts+1))
 556       CALL POPREAL8ARRAY(pgacw, (ite-its+1)*(kte-kts+1))
 557       CALL A_ACCRET2(qrs, a_qrs, t, a_t, q, a_q, den, a_den, dtcld, &
 558 &              psacw, a_psacw, pgacw, a_pgacw, pracs, a_pracs, psacr, &
 559 &              a_psacr, pgacr, a_pgacr, pgacs, a_pgacs, pseml, a_pseml, &
 560 &              pgeml, a_pgeml, ims, ime, kms, kme, its, ite, kts, kte)
 561       CALL POPREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 562       CALL POPREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 563       CALL POPREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 564       CALL A_ACCRET1(qci, a_qci, den, a_den, qrs, a_qrs, t, a_t, q, a_q&
 565 &              , dtcld, praci, a_praci, piacr, a_piacr, psaci, a_psaci, &
 566 &              pgaci, a_pgaci, psacw, a_psacw, pgacw, a_pgacw, ims, ime&
 567 &              , kms, kme, its, ite, kts, kte)
 568       CALL POPREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 569       CALL POPREAL8ARRAY(q, (ime-ims+1)*(kme-kms+1))
 570       CALL POPREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 571       CALL POPREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 572       CALL POPREAL8ARRAY(rh, (ite-its+1)*(kte-kts+1)*3)
 573       CALL POPREAL8ARRAY(qs, (ite-its+1)*(kte-kts+1)*3)
 574       CALL A_WARMR(t, a_t, q, a_q, qci, a_qci, qrs, a_qrs, den, a_den, p&
 575 &            , a_p, dtcld, xl, a_xl, rh, a_rh, qs, a_qs, praut, a_praut&
 576 &            , pracw, a_pracw, prevp, a_prevp, ims, ime, kms, kme, its, &
 577 &            ite, kts, kte)
 578       CALL POPREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 579       CALL POPREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 580       CALL POPREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 581       CALL A_RAINSC(fall, a_fall, fallc, a_fallc, xl, a_xl, t, a_t, q, &
 582 &             qci, a_qci, cpm, a_cpm, den, a_den, qrs, a_qrs, delz, &
 583 &             a_delz, rain, a_rain, rainncv, a_rainncv, dtcld, kte, kts&
 584 &             , its, ite, kme, kms, ims, ime)
 585       CALL POPREAL8ARRAY(qci, (ite-its+1)*(kte-kts+1)*2)
 586       CALL A_FALLKC(qci, a_qci, fallc, a_fallc, den, a_den, delz, a_delz&
 587 &             , dtcld, kte, kts, its, ite, kme, kms, ims, ime)
 588       CALL POPREAL8ARRAY(cpm, (ite-its+1)*(kte-kts+1))
 589       CALL POPREAL8ARRAY(t, (ite-its+1)*(kte-kts+1))
 590       CALL POPREAL8ARRAY(qrs, (ite-its+1)*(kte-kts+1)*3)
 591       CALL POPREAL8ARRAY(falk, (ite-its+1)*(kte-kts+1)*3)
 592       CALL A_FALLK(cpm, a_cpm, t, a_t, p, a_p, q, a_q, den, a_den, qrs, &
 593 &            a_qrs, delz, a_delz, dtcld, falk, a_falk, fall, a_fall, kte&
 594 &            , kts, its, ite, kme, kms, ims, ime)
 595       CALL POPREAL8ARRAY(fall, (ite-its+1)*(kte-kts+1)*3)
 596       CALL POPREAL8ARRAY(fallc, (ite-its+1)*(kte-kts+1))
 597       CALL A_INIMP(prevp, a_prevp, psdep, a_psdep, pgdep, a_pgdep, praut&
 598 &            , a_praut, psaut, a_psaut, pgaut, a_pgaut, pracw, a_pracw, &
 599 &            praci, a_praci, piacr, a_piacr, psaci, a_psaci, psacw, &
 600 &            a_psacw, pracs, a_pracs, psacr, a_psacr, pgacw, a_pgacw, &
 601 &            pgaci, a_pgaci, pgacr, a_pgacr, pgacs, a_pgacs, pigen, &
 602 &            a_pigen, pidep, a_pidep, pcond, pseml, a_pseml, pgeml, &
 603 &            a_pgeml, psevp, a_psevp, pgevp, a_pgevp, falk, a_falk, fall&
 604 &            , a_fall, fallc, a_fallc, xni, kts, kte, its, ite)
 605     END DO
 606     DO k=kte,kts,-1
 607       DO i=ite,its,-1
 608         CALL POPCONTROL1B(branch)
 609         IF (branch .EQ. 0) a_qrs(i, k, 3) = 0.0_8
 610         CALL POPCONTROL1B(branch)
 611         IF (branch .EQ. 0) a_qrs(i, k, 2) = 0.0_8
 612         CALL POPCONTROL1B(branch)
 613         IF (branch .EQ. 0) a_qci(i, k, 2) = 0.0_8
 614         CALL POPCONTROL1B(branch)
 615         IF (branch .EQ. 0) a_qrs(i, k, 1) = 0.0_8
 616         CALL POPCONTROL1B(branch)
 617         IF (branch .EQ. 0) a_qci(i, k, 1) = 0.0_8
 618         CALL POPCONTROL1B(branch)
 619         IF (branch .EQ. 0) a_q(i, k) = 0.0_8
 620       END DO
 621     END DO
 622   END SUBROUTINE A_WSM62D
 623
 624 !=======================================================================
 625 !
 626 !=======================================================================
 627   SUBROUTINE WSM62D(t, q, qci, qrs, den, p, delz, delt, rain, rainncv, &
 628 &   ims, ime, kms, kme, its, ite, kts, kte)
 629     IMPLICIT NONE
 630 ! big loops
 631 !
 632 !-------------------------------------------------------------------
 633     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
 634     REAL, DIMENSION(its:ite, kts:kte), INTENT(INOUT) :: t
 635     REAL, DIMENSION(its:ite, kts:kte, 2), INTENT(INOUT) :: qci
 636     REAL, DIMENSION(its:ite, kts:kte, 3), INTENT(INOUT) :: qrs
 637     REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT) :: q
 638     REAL, DIMENSION(ims:ime, kms:kme), INTENT(IN) :: den, p, delz
 639     REAL, INTENT(IN) :: delt
 640     REAL, DIMENSION(ims:ime), INTENT(INOUT) :: rain, rainncv
 641 !  LOCAL VAR
 642     REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, rslope, rslope2, &
 643 &   rslope3, rslopeb, falk, fall, work1
 644     REAL, DIMENSION(its:ite, kts:kte) :: pracw, psacw, pgacw, pgacr, &
 645 &   pgacs, psaci, praci, piacr, pracs, psacr, pgaci, pseml, pgeml, fallc&
 646 &   , praut, psaut, pgaut, prevp, psdep, pgdep
 647     REAL, DIMENSION(its:ite, kts:kte) :: pigen, pidep, pcond, xl, cpm, &
 648 &   psevp, xni, pgevp, n0sfac, work2
 649 !   LOGICAL, DIMENSION( its:ite ) :: flgcld
 650     REAL :: dtcld, temp, temp0, supcol, supsat, satdt, eacrs, xmi, &
 651 &   diameter, delta2, delta3
 652     INTEGER :: i, k, loop, loops
 653     REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, &
 654 &   qs10, qs11, qs20, qs21
 655     REAL :: fq, fqc, fqi, fqr, fqs, fqg, fallsum
 656     INTRINSIC MAX
 657     INTRINSIC NINT
 658     INTEGER :: x1
 659 !=================================================================
 660 !
 661     CALL WSM6RINIT()
 662 !----------------------------------------------------------------
 663 !  paddint 0 for negative values generated by dynamics
 664 !
 665     DO k=kts,kte
 666       DO i=its,ite
 667         IF (q(i, k) .LT. 0.) THEN
 668           q(i, k) = 0.
 669         ELSE
 670           q(i, k) = q(i, k)
 671         END IF
 672         IF (qci(i, k, 1) .LT. 0.) THEN
 673           qci(i, k, 1) = 0.
 674         ELSE
 675           qci(i, k, 1) = qci(i, k, 1)
 676         END IF
 677         IF (qrs(i, k, 1) .LT. 0.) THEN
 678           qrs(i, k, 1) = 0.
 679         ELSE
 680           qrs(i, k, 1) = qrs(i, k, 1)
 681         END IF
 682         IF (qci(i, k, 2) .LT. 0.) THEN
 683           qci(i, k, 2) = 0.
 684         ELSE
 685           qci(i, k, 2) = qci(i, k, 2)
 686         END IF
 687         IF (qrs(i, k, 2) .LT. 0.) THEN
 688           qrs(i, k, 2) = 0.
 689         ELSE
 690           qrs(i, k, 2) = qrs(i, k, 2)
 691         END IF
 692         IF (qrs(i, k, 3) .LT. 0.) THEN
 693           qrs(i, k, 3) = 0.
 694         ELSE
 695           qrs(i, k, 3) = qrs(i, k, 3)
 696         END IF
 697       END DO
 698     END DO
 699     x1 = NINT(delt/dtcldcr)
 700     IF (x1 .LT. 1) THEN
 701       loops = 1
 702     ELSE
 703       loops = x1
 704     END IF
 705     dtcld = delt/loops
 706     IF (delt .LE. dtcldcr) dtcld = delt
 707 !
 708     DO loop=1,loops
 709 !
 710 !----------------------------------------------------------------
 711 !     initialize the variables for microphysical physics
 712       CALL INIMP(prevp, psdep, pgdep, praut, psaut, pgaut, pracw, praci&
 713 &          , piacr, psaci, psacw, pracs, psacr, pgacw, pgaci, pgacr, &
 714 &          pgacs, pigen, pidep, pcond, pseml, pgeml, psevp, pgevp, falk&
 715 &          , fall, fallc, xni, kts, kte, its, ite)
 716 !----------------------------------------------------------------
 717 !     compute the fallout term:
 718 !     first, vertical terminal velosity for minor loops
 719       CALL FALLK(cpm, t, p, q, den, qrs, delz, dtcld, falk, fall, kte, &
 720 &          kts, its, ite, kme, kms, ims, ime)
 721       CALL FALLKC(qci, fallc, den, delz, dtcld, kte, kts, its, ite, kme&
 722 &           , kms, ims, ime)
 723       CALL RAINSC(fall, fallc, xl, t, q, qci, cpm, den, qrs, delz, rain&
 724 &           , rainncv, dtcld, kte, kts, its, ite, kme, kms, ims, ime)
 725       CALL WARMR(t, q, qci, qrs, den, p, dtcld, xl, rh, qs, praut, pracw&
 726 &          , prevp, ims, ime, kms, kme, its, ite, kts, kte)
 727 !
 728 ! cold rain processes
 729 !
 730 !
 731       CALL ACCRET1(qci, den, qrs, t, q, dtcld, praci, piacr, psaci, &
 732 &            pgaci, psacw, pgacw, ims, ime, kms, kme, its, ite, kts, kte&
 733 &           )
 734       CALL ACCRET2(qrs, t, q, den, dtcld, psacw, pgacw, pracs, psacr, &
 735 &            pgacr, pgacs, pseml, pgeml, ims, ime, kms, kme, its, ite, &
 736 &            kts, kte)
 737       CALL ACCRET3(qrs, qci, rh, t, p, den, dtcld, q, qs, psdep, pgdep, &
 738 &            pigen, psaut, pgaut, psevp, pgevp, pidep, ims, ime, kms, &
 739 &            kme, its, ite, kts, kte)
 740       CALL PCONADD(t, p, q, qci, qs, xl, cpm, dtcld, kte, kts, its, ite&
 741 &            , kme, kms, ims, ime)
 742     END DO
 743   END SUBROUTINE WSM62D
 744
 745 !  Differentiation of calcrh in reverse (adjoint) mode (with options r8):
 746 !   gradient     of useful results: p q t qs rh
 747 !   with respect to varying inputs: p q t qs rh
 748 !=======================================================================
 749 !
 750 !=======================================================================
 751   SUBROUTINE A_CALCRH(t, a_t, p, a_p, q, a_q, rh, a_rh, qs, a_qs)
 752     IMPLICIT NONE
 753     REAL, INTENT(IN) :: t, q, p
 754     REAL :: a_t, a_q, a_p
 755     REAL, DIMENSION(3) :: rh, qs
 756     REAL, DIMENSION(3) :: a_rh, a_qs
 757     REAL :: tr, qs10, qs11, qs20, qs21
 758     REAL :: a_tr, a_qs10, a_qs11, a_qs20, a_qs21
 759     REAL, PARAMETER :: hsub=xls
 760     REAL, PARAMETER :: hvap=xlv0
 761     REAL, PARAMETER :: cvap=cpv
 762     REAL, PARAMETER :: ttp=t0c+0.01
 763     REAL, PARAMETER :: dldt=cvap-cliq
 764     REAL, PARAMETER :: xa=-(dldt/rv)
 765     REAL, PARAMETER :: xb=xa+hvap/(rv*ttp)
 766     REAL, PARAMETER :: dldti=cvap-cice
 767     REAL, PARAMETER :: xai=-(dldti/rv)
 768     REAL, PARAMETER :: xbi=xai+hsub/(rv*ttp)
 769     INTRINSIC LOG
 770     INTRINSIC EXP
 771     INTRINSIC MAX
 772     REAL :: max1
 773     REAL :: a_max1
 774     REAL :: max2
 775     REAL :: a_max2
 776     REAL :: temp
 777     REAL :: a_temp
 778     REAL :: temp0
 779     REAL :: a_temp0
 780     INTEGER :: branch
 781     tr = ttp/t
 782     qs10 = psat*EXP(LOG(tr)*xa)*EXP(xb*(1.-tr))
 783     qs11 = ep2*qs10/(p-qs10)
 784     CALL PUSHREAL8(qs(1))
 785     qs(1) = qs11
 786     IF (qs(1) .LT. qmin) THEN
 787       CALL PUSHCONTROL1B(0)
 788       max1 = qmin
 789     ELSE
 790       max1 = qs(1)
 791       CALL PUSHCONTROL1B(1)
 792     END IF
 793     qs20 = psat*EXP(LOG(tr)*xai)*EXP(xbi*(1.-tr))
 794     qs21 = ep2*qs20/(p-qs20)
 795     CALL PUSHREAL8(qs(2))
 796     qs(2) = qs21
 797     IF (qs(2) .LT. qmin) THEN
 798       CALL PUSHCONTROL1B(0)
 799       max2 = qmin
 800     ELSE
 801       max2 = qs(2)
 802       CALL PUSHCONTROL1B(1)
 803     END IF
 804     a_q = a_q + a_rh(2)/max2
 805     a_max2 = -(q*a_rh(2)/max2**2)
 806     a_rh(2) = 0.0_8
 807     CALL POPCONTROL1B(branch)
 808     IF (branch .NE. 0) a_qs(2) = a_qs(2) + a_max2
 809     CALL POPREAL8(qs(2))
 810     a_qs21 = a_qs(2)
 811     a_qs(2) = 0.0_8
 812     a_temp0 = ep2*a_qs21/(p-qs20)
 813     a_temp = -(qs20*a_temp0/(p-qs20))
 814     a_qs20 = a_temp0 - a_temp
 815     a_p = a_p + a_temp
 816     temp0 = xai*LOG(tr)
 817     a_tr = (xai*EXP(temp0)*EXP(xbi*(1.-tr))*psat/tr-xbi*EXP(xbi*(1.-tr))&
 818 &     *EXP(temp0)*psat)*a_qs20
 819     a_q = a_q + a_rh(1)/max1
 820     a_max1 = -(q*a_rh(1)/max1**2)
 821     a_rh(1) = 0.0_8
 822     CALL POPCONTROL1B(branch)
 823     IF (branch .NE. 0) a_qs(1) = a_qs(1) + a_max1
 824     CALL POPREAL8(qs(1))
 825     a_qs11 = a_qs(1)
 826     a_qs(1) = 0.0_8
 827     a_temp = ep2*a_qs11/(p-qs10)
 828     a_temp0 = -(qs10*a_temp/(p-qs10))
 829     a_qs10 = a_temp - a_temp0
 830     a_p = a_p + a_temp0
 831     temp = xa*LOG(tr)
 832     a_tr = a_tr + (xa*EXP(temp)*EXP(xb*(1.-tr))*psat/tr-xb*EXP(xb*(1.-tr&
 833 &     ))*EXP(temp)*psat)*a_qs10
 834     a_t = a_t - ttp*a_tr/t**2
 835   END SUBROUTINE A_CALCRH
 836
 837 !=======================================================================
 838 !
 839 !=======================================================================
 840   SUBROUTINE CALCRH(t, p, q, rh, qs)
 841     IMPLICIT NONE
 842     REAL, INTENT(IN) :: t, q, p
 843     REAL, DIMENSION(3), INTENT(OUT) :: rh, qs
 844     REAL :: tr, qs10, qs11, qs20, qs21
 845     REAL, PARAMETER :: hsub=xls
 846     REAL, PARAMETER :: hvap=xlv0
 847     REAL, PARAMETER :: cvap=cpv
 848     REAL, PARAMETER :: ttp=t0c+0.01
 849     REAL, PARAMETER :: dldt=cvap-cliq
 850     REAL, PARAMETER :: xa=-(dldt/rv)
 851     REAL, PARAMETER :: xb=xa+hvap/(rv*ttp)
 852     REAL, PARAMETER :: dldti=cvap-cice
 853     REAL, PARAMETER :: xai=-(dldti/rv)
 854     REAL, PARAMETER :: xbi=xai+hsub/(rv*ttp)
 855     INTRINSIC LOG
 856     INTRINSIC EXP
 857     INTRINSIC MAX
 858     REAL :: max1
 859     REAL :: max2
 860     tr = ttp/t
 861     qs10 = psat*EXP(LOG(tr)*xa)*EXP(xb*(1.-tr))
 862     qs11 = ep2*qs10/(p-qs10)
 863     qs(1) = qs11
 864     IF (qs(1) .LT. qmin) THEN
 865       max1 = qmin
 866     ELSE
 867       max1 = qs(1)
 868     END IF
 869     rh(1) = q/max1
 870     qs20 = psat*EXP(LOG(tr)*xai)*EXP(xbi*(1.-tr))
 871     qs21 = ep2*qs20/(p-qs20)
 872     qs(2) = qs21
 873     IF (qs(2) .LT. qmin) THEN
 874       max2 = qmin
 875     ELSE
 876       max2 = qs(2)
 877     END IF
 878     rh(2) = q/max2
 879   END SUBROUTINE CALCRH
 880
 881 !
 882 !=======================================================================
 883 !
 884 !=======================================================================
 885   SUBROUTINE WSM6RINIT()
 886     IMPLICIT NONE
 887     INTRINSIC ATAN
 888     INTRINSIC SQRT
 889 !-------------------------------------------------------------------
 890 !.... constants which may not be tunable
 891     pi = 4.*ATAN(1.)
 892     xlv1 = cliq - cpv
 893 ! 0.419e-3 -- .61e-3
 894     qc0 = 4./3.*pi*denr*r0**3*xncr/den0
 895 ! 7.03
 896     qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.)
 897     bvtr1 = 1. + bvtr
 898     bvtr2 = 2.5 + .5*bvtr
 899     bvtr3 = 3. + bvtr
 900     bvtr4 = 4. + bvtr
 901     bvtr6 = 6. + bvtr
 902     g1pbr = RGMMA(bvtr1)
 903     g3pbr = RGMMA(bvtr3)
 904 ! 17.837825
 905     g4pbr = RGMMA(bvtr4)
 906     g6pbr = RGMMA(bvtr6)
 907 ! 1.8273
 908     g5pbro2 = RGMMA(bvtr2)
 909     pvtr = avtr*g4pbr/6.
 910     roqimax = 2.08e22*dimax**8
 911 !
 912     bvts1 = 1. + bvts
 913     bvts2 = 2.5 + .5*bvts
 914     bvts3 = 3. + bvts
 915     bvts4 = 4. + bvts
 916 !.8875
 917     g1pbs = RGMMA(bvts1)
 918     g3pbs = RGMMA(bvts3)
 919 ! 12.0786
 920     g4pbs = RGMMA(bvts4)
 921     g5pbso2 = RGMMA(bvts2)
 922     pvts = avts*g4pbs/6.
 923     pidn0r = pi*denr*n0r
 924     pidn0s = pi*dens*n0s
 925     bvtg1 = 1. + bvtg
 926     bvtg2 = 2.5 + .5*bvtg
 927     bvtg3 = 3. + bvtg
 928     bvtg4 = 4. + bvtg
 929     g1pbg = RGMMA(bvtg1)
 930     g3pbg = RGMMA(bvtg3)
 931     g4pbg = RGMMA(bvtg4)
 932     g5pbgo2 = RGMMA(bvtg2)
 933     pvtg = avtg*g4pbg/6.
 934     pidn0g = pi*deng*n0g
 935     vt2r_a = pvtr*pidn0r**(-(bvtr/4.))*SQRT(den0)
 936     vt2s_a = pvts*pidn0s**(-(bvts/4.))*SQRT(den0)
 937     vt2g_a = pvtg*pidn0g**(-(bvtg/4.))*SQRT(den0)
 938     vt2i_a = 3.3
 939     fallr_a = vt2r_a
 940     falls_a = vt2s_a
 941     fallg_a = vt2g_a
 942     falli_a = vt2i_a
 943     prevp_a = 1.56*pi*n0r/SQRT(pidn0r)
 944     prevp_b = 130.37*pi*SQRT(avtr)*n0r*pidn0r**(-((5.+bvtr)/8.))*SQRT(&
 945 &     SQRT(den0))*g5pbro2
 946     psdep_a = 2.6*n0s/SQRT(pidn0s)
 947     psdep_b = 370.08*SQRT(avts)*n0s*pidn0s**(-((5.+bvts)/8.))*SQRT(SQRT(&
 948 &     den0))*g5pbso2
 949     psevp_a = psdep_a
 950     psevp_b = psdep_b
 951     pgdep_a = 1.56*pi*n0g/SQRT(pidn0g)
 952     pgdep_b = 130.37*pi*SQRT(avtg)*n0g*pidn0g**(-((5.+bvtg)/8.))*SQRT(&
 953 &     SQRT(den0))*g5pbgo2
 954     pgevp_a = pgdep_a
 955     pgevp_b = pgdep_b
 956     psmlt_a = 2.75e-3*pi*n0s/SQRT(pidn0s)/xlf0
 957     psmlt_b = 0.391*pi*n0s*SQRT(SQRT(den0))*SQRT(avts)*pidn0s**(-((5.+&
 958 &     bvts)/8.))*g5pbso2/xlf0
 959     pgmlt_a = 3.3e-3*pi*n0g/SQRT(pidn0g)/xlf0
 960     pgmlt_b = 0.276*pi*n0g*SQRT(SQRT(den0))*SQRT(avtg)*pidn0g**(-((5.+&
 961 &     bvtg)/8.))*g5pbgo2/xlf0
 962     praci_a = pi*n0r/4.
 963     praci_b = 2./pidn0r**(3./4.)
 964     praci_c = 3.245e-3/SQRT(pidn0r)
 965     praci_d = 2.633e-6/SQRT(SQRT(pidn0r))
 966     psaci_a = pi*n0s/4.
 967     psaci_b = 2./pidn0s**(3./4.)
 968     psaci_c = 3.245e-3/SQRT(pidn0s)
 969     psaci_d = 2.633e-6/SQRT(SQRT(pidn0s))
 970     pgaci_a = pi*n0g/4.
 971     pgaci_b = 2./pidn0g**(3./4.)
 972     pgaci_c = 3.245e-3/SQRT(pidn0g)
 973     pgaci_d = 2.633e-6/SQRT(SQRT(pidn0g))
 974     pracs_a = pi*n0r*pidn0s
 975     pracs_b = 5./pidn0s**(3./2.)/SQRT(SQRT(pidn0r))
 976     pracs_c = 2./pidn0s**(5./4.)/SQRT(pidn0r)
 977     pracs_d = .5/pidn0s/pidn0r**(3./4.)
 978     psacr_a = pi*n0s*pidn0r
 979     psacr_b = 5./pidn0r**(3./2.)/SQRT(SQRT(pidn0s))
 980     psacr_c = 2./pidn0r**(5./4.)/SQRT(pidn0s)
 981     psacr_d = .5/pidn0r/pidn0s**(3./4.)
 982     pgacr_a = pi*n0g*pidn0r
 983     pgacr_b = 5./pidn0r**(3./2.)/SQRT(SQRT(pidn0g))
 984     pgacr_c = 2./pidn0r**(5./4.)/SQRT(pidn0g)
 985     pgacr_d = .5/pidn0r/pidn0g**(3./4.)
 986     pgacs_a = pi*n0g*pidn0s
 987     pgacs_b = 5./pidn0s**(3./2.)/SQRT(SQRT(pidn0g))
 988     pgacs_c = 2./pidn0s**(5./4.)/SQRT(pidn0g)
 989     pgacs_d = .5/pidn0s/pidn0g**(3./4.)
 990     pidep_a = 3.4927e5
 991     diffac_a = 4.7274e2
 992     diffac_b = 1.1371e4
 993     pgfrz_a = 20.*pi*pfrz1/pidn0r**(3./4.)
 994     piacr_a = 5.38e7*pi*avtr*pidn0r*g6pbr*SQRT(den0)*pidn0r**(-((6.+bvtr&
 995 &     )/4.))/24.
 996     pracw_a = .25*pi*avtr*n0r*g3pbr*SQRT(den0)*pidn0r**(-((3.+bvtr)/4.))
 997     psacw_a = .25*pi*avts*n0s*g3pbs*SQRT(den0)*pidn0s**(-((3.+bvts)/4.))
 998     pgacw_a = .25*pi*avtg*n0g*g3pbg*SQRT(den0)*pidn0g**(-((3.+bvtg)/4.))
 999   END SUBROUTINE WSM6RINIT
1000
1001 !  Differentiation of inimp in reverse (adjoint) mode (with options r8):
1002 !   gradient     of useful results: fallc piacr psaci pgaci psacr
1003 !                praci psacw pgacr pgacs pracs pgacw pigen pracw
1004 !                psevp pidep falk fall pgevp prevp psdep pseml
1005 !                pgdep pgeml psaut pgaut praut
1006 !   with respect to varying inputs: fallc piacr psaci pgaci psacr
1007 !                praci psacw pgacr pgacs pracs pgacw pigen pracw
1008 !                psevp pidep falk fall pgevp prevp psdep pseml
1009 !                pgdep pgeml psaut pgaut praut
1010 !=======================================================================
1011 !
1012 !=======================================================================
1013   SUBROUTINE A_INIMP(prevp, a_prevp, psdep, a_psdep, pgdep, a_pgdep, &
1014 &   praut, a_praut, psaut, a_psaut, pgaut, a_pgaut, pracw, a_pracw, &
1015 &   praci, a_praci, piacr, a_piacr, psaci, a_psaci, psacw, a_psacw, &
1016 &   pracs, a_pracs, psacr, a_psacr, pgacw, a_pgacw, pgaci, a_pgaci, &
1017 &   pgacr, a_pgacr, pgacs, a_pgacs, pigen, a_pigen, pidep, a_pidep, &
1018 &   pcond, pseml, a_pseml, pgeml, a_pgeml, psevp, a_psevp, pgevp, &
1019 &   a_pgevp, falk, a_falk, fall, a_fall, fallc, a_fallc, xni, kts, kte, &
1020 &   its, ite)
1021     IMPLICIT NONE
1022     INTEGER :: kts, kte, its, ite, k, i
1023     REAL, DIMENSION(its:ite, kts:kte, 3) :: falk, fall
1024     REAL, DIMENSION(its:ite, kts:kte, 3) :: a_falk, a_fall
1025     REAL, DIMENSION(its:ite, kts:kte) :: xni, pgevp, pigen, pidep, pcond&
1026 &   , fallc, pracw, psacw, pgacw, pgacr, pgacs, psaci, praci, piacr, &
1027 &   pracs, psacr, pgaci, pseml, pgeml, psevp, praut, psaut, pgaut, prevp&
1028 &   , psdep, pgdep
1029     REAL, DIMENSION(its:ite, kts:kte) :: a_pgevp, a_pigen, a_pidep, &
1030 &   a_fallc, a_pracw, a_psacw, a_pgacw, a_pgacr, a_pgacs, a_psaci, &
1031 &   a_praci, a_piacr, a_pracs, a_psacr, a_pgaci, a_pseml, a_pgeml, &
1032 &   a_psevp, a_praut, a_psaut, a_pgaut, a_prevp, a_psdep, a_pgdep
1033     DO k=kte,kts,-1
1034       DO i=ite,its,-1
1035         a_fallc(i, k) = 0.0_8
1036         a_fall(i, k, 3) = 0.0_8
1037         a_fall(i, k, 2) = 0.0_8
1038         a_fall(i, k, 1) = 0.0_8
1039         a_falk(i, k, 3) = 0.0_8
1040         a_falk(i, k, 2) = 0.0_8
1041         a_falk(i, k, 1) = 0.0_8
1042         a_pgevp(i, k) = 0.0_8
1043         a_psevp(i, k) = 0.0_8
1044         a_pgeml(i, k) = 0.0_8
1045         a_pseml(i, k) = 0.0_8
1046         a_pidep(i, k) = 0.0_8
1047         a_pigen(i, k) = 0.0_8
1048         a_pgacs(i, k) = 0.0_8
1049         a_pgacr(i, k) = 0.0_8
1050         a_pgaci(i, k) = 0.0_8
1051         a_pgacw(i, k) = 0.0_8
1052         a_psacr(i, k) = 0.0_8
1053         a_pracs(i, k) = 0.0_8
1054         a_psacw(i, k) = 0.0_8
1055         a_psaci(i, k) = 0.0_8
1056         a_piacr(i, k) = 0.0_8
1057         a_praci(i, k) = 0.0_8
1058         a_pracw(i, k) = 0.0_8
1059         a_pgaut(i, k) = 0.0_8
1060         a_psaut(i, k) = 0.0_8
1061         a_praut(i, k) = 0.0_8
1062         a_pgdep(i, k) = 0.0_8
1063         a_psdep(i, k) = 0.0_8
1064         a_prevp(i, k) = 0.0_8
1065       END DO
1066     END DO
1067   END SUBROUTINE A_INIMP
1068
1069 !=======================================================================
1070 !
1071 !=======================================================================
1072   SUBROUTINE INIMP(prevp, psdep, pgdep, praut, psaut, pgaut, pracw, &
1073 &   praci, piacr, psaci, psacw, pracs, psacr, pgacw, pgaci, pgacr, pgacs&
1074 &   , pigen, pidep, pcond, pseml, pgeml, psevp, pgevp, falk, fall, fallc&
1075 &   , xni, kts, kte, its, ite)
1076     IMPLICIT NONE
1077     INTEGER :: kts, kte, its, ite, k, i
1078     REAL, DIMENSION(its:ite, kts:kte, 3) :: falk, fall
1079     REAL, DIMENSION(its:ite, kts:kte) :: xni, pgevp, pigen, pidep, pcond&
1080 &   , fallc, pracw, psacw, pgacw, pgacr, pgacs, psaci, praci, piacr, &
1081 &   pracs, psacr, pgaci, pseml, pgeml, psevp, praut, psaut, pgaut, prevp&
1082 &   , psdep, pgdep
1083     DO k=kts,kte
1084       DO i=its,ite
1085         prevp(i, k) = 0.
1086         psdep(i, k) = 0.
1087         pgdep(i, k) = 0.
1088         praut(i, k) = 0.
1089         psaut(i, k) = 0.
1090         pgaut(i, k) = 0.
1091         pracw(i, k) = 0.
1092         praci(i, k) = 0.
1093         piacr(i, k) = 0.
1094         psaci(i, k) = 0.
1095         psacw(i, k) = 0.
1096         pracs(i, k) = 0.
1097         psacr(i, k) = 0.
1098         pgacw(i, k) = 0.
1099         pgaci(i, k) = 0.
1100         pgacr(i, k) = 0.
1101         pgacs(i, k) = 0.
1102         pigen(i, k) = 0.
1103         pidep(i, k) = 0.
1104         pcond(i, k) = 0.
1105         pseml(i, k) = 0.
1106         pgeml(i, k) = 0.
1107         psevp(i, k) = 0.
1108         pgevp(i, k) = 0.
1109         falk(i, k, 1) = 0.
1110         falk(i, k, 2) = 0.
1111         falk(i, k, 3) = 0.
1112         fall(i, k, 1) = 0.
1113         fall(i, k, 2) = 0.
1114         fall(i, k, 3) = 0.
1115         fallc(i, k) = 0.
1116         xni(i, k) = 1.e3
1117       END DO
1118     END DO
1119   END SUBROUTINE INIMP
1120
1121 !  Differentiation of fallk in reverse (adjoint) mode (with options r8):
1122 !   gradient     of useful results: p q t cpm delz den qrs falk
1123 !                fall
1124 !   with respect to varying inputs: p q t cpm delz den qrs falk
1125 !                fall
1126 !=======================================================================
1127 !
1128 !=======================================================================
1129   SUBROUTINE A_FALLK(cpm, a_cpm, t, a_t, p, a_p, q, a_q, den, a_den, qrs&
1130 &   , a_qrs, delz, a_delz, dtcld, falk, a_falk, fall, a_fall, kte, kts, &
1131 &   its, ite, kme, kms, ims, ime)
1132     IMPLICIT NONE
1133     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
1134     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, falk, fall, work1
1135     REAL, DIMENSION(its:ite, kts:kte, 3) :: a_qrs, a_falk, a_fall, &
1136 &   a_work1
1137     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, p, q
1138     REAL, DIMENSION(ims:ime, kms:kme) :: a_delz, a_den, a_p, a_q
1139     REAL, DIMENSION(its:ite, kts:kte) :: psmlt, pgmlt, t, work2, cpm
1140     REAL, DIMENSION(its:ite, kts:kte) :: a_psmlt, a_pgmlt, a_t, a_cpm
1141     INTEGER, DIMENSION(its:ite) :: mstep, numdt
1142     REAL :: dtcld, coeres1, coeres2, coeresi, coeresh, xlf, psmlt0, &
1143 &   pgmlt0, help_i, help_h, w1
1144     REAL :: a_psmlt0, a_pgmlt0
1145     REAL :: tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7, tmp8
1146     REAL :: a_tmp1, a_tmp2, a_tmp3, a_tmp4, a_tmp5, a_tmp6, a_tmp7, &
1147 &   a_tmp8
1148     INTEGER :: mstepmax, k, i, n, nw, jj
1149     REAL :: fqs, fqg, supcol, a, b, c, d
1150     REAL :: a_a, a_b, a_c, a_d
1151     INTRINSIC MAX
1152     INTRINSIC MIN
1153     INTRINSIC EXP
1154     INTRINSIC NINT
1155     INTRINSIC ABS
1156     INTRINSIC SQRT
1157     REAL :: x1
1158     REAL :: a_x1
1159     REAL :: y1
1160     REAL :: a_y1
1161     REAL :: y2
1162     REAL :: a_y2
1163     REAL :: y3
1164     REAL :: a_y3
1165     REAL :: max1
1166     REAL :: a_max1
1167     REAL :: max2
1168     REAL :: a_max2
1169     REAL :: max3
1170     REAL :: a_max3
1171     REAL :: abs0
1172     REAL :: abs1
1173     REAL :: max4
1174     REAL :: a_max4
1175     REAL :: max5
1176     REAL :: a_max5
1177     REAL :: max6
1178     REAL :: a_max6
1179     REAL :: abs2
1180     REAL :: max7
1181     REAL :: a_max7
1182     REAL :: abs3
1183     REAL :: max8
1184     REAL :: a_max8
1185     REAL :: max9
1186     REAL :: a_max9
1187     REAL :: max10
1188     REAL :: a_max10
1189     REAL :: temp
1190     REAL :: temp0
1191     REAL :: temp1
1192     REAL :: a_temp
1193     REAL :: temp2
1194     REAL :: temp3
1195     REAL :: temp4
1196     REAL :: a_temp0
1197     REAL :: a_temp1
1198     REAL :: a_temp2
1199     REAL :: a_temp3
1200     REAL :: temp5
1201     REAL :: temp6
1202     REAL :: temp7
1203     REAL :: temp8
1204     REAL :: temp9
1205     REAL :: a_temp4
1206     REAL :: a_temp5
1207     INTEGER :: branch
1208     mstep = 1
1209     mstepmax = 1
1210     DO k=kte,kts,-1
1211       DO i=its,ite
1212         IF (qcrmin .LT. qrs(i, k, 1)) THEN
1213           CALL PUSHREAL8(max1)
1214           max1 = qrs(i, k, 1)
1215           CALL PUSHCONTROL1B(0)
1216         ELSE
1217           CALL PUSHREAL8(max1)
1218           max1 = qcrmin
1219           CALL PUSHCONTROL1B(1)
1220         END IF
1221         work1(i, k, 1) = vt2r_a*den(i, k)**((bvtr-2.)/4.)*max1**(bvtr/4.&
1222 &         )/delz(i, k)
1223         IF (qcrmin .LT. qrs(i, k, 2)) THEN
1224           CALL PUSHREAL8(max2)
1225           max2 = qrs(i, k, 2)
1226           CALL PUSHCONTROL1B(0)
1227         ELSE
1228           CALL PUSHREAL8(max2)
1229           max2 = qcrmin
1230           CALL PUSHCONTROL1B(1)
1231         END IF
1232         IF (90. .GT. t0c - t(i, k)) THEN
1233           y3 = t0c - t(i, k)
1234           CALL PUSHCONTROL1B(0)
1235         ELSE
1236           CALL PUSHCONTROL1B(1)
1237           y3 = 90.
1238         END IF
1239         IF (0. .LT. y3) THEN
1240           CALL PUSHREAL8(max8)
1241           max8 = y3
1242           CALL PUSHCONTROL1B(0)
1243         ELSE
1244           CALL PUSHREAL8(max8)
1245           max8 = 0.
1246           CALL PUSHCONTROL1B(1)
1247         END IF
1248         work1(i, k, 2) = vt2s_a*den(i, k)**((bvts-2.)/4.)*max2**(bvts/4.&
1249 &         )/delz(i, k)*EXP(-(bvts*alpha*max8/4.))
1250         IF (qcrmin .LT. qrs(i, k, 3)) THEN
1251           CALL PUSHREAL8(max3)
1252           max3 = qrs(i, k, 3)
1253           CALL PUSHCONTROL1B(0)
1254         ELSE
1255           CALL PUSHREAL8(max3)
1256           max3 = qcrmin
1257           CALL PUSHCONTROL1B(1)
1258         END IF
1259         work1(i, k, 3) = vt2g_a*den(i, k)**((bvtg-2.)/4.)*max3**(bvtg/4.&
1260 &         )/delz(i, k)
1261         IF (work1(i, k, 1) .GE. work1(i, k, 2) .AND. work1(i, k, 1) .GE.&
1262 &           work1(i, k, 3)) THEN
1263           CALL PUSHCONTROL1B(0)
1264           w1 = work1(i, k, 1)
1265         ELSE IF (work1(i, k, 2) .GE. work1(i, k, 1) .AND. work1(i, k, 2)&
1266 &           .GE. work1(i, k, 3)) THEN
1267           CALL PUSHCONTROL1B(1)
1268           w1 = work1(i, k, 2)
1269         ELSE
1270           CALL PUSHCONTROL1B(1)
1271           w1 = work1(i, k, 3)
1272         END IF
1273         nw = NINT(w1*dtcld + .5)
1274         IF (nw .GT. 1) THEN
1275           numdt(i) = nw
1276         ELSE
1277           numdt(i) = 1
1278         END IF
1279         IF (numdt(i) .GE. mstep(i)) THEN
1280           CALL PUSHCONTROL1B(1)
1281           mstep(i) = numdt(i)
1282         ELSE
1283           CALL PUSHCONTROL1B(0)
1284         END IF
1285       END DO
1286     END DO
1287     DO i=its,ite
1288       IF (mstepmax .LE. mstep(i)) THEN
1289         CALL PUSHCONTROL1B(1)
1290         mstepmax = mstep(i)
1291       ELSE
1292         CALL PUSHCONTROL1B(0)
1293       END IF
1294     END DO
1295     DO n=1,mstepmax
1296       DO i=its,ite
1297         IF (n .LE. mstep(i)) THEN
1298           CALL PUSHINTEGER4(k)
1299           k = kte
1300           CALL PUSHREAL8(falk(i, k, 1))
1301           falk(i, k, 1) = den(i, k)*qrs(i, k, 1)*work1(i, k, 1)/mstep(i)
1302           CALL PUSHREAL8(falk(i, k, 2))
1303           falk(i, k, 2) = den(i, k)*qrs(i, k, 2)*work1(i, k, 2)/mstep(i)
1304           CALL PUSHREAL8(falk(i, k, 3))
1305           falk(i, k, 3) = den(i, k)*qrs(i, k, 3)*work1(i, k, 3)/mstep(i)
1306           DO jj=1,3
1307             x1 = falk(i, k, jj)*dtcld/den(i, k)
1308             IF (x1 .GT. qrs(i, k, jj)) THEN
1309               tmp1 = qrs(i, k, jj)
1310               CALL PUSHCONTROL1B(0)
1311             ELSE
1312               tmp1 = x1
1313               CALL PUSHCONTROL1B(1)
1314             END IF
1315             IF (tmp1 .GE. 0.) THEN
1316               abs0 = tmp1
1317             ELSE
1318               abs0 = -tmp1
1319             END IF
1320             IF (abs0 .LT. qmin) THEN
1321               tmp1 = 0.
1322               CALL PUSHCONTROL1B(0)
1323             ELSE
1324               CALL PUSHCONTROL1B(1)
1325             END IF
1326             CALL PUSHREAL8(qrs(i, k, jj))
1327             qrs(i, k, jj) = qrs(i, k, jj) - tmp1
1328           END DO
1329           CALL PUSHCONTROL1B(1)
1330         ELSE
1331           CALL PUSHCONTROL1B(0)
1332         END IF
1333       END DO
1334       CALL PUSHINTEGER4(k)
1335       DO k=kte-1,kts,-1
1336         DO i=its,ite
1337           IF (n .LE. mstep(i)) THEN
1338             CALL PUSHREAL8(falk(i, k, 1))
1339             falk(i, k, 1) = den(i, k)*qrs(i, k, 1)*work1(i, k, 1)/mstep(&
1340 &             i)
1341             CALL PUSHREAL8(falk(i, k, 2))
1342             falk(i, k, 2) = den(i, k)*qrs(i, k, 2)*work1(i, k, 2)/mstep(&
1343 &             i)
1344             CALL PUSHREAL8(falk(i, k, 3))
1345             falk(i, k, 3) = den(i, k)*qrs(i, k, 3)*work1(i, k, 3)/mstep(&
1346 &             i)
1347             DO jj=1,3
1348               IF ((falk(i, k, jj)-falk(i, k+1, jj)*delz(i, k+1)/delz(i, &
1349 &                 k))*dtcld/den(i, k) .GT. qrs(i, k, jj)) THEN
1350                 tmp2 = qrs(i, k, jj)
1351                 CALL PUSHCONTROL1B(0)
1352               ELSE
1353                 tmp2 = (falk(i, k, jj)-falk(i, k+1, jj)*delz(i, k+1)/&
1354 &                 delz(i, k))*dtcld/den(i, k)
1355                 CALL PUSHCONTROL1B(1)
1356               END IF
1357               IF (tmp2 .GE. 0.) THEN
1358                 abs1 = tmp2
1359               ELSE
1360                 abs1 = -tmp2
1361               END IF
1362               IF (abs1 .LT. qmin) THEN
1363                 tmp2 = 0.
1364                 CALL PUSHCONTROL1B(0)
1365               ELSE
1366                 CALL PUSHCONTROL1B(1)
1367               END IF
1368               CALL PUSHREAL8(qrs(i, k, jj))
1369               qrs(i, k, jj) = qrs(i, k, jj) - tmp2
1370             END DO
1371             CALL PUSHCONTROL1B(1)
1372           ELSE
1373             CALL PUSHCONTROL1B(0)
1374           END IF
1375         END DO
1376       END DO
1377       DO k=kte,kts,-1
1378         DO i=its,ite
1379           IF (n .LE. mstep(i)) THEN
1380 !
1381 !---------------------------------------------------------------
1382 ! psmlt: melting of snow [RH83 A25]
1383 !       (T>T0: S->R) psmlt<0: min=-qrs(i,k,2), max=0
1384 !---------------------------------------------------------------
1385 !update xl, cpm
1386             CALL PUSHREAL8(cpm(i, k))
1387             cpm(i, k) = CPMCAL(q(i, k))
1388             xlf = xlf0
1389             IF (90. .GT. t0c - t(i, k)) THEN
1390               y1 = t0c - t(i, k)
1391               CALL PUSHCONTROL1B(0)
1392             ELSE
1393               CALL PUSHCONTROL1B(1)
1394               y1 = 90.
1395             END IF
1396             IF (0. .LT. y1) THEN
1397               CALL PUSHREAL8(max4)
1398               max4 = y1
1399               CALL PUSHCONTROL1B(0)
1400             ELSE
1401               CALL PUSHREAL8(max4)
1402               max4 = 0.
1403               CALL PUSHCONTROL1B(1)
1404             END IF
1405             CALL PUSHREAL8(a)
1406             a = EXP(alpha*max4/2.)
1407             IF (90. .GT. t0c - t(i, k)) THEN
1408               y2 = t0c - t(i, k)
1409               CALL PUSHCONTROL1B(0)
1410             ELSE
1411               CALL PUSHCONTROL1B(1)
1412               y2 = 90.
1413             END IF
1414             IF (0. .LT. y2) THEN
1415               CALL PUSHREAL8(max5)
1416               max5 = y2
1417               CALL PUSHCONTROL1B(0)
1418             ELSE
1419               CALL PUSHREAL8(max5)
1420               max5 = 0.
1421               CALL PUSHCONTROL1B(1)
1422             END IF
1423             CALL PUSHREAL8(b)
1424             b = EXP(alpha*max5*(3-bvts)/8.)
1425             c = t(i, k)**1.5*(t0c-t(i, k))/(t(i, k)+120.)
1426             CALL PUSHREAL8(d)
1427             d = t(i, k)**(3.88/6.)*(t0c-t(i, k))/(t(i, k)+120.)**(5./6.)
1428             IF (qrs(i, k, 2) .LT. qcrmin) THEN
1429               CALL PUSHREAL8(max6)
1430               max6 = qcrmin
1431               CALL PUSHCONTROL1B(1)
1432             ELSE
1433               CALL PUSHREAL8(max6)
1434               max6 = qrs(i, k, 2)
1435               CALL PUSHCONTROL1B(0)
1436             END IF
1437             IF (qrs(i, k, 2) .LT. qcrmin) THEN
1438               CALL PUSHREAL8(max9)
1439               max9 = qcrmin
1440               CALL PUSHCONTROL1B(0)
1441             ELSE
1442               CALL PUSHREAL8(max9)
1443               max9 = qrs(i, k, 2)
1444               CALL PUSHCONTROL1B(1)
1445             END IF
1446             psmlt0 = psmlt_a*a*c*SQRT(den(i, k)*max6) + psmlt_b*b*d*p(i&
1447 &             , k)**(1./3.)*den(i, k)**((13.+3*bvts)/24.)*max9**((5.+&
1448 &             bvts)/8.)
1449             tmp3 = psmlt0*dtcld/mstep(i)
1450             tmp4 = -(qrs(i, k, 2)/mstep(i))
1451             IF (tmp3 .GT. tmp4) THEN
1452               tmp5 = tmp3
1453               CALL PUSHCONTROL1B(0)
1454             ELSE
1455               tmp5 = tmp4
1456               CALL PUSHCONTROL1B(1)
1457             END IF
1458             IF (tmp5 .LT. 0.) THEN
1459               CALL PUSHREAL8(psmlt(i, k))
1460               psmlt(i, k) = tmp5
1461               CALL PUSHCONTROL1B(1)
1462             ELSE
1463               CALL PUSHREAL8(psmlt(i, k))
1464               psmlt(i, k) = 0.
1465               CALL PUSHCONTROL1B(0)
1466             END IF
1467             IF (psmlt(i, k) .GE. 0.) THEN
1468               abs2 = psmlt(i, k)
1469             ELSE
1470               abs2 = -psmlt(i, k)
1471             END IF
1472             IF (abs2 .LT. qmin) THEN
1473               psmlt(i, k) = 0.
1474               CALL PUSHCONTROL1B(1)
1475             ELSE
1476               CALL PUSHCONTROL1B(0)
1477             END IF
1478             IF (qrs(i, k, 2) + psmlt(i, k) .LT. 0.) THEN
1479               CALL PUSHREAL8(qrs(i, k, 2))
1480               qrs(i, k, 2) = 0.
1481               CALL PUSHCONTROL1B(0)
1482             ELSE
1483               CALL PUSHREAL8(qrs(i, k, 2))
1484               qrs(i, k, 2) = qrs(i, k, 2) + psmlt(i, k)
1485               CALL PUSHCONTROL1B(1)
1486             END IF
1487             IF (qrs(i, k, 1) - psmlt(i, k) .LT. 0.) THEN
1488               CALL PUSHREAL8(qrs(i, k, 1))
1489               qrs(i, k, 1) = 0.
1490               CALL PUSHCONTROL1B(0)
1491             ELSE
1492               CALL PUSHREAL8(qrs(i, k, 1))
1493               qrs(i, k, 1) = qrs(i, k, 1) - psmlt(i, k)
1494               CALL PUSHCONTROL1B(1)
1495             END IF
1496             CALL PUSHREAL8(t(i, k))
1497             t(i, k) = t(i, k) + xlf/cpm(i, k)*psmlt(i, k)
1498             CALL PUSHCONTROL1B(1)
1499           ELSE
1500             CALL PUSHCONTROL1B(0)
1501           END IF
1502         END DO
1503       END DO
1504 !---------------------------------------------------------------
1505 ! pgmlt: melting of graupel [LFO 47]
1506 !       (T>T0: G->R) pgmlt<0: min=-qrs(i,k,3), max=0
1507 !---------------------------------------------------------------
1508       DO k=kte,kts,-1
1509         DO i=its,ite
1510           IF (n .LE. mstep(i)) THEN
1511 !update xl, cpm
1512             xlf = xlf0
1513 !               cpm(i,k)=cpmcal(q(i,k)) ! not change
1514             c = t(i, k)**1.5*(t0c-t(i, k))/(t(i, k)+120.)
1515             CALL PUSHREAL8(d)
1516             d = t(i, k)**(3.88/6.)*(t0c-t(i, k))/(t(i, k)+120.)**(5./6.)
1517             IF (qrs(i, k, 3) .LT. qcrmin) THEN
1518               CALL PUSHREAL8(max7)
1519               max7 = qcrmin
1520               CALL PUSHCONTROL1B(1)
1521             ELSE
1522               CALL PUSHREAL8(max7)
1523               max7 = qrs(i, k, 3)
1524               CALL PUSHCONTROL1B(0)
1525             END IF
1526             IF (qrs(i, k, 3) .LT. qcrmin) THEN
1527               CALL PUSHREAL8(max10)
1528               max10 = qcrmin
1529               CALL PUSHCONTROL1B(0)
1530             ELSE
1531               CALL PUSHREAL8(max10)
1532               max10 = qrs(i, k, 3)
1533               CALL PUSHCONTROL1B(1)
1534             END IF
1535             pgmlt0 = pgmlt_a*c*SQRT(den(i, k)*max7) + pgmlt_b*d*p(i, k)&
1536 &             **(1./3.)*den(i, k)**((13.+3*bvtg)/24.)*max10**((5.+bvtg)/&
1537 &             8.)
1538             tmp6 = pgmlt0*dtcld/mstep(i)
1539             tmp7 = -(qrs(i, k, 3)/mstep(i))
1540             IF (tmp6 .GT. tmp7) THEN
1541               tmp8 = tmp6
1542               CALL PUSHCONTROL1B(0)
1543             ELSE
1544               tmp8 = tmp7
1545               CALL PUSHCONTROL1B(1)
1546             END IF
1547             IF (tmp8 .LT. 0.) THEN
1548               CALL PUSHREAL8(pgmlt(i, k))
1549               pgmlt(i, k) = tmp8
1550               CALL PUSHCONTROL1B(1)
1551             ELSE
1552               CALL PUSHREAL8(pgmlt(i, k))
1553               pgmlt(i, k) = 0.
1554               CALL PUSHCONTROL1B(0)
1555             END IF
1556             IF (pgmlt(i, k) .GE. 0.) THEN
1557               abs3 = pgmlt(i, k)
1558             ELSE
1559               abs3 = -pgmlt(i, k)
1560             END IF
1561             IF (abs3 .LT. qmin) THEN
1562               pgmlt(i, k) = 0.
1563               CALL PUSHCONTROL1B(1)
1564             ELSE
1565               CALL PUSHCONTROL1B(0)
1566             END IF
1567             IF (qrs(i, k, 3) + pgmlt(i, k) .LT. 0.) THEN
1568               CALL PUSHREAL8(qrs(i, k, 3))
1569               qrs(i, k, 3) = 0.
1570               CALL PUSHCONTROL1B(0)
1571             ELSE
1572               CALL PUSHREAL8(qrs(i, k, 3))
1573               qrs(i, k, 3) = qrs(i, k, 3) + pgmlt(i, k)
1574               CALL PUSHCONTROL1B(1)
1575             END IF
1576             IF (qrs(i, k, 1) - pgmlt(i, k) .LT. 0.) THEN
1577               CALL PUSHREAL8(qrs(i, k, 1))
1578               qrs(i, k, 1) = 0.
1579               CALL PUSHCONTROL1B(0)
1580             ELSE
1581               CALL PUSHREAL8(qrs(i, k, 1))
1582               qrs(i, k, 1) = qrs(i, k, 1) - pgmlt(i, k)
1583               CALL PUSHCONTROL1B(1)
1584             END IF
1585             CALL PUSHREAL8(t(i, k))
1586             t(i, k) = t(i, k) + xlf/cpm(i, k)*pgmlt(i, k)
1587             CALL PUSHCONTROL1B(1)
1588           ELSE
1589             CALL PUSHCONTROL1B(0)
1590           END IF
1591         END DO
1592       END DO
1593     END DO
1594     a_work1 = 0.0_8
1595     a_psmlt = 0.0_8
1596     a_pgmlt = 0.0_8
1597     DO n=mstepmax,1,-1
1598       DO k=kts,kte,1
1599         DO i=ite,its,-1
1600           CALL POPCONTROL1B(branch)
1601           IF (branch .NE. 0) THEN
1602             xlf = xlf0
1603             CALL POPREAL8(t(i, k))
1604             a_temp4 = xlf*a_t(i, k)/cpm(i, k)
1605             a_pgmlt(i, k) = a_pgmlt(i, k) + a_temp4
1606             a_cpm(i, k) = a_cpm(i, k) - pgmlt(i, k)*a_temp4/cpm(i, k)
1607             CALL POPCONTROL1B(branch)
1608             IF (branch .EQ. 0) THEN
1609               CALL POPREAL8(qrs(i, k, 1))
1610               a_qrs(i, k, 1) = 0.0_8
1611             ELSE
1612               CALL POPREAL8(qrs(i, k, 1))
1613               a_pgmlt(i, k) = a_pgmlt(i, k) - a_qrs(i, k, 1)
1614             END IF
1615             CALL POPCONTROL1B(branch)
1616             IF (branch .EQ. 0) THEN
1617               CALL POPREAL8(qrs(i, k, 3))
1618               a_qrs(i, k, 3) = 0.0_8
1619             ELSE
1620               CALL POPREAL8(qrs(i, k, 3))
1621               a_pgmlt(i, k) = a_pgmlt(i, k) + a_qrs(i, k, 3)
1622             END IF
1623             CALL POPCONTROL1B(branch)
1624             IF (branch .NE. 0) a_pgmlt(i, k) = 0.0_8
1625             CALL POPCONTROL1B(branch)
1626             IF (branch .EQ. 0) THEN
1627               CALL POPREAL8(pgmlt(i, k))
1628               a_pgmlt(i, k) = 0.0_8
1629               a_tmp8 = 0.0_8
1630             ELSE
1631               CALL POPREAL8(pgmlt(i, k))
1632               a_tmp8 = a_pgmlt(i, k)
1633               a_pgmlt(i, k) = 0.0_8
1634             END IF
1635             CALL POPCONTROL1B(branch)
1636             IF (branch .EQ. 0) THEN
1637               a_tmp6 = a_tmp8
1638               a_tmp7 = 0.0_8
1639             ELSE
1640               a_tmp7 = a_tmp8
1641               a_tmp6 = 0.0_8
1642             END IF
1643             a_qrs(i, k, 3) = a_qrs(i, k, 3) - a_tmp7/mstep(i)
1644             a_pgmlt0 = dtcld*a_tmp6/mstep(i)
1645             c = t(i, k)**1.5*(t0c-t(i, k))/(t(i, k)+120.)
1646             temp9 = den(i, k)*max7
1647             temp8 = SQRT(temp9)
1648             temp7 = (bvtg+5.)/8.
1649             temp6 = max10**temp7
1650             temp5 = 1.0/3.
1651             temp4 = p(i, k)**temp5
1652             temp3 = (3*bvtg+13.)/24.
1653             a_c = temp8*pgmlt_a*a_pgmlt0
1654             IF (temp9 .EQ. 0.0_8) THEN
1655               a_temp4 = 0.0_8
1656             ELSE
1657               a_temp4 = c*pgmlt_a*a_pgmlt0/(2.0*temp8)
1658             END IF
1659             IF (den(i, k) .LE. 0.0_8 .AND. (temp3 .EQ. 0.0_8 .OR. temp3 &
1660 &               .NE. INT(temp3))) THEN
1661               a_den(i, k) = a_den(i, k) + max7*a_temp4
1662             ELSE
1663               a_den(i, k) = a_den(i, k) + temp3*den(i, k)**(temp3-1)*&
1664 &               temp4*d*temp6*pgmlt_b*a_pgmlt0 + max7*a_temp4
1665             END IF
1666             a_temp0 = den(i, k)**temp3*pgmlt_b*a_pgmlt0
1667             IF (.NOT.(p(i, k) .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR. &
1668 &               temp5 .NE. INT(temp5)))) a_p(i, k) = a_p(i, k) + temp5*p&
1669 &               (i, k)**(temp5-1)*d*temp6*a_temp0
1670             a_d = temp6*temp4*a_temp0
1671             IF (max10 .LE. 0.0_8 .AND. (temp7 .EQ. 0.0_8 .OR. temp7 .NE.&
1672 &               INT(temp7))) THEN
1673               a_max10 = 0.0_8
1674             ELSE
1675               a_max10 = temp7*max10**(temp7-1)*d*temp4*a_temp0
1676             END IF
1677             a_max7 = den(i, k)*a_temp4
1678             CALL POPCONTROL1B(branch)
1679             IF (branch .EQ. 0) THEN
1680               CALL POPREAL8(max10)
1681             ELSE
1682               CALL POPREAL8(max10)
1683               a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max10
1684             END IF
1685             CALL POPCONTROL1B(branch)
1686             IF (branch .EQ. 0) THEN
1687               CALL POPREAL8(max7)
1688               a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max7
1689             ELSE
1690               CALL POPREAL8(max7)
1691             END IF
1692             a_temp4 = t(i, k)**1.5*a_c/(t(i, k)+120.)
1693             CALL POPREAL8(d)
1694             temp9 = 5./6.
1695             temp8 = (t(i, k)+120.)**temp9
1696             temp6 = 3.88/6.
1697             temp5 = t(i, k)**temp6
1698             a_temp5 = a_d/temp8
1699             IF (.NOT.(t(i, k) .LE. 0.0_8 .AND. (temp6 .EQ. 0.0_8 .OR. &
1700 &               temp6 .NE. INT(temp6)))) a_t(i, k) = a_t(i, k) + temp6*t&
1701 &               (i, k)**(temp6-1)*(t0c-t(i, k))*a_temp5
1702             IF (t(i, k) + 120. .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR. &
1703 &               temp9 .NE. INT(temp9))) THEN
1704               a_t(i, k) = a_t(i, k) - temp5*a_temp5
1705             ELSE
1706               a_t(i, k) = a_t(i, k) - (temp5+temp9*(t(i, k)+120.)**(&
1707 &               temp9-1)*temp5*(t0c-t(i, k))/temp8)*a_temp5
1708             END IF
1709             temp9 = (t0c-t(i, k))/(t(i, k)+120.)
1710             a_t(i, k) = a_t(i, k) + 1.5*t(i, k)**0.5*temp9*a_c - (temp9+&
1711 &             1.0)*a_temp4
1712           END IF
1713         END DO
1714       END DO
1715       DO k=kts,kte,1
1716         DO i=ite,its,-1
1717           CALL POPCONTROL1B(branch)
1718           IF (branch .NE. 0) THEN
1719             xlf = xlf0
1720             CALL POPREAL8(t(i, k))
1721             a_temp4 = xlf*a_t(i, k)/cpm(i, k)
1722             a_psmlt(i, k) = a_psmlt(i, k) + a_temp4
1723             a_cpm(i, k) = a_cpm(i, k) - psmlt(i, k)*a_temp4/cpm(i, k)
1724             CALL POPCONTROL1B(branch)
1725             IF (branch .EQ. 0) THEN
1726               CALL POPREAL8(qrs(i, k, 1))
1727               a_qrs(i, k, 1) = 0.0_8
1728             ELSE
1729               CALL POPREAL8(qrs(i, k, 1))
1730               a_psmlt(i, k) = a_psmlt(i, k) - a_qrs(i, k, 1)
1731             END IF
1732             CALL POPCONTROL1B(branch)
1733             IF (branch .EQ. 0) THEN
1734               CALL POPREAL8(qrs(i, k, 2))
1735               a_qrs(i, k, 2) = 0.0_8
1736             ELSE
1737               CALL POPREAL8(qrs(i, k, 2))
1738               a_psmlt(i, k) = a_psmlt(i, k) + a_qrs(i, k, 2)
1739             END IF
1740             CALL POPCONTROL1B(branch)
1741             IF (branch .NE. 0) a_psmlt(i, k) = 0.0_8
1742             CALL POPCONTROL1B(branch)
1743             IF (branch .EQ. 0) THEN
1744               CALL POPREAL8(psmlt(i, k))
1745               a_psmlt(i, k) = 0.0_8
1746               a_tmp5 = 0.0_8
1747             ELSE
1748               CALL POPREAL8(psmlt(i, k))
1749               a_tmp5 = a_psmlt(i, k)
1750               a_psmlt(i, k) = 0.0_8
1751             END IF
1752             CALL POPCONTROL1B(branch)
1753             IF (branch .EQ. 0) THEN
1754               a_tmp3 = a_tmp5
1755               a_tmp4 = 0.0_8
1756             ELSE
1757               a_tmp4 = a_tmp5
1758               a_tmp3 = 0.0_8
1759             END IF
1760             a_qrs(i, k, 2) = a_qrs(i, k, 2) - a_tmp4/mstep(i)
1761             a_psmlt0 = dtcld*a_tmp3/mstep(i)
1762             c = t(i, k)**1.5*(t0c-t(i, k))/(t(i, k)+120.)
1763             temp3 = den(i, k)*max6
1764             temp2 = SQRT(temp3)
1765             temp1 = (bvts+5.)/8.
1766             temp0 = max9**temp1
1767             temp5 = (3*bvts+13.)/24.
1768             temp6 = den(i, k)**temp5
1769             temp7 = 1.0/3.
1770             temp8 = p(i, k)**temp7
1771             a_temp2 = psmlt_a*a_psmlt0
1772             a_temp3 = b*d*temp0*psmlt_b*a_psmlt0
1773             a_temp4 = temp8*temp6*psmlt_b*a_psmlt0
1774             a_b = d*temp0*a_temp4
1775             a_d = b*temp0*a_temp4
1776             IF (max9 .LE. 0.0_8 .AND. (temp1 .EQ. 0.0_8 .OR. temp1 .NE. &
1777 &               INT(temp1))) THEN
1778               a_max9 = 0.0_8
1779             ELSE
1780               a_max9 = temp1*max9**(temp1-1)*b*d*a_temp4
1781             END IF
1782             IF (.NOT.(p(i, k) .LE. 0.0_8 .AND. (temp7 .EQ. 0.0_8 .OR. &
1783 &               temp7 .NE. INT(temp7)))) a_p(i, k) = a_p(i, k) + temp7*p&
1784 &               (i, k)**(temp7-1)*temp6*a_temp3
1785             a_a = c*temp2*a_temp2
1786             a_c = a*temp2*a_temp2
1787             IF (temp3 .EQ. 0.0_8) THEN
1788               a_temp1 = 0.0_8
1789             ELSE
1790               a_temp1 = a*c*a_temp2/(2.0*temp2)
1791             END IF
1792             IF (den(i, k) .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR. temp5 &
1793 &               .NE. INT(temp5))) THEN
1794               a_den(i, k) = a_den(i, k) + max6*a_temp1
1795             ELSE
1796               a_den(i, k) = a_den(i, k) + temp5*den(i, k)**(temp5-1)*&
1797 &               temp8*a_temp3 + max6*a_temp1
1798             END IF
1799             a_max6 = den(i, k)*a_temp1
1800             CALL POPCONTROL1B(branch)
1801             IF (branch .EQ. 0) THEN
1802               CALL POPREAL8(max9)
1803             ELSE
1804               CALL POPREAL8(max9)
1805               a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max9
1806             END IF
1807             CALL POPCONTROL1B(branch)
1808             IF (branch .EQ. 0) THEN
1809               CALL POPREAL8(max6)
1810               a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max6
1811             ELSE
1812               CALL POPREAL8(max6)
1813             END IF
1814             a_temp2 = t(i, k)**1.5*a_c/(t(i, k)+120.)
1815             CALL POPREAL8(d)
1816             temp4 = 5./6.
1817             temp3 = (t(i, k)+120.)**temp4
1818             temp1 = 3.88/6.
1819             temp0 = t(i, k)**temp1
1820             a_temp0 = a_d/temp3
1821             IF (.NOT.(t(i, k) .LE. 0.0_8 .AND. (temp1 .EQ. 0.0_8 .OR. &
1822 &               temp1 .NE. INT(temp1)))) a_t(i, k) = a_t(i, k) + temp1*t&
1823 &               (i, k)**(temp1-1)*(t0c-t(i, k))*a_temp0
1824             IF (t(i, k) + 120. .LE. 0.0_8 .AND. (temp4 .EQ. 0.0_8 .OR. &
1825 &               temp4 .NE. INT(temp4))) THEN
1826               a_t(i, k) = a_t(i, k) - temp0*a_temp0
1827             ELSE
1828               a_t(i, k) = a_t(i, k) - (temp0+temp4*(t(i, k)+120.)**(&
1829 &               temp4-1)*temp0*(t0c-t(i, k))/temp3)*a_temp0
1830             END IF
1831             temp4 = (t0c-t(i, k))/(t(i, k)+120.)
1832             a_t(i, k) = a_t(i, k) + 1.5*t(i, k)**0.5*temp4*a_c - (temp4+&
1833 &             1.0)*a_temp2
1834             CALL POPREAL8(b)
1835             a_max5 = alpha*(3-bvts)*EXP(alpha*(3-bvts)*(max5/8.))*a_b/8.
1836             CALL POPCONTROL1B(branch)
1837             IF (branch .EQ. 0) THEN
1838               CALL POPREAL8(max5)
1839               a_y2 = a_max5
1840             ELSE
1841               CALL POPREAL8(max5)
1842               a_y2 = 0.0_8
1843             END IF
1844             CALL POPCONTROL1B(branch)
1845             IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y2
1846             CALL POPREAL8(a)
1847             a_max4 = alpha*EXP(alpha*(max4/2.))*a_a/2.
1848             CALL POPCONTROL1B(branch)
1849             IF (branch .EQ. 0) THEN
1850               CALL POPREAL8(max4)
1851               a_y1 = a_max4
1852             ELSE
1853               CALL POPREAL8(max4)
1854               a_y1 = 0.0_8
1855             END IF
1856             CALL POPCONTROL1B(branch)
1857             IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y1
1858             CALL POPREAL8(cpm(i, k))
1859             CALL A_CPMCAL0(q(i, k), a_q(i, k), a_cpm(i, k))
1860             a_cpm(i, k) = 0.0_8
1861           END IF
1862         END DO
1863       END DO
1864       DO k=kts,kte-1,1
1865         DO i=ite,its,-1
1866           CALL POPCONTROL1B(branch)
1867           IF (branch .NE. 0) THEN
1868             DO jj=3,1,-1
1869               CALL POPREAL8(qrs(i, k, jj))
1870               a_tmp2 = -a_qrs(i, k, jj)
1871               CALL POPCONTROL1B(branch)
1872               IF (branch .EQ. 0) a_tmp2 = 0.0_8
1873               CALL POPCONTROL1B(branch)
1874               IF (branch .EQ. 0) THEN
1875                 a_qrs(i, k, jj) = a_qrs(i, k, jj) + a_tmp2
1876               ELSE
1877                 temp3 = delz(i, k+1)/delz(i, k)
1878                 a_temp2 = dtcld*a_tmp2/den(i, k)
1879                 a_falk(i, k, jj) = a_falk(i, k, jj) + a_temp2
1880                 a_falk(i, k+1, jj) = a_falk(i, k+1, jj) - temp3*a_temp2
1881                 a_temp1 = -(falk(i, k+1, jj)*a_temp2/delz(i, k))
1882                 a_den(i, k) = a_den(i, k) - (falk(i, k, jj)-falk(i, k+1&
1883 &                 , jj)*temp3)*a_temp2/den(i, k)
1884                 a_delz(i, k+1) = a_delz(i, k+1) + a_temp1
1885                 a_delz(i, k) = a_delz(i, k) - temp3*a_temp1
1886               END IF
1887             END DO
1888             a_falk(i, k, 3) = a_falk(i, k, 3) + a_fall(i, k, 3)
1889             a_falk(i, k, 2) = a_falk(i, k, 2) + a_fall(i, k, 2)
1890             a_falk(i, k, 1) = a_falk(i, k, 1) + a_fall(i, k, 1)
1891             CALL POPREAL8(falk(i, k, 3))
1892             a_den(i, k) = a_den(i, k) + qrs(i, k, 3)*work1(i, k, 3)*&
1893 &             a_falk(i, k, 3)/mstep(i) + qrs(i, k, 2)*work1(i, k, 2)*&
1894 &             a_falk(i, k, 2)/mstep(i) + qrs(i, k, 1)*work1(i, k, 1)*&
1895 &             a_falk(i, k, 1)/mstep(i)
1896             a_temp2 = den(i, k)*a_falk(i, k, 3)/mstep(i)
1897             a_falk(i, k, 3) = 0.0_8
1898             a_qrs(i, k, 3) = a_qrs(i, k, 3) + work1(i, k, 3)*a_temp2
1899             a_work1(i, k, 3) = a_work1(i, k, 3) + qrs(i, k, 3)*a_temp2
1900             CALL POPREAL8(falk(i, k, 2))
1901             a_temp2 = den(i, k)*a_falk(i, k, 2)/mstep(i)
1902             a_falk(i, k, 2) = 0.0_8
1903             a_qrs(i, k, 2) = a_qrs(i, k, 2) + work1(i, k, 2)*a_temp2
1904             a_work1(i, k, 2) = a_work1(i, k, 2) + qrs(i, k, 2)*a_temp2
1905             CALL POPREAL8(falk(i, k, 1))
1906             a_temp2 = den(i, k)*a_falk(i, k, 1)/mstep(i)
1907             a_falk(i, k, 1) = 0.0_8
1908             a_qrs(i, k, 1) = a_qrs(i, k, 1) + work1(i, k, 1)*a_temp2
1909             a_work1(i, k, 1) = a_work1(i, k, 1) + qrs(i, k, 1)*a_temp2
1910           END IF
1911         END DO
1912       END DO
1913       CALL POPINTEGER4(k)
1914       DO i=ite,its,-1
1915         CALL POPCONTROL1B(branch)
1916         IF (branch .NE. 0) THEN
1917           DO jj=3,1,-1
1918             CALL POPREAL8(qrs(i, k, jj))
1919             a_tmp1 = -a_qrs(i, k, jj)
1920             CALL POPCONTROL1B(branch)
1921             IF (branch .EQ. 0) a_tmp1 = 0.0_8
1922             CALL POPCONTROL1B(branch)
1923             IF (branch .EQ. 0) THEN
1924               a_qrs(i, k, jj) = a_qrs(i, k, jj) + a_tmp1
1925               a_x1 = 0.0_8
1926             ELSE
1927               a_x1 = a_tmp1
1928             END IF
1929             a_temp2 = dtcld*a_x1/den(i, k)
1930             a_falk(i, k, jj) = a_falk(i, k, jj) + a_temp2
1931             a_den(i, k) = a_den(i, k) - falk(i, k, jj)*a_temp2/den(i, k)
1932           END DO
1933           a_falk(i, k, 3) = a_falk(i, k, 3) + a_fall(i, k, 3)
1934           a_falk(i, k, 2) = a_falk(i, k, 2) + a_fall(i, k, 2)
1935           a_falk(i, k, 1) = a_falk(i, k, 1) + a_fall(i, k, 1)
1936           CALL POPREAL8(falk(i, k, 3))
1937           a_den(i, k) = a_den(i, k) + qrs(i, k, 3)*work1(i, k, 3)*a_falk&
1938 &           (i, k, 3)/mstep(i) + qrs(i, k, 2)*work1(i, k, 2)*a_falk(i, k&
1939 &           , 2)/mstep(i) + qrs(i, k, 1)*work1(i, k, 1)*a_falk(i, k, 1)/&
1940 &           mstep(i)
1941           a_temp2 = den(i, k)*a_falk(i, k, 3)/mstep(i)
1942           a_falk(i, k, 3) = 0.0_8
1943           a_qrs(i, k, 3) = a_qrs(i, k, 3) + work1(i, k, 3)*a_temp2
1944           a_work1(i, k, 3) = a_work1(i, k, 3) + qrs(i, k, 3)*a_temp2
1945           CALL POPREAL8(falk(i, k, 2))
1946           a_temp2 = den(i, k)*a_falk(i, k, 2)/mstep(i)
1947           a_falk(i, k, 2) = 0.0_8
1948           a_qrs(i, k, 2) = a_qrs(i, k, 2) + work1(i, k, 2)*a_temp2
1949           a_work1(i, k, 2) = a_work1(i, k, 2) + qrs(i, k, 2)*a_temp2
1950           CALL POPREAL8(falk(i, k, 1))
1951           a_temp2 = den(i, k)*a_falk(i, k, 1)/mstep(i)
1952           a_falk(i, k, 1) = 0.0_8
1953           a_qrs(i, k, 1) = a_qrs(i, k, 1) + work1(i, k, 1)*a_temp2
1954           a_work1(i, k, 1) = a_work1(i, k, 1) + qrs(i, k, 1)*a_temp2
1955           CALL POPINTEGER4(k)
1956         END IF
1957       END DO
1958     END DO
1959     DO i=ite,its,-1
1960       CALL POPCONTROL1B(branch)
1961     END DO
1962     DO k=kts,kte,1
1963       DO i=ite,its,-1
1964         CALL POPCONTROL1B(branch)
1965         CALL POPCONTROL1B(branch)
1966         temp4 = bvtg/4.
1967         temp3 = max3**temp4/delz(i, k)
1968         temp2 = (bvtg-2.)/4.
1969         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp2 .EQ. 0.0_8 .OR. &
1970 &           temp2 .NE. INT(temp2)))) a_den(i, k) = a_den(i, k) + temp2*&
1971 &           den(i, k)**(temp2-1)*temp3*vt2g_a*a_work1(i, k, 3)
1972         a_temp1 = den(i, k)**temp2*vt2g_a*a_work1(i, k, 3)/delz(i, k)
1973         a_work1(i, k, 3) = 0.0_8
1974         IF (max3 .LE. 0.0_8 .AND. (temp4 .EQ. 0.0_8 .OR. temp4 .NE. INT(&
1975 &           temp4))) THEN
1976           a_max3 = 0.0_8
1977         ELSE
1978           a_max3 = temp4*max3**(temp4-1)*a_temp1
1979         END IF
1980         a_delz(i, k) = a_delz(i, k) - temp3*a_temp1
1981         CALL POPCONTROL1B(branch)
1982         IF (branch .EQ. 0) THEN
1983           CALL POPREAL8(max3)
1984           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max3
1985         ELSE
1986           CALL POPREAL8(max3)
1987         END IF
1988         temp1 = -(bvts*alpha*max8/4.)
1989         temp = bvts/4.
1990         temp2 = max2**temp/delz(i, k)
1991         temp3 = (bvts-2.)/4.
1992         temp4 = den(i, k)**temp3
1993         a_temp = EXP(temp1)*vt2s_a*a_work1(i, k, 2)
1994         a_max8 = -(bvts*alpha*EXP(temp1)*temp4*temp2*vt2s_a*a_work1(i, k&
1995 &         , 2)/4.)
1996         a_work1(i, k, 2) = 0.0_8
1997         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp3 .EQ. 0.0_8 .OR. &
1998 &           temp3 .NE. INT(temp3)))) a_den(i, k) = a_den(i, k) + temp3*&
1999 &           den(i, k)**(temp3-1)*temp2*a_temp
2000         a_temp0 = temp4*a_temp/delz(i, k)
2001         IF (max2 .LE. 0.0_8 .AND. (temp .EQ. 0.0_8 .OR. temp .NE. INT(&
2002 &           temp))) THEN
2003           a_max2 = 0.0_8
2004         ELSE
2005           a_max2 = temp*max2**(temp-1)*a_temp0
2006         END IF
2007         a_delz(i, k) = a_delz(i, k) - temp2*a_temp0
2008         CALL POPCONTROL1B(branch)
2009         IF (branch .EQ. 0) THEN
2010           CALL POPREAL8(max8)
2011           a_y3 = a_max8
2012         ELSE
2013           CALL POPREAL8(max8)
2014           a_y3 = 0.0_8
2015         END IF
2016         CALL POPCONTROL1B(branch)
2017         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y3
2018         CALL POPCONTROL1B(branch)
2019         IF (branch .EQ. 0) THEN
2020           CALL POPREAL8(max2)
2021           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max2
2022         ELSE
2023           CALL POPREAL8(max2)
2024         END IF
2025         temp = bvtr/4.
2026         temp0 = max1**temp/delz(i, k)
2027         temp1 = (bvtr-2.)/4.
2028         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp1 .EQ. 0.0_8 .OR. &
2029 &           temp1 .NE. INT(temp1)))) a_den(i, k) = a_den(i, k) + temp1*&
2030 &           den(i, k)**(temp1-1)*temp0*vt2r_a*a_work1(i, k, 1)
2031         a_temp = den(i, k)**temp1*vt2r_a*a_work1(i, k, 1)/delz(i, k)
2032         a_work1(i, k, 1) = 0.0_8
2033         IF (max1 .LE. 0.0_8 .AND. (temp .EQ. 0.0_8 .OR. temp .NE. INT(&
2034 &           temp))) THEN
2035           a_max1 = 0.0_8
2036         ELSE
2037           a_max1 = temp*max1**(temp-1)*a_temp
2038         END IF
2039         a_delz(i, k) = a_delz(i, k) - temp0*a_temp
2040         CALL POPCONTROL1B(branch)
2041         IF (branch .EQ. 0) THEN
2042           CALL POPREAL8(max1)
2043           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max1
2044         ELSE
2045           CALL POPREAL8(max1)
2046         END IF
2047       END DO
2048     END DO
2049   END SUBROUTINE A_FALLK
2050
2051 !=======================================================================
2052 !
2053 !=======================================================================
2054   SUBROUTINE FALLK(cpm, t, p, q, den, qrs, delz, dtcld, falk, fall, kte&
2055 &   , kts, its, ite, kme, kms, ims, ime)
2056     IMPLICIT NONE
2057     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
2058     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, falk, fall, work1
2059     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, p, q
2060     REAL, DIMENSION(its:ite, kts:kte) :: psmlt, pgmlt, t, work2, cpm
2061     INTEGER, DIMENSION(its:ite) :: mstep, numdt
2062     REAL :: dtcld, coeres1, coeres2, coeresi, coeresh, xlf, psmlt0, &
2063 &   pgmlt0, help_i, help_h, w1
2064     REAL :: tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7, tmp8
2065     INTEGER :: mstepmax, k, i, n, nw, jj
2066     REAL :: fqs, fqg, supcol, a, b, c, d
2067     INTRINSIC MAX
2068     INTRINSIC MIN
2069     INTRINSIC EXP
2070     INTRINSIC NINT
2071     INTRINSIC ABS
2072     INTRINSIC SQRT
2073     REAL :: x1
2074     REAL :: y1
2075     REAL :: y2
2076     REAL :: y3
2077     REAL :: max1
2078     REAL :: max2
2079     REAL :: max3
2080     REAL :: abs0
2081     REAL :: abs1
2082     REAL :: max4
2083     REAL :: max5
2084     REAL :: max6
2085     REAL :: abs2
2086     REAL :: max7
2087     REAL :: abs3
2088     REAL :: max8
2089     REAL :: max9
2090     REAL :: max10
2091     mstep = 1
2092     mstepmax = 1
2093     numdt = 1
2094     DO k=kte,kts,-1
2095       DO i=its,ite
2096         IF (qcrmin .LT. qrs(i, k, 1)) THEN
2097           max1 = qrs(i, k, 1)
2098         ELSE
2099           max1 = qcrmin
2100         END IF
2101         work1(i, k, 1) = vt2r_a*den(i, k)**((bvtr-2.)/4.)*max1**(bvtr/4.&
2102 &         )/delz(i, k)
2103         IF (qcrmin .LT. qrs(i, k, 2)) THEN
2104           max2 = qrs(i, k, 2)
2105         ELSE
2106           max2 = qcrmin
2107         END IF
2108         IF (90. .GT. t0c - t(i, k)) THEN
2109           y3 = t0c - t(i, k)
2110         ELSE
2111           y3 = 90.
2112         END IF
2113         IF (0. .LT. y3) THEN
2114           max8 = y3
2115         ELSE
2116           max8 = 0.
2117         END IF
2118         work1(i, k, 2) = vt2s_a*den(i, k)**((bvts-2.)/4.)*max2**(bvts/4.&
2119 &         )/delz(i, k)*EXP(-(bvts*alpha*max8/4.))
2120         IF (qcrmin .LT. qrs(i, k, 3)) THEN
2121           max3 = qrs(i, k, 3)
2122         ELSE
2123           max3 = qcrmin
2124         END IF
2125         work1(i, k, 3) = vt2g_a*den(i, k)**((bvtg-2.)/4.)*max3**(bvtg/4.&
2126 &         )/delz(i, k)
2127         IF (work1(i, k, 1) .GE. work1(i, k, 2) .AND. work1(i, k, 1) .GE.&
2128 &           work1(i, k, 3)) THEN
2129           w1 = work1(i, k, 1)
2130         ELSE IF (work1(i, k, 2) .GE. work1(i, k, 1) .AND. work1(i, k, 2)&
2131 &           .GE. work1(i, k, 3)) THEN
2132           w1 = work1(i, k, 2)
2133         ELSE
2134           w1 = work1(i, k, 3)
2135         END IF
2136         nw = NINT(w1*dtcld + .5)
2137         IF (nw .GT. 1) THEN
2138           numdt(i) = nw
2139         ELSE
2140           numdt(i) = 1
2141         END IF
2142         IF (numdt(i) .GE. mstep(i)) mstep(i) = numdt(i)
2143       END DO
2144     END DO
2145     DO i=its,ite
2146       IF (mstepmax .LE. mstep(i)) mstepmax = mstep(i)
2147     END DO
2148     DO n=1,mstepmax
2149       DO i=its,ite
2150         IF (n .LE. mstep(i)) THEN
2151           k = kte
2152           falk(i, k, 1) = den(i, k)*qrs(i, k, 1)*work1(i, k, 1)/mstep(i)
2153           falk(i, k, 2) = den(i, k)*qrs(i, k, 2)*work1(i, k, 2)/mstep(i)
2154           falk(i, k, 3) = den(i, k)*qrs(i, k, 3)*work1(i, k, 3)/mstep(i)
2155           fall(i, k, 1) = fall(i, k, 1) + falk(i, k, 1)
2156           fall(i, k, 2) = fall(i, k, 2) + falk(i, k, 2)
2157           fall(i, k, 3) = fall(i, k, 3) + falk(i, k, 3)
2158           DO jj=1,3
2159             x1 = falk(i, k, jj)*dtcld/den(i, k)
2160             IF (x1 .GT. qrs(i, k, jj)) THEN
2161               tmp1 = qrs(i, k, jj)
2162             ELSE
2163               tmp1 = x1
2164             END IF
2165             IF (tmp1 .GE. 0.) THEN
2166               abs0 = tmp1
2167             ELSE
2168               abs0 = -tmp1
2169             END IF
2170             IF (abs0 .LT. qmin) tmp1 = 0.
2171             qrs(i, k, jj) = qrs(i, k, jj) - tmp1
2172           END DO
2173         END IF
2174       END DO
2175       DO k=kte-1,kts,-1
2176         DO i=its,ite
2177           IF (n .LE. mstep(i)) THEN
2178             falk(i, k, 1) = den(i, k)*qrs(i, k, 1)*work1(i, k, 1)/mstep(&
2179 &             i)
2180             falk(i, k, 2) = den(i, k)*qrs(i, k, 2)*work1(i, k, 2)/mstep(&
2181 &             i)
2182             falk(i, k, 3) = den(i, k)*qrs(i, k, 3)*work1(i, k, 3)/mstep(&
2183 &             i)
2184             fall(i, k, 1) = fall(i, k, 1) + falk(i, k, 1)
2185             fall(i, k, 2) = fall(i, k, 2) + falk(i, k, 2)
2186             fall(i, k, 3) = fall(i, k, 3) + falk(i, k, 3)
2187             DO jj=1,3
2188               IF ((falk(i, k, jj)-falk(i, k+1, jj)*delz(i, k+1)/delz(i, &
2189 &                 k))*dtcld/den(i, k) .GT. qrs(i, k, jj)) THEN
2190                 tmp2 = qrs(i, k, jj)
2191               ELSE
2192                 tmp2 = (falk(i, k, jj)-falk(i, k+1, jj)*delz(i, k+1)/&
2193 &                 delz(i, k))*dtcld/den(i, k)
2194               END IF
2195               IF (tmp2 .GE. 0.) THEN
2196                 abs1 = tmp2
2197               ELSE
2198                 abs1 = -tmp2
2199               END IF
2200               IF (abs1 .LT. qmin) tmp2 = 0.
2201               qrs(i, k, jj) = qrs(i, k, jj) - tmp2
2202             END DO
2203           END IF
2204         END DO
2205       END DO
2206       DO k=kte,kts,-1
2207         DO i=its,ite
2208           IF (n .LE. mstep(i)) THEN
2209 !
2210 !---------------------------------------------------------------
2211 ! psmlt: melting of snow [RH83 A25]
2212 !       (T>T0: S->R) psmlt<0: min=-qrs(i,k,2), max=0
2213 !---------------------------------------------------------------
2214 !update xl, cpm
2215             cpm(i, k) = CPMCAL(q(i, k))
2216             xlf = xlf0
2217             IF (90. .GT. t0c - t(i, k)) THEN
2218               y1 = t0c - t(i, k)
2219             ELSE
2220               y1 = 90.
2221             END IF
2222             IF (0. .LT. y1) THEN
2223               max4 = y1
2224             ELSE
2225               max4 = 0.
2226             END IF
2227             a = EXP(alpha*max4/2.)
2228             IF (90. .GT. t0c - t(i, k)) THEN
2229               y2 = t0c - t(i, k)
2230             ELSE
2231               y2 = 90.
2232             END IF
2233             IF (0. .LT. y2) THEN
2234               max5 = y2
2235             ELSE
2236               max5 = 0.
2237             END IF
2238             b = EXP(alpha*max5*(3-bvts)/8.)
2239             c = t(i, k)**1.5*(t0c-t(i, k))/(t(i, k)+120.)
2240             d = t(i, k)**(3.88/6.)*(t0c-t(i, k))/(t(i, k)+120.)**(5./6.)
2241             IF (qrs(i, k, 2) .LT. qcrmin) THEN
2242               max6 = qcrmin
2243             ELSE
2244               max6 = qrs(i, k, 2)
2245             END IF
2246             IF (qrs(i, k, 2) .LT. qcrmin) THEN
2247               max9 = qcrmin
2248             ELSE
2249               max9 = qrs(i, k, 2)
2250             END IF
2251             psmlt0 = psmlt_a*a*c*SQRT(den(i, k)*max6) + psmlt_b*b*d*p(i&
2252 &             , k)**(1./3.)*den(i, k)**((13.+3*bvts)/24.)*max9**((5.+&
2253 &             bvts)/8.)
2254             tmp3 = psmlt0*dtcld/mstep(i)
2255             tmp4 = -(qrs(i, k, 2)/mstep(i))
2256             IF (tmp3 .GT. tmp4) THEN
2257               tmp5 = tmp3
2258             ELSE
2259               tmp5 = tmp4
2260             END IF
2261             IF (tmp5 .LT. 0.) THEN
2262               psmlt(i, k) = tmp5
2263             ELSE
2264               psmlt(i, k) = 0.
2265             END IF
2266             IF (psmlt(i, k) .GE. 0.) THEN
2267               abs2 = psmlt(i, k)
2268             ELSE
2269               abs2 = -psmlt(i, k)
2270             END IF
2271             IF (abs2 .LT. qmin) psmlt(i, k) = 0.
2272             IF (qrs(i, k, 2) + psmlt(i, k) .LT. 0.) THEN
2273               qrs(i, k, 2) = 0.
2274             ELSE
2275               qrs(i, k, 2) = qrs(i, k, 2) + psmlt(i, k)
2276             END IF
2277             IF (qrs(i, k, 1) - psmlt(i, k) .LT. 0.) THEN
2278               qrs(i, k, 1) = 0.
2279             ELSE
2280               qrs(i, k, 1) = qrs(i, k, 1) - psmlt(i, k)
2281             END IF
2282             t(i, k) = t(i, k) + xlf/cpm(i, k)*psmlt(i, k)
2283           END IF
2284         END DO
2285       END DO
2286 !---------------------------------------------------------------
2287 ! pgmlt: melting of graupel [LFO 47]
2288 !       (T>T0: G->R) pgmlt<0: min=-qrs(i,k,3), max=0
2289 !---------------------------------------------------------------
2290       DO k=kte,kts,-1
2291         DO i=its,ite
2292           IF (n .LE. mstep(i)) THEN
2293 !update xl, cpm
2294             xlf = xlf0
2295 !               cpm(i,k)=cpmcal(q(i,k)) ! not change
2296             c = t(i, k)**1.5*(t0c-t(i, k))/(t(i, k)+120.)
2297             d = t(i, k)**(3.88/6.)*(t0c-t(i, k))/(t(i, k)+120.)**(5./6.)
2298             IF (qrs(i, k, 3) .LT. qcrmin) THEN
2299               max7 = qcrmin
2300             ELSE
2301               max7 = qrs(i, k, 3)
2302             END IF
2303             IF (qrs(i, k, 3) .LT. qcrmin) THEN
2304               max10 = qcrmin
2305             ELSE
2306               max10 = qrs(i, k, 3)
2307             END IF
2308             pgmlt0 = pgmlt_a*c*SQRT(den(i, k)*max7) + pgmlt_b*d*p(i, k)&
2309 &             **(1./3.)*den(i, k)**((13.+3*bvtg)/24.)*max10**((5.+bvtg)/&
2310 &             8.)
2311             tmp6 = pgmlt0*dtcld/mstep(i)
2312             tmp7 = -(qrs(i, k, 3)/mstep(i))
2313             IF (tmp6 .GT. tmp7) THEN
2314               tmp8 = tmp6
2315             ELSE
2316               tmp8 = tmp7
2317             END IF
2318             IF (tmp8 .LT. 0.) THEN
2319               pgmlt(i, k) = tmp8
2320             ELSE
2321               pgmlt(i, k) = 0.
2322             END IF
2323             IF (pgmlt(i, k) .GE. 0.) THEN
2324               abs3 = pgmlt(i, k)
2325             ELSE
2326               abs3 = -pgmlt(i, k)
2327             END IF
2328             IF (abs3 .LT. qmin) pgmlt(i, k) = 0.
2329             IF (qrs(i, k, 3) + pgmlt(i, k) .LT. 0.) THEN
2330               qrs(i, k, 3) = 0.
2331             ELSE
2332               qrs(i, k, 3) = qrs(i, k, 3) + pgmlt(i, k)
2333             END IF
2334             IF (qrs(i, k, 1) - pgmlt(i, k) .LT. 0.) THEN
2335               qrs(i, k, 1) = 0.
2336             ELSE
2337               qrs(i, k, 1) = qrs(i, k, 1) - pgmlt(i, k)
2338             END IF
2339             t(i, k) = t(i, k) + xlf/cpm(i, k)*pgmlt(i, k)
2340           END IF
2341         END DO
2342       END DO
2343     END DO
2344   END SUBROUTINE FALLK
2345
2346 !  Differentiation of fallkc in reverse (adjoint) mode (with options r8):
2347 !   gradient     of useful results: fallc delz den qci
2348 !   with respect to varying inputs: fallc delz den qci
2349 !=======================================================================
2350 !
2351 !=======================================================================
2352   SUBROUTINE A_FALLKC(qci, a_qci, fallc, a_fallc, den, a_den, delz, &
2353 &   a_delz, dtcld, kte, kts, its, ite, kme, kms, ims, ime)
2354     IMPLICIT NONE
2355     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
2356     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
2357     REAL, DIMENSION(its:ite, kts:kte, 2) :: a_qci
2358     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den
2359     REAL, DIMENSION(ims:ime, kms:kme) :: a_delz, a_den
2360     REAL, DIMENSION(its:ite, kts:kte) :: falkc, work1c, work2c, xni, &
2361 &   fallc
2362     REAL, DIMENSION(its:ite, kts:kte) :: a_falkc, a_fallc
2363     INTEGER, DIMENSION(its:ite) :: mstep, numdt
2364     REAL :: dtcld, xmi, diameter, temp1, temp2, temp3, temp4, temp5, &
2365 &   temp0
2366     REAL :: a_temp3, a_temp4
2367     INTEGER :: mstepmax, k, i, n
2368     INTRINSIC NINT
2369     INTRINSIC MAX
2370     INTRINSIC MIN
2371     INTRINSIC ABS
2372     INTEGER :: x1
2373     REAL :: x2
2374     REAL :: a_x2
2375     REAL :: abs0
2376     REAL :: abs1
2377     REAL :: temp
2378     REAL :: temp6
2379     REAL :: a_temp
2380     REAL :: temp7
2381     REAL :: temp8
2382     REAL :: a_temp0
2383     REAL :: a_temp1
2384     INTEGER :: branch
2385     mstepmax = 1
2386     mstep = 1
2387     DO k=kte,kts,-1
2388       DO i=its,ite
2389         work1c(i, k) = vt2i_a*(den(i, k)*qci(i, k, 2))**(1.31/8.)
2390         work2c(i, k) = work1c(i, k)/delz(i, k)
2391         x1 = NINT(work2c(i, k)*dtcld + .5)
2392         IF (x1 .LT. 1) THEN
2393           numdt(i) = 1
2394         ELSE
2395           numdt(i) = x1
2396         END IF
2397         IF (numdt(i) .GE. mstep(i)) THEN
2398           CALL PUSHCONTROL1B(1)
2399           mstep(i) = numdt(i)
2400         ELSE
2401           CALL PUSHCONTROL1B(0)
2402         END IF
2403       END DO
2404     END DO
2405     DO i=its,ite
2406       IF (mstepmax .LE. mstep(i)) THEN
2407         CALL PUSHCONTROL1B(1)
2408         mstepmax = mstep(i)
2409       ELSE
2410         CALL PUSHCONTROL1B(0)
2411       END IF
2412     END DO
2413     DO n=1,mstepmax
2414       k = kte
2415       DO i=its,ite
2416         IF (n .LE. mstep(i)) THEN
2417           CALL PUSHREAL8(falkc(i, k))
2418           falkc(i, k) = falli_a*(den(i, k)*qci(i, k, 2))**(9.31/8.)/delz&
2419 &           (i, k)/mstep(i)
2420           x2 = falkc(i, k)*dtcld/den(i, k)
2421           IF (x2 .GT. qci(i, k, 2)) THEN
2422             temp3 = qci(i, k, 2)
2423             CALL PUSHCONTROL1B(0)
2424           ELSE
2425             temp3 = x2
2426             CALL PUSHCONTROL1B(1)
2427           END IF
2428           IF (temp3 .GE. 0.) THEN
2429             abs0 = temp3
2430           ELSE
2431             abs0 = -temp3
2432           END IF
2433           IF (abs0 .LT. qmin) THEN
2434             temp3 = 0.
2435             CALL PUSHCONTROL1B(0)
2436           ELSE
2437             CALL PUSHCONTROL1B(1)
2438           END IF
2439           CALL PUSHREAL8(qci(i, k, 2))
2440           qci(i, k, 2) = qci(i, k, 2) - temp3
2441           CALL PUSHCONTROL1B(1)
2442         ELSE
2443           CALL PUSHCONTROL1B(0)
2444         END IF
2445       END DO
2446       CALL PUSHINTEGER4(k)
2447       DO k=kte-1,kts,-1
2448         DO i=its,ite
2449           IF (n .LE. mstep(i)) THEN
2450             CALL PUSHREAL8(falkc(i, k))
2451             falkc(i, k) = falli_a*(den(i, k)*qci(i, k, 2))**(9.31/8.)/&
2452 &             delz(i, k)/mstep(i)
2453             IF ((falkc(i, k)-falkc(i, k+1)*delz(i, k+1)/delz(i, k))*&
2454 &               dtcld/den(i, k) .GT. qci(i, k, 2)) THEN
2455               temp4 = qci(i, k, 2)
2456               CALL PUSHCONTROL1B(0)
2457             ELSE
2458               temp4 = (falkc(i, k)-falkc(i, k+1)*delz(i, k+1)/delz(i, k)&
2459 &               )*dtcld/den(i, k)
2460               CALL PUSHCONTROL1B(1)
2461             END IF
2462             IF (temp4 .GE. 0.) THEN
2463               abs1 = temp4
2464             ELSE
2465               abs1 = -temp4
2466             END IF
2467             IF (abs1 .LT. qmin) THEN
2468               temp4 = 0.
2469               CALL PUSHCONTROL1B(0)
2470             ELSE
2471               CALL PUSHCONTROL1B(1)
2472             END IF
2473             CALL PUSHREAL8(qci(i, k, 2))
2474             qci(i, k, 2) = qci(i, k, 2) - temp4
2475             CALL PUSHCONTROL1B(1)
2476           ELSE
2477             CALL PUSHCONTROL1B(0)
2478           END IF
2479         END DO
2480       END DO
2481     END DO
2482     a_falkc = 0.0_8
2483     DO n=mstepmax,1,-1
2484       DO k=kts,kte-1,1
2485         DO i=ite,its,-1
2486           CALL POPCONTROL1B(branch)
2487           IF (branch .NE. 0) THEN
2488             CALL POPREAL8(qci(i, k, 2))
2489             a_temp4 = -a_qci(i, k, 2)
2490             CALL POPCONTROL1B(branch)
2491             IF (branch .EQ. 0) a_temp4 = 0.0_8
2492             CALL POPCONTROL1B(branch)
2493             IF (branch .EQ. 0) THEN
2494               a_qci(i, k, 2) = a_qci(i, k, 2) + a_temp4
2495             ELSE
2496               temp7 = falkc(i, k+1)/delz(i, k)
2497               a_temp1 = dtcld*a_temp4/den(i, k)
2498               a_falkc(i, k) = a_falkc(i, k) + a_temp1
2499               a_temp0 = -(delz(i, k+1)*a_temp1/delz(i, k))
2500               a_delz(i, k+1) = a_delz(i, k+1) - temp7*a_temp1
2501               a_den(i, k) = a_den(i, k) - (falkc(i, k)-temp7*delz(i, k+1&
2502 &               ))*a_temp1/den(i, k)
2503               a_falkc(i, k+1) = a_falkc(i, k+1) + a_temp0
2504               a_delz(i, k) = a_delz(i, k) - temp7*a_temp0
2505             END IF
2506             a_falkc(i, k) = a_falkc(i, k) + a_fallc(i, k)
2507             CALL POPREAL8(falkc(i, k))
2508             temp8 = mstep(i)*delz(i, k)
2509             temp6 = den(i, k)*qci(i, k, 2)
2510             temp = 9.31/8.
2511             a_temp0 = falli_a*a_falkc(i, k)/temp8
2512             a_falkc(i, k) = 0.0_8
2513             IF (temp6 .LE. 0.0_8 .AND. (temp .EQ. 0.0_8 .OR. temp .NE. &
2514 &               INT(temp))) THEN
2515               a_temp = 0.0_8
2516             ELSE
2517               a_temp = temp*temp6**(temp-1)*a_temp0
2518             END IF
2519             a_delz(i, k) = a_delz(i, k) - mstep(i)*temp6**temp*a_temp0/&
2520 &             temp8
2521             a_den(i, k) = a_den(i, k) + qci(i, k, 2)*a_temp
2522             a_qci(i, k, 2) = a_qci(i, k, 2) + den(i, k)*a_temp
2523           END IF
2524         END DO
2525       END DO
2526       CALL POPINTEGER4(k)
2527       DO i=ite,its,-1
2528         CALL POPCONTROL1B(branch)
2529         IF (branch .NE. 0) THEN
2530           CALL POPREAL8(qci(i, k, 2))
2531           a_temp3 = -a_qci(i, k, 2)
2532           CALL POPCONTROL1B(branch)
2533           IF (branch .EQ. 0) a_temp3 = 0.0_8
2534           CALL POPCONTROL1B(branch)
2535           IF (branch .EQ. 0) THEN
2536             a_qci(i, k, 2) = a_qci(i, k, 2) + a_temp3
2537             a_x2 = 0.0_8
2538           ELSE
2539             a_x2 = a_temp3
2540           END IF
2541           a_temp1 = dtcld*a_x2/den(i, k)
2542           a_falkc(i, k) = a_falkc(i, k) + a_temp1 + a_fallc(i, k)
2543           temp = mstep(i)*delz(i, k)
2544           temp7 = den(i, k)*qci(i, k, 2)
2545           temp8 = 9.31/8.
2546           a_temp = falli_a*a_falkc(i, k)/temp
2547           a_falkc(i, k) = 0.0_8
2548           IF (temp7 .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. temp8 .NE. &
2549 &             INT(temp8))) THEN
2550             a_temp0 = 0.0_8
2551           ELSE
2552             a_temp0 = temp8*temp7**(temp8-1)*a_temp
2553           END IF
2554           a_den(i, k) = a_den(i, k) + qci(i, k, 2)*a_temp0 - falkc(i, k)&
2555 &           *a_temp1/den(i, k)
2556           CALL POPREAL8(falkc(i, k))
2557           a_delz(i, k) = a_delz(i, k) - mstep(i)*temp7**temp8*a_temp/&
2558 &           temp
2559           a_qci(i, k, 2) = a_qci(i, k, 2) + den(i, k)*a_temp0
2560         END IF
2561       END DO
2562     END DO
2563     DO i=ite,its,-1
2564       CALL POPCONTROL1B(branch)
2565     END DO
2566     DO k=kts,kte,1
2567       DO i=ite,its,-1
2568         CALL POPCONTROL1B(branch)
2569       END DO
2570     END DO
2571   END SUBROUTINE A_FALLKC
2572
2573 !=======================================================================
2574 !
2575 !=======================================================================
2576   SUBROUTINE FALLKC(qci, fallc, den, delz, dtcld, kte, kts, its, ite, &
2577 &   kme, kms, ims, ime)
2578     IMPLICIT NONE
2579     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
2580     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
2581     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den
2582     REAL, DIMENSION(its:ite, kts:kte) :: falkc, work1c, work2c, xni, &
2583 &   fallc
2584     INTEGER, DIMENSION(its:ite) :: mstep, numdt
2585     REAL :: dtcld, xmi, diameter, temp1, temp2, temp3, temp4, temp5, &
2586 &   temp0
2587     INTEGER :: mstepmax, k, i, n
2588     INTRINSIC NINT
2589     INTRINSIC MAX
2590     INTRINSIC MIN
2591     INTRINSIC ABS
2592     INTEGER :: x1
2593     REAL :: x2
2594     REAL :: abs0
2595     REAL :: abs1
2596     mstepmax = 1
2597     mstep = 1
2598     numdt = 1
2599     DO k=kte,kts,-1
2600       DO i=its,ite
2601         work1c(i, k) = vt2i_a*(den(i, k)*qci(i, k, 2))**(1.31/8.)
2602         work2c(i, k) = work1c(i, k)/delz(i, k)
2603         x1 = NINT(work2c(i, k)*dtcld + .5)
2604         IF (x1 .LT. 1) THEN
2605           numdt(i) = 1
2606         ELSE
2607           numdt(i) = x1
2608         END IF
2609         IF (numdt(i) .GE. mstep(i)) mstep(i) = numdt(i)
2610       END DO
2611     END DO
2612     DO i=its,ite
2613       IF (mstepmax .LE. mstep(i)) mstepmax = mstep(i)
2614     END DO
2615     DO n=1,mstepmax
2616       k = kte
2617       DO i=its,ite
2618         IF (n .LE. mstep(i)) THEN
2619           falkc(i, k) = falli_a*(den(i, k)*qci(i, k, 2))**(9.31/8.)/delz&
2620 &           (i, k)/mstep(i)
2621           fallc(i, k) = fallc(i, k) + falkc(i, k)
2622           x2 = falkc(i, k)*dtcld/den(i, k)
2623           IF (x2 .GT. qci(i, k, 2)) THEN
2624             temp3 = qci(i, k, 2)
2625           ELSE
2626             temp3 = x2
2627           END IF
2628           IF (temp3 .GE. 0.) THEN
2629             abs0 = temp3
2630           ELSE
2631             abs0 = -temp3
2632           END IF
2633           IF (abs0 .LT. qmin) temp3 = 0.
2634           qci(i, k, 2) = qci(i, k, 2) - temp3
2635         END IF
2636       END DO
2637       DO k=kte-1,kts,-1
2638         DO i=its,ite
2639           IF (n .LE. mstep(i)) THEN
2640             falkc(i, k) = falli_a*(den(i, k)*qci(i, k, 2))**(9.31/8.)/&
2641 &             delz(i, k)/mstep(i)
2642             fallc(i, k) = fallc(i, k) + falkc(i, k)
2643             IF ((falkc(i, k)-falkc(i, k+1)*delz(i, k+1)/delz(i, k))*&
2644 &               dtcld/den(i, k) .GT. qci(i, k, 2)) THEN
2645               temp4 = qci(i, k, 2)
2646             ELSE
2647               temp4 = (falkc(i, k)-falkc(i, k+1)*delz(i, k+1)/delz(i, k)&
2648 &               )*dtcld/den(i, k)
2649             END IF
2650             IF (temp4 .GE. 0.) THEN
2651               abs1 = temp4
2652             ELSE
2653               abs1 = -temp4
2654             END IF
2655             IF (abs1 .LT. qmin) temp4 = 0.
2656             qci(i, k, 2) = qci(i, k, 2) - temp4
2657           END IF
2658         END DO
2659       END DO
2660     END DO
2661   END SUBROUTINE FALLKC
2662
2663 !  Differentiation of rainsc in reverse (adjoint) mode (with options r8):
2664 !   gradient     of useful results: fallc t cpm xl delz den qrs
2665 !                fall rain qci rainncv
2666 !   with respect to varying inputs: fallc t cpm xl delz den qrs
2667 !                fall rain qci rainncv
2668 !=======================================================================
2669 !
2670 !=======================================================================
2671   SUBROUTINE A_RAINSC(fall, a_fall, fallc, a_fallc, xl, a_xl, t, a_t, q&
2672 &   , qci, a_qci, cpm, a_cpm, den, a_den, qrs, a_qrs, delz, a_delz, rain&
2673 &   , a_rain, rainncv, a_rainncv, dtcld, kte, kts, its, ite, kme, kms, &
2674 &   ims, ime)
2675     IMPLICIT NONE
2676     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
2677     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, fall
2678     REAL, DIMENSION(its:ite, kts:kte, 3) :: a_qrs, a_fall
2679     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
2680     REAL, DIMENSION(its:ite, kts:kte, 2) :: a_qci
2681     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, q
2682     REAL, DIMENSION(ims:ime, kms:kme) :: a_delz, a_den
2683     REAL, DIMENSION(its:ite, kts:kte) :: xl, t, cpm, fallc
2684     REAL, DIMENSION(its:ite, kts:kte) :: a_xl, a_t, a_cpm, a_fallc
2685     REAL, DIMENSION(ims:ime) :: rain, rainncv
2686     REAL, DIMENSION(ims:ime) :: a_rain, a_rainncv
2687     INTEGER :: k, i
2688     REAL :: dtcld, fallsum, supcol, xlf, temp, temp0, pfrzdtr, pfrzdtc
2689     REAL :: a_fallsum, a_supcol, a_xlf, a_temp, a_pfrzdtr, a_pfrzdtc
2690     REAL :: ft0, ft40, fsupcol, fqc, fqi, fqr, qtmp
2691     REAL :: a_ft0, a_ft40, a_qtmp
2692     INTRINSIC MAX
2693     INTRINSIC ABS
2694     INTRINSIC EXP
2695     INTRINSIC MIN
2696     REAL :: x1
2697     REAL :: a_x1
2698     REAL :: max1
2699     REAL :: a_max1
2700     REAL :: abs0
2701     REAL :: abs1
2702     REAL :: abs2
2703     REAL :: abs3
2704     REAL :: temp1
2705     REAL :: a_temp0
2706     REAL :: arg0
2707     REAL :: a_arg0
2708     REAL :: temp2
2709     REAL :: temp3
2710     REAL :: temp4
2711     REAL :: a_temp1
2712     REAL :: a_temp2
2713     REAL :: temp5
2714     REAL :: a_temp3
2715     INTEGER :: branch
2716     DO i=its,ite
2717       fallsum = fall(i, kts, 1) + fall(i, kts, 2) + fall(i, kts, 3) + &
2718 &       fallc(i, kts)
2719       IF (fallsum .GT. qmin) THEN
2720         CALL PUSHCONTROL1B(1)
2721       ELSE
2722         CALL PUSHCONTROL1B(0)
2723       END IF
2724     END DO
2725     DO k=kts,kte
2726       DO i=its,ite
2727 !---------------------------------------------------------------
2728 ! pimlt: instantaneous melting of cloud ice [RH83 A28]
2729 !       (T>T0: I->C) pimlt=qci(i,k,2) t-
2730 !---------------------------------------------------------------
2731 !update xl, cpm
2732         xl(i, k) = XLCAL(t(i, k))
2733 !         cpm(i,k)=cpmcal(q(i,k)) !not change
2734         CALL PUSHREAL8(xlf)
2735         xlf = xls - xl(i, k)
2736         supcol = t0c - t(i, k)
2737         IF (supcol .LT. 0.) THEN
2738           xlf = xlf0
2739           CALL PUSHCONTROL1B(1)
2740         ELSE
2741           CALL PUSHCONTROL1B(0)
2742         END IF
2743         CALL PUSHREAL8(ft0)
2744         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
2745         IF (qci(i, k, 2) .LT. 0.) THEN
2746           CALL PUSHREAL8(max1)
2747           max1 = 0.
2748           CALL PUSHCONTROL1B(0)
2749         ELSE
2750           CALL PUSHREAL8(max1)
2751           max1 = qci(i, k, 2)
2752           CALL PUSHCONTROL1B(1)
2753         END IF
2754         CALL PUSHREAL8(qtmp)
2755         qtmp = ft0*max1
2756         IF (qtmp .GE. 0.) THEN
2757           abs0 = qtmp
2758         ELSE
2759           abs0 = -qtmp
2760         END IF
2761         IF (abs0 .LT. qmin) THEN
2762           qtmp = 0.
2763           CALL PUSHCONTROL1B(1)
2764         ELSE
2765           CALL PUSHCONTROL1B(0)
2766         END IF
2767         IF (qci(i, k, 1) + qtmp .LT. 0.) THEN
2768           qci(i, k, 1) = 0.
2769           CALL PUSHCONTROL1B(0)
2770         ELSE
2771           qci(i, k, 1) = qci(i, k, 1) + qtmp
2772           CALL PUSHCONTROL1B(1)
2773         END IF
2774         IF (qci(i, k, 2) - qtmp .LT. 0.) THEN
2775           qci(i, k, 2) = 0.
2776           CALL PUSHCONTROL1B(0)
2777         ELSE
2778           qci(i, k, 2) = qci(i, k, 2) - qtmp
2779           CALL PUSHCONTROL1B(1)
2780         END IF
2781         CALL PUSHREAL8(t(i, k))
2782         t(i, k) = t(i, k) - xlf/cpm(i, k)*qtmp
2783 !---------------------------------------------------------------
2784 ! pihmf: homogeneous freezing of cloud water below -40c
2785 !        (T<-40C: C->I) min=0,pihmf=qci(i,k,1) t+
2786 !---------------------------------------------------------------
2787 !update xl, cpm
2788         xl(i, k) = XLCAL(t(i, k))
2789 !         cpm(i,k)=cpmcal(q(i,k)) !not change
2790         CALL PUSHREAL8(xlf)
2791         xlf = xls - xl(i, k)
2792         supcol = t0c - t(i, k)
2793         IF (supcol .LT. 0.) THEN
2794           xlf = xlf0
2795           CALL PUSHCONTROL1B(1)
2796         ELSE
2797           CALL PUSHCONTROL1B(0)
2798         END IF
2799         CALL PUSHREAL8(ft40)
2800         CALL SMOOTHIF(supcol, 40., ft40, 't0')
2801         IF (ft40*qci(i, k, 1) .LT. 0.) THEN
2802           CALL PUSHREAL8(qtmp)
2803           qtmp = 0.
2804           CALL PUSHCONTROL1B(0)
2805         ELSE
2806           CALL PUSHREAL8(qtmp)
2807           qtmp = ft40*qci(i, k, 1)
2808           CALL PUSHCONTROL1B(1)
2809         END IF
2810         IF (qtmp .GE. 0.) THEN
2811           abs1 = qtmp
2812         ELSE
2813           abs1 = -qtmp
2814         END IF
2815 !update qc, qi, t
2816         IF (abs1 .LT. qmin) THEN
2817           qtmp = 0.
2818           CALL PUSHCONTROL1B(1)
2819         ELSE
2820           CALL PUSHCONTROL1B(0)
2821         END IF
2822         IF (qci(i, k, 2) + qtmp .LT. 0.) THEN
2823           CALL PUSHREAL8(qci(i, k, 2))
2824           qci(i, k, 2) = 0.
2825           CALL PUSHCONTROL1B(0)
2826         ELSE
2827           CALL PUSHREAL8(qci(i, k, 2))
2828           qci(i, k, 2) = qci(i, k, 2) + qtmp
2829           CALL PUSHCONTROL1B(1)
2830         END IF
2831         IF (qci(i, k, 1) - qtmp .LT. 0.) THEN
2832           CALL PUSHREAL8(qci(i, k, 1))
2833           qci(i, k, 1) = 0.
2834           CALL PUSHCONTROL1B(0)
2835         ELSE
2836           CALL PUSHREAL8(qci(i, k, 1))
2837           qci(i, k, 1) = qci(i, k, 1) - qtmp
2838           CALL PUSHCONTROL1B(1)
2839         END IF
2840         t(i, k) = t(i, k) + xlf/cpm(i, k)*qtmp
2841 !---------------------------------------------------------------
2842 ! pihtf: heterogeneous freezing of cloud water
2843 !        (T0>T>-40C: C->I) max=qci(i,k,1),min=0. t+
2844 !---------------------------------------------------------------
2845 !update xl, cpm
2846         xl(i, k) = XLCAL(t(i, k))
2847 !         cpm(i,k)=cpmcal(q(i,k)) !not change
2848         CALL PUSHREAL8(xlf)
2849         xlf = xls - xl(i, k)
2850         CALL PUSHREAL8(supcol)
2851         supcol = t0c - t(i, k)
2852         IF (supcol .LT. 0.) THEN
2853           xlf = xlf0
2854           CALL PUSHCONTROL1B(1)
2855         ELSE
2856           CALL PUSHCONTROL1B(0)
2857         END IF
2858 !t>-40C=t0c-40,t0c-t<40, supcol<40,-supcol>-40
2859         arg0 = -supcol
2860         CALL PUSHREAL8(ft40)
2861         CALL SMOOTHIF(arg0, -40., ft40, 't0')
2862         x1 = pfrz1*(EXP(pfrz2*supcol)-1.)*den(i, k)/denr/xncr*qci(i, k, &
2863 &         1)*qci(i, k, 1)*dtcld
2864         IF (x1 .GT. qci(i, k, 1)) THEN
2865           CALL PUSHREAL8(pfrzdtc)
2866           pfrzdtc = qci(i, k, 1)
2867           CALL PUSHCONTROL1B(0)
2868         ELSE
2869           CALL PUSHREAL8(pfrzdtc)
2870           pfrzdtc = x1
2871           CALL PUSHCONTROL1B(1)
2872         END IF
2873         IF (ft40*pfrzdtc .LT. 0.) THEN
2874           CALL PUSHREAL8(qtmp)
2875           qtmp = 0.
2876           CALL PUSHCONTROL1B(0)
2877         ELSE
2878           CALL PUSHREAL8(qtmp)
2879           qtmp = ft40*pfrzdtc
2880           CALL PUSHCONTROL1B(1)
2881         END IF
2882         IF (qtmp .GE. 0.) THEN
2883           abs2 = qtmp
2884         ELSE
2885           abs2 = -qtmp
2886         END IF
2887 !update qc, qi, t
2888         IF (abs2 .LT. qmin) THEN
2889           qtmp = 0.
2890           CALL PUSHCONTROL1B(1)
2891         ELSE
2892           CALL PUSHCONTROL1B(0)
2893         END IF
2894         IF (qci(i, k, 2) + qtmp .LT. 0.) THEN
2895           CALL PUSHREAL8(qci(i, k, 2))
2896           qci(i, k, 2) = 0.
2897           CALL PUSHCONTROL1B(0)
2898         ELSE
2899           CALL PUSHREAL8(qci(i, k, 2))
2900           qci(i, k, 2) = qci(i, k, 2) + qtmp
2901           CALL PUSHCONTROL1B(1)
2902         END IF
2903         IF (qci(i, k, 1) - qtmp .LT. 0.) THEN
2904           CALL PUSHCONTROL1B(0)
2905         ELSE
2906           CALL PUSHCONTROL1B(1)
2907         END IF
2908         t(i, k) = t(i, k) + xlf/cpm(i, k)*qtmp
2909 !---------------------------------------------------------------
2910 ! pgfrz: freezing of rain water [LFO 45]
2911 !        (T<T0, R->G) max=qrs(i,k,1),min=0. t+
2912 !---------------------------------------------------------------
2913 !update xl, cpm
2914         xl(i, k) = XLCAL(t(i, k))
2915 !         cpm(i,k)=cpmcal(q(i,k))!not change
2916         CALL PUSHREAL8(xlf)
2917         xlf = xls - xl(i, k)
2918         CALL PUSHREAL8(supcol)
2919         supcol = t0c - t(i, k)
2920         IF (supcol .LT. 0.) THEN
2921           xlf = xlf0
2922           CALL PUSHCONTROL1B(0)
2923         ELSE
2924           CALL PUSHCONTROL1B(1)
2925         END IF
2926         IF (qrs(i, k, 1) .GT. 0.) THEN
2927           temp = pgfrz_a*(EXP(pfrz2*supcol)-1.)*den(i, k)**(3./4.)*qrs(i&
2928 &           , k, 1)**(7./4.)
2929           CALL PUSHCONTROL1B(1)
2930         ELSE
2931           temp = 0.
2932           CALL PUSHCONTROL1B(0)
2933         END IF
2934         IF (temp*dtcld .GT. qrs(i, k, 1)) THEN
2935           pfrzdtr = qrs(i, k, 1)
2936           CALL PUSHCONTROL1B(0)
2937         ELSE
2938           pfrzdtr = temp*dtcld
2939           CALL PUSHCONTROL1B(1)
2940         END IF
2941         IF (pfrzdtr .LT. 0.) THEN
2942           CALL PUSHREAL8(qtmp)
2943           qtmp = 0.
2944           CALL PUSHCONTROL1B(0)
2945         ELSE
2946           CALL PUSHREAL8(qtmp)
2947           qtmp = pfrzdtr
2948           CALL PUSHCONTROL1B(1)
2949         END IF
2950         IF (qtmp .GE. 0.) THEN
2951           abs3 = qtmp
2952         ELSE
2953           abs3 = -qtmp
2954         END IF
2955         IF (abs3 .LT. qmin) THEN
2956           qtmp = 0.
2957           CALL PUSHCONTROL1B(1)
2958         ELSE
2959           CALL PUSHCONTROL1B(0)
2960         END IF
2961         IF (qrs(i, k, 3) + qtmp .LT. 0.) THEN
2962           CALL PUSHREAL8(qrs(i, k, 3))
2963           qrs(i, k, 3) = 0.
2964           CALL PUSHCONTROL1B(0)
2965         ELSE
2966           CALL PUSHREAL8(qrs(i, k, 3))
2967           qrs(i, k, 3) = qrs(i, k, 3) + qtmp
2968           CALL PUSHCONTROL1B(1)
2969         END IF
2970         IF (qrs(i, k, 1) - qtmp .LT. 0.) THEN
2971           CALL PUSHCONTROL1B(0)
2972         ELSE
2973           CALL PUSHCONTROL1B(1)
2974         END IF
2975       END DO
2976     END DO
2977     DO k=kte,kts,-1
2978       DO i=ite,its,-1
2979         a_temp3 = a_t(i, k)/cpm(i, k)
2980         a_xlf = qtmp*a_temp3
2981         a_qtmp = xlf*a_temp3
2982         a_cpm(i, k) = a_cpm(i, k) - xlf*qtmp*a_temp3/cpm(i, k)
2983         CALL POPCONTROL1B(branch)
2984         IF (branch .EQ. 0) THEN
2985           a_qrs(i, k, 1) = 0.0_8
2986         ELSE
2987           a_qtmp = a_qtmp - a_qrs(i, k, 1)
2988         END IF
2989         CALL POPCONTROL1B(branch)
2990         IF (branch .EQ. 0) THEN
2991           CALL POPREAL8(qrs(i, k, 3))
2992           a_qrs(i, k, 3) = 0.0_8
2993         ELSE
2994           CALL POPREAL8(qrs(i, k, 3))
2995           a_qtmp = a_qtmp + a_qrs(i, k, 3)
2996         END IF
2997         CALL POPCONTROL1B(branch)
2998         IF (branch .NE. 0) a_qtmp = 0.0_8
2999         CALL POPCONTROL1B(branch)
3000         IF (branch .EQ. 0) THEN
3001           CALL POPREAL8(qtmp)
3002           a_pfrzdtr = 0.0_8
3003         ELSE
3004           CALL POPREAL8(qtmp)
3005           a_pfrzdtr = a_qtmp
3006         END IF
3007         CALL POPCONTROL1B(branch)
3008         IF (branch .EQ. 0) THEN
3009           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_pfrzdtr
3010           a_temp = 0.0_8
3011         ELSE
3012           a_temp = dtcld*a_pfrzdtr
3013         END IF
3014         CALL POPCONTROL1B(branch)
3015         IF (branch .EQ. 0) THEN
3016           a_supcol = 0.0_8
3017         ELSE
3018           supcol = t0c - t(i, k)
3019           temp4 = 7./4.
3020           temp2 = 3./4.
3021           temp1 = den(i, k)**temp2
3022           temp5 = EXP(pfrz2*supcol) - 1.
3023           a_temp2 = qrs(i, k, 1)**temp4*pgfrz_a*a_temp
3024           IF (.NOT.(qrs(i, k, 1) .LE. 0.0_8 .AND. (temp4 .EQ. 0.0_8 .OR.&
3025 &             temp4 .NE. INT(temp4)))) a_qrs(i, k, 1) = a_qrs(i, k, 1) +&
3026 &             temp4*qrs(i, k, 1)**(temp4-1)*temp5*temp1*pgfrz_a*a_temp
3027           a_supcol = pfrz2*EXP(pfrz2*supcol)*temp1*a_temp2
3028           IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp2 .EQ. 0.0_8 .OR. &
3029 &             temp2 .NE. INT(temp2)))) a_den(i, k) = a_den(i, k) + temp2&
3030 &             *den(i, k)**(temp2-1)*temp5*a_temp2
3031         END IF
3032         CALL POPCONTROL1B(branch)
3033         IF (branch .EQ. 0) a_xlf = 0.0_8
3034         CALL POPREAL8(supcol)
3035         a_t(i, k) = a_t(i, k) - a_supcol
3036         CALL POPREAL8(xlf)
3037         a_xl(i, k) = a_xl(i, k) - a_xlf
3038         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
3039         a_xl(i, k) = 0.0_8
3040         a_temp1 = a_t(i, k)/cpm(i, k)
3041         a_xlf = qtmp*a_temp1
3042         a_qtmp = xlf*a_temp1
3043         a_cpm(i, k) = a_cpm(i, k) - xlf*qtmp*a_temp1/cpm(i, k)
3044         CALL POPCONTROL1B(branch)
3045         IF (branch .EQ. 0) THEN
3046           a_qci(i, k, 1) = 0.0_8
3047         ELSE
3048           a_qtmp = a_qtmp - a_qci(i, k, 1)
3049         END IF
3050         CALL POPCONTROL1B(branch)
3051         IF (branch .EQ. 0) THEN
3052           CALL POPREAL8(qci(i, k, 2))
3053           a_qci(i, k, 2) = 0.0_8
3054         ELSE
3055           CALL POPREAL8(qci(i, k, 2))
3056           a_qtmp = a_qtmp + a_qci(i, k, 2)
3057         END IF
3058         CALL POPCONTROL1B(branch)
3059         IF (branch .NE. 0) a_qtmp = 0.0_8
3060         CALL POPCONTROL1B(branch)
3061         IF (branch .EQ. 0) THEN
3062           CALL POPREAL8(qtmp)
3063           a_ft40 = 0.0_8
3064           a_pfrzdtc = 0.0_8
3065         ELSE
3066           CALL POPREAL8(qtmp)
3067           a_ft40 = pfrzdtc*a_qtmp
3068           a_pfrzdtc = ft40*a_qtmp
3069         END IF
3070         CALL POPCONTROL1B(branch)
3071         IF (branch .EQ. 0) THEN
3072           CALL POPREAL8(pfrzdtc)
3073           a_qci(i, k, 1) = a_qci(i, k, 1) + a_pfrzdtc
3074           a_x1 = 0.0_8
3075         ELSE
3076           CALL POPREAL8(pfrzdtc)
3077           a_x1 = a_pfrzdtc
3078         END IF
3079         temp2 = den(i, k)/(denr*xncr)
3080         temp3 = qci(i, k, 1)
3081         a_temp0 = pfrz1*dtcld*a_x1
3082         a_supcol = pfrz2*EXP(pfrz2*supcol)*temp3**2*temp2*a_temp0
3083         a_temp1 = (EXP(pfrz2*supcol)-1.)*a_temp0
3084         a_qci(i, k, 1) = a_qci(i, k, 1) + 2*temp3*temp2*a_temp1
3085         a_den(i, k) = a_den(i, k) + temp3**2*a_temp1/(denr*xncr)
3086         CALL POPREAL8(ft40)
3087         a_arg0 = 0.0_8
3088         CALL A_SMOOTHIF(arg0, a_arg0, -40., ft40, a_ft40, 't0')
3089         a_supcol = a_supcol - a_arg0
3090         CALL POPCONTROL1B(branch)
3091         IF (branch .NE. 0) a_xlf = 0.0_8
3092         CALL POPREAL8(supcol)
3093         a_t(i, k) = a_t(i, k) - a_supcol
3094         CALL POPREAL8(xlf)
3095         a_xl(i, k) = a_xl(i, k) - a_xlf
3096         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
3097         a_xl(i, k) = 0.0_8
3098         a_temp0 = a_t(i, k)/cpm(i, k)
3099         a_xlf = qtmp*a_temp0
3100         a_qtmp = xlf*a_temp0
3101         a_cpm(i, k) = a_cpm(i, k) - xlf*qtmp*a_temp0/cpm(i, k)
3102         CALL POPCONTROL1B(branch)
3103         IF (branch .EQ. 0) THEN
3104           CALL POPREAL8(qci(i, k, 1))
3105           a_qci(i, k, 1) = 0.0_8
3106         ELSE
3107           CALL POPREAL8(qci(i, k, 1))
3108           a_qtmp = a_qtmp - a_qci(i, k, 1)
3109         END IF
3110         CALL POPCONTROL1B(branch)
3111         IF (branch .EQ. 0) THEN
3112           CALL POPREAL8(qci(i, k, 2))
3113           a_qci(i, k, 2) = 0.0_8
3114         ELSE
3115           CALL POPREAL8(qci(i, k, 2))
3116           a_qtmp = a_qtmp + a_qci(i, k, 2)
3117         END IF
3118         CALL POPCONTROL1B(branch)
3119         IF (branch .NE. 0) a_qtmp = 0.0_8
3120         CALL POPCONTROL1B(branch)
3121         IF (branch .EQ. 0) THEN
3122           CALL POPREAL8(qtmp)
3123           a_ft40 = 0.0_8
3124         ELSE
3125           CALL POPREAL8(qtmp)
3126           a_ft40 = qci(i, k, 1)*a_qtmp
3127           a_qci(i, k, 1) = a_qci(i, k, 1) + ft40*a_qtmp
3128         END IF
3129         CALL POPREAL8(ft40)
3130         a_supcol = 0.0_8
3131         CALL A_SMOOTHIF(supcol, a_supcol, 40., ft40, a_ft40, 't0')
3132         CALL POPCONTROL1B(branch)
3133         IF (branch .NE. 0) a_xlf = 0.0_8
3134         a_t(i, k) = a_t(i, k) - a_supcol
3135         CALL POPREAL8(xlf)
3136         a_xl(i, k) = a_xl(i, k) - a_xlf
3137         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
3138         a_xl(i, k) = 0.0_8
3139         CALL POPREAL8(t(i, k))
3140         a_temp0 = -(a_t(i, k)/cpm(i, k))
3141         a_xlf = qtmp*a_temp0
3142         a_qtmp = xlf*a_temp0
3143         a_cpm(i, k) = a_cpm(i, k) - xlf*qtmp*a_temp0/cpm(i, k)
3144         CALL POPCONTROL1B(branch)
3145         IF (branch .EQ. 0) THEN
3146           a_qci(i, k, 2) = 0.0_8
3147         ELSE
3148           a_qtmp = a_qtmp - a_qci(i, k, 2)
3149         END IF
3150         CALL POPCONTROL1B(branch)
3151         IF (branch .EQ. 0) THEN
3152           a_qci(i, k, 1) = 0.0_8
3153         ELSE
3154           a_qtmp = a_qtmp + a_qci(i, k, 1)
3155         END IF
3156         CALL POPCONTROL1B(branch)
3157         IF (branch .NE. 0) a_qtmp = 0.0_8
3158         CALL POPREAL8(qtmp)
3159         a_ft0 = max1*a_qtmp
3160         a_max1 = ft0*a_qtmp
3161         CALL POPCONTROL1B(branch)
3162         IF (branch .EQ. 0) THEN
3163           CALL POPREAL8(max1)
3164         ELSE
3165           CALL POPREAL8(max1)
3166           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max1
3167         END IF
3168         CALL POPREAL8(ft0)
3169         CALL A_SMOOTHIF(t(i, k), a_t(i, k), t0c, ft0, a_ft0, 't0')
3170         CALL POPCONTROL1B(branch)
3171         IF (branch .NE. 0) a_xlf = 0.0_8
3172         CALL POPREAL8(xlf)
3173         a_xl(i, k) = a_xl(i, k) - a_xlf
3174         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
3175         a_xl(i, k) = 0.0_8
3176       END DO
3177     END DO
3178     DO i=ite,its,-1
3179       CALL POPCONTROL1B(branch)
3180       IF (branch .EQ. 0) THEN
3181         a_fallsum = 0.0_8
3182       ELSE
3183         fallsum = fall(i, kts, 1) + fall(i, kts, 2) + fall(i, kts, 3) + &
3184 &         fallc(i, kts)
3185         a_temp0 = dtcld*1000.*a_rain(i)
3186         a_delz(i, kts) = a_delz(i, kts) + fallsum*a_temp0/denr
3187         a_fallsum = delz(i, kts)*a_temp0/denr
3188         a_temp0 = dtcld*1000.*a_rainncv(i)
3189         a_rainncv(i) = 0.0_8
3190         a_delz(i, kts) = a_delz(i, kts) + fallsum*a_temp0/denr
3191         a_fallsum = a_fallsum + delz(i, kts)*a_temp0/denr
3192       END IF
3193       a_fall(i, kts, 1) = a_fall(i, kts, 1) + a_fallsum
3194       a_fall(i, kts, 2) = a_fall(i, kts, 2) + a_fallsum
3195       a_fall(i, kts, 3) = a_fall(i, kts, 3) + a_fallsum
3196       a_fallc(i, kts) = a_fallc(i, kts) + a_fallsum
3197     END DO
3198   END SUBROUTINE A_RAINSC
3199
3200 !=======================================================================
3201 !
3202 !=======================================================================
3203   SUBROUTINE RAINSC(fall, fallc, xl, t, q, qci, cpm, den, qrs, delz, &
3204 &   rain, rainncv, dtcld, kte, kts, its, ite, kme, kms, ims, ime)
3205     IMPLICIT NONE
3206     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
3207     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, fall
3208     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
3209     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, q
3210     REAL, DIMENSION(its:ite, kts:kte) :: xl, t, cpm, fallc
3211     REAL, DIMENSION(ims:ime) :: rain, rainncv
3212     INTEGER :: k, i
3213     REAL :: dtcld, fallsum, supcol, xlf, temp, temp0, pfrzdtr, pfrzdtc
3214     REAL :: ft0, ft40, fsupcol, fqc, fqi, fqr, qtmp
3215     INTRINSIC MAX
3216     INTRINSIC ABS
3217     INTRINSIC EXP
3218     INTRINSIC MIN
3219     REAL :: x1
3220     REAL :: max1
3221     REAL :: abs0
3222     REAL :: abs1
3223     REAL :: abs2
3224     REAL :: abs3
3225     DO i=its,ite
3226       fallsum = fall(i, kts, 1) + fall(i, kts, 2) + fall(i, kts, 3) + &
3227 &       fallc(i, kts)
3228       IF (fallsum .GT. qmin) THEN
3229 !rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf
3230         rainncv(i) = fallsum*delz(i, kts)/denr*dtcld*1000.
3231         rain(i) = fallsum*delz(i, kts)/denr*dtcld*1000. + rain(i)
3232       END IF
3233     END DO
3234     DO k=kts,kte
3235       DO i=its,ite
3236 !---------------------------------------------------------------
3237 ! pimlt: instantaneous melting of cloud ice [RH83 A28]
3238 !       (T>T0: I->C) pimlt=qci(i,k,2) t-
3239 !---------------------------------------------------------------
3240 !update xl, cpm
3241         xl(i, k) = XLCAL(t(i, k))
3242 !         cpm(i,k)=cpmcal(q(i,k)) !not change
3243         xlf = xls - xl(i, k)
3244         supcol = t0c - t(i, k)
3245         IF (supcol .LT. 0.) xlf = xlf0
3246         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
3247         IF (qci(i, k, 2) .LT. 0.) THEN
3248           max1 = 0.
3249         ELSE
3250           max1 = qci(i, k, 2)
3251         END IF
3252         qtmp = ft0*max1
3253         IF (qtmp .GE. 0.) THEN
3254           abs0 = qtmp
3255         ELSE
3256           abs0 = -qtmp
3257         END IF
3258         IF (abs0 .LT. qmin) qtmp = 0.
3259         IF (qci(i, k, 1) + qtmp .LT. 0.) THEN
3260           qci(i, k, 1) = 0.
3261         ELSE
3262           qci(i, k, 1) = qci(i, k, 1) + qtmp
3263         END IF
3264         IF (qci(i, k, 2) - qtmp .LT. 0.) THEN
3265           qci(i, k, 2) = 0.
3266         ELSE
3267           qci(i, k, 2) = qci(i, k, 2) - qtmp
3268         END IF
3269         t(i, k) = t(i, k) - xlf/cpm(i, k)*qtmp
3270 !---------------------------------------------------------------
3271 ! pihmf: homogeneous freezing of cloud water below -40c
3272 !        (T<-40C: C->I) min=0,pihmf=qci(i,k,1) t+
3273 !---------------------------------------------------------------
3274 !update xl, cpm
3275         xl(i, k) = XLCAL(t(i, k))
3276 !         cpm(i,k)=cpmcal(q(i,k)) !not change
3277         xlf = xls - xl(i, k)
3278         supcol = t0c - t(i, k)
3279         IF (supcol .LT. 0.) xlf = xlf0
3280         CALL SMOOTHIF(supcol, 40., ft40, 't0')
3281         IF (ft40*qci(i, k, 1) .LT. 0.) THEN
3282           qtmp = 0.
3283         ELSE
3284           qtmp = ft40*qci(i, k, 1)
3285         END IF
3286         IF (qtmp .GE. 0.) THEN
3287           abs1 = qtmp
3288         ELSE
3289           abs1 = -qtmp
3290         END IF
3291 !update qc, qi, t
3292         IF (abs1 .LT. qmin) qtmp = 0.
3293         IF (qci(i, k, 2) + qtmp .LT. 0.) THEN
3294           qci(i, k, 2) = 0.
3295         ELSE
3296           qci(i, k, 2) = qci(i, k, 2) + qtmp
3297         END IF
3298         IF (qci(i, k, 1) - qtmp .LT. 0.) THEN
3299           qci(i, k, 1) = 0.
3300         ELSE
3301           qci(i, k, 1) = qci(i, k, 1) - qtmp
3302         END IF
3303         t(i, k) = t(i, k) + xlf/cpm(i, k)*qtmp
3304 !---------------------------------------------------------------
3305 ! pihtf: heterogeneous freezing of cloud water
3306 !        (T0>T>-40C: C->I) max=qci(i,k,1),min=0. t+
3307 !---------------------------------------------------------------
3308 !update xl, cpm
3309         xl(i, k) = XLCAL(t(i, k))
3310 !         cpm(i,k)=cpmcal(q(i,k)) !not change
3311         xlf = xls - xl(i, k)
3312         supcol = t0c - t(i, k)
3313         IF (supcol .LT. 0.) xlf = xlf0
3314 !t>-40C=t0c-40,t0c-t<40, supcol<40,-supcol>-40
3315         CALL SMOOTHIF(-supcol, -40., ft40, 't0')
3316         x1 = pfrz1*(EXP(pfrz2*supcol)-1.)*den(i, k)/denr/xncr*qci(i, k, &
3317 &         1)*qci(i, k, 1)*dtcld
3318         IF (x1 .GT. qci(i, k, 1)) THEN
3319           pfrzdtc = qci(i, k, 1)
3320         ELSE
3321           pfrzdtc = x1
3322         END IF
3323         IF (ft40*pfrzdtc .LT. 0.) THEN
3324           qtmp = 0.
3325         ELSE
3326           qtmp = ft40*pfrzdtc
3327         END IF
3328         IF (qtmp .GE. 0.) THEN
3329           abs2 = qtmp
3330         ELSE
3331           abs2 = -qtmp
3332         END IF
3333 !update qc, qi, t
3334         IF (abs2 .LT. qmin) qtmp = 0.
3335         IF (qci(i, k, 2) + qtmp .LT. 0.) THEN
3336           qci(i, k, 2) = 0.
3337         ELSE
3338           qci(i, k, 2) = qci(i, k, 2) + qtmp
3339         END IF
3340         IF (qci(i, k, 1) - qtmp .LT. 0.) THEN
3341           qci(i, k, 1) = 0.
3342         ELSE
3343           qci(i, k, 1) = qci(i, k, 1) - qtmp
3344         END IF
3345         t(i, k) = t(i, k) + xlf/cpm(i, k)*qtmp
3346 !---------------------------------------------------------------
3347 ! pgfrz: freezing of rain water [LFO 45]
3348 !        (T<T0, R->G) max=qrs(i,k,1),min=0. t+
3349 !---------------------------------------------------------------
3350 !update xl, cpm
3351         xl(i, k) = XLCAL(t(i, k))
3352 !         cpm(i,k)=cpmcal(q(i,k))!not change
3353         xlf = xls - xl(i, k)
3354         supcol = t0c - t(i, k)
3355         IF (supcol .LT. 0.) xlf = xlf0
3356         IF (qrs(i, k, 1) .GT. 0.) THEN
3357           temp = pgfrz_a*(EXP(pfrz2*supcol)-1.)*den(i, k)**(3./4.)*qrs(i&
3358 &           , k, 1)**(7./4.)
3359         ELSE
3360           temp = 0.
3361         END IF
3362         IF (temp*dtcld .GT. qrs(i, k, 1)) THEN
3363           pfrzdtr = qrs(i, k, 1)
3364         ELSE
3365           pfrzdtr = temp*dtcld
3366         END IF
3367         IF (pfrzdtr .LT. 0.) THEN
3368           qtmp = 0.
3369         ELSE
3370           qtmp = pfrzdtr
3371         END IF
3372         IF (qtmp .GE. 0.) THEN
3373           abs3 = qtmp
3374         ELSE
3375           abs3 = -qtmp
3376         END IF
3377         IF (abs3 .LT. qmin) qtmp = 0.
3378         IF (qrs(i, k, 3) + qtmp .LT. 0.) THEN
3379           qrs(i, k, 3) = 0.
3380         ELSE
3381           qrs(i, k, 3) = qrs(i, k, 3) + qtmp
3382         END IF
3383         IF (qrs(i, k, 1) - qtmp .LT. 0.) THEN
3384           qrs(i, k, 1) = 0.
3385         ELSE
3386           qrs(i, k, 1) = qrs(i, k, 1) - qtmp
3387         END IF
3388         t(i, k) = t(i, k) + xlf/cpm(i, k)*qtmp
3389       END DO
3390     END DO
3391   END SUBROUTINE RAINSC
3392
3393 !  Differentiation of warmr in reverse (adjoint) mode (with options r8):
3394 !   gradient     of useful results: p q t qs xl pracw rh den qrs
3395 !                prevp qci praut
3396 !   with respect to varying inputs: p q t qs xl pracw rh den qrs
3397 !                prevp qci praut
3398 !=======================================================================
3399 !
3400 !=======================================================================
3401   SUBROUTINE A_WARMR(t, a_t, q, a_q, qci, a_qci, qrs, a_qrs, den, a_den&
3402 &   , p, a_p, dtcld, xl, a_xl, rh, a_rh, qs, a_qs, praut, a_praut, pracw&
3403 &   , a_pracw, prevp, a_prevp, ims, ime, kms, kme, its, ite, kts, kte)
3404     IMPLICIT NONE
3405     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
3406 !------------------------------------------------------------------
3407     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
3408     REAL, DIMENSION(its:ite, kts:kte, 2) :: a_qci
3409     REAL, DIMENSION(ims:ime, kms:kme) :: q, den, p
3410     REAL, DIMENSION(ims:ime, kms:kme) :: a_q, a_den, a_p
3411     REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, qrs, work1
3412     REAL, DIMENSION(its:ite, kts:kte, 3) :: a_rh, a_qs, a_qrs
3413     REAL, DIMENSION(its:ite, kts:kte) :: praut, prevp, pracw, xl, denfac&
3414 &   , t, cpm
3415     REAL, DIMENSION(its:ite, kts:kte) :: a_praut, a_prevp, a_pracw, a_xl&
3416 &   , a_t, a_cpm
3417     REAL :: coeres, supsat, satdt, dtcld, praut1
3418     REAL :: a_supsat, a_satdt, a_praut1
3419     INTEGER :: i, k
3420     REAL :: fqv, fqc, fqr, fqc0, fprevp, prevp0, prevp1, temp, a, b, c, &
3421 &   d, e
3422     REAL :: a_fqc0, a_a, a_b, a_c, a_d, a_e
3423     INTRINSIC LOG
3424     INTRINSIC EXP
3425     INTRINSIC MIN
3426     INTRINSIC ABS
3427     INTRINSIC MAX
3428     INTRINSIC SQRT
3429     REAL :: x1
3430     REAL :: a_x1
3431     REAL :: x2
3432     REAL :: a_x2
3433     REAL :: x3
3434     REAL :: a_x3
3435     REAL :: abs0
3436     REAL :: abs1
3437     REAL :: max1
3438     REAL :: a_max1
3439     REAL :: max2
3440     REAL :: a_max2
3441     REAL :: abs2
3442     REAL :: temp0
3443     REAL :: temp1
3444     REAL :: a_temp
3445     REAL :: temp2
3446     REAL :: temp3
3447     REAL :: a_temp0
3448     REAL :: temp4
3449     REAL :: temp5
3450     REAL :: temp6
3451     REAL :: temp7
3452     REAL :: temp8
3453     REAL :: temp9
3454     REAL :: a_temp1
3455     REAL :: temp10
3456     REAL :: temp11
3457     REAL :: a_temp2
3458     REAL :: a_temp3
3459     INTEGER :: branch
3460     DO k=kts,kte
3461       DO i=its,ite
3462 !---------------------------------------------------------------
3463 ! praut: auto conversion rate from cloud to rain [HDC 16]
3464 !        (C->R) praut>0 max=qci(i,k,1)/dtcld, min=0.
3465 !---------------------------------------------------------------
3466         CALL PUSHREAL8(fqc0)
3467         CALL SMOOTHIF(qci(i, k, 1), qc0, fqc0, 'q0')
3468 !qc0=5.03e-4
3469         IF (qci(i, k, 1) .GT. 0.) THEN
3470 ! x**a need x>0
3471 !(qci(i,k,1)**(7./3.))
3472           praut1 = fqc0*qck1*EXP(LOG(qci(i, k, 1))*(7./3.))
3473           CALL PUSHCONTROL1B(1)
3474         ELSE
3475           praut1 = 0.
3476           CALL PUSHCONTROL1B(0)
3477         END IF
3478         IF (praut1 .GT. qci(i, k, 1)/dtcld) THEN
3479           praut(i, k) = qci(i, k, 1)/dtcld
3480           CALL PUSHCONTROL1B(0)
3481         ELSE
3482           praut(i, k) = praut1
3483           CALL PUSHCONTROL1B(1)
3484         END IF
3485         IF (praut(i, k) .GE. 0.) THEN
3486           abs0 = praut(i, k)
3487         ELSE
3488           abs0 = -praut(i, k)
3489         END IF
3490         IF (abs0 .LT. qmin/dtcld) THEN
3491           praut(i, k) = 0.
3492           CALL PUSHCONTROL1B(1)
3493         ELSE
3494           CALL PUSHCONTROL1B(0)
3495         END IF
3496         IF (qci(i, k, 1) - praut(i, k)*dtcld .LT. 0.) THEN
3497           CALL PUSHREAL8(qci(i, k, 1))
3498           qci(i, k, 1) = 0.
3499           CALL PUSHCONTROL1B(0)
3500         ELSE
3501           CALL PUSHREAL8(qci(i, k, 1))
3502           qci(i, k, 1) = qci(i, k, 1) - praut(i, k)*dtcld
3503           CALL PUSHCONTROL1B(1)
3504         END IF
3505         IF (qrs(i, k, 1) + praut(i, k)*dtcld .LT. 0.) THEN
3506           qrs(i, k, 1) = 0.
3507           CALL PUSHCONTROL1B(0)
3508         ELSE
3509           qrs(i, k, 1) = qrs(i, k, 1) + praut(i, k)*dtcld
3510           CALL PUSHCONTROL1B(1)
3511         END IF
3512 !---------------------------------------------------------------
3513 ! pracw: accretion of cloud water by rain [LFO 51]
3514 !        (C->R) max=qci(i,k,1)/dtcld, min=0.
3515 !---------------------------------------------------------------
3516 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
3517 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
3518         IF (qrs(i, k, 1) .GT. 0 .AND. qci(i, k, 1) .GT. 0.) THEN
3519           pracw(i, k) = pracw_a*den(i, k)**((1.+bvtr)/4.)*qrs(i, k, 1)**&
3520 &           ((3.+bvtr)/4.)*qci(i, k, 1)
3521           CALL PUSHCONTROL1B(0)
3522         ELSE
3523           pracw(i, k) = 0.
3524           CALL PUSHCONTROL1B(1)
3525         END IF
3526         IF (pracw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
3527           x1 = qci(i, k, 1)/dtcld
3528           CALL PUSHCONTROL1B(0)
3529         ELSE
3530           x1 = pracw(i, k)
3531           CALL PUSHCONTROL1B(1)
3532         END IF
3533         IF (x1 .LT. 0.) THEN
3534           pracw(i, k) = 0.
3535           CALL PUSHCONTROL1B(0)
3536         ELSE
3537           pracw(i, k) = x1
3538           CALL PUSHCONTROL1B(1)
3539         END IF
3540         IF (pracw(i, k) .GE. 0.) THEN
3541           abs1 = pracw(i, k)
3542         ELSE
3543           abs1 = -pracw(i, k)
3544         END IF
3545         IF (abs1 .LT. qmin/dtcld) THEN
3546           pracw(i, k) = 0.
3547           CALL PUSHCONTROL1B(1)
3548         ELSE
3549           CALL PUSHCONTROL1B(0)
3550         END IF
3551         IF (qci(i, k, 1) - pracw(i, k)*dtcld .LT. 0.) THEN
3552           CALL PUSHCONTROL1B(0)
3553         ELSE
3554           CALL PUSHCONTROL1B(1)
3555         END IF
3556         IF (qrs(i, k, 1) + pracw(i, k)*dtcld .LT. 0.) THEN
3557           CALL PUSHREAL8(qrs(i, k, 1))
3558           qrs(i, k, 1) = 0.
3559           CALL PUSHCONTROL1B(0)
3560         ELSE
3561           CALL PUSHREAL8(qrs(i, k, 1))
3562           qrs(i, k, 1) = qrs(i, k, 1) + pracw(i, k)*dtcld
3563           CALL PUSHCONTROL1B(1)
3564         END IF
3565 !
3566 !---------------------------------------------------------------
3567 ! prevp: evaporation/condensation rate of rain [HDC 14]
3568 !        (V->R or R->V) rh(i,k,1)>1., prevp>0, V->R, min=0.,                max=satdt ;
3569 !                       rh(i,k,1)<1., prevp<0, R->V, min=-qrs(i,k,1)/dtcld, max=0.
3570 !---------------------------------------------------------------
3571 !update rh
3572         CALL PUSHREAL8ARRAY(qs(i, k, :), 3)
3573         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
3574 !update xl, cpm
3575         xl(i, k) = XLCAL(t(i, k))
3576         cpm(i, k) = CPMCAL(q(i, k))
3577         supsat = q(i, k) - qs(i, k, 1)
3578         satdt = supsat/dtcld
3579         IF (qrs(i, k, 1) .LT. qcrmin) THEN
3580           CALL PUSHREAL8(max1)
3581           max1 = qcrmin
3582           CALL PUSHCONTROL1B(0)
3583         ELSE
3584           CALL PUSHREAL8(max1)
3585           max1 = qrs(i, k, 1)
3586           CALL PUSHCONTROL1B(1)
3587         END IF
3588         CALL PUSHREAL8(a)
3589         a = SQRT(den(i, k)*max1)
3590         IF (qrs(i, k, 1) .LT. qcrmin) THEN
3591           CALL PUSHREAL8(max2)
3592           max2 = qcrmin
3593           CALL PUSHCONTROL1B(0)
3594         ELSE
3595           CALL PUSHREAL8(max2)
3596           max2 = qrs(i, k, 1)
3597           CALL PUSHCONTROL1B(1)
3598         END IF
3599         CALL PUSHREAL8(b)
3600         b = (t(i, k)+120.)**(1./6.)/t(i, k)**(5.12/6.)*p(i, k)**(1./3.)*&
3601 &         den(i, k)**((13.+3.*bvtr)/24.)*max2**((5.+bvtr)/8.)
3602         CALL PUSHREAL8(c)
3603         c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, &
3604 &         k)**3.5
3605         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1)
3606         e = (rh(i, k, 1)-1.)/(c+d)
3607         prevp(i, k) = (prevp_a*a+prevp_b*b)*e
3608         IF (prevp(i, k) .LT. 0.) THEN
3609           IF (prevp(i, k) .LT. -(qrs(i, k, 1)/dtcld)) THEN
3610             x2 = -(qrs(i, k, 1)/dtcld)
3611             CALL PUSHCONTROL1B(0)
3612           ELSE
3613             x2 = prevp(i, k)
3614             CALL PUSHCONTROL1B(1)
3615           END IF
3616           IF (x2 .GT. 0.) THEN
3617             prevp(i, k) = 0.
3618             CALL PUSHCONTROL2B(1)
3619           ELSE
3620             prevp(i, k) = x2
3621             CALL PUSHCONTROL2B(0)
3622           END IF
3623         ELSE
3624           IF (prevp(i, k) .GT. satdt) THEN
3625             x3 = satdt
3626             CALL PUSHCONTROL1B(0)
3627           ELSE
3628             x3 = prevp(i, k)
3629             CALL PUSHCONTROL1B(1)
3630           END IF
3631           IF (x3 .LT. 0.) THEN
3632             prevp(i, k) = 0.
3633             CALL PUSHCONTROL2B(3)
3634           ELSE
3635             prevp(i, k) = x3
3636             CALL PUSHCONTROL2B(2)
3637           END IF
3638         END IF
3639         IF (prevp(i, k) .GE. 0.) THEN
3640           abs2 = prevp(i, k)
3641         ELSE
3642           abs2 = -prevp(i, k)
3643         END IF
3644         IF (abs2 .LT. qmin/dtcld) THEN
3645           prevp(i, k) = 0.
3646           CALL PUSHCONTROL1B(1)
3647         ELSE
3648           CALL PUSHCONTROL1B(0)
3649         END IF
3650         IF (q(i, k) - prevp(i, k)*dtcld .LT. 0.) THEN
3651           CALL PUSHCONTROL1B(0)
3652         ELSE
3653           CALL PUSHCONTROL1B(1)
3654         END IF
3655         IF (qrs(i, k, 1) + prevp(i, k)*dtcld .LT. 0.) THEN
3656           CALL PUSHCONTROL1B(0)
3657         ELSE
3658           CALL PUSHCONTROL1B(1)
3659         END IF
3660       END DO
3661     END DO
3662     a_cpm = 0.0_8
3663     DO k=kte,kts,-1
3664       DO i=ite,its,-1
3665         a_temp2 = dtcld*a_t(i, k)/cpm(i, k)
3666         a_prevp(i, k) = xl(i, k)*a_temp2
3667         a_xl(i, k) = a_xl(i, k) + prevp(i, k)*a_temp2
3668         a_cpm(i, k) = a_cpm(i, k) - prevp(i, k)*xl(i, k)*a_temp2/cpm(i, &
3669 &         k)
3670         CALL POPCONTROL1B(branch)
3671         IF (branch .EQ. 0) THEN
3672           a_qrs(i, k, 1) = 0.0_8
3673         ELSE
3674           a_prevp(i, k) = a_prevp(i, k) + dtcld*a_qrs(i, k, 1)
3675         END IF
3676         CALL POPCONTROL1B(branch)
3677         IF (branch .EQ. 0) THEN
3678           a_q(i, k) = 0.0_8
3679         ELSE
3680           a_prevp(i, k) = a_prevp(i, k) - dtcld*a_q(i, k)
3681         END IF
3682         CALL POPCONTROL1B(branch)
3683         IF (branch .NE. 0) a_prevp(i, k) = 0.0_8
3684         CALL POPCONTROL2B(branch)
3685         IF (branch .LT. 2) THEN
3686           IF (branch .EQ. 0) THEN
3687             a_x2 = a_prevp(i, k)
3688             a_prevp(i, k) = 0.0_8
3689           ELSE
3690             a_prevp(i, k) = 0.0_8
3691             a_x2 = 0.0_8
3692           END IF
3693           CALL POPCONTROL1B(branch)
3694           IF (branch .EQ. 0) THEN
3695             a_qrs(i, k, 1) = a_qrs(i, k, 1) - a_x2/dtcld
3696           ELSE
3697             a_prevp(i, k) = a_prevp(i, k) + a_x2
3698           END IF
3699           a_satdt = 0.0_8
3700         ELSE
3701           IF (branch .EQ. 2) THEN
3702             a_x3 = a_prevp(i, k)
3703             a_prevp(i, k) = 0.0_8
3704           ELSE
3705             a_prevp(i, k) = 0.0_8
3706             a_x3 = 0.0_8
3707           END IF
3708           CALL POPCONTROL1B(branch)
3709           IF (branch .EQ. 0) THEN
3710             a_satdt = a_x3
3711           ELSE
3712             a_prevp(i, k) = a_prevp(i, k) + a_x3
3713             a_satdt = 0.0_8
3714           END IF
3715         END IF
3716         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1)
3717         e = (rh(i, k, 1)-1.)/(c+d)
3718         a_a = prevp_a*e*a_prevp(i, k)
3719         a_b = prevp_b*e*a_prevp(i, k)
3720         a_e = (prevp_a*a+prevp_b*b)*a_prevp(i, k)
3721         a_prevp(i, k) = 0.0_8
3722         a_temp2 = a_e/(c+d)
3723         a_rh(i, k, 1) = a_rh(i, k, 1) + a_temp2
3724         a_temp3 = -((rh(i, k, 1)-1.)*a_temp2/(c+d))
3725         a_c = a_temp3
3726         a_d = a_temp3
3727         temp11 = t(i, k)**1.81
3728         temp10 = temp11*qs(i, k, 1)
3729         a_temp1 = diffac_b*a_d/temp10
3730         a_temp3 = -(p(i, k)*a_temp1/temp10)
3731         a_t(i, k) = a_t(i, k) + 1.81*t(i, k)**0.81*qs(i, k, 1)*a_temp3
3732         a_qs(i, k, 1) = a_qs(i, k, 1) + temp11*a_temp3
3733         CALL POPREAL8(c)
3734         temp11 = rv*t(i, k)**3.5
3735         temp9 = den(i, k)*(t(i, k)+120.)
3736         temp8 = xl(i, k)*xl(i, k)
3737         a_temp3 = diffac_a*a_c/temp11
3738         a_xl(i, k) = a_xl(i, k) + 2*xl(i, k)*temp9*a_temp3
3739         a_den(i, k) = a_den(i, k) + (t(i, k)+120.)*temp8*a_temp3
3740         a_t(i, k) = a_t(i, k) + (den(i, k)*temp8-3.5*t(i, k)**2.5*rv*&
3741 &         temp8*temp9/temp11)*a_temp3
3742         CALL POPREAL8(b)
3743         temp3 = (3.*bvtr+13.)/24.
3744         temp2 = den(i, k)**temp3
3745         temp1 = (bvtr+5.)/8.
3746         temp0 = max2**temp1
3747         temp4 = 1.0/3.
3748         temp5 = p(i, k)**temp4
3749         temp6 = temp5*temp0
3750         temp7 = 5.12/6.
3751         temp8 = t(i, k)**temp7
3752         temp10 = 1.0/6.
3753         temp9 = (t(i, k)+120.)**temp10/temp8
3754         a_temp2 = temp9*a_b
3755         IF (p(i, k) .LE. 0.0_8 .AND. (temp4 .EQ. 0.0_8 .OR. temp4 .NE. &
3756 &           INT(temp4))) THEN
3757           a_p(i, k) = a_p(i, k) + a_temp1
3758         ELSE
3759           a_p(i, k) = a_p(i, k) + a_temp1 + temp4*p(i, k)**(temp4-1)*&
3760 &           temp0*temp2*a_temp2
3761         END IF
3762         a_temp1 = temp6*temp2*a_b/temp8
3763         IF (max2 .LE. 0.0_8 .AND. (temp1 .EQ. 0.0_8 .OR. temp1 .NE. INT(&
3764 &           temp1))) THEN
3765           a_max2 = 0.0_8
3766         ELSE
3767           a_max2 = temp1*max2**(temp1-1)*temp5*temp2*a_temp2
3768         END IF
3769         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp3 .EQ. 0.0_8 .OR. &
3770 &           temp3 .NE. INT(temp3)))) a_den(i, k) = a_den(i, k) + temp3*&
3771 &           den(i, k)**(temp3-1)*temp6*a_temp2
3772         IF (.NOT.(t(i, k) + 120. .LE. 0.0_8 .AND. (temp10 .EQ. 0.0_8 &
3773 &           .OR. temp10 .NE. INT(temp10)))) a_t(i, k) = a_t(i, k) + &
3774 &           temp10*(t(i, k)+120.)**(temp10-1)*a_temp1
3775         IF (.NOT.(t(i, k) .LE. 0.0_8 .AND. (temp7 .EQ. 0.0_8 .OR. temp7 &
3776 &           .NE. INT(temp7)))) a_t(i, k) = a_t(i, k) - temp7*t(i, k)**(&
3777 &           temp7-1)*temp9*a_temp1
3778         CALL POPCONTROL1B(branch)
3779         IF (branch .EQ. 0) THEN
3780           CALL POPREAL8(max2)
3781         ELSE
3782           CALL POPREAL8(max2)
3783           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max2
3784         END IF
3785         CALL POPREAL8(a)
3786         IF (den(i, k)*max1 .EQ. 0.0_8) THEN
3787           a_temp0 = 0.0_8
3788         ELSE
3789           a_temp0 = a_a/(2.0*SQRT(den(i, k)*max1))
3790         END IF
3791         a_den(i, k) = a_den(i, k) + max1*a_temp0
3792         a_max1 = den(i, k)*a_temp0
3793         CALL POPCONTROL1B(branch)
3794         IF (branch .EQ. 0) THEN
3795           CALL POPREAL8(max1)
3796         ELSE
3797           CALL POPREAL8(max1)
3798           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max1
3799         END IF
3800         a_supsat = a_satdt/dtcld
3801         a_q(i, k) = a_q(i, k) + a_supsat
3802         a_qs(i, k, 1) = a_qs(i, k, 1) - a_supsat
3803         CALL A_CPMCAL0(q(i, k), a_q(i, k), a_cpm(i, k))
3804         a_cpm(i, k) = 0.0_8
3805         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
3806         a_xl(i, k) = 0.0_8
3807         CALL POPREAL8ARRAY(qs(i, k, :), 3)
3808         CALL A_CALCRH(t(i, k), a_t(i, k), p(i, k), a_p(i, k), q(i, k), &
3809 &               a_q(i, k), rh(i, k, :), a_rh(i, k, :), qs(i, k, :), a_qs&
3810 &               (i, k, :))
3811         a_pracw(i, k) = 0.0_8
3812         CALL POPCONTROL1B(branch)
3813         IF (branch .EQ. 0) THEN
3814           CALL POPREAL8(qrs(i, k, 1))
3815           a_qrs(i, k, 1) = 0.0_8
3816         ELSE
3817           CALL POPREAL8(qrs(i, k, 1))
3818           a_pracw(i, k) = a_pracw(i, k) + dtcld*a_qrs(i, k, 1)
3819         END IF
3820         CALL POPCONTROL1B(branch)
3821         IF (branch .EQ. 0) THEN
3822           a_qci(i, k, 1) = 0.0_8
3823         ELSE
3824           a_pracw(i, k) = a_pracw(i, k) - dtcld*a_qci(i, k, 1)
3825         END IF
3826         CALL POPCONTROL1B(branch)
3827         IF (branch .NE. 0) a_pracw(i, k) = 0.0_8
3828         CALL POPCONTROL1B(branch)
3829         IF (branch .EQ. 0) THEN
3830           a_pracw(i, k) = 0.0_8
3831           a_x1 = 0.0_8
3832         ELSE
3833           a_x1 = a_pracw(i, k)
3834           a_pracw(i, k) = 0.0_8
3835         END IF
3836         CALL POPCONTROL1B(branch)
3837         IF (branch .EQ. 0) THEN
3838           a_qci(i, k, 1) = a_qci(i, k, 1) + a_x1/dtcld
3839         ELSE
3840           a_pracw(i, k) = a_pracw(i, k) + a_x1
3841         END IF
3842         CALL POPCONTROL1B(branch)
3843         IF (branch .EQ. 0) THEN
3844           temp0 = (bvtr+3.)/4.
3845           temp2 = (bvtr+1.)/4.
3846           temp3 = den(i, k)**temp2
3847           a_temp = qrs(i, k, 1)**temp0*pracw_a*a_pracw(i, k)
3848           IF (.NOT.(qrs(i, k, 1) .LE. 0.0_8 .AND. (temp0 .EQ. 0.0_8 .OR.&
3849 &             temp0 .NE. INT(temp0)))) a_qrs(i, k, 1) = a_qrs(i, k, 1) +&
3850 &             temp0*qrs(i, k, 1)**(temp0-1)*temp3*qci(i, k, 1)*pracw_a*&
3851 &             a_pracw(i, k)
3852           a_pracw(i, k) = 0.0_8
3853           IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp2 .EQ. 0.0_8 .OR. &
3854 &             temp2 .NE. INT(temp2)))) a_den(i, k) = a_den(i, k) + temp2&
3855 &             *den(i, k)**(temp2-1)*qci(i, k, 1)*a_temp
3856           a_qci(i, k, 1) = a_qci(i, k, 1) + temp3*a_temp
3857         ELSE
3858           a_pracw(i, k) = 0.0_8
3859         END IF
3860         a_praut(i, k) = 0.0_8
3861         CALL POPCONTROL1B(branch)
3862         IF (branch .EQ. 0) THEN
3863           a_qrs(i, k, 1) = 0.0_8
3864         ELSE
3865           a_praut(i, k) = a_praut(i, k) + dtcld*a_qrs(i, k, 1)
3866         END IF
3867         CALL POPCONTROL1B(branch)
3868         IF (branch .EQ. 0) THEN
3869           CALL POPREAL8(qci(i, k, 1))
3870           a_qci(i, k, 1) = 0.0_8
3871         ELSE
3872           CALL POPREAL8(qci(i, k, 1))
3873           a_praut(i, k) = a_praut(i, k) - dtcld*a_qci(i, k, 1)
3874         END IF
3875         CALL POPCONTROL1B(branch)
3876         IF (branch .NE. 0) a_praut(i, k) = 0.0_8
3877         CALL POPCONTROL1B(branch)
3878         IF (branch .EQ. 0) THEN
3879           a_qci(i, k, 1) = a_qci(i, k, 1) + a_praut(i, k)/dtcld
3880           a_praut(i, k) = 0.0_8
3881           a_praut1 = 0.0_8
3882         ELSE
3883           a_praut1 = a_praut(i, k)
3884           a_praut(i, k) = 0.0_8
3885         END IF
3886         CALL POPCONTROL1B(branch)
3887         IF (branch .EQ. 0) THEN
3888           a_fqc0 = 0.0_8
3889         ELSE
3890           temp0 = 7.*LOG(qci(i, k, 1))/3.
3891           a_fqc0 = EXP(temp0)*qck1*a_praut1
3892           a_qci(i, k, 1) = a_qci(i, k, 1) + 7.*EXP(temp0)*fqc0*qck1*&
3893 &           a_praut1/(qci(i, k, 1)*3.)
3894         END IF
3895         CALL POPREAL8(fqc0)
3896         CALL A_SMOOTHIF(qci(i, k, 1), a_qci(i, k, 1), qc0, fqc0, a_fqc0&
3897 &                 , 'q0')
3898       END DO
3899     END DO
3900   END SUBROUTINE A_WARMR
3901
3902 !=======================================================================
3903 !
3904 !=======================================================================
3905   SUBROUTINE WARMR(t, q, qci, qrs, den, p, dtcld, xl, rh, qs, praut, &
3906 &   pracw, prevp, ims, ime, kms, kme, its, ite, kts, kte)
3907     IMPLICIT NONE
3908     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
3909 !------------------------------------------------------------------
3910     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
3911     REAL, DIMENSION(ims:ime, kms:kme) :: q, den, p
3912     REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, qrs, work1
3913     REAL, DIMENSION(its:ite, kts:kte) :: praut, prevp, pracw, xl, denfac&
3914 &   , t, cpm
3915     REAL :: coeres, supsat, satdt, dtcld, praut1
3916     INTEGER :: i, k
3917     REAL :: fqv, fqc, fqr, fqc0, fprevp, prevp0, prevp1, temp, a, b, c, &
3918 &   d, e
3919     INTRINSIC LOG
3920     INTRINSIC EXP
3921     INTRINSIC MIN
3922     INTRINSIC ABS
3923     INTRINSIC MAX
3924     INTRINSIC SQRT
3925     REAL :: x1
3926     REAL :: x2
3927     REAL :: x3
3928     REAL :: abs0
3929     REAL :: abs1
3930     REAL :: max1
3931     REAL :: max2
3932     REAL :: abs2
3933     DO k=kts,kte
3934       DO i=its,ite
3935 !---------------------------------------------------------------
3936 ! praut: auto conversion rate from cloud to rain [HDC 16]
3937 !        (C->R) praut>0 max=qci(i,k,1)/dtcld, min=0.
3938 !---------------------------------------------------------------
3939         CALL SMOOTHIF(qci(i, k, 1), qc0, fqc0, 'q0')
3940 !qc0=5.03e-4
3941         IF (qci(i, k, 1) .GT. 0.) THEN
3942 ! x**a need x>0
3943 !(qci(i,k,1)**(7./3.))
3944           praut1 = fqc0*qck1*EXP(LOG(qci(i, k, 1))*(7./3.))
3945         ELSE
3946           praut1 = 0.
3947         END IF
3948         IF (praut1 .GT. qci(i, k, 1)/dtcld) THEN
3949           praut(i, k) = qci(i, k, 1)/dtcld
3950         ELSE
3951           praut(i, k) = praut1
3952         END IF
3953         IF (praut(i, k) .GE. 0.) THEN
3954           abs0 = praut(i, k)
3955         ELSE
3956           abs0 = -praut(i, k)
3957         END IF
3958         IF (abs0 .LT. qmin/dtcld) praut(i, k) = 0.
3959         IF (qci(i, k, 1) - praut(i, k)*dtcld .LT. 0.) THEN
3960           qci(i, k, 1) = 0.
3961         ELSE
3962           qci(i, k, 1) = qci(i, k, 1) - praut(i, k)*dtcld
3963         END IF
3964         IF (qrs(i, k, 1) + praut(i, k)*dtcld .LT. 0.) THEN
3965           qrs(i, k, 1) = 0.
3966         ELSE
3967           qrs(i, k, 1) = qrs(i, k, 1) + praut(i, k)*dtcld
3968         END IF
3969         praut(i, k) = 0.
3970 !---------------------------------------------------------------
3971 ! pracw: accretion of cloud water by rain [LFO 51]
3972 !        (C->R) max=qci(i,k,1)/dtcld, min=0.
3973 !---------------------------------------------------------------
3974 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
3975 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
3976         IF (qrs(i, k, 1) .GT. 0 .AND. qci(i, k, 1) .GT. 0.) THEN
3977           pracw(i, k) = pracw_a*den(i, k)**((1.+bvtr)/4.)*qrs(i, k, 1)**&
3978 &           ((3.+bvtr)/4.)*qci(i, k, 1)
3979         ELSE
3980           pracw(i, k) = 0.
3981         END IF
3982         IF (pracw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
3983           x1 = qci(i, k, 1)/dtcld
3984         ELSE
3985           x1 = pracw(i, k)
3986         END IF
3987         IF (x1 .LT. 0.) THEN
3988           pracw(i, k) = 0.
3989         ELSE
3990           pracw(i, k) = x1
3991         END IF
3992         IF (pracw(i, k) .GE. 0.) THEN
3993           abs1 = pracw(i, k)
3994         ELSE
3995           abs1 = -pracw(i, k)
3996         END IF
3997         IF (abs1 .LT. qmin/dtcld) pracw(i, k) = 0.
3998         IF (qci(i, k, 1) - pracw(i, k)*dtcld .LT. 0.) THEN
3999           qci(i, k, 1) = 0.
4000         ELSE
4001           qci(i, k, 1) = qci(i, k, 1) - pracw(i, k)*dtcld
4002         END IF
4003         IF (qrs(i, k, 1) + pracw(i, k)*dtcld .LT. 0.) THEN
4004           qrs(i, k, 1) = 0.
4005         ELSE
4006           qrs(i, k, 1) = qrs(i, k, 1) + pracw(i, k)*dtcld
4007         END IF
4008         pracw(i, k) = 0.
4009 !
4010 !---------------------------------------------------------------
4011 ! prevp: evaporation/condensation rate of rain [HDC 14]
4012 !        (V->R or R->V) rh(i,k,1)>1., prevp>0, V->R, min=0.,                max=satdt ;
4013 !                       rh(i,k,1)<1., prevp<0, R->V, min=-qrs(i,k,1)/dtcld, max=0.
4014 !---------------------------------------------------------------
4015 !update rh
4016         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
4017 !update xl, cpm
4018         xl(i, k) = XLCAL(t(i, k))
4019         cpm(i, k) = CPMCAL(q(i, k))
4020         supsat = q(i, k) - qs(i, k, 1)
4021         satdt = supsat/dtcld
4022         IF (qrs(i, k, 1) .LT. qcrmin) THEN
4023           max1 = qcrmin
4024         ELSE
4025           max1 = qrs(i, k, 1)
4026         END IF
4027         a = SQRT(den(i, k)*max1)
4028         IF (qrs(i, k, 1) .LT. qcrmin) THEN
4029           max2 = qcrmin
4030         ELSE
4031           max2 = qrs(i, k, 1)
4032         END IF
4033         b = (t(i, k)+120.)**(1./6.)/t(i, k)**(5.12/6.)*p(i, k)**(1./3.)*&
4034 &         den(i, k)**((13.+3.*bvtr)/24.)*max2**((5.+bvtr)/8.)
4035         c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, &
4036 &         k)**3.5
4037         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1)
4038         e = (rh(i, k, 1)-1.)/(c+d)
4039         prevp(i, k) = (prevp_a*a+prevp_b*b)*e
4040         IF (prevp(i, k) .LT. 0.) THEN
4041           IF (prevp(i, k) .LT. -(qrs(i, k, 1)/dtcld)) THEN
4042             x2 = -(qrs(i, k, 1)/dtcld)
4043           ELSE
4044             x2 = prevp(i, k)
4045           END IF
4046           IF (x2 .GT. 0.) THEN
4047             prevp(i, k) = 0.
4048           ELSE
4049             prevp(i, k) = x2
4050           END IF
4051         ELSE
4052           IF (prevp(i, k) .GT. satdt) THEN
4053             x3 = satdt
4054           ELSE
4055             x3 = prevp(i, k)
4056           END IF
4057           IF (x3 .LT. 0.) THEN
4058             prevp(i, k) = 0.
4059           ELSE
4060             prevp(i, k) = x3
4061           END IF
4062         END IF
4063         IF (prevp(i, k) .GE. 0.) THEN
4064           abs2 = prevp(i, k)
4065         ELSE
4066           abs2 = -prevp(i, k)
4067         END IF
4068         IF (abs2 .LT. qmin/dtcld) prevp(i, k) = 0.
4069         IF (q(i, k) - prevp(i, k)*dtcld .LT. 0.) THEN
4070           q(i, k) = 0.
4071         ELSE
4072           q(i, k) = q(i, k) - prevp(i, k)*dtcld
4073         END IF
4074         IF (qrs(i, k, 1) + prevp(i, k)*dtcld .LT. 0.) THEN
4075           qrs(i, k, 1) = 0.
4076         ELSE
4077           qrs(i, k, 1) = qrs(i, k, 1) + prevp(i, k)*dtcld
4078         END IF
4079         t(i, k) = t(i, k) + prevp(i, k)*dtcld*xl(i, k)/cpm(i, k)
4080         prevp(i, k) = 0.
4081       END DO
4082     END DO
4083   END SUBROUTINE WARMR
4084
4085 !  Differentiation of accret1 in reverse (adjoint) mode (with options r8):
4086 !   gradient     of useful results: piacr psaci q pgaci t praci
4087 !                psacw pgacw den qrs qci
4088 !   with respect to varying inputs: piacr psaci q pgaci t praci
4089 !                psacw pgacw den qrs qci
4090 !===================================================================
4091   SUBROUTINE A_ACCRET1(qci, a_qci, den, a_den, qrs, a_qrs, t, a_t, q, &
4092 &   a_q, dtcld, praci, a_praci, piacr, a_piacr, psaci, a_psaci, pgaci, &
4093 &   a_pgaci, psacw, a_psacw, pgacw, a_pgacw, ims, ime, kms, kme, its, &
4094 &   ite, kts, kte)
4095     IMPLICIT NONE
4096     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
4097 !-------------------------------------------------------------------
4098     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
4099     REAL, DIMENSION(its:ite, kts:kte, 2) :: a_qci
4100     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
4101     REAL, DIMENSION(its:ite, kts:kte, 3) :: a_qrs
4102     REAL, DIMENSION(ims:ime, kms:kme) :: den, q
4103     REAL, DIMENSION(ims:ime, kms:kme) :: a_den, a_q
4104     REAL, DIMENSION(its:ite, kts:kte) :: praci, piacr, psaci, pgaci, &
4105 &   psacw, pgacw, t, xl, cpm
4106     REAL, DIMENSION(its:ite, kts:kte) :: a_praci, a_piacr, a_psaci, &
4107 &   a_pgaci, a_psacw, a_pgacw, a_t, a_xl, a_cpm
4108     REAL :: supcol, dtcld, eacrs, egi, praci1, piacr1, psaci1, pgaci1, &
4109 &   temp, temp0
4110     REAL :: a_supcol, a_eacrs, a_egi, a_praci1, a_piacr1, a_psaci1, &
4111 &   a_pgaci1
4112     INTEGER :: i, k
4113     REAL :: fsupcol, fqc, fqi, fqr, fqs, fqg, delta3, xlf, a, b, c, d, e
4114     REAL :: a_fsupcol, a_xlf, a_a, a_b, a_c, a_d
4115     INTRINSIC MAX
4116     INTRINSIC SQRT
4117     INTRINSIC ABS
4118     INTRINSIC MIN
4119     INTRINSIC EXP
4120     REAL :: x1
4121     REAL :: a_x1
4122     REAL :: x2
4123     REAL :: a_x2
4124     REAL :: x3
4125     REAL :: a_x3
4126     REAL :: x4
4127     REAL :: a_x4
4128     REAL :: x5
4129     REAL :: a_x5
4130     REAL :: y1
4131     REAL :: a_y1
4132     REAL :: y2
4133     REAL :: a_y2
4134     REAL :: y3
4135     REAL :: a_y3
4136     REAL :: y4
4137     REAL :: a_y4
4138     REAL :: y5
4139     REAL :: a_y5
4140     REAL :: x6
4141     REAL :: a_x6
4142     REAL :: x7
4143     REAL :: a_x7
4144     REAL :: x8
4145     REAL :: a_x8
4146     REAL :: x9
4147     REAL :: a_x9
4148     REAL :: x10
4149     REAL :: a_x10
4150     REAL :: x11
4151     REAL :: a_x11
4152     REAL :: y6
4153     REAL :: a_y6
4154     REAL :: max1
4155     REAL :: a_max1
4156     REAL :: max2
4157     REAL :: a_max2
4158     REAL :: max3
4159     REAL :: a_max3
4160     REAL :: max4
4161     REAL :: a_max4
4162     REAL :: max5
4163     REAL :: a_max5
4164     REAL :: abs0
4165     REAL :: a_abs0
4166     REAL :: abs1
4167     REAL :: abs2
4168     REAL :: max6
4169     REAL :: a_max6
4170     REAL :: max7
4171     REAL :: a_max7
4172     REAL :: max8
4173     REAL :: a_max8
4174     REAL :: max9
4175     REAL :: a_max9
4176     REAL :: max10
4177     REAL :: a_max10
4178     REAL :: max11
4179     REAL :: a_max11
4180     REAL :: abs3
4181     REAL :: a_abs3
4182     REAL :: abs4
4183     REAL :: max12
4184     REAL :: a_max12
4185     REAL :: max13
4186     REAL :: a_max13
4187     REAL :: max14
4188     REAL :: a_max14
4189     REAL :: max15
4190     REAL :: a_max15
4191     REAL :: max16
4192     REAL :: a_max16
4193     REAL :: abs5
4194     REAL :: a_abs5
4195     REAL :: abs6
4196     REAL :: max17
4197     REAL :: a_max17
4198     REAL :: abs7
4199     REAL :: abs8
4200     REAL :: max18
4201     REAL :: a_max18
4202     REAL :: max19
4203     REAL :: a_max19
4204     REAL :: max20
4205     REAL :: a_max20
4206     REAL :: max21
4207     REAL :: a_max21
4208     REAL :: max22
4209     REAL :: a_max22
4210     REAL :: max23
4211     REAL :: a_max23
4212     REAL :: max24
4213     REAL :: a_max24
4214     REAL :: max25
4215     REAL :: a_max25
4216     REAL :: max26
4217     REAL :: a_max26
4218     REAL :: max27
4219     REAL :: a_max27
4220     REAL :: max28
4221     REAL :: a_max28
4222     REAL :: max29
4223     REAL :: a_max29
4224     REAL :: max30
4225     REAL :: a_max30
4226     REAL :: temp1
4227     REAL :: temp2
4228     REAL :: a_temp
4229     REAL :: temp3
4230     REAL :: temp4
4231     REAL :: temp5
4232     REAL :: a_temp0
4233     REAL :: a_temp1
4234     REAL :: temp6
4235     REAL :: a_temp2
4236     REAL :: a_temp3
4237     REAL :: temp7
4238     REAL :: temp8
4239     REAL :: temp9
4240     REAL :: a_temp4
4241     REAL :: a_temp5
4242     REAL :: a_temp6
4243     INTEGER :: branch
4244     DO k=kts,kte
4245       DO i=its,ite
4246 !-------------------------------------------------------------
4247 ! praci: Accretion of cloud ice by rain [LFO 25]
4248 !        (T<T0: I->S or I->G) praci: min=0,max=qci(i,k,2)/dtcld
4249 !-------------------------------------------------------------
4250         supcol = t0c - t(i, k)
4251         CALL PUSHREAL8(fsupcol)
4252         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
4253         IF (qrs(i, k, 1) .LT. qcrmin) THEN
4254           CALL PUSHREAL8(max1)
4255           max1 = qcrmin
4256           CALL PUSHCONTROL1B(0)
4257         ELSE
4258           CALL PUSHREAL8(max1)
4259           max1 = qrs(i, k, 1)
4260           CALL PUSHCONTROL1B(1)
4261         END IF
4262         vt2r = vt2r_a*den(i, k)**((bvtr-2.)/4.)*max1**(bvtr/4.)
4263         IF (qci(i, k, 2) .LT. qmin) THEN
4264           CALL PUSHREAL8(max2)
4265           max2 = qmin
4266           CALL PUSHCONTROL1B(0)
4267         ELSE
4268           CALL PUSHREAL8(max2)
4269           max2 = qci(i, k, 2)
4270           CALL PUSHCONTROL1B(1)
4271         END IF
4272         vt2i = vt2i_a*(den(i, k)*max2)**(1.31/8.)
4273         IF (qrs(i, k, 1) .LT. qcrmin) THEN
4274           CALL PUSHREAL8(max3)
4275           max3 = qcrmin
4276           CALL PUSHCONTROL1B(1)
4277         ELSE
4278           CALL PUSHREAL8(max3)
4279           max3 = qrs(i, k, 1)
4280           CALL PUSHCONTROL1B(0)
4281         END IF
4282         IF (qci(i, k, 2) .LT. qmin) THEN
4283           CALL PUSHREAL8(max18)
4284           max18 = qmin
4285           CALL PUSHCONTROL1B(0)
4286         ELSE
4287           CALL PUSHREAL8(max18)
4288           max18 = qci(i, k, 2)
4289           CALL PUSHCONTROL1B(1)
4290         END IF
4291         CALL PUSHREAL8(b)
4292         b = (den(i, k)*max3)**(3./4.)*max18
4293         IF (qrs(i, k, 1) .LT. qcrmin) THEN
4294           CALL PUSHREAL8(max4)
4295           max4 = qcrmin
4296           CALL PUSHCONTROL1B(1)
4297         ELSE
4298           CALL PUSHREAL8(max4)
4299           max4 = qrs(i, k, 1)
4300           CALL PUSHCONTROL1B(0)
4301         END IF
4302         IF (qci(i, k, 2) .LT. qmin) THEN
4303           CALL PUSHREAL8(max19)
4304           max19 = qmin
4305           CALL PUSHCONTROL1B(0)
4306         ELSE
4307           CALL PUSHREAL8(max19)
4308           max19 = qci(i, k, 2)
4309           CALL PUSHCONTROL1B(1)
4310         END IF
4311         CALL PUSHREAL8(c)
4312         c = den(i, k)**(5./8.)*SQRT(max4)*max19**(9./8.)
4313         IF (qrs(i, k, 1) .LT. qcrmin) THEN
4314           CALL PUSHREAL8(max5)
4315           max5 = qcrmin
4316           CALL PUSHCONTROL1B(1)
4317         ELSE
4318           CALL PUSHREAL8(max5)
4319           max5 = qrs(i, k, 1)
4320           CALL PUSHCONTROL1B(0)
4321         END IF
4322         IF (qci(i, k, 2) .LT. qmin) THEN
4323           CALL PUSHREAL8(max20)
4324           max20 = qmin
4325           CALL PUSHCONTROL1B(0)
4326         ELSE
4327           CALL PUSHREAL8(max20)
4328           max20 = qci(i, k, 2)
4329           CALL PUSHCONTROL1B(1)
4330         END IF
4331         CALL PUSHREAL8(d)
4332         d = SQRT(den(i, k))*SQRT(SQRT(max5))*max20**(5./4.)
4333         IF (vt2r - vt2i .GE. 0.) THEN
4334           CALL PUSHREAL8(abs0)
4335           abs0 = vt2r - vt2i
4336           CALL PUSHCONTROL1B(0)
4337         ELSE
4338           CALL PUSHREAL8(abs0)
4339           abs0 = -(vt2r-vt2i)
4340           CALL PUSHCONTROL1B(1)
4341         END IF
4342         praci1 = praci_a*abs0*(praci_b*b+praci_c*c+praci_d*d)
4343         IF (praci1 .GT. qci(i, k, 2)/dtcld) THEN
4344           praci(i, k) = qci(i, k, 2)/dtcld
4345           CALL PUSHCONTROL1B(0)
4346         ELSE
4347           praci(i, k) = praci1
4348           CALL PUSHCONTROL1B(1)
4349         END IF
4350         CALL PUSHREAL8(praci(i, k))
4351         praci(i, k) = fsupcol*praci(i, k)
4352 !update qi, qs, qg
4353         IF (qrs(i, k, 1) .LT. 1.e-4) THEN
4354           CALL PUSHREAL8(delta3)
4355           delta3 = 1.
4356           CALL PUSHCONTROL1B(1)
4357         ELSE
4358           CALL PUSHREAL8(delta3)
4359           delta3 = 0.
4360           CALL PUSHCONTROL1B(0)
4361         END IF
4362         IF (praci(i, k) .GE. 0.) THEN
4363           abs1 = praci(i, k)
4364         ELSE
4365           abs1 = -praci(i, k)
4366         END IF
4367         IF (abs1 .LT. qmin/dtcld) THEN
4368           praci(i, k) = 0.
4369           CALL PUSHCONTROL1B(1)
4370         ELSE
4371           CALL PUSHCONTROL1B(0)
4372         END IF
4373         IF (qci(i, k, 2) - praci(i, k)*dtcld .LT. 0.) THEN
4374           qci(i, k, 2) = 0.
4375           CALL PUSHCONTROL1B(0)
4376         ELSE
4377           qci(i, k, 2) = qci(i, k, 2) - praci(i, k)*dtcld
4378           CALL PUSHCONTROL1B(1)
4379         END IF
4380         x1 = qrs(i, k, 2) + praci(i, k)*delta3*dtcld
4381         IF (x1 .LT. 0.) THEN
4382           qrs(i, k, 2) = 0.
4383           CALL PUSHCONTROL1B(0)
4384         ELSE
4385           qrs(i, k, 2) = x1
4386           CALL PUSHCONTROL1B(1)
4387         END IF
4388         x2 = qrs(i, k, 3) + praci(i, k)*(1-delta3)*dtcld
4389         IF (x2 .LT. 0.) THEN
4390           qrs(i, k, 3) = 0.
4391           CALL PUSHCONTROL1B(0)
4392         ELSE
4393           qrs(i, k, 3) = x2
4394           CALL PUSHCONTROL1B(1)
4395         END IF
4396 !-------------------------------------------------------------
4397 ! piacr: Accretion of rain by cloud ice [LFO 26]
4398 !        (T<T0: R->S or R->G) piacr: min=0,max=qrs(i,k,1)/dtcld
4399 !-------------------------------------------------------------
4400 !         supcol = t0c-t(i,k) !not change
4401         CALL PUSHREAL8(fsupcol)
4402         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
4403 !call smoothif(qci(i,k,2),qmin  ,fqi,'q0')
4404 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
4405 !update cpm
4406         cpm(i, k) = CPMCAL(q(i, k))
4407         xl(i, k) = XLCAL(t(i, k))
4408         CALL PUSHREAL8(xlf)
4409         xlf = xls - xl(i, k)
4410         IF (supcol .LT. 0.) THEN
4411           xlf = xlf0
4412           CALL PUSHCONTROL1B(0)
4413         ELSE
4414           CALL PUSHCONTROL1B(1)
4415         END IF
4416         IF (qci(i, k, 2) .GT. 0. .AND. qrs(i, k, 1) .GT. 0.) THEN
4417 !piacr_a=1.75e5
4418           piacr1 = piacr_a*den(i, k)**((3.+bvtr)/4.)*qci(i, k, 2)**0.75*&
4419 &           qrs(i, k, 1)**((6.+bvtr)/4.)
4420           CALL PUSHCONTROL1B(1)
4421         ELSE
4422           CALL PUSHCONTROL1B(0)
4423           piacr1 = 0.
4424         END IF
4425         IF (piacr1 .GT. qrs(i, k, 1)/dtcld) THEN
4426           piacr(i, k) = qrs(i, k, 1)/dtcld
4427           CALL PUSHCONTROL1B(0)
4428         ELSE
4429           piacr(i, k) = piacr1
4430           CALL PUSHCONTROL1B(1)
4431         END IF
4432         CALL PUSHREAL8(piacr(i, k))
4433         piacr(i, k) = fsupcol*piacr(i, k)
4434 ! update qr,qs,qg,t
4435         IF (qrs(i, k, 1) .LT. 1.e-4) THEN
4436           CALL PUSHREAL8(delta3)
4437           delta3 = 1.
4438           CALL PUSHCONTROL1B(1)
4439         ELSE
4440           CALL PUSHREAL8(delta3)
4441           delta3 = 0.
4442           CALL PUSHCONTROL1B(0)
4443         END IF
4444         IF (piacr(i, k) .GE. 0.) THEN
4445           abs2 = piacr(i, k)
4446         ELSE
4447           abs2 = -piacr(i, k)
4448         END IF
4449         IF (abs2 .LT. qmin/dtcld) THEN
4450           piacr(i, k) = 0.
4451           CALL PUSHCONTROL1B(1)
4452         ELSE
4453           CALL PUSHCONTROL1B(0)
4454         END IF
4455         IF (qrs(i, k, 1) - piacr(i, k)*dtcld .LT. 0.) THEN
4456           CALL PUSHREAL8(qrs(i, k, 1))
4457           qrs(i, k, 1) = 0.
4458           CALL PUSHCONTROL1B(0)
4459         ELSE
4460           CALL PUSHREAL8(qrs(i, k, 1))
4461           qrs(i, k, 1) = qrs(i, k, 1) - piacr(i, k)*dtcld
4462           CALL PUSHCONTROL1B(1)
4463         END IF
4464         x3 = qrs(i, k, 2) + piacr(i, k)*delta3*dtcld
4465         IF (x3 .LT. 0.) THEN
4466           CALL PUSHREAL8(qrs(i, k, 2))
4467           qrs(i, k, 2) = 0.
4468           CALL PUSHCONTROL1B(0)
4469         ELSE
4470           CALL PUSHREAL8(qrs(i, k, 2))
4471           qrs(i, k, 2) = x3
4472           CALL PUSHCONTROL1B(1)
4473         END IF
4474         x4 = qrs(i, k, 3) + piacr(i, k)*(1-delta3)*dtcld
4475         IF (x4 .LT. 0.) THEN
4476           CALL PUSHREAL8(qrs(i, k, 3))
4477           qrs(i, k, 3) = 0.
4478           CALL PUSHCONTROL1B(0)
4479         ELSE
4480           CALL PUSHREAL8(qrs(i, k, 3))
4481           qrs(i, k, 3) = x4
4482           CALL PUSHCONTROL1B(1)
4483         END IF
4484         t(i, k) = t(i, k) + piacr(i, k)*dtcld*xlf/cpm(i, k)
4485 !-------------------------------------------------------------
4486 ! psaci: Accretion of cloud ice by snow [HDC 10]
4487 !        (T<T0: I->S) psaci: min=0, max=qci(i,k,2)/dtcld
4488 !-------------------------------------------------------------
4489         CALL PUSHREAL8(supcol)
4490         supcol = t0c - t(i, k)
4491         CALL PUSHREAL8(fsupcol)
4492         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
4493         x5 = EXP(0.07*(-supcol))
4494         IF (x5 .GT. 1.) THEN
4495           CALL PUSHREAL8(eacrs)
4496           eacrs = 1.
4497           CALL PUSHCONTROL1B(0)
4498         ELSE
4499           CALL PUSHREAL8(eacrs)
4500           eacrs = x5
4501           CALL PUSHCONTROL1B(1)
4502         END IF
4503         IF (qrs(i, k, 2) .LT. qcrmin) THEN
4504           CALL PUSHREAL8(max6)
4505           max6 = qcrmin
4506           CALL PUSHCONTROL1B(0)
4507         ELSE
4508           CALL PUSHREAL8(max6)
4509           max6 = qrs(i, k, 2)
4510           CALL PUSHCONTROL1B(1)
4511         END IF
4512         IF (90. .GT. t0c - t(i, k)) THEN
4513           y6 = t0c - t(i, k)
4514           CALL PUSHCONTROL1B(0)
4515         ELSE
4516           CALL PUSHCONTROL1B(1)
4517           y6 = 90.
4518         END IF
4519         IF (0. .LT. y6) THEN
4520           CALL PUSHREAL8(max21)
4521           max21 = y6
4522           CALL PUSHCONTROL1B(0)
4523         ELSE
4524           CALL PUSHREAL8(max21)
4525           max21 = 0.
4526           CALL PUSHCONTROL1B(1)
4527         END IF
4528         vt2s = vt2s_a*den(i, k)**((bvts-2.)/4.)*max6**(bvts/4.)*EXP(-(&
4529 &         alpha*bvts*max21/4.))
4530         IF (qci(i, k, 2) .LT. qmin) THEN
4531           CALL PUSHREAL8(max7)
4532           max7 = qmin
4533           CALL PUSHCONTROL1B(0)
4534         ELSE
4535           CALL PUSHREAL8(max7)
4536           max7 = qci(i, k, 2)
4537           CALL PUSHCONTROL1B(1)
4538         END IF
4539         vt2i = vt2i_a*(den(i, k)*max7)**(1.31/8.)
4540         IF (90. .GT. t0c - t(i, k)) THEN
4541           y1 = t0c - t(i, k)
4542           CALL PUSHCONTROL1B(0)
4543         ELSE
4544           CALL PUSHCONTROL1B(1)
4545           y1 = 90.
4546         END IF
4547         IF (0. .LT. y1) THEN
4548           CALL PUSHREAL8(max8)
4549           max8 = y1
4550           CALL PUSHCONTROL1B(0)
4551         ELSE
4552           CALL PUSHREAL8(max8)
4553           max8 = 0.
4554           CALL PUSHCONTROL1B(1)
4555         END IF
4556         CALL PUSHREAL8(a)
4557         a = EXP(alpha*max8)
4558         IF (90. .GT. t0c - t(i, k)) THEN
4559           y2 = t0c - t(i, k)
4560           CALL PUSHCONTROL1B(0)
4561         ELSE
4562           CALL PUSHCONTROL1B(1)
4563           y2 = 90.
4564         END IF
4565         IF (0. .LT. y2) THEN
4566           CALL PUSHREAL8(max9)
4567           max9 = y2
4568           CALL PUSHCONTROL1B(1)
4569         ELSE
4570           CALL PUSHREAL8(max9)
4571           max9 = 0.
4572           CALL PUSHCONTROL1B(0)
4573         END IF
4574         IF (qrs(i, k, 2) .LT. qcrmin) THEN
4575           CALL PUSHREAL8(max22)
4576           max22 = qcrmin
4577           CALL PUSHCONTROL1B(1)
4578         ELSE
4579           CALL PUSHREAL8(max22)
4580           max22 = qrs(i, k, 2)
4581           CALL PUSHCONTROL1B(0)
4582         END IF
4583         IF (qci(i, k, 2) .LT. qmin) THEN
4584           CALL PUSHREAL8(max28)
4585           max28 = qmin
4586           CALL PUSHCONTROL1B(0)
4587         ELSE
4588           CALL PUSHREAL8(max28)
4589           max28 = qci(i, k, 2)
4590           CALL PUSHCONTROL1B(1)
4591         END IF
4592         b = EXP(-(3.*alpha*max9/4.))*(den(i, k)*max22)**(3./4.)*max28
4593         IF (90. .GT. t0c - t(i, k)) THEN
4594           y3 = t0c - t(i, k)
4595           CALL PUSHCONTROL1B(0)
4596         ELSE
4597           CALL PUSHCONTROL1B(1)
4598           y3 = 90.
4599         END IF
4600         IF (0. .LT. y3) THEN
4601           CALL PUSHREAL8(max10)
4602           max10 = y3
4603           CALL PUSHCONTROL1B(1)
4604         ELSE
4605           CALL PUSHREAL8(max10)
4606           max10 = 0.
4607           CALL PUSHCONTROL1B(0)
4608         END IF
4609         IF (qrs(i, k, 2) .LT. qcrmin) THEN
4610           CALL PUSHREAL8(max23)
4611           max23 = qcrmin
4612           CALL PUSHCONTROL1B(1)
4613         ELSE
4614           CALL PUSHREAL8(max23)
4615           max23 = qrs(i, k, 2)
4616           CALL PUSHCONTROL1B(0)
4617         END IF
4618         IF (qci(i, k, 2) .LT. qmin) THEN
4619           CALL PUSHREAL8(max29)
4620           max29 = qmin
4621           CALL PUSHCONTROL1B(0)
4622         ELSE
4623           CALL PUSHREAL8(max29)
4624           max29 = qci(i, k, 2)
4625           CALL PUSHCONTROL1B(1)
4626         END IF
4627         CALL PUSHREAL8(c)
4628         c = EXP(-(alpha*max10/2.))*den(i, k)**(5./8.)*SQRT(max23)*max29&
4629 &         **(9./8.)
4630         IF (90. .GT. t0c - t(i, k)) THEN
4631           y4 = t0c - t(i, k)
4632           CALL PUSHCONTROL1B(0)
4633         ELSE
4634           CALL PUSHCONTROL1B(1)
4635           y4 = 90.
4636         END IF
4637         IF (0. .LT. y4) THEN
4638           CALL PUSHREAL8(max11)
4639           max11 = y4
4640           CALL PUSHCONTROL1B(1)
4641         ELSE
4642           CALL PUSHREAL8(max11)
4643           max11 = 0.
4644           CALL PUSHCONTROL1B(0)
4645         END IF
4646         IF (qrs(i, k, 2) .LT. qcrmin) THEN
4647           CALL PUSHREAL8(max24)
4648           max24 = qcrmin
4649           CALL PUSHCONTROL1B(1)
4650         ELSE
4651           CALL PUSHREAL8(max24)
4652           max24 = qrs(i, k, 2)
4653           CALL PUSHCONTROL1B(0)
4654         END IF
4655         IF (qci(i, k, 2) .LT. qmin) THEN
4656           CALL PUSHREAL8(max30)
4657           max30 = qmin
4658           CALL PUSHCONTROL1B(0)
4659         ELSE
4660           CALL PUSHREAL8(max30)
4661           max30 = qci(i, k, 2)
4662           CALL PUSHCONTROL1B(1)
4663         END IF
4664         CALL PUSHREAL8(d)
4665         d = EXP(-(alpha*max11/4.))*SQRT(den(i, k))*SQRT(SQRT(max24))*&
4666 &         max30**(5./4.)
4667         IF (vt2s - vt2i .GE. 0.) THEN
4668           CALL PUSHREAL8(abs3)
4669           abs3 = vt2s - vt2i
4670           CALL PUSHCONTROL1B(0)
4671         ELSE
4672           CALL PUSHREAL8(abs3)
4673           abs3 = -(vt2s-vt2i)
4674           CALL PUSHCONTROL1B(1)
4675         END IF
4676         psaci1 = psaci_a*a*abs3*(psaci_b*b+psaci_c*c+psaci_d*d)*eacrs
4677         IF (psaci1 .GT. qci(i, k, 2)/dtcld) THEN
4678           psaci(i, k) = qci(i, k, 2)/dtcld
4679           CALL PUSHCONTROL1B(0)
4680         ELSE
4681           psaci(i, k) = psaci1
4682           CALL PUSHCONTROL1B(1)
4683         END IF
4684         CALL PUSHREAL8(psaci(i, k))
4685         psaci(i, k) = fsupcol*psaci(i, k)
4686         IF (psaci(i, k) .GE. 0.) THEN
4687           abs4 = psaci(i, k)
4688         ELSE
4689           abs4 = -psaci(i, k)
4690         END IF
4691         IF (abs4 .LT. qmin/dtcld) THEN
4692           psaci(i, k) = 0.
4693           CALL PUSHCONTROL1B(1)
4694         ELSE
4695           CALL PUSHCONTROL1B(0)
4696         END IF
4697         IF (qci(i, k, 2) - psaci(i, k)*dtcld .LT. 0.) THEN
4698           CALL PUSHREAL8(qci(i, k, 2))
4699           qci(i, k, 2) = 0.
4700           CALL PUSHCONTROL1B(0)
4701         ELSE
4702           CALL PUSHREAL8(qci(i, k, 2))
4703           qci(i, k, 2) = qci(i, k, 2) - psaci(i, k)*dtcld
4704           CALL PUSHCONTROL1B(1)
4705         END IF
4706         IF (qrs(i, k, 2) + psaci(i, k)*dtcld .LT. 0.) THEN
4707           CALL PUSHREAL8(qrs(i, k, 2))
4708           qrs(i, k, 2) = 0.
4709           CALL PUSHCONTROL1B(0)
4710         ELSE
4711           CALL PUSHREAL8(qrs(i, k, 2))
4712           qrs(i, k, 2) = qrs(i, k, 2) + psaci(i, k)*dtcld
4713           CALL PUSHCONTROL1B(1)
4714         END IF
4715 !-------------------------------------------------------------
4716 ! pgaci: Accretion of cloud ice by graupel [LFO 41]
4717 !        (T<T0: I->G) pgaci:min=0,max=qci(i,k,2)/dtcld
4718 !-------------------------------------------------------------
4719 !         supcol = t0c-t(i,k) !not change
4720 !         call smoothif(supcol,    0.,fsupcol,'t0')
4721 !call smoothif(qci(i,k,2),qmin  ,fqi,'q0')
4722 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
4723 !min(exp(0.07*(-supcol)),1.)
4724         CALL PUSHREAL8(egi)
4725         egi = eacrs
4726         IF (qrs(i, k, 3) .LT. qcrmin) THEN
4727           CALL PUSHREAL8(max12)
4728           max12 = qcrmin
4729           CALL PUSHCONTROL1B(0)
4730         ELSE
4731           CALL PUSHREAL8(max12)
4732           max12 = qrs(i, k, 3)
4733           CALL PUSHCONTROL1B(1)
4734         END IF
4735         vt2g = vt2g_a*den(i, k)**((bvtg-2.)/4.)*max12**(bvtg/4.)
4736         IF (qci(i, k, 2) .LT. qmin) THEN
4737           CALL PUSHREAL8(max13)
4738           max13 = qmin
4739           CALL PUSHCONTROL1B(0)
4740         ELSE
4741           CALL PUSHREAL8(max13)
4742           max13 = qci(i, k, 2)
4743           CALL PUSHCONTROL1B(1)
4744         END IF
4745         vt2i = vt2i_a*(den(i, k)*max13)**(1.31/8.)
4746         IF (qrs(i, k, 3) .LT. qcrmin) THEN
4747           CALL PUSHREAL8(max14)
4748           max14 = qcrmin
4749           CALL PUSHCONTROL1B(1)
4750         ELSE
4751           CALL PUSHREAL8(max14)
4752           max14 = qrs(i, k, 3)
4753           CALL PUSHCONTROL1B(0)
4754         END IF
4755         IF (qci(i, k, 2) .LT. qmin) THEN
4756           CALL PUSHREAL8(max25)
4757           max25 = qmin
4758           CALL PUSHCONTROL1B(0)
4759         ELSE
4760           CALL PUSHREAL8(max25)
4761           max25 = qci(i, k, 2)
4762           CALL PUSHCONTROL1B(1)
4763         END IF
4764         CALL PUSHREAL8(b)
4765         b = (den(i, k)*max14)**(3./4.)*max25
4766         IF (qrs(i, k, 3) .LT. qcrmin) THEN
4767           CALL PUSHREAL8(max15)
4768           max15 = qcrmin
4769           CALL PUSHCONTROL1B(1)
4770         ELSE
4771           CALL PUSHREAL8(max15)
4772           max15 = qrs(i, k, 3)
4773           CALL PUSHCONTROL1B(0)
4774         END IF
4775         IF (qci(i, k, 2) .LT. qmin) THEN
4776           CALL PUSHREAL8(max26)
4777           max26 = qmin
4778           CALL PUSHCONTROL1B(0)
4779         ELSE
4780           CALL PUSHREAL8(max26)
4781           max26 = qci(i, k, 2)
4782           CALL PUSHCONTROL1B(1)
4783         END IF
4784         CALL PUSHREAL8(c)
4785         c = den(i, k)**(5./8.)*SQRT(max15)*max26**(9./8.)
4786         IF (qrs(i, k, 3) .LT. qcrmin) THEN
4787           CALL PUSHREAL8(max16)
4788           max16 = qcrmin
4789           CALL PUSHCONTROL1B(1)
4790         ELSE
4791           CALL PUSHREAL8(max16)
4792           max16 = qrs(i, k, 3)
4793           CALL PUSHCONTROL1B(0)
4794         END IF
4795         IF (qci(i, k, 2) .LT. qmin) THEN
4796           CALL PUSHREAL8(max27)
4797           max27 = qmin
4798           CALL PUSHCONTROL1B(0)
4799         ELSE
4800           CALL PUSHREAL8(max27)
4801           max27 = qci(i, k, 2)
4802           CALL PUSHCONTROL1B(1)
4803         END IF
4804         CALL PUSHREAL8(d)
4805         d = SQRT(den(i, k))*SQRT(SQRT(max16))*max27**(5./4.)
4806         IF (vt2g - vt2i .GE. 0.) THEN
4807           CALL PUSHREAL8(abs5)
4808           abs5 = vt2g - vt2i
4809           CALL PUSHCONTROL1B(0)
4810         ELSE
4811           CALL PUSHREAL8(abs5)
4812           abs5 = -(vt2g-vt2i)
4813           CALL PUSHCONTROL1B(1)
4814         END IF
4815         pgaci1 = pgaci_a*abs5*(pgaci_b*b+pgaci_c*c+pgaci_d*d)*egi
4816         IF (pgaci1 .GT. qci(i, k, 2)/dtcld) THEN
4817           pgaci(i, k) = qci(i, k, 2)/dtcld
4818           CALL PUSHCONTROL1B(0)
4819         ELSE
4820           pgaci(i, k) = pgaci1
4821           CALL PUSHCONTROL1B(1)
4822         END IF
4823         CALL PUSHREAL8(pgaci(i, k))
4824         pgaci(i, k) = fsupcol*pgaci(i, k)
4825         IF (pgaci(i, k) .GE. 0.) THEN
4826           abs6 = pgaci(i, k)
4827         ELSE
4828           abs6 = -pgaci(i, k)
4829         END IF
4830         IF (abs6 .LT. qmin/dtcld) THEN
4831           pgaci(i, k) = 0.
4832           CALL PUSHCONTROL1B(1)
4833         ELSE
4834           CALL PUSHCONTROL1B(0)
4835         END IF
4836         IF (qci(i, k, 2) - pgaci(i, k)*dtcld .LT. 0.) THEN
4837           CALL PUSHREAL8(qci(i, k, 2))
4838           qci(i, k, 2) = 0.
4839           CALL PUSHCONTROL1B(0)
4840         ELSE
4841           CALL PUSHREAL8(qci(i, k, 2))
4842           qci(i, k, 2) = qci(i, k, 2) - pgaci(i, k)*dtcld
4843           CALL PUSHCONTROL1B(1)
4844         END IF
4845         IF (qrs(i, k, 3) + pgaci(i, k)*dtcld .LT. 0.) THEN
4846           CALL PUSHREAL8(qrs(i, k, 3))
4847           qrs(i, k, 3) = 0.
4848           CALL PUSHCONTROL1B(0)
4849         ELSE
4850           CALL PUSHREAL8(qrs(i, k, 3))
4851           qrs(i, k, 3) = qrs(i, k, 3) + pgaci(i, k)*dtcld
4852           CALL PUSHCONTROL1B(1)
4853         END IF
4854 !-------------------------------------------------------------
4855 ! psacw: Accretion of cloud water by snow  [LFO 24]
4856 !        (T<T0: C->G, and T>=T0: C->R) psacw:min=0,max=qci(i,k,1)/dtcld
4857 !-------------------------------------------------------------
4858 !         supcol = t0c-t(i,k) !not change
4859 !         call smoothif(supcol,    0.,fsupcol,'t0')
4860 !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0')
4861 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
4862 !update cpm
4863 !         cpm(i,k)=cpmcal(q(i,k)) !not change
4864         xl(i, k) = XLCAL(t(i, k))
4865         CALL PUSHREAL8(xlf)
4866         xlf = xls - xl(i, k)
4867         IF (supcol .LT. 0.) THEN
4868           xlf = xlf0
4869           CALL PUSHCONTROL1B(0)
4870         ELSE
4871           CALL PUSHCONTROL1B(1)
4872         END IF
4873         IF (qrs(i, k, 2) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN
4874           IF (90. .GT. t0c - t(i, k)) THEN
4875             y5 = t0c - t(i, k)
4876             CALL PUSHCONTROL1B(0)
4877           ELSE
4878             CALL PUSHCONTROL1B(1)
4879             y5 = 90.
4880           END IF
4881           IF (0. .LT. y5) THEN
4882             CALL PUSHREAL8(max17)
4883             max17 = y5
4884             CALL PUSHCONTROL1B(0)
4885           ELSE
4886             CALL PUSHREAL8(max17)
4887             max17 = 0.
4888             CALL PUSHCONTROL1B(1)
4889           END IF
4890           CALL PUSHREAL8(a)
4891           a = EXP((1.-bvts)*alpha*max17/4.)
4892           psacw(i, k) = psacw_a*a*den(i, k)**((1.+bvts)/4.)*qrs(i, k, 2)&
4893 &           **((3.+bvts)/4.)*qci(i, k, 1)
4894           CALL PUSHCONTROL1B(0)
4895         ELSE
4896           psacw(i, k) = 0.
4897           CALL PUSHCONTROL1B(1)
4898         END IF
4899         IF (psacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
4900           x6 = qci(i, k, 1)/dtcld
4901           CALL PUSHCONTROL1B(0)
4902         ELSE
4903           x6 = psacw(i, k)
4904           CALL PUSHCONTROL1B(1)
4905         END IF
4906         IF (x6 .LT. 0.) THEN
4907           psacw(i, k) = 0.
4908           CALL PUSHCONTROL1B(0)
4909         ELSE
4910           psacw(i, k) = x6
4911           CALL PUSHCONTROL1B(1)
4912         END IF
4913         CALL PUSHREAL8(psacw(i, k))
4914         psacw(i, k) = fsupcol*psacw(i, k)
4915         IF (psacw(i, k) .GE. 0.) THEN
4916           abs7 = psacw(i, k)
4917         ELSE
4918           abs7 = -psacw(i, k)
4919         END IF
4920         IF (abs7 .LT. qmin/dtcld) THEN
4921           psacw(i, k) = 0.
4922           CALL PUSHCONTROL1B(1)
4923         ELSE
4924           CALL PUSHCONTROL1B(0)
4925         END IF
4926         IF (qci(i, k, 1) - psacw(i, k)*dtcld .LT. 0.) THEN
4927           CALL PUSHREAL8(qci(i, k, 1))
4928           qci(i, k, 1) = 0.
4929           CALL PUSHCONTROL1B(0)
4930         ELSE
4931           CALL PUSHREAL8(qci(i, k, 1))
4932           qci(i, k, 1) = qci(i, k, 1) - psacw(i, k)*dtcld
4933           CALL PUSHCONTROL1B(1)
4934         END IF
4935         x7 = qrs(i, k, 1) + (1.-fsupcol)*psacw(i, k)*dtcld
4936         IF (x7 .LT. 0.) THEN
4937           CALL PUSHREAL8(qrs(i, k, 1))
4938           qrs(i, k, 1) = 0.
4939           CALL PUSHCONTROL1B(0)
4940         ELSE
4941           CALL PUSHREAL8(qrs(i, k, 1))
4942           qrs(i, k, 1) = x7
4943           CALL PUSHCONTROL1B(1)
4944         END IF
4945         x8 = qrs(i, k, 3) + fsupcol*psacw(i, k)*dtcld
4946         IF (x8 .LT. 0.) THEN
4947           CALL PUSHREAL8(qrs(i, k, 3))
4948           qrs(i, k, 3) = 0.
4949           CALL PUSHCONTROL1B(0)
4950         ELSE
4951           CALL PUSHREAL8(qrs(i, k, 3))
4952           qrs(i, k, 3) = x8
4953           CALL PUSHCONTROL1B(1)
4954         END IF
4955         t(i, k) = t(i, k) + fsupcol*psacw(i, k)*dtcld*xlf/cpm(i, k)
4956 !t>=t0 pseml
4957 !-------------------------------------------------------------
4958 ! pgacw: Accretion of cloud water by graupel [LFO 40]
4959 !        (T<T0: C->G, and T>=T0: C->R) pgacw:min=0.,max=qci(i,k,1)/dtcld
4960 !-------------------------------------------------------------
4961         CALL PUSHREAL8(supcol)
4962         supcol = t0c - t(i, k)
4963         CALL PUSHREAL8(fsupcol)
4964         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
4965 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
4966 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
4967 !         cpm(i,k)=cpmcal(q(i,k)) !not change
4968         xl(i, k) = XLCAL(t(i, k))
4969         CALL PUSHREAL8(xlf)
4970         xlf = xls - xl(i, k)
4971         IF (supcol .LT. 0.) THEN
4972           xlf = xlf0
4973           CALL PUSHCONTROL1B(0)
4974         ELSE
4975           CALL PUSHCONTROL1B(1)
4976         END IF
4977         IF (qrs(i, k, 3) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN
4978           pgacw(i, k) = pgacw_a*den(i, k)**((1.+bvtg)/4.)*qrs(i, k, 3)**&
4979 &           ((3.+bvtg)/4.)*qci(i, k, 1)
4980           CALL PUSHCONTROL1B(0)
4981         ELSE
4982           pgacw(i, k) = 0.
4983           CALL PUSHCONTROL1B(1)
4984         END IF
4985         IF (pgacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
4986           x9 = qci(i, k, 1)/dtcld
4987           CALL PUSHCONTROL1B(0)
4988         ELSE
4989           x9 = pgacw(i, k)
4990           CALL PUSHCONTROL1B(1)
4991         END IF
4992         IF (x9 .LT. 0.) THEN
4993           pgacw(i, k) = 0.
4994           CALL PUSHCONTROL1B(0)
4995         ELSE
4996           pgacw(i, k) = x9
4997           CALL PUSHCONTROL1B(1)
4998         END IF
4999         IF (pgacw(i, k) .GE. 0.) THEN
5000           abs8 = pgacw(i, k)
5001         ELSE
5002           abs8 = -pgacw(i, k)
5003         END IF
5004 !pgacw(i,k)=fqg*fqc*pgacw(i,k)
5005         IF (abs8 .LT. qmin/dtcld) THEN
5006           pgacw(i, k) = 0.
5007           CALL PUSHCONTROL1B(1)
5008         ELSE
5009           CALL PUSHCONTROL1B(0)
5010         END IF
5011         IF (qci(i, k, 1) - pgacw(i, k)*dtcld .LT. 0.) THEN
5012           CALL PUSHCONTROL1B(0)
5013         ELSE
5014           CALL PUSHCONTROL1B(1)
5015         END IF
5016         x10 = qrs(i, k, 1) + (1.-fsupcol)*pgacw(i, k)*dtcld
5017         IF (x10 .LT. 0.) THEN
5018           CALL PUSHREAL8(qrs(i, k, 1))
5019           qrs(i, k, 1) = 0.
5020           CALL PUSHCONTROL1B(0)
5021         ELSE
5022           CALL PUSHREAL8(qrs(i, k, 1))
5023           qrs(i, k, 1) = x10
5024           CALL PUSHCONTROL1B(1)
5025         END IF
5026         x11 = qrs(i, k, 3) + fsupcol*pgacw(i, k)*dtcld
5027         IF (x11 .LT. 0.) THEN
5028           CALL PUSHCONTROL1B(0)
5029         ELSE
5030           CALL PUSHCONTROL1B(1)
5031         END IF
5032       END DO
5033     END DO
5034     a_cpm = 0.0_8
5035     a_xl = 0.0_8
5036     DO k=kte,kts,-1
5037       DO i=ite,its,-1
5038         a_temp4 = dtcld*a_t(i, k)
5039         a_temp6 = fsupcol*xlf*a_temp4/cpm(i, k)
5040         temp8 = pgacw(i, k)/cpm(i, k)
5041         a_fsupcol = xlf*temp8*a_temp4 - pgacw(i, k)*a_pgacw(i, k)
5042         a_pgacw(i, k) = (1-fsupcol)*a_pgacw(i, k) + a_temp6
5043         a_xlf = fsupcol*temp8*a_temp4
5044         a_cpm(i, k) = a_cpm(i, k) - temp8*a_temp6
5045         CALL POPCONTROL1B(branch)
5046         IF (branch .EQ. 0) THEN
5047           a_qrs(i, k, 3) = 0.0_8
5048           a_x11 = 0.0_8
5049         ELSE
5050           a_x11 = a_qrs(i, k, 3)
5051           a_qrs(i, k, 3) = 0.0_8
5052         END IF
5053         a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_x11
5054         a_fsupcol = a_fsupcol + pgacw(i, k)*dtcld*a_x11
5055         a_pgacw(i, k) = a_pgacw(i, k) + fsupcol*dtcld*a_x11
5056         CALL POPCONTROL1B(branch)
5057         IF (branch .EQ. 0) THEN
5058           CALL POPREAL8(qrs(i, k, 1))
5059           a_qrs(i, k, 1) = 0.0_8
5060           a_x10 = 0.0_8
5061         ELSE
5062           CALL POPREAL8(qrs(i, k, 1))
5063           a_x10 = a_qrs(i, k, 1)
5064           a_qrs(i, k, 1) = 0.0_8
5065         END IF
5066         a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_x10
5067         a_fsupcol = a_fsupcol - pgacw(i, k)*dtcld*a_x10
5068         a_pgacw(i, k) = a_pgacw(i, k) + (1.-fsupcol)*dtcld*a_x10
5069         CALL POPCONTROL1B(branch)
5070         IF (branch .EQ. 0) THEN
5071           a_qci(i, k, 1) = 0.0_8
5072         ELSE
5073           a_pgacw(i, k) = a_pgacw(i, k) - dtcld*a_qci(i, k, 1)
5074         END IF
5075         CALL POPCONTROL1B(branch)
5076         IF (branch .NE. 0) a_pgacw(i, k) = 0.0_8
5077         CALL POPCONTROL1B(branch)
5078         IF (branch .EQ. 0) THEN
5079           a_pgacw(i, k) = 0.0_8
5080           a_x9 = 0.0_8
5081         ELSE
5082           a_x9 = a_pgacw(i, k)
5083           a_pgacw(i, k) = 0.0_8
5084         END IF
5085         CALL POPCONTROL1B(branch)
5086         IF (branch .EQ. 0) THEN
5087           a_qci(i, k, 1) = a_qci(i, k, 1) + a_x9/dtcld
5088         ELSE
5089           a_pgacw(i, k) = a_pgacw(i, k) + a_x9
5090         END IF
5091         CALL POPCONTROL1B(branch)
5092         IF (branch .EQ. 0) THEN
5093           temp9 = (bvtg+3.)/4.
5094           temp7 = (bvtg+1.)/4.
5095           temp6 = den(i, k)**temp7
5096           a_temp6 = qrs(i, k, 3)**temp9*pgacw_a*a_pgacw(i, k)
5097           IF (.NOT.(qrs(i, k, 3) .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR.&
5098 &             temp9 .NE. INT(temp9)))) a_qrs(i, k, 3) = a_qrs(i, k, 3) +&
5099 &             temp9*qrs(i, k, 3)**(temp9-1)*temp6*qci(i, k, 1)*pgacw_a*&
5100 &             a_pgacw(i, k)
5101           a_pgacw(i, k) = 0.0_8
5102           IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp7 .EQ. 0.0_8 .OR. &
5103 &             temp7 .NE. INT(temp7)))) a_den(i, k) = a_den(i, k) + temp7&
5104 &             *den(i, k)**(temp7-1)*qci(i, k, 1)*a_temp6
5105           a_qci(i, k, 1) = a_qci(i, k, 1) + temp6*a_temp6
5106         ELSE
5107           a_pgacw(i, k) = 0.0_8
5108         END IF
5109         CALL POPCONTROL1B(branch)
5110         IF (branch .EQ. 0) a_xlf = 0.0_8
5111         supcol = t0c - t(i, k)
5112         CALL POPREAL8(xlf)
5113         a_xl(i, k) = a_xl(i, k) - a_xlf
5114         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
5115         a_xl(i, k) = 0.0_8
5116         CALL POPREAL8(fsupcol)
5117         a_supcol = 0.0_8
5118         CALL A_SMOOTHIF(supcol, a_supcol, 0., fsupcol, a_fsupcol, 't0')
5119         CALL POPREAL8(supcol)
5120         a_t(i, k) = a_t(i, k) - a_supcol
5121         temp8 = psacw(i, k)/cpm(i, k)
5122         a_temp4 = dtcld*a_t(i, k)
5123         a_fsupcol = xlf*temp8*a_temp4 - psacw(i, k)*a_psacw(i, k)
5124         a_xlf = fsupcol*temp8*a_temp4
5125         a_temp6 = fsupcol*xlf*a_temp4/cpm(i, k)
5126         a_psacw(i, k) = (1-fsupcol)*a_psacw(i, k) + a_temp6
5127         a_cpm(i, k) = a_cpm(i, k) - temp8*a_temp6
5128         CALL POPCONTROL1B(branch)
5129         IF (branch .EQ. 0) THEN
5130           CALL POPREAL8(qrs(i, k, 3))
5131           a_qrs(i, k, 3) = 0.0_8
5132           a_x8 = 0.0_8
5133         ELSE
5134           CALL POPREAL8(qrs(i, k, 3))
5135           a_x8 = a_qrs(i, k, 3)
5136           a_qrs(i, k, 3) = 0.0_8
5137         END IF
5138         a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_x8
5139         a_fsupcol = a_fsupcol + psacw(i, k)*dtcld*a_x8
5140         a_psacw(i, k) = a_psacw(i, k) + fsupcol*dtcld*a_x8
5141         CALL POPCONTROL1B(branch)
5142         IF (branch .EQ. 0) THEN
5143           CALL POPREAL8(qrs(i, k, 1))
5144           a_qrs(i, k, 1) = 0.0_8
5145           a_x7 = 0.0_8
5146         ELSE
5147           CALL POPREAL8(qrs(i, k, 1))
5148           a_x7 = a_qrs(i, k, 1)
5149           a_qrs(i, k, 1) = 0.0_8
5150         END IF
5151         a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_x7
5152         a_fsupcol = a_fsupcol - psacw(i, k)*dtcld*a_x7
5153         a_psacw(i, k) = a_psacw(i, k) + (1.-fsupcol)*dtcld*a_x7
5154         CALL POPCONTROL1B(branch)
5155         IF (branch .EQ. 0) THEN
5156           CALL POPREAL8(qci(i, k, 1))
5157           a_qci(i, k, 1) = 0.0_8
5158         ELSE
5159           CALL POPREAL8(qci(i, k, 1))
5160           a_psacw(i, k) = a_psacw(i, k) - dtcld*a_qci(i, k, 1)
5161         END IF
5162         CALL POPCONTROL1B(branch)
5163         IF (branch .NE. 0) a_psacw(i, k) = 0.0_8
5164         CALL POPREAL8(psacw(i, k))
5165         a_fsupcol = a_fsupcol + psacw(i, k)*a_psacw(i, k)
5166         a_psacw(i, k) = fsupcol*a_psacw(i, k)
5167         CALL POPCONTROL1B(branch)
5168         IF (branch .EQ. 0) THEN
5169           a_psacw(i, k) = 0.0_8
5170           a_x6 = 0.0_8
5171         ELSE
5172           a_x6 = a_psacw(i, k)
5173           a_psacw(i, k) = 0.0_8
5174         END IF
5175         CALL POPCONTROL1B(branch)
5176         IF (branch .EQ. 0) THEN
5177           a_qci(i, k, 1) = a_qci(i, k, 1) + a_x6/dtcld
5178         ELSE
5179           a_psacw(i, k) = a_psacw(i, k) + a_x6
5180         END IF
5181         CALL POPCONTROL1B(branch)
5182         IF (branch .EQ. 0) THEN
5183           temp9 = (bvts+3.)/4.
5184           temp7 = a*qci(i, k, 1)
5185           temp6 = (bvts+1.)/4.
5186           temp5 = den(i, k)**temp6
5187           a_temp6 = qrs(i, k, 2)**temp9*psacw_a*a_psacw(i, k)
5188           IF (.NOT.(qrs(i, k, 2) .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR.&
5189 &             temp9 .NE. INT(temp9)))) a_qrs(i, k, 2) = a_qrs(i, k, 2) +&
5190 &             temp9*qrs(i, k, 2)**(temp9-1)*temp5*temp7*psacw_a*a_psacw(&
5191 &             i, k)
5192           a_psacw(i, k) = 0.0_8
5193           IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp6 .EQ. 0.0_8 .OR. &
5194 &             temp6 .NE. INT(temp6)))) a_den(i, k) = a_den(i, k) + temp6&
5195 &             *den(i, k)**(temp6-1)*temp7*a_temp6
5196           a_a = qci(i, k, 1)*temp5*a_temp6
5197           a_qci(i, k, 1) = a_qci(i, k, 1) + a*temp5*a_temp6
5198           CALL POPREAL8(a)
5199           a_max17 = (1.-bvts)*alpha*EXP((1.-bvts)*alpha*(max17/4.))*a_a/&
5200 &           4.
5201           CALL POPCONTROL1B(branch)
5202           IF (branch .EQ. 0) THEN
5203             CALL POPREAL8(max17)
5204             a_y5 = a_max17
5205           ELSE
5206             CALL POPREAL8(max17)
5207             a_y5 = 0.0_8
5208           END IF
5209           CALL POPCONTROL1B(branch)
5210           IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y5
5211         ELSE
5212           a_psacw(i, k) = 0.0_8
5213         END IF
5214         CALL POPCONTROL1B(branch)
5215         IF (branch .EQ. 0) a_xlf = 0.0_8
5216         CALL POPREAL8(xlf)
5217         a_xl(i, k) = a_xl(i, k) - a_xlf
5218         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
5219         a_xl(i, k) = 0.0_8
5220         a_pgaci(i, k) = 0.0_8
5221         CALL POPCONTROL1B(branch)
5222         IF (branch .EQ. 0) THEN
5223           CALL POPREAL8(qrs(i, k, 3))
5224           a_qrs(i, k, 3) = 0.0_8
5225         ELSE
5226           CALL POPREAL8(qrs(i, k, 3))
5227           a_pgaci(i, k) = a_pgaci(i, k) + dtcld*a_qrs(i, k, 3)
5228         END IF
5229         CALL POPCONTROL1B(branch)
5230         IF (branch .EQ. 0) THEN
5231           CALL POPREAL8(qci(i, k, 2))
5232           a_qci(i, k, 2) = 0.0_8
5233         ELSE
5234           CALL POPREAL8(qci(i, k, 2))
5235           a_pgaci(i, k) = a_pgaci(i, k) - dtcld*a_qci(i, k, 2)
5236         END IF
5237         CALL POPCONTROL1B(branch)
5238         IF (branch .NE. 0) a_pgaci(i, k) = 0.0_8
5239         CALL POPREAL8(pgaci(i, k))
5240         a_fsupcol = a_fsupcol + pgaci(i, k)*a_pgaci(i, k)
5241         a_pgaci(i, k) = fsupcol*a_pgaci(i, k)
5242         CALL POPCONTROL1B(branch)
5243         IF (branch .EQ. 0) THEN
5244           a_qci(i, k, 2) = a_qci(i, k, 2) + a_pgaci(i, k)/dtcld
5245           a_pgaci(i, k) = 0.0_8
5246           a_pgaci1 = 0.0_8
5247         ELSE
5248           a_pgaci1 = a_pgaci(i, k)
5249           a_pgaci(i, k) = 0.0_8
5250         END IF
5251         a_temp4 = abs5*egi*pgaci_a*a_pgaci1
5252         a_temp6 = (pgaci_b*b+pgaci_c*c+pgaci_d*d)*pgaci_a*a_pgaci1
5253         a_abs5 = egi*a_temp6
5254         a_egi = abs5*a_temp6
5255         a_b = pgaci_b*a_temp4
5256         a_c = pgaci_c*a_temp4
5257         a_d = pgaci_d*a_temp4
5258         CALL POPCONTROL1B(branch)
5259         IF (branch .EQ. 0) THEN
5260           CALL POPREAL8(abs5)
5261           a_vt2g = a_abs5
5262           a_vt2i = -a_abs5
5263         ELSE
5264           CALL POPREAL8(abs5)
5265           a_vt2i = a_abs5
5266           a_vt2g = -a_abs5
5267         END IF
5268         CALL POPREAL8(d)
5269         temp9 = SQRT(max16)
5270         temp8 = SQRT(temp9)
5271         temp7 = 5./4.
5272         temp6 = max27**temp7
5273         temp5 = SQRT(den(i, k))
5274         IF (.NOT.den(i, k) .EQ. 0.0_8) a_den(i, k) = a_den(i, k) + temp6&
5275 &           *temp8*a_d/(2.0*temp5)
5276         IF (max27 .LE. 0.0_8 .AND. (temp7 .EQ. 0.0_8 .OR. temp7 .NE. INT&
5277 &           (temp7))) THEN
5278           a_max27 = 0.0_8
5279         ELSE
5280           a_max27 = temp7*max27**(temp7-1)*temp5*temp8*a_d
5281         END IF
5282         IF (max16 .EQ. 0.0_8 .OR. temp9 .EQ. 0.0_8) THEN
5283           a_max16 = 0.0_8
5284         ELSE
5285           a_max16 = temp5*temp6*a_d/(2.0**2*temp9*temp8)
5286         END IF
5287         CALL POPCONTROL1B(branch)
5288         IF (branch .EQ. 0) THEN
5289           CALL POPREAL8(max27)
5290         ELSE
5291           CALL POPREAL8(max27)
5292           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max27
5293         END IF
5294         CALL POPCONTROL1B(branch)
5295         IF (branch .EQ. 0) THEN
5296           CALL POPREAL8(max16)
5297           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max16
5298         ELSE
5299           CALL POPREAL8(max16)
5300         END IF
5301         CALL POPREAL8(c)
5302         temp9 = 9./8.
5303         temp8 = max26**temp9
5304         temp7 = SQRT(max15)
5305         temp6 = 5./8.
5306         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp6 .EQ. 0.0_8 .OR. &
5307 &           temp6 .NE. INT(temp6)))) a_den(i, k) = a_den(i, k) + temp6*&
5308 &           den(i, k)**(temp6-1)*temp7*temp8*a_c
5309         a_temp0 = den(i, k)**temp6*a_c
5310         IF (max15 .EQ. 0.0_8) THEN
5311           a_max15 = 0.0_8
5312         ELSE
5313           a_max15 = temp8*a_temp0/(2.0*temp7)
5314         END IF
5315         IF (max26 .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR. temp9 .NE. INT&
5316 &           (temp9))) THEN
5317           a_max26 = 0.0_8
5318         ELSE
5319           a_max26 = temp9*max26**(temp9-1)*temp7*a_temp0
5320         END IF
5321         CALL POPCONTROL1B(branch)
5322         IF (branch .EQ. 0) THEN
5323           CALL POPREAL8(max26)
5324         ELSE
5325           CALL POPREAL8(max26)
5326           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max26
5327         END IF
5328         CALL POPCONTROL1B(branch)
5329         IF (branch .EQ. 0) THEN
5330           CALL POPREAL8(max15)
5331           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max15
5332         ELSE
5333           CALL POPREAL8(max15)
5334         END IF
5335         CALL POPREAL8(b)
5336         temp9 = den(i, k)*max14
5337         temp8 = 3./4.
5338         IF (temp9 .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. temp8 .NE. INT&
5339 &           (temp8))) THEN
5340           a_temp4 = 0.0_8
5341         ELSE
5342           a_temp4 = temp8*temp9**(temp8-1)*max25*a_b
5343         END IF
5344         a_max25 = temp9**temp8*a_b
5345         a_den(i, k) = a_den(i, k) + max14*a_temp4
5346         a_max14 = den(i, k)*a_temp4
5347         CALL POPCONTROL1B(branch)
5348         IF (branch .EQ. 0) THEN
5349           CALL POPREAL8(max25)
5350         ELSE
5351           CALL POPREAL8(max25)
5352           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max25
5353         END IF
5354         CALL POPCONTROL1B(branch)
5355         IF (branch .EQ. 0) THEN
5356           CALL POPREAL8(max14)
5357           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max14
5358         ELSE
5359           CALL POPREAL8(max14)
5360         END IF
5361         IF (den(i, k)*max13 .LE. 0.0_8 .AND. (1.31/8. .EQ. 0.0_8 .OR. &
5362 &           1.31/8. .NE. INT(1.31/8.))) THEN
5363           a_temp4 = 0.0_8
5364         ELSE
5365           a_temp4 = 1.31*(den(i, k)*max13)**(1.31/8.-1)*vt2i_a*a_vt2i/8.
5366         END IF
5367         a_den(i, k) = a_den(i, k) + max13*a_temp4
5368         a_max13 = den(i, k)*a_temp4
5369         CALL POPCONTROL1B(branch)
5370         IF (branch .EQ. 0) THEN
5371           CALL POPREAL8(max13)
5372         ELSE
5373           CALL POPREAL8(max13)
5374           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max13
5375         END IF
5376         temp9 = bvtg/4.
5377         temp8 = (bvtg-2.)/4.
5378         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. &
5379 &           temp8 .NE. INT(temp8)))) a_den(i, k) = a_den(i, k) + temp8*&
5380 &           den(i, k)**(temp8-1)*max12**temp9*vt2g_a*a_vt2g
5381         IF (max12 .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR. temp9 .NE. INT&
5382 &           (temp9))) THEN
5383           a_max12 = 0.0_8
5384         ELSE
5385           a_max12 = temp9*max12**(temp9-1)*den(i, k)**temp8*vt2g_a*&
5386 &           a_vt2g
5387         END IF
5388         CALL POPCONTROL1B(branch)
5389         IF (branch .EQ. 0) THEN
5390           CALL POPREAL8(max12)
5391         ELSE
5392           CALL POPREAL8(max12)
5393           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max12
5394         END IF
5395         CALL POPREAL8(egi)
5396         a_eacrs = a_egi
5397         a_psaci(i, k) = 0.0_8
5398         CALL POPCONTROL1B(branch)
5399         IF (branch .EQ. 0) THEN
5400           CALL POPREAL8(qrs(i, k, 2))
5401           a_qrs(i, k, 2) = 0.0_8
5402         ELSE
5403           CALL POPREAL8(qrs(i, k, 2))
5404           a_psaci(i, k) = a_psaci(i, k) + dtcld*a_qrs(i, k, 2)
5405         END IF
5406         CALL POPCONTROL1B(branch)
5407         IF (branch .EQ. 0) THEN
5408           CALL POPREAL8(qci(i, k, 2))
5409           a_qci(i, k, 2) = 0.0_8
5410         ELSE
5411           CALL POPREAL8(qci(i, k, 2))
5412           a_psaci(i, k) = a_psaci(i, k) - dtcld*a_qci(i, k, 2)
5413         END IF
5414         CALL POPCONTROL1B(branch)
5415         IF (branch .NE. 0) a_psaci(i, k) = 0.0_8
5416         CALL POPREAL8(psaci(i, k))
5417         a_fsupcol = a_fsupcol + psaci(i, k)*a_psaci(i, k)
5418         a_psaci(i, k) = fsupcol*a_psaci(i, k)
5419         CALL POPCONTROL1B(branch)
5420         IF (branch .EQ. 0) THEN
5421           a_qci(i, k, 2) = a_qci(i, k, 2) + a_psaci(i, k)/dtcld
5422           a_psaci(i, k) = 0.0_8
5423           a_psaci1 = 0.0_8
5424         ELSE
5425           a_psaci1 = a_psaci(i, k)
5426           a_psaci(i, k) = 0.0_8
5427         END IF
5428         a_temp4 = (psaci_b*b+psaci_c*c+psaci_d*d)*psaci_a*a_psaci1
5429         a_temp6 = a*abs3*eacrs*psaci_a*a_psaci1
5430         a_b = psaci_b*a_temp6
5431         a_c = psaci_c*a_temp6
5432         a_d = psaci_d*a_temp6
5433         a_a = abs3*eacrs*a_temp4
5434         a_abs3 = a*eacrs*a_temp4
5435         a_eacrs = a_eacrs + a*abs3*a_temp4
5436         CALL POPCONTROL1B(branch)
5437         IF (branch .EQ. 0) THEN
5438           CALL POPREAL8(abs3)
5439           a_vt2s = a_abs3
5440           a_vt2i = -a_abs3
5441         ELSE
5442           CALL POPREAL8(abs3)
5443           a_vt2i = a_abs3
5444           a_vt2s = -a_abs3
5445         END IF
5446         CALL POPREAL8(d)
5447         temp9 = SQRT(max24)
5448         temp8 = SQRT(temp9)
5449         temp7 = -(alpha*max11/4.)
5450         temp6 = EXP(temp7)
5451         temp4 = 5./4.
5452         temp3 = max30**temp4
5453         temp2 = SQRT(den(i, k))
5454         a_temp0 = temp6*temp8*a_d
5455         a_temp5 = temp2*temp3*a_d
5456         a_max11 = -(alpha*EXP(temp7)*temp8*a_temp5/4.)
5457         IF (max24 .EQ. 0.0_8 .OR. temp9 .EQ. 0.0_8) THEN
5458           a_max24 = 0.0_8
5459         ELSE
5460           a_max24 = temp6*a_temp5/(2.0**2*temp9*temp8)
5461         END IF
5462         IF (.NOT.den(i, k) .EQ. 0.0_8) a_den(i, k) = a_den(i, k) + temp3&
5463 &           *a_temp0/(2.0*temp2)
5464         IF (max30 .LE. 0.0_8 .AND. (temp4 .EQ. 0.0_8 .OR. temp4 .NE. INT&
5465 &           (temp4))) THEN
5466           a_max30 = 0.0_8
5467         ELSE
5468           a_max30 = temp4*max30**(temp4-1)*temp2*a_temp0
5469         END IF
5470         CALL POPCONTROL1B(branch)
5471         IF (branch .EQ. 0) THEN
5472           CALL POPREAL8(max30)
5473         ELSE
5474           CALL POPREAL8(max30)
5475           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max30
5476         END IF
5477         CALL POPCONTROL1B(branch)
5478         IF (branch .EQ. 0) THEN
5479           CALL POPREAL8(max24)
5480           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max24
5481         ELSE
5482           CALL POPREAL8(max24)
5483         END IF
5484         CALL POPCONTROL1B(branch)
5485         IF (branch .EQ. 0) THEN
5486           CALL POPREAL8(max11)
5487           a_y4 = 0.0_8
5488         ELSE
5489           CALL POPREAL8(max11)
5490           a_y4 = a_max11
5491         END IF
5492         CALL POPCONTROL1B(branch)
5493         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y4
5494         CALL POPREAL8(c)
5495         temp6 = 9./8.
5496         temp5 = max29**temp6
5497         temp4 = SQRT(max23)
5498         temp2 = 5./8.
5499         temp1 = den(i, k)**temp2
5500         temp7 = -(alpha*max10/2.)
5501         temp8 = EXP(temp7)
5502         a_temp3 = temp4*temp5*a_c
5503         a_temp4 = temp8*temp1*a_c
5504         IF (max23 .EQ. 0.0_8) THEN
5505           a_max23 = 0.0_8
5506         ELSE
5507           a_max23 = temp5*a_temp4/(2.0*temp4)
5508         END IF
5509         IF (max29 .LE. 0.0_8 .AND. (temp6 .EQ. 0.0_8 .OR. temp6 .NE. INT&
5510 &           (temp6))) THEN
5511           a_max29 = 0.0_8
5512         ELSE
5513           a_max29 = temp6*max29**(temp6-1)*temp4*a_temp4
5514         END IF
5515         a_max10 = -(alpha*EXP(temp7)*temp1*a_temp3/2.)
5516         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp2 .EQ. 0.0_8 .OR. &
5517 &           temp2 .NE. INT(temp2)))) a_den(i, k) = a_den(i, k) + temp2*&
5518 &           den(i, k)**(temp2-1)*temp8*a_temp3
5519         CALL POPCONTROL1B(branch)
5520         IF (branch .EQ. 0) THEN
5521           CALL POPREAL8(max29)
5522         ELSE
5523           CALL POPREAL8(max29)
5524           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max29
5525         END IF
5526         CALL POPCONTROL1B(branch)
5527         IF (branch .EQ. 0) THEN
5528           CALL POPREAL8(max23)
5529           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max23
5530         ELSE
5531           CALL POPREAL8(max23)
5532         END IF
5533         CALL POPCONTROL1B(branch)
5534         IF (branch .EQ. 0) THEN
5535           CALL POPREAL8(max10)
5536           a_y3 = 0.0_8
5537         ELSE
5538           CALL POPREAL8(max10)
5539           a_y3 = a_max10
5540         END IF
5541         CALL POPCONTROL1B(branch)
5542         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y3
5543         temp6 = 3./4.
5544         temp5 = den(i, k)*max22
5545         temp4 = temp5**temp6
5546         temp3 = -(3.*alpha*max9/4.)
5547         a_max9 = -(alpha*3.*EXP(temp3)*temp4*max28*a_b/4.)
5548         a_temp = EXP(temp3)*a_b
5549         IF (temp5 .LE. 0.0_8 .AND. (temp6 .EQ. 0.0_8 .OR. temp6 .NE. INT&
5550 &           (temp6))) THEN
5551           a_temp0 = 0.0_8
5552         ELSE
5553           a_temp0 = temp6*temp5**(temp6-1)*max28*a_temp
5554         END IF
5555         a_max28 = temp4*a_temp
5556         a_den(i, k) = a_den(i, k) + max22*a_temp0
5557         a_max22 = den(i, k)*a_temp0
5558         b = (den(i, k)*max3)**(3./4.)*max18
5559         CALL POPCONTROL1B(branch)
5560         IF (branch .EQ. 0) THEN
5561           CALL POPREAL8(max28)
5562         ELSE
5563           CALL POPREAL8(max28)
5564           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max28
5565         END IF
5566         CALL POPCONTROL1B(branch)
5567         IF (branch .EQ. 0) THEN
5568           CALL POPREAL8(max22)
5569           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max22
5570         ELSE
5571           CALL POPREAL8(max22)
5572         END IF
5573         CALL POPCONTROL1B(branch)
5574         IF (branch .EQ. 0) THEN
5575           CALL POPREAL8(max9)
5576           a_y2 = 0.0_8
5577         ELSE
5578           CALL POPREAL8(max9)
5579           a_y2 = a_max9
5580         END IF
5581         CALL POPCONTROL1B(branch)
5582         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y2
5583         CALL POPREAL8(a)
5584         a_max8 = alpha*EXP(alpha*max8)*a_a
5585         CALL POPCONTROL1B(branch)
5586         IF (branch .EQ. 0) THEN
5587           CALL POPREAL8(max8)
5588           a_y1 = a_max8
5589         ELSE
5590           CALL POPREAL8(max8)
5591           a_y1 = 0.0_8
5592         END IF
5593         CALL POPCONTROL1B(branch)
5594         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y1
5595         IF (den(i, k)*max7 .LE. 0.0_8 .AND. (1.31/8. .EQ. 0.0_8 .OR. &
5596 &           1.31/8. .NE. INT(1.31/8.))) THEN
5597           a_temp2 = 0.0_8
5598         ELSE
5599           a_temp2 = 1.31*(den(i, k)*max7)**(1.31/8.-1)*vt2i_a*a_vt2i/8.
5600         END IF
5601         a_den(i, k) = a_den(i, k) + max7*a_temp2
5602         a_max7 = den(i, k)*a_temp2
5603         CALL POPCONTROL1B(branch)
5604         IF (branch .EQ. 0) THEN
5605           CALL POPREAL8(max7)
5606         ELSE
5607           CALL POPREAL8(max7)
5608           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max7
5609         END IF
5610         temp5 = -(alpha*bvts*max21/4.)
5611         temp3 = bvts/4.
5612         temp2 = max6**temp3
5613         temp1 = (bvts-2.)/4.
5614         temp6 = den(i, k)**temp1
5615         a_temp1 = EXP(temp5)*vt2s_a*a_vt2s
5616         a_max21 = -(alpha*bvts*EXP(temp5)*temp6*temp2*vt2s_a*a_vt2s/4.)
5617         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp1 .EQ. 0.0_8 .OR. &
5618 &           temp1 .NE. INT(temp1)))) a_den(i, k) = a_den(i, k) + temp1*&
5619 &           den(i, k)**(temp1-1)*temp2*a_temp1
5620         IF (max6 .LE. 0.0_8 .AND. (temp3 .EQ. 0.0_8 .OR. temp3 .NE. INT(&
5621 &           temp3))) THEN
5622           a_max6 = 0.0_8
5623         ELSE
5624           a_max6 = temp3*max6**(temp3-1)*temp6*a_temp1
5625         END IF
5626         CALL POPCONTROL1B(branch)
5627         IF (branch .EQ. 0) THEN
5628           CALL POPREAL8(max21)
5629           a_y6 = a_max21
5630         ELSE
5631           CALL POPREAL8(max21)
5632           a_y6 = 0.0_8
5633         END IF
5634         CALL POPCONTROL1B(branch)
5635         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y6
5636         CALL POPCONTROL1B(branch)
5637         IF (branch .EQ. 0) THEN
5638           CALL POPREAL8(max6)
5639         ELSE
5640           CALL POPREAL8(max6)
5641           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max6
5642         END IF
5643         CALL POPCONTROL1B(branch)
5644         IF (branch .EQ. 0) THEN
5645           CALL POPREAL8(eacrs)
5646           a_x5 = 0.0_8
5647         ELSE
5648           CALL POPREAL8(eacrs)
5649           a_x5 = a_eacrs
5650         END IF
5651         a_supcol = -(0.07*EXP(-(0.07*supcol))*a_x5)
5652         CALL POPREAL8(fsupcol)
5653         CALL A_SMOOTHIF(supcol, a_supcol, 0., fsupcol, a_fsupcol, 't0')
5654         CALL POPREAL8(supcol)
5655         a_t(i, k) = a_t(i, k) - a_supcol
5656         a_temp0 = dtcld*a_t(i, k)/cpm(i, k)
5657         a_piacr(i, k) = xlf*a_temp0
5658         a_xlf = piacr(i, k)*a_temp0
5659         a_cpm(i, k) = a_cpm(i, k) - piacr(i, k)*xlf*a_temp0/cpm(i, k)
5660         CALL POPCONTROL1B(branch)
5661         IF (branch .EQ. 0) THEN
5662           CALL POPREAL8(qrs(i, k, 3))
5663           a_qrs(i, k, 3) = 0.0_8
5664           a_x4 = 0.0_8
5665         ELSE
5666           CALL POPREAL8(qrs(i, k, 3))
5667           a_x4 = a_qrs(i, k, 3)
5668           a_qrs(i, k, 3) = 0.0_8
5669         END IF
5670         a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_x4
5671         a_piacr(i, k) = a_piacr(i, k) + (1-delta3)*dtcld*a_x4
5672         CALL POPCONTROL1B(branch)
5673         IF (branch .EQ. 0) THEN
5674           CALL POPREAL8(qrs(i, k, 2))
5675           a_qrs(i, k, 2) = 0.0_8
5676           a_x3 = 0.0_8
5677         ELSE
5678           CALL POPREAL8(qrs(i, k, 2))
5679           a_x3 = a_qrs(i, k, 2)
5680           a_qrs(i, k, 2) = 0.0_8
5681         END IF
5682         a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_x3
5683         a_piacr(i, k) = a_piacr(i, k) + delta3*dtcld*a_x3
5684         CALL POPCONTROL1B(branch)
5685         IF (branch .EQ. 0) THEN
5686           CALL POPREAL8(qrs(i, k, 1))
5687           a_qrs(i, k, 1) = 0.0_8
5688         ELSE
5689           CALL POPREAL8(qrs(i, k, 1))
5690           a_piacr(i, k) = a_piacr(i, k) - dtcld*a_qrs(i, k, 1)
5691         END IF
5692         CALL POPCONTROL1B(branch)
5693         IF (branch .NE. 0) a_piacr(i, k) = 0.0_8
5694         CALL POPCONTROL1B(branch)
5695         IF (branch .EQ. 0) THEN
5696           CALL POPREAL8(delta3)
5697         ELSE
5698           CALL POPREAL8(delta3)
5699         END IF
5700         CALL POPREAL8(piacr(i, k))
5701         a_fsupcol = piacr(i, k)*a_piacr(i, k)
5702         a_piacr(i, k) = fsupcol*a_piacr(i, k)
5703         CALL POPCONTROL1B(branch)
5704         IF (branch .EQ. 0) THEN
5705           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_piacr(i, k)/dtcld
5706           a_piacr(i, k) = 0.0_8
5707           a_piacr1 = 0.0_8
5708         ELSE
5709           a_piacr1 = a_piacr(i, k)
5710           a_piacr(i, k) = 0.0_8
5711         END IF
5712         CALL POPCONTROL1B(branch)
5713         IF (branch .NE. 0) THEN
5714           temp5 = (bvtr+6.)/4.
5715           temp3 = qci(i, k, 2)**0.75
5716           temp2 = (bvtr+3.)/4.
5717           temp1 = den(i, k)**temp2
5718           a_temp1 = qrs(i, k, 1)**temp5*piacr_a*a_piacr1
5719           IF (.NOT.(qrs(i, k, 1) .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR.&
5720 &             temp5 .NE. INT(temp5)))) a_qrs(i, k, 1) = a_qrs(i, k, 1) +&
5721 &             temp5*qrs(i, k, 1)**(temp5-1)*temp1*temp3*piacr_a*a_piacr1
5722           IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp2 .EQ. 0.0_8 .OR. &
5723 &             temp2 .NE. INT(temp2)))) a_den(i, k) = a_den(i, k) + temp2&
5724 &             *den(i, k)**(temp2-1)*temp3*a_temp1
5725           a_qci(i, k, 2) = a_qci(i, k, 2) + 0.75*qci(i, k, 2)**(-0.25)*&
5726 &           temp1*a_temp1
5727         END IF
5728         CALL POPCONTROL1B(branch)
5729         IF (branch .EQ. 0) a_xlf = 0.0_8
5730         CALL POPREAL8(xlf)
5731         a_xl(i, k) = a_xl(i, k) - a_xlf
5732         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
5733         a_xl(i, k) = 0.0_8
5734         CALL A_CPMCAL0(q(i, k), a_q(i, k), a_cpm(i, k))
5735         a_cpm(i, k) = 0.0_8
5736         CALL POPREAL8(fsupcol)
5737         a_supcol = 0.0_8
5738         CALL A_SMOOTHIF(supcol, a_supcol, 0., fsupcol, a_fsupcol, 't0')
5739         a_praci(i, k) = 0.0_8
5740         CALL POPCONTROL1B(branch)
5741         IF (branch .EQ. 0) THEN
5742           a_qrs(i, k, 3) = 0.0_8
5743           a_x2 = 0.0_8
5744         ELSE
5745           a_x2 = a_qrs(i, k, 3)
5746           a_qrs(i, k, 3) = 0.0_8
5747         END IF
5748         a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_x2
5749         a_praci(i, k) = a_praci(i, k) + (1-delta3)*dtcld*a_x2
5750         CALL POPCONTROL1B(branch)
5751         IF (branch .EQ. 0) THEN
5752           a_qrs(i, k, 2) = 0.0_8
5753           a_x1 = 0.0_8
5754         ELSE
5755           a_x1 = a_qrs(i, k, 2)
5756           a_qrs(i, k, 2) = 0.0_8
5757         END IF
5758         a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_x1
5759         a_praci(i, k) = a_praci(i, k) + delta3*dtcld*a_x1
5760         CALL POPCONTROL1B(branch)
5761         IF (branch .EQ. 0) THEN
5762           a_qci(i, k, 2) = 0.0_8
5763         ELSE
5764           a_praci(i, k) = a_praci(i, k) - dtcld*a_qci(i, k, 2)
5765         END IF
5766         CALL POPCONTROL1B(branch)
5767         IF (branch .NE. 0) a_praci(i, k) = 0.0_8
5768         CALL POPCONTROL1B(branch)
5769         IF (branch .EQ. 0) THEN
5770           CALL POPREAL8(delta3)
5771         ELSE
5772           CALL POPREAL8(delta3)
5773         END IF
5774         CALL POPREAL8(praci(i, k))
5775         a_fsupcol = praci(i, k)*a_praci(i, k)
5776         a_praci(i, k) = fsupcol*a_praci(i, k)
5777         CALL POPCONTROL1B(branch)
5778         IF (branch .EQ. 0) THEN
5779           a_qci(i, k, 2) = a_qci(i, k, 2) + a_praci(i, k)/dtcld
5780           a_praci(i, k) = 0.0_8
5781           a_praci1 = 0.0_8
5782         ELSE
5783           a_praci1 = a_praci(i, k)
5784           a_praci(i, k) = 0.0_8
5785         END IF
5786         a_abs0 = (praci_b*b+praci_c*c+praci_d*d)*praci_a*a_praci1
5787         a_temp0 = abs0*praci_a*a_praci1
5788         a_b = praci_b*a_temp0
5789         a_c = praci_c*a_temp0
5790         a_d = praci_d*a_temp0
5791         CALL POPCONTROL1B(branch)
5792         IF (branch .EQ. 0) THEN
5793           CALL POPREAL8(abs0)
5794           a_vt2r = a_abs0
5795           a_vt2i = -a_abs0
5796         ELSE
5797           CALL POPREAL8(abs0)
5798           a_vt2i = a_abs0
5799           a_vt2r = -a_abs0
5800         END IF
5801         CALL POPREAL8(d)
5802         temp5 = SQRT(max5)
5803         temp4 = SQRT(temp5)
5804         temp3 = 5./4.
5805         temp2 = max20**temp3
5806         temp1 = SQRT(den(i, k))
5807         IF (.NOT.den(i, k) .EQ. 0.0_8) a_den(i, k) = a_den(i, k) + temp2&
5808 &           *temp4*a_d/(2.0*temp1)
5809         IF (max20 .LE. 0.0_8 .AND. (temp3 .EQ. 0.0_8 .OR. temp3 .NE. INT&
5810 &           (temp3))) THEN
5811           a_max20 = 0.0_8
5812         ELSE
5813           a_max20 = temp3*max20**(temp3-1)*temp1*temp4*a_d
5814         END IF
5815         IF (max5 .EQ. 0.0_8 .OR. temp5 .EQ. 0.0_8) THEN
5816           a_max5 = 0.0_8
5817         ELSE
5818           a_max5 = temp1*temp2*a_d/(2.0**2*temp5*temp4)
5819         END IF
5820         CALL POPCONTROL1B(branch)
5821         IF (branch .EQ. 0) THEN
5822           CALL POPREAL8(max20)
5823         ELSE
5824           CALL POPREAL8(max20)
5825           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max20
5826         END IF
5827         CALL POPCONTROL1B(branch)
5828         IF (branch .EQ. 0) THEN
5829           CALL POPREAL8(max5)
5830           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max5
5831         ELSE
5832           CALL POPREAL8(max5)
5833         END IF
5834         CALL POPREAL8(c)
5835         temp2 = 9./8.
5836         temp1 = max19**temp2
5837         temp3 = SQRT(max4)
5838         temp4 = 5./8.
5839         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp4 .EQ. 0.0_8 .OR. &
5840 &           temp4 .NE. INT(temp4)))) a_den(i, k) = a_den(i, k) + temp4*&
5841 &           den(i, k)**(temp4-1)*temp3*temp1*a_c
5842         a_temp0 = den(i, k)**temp4*a_c
5843         IF (max4 .EQ. 0.0_8) THEN
5844           a_max4 = 0.0_8
5845         ELSE
5846           a_max4 = temp1*a_temp0/(2.0*temp3)
5847         END IF
5848         IF (max19 .LE. 0.0_8 .AND. (temp2 .EQ. 0.0_8 .OR. temp2 .NE. INT&
5849 &           (temp2))) THEN
5850           a_max19 = 0.0_8
5851         ELSE
5852           a_max19 = temp2*max19**(temp2-1)*temp3*a_temp0
5853         END IF
5854         CALL POPCONTROL1B(branch)
5855         IF (branch .EQ. 0) THEN
5856           CALL POPREAL8(max19)
5857         ELSE
5858           CALL POPREAL8(max19)
5859           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max19
5860         END IF
5861         CALL POPCONTROL1B(branch)
5862         IF (branch .EQ. 0) THEN
5863           CALL POPREAL8(max4)
5864           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max4
5865         ELSE
5866           CALL POPREAL8(max4)
5867         END IF
5868         CALL POPREAL8(b)
5869         temp2 = den(i, k)*max3
5870         temp1 = 3./4.
5871         IF (temp2 .LE. 0.0_8 .AND. (temp1 .EQ. 0.0_8 .OR. temp1 .NE. INT&
5872 &           (temp1))) THEN
5873           a_temp = 0.0_8
5874         ELSE
5875           a_temp = temp1*temp2**(temp1-1)*max18*a_b
5876         END IF
5877         a_max18 = temp2**temp1*a_b
5878         a_den(i, k) = a_den(i, k) + max3*a_temp
5879         a_max3 = den(i, k)*a_temp
5880         CALL POPCONTROL1B(branch)
5881         IF (branch .EQ. 0) THEN
5882           CALL POPREAL8(max18)
5883         ELSE
5884           CALL POPREAL8(max18)
5885           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max18
5886         END IF
5887         CALL POPCONTROL1B(branch)
5888         IF (branch .EQ. 0) THEN
5889           CALL POPREAL8(max3)
5890           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max3
5891         ELSE
5892           CALL POPREAL8(max3)
5893         END IF
5894         IF (den(i, k)*max2 .LE. 0.0_8 .AND. (1.31/8. .EQ. 0.0_8 .OR. &
5895 &           1.31/8. .NE. INT(1.31/8.))) THEN
5896           a_temp = 0.0_8
5897         ELSE
5898           a_temp = 1.31*(den(i, k)*max2)**(1.31/8.-1)*vt2i_a*a_vt2i/8.
5899         END IF
5900         a_den(i, k) = a_den(i, k) + max2*a_temp
5901         a_max2 = den(i, k)*a_temp
5902         CALL POPCONTROL1B(branch)
5903         IF (branch .EQ. 0) THEN
5904           CALL POPREAL8(max2)
5905         ELSE
5906           CALL POPREAL8(max2)
5907           a_qci(i, k, 2) = a_qci(i, k, 2) + a_max2
5908         END IF
5909         temp1 = bvtr/4.
5910         temp2 = (bvtr-2.)/4.
5911         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp2 .EQ. 0.0_8 .OR. &
5912 &           temp2 .NE. INT(temp2)))) a_den(i, k) = a_den(i, k) + temp2*&
5913 &           den(i, k)**(temp2-1)*max1**temp1*vt2r_a*a_vt2r
5914         IF (max1 .LE. 0.0_8 .AND. (temp1 .EQ. 0.0_8 .OR. temp1 .NE. INT(&
5915 &           temp1))) THEN
5916           a_max1 = 0.0_8
5917         ELSE
5918           a_max1 = temp1*max1**(temp1-1)*den(i, k)**temp2*vt2r_a*a_vt2r
5919         END IF
5920         CALL POPCONTROL1B(branch)
5921         IF (branch .EQ. 0) THEN
5922           CALL POPREAL8(max1)
5923         ELSE
5924           CALL POPREAL8(max1)
5925           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max1
5926         END IF
5927         CALL POPREAL8(fsupcol)
5928         CALL A_SMOOTHIF(supcol, a_supcol, 0., fsupcol, a_fsupcol, 't0')
5929         a_t(i, k) = a_t(i, k) - a_supcol
5930       END DO
5931     END DO
5932   END SUBROUTINE A_ACCRET1
5933
5934 !===================================================================
5935   SUBROUTINE ACCRET1(qci, den, qrs, t, q, dtcld, praci, piacr, psaci, &
5936 &   pgaci, psacw, pgacw, ims, ime, kms, kme, its, ite, kts, kte)
5937     IMPLICIT NONE
5938     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
5939 !-------------------------------------------------------------------
5940     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
5941     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
5942     REAL, DIMENSION(ims:ime, kms:kme) :: den, q
5943     REAL, DIMENSION(its:ite, kts:kte) :: praci, piacr, psaci, pgaci, &
5944 &   psacw, pgacw, t, xl, cpm
5945     REAL :: supcol, dtcld, eacrs, egi, praci1, piacr1, psaci1, pgaci1, &
5946 &   temp, temp0
5947     INTEGER :: i, k
5948     REAL :: fsupcol, fqc, fqi, fqr, fqs, fqg, delta3, xlf, a, b, c, d, e
5949     INTRINSIC MAX
5950     INTRINSIC SQRT
5951     INTRINSIC ABS
5952     INTRINSIC MIN
5953     INTRINSIC EXP
5954     REAL :: x1
5955     REAL :: x2
5956     REAL :: x3
5957     REAL :: x4
5958     REAL :: x5
5959     REAL :: y1
5960     REAL :: y2
5961     REAL :: y3
5962     REAL :: y4
5963     REAL :: y5
5964     REAL :: x6
5965     REAL :: x7
5966     REAL :: x8
5967     REAL :: x9
5968     REAL :: x10
5969     REAL :: x11
5970     REAL :: y6
5971     REAL :: max1
5972     REAL :: max2
5973     REAL :: max3
5974     REAL :: max4
5975     REAL :: max5
5976     REAL :: abs0
5977     REAL :: abs1
5978     REAL :: abs2
5979     REAL :: max6
5980     REAL :: max7
5981     REAL :: max8
5982     REAL :: max9
5983     REAL :: max10
5984     REAL :: max11
5985     REAL :: abs3
5986     REAL :: abs4
5987     REAL :: max12
5988     REAL :: max13
5989     REAL :: max14
5990     REAL :: max15
5991     REAL :: max16
5992     REAL :: abs5
5993     REAL :: abs6
5994     REAL :: max17
5995     REAL :: abs7
5996     REAL :: abs8
5997     REAL :: max18
5998     REAL :: max19
5999     REAL :: max20
6000     REAL :: max21
6001     REAL :: max22
6002     REAL :: max23
6003     REAL :: max24
6004     REAL :: max25
6005     REAL :: max26
6006     REAL :: max27
6007     REAL :: max28
6008     REAL :: max29
6009     REAL :: max30
6010     DO k=kts,kte
6011       DO i=its,ite
6012 !-------------------------------------------------------------
6013 ! praci: Accretion of cloud ice by rain [LFO 25]
6014 !        (T<T0: I->S or I->G) praci: min=0,max=qci(i,k,2)/dtcld
6015 !-------------------------------------------------------------
6016         supcol = t0c - t(i, k)
6017         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
6018         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6019           max1 = qcrmin
6020         ELSE
6021           max1 = qrs(i, k, 1)
6022         END IF
6023         vt2r = vt2r_a*den(i, k)**((bvtr-2.)/4.)*max1**(bvtr/4.)
6024         IF (qci(i, k, 2) .LT. qmin) THEN
6025           max2 = qmin
6026         ELSE
6027           max2 = qci(i, k, 2)
6028         END IF
6029         vt2i = vt2i_a*(den(i, k)*max2)**(1.31/8.)
6030         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6031           max3 = qcrmin
6032         ELSE
6033           max3 = qrs(i, k, 1)
6034         END IF
6035         IF (qci(i, k, 2) .LT. qmin) THEN
6036           max18 = qmin
6037         ELSE
6038           max18 = qci(i, k, 2)
6039         END IF
6040         b = (den(i, k)*max3)**(3./4.)*max18
6041         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6042           max4 = qcrmin
6043         ELSE
6044           max4 = qrs(i, k, 1)
6045         END IF
6046         IF (qci(i, k, 2) .LT. qmin) THEN
6047           max19 = qmin
6048         ELSE
6049           max19 = qci(i, k, 2)
6050         END IF
6051         c = den(i, k)**(5./8.)*SQRT(max4)*max19**(9./8.)
6052         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6053           max5 = qcrmin
6054         ELSE
6055           max5 = qrs(i, k, 1)
6056         END IF
6057         IF (qci(i, k, 2) .LT. qmin) THEN
6058           max20 = qmin
6059         ELSE
6060           max20 = qci(i, k, 2)
6061         END IF
6062         d = SQRT(den(i, k))*SQRT(SQRT(max5))*max20**(5./4.)
6063         IF (vt2r - vt2i .GE. 0.) THEN
6064           abs0 = vt2r - vt2i
6065         ELSE
6066           abs0 = -(vt2r-vt2i)
6067         END IF
6068         praci1 = praci_a*abs0*(praci_b*b+praci_c*c+praci_d*d)
6069         IF (praci1 .GT. qci(i, k, 2)/dtcld) THEN
6070           praci(i, k) = qci(i, k, 2)/dtcld
6071         ELSE
6072           praci(i, k) = praci1
6073         END IF
6074         praci(i, k) = fsupcol*praci(i, k)
6075 !update qi, qs, qg
6076         IF (qrs(i, k, 1) .LT. 1.e-4) THEN
6077           delta3 = 1.
6078         ELSE
6079           delta3 = 0.
6080         END IF
6081         IF (praci(i, k) .GE. 0.) THEN
6082           abs1 = praci(i, k)
6083         ELSE
6084           abs1 = -praci(i, k)
6085         END IF
6086         IF (abs1 .LT. qmin/dtcld) praci(i, k) = 0.
6087         IF (qci(i, k, 2) - praci(i, k)*dtcld .LT. 0.) THEN
6088           qci(i, k, 2) = 0.
6089         ELSE
6090           qci(i, k, 2) = qci(i, k, 2) - praci(i, k)*dtcld
6091         END IF
6092         x1 = qrs(i, k, 2) + praci(i, k)*delta3*dtcld
6093         IF (x1 .LT. 0.) THEN
6094           qrs(i, k, 2) = 0.
6095         ELSE
6096           qrs(i, k, 2) = x1
6097         END IF
6098         x2 = qrs(i, k, 3) + praci(i, k)*(1-delta3)*dtcld
6099         IF (x2 .LT. 0.) THEN
6100           qrs(i, k, 3) = 0.
6101         ELSE
6102           qrs(i, k, 3) = x2
6103         END IF
6104         praci(i, k) = 0.
6105 !-------------------------------------------------------------
6106 ! piacr: Accretion of rain by cloud ice [LFO 26]
6107 !        (T<T0: R->S or R->G) piacr: min=0,max=qrs(i,k,1)/dtcld
6108 !-------------------------------------------------------------
6109 !         supcol = t0c-t(i,k) !not change
6110         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
6111 !call smoothif(qci(i,k,2),qmin  ,fqi,'q0')
6112 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
6113 !update cpm
6114         cpm(i, k) = CPMCAL(q(i, k))
6115         xl(i, k) = XLCAL(t(i, k))
6116         xlf = xls - xl(i, k)
6117         IF (supcol .LT. 0.) xlf = xlf0
6118         IF (qci(i, k, 2) .GT. 0. .AND. qrs(i, k, 1) .GT. 0.) THEN
6119 !piacr_a=1.75e5
6120           piacr1 = piacr_a*den(i, k)**((3.+bvtr)/4.)*qci(i, k, 2)**0.75*&
6121 &           qrs(i, k, 1)**((6.+bvtr)/4.)
6122         ELSE
6123           piacr1 = 0.
6124         END IF
6125         IF (piacr1 .GT. qrs(i, k, 1)/dtcld) THEN
6126           piacr(i, k) = qrs(i, k, 1)/dtcld
6127         ELSE
6128           piacr(i, k) = piacr1
6129         END IF
6130         piacr(i, k) = fsupcol*piacr(i, k)
6131 ! update qr,qs,qg,t
6132         IF (qrs(i, k, 1) .LT. 1.e-4) THEN
6133           delta3 = 1.
6134         ELSE
6135           delta3 = 0.
6136         END IF
6137         IF (piacr(i, k) .GE. 0.) THEN
6138           abs2 = piacr(i, k)
6139         ELSE
6140           abs2 = -piacr(i, k)
6141         END IF
6142         IF (abs2 .LT. qmin/dtcld) piacr(i, k) = 0.
6143         IF (qrs(i, k, 1) - piacr(i, k)*dtcld .LT. 0.) THEN
6144           qrs(i, k, 1) = 0.
6145         ELSE
6146           qrs(i, k, 1) = qrs(i, k, 1) - piacr(i, k)*dtcld
6147         END IF
6148         x3 = qrs(i, k, 2) + piacr(i, k)*delta3*dtcld
6149         IF (x3 .LT. 0.) THEN
6150           qrs(i, k, 2) = 0.
6151         ELSE
6152           qrs(i, k, 2) = x3
6153         END IF
6154         x4 = qrs(i, k, 3) + piacr(i, k)*(1-delta3)*dtcld
6155         IF (x4 .LT. 0.) THEN
6156           qrs(i, k, 3) = 0.
6157         ELSE
6158           qrs(i, k, 3) = x4
6159         END IF
6160         t(i, k) = t(i, k) + piacr(i, k)*dtcld*xlf/cpm(i, k)
6161         piacr(i, k) = 0.
6162 !-------------------------------------------------------------
6163 ! psaci: Accretion of cloud ice by snow [HDC 10]
6164 !        (T<T0: I->S) psaci: min=0, max=qci(i,k,2)/dtcld
6165 !-------------------------------------------------------------
6166         supcol = t0c - t(i, k)
6167         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
6168         x5 = EXP(0.07*(-supcol))
6169         IF (x5 .GT. 1.) THEN
6170           eacrs = 1.
6171         ELSE
6172           eacrs = x5
6173         END IF
6174         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6175           max6 = qcrmin
6176         ELSE
6177           max6 = qrs(i, k, 2)
6178         END IF
6179         IF (90. .GT. t0c - t(i, k)) THEN
6180           y6 = t0c - t(i, k)
6181         ELSE
6182           y6 = 90.
6183         END IF
6184         IF (0. .LT. y6) THEN
6185           max21 = y6
6186         ELSE
6187           max21 = 0.
6188         END IF
6189         vt2s = vt2s_a*den(i, k)**((bvts-2.)/4.)*max6**(bvts/4.)*EXP(-(&
6190 &         alpha*bvts*max21/4.))
6191         IF (qci(i, k, 2) .LT. qmin) THEN
6192           max7 = qmin
6193         ELSE
6194           max7 = qci(i, k, 2)
6195         END IF
6196         vt2i = vt2i_a*(den(i, k)*max7)**(1.31/8.)
6197         IF (90. .GT. t0c - t(i, k)) THEN
6198           y1 = t0c - t(i, k)
6199         ELSE
6200           y1 = 90.
6201         END IF
6202         IF (0. .LT. y1) THEN
6203           max8 = y1
6204         ELSE
6205           max8 = 0.
6206         END IF
6207         a = EXP(alpha*max8)
6208         IF (90. .GT. t0c - t(i, k)) THEN
6209           y2 = t0c - t(i, k)
6210         ELSE
6211           y2 = 90.
6212         END IF
6213         IF (0. .LT. y2) THEN
6214           max9 = y2
6215         ELSE
6216           max9 = 0.
6217         END IF
6218         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6219           max22 = qcrmin
6220         ELSE
6221           max22 = qrs(i, k, 2)
6222         END IF
6223         IF (qci(i, k, 2) .LT. qmin) THEN
6224           max28 = qmin
6225         ELSE
6226           max28 = qci(i, k, 2)
6227         END IF
6228         b = EXP(-(3.*alpha*max9/4.))*(den(i, k)*max22)**(3./4.)*max28
6229         IF (90. .GT. t0c - t(i, k)) THEN
6230           y3 = t0c - t(i, k)
6231         ELSE
6232           y3 = 90.
6233         END IF
6234         IF (0. .LT. y3) THEN
6235           max10 = y3
6236         ELSE
6237           max10 = 0.
6238         END IF
6239         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6240           max23 = qcrmin
6241         ELSE
6242           max23 = qrs(i, k, 2)
6243         END IF
6244         IF (qci(i, k, 2) .LT. qmin) THEN
6245           max29 = qmin
6246         ELSE
6247           max29 = qci(i, k, 2)
6248         END IF
6249         c = EXP(-(alpha*max10/2.))*den(i, k)**(5./8.)*SQRT(max23)*max29&
6250 &         **(9./8.)
6251         IF (90. .GT. t0c - t(i, k)) THEN
6252           y4 = t0c - t(i, k)
6253         ELSE
6254           y4 = 90.
6255         END IF
6256         IF (0. .LT. y4) THEN
6257           max11 = y4
6258         ELSE
6259           max11 = 0.
6260         END IF
6261         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6262           max24 = qcrmin
6263         ELSE
6264           max24 = qrs(i, k, 2)
6265         END IF
6266         IF (qci(i, k, 2) .LT. qmin) THEN
6267           max30 = qmin
6268         ELSE
6269           max30 = qci(i, k, 2)
6270         END IF
6271         d = EXP(-(alpha*max11/4.))*SQRT(den(i, k))*SQRT(SQRT(max24))*&
6272 &         max30**(5./4.)
6273         IF (vt2s - vt2i .GE. 0.) THEN
6274           abs3 = vt2s - vt2i
6275         ELSE
6276           abs3 = -(vt2s-vt2i)
6277         END IF
6278         psaci1 = psaci_a*a*abs3*(psaci_b*b+psaci_c*c+psaci_d*d)*eacrs
6279         IF (psaci1 .GT. qci(i, k, 2)/dtcld) THEN
6280           psaci(i, k) = qci(i, k, 2)/dtcld
6281         ELSE
6282           psaci(i, k) = psaci1
6283         END IF
6284         psaci(i, k) = fsupcol*psaci(i, k)
6285         IF (psaci(i, k) .GE. 0.) THEN
6286           abs4 = psaci(i, k)
6287         ELSE
6288           abs4 = -psaci(i, k)
6289         END IF
6290         IF (abs4 .LT. qmin/dtcld) psaci(i, k) = 0.
6291         IF (qci(i, k, 2) - psaci(i, k)*dtcld .LT. 0.) THEN
6292           qci(i, k, 2) = 0.
6293         ELSE
6294           qci(i, k, 2) = qci(i, k, 2) - psaci(i, k)*dtcld
6295         END IF
6296         IF (qrs(i, k, 2) + psaci(i, k)*dtcld .LT. 0.) THEN
6297           qrs(i, k, 2) = 0.
6298         ELSE
6299           qrs(i, k, 2) = qrs(i, k, 2) + psaci(i, k)*dtcld
6300         END IF
6301         psaci(i, k) = 0.
6302 !-------------------------------------------------------------
6303 ! pgaci: Accretion of cloud ice by graupel [LFO 41]
6304 !        (T<T0: I->G) pgaci:min=0,max=qci(i,k,2)/dtcld
6305 !-------------------------------------------------------------
6306 !         supcol = t0c-t(i,k) !not change
6307 !         call smoothif(supcol,    0.,fsupcol,'t0')
6308 !call smoothif(qci(i,k,2),qmin  ,fqi,'q0')
6309 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
6310 !min(exp(0.07*(-supcol)),1.)
6311         egi = eacrs
6312         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6313           max12 = qcrmin
6314         ELSE
6315           max12 = qrs(i, k, 3)
6316         END IF
6317         vt2g = vt2g_a*den(i, k)**((bvtg-2.)/4.)*max12**(bvtg/4.)
6318         IF (qci(i, k, 2) .LT. qmin) THEN
6319           max13 = qmin
6320         ELSE
6321           max13 = qci(i, k, 2)
6322         END IF
6323         vt2i = vt2i_a*(den(i, k)*max13)**(1.31/8.)
6324         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6325           max14 = qcrmin
6326         ELSE
6327           max14 = qrs(i, k, 3)
6328         END IF
6329         IF (qci(i, k, 2) .LT. qmin) THEN
6330           max25 = qmin
6331         ELSE
6332           max25 = qci(i, k, 2)
6333         END IF
6334         b = (den(i, k)*max14)**(3./4.)*max25
6335         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6336           max15 = qcrmin
6337         ELSE
6338           max15 = qrs(i, k, 3)
6339         END IF
6340         IF (qci(i, k, 2) .LT. qmin) THEN
6341           max26 = qmin
6342         ELSE
6343           max26 = qci(i, k, 2)
6344         END IF
6345         c = den(i, k)**(5./8.)*SQRT(max15)*max26**(9./8.)
6346         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6347           max16 = qcrmin
6348         ELSE
6349           max16 = qrs(i, k, 3)
6350         END IF
6351         IF (qci(i, k, 2) .LT. qmin) THEN
6352           max27 = qmin
6353         ELSE
6354           max27 = qci(i, k, 2)
6355         END IF
6356         d = SQRT(den(i, k))*SQRT(SQRT(max16))*max27**(5./4.)
6357         IF (vt2g - vt2i .GE. 0.) THEN
6358           abs5 = vt2g - vt2i
6359         ELSE
6360           abs5 = -(vt2g-vt2i)
6361         END IF
6362         pgaci1 = pgaci_a*abs5*(pgaci_b*b+pgaci_c*c+pgaci_d*d)*egi
6363         IF (pgaci1 .GT. qci(i, k, 2)/dtcld) THEN
6364           pgaci(i, k) = qci(i, k, 2)/dtcld
6365         ELSE
6366           pgaci(i, k) = pgaci1
6367         END IF
6368         pgaci(i, k) = fsupcol*pgaci(i, k)
6369         IF (pgaci(i, k) .GE. 0.) THEN
6370           abs6 = pgaci(i, k)
6371         ELSE
6372           abs6 = -pgaci(i, k)
6373         END IF
6374         IF (abs6 .LT. qmin/dtcld) pgaci(i, k) = 0.
6375         IF (qci(i, k, 2) - pgaci(i, k)*dtcld .LT. 0.) THEN
6376           qci(i, k, 2) = 0.
6377         ELSE
6378           qci(i, k, 2) = qci(i, k, 2) - pgaci(i, k)*dtcld
6379         END IF
6380         IF (qrs(i, k, 3) + pgaci(i, k)*dtcld .LT. 0.) THEN
6381           qrs(i, k, 3) = 0.
6382         ELSE
6383           qrs(i, k, 3) = qrs(i, k, 3) + pgaci(i, k)*dtcld
6384         END IF
6385         pgaci(i, k) = 0.
6386 !-------------------------------------------------------------
6387 ! psacw: Accretion of cloud water by snow  [LFO 24]
6388 !        (T<T0: C->G, and T>=T0: C->R) psacw:min=0,max=qci(i,k,1)/dtcld
6389 !-------------------------------------------------------------
6390 !         supcol = t0c-t(i,k) !not change
6391 !         call smoothif(supcol,    0.,fsupcol,'t0')
6392 !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0')
6393 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
6394 !update cpm
6395 !         cpm(i,k)=cpmcal(q(i,k)) !not change
6396         xl(i, k) = XLCAL(t(i, k))
6397         xlf = xls - xl(i, k)
6398         IF (supcol .LT. 0.) xlf = xlf0
6399         IF (qrs(i, k, 2) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN
6400           IF (90. .GT. t0c - t(i, k)) THEN
6401             y5 = t0c - t(i, k)
6402           ELSE
6403             y5 = 90.
6404           END IF
6405           IF (0. .LT. y5) THEN
6406             max17 = y5
6407           ELSE
6408             max17 = 0.
6409           END IF
6410           a = EXP((1.-bvts)*alpha*max17/4.)
6411           psacw(i, k) = psacw_a*a*den(i, k)**((1.+bvts)/4.)*qrs(i, k, 2)&
6412 &           **((3.+bvts)/4.)*qci(i, k, 1)
6413         ELSE
6414           psacw(i, k) = 0.
6415         END IF
6416         IF (psacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
6417           x6 = qci(i, k, 1)/dtcld
6418         ELSE
6419           x6 = psacw(i, k)
6420         END IF
6421         IF (x6 .LT. 0.) THEN
6422           psacw(i, k) = 0.
6423         ELSE
6424           psacw(i, k) = x6
6425         END IF
6426         psacw(i, k) = fsupcol*psacw(i, k)
6427         IF (psacw(i, k) .GE. 0.) THEN
6428           abs7 = psacw(i, k)
6429         ELSE
6430           abs7 = -psacw(i, k)
6431         END IF
6432         IF (abs7 .LT. qmin/dtcld) psacw(i, k) = 0.
6433         IF (qci(i, k, 1) - psacw(i, k)*dtcld .LT. 0.) THEN
6434           qci(i, k, 1) = 0.
6435         ELSE
6436           qci(i, k, 1) = qci(i, k, 1) - psacw(i, k)*dtcld
6437         END IF
6438         x7 = qrs(i, k, 1) + (1.-fsupcol)*psacw(i, k)*dtcld
6439         IF (x7 .LT. 0.) THEN
6440           qrs(i, k, 1) = 0.
6441         ELSE
6442           qrs(i, k, 1) = x7
6443         END IF
6444         x8 = qrs(i, k, 3) + fsupcol*psacw(i, k)*dtcld
6445         IF (x8 .LT. 0.) THEN
6446           qrs(i, k, 3) = 0.
6447         ELSE
6448           qrs(i, k, 3) = x8
6449         END IF
6450         t(i, k) = t(i, k) + fsupcol*psacw(i, k)*dtcld*xlf/cpm(i, k)
6451 !t>=t0 pseml
6452         psacw(i, k) = (1-fsupcol)*psacw(i, k)
6453 !-------------------------------------------------------------
6454 ! pgacw: Accretion of cloud water by graupel [LFO 40]
6455 !        (T<T0: C->G, and T>=T0: C->R) pgacw:min=0.,max=qci(i,k,1)/dtcld
6456 !-------------------------------------------------------------
6457         supcol = t0c - t(i, k)
6458         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
6459 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
6460 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
6461 !         cpm(i,k)=cpmcal(q(i,k)) !not change
6462         xl(i, k) = XLCAL(t(i, k))
6463         xlf = xls - xl(i, k)
6464         IF (supcol .LT. 0.) xlf = xlf0
6465         IF (qrs(i, k, 3) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN
6466           pgacw(i, k) = pgacw_a*den(i, k)**((1.+bvtg)/4.)*qrs(i, k, 3)**&
6467 &           ((3.+bvtg)/4.)*qci(i, k, 1)
6468         ELSE
6469           pgacw(i, k) = 0.
6470         END IF
6471         IF (pgacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
6472           x9 = qci(i, k, 1)/dtcld
6473         ELSE
6474           x9 = pgacw(i, k)
6475         END IF
6476         IF (x9 .LT. 0.) THEN
6477           pgacw(i, k) = 0.
6478         ELSE
6479           pgacw(i, k) = x9
6480         END IF
6481         IF (pgacw(i, k) .GE. 0.) THEN
6482           abs8 = pgacw(i, k)
6483         ELSE
6484           abs8 = -pgacw(i, k)
6485         END IF
6486 !pgacw(i,k)=fqg*fqc*pgacw(i,k)
6487         IF (abs8 .LT. qmin/dtcld) pgacw(i, k) = 0.
6488         IF (qci(i, k, 1) - pgacw(i, k)*dtcld .LT. 0.) THEN
6489           qci(i, k, 1) = 0.
6490         ELSE
6491           qci(i, k, 1) = qci(i, k, 1) - pgacw(i, k)*dtcld
6492         END IF
6493         x10 = qrs(i, k, 1) + (1.-fsupcol)*pgacw(i, k)*dtcld
6494         IF (x10 .LT. 0.) THEN
6495           qrs(i, k, 1) = 0.
6496         ELSE
6497           qrs(i, k, 1) = x10
6498         END IF
6499         x11 = qrs(i, k, 3) + fsupcol*pgacw(i, k)*dtcld
6500         IF (x11 .LT. 0.) THEN
6501           qrs(i, k, 3) = 0.
6502         ELSE
6503           qrs(i, k, 3) = x11
6504         END IF
6505         t(i, k) = t(i, k) + fsupcol*pgacw(i, k)*dtcld*xlf/cpm(i, k)
6506 ! t>=t0 pgeml
6507         pgacw(i, k) = (1-fsupcol)*pgacw(i, k)
6508       END DO
6509     END DO
6510   END SUBROUTINE ACCRET1
6511
6512 !  Differentiation of accret2 in reverse (adjoint) mode (with options r8):
6513 !   gradient     of useful results: q t psacr psacw pgacr pgacs
6514 !                pracs pgacw den qrs pseml pgeml
6515 !   with respect to varying inputs: q t psacr psacw pgacr pgacs
6516 !                pracs pgacw den qrs pseml pgeml
6517 !=======================================================================
6518 !
6519 !=======================================================================
6520   SUBROUTINE A_ACCRET2(qrs, a_qrs, t, a_t, q, a_q, den, a_den, dtcld, &
6521 &   psacw, a_psacw, pgacw, a_pgacw, pracs, a_pracs, psacr, a_psacr, &
6522 &   pgacr, a_pgacr, pgacs, a_pgacs, pseml, a_pseml, pgeml, a_pgeml, ims&
6523 &   , ime, kms, kme, its, ite, kts, kte)
6524     IMPLICIT NONE
6525     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
6526 !-------------------------------------------------------------------
6527     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
6528     REAL, DIMENSION(its:ite, kts:kte, 3) :: a_qrs
6529     REAL, DIMENSION(ims:ime, kms:kme) :: den, q
6530     REAL, DIMENSION(ims:ime, kms:kme) :: a_den, a_q
6531     REAL, DIMENSION(its:ite, kts:kte) :: psacw, pgacw, pracs, psacr, &
6532 &   pgacr, pgacs, pseml, pgeml, t, xl, cpm
6533     REAL, DIMENSION(its:ite, kts:kte) :: a_psacw, a_pgacw, a_pracs, &
6534 &   a_psacr, a_pgacr, a_pgacs, a_pseml, a_pgeml, a_t, a_xl, a_cpm
6535     REAL :: supcol, vt2r, vt2s, vt2g, dtcld, xlf, egs
6536     REAL :: a_supcol, a_vt2r, a_vt2s, a_vt2g, a_xlf, a_egs
6537     REAL :: acrfac1, acrfac2, acrfac3, acrfac4, pracs1, psacr1, pgacr1, &
6538 &   pgacs1
6539     REAL :: a_pracs1, a_psacr1, a_pgacr1, a_pgacs1
6540     INTEGER :: i, k
6541     REAL :: fsupcol, ft0, fqr, fqs, fqg, temp1, delta2, a, b, c, d
6542     REAL :: a_fsupcol, a_ft0, a_fqs, a_fqg, a_a, a_b, a_c, a_d
6543     INTRINSIC MAX
6544     INTRINSIC MIN
6545     INTRINSIC EXP
6546     INTRINSIC SQRT
6547     INTRINSIC ABS
6548     REAL :: y1
6549     REAL :: a_y1
6550     REAL :: y2
6551     REAL :: a_y2
6552     REAL :: y3
6553     REAL :: a_y3
6554     REAL :: y4
6555     REAL :: a_y4
6556     REAL :: y5
6557     REAL :: a_y5
6558     REAL :: y6
6559     REAL :: a_y6
6560     REAL :: y7
6561     REAL :: a_y7
6562     REAL :: y8
6563     REAL :: a_y8
6564     REAL :: x1
6565     REAL :: a_x1
6566     REAL :: x2
6567     REAL :: a_x2
6568     REAL :: x3
6569     REAL :: a_x3
6570     REAL :: x4
6571     REAL :: a_x4
6572     REAL :: y9
6573     REAL :: a_y9
6574     REAL :: y10
6575     REAL :: a_y10
6576     REAL :: y11
6577     REAL :: a_y11
6578     REAL :: y12
6579     REAL :: a_y12
6580     REAL :: x5
6581     REAL :: a_x5
6582     REAL :: x6
6583     REAL :: a_x6
6584     REAL :: y13
6585     REAL :: a_y13
6586     REAL :: y14
6587     REAL :: a_y14
6588     REAL :: y15
6589     REAL :: a_y15
6590     REAL :: x7
6591     REAL :: a_x7
6592     REAL :: x8
6593     REAL :: a_x8
6594     REAL :: max1
6595     REAL :: a_max1
6596     REAL :: max2
6597     REAL :: a_max2
6598     REAL :: max3
6599     REAL :: a_max3
6600     REAL :: max4
6601     REAL :: a_max4
6602     REAL :: max5
6603     REAL :: a_max5
6604     REAL :: max6
6605     REAL :: a_max6
6606     REAL :: abs0
6607     REAL :: a_abs0
6608     REAL :: abs1
6609     REAL :: max7
6610     REAL :: a_max7
6611     REAL :: max8
6612     REAL :: a_max8
6613     REAL :: max9
6614     REAL :: a_max9
6615     REAL :: max10
6616     REAL :: a_max10
6617     REAL :: max11
6618     REAL :: a_max11
6619     REAL :: max12
6620     REAL :: a_max12
6621     REAL :: abs2
6622     REAL :: a_abs2
6623     REAL :: abs3
6624     REAL :: max13
6625     REAL :: a_max13
6626     REAL :: max14
6627     REAL :: a_max14
6628     REAL :: max15
6629     REAL :: a_max15
6630     REAL :: max16
6631     REAL :: a_max16
6632     REAL :: max17
6633     REAL :: a_max17
6634     REAL :: abs4
6635     REAL :: a_abs4
6636     REAL :: abs5
6637     REAL :: max18
6638     REAL :: a_max18
6639     REAL :: max19
6640     REAL :: a_max19
6641     REAL :: max20
6642     REAL :: a_max20
6643     REAL :: max21
6644     REAL :: a_max21
6645     REAL :: max22
6646     REAL :: a_max22
6647     REAL :: max23
6648     REAL :: a_max23
6649     REAL :: abs6
6650     REAL :: a_abs6
6651     REAL :: abs7
6652     REAL :: abs8
6653     REAL :: abs9
6654     REAL :: max24
6655     REAL :: a_max24
6656     REAL :: max25
6657     REAL :: a_max25
6658     REAL :: max26
6659     REAL :: a_max26
6660     REAL :: max27
6661     REAL :: a_max27
6662     REAL :: max28
6663     REAL :: a_max28
6664     REAL :: max29
6665     REAL :: a_max29
6666     REAL :: max30
6667     REAL :: a_max30
6668     REAL :: max31
6669     REAL :: a_max31
6670     REAL :: max32
6671     REAL :: a_max32
6672     REAL :: max33
6673     REAL :: a_max33
6674     REAL :: max34
6675     REAL :: a_max34
6676     REAL :: max35
6677     REAL :: a_max35
6678     REAL :: max36
6679     REAL :: a_max36
6680     REAL :: max37
6681     REAL :: a_max37
6682     REAL :: max38
6683     REAL :: a_max38
6684     REAL :: max39
6685     REAL :: a_max39
6686     REAL :: max40
6687     REAL :: a_max40
6688     REAL :: max41
6689     REAL :: a_max41
6690     REAL :: max42
6691     REAL :: a_max42
6692     REAL :: max43
6693     REAL :: a_max43
6694     REAL :: max44
6695     REAL :: a_max44
6696     REAL :: max45
6697     REAL :: a_max45
6698     REAL :: max46
6699     REAL :: a_max46
6700     REAL :: max47
6701     REAL :: a_max47
6702     REAL :: temp
6703     REAL :: temp0
6704     REAL :: a_temp
6705     REAL :: temp2
6706     REAL :: temp3
6707     REAL :: temp4
6708     REAL :: temp5
6709     REAL :: a_temp0
6710     REAL :: temp6
6711     REAL :: temp7
6712     REAL :: temp8
6713     REAL :: temp9
6714     REAL :: a_temp1
6715     REAL :: a_temp2
6716     REAL :: a_temp3
6717     REAL :: a_temp4
6718     REAL :: a_temp5
6719     REAL :: a_temp6
6720     REAL :: a_temp7
6721     INTEGER :: branch
6722     DO k=kts,kte
6723       DO i=its,ite
6724 !-------------------------------------------------------------
6725 ! pracs: Accretion of snow by rain [LFO 27]
6726 !         (T<T0: S->G) pracs: min=0., max=qrs(i,k,2)/dtcld
6727 !-------------------------------------------------------------
6728         CALL PUSHREAL8(supcol)
6729         supcol = t0c - t(i, k)
6730         CALL PUSHREAL8(fsupcol)
6731         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
6732         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6733           CALL PUSHREAL8(max1)
6734           max1 = qcrmin
6735           CALL PUSHCONTROL1B(0)
6736         ELSE
6737           CALL PUSHREAL8(max1)
6738           max1 = qrs(i, k, 1)
6739           CALL PUSHCONTROL1B(1)
6740         END IF
6741 !call smoothif(qrs(i,k,1),1.e-4,fqr,'q0')
6742 !call smoothif(qrs(i,k,2),1.e-4,fqs,'q0')
6743         vt2r = vt2r_a*den(i, k)**((bvtr-2.)/4.)*max1**(bvtr/4.)
6744         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6745           CALL PUSHREAL8(max2)
6746           max2 = qcrmin
6747           CALL PUSHCONTROL1B(0)
6748         ELSE
6749           CALL PUSHREAL8(max2)
6750           max2 = qrs(i, k, 2)
6751           CALL PUSHCONTROL1B(1)
6752         END IF
6753         IF (90. .GT. t0c - t(i, k)) THEN
6754           y13 = t0c - t(i, k)
6755           CALL PUSHCONTROL1B(0)
6756         ELSE
6757           CALL PUSHCONTROL1B(1)
6758           y13 = 90.
6759         END IF
6760         IF (0. .LT. y13) THEN
6761           CALL PUSHREAL8(max24)
6762           max24 = y13
6763           CALL PUSHCONTROL1B(0)
6764         ELSE
6765           CALL PUSHREAL8(max24)
6766           max24 = 0.
6767           CALL PUSHCONTROL1B(1)
6768         END IF
6769         vt2s = vt2s_a*den(i, k)**((bvts-2.)/4.)*max2**(bvts/4.)*EXP(-(&
6770 &         alpha*bvts*max24/4.))
6771         IF (90. .GT. t0c - t(i, k)) THEN
6772           y1 = t0c - t(i, k)
6773           CALL PUSHCONTROL1B(0)
6774         ELSE
6775           CALL PUSHCONTROL1B(1)
6776           y1 = 90.
6777         END IF
6778         IF (0. .LT. y1) THEN
6779           CALL PUSHREAL8(max3)
6780           max3 = y1
6781           CALL PUSHCONTROL1B(0)
6782         ELSE
6783           CALL PUSHREAL8(max3)
6784           max3 = 0.
6785           CALL PUSHCONTROL1B(1)
6786         END IF
6787         CALL PUSHREAL8(a)
6788         a = EXP(alpha*max3)
6789         IF (90. .GT. t0c - t(i, k)) THEN
6790           y2 = t0c - t(i, k)
6791           CALL PUSHCONTROL1B(0)
6792         ELSE
6793           CALL PUSHCONTROL1B(1)
6794           y2 = 90.
6795         END IF
6796         IF (0. .LT. y2) THEN
6797           CALL PUSHREAL8(max4)
6798           max4 = y2
6799           CALL PUSHCONTROL1B(1)
6800         ELSE
6801           CALL PUSHREAL8(max4)
6802           max4 = 0.
6803           CALL PUSHCONTROL1B(0)
6804         END IF
6805         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6806           CALL PUSHREAL8(max25)
6807           max25 = qcrmin
6808           CALL PUSHCONTROL1B(1)
6809         ELSE
6810           CALL PUSHREAL8(max25)
6811           max25 = qrs(i, k, 2)
6812           CALL PUSHCONTROL1B(0)
6813         END IF
6814         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6815           CALL PUSHREAL8(max39)
6816           max39 = qcrmin
6817           CALL PUSHCONTROL1B(0)
6818         ELSE
6819           CALL PUSHREAL8(max39)
6820           max39 = qrs(i, k, 1)
6821           CALL PUSHCONTROL1B(1)
6822         END IF
6823         CALL PUSHREAL8(b)
6824         b = EXP(-(3.*alpha*max4/2.))*den(i, k)**(3./4.)*max25**(3./2.)*&
6825 &         SQRT(SQRT(max39))
6826         IF (90. .GT. t0c - t(i, k)) THEN
6827           y3 = t0c - t(i, k)
6828           CALL PUSHCONTROL1B(0)
6829         ELSE
6830           CALL PUSHCONTROL1B(1)
6831           y3 = 90.
6832         END IF
6833         IF (0. .LT. y3) THEN
6834           CALL PUSHREAL8(max5)
6835           max5 = y3
6836           CALL PUSHCONTROL1B(1)
6837         ELSE
6838           CALL PUSHREAL8(max5)
6839           max5 = 0.
6840           CALL PUSHCONTROL1B(0)
6841         END IF
6842         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6843           CALL PUSHREAL8(max26)
6844           max26 = qcrmin
6845           CALL PUSHCONTROL1B(1)
6846         ELSE
6847           CALL PUSHREAL8(max26)
6848           max26 = qrs(i, k, 2)
6849           CALL PUSHCONTROL1B(0)
6850         END IF
6851         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6852           CALL PUSHREAL8(max40)
6853           max40 = qcrmin
6854           CALL PUSHCONTROL1B(0)
6855         ELSE
6856           CALL PUSHREAL8(max40)
6857           max40 = qrs(i, k, 1)
6858           CALL PUSHCONTROL1B(1)
6859         END IF
6860         CALL PUSHREAL8(c)
6861         c = EXP(-(5.*alpha*max5/4.))*den(i, k)**(3./4.)*max26**(5./4.)*&
6862 &         SQRT(max40)
6863         IF (90. .GT. t0c - t(i, k)) THEN
6864           y4 = t0c - t(i, k)
6865           CALL PUSHCONTROL1B(0)
6866         ELSE
6867           CALL PUSHCONTROL1B(1)
6868           y4 = 90.
6869         END IF
6870         IF (0. .LT. y4) THEN
6871           CALL PUSHREAL8(max6)
6872           max6 = y4
6873           CALL PUSHCONTROL1B(1)
6874         ELSE
6875           CALL PUSHREAL8(max6)
6876           max6 = 0.
6877           CALL PUSHCONTROL1B(0)
6878         END IF
6879         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6880           CALL PUSHREAL8(max27)
6881           max27 = qcrmin
6882           CALL PUSHCONTROL1B(1)
6883         ELSE
6884           CALL PUSHREAL8(max27)
6885           max27 = qrs(i, k, 2)
6886           CALL PUSHCONTROL1B(0)
6887         END IF
6888         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6889           CALL PUSHREAL8(max41)
6890           max41 = qcrmin
6891           CALL PUSHCONTROL1B(0)
6892         ELSE
6893           CALL PUSHREAL8(max41)
6894           max41 = qrs(i, k, 1)
6895           CALL PUSHCONTROL1B(1)
6896         END IF
6897         CALL PUSHREAL8(d)
6898         d = EXP(-(alpha*max6))*den(i, k)**(3./4.)*max27*max41**(3./4.)
6899         IF (vt2r - vt2s .GE. 0.) THEN
6900           CALL PUSHREAL8(abs0)
6901           abs0 = vt2r - vt2s
6902           CALL PUSHCONTROL1B(0)
6903         ELSE
6904           CALL PUSHREAL8(abs0)
6905           abs0 = -(vt2r-vt2s)
6906           CALL PUSHCONTROL1B(1)
6907         END IF
6908         pracs1 = pracs_a*a*abs0*(pracs_b*b+pracs_c*c+pracs_d*d)
6909         IF (pracs1 .GT. qrs(i, k, 2)/dtcld) THEN
6910           pracs(i, k) = qrs(i, k, 2)/dtcld
6911           CALL PUSHCONTROL1B(0)
6912         ELSE
6913           pracs(i, k) = pracs1
6914           CALL PUSHCONTROL1B(1)
6915         END IF
6916         CALL PUSHREAL8(pracs(i, k))
6917         pracs(i, k) = fsupcol*pracs(i, k)
6918         IF (pracs(i, k) .GE. 0.) THEN
6919           abs1 = pracs(i, k)
6920         ELSE
6921           abs1 = -pracs(i, k)
6922         END IF
6923         IF (abs1 .LT. qmin/dtcld) THEN
6924           pracs(i, k) = 0.
6925           CALL PUSHCONTROL1B(1)
6926         ELSE
6927           CALL PUSHCONTROL1B(0)
6928         END IF
6929         IF (qrs(i, k, 2) - pracs(i, k)*dtcld .LT. 0.) THEN
6930           qrs(i, k, 2) = 0.
6931           CALL PUSHCONTROL1B(0)
6932         ELSE
6933           qrs(i, k, 2) = qrs(i, k, 2) - pracs(i, k)*dtcld
6934           CALL PUSHCONTROL1B(1)
6935         END IF
6936         IF (qrs(i, k, 3) + pracs(i, k)*dtcld .LT. 0.) THEN
6937           qrs(i, k, 3) = 0.
6938           CALL PUSHCONTROL1B(0)
6939         ELSE
6940           qrs(i, k, 3) = qrs(i, k, 3) + pracs(i, k)*dtcld
6941           CALL PUSHCONTROL1B(1)
6942         END IF
6943 !-------------------------------------------------------------
6944 ! psacr: Accretion of rain by snow [LFO 28]
6945 !         (T< T0: R->S or R->G)                 min=0.,max=qrs(i,k,1)/dtcld
6946 !         (T>=T0: S->R enhance melting of snow) min=0.,max=qrs(i,k,2)/dtcld
6947 !-------------------------------------------------------------
6948 !         supcol = t0c-t(i,k) !not change
6949 !         call smoothif(supcol,0.,fsupcol,'t0')
6950 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
6951 !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0')
6952 !update cpm
6953         cpm(i, k) = CPMCAL(q(i, k))
6954         xl(i, k) = XLCAL(t(i, k))
6955         CALL PUSHREAL8(xlf)
6956         xlf = xls - xl(i, k)
6957         IF (supcol .LT. 0.) THEN
6958           xlf = xlf0
6959           CALL PUSHCONTROL1B(1)
6960         ELSE
6961           CALL PUSHCONTROL1B(0)
6962         END IF
6963         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6964           CALL PUSHREAL8(max7)
6965           max7 = qcrmin
6966           CALL PUSHCONTROL1B(0)
6967         ELSE
6968           CALL PUSHREAL8(max7)
6969           max7 = qrs(i, k, 1)
6970           CALL PUSHCONTROL1B(1)
6971         END IF
6972         vt2r = vt2r_a*den(i, k)**((bvtr-2.)/4.)*max7**(bvtr/4.)
6973         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6974           CALL PUSHREAL8(max8)
6975           max8 = qcrmin
6976           CALL PUSHCONTROL1B(0)
6977         ELSE
6978           CALL PUSHREAL8(max8)
6979           max8 = qrs(i, k, 2)
6980           CALL PUSHCONTROL1B(1)
6981         END IF
6982         IF (90. .GT. t0c - t(i, k)) THEN
6983           y14 = t0c - t(i, k)
6984           CALL PUSHCONTROL1B(0)
6985         ELSE
6986           CALL PUSHCONTROL1B(1)
6987           y14 = 90.
6988         END IF
6989         IF (0. .LT. y14) THEN
6990           CALL PUSHREAL8(max28)
6991           max28 = y14
6992           CALL PUSHCONTROL1B(0)
6993         ELSE
6994           CALL PUSHREAL8(max28)
6995           max28 = 0.
6996           CALL PUSHCONTROL1B(1)
6997         END IF
6998         vt2s = vt2s_a*den(i, k)**((bvts-2.)/4.)*max8**(bvts/4.)*EXP(-(&
6999 &         alpha*bvts*max28/4.))
7000         IF (90. .GT. t0c - t(i, k)) THEN
7001           y5 = t0c - t(i, k)
7002           CALL PUSHCONTROL1B(0)
7003         ELSE
7004           CALL PUSHCONTROL1B(1)
7005           y5 = 90.
7006         END IF
7007         IF (0. .LT. y5) THEN
7008           CALL PUSHREAL8(max9)
7009           max9 = y5
7010           CALL PUSHCONTROL1B(0)
7011         ELSE
7012           CALL PUSHREAL8(max9)
7013           max9 = 0.
7014           CALL PUSHCONTROL1B(1)
7015         END IF
7016         CALL PUSHREAL8(a)
7017         a = EXP(alpha*max9)
7018         IF (90. .GT. t0c - t(i, k)) THEN
7019           y6 = t0c - t(i, k)
7020           CALL PUSHCONTROL1B(0)
7021         ELSE
7022           CALL PUSHCONTROL1B(1)
7023           y6 = 90.
7024         END IF
7025         IF (0. .LT. y6) THEN
7026           CALL PUSHREAL8(max10)
7027           max10 = y6
7028           CALL PUSHCONTROL1B(1)
7029         ELSE
7030           CALL PUSHREAL8(max10)
7031           max10 = 0.
7032           CALL PUSHCONTROL1B(0)
7033         END IF
7034         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7035           CALL PUSHREAL8(max29)
7036           max29 = qcrmin
7037           CALL PUSHCONTROL1B(1)
7038         ELSE
7039           CALL PUSHREAL8(max29)
7040           max29 = qrs(i, k, 1)
7041           CALL PUSHCONTROL1B(0)
7042         END IF
7043         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7044           CALL PUSHREAL8(max42)
7045           max42 = qcrmin
7046           CALL PUSHCONTROL1B(0)
7047         ELSE
7048           CALL PUSHREAL8(max42)
7049           max42 = qrs(i, k, 2)
7050           CALL PUSHCONTROL1B(1)
7051         END IF
7052         CALL PUSHREAL8(b)
7053         b = EXP(-(alpha*max10/4.))*den(i, k)**(3./4.)*max29**(3./2.)*&
7054 &         SQRT(SQRT(max42))
7055         IF (90. .GT. t0c - t(i, k)) THEN
7056           y7 = t0c - t(i, k)
7057           CALL PUSHCONTROL1B(0)
7058         ELSE
7059           CALL PUSHCONTROL1B(1)
7060           y7 = 90.
7061         END IF
7062         IF (0. .LT. y7) THEN
7063           CALL PUSHREAL8(max11)
7064           max11 = y7
7065           CALL PUSHCONTROL1B(1)
7066         ELSE
7067           CALL PUSHREAL8(max11)
7068           max11 = 0.
7069           CALL PUSHCONTROL1B(0)
7070         END IF
7071         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7072           CALL PUSHREAL8(max30)
7073           max30 = qcrmin
7074           CALL PUSHCONTROL1B(1)
7075         ELSE
7076           CALL PUSHREAL8(max30)
7077           max30 = qrs(i, k, 1)
7078           CALL PUSHCONTROL1B(0)
7079         END IF
7080         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7081           CALL PUSHREAL8(max43)
7082           max43 = qcrmin
7083           CALL PUSHCONTROL1B(0)
7084         ELSE
7085           CALL PUSHREAL8(max43)
7086           max43 = qrs(i, k, 2)
7087           CALL PUSHCONTROL1B(1)
7088         END IF
7089         CALL PUSHREAL8(c)
7090         c = EXP(-(alpha*max11/2.))*den(i, k)**(3./4.)*max30**(5./4.)*&
7091 &         SQRT(max43)
7092         IF (90. .GT. t0c - t(i, k)) THEN
7093           y8 = t0c - t(i, k)
7094           CALL PUSHCONTROL1B(0)
7095         ELSE
7096           CALL PUSHCONTROL1B(1)
7097           y8 = 90.
7098         END IF
7099         IF (0. .LT. y8) THEN
7100           CALL PUSHREAL8(max12)
7101           max12 = y8
7102           CALL PUSHCONTROL1B(1)
7103         ELSE
7104           CALL PUSHREAL8(max12)
7105           max12 = 0.
7106           CALL PUSHCONTROL1B(0)
7107         END IF
7108         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7109           CALL PUSHREAL8(max31)
7110           max31 = qcrmin
7111           CALL PUSHCONTROL1B(1)
7112         ELSE
7113           CALL PUSHREAL8(max31)
7114           max31 = qrs(i, k, 1)
7115           CALL PUSHCONTROL1B(0)
7116         END IF
7117         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7118           CALL PUSHREAL8(max44)
7119           max44 = qcrmin
7120           CALL PUSHCONTROL1B(0)
7121         ELSE
7122           CALL PUSHREAL8(max44)
7123           max44 = qrs(i, k, 2)
7124           CALL PUSHCONTROL1B(1)
7125         END IF
7126         CALL PUSHREAL8(d)
7127         d = EXP(-(3.*alpha*max12/4.))*den(i, k)**(3./4.)*max31*max44**(&
7128 &         3./4.)
7129         IF (vt2r - vt2s .GE. 0.) THEN
7130           CALL PUSHREAL8(abs2)
7131           abs2 = vt2r - vt2s
7132           CALL PUSHCONTROL1B(0)
7133         ELSE
7134           CALL PUSHREAL8(abs2)
7135           abs2 = -(vt2r-vt2s)
7136           CALL PUSHCONTROL1B(1)
7137         END IF
7138         psacr1 = psacr_a*a*abs2*(psacr_b*b+psacr_c*c+psacr_d*d)
7139         IF (supcol .GT. 0.) THEN
7140           IF (psacr1 .GT. qrs(i, k, 1)/dtcld) THEN
7141             psacr(i, k) = qrs(i, k, 1)/dtcld
7142             CALL PUSHCONTROL2B(1)
7143           ELSE
7144             psacr(i, k) = psacr1
7145             CALL PUSHCONTROL2B(0)
7146           END IF
7147         ELSE IF (psacr1 .GT. qrs(i, k, 2)/dtcld) THEN
7148           psacr(i, k) = qrs(i, k, 2)/dtcld
7149           CALL PUSHCONTROL2B(3)
7150         ELSE
7151           psacr(i, k) = psacr1
7152           CALL PUSHCONTROL2B(2)
7153         END IF
7154         IF (psacr(i, k) .GE. 0.) THEN
7155           abs3 = psacr(i, k)
7156         ELSE
7157           abs3 = -psacr(i, k)
7158         END IF
7159 !psacr(i,k)=fqr*fqs*psacr(i,k)
7160         IF (abs3 .LT. qmin/dtcld) THEN
7161           psacr(i, k) = 0.
7162           CALL PUSHCONTROL1B(0)
7163         ELSE
7164           CALL PUSHCONTROL1B(1)
7165         END IF
7166 !update qr qs qg
7167         IF (qrs(i, k, 1) .LT. 1.e-4 .AND. qrs(i, k, 2) .LT. 1.e-4) THEN
7168           CALL PUSHREAL8(delta2)
7169           delta2 = 1.
7170           CALL PUSHCONTROL1B(1)
7171         ELSE
7172           CALL PUSHREAL8(delta2)
7173           delta2 = 0.
7174           CALL PUSHCONTROL1B(0)
7175         END IF
7176         IF (qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld .LT. 0.) THEN
7177           qrs(i, k, 1) = 0.
7178           CALL PUSHCONTROL1B(0)
7179         ELSE
7180           qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld
7181           CALL PUSHCONTROL1B(1)
7182         END IF
7183         x1 = qrs(i, k, 2) + fsupcol*delta2*psacr(i, k)*dtcld
7184         IF (x1 .LT. 0.) THEN
7185           qrs(i, k, 2) = 0.
7186           CALL PUSHCONTROL1B(0)
7187         ELSE
7188           qrs(i, k, 2) = x1
7189           CALL PUSHCONTROL1B(1)
7190         END IF
7191         x2 = qrs(i, k, 3) + fsupcol*(1-delta2)*psacr(i, k)*dtcld
7192         IF (x2 .LT. 0.) THEN
7193           qrs(i, k, 3) = 0.
7194           CALL PUSHCONTROL1B(0)
7195         ELSE
7196           qrs(i, k, 3) = x2
7197           CALL PUSHCONTROL1B(1)
7198         END IF
7199         t(i, k) = t(i, k) + fsupcol*psacr(i, k)*dtcld*xlf/cpm(i, k)
7200 ! t>=t0 pseml
7201         CALL PUSHREAL8(psacr(i, k))
7202         psacr(i, k) = (1-fsupcol)*psacr(i, k)
7203 !-------------------------------------------------------------
7204 ! pgacr: Accretion of rain by graupel [LFO 42]
7205 !         (T< T0: R->G)                            min=0.,max=qrs(i,k,1)/dtcld
7206 !         (T>=T0: G->R enhance melting of graupel) min=0.,max=qrs(i,k,3)/dtcld
7207 !-------------------------------------------------------------
7208         CALL PUSHREAL8(supcol)
7209         supcol = t0c - t(i, k)
7210         CALL PUSHREAL8(fsupcol)
7211         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
7212 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
7213 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
7214 !update cpm
7215 !         cpm(i,k)=cpmcal(q(i,k)) !not change
7216         xl(i, k) = XLCAL(t(i, k))
7217         CALL PUSHREAL8(xlf)
7218         xlf = xls - xl(i, k)
7219         IF (supcol .LT. 0.) THEN
7220           xlf = xlf0
7221           CALL PUSHCONTROL1B(1)
7222         ELSE
7223           CALL PUSHCONTROL1B(0)
7224         END IF
7225         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7226           CALL PUSHREAL8(max13)
7227           max13 = qcrmin
7228           CALL PUSHCONTROL1B(0)
7229         ELSE
7230           CALL PUSHREAL8(max13)
7231           max13 = qrs(i, k, 1)
7232           CALL PUSHCONTROL1B(1)
7233         END IF
7234         vt2r = vt2r_a*den(i, k)**((bvtr-2.)/4.)*max13**(bvtr/4.)
7235         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7236           CALL PUSHREAL8(max14)
7237           max14 = qcrmin
7238           CALL PUSHCONTROL1B(0)
7239         ELSE
7240           CALL PUSHREAL8(max14)
7241           max14 = qrs(i, k, 3)
7242           CALL PUSHCONTROL1B(1)
7243         END IF
7244         vt2g = vt2g_a*den(i, k)**((bvtg-2.)/4.)*max14**(bvtg/4.)
7245         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7246           CALL PUSHREAL8(max15)
7247           max15 = qcrmin
7248           CALL PUSHCONTROL1B(1)
7249         ELSE
7250           CALL PUSHREAL8(max15)
7251           max15 = qrs(i, k, 1)
7252           CALL PUSHCONTROL1B(0)
7253         END IF
7254         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7255           CALL PUSHREAL8(max32)
7256           max32 = qcrmin
7257           CALL PUSHCONTROL1B(0)
7258         ELSE
7259           CALL PUSHREAL8(max32)
7260           max32 = qrs(i, k, 3)
7261           CALL PUSHCONTROL1B(1)
7262         END IF
7263         CALL PUSHREAL8(b)
7264         b = den(i, k)**(3./4.)*max15**(3./2.)*SQRT(SQRT(max32))
7265         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7266           CALL PUSHREAL8(max16)
7267           max16 = qcrmin
7268           CALL PUSHCONTROL1B(1)
7269         ELSE
7270           CALL PUSHREAL8(max16)
7271           max16 = qrs(i, k, 1)
7272           CALL PUSHCONTROL1B(0)
7273         END IF
7274         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7275           CALL PUSHREAL8(max33)
7276           max33 = qcrmin
7277           CALL PUSHCONTROL1B(0)
7278         ELSE
7279           CALL PUSHREAL8(max33)
7280           max33 = qrs(i, k, 3)
7281           CALL PUSHCONTROL1B(1)
7282         END IF
7283         CALL PUSHREAL8(c)
7284         c = den(i, k)**(3./4.)*max16**(5./4.)*SQRT(max33)
7285         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7286           CALL PUSHREAL8(max17)
7287           max17 = qcrmin
7288           CALL PUSHCONTROL1B(1)
7289         ELSE
7290           CALL PUSHREAL8(max17)
7291           max17 = qrs(i, k, 1)
7292           CALL PUSHCONTROL1B(0)
7293         END IF
7294         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7295           CALL PUSHREAL8(max34)
7296           max34 = qcrmin
7297           CALL PUSHCONTROL1B(0)
7298         ELSE
7299           CALL PUSHREAL8(max34)
7300           max34 = qrs(i, k, 3)
7301           CALL PUSHCONTROL1B(1)
7302         END IF
7303         CALL PUSHREAL8(d)
7304         d = den(i, k)**(3./4.)*max17*max34**(3./4.)
7305         IF (vt2r - vt2g .GE. 0.) THEN
7306           CALL PUSHREAL8(abs4)
7307           abs4 = vt2r - vt2g
7308           CALL PUSHCONTROL1B(0)
7309         ELSE
7310           CALL PUSHREAL8(abs4)
7311           abs4 = -(vt2r-vt2g)
7312           CALL PUSHCONTROL1B(1)
7313         END IF
7314         pgacr1 = pgacr_a*abs4*(pgacr_b*b+pgacr_c*c+pgacr_d*d)
7315         IF (supcol .GT. 0.) THEN
7316           IF (pgacr1 .GT. qrs(i, k, 1)/dtcld) THEN
7317             pgacr(i, k) = qrs(i, k, 1)/dtcld
7318             CALL PUSHCONTROL2B(1)
7319           ELSE
7320             pgacr(i, k) = pgacr1
7321             CALL PUSHCONTROL2B(0)
7322           END IF
7323         ELSE IF (pgacr1 .GT. qrs(i, k, 3)/dtcld) THEN
7324           pgacr(i, k) = qrs(i, k, 3)/dtcld
7325           CALL PUSHCONTROL2B(3)
7326         ELSE
7327           pgacr(i, k) = pgacr1
7328           CALL PUSHCONTROL2B(2)
7329         END IF
7330         IF (pgacr(i, k) .GE. 0.) THEN
7331           abs5 = pgacr(i, k)
7332         ELSE
7333           abs5 = -pgacr(i, k)
7334         END IF
7335 !pgacr(i,k)=fqg*fqr*pgacr(i,k)
7336         IF (abs5 .LT. qmin/dtcld) THEN
7337           pgacr(i, k) = 0.
7338           CALL PUSHCONTROL1B(1)
7339         ELSE
7340           CALL PUSHCONTROL1B(0)
7341         END IF
7342         IF (qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld .LT. 0.) THEN
7343           qrs(i, k, 1) = 0.
7344           CALL PUSHCONTROL1B(0)
7345         ELSE
7346           qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld
7347           CALL PUSHCONTROL1B(1)
7348         END IF
7349         x3 = qrs(i, k, 3) + fsupcol*pgacr(i, k)*dtcld
7350         IF (x3 .LT. 0.) THEN
7351           qrs(i, k, 3) = 0.
7352           CALL PUSHCONTROL1B(0)
7353         ELSE
7354           qrs(i, k, 3) = x3
7355           CALL PUSHCONTROL1B(1)
7356         END IF
7357         t(i, k) = t(i, k) + fsupcol*pgacr(i, k)*dtcld*xlf/cpm(i, k)
7358 ! t>=t0 pgeml
7359         CALL PUSHREAL8(pgacr(i, k))
7360         pgacr(i, k) = (1-fsupcol)*pgacr(i, k)
7361 !-------------------------------------------------------------
7362 ! pgacs: Accretion of snow by graupel [LFO 29]
7363 !        (S->G) min=0,max=qrs(i,k,2)/dtcld
7364 !-------------------------------------------------------------
7365         CALL PUSHREAL8(supcol)
7366         supcol = t0c - t(i, k)
7367         x4 = EXP(-(0.09*supcol))
7368         IF (x4 .GT. 1.) THEN
7369           CALL PUSHREAL8(egs)
7370           egs = 1.
7371           CALL PUSHCONTROL1B(0)
7372         ELSE
7373           CALL PUSHREAL8(egs)
7374           egs = x4
7375           CALL PUSHCONTROL1B(1)
7376         END IF
7377         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7378           CALL PUSHREAL8(max18)
7379           max18 = qcrmin
7380           CALL PUSHCONTROL1B(0)
7381         ELSE
7382           CALL PUSHREAL8(max18)
7383           max18 = qrs(i, k, 3)
7384           CALL PUSHCONTROL1B(1)
7385         END IF
7386         vt2g = vt2g_a*den(i, k)**((bvtg-2.)/4.)*max18**(bvtg/4.)
7387         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7388           CALL PUSHREAL8(max19)
7389           max19 = qcrmin
7390           CALL PUSHCONTROL1B(0)
7391         ELSE
7392           CALL PUSHREAL8(max19)
7393           max19 = qrs(i, k, 2)
7394           CALL PUSHCONTROL1B(1)
7395         END IF
7396         IF (90. .GT. t0c - t(i, k)) THEN
7397           y15 = t0c - t(i, k)
7398           CALL PUSHCONTROL1B(0)
7399         ELSE
7400           CALL PUSHCONTROL1B(1)
7401           y15 = 90.
7402         END IF
7403         IF (0. .LT. y15) THEN
7404           CALL PUSHREAL8(max35)
7405           max35 = y15
7406           CALL PUSHCONTROL1B(0)
7407         ELSE
7408           CALL PUSHREAL8(max35)
7409           max35 = 0.
7410           CALL PUSHCONTROL1B(1)
7411         END IF
7412         vt2s = vt2s_a*den(i, k)**((bvts-2.)/4.)*max19**(bvts/4.)*EXP(-(&
7413 &         alpha*bvts*max35/4.))
7414         IF (90. .GT. t0c - t(i, k)) THEN
7415           y9 = t0c - t(i, k)
7416           CALL PUSHCONTROL1B(0)
7417         ELSE
7418           CALL PUSHCONTROL1B(1)
7419           y9 = 90.
7420         END IF
7421         IF (0. .LT. y9) THEN
7422           CALL PUSHREAL8(max20)
7423           max20 = y9
7424           CALL PUSHCONTROL1B(0)
7425         ELSE
7426           CALL PUSHREAL8(max20)
7427           max20 = 0.
7428           CALL PUSHCONTROL1B(1)
7429         END IF
7430         CALL PUSHREAL8(a)
7431         a = EXP(alpha*max20)
7432         IF (90. .GT. t0c - t(i, k)) THEN
7433           y10 = t0c - t(i, k)
7434           CALL PUSHCONTROL1B(0)
7435         ELSE
7436           CALL PUSHCONTROL1B(1)
7437           y10 = 90.
7438         END IF
7439         IF (0. .LT. y10) THEN
7440           CALL PUSHREAL8(max21)
7441           max21 = y10
7442           CALL PUSHCONTROL1B(1)
7443         ELSE
7444           CALL PUSHREAL8(max21)
7445           max21 = 0.
7446           CALL PUSHCONTROL1B(0)
7447         END IF
7448         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7449           CALL PUSHREAL8(max36)
7450           max36 = qcrmin
7451           CALL PUSHCONTROL1B(1)
7452         ELSE
7453           CALL PUSHREAL8(max36)
7454           max36 = qrs(i, k, 2)
7455           CALL PUSHCONTROL1B(0)
7456         END IF
7457         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7458           CALL PUSHREAL8(max45)
7459           max45 = qcrmin
7460           CALL PUSHCONTROL1B(0)
7461         ELSE
7462           CALL PUSHREAL8(max45)
7463           max45 = qrs(i, k, 3)
7464           CALL PUSHCONTROL1B(1)
7465         END IF
7466         CALL PUSHREAL8(b)
7467         b = EXP(-(3.*alpha*max21/2.))*den(i, k)**(3./4.)*max36**(3./2.)*&
7468 &         SQRT(SQRT(max45))
7469         IF (90. .GT. t0c - t(i, k)) THEN
7470           y11 = t0c - t(i, k)
7471           CALL PUSHCONTROL1B(0)
7472         ELSE
7473           CALL PUSHCONTROL1B(1)
7474           y11 = 90.
7475         END IF
7476         IF (0. .LT. y11) THEN
7477           CALL PUSHREAL8(max22)
7478           max22 = y11
7479           CALL PUSHCONTROL1B(1)
7480         ELSE
7481           CALL PUSHREAL8(max22)
7482           max22 = 0.
7483           CALL PUSHCONTROL1B(0)
7484         END IF
7485         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7486           CALL PUSHREAL8(max37)
7487           max37 = qcrmin
7488           CALL PUSHCONTROL1B(1)
7489         ELSE
7490           CALL PUSHREAL8(max37)
7491           max37 = qrs(i, k, 2)
7492           CALL PUSHCONTROL1B(0)
7493         END IF
7494         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7495           CALL PUSHREAL8(max46)
7496           max46 = qcrmin
7497           CALL PUSHCONTROL1B(0)
7498         ELSE
7499           CALL PUSHREAL8(max46)
7500           max46 = qrs(i, k, 3)
7501           CALL PUSHCONTROL1B(1)
7502         END IF
7503         CALL PUSHREAL8(c)
7504         c = EXP(-(5.*alpha*max22/4.))*den(i, k)**(3./4.)*max37**(5./4.)*&
7505 &         SQRT(max46)
7506         IF (90. .GT. t0c - t(i, k)) THEN
7507           y12 = t0c - t(i, k)
7508           CALL PUSHCONTROL1B(0)
7509         ELSE
7510           CALL PUSHCONTROL1B(1)
7511           y12 = 90.
7512         END IF
7513         IF (0. .LT. y12) THEN
7514           CALL PUSHREAL8(max23)
7515           max23 = y12
7516           CALL PUSHCONTROL1B(1)
7517         ELSE
7518           CALL PUSHREAL8(max23)
7519           max23 = 0.
7520           CALL PUSHCONTROL1B(0)
7521         END IF
7522         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7523           CALL PUSHREAL8(max38)
7524           max38 = qcrmin
7525           CALL PUSHCONTROL1B(1)
7526         ELSE
7527           CALL PUSHREAL8(max38)
7528           max38 = qrs(i, k, 2)
7529           CALL PUSHCONTROL1B(0)
7530         END IF
7531         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7532           CALL PUSHREAL8(max47)
7533           max47 = qcrmin
7534           CALL PUSHCONTROL1B(0)
7535         ELSE
7536           CALL PUSHREAL8(max47)
7537           max47 = qrs(i, k, 3)
7538           CALL PUSHCONTROL1B(1)
7539         END IF
7540         d = EXP(-(alpha*max23))*den(i, k)**(3./4.)*max38*max47**(3./4.)
7541         IF (vt2g - vt2s .GE. 0.) THEN
7542           CALL PUSHREAL8(abs6)
7543           abs6 = vt2g - vt2s
7544           CALL PUSHCONTROL1B(0)
7545         ELSE
7546           CALL PUSHREAL8(abs6)
7547           abs6 = -(vt2g-vt2s)
7548           CALL PUSHCONTROL1B(1)
7549         END IF
7550         pgacs1 = pgacs_a*a*abs6*(pgacs_b*b+pgacs_c*c+pgacs_d*d)*egs
7551         IF (pgacs1 .GT. qrs(i, k, 2)/dtcld) THEN
7552           pgacs(i, k) = qrs(i, k, 2)/dtcld
7553           CALL PUSHCONTROL1B(0)
7554         ELSE
7555           pgacs(i, k) = pgacs1
7556           CALL PUSHCONTROL1B(1)
7557         END IF
7558         IF (pgacs(i, k) .GE. 0.) THEN
7559           abs7 = pgacs(i, k)
7560         ELSE
7561           abs7 = -pgacs(i, k)
7562         END IF
7563 !pgacs(i,k)=fqg*fqs*pgacs(i,k)
7564         IF (abs7 .LT. qmin/dtcld) THEN
7565           pgacs(i, k) = 0.
7566           CALL PUSHCONTROL1B(1)
7567         ELSE
7568           CALL PUSHCONTROL1B(0)
7569         END IF
7570         IF (qrs(i, k, 2) - pgacs(i, k)*dtcld .LT. 0.) THEN
7571           qrs(i, k, 2) = 0.
7572           CALL PUSHCONTROL1B(0)
7573         ELSE
7574           qrs(i, k, 2) = qrs(i, k, 2) - pgacs(i, k)*dtcld
7575           CALL PUSHCONTROL1B(1)
7576         END IF
7577         IF (qrs(i, k, 3) + pgacs(i, k)*dtcld .LT. 0.) THEN
7578           qrs(i, k, 3) = 0.
7579           CALL PUSHCONTROL1B(0)
7580         ELSE
7581           qrs(i, k, 3) = qrs(i, k, 3) + pgacs(i, k)*dtcld
7582           CALL PUSHCONTROL1B(1)
7583         END IF
7584 !-------------------------------------------------------------
7585 ! pseml: Enhanced melting of snow by accretion of water
7586 !        (T>=T0: S->R) pseml<0 max=0,min=-qrs(i,k,2)/dtcld
7587 !-------------------------------------------------------------
7588 !         supcol = t0c-t(i,k) ! not change
7589 !update cpm
7590 !         cpm(i,k)=cpmcal(q(i,k)) ! not change
7591         xl(i, k) = XLCAL(t(i, k))
7592         CALL PUSHREAL8(xlf)
7593         xlf = xls - xl(i, k)
7594         IF (supcol .LT. 0.) THEN
7595           xlf = xlf0
7596           CALL PUSHCONTROL1B(1)
7597         ELSE
7598           CALL PUSHCONTROL1B(0)
7599         END IF
7600         CALL PUSHREAL8(ft0)
7601         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
7602         CALL PUSHREAL8(fqs)
7603         CALL SMOOTHIF(qrs(i, k, 2), 0., fqs, 'q+')
7604         x7 = cliq*supcol*(psacw(i, k)+psacr(i, k))/xlf
7605         IF (x7 .LT. -(qrs(i, k, 2)/dtcld)) THEN
7606           x5 = -(qrs(i, k, 2)/dtcld)
7607           CALL PUSHCONTROL1B(0)
7608         ELSE
7609           x5 = x7
7610           CALL PUSHCONTROL1B(1)
7611         END IF
7612         IF (x5 .GT. 0.) THEN
7613           pseml(i, k) = 0.
7614           CALL PUSHCONTROL1B(0)
7615         ELSE
7616           pseml(i, k) = x5
7617           CALL PUSHCONTROL1B(1)
7618         END IF
7619         CALL PUSHREAL8(pseml(i, k))
7620         pseml(i, k) = ft0*fqs*pseml(i, k)
7621         IF (pseml(i, k) .GE. 0.) THEN
7622           abs8 = pseml(i, k)
7623         ELSE
7624           abs8 = -pseml(i, k)
7625         END IF
7626         IF (abs8 .LT. qmin/dtcld) THEN
7627           pseml(i, k) = 0.
7628           CALL PUSHCONTROL1B(1)
7629         ELSE
7630           CALL PUSHCONTROL1B(0)
7631         END IF
7632         IF (qrs(i, k, 1) - pseml(i, k)*dtcld .LT. 0.) THEN
7633           CALL PUSHREAL8(qrs(i, k, 1))
7634           qrs(i, k, 1) = 0.
7635           CALL PUSHCONTROL1B(0)
7636         ELSE
7637           CALL PUSHREAL8(qrs(i, k, 1))
7638           qrs(i, k, 1) = qrs(i, k, 1) - pseml(i, k)*dtcld
7639           CALL PUSHCONTROL1B(1)
7640         END IF
7641         IF (qrs(i, k, 2) + pseml(i, k)*dtcld .LT. 0.) THEN
7642           CALL PUSHREAL8(qrs(i, k, 2))
7643           qrs(i, k, 2) = 0.
7644           CALL PUSHCONTROL1B(0)
7645         ELSE
7646           CALL PUSHREAL8(qrs(i, k, 2))
7647           qrs(i, k, 2) = qrs(i, k, 2) + pseml(i, k)*dtcld
7648           CALL PUSHCONTROL1B(1)
7649         END IF
7650         CALL PUSHREAL8(t(i, k))
7651         t(i, k) = t(i, k) + pseml(i, k)*dtcld*xlf/cpm(i, k)
7652 !-------------------------------------------------------------
7653 ! pgeml: Enhanced melting of graupel by accretion of water [RH84 A21-A22]
7654 !        (T>=T0: G->R) pgeml<0 max=0,min=-qrs(i,k,3)/dtcld
7655 !-------------------------------------------------------------
7656         CALL PUSHREAL8(supcol)
7657         supcol = t0c - t(i, k)
7658 !update cpm
7659 !         cpm(i,k)=cpmcal(q(i,k)) ! not change
7660         xl(i, k) = XLCAL(t(i, k))
7661         CALL PUSHREAL8(xlf)
7662         xlf = xls - xl(i, k)
7663         IF (supcol .LT. 0.) THEN
7664           xlf = xlf0
7665           CALL PUSHCONTROL1B(1)
7666         ELSE
7667           CALL PUSHCONTROL1B(0)
7668         END IF
7669         CALL PUSHREAL8(ft0)
7670         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
7671         CALL PUSHREAL8(fqg)
7672         CALL SMOOTHIF(qrs(i, k, 3), 0., fqg, 'q+')
7673         x8 = cliq*supcol*(pgacw(i, k)+pgacr(i, k))/xlf
7674         IF (x8 .LT. -(qrs(i, k, 3)/dtcld)) THEN
7675           x6 = -(qrs(i, k, 3)/dtcld)
7676           CALL PUSHCONTROL1B(0)
7677         ELSE
7678           x6 = x8
7679           CALL PUSHCONTROL1B(1)
7680         END IF
7681         IF (x6 .GT. 0.) THEN
7682           pgeml(i, k) = 0.
7683           CALL PUSHCONTROL1B(0)
7684         ELSE
7685           pgeml(i, k) = x6
7686           CALL PUSHCONTROL1B(1)
7687         END IF
7688         CALL PUSHREAL8(pgeml(i, k))
7689         pgeml(i, k) = ft0*fqg*pgeml(i, k)
7690         IF (pgeml(i, k) .GE. 0.) THEN
7691           abs9 = pgeml(i, k)
7692         ELSE
7693           abs9 = -pgeml(i, k)
7694         END IF
7695         IF (abs9 .LT. qmin/dtcld) THEN
7696           pgeml(i, k) = 0.
7697           CALL PUSHCONTROL1B(1)
7698         ELSE
7699           CALL PUSHCONTROL1B(0)
7700         END IF
7701         IF (qrs(i, k, 1) - pgeml(i, k)*dtcld .LT. 0.) THEN
7702           CALL PUSHREAL8(qrs(i, k, 1))
7703           qrs(i, k, 1) = 0.
7704           CALL PUSHCONTROL1B(0)
7705         ELSE
7706           CALL PUSHREAL8(qrs(i, k, 1))
7707           qrs(i, k, 1) = qrs(i, k, 1) - pgeml(i, k)*dtcld
7708           CALL PUSHCONTROL1B(1)
7709         END IF
7710         IF (qrs(i, k, 3) + pgeml(i, k)*dtcld .LT. 0.) THEN
7711           CALL PUSHCONTROL1B(0)
7712         ELSE
7713           CALL PUSHCONTROL1B(1)
7714         END IF
7715       END DO
7716     END DO
7717     a_cpm = 0.0_8
7718     a_xl = 0.0_8
7719     DO k=kte,kts,-1
7720       DO i=ite,its,-1
7721         a_temp1 = dtcld*a_t(i, k)/cpm(i, k)
7722         a_pgacr(i, k) = 0.0_8
7723         a_pgacw(i, k) = 0.0_8
7724         a_pgeml(i, k) = xlf*a_temp1
7725         a_xlf = pgeml(i, k)*a_temp1
7726         a_cpm(i, k) = a_cpm(i, k) - pgeml(i, k)*xlf*a_temp1/cpm(i, k)
7727         CALL POPCONTROL1B(branch)
7728         IF (branch .EQ. 0) THEN
7729           a_qrs(i, k, 3) = 0.0_8
7730         ELSE
7731           a_pgeml(i, k) = a_pgeml(i, k) + dtcld*a_qrs(i, k, 3)
7732         END IF
7733         CALL POPCONTROL1B(branch)
7734         IF (branch .EQ. 0) THEN
7735           CALL POPREAL8(qrs(i, k, 1))
7736           a_qrs(i, k, 1) = 0.0_8
7737         ELSE
7738           CALL POPREAL8(qrs(i, k, 1))
7739           a_pgeml(i, k) = a_pgeml(i, k) - dtcld*a_qrs(i, k, 1)
7740         END IF
7741         CALL POPCONTROL1B(branch)
7742         IF (branch .NE. 0) a_pgeml(i, k) = 0.0_8
7743         CALL POPREAL8(pgeml(i, k))
7744         a_temp1 = pgeml(i, k)*a_pgeml(i, k)
7745         a_pgeml(i, k) = ft0*fqg*a_pgeml(i, k)
7746         a_ft0 = fqg*a_temp1
7747         a_fqg = ft0*a_temp1
7748         CALL POPCONTROL1B(branch)
7749         IF (branch .EQ. 0) THEN
7750           a_pgeml(i, k) = 0.0_8
7751           a_x6 = 0.0_8
7752         ELSE
7753           a_x6 = a_pgeml(i, k)
7754           a_pgeml(i, k) = 0.0_8
7755         END IF
7756         CALL POPCONTROL1B(branch)
7757         IF (branch .EQ. 0) THEN
7758           a_qrs(i, k, 3) = a_qrs(i, k, 3) - a_x6/dtcld
7759           a_x8 = 0.0_8
7760         ELSE
7761           a_x8 = a_x6
7762         END IF
7763         a_temp1 = supcol*cliq*a_x8/xlf
7764         a_temp5 = (pgacw(i, k)+pgacr(i, k))*cliq*a_x8/xlf
7765         a_supcol = a_temp5
7766         a_xlf = a_xlf - supcol*a_temp5/xlf
7767         a_pgacw(i, k) = a_pgacw(i, k) + a_temp1
7768         a_pgacr(i, k) = a_pgacr(i, k) + a_temp1
7769         CALL POPREAL8(fqg)
7770         CALL A_SMOOTHIF(qrs(i, k, 3), a_qrs(i, k, 3), 0., fqg, a_fqg, &
7771 &                 'q+')
7772         CALL POPREAL8(ft0)
7773         CALL A_SMOOTHIF(t(i, k), a_t(i, k), t0c, ft0, a_ft0, 't0')
7774         CALL POPCONTROL1B(branch)
7775         IF (branch .NE. 0) a_xlf = 0.0_8
7776         CALL POPREAL8(xlf)
7777         a_xl(i, k) = a_xl(i, k) - a_xlf
7778         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
7779         a_xl(i, k) = 0.0_8
7780         CALL POPREAL8(supcol)
7781         a_t(i, k) = a_t(i, k) - a_supcol
7782         a_psacr(i, k) = 0.0_8
7783         a_psacw(i, k) = 0.0_8
7784         CALL POPREAL8(t(i, k))
7785         a_temp1 = dtcld*a_t(i, k)/cpm(i, k)
7786         a_pseml(i, k) = xlf*a_temp1
7787         a_xlf = pseml(i, k)*a_temp1
7788         a_cpm(i, k) = a_cpm(i, k) - pseml(i, k)*xlf*a_temp1/cpm(i, k)
7789         CALL POPCONTROL1B(branch)
7790         IF (branch .EQ. 0) THEN
7791           CALL POPREAL8(qrs(i, k, 2))
7792           a_qrs(i, k, 2) = 0.0_8
7793         ELSE
7794           CALL POPREAL8(qrs(i, k, 2))
7795           a_pseml(i, k) = a_pseml(i, k) + dtcld*a_qrs(i, k, 2)
7796         END IF
7797         CALL POPCONTROL1B(branch)
7798         IF (branch .EQ. 0) THEN
7799           CALL POPREAL8(qrs(i, k, 1))
7800           a_qrs(i, k, 1) = 0.0_8
7801         ELSE
7802           CALL POPREAL8(qrs(i, k, 1))
7803           a_pseml(i, k) = a_pseml(i, k) - dtcld*a_qrs(i, k, 1)
7804         END IF
7805         CALL POPCONTROL1B(branch)
7806         IF (branch .NE. 0) a_pseml(i, k) = 0.0_8
7807         CALL POPREAL8(pseml(i, k))
7808         a_temp1 = pseml(i, k)*a_pseml(i, k)
7809         a_pseml(i, k) = ft0*fqs*a_pseml(i, k)
7810         a_ft0 = fqs*a_temp1
7811         a_fqs = ft0*a_temp1
7812         CALL POPCONTROL1B(branch)
7813         IF (branch .EQ. 0) THEN
7814           a_pseml(i, k) = 0.0_8
7815           a_x5 = 0.0_8
7816         ELSE
7817           a_x5 = a_pseml(i, k)
7818           a_pseml(i, k) = 0.0_8
7819         END IF
7820         CALL POPCONTROL1B(branch)
7821         IF (branch .EQ. 0) THEN
7822           a_qrs(i, k, 2) = a_qrs(i, k, 2) - a_x5/dtcld
7823           a_x7 = 0.0_8
7824         ELSE
7825           a_x7 = a_x5
7826         END IF
7827         a_temp1 = supcol*cliq*a_x7/xlf
7828         a_temp5 = (psacw(i, k)+psacr(i, k))*cliq*a_x7/xlf
7829         a_supcol = a_temp5
7830         a_xlf = a_xlf - supcol*a_temp5/xlf
7831         a_psacw(i, k) = a_psacw(i, k) + a_temp1
7832         a_psacr(i, k) = a_psacr(i, k) + a_temp1
7833         CALL POPREAL8(fqs)
7834         CALL A_SMOOTHIF(qrs(i, k, 2), a_qrs(i, k, 2), 0., fqs, a_fqs, &
7835 &                 'q+')
7836         CALL POPREAL8(ft0)
7837         CALL A_SMOOTHIF(t(i, k), a_t(i, k), t0c, ft0, a_ft0, 't0')
7838         CALL POPCONTROL1B(branch)
7839         IF (branch .NE. 0) a_xlf = 0.0_8
7840         CALL POPREAL8(xlf)
7841         a_xl(i, k) = a_xl(i, k) - a_xlf
7842         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
7843         a_xl(i, k) = 0.0_8
7844         a_pgacs(i, k) = 0.0_8
7845         CALL POPCONTROL1B(branch)
7846         IF (branch .EQ. 0) THEN
7847           a_qrs(i, k, 3) = 0.0_8
7848         ELSE
7849           a_pgacs(i, k) = a_pgacs(i, k) + dtcld*a_qrs(i, k, 3)
7850         END IF
7851         CALL POPCONTROL1B(branch)
7852         IF (branch .EQ. 0) THEN
7853           a_qrs(i, k, 2) = 0.0_8
7854         ELSE
7855           a_pgacs(i, k) = a_pgacs(i, k) - dtcld*a_qrs(i, k, 2)
7856         END IF
7857         CALL POPCONTROL1B(branch)
7858         IF (branch .NE. 0) a_pgacs(i, k) = 0.0_8
7859         CALL POPCONTROL1B(branch)
7860         IF (branch .EQ. 0) THEN
7861           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_pgacs(i, k)/dtcld
7862           a_pgacs(i, k) = 0.0_8
7863           a_pgacs1 = 0.0_8
7864         ELSE
7865           a_pgacs1 = a_pgacs(i, k)
7866           a_pgacs(i, k) = 0.0_8
7867         END IF
7868         a_temp1 = (pgacs_b*b+pgacs_c*c+pgacs_d*d)*pgacs_a*a_pgacs1
7869         a_temp5 = a*abs6*egs*pgacs_a*a_pgacs1
7870         a_b = pgacs_b*a_temp5
7871         a_c = pgacs_c*a_temp5
7872         a_d = pgacs_d*a_temp5
7873         a_a = abs6*egs*a_temp1
7874         a_abs6 = a*egs*a_temp1
7875         a_egs = a*abs6*a_temp1
7876         CALL POPCONTROL1B(branch)
7877         IF (branch .EQ. 0) THEN
7878           CALL POPREAL8(abs6)
7879           a_vt2g = a_abs6
7880           a_vt2s = -a_abs6
7881         ELSE
7882           CALL POPREAL8(abs6)
7883           a_vt2s = a_abs6
7884           a_vt2g = -a_abs6
7885         END IF
7886         temp9 = 3./4.
7887         temp8 = max47**temp9
7888         temp6 = 3./4.
7889         temp5 = den(i, k)**temp6
7890         temp4 = EXP(-(alpha*max23))
7891         a_temp3 = max38*temp8*a_d
7892         a_temp4 = temp4*temp5*a_d
7893         a_max38 = temp8*a_temp4
7894         IF (max47 .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR. temp9 .NE. INT&
7895 &           (temp9))) THEN
7896           a_max47 = 0.0_8
7897         ELSE
7898           a_max47 = temp9*max47**(temp9-1)*max38*a_temp4
7899         END IF
7900         a_max23 = -(alpha*EXP(-(alpha*max23))*temp5*a_temp3)
7901         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp6 .EQ. 0.0_8 .OR. &
7902 &           temp6 .NE. INT(temp6)))) a_den(i, k) = a_den(i, k) + temp6*&
7903 &           den(i, k)**(temp6-1)*temp4*a_temp3
7904         CALL POPCONTROL1B(branch)
7905         IF (branch .EQ. 0) THEN
7906           CALL POPREAL8(max47)
7907         ELSE
7908           CALL POPREAL8(max47)
7909           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max47
7910         END IF
7911         CALL POPCONTROL1B(branch)
7912         IF (branch .EQ. 0) THEN
7913           CALL POPREAL8(max38)
7914           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max38
7915         ELSE
7916           CALL POPREAL8(max38)
7917         END IF
7918         CALL POPCONTROL1B(branch)
7919         IF (branch .EQ. 0) THEN
7920           CALL POPREAL8(max23)
7921           a_y12 = 0.0_8
7922         ELSE
7923           CALL POPREAL8(max23)
7924           a_y12 = a_max23
7925         END IF
7926         CALL POPCONTROL1B(branch)
7927         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y12
7928         CALL POPREAL8(c)
7929         temp9 = SQRT(max46)
7930         temp8 = 5./4.
7931         temp7 = max37**temp8
7932         temp5 = 3./4.
7933         temp4 = den(i, k)**temp5
7934         temp3 = -(5.*alpha*max22/4.)
7935         temp2 = EXP(temp3)
7936         a_temp2 = temp7*temp9*a_c
7937         a_temp0 = temp2*temp4*a_c
7938         IF (max37 .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. temp8 .NE. INT&
7939 &           (temp8))) THEN
7940           a_max37 = 0.0_8
7941         ELSE
7942           a_max37 = temp8*max37**(temp8-1)*temp9*a_temp0
7943         END IF
7944         IF (max46 .EQ. 0.0_8) THEN
7945           a_max46 = 0.0_8
7946         ELSE
7947           a_max46 = temp7*a_temp0/(2.0*temp9)
7948         END IF
7949         a_max22 = -(alpha*5.*EXP(temp3)*temp4*a_temp2/4.)
7950         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR. &
7951 &           temp5 .NE. INT(temp5)))) a_den(i, k) = a_den(i, k) + temp5*&
7952 &           den(i, k)**(temp5-1)*temp2*a_temp2
7953         CALL POPCONTROL1B(branch)
7954         IF (branch .EQ. 0) THEN
7955           CALL POPREAL8(max46)
7956         ELSE
7957           CALL POPREAL8(max46)
7958           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max46
7959         END IF
7960         CALL POPCONTROL1B(branch)
7961         IF (branch .EQ. 0) THEN
7962           CALL POPREAL8(max37)
7963           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max37
7964         ELSE
7965           CALL POPREAL8(max37)
7966         END IF
7967         CALL POPCONTROL1B(branch)
7968         IF (branch .EQ. 0) THEN
7969           CALL POPREAL8(max22)
7970           a_y11 = 0.0_8
7971         ELSE
7972           CALL POPREAL8(max22)
7973           a_y11 = a_max22
7974         END IF
7975         CALL POPCONTROL1B(branch)
7976         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y11
7977         d = den(i, k)**(3./4.)*max17*max34**(3./4.)
7978         CALL POPREAL8(b)
7979         temp9 = SQRT(max45)
7980         temp8 = SQRT(temp9)
7981         temp7 = -(3.*alpha*max21/2.)
7982         temp6 = EXP(temp7)
7983         temp4 = 3./2.
7984         temp3 = max36**temp4
7985         temp2 = 3./4.
7986         temp0 = den(i, k)**temp2
7987         a_temp6 = temp6*temp8*a_b
7988         a_temp = temp0*temp3*a_b
7989         a_max21 = -(alpha*3.*EXP(temp7)*temp8*a_temp/2.)
7990         IF (max45 .EQ. 0.0_8 .OR. temp9 .EQ. 0.0_8) THEN
7991           a_max45 = 0.0_8
7992         ELSE
7993           a_max45 = temp6*a_temp/(2.0**2*temp9*temp8)
7994         END IF
7995         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp2 .EQ. 0.0_8 .OR. &
7996 &           temp2 .NE. INT(temp2)))) a_den(i, k) = a_den(i, k) + temp2*&
7997 &           den(i, k)**(temp2-1)*temp3*a_temp6
7998         IF (max36 .LE. 0.0_8 .AND. (temp4 .EQ. 0.0_8 .OR. temp4 .NE. INT&
7999 &           (temp4))) THEN
8000           a_max36 = 0.0_8
8001         ELSE
8002           a_max36 = temp4*max36**(temp4-1)*temp0*a_temp6
8003         END IF
8004         CALL POPCONTROL1B(branch)
8005         IF (branch .EQ. 0) THEN
8006           CALL POPREAL8(max45)
8007         ELSE
8008           CALL POPREAL8(max45)
8009           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max45
8010         END IF
8011         CALL POPCONTROL1B(branch)
8012         IF (branch .EQ. 0) THEN
8013           CALL POPREAL8(max36)
8014           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max36
8015         ELSE
8016           CALL POPREAL8(max36)
8017         END IF
8018         CALL POPCONTROL1B(branch)
8019         IF (branch .EQ. 0) THEN
8020           CALL POPREAL8(max21)
8021           a_y10 = 0.0_8
8022         ELSE
8023           CALL POPREAL8(max21)
8024           a_y10 = a_max21
8025         END IF
8026         CALL POPCONTROL1B(branch)
8027         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y10
8028         CALL POPREAL8(a)
8029         a_max20 = alpha*EXP(alpha*max20)*a_a
8030         CALL POPCONTROL1B(branch)
8031         IF (branch .EQ. 0) THEN
8032           CALL POPREAL8(max20)
8033           a_y9 = a_max20
8034         ELSE
8035           CALL POPREAL8(max20)
8036           a_y9 = 0.0_8
8037         END IF
8038         CALL POPCONTROL1B(branch)
8039         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y9
8040         temp9 = -(alpha*bvts*max35/4.)
8041         temp7 = bvts/4.
8042         temp6 = max19**temp7
8043         temp5 = (bvts-2.)/4.
8044         temp4 = den(i, k)**temp5
8045         a_temp5 = EXP(temp9)*vt2s_a*a_vt2s
8046         a_max35 = -(alpha*bvts*EXP(temp9)*temp4*temp6*vt2s_a*a_vt2s/4.)
8047         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR. &
8048 &           temp5 .NE. INT(temp5)))) a_den(i, k) = a_den(i, k) + temp5*&
8049 &           den(i, k)**(temp5-1)*temp6*a_temp5
8050         IF (max19 .LE. 0.0_8 .AND. (temp7 .EQ. 0.0_8 .OR. temp7 .NE. INT&
8051 &           (temp7))) THEN
8052           a_max19 = 0.0_8
8053         ELSE
8054           a_max19 = temp7*max19**(temp7-1)*temp4*a_temp5
8055         END IF
8056         CALL POPCONTROL1B(branch)
8057         IF (branch .EQ. 0) THEN
8058           CALL POPREAL8(max35)
8059           a_y15 = a_max35
8060         ELSE
8061           CALL POPREAL8(max35)
8062           a_y15 = 0.0_8
8063         END IF
8064         CALL POPCONTROL1B(branch)
8065         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y15
8066         CALL POPCONTROL1B(branch)
8067         IF (branch .EQ. 0) THEN
8068           CALL POPREAL8(max19)
8069         ELSE
8070           CALL POPREAL8(max19)
8071           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max19
8072         END IF
8073         temp9 = bvtg/4.
8074         temp8 = (bvtg-2.)/4.
8075         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. &
8076 &           temp8 .NE. INT(temp8)))) a_den(i, k) = a_den(i, k) + temp8*&
8077 &           den(i, k)**(temp8-1)*max18**temp9*vt2g_a*a_vt2g
8078         IF (max18 .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR. temp9 .NE. INT&
8079 &           (temp9))) THEN
8080           a_max18 = 0.0_8
8081         ELSE
8082           a_max18 = temp9*max18**(temp9-1)*den(i, k)**temp8*vt2g_a*&
8083 &           a_vt2g
8084         END IF
8085         CALL POPCONTROL1B(branch)
8086         IF (branch .EQ. 0) THEN
8087           CALL POPREAL8(max18)
8088         ELSE
8089           CALL POPREAL8(max18)
8090           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max18
8091         END IF
8092         CALL POPCONTROL1B(branch)
8093         IF (branch .EQ. 0) THEN
8094           CALL POPREAL8(egs)
8095           a_x4 = 0.0_8
8096         ELSE
8097           CALL POPREAL8(egs)
8098           a_x4 = a_egs
8099         END IF
8100         a_supcol = a_supcol - 0.09*EXP(-(0.09*supcol))*a_x4
8101         CALL POPREAL8(supcol)
8102         a_t(i, k) = a_t(i, k) - a_supcol
8103         CALL POPREAL8(pgacr(i, k))
8104         temp8 = pgacr(i, k)/cpm(i, k)
8105         a_temp1 = dtcld*a_t(i, k)
8106         a_fsupcol = xlf*temp8*a_temp1 - pgacr(i, k)*a_pgacr(i, k)
8107         a_xlf = fsupcol*temp8*a_temp1
8108         a_temp5 = fsupcol*xlf*a_temp1/cpm(i, k)
8109         a_pgacr(i, k) = (1-fsupcol)*a_pgacr(i, k) + a_temp5
8110         a_cpm(i, k) = a_cpm(i, k) - temp8*a_temp5
8111         CALL POPCONTROL1B(branch)
8112         IF (branch .EQ. 0) THEN
8113           a_qrs(i, k, 3) = 0.0_8
8114           a_x3 = 0.0_8
8115         ELSE
8116           a_x3 = a_qrs(i, k, 3)
8117           a_qrs(i, k, 3) = 0.0_8
8118         END IF
8119         a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_x3
8120         a_fsupcol = a_fsupcol + pgacr(i, k)*dtcld*a_x3
8121         a_pgacr(i, k) = a_pgacr(i, k) + fsupcol*dtcld*a_x3
8122         CALL POPCONTROL1B(branch)
8123         IF (branch .EQ. 0) THEN
8124           a_qrs(i, k, 1) = 0.0_8
8125         ELSE
8126           a_fsupcol = a_fsupcol - pgacr(i, k)*dtcld*a_qrs(i, k, 1)
8127           a_pgacr(i, k) = a_pgacr(i, k) - fsupcol*dtcld*a_qrs(i, k, 1)
8128         END IF
8129         CALL POPCONTROL1B(branch)
8130         IF (branch .NE. 0) a_pgacr(i, k) = 0.0_8
8131         CALL POPCONTROL2B(branch)
8132         IF (branch .LT. 2) THEN
8133           IF (branch .EQ. 0) THEN
8134             a_pgacr1 = a_pgacr(i, k)
8135             a_pgacr(i, k) = 0.0_8
8136           ELSE
8137             a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_pgacr(i, k)/dtcld
8138             a_pgacr(i, k) = 0.0_8
8139             a_pgacr1 = 0.0_8
8140           END IF
8141         ELSE IF (branch .EQ. 2) THEN
8142           a_pgacr1 = a_pgacr(i, k)
8143           a_pgacr(i, k) = 0.0_8
8144         ELSE
8145           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_pgacr(i, k)/dtcld
8146           a_pgacr(i, k) = 0.0_8
8147           a_pgacr1 = 0.0_8
8148         END IF
8149         a_abs4 = (pgacr_b*b+pgacr_c*c+pgacr_d*d)*pgacr_a*a_pgacr1
8150         a_temp1 = abs4*pgacr_a*a_pgacr1
8151         a_b = pgacr_b*a_temp1
8152         a_c = pgacr_c*a_temp1
8153         a_d = pgacr_d*a_temp1
8154         CALL POPCONTROL1B(branch)
8155         IF (branch .EQ. 0) THEN
8156           CALL POPREAL8(abs4)
8157           a_vt2r = a_abs4
8158           a_vt2g = -a_abs4
8159         ELSE
8160           CALL POPREAL8(abs4)
8161           a_vt2g = a_abs4
8162           a_vt2r = -a_abs4
8163         END IF
8164         CALL POPREAL8(d)
8165         temp9 = 3./4.
8166         temp8 = max34**temp9
8167         temp7 = 3./4.
8168         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp7 .EQ. 0.0_8 .OR. &
8169 &           temp7 .NE. INT(temp7)))) a_den(i, k) = a_den(i, k) + temp7*&
8170 &           den(i, k)**(temp7-1)*max17*temp8*a_d
8171         a_temp2 = den(i, k)**temp7*a_d
8172         a_max17 = temp8*a_temp2
8173         IF (max34 .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR. temp9 .NE. INT&
8174 &           (temp9))) THEN
8175           a_max34 = 0.0_8
8176         ELSE
8177           a_max34 = temp9*max34**(temp9-1)*max17*a_temp2
8178         END IF
8179         CALL POPCONTROL1B(branch)
8180         IF (branch .EQ. 0) THEN
8181           CALL POPREAL8(max34)
8182         ELSE
8183           CALL POPREAL8(max34)
8184           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max34
8185         END IF
8186         CALL POPCONTROL1B(branch)
8187         IF (branch .EQ. 0) THEN
8188           CALL POPREAL8(max17)
8189           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max17
8190         ELSE
8191           CALL POPREAL8(max17)
8192         END IF
8193         CALL POPREAL8(c)
8194         temp9 = SQRT(max33)
8195         temp8 = 5./4.
8196         temp7 = max16**temp8
8197         temp6 = 3./4.
8198         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp6 .EQ. 0.0_8 .OR. &
8199 &           temp6 .NE. INT(temp6)))) a_den(i, k) = a_den(i, k) + temp6*&
8200 &           den(i, k)**(temp6-1)*temp7*temp9*a_c
8201         a_temp6 = den(i, k)**temp6*a_c
8202         IF (max16 .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. temp8 .NE. INT&
8203 &           (temp8))) THEN
8204           a_max16 = 0.0_8
8205         ELSE
8206           a_max16 = temp8*max16**(temp8-1)*temp9*a_temp6
8207         END IF
8208         IF (max33 .EQ. 0.0_8) THEN
8209           a_max33 = 0.0_8
8210         ELSE
8211           a_max33 = temp7*a_temp6/(2.0*temp9)
8212         END IF
8213         CALL POPCONTROL1B(branch)
8214         IF (branch .EQ. 0) THEN
8215           CALL POPREAL8(max33)
8216         ELSE
8217           CALL POPREAL8(max33)
8218           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max33
8219         END IF
8220         CALL POPCONTROL1B(branch)
8221         IF (branch .EQ. 0) THEN
8222           CALL POPREAL8(max16)
8223           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max16
8224         ELSE
8225           CALL POPREAL8(max16)
8226         END IF
8227         CALL POPREAL8(b)
8228         temp9 = SQRT(max32)
8229         temp8 = SQRT(temp9)
8230         temp7 = 3./2.
8231         temp6 = max15**temp7
8232         temp5 = 3./4.
8233         temp4 = den(i, k)**temp5
8234         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR. &
8235 &           temp5 .NE. INT(temp5)))) a_den(i, k) = a_den(i, k) + temp5*&
8236 &           den(i, k)**(temp5-1)*temp6*temp8*a_b
8237         IF (max15 .LE. 0.0_8 .AND. (temp7 .EQ. 0.0_8 .OR. temp7 .NE. INT&
8238 &           (temp7))) THEN
8239           a_max15 = 0.0_8
8240         ELSE
8241           a_max15 = temp7*max15**(temp7-1)*temp4*temp8*a_b
8242         END IF
8243         IF (max32 .EQ. 0.0_8 .OR. temp9 .EQ. 0.0_8) THEN
8244           a_max32 = 0.0_8
8245         ELSE
8246           a_max32 = temp4*temp6*a_b/(2.0**2*temp9*temp8)
8247         END IF
8248         CALL POPCONTROL1B(branch)
8249         IF (branch .EQ. 0) THEN
8250           CALL POPREAL8(max32)
8251         ELSE
8252           CALL POPREAL8(max32)
8253           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max32
8254         END IF
8255         CALL POPCONTROL1B(branch)
8256         IF (branch .EQ. 0) THEN
8257           CALL POPREAL8(max15)
8258           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max15
8259         ELSE
8260           CALL POPREAL8(max15)
8261         END IF
8262         temp9 = bvtg/4.
8263         temp8 = (bvtg-2.)/4.
8264         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. &
8265 &           temp8 .NE. INT(temp8)))) a_den(i, k) = a_den(i, k) + temp8*&
8266 &           den(i, k)**(temp8-1)*max14**temp9*vt2g_a*a_vt2g
8267         IF (max14 .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR. temp9 .NE. INT&
8268 &           (temp9))) THEN
8269           a_max14 = 0.0_8
8270         ELSE
8271           a_max14 = temp9*max14**(temp9-1)*den(i, k)**temp8*vt2g_a*&
8272 &           a_vt2g
8273         END IF
8274         CALL POPCONTROL1B(branch)
8275         IF (branch .EQ. 0) THEN
8276           CALL POPREAL8(max14)
8277         ELSE
8278           CALL POPREAL8(max14)
8279           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max14
8280         END IF
8281         temp9 = bvtr/4.
8282         temp8 = (bvtr-2.)/4.
8283         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. &
8284 &           temp8 .NE. INT(temp8)))) a_den(i, k) = a_den(i, k) + temp8*&
8285 &           den(i, k)**(temp8-1)*max13**temp9*vt2r_a*a_vt2r
8286         IF (max13 .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR. temp9 .NE. INT&
8287 &           (temp9))) THEN
8288           a_max13 = 0.0_8
8289         ELSE
8290           a_max13 = temp9*max13**(temp9-1)*den(i, k)**temp8*vt2r_a*&
8291 &           a_vt2r
8292         END IF
8293         CALL POPCONTROL1B(branch)
8294         IF (branch .EQ. 0) THEN
8295           CALL POPREAL8(max13)
8296         ELSE
8297           CALL POPREAL8(max13)
8298           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max13
8299         END IF
8300         CALL POPCONTROL1B(branch)
8301         IF (branch .NE. 0) a_xlf = 0.0_8
8302         CALL POPREAL8(xlf)
8303         a_xl(i, k) = a_xl(i, k) - a_xlf
8304         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
8305         a_xl(i, k) = 0.0_8
8306         CALL POPREAL8(fsupcol)
8307         a_supcol = 0.0_8
8308         CALL A_SMOOTHIF(supcol, a_supcol, 0., fsupcol, a_fsupcol, 't0')
8309         CALL POPREAL8(supcol)
8310         a_t(i, k) = a_t(i, k) - a_supcol
8311         CALL POPREAL8(psacr(i, k))
8312         temp8 = psacr(i, k)/cpm(i, k)
8313         a_temp1 = dtcld*a_t(i, k)
8314         a_fsupcol = xlf*temp8*a_temp1 - psacr(i, k)*a_psacr(i, k)
8315         a_xlf = fsupcol*temp8*a_temp1
8316         a_temp5 = fsupcol*xlf*a_temp1/cpm(i, k)
8317         a_psacr(i, k) = (1-fsupcol)*a_psacr(i, k) + a_temp5
8318         a_cpm(i, k) = a_cpm(i, k) - temp8*a_temp5
8319         CALL POPCONTROL1B(branch)
8320         IF (branch .EQ. 0) THEN
8321           a_qrs(i, k, 3) = 0.0_8
8322           a_x2 = 0.0_8
8323         ELSE
8324           a_x2 = a_qrs(i, k, 3)
8325           a_qrs(i, k, 3) = 0.0_8
8326         END IF
8327         a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_x2
8328         a_temp1 = (1-delta2)*dtcld*a_x2
8329         a_fsupcol = a_fsupcol + psacr(i, k)*a_temp1
8330         a_psacr(i, k) = a_psacr(i, k) + fsupcol*a_temp1
8331         CALL POPCONTROL1B(branch)
8332         IF (branch .EQ. 0) THEN
8333           a_qrs(i, k, 2) = 0.0_8
8334           a_x1 = 0.0_8
8335         ELSE
8336           a_x1 = a_qrs(i, k, 2)
8337           a_qrs(i, k, 2) = 0.0_8
8338         END IF
8339         a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_x1
8340         a_temp1 = delta2*dtcld*a_x1
8341         a_fsupcol = a_fsupcol + psacr(i, k)*a_temp1
8342         a_psacr(i, k) = a_psacr(i, k) + fsupcol*a_temp1
8343         CALL POPCONTROL1B(branch)
8344         IF (branch .EQ. 0) THEN
8345           a_qrs(i, k, 1) = 0.0_8
8346         ELSE
8347           a_fsupcol = a_fsupcol - psacr(i, k)*dtcld*a_qrs(i, k, 1)
8348           a_psacr(i, k) = a_psacr(i, k) - fsupcol*dtcld*a_qrs(i, k, 1)
8349         END IF
8350         CALL POPCONTROL1B(branch)
8351         IF (branch .EQ. 0) THEN
8352           CALL POPREAL8(delta2)
8353         ELSE
8354           CALL POPREAL8(delta2)
8355         END IF
8356         CALL POPCONTROL1B(branch)
8357         IF (branch .EQ. 0) a_psacr(i, k) = 0.0_8
8358         CALL POPCONTROL2B(branch)
8359         IF (branch .LT. 2) THEN
8360           IF (branch .EQ. 0) THEN
8361             a_psacr1 = a_psacr(i, k)
8362             a_psacr(i, k) = 0.0_8
8363           ELSE
8364             a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_psacr(i, k)/dtcld
8365             a_psacr(i, k) = 0.0_8
8366             a_psacr1 = 0.0_8
8367           END IF
8368         ELSE IF (branch .EQ. 2) THEN
8369           a_psacr1 = a_psacr(i, k)
8370           a_psacr(i, k) = 0.0_8
8371         ELSE
8372           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_psacr(i, k)/dtcld
8373           a_psacr(i, k) = 0.0_8
8374           a_psacr1 = 0.0_8
8375         END IF
8376         a_temp1 = (psacr_b*b+psacr_c*c+psacr_d*d)*psacr_a*a_psacr1
8377         a_temp5 = a*abs2*psacr_a*a_psacr1
8378         a_b = psacr_b*a_temp5
8379         a_c = psacr_c*a_temp5
8380         a_d = psacr_d*a_temp5
8381         a_a = abs2*a_temp1
8382         a_abs2 = a*a_temp1
8383         CALL POPCONTROL1B(branch)
8384         IF (branch .EQ. 0) THEN
8385           CALL POPREAL8(abs2)
8386           a_vt2r = a_abs2
8387           a_vt2s = -a_abs2
8388         ELSE
8389           CALL POPREAL8(abs2)
8390           a_vt2s = a_abs2
8391           a_vt2r = -a_abs2
8392         END IF
8393         CALL POPREAL8(d)
8394         temp9 = 3./4.
8395         temp8 = max44**temp9
8396         temp7 = 3./4.
8397         temp6 = den(i, k)**temp7
8398         temp5 = -(3.*alpha*max12/4.)
8399         a_max12 = -(alpha*3.*EXP(temp5)*temp6*max31*temp8*a_d/4.)
8400         a_temp7 = EXP(temp5)*a_d
8401         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp7 .EQ. 0.0_8 .OR. &
8402 &           temp7 .NE. INT(temp7)))) a_den(i, k) = a_den(i, k) + temp7*&
8403 &           den(i, k)**(temp7-1)*max31*temp8*a_temp7
8404         a_max31 = temp8*temp6*a_temp7
8405         IF (max44 .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR. temp9 .NE. INT&
8406 &           (temp9))) THEN
8407           a_max44 = 0.0_8
8408         ELSE
8409           a_max44 = temp9*max44**(temp9-1)*max31*temp6*a_temp7
8410         END IF
8411         CALL POPCONTROL1B(branch)
8412         IF (branch .EQ. 0) THEN
8413           CALL POPREAL8(max44)
8414         ELSE
8415           CALL POPREAL8(max44)
8416           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max44
8417         END IF
8418         CALL POPCONTROL1B(branch)
8419         IF (branch .EQ. 0) THEN
8420           CALL POPREAL8(max31)
8421           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max31
8422         ELSE
8423           CALL POPREAL8(max31)
8424         END IF
8425         CALL POPCONTROL1B(branch)
8426         IF (branch .EQ. 0) THEN
8427           CALL POPREAL8(max12)
8428           a_y8 = 0.0_8
8429         ELSE
8430           CALL POPREAL8(max12)
8431           a_y8 = a_max12
8432         END IF
8433         CALL POPCONTROL1B(branch)
8434         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y8
8435         CALL POPREAL8(c)
8436         temp9 = SQRT(max43)
8437         temp8 = 5./4.
8438         temp7 = max30**temp8
8439         temp5 = 3./4.
8440         temp4 = den(i, k)**temp5
8441         temp3 = -(alpha*max11/2.)
8442         temp2 = EXP(temp3)
8443         a_temp2 = temp7*temp9*a_c
8444         a_temp0 = temp2*temp4*a_c
8445         IF (max30 .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. temp8 .NE. INT&
8446 &           (temp8))) THEN
8447           a_max30 = 0.0_8
8448         ELSE
8449           a_max30 = temp8*max30**(temp8-1)*temp9*a_temp0
8450         END IF
8451         IF (max43 .EQ. 0.0_8) THEN
8452           a_max43 = 0.0_8
8453         ELSE
8454           a_max43 = temp7*a_temp0/(2.0*temp9)
8455         END IF
8456         a_max11 = -(alpha*EXP(temp3)*temp4*a_temp2/2.)
8457         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR. &
8458 &           temp5 .NE. INT(temp5)))) a_den(i, k) = a_den(i, k) + temp5*&
8459 &           den(i, k)**(temp5-1)*temp2*a_temp2
8460         CALL POPCONTROL1B(branch)
8461         IF (branch .EQ. 0) THEN
8462           CALL POPREAL8(max43)
8463         ELSE
8464           CALL POPREAL8(max43)
8465           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max43
8466         END IF
8467         CALL POPCONTROL1B(branch)
8468         IF (branch .EQ. 0) THEN
8469           CALL POPREAL8(max30)
8470           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max30
8471         ELSE
8472           CALL POPREAL8(max30)
8473         END IF
8474         CALL POPCONTROL1B(branch)
8475         IF (branch .EQ. 0) THEN
8476           CALL POPREAL8(max11)
8477           a_y7 = 0.0_8
8478         ELSE
8479           CALL POPREAL8(max11)
8480           a_y7 = a_max11
8481         END IF
8482         CALL POPCONTROL1B(branch)
8483         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y7
8484         CALL POPREAL8(b)
8485         temp9 = SQRT(max42)
8486         temp8 = SQRT(temp9)
8487         temp7 = -(alpha*max10/4.)
8488         temp6 = EXP(temp7)
8489         temp4 = 3./2.
8490         temp3 = max29**temp4
8491         temp2 = 3./4.
8492         temp0 = den(i, k)**temp2
8493         a_temp6 = temp6*temp8*a_b
8494         a_temp = temp0*temp3*a_b
8495         a_max10 = -(alpha*EXP(temp7)*temp8*a_temp/4.)
8496         IF (max42 .EQ. 0.0_8 .OR. temp9 .EQ. 0.0_8) THEN
8497           a_max42 = 0.0_8
8498         ELSE
8499           a_max42 = temp6*a_temp/(2.0**2*temp9*temp8)
8500         END IF
8501         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp2 .EQ. 0.0_8 .OR. &
8502 &           temp2 .NE. INT(temp2)))) a_den(i, k) = a_den(i, k) + temp2*&
8503 &           den(i, k)**(temp2-1)*temp3*a_temp6
8504         IF (max29 .LE. 0.0_8 .AND. (temp4 .EQ. 0.0_8 .OR. temp4 .NE. INT&
8505 &           (temp4))) THEN
8506           a_max29 = 0.0_8
8507         ELSE
8508           a_max29 = temp4*max29**(temp4-1)*temp0*a_temp6
8509         END IF
8510         CALL POPCONTROL1B(branch)
8511         IF (branch .EQ. 0) THEN
8512           CALL POPREAL8(max42)
8513         ELSE
8514           CALL POPREAL8(max42)
8515           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max42
8516         END IF
8517         CALL POPCONTROL1B(branch)
8518         IF (branch .EQ. 0) THEN
8519           CALL POPREAL8(max29)
8520           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max29
8521         ELSE
8522           CALL POPREAL8(max29)
8523         END IF
8524         CALL POPCONTROL1B(branch)
8525         IF (branch .EQ. 0) THEN
8526           CALL POPREAL8(max10)
8527           a_y6 = 0.0_8
8528         ELSE
8529           CALL POPREAL8(max10)
8530           a_y6 = a_max10
8531         END IF
8532         CALL POPCONTROL1B(branch)
8533         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y6
8534         CALL POPREAL8(a)
8535         a_max9 = alpha*EXP(alpha*max9)*a_a
8536         CALL POPCONTROL1B(branch)
8537         IF (branch .EQ. 0) THEN
8538           CALL POPREAL8(max9)
8539           a_y5 = a_max9
8540         ELSE
8541           CALL POPREAL8(max9)
8542           a_y5 = 0.0_8
8543         END IF
8544         CALL POPCONTROL1B(branch)
8545         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y5
8546         temp9 = -(alpha*bvts*max28/4.)
8547         temp7 = bvts/4.
8548         temp6 = max8**temp7
8549         temp5 = (bvts-2.)/4.
8550         temp4 = den(i, k)**temp5
8551         a_temp5 = EXP(temp9)*vt2s_a*a_vt2s
8552         a_max28 = -(alpha*bvts*EXP(temp9)*temp4*temp6*vt2s_a*a_vt2s/4.)
8553         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR. &
8554 &           temp5 .NE. INT(temp5)))) a_den(i, k) = a_den(i, k) + temp5*&
8555 &           den(i, k)**(temp5-1)*temp6*a_temp5
8556         IF (max8 .LE. 0.0_8 .AND. (temp7 .EQ. 0.0_8 .OR. temp7 .NE. INT(&
8557 &           temp7))) THEN
8558           a_max8 = 0.0_8
8559         ELSE
8560           a_max8 = temp7*max8**(temp7-1)*temp4*a_temp5
8561         END IF
8562         CALL POPCONTROL1B(branch)
8563         IF (branch .EQ. 0) THEN
8564           CALL POPREAL8(max28)
8565           a_y14 = a_max28
8566         ELSE
8567           CALL POPREAL8(max28)
8568           a_y14 = 0.0_8
8569         END IF
8570         CALL POPCONTROL1B(branch)
8571         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y14
8572         CALL POPCONTROL1B(branch)
8573         IF (branch .EQ. 0) THEN
8574           CALL POPREAL8(max8)
8575         ELSE
8576           CALL POPREAL8(max8)
8577           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max8
8578         END IF
8579         temp9 = bvtr/4.
8580         temp8 = (bvtr-2.)/4.
8581         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. &
8582 &           temp8 .NE. INT(temp8)))) a_den(i, k) = a_den(i, k) + temp8*&
8583 &           den(i, k)**(temp8-1)*max7**temp9*vt2r_a*a_vt2r
8584         IF (max7 .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR. temp9 .NE. INT(&
8585 &           temp9))) THEN
8586           a_max7 = 0.0_8
8587         ELSE
8588           a_max7 = temp9*max7**(temp9-1)*den(i, k)**temp8*vt2r_a*a_vt2r
8589         END IF
8590         CALL POPCONTROL1B(branch)
8591         IF (branch .EQ. 0) THEN
8592           CALL POPREAL8(max7)
8593         ELSE
8594           CALL POPREAL8(max7)
8595           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max7
8596         END IF
8597         CALL POPCONTROL1B(branch)
8598         IF (branch .NE. 0) a_xlf = 0.0_8
8599         CALL POPREAL8(xlf)
8600         a_xl(i, k) = a_xl(i, k) - a_xlf
8601         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
8602         a_xl(i, k) = 0.0_8
8603         CALL A_CPMCAL0(q(i, k), a_q(i, k), a_cpm(i, k))
8604         a_cpm(i, k) = 0.0_8
8605         a_pracs(i, k) = 0.0_8
8606         CALL POPCONTROL1B(branch)
8607         IF (branch .EQ. 0) THEN
8608           a_qrs(i, k, 3) = 0.0_8
8609         ELSE
8610           a_pracs(i, k) = a_pracs(i, k) + dtcld*a_qrs(i, k, 3)
8611         END IF
8612         CALL POPCONTROL1B(branch)
8613         IF (branch .EQ. 0) THEN
8614           a_qrs(i, k, 2) = 0.0_8
8615         ELSE
8616           a_pracs(i, k) = a_pracs(i, k) - dtcld*a_qrs(i, k, 2)
8617         END IF
8618         CALL POPCONTROL1B(branch)
8619         IF (branch .NE. 0) a_pracs(i, k) = 0.0_8
8620         CALL POPREAL8(pracs(i, k))
8621         a_fsupcol = a_fsupcol + pracs(i, k)*a_pracs(i, k)
8622         a_pracs(i, k) = fsupcol*a_pracs(i, k)
8623         CALL POPCONTROL1B(branch)
8624         IF (branch .EQ. 0) THEN
8625           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_pracs(i, k)/dtcld
8626           a_pracs(i, k) = 0.0_8
8627           a_pracs1 = 0.0_8
8628         ELSE
8629           a_pracs1 = a_pracs(i, k)
8630           a_pracs(i, k) = 0.0_8
8631         END IF
8632         a_temp1 = (pracs_b*b+pracs_c*c+pracs_d*d)*pracs_a*a_pracs1
8633         a_temp5 = a*abs0*pracs_a*a_pracs1
8634         a_b = pracs_b*a_temp5
8635         a_c = pracs_c*a_temp5
8636         a_d = pracs_d*a_temp5
8637         a_a = abs0*a_temp1
8638         a_abs0 = a*a_temp1
8639         CALL POPCONTROL1B(branch)
8640         IF (branch .EQ. 0) THEN
8641           CALL POPREAL8(abs0)
8642           a_vt2r = a_abs0
8643           a_vt2s = -a_abs0
8644         ELSE
8645           CALL POPREAL8(abs0)
8646           a_vt2s = a_abs0
8647           a_vt2r = -a_abs0
8648         END IF
8649         CALL POPREAL8(d)
8650         temp9 = 3./4.
8651         temp8 = max41**temp9
8652         temp6 = 3./4.
8653         temp5 = den(i, k)**temp6
8654         temp4 = EXP(-(alpha*max6))
8655         a_temp3 = max27*temp8*a_d
8656         a_temp4 = temp4*temp5*a_d
8657         a_max27 = temp8*a_temp4
8658         IF (max41 .LE. 0.0_8 .AND. (temp9 .EQ. 0.0_8 .OR. temp9 .NE. INT&
8659 &           (temp9))) THEN
8660           a_max41 = 0.0_8
8661         ELSE
8662           a_max41 = temp9*max41**(temp9-1)*max27*a_temp4
8663         END IF
8664         a_max6 = -(alpha*EXP(-(alpha*max6))*temp5*a_temp3)
8665         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp6 .EQ. 0.0_8 .OR. &
8666 &           temp6 .NE. INT(temp6)))) a_den(i, k) = a_den(i, k) + temp6*&
8667 &           den(i, k)**(temp6-1)*temp4*a_temp3
8668         CALL POPCONTROL1B(branch)
8669         IF (branch .EQ. 0) THEN
8670           CALL POPREAL8(max41)
8671         ELSE
8672           CALL POPREAL8(max41)
8673           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max41
8674         END IF
8675         CALL POPCONTROL1B(branch)
8676         IF (branch .EQ. 0) THEN
8677           CALL POPREAL8(max27)
8678           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max27
8679         ELSE
8680           CALL POPREAL8(max27)
8681         END IF
8682         CALL POPCONTROL1B(branch)
8683         IF (branch .EQ. 0) THEN
8684           CALL POPREAL8(max6)
8685           a_y4 = 0.0_8
8686         ELSE
8687           CALL POPREAL8(max6)
8688           a_y4 = a_max6
8689         END IF
8690         CALL POPCONTROL1B(branch)
8691         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y4
8692         CALL POPREAL8(c)
8693         temp9 = SQRT(max40)
8694         temp8 = 5./4.
8695         temp7 = max26**temp8
8696         temp5 = 3./4.
8697         temp4 = den(i, k)**temp5
8698         temp3 = -(5.*alpha*max5/4.)
8699         temp2 = EXP(temp3)
8700         a_temp2 = temp7*temp9*a_c
8701         a_temp0 = temp2*temp4*a_c
8702         IF (max26 .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. temp8 .NE. INT&
8703 &           (temp8))) THEN
8704           a_max26 = 0.0_8
8705         ELSE
8706           a_max26 = temp8*max26**(temp8-1)*temp9*a_temp0
8707         END IF
8708         IF (max40 .EQ. 0.0_8) THEN
8709           a_max40 = 0.0_8
8710         ELSE
8711           a_max40 = temp7*a_temp0/(2.0*temp9)
8712         END IF
8713         a_max5 = -(alpha*5.*EXP(temp3)*temp4*a_temp2/4.)
8714         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR. &
8715 &           temp5 .NE. INT(temp5)))) a_den(i, k) = a_den(i, k) + temp5*&
8716 &           den(i, k)**(temp5-1)*temp2*a_temp2
8717         CALL POPCONTROL1B(branch)
8718         IF (branch .EQ. 0) THEN
8719           CALL POPREAL8(max40)
8720         ELSE
8721           CALL POPREAL8(max40)
8722           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max40
8723         END IF
8724         CALL POPCONTROL1B(branch)
8725         IF (branch .EQ. 0) THEN
8726           CALL POPREAL8(max26)
8727           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max26
8728         ELSE
8729           CALL POPREAL8(max26)
8730         END IF
8731         CALL POPCONTROL1B(branch)
8732         IF (branch .EQ. 0) THEN
8733           CALL POPREAL8(max5)
8734           a_y3 = 0.0_8
8735         ELSE
8736           CALL POPREAL8(max5)
8737           a_y3 = a_max5
8738         END IF
8739         CALL POPCONTROL1B(branch)
8740         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y3
8741         CALL POPREAL8(b)
8742         temp5 = SQRT(max39)
8743         temp4 = SQRT(temp5)
8744         temp3 = -(3.*alpha*max4/2.)
8745         temp2 = EXP(temp3)
8746         temp = 3./2.
8747         temp6 = max25**temp
8748         temp7 = 3./4.
8749         temp8 = den(i, k)**temp7
8750         a_temp0 = temp2*temp4*a_b
8751         a_temp1 = temp8*temp6*a_b
8752         a_max4 = -(alpha*3.*EXP(temp3)*temp4*a_temp1/2.)
8753         IF (max39 .EQ. 0.0_8 .OR. temp5 .EQ. 0.0_8) THEN
8754           a_max39 = 0.0_8
8755         ELSE
8756           a_max39 = temp2*a_temp1/(2.0**2*temp5*temp4)
8757         END IF
8758         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp7 .EQ. 0.0_8 .OR. &
8759 &           temp7 .NE. INT(temp7)))) a_den(i, k) = a_den(i, k) + temp7*&
8760 &           den(i, k)**(temp7-1)*temp6*a_temp0
8761         IF (max25 .LE. 0.0_8 .AND. (temp .EQ. 0.0_8 .OR. temp .NE. INT(&
8762 &           temp))) THEN
8763           a_max25 = 0.0_8
8764         ELSE
8765           a_max25 = temp*max25**(temp-1)*temp8*a_temp0
8766         END IF
8767         CALL POPCONTROL1B(branch)
8768         IF (branch .EQ. 0) THEN
8769           CALL POPREAL8(max39)
8770         ELSE
8771           CALL POPREAL8(max39)
8772           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max39
8773         END IF
8774         CALL POPCONTROL1B(branch)
8775         IF (branch .EQ. 0) THEN
8776           CALL POPREAL8(max25)
8777           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max25
8778         ELSE
8779           CALL POPREAL8(max25)
8780         END IF
8781         CALL POPCONTROL1B(branch)
8782         IF (branch .EQ. 0) THEN
8783           CALL POPREAL8(max4)
8784           a_y2 = 0.0_8
8785         ELSE
8786           CALL POPREAL8(max4)
8787           a_y2 = a_max4
8788         END IF
8789         CALL POPCONTROL1B(branch)
8790         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y2
8791         CALL POPREAL8(a)
8792         a_max3 = alpha*EXP(alpha*max3)*a_a
8793         CALL POPCONTROL1B(branch)
8794         IF (branch .EQ. 0) THEN
8795           CALL POPREAL8(max3)
8796           a_y1 = a_max3
8797         ELSE
8798           CALL POPREAL8(max3)
8799           a_y1 = 0.0_8
8800         END IF
8801         CALL POPCONTROL1B(branch)
8802         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y1
8803         temp0 = -(alpha*bvts*max24/4.)
8804         temp2 = bvts/4.
8805         temp3 = max2**temp2
8806         temp4 = (bvts-2.)/4.
8807         temp5 = den(i, k)**temp4
8808         a_temp = EXP(temp0)*vt2s_a*a_vt2s
8809         a_max24 = -(alpha*bvts*EXP(temp0)*temp5*temp3*vt2s_a*a_vt2s/4.)
8810         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp4 .EQ. 0.0_8 .OR. &
8811 &           temp4 .NE. INT(temp4)))) a_den(i, k) = a_den(i, k) + temp4*&
8812 &           den(i, k)**(temp4-1)*temp3*a_temp
8813         IF (max2 .LE. 0.0_8 .AND. (temp2 .EQ. 0.0_8 .OR. temp2 .NE. INT(&
8814 &           temp2))) THEN
8815           a_max2 = 0.0_8
8816         ELSE
8817           a_max2 = temp2*max2**(temp2-1)*temp5*a_temp
8818         END IF
8819         CALL POPCONTROL1B(branch)
8820         IF (branch .EQ. 0) THEN
8821           CALL POPREAL8(max24)
8822           a_y13 = a_max24
8823         ELSE
8824           CALL POPREAL8(max24)
8825           a_y13 = 0.0_8
8826         END IF
8827         CALL POPCONTROL1B(branch)
8828         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y13
8829         CALL POPCONTROL1B(branch)
8830         IF (branch .EQ. 0) THEN
8831           CALL POPREAL8(max2)
8832         ELSE
8833           CALL POPREAL8(max2)
8834           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max2
8835         END IF
8836         temp = bvtr/4.
8837         temp0 = (bvtr-2.)/4.
8838         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp0 .EQ. 0.0_8 .OR. &
8839 &           temp0 .NE. INT(temp0)))) a_den(i, k) = a_den(i, k) + temp0*&
8840 &           den(i, k)**(temp0-1)*max1**temp*vt2r_a*a_vt2r
8841         IF (max1 .LE. 0.0_8 .AND. (temp .EQ. 0.0_8 .OR. temp .NE. INT(&
8842 &           temp))) THEN
8843           a_max1 = 0.0_8
8844         ELSE
8845           a_max1 = temp*max1**(temp-1)*den(i, k)**temp0*vt2r_a*a_vt2r
8846         END IF
8847         CALL POPCONTROL1B(branch)
8848         IF (branch .EQ. 0) THEN
8849           CALL POPREAL8(max1)
8850         ELSE
8851           CALL POPREAL8(max1)
8852           a_qrs(i, k, 1) = a_qrs(i, k, 1) + a_max1
8853         END IF
8854         CALL POPREAL8(fsupcol)
8855         a_supcol = 0.0_8
8856         CALL A_SMOOTHIF(supcol, a_supcol, 0., fsupcol, a_fsupcol, 't0')
8857         CALL POPREAL8(supcol)
8858         a_t(i, k) = a_t(i, k) - a_supcol
8859       END DO
8860     END DO
8861   END SUBROUTINE A_ACCRET2
8862
8863 !=======================================================================
8864 !
8865 !=======================================================================
8866   SUBROUTINE ACCRET2(qrs, t, q, den, dtcld, psacw, pgacw, pracs, psacr, &
8867 &   pgacr, pgacs, pseml, pgeml, ims, ime, kms, kme, its, ite, kts, kte)
8868     IMPLICIT NONE
8869     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
8870 !-------------------------------------------------------------------
8871     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
8872     REAL, DIMENSION(ims:ime, kms:kme) :: den, q
8873     REAL, DIMENSION(its:ite, kts:kte) :: psacw, pgacw, pracs, psacr, &
8874 &   pgacr, pgacs, pseml, pgeml, t, xl, cpm
8875     REAL :: supcol, vt2r, vt2s, vt2g, dtcld, xlf, egs
8876     REAL :: acrfac1, acrfac2, acrfac3, acrfac4, pracs1, psacr1, pgacr1, &
8877 &   pgacs1
8878     INTEGER :: i, k
8879     REAL :: fsupcol, ft0, fqr, fqs, fqg, temp1, delta2, a, b, c, d
8880     INTRINSIC MAX
8881     INTRINSIC MIN
8882     INTRINSIC EXP
8883     INTRINSIC SQRT
8884     INTRINSIC ABS
8885     REAL :: y1
8886     REAL :: y2
8887     REAL :: y3
8888     REAL :: y4
8889     REAL :: y5
8890     REAL :: y6
8891     REAL :: y7
8892     REAL :: y8
8893     REAL :: x1
8894     REAL :: x2
8895     REAL :: x3
8896     REAL :: x4
8897     REAL :: y9
8898     REAL :: y10
8899     REAL :: y11
8900     REAL :: y12
8901     REAL :: x5
8902     REAL :: x6
8903     REAL :: y13
8904     REAL :: y14
8905     REAL :: y15
8906     REAL :: x7
8907     REAL :: x8
8908     REAL :: max1
8909     REAL :: max2
8910     REAL :: max3
8911     REAL :: max4
8912     REAL :: max5
8913     REAL :: max6
8914     REAL :: abs0
8915     REAL :: abs1
8916     REAL :: max7
8917     REAL :: max8
8918     REAL :: max9
8919     REAL :: max10
8920     REAL :: max11
8921     REAL :: max12
8922     REAL :: abs2
8923     REAL :: abs3
8924     REAL :: max13
8925     REAL :: max14
8926     REAL :: max15
8927     REAL :: max16
8928     REAL :: max17
8929     REAL :: abs4
8930     REAL :: abs5
8931     REAL :: max18
8932     REAL :: max19
8933     REAL :: max20
8934     REAL :: max21
8935     REAL :: max22
8936     REAL :: max23
8937     REAL :: abs6
8938     REAL :: abs7
8939     REAL :: abs8
8940     REAL :: abs9
8941     REAL :: max24
8942     REAL :: max25
8943     REAL :: max26
8944     REAL :: max27
8945     REAL :: max28
8946     REAL :: max29
8947     REAL :: max30
8948     REAL :: max31
8949     REAL :: max32
8950     REAL :: max33
8951     REAL :: max34
8952     REAL :: max35
8953     REAL :: max36
8954     REAL :: max37
8955     REAL :: max38
8956     REAL :: max39
8957     REAL :: max40
8958     REAL :: max41
8959     REAL :: max42
8960     REAL :: max43
8961     REAL :: max44
8962     REAL :: max45
8963     REAL :: max46
8964     REAL :: max47
8965     DO k=kts,kte
8966       DO i=its,ite
8967 !-------------------------------------------------------------
8968 ! pracs: Accretion of snow by rain [LFO 27]
8969 !         (T<T0: S->G) pracs: min=0., max=qrs(i,k,2)/dtcld
8970 !-------------------------------------------------------------
8971         supcol = t0c - t(i, k)
8972         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
8973         IF (qrs(i, k, 1) .LT. qcrmin) THEN
8974           max1 = qcrmin
8975         ELSE
8976           max1 = qrs(i, k, 1)
8977         END IF
8978 !call smoothif(qrs(i,k,1),1.e-4,fqr,'q0')
8979 !call smoothif(qrs(i,k,2),1.e-4,fqs,'q0')
8980         vt2r = vt2r_a*den(i, k)**((bvtr-2.)/4.)*max1**(bvtr/4.)
8981         IF (qrs(i, k, 2) .LT. qcrmin) THEN
8982           max2 = qcrmin
8983         ELSE
8984           max2 = qrs(i, k, 2)
8985         END IF
8986         IF (90. .GT. t0c - t(i, k)) THEN
8987           y13 = t0c - t(i, k)
8988         ELSE
8989           y13 = 90.
8990         END IF
8991         IF (0. .LT. y13) THEN
8992           max24 = y13
8993         ELSE
8994           max24 = 0.
8995         END IF
8996         vt2s = vt2s_a*den(i, k)**((bvts-2.)/4.)*max2**(bvts/4.)*EXP(-(&
8997 &         alpha*bvts*max24/4.))
8998         IF (90. .GT. t0c - t(i, k)) THEN
8999           y1 = t0c - t(i, k)
9000         ELSE
9001           y1 = 90.
9002         END IF
9003         IF (0. .LT. y1) THEN
9004           max3 = y1
9005         ELSE
9006           max3 = 0.
9007         END IF
9008         a = EXP(alpha*max3)
9009         IF (90. .GT. t0c - t(i, k)) THEN
9010           y2 = t0c - t(i, k)
9011         ELSE
9012           y2 = 90.
9013         END IF
9014         IF (0. .LT. y2) THEN
9015           max4 = y2
9016         ELSE
9017           max4 = 0.
9018         END IF
9019         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9020           max25 = qcrmin
9021         ELSE
9022           max25 = qrs(i, k, 2)
9023         END IF
9024         IF (qrs(i, k, 1) .LT. qcrmin) THEN
9025           max39 = qcrmin
9026         ELSE
9027           max39 = qrs(i, k, 1)
9028         END IF
9029         b = EXP(-(3.*alpha*max4/2.))*den(i, k)**(3./4.)*max25**(3./2.)*&
9030 &         SQRT(SQRT(max39))
9031         IF (90. .GT. t0c - t(i, k)) THEN
9032           y3 = t0c - t(i, k)
9033         ELSE
9034           y3 = 90.
9035         END IF
9036         IF (0. .LT. y3) THEN
9037           max5 = y3
9038         ELSE
9039           max5 = 0.
9040         END IF
9041         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9042           max26 = qcrmin
9043         ELSE
9044           max26 = qrs(i, k, 2)
9045         END IF
9046         IF (qrs(i, k, 1) .LT. qcrmin) THEN
9047           max40 = qcrmin
9048         ELSE
9049           max40 = qrs(i, k, 1)
9050         END IF
9051         c = EXP(-(5.*alpha*max5/4.))*den(i, k)**(3./4.)*max26**(5./4.)*&
9052 &         SQRT(max40)
9053         IF (90. .GT. t0c - t(i, k)) THEN
9054           y4 = t0c - t(i, k)
9055         ELSE
9056           y4 = 90.
9057         END IF
9058         IF (0. .LT. y4) THEN
9059           max6 = y4
9060         ELSE
9061           max6 = 0.
9062         END IF
9063         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9064           max27 = qcrmin
9065         ELSE
9066           max27 = qrs(i, k, 2)
9067         END IF
9068         IF (qrs(i, k, 1) .LT. qcrmin) THEN
9069           max41 = qcrmin
9070         ELSE
9071           max41 = qrs(i, k, 1)
9072         END IF
9073         d = EXP(-(alpha*max6))*den(i, k)**(3./4.)*max27*max41**(3./4.)
9074         IF (vt2r - vt2s .GE. 0.) THEN
9075           abs0 = vt2r - vt2s
9076         ELSE
9077           abs0 = -(vt2r-vt2s)
9078         END IF
9079         pracs1 = pracs_a*a*abs0*(pracs_b*b+pracs_c*c+pracs_d*d)
9080         IF (pracs1 .GT. qrs(i, k, 2)/dtcld) THEN
9081           pracs(i, k) = qrs(i, k, 2)/dtcld
9082         ELSE
9083           pracs(i, k) = pracs1
9084         END IF
9085         pracs(i, k) = fsupcol*pracs(i, k)
9086         IF (pracs(i, k) .GE. 0.) THEN
9087           abs1 = pracs(i, k)
9088         ELSE
9089           abs1 = -pracs(i, k)
9090         END IF
9091         IF (abs1 .LT. qmin/dtcld) pracs(i, k) = 0.
9092         IF (qrs(i, k, 2) - pracs(i, k)*dtcld .LT. 0.) THEN
9093           qrs(i, k, 2) = 0.
9094         ELSE
9095           qrs(i, k, 2) = qrs(i, k, 2) - pracs(i, k)*dtcld
9096         END IF
9097         IF (qrs(i, k, 3) + pracs(i, k)*dtcld .LT. 0.) THEN
9098           qrs(i, k, 3) = 0.
9099         ELSE
9100           qrs(i, k, 3) = qrs(i, k, 3) + pracs(i, k)*dtcld
9101         END IF
9102         pracs(i, k) = 0.
9103 !-------------------------------------------------------------
9104 ! psacr: Accretion of rain by snow [LFO 28]
9105 !         (T< T0: R->S or R->G)                 min=0.,max=qrs(i,k,1)/dtcld
9106 !         (T>=T0: S->R enhance melting of snow) min=0.,max=qrs(i,k,2)/dtcld
9107 !-------------------------------------------------------------
9108 !         supcol = t0c-t(i,k) !not change
9109 !         call smoothif(supcol,0.,fsupcol,'t0')
9110 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
9111 !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0')
9112 !update cpm
9113         cpm(i, k) = CPMCAL(q(i, k))
9114         xl(i, k) = XLCAL(t(i, k))
9115         xlf = xls - xl(i, k)
9116         IF (supcol .LT. 0.) xlf = xlf0
9117         IF (qrs(i, k, 1) .LT. qcrmin) THEN
9118           max7 = qcrmin
9119         ELSE
9120           max7 = qrs(i, k, 1)
9121         END IF
9122         vt2r = vt2r_a*den(i, k)**((bvtr-2.)/4.)*max7**(bvtr/4.)
9123         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9124           max8 = qcrmin
9125         ELSE
9126           max8 = qrs(i, k, 2)
9127         END IF
9128         IF (90. .GT. t0c - t(i, k)) THEN
9129           y14 = t0c - t(i, k)
9130         ELSE
9131           y14 = 90.
9132         END IF
9133         IF (0. .LT. y14) THEN
9134           max28 = y14
9135         ELSE
9136           max28 = 0.
9137         END IF
9138         vt2s = vt2s_a*den(i, k)**((bvts-2.)/4.)*max8**(bvts/4.)*EXP(-(&
9139 &         alpha*bvts*max28/4.))
9140         IF (90. .GT. t0c - t(i, k)) THEN
9141           y5 = t0c - t(i, k)
9142         ELSE
9143           y5 = 90.
9144         END IF
9145         IF (0. .LT. y5) THEN
9146           max9 = y5
9147         ELSE
9148           max9 = 0.
9149         END IF
9150         a = EXP(alpha*max9)
9151         IF (90. .GT. t0c - t(i, k)) THEN
9152           y6 = t0c - t(i, k)
9153         ELSE
9154           y6 = 90.
9155         END IF
9156         IF (0. .LT. y6) THEN
9157           max10 = y6
9158         ELSE
9159           max10 = 0.
9160         END IF
9161         IF (qrs(i, k, 1) .LT. qcrmin) THEN
9162           max29 = qcrmin
9163         ELSE
9164           max29 = qrs(i, k, 1)
9165         END IF
9166         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9167           max42 = qcrmin
9168         ELSE
9169           max42 = qrs(i, k, 2)
9170         END IF
9171         b = EXP(-(alpha*max10/4.))*den(i, k)**(3./4.)*max29**(3./2.)*&
9172 &         SQRT(SQRT(max42))
9173         IF (90. .GT. t0c - t(i, k)) THEN
9174           y7 = t0c - t(i, k)
9175         ELSE
9176           y7 = 90.
9177         END IF
9178         IF (0. .LT. y7) THEN
9179           max11 = y7
9180         ELSE
9181           max11 = 0.
9182         END IF
9183         IF (qrs(i, k, 1) .LT. qcrmin) THEN
9184           max30 = qcrmin
9185         ELSE
9186           max30 = qrs(i, k, 1)
9187         END IF
9188         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9189           max43 = qcrmin
9190         ELSE
9191           max43 = qrs(i, k, 2)
9192         END IF
9193         c = EXP(-(alpha*max11/2.))*den(i, k)**(3./4.)*max30**(5./4.)*&
9194 &         SQRT(max43)
9195         IF (90. .GT. t0c - t(i, k)) THEN
9196           y8 = t0c - t(i, k)
9197         ELSE
9198           y8 = 90.
9199         END IF
9200         IF (0. .LT. y8) THEN
9201           max12 = y8
9202         ELSE
9203           max12 = 0.
9204         END IF
9205         IF (qrs(i, k, 1) .LT. qcrmin) THEN
9206           max31 = qcrmin
9207         ELSE
9208           max31 = qrs(i, k, 1)
9209         END IF
9210         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9211           max44 = qcrmin
9212         ELSE
9213           max44 = qrs(i, k, 2)
9214         END IF
9215         d = EXP(-(3.*alpha*max12/4.))*den(i, k)**(3./4.)*max31*max44**(&
9216 &         3./4.)
9217         IF (vt2r - vt2s .GE. 0.) THEN
9218           abs2 = vt2r - vt2s
9219         ELSE
9220           abs2 = -(vt2r-vt2s)
9221         END IF
9222         psacr1 = psacr_a*a*abs2*(psacr_b*b+psacr_c*c+psacr_d*d)
9223         IF (supcol .GT. 0.) THEN
9224           IF (psacr1 .GT. qrs(i, k, 1)/dtcld) THEN
9225             psacr(i, k) = qrs(i, k, 1)/dtcld
9226           ELSE
9227             psacr(i, k) = psacr1
9228           END IF
9229         ELSE IF (psacr1 .GT. qrs(i, k, 2)/dtcld) THEN
9230           psacr(i, k) = qrs(i, k, 2)/dtcld
9231         ELSE
9232           psacr(i, k) = psacr1
9233         END IF
9234         IF (psacr(i, k) .GE. 0.) THEN
9235           abs3 = psacr(i, k)
9236         ELSE
9237           abs3 = -psacr(i, k)
9238         END IF
9239 !psacr(i,k)=fqr*fqs*psacr(i,k)
9240         IF (abs3 .LT. qmin/dtcld) psacr(i, k) = 0.
9241 !update qr qs qg
9242         IF (qrs(i, k, 1) .LT. 1.e-4 .AND. qrs(i, k, 2) .LT. 1.e-4) THEN
9243           delta2 = 1.
9244         ELSE
9245           delta2 = 0.
9246         END IF
9247         IF (qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld .LT. 0.) THEN
9248           qrs(i, k, 1) = 0.
9249         ELSE
9250           qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld
9251         END IF
9252         x1 = qrs(i, k, 2) + fsupcol*delta2*psacr(i, k)*dtcld
9253         IF (x1 .LT. 0.) THEN
9254           qrs(i, k, 2) = 0.
9255         ELSE
9256           qrs(i, k, 2) = x1
9257         END IF
9258         x2 = qrs(i, k, 3) + fsupcol*(1-delta2)*psacr(i, k)*dtcld
9259         IF (x2 .LT. 0.) THEN
9260           qrs(i, k, 3) = 0.
9261         ELSE
9262           qrs(i, k, 3) = x2
9263         END IF
9264         t(i, k) = t(i, k) + fsupcol*psacr(i, k)*dtcld*xlf/cpm(i, k)
9265 ! t>=t0 pseml
9266         psacr(i, k) = (1-fsupcol)*psacr(i, k)
9267 !-------------------------------------------------------------
9268 ! pgacr: Accretion of rain by graupel [LFO 42]
9269 !         (T< T0: R->G)                            min=0.,max=qrs(i,k,1)/dtcld
9270 !         (T>=T0: G->R enhance melting of graupel) min=0.,max=qrs(i,k,3)/dtcld
9271 !-------------------------------------------------------------
9272         supcol = t0c - t(i, k)
9273         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
9274 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
9275 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
9276 !update cpm
9277 !         cpm(i,k)=cpmcal(q(i,k)) !not change
9278         xl(i, k) = XLCAL(t(i, k))
9279         xlf = xls - xl(i, k)
9280         IF (supcol .LT. 0.) xlf = xlf0
9281         IF (qrs(i, k, 1) .LT. qcrmin) THEN
9282           max13 = qcrmin
9283         ELSE
9284           max13 = qrs(i, k, 1)
9285         END IF
9286         vt2r = vt2r_a*den(i, k)**((bvtr-2.)/4.)*max13**(bvtr/4.)
9287         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9288           max14 = qcrmin
9289         ELSE
9290           max14 = qrs(i, k, 3)
9291         END IF
9292         vt2g = vt2g_a*den(i, k)**((bvtg-2.)/4.)*max14**(bvtg/4.)
9293         IF (qrs(i, k, 1) .LT. qcrmin) THEN
9294           max15 = qcrmin
9295         ELSE
9296           max15 = qrs(i, k, 1)
9297         END IF
9298         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9299           max32 = qcrmin
9300         ELSE
9301           max32 = qrs(i, k, 3)
9302         END IF
9303         b = den(i, k)**(3./4.)*max15**(3./2.)*SQRT(SQRT(max32))
9304         IF (qrs(i, k, 1) .LT. qcrmin) THEN
9305           max16 = qcrmin
9306         ELSE
9307           max16 = qrs(i, k, 1)
9308         END IF
9309         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9310           max33 = qcrmin
9311         ELSE
9312           max33 = qrs(i, k, 3)
9313         END IF
9314         c = den(i, k)**(3./4.)*max16**(5./4.)*SQRT(max33)
9315         IF (qrs(i, k, 1) .LT. qcrmin) THEN
9316           max17 = qcrmin
9317         ELSE
9318           max17 = qrs(i, k, 1)
9319         END IF
9320         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9321           max34 = qcrmin
9322         ELSE
9323           max34 = qrs(i, k, 3)
9324         END IF
9325         d = den(i, k)**(3./4.)*max17*max34**(3./4.)
9326         IF (vt2r - vt2g .GE. 0.) THEN
9327           abs4 = vt2r - vt2g
9328         ELSE
9329           abs4 = -(vt2r-vt2g)
9330         END IF
9331         pgacr1 = pgacr_a*abs4*(pgacr_b*b+pgacr_c*c+pgacr_d*d)
9332         IF (supcol .GT. 0.) THEN
9333           IF (pgacr1 .GT. qrs(i, k, 1)/dtcld) THEN
9334             pgacr(i, k) = qrs(i, k, 1)/dtcld
9335           ELSE
9336             pgacr(i, k) = pgacr1
9337           END IF
9338         ELSE IF (pgacr1 .GT. qrs(i, k, 3)/dtcld) THEN
9339           pgacr(i, k) = qrs(i, k, 3)/dtcld
9340         ELSE
9341           pgacr(i, k) = pgacr1
9342         END IF
9343         IF (pgacr(i, k) .GE. 0.) THEN
9344           abs5 = pgacr(i, k)
9345         ELSE
9346           abs5 = -pgacr(i, k)
9347         END IF
9348 !pgacr(i,k)=fqg*fqr*pgacr(i,k)
9349         IF (abs5 .LT. qmin/dtcld) pgacr(i, k) = 0.
9350         IF (qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld .LT. 0.) THEN
9351           qrs(i, k, 1) = 0.
9352         ELSE
9353           qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld
9354         END IF
9355         x3 = qrs(i, k, 3) + fsupcol*pgacr(i, k)*dtcld
9356         IF (x3 .LT. 0.) THEN
9357           qrs(i, k, 3) = 0.
9358         ELSE
9359           qrs(i, k, 3) = x3
9360         END IF
9361         t(i, k) = t(i, k) + fsupcol*pgacr(i, k)*dtcld*xlf/cpm(i, k)
9362 ! t>=t0 pgeml
9363         pgacr(i, k) = (1-fsupcol)*pgacr(i, k)
9364 !-------------------------------------------------------------
9365 ! pgacs: Accretion of snow by graupel [LFO 29]
9366 !        (S->G) min=0,max=qrs(i,k,2)/dtcld
9367 !-------------------------------------------------------------
9368         supcol = t0c - t(i, k)
9369         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
9370         x4 = EXP(-(0.09*supcol))
9371         IF (x4 .GT. 1.) THEN
9372           egs = 1.
9373         ELSE
9374           egs = x4
9375         END IF
9376         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9377           max18 = qcrmin
9378         ELSE
9379           max18 = qrs(i, k, 3)
9380         END IF
9381         vt2g = vt2g_a*den(i, k)**((bvtg-2.)/4.)*max18**(bvtg/4.)
9382         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9383           max19 = qcrmin
9384         ELSE
9385           max19 = qrs(i, k, 2)
9386         END IF
9387         IF (90. .GT. t0c - t(i, k)) THEN
9388           y15 = t0c - t(i, k)
9389         ELSE
9390           y15 = 90.
9391         END IF
9392         IF (0. .LT. y15) THEN
9393           max35 = y15
9394         ELSE
9395           max35 = 0.
9396         END IF
9397         vt2s = vt2s_a*den(i, k)**((bvts-2.)/4.)*max19**(bvts/4.)*EXP(-(&
9398 &         alpha*bvts*max35/4.))
9399         IF (90. .GT. t0c - t(i, k)) THEN
9400           y9 = t0c - t(i, k)
9401         ELSE
9402           y9 = 90.
9403         END IF
9404         IF (0. .LT. y9) THEN
9405           max20 = y9
9406         ELSE
9407           max20 = 0.
9408         END IF
9409         a = EXP(alpha*max20)
9410         IF (90. .GT. t0c - t(i, k)) THEN
9411           y10 = t0c - t(i, k)
9412         ELSE
9413           y10 = 90.
9414         END IF
9415         IF (0. .LT. y10) THEN
9416           max21 = y10
9417         ELSE
9418           max21 = 0.
9419         END IF
9420         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9421           max36 = qcrmin
9422         ELSE
9423           max36 = qrs(i, k, 2)
9424         END IF
9425         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9426           max45 = qcrmin
9427         ELSE
9428           max45 = qrs(i, k, 3)
9429         END IF
9430         b = EXP(-(3.*alpha*max21/2.))*den(i, k)**(3./4.)*max36**(3./2.)*&
9431 &         SQRT(SQRT(max45))
9432         IF (90. .GT. t0c - t(i, k)) THEN
9433           y11 = t0c - t(i, k)
9434         ELSE
9435           y11 = 90.
9436         END IF
9437         IF (0. .LT. y11) THEN
9438           max22 = y11
9439         ELSE
9440           max22 = 0.
9441         END IF
9442         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9443           max37 = qcrmin
9444         ELSE
9445           max37 = qrs(i, k, 2)
9446         END IF
9447         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9448           max46 = qcrmin
9449         ELSE
9450           max46 = qrs(i, k, 3)
9451         END IF
9452         c = EXP(-(5.*alpha*max22/4.))*den(i, k)**(3./4.)*max37**(5./4.)*&
9453 &         SQRT(max46)
9454         IF (90. .GT. t0c - t(i, k)) THEN
9455           y12 = t0c - t(i, k)
9456         ELSE
9457           y12 = 90.
9458         END IF
9459         IF (0. .LT. y12) THEN
9460           max23 = y12
9461         ELSE
9462           max23 = 0.
9463         END IF
9464         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9465           max38 = qcrmin
9466         ELSE
9467           max38 = qrs(i, k, 2)
9468         END IF
9469         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9470           max47 = qcrmin
9471         ELSE
9472           max47 = qrs(i, k, 3)
9473         END IF
9474         d = EXP(-(alpha*max23))*den(i, k)**(3./4.)*max38*max47**(3./4.)
9475         IF (vt2g - vt2s .GE. 0.) THEN
9476           abs6 = vt2g - vt2s
9477         ELSE
9478           abs6 = -(vt2g-vt2s)
9479         END IF
9480         pgacs1 = pgacs_a*a*abs6*(pgacs_b*b+pgacs_c*c+pgacs_d*d)*egs
9481         IF (pgacs1 .GT. qrs(i, k, 2)/dtcld) THEN
9482           pgacs(i, k) = qrs(i, k, 2)/dtcld
9483         ELSE
9484           pgacs(i, k) = pgacs1
9485         END IF
9486         IF (pgacs(i, k) .GE. 0.) THEN
9487           abs7 = pgacs(i, k)
9488         ELSE
9489           abs7 = -pgacs(i, k)
9490         END IF
9491 !pgacs(i,k)=fqg*fqs*pgacs(i,k)
9492         IF (abs7 .LT. qmin/dtcld) pgacs(i, k) = 0.
9493         IF (qrs(i, k, 2) - pgacs(i, k)*dtcld .LT. 0.) THEN
9494           qrs(i, k, 2) = 0.
9495         ELSE
9496           qrs(i, k, 2) = qrs(i, k, 2) - pgacs(i, k)*dtcld
9497         END IF
9498         IF (qrs(i, k, 3) + pgacs(i, k)*dtcld .LT. 0.) THEN
9499           qrs(i, k, 3) = 0.
9500         ELSE
9501           qrs(i, k, 3) = qrs(i, k, 3) + pgacs(i, k)*dtcld
9502         END IF
9503         pgacs(i, k) = 0.
9504 !-------------------------------------------------------------
9505 ! pseml: Enhanced melting of snow by accretion of water
9506 !        (T>=T0: S->R) pseml<0 max=0,min=-qrs(i,k,2)/dtcld
9507 !-------------------------------------------------------------
9508 !         supcol = t0c-t(i,k) ! not change
9509 !update cpm
9510 !         cpm(i,k)=cpmcal(q(i,k)) ! not change
9511         xl(i, k) = XLCAL(t(i, k))
9512         xlf = xls - xl(i, k)
9513         IF (supcol .LT. 0.) xlf = xlf0
9514         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
9515         CALL SMOOTHIF(qrs(i, k, 2), 0., fqs, 'q+')
9516         x7 = cliq*supcol*(psacw(i, k)+psacr(i, k))/xlf
9517         IF (x7 .LT. -(qrs(i, k, 2)/dtcld)) THEN
9518           x5 = -(qrs(i, k, 2)/dtcld)
9519         ELSE
9520           x5 = x7
9521         END IF
9522         IF (x5 .GT. 0.) THEN
9523           pseml(i, k) = 0.
9524         ELSE
9525           pseml(i, k) = x5
9526         END IF
9527         pseml(i, k) = ft0*fqs*pseml(i, k)
9528         IF (pseml(i, k) .GE. 0.) THEN
9529           abs8 = pseml(i, k)
9530         ELSE
9531           abs8 = -pseml(i, k)
9532         END IF
9533         IF (abs8 .LT. qmin/dtcld) pseml(i, k) = 0.
9534         IF (qrs(i, k, 1) - pseml(i, k)*dtcld .LT. 0.) THEN
9535           qrs(i, k, 1) = 0.
9536         ELSE
9537           qrs(i, k, 1) = qrs(i, k, 1) - pseml(i, k)*dtcld
9538         END IF
9539         IF (qrs(i, k, 2) + pseml(i, k)*dtcld .LT. 0.) THEN
9540           qrs(i, k, 2) = 0.
9541         ELSE
9542           qrs(i, k, 2) = qrs(i, k, 2) + pseml(i, k)*dtcld
9543         END IF
9544         t(i, k) = t(i, k) + pseml(i, k)*dtcld*xlf/cpm(i, k)
9545         pseml(i, k) = 0.
9546         psacw(i, k) = 0.
9547         psacr(i, k) = 0.
9548 !-------------------------------------------------------------
9549 ! pgeml: Enhanced melting of graupel by accretion of water [RH84 A21-A22]
9550 !        (T>=T0: G->R) pgeml<0 max=0,min=-qrs(i,k,3)/dtcld
9551 !-------------------------------------------------------------
9552         supcol = t0c - t(i, k)
9553 !update cpm
9554 !         cpm(i,k)=cpmcal(q(i,k)) ! not change
9555         xl(i, k) = XLCAL(t(i, k))
9556         xlf = xls - xl(i, k)
9557         IF (supcol .LT. 0.) xlf = xlf0
9558         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
9559         CALL SMOOTHIF(qrs(i, k, 3), 0., fqg, 'q+')
9560         x8 = cliq*supcol*(pgacw(i, k)+pgacr(i, k))/xlf
9561         IF (x8 .LT. -(qrs(i, k, 3)/dtcld)) THEN
9562           x6 = -(qrs(i, k, 3)/dtcld)
9563         ELSE
9564           x6 = x8
9565         END IF
9566         IF (x6 .GT. 0.) THEN
9567           pgeml(i, k) = 0.
9568         ELSE
9569           pgeml(i, k) = x6
9570         END IF
9571         pgeml(i, k) = ft0*fqg*pgeml(i, k)
9572         IF (pgeml(i, k) .GE. 0.) THEN
9573           abs9 = pgeml(i, k)
9574         ELSE
9575           abs9 = -pgeml(i, k)
9576         END IF
9577         IF (abs9 .LT. qmin/dtcld) pgeml(i, k) = 0.
9578         IF (qrs(i, k, 1) - pgeml(i, k)*dtcld .LT. 0.) THEN
9579           qrs(i, k, 1) = 0.
9580         ELSE
9581           qrs(i, k, 1) = qrs(i, k, 1) - pgeml(i, k)*dtcld
9582         END IF
9583         IF (qrs(i, k, 3) + pgeml(i, k)*dtcld .LT. 0.) THEN
9584           qrs(i, k, 3) = 0.
9585         ELSE
9586           qrs(i, k, 3) = qrs(i, k, 3) + pgeml(i, k)*dtcld
9587         END IF
9588         t(i, k) = t(i, k) + pgeml(i, k)*dtcld*xlf/cpm(i, k)
9589         pgeml(i, k) = 0.
9590         pgacw(i, k) = 0.
9591         pgacr(i, k) = 0.
9592       END DO
9593     END DO
9594   END SUBROUTINE ACCRET2
9595
9596 !  Differentiation of accret3 in reverse (adjoint) mode (with options r8):
9597 !   gradient     of useful results: p q t qs pigen rh den qrs psevp
9598 !                pidep pgevp psdep qci pgdep psaut pgaut
9599 !   with respect to varying inputs: p q t qs pigen rh den qrs psevp
9600 !                pidep pgevp psdep qci pgdep psaut pgaut
9601 !=======================================================================
9602 !
9603 !=======================================================================
9604   SUBROUTINE A_ACCRET3(qrs, a_qrs, qci, a_qci, rh, a_rh, t, a_t, p, a_p&
9605 &   , den, a_den, dtcld, q, a_q, qs, a_qs, psdep, a_psdep, pgdep, &
9606 &   a_pgdep, pigen, a_pigen, psaut, a_psaut, pgaut, a_pgaut, psevp, &
9607 &   a_psevp, pgevp, a_pgevp, pidep, a_pidep, ims, ime, kms, kme, its, &
9608 &   ite, kts, kte)
9609     IMPLICIT NONE
9610     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
9611 !-------------------------------------------------------------------
9612     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
9613     REAL, DIMENSION(its:ite, kts:kte, 2) :: a_qci
9614     REAL, DIMENSION(ims:ime, kms:kme) :: den, q, p
9615     REAL, DIMENSION(ims:ime, kms:kme) :: a_den, a_q, a_p
9616     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, rh, qs
9617     REAL, DIMENSION(its:ite, kts:kte, 3) :: a_qrs, a_rh, a_qs
9618     REAL, DIMENSION(its:ite, kts:kte) :: pigen, psevp, pgevp, pidep, t, &
9619 &   xl, cpm, psdep, pgdep, psaut, pgaut
9620     REAL, DIMENSION(its:ite, kts:kte) :: a_pigen, a_psevp, a_pgevp, &
9621 &   a_pidep, a_t, a_xl, a_cpm, a_psdep, a_pgdep, a_psaut, a_pgaut
9622     REAL :: supcol, dtcld, satdt, supsat, qimax, diameter, xni0, roqi0, &
9623 &   supice1, supice2, supice3, supice4, alpha2
9624     REAL :: a_supcol, a_satdt, a_supsat, a_qimax, a_xni0, a_roqi0, &
9625 &   a_alpha2
9626     REAL :: pidep0, pidep1, psdep0, pgdep3, pigen0, psevp0, pgevp0, &
9627 &   coeres1, coeres2, coeres3, coeres4
9628     REAL :: a_pidep0, a_psdep0, a_pgdep3, a_pigen0, a_psevp0, a_pgevp0
9629     REAL :: temp0, temp, xmi
9630     INTEGER :: i, k
9631     REAL :: fqi, fqr, fqv, fqs, fqg, frh, ft0, fpidep, fpsdep, fpgdep, &
9632 &   fsupcol, fsupsat, pidep2
9633     REAL :: a_ft0, a_fsupcol, a_fsupsat
9634     REAL :: value01, factor01, source01, vice, a, b, c, d, e, f, g
9635     REAL :: a_a, a_b, a_c, a_d, a_e
9636     INTRINSIC MAX
9637     INTRINSIC MIN
9638     INTRINSIC ABS
9639     INTRINSIC EXP
9640     INTRINSIC SQRT
9641     REAL :: x1
9642     REAL :: a_x1
9643     REAL :: x2
9644     REAL :: a_x2
9645     REAL :: y1
9646     REAL :: a_y1
9647     REAL :: y2
9648     REAL :: a_y2
9649     REAL :: x3
9650     REAL :: a_x3
9651     REAL :: x4
9652     REAL :: a_x4
9653     REAL :: x5
9654     REAL :: a_x5
9655     REAL :: x6
9656     REAL :: a_x6
9657     REAL :: x7
9658     REAL :: a_x7
9659     REAL :: x8
9660     REAL :: a_x8
9661     REAL :: y3
9662     REAL :: a_y3
9663     REAL :: y4
9664     REAL :: a_y4
9665     REAL :: x9
9666     REAL :: a_x9
9667     REAL :: x10
9668     REAL :: a_x10
9669     REAL :: abs0
9670     REAL :: max1
9671     REAL :: a_max1
9672     REAL :: max2
9673     REAL :: a_max2
9674     REAL :: abs1
9675     REAL :: max3
9676     REAL :: a_max3
9677     REAL :: max4
9678     REAL :: a_max4
9679     REAL :: abs2
9680     REAL :: abs3
9681     REAL :: abs4
9682     REAL :: abs5
9683     REAL :: max5
9684     REAL :: a_max5
9685     REAL :: max6
9686     REAL :: a_max6
9687     REAL :: abs6
9688     REAL :: max7
9689     REAL :: a_max7
9690     REAL :: max8
9691     REAL :: a_max8
9692     REAL :: abs7
9693     REAL :: max9
9694     REAL :: a_max9
9695     REAL :: max10
9696     REAL :: a_max10
9697     REAL :: max11
9698     REAL :: a_max11
9699     REAL :: max12
9700     REAL :: a_max12
9701     REAL :: max13
9702     REAL :: a_max13
9703     REAL :: temp1
9704     REAL :: temp2
9705     REAL :: a_temp
9706     REAL :: temp3
9707     REAL :: a_temp0
9708     REAL :: a_temp1
9709     REAL :: temp4
9710     REAL :: temp5
9711     REAL :: temp6
9712     REAL :: temp7
9713     REAL :: temp8
9714     REAL :: temp9
9715     REAL :: temp10
9716     REAL :: a_temp2
9717     REAL :: temp11
9718     REAL :: temp12
9719     REAL :: temp13
9720     REAL :: temp14
9721     REAL :: temp15
9722     REAL :: a_temp3
9723     REAL :: a_temp4
9724     REAL :: a_temp5
9725     REAL :: a_temp6
9726     REAL :: a_temp7
9727     REAL :: a_temp8
9728     REAL :: a_temp9
9729     INTEGER :: branch
9730     DO k=kts,kte
9731       DO i=its,ite
9732 !
9733 !-------------------------------------------------------------
9734 ! pidep: Deposition/Sublimation rate of ice [HDC 9]
9735 !       (T<T0: V->I or I->V)
9736 !       rh(i,k,2)>1.,pidep>0: V->I, min=0,        max=satdt
9737 !       rh(i,k,2)<1.,pidep<0: I->V, min=-qi/dtcld,max=0,
9738 !-------------------------------------------------------------
9739 !update supcol
9740         CALL PUSHREAL8(supcol)
9741         supcol = t0c - t(i, k)
9742 !update rh qs
9743         CALL PUSHREAL8ARRAY(qs(i, k, :), 3)
9744         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
9745 !update satdt
9746         CALL PUSHREAL8(supsat)
9747         supsat = q(i, k) - qs(i, k, 2)
9748         satdt = supsat/dtcld
9749 !update xl, cpm
9750         cpm(i, k) = CPMCAL(q(i, k))
9751         CALL PUSHREAL8(fsupcol)
9752         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
9753         IF (qci(i, k, 2) .GT. 0.) THEN
9754           CALL PUSHREAL8(b)
9755           b = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5
9756           CALL PUSHREAL8(c)
9757           c = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2)
9758           CALL PUSHREAL8(a)
9759           a = (rh(i, k, 2)-1.)/(b+c)
9760           pidep0 = pidep_a*a*(den(i, k)*qci(i, k, 2))**(7./8.)
9761           CALL PUSHCONTROL1B(0)
9762         ELSE
9763           CALL PUSHCONTROL1B(1)
9764           pidep0 = 0.
9765         END IF
9766         IF (pidep0 .LT. 0.) THEN
9767           IF (pidep0 .LT. -(qci(i, k, 2)/dtcld)) THEN
9768             x1 = -(qci(i, k, 2)/dtcld)
9769             CALL PUSHCONTROL1B(0)
9770           ELSE
9771             x1 = pidep0
9772             CALL PUSHCONTROL1B(1)
9773           END IF
9774           IF (x1 .GT. 0.) THEN
9775             pidep(i, k) = 0.
9776             CALL PUSHCONTROL2B(1)
9777           ELSE
9778             pidep(i, k) = x1
9779             CALL PUSHCONTROL2B(0)
9780           END IF
9781         ELSE
9782           IF (pidep0 .GT. satdt) THEN
9783             x2 = satdt
9784             CALL PUSHCONTROL1B(0)
9785           ELSE
9786             x2 = pidep0
9787             CALL PUSHCONTROL1B(1)
9788           END IF
9789           IF (x2 .LT. 0.) THEN
9790             pidep(i, k) = 0.
9791             CALL PUSHCONTROL2B(3)
9792           ELSE
9793             pidep(i, k) = x2
9794             CALL PUSHCONTROL2B(2)
9795           END IF
9796         END IF
9797         CALL PUSHREAL8(pidep(i, k))
9798         pidep(i, k) = fsupcol*pidep(i, k)
9799         IF (pidep(i, k) .GE. 0.) THEN
9800           abs0 = pidep(i, k)
9801         ELSE
9802           abs0 = -pidep(i, k)
9803         END IF
9804         IF (abs0 .LT. qmin/dtcld) THEN
9805           pidep(i, k) = 0.
9806           CALL PUSHCONTROL1B(1)
9807         ELSE
9808           CALL PUSHCONTROL1B(0)
9809         END IF
9810         IF (q(i, k) - pidep(i, k)*dtcld .LT. 0.) THEN
9811           CALL PUSHREAL8(q(i, k))
9812           q(i, k) = 0.
9813           CALL PUSHCONTROL1B(0)
9814         ELSE
9815           CALL PUSHREAL8(q(i, k))
9816           q(i, k) = q(i, k) - pidep(i, k)*dtcld
9817           CALL PUSHCONTROL1B(1)
9818         END IF
9819         IF (qci(i, k, 2) + pidep(i, k)*dtcld .LT. 0.) THEN
9820           CALL PUSHREAL8(qci(i, k, 2))
9821           qci(i, k, 2) = 0.
9822           CALL PUSHCONTROL1B(0)
9823         ELSE
9824           CALL PUSHREAL8(qci(i, k, 2))
9825           qci(i, k, 2) = qci(i, k, 2) + pidep(i, k)*dtcld
9826           CALL PUSHCONTROL1B(1)
9827         END IF
9828         CALL PUSHREAL8(t(i, k))
9829         t(i, k) = t(i, k) + pidep(i, k)*dtcld*xls/cpm(i, k)
9830 !
9831 !-------------------------------------------------------------
9832 ! psdep: deposition/sublimation rate of snow [HDC 14]
9833 !        (T<T0: V->S or S->V)
9834 !       rh(i,k,2)>1.,psdep>0: V->S, min=0,        max=satdt
9835 !       rh(i,k,2)<1.,psdep<0: S->V, min=-qs/dtcld,max=0,
9836 !-------------------------------------------------------------
9837 !update supcol
9838         CALL PUSHREAL8(supcol)
9839         supcol = t0c - t(i, k)
9840 !update rh qs
9841         CALL PUSHREAL8ARRAY(qs(i, k, :), 3)
9842         CALL PUSHREAL8ARRAY(rh(i, k, :), 3)
9843         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
9844 !update satdt
9845         supsat = q(i, k) - qs(i, k, 2)
9846         satdt = supsat/dtcld
9847 !update xl, cpm
9848         CALL PUSHREAL8(cpm(i, k))
9849         cpm(i, k) = CPMCAL(q(i, k))
9850         CALL PUSHREAL8(fsupcol)
9851         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
9852         IF (90. .GT. t0c - t(i, k)) THEN
9853           y1 = t0c - t(i, k)
9854           CALL PUSHCONTROL1B(0)
9855         ELSE
9856           CALL PUSHCONTROL1B(1)
9857           y1 = 90.
9858         END IF
9859         IF (0. .LT. y1) THEN
9860           CALL PUSHREAL8(max1)
9861           max1 = y1
9862           CALL PUSHCONTROL1B(1)
9863         ELSE
9864           CALL PUSHREAL8(max1)
9865           max1 = 0.
9866           CALL PUSHCONTROL1B(0)
9867         END IF
9868         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9869           CALL PUSHREAL8(max9)
9870           max9 = qcrmin
9871           CALL PUSHCONTROL1B(0)
9872         ELSE
9873           CALL PUSHREAL8(max9)
9874           max9 = qrs(i, k, 2)
9875           CALL PUSHCONTROL1B(1)
9876         END IF
9877 !         call smoothif(qrs(i,k,2),0.,fqs,'q+')
9878 !         call smoothif(q  (i,k  ),0.,fqv,'q+')
9879         CALL PUSHREAL8(a)
9880         a = EXP(alpha*max1/2.)*SQRT(den(i, k)*max9)
9881         IF (90. .GT. t0c - t(i, k)) THEN
9882           y2 = t0c - t(i, k)
9883           CALL PUSHCONTROL1B(0)
9884         ELSE
9885           CALL PUSHCONTROL1B(1)
9886           y2 = 90.
9887         END IF
9888         IF (0. .LT. y2) THEN
9889           CALL PUSHREAL8(max2)
9890           max2 = y2
9891           CALL PUSHCONTROL1B(1)
9892         ELSE
9893           CALL PUSHREAL8(max2)
9894           max2 = 0.
9895           CALL PUSHCONTROL1B(0)
9896         END IF
9897         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9898           CALL PUSHREAL8(max10)
9899           max10 = qcrmin
9900           CALL PUSHCONTROL1B(0)
9901         ELSE
9902           CALL PUSHREAL8(max10)
9903           max10 = qrs(i, k, 2)
9904           CALL PUSHCONTROL1B(1)
9905         END IF
9906         CALL PUSHREAL8(b)
9907         b = EXP((3.-bvts)*alpha*max2/8.)*(t(i, k)+120.)**(1./6.)/t(i, k)&
9908 &         **(5.12/6.)*p(i, k)**(1./3.)*den(i, k)**((13.+3.*bvts)/24.)*&
9909 &         max10**((5.+bvts)/8.)
9910         CALL PUSHREAL8(c)
9911         c = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5
9912         CALL PUSHREAL8(d)
9913         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2)
9914         CALL PUSHREAL8(e)
9915         e = (rh(i, k, 2)-1.)/(c+d)
9916         psdep0 = e*(psdep_a*a+psdep_b*b)
9917         IF (psdep0 .LT. 0.) THEN
9918           IF (psdep0 .LT. -(qrs(i, k, 2)/dtcld)) THEN
9919             x3 = -(qrs(i, k, 2)/dtcld)
9920             CALL PUSHCONTROL1B(0)
9921           ELSE
9922             x3 = psdep0
9923             CALL PUSHCONTROL1B(1)
9924           END IF
9925           IF (x3 .GT. 0.) THEN
9926             psdep(i, k) = 0.
9927             CALL PUSHCONTROL2B(1)
9928           ELSE
9929             psdep(i, k) = x3
9930             CALL PUSHCONTROL2B(0)
9931           END IF
9932         ELSE
9933           IF (psdep0 .GT. satdt) THEN
9934             x4 = satdt
9935             CALL PUSHCONTROL1B(0)
9936           ELSE
9937             x4 = psdep0
9938             CALL PUSHCONTROL1B(1)
9939           END IF
9940           IF (x4 .LT. 0.) THEN
9941             psdep(i, k) = 0.
9942             CALL PUSHCONTROL2B(3)
9943           ELSE
9944             psdep(i, k) = x4
9945             CALL PUSHCONTROL2B(2)
9946           END IF
9947         END IF
9948         CALL PUSHREAL8(psdep(i, k))
9949         psdep(i, k) = fsupcol*psdep(i, k)
9950         IF (psdep(i, k) .GE. 0.) THEN
9951           abs1 = psdep(i, k)
9952         ELSE
9953           abs1 = -psdep(i, k)
9954         END IF
9955         IF (abs1 .LT. qmin/dtcld) THEN
9956           psdep(i, k) = 0.
9957           CALL PUSHCONTROL1B(1)
9958         ELSE
9959           CALL PUSHCONTROL1B(0)
9960         END IF
9961         IF (q(i, k) - psdep(i, k)*dtcld .LT. 0.) THEN
9962           CALL PUSHREAL8(q(i, k))
9963           q(i, k) = 0.
9964           CALL PUSHCONTROL1B(0)
9965         ELSE
9966           CALL PUSHREAL8(q(i, k))
9967           q(i, k) = q(i, k) - psdep(i, k)*dtcld
9968           CALL PUSHCONTROL1B(1)
9969         END IF
9970         IF (qrs(i, k, 2) + psdep(i, k)*dtcld .LT. 0.) THEN
9971           qrs(i, k, 2) = 0.
9972           CALL PUSHCONTROL1B(0)
9973         ELSE
9974           qrs(i, k, 2) = qrs(i, k, 2) + psdep(i, k)*dtcld
9975           CALL PUSHCONTROL1B(1)
9976         END IF
9977         CALL PUSHREAL8(t(i, k))
9978         t(i, k) = t(i, k) + psdep(i, k)*dtcld*xls/cpm(i, k)
9979 !
9980 !------------------------------------------------------------
9981 ! pgdep: deposition/sublimation rate of graupel [LFO 46]
9982 !        (T<T0: V->G or G->V)
9983 !       rh(i,k,2)>1.,pgdep>0: V->G, min=0,        max=satdt
9984 !       rh(i,k,2)<1.,pgdep<0: G->V, min=-qg/dtcld,max=0,
9985 !------------------------------------------------------------
9986 !update supcol
9987         CALL PUSHREAL8(supcol)
9988         supcol = t0c - t(i, k)
9989 !update rh qs
9990         CALL PUSHREAL8ARRAY(qs(i, k, :), 3)
9991         CALL PUSHREAL8ARRAY(rh(i, k, :), 3)
9992         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
9993 !update satdt
9994         supsat = q(i, k) - qs(i, k, 2)
9995         satdt = supsat/dtcld
9996 !update xl, cpm
9997         CALL PUSHREAL8(cpm(i, k))
9998         cpm(i, k) = CPMCAL(q(i, k))
9999         CALL PUSHREAL8(fsupcol)
10000         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
10001         IF (qrs(i, k, 3) .LT. qcrmin) THEN
10002           CALL PUSHREAL8(max3)
10003           max3 = qcrmin
10004           CALL PUSHCONTROL1B(0)
10005         ELSE
10006           CALL PUSHREAL8(max3)
10007           max3 = qrs(i, k, 3)
10008           CALL PUSHCONTROL1B(1)
10009         END IF
10010 !         call smoothif(qrs(i,k,3),0.,fqg,'q+')
10011 !         call smoothif(q  (i,k  ),0.,fqv,'q+')
10012         CALL PUSHREAL8(a)
10013         a = SQRT(den(i, k)*max3)
10014         IF (qrs(i, k, 3) .LT. qcrmin) THEN
10015           CALL PUSHREAL8(max4)
10016           max4 = qcrmin
10017           CALL PUSHCONTROL1B(0)
10018         ELSE
10019           CALL PUSHREAL8(max4)
10020           max4 = qrs(i, k, 3)
10021           CALL PUSHCONTROL1B(1)
10022         END IF
10023         CALL PUSHREAL8(b)
10024         b = (t(i, k)+120.)**(1./6.)/t(i, k)**(5.12/6.)*p(i, k)**(1./3.)*&
10025 &         den(i, k)**((13.+3.*bvtg)/24.)*max4**((5.+bvtg)/8.)
10026         CALL PUSHREAL8(c)
10027         c = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5
10028         CALL PUSHREAL8(d)
10029         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2)
10030         CALL PUSHREAL8(e)
10031         e = (rh(i, k, 2)-1.)/(c+d)
10032         pgdep3 = e*(pgdep_a*a+pgdep_b*b)
10033         IF (pgdep3 .LT. 0.) THEN
10034           IF (pgdep3 .LT. -(qrs(i, k, 3)/dtcld)) THEN
10035             x5 = -(qrs(i, k, 3)/dtcld)
10036             CALL PUSHCONTROL1B(0)
10037           ELSE
10038             x5 = pgdep3
10039             CALL PUSHCONTROL1B(1)
10040           END IF
10041           IF (x5 .GT. 0.) THEN
10042             pgdep(i, k) = 0.
10043             CALL PUSHCONTROL2B(1)
10044           ELSE
10045             pgdep(i, k) = x5
10046             CALL PUSHCONTROL2B(0)
10047           END IF
10048         ELSE
10049           IF (pgdep3 .GT. satdt) THEN
10050             x6 = satdt
10051             CALL PUSHCONTROL1B(0)
10052           ELSE
10053             x6 = pgdep3
10054             CALL PUSHCONTROL1B(1)
10055           END IF
10056           IF (x6 .LT. 0.) THEN
10057             pgdep(i, k) = 0.
10058             CALL PUSHCONTROL2B(3)
10059           ELSE
10060             pgdep(i, k) = x6
10061             CALL PUSHCONTROL2B(2)
10062           END IF
10063         END IF
10064         CALL PUSHREAL8(pgdep(i, k))
10065         pgdep(i, k) = fsupcol*pgdep(i, k)
10066         IF (pgdep(i, k) .GE. 0.) THEN
10067           abs2 = pgdep(i, k)
10068         ELSE
10069           abs2 = -pgdep(i, k)
10070         END IF
10071         IF (abs2 .LT. qmin/dtcld) THEN
10072           pgdep(i, k) = 0.
10073           CALL PUSHCONTROL1B(1)
10074         ELSE
10075           CALL PUSHCONTROL1B(0)
10076         END IF
10077         IF (q(i, k) - pgdep(i, k)*dtcld .LT. 0.) THEN
10078           CALL PUSHREAL8(q(i, k))
10079           q(i, k) = 0.
10080           CALL PUSHCONTROL1B(0)
10081         ELSE
10082           CALL PUSHREAL8(q(i, k))
10083           q(i, k) = q(i, k) - pgdep(i, k)*dtcld
10084           CALL PUSHCONTROL1B(1)
10085         END IF
10086         IF (qrs(i, k, 3) + pgdep(i, k)*dtcld .LT. 0.) THEN
10087           qrs(i, k, 3) = 0.
10088           CALL PUSHCONTROL1B(0)
10089         ELSE
10090           qrs(i, k, 3) = qrs(i, k, 3) + pgdep(i, k)*dtcld
10091           CALL PUSHCONTROL1B(1)
10092         END IF
10093         CALL PUSHREAL8(t(i, k))
10094         t(i, k) = t(i, k) + pgdep(i, k)*dtcld*xls/cpm(i, k)
10095 !-------------------------------------------------------------
10096 ! pigen: generation(nucleation) of ice from vapor [HDC 7-8]
10097 !       (T<T0: V->I) min=0,max=min(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld,satdt)
10098 !-------------------------------------------------------------
10099 !update supcol
10100         CALL PUSHREAL8(supcol)
10101         supcol = t0c - t(i, k)
10102         CALL PUSHREAL8(cpm(i, k))
10103         cpm(i, k) = CPMCAL(q(i, k))
10104 !update rh qs
10105         CALL PUSHREAL8ARRAY(qs(i, k, :), 3)
10106         CALL PUSHREAL8ARRAY(rh(i, k, :), 3)
10107         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
10108 !update satdt
10109         supsat = q(i, k) - qs(i, k, 2)
10110         satdt = supsat/dtcld
10111         CALL PUSHREAL8(fsupsat)
10112         CALL SMOOTHIF(supsat, 0., fsupsat, 'q+')
10113         CALL PUSHREAL8(fsupcol)
10114         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
10115         CALL PUSHREAL8(xni0)
10116         xni0 = 1.e3*EXP(0.1*supcol)
10117         roqi0 = 4.92e-11*xni0**1.33
10118         IF (qci(i, k, 2) .LT. 0.) THEN
10119           CALL PUSHCONTROL1B(0)
10120           max11 = 0.
10121         ELSE
10122           max11 = qci(i, k, 2)
10123           CALL PUSHCONTROL1B(1)
10124         END IF
10125         x7 = (roqi0/den(i, k)-max11)/dtcld
10126         IF (x7 .GT. satdt) THEN
10127           pigen0 = satdt
10128           CALL PUSHCONTROL1B(0)
10129         ELSE
10130           pigen0 = x7
10131           CALL PUSHCONTROL1B(1)
10132         END IF
10133         IF (pigen0 .LT. 0.) THEN
10134           pigen(i, k) = 0.
10135           CALL PUSHCONTROL1B(0)
10136         ELSE
10137           pigen(i, k) = pigen0
10138           CALL PUSHCONTROL1B(1)
10139         END IF
10140         CALL PUSHREAL8(pigen(i, k))
10141         pigen(i, k) = fsupcol*fsupsat*pigen(i, k)
10142         IF (pigen(i, k) .GE. 0.) THEN
10143           abs3 = pigen(i, k)
10144         ELSE
10145           abs3 = -pigen(i, k)
10146         END IF
10147         IF (abs3 .LT. qmin/dtcld) THEN
10148           pigen(i, k) = 0.
10149           CALL PUSHCONTROL1B(1)
10150         ELSE
10151           CALL PUSHCONTROL1B(0)
10152         END IF
10153         IF (q(i, k) - pigen(i, k)*dtcld .LT. 0.) THEN
10154           CALL PUSHREAL8(q(i, k))
10155           q(i, k) = 0.
10156           CALL PUSHCONTROL1B(0)
10157         ELSE
10158           CALL PUSHREAL8(q(i, k))
10159           q(i, k) = q(i, k) - pigen(i, k)*dtcld
10160           CALL PUSHCONTROL1B(1)
10161         END IF
10162         IF (qci(i, k, 2) + pigen(i, k)*dtcld .LT. 0.) THEN
10163           qci(i, k, 2) = 0.
10164           CALL PUSHCONTROL1B(0)
10165         ELSE
10166           qci(i, k, 2) = qci(i, k, 2) + pigen(i, k)*dtcld
10167           CALL PUSHCONTROL1B(1)
10168         END IF
10169         CALL PUSHREAL8(t(i, k))
10170         t(i, k) = t(i, k) + pigen(i, k)*dtcld*xls/cpm(i, k)
10171 !
10172 !------------------------------------------------------------
10173 ! psaut: conversion(aggregation) of ice to snow [HDC 12]
10174 !        (T<T0: I->S) psaut>0, min=0,max=(qci(i,k,2)-qimax)/dtcld
10175 !-------------------------------------------------------------
10176 !update supcol
10177         CALL PUSHREAL8(supcol)
10178         supcol = t0c - t(i, k)
10179         CALL PUSHREAL8(fsupcol)
10180         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
10181 !         call smoothif(qci(i,k,2),0.,fqi,'q+')
10182         qimax = roqimax/den(i, k)
10183         IF (0. .LT. (qci(i, k, 2)-qimax)/dtcld) THEN
10184           psaut(i, k) = (qci(i, k, 2)-qimax)/dtcld
10185           CALL PUSHCONTROL1B(0)
10186         ELSE
10187           psaut(i, k) = 0.
10188           CALL PUSHCONTROL1B(1)
10189         END IF
10190         CALL PUSHREAL8(psaut(i, k))
10191         psaut(i, k) = fsupcol*psaut(i, k)
10192         IF (psaut(i, k) .GE. 0.) THEN
10193           abs4 = psaut(i, k)
10194         ELSE
10195           abs4 = -psaut(i, k)
10196         END IF
10197         IF (abs4 .LT. qmin/dtcld) THEN
10198           psaut(i, k) = 0.
10199           CALL PUSHCONTROL1B(1)
10200         ELSE
10201           CALL PUSHCONTROL1B(0)
10202         END IF
10203         IF (qci(i, k, 2) - psaut(i, k)*dtcld .LT. 0.) THEN
10204           CALL PUSHCONTROL1B(0)
10205         ELSE
10206           CALL PUSHCONTROL1B(1)
10207         END IF
10208         IF (qrs(i, k, 2) + psaut(i, k)*dtcld .LT. 0.) THEN
10209           qrs(i, k, 2) = 0.
10210           CALL PUSHCONTROL1B(0)
10211         ELSE
10212           qrs(i, k, 2) = qrs(i, k, 2) + psaut(i, k)*dtcld
10213           CALL PUSHCONTROL1B(1)
10214         END IF
10215 !
10216 !-------------------------------------------------------------
10217 ! pgaut: conversion(aggregation) of snow to graupel [LFO 37]
10218 !        (T<T0: S->G) pgaut>0 min=0.,max=qrs(i,k,2)/dtcld
10219 !-------------------------------------------------------------
10220 !update supcol
10221 !         supcol = t0c-t(i,k) ! not change
10222 !         call smoothif(supcol,0.,fsupcol,'t0')
10223 !         call smoothif(qrs(i,k,2),0.,fqs,'q+')
10224         CALL PUSHREAL8(alpha2)
10225         alpha2 = 1.e-3*EXP(0.09*(-supcol))
10226         IF (0. .LT. alpha2*(qrs(i, k, 2)-qs0)) THEN
10227           x8 = alpha2*(qrs(i, k, 2)-qs0)
10228           CALL PUSHCONTROL1B(0)
10229         ELSE
10230           x8 = 0.
10231           CALL PUSHCONTROL1B(1)
10232         END IF
10233         IF (x8 .GT. qrs(i, k, 2)/dtcld) THEN
10234           pgaut(i, k) = qrs(i, k, 2)/dtcld
10235           CALL PUSHCONTROL1B(0)
10236         ELSE
10237           pgaut(i, k) = x8
10238           CALL PUSHCONTROL1B(1)
10239         END IF
10240         CALL PUSHREAL8(pgaut(i, k))
10241         pgaut(i, k) = fsupcol*pgaut(i, k)
10242         IF (pgaut(i, k) .GE. 0.) THEN
10243           abs5 = pgaut(i, k)
10244         ELSE
10245           abs5 = -pgaut(i, k)
10246         END IF
10247         IF (abs5 .LT. qmin/dtcld) THEN
10248           pgaut(i, k) = 0.
10249           CALL PUSHCONTROL1B(1)
10250         ELSE
10251           CALL PUSHCONTROL1B(0)
10252         END IF
10253         IF (qrs(i, k, 2) - pgaut(i, k)*dtcld .LT. 0.) THEN
10254           CALL PUSHREAL8(qrs(i, k, 2))
10255           qrs(i, k, 2) = 0.
10256           CALL PUSHCONTROL1B(0)
10257         ELSE
10258           CALL PUSHREAL8(qrs(i, k, 2))
10259           qrs(i, k, 2) = qrs(i, k, 2) - pgaut(i, k)*dtcld
10260           CALL PUSHCONTROL1B(1)
10261         END IF
10262         IF (qrs(i, k, 3) + pgaut(i, k)*dtcld .LT. 0.) THEN
10263           CALL PUSHREAL8(qrs(i, k, 3))
10264           qrs(i, k, 3) = 0.
10265           CALL PUSHCONTROL1B(0)
10266         ELSE
10267           CALL PUSHREAL8(qrs(i, k, 3))
10268           qrs(i, k, 3) = qrs(i, k, 3) + pgaut(i, k)*dtcld
10269           CALL PUSHCONTROL1B(1)
10270         END IF
10271 !
10272 !-------------------------------------------------------------
10273 ! psevp: Evaporation of melting snow [RH83 A27]
10274 !       (T>=T0: S->V) rh<1., psevp<0, min=-qrs(i,k,2)/dtcld, max=0.
10275 !-------------------------------------------------------------
10276 !         supcol = t0c-t(i,k) ! not change
10277 !update rh qs
10278         CALL PUSHREAL8ARRAY(qs(i, k, :), 3)
10279         CALL PUSHREAL8ARRAY(rh(i, k, :), 3)
10280         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
10281 !update xl, cpm
10282         xl(i, k) = XLCAL(t(i, k))
10283         CALL PUSHREAL8(cpm(i, k))
10284         cpm(i, k) = CPMCAL(q(i, k))
10285         CALL PUSHREAL8(ft0)
10286         CALL SMOOTHIF(t(i, k), t0c, ft0, 't+')
10287         IF (90. .GT. t0c - t(i, k)) THEN
10288           y3 = t0c - t(i, k)
10289           CALL PUSHCONTROL1B(0)
10290         ELSE
10291           CALL PUSHCONTROL1B(1)
10292           y3 = 90.
10293         END IF
10294         IF (0. .LT. y3) THEN
10295           CALL PUSHREAL8(max5)
10296           max5 = y3
10297           CALL PUSHCONTROL1B(1)
10298         ELSE
10299           CALL PUSHREAL8(max5)
10300           max5 = 0.
10301           CALL PUSHCONTROL1B(0)
10302         END IF
10303         IF (qrs(i, k, 2) .LT. qcrmin) THEN
10304           CALL PUSHREAL8(max12)
10305           max12 = qcrmin
10306           CALL PUSHCONTROL1B(0)
10307         ELSE
10308           CALL PUSHREAL8(max12)
10309           max12 = qrs(i, k, 2)
10310           CALL PUSHCONTROL1B(1)
10311         END IF
10312         CALL PUSHREAL8(a)
10313         a = EXP(alpha*max5/2.)*SQRT(den(i, k)*max12)
10314         IF (90. .GT. t0c - t(i, k)) THEN
10315           y4 = t0c - t(i, k)
10316           CALL PUSHCONTROL1B(0)
10317         ELSE
10318           CALL PUSHCONTROL1B(1)
10319           y4 = 90.
10320         END IF
10321         IF (0. .LT. y4) THEN
10322           CALL PUSHREAL8(max6)
10323           max6 = y4
10324           CALL PUSHCONTROL1B(1)
10325         ELSE
10326           CALL PUSHREAL8(max6)
10327           max6 = 0.
10328           CALL PUSHCONTROL1B(0)
10329         END IF
10330         IF (qrs(i, k, 2) .LT. qcrmin) THEN
10331           CALL PUSHREAL8(max13)
10332           max13 = qcrmin
10333           CALL PUSHCONTROL1B(0)
10334         ELSE
10335           CALL PUSHREAL8(max13)
10336           max13 = qrs(i, k, 2)
10337           CALL PUSHCONTROL1B(1)
10338         END IF
10339         CALL PUSHREAL8(b)
10340         b = EXP((3.-bvts)*alpha*max6/8.)*(t(i, k)+120.)**(1./6.)/t(i, k)&
10341 &         **(5.12/6.)*p(i, k)**(1./3.)*den(i, k)**((13.+3.*bvts)/24.)*&
10342 &         max13**((5.+bvts)/8.)
10343         CALL PUSHREAL8(c)
10344         c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, &
10345 &         k)**3.5
10346         CALL PUSHREAL8(d)
10347         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1)
10348         CALL PUSHREAL8(e)
10349         e = (rh(i, k, 1)-1.)/(c+d)
10350         psevp0 = e*(psevp_a*a+psevp_b*b)
10351         IF (psevp0 .LT. -(qrs(i, k, 2)/dtcld)) THEN
10352           x9 = -(qrs(i, k, 2)/dtcld)
10353           CALL PUSHCONTROL1B(0)
10354         ELSE
10355           x9 = psevp0
10356           CALL PUSHCONTROL1B(1)
10357         END IF
10358         IF (x9 .GT. 0.) THEN
10359           psevp(i, k) = 0.
10360           CALL PUSHCONTROL1B(0)
10361         ELSE
10362           psevp(i, k) = x9
10363           CALL PUSHCONTROL1B(1)
10364         END IF
10365         CALL PUSHREAL8(psevp(i, k))
10366         psevp(i, k) = ft0*psevp(i, k)
10367         IF (psevp(i, k) .GE. 0.) THEN
10368           abs6 = psevp(i, k)
10369         ELSE
10370           abs6 = -psevp(i, k)
10371         END IF
10372         IF (abs6 .LT. qmin/dtcld) THEN
10373           psevp(i, k) = 0.
10374           CALL PUSHCONTROL1B(1)
10375         ELSE
10376           CALL PUSHCONTROL1B(0)
10377         END IF
10378         IF (q(i, k) - psevp(i, k)*dtcld .LT. 0.) THEN
10379           CALL PUSHREAL8(q(i, k))
10380           q(i, k) = 0.
10381           CALL PUSHCONTROL1B(0)
10382         ELSE
10383           CALL PUSHREAL8(q(i, k))
10384           q(i, k) = q(i, k) - psevp(i, k)*dtcld
10385           CALL PUSHCONTROL1B(1)
10386         END IF
10387         IF (qrs(i, k, 2) + psevp(i, k)*dtcld .LT. 0.) THEN
10388           CALL PUSHREAL8(qrs(i, k, 2))
10389           qrs(i, k, 2) = 0.
10390           CALL PUSHCONTROL1B(0)
10391         ELSE
10392           CALL PUSHREAL8(qrs(i, k, 2))
10393           qrs(i, k, 2) = qrs(i, k, 2) + psevp(i, k)*dtcld
10394           CALL PUSHCONTROL1B(1)
10395         END IF
10396         CALL PUSHREAL8(t(i, k))
10397         t(i, k) = t(i, k) + psevp(i, k)*dtcld*xls/cpm(i, k)
10398 !
10399 !-------------------------------------------------------------
10400 ! pgevp: Evaporation of melting graupel [RH84 A19]
10401 !       (T>=T0: G->V) rh<1., pgevp<0, min=-qrs(i,k,3)/dtcld, max=0.
10402 !-------------------------------------------------------------
10403 !update rh qs
10404         CALL PUSHREAL8ARRAY(qs(i, k, :), 3)
10405         CALL PUSHREAL8ARRAY(rh(i, k, :), 3)
10406         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
10407 !update xl, cpm
10408         CALL PUSHREAL8(xl(i, k))
10409         xl(i, k) = XLCAL(t(i, k))
10410         CALL PUSHREAL8(cpm(i, k))
10411         cpm(i, k) = CPMCAL(q(i, k))
10412         CALL PUSHREAL8(ft0)
10413         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
10414         IF (qrs(i, k, 3) .LT. qcrmin) THEN
10415           CALL PUSHREAL8(max7)
10416           max7 = qcrmin
10417           CALL PUSHCONTROL1B(0)
10418         ELSE
10419           CALL PUSHREAL8(max7)
10420           max7 = qrs(i, k, 3)
10421           CALL PUSHCONTROL1B(1)
10422         END IF
10423         CALL PUSHREAL8(a)
10424         a = SQRT(den(i, k)*max7)
10425         IF (qrs(i, k, 3) .LT. qcrmin) THEN
10426           CALL PUSHREAL8(max8)
10427           max8 = qcrmin
10428           CALL PUSHCONTROL1B(0)
10429         ELSE
10430           CALL PUSHREAL8(max8)
10431           max8 = qrs(i, k, 3)
10432           CALL PUSHCONTROL1B(1)
10433         END IF
10434         CALL PUSHREAL8(b)
10435         b = (t(i, k)+120.)**(1./6.)/t(i, k)**(5.12/6.)*p(i, k)**(1./3.)*&
10436 &         den(i, k)**((13.+3.*bvtg)/24.)*max8**((5.+bvtg)/8.)
10437         CALL PUSHREAL8(c)
10438         c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, &
10439 &         k)**3.5
10440         CALL PUSHREAL8(d)
10441         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1)
10442         CALL PUSHREAL8(e)
10443         e = (rh(i, k, 1)-1.)/(c+d)
10444         pgevp0 = e*(pgevp_a*a+pgevp_b*b)
10445         IF (pgevp0 .LT. -(qrs(i, k, 3)/dtcld)) THEN
10446           x10 = -(qrs(i, k, 3)/dtcld)
10447           CALL PUSHCONTROL1B(0)
10448         ELSE
10449           x10 = pgevp0
10450           CALL PUSHCONTROL1B(1)
10451         END IF
10452         IF (x10 .GT. 0.) THEN
10453           pgevp(i, k) = 0.
10454           CALL PUSHCONTROL1B(0)
10455         ELSE
10456           pgevp(i, k) = x10
10457           CALL PUSHCONTROL1B(1)
10458         END IF
10459         CALL PUSHREAL8(pgevp(i, k))
10460         pgevp(i, k) = ft0*pgevp(i, k)
10461         IF (pgevp(i, k) .GE. 0.) THEN
10462           abs7 = pgevp(i, k)
10463         ELSE
10464           abs7 = -pgevp(i, k)
10465         END IF
10466         IF (abs7 .LT. qmin/dtcld) THEN
10467           pgevp(i, k) = 0.
10468           CALL PUSHCONTROL1B(1)
10469         ELSE
10470           CALL PUSHCONTROL1B(0)
10471         END IF
10472         IF (q(i, k) - pgevp(i, k)*dtcld .LT. 0.) THEN
10473           CALL PUSHCONTROL1B(0)
10474         ELSE
10475           CALL PUSHCONTROL1B(1)
10476         END IF
10477         IF (qrs(i, k, 3) + pgevp(i, k)*dtcld .LT. 0.) THEN
10478           CALL PUSHCONTROL1B(0)
10479         ELSE
10480           CALL PUSHCONTROL1B(1)
10481         END IF
10482       END DO
10483     END DO
10484     a_cpm = 0.0_8
10485     a_xl = 0.0_8
10486     DO k=kte,kts,-1
10487       DO i=ite,its,-1
10488         a_temp3 = dtcld*xls*a_t(i, k)/cpm(i, k)
10489         a_pgevp(i, k) = a_temp3
10490         a_cpm(i, k) = a_cpm(i, k) - pgevp(i, k)*a_temp3/cpm(i, k)
10491         CALL POPCONTROL1B(branch)
10492         IF (branch .EQ. 0) THEN
10493           a_qrs(i, k, 3) = 0.0_8
10494         ELSE
10495           a_pgevp(i, k) = a_pgevp(i, k) + dtcld*a_qrs(i, k, 3)
10496         END IF
10497         CALL POPCONTROL1B(branch)
10498         IF (branch .EQ. 0) THEN
10499           a_q(i, k) = 0.0_8
10500         ELSE
10501           a_pgevp(i, k) = a_pgevp(i, k) - dtcld*a_q(i, k)
10502         END IF
10503         CALL POPCONTROL1B(branch)
10504         IF (branch .NE. 0) a_pgevp(i, k) = 0.0_8
10505         CALL POPREAL8(pgevp(i, k))
10506         a_ft0 = pgevp(i, k)*a_pgevp(i, k)
10507         a_pgevp(i, k) = ft0*a_pgevp(i, k)
10508         CALL POPCONTROL1B(branch)
10509         IF (branch .EQ. 0) THEN
10510           a_pgevp(i, k) = 0.0_8
10511           a_x10 = 0.0_8
10512         ELSE
10513           a_x10 = a_pgevp(i, k)
10514           a_pgevp(i, k) = 0.0_8
10515         END IF
10516         CALL POPCONTROL1B(branch)
10517         IF (branch .EQ. 0) THEN
10518           a_qrs(i, k, 3) = a_qrs(i, k, 3) - a_x10/dtcld
10519           a_pgevp0 = 0.0_8
10520         ELSE
10521           a_pgevp0 = a_x10
10522         END IF
10523         a_e = (pgevp_a*a+pgevp_b*b)*a_pgevp0
10524         a_a = pgevp_a*e*a_pgevp0
10525         a_b = pgevp_b*e*a_pgevp0
10526         CALL POPREAL8(e)
10527         a_temp3 = a_e/(c+d)
10528         a_rh(i, k, 1) = a_rh(i, k, 1) + a_temp3
10529         a_temp5 = -((rh(i, k, 1)-1.)*a_temp3/(c+d))
10530         a_c = a_temp5
10531         a_d = a_temp5
10532         CALL POPREAL8(d)
10533         temp15 = t(i, k)**1.81
10534         temp14 = temp15*qs(i, k, 1)
10535         a_temp6 = diffac_b*a_d/temp14
10536         a_temp5 = -(p(i, k)*a_temp6/temp14)
10537         a_t(i, k) = a_t(i, k) + 1.81*t(i, k)**0.81*qs(i, k, 1)*a_temp5
10538         a_qs(i, k, 1) = a_qs(i, k, 1) + temp15*a_temp5
10539         CALL POPREAL8(c)
10540         temp15 = rv*t(i, k)**3.5
10541         temp13 = den(i, k)*(t(i, k)+120.)
10542         temp12 = xl(i, k)*xl(i, k)
10543         a_temp5 = diffac_a*a_c/temp15
10544         a_xl(i, k) = a_xl(i, k) + 2*xl(i, k)*temp13*a_temp5
10545         a_den(i, k) = a_den(i, k) + (t(i, k)+120.)*temp12*a_temp5
10546         a_t(i, k) = a_t(i, k) + (den(i, k)*temp12-3.5*t(i, k)**2.5*rv*&
10547 &         temp12*temp13/temp15)*a_temp5
10548         CALL POPREAL8(b)
10549         temp15 = (3.*bvtg+13.)/24.
10550         temp14 = den(i, k)**temp15
10551         temp13 = (bvtg+5.)/8.
10552         temp12 = max8**temp13
10553         temp11 = 1.0/3.
10554         temp10 = p(i, k)**temp11
10555         temp9 = temp10*temp12
10556         temp8 = 5.12/6.
10557         temp7 = t(i, k)**temp8
10558         temp5 = 1.0/6.
10559         temp6 = (t(i, k)+120.)**temp5/temp7
10560         a_temp7 = temp9*temp14*a_b/temp7
10561         a_temp8 = temp6*a_b
10562         IF (p(i, k) .LE. 0.0_8 .AND. (temp11 .EQ. 0.0_8 .OR. temp11 .NE.&
10563 &           INT(temp11))) THEN
10564           a_p(i, k) = a_p(i, k) + a_temp6
10565         ELSE
10566           a_p(i, k) = a_p(i, k) + a_temp6 + temp11*p(i, k)**(temp11-1)*&
10567 &           temp12*temp14*a_temp8
10568         END IF
10569         IF (max8 .LE. 0.0_8 .AND. (temp13 .EQ. 0.0_8 .OR. temp13 .NE. &
10570 &           INT(temp13))) THEN
10571           a_max8 = 0.0_8
10572         ELSE
10573           a_max8 = temp13*max8**(temp13-1)*temp10*temp14*a_temp8
10574         END IF
10575         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp15 .EQ. 0.0_8 .OR. &
10576 &           temp15 .NE. INT(temp15)))) a_den(i, k) = a_den(i, k) + &
10577 &           temp15*den(i, k)**(temp15-1)*temp9*a_temp8
10578         IF (.NOT.(t(i, k) + 120. .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR.&
10579 &           temp5 .NE. INT(temp5)))) a_t(i, k) = a_t(i, k) + temp5*(t(i&
10580 &           , k)+120.)**(temp5-1)*a_temp7
10581         IF (.NOT.(t(i, k) .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. temp8 &
10582 &           .NE. INT(temp8)))) a_t(i, k) = a_t(i, k) - temp8*t(i, k)**(&
10583 &           temp8-1)*temp6*a_temp7
10584         CALL POPCONTROL1B(branch)
10585         IF (branch .EQ. 0) THEN
10586           CALL POPREAL8(max8)
10587         ELSE
10588           CALL POPREAL8(max8)
10589           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max8
10590         END IF
10591         CALL POPREAL8(a)
10592         IF (den(i, k)*max7 .EQ. 0.0_8) THEN
10593           a_temp3 = 0.0_8
10594         ELSE
10595           a_temp3 = a_a/(2.0*SQRT(den(i, k)*max7))
10596         END IF
10597         a_den(i, k) = a_den(i, k) + max7*a_temp3
10598         a_max7 = den(i, k)*a_temp3
10599         CALL POPCONTROL1B(branch)
10600         IF (branch .EQ. 0) THEN
10601           CALL POPREAL8(max7)
10602         ELSE
10603           CALL POPREAL8(max7)
10604           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max7
10605         END IF
10606         CALL POPREAL8(ft0)
10607         CALL A_SMOOTHIF(t(i, k), a_t(i, k), t0c, ft0, a_ft0, 't0')
10608         CALL POPREAL8(cpm(i, k))
10609         CALL A_CPMCAL0(q(i, k), a_q(i, k), a_cpm(i, k))
10610         a_cpm(i, k) = 0.0_8
10611         CALL POPREAL8(xl(i, k))
10612         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
10613         a_xl(i, k) = 0.0_8
10614         CALL POPREAL8ARRAY(rh(i, k, :), 3)
10615         CALL POPREAL8ARRAY(qs(i, k, :), 3)
10616         CALL A_CALCRH(t(i, k), a_t(i, k), p(i, k), a_p(i, k), q(i, k), &
10617 &               a_q(i, k), rh(i, k, :), a_rh(i, k, :), qs(i, k, :), a_qs&
10618 &               (i, k, :))
10619         CALL POPREAL8(t(i, k))
10620         a_temp3 = dtcld*xls*a_t(i, k)/cpm(i, k)
10621         a_psevp(i, k) = a_temp3
10622         a_cpm(i, k) = a_cpm(i, k) - psevp(i, k)*a_temp3/cpm(i, k)
10623         CALL POPCONTROL1B(branch)
10624         IF (branch .EQ. 0) THEN
10625           CALL POPREAL8(qrs(i, k, 2))
10626           a_qrs(i, k, 2) = 0.0_8
10627         ELSE
10628           CALL POPREAL8(qrs(i, k, 2))
10629           a_psevp(i, k) = a_psevp(i, k) + dtcld*a_qrs(i, k, 2)
10630         END IF
10631         CALL POPCONTROL1B(branch)
10632         IF (branch .EQ. 0) THEN
10633           CALL POPREAL8(q(i, k))
10634           a_q(i, k) = 0.0_8
10635         ELSE
10636           CALL POPREAL8(q(i, k))
10637           a_psevp(i, k) = a_psevp(i, k) - dtcld*a_q(i, k)
10638         END IF
10639         CALL POPCONTROL1B(branch)
10640         IF (branch .NE. 0) a_psevp(i, k) = 0.0_8
10641         CALL POPREAL8(psevp(i, k))
10642         a_ft0 = psevp(i, k)*a_psevp(i, k)
10643         a_psevp(i, k) = ft0*a_psevp(i, k)
10644         CALL POPCONTROL1B(branch)
10645         IF (branch .EQ. 0) THEN
10646           a_psevp(i, k) = 0.0_8
10647           a_x9 = 0.0_8
10648         ELSE
10649           a_x9 = a_psevp(i, k)
10650           a_psevp(i, k) = 0.0_8
10651         END IF
10652         CALL POPCONTROL1B(branch)
10653         IF (branch .EQ. 0) THEN
10654           a_qrs(i, k, 2) = a_qrs(i, k, 2) - a_x9/dtcld
10655           a_psevp0 = 0.0_8
10656         ELSE
10657           a_psevp0 = a_x9
10658         END IF
10659         a_e = (psevp_a*a+psevp_b*b)*a_psevp0
10660         a_a = psevp_a*e*a_psevp0
10661         a_b = psevp_b*e*a_psevp0
10662         CALL POPREAL8(e)
10663         a_temp3 = a_e/(c+d)
10664         a_rh(i, k, 1) = a_rh(i, k, 1) + a_temp3
10665         a_temp5 = -((rh(i, k, 1)-1.)*a_temp3/(c+d))
10666         a_c = a_temp5
10667         a_d = a_temp5
10668         CALL POPREAL8(d)
10669         temp15 = t(i, k)**1.81
10670         temp14 = temp15*qs(i, k, 1)
10671         a_temp6 = diffac_b*a_d/temp14
10672         a_temp5 = -(p(i, k)*a_temp6/temp14)
10673         a_t(i, k) = a_t(i, k) + 1.81*t(i, k)**0.81*qs(i, k, 1)*a_temp5
10674         a_qs(i, k, 1) = a_qs(i, k, 1) + temp15*a_temp5
10675         CALL POPREAL8(c)
10676         temp15 = rv*t(i, k)**3.5
10677         temp13 = den(i, k)*(t(i, k)+120.)
10678         temp12 = xl(i, k)*xl(i, k)
10679         a_temp5 = diffac_a*a_c/temp15
10680         a_xl(i, k) = a_xl(i, k) + 2*xl(i, k)*temp13*a_temp5
10681         a_den(i, k) = a_den(i, k) + (t(i, k)+120.)*temp12*a_temp5
10682         a_t(i, k) = a_t(i, k) + (den(i, k)*temp12-3.5*t(i, k)**2.5*rv*&
10683 &         temp12*temp13/temp15)*a_temp5
10684         CALL POPREAL8(b)
10685         temp15 = (bvts+5.)/8.
10686         temp14 = max13**temp15
10687         temp13 = 1.0/3.
10688         temp12 = p(i, k)**temp13
10689         temp11 = temp12*temp14
10690         temp10 = 5.12/6.
10691         temp9 = t(i, k)**temp10
10692         temp8 = 1.0/6.
10693         temp7 = (t(i, k)+120.)**temp8/temp9
10694         temp5 = (3.*bvts+13.)/24.
10695         temp4 = den(i, k)**temp5
10696         temp3 = (-bvts+3.)*alpha*max6/8.
10697         temp2 = EXP(temp3)
10698         a_temp7 = temp7*temp11*a_b
10699         a_temp1 = temp2*temp4*a_b
10700         IF (p(i, k) .LE. 0.0_8 .AND. (temp13 .EQ. 0.0_8 .OR. temp13 .NE.&
10701 &           INT(temp13))) THEN
10702           a_p(i, k) = a_p(i, k) + a_temp6
10703         ELSE
10704           a_p(i, k) = a_p(i, k) + a_temp6 + temp13*p(i, k)**(temp13-1)*&
10705 &           temp14*temp7*a_temp1
10706         END IF
10707         a_temp9 = temp11*a_temp1/temp9
10708         IF (max13 .LE. 0.0_8 .AND. (temp15 .EQ. 0.0_8 .OR. temp15 .NE. &
10709 &           INT(temp15))) THEN
10710           a_max13 = 0.0_8
10711         ELSE
10712           a_max13 = temp15*max13**(temp15-1)*temp12*temp7*a_temp1
10713         END IF
10714         IF (.NOT.(t(i, k) + 120. .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR.&
10715 &           temp8 .NE. INT(temp8)))) a_t(i, k) = a_t(i, k) + temp8*(t(i&
10716 &           , k)+120.)**(temp8-1)*a_temp9
10717         IF (.NOT.(t(i, k) .LE. 0.0_8 .AND. (temp10 .EQ. 0.0_8 .OR. &
10718 &           temp10 .NE. INT(temp10)))) a_t(i, k) = a_t(i, k) - temp10*t(&
10719 &           i, k)**(temp10-1)*temp7*a_temp9
10720         a_max6 = (3.-bvts)*alpha*EXP(temp3)*temp4*a_temp7/8.
10721         IF (.NOT.(den(i, k) .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR. &
10722 &           temp5 .NE. INT(temp5)))) a_den(i, k) = a_den(i, k) + temp5*&
10723 &           den(i, k)**(temp5-1)*temp2*a_temp7
10724         CALL POPCONTROL1B(branch)
10725         IF (branch .EQ. 0) THEN
10726           CALL POPREAL8(max13)
10727         ELSE
10728           CALL POPREAL8(max13)
10729           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max13
10730         END IF
10731         CALL POPCONTROL1B(branch)
10732         IF (branch .EQ. 0) THEN
10733           CALL POPREAL8(max6)
10734           a_y4 = 0.0_8
10735         ELSE
10736           CALL POPREAL8(max6)
10737           a_y4 = a_max6
10738         END IF
10739         CALL POPCONTROL1B(branch)
10740         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y4
10741         CALL POPREAL8(a)
10742         temp15 = den(i, k)*max12
10743         temp14 = SQRT(temp15)
10744         temp13 = alpha*max5/2.
10745         a_max5 = alpha*EXP(temp13)*temp14*a_a/2.
10746         IF (temp15 .EQ. 0.0_8) THEN
10747           a_temp3 = 0.0_8
10748         ELSE
10749           a_temp3 = EXP(temp13)*a_a/(2.0*temp14)
10750         END IF
10751         a_den(i, k) = a_den(i, k) + max12*a_temp3
10752         a_max12 = den(i, k)*a_temp3
10753         CALL POPCONTROL1B(branch)
10754         IF (branch .EQ. 0) THEN
10755           CALL POPREAL8(max12)
10756         ELSE
10757           CALL POPREAL8(max12)
10758           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max12
10759         END IF
10760         CALL POPCONTROL1B(branch)
10761         IF (branch .EQ. 0) THEN
10762           CALL POPREAL8(max5)
10763           a_y3 = 0.0_8
10764         ELSE
10765           CALL POPREAL8(max5)
10766           a_y3 = a_max5
10767         END IF
10768         CALL POPCONTROL1B(branch)
10769         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y3
10770         CALL POPREAL8(ft0)
10771         CALL A_SMOOTHIF(t(i, k), a_t(i, k), t0c, ft0, a_ft0, 't+')
10772         CALL POPREAL8(cpm(i, k))
10773         CALL A_CPMCAL0(q(i, k), a_q(i, k), a_cpm(i, k))
10774         a_cpm(i, k) = 0.0_8
10775         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
10776         a_xl(i, k) = 0.0_8
10777         CALL POPREAL8ARRAY(rh(i, k, :), 3)
10778         CALL POPREAL8ARRAY(qs(i, k, :), 3)
10779         CALL A_CALCRH(t(i, k), a_t(i, k), p(i, k), a_p(i, k), q(i, k), &
10780 &               a_q(i, k), rh(i, k, :), a_rh(i, k, :), qs(i, k, :), a_qs&
10781 &               (i, k, :))
10782         a_pgaut(i, k) = 0.0_8
10783         CALL POPCONTROL1B(branch)
10784         IF (branch .EQ. 0) THEN
10785           CALL POPREAL8(qrs(i, k, 3))
10786           a_qrs(i, k, 3) = 0.0_8
10787         ELSE
10788           CALL POPREAL8(qrs(i, k, 3))
10789           a_pgaut(i, k) = a_pgaut(i, k) + dtcld*a_qrs(i, k, 3)
10790         END IF
10791         CALL POPCONTROL1B(branch)
10792         IF (branch .EQ. 0) THEN
10793           CALL POPREAL8(qrs(i, k, 2))
10794           a_qrs(i, k, 2) = 0.0_8
10795         ELSE
10796           CALL POPREAL8(qrs(i, k, 2))
10797           a_pgaut(i, k) = a_pgaut(i, k) - dtcld*a_qrs(i, k, 2)
10798         END IF
10799         CALL POPCONTROL1B(branch)
10800         IF (branch .NE. 0) a_pgaut(i, k) = 0.0_8
10801         CALL POPREAL8(pgaut(i, k))
10802         a_fsupcol = pgaut(i, k)*a_pgaut(i, k)
10803         a_pgaut(i, k) = fsupcol*a_pgaut(i, k)
10804         CALL POPCONTROL1B(branch)
10805         IF (branch .EQ. 0) THEN
10806           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_pgaut(i, k)/dtcld
10807           a_pgaut(i, k) = 0.0_8
10808           a_x8 = 0.0_8
10809         ELSE
10810           a_x8 = a_pgaut(i, k)
10811           a_pgaut(i, k) = 0.0_8
10812         END IF
10813         CALL POPCONTROL1B(branch)
10814         IF (branch .EQ. 0) THEN
10815           a_alpha2 = (qrs(i, k, 2)-qs0)*a_x8
10816           a_qrs(i, k, 2) = a_qrs(i, k, 2) + alpha2*a_x8
10817         ELSE
10818           a_alpha2 = 0.0_8
10819         END IF
10820         CALL POPREAL8(alpha2)
10821         a_supcol = -(0.09*EXP(-(0.09*supcol))*1.e-3*a_alpha2)
10822         a_psaut(i, k) = 0.0_8
10823         CALL POPCONTROL1B(branch)
10824         IF (branch .EQ. 0) THEN
10825           a_qrs(i, k, 2) = 0.0_8
10826         ELSE
10827           a_psaut(i, k) = a_psaut(i, k) + dtcld*a_qrs(i, k, 2)
10828         END IF
10829         CALL POPCONTROL1B(branch)
10830         IF (branch .EQ. 0) THEN
10831           a_qci(i, k, 2) = 0.0_8
10832         ELSE
10833           a_psaut(i, k) = a_psaut(i, k) - dtcld*a_qci(i, k, 2)
10834         END IF
10835         CALL POPCONTROL1B(branch)
10836         IF (branch .NE. 0) a_psaut(i, k) = 0.0_8
10837         CALL POPREAL8(psaut(i, k))
10838         a_fsupcol = a_fsupcol + psaut(i, k)*a_psaut(i, k)
10839         a_psaut(i, k) = fsupcol*a_psaut(i, k)
10840         CALL POPCONTROL1B(branch)
10841         IF (branch .EQ. 0) THEN
10842           a_qci(i, k, 2) = a_qci(i, k, 2) + a_psaut(i, k)/dtcld
10843           a_qimax = -(a_psaut(i, k)/dtcld)
10844           a_psaut(i, k) = 0.0_8
10845         ELSE
10846           a_psaut(i, k) = 0.0_8
10847           a_qimax = 0.0_8
10848         END IF
10849         a_den(i, k) = a_den(i, k) - roqimax*a_qimax/den(i, k)**2
10850         CALL POPREAL8(fsupcol)
10851         CALL A_SMOOTHIF(supcol, a_supcol, 0., fsupcol, a_fsupcol, 't+')
10852         CALL POPREAL8(supcol)
10853         a_t(i, k) = a_t(i, k) - a_supcol
10854         CALL POPREAL8(t(i, k))
10855         a_temp3 = dtcld*xls*a_t(i, k)/cpm(i, k)
10856         a_pigen(i, k) = a_temp3
10857         a_cpm(i, k) = a_cpm(i, k) - pigen(i, k)*a_temp3/cpm(i, k)
10858         CALL POPCONTROL1B(branch)
10859         IF (branch .EQ. 0) THEN
10860           a_qci(i, k, 2) = 0.0_8
10861         ELSE
10862           a_pigen(i, k) = a_pigen(i, k) + dtcld*a_qci(i, k, 2)
10863         END IF
10864         CALL POPCONTROL1B(branch)
10865         IF (branch .EQ. 0) THEN
10866           CALL POPREAL8(q(i, k))
10867           a_q(i, k) = 0.0_8
10868         ELSE
10869           CALL POPREAL8(q(i, k))
10870           a_pigen(i, k) = a_pigen(i, k) - dtcld*a_q(i, k)
10871         END IF
10872         CALL POPCONTROL1B(branch)
10873         IF (branch .NE. 0) a_pigen(i, k) = 0.0_8
10874         CALL POPREAL8(pigen(i, k))
10875         a_temp3 = pigen(i, k)*a_pigen(i, k)
10876         a_pigen(i, k) = fsupcol*fsupsat*a_pigen(i, k)
10877         a_fsupcol = fsupsat*a_temp3
10878         a_fsupsat = fsupcol*a_temp3
10879         CALL POPCONTROL1B(branch)
10880         IF (branch .EQ. 0) THEN
10881           a_pigen(i, k) = 0.0_8
10882           a_pigen0 = 0.0_8
10883         ELSE
10884           a_pigen0 = a_pigen(i, k)
10885           a_pigen(i, k) = 0.0_8
10886         END IF
10887         CALL POPCONTROL1B(branch)
10888         IF (branch .EQ. 0) THEN
10889           a_satdt = a_pigen0
10890           a_x7 = 0.0_8
10891         ELSE
10892           a_x7 = a_pigen0
10893           a_satdt = 0.0_8
10894         END IF
10895         roqi0 = 4.92e-11*xni0**1.33
10896         a_temp3 = a_x7/(den(i, k)*dtcld)
10897         a_max11 = -(a_x7/dtcld)
10898         a_roqi0 = a_temp3
10899         a_den(i, k) = a_den(i, k) - roqi0*a_temp3/den(i, k)
10900         CALL POPCONTROL1B(branch)
10901         IF (branch .NE. 0) a_qci(i, k, 2) = a_qci(i, k, 2) + a_max11
10902         a_xni0 = 1.33*xni0**0.33*4.92e-11*a_roqi0
10903         CALL POPREAL8(xni0)
10904         a_supcol = 0.1*EXP(0.1*supcol)*1.e3*a_xni0
10905         CALL POPREAL8(fsupcol)
10906         CALL A_SMOOTHIF(supcol, a_supcol, 0., fsupcol, a_fsupcol, 't+')
10907         CALL POPREAL8(fsupsat)
10908         a_supsat = 0.0_8
10909         CALL A_SMOOTHIF(supsat, a_supsat, 0., fsupsat, a_fsupsat, 'q+')
10910         a_supsat = a_supsat + a_satdt/dtcld
10911         a_q(i, k) = a_q(i, k) + a_supsat
10912         a_qs(i, k, 2) = a_qs(i, k, 2) - a_supsat
10913         CALL POPREAL8ARRAY(rh(i, k, :), 3)
10914         CALL POPREAL8ARRAY(qs(i, k, :), 3)
10915         CALL A_CALCRH(t(i, k), a_t(i, k), p(i, k), a_p(i, k), q(i, k), &
10916 &               a_q(i, k), rh(i, k, :), a_rh(i, k, :), qs(i, k, :), a_qs&
10917 &               (i, k, :))
10918         CALL POPREAL8(cpm(i, k))
10919         CALL A_CPMCAL0(q(i, k), a_q(i, k), a_cpm(i, k))
10920         a_cpm(i, k) = 0.0_8
10921         CALL POPREAL8(supcol)
10922         a_t(i, k) = a_t(i, k) - a_supcol
10923         CALL POPREAL8(t(i, k))
10924         a_temp3 = dtcld*xls*a_t(i, k)/cpm(i, k)
10925         a_pgdep(i, k) = a_temp3
10926         a_cpm(i, k) = a_cpm(i, k) - pgdep(i, k)*a_temp3/cpm(i, k)
10927         CALL POPCONTROL1B(branch)
10928         IF (branch .EQ. 0) THEN
10929           a_qrs(i, k, 3) = 0.0_8
10930         ELSE
10931           a_pgdep(i, k) = a_pgdep(i, k) + dtcld*a_qrs(i, k, 3)
10932         END IF
10933         CALL POPCONTROL1B(branch)
10934         IF (branch .EQ. 0) THEN
10935           CALL POPREAL8(q(i, k))
10936           a_q(i, k) = 0.0_8
10937         ELSE
10938           CALL POPREAL8(q(i, k))
10939           a_pgdep(i, k) = a_pgdep(i, k) - dtcld*a_q(i, k)
10940         END IF
10941         CALL POPCONTROL1B(branch)
10942         IF (branch .NE. 0) a_pgdep(i, k) = 0.0_8
10943         CALL POPREAL8(pgdep(i, k))
10944         a_fsupcol = pgdep(i, k)*a_pgdep(i, k)
10945         a_pgdep(i, k) = fsupcol*a_pgdep(i, k)
10946         CALL POPCONTROL2B(branch)
10947         IF (branch .LT. 2) THEN
10948           IF (branch .EQ. 0) THEN
10949             a_x5 = a_pgdep(i, k)
10950             a_pgdep(i, k) = 0.0_8
10951           ELSE
10952             a_pgdep(i, k) = 0.0_8
10953             a_x5 = 0.0_8
10954           END IF
10955           CALL POPCONTROL1B(branch)
10956           IF (branch .EQ. 0) THEN
10957             a_qrs(i, k, 3) = a_qrs(i, k, 3) - a_x5/dtcld
10958             a_pgdep3 = 0.0_8
10959           ELSE
10960             a_pgdep3 = a_x5
10961           END IF
10962           a_satdt = 0.0_8
10963         ELSE
10964           IF (branch .EQ. 2) THEN
10965             a_x6 = a_pgdep(i, k)
10966             a_pgdep(i, k) = 0.0_8
10967           ELSE
10968             a_pgdep(i, k) = 0.0_8
10969             a_x6 = 0.0_8
10970           END IF
10971           CALL POPCONTROL1B(branch)
10972           IF (branch .EQ. 0) THEN
10973             a_satdt = a_x6
10974             a_pgdep3 = 0.0_8
10975           ELSE
10976             a_pgdep3 = a_x6
10977             a_satdt = 0.0_8
10978           END IF
10979         END IF
10980         a_e = (pgdep_a*a+pgdep_b*b)*a_pgdep3
10981         a_a = pgdep_a*e*a_pgdep3
10982         a_b = pgdep_b*e*a_pgdep3
10983         CALL POPREAL8(e)
10984         a_temp3 = a_e/(c+d)
10985         a_rh(i, k, 2) = a_rh(i, k, 2) + a_temp3
10986         a_temp5 = -((rh(i, k, 2)-1.)*a_temp3/(c+d))
10987         a_c = a_temp5
10988         a_d = a_temp5
10989         CALL POPREAL8(d)
10990         temp15 = t(i, k)**1.81
10991         temp14 = temp15*qs(i, k, 2)
10992         a_temp6 = diffac_b*a_d/temp14
10993         a_temp5 = -(p(i, k)*a_temp6/temp14)
10994         a_t(i, k) = a_t(i, k) + 1.81*t(i, k)**0.81*qs(i, k, 2)*a_temp5
10995         a_qs(i, k, 2) = a_qs(i, k, 2) + temp15*a_temp5
10996         CALL POPREAL8(c)
10997         temp15 = rv*t(i, k)**3.5
10998         a_temp5 = diffac_a*xls**2*a_c/temp15
10999         a_t(i, k) = a_t(i, k) + (den(i, k)-3.5*t(i, k)**2.5*rv*den(i, k)&
11000 &         *(t(i, k)+120.)/temp15)*a_temp5
11001         CALL POPREAL8(b)
11002         temp15 = (3.*bvtg+13.)/24.
11003         temp14 = den(i, k)**temp15
11004         temp13 = (bvtg+5.)/8.
11005         temp12 = max4**temp13
11006         temp11 = 1.0/3.
11007         temp10 = p(i, k)**temp11
11008         temp9 = temp10*temp12
11009         temp8 = 5.12/6.
11010         temp7 = t(i, k)**temp8
11011         temp5 = 1.0/6.
11012         temp6 = (t(i, k)+120.)**temp5/temp7
11013         a_temp7 = temp9*temp14*a_b/temp7
11014         a_temp8 = temp6*a_b
11015         IF (p(i, k) .LE. 0.0_8 .AND. (temp11 .EQ. 0.0_8 .OR. temp11 .NE.&
11016 &           INT(temp11))) THEN
11017           a_p(i, k) = a_p(i, k) + a_temp6
11018         ELSE
11019           a_p(i, k) = a_p(i, k) + a_temp6 + temp11*p(i, k)**(temp11-1)*&
11020 &           temp12*temp14*a_temp8
11021         END IF
11022         IF (den(i, k) .LE. 0.0_8 .AND. (temp15 .EQ. 0.0_8 .OR. temp15 &
11023 &           .NE. INT(temp15))) THEN
11024           a_den(i, k) = a_den(i, k) + (t(i, k)+120.)*a_temp5
11025         ELSE
11026           a_den(i, k) = a_den(i, k) + (t(i, k)+120.)*a_temp5 + temp15*&
11027 &           den(i, k)**(temp15-1)*temp9*a_temp8
11028         END IF
11029         IF (max4 .LE. 0.0_8 .AND. (temp13 .EQ. 0.0_8 .OR. temp13 .NE. &
11030 &           INT(temp13))) THEN
11031           a_max4 = 0.0_8
11032         ELSE
11033           a_max4 = temp13*max4**(temp13-1)*temp10*temp14*a_temp8
11034         END IF
11035         IF (.NOT.(t(i, k) + 120. .LE. 0.0_8 .AND. (temp5 .EQ. 0.0_8 .OR.&
11036 &           temp5 .NE. INT(temp5)))) a_t(i, k) = a_t(i, k) + temp5*(t(i&
11037 &           , k)+120.)**(temp5-1)*a_temp7
11038         IF (.NOT.(t(i, k) .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. temp8 &
11039 &           .NE. INT(temp8)))) a_t(i, k) = a_t(i, k) - temp8*t(i, k)**(&
11040 &           temp8-1)*temp6*a_temp7
11041         CALL POPCONTROL1B(branch)
11042         IF (branch .EQ. 0) THEN
11043           CALL POPREAL8(max4)
11044         ELSE
11045           CALL POPREAL8(max4)
11046           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max4
11047         END IF
11048         CALL POPREAL8(a)
11049         IF (den(i, k)*max3 .EQ. 0.0_8) THEN
11050           a_temp3 = 0.0_8
11051         ELSE
11052           a_temp3 = a_a/(2.0*SQRT(den(i, k)*max3))
11053         END IF
11054         a_den(i, k) = a_den(i, k) + max3*a_temp3
11055         a_max3 = den(i, k)*a_temp3
11056         CALL POPCONTROL1B(branch)
11057         IF (branch .EQ. 0) THEN
11058           CALL POPREAL8(max3)
11059         ELSE
11060           CALL POPREAL8(max3)
11061           a_qrs(i, k, 3) = a_qrs(i, k, 3) + a_max3
11062         END IF
11063         CALL POPREAL8(fsupcol)
11064         a_supcol = 0.0_8
11065         CALL A_SMOOTHIF(supcol, a_supcol, 0., fsupcol, a_fsupcol, 't+')
11066         CALL POPREAL8(cpm(i, k))
11067         CALL A_CPMCAL0(q(i, k), a_q(i, k), a_cpm(i, k))
11068         a_cpm(i, k) = 0.0_8
11069         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
11070         a_xl(i, k) = 0.0_8
11071         a_supsat = a_satdt/dtcld
11072         a_q(i, k) = a_q(i, k) + a_supsat
11073         a_qs(i, k, 2) = a_qs(i, k, 2) - a_supsat
11074         CALL POPREAL8ARRAY(rh(i, k, :), 3)
11075         CALL POPREAL8ARRAY(qs(i, k, :), 3)
11076         CALL A_CALCRH(t(i, k), a_t(i, k), p(i, k), a_p(i, k), q(i, k), &
11077 &               a_q(i, k), rh(i, k, :), a_rh(i, k, :), qs(i, k, :), a_qs&
11078 &               (i, k, :))
11079         CALL POPREAL8(supcol)
11080         a_t(i, k) = a_t(i, k) - a_supcol
11081         CALL POPREAL8(t(i, k))
11082         a_temp3 = dtcld*xls*a_t(i, k)/cpm(i, k)
11083         a_psdep(i, k) = a_temp3
11084         a_cpm(i, k) = a_cpm(i, k) - psdep(i, k)*a_temp3/cpm(i, k)
11085         CALL POPCONTROL1B(branch)
11086         IF (branch .EQ. 0) THEN
11087           a_qrs(i, k, 2) = 0.0_8
11088         ELSE
11089           a_psdep(i, k) = a_psdep(i, k) + dtcld*a_qrs(i, k, 2)
11090         END IF
11091         CALL POPCONTROL1B(branch)
11092         IF (branch .EQ. 0) THEN
11093           CALL POPREAL8(q(i, k))
11094           a_q(i, k) = 0.0_8
11095         ELSE
11096           CALL POPREAL8(q(i, k))
11097           a_psdep(i, k) = a_psdep(i, k) - dtcld*a_q(i, k)
11098         END IF
11099         CALL POPCONTROL1B(branch)
11100         IF (branch .NE. 0) a_psdep(i, k) = 0.0_8
11101         CALL POPREAL8(psdep(i, k))
11102         a_fsupcol = psdep(i, k)*a_psdep(i, k)
11103         a_psdep(i, k) = fsupcol*a_psdep(i, k)
11104         CALL POPCONTROL2B(branch)
11105         IF (branch .LT. 2) THEN
11106           IF (branch .EQ. 0) THEN
11107             a_x3 = a_psdep(i, k)
11108             a_psdep(i, k) = 0.0_8
11109           ELSE
11110             a_psdep(i, k) = 0.0_8
11111             a_x3 = 0.0_8
11112           END IF
11113           CALL POPCONTROL1B(branch)
11114           IF (branch .EQ. 0) THEN
11115             a_qrs(i, k, 2) = a_qrs(i, k, 2) - a_x3/dtcld
11116             a_psdep0 = 0.0_8
11117           ELSE
11118             a_psdep0 = a_x3
11119           END IF
11120           a_satdt = 0.0_8
11121         ELSE
11122           IF (branch .EQ. 2) THEN
11123             a_x4 = a_psdep(i, k)
11124             a_psdep(i, k) = 0.0_8
11125           ELSE
11126             a_psdep(i, k) = 0.0_8
11127             a_x4 = 0.0_8
11128           END IF
11129           CALL POPCONTROL1B(branch)
11130           IF (branch .EQ. 0) THEN
11131             a_satdt = a_x4
11132             a_psdep0 = 0.0_8
11133           ELSE
11134             a_psdep0 = a_x4
11135             a_satdt = 0.0_8
11136           END IF
11137         END IF
11138         a_e = (psdep_a*a+psdep_b*b)*a_psdep0
11139         a_a = psdep_a*e*a_psdep0
11140         a_b = psdep_b*e*a_psdep0
11141         CALL POPREAL8(e)
11142         a_temp3 = a_e/(c+d)
11143         a_rh(i, k, 2) = a_rh(i, k, 2) + a_temp3
11144         a_temp5 = -((rh(i, k, 2)-1.)*a_temp3/(c+d))
11145         a_c = a_temp5
11146         a_d = a_temp5
11147         CALL POPREAL8(d)
11148         temp15 = t(i, k)**1.81
11149         temp14 = temp15*qs(i, k, 2)
11150         a_temp6 = diffac_b*a_d/temp14
11151         a_temp5 = -(p(i, k)*a_temp6/temp14)
11152         a_t(i, k) = a_t(i, k) + 1.81*t(i, k)**0.81*qs(i, k, 2)*a_temp5
11153         a_qs(i, k, 2) = a_qs(i, k, 2) + temp15*a_temp5
11154         CALL POPREAL8(c)
11155         temp15 = rv*t(i, k)**3.5
11156         a_temp5 = diffac_a*xls**2*a_c/temp15
11157         CALL POPREAL8(b)
11158         temp3 = (bvts+5.)/8.
11159         temp2 = max10**temp3
11160         temp1 = 1.0/3.
11161         temp4 = p(i, k)**temp1
11162         temp5 = temp4*temp2
11163         temp6 = 5.12/6.
11164         temp7 = t(i, k)**temp6
11165         temp8 = 1.0/6.
11166         temp9 = (t(i, k)+120.)**temp8/temp7
11167         temp11 = (3.*bvts+13.)/24.
11168         temp12 = den(i, k)**temp11
11169         temp13 = (-bvts+3.)*alpha*max2/8.
11170         temp14 = EXP(temp13)
11171         a_temp2 = temp9*temp5*a_b
11172         IF (den(i, k) .LE. 0.0_8 .AND. (temp11 .EQ. 0.0_8 .OR. temp11 &
11173 &           .NE. INT(temp11))) THEN
11174           a_den(i, k) = a_den(i, k) + (t(i, k)+120.)*a_temp5
11175         ELSE
11176           a_den(i, k) = a_den(i, k) + (t(i, k)+120.)*a_temp5 + temp11*&
11177 &           den(i, k)**(temp11-1)*temp14*a_temp2
11178         END IF
11179         a_temp3 = temp14*temp12*a_b
11180         IF (p(i, k) .LE. 0.0_8 .AND. (temp1 .EQ. 0.0_8 .OR. temp1 .NE. &
11181 &           INT(temp1))) THEN
11182           a_p(i, k) = a_p(i, k) + a_temp6
11183         ELSE
11184           a_p(i, k) = a_p(i, k) + a_temp6 + temp1*p(i, k)**(temp1-1)*&
11185 &           temp2*temp9*a_temp3
11186         END IF
11187         a_temp4 = temp5*a_temp3/temp7
11188         IF (t(i, k) + 120. .LE. 0.0_8 .AND. (temp8 .EQ. 0.0_8 .OR. temp8&
11189 &           .NE. INT(temp8))) THEN
11190           a_t(i, k) = a_t(i, k) + (den(i, k)-3.5*t(i, k)**2.5*rv*den(i, &
11191 &           k)*(t(i, k)+120.)/temp15)*a_temp5
11192         ELSE
11193           a_t(i, k) = a_t(i, k) + (den(i, k)-3.5*t(i, k)**2.5*rv*den(i, &
11194 &           k)*(t(i, k)+120.)/temp15)*a_temp5 + temp8*(t(i, k)+120.)**(&
11195 &           temp8-1)*a_temp4
11196         END IF
11197         IF (max10 .LE. 0.0_8 .AND. (temp3 .EQ. 0.0_8 .OR. temp3 .NE. INT&
11198 &           (temp3))) THEN
11199           a_max10 = 0.0_8
11200         ELSE
11201           a_max10 = temp3*max10**(temp3-1)*temp4*temp9*a_temp3
11202         END IF
11203         IF (.NOT.(t(i, k) .LE. 0.0_8 .AND. (temp6 .EQ. 0.0_8 .OR. temp6 &
11204 &           .NE. INT(temp6)))) a_t(i, k) = a_t(i, k) - temp6*t(i, k)**(&
11205 &           temp6-1)*temp9*a_temp4
11206         a_max2 = (3.-bvts)*alpha*EXP(temp13)*temp12*a_temp2/8.
11207         CALL POPCONTROL1B(branch)
11208         IF (branch .EQ. 0) THEN
11209           CALL POPREAL8(max10)
11210         ELSE
11211           CALL POPREAL8(max10)
11212           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max10
11213         END IF
11214         CALL POPCONTROL1B(branch)
11215         IF (branch .EQ. 0) THEN
11216           CALL POPREAL8(max2)
11217           a_y2 = 0.0_8
11218         ELSE
11219           CALL POPREAL8(max2)
11220           a_y2 = a_max2
11221         END IF
11222         CALL POPCONTROL1B(branch)
11223         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y2
11224         CALL POPREAL8(a)
11225         temp3 = den(i, k)*max9
11226         temp2 = SQRT(temp3)
11227         temp1 = alpha*max1/2.
11228         a_max1 = alpha*EXP(temp1)*temp2*a_a/2.
11229         IF (temp3 .EQ. 0.0_8) THEN
11230           a_temp0 = 0.0_8
11231         ELSE
11232           a_temp0 = EXP(temp1)*a_a/(2.0*temp2)
11233         END IF
11234         a_den(i, k) = a_den(i, k) + max9*a_temp0
11235         a_max9 = den(i, k)*a_temp0
11236         CALL POPCONTROL1B(branch)
11237         IF (branch .EQ. 0) THEN
11238           CALL POPREAL8(max9)
11239         ELSE
11240           CALL POPREAL8(max9)
11241           a_qrs(i, k, 2) = a_qrs(i, k, 2) + a_max9
11242         END IF
11243         CALL POPCONTROL1B(branch)
11244         IF (branch .EQ. 0) THEN
11245           CALL POPREAL8(max1)
11246           a_y1 = 0.0_8
11247         ELSE
11248           CALL POPREAL8(max1)
11249           a_y1 = a_max1
11250         END IF
11251         CALL POPCONTROL1B(branch)
11252         IF (branch .EQ. 0) a_t(i, k) = a_t(i, k) - a_y1
11253         CALL POPREAL8(fsupcol)
11254         a_supcol = 0.0_8
11255         CALL A_SMOOTHIF(supcol, a_supcol, 0., fsupcol, a_fsupcol, 't+')
11256         CALL POPREAL8(cpm(i, k))
11257         CALL A_CPMCAL0(q(i, k), a_q(i, k), a_cpm(i, k))
11258         a_cpm(i, k) = 0.0_8
11259         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
11260         a_xl(i, k) = 0.0_8
11261         a_supsat = a_satdt/dtcld
11262         a_q(i, k) = a_q(i, k) + a_supsat
11263         a_qs(i, k, 2) = a_qs(i, k, 2) - a_supsat
11264         CALL POPREAL8ARRAY(rh(i, k, :), 3)
11265         CALL POPREAL8ARRAY(qs(i, k, :), 3)
11266         CALL A_CALCRH(t(i, k), a_t(i, k), p(i, k), a_p(i, k), q(i, k), &
11267 &               a_q(i, k), rh(i, k, :), a_rh(i, k, :), qs(i, k, :), a_qs&
11268 &               (i, k, :))
11269         CALL POPREAL8(supcol)
11270         a_t(i, k) = a_t(i, k) - a_supcol
11271         CALL POPREAL8(t(i, k))
11272         a_temp0 = dtcld*xls*a_t(i, k)/cpm(i, k)
11273         a_pidep(i, k) = a_temp0
11274         a_cpm(i, k) = a_cpm(i, k) - pidep(i, k)*a_temp0/cpm(i, k)
11275         CALL POPCONTROL1B(branch)
11276         IF (branch .EQ. 0) THEN
11277           CALL POPREAL8(qci(i, k, 2))
11278           a_qci(i, k, 2) = 0.0_8
11279         ELSE
11280           CALL POPREAL8(qci(i, k, 2))
11281           a_pidep(i, k) = a_pidep(i, k) + dtcld*a_qci(i, k, 2)
11282         END IF
11283         CALL POPCONTROL1B(branch)
11284         IF (branch .EQ. 0) THEN
11285           CALL POPREAL8(q(i, k))
11286           a_q(i, k) = 0.0_8
11287         ELSE
11288           CALL POPREAL8(q(i, k))
11289           a_pidep(i, k) = a_pidep(i, k) - dtcld*a_q(i, k)
11290         END IF
11291         CALL POPCONTROL1B(branch)
11292         IF (branch .NE. 0) a_pidep(i, k) = 0.0_8
11293         CALL POPREAL8(pidep(i, k))
11294         a_fsupcol = pidep(i, k)*a_pidep(i, k)
11295         a_pidep(i, k) = fsupcol*a_pidep(i, k)
11296         CALL POPCONTROL2B(branch)
11297         IF (branch .LT. 2) THEN
11298           IF (branch .EQ. 0) THEN
11299             a_x1 = a_pidep(i, k)
11300             a_pidep(i, k) = 0.0_8
11301           ELSE
11302             a_pidep(i, k) = 0.0_8
11303             a_x1 = 0.0_8
11304           END IF
11305           CALL POPCONTROL1B(branch)
11306           IF (branch .EQ. 0) THEN
11307             a_qci(i, k, 2) = a_qci(i, k, 2) - a_x1/dtcld
11308             a_pidep0 = 0.0_8
11309           ELSE
11310             a_pidep0 = a_x1
11311           END IF
11312           a_satdt = 0.0_8
11313         ELSE
11314           IF (branch .EQ. 2) THEN
11315             a_x2 = a_pidep(i, k)
11316             a_pidep(i, k) = 0.0_8
11317           ELSE
11318             a_pidep(i, k) = 0.0_8
11319             a_x2 = 0.0_8
11320           END IF
11321           CALL POPCONTROL1B(branch)
11322           IF (branch .EQ. 0) THEN
11323             a_satdt = a_x2
11324             a_pidep0 = 0.0_8
11325           ELSE
11326             a_pidep0 = a_x2
11327             a_satdt = 0.0_8
11328           END IF
11329         END IF
11330         CALL POPCONTROL1B(branch)
11331         IF (branch .EQ. 0) THEN
11332           temp3 = 7./8.
11333           temp2 = den(i, k)*qci(i, k, 2)
11334           a_a = temp2**temp3*pidep_a*a_pidep0
11335           IF (temp2 .LE. 0.0_8 .AND. (temp3 .EQ. 0.0_8 .OR. temp3 .NE. &
11336 &             INT(temp3))) THEN
11337             a_temp = 0.0_8
11338           ELSE
11339             a_temp = temp3*temp2**(temp3-1)*a*pidep_a*a_pidep0
11340           END IF
11341           a_den(i, k) = a_den(i, k) + qci(i, k, 2)*a_temp
11342           a_qci(i, k, 2) = a_qci(i, k, 2) + den(i, k)*a_temp
11343           CALL POPREAL8(a)
11344           a_temp0 = a_a/(b+c)
11345           a_rh(i, k, 2) = a_rh(i, k, 2) + a_temp0
11346           a_temp = -((rh(i, k, 2)-1.)*a_temp0/(b+c))
11347           a_b = a_temp
11348           a_c = a_temp
11349           CALL POPREAL8(c)
11350           temp2 = t(i, k)**1.81
11351           temp1 = temp2*qs(i, k, 2)
11352           a_temp0 = diffac_b*a_c/temp1
11353           a_p(i, k) = a_p(i, k) + a_temp0
11354           a_temp1 = -(p(i, k)*a_temp0/temp1)
11355           a_qs(i, k, 2) = a_qs(i, k, 2) + temp2*a_temp1
11356           CALL POPREAL8(b)
11357           temp1 = rv*t(i, k)**3.5
11358           a_temp = diffac_a*xls**2*a_b/temp1
11359           a_t(i, k) = a_t(i, k) + 1.81*t(i, k)**0.81*qs(i, k, 2)*a_temp1&
11360 &           + (den(i, k)-3.5*t(i, k)**2.5*rv*den(i, k)*(t(i, k)+120.)/&
11361 &           temp1)*a_temp
11362           a_den(i, k) = a_den(i, k) + (t(i, k)+120.)*a_temp
11363         END IF
11364         CALL POPREAL8(fsupcol)
11365         a_supcol = 0.0_8
11366         CALL A_SMOOTHIF(supcol, a_supcol, 0., fsupcol, a_fsupcol, 't+')
11367         CALL A_CPMCAL0(q(i, k), a_q(i, k), a_cpm(i, k))
11368         a_cpm(i, k) = 0.0_8
11369         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
11370         a_xl(i, k) = 0.0_8
11371         a_supsat = a_satdt/dtcld
11372         CALL POPREAL8(supsat)
11373         a_q(i, k) = a_q(i, k) + a_supsat
11374         a_qs(i, k, 2) = a_qs(i, k, 2) - a_supsat
11375         CALL POPREAL8ARRAY(qs(i, k, :), 3)
11376         CALL A_CALCRH(t(i, k), a_t(i, k), p(i, k), a_p(i, k), q(i, k), &
11377 &               a_q(i, k), rh(i, k, :), a_rh(i, k, :), qs(i, k, :), a_qs&
11378 &               (i, k, :))
11379         CALL POPREAL8(supcol)
11380         a_t(i, k) = a_t(i, k) - a_supcol
11381       END DO
11382     END DO
11383   END SUBROUTINE A_ACCRET3
11384
11385 !=======================================================================
11386 !
11387 !=======================================================================
11388   SUBROUTINE ACCRET3(qrs, qci, rh, t, p, den, dtcld, q, qs, psdep, pgdep&
11389 &   , pigen, psaut, pgaut, psevp, pgevp, pidep, ims, ime, kms, kme, its&
11390 &   , ite, kts, kte)
11391     IMPLICIT NONE
11392     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
11393 !-------------------------------------------------------------------
11394     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
11395     REAL, DIMENSION(ims:ime, kms:kme) :: den, q, p
11396     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, rh, qs
11397     REAL, DIMENSION(its:ite, kts:kte) :: pigen, psevp, pgevp, pidep, t, &
11398 &   xl, cpm, psdep, pgdep, psaut, pgaut
11399     REAL :: supcol, dtcld, satdt, supsat, qimax, diameter, xni0, roqi0, &
11400 &   supice1, supice2, supice3, supice4, alpha2
11401     REAL :: pidep0, pidep1, psdep0, pgdep3, pigen0, psevp0, pgevp0, &
11402 &   coeres1, coeres2, coeres3, coeres4
11403     REAL :: temp0, temp, xmi
11404     INTEGER :: i, k
11405     REAL :: fqi, fqr, fqv, fqs, fqg, frh, ft0, fpidep, fpsdep, fpgdep, &
11406 &   fsupcol, fsupsat, pidep2
11407     REAL :: value01, factor01, source01, vice, a, b, c, d, e, f, g
11408     INTRINSIC MAX
11409     INTRINSIC MIN
11410     INTRINSIC ABS
11411     INTRINSIC EXP
11412     INTRINSIC SQRT
11413     REAL :: x1
11414     REAL :: x2
11415     REAL :: y1
11416     REAL :: y2
11417     REAL :: x3
11418     REAL :: x4
11419     REAL :: x5
11420     REAL :: x6
11421     REAL :: x7
11422     REAL :: x8
11423     REAL :: y3
11424     REAL :: y4
11425     REAL :: x9
11426     REAL :: x10
11427     REAL :: abs0
11428     REAL :: max1
11429     REAL :: max2
11430     REAL :: abs1
11431     REAL :: max3
11432     REAL :: max4
11433     REAL :: abs2
11434     REAL :: abs3
11435     REAL :: abs4
11436     REAL :: abs5
11437     REAL :: max5
11438     REAL :: max6
11439     REAL :: abs6
11440     REAL :: max7
11441     REAL :: max8
11442     REAL :: abs7
11443     REAL :: max9
11444     REAL :: max10
11445     REAL :: max11
11446     REAL :: max12
11447     REAL :: max13
11448     DO k=kts,kte
11449       DO i=its,ite
11450 !
11451 !-------------------------------------------------------------
11452 ! pidep: Deposition/Sublimation rate of ice [HDC 9]
11453 !       (T<T0: V->I or I->V)
11454 !       rh(i,k,2)>1.,pidep>0: V->I, min=0,        max=satdt
11455 !       rh(i,k,2)<1.,pidep<0: I->V, min=-qi/dtcld,max=0,
11456 !-------------------------------------------------------------
11457 !update supcol
11458         supcol = t0c - t(i, k)
11459 !update rh qs
11460         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
11461 !update satdt
11462         supsat = q(i, k) - qs(i, k, 2)
11463         satdt = supsat/dtcld
11464 !update xl, cpm
11465         xl(i, k) = XLCAL(t(i, k))
11466         cpm(i, k) = CPMCAL(q(i, k))
11467         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
11468         IF (qci(i, k, 2) .GT. 0.) THEN
11469           b = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5
11470           c = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2)
11471           a = (rh(i, k, 2)-1.)/(b+c)
11472           pidep0 = pidep_a*a*(den(i, k)*qci(i, k, 2))**(7./8.)
11473         ELSE
11474           pidep0 = 0.
11475         END IF
11476         IF (pidep0 .LT. 0.) THEN
11477           IF (pidep0 .LT. -(qci(i, k, 2)/dtcld)) THEN
11478             x1 = -(qci(i, k, 2)/dtcld)
11479           ELSE
11480             x1 = pidep0
11481           END IF
11482           IF (x1 .GT. 0.) THEN
11483             pidep(i, k) = 0.
11484           ELSE
11485             pidep(i, k) = x1
11486           END IF
11487         ELSE
11488           IF (pidep0 .GT. satdt) THEN
11489             x2 = satdt
11490           ELSE
11491             x2 = pidep0
11492           END IF
11493           IF (x2 .LT. 0.) THEN
11494             pidep(i, k) = 0.
11495           ELSE
11496             pidep(i, k) = x2
11497           END IF
11498         END IF
11499         pidep(i, k) = fsupcol*pidep(i, k)
11500         IF (pidep(i, k) .GE. 0.) THEN
11501           abs0 = pidep(i, k)
11502         ELSE
11503           abs0 = -pidep(i, k)
11504         END IF
11505         IF (abs0 .LT. qmin/dtcld) pidep(i, k) = 0.
11506         IF (q(i, k) - pidep(i, k)*dtcld .LT. 0.) THEN
11507           q(i, k) = 0.
11508         ELSE
11509           q(i, k) = q(i, k) - pidep(i, k)*dtcld
11510         END IF
11511         IF (qci(i, k, 2) + pidep(i, k)*dtcld .LT. 0.) THEN
11512           qci(i, k, 2) = 0.
11513         ELSE
11514           qci(i, k, 2) = qci(i, k, 2) + pidep(i, k)*dtcld
11515         END IF
11516         t(i, k) = t(i, k) + pidep(i, k)*dtcld*xls/cpm(i, k)
11517         pidep(i, k) = 0.
11518 !
11519 !-------------------------------------------------------------
11520 ! psdep: deposition/sublimation rate of snow [HDC 14]
11521 !        (T<T0: V->S or S->V)
11522 !       rh(i,k,2)>1.,psdep>0: V->S, min=0,        max=satdt
11523 !       rh(i,k,2)<1.,psdep<0: S->V, min=-qs/dtcld,max=0,
11524 !-------------------------------------------------------------
11525 !update supcol
11526         supcol = t0c - t(i, k)
11527 !update rh qs
11528         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
11529 !update satdt
11530         supsat = q(i, k) - qs(i, k, 2)
11531         satdt = supsat/dtcld
11532 !update xl, cpm
11533         xl(i, k) = XLCAL(t(i, k))
11534         cpm(i, k) = CPMCAL(q(i, k))
11535         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
11536         IF (90. .GT. t0c - t(i, k)) THEN
11537           y1 = t0c - t(i, k)
11538         ELSE
11539           y1 = 90.
11540         END IF
11541         IF (0. .LT. y1) THEN
11542           max1 = y1
11543         ELSE
11544           max1 = 0.
11545         END IF
11546         IF (qrs(i, k, 2) .LT. qcrmin) THEN
11547           max9 = qcrmin
11548         ELSE
11549           max9 = qrs(i, k, 2)
11550         END IF
11551 !         call smoothif(qrs(i,k,2),0.,fqs,'q+')
11552 !         call smoothif(q  (i,k  ),0.,fqv,'q+')
11553         a = EXP(alpha*max1/2.)*SQRT(den(i, k)*max9)
11554         IF (90. .GT. t0c - t(i, k)) THEN
11555           y2 = t0c - t(i, k)
11556         ELSE
11557           y2 = 90.
11558         END IF
11559         IF (0. .LT. y2) THEN
11560           max2 = y2
11561         ELSE
11562           max2 = 0.
11563         END IF
11564         IF (qrs(i, k, 2) .LT. qcrmin) THEN
11565           max10 = qcrmin
11566         ELSE
11567           max10 = qrs(i, k, 2)
11568         END IF
11569         b = EXP((3.-bvts)*alpha*max2/8.)*(t(i, k)+120.)**(1./6.)/t(i, k)&
11570 &         **(5.12/6.)*p(i, k)**(1./3.)*den(i, k)**((13.+3.*bvts)/24.)*&
11571 &         max10**((5.+bvts)/8.)
11572         c = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5
11573         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2)
11574         e = (rh(i, k, 2)-1.)/(c+d)
11575         psdep0 = e*(psdep_a*a+psdep_b*b)
11576         IF (psdep0 .LT. 0.) THEN
11577           IF (psdep0 .LT. -(qrs(i, k, 2)/dtcld)) THEN
11578             x3 = -(qrs(i, k, 2)/dtcld)
11579           ELSE
11580             x3 = psdep0
11581           END IF
11582           IF (x3 .GT. 0.) THEN
11583             psdep(i, k) = 0.
11584           ELSE
11585             psdep(i, k) = x3
11586           END IF
11587         ELSE
11588           IF (psdep0 .GT. satdt) THEN
11589             x4 = satdt
11590           ELSE
11591             x4 = psdep0
11592           END IF
11593           IF (x4 .LT. 0.) THEN
11594             psdep(i, k) = 0.
11595           ELSE
11596             psdep(i, k) = x4
11597           END IF
11598         END IF
11599         psdep(i, k) = fsupcol*psdep(i, k)
11600         IF (psdep(i, k) .GE. 0.) THEN
11601           abs1 = psdep(i, k)
11602         ELSE
11603           abs1 = -psdep(i, k)
11604         END IF
11605         IF (abs1 .LT. qmin/dtcld) psdep(i, k) = 0.
11606         IF (q(i, k) - psdep(i, k)*dtcld .LT. 0.) THEN
11607           q(i, k) = 0.
11608         ELSE
11609           q(i, k) = q(i, k) - psdep(i, k)*dtcld
11610         END IF
11611         IF (qrs(i, k, 2) + psdep(i, k)*dtcld .LT. 0.) THEN
11612           qrs(i, k, 2) = 0.
11613         ELSE
11614           qrs(i, k, 2) = qrs(i, k, 2) + psdep(i, k)*dtcld
11615         END IF
11616         t(i, k) = t(i, k) + psdep(i, k)*dtcld*xls/cpm(i, k)
11617         psdep(i, k) = 0.
11618 !
11619 !------------------------------------------------------------
11620 ! pgdep: deposition/sublimation rate of graupel [LFO 46]
11621 !        (T<T0: V->G or G->V)
11622 !       rh(i,k,2)>1.,pgdep>0: V->G, min=0,        max=satdt
11623 !       rh(i,k,2)<1.,pgdep<0: G->V, min=-qg/dtcld,max=0,
11624 !------------------------------------------------------------
11625 !update supcol
11626         supcol = t0c - t(i, k)
11627 !update rh qs
11628         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
11629 !update satdt
11630         supsat = q(i, k) - qs(i, k, 2)
11631         satdt = supsat/dtcld
11632 !update xl, cpm
11633         xl(i, k) = XLCAL(t(i, k))
11634         cpm(i, k) = CPMCAL(q(i, k))
11635         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
11636         IF (qrs(i, k, 3) .LT. qcrmin) THEN
11637           max3 = qcrmin
11638         ELSE
11639           max3 = qrs(i, k, 3)
11640         END IF
11641 !         call smoothif(qrs(i,k,3),0.,fqg,'q+')
11642 !         call smoothif(q  (i,k  ),0.,fqv,'q+')
11643         a = SQRT(den(i, k)*max3)
11644         IF (qrs(i, k, 3) .LT. qcrmin) THEN
11645           max4 = qcrmin
11646         ELSE
11647           max4 = qrs(i, k, 3)
11648         END IF
11649         b = (t(i, k)+120.)**(1./6.)/t(i, k)**(5.12/6.)*p(i, k)**(1./3.)*&
11650 &         den(i, k)**((13.+3.*bvtg)/24.)*max4**((5.+bvtg)/8.)
11651         c = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5
11652         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2)
11653         e = (rh(i, k, 2)-1.)/(c+d)
11654         pgdep3 = e*(pgdep_a*a+pgdep_b*b)
11655         IF (pgdep3 .LT. 0.) THEN
11656           IF (pgdep3 .LT. -(qrs(i, k, 3)/dtcld)) THEN
11657             x5 = -(qrs(i, k, 3)/dtcld)
11658           ELSE
11659             x5 = pgdep3
11660           END IF
11661           IF (x5 .GT. 0.) THEN
11662             pgdep(i, k) = 0.
11663           ELSE
11664             pgdep(i, k) = x5
11665           END IF
11666         ELSE
11667           IF (pgdep3 .GT. satdt) THEN
11668             x6 = satdt
11669           ELSE
11670             x6 = pgdep3
11671           END IF
11672           IF (x6 .LT. 0.) THEN
11673             pgdep(i, k) = 0.
11674           ELSE
11675             pgdep(i, k) = x6
11676           END IF
11677         END IF
11678         pgdep(i, k) = fsupcol*pgdep(i, k)
11679         IF (pgdep(i, k) .GE. 0.) THEN
11680           abs2 = pgdep(i, k)
11681         ELSE
11682           abs2 = -pgdep(i, k)
11683         END IF
11684         IF (abs2 .LT. qmin/dtcld) pgdep(i, k) = 0.
11685         IF (q(i, k) - pgdep(i, k)*dtcld .LT. 0.) THEN
11686           q(i, k) = 0.
11687         ELSE
11688           q(i, k) = q(i, k) - pgdep(i, k)*dtcld
11689         END IF
11690         IF (qrs(i, k, 3) + pgdep(i, k)*dtcld .LT. 0.) THEN
11691           qrs(i, k, 3) = 0.
11692         ELSE
11693           qrs(i, k, 3) = qrs(i, k, 3) + pgdep(i, k)*dtcld
11694         END IF
11695         t(i, k) = t(i, k) + pgdep(i, k)*dtcld*xls/cpm(i, k)
11696         pgdep(i, k) = 0.
11697 !-------------------------------------------------------------
11698 ! pigen: generation(nucleation) of ice from vapor [HDC 7-8]
11699 !       (T<T0: V->I) min=0,max=min(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld,satdt)
11700 !-------------------------------------------------------------
11701 !update supcol
11702         supcol = t0c - t(i, k)
11703         cpm(i, k) = CPMCAL(q(i, k))
11704 !update rh qs
11705         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
11706 !update satdt
11707         supsat = q(i, k) - qs(i, k, 2)
11708         satdt = supsat/dtcld
11709         CALL SMOOTHIF(supsat, 0., fsupsat, 'q+')
11710         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
11711         xni0 = 1.e3*EXP(0.1*supcol)
11712         roqi0 = 4.92e-11*xni0**1.33
11713         IF (qci(i, k, 2) .LT. 0.) THEN
11714           max11 = 0.
11715         ELSE
11716           max11 = qci(i, k, 2)
11717         END IF
11718         x7 = (roqi0/den(i, k)-max11)/dtcld
11719         IF (x7 .GT. satdt) THEN
11720           pigen0 = satdt
11721         ELSE
11722           pigen0 = x7
11723         END IF
11724         IF (pigen0 .LT. 0.) THEN
11725           pigen(i, k) = 0.
11726         ELSE
11727           pigen(i, k) = pigen0
11728         END IF
11729         pigen(i, k) = fsupcol*fsupsat*pigen(i, k)
11730         IF (pigen(i, k) .GE. 0.) THEN
11731           abs3 = pigen(i, k)
11732         ELSE
11733           abs3 = -pigen(i, k)
11734         END IF
11735         IF (abs3 .LT. qmin/dtcld) pigen(i, k) = 0.
11736         IF (q(i, k) - pigen(i, k)*dtcld .LT. 0.) THEN
11737           q(i, k) = 0.
11738         ELSE
11739           q(i, k) = q(i, k) - pigen(i, k)*dtcld
11740         END IF
11741         IF (qci(i, k, 2) + pigen(i, k)*dtcld .LT. 0.) THEN
11742           qci(i, k, 2) = 0.
11743         ELSE
11744           qci(i, k, 2) = qci(i, k, 2) + pigen(i, k)*dtcld
11745         END IF
11746         t(i, k) = t(i, k) + pigen(i, k)*dtcld*xls/cpm(i, k)
11747         pigen(i, k) = 0.
11748 !
11749 !------------------------------------------------------------
11750 ! psaut: conversion(aggregation) of ice to snow [HDC 12]
11751 !        (T<T0: I->S) psaut>0, min=0,max=(qci(i,k,2)-qimax)/dtcld
11752 !-------------------------------------------------------------
11753 !update supcol
11754         supcol = t0c - t(i, k)
11755         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
11756 !         call smoothif(qci(i,k,2),0.,fqi,'q+')
11757         qimax = roqimax/den(i, k)
11758         IF (0. .LT. (qci(i, k, 2)-qimax)/dtcld) THEN
11759           psaut(i, k) = (qci(i, k, 2)-qimax)/dtcld
11760         ELSE
11761           psaut(i, k) = 0.
11762         END IF
11763         psaut(i, k) = fsupcol*psaut(i, k)
11764         IF (psaut(i, k) .GE. 0.) THEN
11765           abs4 = psaut(i, k)
11766         ELSE
11767           abs4 = -psaut(i, k)
11768         END IF
11769         IF (abs4 .LT. qmin/dtcld) psaut(i, k) = 0.
11770         IF (qci(i, k, 2) - psaut(i, k)*dtcld .LT. 0.) THEN
11771           qci(i, k, 2) = 0.
11772         ELSE
11773           qci(i, k, 2) = qci(i, k, 2) - psaut(i, k)*dtcld
11774         END IF
11775         IF (qrs(i, k, 2) + psaut(i, k)*dtcld .LT. 0.) THEN
11776           qrs(i, k, 2) = 0.
11777         ELSE
11778           qrs(i, k, 2) = qrs(i, k, 2) + psaut(i, k)*dtcld
11779         END IF
11780         psaut(i, k) = 0.
11781 !
11782 !-------------------------------------------------------------
11783 ! pgaut: conversion(aggregation) of snow to graupel [LFO 37]
11784 !        (T<T0: S->G) pgaut>0 min=0.,max=qrs(i,k,2)/dtcld
11785 !-------------------------------------------------------------
11786 !update supcol
11787 !         supcol = t0c-t(i,k) ! not change
11788 !         call smoothif(supcol,0.,fsupcol,'t0')
11789 !         call smoothif(qrs(i,k,2),0.,fqs,'q+')
11790         alpha2 = 1.e-3*EXP(0.09*(-supcol))
11791         IF (0. .LT. alpha2*(qrs(i, k, 2)-qs0)) THEN
11792           x8 = alpha2*(qrs(i, k, 2)-qs0)
11793         ELSE
11794           x8 = 0.
11795         END IF
11796         IF (x8 .GT. qrs(i, k, 2)/dtcld) THEN
11797           pgaut(i, k) = qrs(i, k, 2)/dtcld
11798         ELSE
11799           pgaut(i, k) = x8
11800         END IF
11801         pgaut(i, k) = fsupcol*pgaut(i, k)
11802         IF (pgaut(i, k) .GE. 0.) THEN
11803           abs5 = pgaut(i, k)
11804         ELSE
11805           abs5 = -pgaut(i, k)
11806         END IF
11807         IF (abs5 .LT. qmin/dtcld) pgaut(i, k) = 0.
11808         IF (qrs(i, k, 2) - pgaut(i, k)*dtcld .LT. 0.) THEN
11809           qrs(i, k, 2) = 0.
11810         ELSE
11811           qrs(i, k, 2) = qrs(i, k, 2) - pgaut(i, k)*dtcld
11812         END IF
11813         IF (qrs(i, k, 3) + pgaut(i, k)*dtcld .LT. 0.) THEN
11814           qrs(i, k, 3) = 0.
11815         ELSE
11816           qrs(i, k, 3) = qrs(i, k, 3) + pgaut(i, k)*dtcld
11817         END IF
11818         pgaut(i, k) = 0.
11819 !
11820 !-------------------------------------------------------------
11821 ! psevp: Evaporation of melting snow [RH83 A27]
11822 !       (T>=T0: S->V) rh<1., psevp<0, min=-qrs(i,k,2)/dtcld, max=0.
11823 !-------------------------------------------------------------
11824 !         supcol = t0c-t(i,k) ! not change
11825 !update rh qs
11826         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
11827 !update xl, cpm
11828         xl(i, k) = XLCAL(t(i, k))
11829         cpm(i, k) = CPMCAL(q(i, k))
11830         CALL SMOOTHIF(t(i, k), t0c, ft0, 't+')
11831         IF (90. .GT. t0c - t(i, k)) THEN
11832           y3 = t0c - t(i, k)
11833         ELSE
11834           y3 = 90.
11835         END IF
11836         IF (0. .LT. y3) THEN
11837           max5 = y3
11838         ELSE
11839           max5 = 0.
11840         END IF
11841         IF (qrs(i, k, 2) .LT. qcrmin) THEN
11842           max12 = qcrmin
11843         ELSE
11844           max12 = qrs(i, k, 2)
11845         END IF
11846         a = EXP(alpha*max5/2.)*SQRT(den(i, k)*max12)
11847         IF (90. .GT. t0c - t(i, k)) THEN
11848           y4 = t0c - t(i, k)
11849         ELSE
11850           y4 = 90.
11851         END IF
11852         IF (0. .LT. y4) THEN
11853           max6 = y4
11854         ELSE
11855           max6 = 0.
11856         END IF
11857         IF (qrs(i, k, 2) .LT. qcrmin) THEN
11858           max13 = qcrmin
11859         ELSE
11860           max13 = qrs(i, k, 2)
11861         END IF
11862         b = EXP((3.-bvts)*alpha*max6/8.)*(t(i, k)+120.)**(1./6.)/t(i, k)&
11863 &         **(5.12/6.)*p(i, k)**(1./3.)*den(i, k)**((13.+3.*bvts)/24.)*&
11864 &         max13**((5.+bvts)/8.)
11865         c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, &
11866 &         k)**3.5
11867         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1)
11868         e = (rh(i, k, 1)-1.)/(c+d)
11869         psevp0 = e*(psevp_a*a+psevp_b*b)
11870         IF (psevp0 .LT. -(qrs(i, k, 2)/dtcld)) THEN
11871           x9 = -(qrs(i, k, 2)/dtcld)
11872         ELSE
11873           x9 = psevp0
11874         END IF
11875         IF (x9 .GT. 0.) THEN
11876           psevp(i, k) = 0.
11877         ELSE
11878           psevp(i, k) = x9
11879         END IF
11880         psevp(i, k) = ft0*psevp(i, k)
11881         IF (psevp(i, k) .GE. 0.) THEN
11882           abs6 = psevp(i, k)
11883         ELSE
11884           abs6 = -psevp(i, k)
11885         END IF
11886         IF (abs6 .LT. qmin/dtcld) psevp(i, k) = 0.
11887         IF (q(i, k) - psevp(i, k)*dtcld .LT. 0.) THEN
11888           q(i, k) = 0.
11889         ELSE
11890           q(i, k) = q(i, k) - psevp(i, k)*dtcld
11891         END IF
11892         IF (qrs(i, k, 2) + psevp(i, k)*dtcld .LT. 0.) THEN
11893           qrs(i, k, 2) = 0.
11894         ELSE
11895           qrs(i, k, 2) = qrs(i, k, 2) + psevp(i, k)*dtcld
11896         END IF
11897         t(i, k) = t(i, k) + psevp(i, k)*dtcld*xls/cpm(i, k)
11898         psevp(i, k) = 0.
11899 !
11900 !-------------------------------------------------------------
11901 ! pgevp: Evaporation of melting graupel [RH84 A19]
11902 !       (T>=T0: G->V) rh<1., pgevp<0, min=-qrs(i,k,3)/dtcld, max=0.
11903 !-------------------------------------------------------------
11904         supcol = t0c - t(i, k)
11905 !update rh qs
11906         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
11907 !update xl, cpm
11908         xl(i, k) = XLCAL(t(i, k))
11909         cpm(i, k) = CPMCAL(q(i, k))
11910         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
11911         IF (qrs(i, k, 3) .LT. qcrmin) THEN
11912           max7 = qcrmin
11913         ELSE
11914           max7 = qrs(i, k, 3)
11915         END IF
11916         a = SQRT(den(i, k)*max7)
11917         IF (qrs(i, k, 3) .LT. qcrmin) THEN
11918           max8 = qcrmin
11919         ELSE
11920           max8 = qrs(i, k, 3)
11921         END IF
11922         b = (t(i, k)+120.)**(1./6.)/t(i, k)**(5.12/6.)*p(i, k)**(1./3.)*&
11923 &         den(i, k)**((13.+3.*bvtg)/24.)*max8**((5.+bvtg)/8.)
11924         c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, &
11925 &         k)**3.5
11926         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1)
11927         e = (rh(i, k, 1)-1.)/(c+d)
11928         pgevp0 = e*(pgevp_a*a+pgevp_b*b)
11929         IF (pgevp0 .LT. -(qrs(i, k, 3)/dtcld)) THEN
11930           x10 = -(qrs(i, k, 3)/dtcld)
11931         ELSE
11932           x10 = pgevp0
11933         END IF
11934         IF (x10 .GT. 0.) THEN
11935           pgevp(i, k) = 0.
11936         ELSE
11937           pgevp(i, k) = x10
11938         END IF
11939         pgevp(i, k) = ft0*pgevp(i, k)
11940         IF (pgevp(i, k) .GE. 0.) THEN
11941           abs7 = pgevp(i, k)
11942         ELSE
11943           abs7 = -pgevp(i, k)
11944         END IF
11945         IF (abs7 .LT. qmin/dtcld) pgevp(i, k) = 0.
11946         IF (q(i, k) - pgevp(i, k)*dtcld .LT. 0.) THEN
11947           q(i, k) = 0.
11948         ELSE
11949           q(i, k) = q(i, k) - pgevp(i, k)*dtcld
11950         END IF
11951         IF (qrs(i, k, 3) + pgevp(i, k)*dtcld .LT. 0.) THEN
11952           qrs(i, k, 3) = 0.
11953         ELSE
11954           qrs(i, k, 3) = qrs(i, k, 3) + pgevp(i, k)*dtcld
11955         END IF
11956         t(i, k) = t(i, k) + pgevp(i, k)*dtcld*xls/cpm(i, k)
11957         pgevp(i, k) = 0.
11958       END DO
11959     END DO
11960   END SUBROUTINE ACCRET3
11961
11962 !  Differentiation of pconadd in reverse (adjoint) mode (with options r8):
11963 !   gradient     of useful results: p q t qs cpm xl qci
11964 !   with respect to varying inputs: p q t qs cpm xl qci
11965 !=======================================================================
11966 !
11967 !=======================================================================
11968   SUBROUTINE A_PCONADD(t, a_t, p, a_p, q, a_q, qci, a_qci, qs, a_qs, xl&
11969 &   , a_xl, cpm, a_cpm, dtcld, kte, kts, its, ite, kme, kms, ims, ime)
11970     IMPLICIT NONE
11971     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
11972     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
11973     REAL, DIMENSION(its:ite, kts:kte, 2) :: a_qci
11974     REAL, DIMENSION(its:ite, kts:kte) :: t, xl, pcond, work2, cpm
11975     REAL, DIMENSION(its:ite, kts:kte) :: a_t, a_xl, a_pcond, a_cpm
11976     REAL, DIMENSION(its:ite, kts:kte, 3) :: qs, work1, rh
11977     REAL, DIMENSION(its:ite, kts:kte, 3) :: a_qs, a_work1, a_rh
11978     REAL, DIMENSION(ims:ime, kms:kme) :: q, p
11979     REAL, DIMENSION(ims:ime, kms:kme) :: a_q, a_p
11980     INTEGER :: k, i
11981     REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, &
11982 &   dtcld, qs1, qs2, qs3, qs4, w1, q1
11983     REAL :: tmp1, tmp2, f1, f2, qs0
11984     INTRINSIC MAX
11985     INTRINSIC MIN
11986     INTRINSIC ABS
11987     REAL :: y1
11988     REAL :: a_y1
11989     REAL :: min1
11990     REAL :: a_min1
11991     REAL :: max1
11992     REAL :: a_max1
11993     REAL :: abs0
11994     REAL :: a_temp
11995     INTEGER :: branch
11996     DO k=kts,kte
11997       DO i=its,ite
11998 !update qs
11999         CALL PUSHREAL8ARRAY(qs(i, k, :), 3)
12000         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
12001 !update xl, cpm
12002         xl(i, k) = XLCAL(t(i, k))
12003         CALL PUSHREAL8(cpm(i, k))
12004         cpm(i, k) = CPMCAL(q(i, k))
12005 !----------------------------------------------------------------
12006 !  pcond: condensational/evaporational rate of cloud water [RH83 A6]
12007 !     if there exists additional water vapor condensated/if
12008 !     evaporation of cloud water is not enough to remove subsaturation
12009 !q>qs, work1>0, pcond>0 V->C min=0,                 max=q(i,k)/dtcld
12010 !q<qs, work1<0, pcond<0 C->V min=-qci(i,k,1)/dtcld, max=0,
12011         work1(i, k, 1) = CONDEN(t(i, k), q(i, k), qs(i, k, 1), xl(i, k)&
12012 &         , cpm(i, k))
12013         IF (work1(i, k, 1) .GT. 0.) THEN
12014           IF (q(i, k) .LT. 0.) THEN
12015             CALL PUSHCONTROL1B(0)
12016             y1 = 0.
12017           ELSE
12018             y1 = q(i, k)
12019             CALL PUSHCONTROL1B(1)
12020           END IF
12021           IF (work1(i, k, 1) .GT. y1) THEN
12022             min1 = y1
12023             CALL PUSHCONTROL1B(0)
12024           ELSE
12025             min1 = work1(i, k, 1)
12026             CALL PUSHCONTROL1B(1)
12027           END IF
12028           pcond(i, k) = min1/dtcld
12029           CALL PUSHCONTROL1B(1)
12030         ELSE
12031           IF (work1(i, k, 1) .LT. -qci(i, k, 1)) THEN
12032             max1 = -qci(i, k, 1)
12033             CALL PUSHCONTROL1B(0)
12034           ELSE
12035             max1 = work1(i, k, 1)
12036             CALL PUSHCONTROL1B(1)
12037           END IF
12038           pcond(i, k) = max1/dtcld
12039           CALL PUSHCONTROL1B(0)
12040         END IF
12041         IF (pcond(i, k) .GE. 0.) THEN
12042           abs0 = pcond(i, k)
12043         ELSE
12044           abs0 = -pcond(i, k)
12045         END IF
12046         IF (abs0 .LT. qmin/dtcld) THEN
12047           pcond(i, k) = 0.
12048           CALL PUSHCONTROL1B(1)
12049         ELSE
12050           CALL PUSHCONTROL1B(0)
12051         END IF
12052         IF (q(i, k) - pcond(i, k)*dtcld .LT. 0.) THEN
12053           CALL PUSHCONTROL1B(0)
12054         ELSE
12055           CALL PUSHCONTROL1B(1)
12056         END IF
12057         IF (qci(i, k, 1) + pcond(i, k)*dtcld .LT. 0.) THEN
12058           CALL PUSHCONTROL1B(0)
12059         ELSE
12060           CALL PUSHCONTROL1B(1)
12061         END IF
12062       END DO
12063     END DO
12064     a_work1 = 0.0_8
12065     a_pcond = 0.0_8
12066     DO k=kte,kts,-1
12067       DO i=ite,its,-1
12068         a_temp = dtcld*a_t(i, k)/cpm(i, k)
12069         a_pcond(i, k) = xl(i, k)*a_temp
12070         a_xl(i, k) = a_xl(i, k) + pcond(i, k)*a_temp
12071         a_cpm(i, k) = a_cpm(i, k) - pcond(i, k)*xl(i, k)*a_temp/cpm(i, k&
12072 &         )
12073         CALL POPCONTROL1B(branch)
12074         IF (branch .EQ. 0) THEN
12075           a_qci(i, k, 1) = 0.0_8
12076         ELSE
12077           a_pcond(i, k) = a_pcond(i, k) + dtcld*a_qci(i, k, 1)
12078         END IF
12079         CALL POPCONTROL1B(branch)
12080         IF (branch .EQ. 0) THEN
12081           a_q(i, k) = 0.0_8
12082         ELSE
12083           a_pcond(i, k) = a_pcond(i, k) - dtcld*a_q(i, k)
12084         END IF
12085         CALL POPCONTROL1B(branch)
12086         IF (branch .NE. 0) a_pcond(i, k) = 0.0_8
12087         CALL POPCONTROL1B(branch)
12088         IF (branch .EQ. 0) THEN
12089           a_max1 = a_pcond(i, k)/dtcld
12090           a_pcond(i, k) = 0.0_8
12091           CALL POPCONTROL1B(branch)
12092           IF (branch .EQ. 0) THEN
12093             a_qci(i, k, 1) = a_qci(i, k, 1) - a_max1
12094           ELSE
12095             a_work1(i, k, 1) = a_work1(i, k, 1) + a_max1
12096           END IF
12097         ELSE
12098           a_min1 = a_pcond(i, k)/dtcld
12099           a_pcond(i, k) = 0.0_8
12100           CALL POPCONTROL1B(branch)
12101           IF (branch .EQ. 0) THEN
12102             a_y1 = a_min1
12103           ELSE
12104             a_work1(i, k, 1) = a_work1(i, k, 1) + a_min1
12105             a_y1 = 0.0_8
12106           END IF
12107           CALL POPCONTROL1B(branch)
12108           IF (branch .NE. 0) a_q(i, k) = a_q(i, k) + a_y1
12109         END IF
12110         CALL A_CONDEN0(t(i, k), a_t(i, k), q(i, k), a_q(i, k), qs(i, k, &
12111 &                1), a_qs(i, k, 1), xl(i, k), a_xl(i, k), cpm(i, k), &
12112 &                a_cpm(i, k), a_work1(i, k, 1))
12113         a_work1(i, k, 1) = 0.0_8
12114         CALL POPREAL8(cpm(i, k))
12115         CALL A_CPMCAL0(q(i, k), a_q(i, k), a_cpm(i, k))
12116         a_cpm(i, k) = 0.0_8
12117         CALL A_XLCAL0(t(i, k), a_t(i, k), a_xl(i, k))
12118         a_xl(i, k) = 0.0_8
12119         CALL POPREAL8ARRAY(qs(i, k, :), 3)
12120         a_rh = 0.0_8
12121         CALL A_CALCRH(t(i, k), a_t(i, k), p(i, k), a_p(i, k), q(i, k), &
12122 &               a_q(i, k), rh(i, k, :), a_rh(i, k, :), qs(i, k, :), a_qs&
12123 &               (i, k, :))
12124       END DO
12125     END DO
12126   END SUBROUTINE A_PCONADD
12127
12128 !=======================================================================
12129 !
12130 !=======================================================================
12131   SUBROUTINE PCONADD(t, p, q, qci, qs, xl, cpm, dtcld, kte, kts, its, &
12132 &   ite, kme, kms, ims, ime)
12133     IMPLICIT NONE
12134     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
12135     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
12136     REAL, DIMENSION(its:ite, kts:kte) :: t, xl, pcond, work2, cpm
12137     REAL, DIMENSION(its:ite, kts:kte, 3) :: qs, work1, rh
12138     REAL, DIMENSION(ims:ime, kms:kme) :: q, p
12139     INTEGER :: k, i
12140     REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, &
12141 &   dtcld, qs1, qs2, qs3, qs4, w1, q1
12142     REAL :: tmp1, tmp2, f1, f2, qs0
12143     INTRINSIC MAX
12144     INTRINSIC MIN
12145     INTRINSIC ABS
12146     REAL :: y1
12147     REAL :: min1
12148     REAL :: max1
12149     REAL :: abs0
12150     DO k=kts,kte
12151       DO i=its,ite
12152 !update qs
12153         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
12154 !update xl, cpm
12155         xl(i, k) = XLCAL(t(i, k))
12156         cpm(i, k) = CPMCAL(q(i, k))
12157 !----------------------------------------------------------------
12158 !  pcond: condensational/evaporational rate of cloud water [RH83 A6]
12159 !     if there exists additional water vapor condensated/if
12160 !     evaporation of cloud water is not enough to remove subsaturation
12161 !q>qs, work1>0, pcond>0 V->C min=0,                 max=q(i,k)/dtcld
12162 !q<qs, work1<0, pcond<0 C->V min=-qci(i,k,1)/dtcld, max=0,
12163         work1(i, k, 1) = CONDEN(t(i, k), q(i, k), qs(i, k, 1), xl(i, k)&
12164 &         , cpm(i, k))
12165         IF (work1(i, k, 1) .GT. 0.) THEN
12166           IF (q(i, k) .LT. 0.) THEN
12167             y1 = 0.
12168           ELSE
12169             y1 = q(i, k)
12170           END IF
12171           IF (work1(i, k, 1) .GT. y1) THEN
12172             min1 = y1
12173           ELSE
12174             min1 = work1(i, k, 1)
12175           END IF
12176           pcond(i, k) = min1/dtcld
12177         ELSE
12178           IF (work1(i, k, 1) .LT. -qci(i, k, 1)) THEN
12179             max1 = -qci(i, k, 1)
12180           ELSE
12181             max1 = work1(i, k, 1)
12182           END IF
12183           pcond(i, k) = max1/dtcld
12184         END IF
12185         IF (pcond(i, k) .GE. 0.) THEN
12186           abs0 = pcond(i, k)
12187         ELSE
12188           abs0 = -pcond(i, k)
12189         END IF
12190         IF (abs0 .LT. qmin/dtcld) pcond(i, k) = 0.
12191         IF (q(i, k) - pcond(i, k)*dtcld .LT. 0.) THEN
12192           q(i, k) = 0.
12193         ELSE
12194           q(i, k) = q(i, k) - pcond(i, k)*dtcld
12195         END IF
12196         IF (qci(i, k, 1) + pcond(i, k)*dtcld .LT. 0.) THEN
12197           qci(i, k, 1) = 0.
12198         ELSE
12199           qci(i, k, 1) = qci(i, k, 1) + pcond(i, k)*dtcld
12200         END IF
12201         t(i, k) = t(i, k) + pcond(i, k)*dtcld*xl(i, k)/cpm(i, k)
12202         pcond(i, k) = 0.
12203       END DO
12204     END DO
12205   END SUBROUTINE PCONADD
12206
12207 !  Differentiation of smoothif in reverse (adjoint) mode (with options r8):
12208 !   gradient     of useful results: f x
12209 !   with respect to varying inputs: x
12210 !=======================================================================
12211 !
12212 !=======================================================================
12213   SUBROUTINE A_SMOOTHIF(x, a_x, a, f, a_f, opt)
12214     IMPLICIT NONE
12215     REAL, INTENT(IN) :: x, a
12216     REAL :: a_x
12217     CHARACTER(len=2), INTENT(IN) :: opt
12218     REAL :: f
12219     REAL :: a_f
12220     REAL(kind=8) :: k1, a1, x1, c1, f1, k, b
12221     REAL(kind=8) :: a_x1, a_f1, a_k
12222     INTRINSIC EXP
12223     REAL(kind=8) :: temp1, temp2
12224     x1 = x
12225     a1 = a
12226     IF (opt(1:1) .EQ. 'q') THEN
12227       c1 = 1.e-15
12228     ELSE
12229       c1 = 1.e-9
12230     END IF
12231 !f=1/(1+exp(-k*(x-b))
12232     k1 = 747./c1
12233     IF (opt(2:2) .EQ. '+') THEN
12234       b = a1 + 710./k1
12235     ELSE
12236       b = a1
12237     END IF
12238     k = -(k1*(x1-b))
12239     a_f1 = a_f
12240     temp1 = 1/( EXP(k) + 1.)
12241     temp2 = 1/( EXP(-k) + 1.)
12242     a_k = -(temp1*temp2*a_f1)
12243     a_x1 = -(k1*a_k)
12244     a_x = a_x + a_x1
12245   END SUBROUTINE A_SMOOTHIF
12246
12247 !=======================================================================
12248 !
12249 !=======================================================================
12250   SUBROUTINE SMOOTHIF(x, a, f, opt)
12251     IMPLICIT NONE
12252     REAL, INTENT(IN) :: x, a
12253     CHARACTER(len=2), INTENT(IN) :: opt
12254     REAL, INTENT(OUT) :: f
12255     REAL(kind=8) :: k1, a1, x1, c1, f1, k, b
12256     INTRINSIC EXP
12257     x1 = x
12258     a1 = a
12259     IF (opt(1:1) .EQ. 'q') THEN
12260       c1 = 1.e-15
12261     ELSE
12262       c1 = 1.e-9
12263     END IF
12264     k1 = 747./c1
12265     IF (opt(2:2) .EQ. '+') THEN
12266       b = a1 + 710./k1
12267     ELSE
12268       b = a1
12269     END IF
12270     k = -(k1*(x1-b))
12271     f1 = 1./(1.+EXP(k))
12272     f = f1
12273   END SUBROUTINE SMOOTHIF
12274
12275 !
12276 !
12277 !=======================================================================
12278 !
12279 !=======================================================================
12280   REAL FUNCTION RGMMA(x)
12281     IMPLICIT NONE
12282 !-------------------------------------------------------------------
12283 !  rgmma function:  use infinite product form
12284     REAL :: euler
12285     PARAMETER (euler=0.577215664901532)
12286     REAL :: x, y
12287     INTEGER :: i
12288     INTRINSIC EXP
12289     INTRINSIC FLOAT
12290     IF (x .EQ. 1.) THEN
12291       rgmma = 0.
12292     ELSE
12293       rgmma = x*EXP(euler*x)
12294       DO i=1,10000
12295         y = FLOAT(i)
12296         rgmma = rgmma*(1.000+x/y)*EXP(-(x/y))
12297       END DO
12298       rgmma = 1./rgmma
12299     END IF
12300   END FUNCTION RGMMA
12301
12302 !  Differentiation of cpmcal in reverse (adjoint) mode (with options r8):
12303 !   gradient     of useful results: x cpmcal
12304 !   with respect to varying inputs: x
12305 !
12306 !
12307 !=======================================================================
12308 !
12309 !=======================================================================
12310 !   compute internal functions
12311   SUBROUTINE A_CPMCAL0(x, a_x, a_cpmcal)
12312     IMPLICIT NONE
12313     REAL :: cpmcal, x
12314     REAL :: a_cpmcal, a_x
12315     a_x = a_x + (cpv-cpd)*a_cpmcal
12316   END SUBROUTINE A_CPMCAL0
12317
12318 !
12319 !
12320 !=======================================================================
12321 !
12322 !=======================================================================
12323 !   compute internal functions
12324   FUNCTION CPMCAL(x)
12325     IMPLICIT NONE
12326     REAL :: cpmcal, x
12327     cpmcal = cpd + x*(cpv-cpd)
12328   END FUNCTION CPMCAL
12329
12330 !  Differentiation of xlcal in reverse (adjoint) mode (with options r8):
12331 !   gradient     of useful results: xlcal x
12332 !   with respect to varying inputs: x
12333 !
12334 !=======================================================================
12335 !
12336 !=======================================================================
12337   SUBROUTINE A_XLCAL0(x, a_x, a_xlcal)
12338     IMPLICIT NONE
12339     REAL :: xlcal, x
12340     REAL :: a_xlcal, a_x
12341     a_x = a_x - xlv1*a_xlcal
12342   END SUBROUTINE A_XLCAL0
12343
12344 !
12345 !=======================================================================
12346 !
12347 !=======================================================================
12348   FUNCTION XLCAL(x)
12349     IMPLICIT NONE
12350     REAL :: xlcal, x
12351     xlcal = xlv0 - xlv1*(x-t0c)
12352   END FUNCTION XLCAL
12353
12354 !  Differentiation of conden in reverse (adjoint) mode (with options r8):
12355 !   gradient     of useful results: d e conden a b c
12356 !   with respect to varying inputs: d e a b c
12357 !=======================================================================
12358 ! a:t, b:q, c:qs, d:xl, e:cpm
12359 !=======================================================================
12360   SUBROUTINE A_CONDEN0(a, a_a, b, a_b, c, a_c, d, a_d, e, a_e, a_conden)
12361     IMPLICIT NONE
12362     REAL :: conden, a, b, c, d, e
12363     REAL :: a_conden, a_a, a_b, a_c, a_d, a_e
12364     REAL :: f
12365     REAL :: temp
12366     REAL :: temp0
12367     REAL :: a_temp
12368     REAL :: a_temp0
12369     REAL :: a_temp1
12370     temp = rv*e*(a*a)
12371     temp0 = d*d*c/temp
12372     a_temp = a_conden/(temp0+1.)
12373     a_b = a_b + a_temp
12374     a_temp0 = -((b-c)*a_temp/(temp*(temp0+1.)))
12375     a_c = a_c + d**2*a_temp0 - a_temp
12376     a_d = a_d + 2*d*c*a_temp0
12377     a_temp1 = -(temp0*a_temp0)
12378     a_e = a_e + rv*a**2*a_temp1
12379     a_a = a_a + 2*a*rv*e*a_temp1
12380   END SUBROUTINE A_CONDEN0
12381
12382 !=======================================================================
12383 ! a:t, b:q, c:qs, d:xl, e:cpm
12384 !=======================================================================
12385   FUNCTION CONDEN(a, b, c, d, e)
12386     IMPLICIT NONE
12387     REAL :: conden, a, b, c, d, e
12388     REAL :: f
12389     conden = (b-c)/(1.+d*d/(rv*e)*c/(a*a))
12390   END FUNCTION CONDEN
12391
12392 END MODULE A_MODULE_MP_WSM6R
12393 !
12394