wrftladj/module_mp_wsm6r_tl.F

   1 !        Generated by TAPENADE     (INRIA, Ecuador team)
   2 !  Tapenade 3.16 (master) -  9 Oct 2020 17:47
   3 !
   4 MODULE G_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 :: g_vt2i, g_vt2r, g_vt2s, g_vt2g
  96
  97 CONTAINS
  98 !  Differentiation of wsm6r in forward (tangent) mode (with options r8):
  99 !   variations   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:in q:in-out qr:in-out qs:in-out delz:in den:in
 105 !                rain:in-out rainncv:in-out pii:in
 106 !=======================================================================
 107 !
 108 !=======================================================================
 109   SUBROUTINE G_WSM6R(th, g_th, q, g_q, qc, g_qc, qr, g_qr, qi, g_qi, qs&
 110 &   , g_qs, qg, g_qg, den, g_den, pii, g_pii, p, g_p, delz, g_delz, delt&
 111 &   , rain, g_rain, rainncv, g_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) :: g_th, &
 120 &   g_q, g_qc, g_qi, g_qr, g_qs, g_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), INTENT(IN) :: g_den, &
 124 &   g_pii, g_p, g_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) :: g_rain, &
 128 &   g_rainncv
 129 ! LOCAL VAR
 130     REAL, DIMENSION(its:ite, kts:kte) :: t
 131     REAL, DIMENSION(its:ite, kts:kte) :: g_t
 132     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
 133     REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci
 134     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
 135     REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs
 136     REAL, DIMENSION(ims:ime, kms:kme) :: q2d, den2d, p2d, delz2d
 137     REAL, DIMENSION(ims:ime, kms:kme) :: g_q2d, g_den2d, g_p2d, g_delz2d
 138     REAL, DIMENSION(ims:ime) :: r1d, rcv1d
 139     REAL, DIMENSION(ims:ime) :: g_r1d, g_rcv1d
 140     REAL :: delt1
 141     INTEGER :: i, j, k, ierr
 142     REAL :: temp
 143     delt1 = delt
 144     g_t = 0.0_8
 145     g_rcv1d = 0.0_8
 146     g_qrs = 0.0_8
 147     g_q2d = 0.0_8
 148     g_delz2d = 0.0_8
 149     g_den2d = 0.0_8
 150     g_qci = 0.0_8
 151     g_r1d = 0.0_8
 152     g_p2d = 0.0_8
 153     DO j=jts,jte
 154       DO i=its,ite
 155         g_r1d(i) = g_rain(i, j)
 156         r1d(i) = rain(i, j)
 157         g_rcv1d(i) = g_rainncv(i, j)
 158         rcv1d(i) = rainncv(i, j)
 159         DO k=kts,kte
 160           g_t(i, k) = pii(i, k, j)*g_th(i, k, j) + th(i, k, j)*g_pii(i, &
 161 &           k, j)
 162           t(i, k) = th(i, k, j)*pii(i, k, j)
 163           g_qci(i, k, 1) = g_qc(i, k, j)
 164           qci(i, k, 1) = qc(i, k, j)
 165           g_qci(i, k, 2) = g_qi(i, k, j)
 166           qci(i, k, 2) = qi(i, k, j)
 167           g_qrs(i, k, 1) = g_qr(i, k, j)
 168           qrs(i, k, 1) = qr(i, k, j)
 169           g_qrs(i, k, 2) = g_qs(i, k, j)
 170           qrs(i, k, 2) = qs(i, k, j)
 171           g_qrs(i, k, 3) = g_qg(i, k, j)
 172           qrs(i, k, 3) = qg(i, k, j)
 173           g_q2d(i, k) = g_q(i, k, j)
 174           q2d(i, k) = q(i, k, j)
 175           g_den2d(i, k) = g_den(i, k, j)
 176           den2d(i, k) = den(i, k, j)
 177           g_p2d(i, k) = g_p(i, k, j)
 178           p2d(i, k) = p(i, k, j)
 179           g_delz2d(i, k) = g_delz(i, k, j)
 180           delz2d(i, k) = delz(i, k, j)
 181         END DO
 182       END DO
 183 !  Sending array starting locations of optional variables may cause
 184 !  troubles, so we explicitly change the call.
 185       CALL G_WSM62D(t, g_t, q2d, g_q2d, qci, g_qci, qrs, g_qrs, den2d, &
 186 &             g_den2d, p2d, g_p2d, delz2d, g_delz2d, delt1, r1d, g_r1d, &
 187 &             rcv1d, g_rcv1d, ims, ime, kms, kme, its, ite, kts, kte)
 188       DO i=its,ite
 189         g_rain(i, j) = g_r1d(i)
 190         rain(i, j) = r1d(i)
 191         g_rainncv(i, j) = g_rcv1d(i)
 192         rainncv(i, j) = rcv1d(i)
 193         DO k=kts,kte
 194           temp = t(i, k)/pii(i, k, j)
 195           g_th(i, k, j) = (g_t(i, k)-temp*g_pii(i, k, j))/pii(i, k, j)
 196           th(i, k, j) = temp
 197           g_qc(i, k, j) = g_qci(i, k, 1)
 198           qc(i, k, j) = qci(i, k, 1)
 199           g_qi(i, k, j) = g_qci(i, k, 2)
 200           qi(i, k, j) = qci(i, k, 2)
 201           g_qr(i, k, j) = g_qrs(i, k, 1)
 202           qr(i, k, j) = qrs(i, k, 1)
 203           g_qs(i, k, j) = g_qrs(i, k, 2)
 204           qs(i, k, j) = qrs(i, k, 2)
 205           g_qg(i, k, j) = g_qrs(i, k, 3)
 206           qg(i, k, j) = qrs(i, k, 3)
 207           g_q(i, k, j) = g_q2d(i, k)
 208           q(i, k, j) = q2d(i, k)
 209         END DO
 210       END DO
 211     END DO
 212   END SUBROUTINE G_WSM6R
 213
 214 !=======================================================================
 215 !
 216 !=======================================================================
 217   SUBROUTINE WSM6R(th, q, qc, qr, qi, qs, qg, den, pii, p, delz, delt, &
 218 &   rain, rainncv, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms&
 219 &   , kme, its, ite, jts, jte, kts, kte)
 220     IMPLICIT NONE
 221 !-------------------------------------------------------------------
 222     INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 223 &   jme, kms, kme, its, ite, jts, jte, kts, kte
 224     REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: th, q, &
 225 &   qc, qi, qr, qs, qg
 226     REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: den, pii, &
 227 &   p, delz
 228     REAL, INTENT(IN) :: delt
 229     REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rain, rainncv
 230 !  LOCAL VAR
 231     REAL, DIMENSION(its:ite, kts:kte) :: t
 232     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
 233     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
 234     REAL, DIMENSION(ims:ime, kms:kme) :: q2d, den2d, p2d, delz2d
 235     REAL, DIMENSION(ims:ime) :: r1d, rcv1d
 236     REAL :: delt1
 237     INTEGER :: i, j, k, ierr
 238     delt1 = delt
 239     DO j=jts,jte
 240       DO i=its,ite
 241         r1d(i) = rain(i, j)
 242         rcv1d(i) = rainncv(i, j)
 243         DO k=kts,kte
 244           t(i, k) = th(i, k, j)*pii(i, k, j)
 245           qci(i, k, 1) = qc(i, k, j)
 246           qci(i, k, 2) = qi(i, k, j)
 247           qrs(i, k, 1) = qr(i, k, j)
 248           qrs(i, k, 2) = qs(i, k, j)
 249           qrs(i, k, 3) = qg(i, k, j)
 250           q2d(i, k) = q(i, k, j)
 251           den2d(i, k) = den(i, k, j)
 252           p2d(i, k) = p(i, k, j)
 253           delz2d(i, k) = delz(i, k, j)
 254         END DO
 255       END DO
 256 !  Sending array starting locations of optional variables may cause
 257 !  troubles, so we explicitly change the call.
 258       CALL WSM62D(t, q2d, qci, qrs, den2d, p2d, delz2d, delt1, r1d, &
 259 &           rcv1d, ims, ime, kms, kme, its, ite, kts, kte)
 260       DO i=its,ite
 261         rain(i, j) = r1d(i)
 262         rainncv(i, j) = rcv1d(i)
 263         DO k=kts,kte
 264           th(i, k, j) = t(i, k)/pii(i, k, j)
 265           qc(i, k, j) = qci(i, k, 1)
 266           qi(i, k, j) = qci(i, k, 2)
 267           qr(i, k, j) = qrs(i, k, 1)
 268           qs(i, k, j) = qrs(i, k, 2)
 269           qg(i, k, j) = qrs(i, k, 3)
 270           q(i, k, j) = q2d(i, k)
 271         END DO
 272       END DO
 273     END DO
 274   END SUBROUTINE WSM6R
 275
 276 !  Differentiation of wsm62d in forward (tangent) mode (with options r8):
 277 !   variations   of useful results: q t qrs rain qci rainncv
 278 !   with respect to varying inputs: p q t delz den qrs rain qci
 279 !                rainncv
 280 !=======================================================================
 281 !
 282 !=======================================================================
 283   SUBROUTINE G_WSM62D(t, g_t, q, g_q, qci, g_qci, qrs, g_qrs, den, g_den&
 284 &   , p, g_p, delz, g_delz, delt, rain, g_rain, rainncv, g_rainncv, ims&
 285 &   , ime, kms, kme, its, ite, kts, kte)
 286     IMPLICIT NONE
 287 ! big loops
 288 !
 289 !-------------------------------------------------------------------
 290     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
 291     REAL, DIMENSION(its:ite, kts:kte), INTENT(INOUT) :: t
 292     REAL, DIMENSION(its:ite, kts:kte), INTENT(INOUT) :: g_t
 293     REAL, DIMENSION(its:ite, kts:kte, 2), INTENT(INOUT) :: qci
 294     REAL, DIMENSION(its:ite, kts:kte, 2), INTENT(INOUT) :: g_qci
 295     REAL, DIMENSION(its:ite, kts:kte, 3), INTENT(INOUT) :: qrs
 296     REAL, DIMENSION(its:ite, kts:kte, 3), INTENT(INOUT) :: g_qrs
 297     REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT) :: q
 298     REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT) :: g_q
 299     REAL, DIMENSION(ims:ime, kms:kme), INTENT(IN) :: den, p, delz
 300     REAL, DIMENSION(ims:ime, kms:kme), INTENT(IN) :: g_den, g_p, g_delz
 301     REAL, INTENT(IN) :: delt
 302     REAL, DIMENSION(ims:ime), INTENT(INOUT) :: rain, rainncv
 303     REAL, DIMENSION(ims:ime), INTENT(INOUT) :: g_rain, g_rainncv
 304 !  LOCAL VAR
 305     REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, rslope, rslope2, &
 306 &   rslope3, rslopeb, falk, fall, work1
 307     REAL, DIMENSION(its:ite, kts:kte, 3) :: g_rh, g_qs, g_falk, g_fall
 308     REAL, DIMENSION(its:ite, kts:kte) :: pracw, psacw, pgacw, pgacr, &
 309 &   pgacs, psaci, praci, piacr, pracs, psacr, pgaci, pseml, pgeml, fallc&
 310 &   , praut, psaut, pgaut, prevp, psdep, pgdep
 311     REAL, DIMENSION(its:ite, kts:kte) :: g_pracw, g_psacw, g_pgacw, &
 312 &   g_pgacr, g_pgacs, g_psaci, g_praci, g_piacr, g_pracs, g_psacr, &
 313 &   g_pgaci, g_pseml, g_pgeml, g_fallc, g_praut, g_psaut, g_pgaut, &
 314 &   g_prevp, g_psdep, g_pgdep
 315     REAL, DIMENSION(its:ite, kts:kte) :: pigen, pidep, pcond, xl, cpm, &
 316 &   psevp, xni, pgevp, n0sfac, work2
 317     REAL, DIMENSION(its:ite, kts:kte) :: g_pigen, g_pidep, g_xl, g_cpm, &
 318 &   g_psevp, g_pgevp
 319 !   LOGICAL, DIMENSION( its:ite ) :: flgcld
 320     REAL :: dtcld, temp, temp0, supcol, supsat, satdt, eacrs, xmi, &
 321 &   diameter, delta2, delta3
 322     INTEGER :: i, k, loop, loops
 323     REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, &
 324 &   qs10, qs11, qs20, qs21
 325     REAL :: fq, fqc, fqi, fqr, fqs, fqg, fallsum
 326     INTRINSIC MAX
 327     INTRINSIC NINT
 328     INTEGER :: x1
 329 !=================================================================
 330 !
 331     CALL WSM6RINIT()
 332 !----------------------------------------------------------------
 333 !  paddint 0 for negative values generated by dynamics
 334 !
 335     DO k=kts,kte
 336       DO i=its,ite
 337         IF (q(i, k) .LT. 0.) THEN
 338           g_q(i, k) = 0.0_8
 339           q(i, k) = 0.
 340         ELSE
 341           q(i, k) = q(i, k)
 342         END IF
 343         IF (qci(i, k, 1) .LT. 0.) THEN
 344           g_qci(i, k, 1) = 0.0_8
 345           qci(i, k, 1) = 0.
 346         ELSE
 347           qci(i, k, 1) = qci(i, k, 1)
 348         END IF
 349         IF (qrs(i, k, 1) .LT. 0.) THEN
 350           g_qrs(i, k, 1) = 0.0_8
 351           qrs(i, k, 1) = 0.
 352         ELSE
 353           qrs(i, k, 1) = qrs(i, k, 1)
 354         END IF
 355         IF (qci(i, k, 2) .LT. 0.) THEN
 356           g_qci(i, k, 2) = 0.0_8
 357           qci(i, k, 2) = 0.
 358         ELSE
 359           qci(i, k, 2) = qci(i, k, 2)
 360         END IF
 361         IF (qrs(i, k, 2) .LT. 0.) THEN
 362           g_qrs(i, k, 2) = 0.0_8
 363           qrs(i, k, 2) = 0.
 364         ELSE
 365           qrs(i, k, 2) = qrs(i, k, 2)
 366         END IF
 367         IF (qrs(i, k, 3) .LT. 0.) THEN
 368           g_qrs(i, k, 3) = 0.0_8
 369           qrs(i, k, 3) = 0.
 370         ELSE
 371           qrs(i, k, 3) = qrs(i, k, 3)
 372         END IF
 373       END DO
 374     END DO
 375     x1 = NINT(delt/dtcldcr)
 376     IF (x1 .LT. 1) THEN
 377       loops = 1
 378     ELSE
 379       loops = x1
 380     END IF
 381     dtcld = delt/loops
 382     IF (delt .LE. dtcldcr) THEN
 383       dtcld = delt
 384       g_fallc = 0.0_8
 385       g_piacr = 0.0_8
 386       g_psaci = 0.0_8
 387       g_pgaci = 0.0_8
 388       g_psacr = 0.0_8
 389       g_praci = 0.0_8
 390       g_qs = 0.0_8
 391       g_cpm = 0.0_8
 392       g_psacw = 0.0_8
 393       g_pgacr = 0.0_8
 394       g_pgacs = 0.0_8
 395       g_pracs = 0.0_8
 396       g_xl = 0.0_8
 397       g_pgacw = 0.0_8
 398       g_pigen = 0.0_8
 399       g_pracw = 0.0_8
 400       g_rh = 0.0_8
 401       g_psevp = 0.0_8
 402       g_pidep = 0.0_8
 403       g_falk = 0.0_8
 404       g_fall = 0.0_8
 405       g_pgevp = 0.0_8
 406       g_prevp = 0.0_8
 407       g_psdep = 0.0_8
 408       g_pseml = 0.0_8
 409       g_pgdep = 0.0_8
 410       g_pgeml = 0.0_8
 411       g_psaut = 0.0_8
 412       g_pgaut = 0.0_8
 413       g_praut = 0.0_8
 414     ELSE
 415       g_fallc = 0.0_8
 416       g_piacr = 0.0_8
 417       g_psaci = 0.0_8
 418       g_pgaci = 0.0_8
 419       g_psacr = 0.0_8
 420       g_praci = 0.0_8
 421       g_qs = 0.0_8
 422       g_cpm = 0.0_8
 423       g_psacw = 0.0_8
 424       g_pgacr = 0.0_8
 425       g_pgacs = 0.0_8
 426       g_pracs = 0.0_8
 427       g_xl = 0.0_8
 428       g_pgacw = 0.0_8
 429       g_pigen = 0.0_8
 430       g_pracw = 0.0_8
 431       g_rh = 0.0_8
 432       g_psevp = 0.0_8
 433       g_pidep = 0.0_8
 434       g_falk = 0.0_8
 435       g_fall = 0.0_8
 436       g_pgevp = 0.0_8
 437       g_prevp = 0.0_8
 438       g_psdep = 0.0_8
 439       g_pseml = 0.0_8
 440       g_pgdep = 0.0_8
 441       g_pgeml = 0.0_8
 442       g_psaut = 0.0_8
 443       g_pgaut = 0.0_8
 444       g_praut = 0.0_8
 445     END IF
 446 !
 447     DO loop=1,loops
 448 !
 449 !----------------------------------------------------------------
 450 !     initialize the variables for microphysical physics
 451       CALL G_INIMP(prevp, g_prevp, psdep, g_psdep, pgdep, g_pgdep, praut&
 452 &            , g_praut, psaut, g_psaut, pgaut, g_pgaut, pracw, g_pracw, &
 453 &            praci, g_praci, piacr, g_piacr, psaci, g_psaci, psacw, &
 454 &            g_psacw, pracs, g_pracs, psacr, g_psacr, pgacw, g_pgacw, &
 455 &            pgaci, g_pgaci, pgacr, g_pgacr, pgacs, g_pgacs, pigen, &
 456 &            g_pigen, pidep, g_pidep, pcond, pseml, g_pseml, pgeml, &
 457 &            g_pgeml, psevp, g_psevp, pgevp, g_pgevp, falk, g_falk, fall&
 458 &            , g_fall, fallc, g_fallc, xni, kts, kte, its, ite)
 459 !----------------------------------------------------------------
 460 !     compute the fallout term:
 461 !     first, vertical terminal velosity for minor loops
 462       CALL G_FALLK(cpm, g_cpm, t, g_t, p, g_p, q, g_q, den, g_den, qrs, &
 463 &            g_qrs, delz, g_delz, dtcld, falk, g_falk, fall, g_fall, kte&
 464 &            , kts, its, ite, kme, kms, ims, ime)
 465       CALL G_FALLKC(qci, g_qci, fallc, g_fallc, den, g_den, delz, g_delz&
 466 &             , dtcld, kte, kts, its, ite, kme, kms, ims, ime)
 467       CALL G_RAINSC(fall, g_fall, fallc, g_fallc, xl, g_xl, t, g_t, q, &
 468 &             qci, g_qci, cpm, g_cpm, den, g_den, qrs, g_qrs, delz, &
 469 &             g_delz, rain, g_rain, rainncv, g_rainncv, dtcld, kte, kts&
 470 &             , its, ite, kme, kms, ims, ime)
 471       CALL G_WARMR(t, g_t, q, g_q, qci, g_qci, qrs, g_qrs, den, g_den, p&
 472 &            , g_p, dtcld, xl, g_xl, rh, g_rh, qs, g_qs, praut, g_praut&
 473 &            , pracw, g_pracw, prevp, g_prevp, ims, ime, kms, kme, its, &
 474 &            ite, kts, kte)
 475 !
 476 ! cold rain processes
 477 !
 478 !
 479       CALL G_ACCRET1(qci, g_qci, den, g_den, qrs, g_qrs, t, g_t, q, g_q&
 480 &              , dtcld, praci, g_praci, piacr, g_piacr, psaci, g_psaci, &
 481 &              pgaci, g_pgaci, psacw, g_psacw, pgacw, g_pgacw, ims, ime&
 482 &              , kms, kme, its, ite, kts, kte)
 483       CALL G_ACCRET2(qrs, g_qrs, t, g_t, q, g_q, den, g_den, dtcld, &
 484 &              psacw, g_psacw, pgacw, g_pgacw, pracs, g_pracs, psacr, &
 485 &              g_psacr, pgacr, g_pgacr, pgacs, g_pgacs, pseml, g_pseml, &
 486 &              pgeml, g_pgeml, ims, ime, kms, kme, its, ite, kts, kte)
 487       CALL G_ACCRET3(qrs, g_qrs, qci, g_qci, rh, g_rh, t, g_t, p, g_p, &
 488 &              den, g_den, dtcld, q, g_q, qs, g_qs, psdep, g_psdep, &
 489 &              pgdep, g_pgdep, pigen, g_pigen, psaut, g_psaut, pgaut, &
 490 &              g_pgaut, psevp, g_psevp, pgevp, g_pgevp, pidep, g_pidep, &
 491 &              ims, ime, kms, kme, its, ite, kts, kte)
 492       CALL G_PCONADD(t, g_t, p, g_p, q, g_q, qci, g_qci, qs, g_qs, xl, &
 493 &              g_xl, cpm, g_cpm, dtcld, kte, kts, its, ite, kme, kms, &
 494 &              ims, ime)
 495     END DO
 496   END SUBROUTINE G_WSM62D
 497
 498 !=======================================================================
 499 !
 500 !=======================================================================
 501   SUBROUTINE WSM62D(t, q, qci, qrs, den, p, delz, delt, rain, rainncv, &
 502 &   ims, ime, kms, kme, its, ite, kts, kte)
 503     IMPLICIT NONE
 504 ! big loops
 505 !
 506 !-------------------------------------------------------------------
 507     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
 508     REAL, DIMENSION(its:ite, kts:kte), INTENT(INOUT) :: t
 509     REAL, DIMENSION(its:ite, kts:kte, 2), INTENT(INOUT) :: qci
 510     REAL, DIMENSION(its:ite, kts:kte, 3), INTENT(INOUT) :: qrs
 511     REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT) :: q
 512     REAL, DIMENSION(ims:ime, kms:kme), INTENT(IN) :: den, p, delz
 513     REAL, INTENT(IN) :: delt
 514     REAL, DIMENSION(ims:ime), INTENT(INOUT) :: rain, rainncv
 515 !  LOCAL VAR
 516     REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, rslope, rslope2, &
 517 &   rslope3, rslopeb, falk, fall, work1
 518     REAL, DIMENSION(its:ite, kts:kte) :: pracw, psacw, pgacw, pgacr, &
 519 &   pgacs, psaci, praci, piacr, pracs, psacr, pgaci, pseml, pgeml, fallc&
 520 &   , praut, psaut, pgaut, prevp, psdep, pgdep
 521     REAL, DIMENSION(its:ite, kts:kte) :: pigen, pidep, pcond, xl, cpm, &
 522 &   psevp, xni, pgevp, n0sfac, work2
 523 !   LOGICAL, DIMENSION( its:ite ) :: flgcld
 524     REAL :: dtcld, temp, temp0, supcol, supsat, satdt, eacrs, xmi, &
 525 &   diameter, delta2, delta3
 526     INTEGER :: i, k, loop, loops
 527     REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, &
 528 &   qs10, qs11, qs20, qs21
 529     REAL :: fq, fqc, fqi, fqr, fqs, fqg, fallsum
 530     INTRINSIC MAX
 531     INTRINSIC NINT
 532     INTEGER :: x1
 533 !=================================================================
 534 !
 535     CALL WSM6RINIT()
 536 !----------------------------------------------------------------
 537 !  paddint 0 for negative values generated by dynamics
 538 !
 539     DO k=kts,kte
 540       DO i=its,ite
 541         IF (q(i, k) .LT. 0.) THEN
 542           q(i, k) = 0.
 543         ELSE
 544           q(i, k) = q(i, k)
 545         END IF
 546         IF (qci(i, k, 1) .LT. 0.) THEN
 547           qci(i, k, 1) = 0.
 548         ELSE
 549           qci(i, k, 1) = qci(i, k, 1)
 550         END IF
 551         IF (qrs(i, k, 1) .LT. 0.) THEN
 552           qrs(i, k, 1) = 0.
 553         ELSE
 554           qrs(i, k, 1) = qrs(i, k, 1)
 555         END IF
 556         IF (qci(i, k, 2) .LT. 0.) THEN
 557           qci(i, k, 2) = 0.
 558         ELSE
 559           qci(i, k, 2) = qci(i, k, 2)
 560         END IF
 561         IF (qrs(i, k, 2) .LT. 0.) THEN
 562           qrs(i, k, 2) = 0.
 563         ELSE
 564           qrs(i, k, 2) = qrs(i, k, 2)
 565         END IF
 566         IF (qrs(i, k, 3) .LT. 0.) THEN
 567           qrs(i, k, 3) = 0.
 568         ELSE
 569           qrs(i, k, 3) = qrs(i, k, 3)
 570         END IF
 571       END DO
 572     END DO
 573     x1 = NINT(delt/dtcldcr)
 574     IF (x1 .LT. 1) THEN
 575       loops = 1
 576     ELSE
 577       loops = x1
 578     END IF
 579     dtcld = delt/loops
 580     IF (delt .LE. dtcldcr) dtcld = delt
 581 !
 582     DO loop=1,loops
 583 !
 584 !----------------------------------------------------------------
 585 !     initialize the variables for microphysical physics
 586       CALL INIMP(prevp, psdep, pgdep, praut, psaut, pgaut, pracw, praci&
 587 &          , piacr, psaci, psacw, pracs, psacr, pgacw, pgaci, pgacr, &
 588 &          pgacs, pigen, pidep, pcond, pseml, pgeml, psevp, pgevp, falk&
 589 &          , fall, fallc, xni, kts, kte, its, ite)
 590 !----------------------------------------------------------------
 591 !     compute the fallout term:
 592 !     first, vertical terminal velosity for minor loops
 593       CALL FALLK(cpm, t, p, q, den, qrs, delz, dtcld, falk, fall, kte, &
 594 &          kts, its, ite, kme, kms, ims, ime)
 595       CALL FALLKC(qci, fallc, den, delz, dtcld, kte, kts, its, ite, kme&
 596 &           , kms, ims, ime)
 597       CALL RAINSC(fall, fallc, xl, t, q, qci, cpm, den, qrs, delz, rain&
 598 &           , rainncv, dtcld, kte, kts, its, ite, kme, kms, ims, ime)
 599       CALL WARMR(t, q, qci, qrs, den, p, dtcld, xl, rh, qs, praut, pracw&
 600 &          , prevp, ims, ime, kms, kme, its, ite, kts, kte)
 601 !
 602 ! cold rain processes
 603 !
 604 !
 605       CALL ACCRET1(qci, den, qrs, t, q, dtcld, praci, piacr, psaci, &
 606 &            pgaci, psacw, pgacw, ims, ime, kms, kme, its, ite, kts, kte&
 607 &           )
 608       CALL ACCRET2(qrs, t, q, den, dtcld, psacw, pgacw, pracs, psacr, &
 609 &            pgacr, pgacs, pseml, pgeml, ims, ime, kms, kme, its, ite, &
 610 &            kts, kte)
 611       CALL ACCRET3(qrs, qci, rh, t, p, den, dtcld, q, qs, psdep, pgdep, &
 612 &            pigen, psaut, pgaut, psevp, pgevp, pidep, ims, ime, kms, &
 613 &            kme, its, ite, kts, kte)
 614       CALL PCONADD(t, p, q, qci, qs, xl, cpm, dtcld, kte, kts, its, ite&
 615 &            , kme, kms, ims, ime)
 616     END DO
 617   END SUBROUTINE WSM62D
 618
 619 !  Differentiation of calcrh in forward (tangent) mode (with options r8):
 620 !   variations   of useful results: qs rh
 621 !   with respect to varying inputs: p q t qs rh
 622 !=======================================================================
 623 !
 624 !=======================================================================
 625   SUBROUTINE G_CALCRH(t, g_t, p, g_p, q, g_q, rh, g_rh, qs, g_qs)
 626     IMPLICIT NONE
 627     REAL, INTENT(IN) :: t, q, p
 628     REAL, INTENT(IN) :: g_t, g_q, g_p
 629     REAL, DIMENSION(3), INTENT(OUT) :: rh, qs
 630     REAL, DIMENSION(3), INTENT(OUT) :: g_rh, g_qs
 631     REAL :: tr, qs10, qs11, qs20, qs21
 632     REAL :: g_tr, g_qs10, g_qs11, g_qs20, g_qs21
 633     REAL, PARAMETER :: hsub=xls
 634     REAL, PARAMETER :: hvap=xlv0
 635     REAL, PARAMETER :: cvap=cpv
 636     REAL, PARAMETER :: ttp=t0c+0.01
 637     REAL, PARAMETER :: dldt=cvap-cliq
 638     REAL, PARAMETER :: xa=-(dldt/rv)
 639     REAL, PARAMETER :: xb=xa+hvap/(rv*ttp)
 640     REAL, PARAMETER :: dldti=cvap-cice
 641     REAL, PARAMETER :: xai=-(dldti/rv)
 642     REAL, PARAMETER :: xbi=xai+hsub/(rv*ttp)
 643     INTRINSIC LOG
 644     INTRINSIC EXP
 645     INTRINSIC MAX
 646     REAL :: max1
 647     REAL :: g_max1
 648     REAL :: max2
 649     REAL :: g_max2
 650     REAL :: arg1
 651     REAL :: g_arg1
 652     REAL :: temp
 653     REAL :: temp0
 654     g_tr = -(ttp*g_t/t**2)
 655     tr = ttp/t
 656     g_arg1 = xa*g_tr/tr
 657     arg1 = LOG(tr)*xa
 658     temp = EXP(xb*(-tr+1.))
 659     temp0 = EXP(arg1)
 660     g_qs10 = psat*(temp*EXP(arg1)*g_arg1-temp0*EXP(xb*(1.-tr))*xb*g_tr)
 661     qs10 = psat*(temp0*temp)
 662     temp0 = qs10/(p-qs10)
 663     g_qs11 = ep2*(g_qs10-temp0*(g_p-g_qs10))/(p-qs10)
 664     qs11 = ep2*temp0
 665     g_qs(1) = g_qs11
 666     qs(1) = qs11
 667     IF (qs(1) .LT. qmin) THEN
 668       max1 = qmin
 669       g_max1 = 0.0_8
 670     ELSE
 671       g_max1 = g_qs(1)
 672       max1 = qs(1)
 673     END IF
 674     g_rh(1) = (g_q-q*g_max1/max1)/max1
 675     rh(1) = q/max1
 676     g_arg1 = xai*g_tr/tr
 677     arg1 = LOG(tr)*xai
 678     temp0 = EXP(xbi*(-tr+1.))
 679     temp = EXP(arg1)
 680     g_qs20 = psat*(temp0*EXP(arg1)*g_arg1-temp*EXP(xbi*(1.-tr))*xbi*g_tr&
 681 &     )
 682     qs20 = psat*(temp*temp0)
 683     temp0 = qs20/(p-qs20)
 684     g_qs21 = ep2*(g_qs20-temp0*(g_p-g_qs20))/(p-qs20)
 685     qs21 = ep2*temp0
 686     g_qs(2) = g_qs21
 687     qs(2) = qs21
 688     IF (qs(2) .LT. qmin) THEN
 689       max2 = qmin
 690       g_max2 = 0.0_8
 691     ELSE
 692       g_max2 = g_qs(2)
 693       max2 = qs(2)
 694     END IF
 695     g_rh(2) = (g_q-q*g_max2/max2)/max2
 696     rh(2) = q/max2
 697   END SUBROUTINE G_CALCRH
 698
 699 !=======================================================================
 700 !
 701 !=======================================================================
 702   SUBROUTINE CALCRH(t, p, q, rh, qs)
 703     IMPLICIT NONE
 704     REAL, INTENT(IN) :: t, q, p
 705     REAL, DIMENSION(3), INTENT(OUT) :: rh, qs
 706     REAL :: tr, qs10, qs11, qs20, qs21
 707     REAL, PARAMETER :: hsub=xls
 708     REAL, PARAMETER :: hvap=xlv0
 709     REAL, PARAMETER :: cvap=cpv
 710     REAL, PARAMETER :: ttp=t0c+0.01
 711     REAL, PARAMETER :: dldt=cvap-cliq
 712     REAL, PARAMETER :: xa=-(dldt/rv)
 713     REAL, PARAMETER :: xb=xa+hvap/(rv*ttp)
 714     REAL, PARAMETER :: dldti=cvap-cice
 715     REAL, PARAMETER :: xai=-(dldti/rv)
 716     REAL, PARAMETER :: xbi=xai+hsub/(rv*ttp)
 717     INTRINSIC LOG
 718     INTRINSIC EXP
 719     INTRINSIC MAX
 720     REAL :: max1
 721     REAL :: max2
 722     REAL :: arg1
 723     tr = ttp/t
 724     arg1 = LOG(tr)*xa
 725     qs10 = psat*EXP(arg1)*EXP(xb*(1.-tr))
 726     qs11 = ep2*qs10/(p-qs10)
 727     qs(1) = qs11
 728     IF (qs(1) .LT. qmin) THEN
 729       max1 = qmin
 730     ELSE
 731       max1 = qs(1)
 732     END IF
 733     rh(1) = q/max1
 734     arg1 = LOG(tr)*xai
 735     qs20 = psat*EXP(arg1)*EXP(xbi*(1.-tr))
 736     qs21 = ep2*qs20/(p-qs20)
 737     qs(2) = qs21
 738     IF (qs(2) .LT. qmin) THEN
 739       max2 = qmin
 740     ELSE
 741       max2 = qs(2)
 742     END IF
 743     rh(2) = q/max2
 744   END SUBROUTINE CALCRH
 745
 746 !
 747 !=======================================================================
 748 !
 749 !=======================================================================
 750   SUBROUTINE WSM6RINIT()
 751     IMPLICIT NONE
 752     INTRINSIC ATAN
 753     INTRINSIC SQRT
 754     REAL :: pwx1
 755     REAL :: pwr1
 756     REAL :: pwr2
 757     REAL :: pwy1
 758     REAL :: result1
 759     REAL :: result2
 760     REAL :: result3
 761 !-------------------------------------------------------------------
 762 !.... constants which may not be tunable
 763     pi = 4.*ATAN(1.)
 764     xlv1 = cliq - cpv
 765 ! 0.419e-3 -- .61e-3
 766     qc0 = 4./3.*pi*denr*r0**3*xncr/den0
 767 ! 7.03
 768     pwx1 = xncr*denr
 769     pwr1 = pwx1**(1./3.)
 770     pwr2 = den0**(4./3.)
 771     qck1 = .104*9.8*peaut/pwr1/xmyu*pwr2
 772     bvtr1 = 1. + bvtr
 773     bvtr2 = 2.5 + .5*bvtr
 774     bvtr3 = 3. + bvtr
 775     bvtr4 = 4. + bvtr
 776     bvtr6 = 6. + bvtr
 777     g1pbr = RGMMA(bvtr1)
 778     g3pbr = RGMMA(bvtr3)
 779 ! 17.837825
 780     g4pbr = RGMMA(bvtr4)
 781     g6pbr = RGMMA(bvtr6)
 782 ! 1.8273
 783     g5pbro2 = RGMMA(bvtr2)
 784     pvtr = avtr*g4pbr/6.
 785     roqimax = 2.08e22*dimax**8
 786 !
 787     bvts1 = 1. + bvts
 788     bvts2 = 2.5 + .5*bvts
 789     bvts3 = 3. + bvts
 790     bvts4 = 4. + bvts
 791 !.8875
 792     g1pbs = RGMMA(bvts1)
 793     g3pbs = RGMMA(bvts3)
 794 ! 12.0786
 795     g4pbs = RGMMA(bvts4)
 796     g5pbso2 = RGMMA(bvts2)
 797     pvts = avts*g4pbs/6.
 798     pidn0r = pi*denr*n0r
 799     pidn0s = pi*dens*n0s
 800     bvtg1 = 1. + bvtg
 801     bvtg2 = 2.5 + .5*bvtg
 802     bvtg3 = 3. + bvtg
 803     bvtg4 = 4. + bvtg
 804     g1pbg = RGMMA(bvtg1)
 805     g3pbg = RGMMA(bvtg3)
 806     g4pbg = RGMMA(bvtg4)
 807     g5pbgo2 = RGMMA(bvtg2)
 808     pvtg = avtg*g4pbg/6.
 809     pidn0g = pi*deng*n0g
 810     pwy1 = -(bvtr/4.)
 811     pwr1 = pidn0r**pwy1
 812     result1 = SQRT(den0)
 813     vt2r_a = pvtr*pwr1*result1
 814     pwy1 = -(bvts/4.)
 815     pwr1 = pidn0s**pwy1
 816     result1 = SQRT(den0)
 817     vt2s_a = pvts*pwr1*result1
 818     pwy1 = -(bvtg/4.)
 819     pwr1 = pidn0g**pwy1
 820     result1 = SQRT(den0)
 821     vt2g_a = pvtg*pwr1*result1
 822     vt2i_a = 3.3
 823     fallr_a = vt2r_a
 824     falls_a = vt2s_a
 825     fallg_a = vt2g_a
 826     falli_a = vt2i_a
 827     result1 = SQRT(pidn0r)
 828     prevp_a = 1.56*pi*n0r/result1
 829     result1 = SQRT(avtr)
 830     pwy1 = -((5.+bvtr)/8.)
 831     pwr1 = pidn0r**pwy1
 832     result2 = SQRT(den0)
 833     result3 = SQRT(result2)
 834     prevp_b = 130.37*pi*result1*n0r*pwr1*result3*g5pbro2
 835     result1 = SQRT(pidn0s)
 836     psdep_a = 2.6*n0s/result1
 837     result1 = SQRT(avts)
 838     pwy1 = -((5.+bvts)/8.)
 839     pwr1 = pidn0s**pwy1
 840     result2 = SQRT(den0)
 841     result3 = SQRT(result2)
 842     psdep_b = 370.08*result1*n0s*pwr1*result3*g5pbso2
 843     psevp_a = psdep_a
 844     psevp_b = psdep_b
 845     result1 = SQRT(pidn0g)
 846     pgdep_a = 1.56*pi*n0g/result1
 847     result1 = SQRT(avtg)
 848     pwy1 = -((5.+bvtg)/8.)
 849     pwr1 = pidn0g**pwy1
 850     result2 = SQRT(den0)
 851     result3 = SQRT(result2)
 852     pgdep_b = 130.37*pi*result1*n0g*pwr1*result3*g5pbgo2
 853     pgevp_a = pgdep_a
 854     pgevp_b = pgdep_b
 855     result1 = SQRT(pidn0s)
 856     psmlt_a = 2.75e-3*pi*n0s/result1/xlf0
 857     result1 = SQRT(den0)
 858     result2 = SQRT(result1)
 859     result3 = SQRT(avts)
 860     pwy1 = -((5.+bvts)/8.)
 861     pwr1 = pidn0s**pwy1
 862     psmlt_b = 0.391*pi*n0s*result2*result3*pwr1*g5pbso2/xlf0
 863     result1 = SQRT(pidn0g)
 864     pgmlt_a = 3.3e-3*pi*n0g/result1/xlf0
 865     result1 = SQRT(den0)
 866     result2 = SQRT(result1)
 867     result3 = SQRT(avtg)
 868     pwy1 = -((5.+bvtg)/8.)
 869     pwr1 = pidn0g**pwy1
 870     pgmlt_b = 0.276*pi*n0g*result2*result3*pwr1*g5pbgo2/xlf0
 871     praci_a = pi*n0r/4.
 872     pwr1 = pidn0r**(3./4.)
 873     praci_b = 2./pwr1
 874     result1 = SQRT(pidn0r)
 875     praci_c = 3.245e-3/result1
 876     result1 = SQRT(pidn0r)
 877     result2 = SQRT(result1)
 878     praci_d = 2.633e-6/result2
 879     psaci_a = pi*n0s/4.
 880     pwr1 = pidn0s**(3./4.)
 881     psaci_b = 2./pwr1
 882     result1 = SQRT(pidn0s)
 883     psaci_c = 3.245e-3/result1
 884     result1 = SQRT(pidn0s)
 885     result2 = SQRT(result1)
 886     psaci_d = 2.633e-6/result2
 887     pgaci_a = pi*n0g/4.
 888     pwr1 = pidn0g**(3./4.)
 889     pgaci_b = 2./pwr1
 890     result1 = SQRT(pidn0g)
 891     pgaci_c = 3.245e-3/result1
 892     result1 = SQRT(pidn0g)
 893     result2 = SQRT(result1)
 894     pgaci_d = 2.633e-6/result2
 895     pracs_a = pi*n0r*pidn0s
 896     pwr1 = pidn0s**(3./2.)
 897     result1 = SQRT(pidn0r)
 898     result2 = SQRT(result1)
 899     pracs_b = 5./pwr1/result2
 900     pwr1 = pidn0s**(5./4.)
 901     result1 = SQRT(pidn0r)
 902     pracs_c = 2./pwr1/result1
 903     pwr1 = pidn0r**(3./4.)
 904     pracs_d = .5/pidn0s/pwr1
 905     psacr_a = pi*n0s*pidn0r
 906     pwr1 = pidn0r**(3./2.)
 907     result1 = SQRT(pidn0s)
 908     result2 = SQRT(result1)
 909     psacr_b = 5./pwr1/result2
 910     pwr1 = pidn0r**(5./4.)
 911     result1 = SQRT(pidn0s)
 912     psacr_c = 2./pwr1/result1
 913     pwr1 = pidn0s**(3./4.)
 914     psacr_d = .5/pidn0r/pwr1
 915     pgacr_a = pi*n0g*pidn0r
 916     pwr1 = pidn0r**(3./2.)
 917     result1 = SQRT(pidn0g)
 918     result2 = SQRT(result1)
 919     pgacr_b = 5./pwr1/result2
 920     pwr1 = pidn0r**(5./4.)
 921     result1 = SQRT(pidn0g)
 922     pgacr_c = 2./pwr1/result1
 923     pwr1 = pidn0g**(3./4.)
 924     pgacr_d = .5/pidn0r/pwr1
 925     pgacs_a = pi*n0g*pidn0s
 926     pwr1 = pidn0s**(3./2.)
 927     result1 = SQRT(pidn0g)
 928     result2 = SQRT(result1)
 929     pgacs_b = 5./pwr1/result2
 930     pwr1 = pidn0s**(5./4.)
 931     result1 = SQRT(pidn0g)
 932     pgacs_c = 2./pwr1/result1
 933     pwr1 = pidn0g**(3./4.)
 934     pgacs_d = .5/pidn0s/pwr1
 935     pidep_a = 3.4927e5
 936     diffac_a = 4.7274e2
 937     diffac_b = 1.1371e4
 938     pwr1 = pidn0r**(3./4.)
 939     pgfrz_a = 20.*pi*pfrz1/pwr1
 940     result1 = SQRT(den0)
 941     pwy1 = -((6.+bvtr)/4.)
 942     pwr1 = pidn0r**pwy1
 943     piacr_a = 5.38e7*pi*avtr*pidn0r*g6pbr*result1*pwr1/24.
 944     result1 = SQRT(den0)
 945     pwy1 = -((3.+bvtr)/4.)
 946     pwr1 = pidn0r**pwy1
 947     pracw_a = .25*pi*avtr*n0r*g3pbr*result1*pwr1
 948     result1 = SQRT(den0)
 949     pwy1 = -((3.+bvts)/4.)
 950     pwr1 = pidn0s**pwy1
 951     psacw_a = .25*pi*avts*n0s*g3pbs*result1*pwr1
 952     result1 = SQRT(den0)
 953     pwy1 = -((3.+bvtg)/4.)
 954     pwr1 = pidn0g**pwy1
 955     pgacw_a = .25*pi*avtg*n0g*g3pbg*result1*pwr1
 956   END SUBROUTINE WSM6RINIT
 957
 958 !  Differentiation of inimp in forward (tangent) mode (with options r8):
 959 !   variations   of useful results: fallc piacr psaci pgaci psacr
 960 !                praci psacw pgacr pgacs pracs pgacw pigen pracw
 961 !                psevp pidep falk fall pgevp prevp psdep pseml
 962 !                pgdep pgeml psaut pgaut praut
 963 !   with respect to varying inputs: fallc piacr psaci pgaci psacr
 964 !                praci psacw pgacr pgacs pracs pgacw pigen pracw
 965 !                psevp pidep falk fall pgevp prevp psdep pseml
 966 !                pgdep pgeml psaut pgaut praut
 967 !=======================================================================
 968 !
 969 !=======================================================================
 970   SUBROUTINE G_INIMP(prevp, g_prevp, psdep, g_psdep, pgdep, g_pgdep, &
 971 &   praut, g_praut, psaut, g_psaut, pgaut, g_pgaut, pracw, g_pracw, &
 972 &   praci, g_praci, piacr, g_piacr, psaci, g_psaci, psacw, g_psacw, &
 973 &   pracs, g_pracs, psacr, g_psacr, pgacw, g_pgacw, pgaci, g_pgaci, &
 974 &   pgacr, g_pgacr, pgacs, g_pgacs, pigen, g_pigen, pidep, g_pidep, &
 975 &   pcond, pseml, g_pseml, pgeml, g_pgeml, psevp, g_psevp, pgevp, &
 976 &   g_pgevp, falk, g_falk, fall, g_fall, fallc, g_fallc, xni, kts, kte, &
 977 &   its, ite)
 978     IMPLICIT NONE
 979     INTEGER :: kts, kte, its, ite, k, i
 980     REAL, DIMENSION(its:ite, kts:kte, 3) :: falk, fall
 981     REAL, DIMENSION(its:ite, kts:kte, 3) :: g_falk, g_fall
 982     REAL, DIMENSION(its:ite, kts:kte) :: xni, pgevp, pigen, pidep, pcond&
 983 &   , fallc, pracw, psacw, pgacw, pgacr, pgacs, psaci, praci, piacr, &
 984 &   pracs, psacr, pgaci, pseml, pgeml, psevp, praut, psaut, pgaut, prevp&
 985 &   , psdep, pgdep
 986     REAL, DIMENSION(its:ite, kts:kte) :: g_pgevp, g_pigen, g_pidep, &
 987 &   g_fallc, g_pracw, g_psacw, g_pgacw, g_pgacr, g_pgacs, g_psaci, &
 988 &   g_praci, g_piacr, g_pracs, g_psacr, g_pgaci, g_pseml, g_pgeml, &
 989 &   g_psevp, g_praut, g_psaut, g_pgaut, g_prevp, g_psdep, g_pgdep
 990     DO k=kts,kte
 991       DO i=its,ite
 992         g_prevp(i, k) = 0.0_8
 993         prevp(i, k) = 0.
 994         g_psdep(i, k) = 0.0_8
 995         psdep(i, k) = 0.
 996         g_pgdep(i, k) = 0.0_8
 997         pgdep(i, k) = 0.
 998         g_praut(i, k) = 0.0_8
 999         praut(i, k) = 0.
1000         g_psaut(i, k) = 0.0_8
1001         psaut(i, k) = 0.
1002         g_pgaut(i, k) = 0.0_8
1003         pgaut(i, k) = 0.
1004         g_pracw(i, k) = 0.0_8
1005         pracw(i, k) = 0.
1006         g_praci(i, k) = 0.0_8
1007         praci(i, k) = 0.
1008         g_piacr(i, k) = 0.0_8
1009         piacr(i, k) = 0.
1010         g_psaci(i, k) = 0.0_8
1011         psaci(i, k) = 0.
1012         g_psacw(i, k) = 0.0_8
1013         psacw(i, k) = 0.
1014         g_pracs(i, k) = 0.0_8
1015         pracs(i, k) = 0.
1016         g_psacr(i, k) = 0.0_8
1017         psacr(i, k) = 0.
1018         g_pgacw(i, k) = 0.0_8
1019         pgacw(i, k) = 0.
1020         g_pgaci(i, k) = 0.0_8
1021         pgaci(i, k) = 0.
1022         g_pgacr(i, k) = 0.0_8
1023         pgacr(i, k) = 0.
1024         g_pgacs(i, k) = 0.0_8
1025         pgacs(i, k) = 0.
1026         g_pigen(i, k) = 0.0_8
1027         pigen(i, k) = 0.
1028         g_pidep(i, k) = 0.0_8
1029         pidep(i, k) = 0.
1030         pcond(i, k) = 0.
1031         g_pseml(i, k) = 0.0_8
1032         pseml(i, k) = 0.
1033         g_pgeml(i, k) = 0.0_8
1034         pgeml(i, k) = 0.
1035         g_psevp(i, k) = 0.0_8
1036         psevp(i, k) = 0.
1037         g_pgevp(i, k) = 0.0_8
1038         pgevp(i, k) = 0.
1039         g_falk(i, k, 1) = 0.0_8
1040         falk(i, k, 1) = 0.
1041         g_falk(i, k, 2) = 0.0_8
1042         falk(i, k, 2) = 0.
1043         g_falk(i, k, 3) = 0.0_8
1044         falk(i, k, 3) = 0.
1045         g_fall(i, k, 1) = 0.0_8
1046         fall(i, k, 1) = 0.
1047         g_fall(i, k, 2) = 0.0_8
1048         fall(i, k, 2) = 0.
1049         g_fall(i, k, 3) = 0.0_8
1050         fall(i, k, 3) = 0.
1051         g_fallc(i, k) = 0.0_8
1052         fallc(i, k) = 0.
1053         xni(i, k) = 1.e3
1054       END DO
1055     END DO
1056   END SUBROUTINE G_INIMP
1057
1058 !=======================================================================
1059 !
1060 !=======================================================================
1061   SUBROUTINE INIMP(prevp, psdep, pgdep, praut, psaut, pgaut, pracw, &
1062 &   praci, piacr, psaci, psacw, pracs, psacr, pgacw, pgaci, pgacr, pgacs&
1063 &   , pigen, pidep, pcond, pseml, pgeml, psevp, pgevp, falk, fall, fallc&
1064 &   , xni, kts, kte, its, ite)
1065     IMPLICIT NONE
1066     INTEGER :: kts, kte, its, ite, k, i
1067     REAL, DIMENSION(its:ite, kts:kte, 3) :: falk, fall
1068     REAL, DIMENSION(its:ite, kts:kte) :: xni, pgevp, pigen, pidep, pcond&
1069 &   , fallc, pracw, psacw, pgacw, pgacr, pgacs, psaci, praci, piacr, &
1070 &   pracs, psacr, pgaci, pseml, pgeml, psevp, praut, psaut, pgaut, prevp&
1071 &   , psdep, pgdep
1072     DO k=kts,kte
1073       DO i=its,ite
1074         prevp(i, k) = 0.
1075         psdep(i, k) = 0.
1076         pgdep(i, k) = 0.
1077         praut(i, k) = 0.
1078         psaut(i, k) = 0.
1079         pgaut(i, k) = 0.
1080         pracw(i, k) = 0.
1081         praci(i, k) = 0.
1082         piacr(i, k) = 0.
1083         psaci(i, k) = 0.
1084         psacw(i, k) = 0.
1085         pracs(i, k) = 0.
1086         psacr(i, k) = 0.
1087         pgacw(i, k) = 0.
1088         pgaci(i, k) = 0.
1089         pgacr(i, k) = 0.
1090         pgacs(i, k) = 0.
1091         pigen(i, k) = 0.
1092         pidep(i, k) = 0.
1093         pcond(i, k) = 0.
1094         pseml(i, k) = 0.
1095         pgeml(i, k) = 0.
1096         psevp(i, k) = 0.
1097         pgevp(i, k) = 0.
1098         falk(i, k, 1) = 0.
1099         falk(i, k, 2) = 0.
1100         falk(i, k, 3) = 0.
1101         fall(i, k, 1) = 0.
1102         fall(i, k, 2) = 0.
1103         fall(i, k, 3) = 0.
1104         fallc(i, k) = 0.
1105         xni(i, k) = 1.e3
1106       END DO
1107     END DO
1108   END SUBROUTINE INIMP
1109
1110 !  Differentiation of fallk in forward (tangent) mode (with options r8):
1111 !   variations   of useful results: t cpm qrs falk fall
1112 !   with respect to varying inputs: p q t cpm delz den qrs falk
1113 !                fall
1114 !=======================================================================
1115 !
1116 !=======================================================================
1117   SUBROUTINE G_FALLK(cpm, g_cpm, t, g_t, p, g_p, q, g_q, den, g_den, qrs&
1118 &   , g_qrs, delz, g_delz, dtcld, falk, g_falk, fall, g_fall, kte, kts, &
1119 &   its, ite, kme, kms, ims, ime)
1120     IMPLICIT NONE
1121     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
1122     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, falk, fall, work1
1123     REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs, g_falk, g_fall, &
1124 &   g_work1
1125     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, p, q
1126     REAL, DIMENSION(ims:ime, kms:kme) :: g_delz, g_den, g_p, g_q
1127     REAL, DIMENSION(its:ite, kts:kte) :: psmlt, pgmlt, t, work2, cpm
1128     REAL, DIMENSION(its:ite, kts:kte) :: g_psmlt, g_pgmlt, g_t, g_cpm
1129     INTEGER, DIMENSION(its:ite) :: mstep, numdt
1130     REAL :: dtcld, coeres1, coeres2, coeresi, coeresh, xlf, psmlt0, &
1131 &   pgmlt0, help_i, help_h, w1
1132     REAL :: g_psmlt0, g_pgmlt0
1133     REAL :: tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7, tmp8
1134     REAL :: g_tmp1, g_tmp2, g_tmp3, g_tmp4, g_tmp5, g_tmp6, g_tmp7, &
1135 &   g_tmp8
1136     INTEGER :: mstepmax, k, i, n, nw, jj
1137     REAL :: fqs, fqg, supcol, a, b, c, d
1138     REAL :: g_a, g_b, g_c, g_d
1139     INTRINSIC MAX
1140     INTRINSIC MIN
1141     INTRINSIC EXP
1142     INTRINSIC NINT
1143     INTRINSIC ABS
1144     INTRINSIC SQRT
1145     REAL :: x1
1146     REAL :: g_x1
1147     REAL :: y1
1148     REAL :: g_y1
1149     REAL :: y2
1150     REAL :: g_y2
1151     REAL :: y3
1152     REAL :: g_y3
1153     REAL :: max1
1154     REAL :: g_max1
1155     REAL :: max2
1156     REAL :: g_max2
1157     REAL :: max3
1158     REAL :: g_max3
1159     REAL :: abs0
1160     REAL :: abs1
1161     REAL :: max4
1162     REAL :: g_max4
1163     REAL :: max5
1164     REAL :: g_max5
1165     REAL :: max6
1166     REAL :: g_max6
1167     REAL :: abs2
1168     REAL :: max7
1169     REAL :: g_max7
1170     REAL :: abs3
1171     REAL :: max8
1172     REAL :: g_max8
1173     REAL :: max9
1174     REAL :: g_max9
1175     REAL :: max10
1176     REAL :: g_max10
1177     REAL :: pwy1
1178     REAL :: pwr1
1179     REAL :: g_pwr1
1180     REAL :: pwy2
1181     REAL :: pwr2
1182     REAL :: g_pwr2
1183     REAL :: arg1
1184     REAL :: g_arg1
1185     REAL :: pwx2
1186     REAL :: g_pwx2
1187     REAL :: result1
1188     REAL :: g_result1
1189     REAL :: pwy3
1190     REAL :: pwr3
1191     REAL :: g_pwr3
1192     REAL :: temp
1193     REAL :: temp0
1194     mstep = 1
1195     mstepmax = 1
1196     numdt = 1
1197     g_work1 = 0.0_8
1198     DO k=kte,kts,-1
1199       DO i=its,ite
1200         IF (qcrmin .LT. qrs(i, k, 1)) THEN
1201           g_max1 = g_qrs(i, k, 1)
1202           max1 = qrs(i, k, 1)
1203         ELSE
1204           max1 = qcrmin
1205           g_max1 = 0.0_8
1206         END IF
1207         pwy1 = (bvtr-2.)/4.
1208         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
1209 &           INT(pwy1))) THEN
1210           g_pwr1 = 0.0_8
1211         ELSE
1212           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
1213         END IF
1214         pwr1 = den(i, k)**pwy1
1215         pwy2 = bvtr/4.
1216         IF (max1 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
1217 &           pwy2))) THEN
1218           g_pwr2 = 0.0_8
1219         ELSE
1220           g_pwr2 = pwy2*max1**(pwy2-1)*g_max1
1221         END IF
1222         pwr2 = max1**pwy2
1223         temp = pwr1*pwr2/delz(i, k)
1224         g_work1(i, k, 1) = vt2r_a*(pwr2*g_pwr1+pwr1*g_pwr2-temp*g_delz(i&
1225 &         , k))/delz(i, k)
1226         work1(i, k, 1) = vt2r_a*temp
1227         IF (qcrmin .LT. qrs(i, k, 2)) THEN
1228           g_max2 = g_qrs(i, k, 2)
1229           max2 = qrs(i, k, 2)
1230         ELSE
1231           max2 = qcrmin
1232           g_max2 = 0.0_8
1233         END IF
1234         IF (90. .GT. t0c - t(i, k)) THEN
1235           g_y3 = -g_t(i, k)
1236           y3 = t0c - t(i, k)
1237         ELSE
1238           y3 = 90.
1239           g_y3 = 0.0_8
1240         END IF
1241         IF (0. .LT. y3) THEN
1242           g_max8 = g_y3
1243           max8 = y3
1244         ELSE
1245           max8 = 0.
1246           g_max8 = 0.0_8
1247         END IF
1248         pwy1 = (bvts-2.)/4.
1249         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
1250 &           INT(pwy1))) THEN
1251           g_pwr1 = 0.0_8
1252         ELSE
1253           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
1254         END IF
1255         pwr1 = den(i, k)**pwy1
1256         pwy2 = bvts/4.
1257         IF (max2 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
1258 &           pwy2))) THEN
1259           g_pwr2 = 0.0_8
1260         ELSE
1261           g_pwr2 = pwy2*max2**(pwy2-1)*g_max2
1262         END IF
1263         pwr2 = max2**pwy2
1264         g_arg1 = -(bvts*alpha*g_max8/4.)
1265         arg1 = -(bvts*alpha*max8/4.)
1266         temp = EXP(arg1)
1267         temp0 = pwr1*pwr2/delz(i, k)
1268         g_work1(i, k, 2) = vt2s_a*(temp*(pwr2*g_pwr1+pwr1*g_pwr2-temp0*&
1269 &         g_delz(i, k))/delz(i, k)+temp0*EXP(arg1)*g_arg1)
1270         work1(i, k, 2) = vt2s_a*(temp0*temp)
1271         IF (qcrmin .LT. qrs(i, k, 3)) THEN
1272           g_max3 = g_qrs(i, k, 3)
1273           max3 = qrs(i, k, 3)
1274         ELSE
1275           max3 = qcrmin
1276           g_max3 = 0.0_8
1277         END IF
1278         pwy1 = (bvtg-2.)/4.
1279         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
1280 &           INT(pwy1))) THEN
1281           g_pwr1 = 0.0_8
1282         ELSE
1283           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
1284         END IF
1285         pwr1 = den(i, k)**pwy1
1286         pwy2 = bvtg/4.
1287         IF (max3 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
1288 &           pwy2))) THEN
1289           g_pwr2 = 0.0_8
1290         ELSE
1291           g_pwr2 = pwy2*max3**(pwy2-1)*g_max3
1292         END IF
1293         pwr2 = max3**pwy2
1294         temp0 = pwr1*pwr2/delz(i, k)
1295         g_work1(i, k, 3) = vt2g_a*(pwr2*g_pwr1+pwr1*g_pwr2-temp0*g_delz(&
1296 &         i, k))/delz(i, k)
1297         work1(i, k, 3) = vt2g_a*temp0
1298         IF (work1(i, k, 1) .GE. work1(i, k, 2) .AND. work1(i, k, 1) .GE.&
1299 &           work1(i, k, 3)) THEN
1300           w1 = work1(i, k, 1)
1301         ELSE IF (work1(i, k, 2) .GE. work1(i, k, 1) .AND. work1(i, k, 2)&
1302 &           .GE. work1(i, k, 3)) THEN
1303           w1 = work1(i, k, 2)
1304         ELSE
1305           w1 = work1(i, k, 3)
1306         END IF
1307         nw = NINT(w1*dtcld + .5)
1308         IF (nw .GT. 1) THEN
1309           numdt(i) = nw
1310         ELSE
1311           numdt(i) = 1
1312         END IF
1313         IF (numdt(i) .GE. mstep(i)) mstep(i) = numdt(i)
1314       END DO
1315     END DO
1316     DO i=its,ite
1317       IF (mstepmax .LE. mstep(i)) mstepmax = mstep(i)
1318     END DO
1319     g_psmlt = 0.0_8
1320     g_pgmlt = 0.0_8
1321     DO n=1,mstepmax
1322       DO i=its,ite
1323         IF (n .LE. mstep(i)) THEN
1324           k = kte
1325           temp0 = qrs(i, k, 1)*work1(i, k, 1)
1326           temp = den(i, k)/mstep(i)
1327           g_falk(i, k, 1) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i, &
1328 &           k, 1)*g_qrs(i, k, 1)+qrs(i, k, 1)*g_work1(i, k, 1))
1329           falk(i, k, 1) = temp*temp0
1330           temp0 = qrs(i, k, 2)*work1(i, k, 2)
1331           temp = den(i, k)/mstep(i)
1332           g_falk(i, k, 2) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i, &
1333 &           k, 2)*g_qrs(i, k, 2)+qrs(i, k, 2)*g_work1(i, k, 2))
1334           falk(i, k, 2) = temp*temp0
1335           temp0 = qrs(i, k, 3)*work1(i, k, 3)
1336           temp = den(i, k)/mstep(i)
1337           g_falk(i, k, 3) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i, &
1338 &           k, 3)*g_qrs(i, k, 3)+qrs(i, k, 3)*g_work1(i, k, 3))
1339           falk(i, k, 3) = temp*temp0
1340           g_fall(i, k, 1) = g_fall(i, k, 1) + g_falk(i, k, 1)
1341           fall(i, k, 1) = fall(i, k, 1) + falk(i, k, 1)
1342           g_fall(i, k, 2) = g_fall(i, k, 2) + g_falk(i, k, 2)
1343           fall(i, k, 2) = fall(i, k, 2) + falk(i, k, 2)
1344           g_fall(i, k, 3) = g_fall(i, k, 3) + g_falk(i, k, 3)
1345           fall(i, k, 3) = fall(i, k, 3) + falk(i, k, 3)
1346           DO jj=1,3
1347             temp0 = falk(i, k, jj)/den(i, k)
1348             g_x1 = dtcld*(g_falk(i, k, jj)-temp0*g_den(i, k))/den(i, k)
1349             x1 = dtcld*temp0
1350             IF (x1 .GT. qrs(i, k, jj)) THEN
1351               g_tmp1 = g_qrs(i, k, jj)
1352               tmp1 = qrs(i, k, jj)
1353             ELSE
1354               g_tmp1 = g_x1
1355               tmp1 = x1
1356             END IF
1357             IF (tmp1 .GE. 0.) THEN
1358               abs0 = tmp1
1359             ELSE
1360               abs0 = -tmp1
1361             END IF
1362             IF (abs0 .LT. qmin) THEN
1363               tmp1 = 0.
1364               g_tmp1 = 0.0_8
1365             END IF
1366             g_qrs(i, k, jj) = g_qrs(i, k, jj) - g_tmp1
1367             qrs(i, k, jj) = qrs(i, k, jj) - tmp1
1368           END DO
1369         END IF
1370       END DO
1371       DO k=kte-1,kts,-1
1372         DO i=its,ite
1373           IF (n .LE. mstep(i)) THEN
1374             temp0 = qrs(i, k, 1)*work1(i, k, 1)
1375             temp = den(i, k)/mstep(i)
1376             g_falk(i, k, 1) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i&
1377 &             , k, 1)*g_qrs(i, k, 1)+qrs(i, k, 1)*g_work1(i, k, 1))
1378             falk(i, k, 1) = temp*temp0
1379             temp0 = qrs(i, k, 2)*work1(i, k, 2)
1380             temp = den(i, k)/mstep(i)
1381             g_falk(i, k, 2) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i&
1382 &             , k, 2)*g_qrs(i, k, 2)+qrs(i, k, 2)*g_work1(i, k, 2))
1383             falk(i, k, 2) = temp*temp0
1384             temp0 = qrs(i, k, 3)*work1(i, k, 3)
1385             temp = den(i, k)/mstep(i)
1386             g_falk(i, k, 3) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i&
1387 &             , k, 3)*g_qrs(i, k, 3)+qrs(i, k, 3)*g_work1(i, k, 3))
1388             falk(i, k, 3) = temp*temp0
1389             g_fall(i, k, 1) = g_fall(i, k, 1) + g_falk(i, k, 1)
1390             fall(i, k, 1) = fall(i, k, 1) + falk(i, k, 1)
1391             g_fall(i, k, 2) = g_fall(i, k, 2) + g_falk(i, k, 2)
1392             fall(i, k, 2) = fall(i, k, 2) + falk(i, k, 2)
1393             g_fall(i, k, 3) = g_fall(i, k, 3) + g_falk(i, k, 3)
1394             fall(i, k, 3) = fall(i, k, 3) + falk(i, k, 3)
1395             DO jj=1,3
1396               IF ((falk(i, k, jj)-falk(i, k+1, jj)*delz(i, k+1)/delz(i, &
1397 &                 k))*dtcld/den(i, k) .GT. qrs(i, k, jj)) THEN
1398                 g_tmp2 = g_qrs(i, k, jj)
1399                 tmp2 = qrs(i, k, jj)
1400               ELSE
1401                 temp0 = delz(i, k+1)/delz(i, k)
1402                 temp = (falk(i, k, jj)-falk(i, k+1, jj)*temp0)/den(i, k)
1403                 g_tmp2 = dtcld*(g_falk(i, k, jj)-temp0*g_falk(i, k+1, jj&
1404 &                 )-falk(i, k+1, jj)*(g_delz(i, k+1)-temp0*g_delz(i, k))&
1405 &                 /delz(i, k)-temp*g_den(i, k))/den(i, k)
1406                 tmp2 = dtcld*temp
1407               END IF
1408               IF (tmp2 .GE. 0.) THEN
1409                 abs1 = tmp2
1410               ELSE
1411                 abs1 = -tmp2
1412               END IF
1413               IF (abs1 .LT. qmin) THEN
1414                 tmp2 = 0.
1415                 g_tmp2 = 0.0_8
1416               END IF
1417               g_qrs(i, k, jj) = g_qrs(i, k, jj) - g_tmp2
1418               qrs(i, k, jj) = qrs(i, k, jj) - tmp2
1419             END DO
1420           END IF
1421         END DO
1422       END DO
1423       DO k=kte,kts,-1
1424         DO i=its,ite
1425           IF (n .LE. mstep(i)) THEN
1426 !
1427 !---------------------------------------------------------------
1428 ! psmlt: melting of snow [RH83 A25]
1429 !       (T>T0: S->R) psmlt<0: min=-qrs(i,k,2), max=0
1430 !---------------------------------------------------------------
1431 !update xl, cpm
1432             g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k))
1433             xlf = xlf0
1434             IF (90. .GT. t0c - t(i, k)) THEN
1435               g_y1 = -g_t(i, k)
1436               y1 = t0c - t(i, k)
1437             ELSE
1438               y1 = 90.
1439               g_y1 = 0.0_8
1440             END IF
1441             IF (0. .LT. y1) THEN
1442               g_max4 = g_y1
1443               max4 = y1
1444             ELSE
1445               max4 = 0.
1446               g_max4 = 0.0_8
1447             END IF
1448             temp0 = alpha*max4/2.
1449             g_a = EXP(temp0)*alpha*g_max4/2.
1450             a = EXP(temp0)
1451             IF (90. .GT. t0c - t(i, k)) THEN
1452               g_y2 = -g_t(i, k)
1453               y2 = t0c - t(i, k)
1454             ELSE
1455               y2 = 90.
1456               g_y2 = 0.0_8
1457             END IF
1458             IF (0. .LT. y2) THEN
1459               g_max5 = g_y2
1460               max5 = y2
1461             ELSE
1462               max5 = 0.
1463               g_max5 = 0.0_8
1464             END IF
1465             g_arg1 = alpha*(3-bvts)*g_max5/8.
1466             arg1 = alpha*max5*(3-bvts)/8.
1467             g_b = EXP(arg1)*g_arg1
1468             b = EXP(arg1)
1469             temp0 = (t0c-t(i, k))/(t(i, k)+120.)
1470             temp = t(i, k)**1.5
1471             g_c = (temp0*1.5*t(i, k)**0.5-temp*(temp0+1.0)/(t(i, k)+120.&
1472 &             ))*g_t(i, k)
1473             c = temp*temp0
1474             IF (t(i, k) .LE. 0.0_8 .AND. (3.88/6. .EQ. 0.0_8 .OR. 3.88/&
1475 &               6. .NE. INT(3.88/6.))) THEN
1476               g_pwr1 = 0.0_8
1477             ELSE
1478               g_pwr1 = 3.88*t(i, k)**(3.88/6.-1)*g_t(i, k)/6.
1479             END IF
1480             pwr1 = t(i, k)**(3.88/6.)
1481             g_pwx2 = g_t(i, k)
1482             pwx2 = t(i, k) + 120.
1483             IF (pwx2 .LE. 0.0_8 .AND. (5./6. .EQ. 0.0_8 .OR. 5./6. .NE. &
1484 &               INT(5./6.))) THEN
1485               g_pwr2 = 0.0_8
1486             ELSE
1487               g_pwr2 = 5.*pwx2**(5./6.-1)*g_pwx2/6.
1488             END IF
1489             pwr2 = pwx2**(5./6.)
1490             temp0 = pwr1/pwr2
1491             g_d = (t0c-t(i, k))*(g_pwr1-temp0*g_pwr2)/pwr2 - temp0*g_t(i&
1492 &             , k)
1493             d = (t0c-t(i, k))*temp0
1494             IF (qrs(i, k, 2) .LT. qcrmin) THEN
1495               max6 = qcrmin
1496               g_max6 = 0.0_8
1497             ELSE
1498               g_max6 = g_qrs(i, k, 2)
1499               max6 = qrs(i, k, 2)
1500             END IF
1501             IF (qrs(i, k, 2) .LT. qcrmin) THEN
1502               max9 = qcrmin
1503               g_max9 = 0.0_8
1504             ELSE
1505               g_max9 = g_qrs(i, k, 2)
1506               max9 = qrs(i, k, 2)
1507             END IF
1508             g_arg1 = max6*g_den(i, k) + den(i, k)*g_max6
1509             arg1 = den(i, k)*max6
1510             temp0 = SQRT(arg1)
1511             IF (arg1 .EQ. 0.0_8) THEN
1512               g_result1 = 0.0_8
1513             ELSE
1514               g_result1 = g_arg1/(2.0*temp0)
1515             END IF
1516             result1 = temp0
1517             IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. &
1518 &               .NE. INT(1.0/3.))) THEN
1519               g_pwr1 = 0.0_8
1520             ELSE
1521               g_pwr1 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3.
1522             END IF
1523             pwr1 = p(i, k)**(1./3.)
1524             pwy2 = (13.+3*bvts)/24.
1525             IF (den(i, k) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 &
1526 &               .NE. INT(pwy2))) THEN
1527               g_pwr2 = 0.0_8
1528             ELSE
1529               g_pwr2 = pwy2*den(i, k)**(pwy2-1)*g_den(i, k)
1530             END IF
1531             pwr2 = den(i, k)**pwy2
1532             pwy3 = (5.+bvts)/8.
1533             IF (max9 .LE. 0.0_8 .AND. (pwy3 .EQ. 0.0_8 .OR. pwy3 .NE. &
1534 &               INT(pwy3))) THEN
1535               g_pwr3 = 0.0_8
1536             ELSE
1537               g_pwr3 = pwy3*max9**(pwy3-1)*g_max9
1538             END IF
1539             pwr3 = max9**pwy3
1540             temp0 = b*d*pwr3
1541             g_psmlt0 = psmlt_a*(result1*(c*g_a+a*g_c)+a*c*g_result1) + &
1542 &             psmlt_b*(pwr1*pwr2*(pwr3*(d*g_b+b*g_d)+b*d*g_pwr3)+temp0*(&
1543 &             pwr2*g_pwr1+pwr1*g_pwr2))
1544             psmlt0 = psmlt_a*(a*c*result1) + psmlt_b*(temp0*(pwr1*pwr2))
1545             g_tmp3 = dtcld*g_psmlt0/mstep(i)
1546             tmp3 = psmlt0*dtcld/mstep(i)
1547             g_tmp4 = -(g_qrs(i, k, 2)/mstep(i))
1548             tmp4 = -(qrs(i, k, 2)/mstep(i))
1549             IF (tmp3 .GT. tmp4) THEN
1550               g_tmp5 = g_tmp3
1551               tmp5 = tmp3
1552             ELSE
1553               g_tmp5 = g_tmp4
1554               tmp5 = tmp4
1555             END IF
1556             IF (tmp5 .LT. 0.) THEN
1557               g_psmlt(i, k) = g_tmp5
1558               psmlt(i, k) = tmp5
1559             ELSE
1560               g_psmlt(i, k) = 0.0_8
1561               psmlt(i, k) = 0.
1562             END IF
1563             IF (psmlt(i, k) .GE. 0.) THEN
1564               abs2 = psmlt(i, k)
1565             ELSE
1566               abs2 = -psmlt(i, k)
1567             END IF
1568             IF (abs2 .LT. qmin) THEN
1569               g_psmlt(i, k) = 0.0_8
1570               psmlt(i, k) = 0.
1571             END IF
1572             IF (qrs(i, k, 2) + psmlt(i, k) .LT. 0.) THEN
1573               g_qrs(i, k, 2) = 0.0_8
1574               qrs(i, k, 2) = 0.
1575             ELSE
1576               g_qrs(i, k, 2) = g_qrs(i, k, 2) + g_psmlt(i, k)
1577               qrs(i, k, 2) = qrs(i, k, 2) + psmlt(i, k)
1578             END IF
1579             IF (qrs(i, k, 1) - psmlt(i, k) .LT. 0.) THEN
1580               g_qrs(i, k, 1) = 0.0_8
1581               qrs(i, k, 1) = 0.
1582             ELSE
1583               g_qrs(i, k, 1) = g_qrs(i, k, 1) - g_psmlt(i, k)
1584               qrs(i, k, 1) = qrs(i, k, 1) - psmlt(i, k)
1585             END IF
1586             temp0 = psmlt(i, k)/cpm(i, k)
1587             g_t(i, k) = g_t(i, k) + xlf*(g_psmlt(i, k)-temp0*g_cpm(i, k)&
1588 &             )/cpm(i, k)
1589             t(i, k) = t(i, k) + xlf*temp0
1590           END IF
1591         END DO
1592       END DO
1593 !---------------------------------------------------------------
1594 ! pgmlt: melting of graupel [LFO 47]
1595 !       (T>T0: G->R) pgmlt<0: min=-qrs(i,k,3), max=0
1596 !---------------------------------------------------------------
1597       DO k=kte,kts,-1
1598         DO i=its,ite
1599           IF (n .LE. mstep(i)) THEN
1600 !update xl, cpm
1601             xlf = xlf0
1602 !               cpm(i,k)=cpmcal(q(i,k)) ! not change
1603             temp0 = (t0c-t(i, k))/(t(i, k)+120.)
1604             temp = t(i, k)**1.5
1605             g_c = (temp0*1.5*t(i, k)**0.5-temp*(temp0+1.0)/(t(i, k)+120.&
1606 &             ))*g_t(i, k)
1607             c = temp*temp0
1608             IF (t(i, k) .LE. 0.0_8 .AND. (3.88/6. .EQ. 0.0_8 .OR. 3.88/&
1609 &               6. .NE. INT(3.88/6.))) THEN
1610               g_pwr1 = 0.0_8
1611             ELSE
1612               g_pwr1 = 3.88*t(i, k)**(3.88/6.-1)*g_t(i, k)/6.
1613             END IF
1614             pwr1 = t(i, k)**(3.88/6.)
1615             g_pwx2 = g_t(i, k)
1616             pwx2 = t(i, k) + 120.
1617             IF (pwx2 .LE. 0.0_8 .AND. (5./6. .EQ. 0.0_8 .OR. 5./6. .NE. &
1618 &               INT(5./6.))) THEN
1619               g_pwr2 = 0.0_8
1620             ELSE
1621               g_pwr2 = 5.*pwx2**(5./6.-1)*g_pwx2/6.
1622             END IF
1623             pwr2 = pwx2**(5./6.)
1624             temp0 = pwr1/pwr2
1625             g_d = (t0c-t(i, k))*(g_pwr1-temp0*g_pwr2)/pwr2 - temp0*g_t(i&
1626 &             , k)
1627             d = (t0c-t(i, k))*temp0
1628             IF (qrs(i, k, 3) .LT. qcrmin) THEN
1629               max7 = qcrmin
1630               g_max7 = 0.0_8
1631             ELSE
1632               g_max7 = g_qrs(i, k, 3)
1633               max7 = qrs(i, k, 3)
1634             END IF
1635             IF (qrs(i, k, 3) .LT. qcrmin) THEN
1636               max10 = qcrmin
1637               g_max10 = 0.0_8
1638             ELSE
1639               g_max10 = g_qrs(i, k, 3)
1640               max10 = qrs(i, k, 3)
1641             END IF
1642             g_arg1 = max7*g_den(i, k) + den(i, k)*g_max7
1643             arg1 = den(i, k)*max7
1644             temp0 = SQRT(arg1)
1645             IF (arg1 .EQ. 0.0_8) THEN
1646               g_result1 = 0.0_8
1647             ELSE
1648               g_result1 = g_arg1/(2.0*temp0)
1649             END IF
1650             result1 = temp0
1651             IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. &
1652 &               .NE. INT(1.0/3.))) THEN
1653               g_pwr1 = 0.0_8
1654             ELSE
1655               g_pwr1 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3.
1656             END IF
1657             pwr1 = p(i, k)**(1./3.)
1658             pwy2 = (13.+3*bvtg)/24.
1659             IF (den(i, k) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 &
1660 &               .NE. INT(pwy2))) THEN
1661               g_pwr2 = 0.0_8
1662             ELSE
1663               g_pwr2 = pwy2*den(i, k)**(pwy2-1)*g_den(i, k)
1664             END IF
1665             pwr2 = den(i, k)**pwy2
1666             pwy3 = (5.+bvtg)/8.
1667             IF (max10 .LE. 0.0_8 .AND. (pwy3 .EQ. 0.0_8 .OR. pwy3 .NE. &
1668 &               INT(pwy3))) THEN
1669               g_pwr3 = 0.0_8
1670             ELSE
1671               g_pwr3 = pwy3*max10**(pwy3-1)*g_max10
1672             END IF
1673             pwr3 = max10**pwy3
1674             g_pgmlt0 = pgmlt_a*(result1*g_c+c*g_result1) + pgmlt_b*(pwr2&
1675 &             *pwr3*(pwr1*g_d+d*g_pwr1)+d*pwr1*(pwr3*g_pwr2+pwr2*g_pwr3)&
1676 &             )
1677             pgmlt0 = pgmlt_a*c*result1 + pgmlt_b*d*pwr1*pwr2*pwr3
1678             g_tmp6 = dtcld*g_pgmlt0/mstep(i)
1679             tmp6 = pgmlt0*dtcld/mstep(i)
1680             g_tmp7 = -(g_qrs(i, k, 3)/mstep(i))
1681             tmp7 = -(qrs(i, k, 3)/mstep(i))
1682             IF (tmp6 .GT. tmp7) THEN
1683               g_tmp8 = g_tmp6
1684               tmp8 = tmp6
1685             ELSE
1686               g_tmp8 = g_tmp7
1687               tmp8 = tmp7
1688             END IF
1689             IF (tmp8 .LT. 0.) THEN
1690               g_pgmlt(i, k) = g_tmp8
1691               pgmlt(i, k) = tmp8
1692             ELSE
1693               g_pgmlt(i, k) = 0.0_8
1694               pgmlt(i, k) = 0.
1695             END IF
1696             IF (pgmlt(i, k) .GE. 0.) THEN
1697               abs3 = pgmlt(i, k)
1698             ELSE
1699               abs3 = -pgmlt(i, k)
1700             END IF
1701             IF (abs3 .LT. qmin) THEN
1702               g_pgmlt(i, k) = 0.0_8
1703               pgmlt(i, k) = 0.
1704             END IF
1705             IF (qrs(i, k, 3) + pgmlt(i, k) .LT. 0.) THEN
1706               g_qrs(i, k, 3) = 0.0_8
1707               qrs(i, k, 3) = 0.
1708             ELSE
1709               g_qrs(i, k, 3) = g_qrs(i, k, 3) + g_pgmlt(i, k)
1710               qrs(i, k, 3) = qrs(i, k, 3) + pgmlt(i, k)
1711             END IF
1712             IF (qrs(i, k, 1) - pgmlt(i, k) .LT. 0.) THEN
1713               g_qrs(i, k, 1) = 0.0_8
1714               qrs(i, k, 1) = 0.
1715             ELSE
1716               g_qrs(i, k, 1) = g_qrs(i, k, 1) - g_pgmlt(i, k)
1717               qrs(i, k, 1) = qrs(i, k, 1) - pgmlt(i, k)
1718             END IF
1719             temp0 = pgmlt(i, k)/cpm(i, k)
1720             g_t(i, k) = g_t(i, k) + xlf*(g_pgmlt(i, k)-temp0*g_cpm(i, k)&
1721 &             )/cpm(i, k)
1722             t(i, k) = t(i, k) + xlf*temp0
1723           END IF
1724         END DO
1725       END DO
1726     END DO
1727   END SUBROUTINE G_FALLK
1728
1729 !=======================================================================
1730 !
1731 !=======================================================================
1732   SUBROUTINE FALLK(cpm, t, p, q, den, qrs, delz, dtcld, falk, fall, kte&
1733 &   , kts, its, ite, kme, kms, ims, ime)
1734     IMPLICIT NONE
1735     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
1736     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, falk, fall, work1
1737     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, p, q
1738     REAL, DIMENSION(its:ite, kts:kte) :: psmlt, pgmlt, t, work2, cpm
1739     INTEGER, DIMENSION(its:ite) :: mstep, numdt
1740     REAL :: dtcld, coeres1, coeres2, coeresi, coeresh, xlf, psmlt0, &
1741 &   pgmlt0, help_i, help_h, w1
1742     REAL :: tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7, tmp8
1743     INTEGER :: mstepmax, k, i, n, nw, jj
1744     REAL :: fqs, fqg, supcol, a, b, c, d
1745     INTRINSIC MAX
1746     INTRINSIC MIN
1747     INTRINSIC EXP
1748     INTRINSIC NINT
1749     INTRINSIC ABS
1750     INTRINSIC SQRT
1751     REAL :: x1
1752     REAL :: y1
1753     REAL :: y2
1754     REAL :: y3
1755     REAL :: max1
1756     REAL :: max2
1757     REAL :: max3
1758     REAL :: abs0
1759     REAL :: abs1
1760     REAL :: max4
1761     REAL :: max5
1762     REAL :: max6
1763     REAL :: abs2
1764     REAL :: max7
1765     REAL :: abs3
1766     REAL :: max8
1767     REAL :: max9
1768     REAL :: max10
1769     REAL :: pwy1
1770     REAL :: pwr1
1771     REAL :: pwy2
1772     REAL :: pwr2
1773     REAL :: arg1
1774     REAL :: pwx2
1775     REAL :: result1
1776     REAL :: pwy3
1777     REAL :: pwr3
1778     mstep = 1
1779     mstepmax = 1
1780     numdt = 1
1781     DO k=kte,kts,-1
1782       DO i=its,ite
1783         IF (qcrmin .LT. qrs(i, k, 1)) THEN
1784           max1 = qrs(i, k, 1)
1785         ELSE
1786           max1 = qcrmin
1787         END IF
1788         pwy1 = (bvtr-2.)/4.
1789         pwr1 = den(i, k)**pwy1
1790         pwy2 = bvtr/4.
1791         pwr2 = max1**pwy2
1792         work1(i, k, 1) = vt2r_a*pwr1*pwr2/delz(i, k)
1793         IF (qcrmin .LT. qrs(i, k, 2)) THEN
1794           max2 = qrs(i, k, 2)
1795         ELSE
1796           max2 = qcrmin
1797         END IF
1798         IF (90. .GT. t0c - t(i, k)) THEN
1799           y3 = t0c - t(i, k)
1800         ELSE
1801           y3 = 90.
1802         END IF
1803         IF (0. .LT. y3) THEN
1804           max8 = y3
1805         ELSE
1806           max8 = 0.
1807         END IF
1808         pwy1 = (bvts-2.)/4.
1809         pwr1 = den(i, k)**pwy1
1810         pwy2 = bvts/4.
1811         pwr2 = max2**pwy2
1812         arg1 = -(bvts*alpha*max8/4.)
1813         work1(i, k, 2) = vt2s_a*pwr1*pwr2/delz(i, k)*EXP(arg1)
1814         IF (qcrmin .LT. qrs(i, k, 3)) THEN
1815           max3 = qrs(i, k, 3)
1816         ELSE
1817           max3 = qcrmin
1818         END IF
1819         pwy1 = (bvtg-2.)/4.
1820         pwr1 = den(i, k)**pwy1
1821         pwy2 = bvtg/4.
1822         pwr2 = max3**pwy2
1823         work1(i, k, 3) = vt2g_a*pwr1*pwr2/delz(i, k)
1824         IF (work1(i, k, 1) .GE. work1(i, k, 2) .AND. work1(i, k, 1) .GE.&
1825 &           work1(i, k, 3)) THEN
1826           w1 = work1(i, k, 1)
1827         ELSE IF (work1(i, k, 2) .GE. work1(i, k, 1) .AND. work1(i, k, 2)&
1828 &           .GE. work1(i, k, 3)) THEN
1829           w1 = work1(i, k, 2)
1830         ELSE
1831           w1 = work1(i, k, 3)
1832         END IF
1833         nw = NINT(w1*dtcld + .5)
1834         IF (nw .GT. 1) THEN
1835           numdt(i) = nw
1836         ELSE
1837           numdt(i) = 1
1838         END IF
1839         IF (numdt(i) .GE. mstep(i)) mstep(i) = numdt(i)
1840       END DO
1841     END DO
1842     DO i=its,ite
1843       IF (mstepmax .LE. mstep(i)) mstepmax = mstep(i)
1844     END DO
1845     DO n=1,mstepmax
1846       DO i=its,ite
1847         IF (n .LE. mstep(i)) THEN
1848           k = kte
1849           falk(i, k, 1) = den(i, k)*qrs(i, k, 1)*work1(i, k, 1)/mstep(i)
1850           falk(i, k, 2) = den(i, k)*qrs(i, k, 2)*work1(i, k, 2)/mstep(i)
1851           falk(i, k, 3) = den(i, k)*qrs(i, k, 3)*work1(i, k, 3)/mstep(i)
1852           fall(i, k, 1) = fall(i, k, 1) + falk(i, k, 1)
1853           fall(i, k, 2) = fall(i, k, 2) + falk(i, k, 2)
1854           fall(i, k, 3) = fall(i, k, 3) + falk(i, k, 3)
1855           DO jj=1,3
1856             x1 = falk(i, k, jj)*dtcld/den(i, k)
1857             IF (x1 .GT. qrs(i, k, jj)) THEN
1858               tmp1 = qrs(i, k, jj)
1859             ELSE
1860               tmp1 = x1
1861             END IF
1862             IF (tmp1 .GE. 0.) THEN
1863               abs0 = tmp1
1864             ELSE
1865               abs0 = -tmp1
1866             END IF
1867             IF (abs0 .LT. qmin) tmp1 = 0.
1868             qrs(i, k, jj) = qrs(i, k, jj) - tmp1
1869           END DO
1870         END IF
1871       END DO
1872       DO k=kte-1,kts,-1
1873         DO i=its,ite
1874           IF (n .LE. mstep(i)) THEN
1875             falk(i, k, 1) = den(i, k)*qrs(i, k, 1)*work1(i, k, 1)/mstep(&
1876 &             i)
1877             falk(i, k, 2) = den(i, k)*qrs(i, k, 2)*work1(i, k, 2)/mstep(&
1878 &             i)
1879             falk(i, k, 3) = den(i, k)*qrs(i, k, 3)*work1(i, k, 3)/mstep(&
1880 &             i)
1881             fall(i, k, 1) = fall(i, k, 1) + falk(i, k, 1)
1882             fall(i, k, 2) = fall(i, k, 2) + falk(i, k, 2)
1883             fall(i, k, 3) = fall(i, k, 3) + falk(i, k, 3)
1884             DO jj=1,3
1885               IF ((falk(i, k, jj)-falk(i, k+1, jj)*delz(i, k+1)/delz(i, &
1886 &                 k))*dtcld/den(i, k) .GT. qrs(i, k, jj)) THEN
1887                 tmp2 = qrs(i, k, jj)
1888               ELSE
1889                 tmp2 = (falk(i, k, jj)-falk(i, k+1, jj)*delz(i, k+1)/&
1890 &                 delz(i, k))*dtcld/den(i, k)
1891               END IF
1892               IF (tmp2 .GE. 0.) THEN
1893                 abs1 = tmp2
1894               ELSE
1895                 abs1 = -tmp2
1896               END IF
1897               IF (abs1 .LT. qmin) tmp2 = 0.
1898               qrs(i, k, jj) = qrs(i, k, jj) - tmp2
1899             END DO
1900           END IF
1901         END DO
1902       END DO
1903       DO k=kte,kts,-1
1904         DO i=its,ite
1905           IF (n .LE. mstep(i)) THEN
1906 !
1907 !---------------------------------------------------------------
1908 ! psmlt: melting of snow [RH83 A25]
1909 !       (T>T0: S->R) psmlt<0: min=-qrs(i,k,2), max=0
1910 !---------------------------------------------------------------
1911 !update xl, cpm
1912             cpm(i, k) = CPMCAL(q(i, k))
1913             xlf = xlf0
1914             IF (90. .GT. t0c - t(i, k)) THEN
1915               y1 = t0c - t(i, k)
1916             ELSE
1917               y1 = 90.
1918             END IF
1919             IF (0. .LT. y1) THEN
1920               max4 = y1
1921             ELSE
1922               max4 = 0.
1923             END IF
1924             a = EXP(alpha*max4/2.)
1925             IF (90. .GT. t0c - t(i, k)) THEN
1926               y2 = t0c - t(i, k)
1927             ELSE
1928               y2 = 90.
1929             END IF
1930             IF (0. .LT. y2) THEN
1931               max5 = y2
1932             ELSE
1933               max5 = 0.
1934             END IF
1935             arg1 = alpha*max5*(3-bvts)/8.
1936             b = EXP(arg1)
1937             c = t(i, k)**1.5*(t0c-t(i, k))/(t(i, k)+120.)
1938             pwr1 = t(i, k)**(3.88/6.)
1939             pwx2 = t(i, k) + 120.
1940             pwr2 = pwx2**(5./6.)
1941             d = pwr1*(t0c-t(i, k))/pwr2
1942             IF (qrs(i, k, 2) .LT. qcrmin) THEN
1943               max6 = qcrmin
1944             ELSE
1945               max6 = qrs(i, k, 2)
1946             END IF
1947             IF (qrs(i, k, 2) .LT. qcrmin) THEN
1948               max9 = qcrmin
1949             ELSE
1950               max9 = qrs(i, k, 2)
1951             END IF
1952             arg1 = den(i, k)*max6
1953             result1 = SQRT(arg1)
1954             pwr1 = p(i, k)**(1./3.)
1955             pwy2 = (13.+3*bvts)/24.
1956             pwr2 = den(i, k)**pwy2
1957             pwy3 = (5.+bvts)/8.
1958             pwr3 = max9**pwy3
1959             psmlt0 = psmlt_a*a*c*result1 + psmlt_b*b*d*pwr1*pwr2*pwr3
1960             tmp3 = psmlt0*dtcld/mstep(i)
1961             tmp4 = -(qrs(i, k, 2)/mstep(i))
1962             IF (tmp3 .GT. tmp4) THEN
1963               tmp5 = tmp3
1964             ELSE
1965               tmp5 = tmp4
1966             END IF
1967             IF (tmp5 .LT. 0.) THEN
1968               psmlt(i, k) = tmp5
1969             ELSE
1970               psmlt(i, k) = 0.
1971             END IF
1972             IF (psmlt(i, k) .GE. 0.) THEN
1973               abs2 = psmlt(i, k)
1974             ELSE
1975               abs2 = -psmlt(i, k)
1976             END IF
1977             IF (abs2 .LT. qmin) psmlt(i, k) = 0.
1978             IF (qrs(i, k, 2) + psmlt(i, k) .LT. 0.) THEN
1979               qrs(i, k, 2) = 0.
1980             ELSE
1981               qrs(i, k, 2) = qrs(i, k, 2) + psmlt(i, k)
1982             END IF
1983             IF (qrs(i, k, 1) - psmlt(i, k) .LT. 0.) THEN
1984               qrs(i, k, 1) = 0.
1985             ELSE
1986               qrs(i, k, 1) = qrs(i, k, 1) - psmlt(i, k)
1987             END IF
1988             t(i, k) = t(i, k) + xlf/cpm(i, k)*psmlt(i, k)
1989           END IF
1990         END DO
1991       END DO
1992 !---------------------------------------------------------------
1993 ! pgmlt: melting of graupel [LFO 47]
1994 !       (T>T0: G->R) pgmlt<0: min=-qrs(i,k,3), max=0
1995 !---------------------------------------------------------------
1996       DO k=kte,kts,-1
1997         DO i=its,ite
1998           IF (n .LE. mstep(i)) THEN
1999 !update xl, cpm
2000             xlf = xlf0
2001 !               cpm(i,k)=cpmcal(q(i,k)) ! not change
2002             c = t(i, k)**1.5*(t0c-t(i, k))/(t(i, k)+120.)
2003             pwr1 = t(i, k)**(3.88/6.)
2004             pwx2 = t(i, k) + 120.
2005             pwr2 = pwx2**(5./6.)
2006             d = pwr1*(t0c-t(i, k))/pwr2
2007             IF (qrs(i, k, 3) .LT. qcrmin) THEN
2008               max7 = qcrmin
2009             ELSE
2010               max7 = qrs(i, k, 3)
2011             END IF
2012             IF (qrs(i, k, 3) .LT. qcrmin) THEN
2013               max10 = qcrmin
2014             ELSE
2015               max10 = qrs(i, k, 3)
2016             END IF
2017             arg1 = den(i, k)*max7
2018             result1 = SQRT(arg1)
2019             pwr1 = p(i, k)**(1./3.)
2020             pwy2 = (13.+3*bvtg)/24.
2021             pwr2 = den(i, k)**pwy2
2022             pwy3 = (5.+bvtg)/8.
2023             pwr3 = max10**pwy3
2024             pgmlt0 = pgmlt_a*c*result1 + pgmlt_b*d*pwr1*pwr2*pwr3
2025             tmp6 = pgmlt0*dtcld/mstep(i)
2026             tmp7 = -(qrs(i, k, 3)/mstep(i))
2027             IF (tmp6 .GT. tmp7) THEN
2028               tmp8 = tmp6
2029             ELSE
2030               tmp8 = tmp7
2031             END IF
2032             IF (tmp8 .LT. 0.) THEN
2033               pgmlt(i, k) = tmp8
2034             ELSE
2035               pgmlt(i, k) = 0.
2036             END IF
2037             IF (pgmlt(i, k) .GE. 0.) THEN
2038               abs3 = pgmlt(i, k)
2039             ELSE
2040               abs3 = -pgmlt(i, k)
2041             END IF
2042             IF (abs3 .LT. qmin) pgmlt(i, k) = 0.
2043             IF (qrs(i, k, 3) + pgmlt(i, k) .LT. 0.) THEN
2044               qrs(i, k, 3) = 0.
2045             ELSE
2046               qrs(i, k, 3) = qrs(i, k, 3) + pgmlt(i, k)
2047             END IF
2048             IF (qrs(i, k, 1) - pgmlt(i, k) .LT. 0.) THEN
2049               qrs(i, k, 1) = 0.
2050             ELSE
2051               qrs(i, k, 1) = qrs(i, k, 1) - pgmlt(i, k)
2052             END IF
2053             t(i, k) = t(i, k) + xlf/cpm(i, k)*pgmlt(i, k)
2054           END IF
2055         END DO
2056       END DO
2057     END DO
2058   END SUBROUTINE FALLK
2059
2060 !  Differentiation of fallkc in forward (tangent) mode (with options r8):
2061 !   variations   of useful results: fallc qci
2062 !   with respect to varying inputs: fallc delz den qci
2063 !=======================================================================
2064 !
2065 !=======================================================================
2066   SUBROUTINE G_FALLKC(qci, g_qci, fallc, g_fallc, den, g_den, delz, &
2067 &   g_delz, dtcld, kte, kts, its, ite, kme, kms, ims, ime)
2068     IMPLICIT NONE
2069     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
2070     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
2071     REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci
2072     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den
2073     REAL, DIMENSION(ims:ime, kms:kme) :: g_delz, g_den
2074     REAL, DIMENSION(its:ite, kts:kte) :: falkc, work1c, work2c, xni, &
2075 &   fallc
2076     REAL, DIMENSION(its:ite, kts:kte) :: g_falkc, g_fallc
2077     INTEGER, DIMENSION(its:ite) :: mstep, numdt
2078     REAL :: dtcld, xmi, diameter, temp1, temp2, temp3, temp4, temp5, &
2079 &   temp0
2080     REAL :: g_temp3, g_temp4
2081     INTEGER :: mstepmax, k, i, n
2082     INTRINSIC NINT
2083     INTRINSIC MAX
2084     INTRINSIC MIN
2085     INTRINSIC ABS
2086     INTEGER :: x1
2087     REAL :: x2
2088     REAL :: g_x2
2089     REAL :: abs0
2090     REAL :: abs1
2091     REAL :: pwx1
2092     REAL :: g_pwx1
2093     REAL :: pwr1
2094     REAL :: g_pwr1
2095     REAL :: temp
2096     REAL :: temp6
2097     mstepmax = 1
2098     mstep = 1
2099     numdt = 1
2100     DO k=kte,kts,-1
2101       DO i=its,ite
2102         pwx1 = den(i, k)*qci(i, k, 2)
2103         pwr1 = pwx1**(1.31/8.)
2104         work1c(i, k) = vt2i_a*pwr1
2105         work2c(i, k) = work1c(i, k)/delz(i, k)
2106         x1 = NINT(work2c(i, k)*dtcld + .5)
2107         IF (x1 .LT. 1) THEN
2108           numdt(i) = 1
2109         ELSE
2110           numdt(i) = x1
2111         END IF
2112         IF (numdt(i) .GE. mstep(i)) mstep(i) = numdt(i)
2113       END DO
2114     END DO
2115     DO i=its,ite
2116       IF (mstepmax .LE. mstep(i)) mstepmax = mstep(i)
2117     END DO
2118     g_falkc = 0.0_8
2119     DO n=1,mstepmax
2120       k = kte
2121       DO i=its,ite
2122         IF (n .LE. mstep(i)) THEN
2123           g_pwx1 = qci(i, k, 2)*g_den(i, k) + den(i, k)*g_qci(i, k, 2)
2124           pwx1 = den(i, k)*qci(i, k, 2)
2125           IF (pwx1 .LE. 0.0_8 .AND. (9.31/8. .EQ. 0.0_8 .OR. 9.31/8. &
2126 &             .NE. INT(9.31/8.))) THEN
2127             g_pwr1 = 0.0_8
2128           ELSE
2129             g_pwr1 = 9.31*pwx1**(9.31/8.-1)*g_pwx1/8.
2130           END IF
2131           pwr1 = pwx1**(9.31/8.)
2132           temp = mstep(i)*delz(i, k)
2133           g_falkc(i, k) = falli_a*(g_pwr1-pwr1*mstep(i)*g_delz(i, k)/&
2134 &           temp)/temp
2135           falkc(i, k) = falli_a*(pwr1/temp)
2136           g_fallc(i, k) = g_fallc(i, k) + g_falkc(i, k)
2137           fallc(i, k) = fallc(i, k) + falkc(i, k)
2138           temp = falkc(i, k)/den(i, k)
2139           g_x2 = dtcld*(g_falkc(i, k)-temp*g_den(i, k))/den(i, k)
2140           x2 = dtcld*temp
2141           IF (x2 .GT. qci(i, k, 2)) THEN
2142             g_temp3 = g_qci(i, k, 2)
2143             temp3 = qci(i, k, 2)
2144           ELSE
2145             g_temp3 = g_x2
2146             temp3 = x2
2147           END IF
2148           IF (temp3 .GE. 0.) THEN
2149             abs0 = temp3
2150           ELSE
2151             abs0 = -temp3
2152           END IF
2153           IF (abs0 .LT. qmin) THEN
2154             temp3 = 0.
2155             g_temp3 = 0.0_8
2156           END IF
2157           g_qci(i, k, 2) = g_qci(i, k, 2) - g_temp3
2158           qci(i, k, 2) = qci(i, k, 2) - temp3
2159         END IF
2160       END DO
2161       DO k=kte-1,kts,-1
2162         DO i=its,ite
2163           IF (n .LE. mstep(i)) THEN
2164             g_pwx1 = qci(i, k, 2)*g_den(i, k) + den(i, k)*g_qci(i, k, 2)
2165             pwx1 = den(i, k)*qci(i, k, 2)
2166             IF (pwx1 .LE. 0.0_8 .AND. (9.31/8. .EQ. 0.0_8 .OR. 9.31/8. &
2167 &               .NE. INT(9.31/8.))) THEN
2168               g_pwr1 = 0.0_8
2169             ELSE
2170               g_pwr1 = 9.31*pwx1**(9.31/8.-1)*g_pwx1/8.
2171             END IF
2172             pwr1 = pwx1**(9.31/8.)
2173             temp = mstep(i)*delz(i, k)
2174             g_falkc(i, k) = falli_a*(g_pwr1-pwr1*mstep(i)*g_delz(i, k)/&
2175 &             temp)/temp
2176             falkc(i, k) = falli_a*(pwr1/temp)
2177             g_fallc(i, k) = g_fallc(i, k) + g_falkc(i, k)
2178             fallc(i, k) = fallc(i, k) + falkc(i, k)
2179             IF ((falkc(i, k)-falkc(i, k+1)*delz(i, k+1)/delz(i, k))*&
2180 &               dtcld/den(i, k) .GT. qci(i, k, 2)) THEN
2181               g_temp4 = g_qci(i, k, 2)
2182               temp4 = qci(i, k, 2)
2183             ELSE
2184               temp = falkc(i, k+1)/delz(i, k)
2185               temp6 = (falkc(i, k)-temp*delz(i, k+1))/den(i, k)
2186               g_temp4 = dtcld*(g_falkc(i, k)-delz(i, k+1)*(g_falkc(i, k+&
2187 &               1)-temp*g_delz(i, k))/delz(i, k)-temp*g_delz(i, k+1)-&
2188 &               temp6*g_den(i, k))/den(i, k)
2189               temp4 = dtcld*temp6
2190             END IF
2191             IF (temp4 .GE. 0.) THEN
2192               abs1 = temp4
2193             ELSE
2194               abs1 = -temp4
2195             END IF
2196             IF (abs1 .LT. qmin) THEN
2197               temp4 = 0.
2198               g_temp4 = 0.0_8
2199             END IF
2200             g_qci(i, k, 2) = g_qci(i, k, 2) - g_temp4
2201             qci(i, k, 2) = qci(i, k, 2) - temp4
2202           END IF
2203         END DO
2204       END DO
2205     END DO
2206   END SUBROUTINE G_FALLKC
2207
2208 !=======================================================================
2209 !
2210 !=======================================================================
2211   SUBROUTINE FALLKC(qci, fallc, den, delz, dtcld, kte, kts, its, ite, &
2212 &   kme, kms, ims, ime)
2213     IMPLICIT NONE
2214     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
2215     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
2216     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den
2217     REAL, DIMENSION(its:ite, kts:kte) :: falkc, work1c, work2c, xni, &
2218 &   fallc
2219     INTEGER, DIMENSION(its:ite) :: mstep, numdt
2220     REAL :: dtcld, xmi, diameter, temp1, temp2, temp3, temp4, temp5, &
2221 &   temp0
2222     INTEGER :: mstepmax, k, i, n
2223     INTRINSIC NINT
2224     INTRINSIC MAX
2225     INTRINSIC MIN
2226     INTRINSIC ABS
2227     INTEGER :: x1
2228     REAL :: x2
2229     REAL :: abs0
2230     REAL :: abs1
2231     REAL :: pwx1
2232     REAL :: pwr1
2233     mstepmax = 1
2234     mstep = 1
2235     numdt = 1
2236     DO k=kte,kts,-1
2237       DO i=its,ite
2238         pwx1 = den(i, k)*qci(i, k, 2)
2239         pwr1 = pwx1**(1.31/8.)
2240         work1c(i, k) = vt2i_a*pwr1
2241         work2c(i, k) = work1c(i, k)/delz(i, k)
2242         x1 = NINT(work2c(i, k)*dtcld + .5)
2243         IF (x1 .LT. 1) THEN
2244           numdt(i) = 1
2245         ELSE
2246           numdt(i) = x1
2247         END IF
2248         IF (numdt(i) .GE. mstep(i)) mstep(i) = numdt(i)
2249       END DO
2250     END DO
2251     DO i=its,ite
2252       IF (mstepmax .LE. mstep(i)) mstepmax = mstep(i)
2253     END DO
2254     DO n=1,mstepmax
2255       k = kte
2256       DO i=its,ite
2257         IF (n .LE. mstep(i)) THEN
2258           pwx1 = den(i, k)*qci(i, k, 2)
2259           pwr1 = pwx1**(9.31/8.)
2260           falkc(i, k) = falli_a*pwr1/delz(i, k)/mstep(i)
2261           fallc(i, k) = fallc(i, k) + falkc(i, k)
2262           x2 = falkc(i, k)*dtcld/den(i, k)
2263           IF (x2 .GT. qci(i, k, 2)) THEN
2264             temp3 = qci(i, k, 2)
2265           ELSE
2266             temp3 = x2
2267           END IF
2268           IF (temp3 .GE. 0.) THEN
2269             abs0 = temp3
2270           ELSE
2271             abs0 = -temp3
2272           END IF
2273           IF (abs0 .LT. qmin) temp3 = 0.
2274           qci(i, k, 2) = qci(i, k, 2) - temp3
2275         END IF
2276       END DO
2277       DO k=kte-1,kts,-1
2278         DO i=its,ite
2279           IF (n .LE. mstep(i)) THEN
2280             pwx1 = den(i, k)*qci(i, k, 2)
2281             pwr1 = pwx1**(9.31/8.)
2282             falkc(i, k) = falli_a*pwr1/delz(i, k)/mstep(i)
2283             fallc(i, k) = fallc(i, k) + falkc(i, k)
2284             IF ((falkc(i, k)-falkc(i, k+1)*delz(i, k+1)/delz(i, k))*&
2285 &               dtcld/den(i, k) .GT. qci(i, k, 2)) THEN
2286               temp4 = qci(i, k, 2)
2287             ELSE
2288               temp4 = (falkc(i, k)-falkc(i, k+1)*delz(i, k+1)/delz(i, k)&
2289 &               )*dtcld/den(i, k)
2290             END IF
2291             IF (temp4 .GE. 0.) THEN
2292               abs1 = temp4
2293             ELSE
2294               abs1 = -temp4
2295             END IF
2296             IF (abs1 .LT. qmin) temp4 = 0.
2297             qci(i, k, 2) = qci(i, k, 2) - temp4
2298           END IF
2299         END DO
2300       END DO
2301     END DO
2302   END SUBROUTINE FALLKC
2303
2304 !  Differentiation of rainsc in forward (tangent) mode (with options r8):
2305 !   variations   of useful results: t xl qrs rain qci rainncv
2306 !   with respect to varying inputs: fallc t cpm xl delz den qrs
2307 !                fall rain qci rainncv
2308 !=======================================================================
2309 !
2310 !=======================================================================
2311   SUBROUTINE G_RAINSC(fall, g_fall, fallc, g_fallc, xl, g_xl, t, g_t, q&
2312 &   , qci, g_qci, cpm, g_cpm, den, g_den, qrs, g_qrs, delz, g_delz, rain&
2313 &   , g_rain, rainncv, g_rainncv, dtcld, kte, kts, its, ite, kme, kms, &
2314 &   ims, ime)
2315     IMPLICIT NONE
2316     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
2317     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, fall
2318     REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs, g_fall
2319     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
2320     REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci
2321     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, q
2322     REAL, DIMENSION(ims:ime, kms:kme) :: g_delz, g_den
2323     REAL, DIMENSION(its:ite, kts:kte) :: xl, t, cpm, fallc
2324     REAL, DIMENSION(its:ite, kts:kte) :: g_xl, g_t, g_cpm, g_fallc
2325     REAL, DIMENSION(ims:ime) :: rain, rainncv
2326     REAL, DIMENSION(ims:ime) :: g_rain, g_rainncv
2327     INTEGER :: k, i
2328     REAL :: dtcld, fallsum, supcol, xlf, temp, temp0, pfrzdtr, pfrzdtc
2329     REAL :: g_fallsum, g_supcol, g_xlf, g_temp, g_pfrzdtr, g_pfrzdtc
2330     REAL :: ft0, ft40, fsupcol, fqc, fqi, fqr, qtmp
2331     REAL :: g_ft0, g_ft40, g_qtmp
2332     INTRINSIC MAX
2333     INTRINSIC ABS
2334     INTRINSIC EXP
2335     INTRINSIC MIN
2336     REAL :: x1
2337     REAL :: g_x1
2338     REAL :: max1
2339     REAL :: g_max1
2340     REAL :: abs0
2341     REAL :: abs1
2342     REAL :: abs2
2343     REAL :: abs3
2344     REAL :: pwr1
2345     REAL :: g_pwr1
2346     REAL :: pwr2
2347     REAL :: g_pwr2
2348     REAL :: temp1
2349     REAL :: temp2
2350     REAL :: temp3
2351     DO i=its,ite
2352       g_fallsum = g_fall(i, kts, 1) + g_fall(i, kts, 2) + g_fall(i, kts&
2353 &       , 3) + g_fallc(i, kts)
2354       fallsum = fall(i, kts, 1) + fall(i, kts, 2) + fall(i, kts, 3) + &
2355 &       fallc(i, kts)
2356       IF (fallsum .GT. qmin) THEN
2357 !rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf
2358         g_rainncv(i) = dtcld*1000.*(fallsum*g_delz(i, kts)/denr+delz(i, &
2359 &         kts)*g_fallsum/denr)
2360         rainncv(i) = fallsum*delz(i, kts)/denr*dtcld*1000.
2361         g_rain(i) = dtcld*1000.*(fallsum*g_delz(i, kts)/denr+delz(i, kts&
2362 &         )*g_fallsum/denr) + g_rain(i)
2363         rain(i) = fallsum*delz(i, kts)/denr*dtcld*1000. + rain(i)
2364       END IF
2365     END DO
2366     DO k=kts,kte
2367       DO i=its,ite
2368 !---------------------------------------------------------------
2369 ! pimlt: instantaneous melting of cloud ice [RH83 A28]
2370 !       (T>T0: I->C) pimlt=qci(i,k,2) t-
2371 !---------------------------------------------------------------
2372 !update xl, cpm
2373         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
2374 !         cpm(i,k)=cpmcal(q(i,k)) !not change
2375         g_xlf = -g_xl(i, k)
2376         xlf = xls - xl(i, k)
2377         supcol = t0c - t(i, k)
2378         IF (supcol .LT. 0.) THEN
2379           xlf = xlf0
2380           g_xlf = 0.0_8
2381         END IF
2382         CALL G_SMOOTHIF(t(i, k), g_t(i, k), t0c, ft0, g_ft0, 't0')
2383         IF (qci(i, k, 2) .LT. 0.) THEN
2384           max1 = 0.
2385           g_max1 = 0.0_8
2386         ELSE
2387           g_max1 = g_qci(i, k, 2)
2388           max1 = qci(i, k, 2)
2389         END IF
2390         g_qtmp = max1*g_ft0 + ft0*g_max1
2391         qtmp = ft0*max1
2392         IF (qtmp .GE. 0.) THEN
2393           abs0 = qtmp
2394         ELSE
2395           abs0 = -qtmp
2396         END IF
2397         IF (abs0 .LT. qmin) THEN
2398           qtmp = 0.
2399           g_qtmp = 0.0_8
2400         END IF
2401         IF (qci(i, k, 1) + qtmp .LT. 0.) THEN
2402           g_qci(i, k, 1) = 0.0_8
2403           qci(i, k, 1) = 0.
2404         ELSE
2405           g_qci(i, k, 1) = g_qci(i, k, 1) + g_qtmp
2406           qci(i, k, 1) = qci(i, k, 1) + qtmp
2407         END IF
2408         IF (qci(i, k, 2) - qtmp .LT. 0.) THEN
2409           g_qci(i, k, 2) = 0.0_8
2410           qci(i, k, 2) = 0.
2411         ELSE
2412           g_qci(i, k, 2) = g_qci(i, k, 2) - g_qtmp
2413           qci(i, k, 2) = qci(i, k, 2) - qtmp
2414         END IF
2415         temp1 = xlf*qtmp/cpm(i, k)
2416         g_t(i, k) = g_t(i, k) - (qtmp*g_xlf+xlf*g_qtmp-temp1*g_cpm(i, k)&
2417 &         )/cpm(i, k)
2418         t(i, k) = t(i, k) - temp1
2419 !---------------------------------------------------------------
2420 ! pihmf: homogeneous freezing of cloud water below -40c
2421 !        (T<-40C: C->I) min=0,pihmf=qci(i,k,1) t+
2422 !---------------------------------------------------------------
2423 !update xl, cpm
2424         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
2425 !         cpm(i,k)=cpmcal(q(i,k)) !not change
2426         g_xlf = -g_xl(i, k)
2427         xlf = xls - xl(i, k)
2428         g_supcol = -g_t(i, k)
2429         supcol = t0c - t(i, k)
2430         IF (supcol .LT. 0.) THEN
2431           xlf = xlf0
2432           g_xlf = 0.0_8
2433         END IF
2434         CALL G_SMOOTHIF(supcol, g_supcol, 40., ft40, g_ft40, 't0')
2435         IF (ft40*qci(i, k, 1) .LT. 0.) THEN
2436           qtmp = 0.
2437           g_qtmp = 0.0_8
2438         ELSE
2439           g_qtmp = qci(i, k, 1)*g_ft40 + ft40*g_qci(i, k, 1)
2440           qtmp = ft40*qci(i, k, 1)
2441         END IF
2442         IF (qtmp .GE. 0.) THEN
2443           abs1 = qtmp
2444         ELSE
2445           abs1 = -qtmp
2446         END IF
2447 !update qc, qi, t
2448         IF (abs1 .LT. qmin) THEN
2449           qtmp = 0.
2450           g_qtmp = 0.0_8
2451         END IF
2452         IF (qci(i, k, 2) + qtmp .LT. 0.) THEN
2453           g_qci(i, k, 2) = 0.0_8
2454           qci(i, k, 2) = 0.
2455         ELSE
2456           g_qci(i, k, 2) = g_qci(i, k, 2) + g_qtmp
2457           qci(i, k, 2) = qci(i, k, 2) + qtmp
2458         END IF
2459         IF (qci(i, k, 1) - qtmp .LT. 0.) THEN
2460           g_qci(i, k, 1) = 0.0_8
2461           qci(i, k, 1) = 0.
2462         ELSE
2463           g_qci(i, k, 1) = g_qci(i, k, 1) - g_qtmp
2464           qci(i, k, 1) = qci(i, k, 1) - qtmp
2465         END IF
2466         temp1 = xlf*qtmp/cpm(i, k)
2467         g_t(i, k) = g_t(i, k) + (qtmp*g_xlf+xlf*g_qtmp-temp1*g_cpm(i, k)&
2468 &         )/cpm(i, k)
2469         t(i, k) = t(i, k) + temp1
2470 !---------------------------------------------------------------
2471 ! pihtf: heterogeneous freezing of cloud water
2472 !        (T0>T>-40C: C->I) max=qci(i,k,1),min=0. t+
2473 !---------------------------------------------------------------
2474 !update xl, cpm
2475         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
2476 !         cpm(i,k)=cpmcal(q(i,k)) !not change
2477         g_xlf = -g_xl(i, k)
2478         xlf = xls - xl(i, k)
2479         g_supcol = -g_t(i, k)
2480         supcol = t0c - t(i, k)
2481         IF (supcol .LT. 0.) THEN
2482           xlf = xlf0
2483           g_xlf = 0.0_8
2484         END IF
2485 !t>-40C=t0c-40,t0c-t<40, supcol<40,-supcol>-40
2486         CALL G_SMOOTHIF(-supcol, -g_supcol, -40., ft40, g_ft40, 't0')
2487         temp1 = den(i, k)/(denr*xncr)
2488         temp2 = qci(i, k, 1)*qci(i, k, 1)
2489         temp3 = EXP(pfrz2*supcol) - 1.
2490         g_x1 = pfrz1*dtcld*(temp2*temp1*EXP(pfrz2*supcol)*pfrz2*g_supcol&
2491 &         +temp3*(temp1*2*qci(i, k, 1)*g_qci(i, k, 1)+temp2*g_den(i, k)/&
2492 &         (denr*xncr)))
2493         x1 = pfrz1*dtcld*(temp3*(temp2*temp1))
2494         IF (x1 .GT. qci(i, k, 1)) THEN
2495           g_pfrzdtc = g_qci(i, k, 1)
2496           pfrzdtc = qci(i, k, 1)
2497         ELSE
2498           g_pfrzdtc = g_x1
2499           pfrzdtc = x1
2500         END IF
2501         IF (ft40*pfrzdtc .LT. 0.) THEN
2502           qtmp = 0.
2503           g_qtmp = 0.0_8
2504         ELSE
2505           g_qtmp = pfrzdtc*g_ft40 + ft40*g_pfrzdtc
2506           qtmp = ft40*pfrzdtc
2507         END IF
2508         IF (qtmp .GE. 0.) THEN
2509           abs2 = qtmp
2510         ELSE
2511           abs2 = -qtmp
2512         END IF
2513 !update qc, qi, t
2514         IF (abs2 .LT. qmin) THEN
2515           qtmp = 0.
2516           g_qtmp = 0.0_8
2517         END IF
2518         IF (qci(i, k, 2) + qtmp .LT. 0.) THEN
2519           g_qci(i, k, 2) = 0.0_8
2520           qci(i, k, 2) = 0.
2521         ELSE
2522           g_qci(i, k, 2) = g_qci(i, k, 2) + g_qtmp
2523           qci(i, k, 2) = qci(i, k, 2) + qtmp
2524         END IF
2525         IF (qci(i, k, 1) - qtmp .LT. 0.) THEN
2526           g_qci(i, k, 1) = 0.0_8
2527           qci(i, k, 1) = 0.
2528         ELSE
2529           g_qci(i, k, 1) = g_qci(i, k, 1) - g_qtmp
2530           qci(i, k, 1) = qci(i, k, 1) - qtmp
2531         END IF
2532         temp3 = xlf*qtmp/cpm(i, k)
2533         g_t(i, k) = g_t(i, k) + (qtmp*g_xlf+xlf*g_qtmp-temp3*g_cpm(i, k)&
2534 &         )/cpm(i, k)
2535         t(i, k) = t(i, k) + temp3
2536 !---------------------------------------------------------------
2537 ! pgfrz: freezing of rain water [LFO 45]
2538 !        (T<T0, R->G) max=qrs(i,k,1),min=0. t+
2539 !---------------------------------------------------------------
2540 !update xl, cpm
2541         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
2542 !         cpm(i,k)=cpmcal(q(i,k))!not change
2543         g_xlf = -g_xl(i, k)
2544         xlf = xls - xl(i, k)
2545         g_supcol = -g_t(i, k)
2546         supcol = t0c - t(i, k)
2547         IF (supcol .LT. 0.) THEN
2548           xlf = xlf0
2549           g_xlf = 0.0_8
2550         END IF
2551         IF (qrs(i, k, 1) .GT. 0.) THEN
2552           IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. &
2553 &             .NE. INT(3./4.))) THEN
2554             g_pwr1 = 0.0_8
2555           ELSE
2556             g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
2557           END IF
2558           pwr1 = den(i, k)**(3./4.)
2559           IF (qrs(i, k, 1) .LE. 0.0_8 .AND. (7./4. .EQ. 0.0_8 .OR. 7./4.&
2560 &             .NE. INT(7./4.))) THEN
2561             g_pwr2 = 0.0_8
2562           ELSE
2563             g_pwr2 = 7.*qrs(i, k, 1)**(7./4.-1)*g_qrs(i, k, 1)/4.
2564           END IF
2565           pwr2 = qrs(i, k, 1)**(7./4.)
2566           temp3 = EXP(pfrz2*supcol) - 1.
2567           g_temp = pgfrz_a*(pwr1*pwr2*EXP(pfrz2*supcol)*pfrz2*g_supcol+&
2568 &           temp3*(pwr2*g_pwr1+pwr1*g_pwr2))
2569           temp = pgfrz_a*(temp3*(pwr1*pwr2))
2570         ELSE
2571           temp = 0.
2572           g_temp = 0.0_8
2573         END IF
2574         IF (temp*dtcld .GT. qrs(i, k, 1)) THEN
2575           g_pfrzdtr = g_qrs(i, k, 1)
2576           pfrzdtr = qrs(i, k, 1)
2577         ELSE
2578           g_pfrzdtr = dtcld*g_temp
2579           pfrzdtr = temp*dtcld
2580         END IF
2581         IF (pfrzdtr .LT. 0.) THEN
2582           qtmp = 0.
2583           g_qtmp = 0.0_8
2584         ELSE
2585           g_qtmp = g_pfrzdtr
2586           qtmp = pfrzdtr
2587         END IF
2588         IF (qtmp .GE. 0.) THEN
2589           abs3 = qtmp
2590         ELSE
2591           abs3 = -qtmp
2592         END IF
2593         IF (abs3 .LT. qmin) THEN
2594           qtmp = 0.
2595           g_qtmp = 0.0_8
2596         END IF
2597         IF (qrs(i, k, 3) + qtmp .LT. 0.) THEN
2598           g_qrs(i, k, 3) = 0.0_8
2599           qrs(i, k, 3) = 0.
2600         ELSE
2601           g_qrs(i, k, 3) = g_qrs(i, k, 3) + g_qtmp
2602           qrs(i, k, 3) = qrs(i, k, 3) + qtmp
2603         END IF
2604         IF (qrs(i, k, 1) - qtmp .LT. 0.) THEN
2605           g_qrs(i, k, 1) = 0.0_8
2606           qrs(i, k, 1) = 0.
2607         ELSE
2608           g_qrs(i, k, 1) = g_qrs(i, k, 1) - g_qtmp
2609           qrs(i, k, 1) = qrs(i, k, 1) - qtmp
2610         END IF
2611         temp3 = xlf*qtmp/cpm(i, k)
2612         g_t(i, k) = g_t(i, k) + (qtmp*g_xlf+xlf*g_qtmp-temp3*g_cpm(i, k)&
2613 &         )/cpm(i, k)
2614         t(i, k) = t(i, k) + temp3
2615       END DO
2616     END DO
2617   END SUBROUTINE G_RAINSC
2618
2619 !=======================================================================
2620 !
2621 !=======================================================================
2622   SUBROUTINE RAINSC(fall, fallc, xl, t, q, qci, cpm, den, qrs, delz, &
2623 &   rain, rainncv, dtcld, kte, kts, its, ite, kme, kms, ims, ime)
2624     IMPLICIT NONE
2625     INTEGER :: kte, kts, its, ite, kme, kms, ims, ime
2626     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, fall
2627     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
2628     REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, q
2629     REAL, DIMENSION(its:ite, kts:kte) :: xl, t, cpm, fallc
2630     REAL, DIMENSION(ims:ime) :: rain, rainncv
2631     INTEGER :: k, i
2632     REAL :: dtcld, fallsum, supcol, xlf, temp, temp0, pfrzdtr, pfrzdtc
2633     REAL :: ft0, ft40, fsupcol, fqc, fqi, fqr, qtmp
2634     INTRINSIC MAX
2635     INTRINSIC ABS
2636     INTRINSIC EXP
2637     INTRINSIC MIN
2638     REAL :: x1
2639     REAL :: max1
2640     REAL :: abs0
2641     REAL :: abs1
2642     REAL :: abs2
2643     REAL :: abs3
2644     REAL :: pwr1
2645     REAL :: pwr2
2646     DO i=its,ite
2647       fallsum = fall(i, kts, 1) + fall(i, kts, 2) + fall(i, kts, 3) + &
2648 &       fallc(i, kts)
2649       IF (fallsum .GT. qmin) THEN
2650 !rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf
2651         rainncv(i) = fallsum*delz(i, kts)/denr*dtcld*1000.
2652         rain(i) = fallsum*delz(i, kts)/denr*dtcld*1000. + rain(i)
2653       END IF
2654     END DO
2655     DO k=kts,kte
2656       DO i=its,ite
2657 !---------------------------------------------------------------
2658 ! pimlt: instantaneous melting of cloud ice [RH83 A28]
2659 !       (T>T0: I->C) pimlt=qci(i,k,2) t-
2660 !---------------------------------------------------------------
2661 !update xl, cpm
2662         xl(i, k) = XLCAL(t(i, k))
2663 !         cpm(i,k)=cpmcal(q(i,k)) !not change
2664         xlf = xls - xl(i, k)
2665         supcol = t0c - t(i, k)
2666         IF (supcol .LT. 0.) xlf = xlf0
2667         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
2668         IF (qci(i, k, 2) .LT. 0.) THEN
2669           max1 = 0.
2670         ELSE
2671           max1 = qci(i, k, 2)
2672         END IF
2673         qtmp = ft0*max1
2674         IF (qtmp .GE. 0.) THEN
2675           abs0 = qtmp
2676         ELSE
2677           abs0 = -qtmp
2678         END IF
2679         IF (abs0 .LT. qmin) qtmp = 0.
2680         IF (qci(i, k, 1) + qtmp .LT. 0.) THEN
2681           qci(i, k, 1) = 0.
2682         ELSE
2683           qci(i, k, 1) = qci(i, k, 1) + qtmp
2684         END IF
2685         IF (qci(i, k, 2) - qtmp .LT. 0.) THEN
2686           qci(i, k, 2) = 0.
2687         ELSE
2688           qci(i, k, 2) = qci(i, k, 2) - qtmp
2689         END IF
2690         t(i, k) = t(i, k) - xlf/cpm(i, k)*qtmp
2691 !---------------------------------------------------------------
2692 ! pihmf: homogeneous freezing of cloud water below -40c
2693 !        (T<-40C: C->I) min=0,pihmf=qci(i,k,1) t+
2694 !---------------------------------------------------------------
2695 !update xl, cpm
2696         xl(i, k) = XLCAL(t(i, k))
2697 !         cpm(i,k)=cpmcal(q(i,k)) !not change
2698         xlf = xls - xl(i, k)
2699         supcol = t0c - t(i, k)
2700         IF (supcol .LT. 0.) xlf = xlf0
2701         CALL SMOOTHIF(supcol, 40., ft40, 't0')
2702         IF (ft40*qci(i, k, 1) .LT. 0.) THEN
2703           qtmp = 0.
2704         ELSE
2705           qtmp = ft40*qci(i, k, 1)
2706         END IF
2707         IF (qtmp .GE. 0.) THEN
2708           abs1 = qtmp
2709         ELSE
2710           abs1 = -qtmp
2711         END IF
2712 !update qc, qi, t
2713         IF (abs1 .LT. qmin) qtmp = 0.
2714         IF (qci(i, k, 2) + qtmp .LT. 0.) THEN
2715           qci(i, k, 2) = 0.
2716         ELSE
2717           qci(i, k, 2) = qci(i, k, 2) + qtmp
2718         END IF
2719         IF (qci(i, k, 1) - qtmp .LT. 0.) THEN
2720           qci(i, k, 1) = 0.
2721         ELSE
2722           qci(i, k, 1) = qci(i, k, 1) - qtmp
2723         END IF
2724         t(i, k) = t(i, k) + xlf/cpm(i, k)*qtmp
2725 !---------------------------------------------------------------
2726 ! pihtf: heterogeneous freezing of cloud water
2727 !        (T0>T>-40C: C->I) max=qci(i,k,1),min=0. t+
2728 !---------------------------------------------------------------
2729 !update xl, cpm
2730         xl(i, k) = XLCAL(t(i, k))
2731 !         cpm(i,k)=cpmcal(q(i,k)) !not change
2732         xlf = xls - xl(i, k)
2733         supcol = t0c - t(i, k)
2734         IF (supcol .LT. 0.) xlf = xlf0
2735 !t>-40C=t0c-40,t0c-t<40, supcol<40,-supcol>-40
2736         CALL SMOOTHIF(-supcol, -40., ft40, 't0')
2737         x1 = pfrz1*(EXP(pfrz2*supcol)-1.)*den(i, k)/denr/xncr*qci(i, k, &
2738 &         1)*qci(i, k, 1)*dtcld
2739         IF (x1 .GT. qci(i, k, 1)) THEN
2740           pfrzdtc = qci(i, k, 1)
2741         ELSE
2742           pfrzdtc = x1
2743         END IF
2744         IF (ft40*pfrzdtc .LT. 0.) THEN
2745           qtmp = 0.
2746         ELSE
2747           qtmp = ft40*pfrzdtc
2748         END IF
2749         IF (qtmp .GE. 0.) THEN
2750           abs2 = qtmp
2751         ELSE
2752           abs2 = -qtmp
2753         END IF
2754 !update qc, qi, t
2755         IF (abs2 .LT. qmin) qtmp = 0.
2756         IF (qci(i, k, 2) + qtmp .LT. 0.) THEN
2757           qci(i, k, 2) = 0.
2758         ELSE
2759           qci(i, k, 2) = qci(i, k, 2) + qtmp
2760         END IF
2761         IF (qci(i, k, 1) - qtmp .LT. 0.) THEN
2762           qci(i, k, 1) = 0.
2763         ELSE
2764           qci(i, k, 1) = qci(i, k, 1) - qtmp
2765         END IF
2766         t(i, k) = t(i, k) + xlf/cpm(i, k)*qtmp
2767 !---------------------------------------------------------------
2768 ! pgfrz: freezing of rain water [LFO 45]
2769 !        (T<T0, R->G) max=qrs(i,k,1),min=0. t+
2770 !---------------------------------------------------------------
2771 !update xl, cpm
2772         xl(i, k) = XLCAL(t(i, k))
2773 !         cpm(i,k)=cpmcal(q(i,k))!not change
2774         xlf = xls - xl(i, k)
2775         supcol = t0c - t(i, k)
2776         IF (supcol .LT. 0.) xlf = xlf0
2777         IF (qrs(i, k, 1) .GT. 0.) THEN
2778           pwr1 = den(i, k)**(3./4.)
2779           pwr2 = qrs(i, k, 1)**(7./4.)
2780           temp = pgfrz_a*(EXP(pfrz2*supcol)-1.)*pwr1*pwr2
2781         ELSE
2782           temp = 0.
2783         END IF
2784         IF (temp*dtcld .GT. qrs(i, k, 1)) THEN
2785           pfrzdtr = qrs(i, k, 1)
2786         ELSE
2787           pfrzdtr = temp*dtcld
2788         END IF
2789         IF (pfrzdtr .LT. 0.) THEN
2790           qtmp = 0.
2791         ELSE
2792           qtmp = pfrzdtr
2793         END IF
2794         IF (qtmp .GE. 0.) THEN
2795           abs3 = qtmp
2796         ELSE
2797           abs3 = -qtmp
2798         END IF
2799         IF (abs3 .LT. qmin) qtmp = 0.
2800         IF (qrs(i, k, 3) + qtmp .LT. 0.) THEN
2801           qrs(i, k, 3) = 0.
2802         ELSE
2803           qrs(i, k, 3) = qrs(i, k, 3) + qtmp
2804         END IF
2805         IF (qrs(i, k, 1) - qtmp .LT. 0.) THEN
2806           qrs(i, k, 1) = 0.
2807         ELSE
2808           qrs(i, k, 1) = qrs(i, k, 1) - qtmp
2809         END IF
2810         t(i, k) = t(i, k) + xlf/cpm(i, k)*qtmp
2811       END DO
2812     END DO
2813   END SUBROUTINE RAINSC
2814
2815 !  Differentiation of warmr in forward (tangent) mode (with options r8):
2816 !   variations   of useful results: q t qs xl pracw rh qrs prevp
2817 !                qci praut
2818 !   with respect to varying inputs: p q t qs xl pracw rh den qrs
2819 !                prevp qci praut
2820 !=======================================================================
2821 !
2822 !=======================================================================
2823   SUBROUTINE G_WARMR(t, g_t, q, g_q, qci, g_qci, qrs, g_qrs, den, g_den&
2824 &   , p, g_p, dtcld, xl, g_xl, rh, g_rh, qs, g_qs, praut, g_praut, pracw&
2825 &   , g_pracw, prevp, g_prevp, ims, ime, kms, kme, its, ite, kts, kte)
2826     IMPLICIT NONE
2827     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
2828 !------------------------------------------------------------------
2829     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
2830     REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci
2831     REAL, DIMENSION(ims:ime, kms:kme) :: q, den, p
2832     REAL, DIMENSION(ims:ime, kms:kme) :: g_q, g_den, g_p
2833     REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, qrs, work1
2834     REAL, DIMENSION(its:ite, kts:kte, 3) :: g_rh, g_qs, g_qrs
2835     REAL, DIMENSION(its:ite, kts:kte) :: praut, prevp, pracw, xl, denfac&
2836 &   , t, cpm
2837     REAL, DIMENSION(its:ite, kts:kte) :: g_praut, g_prevp, g_pracw, g_xl&
2838 &   , g_t, g_cpm
2839     REAL :: coeres, supsat, satdt, dtcld, praut1
2840     REAL :: g_supsat, g_satdt, g_praut1
2841     INTEGER :: i, k
2842     REAL :: fqv, fqc, fqr, fqc0, fprevp, prevp0, prevp1, temp, a, b, c, &
2843 &   d, e
2844     REAL :: g_fqc0, g_a, g_b, g_c, g_d, g_e
2845     INTRINSIC LOG
2846     INTRINSIC EXP
2847     INTRINSIC MIN
2848     INTRINSIC ABS
2849     INTRINSIC MAX
2850     INTRINSIC SQRT
2851     REAL :: x1
2852     REAL :: g_x1
2853     REAL :: x2
2854     REAL :: g_x2
2855     REAL :: x3
2856     REAL :: g_x3
2857     REAL :: abs0
2858     REAL :: abs1
2859     REAL :: max1
2860     REAL :: g_max1
2861     REAL :: max2
2862     REAL :: g_max2
2863     REAL :: abs2
2864     REAL :: arg1
2865     REAL :: g_arg1
2866     REAL :: pwy1
2867     REAL :: pwr1
2868     REAL :: g_pwr1
2869     REAL :: pwy2
2870     REAL :: pwr2
2871     REAL :: g_pwr2
2872     REAL :: pwx1
2873     REAL :: g_pwx1
2874     REAL :: pwr3
2875     REAL :: g_pwr3
2876     REAL :: pwy4
2877     REAL :: pwr4
2878     REAL :: g_pwr4
2879     REAL :: pwy5
2880     REAL :: pwr5
2881     REAL :: g_pwr5
2882     REAL :: temp0
2883     REAL :: temp1
2884     REAL :: temp2
2885     REAL :: temp3
2886     g_cpm = 0.0_8
2887     DO k=kts,kte
2888       DO i=its,ite
2889 !---------------------------------------------------------------
2890 ! praut: auto conversion rate from cloud to rain [HDC 16]
2891 !        (C->R) praut>0 max=qci(i,k,1)/dtcld, min=0.
2892 !---------------------------------------------------------------
2893         CALL G_SMOOTHIF(qci(i, k, 1), g_qci(i, k, 1), qc0, fqc0, g_fqc0&
2894 &                 , 'q0')
2895 !qc0=5.03e-4
2896         IF (qci(i, k, 1) .GT. 0.) THEN
2897 ! x**a need x>0
2898 !(qci(i,k,1)**(7./3.))
2899           g_arg1 = 7.*g_qci(i, k, 1)/(3.*qci(i, k, 1))
2900           arg1 = LOG(qci(i, k, 1))*(7./3.)
2901           temp0 = EXP(arg1)
2902           g_praut1 = qck1*(temp0*g_fqc0+fqc0*EXP(arg1)*g_arg1)
2903           praut1 = qck1*(fqc0*temp0)
2904         ELSE
2905           praut1 = 0.
2906           g_praut1 = 0.0_8
2907         END IF
2908         IF (praut1 .GT. qci(i, k, 1)/dtcld) THEN
2909           g_praut(i, k) = g_qci(i, k, 1)/dtcld
2910           praut(i, k) = qci(i, k, 1)/dtcld
2911         ELSE
2912           g_praut(i, k) = g_praut1
2913           praut(i, k) = praut1
2914         END IF
2915         IF (praut(i, k) .GE. 0.) THEN
2916           abs0 = praut(i, k)
2917         ELSE
2918           abs0 = -praut(i, k)
2919         END IF
2920         IF (abs0 .LT. qmin/dtcld) THEN
2921           g_praut(i, k) = 0.0_8
2922           praut(i, k) = 0.
2923         END IF
2924         IF (qci(i, k, 1) - praut(i, k)*dtcld .LT. 0.) THEN
2925           g_qci(i, k, 1) = 0.0_8
2926           qci(i, k, 1) = 0.
2927         ELSE
2928           g_qci(i, k, 1) = g_qci(i, k, 1) - dtcld*g_praut(i, k)
2929           qci(i, k, 1) = qci(i, k, 1) - praut(i, k)*dtcld
2930         END IF
2931         IF (qrs(i, k, 1) + praut(i, k)*dtcld .LT. 0.) THEN
2932           g_qrs(i, k, 1) = 0.0_8
2933           qrs(i, k, 1) = 0.
2934         ELSE
2935           g_qrs(i, k, 1) = g_qrs(i, k, 1) + dtcld*g_praut(i, k)
2936           qrs(i, k, 1) = qrs(i, k, 1) + praut(i, k)*dtcld
2937         END IF
2938         g_praut(i, k) = 0.0_8
2939         praut(i, k) = 0.
2940 !---------------------------------------------------------------
2941 ! pracw: accretion of cloud water by rain [LFO 51]
2942 !        (C->R) max=qci(i,k,1)/dtcld, min=0.
2943 !---------------------------------------------------------------
2944 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
2945 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
2946         IF (qrs(i, k, 1) .GT. 0 .AND. qci(i, k, 1) .GT. 0.) THEN
2947           pwy1 = (1.+bvtr)/4.
2948           IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE.&
2949 &             INT(pwy1))) THEN
2950             g_pwr1 = 0.0_8
2951           ELSE
2952             g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
2953           END IF
2954           pwr1 = den(i, k)**pwy1
2955           pwy2 = (3.+bvtr)/4.
2956           IF (qrs(i, k, 1) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 &
2957 &             .NE. INT(pwy2))) THEN
2958             g_pwr2 = 0.0_8
2959           ELSE
2960             g_pwr2 = pwy2*qrs(i, k, 1)**(pwy2-1)*g_qrs(i, k, 1)
2961           END IF
2962           pwr2 = qrs(i, k, 1)**pwy2
2963           g_pracw(i, k) = pracw_a*(qci(i, k, 1)*(pwr2*g_pwr1+pwr1*g_pwr2&
2964 &           )+pwr1*pwr2*g_qci(i, k, 1))
2965           pracw(i, k) = pracw_a*pwr1*pwr2*qci(i, k, 1)
2966         ELSE
2967           g_pracw(i, k) = 0.0_8
2968           pracw(i, k) = 0.
2969         END IF
2970         IF (pracw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
2971           g_x1 = g_qci(i, k, 1)/dtcld
2972           x1 = qci(i, k, 1)/dtcld
2973         ELSE
2974           g_x1 = g_pracw(i, k)
2975           x1 = pracw(i, k)
2976         END IF
2977         IF (x1 .LT. 0.) THEN
2978           g_pracw(i, k) = 0.0_8
2979           pracw(i, k) = 0.
2980         ELSE
2981           g_pracw(i, k) = g_x1
2982           pracw(i, k) = x1
2983         END IF
2984         IF (pracw(i, k) .GE. 0.) THEN
2985           abs1 = pracw(i, k)
2986         ELSE
2987           abs1 = -pracw(i, k)
2988         END IF
2989         IF (abs1 .LT. qmin/dtcld) THEN
2990           g_pracw(i, k) = 0.0_8
2991           pracw(i, k) = 0.
2992         END IF
2993         IF (qci(i, k, 1) - pracw(i, k)*dtcld .LT. 0.) THEN
2994           g_qci(i, k, 1) = 0.0_8
2995           qci(i, k, 1) = 0.
2996         ELSE
2997           g_qci(i, k, 1) = g_qci(i, k, 1) - dtcld*g_pracw(i, k)
2998           qci(i, k, 1) = qci(i, k, 1) - pracw(i, k)*dtcld
2999         END IF
3000         IF (qrs(i, k, 1) + pracw(i, k)*dtcld .LT. 0.) THEN
3001           g_qrs(i, k, 1) = 0.0_8
3002           qrs(i, k, 1) = 0.
3003         ELSE
3004           g_qrs(i, k, 1) = g_qrs(i, k, 1) + dtcld*g_pracw(i, k)
3005           qrs(i, k, 1) = qrs(i, k, 1) + pracw(i, k)*dtcld
3006         END IF
3007         g_pracw(i, k) = 0.0_8
3008         pracw(i, k) = 0.
3009 !
3010 !---------------------------------------------------------------
3011 ! prevp: evaporation/condensation rate of rain [HDC 14]
3012 !        (V->R or R->V) rh(i,k,1)>1., prevp>0, V->R, min=0.,                max=satdt ;
3013 !                       rh(i,k,1)<1., prevp<0, R->V, min=-qrs(i,k,1)/dtcld, max=0.
3014 !---------------------------------------------------------------
3015 !update rh
3016         CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), &
3017 &               g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs&
3018 &               (i, k, :))
3019 !update xl, cpm
3020         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
3021         g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k))
3022         g_supsat = g_q(i, k) - g_qs(i, k, 1)
3023         supsat = q(i, k) - qs(i, k, 1)
3024         g_satdt = g_supsat/dtcld
3025         satdt = supsat/dtcld
3026         IF (qrs(i, k, 1) .LT. qcrmin) THEN
3027           max1 = qcrmin
3028           g_max1 = 0.0_8
3029         ELSE
3030           g_max1 = g_qrs(i, k, 1)
3031           max1 = qrs(i, k, 1)
3032         END IF
3033         temp0 = den(i, k)*max1
3034         temp1 = SQRT(temp0)
3035         IF (temp0 .EQ. 0.0_8) THEN
3036           g_a = 0.0_8
3037         ELSE
3038           g_a = (max1*g_den(i, k)+den(i, k)*g_max1)/(2.0*temp1)
3039         END IF
3040         a = temp1
3041         IF (qrs(i, k, 1) .LT. qcrmin) THEN
3042           max2 = qcrmin
3043           g_max2 = 0.0_8
3044         ELSE
3045           g_max2 = g_qrs(i, k, 1)
3046           max2 = qrs(i, k, 1)
3047         END IF
3048         g_pwx1 = g_t(i, k)
3049         pwx1 = t(i, k) + 120.
3050         IF (pwx1 .LE. 0.0_8 .AND. (1.0/6. .EQ. 0.0_8 .OR. 1.0/6. .NE. &
3051 &           INT(1.0/6.))) THEN
3052           g_pwr1 = 0.0_8
3053         ELSE
3054           g_pwr1 = pwx1**(1.0/6.-1)*g_pwx1/6.
3055         END IF
3056         pwr1 = pwx1**(1./6.)
3057         IF (t(i, k) .LE. 0.0_8 .AND. (5.12/6. .EQ. 0.0_8 .OR. 5.12/6. &
3058 &           .NE. INT(5.12/6.))) THEN
3059           g_pwr2 = 0.0_8
3060         ELSE
3061           g_pwr2 = 5.12*t(i, k)**(5.12/6.-1)*g_t(i, k)/6.
3062         END IF
3063         pwr2 = t(i, k)**(5.12/6.)
3064         IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. .NE.&
3065 &           INT(1.0/3.))) THEN
3066           g_pwr3 = 0.0_8
3067         ELSE
3068           g_pwr3 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3.
3069         END IF
3070         pwr3 = p(i, k)**(1./3.)
3071         pwy4 = (13.+3.*bvtr)/24.
3072         IF (den(i, k) .LE. 0.0_8 .AND. (pwy4 .EQ. 0.0_8 .OR. pwy4 .NE. &
3073 &           INT(pwy4))) THEN
3074           g_pwr4 = 0.0_8
3075         ELSE
3076           g_pwr4 = pwy4*den(i, k)**(pwy4-1)*g_den(i, k)
3077         END IF
3078         pwr4 = den(i, k)**pwy4
3079         pwy5 = (5.+bvtr)/8.
3080         IF (max2 .LE. 0.0_8 .AND. (pwy5 .EQ. 0.0_8 .OR. pwy5 .NE. INT(&
3081 &           pwy5))) THEN
3082           g_pwr5 = 0.0_8
3083         ELSE
3084           g_pwr5 = pwy5*max2**(pwy5-1)*g_max2
3085         END IF
3086         pwr5 = max2**pwy5
3087         temp1 = pwr1*pwr3/pwr2
3088         g_b = pwr4*pwr5*(pwr3*g_pwr1+pwr1*g_pwr3-temp1*g_pwr2)/pwr2 + &
3089 &         temp1*(pwr5*g_pwr4+pwr4*g_pwr5)
3090         b = temp1*(pwr4*pwr5)
3091         temp1 = rv*t(i, k)**3.5
3092         temp0 = den(i, k)*(t(i, k)+120.)
3093         temp2 = xl(i, k)*xl(i, k)
3094         temp3 = temp2*temp0/temp1
3095         g_c = diffac_a*(temp0*2*xl(i, k)*g_xl(i, k)+temp2*((t(i, k)+120.&
3096 &         )*g_den(i, k)+den(i, k)*g_t(i, k))-temp3*rv*3.5*t(i, k)**2.5*&
3097 &         g_t(i, k))/temp1
3098         c = diffac_a*temp3
3099         temp3 = t(i, k)**1.81
3100         temp2 = temp3*qs(i, k, 1)
3101         temp1 = p(i, k)/temp2
3102         g_d = diffac_b*(g_p(i, k)-temp1*(qs(i, k, 1)*1.81*t(i, k)**0.81*&
3103 &         g_t(i, k)+temp3*g_qs(i, k, 1)))/temp2
3104         d = diffac_b*temp1
3105         temp3 = (rh(i, k, 1)-1.)/(c+d)
3106         g_e = (g_rh(i, k, 1)-temp3*(g_c+g_d))/(c+d)
3107         e = temp3
3108         temp3 = prevp_a*a + prevp_b*b
3109         g_prevp(i, k) = e*(prevp_a*g_a+prevp_b*g_b) + temp3*g_e
3110         prevp(i, k) = temp3*e
3111         IF (prevp(i, k) .LT. 0.) THEN
3112           IF (prevp(i, k) .LT. -(qrs(i, k, 1)/dtcld)) THEN
3113             g_x2 = -(g_qrs(i, k, 1)/dtcld)
3114             x2 = -(qrs(i, k, 1)/dtcld)
3115           ELSE
3116             g_x2 = g_prevp(i, k)
3117             x2 = prevp(i, k)
3118           END IF
3119           IF (x2 .GT. 0.) THEN
3120             g_prevp(i, k) = 0.0_8
3121             prevp(i, k) = 0.
3122           ELSE
3123             g_prevp(i, k) = g_x2
3124             prevp(i, k) = x2
3125           END IF
3126         ELSE
3127           IF (prevp(i, k) .GT. satdt) THEN
3128             g_x3 = g_satdt
3129             x3 = satdt
3130           ELSE
3131             g_x3 = g_prevp(i, k)
3132             x3 = prevp(i, k)
3133           END IF
3134           IF (x3 .LT. 0.) THEN
3135             g_prevp(i, k) = 0.0_8
3136             prevp(i, k) = 0.
3137           ELSE
3138             g_prevp(i, k) = g_x3
3139             prevp(i, k) = x3
3140           END IF
3141         END IF
3142         IF (prevp(i, k) .GE. 0.) THEN
3143           abs2 = prevp(i, k)
3144         ELSE
3145           abs2 = -prevp(i, k)
3146         END IF
3147         IF (abs2 .LT. qmin/dtcld) THEN
3148           g_prevp(i, k) = 0.0_8
3149           prevp(i, k) = 0.
3150         END IF
3151         IF (q(i, k) - prevp(i, k)*dtcld .LT. 0.) THEN
3152           g_q(i, k) = 0.0_8
3153           q(i, k) = 0.
3154         ELSE
3155           g_q(i, k) = g_q(i, k) - dtcld*g_prevp(i, k)
3156           q(i, k) = q(i, k) - prevp(i, k)*dtcld
3157         END IF
3158         IF (qrs(i, k, 1) + prevp(i, k)*dtcld .LT. 0.) THEN
3159           g_qrs(i, k, 1) = 0.0_8
3160           qrs(i, k, 1) = 0.
3161         ELSE
3162           g_qrs(i, k, 1) = g_qrs(i, k, 1) + dtcld*g_prevp(i, k)
3163           qrs(i, k, 1) = qrs(i, k, 1) + prevp(i, k)*dtcld
3164         END IF
3165         temp3 = prevp(i, k)*xl(i, k)/cpm(i, k)
3166         g_t(i, k) = g_t(i, k) + dtcld*(xl(i, k)*g_prevp(i, k)+prevp(i, k&
3167 &         )*g_xl(i, k)-temp3*g_cpm(i, k))/cpm(i, k)
3168         t(i, k) = t(i, k) + dtcld*temp3
3169         g_prevp(i, k) = 0.0_8
3170         prevp(i, k) = 0.
3171       END DO
3172     END DO
3173   END SUBROUTINE G_WARMR
3174
3175 !=======================================================================
3176 !
3177 !=======================================================================
3178   SUBROUTINE WARMR(t, q, qci, qrs, den, p, dtcld, xl, rh, qs, praut, &
3179 &   pracw, prevp, ims, ime, kms, kme, its, ite, kts, kte)
3180     IMPLICIT NONE
3181     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
3182 !------------------------------------------------------------------
3183     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
3184     REAL, DIMENSION(ims:ime, kms:kme) :: q, den, p
3185     REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, qrs, work1
3186     REAL, DIMENSION(its:ite, kts:kte) :: praut, prevp, pracw, xl, denfac&
3187 &   , t, cpm
3188     REAL :: coeres, supsat, satdt, dtcld, praut1
3189     INTEGER :: i, k
3190     REAL :: fqv, fqc, fqr, fqc0, fprevp, prevp0, prevp1, temp, a, b, c, &
3191 &   d, e
3192     INTRINSIC LOG
3193     INTRINSIC EXP
3194     INTRINSIC MIN
3195     INTRINSIC ABS
3196     INTRINSIC MAX
3197     INTRINSIC SQRT
3198     REAL :: x1
3199     REAL :: x2
3200     REAL :: x3
3201     REAL :: abs0
3202     REAL :: abs1
3203     REAL :: max1
3204     REAL :: max2
3205     REAL :: abs2
3206     REAL :: arg1
3207     REAL :: pwy1
3208     REAL :: pwr1
3209     REAL :: pwy2
3210     REAL :: pwr2
3211     REAL :: pwx1
3212     REAL :: pwr3
3213     REAL :: pwy4
3214     REAL :: pwr4
3215     REAL :: pwy5
3216     REAL :: pwr5
3217     DO k=kts,kte
3218       DO i=its,ite
3219 !---------------------------------------------------------------
3220 ! praut: auto conversion rate from cloud to rain [HDC 16]
3221 !        (C->R) praut>0 max=qci(i,k,1)/dtcld, min=0.
3222 !---------------------------------------------------------------
3223         CALL SMOOTHIF(qci(i, k, 1), qc0, fqc0, 'q0')
3224 !qc0=5.03e-4
3225         IF (qci(i, k, 1) .GT. 0.) THEN
3226 ! x**a need x>0
3227 !(qci(i,k,1)**(7./3.))
3228           arg1 = LOG(qci(i, k, 1))*(7./3.)
3229           praut1 = fqc0*qck1*EXP(arg1)
3230         ELSE
3231           praut1 = 0.
3232         END IF
3233         IF (praut1 .GT. qci(i, k, 1)/dtcld) THEN
3234           praut(i, k) = qci(i, k, 1)/dtcld
3235         ELSE
3236           praut(i, k) = praut1
3237         END IF
3238         IF (praut(i, k) .GE. 0.) THEN
3239           abs0 = praut(i, k)
3240         ELSE
3241           abs0 = -praut(i, k)
3242         END IF
3243         IF (abs0 .LT. qmin/dtcld) praut(i, k) = 0.
3244         IF (qci(i, k, 1) - praut(i, k)*dtcld .LT. 0.) THEN
3245           qci(i, k, 1) = 0.
3246         ELSE
3247           qci(i, k, 1) = qci(i, k, 1) - praut(i, k)*dtcld
3248         END IF
3249         IF (qrs(i, k, 1) + praut(i, k)*dtcld .LT. 0.) THEN
3250           qrs(i, k, 1) = 0.
3251         ELSE
3252           qrs(i, k, 1) = qrs(i, k, 1) + praut(i, k)*dtcld
3253         END IF
3254         praut(i, k) = 0.
3255 !---------------------------------------------------------------
3256 ! pracw: accretion of cloud water by rain [LFO 51]
3257 !        (C->R) max=qci(i,k,1)/dtcld, min=0.
3258 !---------------------------------------------------------------
3259 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
3260 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
3261         IF (qrs(i, k, 1) .GT. 0 .AND. qci(i, k, 1) .GT. 0.) THEN
3262           pwy1 = (1.+bvtr)/4.
3263           pwr1 = den(i, k)**pwy1
3264           pwy2 = (3.+bvtr)/4.
3265           pwr2 = qrs(i, k, 1)**pwy2
3266           pracw(i, k) = pracw_a*pwr1*pwr2*qci(i, k, 1)
3267         ELSE
3268           pracw(i, k) = 0.
3269         END IF
3270         IF (pracw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
3271           x1 = qci(i, k, 1)/dtcld
3272         ELSE
3273           x1 = pracw(i, k)
3274         END IF
3275         IF (x1 .LT. 0.) THEN
3276           pracw(i, k) = 0.
3277         ELSE
3278           pracw(i, k) = x1
3279         END IF
3280         IF (pracw(i, k) .GE. 0.) THEN
3281           abs1 = pracw(i, k)
3282         ELSE
3283           abs1 = -pracw(i, k)
3284         END IF
3285         IF (abs1 .LT. qmin/dtcld) pracw(i, k) = 0.
3286         IF (qci(i, k, 1) - pracw(i, k)*dtcld .LT. 0.) THEN
3287           qci(i, k, 1) = 0.
3288         ELSE
3289           qci(i, k, 1) = qci(i, k, 1) - pracw(i, k)*dtcld
3290         END IF
3291         IF (qrs(i, k, 1) + pracw(i, k)*dtcld .LT. 0.) THEN
3292           qrs(i, k, 1) = 0.
3293         ELSE
3294           qrs(i, k, 1) = qrs(i, k, 1) + pracw(i, k)*dtcld
3295         END IF
3296         pracw(i, k) = 0.
3297 !
3298 !---------------------------------------------------------------
3299 ! prevp: evaporation/condensation rate of rain [HDC 14]
3300 !        (V->R or R->V) rh(i,k,1)>1., prevp>0, V->R, min=0.,                max=satdt ;
3301 !                       rh(i,k,1)<1., prevp<0, R->V, min=-qrs(i,k,1)/dtcld, max=0.
3302 !---------------------------------------------------------------
3303 !update rh
3304         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
3305 !update xl, cpm
3306         xl(i, k) = XLCAL(t(i, k))
3307         cpm(i, k) = CPMCAL(q(i, k))
3308         supsat = q(i, k) - qs(i, k, 1)
3309         satdt = supsat/dtcld
3310         IF (qrs(i, k, 1) .LT. qcrmin) THEN
3311           max1 = qcrmin
3312         ELSE
3313           max1 = qrs(i, k, 1)
3314         END IF
3315         a = SQRT(den(i, k)*max1)
3316         IF (qrs(i, k, 1) .LT. qcrmin) THEN
3317           max2 = qcrmin
3318         ELSE
3319           max2 = qrs(i, k, 1)
3320         END IF
3321         pwx1 = t(i, k) + 120.
3322         pwr1 = pwx1**(1./6.)
3323         pwr2 = t(i, k)**(5.12/6.)
3324         pwr3 = p(i, k)**(1./3.)
3325         pwy4 = (13.+3.*bvtr)/24.
3326         pwr4 = den(i, k)**pwy4
3327         pwy5 = (5.+bvtr)/8.
3328         pwr5 = max2**pwy5
3329         b = pwr1/pwr2*pwr3*pwr4*pwr5
3330         c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, &
3331 &         k)**3.5
3332         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1)
3333         e = (rh(i, k, 1)-1.)/(c+d)
3334         prevp(i, k) = (prevp_a*a+prevp_b*b)*e
3335         IF (prevp(i, k) .LT. 0.) THEN
3336           IF (prevp(i, k) .LT. -(qrs(i, k, 1)/dtcld)) THEN
3337             x2 = -(qrs(i, k, 1)/dtcld)
3338           ELSE
3339             x2 = prevp(i, k)
3340           END IF
3341           IF (x2 .GT. 0.) THEN
3342             prevp(i, k) = 0.
3343           ELSE
3344             prevp(i, k) = x2
3345           END IF
3346         ELSE
3347           IF (prevp(i, k) .GT. satdt) THEN
3348             x3 = satdt
3349           ELSE
3350             x3 = prevp(i, k)
3351           END IF
3352           IF (x3 .LT. 0.) THEN
3353             prevp(i, k) = 0.
3354           ELSE
3355             prevp(i, k) = x3
3356           END IF
3357         END IF
3358         IF (prevp(i, k) .GE. 0.) THEN
3359           abs2 = prevp(i, k)
3360         ELSE
3361           abs2 = -prevp(i, k)
3362         END IF
3363         IF (abs2 .LT. qmin/dtcld) prevp(i, k) = 0.
3364         IF (q(i, k) - prevp(i, k)*dtcld .LT. 0.) THEN
3365           q(i, k) = 0.
3366         ELSE
3367           q(i, k) = q(i, k) - prevp(i, k)*dtcld
3368         END IF
3369         IF (qrs(i, k, 1) + prevp(i, k)*dtcld .LT. 0.) THEN
3370           qrs(i, k, 1) = 0.
3371         ELSE
3372           qrs(i, k, 1) = qrs(i, k, 1) + prevp(i, k)*dtcld
3373         END IF
3374         t(i, k) = t(i, k) + prevp(i, k)*dtcld*xl(i, k)/cpm(i, k)
3375         prevp(i, k) = 0.
3376       END DO
3377     END DO
3378   END SUBROUTINE WARMR
3379
3380 !  Differentiation of accret1 in forward (tangent) mode (with options r8):
3381 !   variations   of useful results: piacr psaci pgaci t praci psacw
3382 !                pgacw qrs qci
3383 !   with respect to varying inputs: piacr psaci q pgaci t praci
3384 !                psacw pgacw den qrs qci
3385 !===================================================================
3386   SUBROUTINE G_ACCRET1(qci, g_qci, den, g_den, qrs, g_qrs, t, g_t, q, &
3387 &   g_q, dtcld, praci, g_praci, piacr, g_piacr, psaci, g_psaci, pgaci, &
3388 &   g_pgaci, psacw, g_psacw, pgacw, g_pgacw, ims, ime, kms, kme, its, &
3389 &   ite, kts, kte)
3390     IMPLICIT NONE
3391     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
3392 !-------------------------------------------------------------------
3393     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
3394     REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci
3395     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
3396     REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs
3397     REAL, DIMENSION(ims:ime, kms:kme) :: den, q
3398     REAL, DIMENSION(ims:ime, kms:kme) :: g_den, g_q
3399     REAL, DIMENSION(its:ite, kts:kte) :: praci, piacr, psaci, pgaci, &
3400 &   psacw, pgacw, t, xl, cpm
3401     REAL, DIMENSION(its:ite, kts:kte) :: g_praci, g_piacr, g_psaci, &
3402 &   g_pgaci, g_psacw, g_pgacw, g_t, g_xl, g_cpm
3403     REAL :: supcol, dtcld, eacrs, egi, praci1, piacr1, psaci1, pgaci1, &
3404 &   temp, temp0
3405     REAL :: g_supcol, g_eacrs, g_egi, g_praci1, g_piacr1, g_psaci1, &
3406 &   g_pgaci1
3407     INTEGER :: i, k
3408     REAL :: fsupcol, fqc, fqi, fqr, fqs, fqg, delta3, xlf, a, b, c, d, e
3409     REAL :: g_fsupcol, g_xlf, g_a, g_b, g_c, g_d
3410     INTRINSIC MAX
3411     INTRINSIC SQRT
3412     INTRINSIC ABS
3413     INTRINSIC MIN
3414     INTRINSIC EXP
3415     REAL :: x1
3416     REAL :: g_x1
3417     REAL :: x2
3418     REAL :: g_x2
3419     REAL :: x3
3420     REAL :: g_x3
3421     REAL :: x4
3422     REAL :: g_x4
3423     REAL :: x5
3424     REAL :: g_x5
3425     REAL :: y1
3426     REAL :: g_y1
3427     REAL :: y2
3428     REAL :: g_y2
3429     REAL :: y3
3430     REAL :: g_y3
3431     REAL :: y4
3432     REAL :: g_y4
3433     REAL :: y5
3434     REAL :: g_y5
3435     REAL :: x6
3436     REAL :: g_x6
3437     REAL :: x7
3438     REAL :: g_x7
3439     REAL :: x8
3440     REAL :: g_x8
3441     REAL :: x9
3442     REAL :: g_x9
3443     REAL :: x10
3444     REAL :: g_x10
3445     REAL :: x11
3446     REAL :: g_x11
3447     REAL :: y6
3448     REAL :: g_y6
3449     REAL :: max1
3450     REAL :: g_max1
3451     REAL :: max2
3452     REAL :: g_max2
3453     REAL :: max3
3454     REAL :: g_max3
3455     REAL :: max4
3456     REAL :: g_max4
3457     REAL :: max5
3458     REAL :: g_max5
3459     REAL :: abs0
3460     REAL :: g_abs0
3461     REAL :: abs1
3462     REAL :: abs2
3463     REAL :: max6
3464     REAL :: g_max6
3465     REAL :: max7
3466     REAL :: g_max7
3467     REAL :: max8
3468     REAL :: g_max8
3469     REAL :: max9
3470     REAL :: g_max9
3471     REAL :: max10
3472     REAL :: g_max10
3473     REAL :: max11
3474     REAL :: g_max11
3475     REAL :: abs3
3476     REAL :: g_abs3
3477     REAL :: abs4
3478     REAL :: max12
3479     REAL :: g_max12
3480     REAL :: max13
3481     REAL :: g_max13
3482     REAL :: max14
3483     REAL :: g_max14
3484     REAL :: max15
3485     REAL :: g_max15
3486     REAL :: max16
3487     REAL :: g_max16
3488     REAL :: abs5
3489     REAL :: g_abs5
3490     REAL :: abs6
3491     REAL :: max17
3492     REAL :: g_max17
3493     REAL :: abs7
3494     REAL :: abs8
3495     REAL :: max18
3496     REAL :: g_max18
3497     REAL :: max19
3498     REAL :: g_max19
3499     REAL :: max20
3500     REAL :: g_max20
3501     REAL :: max21
3502     REAL :: g_max21
3503     REAL :: max22
3504     REAL :: g_max22
3505     REAL :: max23
3506     REAL :: g_max23
3507     REAL :: max24
3508     REAL :: g_max24
3509     REAL :: max25
3510     REAL :: g_max25
3511     REAL :: max26
3512     REAL :: g_max26
3513     REAL :: max27
3514     REAL :: g_max27
3515     REAL :: max28
3516     REAL :: g_max28
3517     REAL :: max29
3518     REAL :: g_max29
3519     REAL :: max30
3520     REAL :: g_max30
3521     REAL :: pwy1
3522     REAL :: pwr1
3523     REAL :: g_pwr1
3524     REAL :: pwy2
3525     REAL :: pwr2
3526     REAL :: g_pwr2
3527     REAL :: pwx1
3528     REAL :: g_pwx1
3529     REAL :: result1
3530     REAL :: g_result1
3531     REAL :: result2
3532     REAL :: g_result2
3533     REAL :: result3
3534     REAL :: g_result3
3535     REAL :: arg1
3536     REAL :: g_arg1
3537     REAL :: temp1
3538     REAL :: temp2
3539     g_cpm = 0.0_8
3540     g_xl = 0.0_8
3541     DO k=kts,kte
3542       DO i=its,ite
3543 !-------------------------------------------------------------
3544 ! praci: Accretion of cloud ice by rain [LFO 25]
3545 !        (T<T0: I->S or I->G) praci: min=0,max=qci(i,k,2)/dtcld
3546 !-------------------------------------------------------------
3547         g_supcol = -g_t(i, k)
3548         supcol = t0c - t(i, k)
3549         CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0')
3550         IF (qrs(i, k, 1) .LT. qcrmin) THEN
3551           max1 = qcrmin
3552           g_max1 = 0.0_8
3553         ELSE
3554           g_max1 = g_qrs(i, k, 1)
3555           max1 = qrs(i, k, 1)
3556         END IF
3557         pwy1 = (bvtr-2.)/4.
3558         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
3559 &           INT(pwy1))) THEN
3560           g_pwr1 = 0.0_8
3561         ELSE
3562           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
3563         END IF
3564         pwr1 = den(i, k)**pwy1
3565         pwy2 = bvtr/4.
3566         IF (max1 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
3567 &           pwy2))) THEN
3568           g_pwr2 = 0.0_8
3569         ELSE
3570           g_pwr2 = pwy2*max1**(pwy2-1)*g_max1
3571         END IF
3572         pwr2 = max1**pwy2
3573         g_vt2r = vt2r_a*(pwr2*g_pwr1+pwr1*g_pwr2)
3574         vt2r = vt2r_a*pwr1*pwr2
3575         IF (qci(i, k, 2) .LT. qmin) THEN
3576           max2 = qmin
3577           g_max2 = 0.0_8
3578         ELSE
3579           g_max2 = g_qci(i, k, 2)
3580           max2 = qci(i, k, 2)
3581         END IF
3582         g_pwx1 = max2*g_den(i, k) + den(i, k)*g_max2
3583         pwx1 = den(i, k)*max2
3584         IF (pwx1 .LE. 0.0_8 .AND. (1.31/8. .EQ. 0.0_8 .OR. 1.31/8. .NE. &
3585 &           INT(1.31/8.))) THEN
3586           g_pwr1 = 0.0_8
3587         ELSE
3588           g_pwr1 = 1.31*pwx1**(1.31/8.-1)*g_pwx1/8.
3589         END IF
3590         pwr1 = pwx1**(1.31/8.)
3591         g_vt2i = vt2i_a*g_pwr1
3592         vt2i = vt2i_a*pwr1
3593         IF (qrs(i, k, 1) .LT. qcrmin) THEN
3594           max3 = qcrmin
3595           g_max3 = 0.0_8
3596         ELSE
3597           g_max3 = g_qrs(i, k, 1)
3598           max3 = qrs(i, k, 1)
3599         END IF
3600         IF (qci(i, k, 2) .LT. qmin) THEN
3601           max18 = qmin
3602           g_max18 = 0.0_8
3603         ELSE
3604           g_max18 = g_qci(i, k, 2)
3605           max18 = qci(i, k, 2)
3606         END IF
3607         g_pwx1 = max3*g_den(i, k) + den(i, k)*g_max3
3608         pwx1 = den(i, k)*max3
3609         IF (pwx1 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT(&
3610 &           3./4.))) THEN
3611           g_pwr1 = 0.0_8
3612         ELSE
3613           g_pwr1 = 3.*pwx1**(3./4.-1)*g_pwx1/4.
3614         END IF
3615         pwr1 = pwx1**(3./4.)
3616         g_b = max18*g_pwr1 + pwr1*g_max18
3617         b = pwr1*max18
3618         IF (qrs(i, k, 1) .LT. qcrmin) THEN
3619           max4 = qcrmin
3620           g_max4 = 0.0_8
3621         ELSE
3622           g_max4 = g_qrs(i, k, 1)
3623           max4 = qrs(i, k, 1)
3624         END IF
3625         IF (qci(i, k, 2) .LT. qmin) THEN
3626           max19 = qmin
3627           g_max19 = 0.0_8
3628         ELSE
3629           g_max19 = g_qci(i, k, 2)
3630           max19 = qci(i, k, 2)
3631         END IF
3632         IF (den(i, k) .LE. 0.0_8 .AND. (5./8. .EQ. 0.0_8 .OR. 5./8. .NE.&
3633 &           INT(5./8.))) THEN
3634           g_pwr1 = 0.0_8
3635         ELSE
3636           g_pwr1 = 5.*den(i, k)**(5./8.-1)*g_den(i, k)/8.
3637         END IF
3638         pwr1 = den(i, k)**(5./8.)
3639         temp1 = SQRT(max4)
3640         IF (max4 .EQ. 0.0_8) THEN
3641           g_result1 = 0.0_8
3642         ELSE
3643           g_result1 = g_max4/(2.0*temp1)
3644         END IF
3645         result1 = temp1
3646         IF (max19 .LE. 0.0_8 .AND. (9./8. .EQ. 0.0_8 .OR. 9./8. .NE. INT&
3647 &           (9./8.))) THEN
3648           g_pwr2 = 0.0_8
3649         ELSE
3650           g_pwr2 = 9.*max19**(9./8.-1)*g_max19/8.
3651         END IF
3652         pwr2 = max19**(9./8.)
3653         g_c = pwr2*(result1*g_pwr1+pwr1*g_result1) + pwr1*result1*g_pwr2
3654         c = pwr1*result1*pwr2
3655         IF (qrs(i, k, 1) .LT. qcrmin) THEN
3656           max5 = qcrmin
3657           g_max5 = 0.0_8
3658         ELSE
3659           g_max5 = g_qrs(i, k, 1)
3660           max5 = qrs(i, k, 1)
3661         END IF
3662         IF (qci(i, k, 2) .LT. qmin) THEN
3663           max20 = qmin
3664           g_max20 = 0.0_8
3665         ELSE
3666           g_max20 = g_qci(i, k, 2)
3667           max20 = qci(i, k, 2)
3668         END IF
3669         temp1 = SQRT(den(i, k))
3670         IF (den(i, k) .EQ. 0.0_8) THEN
3671           g_result1 = 0.0_8
3672         ELSE
3673           g_result1 = g_den(i, k)/(2.0*temp1)
3674         END IF
3675         result1 = temp1
3676         temp1 = SQRT(max5)
3677         IF (max5 .EQ. 0.0_8) THEN
3678           g_result2 = 0.0_8
3679         ELSE
3680           g_result2 = g_max5/(2.0*temp1)
3681         END IF
3682         result2 = temp1
3683         temp1 = SQRT(result2)
3684         IF (result2 .EQ. 0.0_8) THEN
3685           g_result3 = 0.0_8
3686         ELSE
3687           g_result3 = g_result2/(2.0*temp1)
3688         END IF
3689         result3 = temp1
3690         IF (max20 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT&
3691 &           (5./4.))) THEN
3692           g_pwr1 = 0.0_8
3693         ELSE
3694           g_pwr1 = 5.*max20**(5./4.-1)*g_max20/4.
3695         END IF
3696         pwr1 = max20**(5./4.)
3697         g_d = pwr1*(result3*g_result1+result1*g_result3) + result1*&
3698 &         result3*g_pwr1
3699         d = result1*result3*pwr1
3700         IF (vt2r - vt2i .GE. 0.) THEN
3701           g_abs0 = g_vt2r - g_vt2i
3702           abs0 = vt2r - vt2i
3703         ELSE
3704           g_abs0 = g_vt2i - g_vt2r
3705           abs0 = -(vt2r-vt2i)
3706         END IF
3707         temp1 = praci_b*b + praci_c*c + praci_d*d
3708         g_praci1 = praci_a*(temp1*g_abs0+abs0*(praci_b*g_b+praci_c*g_c+&
3709 &         praci_d*g_d))
3710         praci1 = praci_a*(abs0*temp1)
3711         IF (praci1 .GT. qci(i, k, 2)/dtcld) THEN
3712           g_praci(i, k) = g_qci(i, k, 2)/dtcld
3713           praci(i, k) = qci(i, k, 2)/dtcld
3714         ELSE
3715           g_praci(i, k) = g_praci1
3716           praci(i, k) = praci1
3717         END IF
3718         g_praci(i, k) = praci(i, k)*g_fsupcol + fsupcol*g_praci(i, k)
3719         praci(i, k) = fsupcol*praci(i, k)
3720 !update qi, qs, qg
3721         IF (qrs(i, k, 1) .LT. 1.e-4) THEN
3722           delta3 = 1.
3723         ELSE
3724           delta3 = 0.
3725         END IF
3726         IF (praci(i, k) .GE. 0.) THEN
3727           abs1 = praci(i, k)
3728         ELSE
3729           abs1 = -praci(i, k)
3730         END IF
3731         IF (abs1 .LT. qmin/dtcld) THEN
3732           g_praci(i, k) = 0.0_8
3733           praci(i, k) = 0.
3734         END IF
3735         IF (qci(i, k, 2) - praci(i, k)*dtcld .LT. 0.) THEN
3736           g_qci(i, k, 2) = 0.0_8
3737           qci(i, k, 2) = 0.
3738         ELSE
3739           g_qci(i, k, 2) = g_qci(i, k, 2) - dtcld*g_praci(i, k)
3740           qci(i, k, 2) = qci(i, k, 2) - praci(i, k)*dtcld
3741         END IF
3742         g_x1 = g_qrs(i, k, 2) + delta3*dtcld*g_praci(i, k)
3743         x1 = qrs(i, k, 2) + praci(i, k)*delta3*dtcld
3744         IF (x1 .LT. 0.) THEN
3745           g_qrs(i, k, 2) = 0.0_8
3746           qrs(i, k, 2) = 0.
3747         ELSE
3748           g_qrs(i, k, 2) = g_x1
3749           qrs(i, k, 2) = x1
3750         END IF
3751         g_x2 = g_qrs(i, k, 3) + (1-delta3)*dtcld*g_praci(i, k)
3752         x2 = qrs(i, k, 3) + praci(i, k)*(1-delta3)*dtcld
3753         IF (x2 .LT. 0.) THEN
3754           g_qrs(i, k, 3) = 0.0_8
3755           qrs(i, k, 3) = 0.
3756         ELSE
3757           g_qrs(i, k, 3) = g_x2
3758           qrs(i, k, 3) = x2
3759         END IF
3760         g_praci(i, k) = 0.0_8
3761         praci(i, k) = 0.
3762 !-------------------------------------------------------------
3763 ! piacr: Accretion of rain by cloud ice [LFO 26]
3764 !        (T<T0: R->S or R->G) piacr: min=0,max=qrs(i,k,1)/dtcld
3765 !-------------------------------------------------------------
3766 !         supcol = t0c-t(i,k) !not change
3767         CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0')
3768 !call smoothif(qci(i,k,2),qmin  ,fqi,'q0')
3769 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
3770 !update cpm
3771         g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k))
3772         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
3773         g_xlf = -g_xl(i, k)
3774         xlf = xls - xl(i, k)
3775         IF (supcol .LT. 0.) THEN
3776           xlf = xlf0
3777           g_xlf = 0.0_8
3778         END IF
3779         IF (qci(i, k, 2) .GT. 0. .AND. qrs(i, k, 1) .GT. 0.) THEN
3780 !piacr_a=1.75e5
3781           pwy1 = (3.+bvtr)/4.
3782           IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE.&
3783 &             INT(pwy1))) THEN
3784             g_pwr1 = 0.0_8
3785           ELSE
3786             g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
3787           END IF
3788           pwr1 = den(i, k)**pwy1
3789           pwy2 = (6.+bvtr)/4.
3790           IF (qrs(i, k, 1) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 &
3791 &             .NE. INT(pwy2))) THEN
3792             g_pwr2 = 0.0_8
3793           ELSE
3794             g_pwr2 = pwy2*qrs(i, k, 1)**(pwy2-1)*g_qrs(i, k, 1)
3795           END IF
3796           pwr2 = qrs(i, k, 1)**pwy2
3797           temp1 = qci(i, k, 2)**0.75
3798           g_piacr1 = piacr_a*(pwr1*pwr2*0.75*qci(i, k, 2)**(-0.25)*g_qci&
3799 &           (i, k, 2)+temp1*(pwr2*g_pwr1+pwr1*g_pwr2))
3800           piacr1 = piacr_a*(temp1*(pwr1*pwr2))
3801         ELSE
3802           piacr1 = 0.
3803           g_piacr1 = 0.0_8
3804         END IF
3805         IF (piacr1 .GT. qrs(i, k, 1)/dtcld) THEN
3806           g_piacr(i, k) = g_qrs(i, k, 1)/dtcld
3807           piacr(i, k) = qrs(i, k, 1)/dtcld
3808         ELSE
3809           g_piacr(i, k) = g_piacr1
3810           piacr(i, k) = piacr1
3811         END IF
3812         g_piacr(i, k) = piacr(i, k)*g_fsupcol + fsupcol*g_piacr(i, k)
3813         piacr(i, k) = fsupcol*piacr(i, k)
3814 ! update qr,qs,qg,t
3815         IF (qrs(i, k, 1) .LT. 1.e-4) THEN
3816           delta3 = 1.
3817         ELSE
3818           delta3 = 0.
3819         END IF
3820         IF (piacr(i, k) .GE. 0.) THEN
3821           abs2 = piacr(i, k)
3822         ELSE
3823           abs2 = -piacr(i, k)
3824         END IF
3825         IF (abs2 .LT. qmin/dtcld) THEN
3826           g_piacr(i, k) = 0.0_8
3827           piacr(i, k) = 0.
3828         END IF
3829         IF (qrs(i, k, 1) - piacr(i, k)*dtcld .LT. 0.) THEN
3830           g_qrs(i, k, 1) = 0.0_8
3831           qrs(i, k, 1) = 0.
3832         ELSE
3833           g_qrs(i, k, 1) = g_qrs(i, k, 1) - dtcld*g_piacr(i, k)
3834           qrs(i, k, 1) = qrs(i, k, 1) - piacr(i, k)*dtcld
3835         END IF
3836         g_x3 = g_qrs(i, k, 2) + delta3*dtcld*g_piacr(i, k)
3837         x3 = qrs(i, k, 2) + piacr(i, k)*delta3*dtcld
3838         IF (x3 .LT. 0.) THEN
3839           g_qrs(i, k, 2) = 0.0_8
3840           qrs(i, k, 2) = 0.
3841         ELSE
3842           g_qrs(i, k, 2) = g_x3
3843           qrs(i, k, 2) = x3
3844         END IF
3845         g_x4 = g_qrs(i, k, 3) + (1-delta3)*dtcld*g_piacr(i, k)
3846         x4 = qrs(i, k, 3) + piacr(i, k)*(1-delta3)*dtcld
3847         IF (x4 .LT. 0.) THEN
3848           g_qrs(i, k, 3) = 0.0_8
3849           qrs(i, k, 3) = 0.
3850         ELSE
3851           g_qrs(i, k, 3) = g_x4
3852           qrs(i, k, 3) = x4
3853         END IF
3854         temp1 = piacr(i, k)*xlf/cpm(i, k)
3855         g_t(i, k) = g_t(i, k) + dtcld*(xlf*g_piacr(i, k)+piacr(i, k)*&
3856 &         g_xlf-temp1*g_cpm(i, k))/cpm(i, k)
3857         t(i, k) = t(i, k) + dtcld*temp1
3858         g_piacr(i, k) = 0.0_8
3859         piacr(i, k) = 0.
3860 !-------------------------------------------------------------
3861 ! psaci: Accretion of cloud ice by snow [HDC 10]
3862 !        (T<T0: I->S) psaci: min=0, max=qci(i,k,2)/dtcld
3863 !-------------------------------------------------------------
3864         g_supcol = -g_t(i, k)
3865         supcol = t0c - t(i, k)
3866         CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0')
3867         g_x5 = -(EXP(-(0.07*supcol))*0.07*g_supcol)
3868         x5 = EXP(0.07*(-supcol))
3869         IF (x5 .GT. 1.) THEN
3870           eacrs = 1.
3871           g_eacrs = 0.0_8
3872         ELSE
3873           g_eacrs = g_x5
3874           eacrs = x5
3875         END IF
3876         IF (qrs(i, k, 2) .LT. qcrmin) THEN
3877           max6 = qcrmin
3878           g_max6 = 0.0_8
3879         ELSE
3880           g_max6 = g_qrs(i, k, 2)
3881           max6 = qrs(i, k, 2)
3882         END IF
3883         IF (90. .GT. t0c - t(i, k)) THEN
3884           g_y6 = -g_t(i, k)
3885           y6 = t0c - t(i, k)
3886         ELSE
3887           y6 = 90.
3888           g_y6 = 0.0_8
3889         END IF
3890         IF (0. .LT. y6) THEN
3891           g_max21 = g_y6
3892           max21 = y6
3893         ELSE
3894           max21 = 0.
3895           g_max21 = 0.0_8
3896         END IF
3897         pwy1 = (bvts-2.)/4.
3898         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
3899 &           INT(pwy1))) THEN
3900           g_pwr1 = 0.0_8
3901         ELSE
3902           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
3903         END IF
3904         pwr1 = den(i, k)**pwy1
3905         pwy2 = bvts/4.
3906         IF (max6 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
3907 &           pwy2))) THEN
3908           g_pwr2 = 0.0_8
3909         ELSE
3910           g_pwr2 = pwy2*max6**(pwy2-1)*g_max6
3911         END IF
3912         pwr2 = max6**pwy2
3913         g_arg1 = -(alpha*bvts*g_max21/4.)
3914         arg1 = -(alpha*bvts*max21/4.)
3915         temp1 = EXP(arg1)
3916         g_vt2s = vt2s_a*(temp1*(pwr2*g_pwr1+pwr1*g_pwr2)+pwr1*pwr2*EXP(&
3917 &         arg1)*g_arg1)
3918         vt2s = vt2s_a*(pwr1*pwr2*temp1)
3919         IF (qci(i, k, 2) .LT. qmin) THEN
3920           max7 = qmin
3921           g_max7 = 0.0_8
3922         ELSE
3923           g_max7 = g_qci(i, k, 2)
3924           max7 = qci(i, k, 2)
3925         END IF
3926         g_pwx1 = max7*g_den(i, k) + den(i, k)*g_max7
3927         pwx1 = den(i, k)*max7
3928         IF (pwx1 .LE. 0.0_8 .AND. (1.31/8. .EQ. 0.0_8 .OR. 1.31/8. .NE. &
3929 &           INT(1.31/8.))) THEN
3930           g_pwr1 = 0.0_8
3931         ELSE
3932           g_pwr1 = 1.31*pwx1**(1.31/8.-1)*g_pwx1/8.
3933         END IF
3934         pwr1 = pwx1**(1.31/8.)
3935         g_vt2i = vt2i_a*g_pwr1
3936         vt2i = vt2i_a*pwr1
3937         IF (90. .GT. t0c - t(i, k)) THEN
3938           g_y1 = -g_t(i, k)
3939           y1 = t0c - t(i, k)
3940         ELSE
3941           y1 = 90.
3942           g_y1 = 0.0_8
3943         END IF
3944         IF (0. .LT. y1) THEN
3945           g_max8 = g_y1
3946           max8 = y1
3947         ELSE
3948           max8 = 0.
3949           g_max8 = 0.0_8
3950         END IF
3951         g_a = EXP(alpha*max8)*alpha*g_max8
3952         a = EXP(alpha*max8)
3953         IF (90. .GT. t0c - t(i, k)) THEN
3954           g_y2 = -g_t(i, k)
3955           y2 = t0c - t(i, k)
3956         ELSE
3957           y2 = 90.
3958           g_y2 = 0.0_8
3959         END IF
3960         IF (0. .LT. y2) THEN
3961           g_max9 = g_y2
3962           max9 = y2
3963         ELSE
3964           max9 = 0.
3965           g_max9 = 0.0_8
3966         END IF
3967         IF (qrs(i, k, 2) .LT. qcrmin) THEN
3968           max22 = qcrmin
3969           g_max22 = 0.0_8
3970         ELSE
3971           g_max22 = g_qrs(i, k, 2)
3972           max22 = qrs(i, k, 2)
3973         END IF
3974         IF (qci(i, k, 2) .LT. qmin) THEN
3975           max28 = qmin
3976           g_max28 = 0.0_8
3977         ELSE
3978           g_max28 = g_qci(i, k, 2)
3979           max28 = qci(i, k, 2)
3980         END IF
3981         g_arg1 = -(alpha*3.*g_max9/4.)
3982         arg1 = -(3.*alpha*max9/4.)
3983         g_pwx1 = max22*g_den(i, k) + den(i, k)*g_max22
3984         pwx1 = den(i, k)*max22
3985         IF (pwx1 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT(&
3986 &           3./4.))) THEN
3987           g_pwr1 = 0.0_8
3988         ELSE
3989           g_pwr1 = 3.*pwx1**(3./4.-1)*g_pwx1/4.
3990         END IF
3991         pwr1 = pwx1**(3./4.)
3992         temp1 = EXP(arg1)
3993         g_b = pwr1*max28*EXP(arg1)*g_arg1 + temp1*(max28*g_pwr1+pwr1*&
3994 &         g_max28)
3995         b = temp1*(pwr1*max28)
3996         IF (90. .GT. t0c - t(i, k)) THEN
3997           g_y3 = -g_t(i, k)
3998           y3 = t0c - t(i, k)
3999         ELSE
4000           y3 = 90.
4001           g_y3 = 0.0_8
4002         END IF
4003         IF (0. .LT. y3) THEN
4004           g_max10 = g_y3
4005           max10 = y3
4006         ELSE
4007           max10 = 0.
4008           g_max10 = 0.0_8
4009         END IF
4010         IF (qrs(i, k, 2) .LT. qcrmin) THEN
4011           max23 = qcrmin
4012           g_max23 = 0.0_8
4013         ELSE
4014           g_max23 = g_qrs(i, k, 2)
4015           max23 = qrs(i, k, 2)
4016         END IF
4017         IF (qci(i, k, 2) .LT. qmin) THEN
4018           max29 = qmin
4019           g_max29 = 0.0_8
4020         ELSE
4021           g_max29 = g_qci(i, k, 2)
4022           max29 = qci(i, k, 2)
4023         END IF
4024         g_arg1 = -(alpha*g_max10/2.)
4025         arg1 = -(alpha*max10/2.)
4026         IF (den(i, k) .LE. 0.0_8 .AND. (5./8. .EQ. 0.0_8 .OR. 5./8. .NE.&
4027 &           INT(5./8.))) THEN
4028           g_pwr1 = 0.0_8
4029         ELSE
4030           g_pwr1 = 5.*den(i, k)**(5./8.-1)*g_den(i, k)/8.
4031         END IF
4032         pwr1 = den(i, k)**(5./8.)
4033         temp1 = SQRT(max23)
4034         IF (max23 .EQ. 0.0_8) THEN
4035           g_result1 = 0.0_8
4036         ELSE
4037           g_result1 = g_max23/(2.0*temp1)
4038         END IF
4039         result1 = temp1
4040         IF (max29 .LE. 0.0_8 .AND. (9./8. .EQ. 0.0_8 .OR. 9./8. .NE. INT&
4041 &           (9./8.))) THEN
4042           g_pwr2 = 0.0_8
4043         ELSE
4044           g_pwr2 = 9.*max29**(9./8.-1)*g_max29/8.
4045         END IF
4046         pwr2 = max29**(9./8.)
4047         temp1 = pwr1*result1*pwr2
4048         temp2 = EXP(arg1)
4049         g_c = temp1*EXP(arg1)*g_arg1 + temp2*(pwr2*(result1*g_pwr1+pwr1*&
4050 &         g_result1)+pwr1*result1*g_pwr2)
4051         c = temp2*temp1
4052         IF (90. .GT. t0c - t(i, k)) THEN
4053           g_y4 = -g_t(i, k)
4054           y4 = t0c - t(i, k)
4055         ELSE
4056           y4 = 90.
4057           g_y4 = 0.0_8
4058         END IF
4059         IF (0. .LT. y4) THEN
4060           g_max11 = g_y4
4061           max11 = y4
4062         ELSE
4063           max11 = 0.
4064           g_max11 = 0.0_8
4065         END IF
4066         IF (qrs(i, k, 2) .LT. qcrmin) THEN
4067           max24 = qcrmin
4068           g_max24 = 0.0_8
4069         ELSE
4070           g_max24 = g_qrs(i, k, 2)
4071           max24 = qrs(i, k, 2)
4072         END IF
4073         IF (qci(i, k, 2) .LT. qmin) THEN
4074           max30 = qmin
4075           g_max30 = 0.0_8
4076         ELSE
4077           g_max30 = g_qci(i, k, 2)
4078           max30 = qci(i, k, 2)
4079         END IF
4080         g_arg1 = -(alpha*g_max11/4.)
4081         arg1 = -(alpha*max11/4.)
4082         temp2 = SQRT(den(i, k))
4083         IF (den(i, k) .EQ. 0.0_8) THEN
4084           g_result1 = 0.0_8
4085         ELSE
4086           g_result1 = g_den(i, k)/(2.0*temp2)
4087         END IF
4088         result1 = temp2
4089         temp2 = SQRT(max24)
4090         IF (max24 .EQ. 0.0_8) THEN
4091           g_result2 = 0.0_8
4092         ELSE
4093           g_result2 = g_max24/(2.0*temp2)
4094         END IF
4095         result2 = temp2
4096         temp2 = SQRT(result2)
4097         IF (result2 .EQ. 0.0_8) THEN
4098           g_result3 = 0.0_8
4099         ELSE
4100           g_result3 = g_result2/(2.0*temp2)
4101         END IF
4102         result3 = temp2
4103         IF (max30 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT&
4104 &           (5./4.))) THEN
4105           g_pwr1 = 0.0_8
4106         ELSE
4107           g_pwr1 = 5.*max30**(5./4.-1)*g_max30/4.
4108         END IF
4109         pwr1 = max30**(5./4.)
4110         temp2 = result1*result3*pwr1
4111         temp1 = EXP(arg1)
4112         g_d = temp2*EXP(arg1)*g_arg1 + temp1*(pwr1*(result3*g_result1+&
4113 &         result1*g_result3)+result1*result3*g_pwr1)
4114         d = temp1*temp2
4115         IF (vt2s - vt2i .GE. 0.) THEN
4116           g_abs3 = g_vt2s - g_vt2i
4117           abs3 = vt2s - vt2i
4118         ELSE
4119           g_abs3 = g_vt2i - g_vt2s
4120           abs3 = -(vt2s-vt2i)
4121         END IF
4122         temp2 = psaci_b*b + psaci_c*c + psaci_d*d
4123         temp1 = a*abs3*eacrs
4124         g_psaci1 = psaci_a*(temp2*(eacrs*(abs3*g_a+a*g_abs3)+a*abs3*&
4125 &         g_eacrs)+temp1*(psaci_b*g_b+psaci_c*g_c+psaci_d*g_d))
4126         psaci1 = psaci_a*(temp1*temp2)
4127         IF (psaci1 .GT. qci(i, k, 2)/dtcld) THEN
4128           g_psaci(i, k) = g_qci(i, k, 2)/dtcld
4129           psaci(i, k) = qci(i, k, 2)/dtcld
4130         ELSE
4131           g_psaci(i, k) = g_psaci1
4132           psaci(i, k) = psaci1
4133         END IF
4134         g_psaci(i, k) = psaci(i, k)*g_fsupcol + fsupcol*g_psaci(i, k)
4135         psaci(i, k) = fsupcol*psaci(i, k)
4136         IF (psaci(i, k) .GE. 0.) THEN
4137           abs4 = psaci(i, k)
4138         ELSE
4139           abs4 = -psaci(i, k)
4140         END IF
4141         IF (abs4 .LT. qmin/dtcld) THEN
4142           g_psaci(i, k) = 0.0_8
4143           psaci(i, k) = 0.
4144         END IF
4145         IF (qci(i, k, 2) - psaci(i, k)*dtcld .LT. 0.) THEN
4146           g_qci(i, k, 2) = 0.0_8
4147           qci(i, k, 2) = 0.
4148         ELSE
4149           g_qci(i, k, 2) = g_qci(i, k, 2) - dtcld*g_psaci(i, k)
4150           qci(i, k, 2) = qci(i, k, 2) - psaci(i, k)*dtcld
4151         END IF
4152         IF (qrs(i, k, 2) + psaci(i, k)*dtcld .LT. 0.) THEN
4153           g_qrs(i, k, 2) = 0.0_8
4154           qrs(i, k, 2) = 0.
4155         ELSE
4156           g_qrs(i, k, 2) = g_qrs(i, k, 2) + dtcld*g_psaci(i, k)
4157           qrs(i, k, 2) = qrs(i, k, 2) + psaci(i, k)*dtcld
4158         END IF
4159         g_psaci(i, k) = 0.0_8
4160         psaci(i, k) = 0.
4161 !-------------------------------------------------------------
4162 ! pgaci: Accretion of cloud ice by graupel [LFO 41]
4163 !        (T<T0: I->G) pgaci:min=0,max=qci(i,k,2)/dtcld
4164 !-------------------------------------------------------------
4165 !         supcol = t0c-t(i,k) !not change
4166 !         call smoothif(supcol,    0.,fsupcol,'t0')
4167 !call smoothif(qci(i,k,2),qmin  ,fqi,'q0')
4168 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
4169 !min(exp(0.07*(-supcol)),1.)
4170         g_egi = g_eacrs
4171         egi = eacrs
4172         IF (qrs(i, k, 3) .LT. qcrmin) THEN
4173           max12 = qcrmin
4174           g_max12 = 0.0_8
4175         ELSE
4176           g_max12 = g_qrs(i, k, 3)
4177           max12 = qrs(i, k, 3)
4178         END IF
4179         pwy1 = (bvtg-2.)/4.
4180         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
4181 &           INT(pwy1))) THEN
4182           g_pwr1 = 0.0_8
4183         ELSE
4184           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
4185         END IF
4186         pwr1 = den(i, k)**pwy1
4187         pwy2 = bvtg/4.
4188         IF (max12 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
4189 &           pwy2))) THEN
4190           g_pwr2 = 0.0_8
4191         ELSE
4192           g_pwr2 = pwy2*max12**(pwy2-1)*g_max12
4193         END IF
4194         pwr2 = max12**pwy2
4195         g_vt2g = vt2g_a*(pwr2*g_pwr1+pwr1*g_pwr2)
4196         vt2g = vt2g_a*pwr1*pwr2
4197         IF (qci(i, k, 2) .LT. qmin) THEN
4198           max13 = qmin
4199           g_max13 = 0.0_8
4200         ELSE
4201           g_max13 = g_qci(i, k, 2)
4202           max13 = qci(i, k, 2)
4203         END IF
4204         g_pwx1 = max13*g_den(i, k) + den(i, k)*g_max13
4205         pwx1 = den(i, k)*max13
4206         IF (pwx1 .LE. 0.0_8 .AND. (1.31/8. .EQ. 0.0_8 .OR. 1.31/8. .NE. &
4207 &           INT(1.31/8.))) THEN
4208           g_pwr1 = 0.0_8
4209         ELSE
4210           g_pwr1 = 1.31*pwx1**(1.31/8.-1)*g_pwx1/8.
4211         END IF
4212         pwr1 = pwx1**(1.31/8.)
4213         g_vt2i = vt2i_a*g_pwr1
4214         vt2i = vt2i_a*pwr1
4215         IF (qrs(i, k, 3) .LT. qcrmin) THEN
4216           max14 = qcrmin
4217           g_max14 = 0.0_8
4218         ELSE
4219           g_max14 = g_qrs(i, k, 3)
4220           max14 = qrs(i, k, 3)
4221         END IF
4222         IF (qci(i, k, 2) .LT. qmin) THEN
4223           max25 = qmin
4224           g_max25 = 0.0_8
4225         ELSE
4226           g_max25 = g_qci(i, k, 2)
4227           max25 = qci(i, k, 2)
4228         END IF
4229         g_pwx1 = max14*g_den(i, k) + den(i, k)*g_max14
4230         pwx1 = den(i, k)*max14
4231         IF (pwx1 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT(&
4232 &           3./4.))) THEN
4233           g_pwr1 = 0.0_8
4234         ELSE
4235           g_pwr1 = 3.*pwx1**(3./4.-1)*g_pwx1/4.
4236         END IF
4237         pwr1 = pwx1**(3./4.)
4238         g_b = max25*g_pwr1 + pwr1*g_max25
4239         b = pwr1*max25
4240         IF (qrs(i, k, 3) .LT. qcrmin) THEN
4241           max15 = qcrmin
4242           g_max15 = 0.0_8
4243         ELSE
4244           g_max15 = g_qrs(i, k, 3)
4245           max15 = qrs(i, k, 3)
4246         END IF
4247         IF (qci(i, k, 2) .LT. qmin) THEN
4248           max26 = qmin
4249           g_max26 = 0.0_8
4250         ELSE
4251           g_max26 = g_qci(i, k, 2)
4252           max26 = qci(i, k, 2)
4253         END IF
4254         IF (den(i, k) .LE. 0.0_8 .AND. (5./8. .EQ. 0.0_8 .OR. 5./8. .NE.&
4255 &           INT(5./8.))) THEN
4256           g_pwr1 = 0.0_8
4257         ELSE
4258           g_pwr1 = 5.*den(i, k)**(5./8.-1)*g_den(i, k)/8.
4259         END IF
4260         pwr1 = den(i, k)**(5./8.)
4261         temp2 = SQRT(max15)
4262         IF (max15 .EQ. 0.0_8) THEN
4263           g_result1 = 0.0_8
4264         ELSE
4265           g_result1 = g_max15/(2.0*temp2)
4266         END IF
4267         result1 = temp2
4268         IF (max26 .LE. 0.0_8 .AND. (9./8. .EQ. 0.0_8 .OR. 9./8. .NE. INT&
4269 &           (9./8.))) THEN
4270           g_pwr2 = 0.0_8
4271         ELSE
4272           g_pwr2 = 9.*max26**(9./8.-1)*g_max26/8.
4273         END IF
4274         pwr2 = max26**(9./8.)
4275         g_c = pwr2*(result1*g_pwr1+pwr1*g_result1) + pwr1*result1*g_pwr2
4276         c = pwr1*result1*pwr2
4277         IF (qrs(i, k, 3) .LT. qcrmin) THEN
4278           max16 = qcrmin
4279           g_max16 = 0.0_8
4280         ELSE
4281           g_max16 = g_qrs(i, k, 3)
4282           max16 = qrs(i, k, 3)
4283         END IF
4284         IF (qci(i, k, 2) .LT. qmin) THEN
4285           max27 = qmin
4286           g_max27 = 0.0_8
4287         ELSE
4288           g_max27 = g_qci(i, k, 2)
4289           max27 = qci(i, k, 2)
4290         END IF
4291         temp2 = SQRT(den(i, k))
4292         IF (den(i, k) .EQ. 0.0_8) THEN
4293           g_result1 = 0.0_8
4294         ELSE
4295           g_result1 = g_den(i, k)/(2.0*temp2)
4296         END IF
4297         result1 = temp2
4298         temp2 = SQRT(max16)
4299         IF (max16 .EQ. 0.0_8) THEN
4300           g_result2 = 0.0_8
4301         ELSE
4302           g_result2 = g_max16/(2.0*temp2)
4303         END IF
4304         result2 = temp2
4305         temp2 = SQRT(result2)
4306         IF (result2 .EQ. 0.0_8) THEN
4307           g_result3 = 0.0_8
4308         ELSE
4309           g_result3 = g_result2/(2.0*temp2)
4310         END IF
4311         result3 = temp2
4312         IF (max27 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT&
4313 &           (5./4.))) THEN
4314           g_pwr1 = 0.0_8
4315         ELSE
4316           g_pwr1 = 5.*max27**(5./4.-1)*g_max27/4.
4317         END IF
4318         pwr1 = max27**(5./4.)
4319         g_d = pwr1*(result3*g_result1+result1*g_result3) + result1*&
4320 &         result3*g_pwr1
4321         d = result1*result3*pwr1
4322         IF (vt2g - vt2i .GE. 0.) THEN
4323           g_abs5 = g_vt2g - g_vt2i
4324           abs5 = vt2g - vt2i
4325         ELSE
4326           g_abs5 = g_vt2i - g_vt2g
4327           abs5 = -(vt2g-vt2i)
4328         END IF
4329         temp2 = pgaci_b*b + pgaci_c*c + pgaci_d*d
4330         g_pgaci1 = pgaci_a*(abs5*egi*(pgaci_b*g_b+pgaci_c*g_c+pgaci_d*&
4331 &         g_d)+temp2*(egi*g_abs5+abs5*g_egi))
4332         pgaci1 = pgaci_a*(temp2*(abs5*egi))
4333         IF (pgaci1 .GT. qci(i, k, 2)/dtcld) THEN
4334           g_pgaci(i, k) = g_qci(i, k, 2)/dtcld
4335           pgaci(i, k) = qci(i, k, 2)/dtcld
4336         ELSE
4337           g_pgaci(i, k) = g_pgaci1
4338           pgaci(i, k) = pgaci1
4339         END IF
4340         g_pgaci(i, k) = pgaci(i, k)*g_fsupcol + fsupcol*g_pgaci(i, k)
4341         pgaci(i, k) = fsupcol*pgaci(i, k)
4342         IF (pgaci(i, k) .GE. 0.) THEN
4343           abs6 = pgaci(i, k)
4344         ELSE
4345           abs6 = -pgaci(i, k)
4346         END IF
4347         IF (abs6 .LT. qmin/dtcld) THEN
4348           g_pgaci(i, k) = 0.0_8
4349           pgaci(i, k) = 0.
4350         END IF
4351         IF (qci(i, k, 2) - pgaci(i, k)*dtcld .LT. 0.) THEN
4352           g_qci(i, k, 2) = 0.0_8
4353           qci(i, k, 2) = 0.
4354         ELSE
4355           g_qci(i, k, 2) = g_qci(i, k, 2) - dtcld*g_pgaci(i, k)
4356           qci(i, k, 2) = qci(i, k, 2) - pgaci(i, k)*dtcld
4357         END IF
4358         IF (qrs(i, k, 3) + pgaci(i, k)*dtcld .LT. 0.) THEN
4359           g_qrs(i, k, 3) = 0.0_8
4360           qrs(i, k, 3) = 0.
4361         ELSE
4362           g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgaci(i, k)
4363           qrs(i, k, 3) = qrs(i, k, 3) + pgaci(i, k)*dtcld
4364         END IF
4365         g_pgaci(i, k) = 0.0_8
4366         pgaci(i, k) = 0.
4367 !-------------------------------------------------------------
4368 ! psacw: Accretion of cloud water by snow  [LFO 24]
4369 !        (T<T0: C->G, and T>=T0: C->R) psacw:min=0,max=qci(i,k,1)/dtcld
4370 !-------------------------------------------------------------
4371 !         supcol = t0c-t(i,k) !not change
4372 !         call smoothif(supcol,    0.,fsupcol,'t0')
4373 !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0')
4374 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
4375 !update cpm
4376 !         cpm(i,k)=cpmcal(q(i,k)) !not change
4377         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
4378         g_xlf = -g_xl(i, k)
4379         xlf = xls - xl(i, k)
4380         IF (supcol .LT. 0.) THEN
4381           xlf = xlf0
4382           g_xlf = 0.0_8
4383         END IF
4384         IF (qrs(i, k, 2) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN
4385           IF (90. .GT. t0c - t(i, k)) THEN
4386             g_y5 = -g_t(i, k)
4387             y5 = t0c - t(i, k)
4388           ELSE
4389             y5 = 90.
4390             g_y5 = 0.0_8
4391           END IF
4392           IF (0. .LT. y5) THEN
4393             g_max17 = g_y5
4394             max17 = y5
4395           ELSE
4396             max17 = 0.
4397             g_max17 = 0.0_8
4398           END IF
4399           g_arg1 = (1.-bvts)*alpha*g_max17/4.
4400           arg1 = (1.-bvts)*alpha*max17/4.
4401           g_a = EXP(arg1)*g_arg1
4402           a = EXP(arg1)
4403           pwy1 = (1.+bvts)/4.
4404           IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE.&
4405 &             INT(pwy1))) THEN
4406             g_pwr1 = 0.0_8
4407           ELSE
4408             g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
4409           END IF
4410           pwr1 = den(i, k)**pwy1
4411           pwy2 = (3.+bvts)/4.
4412           IF (qrs(i, k, 2) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 &
4413 &             .NE. INT(pwy2))) THEN
4414             g_pwr2 = 0.0_8
4415           ELSE
4416             g_pwr2 = pwy2*qrs(i, k, 2)**(pwy2-1)*g_qrs(i, k, 2)
4417           END IF
4418           pwr2 = qrs(i, k, 2)**pwy2
4419           temp2 = a*pwr1*pwr2
4420           g_psacw(i, k) = psacw_a*(qci(i, k, 1)*(pwr2*(pwr1*g_a+a*g_pwr1&
4421 &           )+a*pwr1*g_pwr2)+temp2*g_qci(i, k, 1))
4422           psacw(i, k) = psacw_a*(temp2*qci(i, k, 1))
4423         ELSE
4424           g_psacw(i, k) = 0.0_8
4425           psacw(i, k) = 0.
4426         END IF
4427         IF (psacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
4428           g_x6 = g_qci(i, k, 1)/dtcld
4429           x6 = qci(i, k, 1)/dtcld
4430         ELSE
4431           g_x6 = g_psacw(i, k)
4432           x6 = psacw(i, k)
4433         END IF
4434         IF (x6 .LT. 0.) THEN
4435           g_psacw(i, k) = 0.0_8
4436           psacw(i, k) = 0.
4437         ELSE
4438           g_psacw(i, k) = g_x6
4439           psacw(i, k) = x6
4440         END IF
4441         g_psacw(i, k) = psacw(i, k)*g_fsupcol + fsupcol*g_psacw(i, k)
4442         psacw(i, k) = fsupcol*psacw(i, k)
4443         IF (psacw(i, k) .GE. 0.) THEN
4444           abs7 = psacw(i, k)
4445         ELSE
4446           abs7 = -psacw(i, k)
4447         END IF
4448         IF (abs7 .LT. qmin/dtcld) THEN
4449           g_psacw(i, k) = 0.0_8
4450           psacw(i, k) = 0.
4451         END IF
4452         IF (qci(i, k, 1) - psacw(i, k)*dtcld .LT. 0.) THEN
4453           g_qci(i, k, 1) = 0.0_8
4454           qci(i, k, 1) = 0.
4455         ELSE
4456           g_qci(i, k, 1) = g_qci(i, k, 1) - dtcld*g_psacw(i, k)
4457           qci(i, k, 1) = qci(i, k, 1) - psacw(i, k)*dtcld
4458         END IF
4459         g_x7 = g_qrs(i, k, 1) + dtcld*((1.-fsupcol)*g_psacw(i, k)-psacw(&
4460 &         i, k)*g_fsupcol)
4461         x7 = qrs(i, k, 1) + (1.-fsupcol)*psacw(i, k)*dtcld
4462         IF (x7 .LT. 0.) THEN
4463           g_qrs(i, k, 1) = 0.0_8
4464           qrs(i, k, 1) = 0.
4465         ELSE
4466           g_qrs(i, k, 1) = g_x7
4467           qrs(i, k, 1) = x7
4468         END IF
4469         g_x8 = g_qrs(i, k, 3) + dtcld*(psacw(i, k)*g_fsupcol+fsupcol*&
4470 &         g_psacw(i, k))
4471         x8 = qrs(i, k, 3) + fsupcol*psacw(i, k)*dtcld
4472         IF (x8 .LT. 0.) THEN
4473           g_qrs(i, k, 3) = 0.0_8
4474           qrs(i, k, 3) = 0.
4475         ELSE
4476           g_qrs(i, k, 3) = g_x8
4477           qrs(i, k, 3) = x8
4478         END IF
4479         temp2 = psacw(i, k)/cpm(i, k)
4480         g_t(i, k) = g_t(i, k) + dtcld*(temp2*(xlf*g_fsupcol+fsupcol*&
4481 &         g_xlf)+fsupcol*xlf*(g_psacw(i, k)-temp2*g_cpm(i, k))/cpm(i, k)&
4482 &         )
4483         t(i, k) = t(i, k) + dtcld*(fsupcol*xlf*temp2)
4484 !t>=t0 pseml
4485         g_psacw(i, k) = (1-fsupcol)*g_psacw(i, k) - psacw(i, k)*&
4486 &         g_fsupcol
4487         psacw(i, k) = (1-fsupcol)*psacw(i, k)
4488 !-------------------------------------------------------------
4489 ! pgacw: Accretion of cloud water by graupel [LFO 40]
4490 !        (T<T0: C->G, and T>=T0: C->R) pgacw:min=0.,max=qci(i,k,1)/dtcld
4491 !-------------------------------------------------------------
4492         g_supcol = -g_t(i, k)
4493         supcol = t0c - t(i, k)
4494         CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0')
4495 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
4496 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
4497 !         cpm(i,k)=cpmcal(q(i,k)) !not change
4498         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
4499         g_xlf = -g_xl(i, k)
4500         xlf = xls - xl(i, k)
4501         IF (supcol .LT. 0.) THEN
4502           xlf = xlf0
4503           g_xlf = 0.0_8
4504         END IF
4505         IF (qrs(i, k, 3) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN
4506           pwy1 = (1.+bvtg)/4.
4507           IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE.&
4508 &             INT(pwy1))) THEN
4509             g_pwr1 = 0.0_8
4510           ELSE
4511             g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
4512           END IF
4513           pwr1 = den(i, k)**pwy1
4514           pwy2 = (3.+bvtg)/4.
4515           IF (qrs(i, k, 3) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 &
4516 &             .NE. INT(pwy2))) THEN
4517             g_pwr2 = 0.0_8
4518           ELSE
4519             g_pwr2 = pwy2*qrs(i, k, 3)**(pwy2-1)*g_qrs(i, k, 3)
4520           END IF
4521           pwr2 = qrs(i, k, 3)**pwy2
4522           g_pgacw(i, k) = pgacw_a*(qci(i, k, 1)*(pwr2*g_pwr1+pwr1*g_pwr2&
4523 &           )+pwr1*pwr2*g_qci(i, k, 1))
4524           pgacw(i, k) = pgacw_a*pwr1*pwr2*qci(i, k, 1)
4525         ELSE
4526           g_pgacw(i, k) = 0.0_8
4527           pgacw(i, k) = 0.
4528         END IF
4529         IF (pgacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
4530           g_x9 = g_qci(i, k, 1)/dtcld
4531           x9 = qci(i, k, 1)/dtcld
4532         ELSE
4533           g_x9 = g_pgacw(i, k)
4534           x9 = pgacw(i, k)
4535         END IF
4536         IF (x9 .LT. 0.) THEN
4537           g_pgacw(i, k) = 0.0_8
4538           pgacw(i, k) = 0.
4539         ELSE
4540           g_pgacw(i, k) = g_x9
4541           pgacw(i, k) = x9
4542         END IF
4543         IF (pgacw(i, k) .GE. 0.) THEN
4544           abs8 = pgacw(i, k)
4545         ELSE
4546           abs8 = -pgacw(i, k)
4547         END IF
4548 !pgacw(i,k)=fqg*fqc*pgacw(i,k)
4549         IF (abs8 .LT. qmin/dtcld) THEN
4550           g_pgacw(i, k) = 0.0_8
4551           pgacw(i, k) = 0.
4552         END IF
4553         IF (qci(i, k, 1) - pgacw(i, k)*dtcld .LT. 0.) THEN
4554           g_qci(i, k, 1) = 0.0_8
4555           qci(i, k, 1) = 0.
4556         ELSE
4557           g_qci(i, k, 1) = g_qci(i, k, 1) - dtcld*g_pgacw(i, k)
4558           qci(i, k, 1) = qci(i, k, 1) - pgacw(i, k)*dtcld
4559         END IF
4560         g_x10 = g_qrs(i, k, 1) + dtcld*((1.-fsupcol)*g_pgacw(i, k)-pgacw&
4561 &         (i, k)*g_fsupcol)
4562         x10 = qrs(i, k, 1) + (1.-fsupcol)*pgacw(i, k)*dtcld
4563         IF (x10 .LT. 0.) THEN
4564           g_qrs(i, k, 1) = 0.0_8
4565           qrs(i, k, 1) = 0.
4566         ELSE
4567           g_qrs(i, k, 1) = g_x10
4568           qrs(i, k, 1) = x10
4569         END IF
4570         g_x11 = g_qrs(i, k, 3) + dtcld*(pgacw(i, k)*g_fsupcol+fsupcol*&
4571 &         g_pgacw(i, k))
4572         x11 = qrs(i, k, 3) + fsupcol*pgacw(i, k)*dtcld
4573         IF (x11 .LT. 0.) THEN
4574           g_qrs(i, k, 3) = 0.0_8
4575           qrs(i, k, 3) = 0.
4576         ELSE
4577           g_qrs(i, k, 3) = g_x11
4578           qrs(i, k, 3) = x11
4579         END IF
4580         temp2 = pgacw(i, k)/cpm(i, k)
4581         g_t(i, k) = g_t(i, k) + dtcld*(temp2*(xlf*g_fsupcol+fsupcol*&
4582 &         g_xlf)+fsupcol*xlf*(g_pgacw(i, k)-temp2*g_cpm(i, k))/cpm(i, k)&
4583 &         )
4584         t(i, k) = t(i, k) + dtcld*(fsupcol*xlf*temp2)
4585 ! t>=t0 pgeml
4586         g_pgacw(i, k) = (1-fsupcol)*g_pgacw(i, k) - pgacw(i, k)*&
4587 &         g_fsupcol
4588         pgacw(i, k) = (1-fsupcol)*pgacw(i, k)
4589       END DO
4590     END DO
4591   END SUBROUTINE G_ACCRET1
4592
4593 !===================================================================
4594   SUBROUTINE ACCRET1(qci, den, qrs, t, q, dtcld, praci, piacr, psaci, &
4595 &   pgaci, psacw, pgacw, ims, ime, kms, kme, its, ite, kts, kte)
4596     IMPLICIT NONE
4597     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
4598 !-------------------------------------------------------------------
4599     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
4600     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
4601     REAL, DIMENSION(ims:ime, kms:kme) :: den, q
4602     REAL, DIMENSION(its:ite, kts:kte) :: praci, piacr, psaci, pgaci, &
4603 &   psacw, pgacw, t, xl, cpm
4604     REAL :: supcol, dtcld, eacrs, egi, praci1, piacr1, psaci1, pgaci1, &
4605 &   temp, temp0
4606     INTEGER :: i, k
4607     REAL :: fsupcol, fqc, fqi, fqr, fqs, fqg, delta3, xlf, a, b, c, d, e
4608     INTRINSIC MAX
4609     INTRINSIC SQRT
4610     INTRINSIC ABS
4611     INTRINSIC MIN
4612     INTRINSIC EXP
4613     REAL :: x1
4614     REAL :: x2
4615     REAL :: x3
4616     REAL :: x4
4617     REAL :: x5
4618     REAL :: y1
4619     REAL :: y2
4620     REAL :: y3
4621     REAL :: y4
4622     REAL :: y5
4623     REAL :: x6
4624     REAL :: x7
4625     REAL :: x8
4626     REAL :: x9
4627     REAL :: x10
4628     REAL :: x11
4629     REAL :: y6
4630     REAL :: max1
4631     REAL :: max2
4632     REAL :: max3
4633     REAL :: max4
4634     REAL :: max5
4635     REAL :: abs0
4636     REAL :: abs1
4637     REAL :: abs2
4638     REAL :: max6
4639     REAL :: max7
4640     REAL :: max8
4641     REAL :: max9
4642     REAL :: max10
4643     REAL :: max11
4644     REAL :: abs3
4645     REAL :: abs4
4646     REAL :: max12
4647     REAL :: max13
4648     REAL :: max14
4649     REAL :: max15
4650     REAL :: max16
4651     REAL :: abs5
4652     REAL :: abs6
4653     REAL :: max17
4654     REAL :: abs7
4655     REAL :: abs8
4656     REAL :: max18
4657     REAL :: max19
4658     REAL :: max20
4659     REAL :: max21
4660     REAL :: max22
4661     REAL :: max23
4662     REAL :: max24
4663     REAL :: max25
4664     REAL :: max26
4665     REAL :: max27
4666     REAL :: max28
4667     REAL :: max29
4668     REAL :: max30
4669     REAL :: pwy1
4670     REAL :: pwr1
4671     REAL :: pwy2
4672     REAL :: pwr2
4673     REAL :: pwx1
4674     REAL :: result1
4675     REAL :: result2
4676     REAL :: result3
4677     REAL :: arg1
4678     DO k=kts,kte
4679       DO i=its,ite
4680 !-------------------------------------------------------------
4681 ! praci: Accretion of cloud ice by rain [LFO 25]
4682 !        (T<T0: I->S or I->G) praci: min=0,max=qci(i,k,2)/dtcld
4683 !-------------------------------------------------------------
4684         supcol = t0c - t(i, k)
4685         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
4686         IF (qrs(i, k, 1) .LT. qcrmin) THEN
4687           max1 = qcrmin
4688         ELSE
4689           max1 = qrs(i, k, 1)
4690         END IF
4691         pwy1 = (bvtr-2.)/4.
4692         pwr1 = den(i, k)**pwy1
4693         pwy2 = bvtr/4.
4694         pwr2 = max1**pwy2
4695         vt2r = vt2r_a*pwr1*pwr2
4696         IF (qci(i, k, 2) .LT. qmin) THEN
4697           max2 = qmin
4698         ELSE
4699           max2 = qci(i, k, 2)
4700         END IF
4701         pwx1 = den(i, k)*max2
4702         pwr1 = pwx1**(1.31/8.)
4703         vt2i = vt2i_a*pwr1
4704         IF (qrs(i, k, 1) .LT. qcrmin) THEN
4705           max3 = qcrmin
4706         ELSE
4707           max3 = qrs(i, k, 1)
4708         END IF
4709         IF (qci(i, k, 2) .LT. qmin) THEN
4710           max18 = qmin
4711         ELSE
4712           max18 = qci(i, k, 2)
4713         END IF
4714         pwx1 = den(i, k)*max3
4715         pwr1 = pwx1**(3./4.)
4716         b = pwr1*max18
4717         IF (qrs(i, k, 1) .LT. qcrmin) THEN
4718           max4 = qcrmin
4719         ELSE
4720           max4 = qrs(i, k, 1)
4721         END IF
4722         IF (qci(i, k, 2) .LT. qmin) THEN
4723           max19 = qmin
4724         ELSE
4725           max19 = qci(i, k, 2)
4726         END IF
4727         pwr1 = den(i, k)**(5./8.)
4728         result1 = SQRT(max4)
4729         pwr2 = max19**(9./8.)
4730         c = pwr1*result1*pwr2
4731         IF (qrs(i, k, 1) .LT. qcrmin) THEN
4732           max5 = qcrmin
4733         ELSE
4734           max5 = qrs(i, k, 1)
4735         END IF
4736         IF (qci(i, k, 2) .LT. qmin) THEN
4737           max20 = qmin
4738         ELSE
4739           max20 = qci(i, k, 2)
4740         END IF
4741         result1 = SQRT(den(i, k))
4742         result2 = SQRT(max5)
4743         result3 = SQRT(result2)
4744         pwr1 = max20**(5./4.)
4745         d = result1*result3*pwr1
4746         IF (vt2r - vt2i .GE. 0.) THEN
4747           abs0 = vt2r - vt2i
4748         ELSE
4749           abs0 = -(vt2r-vt2i)
4750         END IF
4751         praci1 = praci_a*abs0*(praci_b*b+praci_c*c+praci_d*d)
4752         IF (praci1 .GT. qci(i, k, 2)/dtcld) THEN
4753           praci(i, k) = qci(i, k, 2)/dtcld
4754         ELSE
4755           praci(i, k) = praci1
4756         END IF
4757         praci(i, k) = fsupcol*praci(i, k)
4758 !update qi, qs, qg
4759         IF (qrs(i, k, 1) .LT. 1.e-4) THEN
4760           delta3 = 1.
4761         ELSE
4762           delta3 = 0.
4763         END IF
4764         IF (praci(i, k) .GE. 0.) THEN
4765           abs1 = praci(i, k)
4766         ELSE
4767           abs1 = -praci(i, k)
4768         END IF
4769         IF (abs1 .LT. qmin/dtcld) praci(i, k) = 0.
4770         IF (qci(i, k, 2) - praci(i, k)*dtcld .LT. 0.) THEN
4771           qci(i, k, 2) = 0.
4772         ELSE
4773           qci(i, k, 2) = qci(i, k, 2) - praci(i, k)*dtcld
4774         END IF
4775         x1 = qrs(i, k, 2) + praci(i, k)*delta3*dtcld
4776         IF (x1 .LT. 0.) THEN
4777           qrs(i, k, 2) = 0.
4778         ELSE
4779           qrs(i, k, 2) = x1
4780         END IF
4781         x2 = qrs(i, k, 3) + praci(i, k)*(1-delta3)*dtcld
4782         IF (x2 .LT. 0.) THEN
4783           qrs(i, k, 3) = 0.
4784         ELSE
4785           qrs(i, k, 3) = x2
4786         END IF
4787         praci(i, k) = 0.
4788 !-------------------------------------------------------------
4789 ! piacr: Accretion of rain by cloud ice [LFO 26]
4790 !        (T<T0: R->S or R->G) piacr: min=0,max=qrs(i,k,1)/dtcld
4791 !-------------------------------------------------------------
4792 !         supcol = t0c-t(i,k) !not change
4793         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
4794 !call smoothif(qci(i,k,2),qmin  ,fqi,'q0')
4795 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
4796 !update cpm
4797         cpm(i, k) = CPMCAL(q(i, k))
4798         xl(i, k) = XLCAL(t(i, k))
4799         xlf = xls - xl(i, k)
4800         IF (supcol .LT. 0.) xlf = xlf0
4801         IF (qci(i, k, 2) .GT. 0. .AND. qrs(i, k, 1) .GT. 0.) THEN
4802 !piacr_a=1.75e5
4803           pwy1 = (3.+bvtr)/4.
4804           pwr1 = den(i, k)**pwy1
4805           pwy2 = (6.+bvtr)/4.
4806           pwr2 = qrs(i, k, 1)**pwy2
4807           piacr1 = piacr_a*pwr1*qci(i, k, 2)**0.75*pwr2
4808         ELSE
4809           piacr1 = 0.
4810         END IF
4811         IF (piacr1 .GT. qrs(i, k, 1)/dtcld) THEN
4812           piacr(i, k) = qrs(i, k, 1)/dtcld
4813         ELSE
4814           piacr(i, k) = piacr1
4815         END IF
4816         piacr(i, k) = fsupcol*piacr(i, k)
4817 ! update qr,qs,qg,t
4818         IF (qrs(i, k, 1) .LT. 1.e-4) THEN
4819           delta3 = 1.
4820         ELSE
4821           delta3 = 0.
4822         END IF
4823         IF (piacr(i, k) .GE. 0.) THEN
4824           abs2 = piacr(i, k)
4825         ELSE
4826           abs2 = -piacr(i, k)
4827         END IF
4828         IF (abs2 .LT. qmin/dtcld) piacr(i, k) = 0.
4829         IF (qrs(i, k, 1) - piacr(i, k)*dtcld .LT. 0.) THEN
4830           qrs(i, k, 1) = 0.
4831         ELSE
4832           qrs(i, k, 1) = qrs(i, k, 1) - piacr(i, k)*dtcld
4833         END IF
4834         x3 = qrs(i, k, 2) + piacr(i, k)*delta3*dtcld
4835         IF (x3 .LT. 0.) THEN
4836           qrs(i, k, 2) = 0.
4837         ELSE
4838           qrs(i, k, 2) = x3
4839         END IF
4840         x4 = qrs(i, k, 3) + piacr(i, k)*(1-delta3)*dtcld
4841         IF (x4 .LT. 0.) THEN
4842           qrs(i, k, 3) = 0.
4843         ELSE
4844           qrs(i, k, 3) = x4
4845         END IF
4846         t(i, k) = t(i, k) + piacr(i, k)*dtcld*xlf/cpm(i, k)
4847         piacr(i, k) = 0.
4848 !-------------------------------------------------------------
4849 ! psaci: Accretion of cloud ice by snow [HDC 10]
4850 !        (T<T0: I->S) psaci: min=0, max=qci(i,k,2)/dtcld
4851 !-------------------------------------------------------------
4852         supcol = t0c - t(i, k)
4853         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
4854         x5 = EXP(0.07*(-supcol))
4855         IF (x5 .GT. 1.) THEN
4856           eacrs = 1.
4857         ELSE
4858           eacrs = x5
4859         END IF
4860         IF (qrs(i, k, 2) .LT. qcrmin) THEN
4861           max6 = qcrmin
4862         ELSE
4863           max6 = qrs(i, k, 2)
4864         END IF
4865         IF (90. .GT. t0c - t(i, k)) THEN
4866           y6 = t0c - t(i, k)
4867         ELSE
4868           y6 = 90.
4869         END IF
4870         IF (0. .LT. y6) THEN
4871           max21 = y6
4872         ELSE
4873           max21 = 0.
4874         END IF
4875         pwy1 = (bvts-2.)/4.
4876         pwr1 = den(i, k)**pwy1
4877         pwy2 = bvts/4.
4878         pwr2 = max6**pwy2
4879         arg1 = -(alpha*bvts*max21/4.)
4880         vt2s = vt2s_a*pwr1*pwr2*EXP(arg1)
4881         IF (qci(i, k, 2) .LT. qmin) THEN
4882           max7 = qmin
4883         ELSE
4884           max7 = qci(i, k, 2)
4885         END IF
4886         pwx1 = den(i, k)*max7
4887         pwr1 = pwx1**(1.31/8.)
4888         vt2i = vt2i_a*pwr1
4889         IF (90. .GT. t0c - t(i, k)) THEN
4890           y1 = t0c - t(i, k)
4891         ELSE
4892           y1 = 90.
4893         END IF
4894         IF (0. .LT. y1) THEN
4895           max8 = y1
4896         ELSE
4897           max8 = 0.
4898         END IF
4899         a = EXP(alpha*max8)
4900         IF (90. .GT. t0c - t(i, k)) THEN
4901           y2 = t0c - t(i, k)
4902         ELSE
4903           y2 = 90.
4904         END IF
4905         IF (0. .LT. y2) THEN
4906           max9 = y2
4907         ELSE
4908           max9 = 0.
4909         END IF
4910         IF (qrs(i, k, 2) .LT. qcrmin) THEN
4911           max22 = qcrmin
4912         ELSE
4913           max22 = qrs(i, k, 2)
4914         END IF
4915         IF (qci(i, k, 2) .LT. qmin) THEN
4916           max28 = qmin
4917         ELSE
4918           max28 = qci(i, k, 2)
4919         END IF
4920         arg1 = -(3.*alpha*max9/4.)
4921         pwx1 = den(i, k)*max22
4922         pwr1 = pwx1**(3./4.)
4923         b = EXP(arg1)*pwr1*max28
4924         IF (90. .GT. t0c - t(i, k)) THEN
4925           y3 = t0c - t(i, k)
4926         ELSE
4927           y3 = 90.
4928         END IF
4929         IF (0. .LT. y3) THEN
4930           max10 = y3
4931         ELSE
4932           max10 = 0.
4933         END IF
4934         IF (qrs(i, k, 2) .LT. qcrmin) THEN
4935           max23 = qcrmin
4936         ELSE
4937           max23 = qrs(i, k, 2)
4938         END IF
4939         IF (qci(i, k, 2) .LT. qmin) THEN
4940           max29 = qmin
4941         ELSE
4942           max29 = qci(i, k, 2)
4943         END IF
4944         arg1 = -(alpha*max10/2.)
4945         pwr1 = den(i, k)**(5./8.)
4946         result1 = SQRT(max23)
4947         pwr2 = max29**(9./8.)
4948         c = EXP(arg1)*pwr1*result1*pwr2
4949         IF (90. .GT. t0c - t(i, k)) THEN
4950           y4 = t0c - t(i, k)
4951         ELSE
4952           y4 = 90.
4953         END IF
4954         IF (0. .LT. y4) THEN
4955           max11 = y4
4956         ELSE
4957           max11 = 0.
4958         END IF
4959         IF (qrs(i, k, 2) .LT. qcrmin) THEN
4960           max24 = qcrmin
4961         ELSE
4962           max24 = qrs(i, k, 2)
4963         END IF
4964         IF (qci(i, k, 2) .LT. qmin) THEN
4965           max30 = qmin
4966         ELSE
4967           max30 = qci(i, k, 2)
4968         END IF
4969         arg1 = -(alpha*max11/4.)
4970         result1 = SQRT(den(i, k))
4971         result2 = SQRT(max24)
4972         result3 = SQRT(result2)
4973         pwr1 = max30**(5./4.)
4974         d = EXP(arg1)*result1*result3*pwr1
4975         IF (vt2s - vt2i .GE. 0.) THEN
4976           abs3 = vt2s - vt2i
4977         ELSE
4978           abs3 = -(vt2s-vt2i)
4979         END IF
4980         psaci1 = psaci_a*a*abs3*(psaci_b*b+psaci_c*c+psaci_d*d)*eacrs
4981         IF (psaci1 .GT. qci(i, k, 2)/dtcld) THEN
4982           psaci(i, k) = qci(i, k, 2)/dtcld
4983         ELSE
4984           psaci(i, k) = psaci1
4985         END IF
4986         psaci(i, k) = fsupcol*psaci(i, k)
4987         IF (psaci(i, k) .GE. 0.) THEN
4988           abs4 = psaci(i, k)
4989         ELSE
4990           abs4 = -psaci(i, k)
4991         END IF
4992         IF (abs4 .LT. qmin/dtcld) psaci(i, k) = 0.
4993         IF (qci(i, k, 2) - psaci(i, k)*dtcld .LT. 0.) THEN
4994           qci(i, k, 2) = 0.
4995         ELSE
4996           qci(i, k, 2) = qci(i, k, 2) - psaci(i, k)*dtcld
4997         END IF
4998         IF (qrs(i, k, 2) + psaci(i, k)*dtcld .LT. 0.) THEN
4999           qrs(i, k, 2) = 0.
5000         ELSE
5001           qrs(i, k, 2) = qrs(i, k, 2) + psaci(i, k)*dtcld
5002         END IF
5003         psaci(i, k) = 0.
5004 !-------------------------------------------------------------
5005 ! pgaci: Accretion of cloud ice by graupel [LFO 41]
5006 !        (T<T0: I->G) pgaci:min=0,max=qci(i,k,2)/dtcld
5007 !-------------------------------------------------------------
5008 !         supcol = t0c-t(i,k) !not change
5009 !         call smoothif(supcol,    0.,fsupcol,'t0')
5010 !call smoothif(qci(i,k,2),qmin  ,fqi,'q0')
5011 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
5012 !min(exp(0.07*(-supcol)),1.)
5013         egi = eacrs
5014         IF (qrs(i, k, 3) .LT. qcrmin) THEN
5015           max12 = qcrmin
5016         ELSE
5017           max12 = qrs(i, k, 3)
5018         END IF
5019         pwy1 = (bvtg-2.)/4.
5020         pwr1 = den(i, k)**pwy1
5021         pwy2 = bvtg/4.
5022         pwr2 = max12**pwy2
5023         vt2g = vt2g_a*pwr1*pwr2
5024         IF (qci(i, k, 2) .LT. qmin) THEN
5025           max13 = qmin
5026         ELSE
5027           max13 = qci(i, k, 2)
5028         END IF
5029         pwx1 = den(i, k)*max13
5030         pwr1 = pwx1**(1.31/8.)
5031         vt2i = vt2i_a*pwr1
5032         IF (qrs(i, k, 3) .LT. qcrmin) THEN
5033           max14 = qcrmin
5034         ELSE
5035           max14 = qrs(i, k, 3)
5036         END IF
5037         IF (qci(i, k, 2) .LT. qmin) THEN
5038           max25 = qmin
5039         ELSE
5040           max25 = qci(i, k, 2)
5041         END IF
5042         pwx1 = den(i, k)*max14
5043         pwr1 = pwx1**(3./4.)
5044         b = pwr1*max25
5045         IF (qrs(i, k, 3) .LT. qcrmin) THEN
5046           max15 = qcrmin
5047         ELSE
5048           max15 = qrs(i, k, 3)
5049         END IF
5050         IF (qci(i, k, 2) .LT. qmin) THEN
5051           max26 = qmin
5052         ELSE
5053           max26 = qci(i, k, 2)
5054         END IF
5055         pwr1 = den(i, k)**(5./8.)
5056         result1 = SQRT(max15)
5057         pwr2 = max26**(9./8.)
5058         c = pwr1*result1*pwr2
5059         IF (qrs(i, k, 3) .LT. qcrmin) THEN
5060           max16 = qcrmin
5061         ELSE
5062           max16 = qrs(i, k, 3)
5063         END IF
5064         IF (qci(i, k, 2) .LT. qmin) THEN
5065           max27 = qmin
5066         ELSE
5067           max27 = qci(i, k, 2)
5068         END IF
5069         result1 = SQRT(den(i, k))
5070         result2 = SQRT(max16)
5071         result3 = SQRT(result2)
5072         pwr1 = max27**(5./4.)
5073         d = result1*result3*pwr1
5074         IF (vt2g - vt2i .GE. 0.) THEN
5075           abs5 = vt2g - vt2i
5076         ELSE
5077           abs5 = -(vt2g-vt2i)
5078         END IF
5079         pgaci1 = pgaci_a*abs5*(pgaci_b*b+pgaci_c*c+pgaci_d*d)*egi
5080         IF (pgaci1 .GT. qci(i, k, 2)/dtcld) THEN
5081           pgaci(i, k) = qci(i, k, 2)/dtcld
5082         ELSE
5083           pgaci(i, k) = pgaci1
5084         END IF
5085         pgaci(i, k) = fsupcol*pgaci(i, k)
5086         IF (pgaci(i, k) .GE. 0.) THEN
5087           abs6 = pgaci(i, k)
5088         ELSE
5089           abs6 = -pgaci(i, k)
5090         END IF
5091         IF (abs6 .LT. qmin/dtcld) pgaci(i, k) = 0.
5092         IF (qci(i, k, 2) - pgaci(i, k)*dtcld .LT. 0.) THEN
5093           qci(i, k, 2) = 0.
5094         ELSE
5095           qci(i, k, 2) = qci(i, k, 2) - pgaci(i, k)*dtcld
5096         END IF
5097         IF (qrs(i, k, 3) + pgaci(i, k)*dtcld .LT. 0.) THEN
5098           qrs(i, k, 3) = 0.
5099         ELSE
5100           qrs(i, k, 3) = qrs(i, k, 3) + pgaci(i, k)*dtcld
5101         END IF
5102         pgaci(i, k) = 0.
5103 !-------------------------------------------------------------
5104 ! psacw: Accretion of cloud water by snow  [LFO 24]
5105 !        (T<T0: C->G, and T>=T0: C->R) psacw:min=0,max=qci(i,k,1)/dtcld
5106 !-------------------------------------------------------------
5107 !         supcol = t0c-t(i,k) !not change
5108 !         call smoothif(supcol,    0.,fsupcol,'t0')
5109 !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0')
5110 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
5111 !update cpm
5112 !         cpm(i,k)=cpmcal(q(i,k)) !not change
5113         xl(i, k) = XLCAL(t(i, k))
5114         xlf = xls - xl(i, k)
5115         IF (supcol .LT. 0.) xlf = xlf0
5116         IF (qrs(i, k, 2) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN
5117           IF (90. .GT. t0c - t(i, k)) THEN
5118             y5 = t0c - t(i, k)
5119           ELSE
5120             y5 = 90.
5121           END IF
5122           IF (0. .LT. y5) THEN
5123             max17 = y5
5124           ELSE
5125             max17 = 0.
5126           END IF
5127           arg1 = (1.-bvts)*alpha*max17/4.
5128           a = EXP(arg1)
5129           pwy1 = (1.+bvts)/4.
5130           pwr1 = den(i, k)**pwy1
5131           pwy2 = (3.+bvts)/4.
5132           pwr2 = qrs(i, k, 2)**pwy2
5133           psacw(i, k) = psacw_a*a*pwr1*pwr2*qci(i, k, 1)
5134         ELSE
5135           psacw(i, k) = 0.
5136         END IF
5137         IF (psacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
5138           x6 = qci(i, k, 1)/dtcld
5139         ELSE
5140           x6 = psacw(i, k)
5141         END IF
5142         IF (x6 .LT. 0.) THEN
5143           psacw(i, k) = 0.
5144         ELSE
5145           psacw(i, k) = x6
5146         END IF
5147         psacw(i, k) = fsupcol*psacw(i, k)
5148         IF (psacw(i, k) .GE. 0.) THEN
5149           abs7 = psacw(i, k)
5150         ELSE
5151           abs7 = -psacw(i, k)
5152         END IF
5153         IF (abs7 .LT. qmin/dtcld) psacw(i, k) = 0.
5154         IF (qci(i, k, 1) - psacw(i, k)*dtcld .LT. 0.) THEN
5155           qci(i, k, 1) = 0.
5156         ELSE
5157           qci(i, k, 1) = qci(i, k, 1) - psacw(i, k)*dtcld
5158         END IF
5159         x7 = qrs(i, k, 1) + (1.-fsupcol)*psacw(i, k)*dtcld
5160         IF (x7 .LT. 0.) THEN
5161           qrs(i, k, 1) = 0.
5162         ELSE
5163           qrs(i, k, 1) = x7
5164         END IF
5165         x8 = qrs(i, k, 3) + fsupcol*psacw(i, k)*dtcld
5166         IF (x8 .LT. 0.) THEN
5167           qrs(i, k, 3) = 0.
5168         ELSE
5169           qrs(i, k, 3) = x8
5170         END IF
5171         t(i, k) = t(i, k) + fsupcol*psacw(i, k)*dtcld*xlf/cpm(i, k)
5172 !t>=t0 pseml
5173         psacw(i, k) = (1-fsupcol)*psacw(i, k)
5174 !-------------------------------------------------------------
5175 ! pgacw: Accretion of cloud water by graupel [LFO 40]
5176 !        (T<T0: C->G, and T>=T0: C->R) pgacw:min=0.,max=qci(i,k,1)/dtcld
5177 !-------------------------------------------------------------
5178         supcol = t0c - t(i, k)
5179         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
5180 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
5181 !call smoothif(qci(i,k,1),qmin  ,fqc,'q0')
5182 !         cpm(i,k)=cpmcal(q(i,k)) !not change
5183         xl(i, k) = XLCAL(t(i, k))
5184         xlf = xls - xl(i, k)
5185         IF (supcol .LT. 0.) xlf = xlf0
5186         IF (qrs(i, k, 3) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN
5187           pwy1 = (1.+bvtg)/4.
5188           pwr1 = den(i, k)**pwy1
5189           pwy2 = (3.+bvtg)/4.
5190           pwr2 = qrs(i, k, 3)**pwy2
5191           pgacw(i, k) = pgacw_a*pwr1*pwr2*qci(i, k, 1)
5192         ELSE
5193           pgacw(i, k) = 0.
5194         END IF
5195         IF (pgacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN
5196           x9 = qci(i, k, 1)/dtcld
5197         ELSE
5198           x9 = pgacw(i, k)
5199         END IF
5200         IF (x9 .LT. 0.) THEN
5201           pgacw(i, k) = 0.
5202         ELSE
5203           pgacw(i, k) = x9
5204         END IF
5205         IF (pgacw(i, k) .GE. 0.) THEN
5206           abs8 = pgacw(i, k)
5207         ELSE
5208           abs8 = -pgacw(i, k)
5209         END IF
5210 !pgacw(i,k)=fqg*fqc*pgacw(i,k)
5211         IF (abs8 .LT. qmin/dtcld) pgacw(i, k) = 0.
5212         IF (qci(i, k, 1) - pgacw(i, k)*dtcld .LT. 0.) THEN
5213           qci(i, k, 1) = 0.
5214         ELSE
5215           qci(i, k, 1) = qci(i, k, 1) - pgacw(i, k)*dtcld
5216         END IF
5217         x10 = qrs(i, k, 1) + (1.-fsupcol)*pgacw(i, k)*dtcld
5218         IF (x10 .LT. 0.) THEN
5219           qrs(i, k, 1) = 0.
5220         ELSE
5221           qrs(i, k, 1) = x10
5222         END IF
5223         x11 = qrs(i, k, 3) + fsupcol*pgacw(i, k)*dtcld
5224         IF (x11 .LT. 0.) THEN
5225           qrs(i, k, 3) = 0.
5226         ELSE
5227           qrs(i, k, 3) = x11
5228         END IF
5229         t(i, k) = t(i, k) + fsupcol*pgacw(i, k)*dtcld*xlf/cpm(i, k)
5230 ! t>=t0 pgeml
5231         pgacw(i, k) = (1-fsupcol)*pgacw(i, k)
5232       END DO
5233     END DO
5234   END SUBROUTINE ACCRET1
5235
5236 !  Differentiation of accret2 in forward (tangent) mode (with options r8):
5237 !   variations   of useful results: t psacr psacw pgacr pgacs pracs
5238 !                pgacw qrs pseml pgeml
5239 !   with respect to varying inputs: q t psacr psacw pgacr pgacs
5240 !                pracs pgacw den qrs pseml pgeml
5241 !=======================================================================
5242 !
5243 !=======================================================================
5244   SUBROUTINE G_ACCRET2(qrs, g_qrs, t, g_t, q, g_q, den, g_den, dtcld, &
5245 &   psacw, g_psacw, pgacw, g_pgacw, pracs, g_pracs, psacr, g_psacr, &
5246 &   pgacr, g_pgacr, pgacs, g_pgacs, pseml, g_pseml, pgeml, g_pgeml, ims&
5247 &   , ime, kms, kme, its, ite, kts, kte)
5248     IMPLICIT NONE
5249     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
5250 !-------------------------------------------------------------------
5251     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
5252     REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs
5253     REAL, DIMENSION(ims:ime, kms:kme) :: den, q
5254     REAL, DIMENSION(ims:ime, kms:kme) :: g_den, g_q
5255     REAL, DIMENSION(its:ite, kts:kte) :: psacw, pgacw, pracs, psacr, &
5256 &   pgacr, pgacs, pseml, pgeml, t, xl, cpm
5257     REAL, DIMENSION(its:ite, kts:kte) :: g_psacw, g_pgacw, g_pracs, &
5258 &   g_psacr, g_pgacr, g_pgacs, g_pseml, g_pgeml, g_t, g_xl, g_cpm
5259     REAL :: supcol, vt2r, vt2s, vt2g, dtcld, xlf, egs
5260     REAL :: g_supcol, g_vt2r, g_vt2s, g_vt2g, g_xlf, g_egs
5261     REAL :: acrfac1, acrfac2, acrfac3, acrfac4, pracs1, psacr1, pgacr1, &
5262 &   pgacs1
5263     REAL :: g_pracs1, g_psacr1, g_pgacr1, g_pgacs1
5264     INTEGER :: i, k
5265     REAL :: fsupcol, ft0, fqr, fqs, fqg, temp1, delta2, a, b, c, d
5266     REAL :: g_fsupcol, g_ft0, g_fqs, g_fqg, g_a, g_b, g_c, g_d
5267     INTRINSIC MAX
5268     INTRINSIC MIN
5269     INTRINSIC EXP
5270     INTRINSIC SQRT
5271     INTRINSIC ABS
5272     REAL :: y1
5273     REAL :: g_y1
5274     REAL :: y2
5275     REAL :: g_y2
5276     REAL :: y3
5277     REAL :: g_y3
5278     REAL :: y4
5279     REAL :: g_y4
5280     REAL :: y5
5281     REAL :: g_y5
5282     REAL :: y6
5283     REAL :: g_y6
5284     REAL :: y7
5285     REAL :: g_y7
5286     REAL :: y8
5287     REAL :: g_y8
5288     REAL :: x1
5289     REAL :: g_x1
5290     REAL :: x2
5291     REAL :: g_x2
5292     REAL :: x3
5293     REAL :: g_x3
5294     REAL :: x4
5295     REAL :: g_x4
5296     REAL :: y9
5297     REAL :: g_y9
5298     REAL :: y10
5299     REAL :: g_y10
5300     REAL :: y11
5301     REAL :: g_y11
5302     REAL :: y12
5303     REAL :: g_y12
5304     REAL :: x5
5305     REAL :: g_x5
5306     REAL :: x6
5307     REAL :: g_x6
5308     REAL :: y13
5309     REAL :: g_y13
5310     REAL :: y14
5311     REAL :: g_y14
5312     REAL :: y15
5313     REAL :: g_y15
5314     REAL :: x7
5315     REAL :: g_x7
5316     REAL :: x8
5317     REAL :: g_x8
5318     REAL :: max1
5319     REAL :: g_max1
5320     REAL :: max2
5321     REAL :: g_max2
5322     REAL :: max3
5323     REAL :: g_max3
5324     REAL :: max4
5325     REAL :: g_max4
5326     REAL :: max5
5327     REAL :: g_max5
5328     REAL :: max6
5329     REAL :: g_max6
5330     REAL :: abs0
5331     REAL :: g_abs0
5332     REAL :: abs1
5333     REAL :: max7
5334     REAL :: g_max7
5335     REAL :: max8
5336     REAL :: g_max8
5337     REAL :: max9
5338     REAL :: g_max9
5339     REAL :: max10
5340     REAL :: g_max10
5341     REAL :: max11
5342     REAL :: g_max11
5343     REAL :: max12
5344     REAL :: g_max12
5345     REAL :: abs2
5346     REAL :: g_abs2
5347     REAL :: abs3
5348     REAL :: max13
5349     REAL :: g_max13
5350     REAL :: max14
5351     REAL :: g_max14
5352     REAL :: max15
5353     REAL :: g_max15
5354     REAL :: max16
5355     REAL :: g_max16
5356     REAL :: max17
5357     REAL :: g_max17
5358     REAL :: abs4
5359     REAL :: g_abs4
5360     REAL :: abs5
5361     REAL :: max18
5362     REAL :: g_max18
5363     REAL :: max19
5364     REAL :: g_max19
5365     REAL :: max20
5366     REAL :: g_max20
5367     REAL :: max21
5368     REAL :: g_max21
5369     REAL :: max22
5370     REAL :: g_max22
5371     REAL :: max23
5372     REAL :: g_max23
5373     REAL :: abs6
5374     REAL :: g_abs6
5375     REAL :: abs7
5376     REAL :: abs8
5377     REAL :: abs9
5378     REAL :: max24
5379     REAL :: g_max24
5380     REAL :: max25
5381     REAL :: g_max25
5382     REAL :: max26
5383     REAL :: g_max26
5384     REAL :: max27
5385     REAL :: g_max27
5386     REAL :: max28
5387     REAL :: g_max28
5388     REAL :: max29
5389     REAL :: g_max29
5390     REAL :: max30
5391     REAL :: g_max30
5392     REAL :: max31
5393     REAL :: g_max31
5394     REAL :: max32
5395     REAL :: g_max32
5396     REAL :: max33
5397     REAL :: g_max33
5398     REAL :: max34
5399     REAL :: g_max34
5400     REAL :: max35
5401     REAL :: g_max35
5402     REAL :: max36
5403     REAL :: g_max36
5404     REAL :: max37
5405     REAL :: g_max37
5406     REAL :: max38
5407     REAL :: g_max38
5408     REAL :: max39
5409     REAL :: g_max39
5410     REAL :: max40
5411     REAL :: g_max40
5412     REAL :: max41
5413     REAL :: g_max41
5414     REAL :: max42
5415     REAL :: g_max42
5416     REAL :: max43
5417     REAL :: g_max43
5418     REAL :: max44
5419     REAL :: g_max44
5420     REAL :: max45
5421     REAL :: g_max45
5422     REAL :: max46
5423     REAL :: g_max46
5424     REAL :: max47
5425     REAL :: g_max47
5426     REAL :: pwy1
5427     REAL :: pwr1
5428     REAL :: g_pwr1
5429     REAL :: pwy2
5430     REAL :: pwr2
5431     REAL :: g_pwr2
5432     REAL :: arg1
5433     REAL :: g_arg1
5434     REAL :: result1
5435     REAL :: g_result1
5436     REAL :: result2
5437     REAL :: g_result2
5438     REAL :: temp
5439     REAL :: temp0
5440     g_cpm = 0.0_8
5441     g_xl = 0.0_8
5442     DO k=kts,kte
5443       DO i=its,ite
5444 !-------------------------------------------------------------
5445 ! pracs: Accretion of snow by rain [LFO 27]
5446 !         (T<T0: S->G) pracs: min=0., max=qrs(i,k,2)/dtcld
5447 !-------------------------------------------------------------
5448         g_supcol = -g_t(i, k)
5449         supcol = t0c - t(i, k)
5450         CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0')
5451         IF (qrs(i, k, 1) .LT. qcrmin) THEN
5452           max1 = qcrmin
5453           g_max1 = 0.0_8
5454         ELSE
5455           g_max1 = g_qrs(i, k, 1)
5456           max1 = qrs(i, k, 1)
5457         END IF
5458 !call smoothif(qrs(i,k,1),1.e-4,fqr,'q0')
5459 !call smoothif(qrs(i,k,2),1.e-4,fqs,'q0')
5460         pwy1 = (bvtr-2.)/4.
5461         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
5462 &           INT(pwy1))) THEN
5463           g_pwr1 = 0.0_8
5464         ELSE
5465           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
5466         END IF
5467         pwr1 = den(i, k)**pwy1
5468         pwy2 = bvtr/4.
5469         IF (max1 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
5470 &           pwy2))) THEN
5471           g_pwr2 = 0.0_8
5472         ELSE
5473           g_pwr2 = pwy2*max1**(pwy2-1)*g_max1
5474         END IF
5475         pwr2 = max1**pwy2
5476         g_vt2r = vt2r_a*(pwr2*g_pwr1+pwr1*g_pwr2)
5477         vt2r = vt2r_a*pwr1*pwr2
5478         IF (qrs(i, k, 2) .LT. qcrmin) THEN
5479           max2 = qcrmin
5480           g_max2 = 0.0_8
5481         ELSE
5482           g_max2 = g_qrs(i, k, 2)
5483           max2 = qrs(i, k, 2)
5484         END IF
5485         IF (90. .GT. t0c - t(i, k)) THEN
5486           g_y13 = -g_t(i, k)
5487           y13 = t0c - t(i, k)
5488         ELSE
5489           y13 = 90.
5490           g_y13 = 0.0_8
5491         END IF
5492         IF (0. .LT. y13) THEN
5493           g_max24 = g_y13
5494           max24 = y13
5495         ELSE
5496           max24 = 0.
5497           g_max24 = 0.0_8
5498         END IF
5499         pwy1 = (bvts-2.)/4.
5500         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
5501 &           INT(pwy1))) THEN
5502           g_pwr1 = 0.0_8
5503         ELSE
5504           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
5505         END IF
5506         pwr1 = den(i, k)**pwy1
5507         pwy2 = bvts/4.
5508         IF (max2 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
5509 &           pwy2))) THEN
5510           g_pwr2 = 0.0_8
5511         ELSE
5512           g_pwr2 = pwy2*max2**(pwy2-1)*g_max2
5513         END IF
5514         pwr2 = max2**pwy2
5515         g_arg1 = -(alpha*bvts*g_max24/4.)
5516         arg1 = -(alpha*bvts*max24/4.)
5517         temp = EXP(arg1)
5518         g_vt2s = vt2s_a*(temp*(pwr2*g_pwr1+pwr1*g_pwr2)+pwr1*pwr2*EXP(&
5519 &         arg1)*g_arg1)
5520         vt2s = vt2s_a*(pwr1*pwr2*temp)
5521         IF (90. .GT. t0c - t(i, k)) THEN
5522           g_y1 = -g_t(i, k)
5523           y1 = t0c - t(i, k)
5524         ELSE
5525           y1 = 90.
5526           g_y1 = 0.0_8
5527         END IF
5528         IF (0. .LT. y1) THEN
5529           g_max3 = g_y1
5530           max3 = y1
5531         ELSE
5532           max3 = 0.
5533           g_max3 = 0.0_8
5534         END IF
5535         g_a = EXP(alpha*max3)*alpha*g_max3
5536         a = EXP(alpha*max3)
5537         IF (90. .GT. t0c - t(i, k)) THEN
5538           g_y2 = -g_t(i, k)
5539           y2 = t0c - t(i, k)
5540         ELSE
5541           y2 = 90.
5542           g_y2 = 0.0_8
5543         END IF
5544         IF (0. .LT. y2) THEN
5545           g_max4 = g_y2
5546           max4 = y2
5547         ELSE
5548           max4 = 0.
5549           g_max4 = 0.0_8
5550         END IF
5551         IF (qrs(i, k, 2) .LT. qcrmin) THEN
5552           max25 = qcrmin
5553           g_max25 = 0.0_8
5554         ELSE
5555           g_max25 = g_qrs(i, k, 2)
5556           max25 = qrs(i, k, 2)
5557         END IF
5558         IF (qrs(i, k, 1) .LT. qcrmin) THEN
5559           max39 = qcrmin
5560           g_max39 = 0.0_8
5561         ELSE
5562           g_max39 = g_qrs(i, k, 1)
5563           max39 = qrs(i, k, 1)
5564         END IF
5565         g_arg1 = -(alpha*3.*g_max4/2.)
5566         arg1 = -(3.*alpha*max4/2.)
5567         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
5568 &           INT(3./4.))) THEN
5569           g_pwr1 = 0.0_8
5570         ELSE
5571           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
5572         END IF
5573         pwr1 = den(i, k)**(3./4.)
5574         IF (max25 .LE. 0.0_8 .AND. (3./2. .EQ. 0.0_8 .OR. 3./2. .NE. INT&
5575 &           (3./2.))) THEN
5576           g_pwr2 = 0.0_8
5577         ELSE
5578           g_pwr2 = 3.*max25**(3./2.-1)*g_max25/2.
5579         END IF
5580         pwr2 = max25**(3./2.)
5581         temp = SQRT(max39)
5582         IF (max39 .EQ. 0.0_8) THEN
5583           g_result1 = 0.0_8
5584         ELSE
5585           g_result1 = g_max39/(2.0*temp)
5586         END IF
5587         result1 = temp
5588         temp = SQRT(result1)
5589         IF (result1 .EQ. 0.0_8) THEN
5590           g_result2 = 0.0_8
5591         ELSE
5592           g_result2 = g_result1/(2.0*temp)
5593         END IF
5594         result2 = temp
5595         temp = pwr1*pwr2*result2
5596         temp0 = EXP(arg1)
5597         g_b = temp*EXP(arg1)*g_arg1 + temp0*(result2*(pwr2*g_pwr1+pwr1*&
5598 &         g_pwr2)+pwr1*pwr2*g_result2)
5599         b = temp0*temp
5600         IF (90. .GT. t0c - t(i, k)) THEN
5601           g_y3 = -g_t(i, k)
5602           y3 = t0c - t(i, k)
5603         ELSE
5604           y3 = 90.
5605           g_y3 = 0.0_8
5606         END IF
5607         IF (0. .LT. y3) THEN
5608           g_max5 = g_y3
5609           max5 = y3
5610         ELSE
5611           max5 = 0.
5612           g_max5 = 0.0_8
5613         END IF
5614         IF (qrs(i, k, 2) .LT. qcrmin) THEN
5615           max26 = qcrmin
5616           g_max26 = 0.0_8
5617         ELSE
5618           g_max26 = g_qrs(i, k, 2)
5619           max26 = qrs(i, k, 2)
5620         END IF
5621         IF (qrs(i, k, 1) .LT. qcrmin) THEN
5622           max40 = qcrmin
5623           g_max40 = 0.0_8
5624         ELSE
5625           g_max40 = g_qrs(i, k, 1)
5626           max40 = qrs(i, k, 1)
5627         END IF
5628         g_arg1 = -(alpha*5.*g_max5/4.)
5629         arg1 = -(5.*alpha*max5/4.)
5630         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
5631 &           INT(3./4.))) THEN
5632           g_pwr1 = 0.0_8
5633         ELSE
5634           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
5635         END IF
5636         pwr1 = den(i, k)**(3./4.)
5637         IF (max26 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT&
5638 &           (5./4.))) THEN
5639           g_pwr2 = 0.0_8
5640         ELSE
5641           g_pwr2 = 5.*max26**(5./4.-1)*g_max26/4.
5642         END IF
5643         pwr2 = max26**(5./4.)
5644         temp0 = SQRT(max40)
5645         IF (max40 .EQ. 0.0_8) THEN
5646           g_result1 = 0.0_8
5647         ELSE
5648           g_result1 = g_max40/(2.0*temp0)
5649         END IF
5650         result1 = temp0
5651         temp0 = pwr1*pwr2*result1
5652         temp = EXP(arg1)
5653         g_c = temp0*EXP(arg1)*g_arg1 + temp*(result1*(pwr2*g_pwr1+pwr1*&
5654 &         g_pwr2)+pwr1*pwr2*g_result1)
5655         c = temp*temp0
5656         IF (90. .GT. t0c - t(i, k)) THEN
5657           g_y4 = -g_t(i, k)
5658           y4 = t0c - t(i, k)
5659         ELSE
5660           y4 = 90.
5661           g_y4 = 0.0_8
5662         END IF
5663         IF (0. .LT. y4) THEN
5664           g_max6 = g_y4
5665           max6 = y4
5666         ELSE
5667           max6 = 0.
5668           g_max6 = 0.0_8
5669         END IF
5670         IF (qrs(i, k, 2) .LT. qcrmin) THEN
5671           max27 = qcrmin
5672           g_max27 = 0.0_8
5673         ELSE
5674           g_max27 = g_qrs(i, k, 2)
5675           max27 = qrs(i, k, 2)
5676         END IF
5677         IF (qrs(i, k, 1) .LT. qcrmin) THEN
5678           max41 = qcrmin
5679           g_max41 = 0.0_8
5680         ELSE
5681           g_max41 = g_qrs(i, k, 1)
5682           max41 = qrs(i, k, 1)
5683         END IF
5684         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
5685 &           INT(3./4.))) THEN
5686           g_pwr1 = 0.0_8
5687         ELSE
5688           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
5689         END IF
5690         pwr1 = den(i, k)**(3./4.)
5691         IF (max41 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT&
5692 &           (3./4.))) THEN
5693           g_pwr2 = 0.0_8
5694         ELSE
5695           g_pwr2 = 3.*max41**(3./4.-1)*g_max41/4.
5696         END IF
5697         pwr2 = max41**(3./4.)
5698         temp0 = pwr1*max27*pwr2
5699         temp = EXP(-(alpha*max6))
5700         g_d = temp*(pwr2*(max27*g_pwr1+pwr1*g_max27)+pwr1*max27*g_pwr2) &
5701 &         - temp0*EXP(-(alpha*max6))*alpha*g_max6
5702         d = temp*temp0
5703         IF (vt2r - vt2s .GE. 0.) THEN
5704           g_abs0 = g_vt2r - g_vt2s
5705           abs0 = vt2r - vt2s
5706         ELSE
5707           g_abs0 = g_vt2s - g_vt2r
5708           abs0 = -(vt2r-vt2s)
5709         END IF
5710         temp0 = pracs_b*b + pracs_c*c + pracs_d*d
5711         g_pracs1 = pracs_a*(temp0*(abs0*g_a+a*g_abs0)+a*abs0*(pracs_b*&
5712 &         g_b+pracs_c*g_c+pracs_d*g_d))
5713         pracs1 = pracs_a*(a*abs0*temp0)
5714         IF (pracs1 .GT. qrs(i, k, 2)/dtcld) THEN
5715           g_pracs(i, k) = g_qrs(i, k, 2)/dtcld
5716           pracs(i, k) = qrs(i, k, 2)/dtcld
5717         ELSE
5718           g_pracs(i, k) = g_pracs1
5719           pracs(i, k) = pracs1
5720         END IF
5721         g_pracs(i, k) = pracs(i, k)*g_fsupcol + fsupcol*g_pracs(i, k)
5722         pracs(i, k) = fsupcol*pracs(i, k)
5723         IF (pracs(i, k) .GE. 0.) THEN
5724           abs1 = pracs(i, k)
5725         ELSE
5726           abs1 = -pracs(i, k)
5727         END IF
5728         IF (abs1 .LT. qmin/dtcld) THEN
5729           g_pracs(i, k) = 0.0_8
5730           pracs(i, k) = 0.
5731         END IF
5732         IF (qrs(i, k, 2) - pracs(i, k)*dtcld .LT. 0.) THEN
5733           g_qrs(i, k, 2) = 0.0_8
5734           qrs(i, k, 2) = 0.
5735         ELSE
5736           g_qrs(i, k, 2) = g_qrs(i, k, 2) - dtcld*g_pracs(i, k)
5737           qrs(i, k, 2) = qrs(i, k, 2) - pracs(i, k)*dtcld
5738         END IF
5739         IF (qrs(i, k, 3) + pracs(i, k)*dtcld .LT. 0.) THEN
5740           g_qrs(i, k, 3) = 0.0_8
5741           qrs(i, k, 3) = 0.
5742         ELSE
5743           g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pracs(i, k)
5744           qrs(i, k, 3) = qrs(i, k, 3) + pracs(i, k)*dtcld
5745         END IF
5746         g_pracs(i, k) = 0.0_8
5747         pracs(i, k) = 0.
5748 !-------------------------------------------------------------
5749 ! psacr: Accretion of rain by snow [LFO 28]
5750 !         (T< T0: R->S or R->G)                 min=0.,max=qrs(i,k,1)/dtcld
5751 !         (T>=T0: S->R enhance melting of snow) min=0.,max=qrs(i,k,2)/dtcld
5752 !-------------------------------------------------------------
5753 !         supcol = t0c-t(i,k) !not change
5754 !         call smoothif(supcol,0.,fsupcol,'t0')
5755 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
5756 !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0')
5757 !update cpm
5758         g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k))
5759         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
5760         g_xlf = -g_xl(i, k)
5761         xlf = xls - xl(i, k)
5762         IF (supcol .LT. 0.) THEN
5763           xlf = xlf0
5764           g_xlf = 0.0_8
5765         END IF
5766         IF (qrs(i, k, 1) .LT. qcrmin) THEN
5767           max7 = qcrmin
5768           g_max7 = 0.0_8
5769         ELSE
5770           g_max7 = g_qrs(i, k, 1)
5771           max7 = qrs(i, k, 1)
5772         END IF
5773         pwy1 = (bvtr-2.)/4.
5774         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
5775 &           INT(pwy1))) THEN
5776           g_pwr1 = 0.0_8
5777         ELSE
5778           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
5779         END IF
5780         pwr1 = den(i, k)**pwy1
5781         pwy2 = bvtr/4.
5782         IF (max7 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
5783 &           pwy2))) THEN
5784           g_pwr2 = 0.0_8
5785         ELSE
5786           g_pwr2 = pwy2*max7**(pwy2-1)*g_max7
5787         END IF
5788         pwr2 = max7**pwy2
5789         g_vt2r = vt2r_a*(pwr2*g_pwr1+pwr1*g_pwr2)
5790         vt2r = vt2r_a*pwr1*pwr2
5791         IF (qrs(i, k, 2) .LT. qcrmin) THEN
5792           max8 = qcrmin
5793           g_max8 = 0.0_8
5794         ELSE
5795           g_max8 = g_qrs(i, k, 2)
5796           max8 = qrs(i, k, 2)
5797         END IF
5798         IF (90. .GT. t0c - t(i, k)) THEN
5799           g_y14 = -g_t(i, k)
5800           y14 = t0c - t(i, k)
5801         ELSE
5802           y14 = 90.
5803           g_y14 = 0.0_8
5804         END IF
5805         IF (0. .LT. y14) THEN
5806           g_max28 = g_y14
5807           max28 = y14
5808         ELSE
5809           max28 = 0.
5810           g_max28 = 0.0_8
5811         END IF
5812         pwy1 = (bvts-2.)/4.
5813         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
5814 &           INT(pwy1))) THEN
5815           g_pwr1 = 0.0_8
5816         ELSE
5817           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
5818         END IF
5819         pwr1 = den(i, k)**pwy1
5820         pwy2 = bvts/4.
5821         IF (max8 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
5822 &           pwy2))) THEN
5823           g_pwr2 = 0.0_8
5824         ELSE
5825           g_pwr2 = pwy2*max8**(pwy2-1)*g_max8
5826         END IF
5827         pwr2 = max8**pwy2
5828         g_arg1 = -(alpha*bvts*g_max28/4.)
5829         arg1 = -(alpha*bvts*max28/4.)
5830         temp0 = EXP(arg1)
5831         g_vt2s = vt2s_a*(temp0*(pwr2*g_pwr1+pwr1*g_pwr2)+pwr1*pwr2*EXP(&
5832 &         arg1)*g_arg1)
5833         vt2s = vt2s_a*(pwr1*pwr2*temp0)
5834         IF (90. .GT. t0c - t(i, k)) THEN
5835           g_y5 = -g_t(i, k)
5836           y5 = t0c - t(i, k)
5837         ELSE
5838           y5 = 90.
5839           g_y5 = 0.0_8
5840         END IF
5841         IF (0. .LT. y5) THEN
5842           g_max9 = g_y5
5843           max9 = y5
5844         ELSE
5845           max9 = 0.
5846           g_max9 = 0.0_8
5847         END IF
5848         g_a = EXP(alpha*max9)*alpha*g_max9
5849         a = EXP(alpha*max9)
5850         IF (90. .GT. t0c - t(i, k)) THEN
5851           g_y6 = -g_t(i, k)
5852           y6 = t0c - t(i, k)
5853         ELSE
5854           y6 = 90.
5855           g_y6 = 0.0_8
5856         END IF
5857         IF (0. .LT. y6) THEN
5858           g_max10 = g_y6
5859           max10 = y6
5860         ELSE
5861           max10 = 0.
5862           g_max10 = 0.0_8
5863         END IF
5864         IF (qrs(i, k, 1) .LT. qcrmin) THEN
5865           max29 = qcrmin
5866           g_max29 = 0.0_8
5867         ELSE
5868           g_max29 = g_qrs(i, k, 1)
5869           max29 = qrs(i, k, 1)
5870         END IF
5871         IF (qrs(i, k, 2) .LT. qcrmin) THEN
5872           max42 = qcrmin
5873           g_max42 = 0.0_8
5874         ELSE
5875           g_max42 = g_qrs(i, k, 2)
5876           max42 = qrs(i, k, 2)
5877         END IF
5878         g_arg1 = -(alpha*g_max10/4.)
5879         arg1 = -(alpha*max10/4.)
5880         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
5881 &           INT(3./4.))) THEN
5882           g_pwr1 = 0.0_8
5883         ELSE
5884           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
5885         END IF
5886         pwr1 = den(i, k)**(3./4.)
5887         IF (max29 .LE. 0.0_8 .AND. (3./2. .EQ. 0.0_8 .OR. 3./2. .NE. INT&
5888 &           (3./2.))) THEN
5889           g_pwr2 = 0.0_8
5890         ELSE
5891           g_pwr2 = 3.*max29**(3./2.-1)*g_max29/2.
5892         END IF
5893         pwr2 = max29**(3./2.)
5894         temp0 = SQRT(max42)
5895         IF (max42 .EQ. 0.0_8) THEN
5896           g_result1 = 0.0_8
5897         ELSE
5898           g_result1 = g_max42/(2.0*temp0)
5899         END IF
5900         result1 = temp0
5901         temp0 = SQRT(result1)
5902         IF (result1 .EQ. 0.0_8) THEN
5903           g_result2 = 0.0_8
5904         ELSE
5905           g_result2 = g_result1/(2.0*temp0)
5906         END IF
5907         result2 = temp0
5908         temp0 = pwr1*pwr2*result2
5909         temp = EXP(arg1)
5910         g_b = temp0*EXP(arg1)*g_arg1 + temp*(result2*(pwr2*g_pwr1+pwr1*&
5911 &         g_pwr2)+pwr1*pwr2*g_result2)
5912         b = temp*temp0
5913         IF (90. .GT. t0c - t(i, k)) THEN
5914           g_y7 = -g_t(i, k)
5915           y7 = t0c - t(i, k)
5916         ELSE
5917           y7 = 90.
5918           g_y7 = 0.0_8
5919         END IF
5920         IF (0. .LT. y7) THEN
5921           g_max11 = g_y7
5922           max11 = y7
5923         ELSE
5924           max11 = 0.
5925           g_max11 = 0.0_8
5926         END IF
5927         IF (qrs(i, k, 1) .LT. qcrmin) THEN
5928           max30 = qcrmin
5929           g_max30 = 0.0_8
5930         ELSE
5931           g_max30 = g_qrs(i, k, 1)
5932           max30 = qrs(i, k, 1)
5933         END IF
5934         IF (qrs(i, k, 2) .LT. qcrmin) THEN
5935           max43 = qcrmin
5936           g_max43 = 0.0_8
5937         ELSE
5938           g_max43 = g_qrs(i, k, 2)
5939           max43 = qrs(i, k, 2)
5940         END IF
5941         g_arg1 = -(alpha*g_max11/2.)
5942         arg1 = -(alpha*max11/2.)
5943         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
5944 &           INT(3./4.))) THEN
5945           g_pwr1 = 0.0_8
5946         ELSE
5947           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
5948         END IF
5949         pwr1 = den(i, k)**(3./4.)
5950         IF (max30 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT&
5951 &           (5./4.))) THEN
5952           g_pwr2 = 0.0_8
5953         ELSE
5954           g_pwr2 = 5.*max30**(5./4.-1)*g_max30/4.
5955         END IF
5956         pwr2 = max30**(5./4.)
5957         temp0 = SQRT(max43)
5958         IF (max43 .EQ. 0.0_8) THEN
5959           g_result1 = 0.0_8
5960         ELSE
5961           g_result1 = g_max43/(2.0*temp0)
5962         END IF
5963         result1 = temp0
5964         temp0 = pwr1*pwr2*result1
5965         temp = EXP(arg1)
5966         g_c = temp0*EXP(arg1)*g_arg1 + temp*(result1*(pwr2*g_pwr1+pwr1*&
5967 &         g_pwr2)+pwr1*pwr2*g_result1)
5968         c = temp*temp0
5969         IF (90. .GT. t0c - t(i, k)) THEN
5970           g_y8 = -g_t(i, k)
5971           y8 = t0c - t(i, k)
5972         ELSE
5973           y8 = 90.
5974           g_y8 = 0.0_8
5975         END IF
5976         IF (0. .LT. y8) THEN
5977           g_max12 = g_y8
5978           max12 = y8
5979         ELSE
5980           max12 = 0.
5981           g_max12 = 0.0_8
5982         END IF
5983         IF (qrs(i, k, 1) .LT. qcrmin) THEN
5984           max31 = qcrmin
5985           g_max31 = 0.0_8
5986         ELSE
5987           g_max31 = g_qrs(i, k, 1)
5988           max31 = qrs(i, k, 1)
5989         END IF
5990         IF (qrs(i, k, 2) .LT. qcrmin) THEN
5991           max44 = qcrmin
5992           g_max44 = 0.0_8
5993         ELSE
5994           g_max44 = g_qrs(i, k, 2)
5995           max44 = qrs(i, k, 2)
5996         END IF
5997         g_arg1 = -(alpha*3.*g_max12/4.)
5998         arg1 = -(3.*alpha*max12/4.)
5999         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
6000 &           INT(3./4.))) THEN
6001           g_pwr1 = 0.0_8
6002         ELSE
6003           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
6004         END IF
6005         pwr1 = den(i, k)**(3./4.)
6006         IF (max44 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT&
6007 &           (3./4.))) THEN
6008           g_pwr2 = 0.0_8
6009         ELSE
6010           g_pwr2 = 3.*max44**(3./4.-1)*g_max44/4.
6011         END IF
6012         pwr2 = max44**(3./4.)
6013         temp0 = pwr1*max31*pwr2
6014         temp = EXP(arg1)
6015         g_d = temp0*EXP(arg1)*g_arg1 + temp*(pwr2*(max31*g_pwr1+pwr1*&
6016 &         g_max31)+pwr1*max31*g_pwr2)
6017         d = temp*temp0
6018         IF (vt2r - vt2s .GE. 0.) THEN
6019           g_abs2 = g_vt2r - g_vt2s
6020           abs2 = vt2r - vt2s
6021         ELSE
6022           g_abs2 = g_vt2s - g_vt2r
6023           abs2 = -(vt2r-vt2s)
6024         END IF
6025         temp0 = psacr_b*b + psacr_c*c + psacr_d*d
6026         g_psacr1 = psacr_a*(temp0*(abs2*g_a+a*g_abs2)+a*abs2*(psacr_b*&
6027 &         g_b+psacr_c*g_c+psacr_d*g_d))
6028         psacr1 = psacr_a*(a*abs2*temp0)
6029         IF (supcol .GT. 0.) THEN
6030           IF (psacr1 .GT. qrs(i, k, 1)/dtcld) THEN
6031             g_psacr(i, k) = g_qrs(i, k, 1)/dtcld
6032             psacr(i, k) = qrs(i, k, 1)/dtcld
6033           ELSE
6034             g_psacr(i, k) = g_psacr1
6035             psacr(i, k) = psacr1
6036           END IF
6037         ELSE IF (psacr1 .GT. qrs(i, k, 2)/dtcld) THEN
6038           g_psacr(i, k) = g_qrs(i, k, 2)/dtcld
6039           psacr(i, k) = qrs(i, k, 2)/dtcld
6040         ELSE
6041           g_psacr(i, k) = g_psacr1
6042           psacr(i, k) = psacr1
6043         END IF
6044         IF (psacr(i, k) .GE. 0.) THEN
6045           abs3 = psacr(i, k)
6046         ELSE
6047           abs3 = -psacr(i, k)
6048         END IF
6049 !psacr(i,k)=fqr*fqs*psacr(i,k)
6050         IF (abs3 .LT. qmin/dtcld) THEN
6051           g_psacr(i, k) = 0.0_8
6052           psacr(i, k) = 0.
6053         END IF
6054 !update qr qs qg
6055         IF (qrs(i, k, 1) .LT. 1.e-4 .AND. qrs(i, k, 2) .LT. 1.e-4) THEN
6056           delta2 = 1.
6057         ELSE
6058           delta2 = 0.
6059         END IF
6060         IF (qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld .LT. 0.) THEN
6061           g_qrs(i, k, 1) = 0.0_8
6062           qrs(i, k, 1) = 0.
6063         ELSE
6064           g_qrs(i, k, 1) = g_qrs(i, k, 1) - dtcld*(psacr(i, k)*g_fsupcol&
6065 &           +fsupcol*g_psacr(i, k))
6066           qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld
6067         END IF
6068         g_x1 = g_qrs(i, k, 2) + delta2*dtcld*(psacr(i, k)*g_fsupcol+&
6069 &         fsupcol*g_psacr(i, k))
6070         x1 = qrs(i, k, 2) + fsupcol*delta2*psacr(i, k)*dtcld
6071         IF (x1 .LT. 0.) THEN
6072           g_qrs(i, k, 2) = 0.0_8
6073           qrs(i, k, 2) = 0.
6074         ELSE
6075           g_qrs(i, k, 2) = g_x1
6076           qrs(i, k, 2) = x1
6077         END IF
6078         g_x2 = g_qrs(i, k, 3) + (1-delta2)*dtcld*(psacr(i, k)*g_fsupcol+&
6079 &         fsupcol*g_psacr(i, k))
6080         x2 = qrs(i, k, 3) + fsupcol*(1-delta2)*psacr(i, k)*dtcld
6081         IF (x2 .LT. 0.) THEN
6082           g_qrs(i, k, 3) = 0.0_8
6083           qrs(i, k, 3) = 0.
6084         ELSE
6085           g_qrs(i, k, 3) = g_x2
6086           qrs(i, k, 3) = x2
6087         END IF
6088         temp0 = psacr(i, k)/cpm(i, k)
6089         g_t(i, k) = g_t(i, k) + dtcld*(temp0*(xlf*g_fsupcol+fsupcol*&
6090 &         g_xlf)+fsupcol*xlf*(g_psacr(i, k)-temp0*g_cpm(i, k))/cpm(i, k)&
6091 &         )
6092         t(i, k) = t(i, k) + dtcld*(fsupcol*xlf*temp0)
6093 ! t>=t0 pseml
6094         g_psacr(i, k) = (1-fsupcol)*g_psacr(i, k) - psacr(i, k)*&
6095 &         g_fsupcol
6096         psacr(i, k) = (1-fsupcol)*psacr(i, k)
6097 !-------------------------------------------------------------
6098 ! pgacr: Accretion of rain by graupel [LFO 42]
6099 !         (T< T0: R->G)                            min=0.,max=qrs(i,k,1)/dtcld
6100 !         (T>=T0: G->R enhance melting of graupel) min=0.,max=qrs(i,k,3)/dtcld
6101 !-------------------------------------------------------------
6102         g_supcol = -g_t(i, k)
6103         supcol = t0c - t(i, k)
6104         CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0')
6105 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
6106 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
6107 !update cpm
6108 !         cpm(i,k)=cpmcal(q(i,k)) !not change
6109         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
6110         g_xlf = -g_xl(i, k)
6111         xlf = xls - xl(i, k)
6112         IF (supcol .LT. 0.) THEN
6113           xlf = xlf0
6114           g_xlf = 0.0_8
6115         END IF
6116         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6117           max13 = qcrmin
6118           g_max13 = 0.0_8
6119         ELSE
6120           g_max13 = g_qrs(i, k, 1)
6121           max13 = qrs(i, k, 1)
6122         END IF
6123         pwy1 = (bvtr-2.)/4.
6124         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
6125 &           INT(pwy1))) THEN
6126           g_pwr1 = 0.0_8
6127         ELSE
6128           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
6129         END IF
6130         pwr1 = den(i, k)**pwy1
6131         pwy2 = bvtr/4.
6132         IF (max13 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
6133 &           pwy2))) THEN
6134           g_pwr2 = 0.0_8
6135         ELSE
6136           g_pwr2 = pwy2*max13**(pwy2-1)*g_max13
6137         END IF
6138         pwr2 = max13**pwy2
6139         g_vt2r = vt2r_a*(pwr2*g_pwr1+pwr1*g_pwr2)
6140         vt2r = vt2r_a*pwr1*pwr2
6141         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6142           max14 = qcrmin
6143           g_max14 = 0.0_8
6144         ELSE
6145           g_max14 = g_qrs(i, k, 3)
6146           max14 = qrs(i, k, 3)
6147         END IF
6148         pwy1 = (bvtg-2.)/4.
6149         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
6150 &           INT(pwy1))) THEN
6151           g_pwr1 = 0.0_8
6152         ELSE
6153           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
6154         END IF
6155         pwr1 = den(i, k)**pwy1
6156         pwy2 = bvtg/4.
6157         IF (max14 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
6158 &           pwy2))) THEN
6159           g_pwr2 = 0.0_8
6160         ELSE
6161           g_pwr2 = pwy2*max14**(pwy2-1)*g_max14
6162         END IF
6163         pwr2 = max14**pwy2
6164         g_vt2g = vt2g_a*(pwr2*g_pwr1+pwr1*g_pwr2)
6165         vt2g = vt2g_a*pwr1*pwr2
6166         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6167           max15 = qcrmin
6168           g_max15 = 0.0_8
6169         ELSE
6170           g_max15 = g_qrs(i, k, 1)
6171           max15 = qrs(i, k, 1)
6172         END IF
6173         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6174           max32 = qcrmin
6175           g_max32 = 0.0_8
6176         ELSE
6177           g_max32 = g_qrs(i, k, 3)
6178           max32 = qrs(i, k, 3)
6179         END IF
6180         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
6181 &           INT(3./4.))) THEN
6182           g_pwr1 = 0.0_8
6183         ELSE
6184           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
6185         END IF
6186         pwr1 = den(i, k)**(3./4.)
6187         IF (max15 .LE. 0.0_8 .AND. (3./2. .EQ. 0.0_8 .OR. 3./2. .NE. INT&
6188 &           (3./2.))) THEN
6189           g_pwr2 = 0.0_8
6190         ELSE
6191           g_pwr2 = 3.*max15**(3./2.-1)*g_max15/2.
6192         END IF
6193         pwr2 = max15**(3./2.)
6194         temp0 = SQRT(max32)
6195         IF (max32 .EQ. 0.0_8) THEN
6196           g_result1 = 0.0_8
6197         ELSE
6198           g_result1 = g_max32/(2.0*temp0)
6199         END IF
6200         result1 = temp0
6201         temp0 = SQRT(result1)
6202         IF (result1 .EQ. 0.0_8) THEN
6203           g_result2 = 0.0_8
6204         ELSE
6205           g_result2 = g_result1/(2.0*temp0)
6206         END IF
6207         result2 = temp0
6208         g_b = result2*(pwr2*g_pwr1+pwr1*g_pwr2) + pwr1*pwr2*g_result2
6209         b = pwr1*pwr2*result2
6210         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6211           max16 = qcrmin
6212           g_max16 = 0.0_8
6213         ELSE
6214           g_max16 = g_qrs(i, k, 1)
6215           max16 = qrs(i, k, 1)
6216         END IF
6217         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6218           max33 = qcrmin
6219           g_max33 = 0.0_8
6220         ELSE
6221           g_max33 = g_qrs(i, k, 3)
6222           max33 = qrs(i, k, 3)
6223         END IF
6224         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
6225 &           INT(3./4.))) THEN
6226           g_pwr1 = 0.0_8
6227         ELSE
6228           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
6229         END IF
6230         pwr1 = den(i, k)**(3./4.)
6231         IF (max16 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT&
6232 &           (5./4.))) THEN
6233           g_pwr2 = 0.0_8
6234         ELSE
6235           g_pwr2 = 5.*max16**(5./4.-1)*g_max16/4.
6236         END IF
6237         pwr2 = max16**(5./4.)
6238         temp0 = SQRT(max33)
6239         IF (max33 .EQ. 0.0_8) THEN
6240           g_result1 = 0.0_8
6241         ELSE
6242           g_result1 = g_max33/(2.0*temp0)
6243         END IF
6244         result1 = temp0
6245         g_c = result1*(pwr2*g_pwr1+pwr1*g_pwr2) + pwr1*pwr2*g_result1
6246         c = pwr1*pwr2*result1
6247         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6248           max17 = qcrmin
6249           g_max17 = 0.0_8
6250         ELSE
6251           g_max17 = g_qrs(i, k, 1)
6252           max17 = qrs(i, k, 1)
6253         END IF
6254         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6255           max34 = qcrmin
6256           g_max34 = 0.0_8
6257         ELSE
6258           g_max34 = g_qrs(i, k, 3)
6259           max34 = qrs(i, k, 3)
6260         END IF
6261         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
6262 &           INT(3./4.))) THEN
6263           g_pwr1 = 0.0_8
6264         ELSE
6265           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
6266         END IF
6267         pwr1 = den(i, k)**(3./4.)
6268         IF (max34 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT&
6269 &           (3./4.))) THEN
6270           g_pwr2 = 0.0_8
6271         ELSE
6272           g_pwr2 = 3.*max34**(3./4.-1)*g_max34/4.
6273         END IF
6274         pwr2 = max34**(3./4.)
6275         g_d = pwr2*(max17*g_pwr1+pwr1*g_max17) + pwr1*max17*g_pwr2
6276         d = pwr1*max17*pwr2
6277         IF (vt2r - vt2g .GE. 0.) THEN
6278           g_abs4 = g_vt2r - g_vt2g
6279           abs4 = vt2r - vt2g
6280         ELSE
6281           g_abs4 = g_vt2g - g_vt2r
6282           abs4 = -(vt2r-vt2g)
6283         END IF
6284         temp0 = pgacr_b*b + pgacr_c*c + pgacr_d*d
6285         g_pgacr1 = pgacr_a*(temp0*g_abs4+abs4*(pgacr_b*g_b+pgacr_c*g_c+&
6286 &         pgacr_d*g_d))
6287         pgacr1 = pgacr_a*(abs4*temp0)
6288         IF (supcol .GT. 0.) THEN
6289           IF (pgacr1 .GT. qrs(i, k, 1)/dtcld) THEN
6290             g_pgacr(i, k) = g_qrs(i, k, 1)/dtcld
6291             pgacr(i, k) = qrs(i, k, 1)/dtcld
6292           ELSE
6293             g_pgacr(i, k) = g_pgacr1
6294             pgacr(i, k) = pgacr1
6295           END IF
6296         ELSE IF (pgacr1 .GT. qrs(i, k, 3)/dtcld) THEN
6297           g_pgacr(i, k) = g_qrs(i, k, 3)/dtcld
6298           pgacr(i, k) = qrs(i, k, 3)/dtcld
6299         ELSE
6300           g_pgacr(i, k) = g_pgacr1
6301           pgacr(i, k) = pgacr1
6302         END IF
6303         IF (pgacr(i, k) .GE. 0.) THEN
6304           abs5 = pgacr(i, k)
6305         ELSE
6306           abs5 = -pgacr(i, k)
6307         END IF
6308 !pgacr(i,k)=fqg*fqr*pgacr(i,k)
6309         IF (abs5 .LT. qmin/dtcld) THEN
6310           g_pgacr(i, k) = 0.0_8
6311           pgacr(i, k) = 0.
6312         END IF
6313         IF (qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld .LT. 0.) THEN
6314           g_qrs(i, k, 1) = 0.0_8
6315           qrs(i, k, 1) = 0.
6316         ELSE
6317           g_qrs(i, k, 1) = g_qrs(i, k, 1) - dtcld*(pgacr(i, k)*g_fsupcol&
6318 &           +fsupcol*g_pgacr(i, k))
6319           qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld
6320         END IF
6321         g_x3 = g_qrs(i, k, 3) + dtcld*(pgacr(i, k)*g_fsupcol+fsupcol*&
6322 &         g_pgacr(i, k))
6323         x3 = qrs(i, k, 3) + fsupcol*pgacr(i, k)*dtcld
6324         IF (x3 .LT. 0.) THEN
6325           g_qrs(i, k, 3) = 0.0_8
6326           qrs(i, k, 3) = 0.
6327         ELSE
6328           g_qrs(i, k, 3) = g_x3
6329           qrs(i, k, 3) = x3
6330         END IF
6331         temp0 = pgacr(i, k)/cpm(i, k)
6332         g_t(i, k) = g_t(i, k) + dtcld*(temp0*(xlf*g_fsupcol+fsupcol*&
6333 &         g_xlf)+fsupcol*xlf*(g_pgacr(i, k)-temp0*g_cpm(i, k))/cpm(i, k)&
6334 &         )
6335         t(i, k) = t(i, k) + dtcld*(fsupcol*xlf*temp0)
6336 ! t>=t0 pgeml
6337         g_pgacr(i, k) = (1-fsupcol)*g_pgacr(i, k) - pgacr(i, k)*&
6338 &         g_fsupcol
6339         pgacr(i, k) = (1-fsupcol)*pgacr(i, k)
6340 !-------------------------------------------------------------
6341 ! pgacs: Accretion of snow by graupel [LFO 29]
6342 !        (S->G) min=0,max=qrs(i,k,2)/dtcld
6343 !-------------------------------------------------------------
6344         g_supcol = -g_t(i, k)
6345         supcol = t0c - t(i, k)
6346         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
6347         g_x4 = -(EXP(-(0.09*supcol))*0.09*g_supcol)
6348         x4 = EXP(-(0.09*supcol))
6349         IF (x4 .GT. 1.) THEN
6350           egs = 1.
6351           g_egs = 0.0_8
6352         ELSE
6353           g_egs = g_x4
6354           egs = x4
6355         END IF
6356         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6357           max18 = qcrmin
6358           g_max18 = 0.0_8
6359         ELSE
6360           g_max18 = g_qrs(i, k, 3)
6361           max18 = qrs(i, k, 3)
6362         END IF
6363         pwy1 = (bvtg-2.)/4.
6364         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
6365 &           INT(pwy1))) THEN
6366           g_pwr1 = 0.0_8
6367         ELSE
6368           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
6369         END IF
6370         pwr1 = den(i, k)**pwy1
6371         pwy2 = bvtg/4.
6372         IF (max18 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
6373 &           pwy2))) THEN
6374           g_pwr2 = 0.0_8
6375         ELSE
6376           g_pwr2 = pwy2*max18**(pwy2-1)*g_max18
6377         END IF
6378         pwr2 = max18**pwy2
6379         g_vt2g = vt2g_a*(pwr2*g_pwr1+pwr1*g_pwr2)
6380         vt2g = vt2g_a*pwr1*pwr2
6381         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6382           max19 = qcrmin
6383           g_max19 = 0.0_8
6384         ELSE
6385           g_max19 = g_qrs(i, k, 2)
6386           max19 = qrs(i, k, 2)
6387         END IF
6388         IF (90. .GT. t0c - t(i, k)) THEN
6389           g_y15 = -g_t(i, k)
6390           y15 = t0c - t(i, k)
6391         ELSE
6392           y15 = 90.
6393           g_y15 = 0.0_8
6394         END IF
6395         IF (0. .LT. y15) THEN
6396           g_max35 = g_y15
6397           max35 = y15
6398         ELSE
6399           max35 = 0.
6400           g_max35 = 0.0_8
6401         END IF
6402         pwy1 = (bvts-2.)/4.
6403         IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. &
6404 &           INT(pwy1))) THEN
6405           g_pwr1 = 0.0_8
6406         ELSE
6407           g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k)
6408         END IF
6409         pwr1 = den(i, k)**pwy1
6410         pwy2 = bvts/4.
6411         IF (max19 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(&
6412 &           pwy2))) THEN
6413           g_pwr2 = 0.0_8
6414         ELSE
6415           g_pwr2 = pwy2*max19**(pwy2-1)*g_max19
6416         END IF
6417         pwr2 = max19**pwy2
6418         g_arg1 = -(alpha*bvts*g_max35/4.)
6419         arg1 = -(alpha*bvts*max35/4.)
6420         temp0 = EXP(arg1)
6421         g_vt2s = vt2s_a*(temp0*(pwr2*g_pwr1+pwr1*g_pwr2)+pwr1*pwr2*EXP(&
6422 &         arg1)*g_arg1)
6423         vt2s = vt2s_a*(pwr1*pwr2*temp0)
6424         IF (90. .GT. t0c - t(i, k)) THEN
6425           g_y9 = -g_t(i, k)
6426           y9 = t0c - t(i, k)
6427         ELSE
6428           y9 = 90.
6429           g_y9 = 0.0_8
6430         END IF
6431         IF (0. .LT. y9) THEN
6432           g_max20 = g_y9
6433           max20 = y9
6434         ELSE
6435           max20 = 0.
6436           g_max20 = 0.0_8
6437         END IF
6438         g_a = EXP(alpha*max20)*alpha*g_max20
6439         a = EXP(alpha*max20)
6440         IF (90. .GT. t0c - t(i, k)) THEN
6441           g_y10 = -g_t(i, k)
6442           y10 = t0c - t(i, k)
6443         ELSE
6444           y10 = 90.
6445           g_y10 = 0.0_8
6446         END IF
6447         IF (0. .LT. y10) THEN
6448           g_max21 = g_y10
6449           max21 = y10
6450         ELSE
6451           max21 = 0.
6452           g_max21 = 0.0_8
6453         END IF
6454         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6455           max36 = qcrmin
6456           g_max36 = 0.0_8
6457         ELSE
6458           g_max36 = g_qrs(i, k, 2)
6459           max36 = qrs(i, k, 2)
6460         END IF
6461         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6462           max45 = qcrmin
6463           g_max45 = 0.0_8
6464         ELSE
6465           g_max45 = g_qrs(i, k, 3)
6466           max45 = qrs(i, k, 3)
6467         END IF
6468         g_arg1 = -(alpha*3.*g_max21/2.)
6469         arg1 = -(3.*alpha*max21/2.)
6470         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
6471 &           INT(3./4.))) THEN
6472           g_pwr1 = 0.0_8
6473         ELSE
6474           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
6475         END IF
6476         pwr1 = den(i, k)**(3./4.)
6477         IF (max36 .LE. 0.0_8 .AND. (3./2. .EQ. 0.0_8 .OR. 3./2. .NE. INT&
6478 &           (3./2.))) THEN
6479           g_pwr2 = 0.0_8
6480         ELSE
6481           g_pwr2 = 3.*max36**(3./2.-1)*g_max36/2.
6482         END IF
6483         pwr2 = max36**(3./2.)
6484         temp0 = SQRT(max45)
6485         IF (max45 .EQ. 0.0_8) THEN
6486           g_result1 = 0.0_8
6487         ELSE
6488           g_result1 = g_max45/(2.0*temp0)
6489         END IF
6490         result1 = temp0
6491         temp0 = SQRT(result1)
6492         IF (result1 .EQ. 0.0_8) THEN
6493           g_result2 = 0.0_8
6494         ELSE
6495           g_result2 = g_result1/(2.0*temp0)
6496         END IF
6497         result2 = temp0
6498         temp0 = pwr1*pwr2*result2
6499         temp = EXP(arg1)
6500         g_b = temp0*EXP(arg1)*g_arg1 + temp*(result2*(pwr2*g_pwr1+pwr1*&
6501 &         g_pwr2)+pwr1*pwr2*g_result2)
6502         b = temp*temp0
6503         IF (90. .GT. t0c - t(i, k)) THEN
6504           g_y11 = -g_t(i, k)
6505           y11 = t0c - t(i, k)
6506         ELSE
6507           y11 = 90.
6508           g_y11 = 0.0_8
6509         END IF
6510         IF (0. .LT. y11) THEN
6511           g_max22 = g_y11
6512           max22 = y11
6513         ELSE
6514           max22 = 0.
6515           g_max22 = 0.0_8
6516         END IF
6517         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6518           max37 = qcrmin
6519           g_max37 = 0.0_8
6520         ELSE
6521           g_max37 = g_qrs(i, k, 2)
6522           max37 = qrs(i, k, 2)
6523         END IF
6524         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6525           max46 = qcrmin
6526           g_max46 = 0.0_8
6527         ELSE
6528           g_max46 = g_qrs(i, k, 3)
6529           max46 = qrs(i, k, 3)
6530         END IF
6531         g_arg1 = -(alpha*5.*g_max22/4.)
6532         arg1 = -(5.*alpha*max22/4.)
6533         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
6534 &           INT(3./4.))) THEN
6535           g_pwr1 = 0.0_8
6536         ELSE
6537           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
6538         END IF
6539         pwr1 = den(i, k)**(3./4.)
6540         IF (max37 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT&
6541 &           (5./4.))) THEN
6542           g_pwr2 = 0.0_8
6543         ELSE
6544           g_pwr2 = 5.*max37**(5./4.-1)*g_max37/4.
6545         END IF
6546         pwr2 = max37**(5./4.)
6547         temp0 = SQRT(max46)
6548         IF (max46 .EQ. 0.0_8) THEN
6549           g_result1 = 0.0_8
6550         ELSE
6551           g_result1 = g_max46/(2.0*temp0)
6552         END IF
6553         result1 = temp0
6554         temp0 = pwr1*pwr2*result1
6555         temp = EXP(arg1)
6556         g_c = temp0*EXP(arg1)*g_arg1 + temp*(result1*(pwr2*g_pwr1+pwr1*&
6557 &         g_pwr2)+pwr1*pwr2*g_result1)
6558         c = temp*temp0
6559         IF (90. .GT. t0c - t(i, k)) THEN
6560           g_y12 = -g_t(i, k)
6561           y12 = t0c - t(i, k)
6562         ELSE
6563           y12 = 90.
6564           g_y12 = 0.0_8
6565         END IF
6566         IF (0. .LT. y12) THEN
6567           g_max23 = g_y12
6568           max23 = y12
6569         ELSE
6570           max23 = 0.
6571           g_max23 = 0.0_8
6572         END IF
6573         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6574           max38 = qcrmin
6575           g_max38 = 0.0_8
6576         ELSE
6577           g_max38 = g_qrs(i, k, 2)
6578           max38 = qrs(i, k, 2)
6579         END IF
6580         IF (qrs(i, k, 3) .LT. qcrmin) THEN
6581           max47 = qcrmin
6582           g_max47 = 0.0_8
6583         ELSE
6584           g_max47 = g_qrs(i, k, 3)
6585           max47 = qrs(i, k, 3)
6586         END IF
6587         IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.&
6588 &           INT(3./4.))) THEN
6589           g_pwr1 = 0.0_8
6590         ELSE
6591           g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4.
6592         END IF
6593         pwr1 = den(i, k)**(3./4.)
6594         IF (max47 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT&
6595 &           (3./4.))) THEN
6596           g_pwr2 = 0.0_8
6597         ELSE
6598           g_pwr2 = 3.*max47**(3./4.-1)*g_max47/4.
6599         END IF
6600         pwr2 = max47**(3./4.)
6601         temp0 = pwr1*max38*pwr2
6602         temp = EXP(-(alpha*max23))
6603         g_d = temp*(pwr2*(max38*g_pwr1+pwr1*g_max38)+pwr1*max38*g_pwr2) &
6604 &         - temp0*EXP(-(alpha*max23))*alpha*g_max23
6605         d = temp*temp0
6606         IF (vt2g - vt2s .GE. 0.) THEN
6607           g_abs6 = g_vt2g - g_vt2s
6608           abs6 = vt2g - vt2s
6609         ELSE
6610           g_abs6 = g_vt2s - g_vt2g
6611           abs6 = -(vt2g-vt2s)
6612         END IF
6613         temp0 = pgacs_b*b + pgacs_c*c + pgacs_d*d
6614         temp = a*abs6*egs
6615         g_pgacs1 = pgacs_a*(temp0*(egs*(abs6*g_a+a*g_abs6)+a*abs6*g_egs)&
6616 &         +temp*(pgacs_b*g_b+pgacs_c*g_c+pgacs_d*g_d))
6617         pgacs1 = pgacs_a*(temp*temp0)
6618         IF (pgacs1 .GT. qrs(i, k, 2)/dtcld) THEN
6619           g_pgacs(i, k) = g_qrs(i, k, 2)/dtcld
6620           pgacs(i, k) = qrs(i, k, 2)/dtcld
6621         ELSE
6622           g_pgacs(i, k) = g_pgacs1
6623           pgacs(i, k) = pgacs1
6624         END IF
6625         IF (pgacs(i, k) .GE. 0.) THEN
6626           abs7 = pgacs(i, k)
6627         ELSE
6628           abs7 = -pgacs(i, k)
6629         END IF
6630 !pgacs(i,k)=fqg*fqs*pgacs(i,k)
6631         IF (abs7 .LT. qmin/dtcld) THEN
6632           g_pgacs(i, k) = 0.0_8
6633           pgacs(i, k) = 0.
6634         END IF
6635         IF (qrs(i, k, 2) - pgacs(i, k)*dtcld .LT. 0.) THEN
6636           g_qrs(i, k, 2) = 0.0_8
6637           qrs(i, k, 2) = 0.
6638         ELSE
6639           g_qrs(i, k, 2) = g_qrs(i, k, 2) - dtcld*g_pgacs(i, k)
6640           qrs(i, k, 2) = qrs(i, k, 2) - pgacs(i, k)*dtcld
6641         END IF
6642         IF (qrs(i, k, 3) + pgacs(i, k)*dtcld .LT. 0.) THEN
6643           g_qrs(i, k, 3) = 0.0_8
6644           qrs(i, k, 3) = 0.
6645         ELSE
6646           g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgacs(i, k)
6647           qrs(i, k, 3) = qrs(i, k, 3) + pgacs(i, k)*dtcld
6648         END IF
6649         g_pgacs(i, k) = 0.0_8
6650         pgacs(i, k) = 0.
6651 !-------------------------------------------------------------
6652 ! pseml: Enhanced melting of snow by accretion of water
6653 !        (T>=T0: S->R) pseml<0 max=0,min=-qrs(i,k,2)/dtcld
6654 !-------------------------------------------------------------
6655 !         supcol = t0c-t(i,k) ! not change
6656 !update cpm
6657 !         cpm(i,k)=cpmcal(q(i,k)) ! not change
6658         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
6659         g_xlf = -g_xl(i, k)
6660         xlf = xls - xl(i, k)
6661         IF (supcol .LT. 0.) THEN
6662           xlf = xlf0
6663           g_xlf = 0.0_8
6664         END IF
6665         CALL G_SMOOTHIF(t(i, k), g_t(i, k), t0c, ft0, g_ft0, 't0')
6666         CALL G_SMOOTHIF(qrs(i, k, 2), g_qrs(i, k, 2), 0., fqs, g_fqs, &
6667 &                 'q+')
6668         temp0 = supcol/xlf
6669         temp = psacw(i, k) + psacr(i, k)
6670         g_x7 = cliq*(temp0*(g_psacw(i, k)+g_psacr(i, k))+temp*(g_supcol-&
6671 &         temp0*g_xlf)/xlf)
6672         x7 = cliq*(temp*temp0)
6673         IF (x7 .LT. -(qrs(i, k, 2)/dtcld)) THEN
6674           g_x5 = -(g_qrs(i, k, 2)/dtcld)
6675           x5 = -(qrs(i, k, 2)/dtcld)
6676         ELSE
6677           g_x5 = g_x7
6678           x5 = x7
6679         END IF
6680         IF (x5 .GT. 0.) THEN
6681           g_pseml(i, k) = 0.0_8
6682           pseml(i, k) = 0.
6683         ELSE
6684           g_pseml(i, k) = g_x5
6685           pseml(i, k) = x5
6686         END IF
6687         g_pseml(i, k) = pseml(i, k)*(fqs*g_ft0+ft0*g_fqs) + ft0*fqs*&
6688 &         g_pseml(i, k)
6689         pseml(i, k) = ft0*fqs*pseml(i, k)
6690         IF (pseml(i, k) .GE. 0.) THEN
6691           abs8 = pseml(i, k)
6692         ELSE
6693           abs8 = -pseml(i, k)
6694         END IF
6695         IF (abs8 .LT. qmin/dtcld) THEN
6696           g_pseml(i, k) = 0.0_8
6697           pseml(i, k) = 0.
6698         END IF
6699         IF (qrs(i, k, 1) - pseml(i, k)*dtcld .LT. 0.) THEN
6700           g_qrs(i, k, 1) = 0.0_8
6701           qrs(i, k, 1) = 0.
6702         ELSE
6703           g_qrs(i, k, 1) = g_qrs(i, k, 1) - dtcld*g_pseml(i, k)
6704           qrs(i, k, 1) = qrs(i, k, 1) - pseml(i, k)*dtcld
6705         END IF
6706         IF (qrs(i, k, 2) + pseml(i, k)*dtcld .LT. 0.) THEN
6707           g_qrs(i, k, 2) = 0.0_8
6708           qrs(i, k, 2) = 0.
6709         ELSE
6710           g_qrs(i, k, 2) = g_qrs(i, k, 2) + dtcld*g_pseml(i, k)
6711           qrs(i, k, 2) = qrs(i, k, 2) + pseml(i, k)*dtcld
6712         END IF
6713         temp0 = pseml(i, k)*xlf/cpm(i, k)
6714         g_t(i, k) = g_t(i, k) + dtcld*(xlf*g_pseml(i, k)+pseml(i, k)*&
6715 &         g_xlf-temp0*g_cpm(i, k))/cpm(i, k)
6716         t(i, k) = t(i, k) + dtcld*temp0
6717         g_pseml(i, k) = 0.0_8
6718         pseml(i, k) = 0.
6719         g_psacw(i, k) = 0.0_8
6720         psacw(i, k) = 0.
6721         g_psacr(i, k) = 0.0_8
6722         psacr(i, k) = 0.
6723 !-------------------------------------------------------------
6724 ! pgeml: Enhanced melting of graupel by accretion of water [RH84 A21-A22]
6725 !        (T>=T0: G->R) pgeml<0 max=0,min=-qrs(i,k,3)/dtcld
6726 !-------------------------------------------------------------
6727         g_supcol = -g_t(i, k)
6728         supcol = t0c - t(i, k)
6729 !update cpm
6730 !         cpm(i,k)=cpmcal(q(i,k)) ! not change
6731         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
6732         g_xlf = -g_xl(i, k)
6733         xlf = xls - xl(i, k)
6734         IF (supcol .LT. 0.) THEN
6735           xlf = xlf0
6736           g_xlf = 0.0_8
6737         END IF
6738         CALL G_SMOOTHIF(t(i, k), g_t(i, k), t0c, ft0, g_ft0, 't0')
6739         CALL G_SMOOTHIF(qrs(i, k, 3), g_qrs(i, k, 3), 0., fqg, g_fqg, &
6740 &                 'q+')
6741         temp0 = supcol/xlf
6742         temp = pgacw(i, k) + pgacr(i, k)
6743         g_x8 = cliq*(temp0*(g_pgacw(i, k)+g_pgacr(i, k))+temp*(g_supcol-&
6744 &         temp0*g_xlf)/xlf)
6745         x8 = cliq*(temp*temp0)
6746         IF (x8 .LT. -(qrs(i, k, 3)/dtcld)) THEN
6747           g_x6 = -(g_qrs(i, k, 3)/dtcld)
6748           x6 = -(qrs(i, k, 3)/dtcld)
6749         ELSE
6750           g_x6 = g_x8
6751           x6 = x8
6752         END IF
6753         IF (x6 .GT. 0.) THEN
6754           g_pgeml(i, k) = 0.0_8
6755           pgeml(i, k) = 0.
6756         ELSE
6757           g_pgeml(i, k) = g_x6
6758           pgeml(i, k) = x6
6759         END IF
6760         g_pgeml(i, k) = pgeml(i, k)*(fqg*g_ft0+ft0*g_fqg) + ft0*fqg*&
6761 &         g_pgeml(i, k)
6762         pgeml(i, k) = ft0*fqg*pgeml(i, k)
6763         IF (pgeml(i, k) .GE. 0.) THEN
6764           abs9 = pgeml(i, k)
6765         ELSE
6766           abs9 = -pgeml(i, k)
6767         END IF
6768         IF (abs9 .LT. qmin/dtcld) THEN
6769           g_pgeml(i, k) = 0.0_8
6770           pgeml(i, k) = 0.
6771         END IF
6772         IF (qrs(i, k, 1) - pgeml(i, k)*dtcld .LT. 0.) THEN
6773           g_qrs(i, k, 1) = 0.0_8
6774           qrs(i, k, 1) = 0.
6775         ELSE
6776           g_qrs(i, k, 1) = g_qrs(i, k, 1) - dtcld*g_pgeml(i, k)
6777           qrs(i, k, 1) = qrs(i, k, 1) - pgeml(i, k)*dtcld
6778         END IF
6779         IF (qrs(i, k, 3) + pgeml(i, k)*dtcld .LT. 0.) THEN
6780           g_qrs(i, k, 3) = 0.0_8
6781           qrs(i, k, 3) = 0.
6782         ELSE
6783           g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgeml(i, k)
6784           qrs(i, k, 3) = qrs(i, k, 3) + pgeml(i, k)*dtcld
6785         END IF
6786         temp0 = pgeml(i, k)*xlf/cpm(i, k)
6787         g_t(i, k) = g_t(i, k) + dtcld*(xlf*g_pgeml(i, k)+pgeml(i, k)*&
6788 &         g_xlf-temp0*g_cpm(i, k))/cpm(i, k)
6789         t(i, k) = t(i, k) + dtcld*temp0
6790         g_pgeml(i, k) = 0.0_8
6791         pgeml(i, k) = 0.
6792         g_pgacw(i, k) = 0.0_8
6793         pgacw(i, k) = 0.
6794         g_pgacr(i, k) = 0.0_8
6795         pgacr(i, k) = 0.
6796       END DO
6797     END DO
6798   END SUBROUTINE G_ACCRET2
6799
6800 !=======================================================================
6801 !
6802 !=======================================================================
6803   SUBROUTINE ACCRET2(qrs, t, q, den, dtcld, psacw, pgacw, pracs, psacr, &
6804 &   pgacr, pgacs, pseml, pgeml, ims, ime, kms, kme, its, ite, kts, kte)
6805     IMPLICIT NONE
6806     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
6807 !-------------------------------------------------------------------
6808     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs
6809     REAL, DIMENSION(ims:ime, kms:kme) :: den, q
6810     REAL, DIMENSION(its:ite, kts:kte) :: psacw, pgacw, pracs, psacr, &
6811 &   pgacr, pgacs, pseml, pgeml, t, xl, cpm
6812     REAL :: supcol, vt2r, vt2s, vt2g, dtcld, xlf, egs
6813     REAL :: acrfac1, acrfac2, acrfac3, acrfac4, pracs1, psacr1, pgacr1, &
6814 &   pgacs1
6815     INTEGER :: i, k
6816     REAL :: fsupcol, ft0, fqr, fqs, fqg, temp1, delta2, a, b, c, d
6817     INTRINSIC MAX
6818     INTRINSIC MIN
6819     INTRINSIC EXP
6820     INTRINSIC SQRT
6821     INTRINSIC ABS
6822     REAL :: y1
6823     REAL :: y2
6824     REAL :: y3
6825     REAL :: y4
6826     REAL :: y5
6827     REAL :: y6
6828     REAL :: y7
6829     REAL :: y8
6830     REAL :: x1
6831     REAL :: x2
6832     REAL :: x3
6833     REAL :: x4
6834     REAL :: y9
6835     REAL :: y10
6836     REAL :: y11
6837     REAL :: y12
6838     REAL :: x5
6839     REAL :: x6
6840     REAL :: y13
6841     REAL :: y14
6842     REAL :: y15
6843     REAL :: x7
6844     REAL :: x8
6845     REAL :: max1
6846     REAL :: max2
6847     REAL :: max3
6848     REAL :: max4
6849     REAL :: max5
6850     REAL :: max6
6851     REAL :: abs0
6852     REAL :: abs1
6853     REAL :: max7
6854     REAL :: max8
6855     REAL :: max9
6856     REAL :: max10
6857     REAL :: max11
6858     REAL :: max12
6859     REAL :: abs2
6860     REAL :: abs3
6861     REAL :: max13
6862     REAL :: max14
6863     REAL :: max15
6864     REAL :: max16
6865     REAL :: max17
6866     REAL :: abs4
6867     REAL :: abs5
6868     REAL :: max18
6869     REAL :: max19
6870     REAL :: max20
6871     REAL :: max21
6872     REAL :: max22
6873     REAL :: max23
6874     REAL :: abs6
6875     REAL :: abs7
6876     REAL :: abs8
6877     REAL :: abs9
6878     REAL :: max24
6879     REAL :: max25
6880     REAL :: max26
6881     REAL :: max27
6882     REAL :: max28
6883     REAL :: max29
6884     REAL :: max30
6885     REAL :: max31
6886     REAL :: max32
6887     REAL :: max33
6888     REAL :: max34
6889     REAL :: max35
6890     REAL :: max36
6891     REAL :: max37
6892     REAL :: max38
6893     REAL :: max39
6894     REAL :: max40
6895     REAL :: max41
6896     REAL :: max42
6897     REAL :: max43
6898     REAL :: max44
6899     REAL :: max45
6900     REAL :: max46
6901     REAL :: max47
6902     REAL :: pwy1
6903     REAL :: pwr1
6904     REAL :: pwy2
6905     REAL :: pwr2
6906     REAL :: arg1
6907     REAL :: result1
6908     REAL :: result2
6909     DO k=kts,kte
6910       DO i=its,ite
6911 !-------------------------------------------------------------
6912 ! pracs: Accretion of snow by rain [LFO 27]
6913 !         (T<T0: S->G) pracs: min=0., max=qrs(i,k,2)/dtcld
6914 !-------------------------------------------------------------
6915         supcol = t0c - t(i, k)
6916         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
6917         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6918           max1 = qcrmin
6919         ELSE
6920           max1 = qrs(i, k, 1)
6921         END IF
6922 !call smoothif(qrs(i,k,1),1.e-4,fqr,'q0')
6923 !call smoothif(qrs(i,k,2),1.e-4,fqs,'q0')
6924         pwy1 = (bvtr-2.)/4.
6925         pwr1 = den(i, k)**pwy1
6926         pwy2 = bvtr/4.
6927         pwr2 = max1**pwy2
6928         vt2r = vt2r_a*pwr1*pwr2
6929         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6930           max2 = qcrmin
6931         ELSE
6932           max2 = qrs(i, k, 2)
6933         END IF
6934         IF (90. .GT. t0c - t(i, k)) THEN
6935           y13 = t0c - t(i, k)
6936         ELSE
6937           y13 = 90.
6938         END IF
6939         IF (0. .LT. y13) THEN
6940           max24 = y13
6941         ELSE
6942           max24 = 0.
6943         END IF
6944         pwy1 = (bvts-2.)/4.
6945         pwr1 = den(i, k)**pwy1
6946         pwy2 = bvts/4.
6947         pwr2 = max2**pwy2
6948         arg1 = -(alpha*bvts*max24/4.)
6949         vt2s = vt2s_a*pwr1*pwr2*EXP(arg1)
6950         IF (90. .GT. t0c - t(i, k)) THEN
6951           y1 = t0c - t(i, k)
6952         ELSE
6953           y1 = 90.
6954         END IF
6955         IF (0. .LT. y1) THEN
6956           max3 = y1
6957         ELSE
6958           max3 = 0.
6959         END IF
6960         a = EXP(alpha*max3)
6961         IF (90. .GT. t0c - t(i, k)) THEN
6962           y2 = t0c - t(i, k)
6963         ELSE
6964           y2 = 90.
6965         END IF
6966         IF (0. .LT. y2) THEN
6967           max4 = y2
6968         ELSE
6969           max4 = 0.
6970         END IF
6971         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6972           max25 = qcrmin
6973         ELSE
6974           max25 = qrs(i, k, 2)
6975         END IF
6976         IF (qrs(i, k, 1) .LT. qcrmin) THEN
6977           max39 = qcrmin
6978         ELSE
6979           max39 = qrs(i, k, 1)
6980         END IF
6981         arg1 = -(3.*alpha*max4/2.)
6982         pwr1 = den(i, k)**(3./4.)
6983         pwr2 = max25**(3./2.)
6984         result1 = SQRT(max39)
6985         result2 = SQRT(result1)
6986         b = EXP(arg1)*pwr1*pwr2*result2
6987         IF (90. .GT. t0c - t(i, k)) THEN
6988           y3 = t0c - t(i, k)
6989         ELSE
6990           y3 = 90.
6991         END IF
6992         IF (0. .LT. y3) THEN
6993           max5 = y3
6994         ELSE
6995           max5 = 0.
6996         END IF
6997         IF (qrs(i, k, 2) .LT. qcrmin) THEN
6998           max26 = qcrmin
6999         ELSE
7000           max26 = qrs(i, k, 2)
7001         END IF
7002         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7003           max40 = qcrmin
7004         ELSE
7005           max40 = qrs(i, k, 1)
7006         END IF
7007         arg1 = -(5.*alpha*max5/4.)
7008         pwr1 = den(i, k)**(3./4.)
7009         pwr2 = max26**(5./4.)
7010         result1 = SQRT(max40)
7011         c = EXP(arg1)*pwr1*pwr2*result1
7012         IF (90. .GT. t0c - t(i, k)) THEN
7013           y4 = t0c - t(i, k)
7014         ELSE
7015           y4 = 90.
7016         END IF
7017         IF (0. .LT. y4) THEN
7018           max6 = y4
7019         ELSE
7020           max6 = 0.
7021         END IF
7022         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7023           max27 = qcrmin
7024         ELSE
7025           max27 = qrs(i, k, 2)
7026         END IF
7027         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7028           max41 = qcrmin
7029         ELSE
7030           max41 = qrs(i, k, 1)
7031         END IF
7032         pwr1 = den(i, k)**(3./4.)
7033         pwr2 = max41**(3./4.)
7034         d = EXP(-(alpha*max6))*pwr1*max27*pwr2
7035         IF (vt2r - vt2s .GE. 0.) THEN
7036           abs0 = vt2r - vt2s
7037         ELSE
7038           abs0 = -(vt2r-vt2s)
7039         END IF
7040         pracs1 = pracs_a*a*abs0*(pracs_b*b+pracs_c*c+pracs_d*d)
7041         IF (pracs1 .GT. qrs(i, k, 2)/dtcld) THEN
7042           pracs(i, k) = qrs(i, k, 2)/dtcld
7043         ELSE
7044           pracs(i, k) = pracs1
7045         END IF
7046         pracs(i, k) = fsupcol*pracs(i, k)
7047         IF (pracs(i, k) .GE. 0.) THEN
7048           abs1 = pracs(i, k)
7049         ELSE
7050           abs1 = -pracs(i, k)
7051         END IF
7052         IF (abs1 .LT. qmin/dtcld) pracs(i, k) = 0.
7053         IF (qrs(i, k, 2) - pracs(i, k)*dtcld .LT. 0.) THEN
7054           qrs(i, k, 2) = 0.
7055         ELSE
7056           qrs(i, k, 2) = qrs(i, k, 2) - pracs(i, k)*dtcld
7057         END IF
7058         IF (qrs(i, k, 3) + pracs(i, k)*dtcld .LT. 0.) THEN
7059           qrs(i, k, 3) = 0.
7060         ELSE
7061           qrs(i, k, 3) = qrs(i, k, 3) + pracs(i, k)*dtcld
7062         END IF
7063         pracs(i, k) = 0.
7064 !-------------------------------------------------------------
7065 ! psacr: Accretion of rain by snow [LFO 28]
7066 !         (T< T0: R->S or R->G)                 min=0.,max=qrs(i,k,1)/dtcld
7067 !         (T>=T0: S->R enhance melting of snow) min=0.,max=qrs(i,k,2)/dtcld
7068 !-------------------------------------------------------------
7069 !         supcol = t0c-t(i,k) !not change
7070 !         call smoothif(supcol,0.,fsupcol,'t0')
7071 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
7072 !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0')
7073 !update cpm
7074         cpm(i, k) = CPMCAL(q(i, k))
7075         xl(i, k) = XLCAL(t(i, k))
7076         xlf = xls - xl(i, k)
7077         IF (supcol .LT. 0.) xlf = xlf0
7078         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7079           max7 = qcrmin
7080         ELSE
7081           max7 = qrs(i, k, 1)
7082         END IF
7083         pwy1 = (bvtr-2.)/4.
7084         pwr1 = den(i, k)**pwy1
7085         pwy2 = bvtr/4.
7086         pwr2 = max7**pwy2
7087         vt2r = vt2r_a*pwr1*pwr2
7088         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7089           max8 = qcrmin
7090         ELSE
7091           max8 = qrs(i, k, 2)
7092         END IF
7093         IF (90. .GT. t0c - t(i, k)) THEN
7094           y14 = t0c - t(i, k)
7095         ELSE
7096           y14 = 90.
7097         END IF
7098         IF (0. .LT. y14) THEN
7099           max28 = y14
7100         ELSE
7101           max28 = 0.
7102         END IF
7103         pwy1 = (bvts-2.)/4.
7104         pwr1 = den(i, k)**pwy1
7105         pwy2 = bvts/4.
7106         pwr2 = max8**pwy2
7107         arg1 = -(alpha*bvts*max28/4.)
7108         vt2s = vt2s_a*pwr1*pwr2*EXP(arg1)
7109         IF (90. .GT. t0c - t(i, k)) THEN
7110           y5 = t0c - t(i, k)
7111         ELSE
7112           y5 = 90.
7113         END IF
7114         IF (0. .LT. y5) THEN
7115           max9 = y5
7116         ELSE
7117           max9 = 0.
7118         END IF
7119         a = EXP(alpha*max9)
7120         IF (90. .GT. t0c - t(i, k)) THEN
7121           y6 = t0c - t(i, k)
7122         ELSE
7123           y6 = 90.
7124         END IF
7125         IF (0. .LT. y6) THEN
7126           max10 = y6
7127         ELSE
7128           max10 = 0.
7129         END IF
7130         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7131           max29 = qcrmin
7132         ELSE
7133           max29 = qrs(i, k, 1)
7134         END IF
7135         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7136           max42 = qcrmin
7137         ELSE
7138           max42 = qrs(i, k, 2)
7139         END IF
7140         arg1 = -(alpha*max10/4.)
7141         pwr1 = den(i, k)**(3./4.)
7142         pwr2 = max29**(3./2.)
7143         result1 = SQRT(max42)
7144         result2 = SQRT(result1)
7145         b = EXP(arg1)*pwr1*pwr2*result2
7146         IF (90. .GT. t0c - t(i, k)) THEN
7147           y7 = t0c - t(i, k)
7148         ELSE
7149           y7 = 90.
7150         END IF
7151         IF (0. .LT. y7) THEN
7152           max11 = y7
7153         ELSE
7154           max11 = 0.
7155         END IF
7156         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7157           max30 = qcrmin
7158         ELSE
7159           max30 = qrs(i, k, 1)
7160         END IF
7161         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7162           max43 = qcrmin
7163         ELSE
7164           max43 = qrs(i, k, 2)
7165         END IF
7166         arg1 = -(alpha*max11/2.)
7167         pwr1 = den(i, k)**(3./4.)
7168         pwr2 = max30**(5./4.)
7169         result1 = SQRT(max43)
7170         c = EXP(arg1)*pwr1*pwr2*result1
7171         IF (90. .GT. t0c - t(i, k)) THEN
7172           y8 = t0c - t(i, k)
7173         ELSE
7174           y8 = 90.
7175         END IF
7176         IF (0. .LT. y8) THEN
7177           max12 = y8
7178         ELSE
7179           max12 = 0.
7180         END IF
7181         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7182           max31 = qcrmin
7183         ELSE
7184           max31 = qrs(i, k, 1)
7185         END IF
7186         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7187           max44 = qcrmin
7188         ELSE
7189           max44 = qrs(i, k, 2)
7190         END IF
7191         arg1 = -(3.*alpha*max12/4.)
7192         pwr1 = den(i, k)**(3./4.)
7193         pwr2 = max44**(3./4.)
7194         d = EXP(arg1)*pwr1*max31*pwr2
7195         IF (vt2r - vt2s .GE. 0.) THEN
7196           abs2 = vt2r - vt2s
7197         ELSE
7198           abs2 = -(vt2r-vt2s)
7199         END IF
7200         psacr1 = psacr_a*a*abs2*(psacr_b*b+psacr_c*c+psacr_d*d)
7201         IF (supcol .GT. 0.) THEN
7202           IF (psacr1 .GT. qrs(i, k, 1)/dtcld) THEN
7203             psacr(i, k) = qrs(i, k, 1)/dtcld
7204           ELSE
7205             psacr(i, k) = psacr1
7206           END IF
7207         ELSE IF (psacr1 .GT. qrs(i, k, 2)/dtcld) THEN
7208           psacr(i, k) = qrs(i, k, 2)/dtcld
7209         ELSE
7210           psacr(i, k) = psacr1
7211         END IF
7212         IF (psacr(i, k) .GE. 0.) THEN
7213           abs3 = psacr(i, k)
7214         ELSE
7215           abs3 = -psacr(i, k)
7216         END IF
7217 !psacr(i,k)=fqr*fqs*psacr(i,k)
7218         IF (abs3 .LT. qmin/dtcld) psacr(i, k) = 0.
7219 !update qr qs qg
7220         IF (qrs(i, k, 1) .LT. 1.e-4 .AND. qrs(i, k, 2) .LT. 1.e-4) THEN
7221           delta2 = 1.
7222         ELSE
7223           delta2 = 0.
7224         END IF
7225         IF (qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld .LT. 0.) THEN
7226           qrs(i, k, 1) = 0.
7227         ELSE
7228           qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld
7229         END IF
7230         x1 = qrs(i, k, 2) + fsupcol*delta2*psacr(i, k)*dtcld
7231         IF (x1 .LT. 0.) THEN
7232           qrs(i, k, 2) = 0.
7233         ELSE
7234           qrs(i, k, 2) = x1
7235         END IF
7236         x2 = qrs(i, k, 3) + fsupcol*(1-delta2)*psacr(i, k)*dtcld
7237         IF (x2 .LT. 0.) THEN
7238           qrs(i, k, 3) = 0.
7239         ELSE
7240           qrs(i, k, 3) = x2
7241         END IF
7242         t(i, k) = t(i, k) + fsupcol*psacr(i, k)*dtcld*xlf/cpm(i, k)
7243 ! t>=t0 pseml
7244         psacr(i, k) = (1-fsupcol)*psacr(i, k)
7245 !-------------------------------------------------------------
7246 ! pgacr: Accretion of rain by graupel [LFO 42]
7247 !         (T< T0: R->G)                            min=0.,max=qrs(i,k,1)/dtcld
7248 !         (T>=T0: G->R enhance melting of graupel) min=0.,max=qrs(i,k,3)/dtcld
7249 !-------------------------------------------------------------
7250         supcol = t0c - t(i, k)
7251         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
7252 !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0')
7253 !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0')
7254 !update cpm
7255 !         cpm(i,k)=cpmcal(q(i,k)) !not change
7256         xl(i, k) = XLCAL(t(i, k))
7257         xlf = xls - xl(i, k)
7258         IF (supcol .LT. 0.) xlf = xlf0
7259         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7260           max13 = qcrmin
7261         ELSE
7262           max13 = qrs(i, k, 1)
7263         END IF
7264         pwy1 = (bvtr-2.)/4.
7265         pwr1 = den(i, k)**pwy1
7266         pwy2 = bvtr/4.
7267         pwr2 = max13**pwy2
7268         vt2r = vt2r_a*pwr1*pwr2
7269         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7270           max14 = qcrmin
7271         ELSE
7272           max14 = qrs(i, k, 3)
7273         END IF
7274         pwy1 = (bvtg-2.)/4.
7275         pwr1 = den(i, k)**pwy1
7276         pwy2 = bvtg/4.
7277         pwr2 = max14**pwy2
7278         vt2g = vt2g_a*pwr1*pwr2
7279         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7280           max15 = qcrmin
7281         ELSE
7282           max15 = qrs(i, k, 1)
7283         END IF
7284         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7285           max32 = qcrmin
7286         ELSE
7287           max32 = qrs(i, k, 3)
7288         END IF
7289         pwr1 = den(i, k)**(3./4.)
7290         pwr2 = max15**(3./2.)
7291         result1 = SQRT(max32)
7292         result2 = SQRT(result1)
7293         b = pwr1*pwr2*result2
7294         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7295           max16 = qcrmin
7296         ELSE
7297           max16 = qrs(i, k, 1)
7298         END IF
7299         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7300           max33 = qcrmin
7301         ELSE
7302           max33 = qrs(i, k, 3)
7303         END IF
7304         pwr1 = den(i, k)**(3./4.)
7305         pwr2 = max16**(5./4.)
7306         result1 = SQRT(max33)
7307         c = pwr1*pwr2*result1
7308         IF (qrs(i, k, 1) .LT. qcrmin) THEN
7309           max17 = qcrmin
7310         ELSE
7311           max17 = qrs(i, k, 1)
7312         END IF
7313         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7314           max34 = qcrmin
7315         ELSE
7316           max34 = qrs(i, k, 3)
7317         END IF
7318         pwr1 = den(i, k)**(3./4.)
7319         pwr2 = max34**(3./4.)
7320         d = pwr1*max17*pwr2
7321         IF (vt2r - vt2g .GE. 0.) THEN
7322           abs4 = vt2r - vt2g
7323         ELSE
7324           abs4 = -(vt2r-vt2g)
7325         END IF
7326         pgacr1 = pgacr_a*abs4*(pgacr_b*b+pgacr_c*c+pgacr_d*d)
7327         IF (supcol .GT. 0.) THEN
7328           IF (pgacr1 .GT. qrs(i, k, 1)/dtcld) THEN
7329             pgacr(i, k) = qrs(i, k, 1)/dtcld
7330           ELSE
7331             pgacr(i, k) = pgacr1
7332           END IF
7333         ELSE IF (pgacr1 .GT. qrs(i, k, 3)/dtcld) THEN
7334           pgacr(i, k) = qrs(i, k, 3)/dtcld
7335         ELSE
7336           pgacr(i, k) = pgacr1
7337         END IF
7338         IF (pgacr(i, k) .GE. 0.) THEN
7339           abs5 = pgacr(i, k)
7340         ELSE
7341           abs5 = -pgacr(i, k)
7342         END IF
7343 !pgacr(i,k)=fqg*fqr*pgacr(i,k)
7344         IF (abs5 .LT. qmin/dtcld) pgacr(i, k) = 0.
7345         IF (qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld .LT. 0.) THEN
7346           qrs(i, k, 1) = 0.
7347         ELSE
7348           qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld
7349         END IF
7350         x3 = qrs(i, k, 3) + fsupcol*pgacr(i, k)*dtcld
7351         IF (x3 .LT. 0.) THEN
7352           qrs(i, k, 3) = 0.
7353         ELSE
7354           qrs(i, k, 3) = x3
7355         END IF
7356         t(i, k) = t(i, k) + fsupcol*pgacr(i, k)*dtcld*xlf/cpm(i, k)
7357 ! t>=t0 pgeml
7358         pgacr(i, k) = (1-fsupcol)*pgacr(i, k)
7359 !-------------------------------------------------------------
7360 ! pgacs: Accretion of snow by graupel [LFO 29]
7361 !        (S->G) min=0,max=qrs(i,k,2)/dtcld
7362 !-------------------------------------------------------------
7363         supcol = t0c - t(i, k)
7364         CALL SMOOTHIF(supcol, 0., fsupcol, 't0')
7365         x4 = EXP(-(0.09*supcol))
7366         IF (x4 .GT. 1.) THEN
7367           egs = 1.
7368         ELSE
7369           egs = x4
7370         END IF
7371         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7372           max18 = qcrmin
7373         ELSE
7374           max18 = qrs(i, k, 3)
7375         END IF
7376         pwy1 = (bvtg-2.)/4.
7377         pwr1 = den(i, k)**pwy1
7378         pwy2 = bvtg/4.
7379         pwr2 = max18**pwy2
7380         vt2g = vt2g_a*pwr1*pwr2
7381         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7382           max19 = qcrmin
7383         ELSE
7384           max19 = qrs(i, k, 2)
7385         END IF
7386         IF (90. .GT. t0c - t(i, k)) THEN
7387           y15 = t0c - t(i, k)
7388         ELSE
7389           y15 = 90.
7390         END IF
7391         IF (0. .LT. y15) THEN
7392           max35 = y15
7393         ELSE
7394           max35 = 0.
7395         END IF
7396         pwy1 = (bvts-2.)/4.
7397         pwr1 = den(i, k)**pwy1
7398         pwy2 = bvts/4.
7399         pwr2 = max19**pwy2
7400         arg1 = -(alpha*bvts*max35/4.)
7401         vt2s = vt2s_a*pwr1*pwr2*EXP(arg1)
7402         IF (90. .GT. t0c - t(i, k)) THEN
7403           y9 = t0c - t(i, k)
7404         ELSE
7405           y9 = 90.
7406         END IF
7407         IF (0. .LT. y9) THEN
7408           max20 = y9
7409         ELSE
7410           max20 = 0.
7411         END IF
7412         a = EXP(alpha*max20)
7413         IF (90. .GT. t0c - t(i, k)) THEN
7414           y10 = t0c - t(i, k)
7415         ELSE
7416           y10 = 90.
7417         END IF
7418         IF (0. .LT. y10) THEN
7419           max21 = y10
7420         ELSE
7421           max21 = 0.
7422         END IF
7423         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7424           max36 = qcrmin
7425         ELSE
7426           max36 = qrs(i, k, 2)
7427         END IF
7428         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7429           max45 = qcrmin
7430         ELSE
7431           max45 = qrs(i, k, 3)
7432         END IF
7433         arg1 = -(3.*alpha*max21/2.)
7434         pwr1 = den(i, k)**(3./4.)
7435         pwr2 = max36**(3./2.)
7436         result1 = SQRT(max45)
7437         result2 = SQRT(result1)
7438         b = EXP(arg1)*pwr1*pwr2*result2
7439         IF (90. .GT. t0c - t(i, k)) THEN
7440           y11 = t0c - t(i, k)
7441         ELSE
7442           y11 = 90.
7443         END IF
7444         IF (0. .LT. y11) THEN
7445           max22 = y11
7446         ELSE
7447           max22 = 0.
7448         END IF
7449         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7450           max37 = qcrmin
7451         ELSE
7452           max37 = qrs(i, k, 2)
7453         END IF
7454         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7455           max46 = qcrmin
7456         ELSE
7457           max46 = qrs(i, k, 3)
7458         END IF
7459         arg1 = -(5.*alpha*max22/4.)
7460         pwr1 = den(i, k)**(3./4.)
7461         pwr2 = max37**(5./4.)
7462         result1 = SQRT(max46)
7463         c = EXP(arg1)*pwr1*pwr2*result1
7464         IF (90. .GT. t0c - t(i, k)) THEN
7465           y12 = t0c - t(i, k)
7466         ELSE
7467           y12 = 90.
7468         END IF
7469         IF (0. .LT. y12) THEN
7470           max23 = y12
7471         ELSE
7472           max23 = 0.
7473         END IF
7474         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7475           max38 = qcrmin
7476         ELSE
7477           max38 = qrs(i, k, 2)
7478         END IF
7479         IF (qrs(i, k, 3) .LT. qcrmin) THEN
7480           max47 = qcrmin
7481         ELSE
7482           max47 = qrs(i, k, 3)
7483         END IF
7484         pwr1 = den(i, k)**(3./4.)
7485         pwr2 = max47**(3./4.)
7486         d = EXP(-(alpha*max23))*pwr1*max38*pwr2
7487         IF (vt2g - vt2s .GE. 0.) THEN
7488           abs6 = vt2g - vt2s
7489         ELSE
7490           abs6 = -(vt2g-vt2s)
7491         END IF
7492         pgacs1 = pgacs_a*a*abs6*(pgacs_b*b+pgacs_c*c+pgacs_d*d)*egs
7493         IF (pgacs1 .GT. qrs(i, k, 2)/dtcld) THEN
7494           pgacs(i, k) = qrs(i, k, 2)/dtcld
7495         ELSE
7496           pgacs(i, k) = pgacs1
7497         END IF
7498         IF (pgacs(i, k) .GE. 0.) THEN
7499           abs7 = pgacs(i, k)
7500         ELSE
7501           abs7 = -pgacs(i, k)
7502         END IF
7503 !pgacs(i,k)=fqg*fqs*pgacs(i,k)
7504         IF (abs7 .LT. qmin/dtcld) pgacs(i, k) = 0.
7505         IF (qrs(i, k, 2) - pgacs(i, k)*dtcld .LT. 0.) THEN
7506           qrs(i, k, 2) = 0.
7507         ELSE
7508           qrs(i, k, 2) = qrs(i, k, 2) - pgacs(i, k)*dtcld
7509         END IF
7510         IF (qrs(i, k, 3) + pgacs(i, k)*dtcld .LT. 0.) THEN
7511           qrs(i, k, 3) = 0.
7512         ELSE
7513           qrs(i, k, 3) = qrs(i, k, 3) + pgacs(i, k)*dtcld
7514         END IF
7515         pgacs(i, k) = 0.
7516 !-------------------------------------------------------------
7517 ! pseml: Enhanced melting of snow by accretion of water
7518 !        (T>=T0: S->R) pseml<0 max=0,min=-qrs(i,k,2)/dtcld
7519 !-------------------------------------------------------------
7520 !         supcol = t0c-t(i,k) ! not change
7521 !update cpm
7522 !         cpm(i,k)=cpmcal(q(i,k)) ! not change
7523         xl(i, k) = XLCAL(t(i, k))
7524         xlf = xls - xl(i, k)
7525         IF (supcol .LT. 0.) xlf = xlf0
7526         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
7527         CALL SMOOTHIF(qrs(i, k, 2), 0., fqs, 'q+')
7528         x7 = cliq*supcol*(psacw(i, k)+psacr(i, k))/xlf
7529         IF (x7 .LT. -(qrs(i, k, 2)/dtcld)) THEN
7530           x5 = -(qrs(i, k, 2)/dtcld)
7531         ELSE
7532           x5 = x7
7533         END IF
7534         IF (x5 .GT. 0.) THEN
7535           pseml(i, k) = 0.
7536         ELSE
7537           pseml(i, k) = x5
7538         END IF
7539         pseml(i, k) = ft0*fqs*pseml(i, k)
7540         IF (pseml(i, k) .GE. 0.) THEN
7541           abs8 = pseml(i, k)
7542         ELSE
7543           abs8 = -pseml(i, k)
7544         END IF
7545         IF (abs8 .LT. qmin/dtcld) pseml(i, k) = 0.
7546         IF (qrs(i, k, 1) - pseml(i, k)*dtcld .LT. 0.) THEN
7547           qrs(i, k, 1) = 0.
7548         ELSE
7549           qrs(i, k, 1) = qrs(i, k, 1) - pseml(i, k)*dtcld
7550         END IF
7551         IF (qrs(i, k, 2) + pseml(i, k)*dtcld .LT. 0.) THEN
7552           qrs(i, k, 2) = 0.
7553         ELSE
7554           qrs(i, k, 2) = qrs(i, k, 2) + pseml(i, k)*dtcld
7555         END IF
7556         t(i, k) = t(i, k) + pseml(i, k)*dtcld*xlf/cpm(i, k)
7557         pseml(i, k) = 0.
7558         psacw(i, k) = 0.
7559         psacr(i, k) = 0.
7560 !-------------------------------------------------------------
7561 ! pgeml: Enhanced melting of graupel by accretion of water [RH84 A21-A22]
7562 !        (T>=T0: G->R) pgeml<0 max=0,min=-qrs(i,k,3)/dtcld
7563 !-------------------------------------------------------------
7564         supcol = t0c - t(i, k)
7565 !update cpm
7566 !         cpm(i,k)=cpmcal(q(i,k)) ! not change
7567         xl(i, k) = XLCAL(t(i, k))
7568         xlf = xls - xl(i, k)
7569         IF (supcol .LT. 0.) xlf = xlf0
7570         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
7571         CALL SMOOTHIF(qrs(i, k, 3), 0., fqg, 'q+')
7572         x8 = cliq*supcol*(pgacw(i, k)+pgacr(i, k))/xlf
7573         IF (x8 .LT. -(qrs(i, k, 3)/dtcld)) THEN
7574           x6 = -(qrs(i, k, 3)/dtcld)
7575         ELSE
7576           x6 = x8
7577         END IF
7578         IF (x6 .GT. 0.) THEN
7579           pgeml(i, k) = 0.
7580         ELSE
7581           pgeml(i, k) = x6
7582         END IF
7583         pgeml(i, k) = ft0*fqg*pgeml(i, k)
7584         IF (pgeml(i, k) .GE. 0.) THEN
7585           abs9 = pgeml(i, k)
7586         ELSE
7587           abs9 = -pgeml(i, k)
7588         END IF
7589         IF (abs9 .LT. qmin/dtcld) pgeml(i, k) = 0.
7590         IF (qrs(i, k, 1) - pgeml(i, k)*dtcld .LT. 0.) THEN
7591           qrs(i, k, 1) = 0.
7592         ELSE
7593           qrs(i, k, 1) = qrs(i, k, 1) - pgeml(i, k)*dtcld
7594         END IF
7595         IF (qrs(i, k, 3) + pgeml(i, k)*dtcld .LT. 0.) THEN
7596           qrs(i, k, 3) = 0.
7597         ELSE
7598           qrs(i, k, 3) = qrs(i, k, 3) + pgeml(i, k)*dtcld
7599         END IF
7600         t(i, k) = t(i, k) + pgeml(i, k)*dtcld*xlf/cpm(i, k)
7601         pgeml(i, k) = 0.
7602         pgacw(i, k) = 0.
7603         pgacr(i, k) = 0.
7604       END DO
7605     END DO
7606   END SUBROUTINE ACCRET2
7607
7608 !  Differentiation of accret3 in forward (tangent) mode (with options r8):
7609 !   variations   of useful results: q t qs pigen rh qrs psevp pidep
7610 !                pgevp psdep qci pgdep psaut pgaut
7611 !   with respect to varying inputs: p q t qs pigen rh den qrs psevp
7612 !                pidep pgevp psdep qci pgdep psaut pgaut
7613 !=======================================================================
7614 !
7615 !=======================================================================
7616   SUBROUTINE G_ACCRET3(qrs, g_qrs, qci, g_qci, rh, g_rh, t, g_t, p, g_p&
7617 &   , den, g_den, dtcld, q, g_q, qs, g_qs, psdep, g_psdep, pgdep, &
7618 &   g_pgdep, pigen, g_pigen, psaut, g_psaut, pgaut, g_pgaut, psevp, &
7619 &   g_psevp, pgevp, g_pgevp, pidep, g_pidep, ims, ime, kms, kme, its, &
7620 &   ite, kts, kte)
7621     IMPLICIT NONE
7622     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
7623 !-------------------------------------------------------------------
7624     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
7625     REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci
7626     REAL, DIMENSION(ims:ime, kms:kme) :: den, q, p
7627     REAL, DIMENSION(ims:ime, kms:kme) :: g_den, g_q, g_p
7628     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, rh, qs
7629     REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs, g_rh, g_qs
7630     REAL, DIMENSION(its:ite, kts:kte) :: pigen, psevp, pgevp, pidep, t, &
7631 &   xl, cpm, psdep, pgdep, psaut, pgaut
7632     REAL, DIMENSION(its:ite, kts:kte) :: g_pigen, g_psevp, g_pgevp, &
7633 &   g_pidep, g_t, g_xl, g_cpm, g_psdep, g_pgdep, g_psaut, g_pgaut
7634     REAL :: supcol, dtcld, satdt, supsat, qimax, diameter, xni0, roqi0, &
7635 &   supice1, supice2, supice3, supice4, alpha2
7636     REAL :: g_supcol, g_satdt, g_supsat, g_qimax, g_xni0, g_roqi0, &
7637 &   g_alpha2
7638     REAL :: pidep0, pidep1, psdep0, pgdep3, pigen0, psevp0, pgevp0, &
7639 &   coeres1, coeres2, coeres3, coeres4
7640     REAL :: g_pidep0, g_psdep0, g_pgdep3, g_pigen0, g_psevp0, g_pgevp0
7641     REAL :: temp0, temp, xmi
7642     INTEGER :: i, k
7643     REAL :: fqi, fqr, fqv, fqs, fqg, frh, ft0, fpidep, fpsdep, fpgdep, &
7644 &   fsupcol, fsupsat, pidep2
7645     REAL :: g_ft0, g_fsupcol, g_fsupsat
7646     REAL :: value01, factor01, source01, vice, a, b, c, d, e, f, g
7647     REAL :: g_a, g_b, g_c, g_d, g_e
7648     INTRINSIC MAX
7649     INTRINSIC MIN
7650     INTRINSIC ABS
7651     INTRINSIC EXP
7652     INTRINSIC SQRT
7653     REAL :: x1
7654     REAL :: g_x1
7655     REAL :: x2
7656     REAL :: g_x2
7657     REAL :: y1
7658     REAL :: g_y1
7659     REAL :: y2
7660     REAL :: g_y2
7661     REAL :: x3
7662     REAL :: g_x3
7663     REAL :: x4
7664     REAL :: g_x4
7665     REAL :: x5
7666     REAL :: g_x5
7667     REAL :: x6
7668     REAL :: g_x6
7669     REAL :: x7
7670     REAL :: g_x7
7671     REAL :: x8
7672     REAL :: g_x8
7673     REAL :: y3
7674     REAL :: g_y3
7675     REAL :: y4
7676     REAL :: g_y4
7677     REAL :: x9
7678     REAL :: g_x9
7679     REAL :: x10
7680     REAL :: g_x10
7681     REAL :: abs0
7682     REAL :: max1
7683     REAL :: g_max1
7684     REAL :: max2
7685     REAL :: g_max2
7686     REAL :: abs1
7687     REAL :: max3
7688     REAL :: g_max3
7689     REAL :: max4
7690     REAL :: g_max4
7691     REAL :: abs2
7692     REAL :: abs3
7693     REAL :: abs4
7694     REAL :: abs5
7695     REAL :: max5
7696     REAL :: g_max5
7697     REAL :: max6
7698     REAL :: g_max6
7699     REAL :: abs6
7700     REAL :: max7
7701     REAL :: g_max7
7702     REAL :: max8
7703     REAL :: g_max8
7704     REAL :: abs7
7705     REAL :: max9
7706     REAL :: g_max9
7707     REAL :: max10
7708     REAL :: g_max10
7709     REAL :: max11
7710     REAL :: g_max11
7711     REAL :: max12
7712     REAL :: g_max12
7713     REAL :: max13
7714     REAL :: g_max13
7715     REAL :: pwx1
7716     REAL :: g_pwx1
7717     REAL :: pwr1
7718     REAL :: g_pwr1
7719     REAL :: arg1
7720     REAL :: g_arg1
7721     REAL :: arg2
7722     REAL :: g_arg2
7723     REAL :: result1
7724     REAL :: g_result1
7725     REAL :: pwr2
7726     REAL :: g_pwr2
7727     REAL :: pwr3
7728     REAL :: g_pwr3
7729     REAL :: pwy4
7730     REAL :: pwr4
7731     REAL :: g_pwr4
7732     REAL :: pwy5
7733     REAL :: pwr5
7734     REAL :: g_pwr5
7735     REAL :: temp1
7736     REAL :: temp2
7737     REAL :: temp3
7738     REAL :: temp4
7739     g_cpm = 0.0_8
7740     g_xl = 0.0_8
7741     DO k=kts,kte
7742       DO i=its,ite
7743 !
7744 !-------------------------------------------------------------
7745 ! pidep: Deposition/Sublimation rate of ice [HDC 9]
7746 !       (T<T0: V->I or I->V)
7747 !       rh(i,k,2)>1.,pidep>0: V->I, min=0,        max=satdt
7748 !       rh(i,k,2)<1.,pidep<0: I->V, min=-qi/dtcld,max=0,
7749 !-------------------------------------------------------------
7750 !update supcol
7751         g_supcol = -g_t(i, k)
7752         supcol = t0c - t(i, k)
7753 !update rh qs
7754         CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), &
7755 &               g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs&
7756 &               (i, k, :))
7757 !update satdt
7758         g_supsat = g_q(i, k) - g_qs(i, k, 2)
7759         supsat = q(i, k) - qs(i, k, 2)
7760         g_satdt = g_supsat/dtcld
7761         satdt = supsat/dtcld
7762 !update xl, cpm
7763         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
7764         g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k))
7765         CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't+')
7766         IF (qci(i, k, 2) .GT. 0.) THEN
7767           temp1 = diffac_a*(xls*xls)
7768           temp2 = rv*t(i, k)**3.5
7769           temp3 = den(i, k)*(t(i, k)+120.)/temp2
7770           g_b = temp1*((t(i, k)+120.)*g_den(i, k)+(den(i, k)-temp3*rv*&
7771 &           3.5*t(i, k)**2.5)*g_t(i, k))/temp2
7772           b = temp1*temp3
7773           temp3 = t(i, k)**1.81
7774           temp2 = temp3*qs(i, k, 2)
7775           temp1 = p(i, k)/temp2
7776           g_c = diffac_b*(g_p(i, k)-temp1*(qs(i, k, 2)*1.81*t(i, k)**&
7777 &           0.81*g_t(i, k)+temp3*g_qs(i, k, 2)))/temp2
7778           c = diffac_b*temp1
7779           temp3 = (rh(i, k, 2)-1.)/(b+c)
7780           g_a = (g_rh(i, k, 2)-temp3*(g_b+g_c))/(b+c)
7781           a = temp3
7782           g_pwx1 = qci(i, k, 2)*g_den(i, k) + den(i, k)*g_qci(i, k, 2)
7783           pwx1 = den(i, k)*qci(i, k, 2)
7784           IF (pwx1 .LE. 0.0_8 .AND. (7./8. .EQ. 0.0_8 .OR. 7./8. .NE. &
7785 &             INT(7./8.))) THEN
7786             g_pwr1 = 0.0_8
7787           ELSE
7788             g_pwr1 = 7.*pwx1**(7./8.-1)*g_pwx1/8.
7789           END IF
7790           pwr1 = pwx1**(7./8.)
7791           g_pidep0 = pidep_a*(pwr1*g_a+a*g_pwr1)
7792           pidep0 = pidep_a*a*pwr1
7793         ELSE
7794           pidep0 = 0.
7795           g_pidep0 = 0.0_8
7796         END IF
7797         IF (pidep0 .LT. 0.) THEN
7798           IF (pidep0 .LT. -(qci(i, k, 2)/dtcld)) THEN
7799             g_x1 = -(g_qci(i, k, 2)/dtcld)
7800             x1 = -(qci(i, k, 2)/dtcld)
7801           ELSE
7802             g_x1 = g_pidep0
7803             x1 = pidep0
7804           END IF
7805           IF (x1 .GT. 0.) THEN
7806             g_pidep(i, k) = 0.0_8
7807             pidep(i, k) = 0.
7808           ELSE
7809             g_pidep(i, k) = g_x1
7810             pidep(i, k) = x1
7811           END IF
7812         ELSE
7813           IF (pidep0 .GT. satdt) THEN
7814             g_x2 = g_satdt
7815             x2 = satdt
7816           ELSE
7817             g_x2 = g_pidep0
7818             x2 = pidep0
7819           END IF
7820           IF (x2 .LT. 0.) THEN
7821             g_pidep(i, k) = 0.0_8
7822             pidep(i, k) = 0.
7823           ELSE
7824             g_pidep(i, k) = g_x2
7825             pidep(i, k) = x2
7826           END IF
7827         END IF
7828         g_pidep(i, k) = pidep(i, k)*g_fsupcol + fsupcol*g_pidep(i, k)
7829         pidep(i, k) = fsupcol*pidep(i, k)
7830         IF (pidep(i, k) .GE. 0.) THEN
7831           abs0 = pidep(i, k)
7832         ELSE
7833           abs0 = -pidep(i, k)
7834         END IF
7835         IF (abs0 .LT. qmin/dtcld) THEN
7836           g_pidep(i, k) = 0.0_8
7837           pidep(i, k) = 0.
7838         END IF
7839         IF (q(i, k) - pidep(i, k)*dtcld .LT. 0.) THEN
7840           g_q(i, k) = 0.0_8
7841           q(i, k) = 0.
7842         ELSE
7843           g_q(i, k) = g_q(i, k) - dtcld*g_pidep(i, k)
7844           q(i, k) = q(i, k) - pidep(i, k)*dtcld
7845         END IF
7846         IF (qci(i, k, 2) + pidep(i, k)*dtcld .LT. 0.) THEN
7847           g_qci(i, k, 2) = 0.0_8
7848           qci(i, k, 2) = 0.
7849         ELSE
7850           g_qci(i, k, 2) = g_qci(i, k, 2) + dtcld*g_pidep(i, k)
7851           qci(i, k, 2) = qci(i, k, 2) + pidep(i, k)*dtcld
7852         END IF
7853         temp3 = pidep(i, k)/cpm(i, k)
7854         g_t(i, k) = g_t(i, k) + dtcld*xls*(g_pidep(i, k)-temp3*g_cpm(i, &
7855 &         k))/cpm(i, k)
7856         t(i, k) = t(i, k) + dtcld*xls*temp3
7857         g_pidep(i, k) = 0.0_8
7858         pidep(i, k) = 0.
7859 !
7860 !-------------------------------------------------------------
7861 ! psdep: deposition/sublimation rate of snow [HDC 14]
7862 !        (T<T0: V->S or S->V)
7863 !       rh(i,k,2)>1.,psdep>0: V->S, min=0,        max=satdt
7864 !       rh(i,k,2)<1.,psdep<0: S->V, min=-qs/dtcld,max=0,
7865 !-------------------------------------------------------------
7866 !update supcol
7867         g_supcol = -g_t(i, k)
7868         supcol = t0c - t(i, k)
7869 !update rh qs
7870         CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), &
7871 &               g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs&
7872 &               (i, k, :))
7873 !update satdt
7874         g_supsat = g_q(i, k) - g_qs(i, k, 2)
7875         supsat = q(i, k) - qs(i, k, 2)
7876         g_satdt = g_supsat/dtcld
7877         satdt = supsat/dtcld
7878 !update xl, cpm
7879         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
7880         g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k))
7881         CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't+')
7882         IF (90. .GT. t0c - t(i, k)) THEN
7883           g_y1 = -g_t(i, k)
7884           y1 = t0c - t(i, k)
7885         ELSE
7886           y1 = 90.
7887           g_y1 = 0.0_8
7888         END IF
7889         IF (0. .LT. y1) THEN
7890           g_max1 = g_y1
7891           max1 = y1
7892         ELSE
7893           max1 = 0.
7894           g_max1 = 0.0_8
7895         END IF
7896         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7897           max9 = qcrmin
7898           g_max9 = 0.0_8
7899         ELSE
7900           g_max9 = g_qrs(i, k, 2)
7901           max9 = qrs(i, k, 2)
7902         END IF
7903 !         call smoothif(qrs(i,k,2),0.,fqs,'q+')
7904 !         call smoothif(q  (i,k  ),0.,fqv,'q+')
7905         g_arg1 = alpha*g_max1/2.
7906         arg1 = alpha*max1/2.
7907         g_arg2 = max9*g_den(i, k) + den(i, k)*g_max9
7908         arg2 = den(i, k)*max9
7909         temp3 = SQRT(arg2)
7910         IF (arg2 .EQ. 0.0_8) THEN
7911           g_result1 = 0.0_8
7912         ELSE
7913           g_result1 = g_arg2/(2.0*temp3)
7914         END IF
7915         result1 = temp3
7916         temp3 = EXP(arg1)
7917         g_a = result1*EXP(arg1)*g_arg1 + temp3*g_result1
7918         a = temp3*result1
7919         IF (90. .GT. t0c - t(i, k)) THEN
7920           g_y2 = -g_t(i, k)
7921           y2 = t0c - t(i, k)
7922         ELSE
7923           y2 = 90.
7924           g_y2 = 0.0_8
7925         END IF
7926         IF (0. .LT. y2) THEN
7927           g_max2 = g_y2
7928           max2 = y2
7929         ELSE
7930           max2 = 0.
7931           g_max2 = 0.0_8
7932         END IF
7933         IF (qrs(i, k, 2) .LT. qcrmin) THEN
7934           max10 = qcrmin
7935           g_max10 = 0.0_8
7936         ELSE
7937           g_max10 = g_qrs(i, k, 2)
7938           max10 = qrs(i, k, 2)
7939         END IF
7940         g_arg1 = (3.-bvts)*alpha*g_max2/8.
7941         arg1 = (3.-bvts)*alpha*max2/8.
7942         g_pwx1 = g_t(i, k)
7943         pwx1 = t(i, k) + 120.
7944         IF (pwx1 .LE. 0.0_8 .AND. (1.0/6. .EQ. 0.0_8 .OR. 1.0/6. .NE. &
7945 &           INT(1.0/6.))) THEN
7946           g_pwr1 = 0.0_8
7947         ELSE
7948           g_pwr1 = pwx1**(1.0/6.-1)*g_pwx1/6.
7949         END IF
7950         pwr1 = pwx1**(1./6.)
7951         IF (t(i, k) .LE. 0.0_8 .AND. (5.12/6. .EQ. 0.0_8 .OR. 5.12/6. &
7952 &           .NE. INT(5.12/6.))) THEN
7953           g_pwr2 = 0.0_8
7954         ELSE
7955           g_pwr2 = 5.12*t(i, k)**(5.12/6.-1)*g_t(i, k)/6.
7956         END IF
7957         pwr2 = t(i, k)**(5.12/6.)
7958         IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. .NE.&
7959 &           INT(1.0/3.))) THEN
7960           g_pwr3 = 0.0_8
7961         ELSE
7962           g_pwr3 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3.
7963         END IF
7964         pwr3 = p(i, k)**(1./3.)
7965         pwy4 = (13.+3.*bvts)/24.
7966         IF (den(i, k) .LE. 0.0_8 .AND. (pwy4 .EQ. 0.0_8 .OR. pwy4 .NE. &
7967 &           INT(pwy4))) THEN
7968           g_pwr4 = 0.0_8
7969         ELSE
7970           g_pwr4 = pwy4*den(i, k)**(pwy4-1)*g_den(i, k)
7971         END IF
7972         pwr4 = den(i, k)**pwy4
7973         pwy5 = (5.+bvts)/8.
7974         IF (max10 .LE. 0.0_8 .AND. (pwy5 .EQ. 0.0_8 .OR. pwy5 .NE. INT(&
7975 &           pwy5))) THEN
7976           g_pwr5 = 0.0_8
7977         ELSE
7978           g_pwr5 = pwy5*max10**(pwy5-1)*g_max10
7979         END IF
7980         pwr5 = max10**pwy5
7981         temp3 = pwr1*pwr3/pwr2
7982         temp2 = temp3*pwr4*pwr5
7983         temp1 = EXP(arg1)
7984         g_b = temp2*EXP(arg1)*g_arg1 + temp1*(pwr4*pwr5*(pwr3*g_pwr1+&
7985 &         pwr1*g_pwr3-temp3*g_pwr2)/pwr2+temp3*(pwr5*g_pwr4+pwr4*g_pwr5)&
7986 &         )
7987         b = temp1*temp2
7988         temp3 = diffac_a*(xls*xls)
7989         temp2 = rv*t(i, k)**3.5
7990         temp1 = den(i, k)*(t(i, k)+120.)/temp2
7991         g_c = temp3*((t(i, k)+120.)*g_den(i, k)+(den(i, k)-temp1*rv*3.5*&
7992 &         t(i, k)**2.5)*g_t(i, k))/temp2
7993         c = temp3*temp1
7994         temp3 = t(i, k)**1.81
7995         temp2 = temp3*qs(i, k, 2)
7996         temp1 = p(i, k)/temp2
7997         g_d = diffac_b*(g_p(i, k)-temp1*(qs(i, k, 2)*1.81*t(i, k)**0.81*&
7998 &         g_t(i, k)+temp3*g_qs(i, k, 2)))/temp2
7999         d = diffac_b*temp1
8000         temp3 = (rh(i, k, 2)-1.)/(c+d)
8001         g_e = (g_rh(i, k, 2)-temp3*(g_c+g_d))/(c+d)
8002         e = temp3
8003         temp3 = psdep_a*a + psdep_b*b
8004         g_psdep0 = temp3*g_e + e*(psdep_a*g_a+psdep_b*g_b)
8005         psdep0 = e*temp3
8006         IF (psdep0 .LT. 0.) THEN
8007           IF (psdep0 .LT. -(qrs(i, k, 2)/dtcld)) THEN
8008             g_x3 = -(g_qrs(i, k, 2)/dtcld)
8009             x3 = -(qrs(i, k, 2)/dtcld)
8010           ELSE
8011             g_x3 = g_psdep0
8012             x3 = psdep0
8013           END IF
8014           IF (x3 .GT. 0.) THEN
8015             g_psdep(i, k) = 0.0_8
8016             psdep(i, k) = 0.
8017           ELSE
8018             g_psdep(i, k) = g_x3
8019             psdep(i, k) = x3
8020           END IF
8021         ELSE
8022           IF (psdep0 .GT. satdt) THEN
8023             g_x4 = g_satdt
8024             x4 = satdt
8025           ELSE
8026             g_x4 = g_psdep0
8027             x4 = psdep0
8028           END IF
8029           IF (x4 .LT. 0.) THEN
8030             g_psdep(i, k) = 0.0_8
8031             psdep(i, k) = 0.
8032           ELSE
8033             g_psdep(i, k) = g_x4
8034             psdep(i, k) = x4
8035           END IF
8036         END IF
8037         g_psdep(i, k) = psdep(i, k)*g_fsupcol + fsupcol*g_psdep(i, k)
8038         psdep(i, k) = fsupcol*psdep(i, k)
8039         IF (psdep(i, k) .GE. 0.) THEN
8040           abs1 = psdep(i, k)
8041         ELSE
8042           abs1 = -psdep(i, k)
8043         END IF
8044         IF (abs1 .LT. qmin/dtcld) THEN
8045           g_psdep(i, k) = 0.0_8
8046           psdep(i, k) = 0.
8047         END IF
8048         IF (q(i, k) - psdep(i, k)*dtcld .LT. 0.) THEN
8049           g_q(i, k) = 0.0_8
8050           q(i, k) = 0.
8051         ELSE
8052           g_q(i, k) = g_q(i, k) - dtcld*g_psdep(i, k)
8053           q(i, k) = q(i, k) - psdep(i, k)*dtcld
8054         END IF
8055         IF (qrs(i, k, 2) + psdep(i, k)*dtcld .LT. 0.) THEN
8056           g_qrs(i, k, 2) = 0.0_8
8057           qrs(i, k, 2) = 0.
8058         ELSE
8059           g_qrs(i, k, 2) = g_qrs(i, k, 2) + dtcld*g_psdep(i, k)
8060           qrs(i, k, 2) = qrs(i, k, 2) + psdep(i, k)*dtcld
8061         END IF
8062         temp3 = psdep(i, k)/cpm(i, k)
8063         g_t(i, k) = g_t(i, k) + dtcld*xls*(g_psdep(i, k)-temp3*g_cpm(i, &
8064 &         k))/cpm(i, k)
8065         t(i, k) = t(i, k) + dtcld*xls*temp3
8066         g_psdep(i, k) = 0.0_8
8067         psdep(i, k) = 0.
8068 !
8069 !------------------------------------------------------------
8070 ! pgdep: deposition/sublimation rate of graupel [LFO 46]
8071 !        (T<T0: V->G or G->V)
8072 !       rh(i,k,2)>1.,pgdep>0: V->G, min=0,        max=satdt
8073 !       rh(i,k,2)<1.,pgdep<0: G->V, min=-qg/dtcld,max=0,
8074 !------------------------------------------------------------
8075 !update supcol
8076         g_supcol = -g_t(i, k)
8077         supcol = t0c - t(i, k)
8078 !update rh qs
8079         CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), &
8080 &               g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs&
8081 &               (i, k, :))
8082 !update satdt
8083         g_supsat = g_q(i, k) - g_qs(i, k, 2)
8084         supsat = q(i, k) - qs(i, k, 2)
8085         g_satdt = g_supsat/dtcld
8086         satdt = supsat/dtcld
8087 !update xl, cpm
8088         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
8089         g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k))
8090         CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't+')
8091         IF (qrs(i, k, 3) .LT. qcrmin) THEN
8092           max3 = qcrmin
8093           g_max3 = 0.0_8
8094         ELSE
8095           g_max3 = g_qrs(i, k, 3)
8096           max3 = qrs(i, k, 3)
8097         END IF
8098 !         call smoothif(qrs(i,k,3),0.,fqg,'q+')
8099 !         call smoothif(q  (i,k  ),0.,fqv,'q+')
8100         temp3 = den(i, k)*max3
8101         temp2 = SQRT(temp3)
8102         IF (temp3 .EQ. 0.0_8) THEN
8103           g_a = 0.0_8
8104         ELSE
8105           g_a = (max3*g_den(i, k)+den(i, k)*g_max3)/(2.0*temp2)
8106         END IF
8107         a = temp2
8108         IF (qrs(i, k, 3) .LT. qcrmin) THEN
8109           max4 = qcrmin
8110           g_max4 = 0.0_8
8111         ELSE
8112           g_max4 = g_qrs(i, k, 3)
8113           max4 = qrs(i, k, 3)
8114         END IF
8115         g_pwx1 = g_t(i, k)
8116         pwx1 = t(i, k) + 120.
8117         IF (pwx1 .LE. 0.0_8 .AND. (1.0/6. .EQ. 0.0_8 .OR. 1.0/6. .NE. &
8118 &           INT(1.0/6.))) THEN
8119           g_pwr1 = 0.0_8
8120         ELSE
8121           g_pwr1 = pwx1**(1.0/6.-1)*g_pwx1/6.
8122         END IF
8123         pwr1 = pwx1**(1./6.)
8124         IF (t(i, k) .LE. 0.0_8 .AND. (5.12/6. .EQ. 0.0_8 .OR. 5.12/6. &
8125 &           .NE. INT(5.12/6.))) THEN
8126           g_pwr2 = 0.0_8
8127         ELSE
8128           g_pwr2 = 5.12*t(i, k)**(5.12/6.-1)*g_t(i, k)/6.
8129         END IF
8130         pwr2 = t(i, k)**(5.12/6.)
8131         IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. .NE.&
8132 &           INT(1.0/3.))) THEN
8133           g_pwr3 = 0.0_8
8134         ELSE
8135           g_pwr3 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3.
8136         END IF
8137         pwr3 = p(i, k)**(1./3.)
8138         pwy4 = (13.+3.*bvtg)/24.
8139         IF (den(i, k) .LE. 0.0_8 .AND. (pwy4 .EQ. 0.0_8 .OR. pwy4 .NE. &
8140 &           INT(pwy4))) THEN
8141           g_pwr4 = 0.0_8
8142         ELSE
8143           g_pwr4 = pwy4*den(i, k)**(pwy4-1)*g_den(i, k)
8144         END IF
8145         pwr4 = den(i, k)**pwy4
8146         pwy5 = (5.+bvtg)/8.
8147         IF (max4 .LE. 0.0_8 .AND. (pwy5 .EQ. 0.0_8 .OR. pwy5 .NE. INT(&
8148 &           pwy5))) THEN
8149           g_pwr5 = 0.0_8
8150         ELSE
8151           g_pwr5 = pwy5*max4**(pwy5-1)*g_max4
8152         END IF
8153         pwr5 = max4**pwy5
8154         temp3 = pwr1*pwr3/pwr2
8155         g_b = pwr4*pwr5*(pwr3*g_pwr1+pwr1*g_pwr3-temp3*g_pwr2)/pwr2 + &
8156 &         temp3*(pwr5*g_pwr4+pwr4*g_pwr5)
8157         b = temp3*(pwr4*pwr5)
8158         temp3 = diffac_a*(xls*xls)
8159         temp2 = rv*t(i, k)**3.5
8160         temp1 = den(i, k)*(t(i, k)+120.)/temp2
8161         g_c = temp3*((t(i, k)+120.)*g_den(i, k)+(den(i, k)-temp1*rv*3.5*&
8162 &         t(i, k)**2.5)*g_t(i, k))/temp2
8163         c = temp3*temp1
8164         temp3 = t(i, k)**1.81
8165         temp2 = temp3*qs(i, k, 2)
8166         temp1 = p(i, k)/temp2
8167         g_d = diffac_b*(g_p(i, k)-temp1*(qs(i, k, 2)*1.81*t(i, k)**0.81*&
8168 &         g_t(i, k)+temp3*g_qs(i, k, 2)))/temp2
8169         d = diffac_b*temp1
8170         temp3 = (rh(i, k, 2)-1.)/(c+d)
8171         g_e = (g_rh(i, k, 2)-temp3*(g_c+g_d))/(c+d)
8172         e = temp3
8173         temp3 = pgdep_a*a + pgdep_b*b
8174         g_pgdep3 = temp3*g_e + e*(pgdep_a*g_a+pgdep_b*g_b)
8175         pgdep3 = e*temp3
8176         IF (pgdep3 .LT. 0.) THEN
8177           IF (pgdep3 .LT. -(qrs(i, k, 3)/dtcld)) THEN
8178             g_x5 = -(g_qrs(i, k, 3)/dtcld)
8179             x5 = -(qrs(i, k, 3)/dtcld)
8180           ELSE
8181             g_x5 = g_pgdep3
8182             x5 = pgdep3
8183           END IF
8184           IF (x5 .GT. 0.) THEN
8185             g_pgdep(i, k) = 0.0_8
8186             pgdep(i, k) = 0.
8187           ELSE
8188             g_pgdep(i, k) = g_x5
8189             pgdep(i, k) = x5
8190           END IF
8191         ELSE
8192           IF (pgdep3 .GT. satdt) THEN
8193             g_x6 = g_satdt
8194             x6 = satdt
8195           ELSE
8196             g_x6 = g_pgdep3
8197             x6 = pgdep3
8198           END IF
8199           IF (x6 .LT. 0.) THEN
8200             g_pgdep(i, k) = 0.0_8
8201             pgdep(i, k) = 0.
8202           ELSE
8203             g_pgdep(i, k) = g_x6
8204             pgdep(i, k) = x6
8205           END IF
8206         END IF
8207         g_pgdep(i, k) = pgdep(i, k)*g_fsupcol + fsupcol*g_pgdep(i, k)
8208         pgdep(i, k) = fsupcol*pgdep(i, k)
8209         IF (pgdep(i, k) .GE. 0.) THEN
8210           abs2 = pgdep(i, k)
8211         ELSE
8212           abs2 = -pgdep(i, k)
8213         END IF
8214         IF (abs2 .LT. qmin/dtcld) THEN
8215           g_pgdep(i, k) = 0.0_8
8216           pgdep(i, k) = 0.
8217         END IF
8218         IF (q(i, k) - pgdep(i, k)*dtcld .LT. 0.) THEN
8219           g_q(i, k) = 0.0_8
8220           q(i, k) = 0.
8221         ELSE
8222           g_q(i, k) = g_q(i, k) - dtcld*g_pgdep(i, k)
8223           q(i, k) = q(i, k) - pgdep(i, k)*dtcld
8224         END IF
8225         IF (qrs(i, k, 3) + pgdep(i, k)*dtcld .LT. 0.) THEN
8226           g_qrs(i, k, 3) = 0.0_8
8227           qrs(i, k, 3) = 0.
8228         ELSE
8229           g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgdep(i, k)
8230           qrs(i, k, 3) = qrs(i, k, 3) + pgdep(i, k)*dtcld
8231         END IF
8232         temp3 = pgdep(i, k)/cpm(i, k)
8233         g_t(i, k) = g_t(i, k) + dtcld*xls*(g_pgdep(i, k)-temp3*g_cpm(i, &
8234 &         k))/cpm(i, k)
8235         t(i, k) = t(i, k) + dtcld*xls*temp3
8236         g_pgdep(i, k) = 0.0_8
8237         pgdep(i, k) = 0.
8238 !-------------------------------------------------------------
8239 ! pigen: generation(nucleation) of ice from vapor [HDC 7-8]
8240 !       (T<T0: V->I) min=0,max=min(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld,satdt)
8241 !-------------------------------------------------------------
8242 !update supcol
8243         g_supcol = -g_t(i, k)
8244         supcol = t0c - t(i, k)
8245         g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k))
8246 !update rh qs
8247         CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), &
8248 &               g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs&
8249 &               (i, k, :))
8250 !update satdt
8251         g_supsat = g_q(i, k) - g_qs(i, k, 2)
8252         supsat = q(i, k) - qs(i, k, 2)
8253         g_satdt = g_supsat/dtcld
8254         satdt = supsat/dtcld
8255         CALL G_SMOOTHIF(supsat, g_supsat, 0., fsupsat, g_fsupsat, 'q+')
8256         CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't+')
8257         g_xni0 = 1.e3*EXP(0.1*supcol)*0.1*g_supcol
8258         xni0 = 1.e3*EXP(0.1*supcol)
8259         g_roqi0 = 4.92e-11*1.33*xni0**0.33*g_xni0
8260         roqi0 = 4.92e-11*xni0**1.33
8261         IF (qci(i, k, 2) .LT. 0.) THEN
8262           max11 = 0.
8263           g_max11 = 0.0_8
8264         ELSE
8265           g_max11 = g_qci(i, k, 2)
8266           max11 = qci(i, k, 2)
8267         END IF
8268         temp3 = roqi0/den(i, k)
8269         g_x7 = ((g_roqi0-temp3*g_den(i, k))/den(i, k)-g_max11)/dtcld
8270         x7 = (temp3-max11)/dtcld
8271         IF (x7 .GT. satdt) THEN
8272           g_pigen0 = g_satdt
8273           pigen0 = satdt
8274         ELSE
8275           g_pigen0 = g_x7
8276           pigen0 = x7
8277         END IF
8278         IF (pigen0 .LT. 0.) THEN
8279           g_pigen(i, k) = 0.0_8
8280           pigen(i, k) = 0.
8281         ELSE
8282           g_pigen(i, k) = g_pigen0
8283           pigen(i, k) = pigen0
8284         END IF
8285         g_pigen(i, k) = pigen(i, k)*(fsupsat*g_fsupcol+fsupcol*g_fsupsat&
8286 &         ) + fsupcol*fsupsat*g_pigen(i, k)
8287         pigen(i, k) = fsupcol*fsupsat*pigen(i, k)
8288         IF (pigen(i, k) .GE. 0.) THEN
8289           abs3 = pigen(i, k)
8290         ELSE
8291           abs3 = -pigen(i, k)
8292         END IF
8293         IF (abs3 .LT. qmin/dtcld) THEN
8294           g_pigen(i, k) = 0.0_8
8295           pigen(i, k) = 0.
8296         END IF
8297         IF (q(i, k) - pigen(i, k)*dtcld .LT. 0.) THEN
8298           g_q(i, k) = 0.0_8
8299           q(i, k) = 0.
8300         ELSE
8301           g_q(i, k) = g_q(i, k) - dtcld*g_pigen(i, k)
8302           q(i, k) = q(i, k) - pigen(i, k)*dtcld
8303         END IF
8304         IF (qci(i, k, 2) + pigen(i, k)*dtcld .LT. 0.) THEN
8305           g_qci(i, k, 2) = 0.0_8
8306           qci(i, k, 2) = 0.
8307         ELSE
8308           g_qci(i, k, 2) = g_qci(i, k, 2) + dtcld*g_pigen(i, k)
8309           qci(i, k, 2) = qci(i, k, 2) + pigen(i, k)*dtcld
8310         END IF
8311         temp3 = pigen(i, k)/cpm(i, k)
8312         g_t(i, k) = g_t(i, k) + dtcld*xls*(g_pigen(i, k)-temp3*g_cpm(i, &
8313 &         k))/cpm(i, k)
8314         t(i, k) = t(i, k) + dtcld*xls*temp3
8315         g_pigen(i, k) = 0.0_8
8316         pigen(i, k) = 0.
8317 !
8318 !------------------------------------------------------------
8319 ! psaut: conversion(aggregation) of ice to snow [HDC 12]
8320 !        (T<T0: I->S) psaut>0, min=0,max=(qci(i,k,2)-qimax)/dtcld
8321 !-------------------------------------------------------------
8322 !update supcol
8323         g_supcol = -g_t(i, k)
8324         supcol = t0c - t(i, k)
8325         CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't+')
8326 !         call smoothif(qci(i,k,2),0.,fqi,'q+')
8327         temp3 = roqimax/den(i, k)
8328         g_qimax = -(temp3*g_den(i, k)/den(i, k))
8329         qimax = temp3
8330         IF (0. .LT. (qci(i, k, 2)-qimax)/dtcld) THEN
8331           g_psaut(i, k) = (g_qci(i, k, 2)-g_qimax)/dtcld
8332           psaut(i, k) = (qci(i, k, 2)-qimax)/dtcld
8333         ELSE
8334           g_psaut(i, k) = 0.0_8
8335           psaut(i, k) = 0.
8336         END IF
8337         g_psaut(i, k) = psaut(i, k)*g_fsupcol + fsupcol*g_psaut(i, k)
8338         psaut(i, k) = fsupcol*psaut(i, k)
8339         IF (psaut(i, k) .GE. 0.) THEN
8340           abs4 = psaut(i, k)
8341         ELSE
8342           abs4 = -psaut(i, k)
8343         END IF
8344         IF (abs4 .LT. qmin/dtcld) THEN
8345           g_psaut(i, k) = 0.0_8
8346           psaut(i, k) = 0.
8347         END IF
8348         IF (qci(i, k, 2) - psaut(i, k)*dtcld .LT. 0.) THEN
8349           g_qci(i, k, 2) = 0.0_8
8350           qci(i, k, 2) = 0.
8351         ELSE
8352           g_qci(i, k, 2) = g_qci(i, k, 2) - dtcld*g_psaut(i, k)
8353           qci(i, k, 2) = qci(i, k, 2) - psaut(i, k)*dtcld
8354         END IF
8355         IF (qrs(i, k, 2) + psaut(i, k)*dtcld .LT. 0.) THEN
8356           g_qrs(i, k, 2) = 0.0_8
8357           qrs(i, k, 2) = 0.
8358         ELSE
8359           g_qrs(i, k, 2) = g_qrs(i, k, 2) + dtcld*g_psaut(i, k)
8360           qrs(i, k, 2) = qrs(i, k, 2) + psaut(i, k)*dtcld
8361         END IF
8362         g_psaut(i, k) = 0.0_8
8363         psaut(i, k) = 0.
8364 !
8365 !-------------------------------------------------------------
8366 ! pgaut: conversion(aggregation) of snow to graupel [LFO 37]
8367 !        (T<T0: S->G) pgaut>0 min=0.,max=qrs(i,k,2)/dtcld
8368 !-------------------------------------------------------------
8369 !update supcol
8370 !         supcol = t0c-t(i,k) ! not change
8371 !         call smoothif(supcol,0.,fsupcol,'t0')
8372 !         call smoothif(qrs(i,k,2),0.,fqs,'q+')
8373         g_alpha2 = -(1.e-3*EXP(-(0.09*supcol))*0.09*g_supcol)
8374         alpha2 = 1.e-3*EXP(0.09*(-supcol))
8375         IF (0. .LT. alpha2*(qrs(i, k, 2)-qs0)) THEN
8376           g_x8 = (qrs(i, k, 2)-qs0)*g_alpha2 + alpha2*g_qrs(i, k, 2)
8377           x8 = alpha2*(qrs(i, k, 2)-qs0)
8378         ELSE
8379           x8 = 0.
8380           g_x8 = 0.0_8
8381         END IF
8382         IF (x8 .GT. qrs(i, k, 2)/dtcld) THEN
8383           g_pgaut(i, k) = g_qrs(i, k, 2)/dtcld
8384           pgaut(i, k) = qrs(i, k, 2)/dtcld
8385         ELSE
8386           g_pgaut(i, k) = g_x8
8387           pgaut(i, k) = x8
8388         END IF
8389         g_pgaut(i, k) = pgaut(i, k)*g_fsupcol + fsupcol*g_pgaut(i, k)
8390         pgaut(i, k) = fsupcol*pgaut(i, k)
8391         IF (pgaut(i, k) .GE. 0.) THEN
8392           abs5 = pgaut(i, k)
8393         ELSE
8394           abs5 = -pgaut(i, k)
8395         END IF
8396         IF (abs5 .LT. qmin/dtcld) THEN
8397           g_pgaut(i, k) = 0.0_8
8398           pgaut(i, k) = 0.
8399         END IF
8400         IF (qrs(i, k, 2) - pgaut(i, k)*dtcld .LT. 0.) THEN
8401           g_qrs(i, k, 2) = 0.0_8
8402           qrs(i, k, 2) = 0.
8403         ELSE
8404           g_qrs(i, k, 2) = g_qrs(i, k, 2) - dtcld*g_pgaut(i, k)
8405           qrs(i, k, 2) = qrs(i, k, 2) - pgaut(i, k)*dtcld
8406         END IF
8407         IF (qrs(i, k, 3) + pgaut(i, k)*dtcld .LT. 0.) THEN
8408           g_qrs(i, k, 3) = 0.0_8
8409           qrs(i, k, 3) = 0.
8410         ELSE
8411           g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgaut(i, k)
8412           qrs(i, k, 3) = qrs(i, k, 3) + pgaut(i, k)*dtcld
8413         END IF
8414         g_pgaut(i, k) = 0.0_8
8415         pgaut(i, k) = 0.
8416 !
8417 !-------------------------------------------------------------
8418 ! psevp: Evaporation of melting snow [RH83 A27]
8419 !       (T>=T0: S->V) rh<1., psevp<0, min=-qrs(i,k,2)/dtcld, max=0.
8420 !-------------------------------------------------------------
8421 !         supcol = t0c-t(i,k) ! not change
8422 !update rh qs
8423         CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), &
8424 &               g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs&
8425 &               (i, k, :))
8426 !update xl, cpm
8427         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
8428         g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k))
8429         CALL G_SMOOTHIF(t(i, k), g_t(i, k), t0c, ft0, g_ft0, 't+')
8430         IF (90. .GT. t0c - t(i, k)) THEN
8431           g_y3 = -g_t(i, k)
8432           y3 = t0c - t(i, k)
8433         ELSE
8434           y3 = 90.
8435           g_y3 = 0.0_8
8436         END IF
8437         IF (0. .LT. y3) THEN
8438           g_max5 = g_y3
8439           max5 = y3
8440         ELSE
8441           max5 = 0.
8442           g_max5 = 0.0_8
8443         END IF
8444         IF (qrs(i, k, 2) .LT. qcrmin) THEN
8445           max12 = qcrmin
8446           g_max12 = 0.0_8
8447         ELSE
8448           g_max12 = g_qrs(i, k, 2)
8449           max12 = qrs(i, k, 2)
8450         END IF
8451         g_arg1 = alpha*g_max5/2.
8452         arg1 = alpha*max5/2.
8453         g_arg2 = max12*g_den(i, k) + den(i, k)*g_max12
8454         arg2 = den(i, k)*max12
8455         temp3 = SQRT(arg2)
8456         IF (arg2 .EQ. 0.0_8) THEN
8457           g_result1 = 0.0_8
8458         ELSE
8459           g_result1 = g_arg2/(2.0*temp3)
8460         END IF
8461         result1 = temp3
8462         temp3 = EXP(arg1)
8463         g_a = result1*EXP(arg1)*g_arg1 + temp3*g_result1
8464         a = temp3*result1
8465         IF (90. .GT. t0c - t(i, k)) THEN
8466           g_y4 = -g_t(i, k)
8467           y4 = t0c - t(i, k)
8468         ELSE
8469           y4 = 90.
8470           g_y4 = 0.0_8
8471         END IF
8472         IF (0. .LT. y4) THEN
8473           g_max6 = g_y4
8474           max6 = y4
8475         ELSE
8476           max6 = 0.
8477           g_max6 = 0.0_8
8478         END IF
8479         IF (qrs(i, k, 2) .LT. qcrmin) THEN
8480           max13 = qcrmin
8481           g_max13 = 0.0_8
8482         ELSE
8483           g_max13 = g_qrs(i, k, 2)
8484           max13 = qrs(i, k, 2)
8485         END IF
8486         g_arg1 = (3.-bvts)*alpha*g_max6/8.
8487         arg1 = (3.-bvts)*alpha*max6/8.
8488         g_pwx1 = g_t(i, k)
8489         pwx1 = t(i, k) + 120.
8490         IF (pwx1 .LE. 0.0_8 .AND. (1.0/6. .EQ. 0.0_8 .OR. 1.0/6. .NE. &
8491 &           INT(1.0/6.))) THEN
8492           g_pwr1 = 0.0_8
8493         ELSE
8494           g_pwr1 = pwx1**(1.0/6.-1)*g_pwx1/6.
8495         END IF
8496         pwr1 = pwx1**(1./6.)
8497         IF (t(i, k) .LE. 0.0_8 .AND. (5.12/6. .EQ. 0.0_8 .OR. 5.12/6. &
8498 &           .NE. INT(5.12/6.))) THEN
8499           g_pwr2 = 0.0_8
8500         ELSE
8501           g_pwr2 = 5.12*t(i, k)**(5.12/6.-1)*g_t(i, k)/6.
8502         END IF
8503         pwr2 = t(i, k)**(5.12/6.)
8504         IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. .NE.&
8505 &           INT(1.0/3.))) THEN
8506           g_pwr3 = 0.0_8
8507         ELSE
8508           g_pwr3 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3.
8509         END IF
8510         pwr3 = p(i, k)**(1./3.)
8511         pwy4 = (13.+3.*bvts)/24.
8512         IF (den(i, k) .LE. 0.0_8 .AND. (pwy4 .EQ. 0.0_8 .OR. pwy4 .NE. &
8513 &           INT(pwy4))) THEN
8514           g_pwr4 = 0.0_8
8515         ELSE
8516           g_pwr4 = pwy4*den(i, k)**(pwy4-1)*g_den(i, k)
8517         END IF
8518         pwr4 = den(i, k)**pwy4
8519         pwy5 = (5.+bvts)/8.
8520         IF (max13 .LE. 0.0_8 .AND. (pwy5 .EQ. 0.0_8 .OR. pwy5 .NE. INT(&
8521 &           pwy5))) THEN
8522           g_pwr5 = 0.0_8
8523         ELSE
8524           g_pwr5 = pwy5*max13**(pwy5-1)*g_max13
8525         END IF
8526         pwr5 = max13**pwy5
8527         temp3 = pwr1*pwr3/pwr2
8528         temp2 = temp3*pwr4*pwr5
8529         temp1 = EXP(arg1)
8530         g_b = temp2*EXP(arg1)*g_arg1 + temp1*(pwr4*pwr5*(pwr3*g_pwr1+&
8531 &         pwr1*g_pwr3-temp3*g_pwr2)/pwr2+temp3*(pwr5*g_pwr4+pwr4*g_pwr5)&
8532 &         )
8533         b = temp1*temp2
8534         temp3 = rv*t(i, k)**3.5
8535         temp2 = den(i, k)*(t(i, k)+120.)
8536         temp1 = xl(i, k)*xl(i, k)
8537         temp4 = temp1*temp2/temp3
8538         g_c = diffac_a*(temp2*2*xl(i, k)*g_xl(i, k)+temp1*((t(i, k)+120.&
8539 &         )*g_den(i, k)+den(i, k)*g_t(i, k))-temp4*rv*3.5*t(i, k)**2.5*&
8540 &         g_t(i, k))/temp3
8541         c = diffac_a*temp4
8542         temp4 = t(i, k)**1.81
8543         temp3 = temp4*qs(i, k, 1)
8544         temp2 = p(i, k)/temp3
8545         g_d = diffac_b*(g_p(i, k)-temp2*(qs(i, k, 1)*1.81*t(i, k)**0.81*&
8546 &         g_t(i, k)+temp4*g_qs(i, k, 1)))/temp3
8547         d = diffac_b*temp2
8548         temp4 = (rh(i, k, 1)-1.)/(c+d)
8549         g_e = (g_rh(i, k, 1)-temp4*(g_c+g_d))/(c+d)
8550         e = temp4
8551         temp4 = psevp_a*a + psevp_b*b
8552         g_psevp0 = temp4*g_e + e*(psevp_a*g_a+psevp_b*g_b)
8553         psevp0 = e*temp4
8554         IF (psevp0 .LT. -(qrs(i, k, 2)/dtcld)) THEN
8555           g_x9 = -(g_qrs(i, k, 2)/dtcld)
8556           x9 = -(qrs(i, k, 2)/dtcld)
8557         ELSE
8558           g_x9 = g_psevp0
8559           x9 = psevp0
8560         END IF
8561         IF (x9 .GT. 0.) THEN
8562           g_psevp(i, k) = 0.0_8
8563           psevp(i, k) = 0.
8564         ELSE
8565           g_psevp(i, k) = g_x9
8566           psevp(i, k) = x9
8567         END IF
8568         g_psevp(i, k) = psevp(i, k)*g_ft0 + ft0*g_psevp(i, k)
8569         psevp(i, k) = ft0*psevp(i, k)
8570         IF (psevp(i, k) .GE. 0.) THEN
8571           abs6 = psevp(i, k)
8572         ELSE
8573           abs6 = -psevp(i, k)
8574         END IF
8575         IF (abs6 .LT. qmin/dtcld) THEN
8576           g_psevp(i, k) = 0.0_8
8577           psevp(i, k) = 0.
8578         END IF
8579         IF (q(i, k) - psevp(i, k)*dtcld .LT. 0.) THEN
8580           g_q(i, k) = 0.0_8
8581           q(i, k) = 0.
8582         ELSE
8583           g_q(i, k) = g_q(i, k) - dtcld*g_psevp(i, k)
8584           q(i, k) = q(i, k) - psevp(i, k)*dtcld
8585         END IF
8586         IF (qrs(i, k, 2) + psevp(i, k)*dtcld .LT. 0.) THEN
8587           g_qrs(i, k, 2) = 0.0_8
8588           qrs(i, k, 2) = 0.
8589         ELSE
8590           g_qrs(i, k, 2) = g_qrs(i, k, 2) + dtcld*g_psevp(i, k)
8591           qrs(i, k, 2) = qrs(i, k, 2) + psevp(i, k)*dtcld
8592         END IF
8593         temp4 = psevp(i, k)/cpm(i, k)
8594         g_t(i, k) = g_t(i, k) + dtcld*xls*(g_psevp(i, k)-temp4*g_cpm(i, &
8595 &         k))/cpm(i, k)
8596         t(i, k) = t(i, k) + dtcld*xls*temp4
8597         g_psevp(i, k) = 0.0_8
8598         psevp(i, k) = 0.
8599 !
8600 !-------------------------------------------------------------
8601 ! pgevp: Evaporation of melting graupel [RH84 A19]
8602 !       (T>=T0: G->V) rh<1., pgevp<0, min=-qrs(i,k,3)/dtcld, max=0.
8603 !-------------------------------------------------------------
8604         supcol = t0c - t(i, k)
8605 !update rh qs
8606         CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), &
8607 &               g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs&
8608 &               (i, k, :))
8609 !update xl, cpm
8610         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
8611         g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k))
8612         CALL G_SMOOTHIF(t(i, k), g_t(i, k), t0c, ft0, g_ft0, 't0')
8613         IF (qrs(i, k, 3) .LT. qcrmin) THEN
8614           max7 = qcrmin
8615           g_max7 = 0.0_8
8616         ELSE
8617           g_max7 = g_qrs(i, k, 3)
8618           max7 = qrs(i, k, 3)
8619         END IF
8620         temp4 = den(i, k)*max7
8621         temp3 = SQRT(temp4)
8622         IF (temp4 .EQ. 0.0_8) THEN
8623           g_a = 0.0_8
8624         ELSE
8625           g_a = (max7*g_den(i, k)+den(i, k)*g_max7)/(2.0*temp3)
8626         END IF
8627         a = temp3
8628         IF (qrs(i, k, 3) .LT. qcrmin) THEN
8629           max8 = qcrmin
8630           g_max8 = 0.0_8
8631         ELSE
8632           g_max8 = g_qrs(i, k, 3)
8633           max8 = qrs(i, k, 3)
8634         END IF
8635         g_pwx1 = g_t(i, k)
8636         pwx1 = t(i, k) + 120.
8637         IF (pwx1 .LE. 0.0_8 .AND. (1.0/6. .EQ. 0.0_8 .OR. 1.0/6. .NE. &
8638 &           INT(1.0/6.))) THEN
8639           g_pwr1 = 0.0_8
8640         ELSE
8641           g_pwr1 = pwx1**(1.0/6.-1)*g_pwx1/6.
8642         END IF
8643         pwr1 = pwx1**(1./6.)
8644         IF (t(i, k) .LE. 0.0_8 .AND. (5.12/6. .EQ. 0.0_8 .OR. 5.12/6. &
8645 &           .NE. INT(5.12/6.))) THEN
8646           g_pwr2 = 0.0_8
8647         ELSE
8648           g_pwr2 = 5.12*t(i, k)**(5.12/6.-1)*g_t(i, k)/6.
8649         END IF
8650         pwr2 = t(i, k)**(5.12/6.)
8651         IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. .NE.&
8652 &           INT(1.0/3.))) THEN
8653           g_pwr3 = 0.0_8
8654         ELSE
8655           g_pwr3 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3.
8656         END IF
8657         pwr3 = p(i, k)**(1./3.)
8658         pwy4 = (13.+3.*bvtg)/24.
8659         IF (den(i, k) .LE. 0.0_8 .AND. (pwy4 .EQ. 0.0_8 .OR. pwy4 .NE. &
8660 &           INT(pwy4))) THEN
8661           g_pwr4 = 0.0_8
8662         ELSE
8663           g_pwr4 = pwy4*den(i, k)**(pwy4-1)*g_den(i, k)
8664         END IF
8665         pwr4 = den(i, k)**pwy4
8666         pwy5 = (5.+bvtg)/8.
8667         IF (max8 .LE. 0.0_8 .AND. (pwy5 .EQ. 0.0_8 .OR. pwy5 .NE. INT(&
8668 &           pwy5))) THEN
8669           g_pwr5 = 0.0_8
8670         ELSE
8671           g_pwr5 = pwy5*max8**(pwy5-1)*g_max8
8672         END IF
8673         pwr5 = max8**pwy5
8674         temp4 = pwr1*pwr3/pwr2
8675         g_b = pwr4*pwr5*(pwr3*g_pwr1+pwr1*g_pwr3-temp4*g_pwr2)/pwr2 + &
8676 &         temp4*(pwr5*g_pwr4+pwr4*g_pwr5)
8677         b = temp4*(pwr4*pwr5)
8678         temp4 = rv*t(i, k)**3.5
8679         temp3 = den(i, k)*(t(i, k)+120.)
8680         temp2 = xl(i, k)*xl(i, k)
8681         temp1 = temp2*temp3/temp4
8682         g_c = diffac_a*(temp3*2*xl(i, k)*g_xl(i, k)+temp2*((t(i, k)+120.&
8683 &         )*g_den(i, k)+den(i, k)*g_t(i, k))-temp1*rv*3.5*t(i, k)**2.5*&
8684 &         g_t(i, k))/temp4
8685         c = diffac_a*temp1
8686         temp4 = t(i, k)**1.81
8687         temp3 = temp4*qs(i, k, 1)
8688         temp2 = p(i, k)/temp3
8689         g_d = diffac_b*(g_p(i, k)-temp2*(qs(i, k, 1)*1.81*t(i, k)**0.81*&
8690 &         g_t(i, k)+temp4*g_qs(i, k, 1)))/temp3
8691         d = diffac_b*temp2
8692         temp4 = (rh(i, k, 1)-1.)/(c+d)
8693         g_e = (g_rh(i, k, 1)-temp4*(g_c+g_d))/(c+d)
8694         e = temp4
8695         temp4 = pgevp_a*a + pgevp_b*b
8696         g_pgevp0 = temp4*g_e + e*(pgevp_a*g_a+pgevp_b*g_b)
8697         pgevp0 = e*temp4
8698         IF (pgevp0 .LT. -(qrs(i, k, 3)/dtcld)) THEN
8699           g_x10 = -(g_qrs(i, k, 3)/dtcld)
8700           x10 = -(qrs(i, k, 3)/dtcld)
8701         ELSE
8702           g_x10 = g_pgevp0
8703           x10 = pgevp0
8704         END IF
8705         IF (x10 .GT. 0.) THEN
8706           g_pgevp(i, k) = 0.0_8
8707           pgevp(i, k) = 0.
8708         ELSE
8709           g_pgevp(i, k) = g_x10
8710           pgevp(i, k) = x10
8711         END IF
8712         g_pgevp(i, k) = pgevp(i, k)*g_ft0 + ft0*g_pgevp(i, k)
8713         pgevp(i, k) = ft0*pgevp(i, k)
8714         IF (pgevp(i, k) .GE. 0.) THEN
8715           abs7 = pgevp(i, k)
8716         ELSE
8717           abs7 = -pgevp(i, k)
8718         END IF
8719         IF (abs7 .LT. qmin/dtcld) THEN
8720           g_pgevp(i, k) = 0.0_8
8721           pgevp(i, k) = 0.
8722         END IF
8723         IF (q(i, k) - pgevp(i, k)*dtcld .LT. 0.) THEN
8724           g_q(i, k) = 0.0_8
8725           q(i, k) = 0.
8726         ELSE
8727           g_q(i, k) = g_q(i, k) - dtcld*g_pgevp(i, k)
8728           q(i, k) = q(i, k) - pgevp(i, k)*dtcld
8729         END IF
8730         IF (qrs(i, k, 3) + pgevp(i, k)*dtcld .LT. 0.) THEN
8731           g_qrs(i, k, 3) = 0.0_8
8732           qrs(i, k, 3) = 0.
8733         ELSE
8734           g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgevp(i, k)
8735           qrs(i, k, 3) = qrs(i, k, 3) + pgevp(i, k)*dtcld
8736         END IF
8737         temp4 = pgevp(i, k)/cpm(i, k)
8738         g_t(i, k) = g_t(i, k) + dtcld*xls*(g_pgevp(i, k)-temp4*g_cpm(i, &
8739 &         k))/cpm(i, k)
8740         t(i, k) = t(i, k) + dtcld*xls*temp4
8741         g_pgevp(i, k) = 0.0_8
8742         pgevp(i, k) = 0.
8743       END DO
8744     END DO
8745   END SUBROUTINE G_ACCRET3
8746
8747 !=======================================================================
8748 !
8749 !=======================================================================
8750   SUBROUTINE ACCRET3(qrs, qci, rh, t, p, den, dtcld, q, qs, psdep, pgdep&
8751 &   , pigen, psaut, pgaut, psevp, pgevp, pidep, ims, ime, kms, kme, its&
8752 &   , ite, kts, kte)
8753     IMPLICIT NONE
8754     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
8755 !-------------------------------------------------------------------
8756     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
8757     REAL, DIMENSION(ims:ime, kms:kme) :: den, q, p
8758     REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, rh, qs
8759     REAL, DIMENSION(its:ite, kts:kte) :: pigen, psevp, pgevp, pidep, t, &
8760 &   xl, cpm, psdep, pgdep, psaut, pgaut
8761     REAL :: supcol, dtcld, satdt, supsat, qimax, diameter, xni0, roqi0, &
8762 &   supice1, supice2, supice3, supice4, alpha2
8763     REAL :: pidep0, pidep1, psdep0, pgdep3, pigen0, psevp0, pgevp0, &
8764 &   coeres1, coeres2, coeres3, coeres4
8765     REAL :: temp0, temp, xmi
8766     INTEGER :: i, k
8767     REAL :: fqi, fqr, fqv, fqs, fqg, frh, ft0, fpidep, fpsdep, fpgdep, &
8768 &   fsupcol, fsupsat, pidep2
8769     REAL :: value01, factor01, source01, vice, a, b, c, d, e, f, g
8770     INTRINSIC MAX
8771     INTRINSIC MIN
8772     INTRINSIC ABS
8773     INTRINSIC EXP
8774     INTRINSIC SQRT
8775     REAL :: x1
8776     REAL :: x2
8777     REAL :: y1
8778     REAL :: y2
8779     REAL :: x3
8780     REAL :: x4
8781     REAL :: x5
8782     REAL :: x6
8783     REAL :: x7
8784     REAL :: x8
8785     REAL :: y3
8786     REAL :: y4
8787     REAL :: x9
8788     REAL :: x10
8789     REAL :: abs0
8790     REAL :: max1
8791     REAL :: max2
8792     REAL :: abs1
8793     REAL :: max3
8794     REAL :: max4
8795     REAL :: abs2
8796     REAL :: abs3
8797     REAL :: abs4
8798     REAL :: abs5
8799     REAL :: max5
8800     REAL :: max6
8801     REAL :: abs6
8802     REAL :: max7
8803     REAL :: max8
8804     REAL :: abs7
8805     REAL :: max9
8806     REAL :: max10
8807     REAL :: max11
8808     REAL :: max12
8809     REAL :: max13
8810     REAL :: pwx1
8811     REAL :: pwr1
8812     REAL :: arg1
8813     REAL :: arg2
8814     REAL :: result1
8815     REAL :: pwr2
8816     REAL :: pwr3
8817     REAL :: pwy4
8818     REAL :: pwr4
8819     REAL :: pwy5
8820     REAL :: pwr5
8821     DO k=kts,kte
8822       DO i=its,ite
8823 !
8824 !-------------------------------------------------------------
8825 ! pidep: Deposition/Sublimation rate of ice [HDC 9]
8826 !       (T<T0: V->I or I->V)
8827 !       rh(i,k,2)>1.,pidep>0: V->I, min=0,        max=satdt
8828 !       rh(i,k,2)<1.,pidep<0: I->V, min=-qi/dtcld,max=0,
8829 !-------------------------------------------------------------
8830 !update supcol
8831         supcol = t0c - t(i, k)
8832 !update rh qs
8833         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
8834 !update satdt
8835         supsat = q(i, k) - qs(i, k, 2)
8836         satdt = supsat/dtcld
8837 !update xl, cpm
8838         xl(i, k) = XLCAL(t(i, k))
8839         cpm(i, k) = CPMCAL(q(i, k))
8840         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
8841         IF (qci(i, k, 2) .GT. 0.) THEN
8842           b = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5
8843           c = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2)
8844           a = (rh(i, k, 2)-1.)/(b+c)
8845           pwx1 = den(i, k)*qci(i, k, 2)
8846           pwr1 = pwx1**(7./8.)
8847           pidep0 = pidep_a*a*pwr1
8848         ELSE
8849           pidep0 = 0.
8850         END IF
8851         IF (pidep0 .LT. 0.) THEN
8852           IF (pidep0 .LT. -(qci(i, k, 2)/dtcld)) THEN
8853             x1 = -(qci(i, k, 2)/dtcld)
8854           ELSE
8855             x1 = pidep0
8856           END IF
8857           IF (x1 .GT. 0.) THEN
8858             pidep(i, k) = 0.
8859           ELSE
8860             pidep(i, k) = x1
8861           END IF
8862         ELSE
8863           IF (pidep0 .GT. satdt) THEN
8864             x2 = satdt
8865           ELSE
8866             x2 = pidep0
8867           END IF
8868           IF (x2 .LT. 0.) THEN
8869             pidep(i, k) = 0.
8870           ELSE
8871             pidep(i, k) = x2
8872           END IF
8873         END IF
8874         pidep(i, k) = fsupcol*pidep(i, k)
8875         IF (pidep(i, k) .GE. 0.) THEN
8876           abs0 = pidep(i, k)
8877         ELSE
8878           abs0 = -pidep(i, k)
8879         END IF
8880         IF (abs0 .LT. qmin/dtcld) pidep(i, k) = 0.
8881         IF (q(i, k) - pidep(i, k)*dtcld .LT. 0.) THEN
8882           q(i, k) = 0.
8883         ELSE
8884           q(i, k) = q(i, k) - pidep(i, k)*dtcld
8885         END IF
8886         IF (qci(i, k, 2) + pidep(i, k)*dtcld .LT. 0.) THEN
8887           qci(i, k, 2) = 0.
8888         ELSE
8889           qci(i, k, 2) = qci(i, k, 2) + pidep(i, k)*dtcld
8890         END IF
8891         t(i, k) = t(i, k) + pidep(i, k)*dtcld*xls/cpm(i, k)
8892         pidep(i, k) = 0.
8893 !
8894 !-------------------------------------------------------------
8895 ! psdep: deposition/sublimation rate of snow [HDC 14]
8896 !        (T<T0: V->S or S->V)
8897 !       rh(i,k,2)>1.,psdep>0: V->S, min=0,        max=satdt
8898 !       rh(i,k,2)<1.,psdep<0: S->V, min=-qs/dtcld,max=0,
8899 !-------------------------------------------------------------
8900 !update supcol
8901         supcol = t0c - t(i, k)
8902 !update rh qs
8903         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
8904 !update satdt
8905         supsat = q(i, k) - qs(i, k, 2)
8906         satdt = supsat/dtcld
8907 !update xl, cpm
8908         xl(i, k) = XLCAL(t(i, k))
8909         cpm(i, k) = CPMCAL(q(i, k))
8910         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
8911         IF (90. .GT. t0c - t(i, k)) THEN
8912           y1 = t0c - t(i, k)
8913         ELSE
8914           y1 = 90.
8915         END IF
8916         IF (0. .LT. y1) THEN
8917           max1 = y1
8918         ELSE
8919           max1 = 0.
8920         END IF
8921         IF (qrs(i, k, 2) .LT. qcrmin) THEN
8922           max9 = qcrmin
8923         ELSE
8924           max9 = qrs(i, k, 2)
8925         END IF
8926 !         call smoothif(qrs(i,k,2),0.,fqs,'q+')
8927 !         call smoothif(q  (i,k  ),0.,fqv,'q+')
8928         arg1 = alpha*max1/2.
8929         arg2 = den(i, k)*max9
8930         result1 = SQRT(arg2)
8931         a = EXP(arg1)*result1
8932         IF (90. .GT. t0c - t(i, k)) THEN
8933           y2 = t0c - t(i, k)
8934         ELSE
8935           y2 = 90.
8936         END IF
8937         IF (0. .LT. y2) THEN
8938           max2 = y2
8939         ELSE
8940           max2 = 0.
8941         END IF
8942         IF (qrs(i, k, 2) .LT. qcrmin) THEN
8943           max10 = qcrmin
8944         ELSE
8945           max10 = qrs(i, k, 2)
8946         END IF
8947         arg1 = (3.-bvts)*alpha*max2/8.
8948         pwx1 = t(i, k) + 120.
8949         pwr1 = pwx1**(1./6.)
8950         pwr2 = t(i, k)**(5.12/6.)
8951         pwr3 = p(i, k)**(1./3.)
8952         pwy4 = (13.+3.*bvts)/24.
8953         pwr4 = den(i, k)**pwy4
8954         pwy5 = (5.+bvts)/8.
8955         pwr5 = max10**pwy5
8956         b = EXP(arg1)*pwr1/pwr2*pwr3*pwr4*pwr5
8957         c = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5
8958         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2)
8959         e = (rh(i, k, 2)-1.)/(c+d)
8960         psdep0 = e*(psdep_a*a+psdep_b*b)
8961         IF (psdep0 .LT. 0.) THEN
8962           IF (psdep0 .LT. -(qrs(i, k, 2)/dtcld)) THEN
8963             x3 = -(qrs(i, k, 2)/dtcld)
8964           ELSE
8965             x3 = psdep0
8966           END IF
8967           IF (x3 .GT. 0.) THEN
8968             psdep(i, k) = 0.
8969           ELSE
8970             psdep(i, k) = x3
8971           END IF
8972         ELSE
8973           IF (psdep0 .GT. satdt) THEN
8974             x4 = satdt
8975           ELSE
8976             x4 = psdep0
8977           END IF
8978           IF (x4 .LT. 0.) THEN
8979             psdep(i, k) = 0.
8980           ELSE
8981             psdep(i, k) = x4
8982           END IF
8983         END IF
8984         psdep(i, k) = fsupcol*psdep(i, k)
8985         IF (psdep(i, k) .GE. 0.) THEN
8986           abs1 = psdep(i, k)
8987         ELSE
8988           abs1 = -psdep(i, k)
8989         END IF
8990         IF (abs1 .LT. qmin/dtcld) psdep(i, k) = 0.
8991         IF (q(i, k) - psdep(i, k)*dtcld .LT. 0.) THEN
8992           q(i, k) = 0.
8993         ELSE
8994           q(i, k) = q(i, k) - psdep(i, k)*dtcld
8995         END IF
8996         IF (qrs(i, k, 2) + psdep(i, k)*dtcld .LT. 0.) THEN
8997           qrs(i, k, 2) = 0.
8998         ELSE
8999           qrs(i, k, 2) = qrs(i, k, 2) + psdep(i, k)*dtcld
9000         END IF
9001         t(i, k) = t(i, k) + psdep(i, k)*dtcld*xls/cpm(i, k)
9002         psdep(i, k) = 0.
9003 !
9004 !------------------------------------------------------------
9005 ! pgdep: deposition/sublimation rate of graupel [LFO 46]
9006 !        (T<T0: V->G or G->V)
9007 !       rh(i,k,2)>1.,pgdep>0: V->G, min=0,        max=satdt
9008 !       rh(i,k,2)<1.,pgdep<0: G->V, min=-qg/dtcld,max=0,
9009 !------------------------------------------------------------
9010 !update supcol
9011         supcol = t0c - t(i, k)
9012 !update rh qs
9013         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
9014 !update satdt
9015         supsat = q(i, k) - qs(i, k, 2)
9016         satdt = supsat/dtcld
9017 !update xl, cpm
9018         xl(i, k) = XLCAL(t(i, k))
9019         cpm(i, k) = CPMCAL(q(i, k))
9020         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
9021         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9022           max3 = qcrmin
9023         ELSE
9024           max3 = qrs(i, k, 3)
9025         END IF
9026 !         call smoothif(qrs(i,k,3),0.,fqg,'q+')
9027 !         call smoothif(q  (i,k  ),0.,fqv,'q+')
9028         a = SQRT(den(i, k)*max3)
9029         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9030           max4 = qcrmin
9031         ELSE
9032           max4 = qrs(i, k, 3)
9033         END IF
9034         pwx1 = t(i, k) + 120.
9035         pwr1 = pwx1**(1./6.)
9036         pwr2 = t(i, k)**(5.12/6.)
9037         pwr3 = p(i, k)**(1./3.)
9038         pwy4 = (13.+3.*bvtg)/24.
9039         pwr4 = den(i, k)**pwy4
9040         pwy5 = (5.+bvtg)/8.
9041         pwr5 = max4**pwy5
9042         b = pwr1/pwr2*pwr3*pwr4*pwr5
9043         c = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5
9044         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2)
9045         e = (rh(i, k, 2)-1.)/(c+d)
9046         pgdep3 = e*(pgdep_a*a+pgdep_b*b)
9047         IF (pgdep3 .LT. 0.) THEN
9048           IF (pgdep3 .LT. -(qrs(i, k, 3)/dtcld)) THEN
9049             x5 = -(qrs(i, k, 3)/dtcld)
9050           ELSE
9051             x5 = pgdep3
9052           END IF
9053           IF (x5 .GT. 0.) THEN
9054             pgdep(i, k) = 0.
9055           ELSE
9056             pgdep(i, k) = x5
9057           END IF
9058         ELSE
9059           IF (pgdep3 .GT. satdt) THEN
9060             x6 = satdt
9061           ELSE
9062             x6 = pgdep3
9063           END IF
9064           IF (x6 .LT. 0.) THEN
9065             pgdep(i, k) = 0.
9066           ELSE
9067             pgdep(i, k) = x6
9068           END IF
9069         END IF
9070         pgdep(i, k) = fsupcol*pgdep(i, k)
9071         IF (pgdep(i, k) .GE. 0.) THEN
9072           abs2 = pgdep(i, k)
9073         ELSE
9074           abs2 = -pgdep(i, k)
9075         END IF
9076         IF (abs2 .LT. qmin/dtcld) pgdep(i, k) = 0.
9077         IF (q(i, k) - pgdep(i, k)*dtcld .LT. 0.) THEN
9078           q(i, k) = 0.
9079         ELSE
9080           q(i, k) = q(i, k) - pgdep(i, k)*dtcld
9081         END IF
9082         IF (qrs(i, k, 3) + pgdep(i, k)*dtcld .LT. 0.) THEN
9083           qrs(i, k, 3) = 0.
9084         ELSE
9085           qrs(i, k, 3) = qrs(i, k, 3) + pgdep(i, k)*dtcld
9086         END IF
9087         t(i, k) = t(i, k) + pgdep(i, k)*dtcld*xls/cpm(i, k)
9088         pgdep(i, k) = 0.
9089 !-------------------------------------------------------------
9090 ! pigen: generation(nucleation) of ice from vapor [HDC 7-8]
9091 !       (T<T0: V->I) min=0,max=min(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld,satdt)
9092 !-------------------------------------------------------------
9093 !update supcol
9094         supcol = t0c - t(i, k)
9095         cpm(i, k) = CPMCAL(q(i, k))
9096 !update rh qs
9097         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
9098 !update satdt
9099         supsat = q(i, k) - qs(i, k, 2)
9100         satdt = supsat/dtcld
9101         CALL SMOOTHIF(supsat, 0., fsupsat, 'q+')
9102         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
9103         xni0 = 1.e3*EXP(0.1*supcol)
9104         roqi0 = 4.92e-11*xni0**1.33
9105         IF (qci(i, k, 2) .LT. 0.) THEN
9106           max11 = 0.
9107         ELSE
9108           max11 = qci(i, k, 2)
9109         END IF
9110         x7 = (roqi0/den(i, k)-max11)/dtcld
9111         IF (x7 .GT. satdt) THEN
9112           pigen0 = satdt
9113         ELSE
9114           pigen0 = x7
9115         END IF
9116         IF (pigen0 .LT. 0.) THEN
9117           pigen(i, k) = 0.
9118         ELSE
9119           pigen(i, k) = pigen0
9120         END IF
9121         pigen(i, k) = fsupcol*fsupsat*pigen(i, k)
9122         IF (pigen(i, k) .GE. 0.) THEN
9123           abs3 = pigen(i, k)
9124         ELSE
9125           abs3 = -pigen(i, k)
9126         END IF
9127         IF (abs3 .LT. qmin/dtcld) pigen(i, k) = 0.
9128         IF (q(i, k) - pigen(i, k)*dtcld .LT. 0.) THEN
9129           q(i, k) = 0.
9130         ELSE
9131           q(i, k) = q(i, k) - pigen(i, k)*dtcld
9132         END IF
9133         IF (qci(i, k, 2) + pigen(i, k)*dtcld .LT. 0.) THEN
9134           qci(i, k, 2) = 0.
9135         ELSE
9136           qci(i, k, 2) = qci(i, k, 2) + pigen(i, k)*dtcld
9137         END IF
9138         t(i, k) = t(i, k) + pigen(i, k)*dtcld*xls/cpm(i, k)
9139         pigen(i, k) = 0.
9140 !
9141 !------------------------------------------------------------
9142 ! psaut: conversion(aggregation) of ice to snow [HDC 12]
9143 !        (T<T0: I->S) psaut>0, min=0,max=(qci(i,k,2)-qimax)/dtcld
9144 !-------------------------------------------------------------
9145 !update supcol
9146         supcol = t0c - t(i, k)
9147         CALL SMOOTHIF(supcol, 0., fsupcol, 't+')
9148 !         call smoothif(qci(i,k,2),0.,fqi,'q+')
9149         qimax = roqimax/den(i, k)
9150         IF (0. .LT. (qci(i, k, 2)-qimax)/dtcld) THEN
9151           psaut(i, k) = (qci(i, k, 2)-qimax)/dtcld
9152         ELSE
9153           psaut(i, k) = 0.
9154         END IF
9155         psaut(i, k) = fsupcol*psaut(i, k)
9156         IF (psaut(i, k) .GE. 0.) THEN
9157           abs4 = psaut(i, k)
9158         ELSE
9159           abs4 = -psaut(i, k)
9160         END IF
9161         IF (abs4 .LT. qmin/dtcld) psaut(i, k) = 0.
9162         IF (qci(i, k, 2) - psaut(i, k)*dtcld .LT. 0.) THEN
9163           qci(i, k, 2) = 0.
9164         ELSE
9165           qci(i, k, 2) = qci(i, k, 2) - psaut(i, k)*dtcld
9166         END IF
9167         IF (qrs(i, k, 2) + psaut(i, k)*dtcld .LT. 0.) THEN
9168           qrs(i, k, 2) = 0.
9169         ELSE
9170           qrs(i, k, 2) = qrs(i, k, 2) + psaut(i, k)*dtcld
9171         END IF
9172         psaut(i, k) = 0.
9173 !
9174 !-------------------------------------------------------------
9175 ! pgaut: conversion(aggregation) of snow to graupel [LFO 37]
9176 !        (T<T0: S->G) pgaut>0 min=0.,max=qrs(i,k,2)/dtcld
9177 !-------------------------------------------------------------
9178 !update supcol
9179 !         supcol = t0c-t(i,k) ! not change
9180 !         call smoothif(supcol,0.,fsupcol,'t0')
9181 !         call smoothif(qrs(i,k,2),0.,fqs,'q+')
9182         alpha2 = 1.e-3*EXP(0.09*(-supcol))
9183         IF (0. .LT. alpha2*(qrs(i, k, 2)-qs0)) THEN
9184           x8 = alpha2*(qrs(i, k, 2)-qs0)
9185         ELSE
9186           x8 = 0.
9187         END IF
9188         IF (x8 .GT. qrs(i, k, 2)/dtcld) THEN
9189           pgaut(i, k) = qrs(i, k, 2)/dtcld
9190         ELSE
9191           pgaut(i, k) = x8
9192         END IF
9193         pgaut(i, k) = fsupcol*pgaut(i, k)
9194         IF (pgaut(i, k) .GE. 0.) THEN
9195           abs5 = pgaut(i, k)
9196         ELSE
9197           abs5 = -pgaut(i, k)
9198         END IF
9199         IF (abs5 .LT. qmin/dtcld) pgaut(i, k) = 0.
9200         IF (qrs(i, k, 2) - pgaut(i, k)*dtcld .LT. 0.) THEN
9201           qrs(i, k, 2) = 0.
9202         ELSE
9203           qrs(i, k, 2) = qrs(i, k, 2) - pgaut(i, k)*dtcld
9204         END IF
9205         IF (qrs(i, k, 3) + pgaut(i, k)*dtcld .LT. 0.) THEN
9206           qrs(i, k, 3) = 0.
9207         ELSE
9208           qrs(i, k, 3) = qrs(i, k, 3) + pgaut(i, k)*dtcld
9209         END IF
9210         pgaut(i, k) = 0.
9211 !
9212 !-------------------------------------------------------------
9213 ! psevp: Evaporation of melting snow [RH83 A27]
9214 !       (T>=T0: S->V) rh<1., psevp<0, min=-qrs(i,k,2)/dtcld, max=0.
9215 !-------------------------------------------------------------
9216 !         supcol = t0c-t(i,k) ! not change
9217 !update rh qs
9218         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
9219 !update xl, cpm
9220         xl(i, k) = XLCAL(t(i, k))
9221         cpm(i, k) = CPMCAL(q(i, k))
9222         CALL SMOOTHIF(t(i, k), t0c, ft0, 't+')
9223         IF (90. .GT. t0c - t(i, k)) THEN
9224           y3 = t0c - t(i, k)
9225         ELSE
9226           y3 = 90.
9227         END IF
9228         IF (0. .LT. y3) THEN
9229           max5 = y3
9230         ELSE
9231           max5 = 0.
9232         END IF
9233         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9234           max12 = qcrmin
9235         ELSE
9236           max12 = qrs(i, k, 2)
9237         END IF
9238         arg1 = alpha*max5/2.
9239         arg2 = den(i, k)*max12
9240         result1 = SQRT(arg2)
9241         a = EXP(arg1)*result1
9242         IF (90. .GT. t0c - t(i, k)) THEN
9243           y4 = t0c - t(i, k)
9244         ELSE
9245           y4 = 90.
9246         END IF
9247         IF (0. .LT. y4) THEN
9248           max6 = y4
9249         ELSE
9250           max6 = 0.
9251         END IF
9252         IF (qrs(i, k, 2) .LT. qcrmin) THEN
9253           max13 = qcrmin
9254         ELSE
9255           max13 = qrs(i, k, 2)
9256         END IF
9257         arg1 = (3.-bvts)*alpha*max6/8.
9258         pwx1 = t(i, k) + 120.
9259         pwr1 = pwx1**(1./6.)
9260         pwr2 = t(i, k)**(5.12/6.)
9261         pwr3 = p(i, k)**(1./3.)
9262         pwy4 = (13.+3.*bvts)/24.
9263         pwr4 = den(i, k)**pwy4
9264         pwy5 = (5.+bvts)/8.
9265         pwr5 = max13**pwy5
9266         b = EXP(arg1)*pwr1/pwr2*pwr3*pwr4*pwr5
9267         c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, &
9268 &         k)**3.5
9269         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1)
9270         e = (rh(i, k, 1)-1.)/(c+d)
9271         psevp0 = e*(psevp_a*a+psevp_b*b)
9272         IF (psevp0 .LT. -(qrs(i, k, 2)/dtcld)) THEN
9273           x9 = -(qrs(i, k, 2)/dtcld)
9274         ELSE
9275           x9 = psevp0
9276         END IF
9277         IF (x9 .GT. 0.) THEN
9278           psevp(i, k) = 0.
9279         ELSE
9280           psevp(i, k) = x9
9281         END IF
9282         psevp(i, k) = ft0*psevp(i, k)
9283         IF (psevp(i, k) .GE. 0.) THEN
9284           abs6 = psevp(i, k)
9285         ELSE
9286           abs6 = -psevp(i, k)
9287         END IF
9288         IF (abs6 .LT. qmin/dtcld) psevp(i, k) = 0.
9289         IF (q(i, k) - psevp(i, k)*dtcld .LT. 0.) THEN
9290           q(i, k) = 0.
9291         ELSE
9292           q(i, k) = q(i, k) - psevp(i, k)*dtcld
9293         END IF
9294         IF (qrs(i, k, 2) + psevp(i, k)*dtcld .LT. 0.) THEN
9295           qrs(i, k, 2) = 0.
9296         ELSE
9297           qrs(i, k, 2) = qrs(i, k, 2) + psevp(i, k)*dtcld
9298         END IF
9299         t(i, k) = t(i, k) + psevp(i, k)*dtcld*xls/cpm(i, k)
9300         psevp(i, k) = 0.
9301 !
9302 !-------------------------------------------------------------
9303 ! pgevp: Evaporation of melting graupel [RH84 A19]
9304 !       (T>=T0: G->V) rh<1., pgevp<0, min=-qrs(i,k,3)/dtcld, max=0.
9305 !-------------------------------------------------------------
9306         supcol = t0c - t(i, k)
9307 !update rh qs
9308         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
9309 !update xl, cpm
9310         xl(i, k) = XLCAL(t(i, k))
9311         cpm(i, k) = CPMCAL(q(i, k))
9312         CALL SMOOTHIF(t(i, k), t0c, ft0, 't0')
9313         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9314           max7 = qcrmin
9315         ELSE
9316           max7 = qrs(i, k, 3)
9317         END IF
9318         a = SQRT(den(i, k)*max7)
9319         IF (qrs(i, k, 3) .LT. qcrmin) THEN
9320           max8 = qcrmin
9321         ELSE
9322           max8 = qrs(i, k, 3)
9323         END IF
9324         pwx1 = t(i, k) + 120.
9325         pwr1 = pwx1**(1./6.)
9326         pwr2 = t(i, k)**(5.12/6.)
9327         pwr3 = p(i, k)**(1./3.)
9328         pwy4 = (13.+3.*bvtg)/24.
9329         pwr4 = den(i, k)**pwy4
9330         pwy5 = (5.+bvtg)/8.
9331         pwr5 = max8**pwy5
9332         b = pwr1/pwr2*pwr3*pwr4*pwr5
9333         c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, &
9334 &         k)**3.5
9335         d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1)
9336         e = (rh(i, k, 1)-1.)/(c+d)
9337         pgevp0 = e*(pgevp_a*a+pgevp_b*b)
9338         IF (pgevp0 .LT. -(qrs(i, k, 3)/dtcld)) THEN
9339           x10 = -(qrs(i, k, 3)/dtcld)
9340         ELSE
9341           x10 = pgevp0
9342         END IF
9343         IF (x10 .GT. 0.) THEN
9344           pgevp(i, k) = 0.
9345         ELSE
9346           pgevp(i, k) = x10
9347         END IF
9348         pgevp(i, k) = ft0*pgevp(i, k)
9349         IF (pgevp(i, k) .GE. 0.) THEN
9350           abs7 = pgevp(i, k)
9351         ELSE
9352           abs7 = -pgevp(i, k)
9353         END IF
9354         IF (abs7 .LT. qmin/dtcld) pgevp(i, k) = 0.
9355         IF (q(i, k) - pgevp(i, k)*dtcld .LT. 0.) THEN
9356           q(i, k) = 0.
9357         ELSE
9358           q(i, k) = q(i, k) - pgevp(i, k)*dtcld
9359         END IF
9360         IF (qrs(i, k, 3) + pgevp(i, k)*dtcld .LT. 0.) THEN
9361           qrs(i, k, 3) = 0.
9362         ELSE
9363           qrs(i, k, 3) = qrs(i, k, 3) + pgevp(i, k)*dtcld
9364         END IF
9365         t(i, k) = t(i, k) + pgevp(i, k)*dtcld*xls/cpm(i, k)
9366         pgevp(i, k) = 0.
9367       END DO
9368     END DO
9369   END SUBROUTINE ACCRET3
9370
9371 !  Differentiation of pconadd in forward (tangent) mode (with options r8):
9372 !   variations   of useful results: q t qs cpm xl qci
9373 !   with respect to varying inputs: p q t qs cpm xl qci
9374 !=======================================================================
9375 !
9376 !=======================================================================
9377   SUBROUTINE G_PCONADD(t, g_t, p, g_p, q, g_q, qci, g_qci, qs, g_qs, xl&
9378 &   , g_xl, cpm, g_cpm, dtcld, kte, kts, its, ite, kme, kms, ims, ime)
9379     IMPLICIT NONE
9380     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
9381     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
9382     REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci
9383     REAL, DIMENSION(its:ite, kts:kte) :: t, xl, pcond, work2, cpm
9384     REAL, DIMENSION(its:ite, kts:kte) :: g_t, g_xl, g_pcond, g_cpm
9385     REAL, DIMENSION(its:ite, kts:kte, 3) :: qs, work1, rh
9386     REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qs, g_work1, g_rh
9387     REAL, DIMENSION(ims:ime, kms:kme) :: q, p
9388     REAL, DIMENSION(ims:ime, kms:kme) :: g_q, g_p
9389     INTEGER :: k, i
9390     REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, &
9391 &   dtcld, qs1, qs2, qs3, qs4, w1, q1
9392     REAL :: tmp1, tmp2, f1, f2, qs0
9393     INTRINSIC MAX
9394     INTRINSIC MIN
9395     INTRINSIC ABS
9396     REAL :: y1
9397     REAL :: g_y1
9398     REAL :: min1
9399     REAL :: g_min1
9400     REAL :: max1
9401     REAL :: g_max1
9402     REAL :: abs0
9403     REAL :: temp
9404     g_work1 = 0.0_8
9405     g_pcond = 0.0_8
9406     DO k=kts,kte
9407       DO i=its,ite
9408 !update qs
9409         g_rh = 0.0_8
9410         CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), &
9411 &               g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs&
9412 &               (i, k, :))
9413 !update xl, cpm
9414         g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k))
9415         g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k))
9416 !----------------------------------------------------------------
9417 !  pcond: condensational/evaporational rate of cloud water [RH83 A6]
9418 !     if there exists additional water vapor condensated/if
9419 !     evaporation of cloud water is not enough to remove subsaturation
9420 !q>qs, work1>0, pcond>0 V->C min=0,                 max=q(i,k)/dtcld
9421 !q<qs, work1<0, pcond<0 C->V min=-qci(i,k,1)/dtcld, max=0,
9422         g_work1(i, k, 1) = G_CONDEN(t(i, k), g_t(i, k), q(i, k), g_q(i, &
9423 &         k), qs(i, k, 1), g_qs(i, k, 1), xl(i, k), g_xl(i, k), cpm(i, k&
9424 &         ), g_cpm(i, k), work1(i, k, 1))
9425         IF (work1(i, k, 1) .GT. 0.) THEN
9426           IF (q(i, k) .LT. 0.) THEN
9427             y1 = 0.
9428             g_y1 = 0.0_8
9429           ELSE
9430             g_y1 = g_q(i, k)
9431             y1 = q(i, k)
9432           END IF
9433           IF (work1(i, k, 1) .GT. y1) THEN
9434             g_min1 = g_y1
9435             min1 = y1
9436           ELSE
9437             g_min1 = g_work1(i, k, 1)
9438             min1 = work1(i, k, 1)
9439           END IF
9440           g_pcond(i, k) = g_min1/dtcld
9441           pcond(i, k) = min1/dtcld
9442         ELSE
9443           IF (work1(i, k, 1) .LT. -qci(i, k, 1)) THEN
9444             g_max1 = -g_qci(i, k, 1)
9445             max1 = -qci(i, k, 1)
9446           ELSE
9447             g_max1 = g_work1(i, k, 1)
9448             max1 = work1(i, k, 1)
9449           END IF
9450           g_pcond(i, k) = g_max1/dtcld
9451           pcond(i, k) = max1/dtcld
9452         END IF
9453         IF (pcond(i, k) .GE. 0.) THEN
9454           abs0 = pcond(i, k)
9455         ELSE
9456           abs0 = -pcond(i, k)
9457         END IF
9458         IF (abs0 .LT. qmin/dtcld) THEN
9459           g_pcond(i, k) = 0.0_8
9460           pcond(i, k) = 0.
9461         END IF
9462         IF (q(i, k) - pcond(i, k)*dtcld .LT. 0.) THEN
9463           g_q(i, k) = 0.0_8
9464           q(i, k) = 0.
9465         ELSE
9466           g_q(i, k) = g_q(i, k) - dtcld*g_pcond(i, k)
9467           q(i, k) = q(i, k) - pcond(i, k)*dtcld
9468         END IF
9469         IF (qci(i, k, 1) + pcond(i, k)*dtcld .LT. 0.) THEN
9470           g_qci(i, k, 1) = 0.0_8
9471           qci(i, k, 1) = 0.
9472         ELSE
9473           g_qci(i, k, 1) = g_qci(i, k, 1) + dtcld*g_pcond(i, k)
9474           qci(i, k, 1) = qci(i, k, 1) + pcond(i, k)*dtcld
9475         END IF
9476         temp = pcond(i, k)*xl(i, k)/cpm(i, k)
9477         g_t(i, k) = g_t(i, k) + dtcld*(xl(i, k)*g_pcond(i, k)+pcond(i, k&
9478 &         )*g_xl(i, k)-temp*g_cpm(i, k))/cpm(i, k)
9479         t(i, k) = t(i, k) + dtcld*temp
9480         g_pcond(i, k) = 0.0_8
9481         pcond(i, k) = 0.
9482       END DO
9483     END DO
9484   END SUBROUTINE G_PCONADD
9485
9486 !=======================================================================
9487 !
9488 !=======================================================================
9489   SUBROUTINE PCONADD(t, p, q, qci, qs, xl, cpm, dtcld, kte, kts, its, &
9490 &   ite, kme, kms, ims, ime)
9491     IMPLICIT NONE
9492     INTEGER :: ims, ime, kms, kme, its, ite, kts, kte
9493     REAL, DIMENSION(its:ite, kts:kte, 2) :: qci
9494     REAL, DIMENSION(its:ite, kts:kte) :: t, xl, pcond, work2, cpm
9495     REAL, DIMENSION(its:ite, kts:kte, 3) :: qs, work1, rh
9496     REAL, DIMENSION(ims:ime, kms:kme) :: q, p
9497     INTEGER :: k, i
9498     REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, &
9499 &   dtcld, qs1, qs2, qs3, qs4, w1, q1
9500     REAL :: tmp1, tmp2, f1, f2, qs0
9501     INTRINSIC MAX
9502     INTRINSIC MIN
9503     INTRINSIC ABS
9504     REAL :: y1
9505     REAL :: min1
9506     REAL :: max1
9507     REAL :: abs0
9508     DO k=kts,kte
9509       DO i=its,ite
9510 !update qs
9511         CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :))
9512 !update xl, cpm
9513         xl(i, k) = XLCAL(t(i, k))
9514         cpm(i, k) = CPMCAL(q(i, k))
9515 !----------------------------------------------------------------
9516 !  pcond: condensational/evaporational rate of cloud water [RH83 A6]
9517 !     if there exists additional water vapor condensated/if
9518 !     evaporation of cloud water is not enough to remove subsaturation
9519 !q>qs, work1>0, pcond>0 V->C min=0,                 max=q(i,k)/dtcld
9520 !q<qs, work1<0, pcond<0 C->V min=-qci(i,k,1)/dtcld, max=0,
9521         work1(i, k, 1) = CONDEN(t(i, k), q(i, k), qs(i, k, 1), xl(i, k)&
9522 &         , cpm(i, k))
9523         IF (work1(i, k, 1) .GT. 0.) THEN
9524           IF (q(i, k) .LT. 0.) THEN
9525             y1 = 0.
9526           ELSE
9527             y1 = q(i, k)
9528           END IF
9529           IF (work1(i, k, 1) .GT. y1) THEN
9530             min1 = y1
9531           ELSE
9532             min1 = work1(i, k, 1)
9533           END IF
9534           pcond(i, k) = min1/dtcld
9535         ELSE
9536           IF (work1(i, k, 1) .LT. -qci(i, k, 1)) THEN
9537             max1 = -qci(i, k, 1)
9538           ELSE
9539             max1 = work1(i, k, 1)
9540           END IF
9541           pcond(i, k) = max1/dtcld
9542         END IF
9543         IF (pcond(i, k) .GE. 0.) THEN
9544           abs0 = pcond(i, k)
9545         ELSE
9546           abs0 = -pcond(i, k)
9547         END IF
9548         IF (abs0 .LT. qmin/dtcld) pcond(i, k) = 0.
9549         IF (q(i, k) - pcond(i, k)*dtcld .LT. 0.) THEN
9550           q(i, k) = 0.
9551         ELSE
9552           q(i, k) = q(i, k) - pcond(i, k)*dtcld
9553         END IF
9554         IF (qci(i, k, 1) + pcond(i, k)*dtcld .LT. 0.) THEN
9555           qci(i, k, 1) = 0.
9556         ELSE
9557           qci(i, k, 1) = qci(i, k, 1) + pcond(i, k)*dtcld
9558         END IF
9559         t(i, k) = t(i, k) + pcond(i, k)*dtcld*xl(i, k)/cpm(i, k)
9560         pcond(i, k) = 0.
9561       END DO
9562     END DO
9563   END SUBROUTINE PCONADD
9564
9565 !  Differentiation of smoothif in forward (tangent) mode (with options r8):
9566 !   variations   of useful results: f
9567 !   with respect to varying inputs: x
9568 !=======================================================================
9569 !
9570 !=======================================================================
9571   SUBROUTINE G_SMOOTHIF(x, g_x, a, f, g_f, opt)
9572     IMPLICIT NONE
9573     REAL, INTENT(IN) :: x, a
9574     REAL, INTENT(IN) :: g_x
9575     CHARACTER(len=2), INTENT(IN) :: opt
9576     REAL, INTENT(OUT) :: f
9577     REAL, INTENT(OUT) :: g_f
9578     REAL(kind=8) :: k1, a1, x1, c1, f1, k, b
9579     REAL(kind=8) :: g_x1, g_f1, g_k
9580     INTRINSIC EXP
9581     INTRINSIC REAL
9582     REAL(kind=8) :: temp1, temp2
9583     g_x1 = g_x
9584     x1 = x
9585     a1 = a
9586     IF (opt(1:1) .EQ. 'q') THEN
9587       c1 = 1.e-15
9588     ELSE
9589       c1 = 1.e-9
9590     END IF
9591 !f=1/(1+exp(-k*(x-b))
9592     k1 = 747./c1
9593     IF (opt(2:2) .EQ. '+') THEN
9594       b = a1 + 710./k1
9595     ELSE
9596       b = a1
9597     END IF
9598     g_k = -(k1*g_x1)
9599     k = -(k1*(x1-b))
9600     temp1 = 1.0/(EXP(k)+1.)
9601     temp2 = 1.0/(EXP(-k)+1.)
9602     g_f1 = -(temp1*temp2*g_k)
9603     f1 = temp1
9604     g_f = g_f1 !REAL(g_f1, 4)
9605     f = f1 !REAL(f1, 4)
9606   END SUBROUTINE G_SMOOTHIF
9607
9608 !=======================================================================
9609 !
9610 !=======================================================================
9611   SUBROUTINE SMOOTHIF(x, a, f, opt)
9612     IMPLICIT NONE
9613     REAL, INTENT(IN) :: x, a
9614     CHARACTER(len=2), INTENT(IN) :: opt
9615     REAL, INTENT(OUT) :: f
9616     REAL(kind=8) :: k1, a1, x1, c1, f1, k, b
9617     INTRINSIC EXP
9618     x1 = x
9619     a1 = a
9620     IF (opt(1:1) .EQ. 'q') THEN
9621       c1 = 1.e-15
9622     ELSE
9623       c1 = 1.e-9
9624     END IF
9625     k1 = 747./c1
9626     IF (opt(2:2) .EQ. '+') THEN
9627       b = a1 + 710./k1
9628     ELSE
9629       b = a1
9630     END IF
9631     k = -(k1*(x1-b))
9632     f1 = 1./(1.+EXP(k))
9633     f = f1
9634   END SUBROUTINE SMOOTHIF
9635
9636 !
9637 !
9638 !=======================================================================
9639 !
9640 !=======================================================================
9641   REAL FUNCTION RGMMA(x)
9642     IMPLICIT NONE
9643 !-------------------------------------------------------------------
9644 !  rgmma function:  use infinite product form
9645     REAL :: euler
9646     PARAMETER (euler=0.577215664901532)
9647     REAL :: x, y
9648     INTEGER :: i
9649     INTRINSIC EXP
9650     INTRINSIC FLOAT
9651     IF (x .EQ. 1.) THEN
9652       rgmma = 0.
9653     ELSE
9654       rgmma = x*EXP(euler*x)
9655       DO i=1,10000
9656         y = FLOAT(i)
9657         rgmma = rgmma*(1.000+x/y)*EXP(-(x/y))
9658       END DO
9659       rgmma = 1./rgmma
9660     END IF
9661   END FUNCTION RGMMA
9662
9663 !  Differentiation of cpmcal in forward (tangent) mode (with options r8):
9664 !   variations   of useful results: cpmcal
9665 !   with respect to varying inputs: x
9666 !
9667 !
9668 !=======================================================================
9669 !
9670 !=======================================================================
9671 !   compute internal functions
9672   FUNCTION G_CPMCAL(x, g_x, cpmcal)
9673     IMPLICIT NONE
9674     REAL :: cpmcal, x
9675     REAL :: g_cpmcal, g_x
9676     g_cpmcal = (cpv-cpd)*g_x
9677     cpmcal = cpd + x*(cpv-cpd)
9678   END FUNCTION G_CPMCAL
9679
9680 !
9681 !
9682 !=======================================================================
9683 !
9684 !=======================================================================
9685 !   compute internal functions
9686   FUNCTION CPMCAL(x)
9687     IMPLICIT NONE
9688     REAL :: cpmcal, x
9689     cpmcal = cpd + x*(cpv-cpd)
9690   END FUNCTION CPMCAL
9691
9692 !  Differentiation of xlcal in forward (tangent) mode (with options r8):
9693 !   variations   of useful results: xlcal
9694 !   with respect to varying inputs: x
9695 !
9696 !=======================================================================
9697 !
9698 !=======================================================================
9699   FUNCTION G_XLCAL(x, g_x, xlcal)
9700     IMPLICIT NONE
9701     REAL :: xlcal, x
9702     REAL :: g_xlcal, g_x
9703     g_xlcal = -(xlv1*g_x)
9704     xlcal = xlv0 - xlv1*(x-t0c)
9705   END FUNCTION G_XLCAL
9706
9707 !
9708 !=======================================================================
9709 !
9710 !=======================================================================
9711   FUNCTION XLCAL(x)
9712     IMPLICIT NONE
9713     REAL :: xlcal, x
9714     xlcal = xlv0 - xlv1*(x-t0c)
9715   END FUNCTION XLCAL
9716
9717 !  Differentiation of conden in forward (tangent) mode (with options r8):
9718 !   variations   of useful results: conden
9719 !   with respect to varying inputs: d e a b c
9720 !=======================================================================
9721 ! a:t, b:q, c:qs, d:xl, e:cpm
9722 !=======================================================================
9723   FUNCTION G_CONDEN(a, g_a, b, g_b, c, g_c, d, g_d, e, g_e, conden)
9724     IMPLICIT NONE
9725     REAL :: conden, a, b, c, d, e
9726     REAL :: g_conden, g_a, g_b, g_c, g_d, g_e
9727     REAL :: f
9728     REAL :: temp
9729     REAL :: temp0
9730     REAL :: temp1
9731     temp = rv*e*(a*a)
9732     temp0 = d*d*c/temp
9733     temp1 = (b-c)/(temp0+1.)
9734     g_conden = (g_b-g_c-temp1*(c*2*d*g_d+d**2*g_c-temp0*(a**2*rv*g_e+rv*&
9735 &     e*2*a*g_a))/temp)/(temp0+1.)
9736     conden = temp1
9737   END FUNCTION G_CONDEN
9738
9739 !=======================================================================
9740 ! a:t, b:q, c:qs, d:xl, e:cpm
9741 !=======================================================================
9742   FUNCTION CONDEN(a, b, c, d, e)
9743     IMPLICIT NONE
9744     REAL :: conden, a, b, c, d, e
9745     REAL :: f
9746     conden = (b-c)/(1.+d*d/(rv*e)*c/(a*a))
9747   END FUNCTION CONDEN
9748
9749 END MODULE G_MODULE_MP_WSM6R
9750 !
9751