! Generated by TAPENADE (INRIA, Ecuador team) ! Tapenade 3.16 (master) - 9 Oct 2020 17:47 ! MODULE G_MODULE_MP_WSM6R IMPLICIT NONE ! ! parameters REAL, PARAMETER :: dtcldcr=120. REAL, PARAMETER :: n0r=8.e6 REAL, PARAMETER :: n0g=4.e6 REAL, PARAMETER :: avtr=841.9 REAL, PARAMETER :: bvtr=0.8 ! 8 microm in contrast to 10 micro m REAL, PARAMETER :: r0=.8e-5 ! collection efficiency REAL, PARAMETER :: peaut=.55 ! maritime cloud in contrast to 3.e8 in tc80 REAL, PARAMETER :: xncr=3.e8 ! the dynamic viscosity kgm-1s-1 REAL, PARAMETER :: xmyu=1.718e-5 REAL, PARAMETER :: avts=11.72 REAL, PARAMETER :: bvts=.41 REAL, PARAMETER :: avtg=330. REAL, PARAMETER :: bvtg=0.8 REAL, PARAMETER :: deng=500. ! t = -90C unlimited REAL, PARAMETER :: n0smax=1.e11 ! REAL, PARAMETER :: betai = .6 ! REAL, PARAMETER :: xn0 = 1.e-2 ! REAL, PARAMETER :: dicon = 11.9 ! REAL, PARAMETER :: di0 = 12.9e-6 REAL, PARAMETER :: dimax=500.e-6 ! temperature dependent n0s REAL, PARAMETER :: n0s=2.e6 ! .122 exponen factor for n0s REAL, PARAMETER :: alpha=.12 REAL, PARAMETER :: pfrz1=100. REAL, PARAMETER :: pfrz2=0.66 REAL, PARAMETER :: t40c=233.16 ! Esc REAL, PARAMETER :: eacrc=1.0 ! Erc REAL, PARAMETER :: eacrr=1.0 REAL, PARAMETER :: dens=100.0 ! pgaut REAL, PARAMETER :: qs0=6.e-4 ! = 9.81 REAL, PARAMETER :: g=9.81 ! gas constant for dry air (J/kg/K) = 287 REAL, PARAMETER :: rd=287. ! gas constant for water vapor (J/kg/K) REAL, PARAMETER :: rv=461.6 ! = 273.15 REAL, PARAMETER :: t0c=273.15 ! density of 0 degree air (kg/m^3) REAL, PARAMETER :: den0=1.28 ! heat capacity at constant pressure for dry air (J/kg/K) = 7.*rd/2. REAL, PARAMETER :: cpd=1004.5 ! heat capacity at constant pressure for vapor (J/kg/K) = 4.*r_v REAL, PARAMETER :: cpv=1846.4 ! REAL, PARAMETER :: ep1 = 0.6083624 ! = rv/rd-1. ! = rd/rv REAL, PARAMETER :: ep2=0.6217504 REAL, PARAMETER :: qcrmin=1.e-9 ! epsilon = 1.E-15 REAL, PARAMETER :: qmin=1.e-15 ! latent heat of sublimation (J/kg) = 2.85E6 REAL, PARAMETER :: xls=2.85e6 ! latent heat of vaporization (J/kg) = 3.15E6 REAL, PARAMETER :: xlv0=2.5e6 ! latent heat of melting (J/kg) = 3.50E5 REAL, PARAMETER :: xlf0=3.50e5 ! = 4190. REAL, PARAMETER :: cliq=4190. ! = 2106 REAL, PARAMETER :: cice=2106. ! = 610.78 REAL, PARAMETER :: psat=610.78 ! water density = 1000 (kg/m^3) REAL, PARAMETER :: denr=1000. REAL, SAVE :: pi, qc0, qck1, bvtr1, bvtr2, bvtr3, bvtr4, bvtr6, g1pbr& & , g3pbr, g4pbr, g5pbro2, g6pbr, pvtr, bvts1, bvts2, bvts3, bvts4, & & g1pbs, g3pbs, g4pbs, g5pbso2, pvts, bvtg1, bvtg2, bvtg3, bvtg4, g1pbg& & , g3pbg, g4pbg, g5pbgo2, pvtg, roqimax, pidn0r, pidn0s, pidn0g, xlv1, & & vt2i, vt2r, vt2s, vt2g, egs, egi, vt2r_a, vt2s_a, vt2g_a, vt2i_a, & & fallr_a, falls_a, fallg_a, falli_a, pgfrz_a, diffac_a, diffac_b, & & pidep_a, pgacs_a, pgacs_b, pgacs_c, pgacs_d, pgacr_a, pgacr_b, pgacr_c& & , pgacr_d, psacr_a, psacr_b, psacr_c, psacr_d, pracs_a, pracs_b, & & pracs_c, pracs_d, pgaci_a, pgaci_b, pgaci_c, pgaci_d, psevp_a, psevp_b& & , pgevp_a REAL, SAVE :: pgevp_b, psmlt_a, psmlt_b, pgmlt_a, pgmlt_b, prevp_a, & & prevp_b, psdep_a, psdep_b, pgdep_a, pgdep_b, praci_a, praci_b, praci_c& & , praci_d, psaci_a, psaci_b, psaci_c, psaci_d, pracw_a, piacr_a, & & psacw_a, pgacw_a REAL, SAVE :: g_vt2i, g_vt2r, g_vt2s, g_vt2g CONTAINS ! Differentiation of wsm6r in forward (tangent) mode (with options r8): ! variations of useful results: th qc qg qi q qr qs rain rainncv ! with respect to varying inputs: th qc qg qi p q qr qs delz ! den rain rainncv pii ! RW status of diff variables: vt2g:(loc) vt2i:(loc) vt2r:(loc) ! vt2s:(loc) th:in-out qc:in-out qg:in-out qi:in-out ! p:in q:in-out qr:in-out qs:in-out delz:in den:in ! rain:in-out rainncv:in-out pii:in !======================================================================= ! !======================================================================= SUBROUTINE G_WSM6R(th, g_th, q, g_q, qc, g_qc, qr, g_qr, qi, g_qi, qs& & , g_qs, qg, g_qg, den, g_den, pii, g_pii, p, g_p, delz, g_delz, delt& & , rain, g_rain, rainncv, g_rainncv, ids, ide, jds, jde, kds, kde, & & ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte) IMPLICIT NONE !------------------------------------------------------------------- INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: th, q, & & qc, qi, qr, qs, qg REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: g_th, & & g_q, g_qc, g_qi, g_qr, g_qs, g_qg REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: den, pii, & & p, delz REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: g_den, & & g_pii, g_p, g_delz REAL, INTENT(IN) :: delt REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rain, rainncv REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: g_rain, & & g_rainncv ! LOCAL VAR REAL, DIMENSION(its:ite, kts:kte) :: t REAL, DIMENSION(its:ite, kts:kte) :: g_t REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs REAL, DIMENSION(ims:ime, kms:kme) :: q2d, den2d, p2d, delz2d REAL, DIMENSION(ims:ime, kms:kme) :: g_q2d, g_den2d, g_p2d, g_delz2d REAL, DIMENSION(ims:ime) :: r1d, rcv1d REAL, DIMENSION(ims:ime) :: g_r1d, g_rcv1d REAL :: delt1 INTEGER :: i, j, k, ierr REAL :: temp delt1 = delt g_t = 0.0_8 g_rcv1d = 0.0_8 g_qrs = 0.0_8 g_q2d = 0.0_8 g_delz2d = 0.0_8 g_den2d = 0.0_8 g_qci = 0.0_8 g_r1d = 0.0_8 g_p2d = 0.0_8 DO j=jts,jte DO i=its,ite g_r1d(i) = g_rain(i, j) r1d(i) = rain(i, j) g_rcv1d(i) = g_rainncv(i, j) rcv1d(i) = rainncv(i, j) DO k=kts,kte g_t(i, k) = pii(i, k, j)*g_th(i, k, j) + th(i, k, j)*g_pii(i, & & k, j) t(i, k) = th(i, k, j)*pii(i, k, j) g_qci(i, k, 1) = g_qc(i, k, j) qci(i, k, 1) = qc(i, k, j) g_qci(i, k, 2) = g_qi(i, k, j) qci(i, k, 2) = qi(i, k, j) g_qrs(i, k, 1) = g_qr(i, k, j) qrs(i, k, 1) = qr(i, k, j) g_qrs(i, k, 2) = g_qs(i, k, j) qrs(i, k, 2) = qs(i, k, j) g_qrs(i, k, 3) = g_qg(i, k, j) qrs(i, k, 3) = qg(i, k, j) g_q2d(i, k) = g_q(i, k, j) q2d(i, k) = q(i, k, j) g_den2d(i, k) = g_den(i, k, j) den2d(i, k) = den(i, k, j) g_p2d(i, k) = g_p(i, k, j) p2d(i, k) = p(i, k, j) g_delz2d(i, k) = g_delz(i, k, j) delz2d(i, k) = delz(i, k, j) END DO END DO ! Sending array starting locations of optional variables may cause ! troubles, so we explicitly change the call. CALL G_WSM62D(t, g_t, q2d, g_q2d, qci, g_qci, qrs, g_qrs, den2d, & & g_den2d, p2d, g_p2d, delz2d, g_delz2d, delt1, r1d, g_r1d, & & rcv1d, g_rcv1d, ims, ime, kms, kme, its, ite, kts, kte) DO i=its,ite g_rain(i, j) = g_r1d(i) rain(i, j) = r1d(i) g_rainncv(i, j) = g_rcv1d(i) rainncv(i, j) = rcv1d(i) DO k=kts,kte temp = t(i, k)/pii(i, k, j) g_th(i, k, j) = (g_t(i, k)-temp*g_pii(i, k, j))/pii(i, k, j) th(i, k, j) = temp g_qc(i, k, j) = g_qci(i, k, 1) qc(i, k, j) = qci(i, k, 1) g_qi(i, k, j) = g_qci(i, k, 2) qi(i, k, j) = qci(i, k, 2) g_qr(i, k, j) = g_qrs(i, k, 1) qr(i, k, j) = qrs(i, k, 1) g_qs(i, k, j) = g_qrs(i, k, 2) qs(i, k, j) = qrs(i, k, 2) g_qg(i, k, j) = g_qrs(i, k, 3) qg(i, k, j) = qrs(i, k, 3) g_q(i, k, j) = g_q2d(i, k) q(i, k, j) = q2d(i, k) END DO END DO END DO END SUBROUTINE G_WSM6R !======================================================================= ! !======================================================================= SUBROUTINE WSM6R(th, q, qc, qr, qi, qs, qg, den, pii, p, delz, delt, & & rain, rainncv, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms& & , kme, its, ite, jts, jte, kts, kte) IMPLICIT NONE !------------------------------------------------------------------- INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, & & jme, kms, kme, its, ite, jts, jte, kts, kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: th, q, & & qc, qi, qr, qs, qg REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: den, pii, & & p, delz REAL, INTENT(IN) :: delt REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rain, rainncv ! LOCAL VAR REAL, DIMENSION(its:ite, kts:kte) :: t REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs REAL, DIMENSION(ims:ime, kms:kme) :: q2d, den2d, p2d, delz2d REAL, DIMENSION(ims:ime) :: r1d, rcv1d REAL :: delt1 INTEGER :: i, j, k, ierr delt1 = delt DO j=jts,jte DO i=its,ite r1d(i) = rain(i, j) rcv1d(i) = rainncv(i, j) DO k=kts,kte t(i, k) = th(i, k, j)*pii(i, k, j) qci(i, k, 1) = qc(i, k, j) qci(i, k, 2) = qi(i, k, j) qrs(i, k, 1) = qr(i, k, j) qrs(i, k, 2) = qs(i, k, j) qrs(i, k, 3) = qg(i, k, j) q2d(i, k) = q(i, k, j) den2d(i, k) = den(i, k, j) p2d(i, k) = p(i, k, j) delz2d(i, k) = delz(i, k, j) END DO END DO ! Sending array starting locations of optional variables may cause ! troubles, so we explicitly change the call. CALL WSM62D(t, q2d, qci, qrs, den2d, p2d, delz2d, delt1, r1d, & & rcv1d, ims, ime, kms, kme, its, ite, kts, kte) DO i=its,ite rain(i, j) = r1d(i) rainncv(i, j) = rcv1d(i) DO k=kts,kte th(i, k, j) = t(i, k)/pii(i, k, j) qc(i, k, j) = qci(i, k, 1) qi(i, k, j) = qci(i, k, 2) qr(i, k, j) = qrs(i, k, 1) qs(i, k, j) = qrs(i, k, 2) qg(i, k, j) = qrs(i, k, 3) q(i, k, j) = q2d(i, k) END DO END DO END DO END SUBROUTINE WSM6R ! Differentiation of wsm62d in forward (tangent) mode (with options r8): ! variations of useful results: q t qrs rain qci rainncv ! with respect to varying inputs: p q t delz den qrs rain qci ! rainncv !======================================================================= ! !======================================================================= SUBROUTINE G_WSM62D(t, g_t, q, g_q, qci, g_qci, qrs, g_qrs, den, g_den& & , p, g_p, delz, g_delz, delt, rain, g_rain, rainncv, g_rainncv, ims& & , ime, kms, kme, its, ite, kts, kte) IMPLICIT NONE ! big loops ! !------------------------------------------------------------------- INTEGER :: ims, ime, kms, kme, its, ite, kts, kte REAL, DIMENSION(its:ite, kts:kte), INTENT(INOUT) :: t REAL, DIMENSION(its:ite, kts:kte), INTENT(INOUT) :: g_t REAL, DIMENSION(its:ite, kts:kte, 2), INTENT(INOUT) :: qci REAL, DIMENSION(its:ite, kts:kte, 2), INTENT(INOUT) :: g_qci REAL, DIMENSION(its:ite, kts:kte, 3), INTENT(INOUT) :: qrs REAL, DIMENSION(its:ite, kts:kte, 3), INTENT(INOUT) :: g_qrs REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT) :: q REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT) :: g_q REAL, DIMENSION(ims:ime, kms:kme), INTENT(IN) :: den, p, delz REAL, DIMENSION(ims:ime, kms:kme), INTENT(IN) :: g_den, g_p, g_delz REAL, INTENT(IN) :: delt REAL, DIMENSION(ims:ime), INTENT(INOUT) :: rain, rainncv REAL, DIMENSION(ims:ime), INTENT(INOUT) :: g_rain, g_rainncv ! LOCAL VAR REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, rslope, rslope2, & & rslope3, rslopeb, falk, fall, work1 REAL, DIMENSION(its:ite, kts:kte, 3) :: g_rh, g_qs, g_falk, g_fall REAL, DIMENSION(its:ite, kts:kte) :: pracw, psacw, pgacw, pgacr, & & pgacs, psaci, praci, piacr, pracs, psacr, pgaci, pseml, pgeml, fallc& & , praut, psaut, pgaut, prevp, psdep, pgdep REAL, DIMENSION(its:ite, kts:kte) :: g_pracw, g_psacw, g_pgacw, & & g_pgacr, g_pgacs, g_psaci, g_praci, g_piacr, g_pracs, g_psacr, & & g_pgaci, g_pseml, g_pgeml, g_fallc, g_praut, g_psaut, g_pgaut, & & g_prevp, g_psdep, g_pgdep REAL, DIMENSION(its:ite, kts:kte) :: pigen, pidep, pcond, xl, cpm, & & psevp, xni, pgevp, n0sfac, work2 REAL, DIMENSION(its:ite, kts:kte) :: g_pigen, g_pidep, g_xl, g_cpm, & & g_psevp, g_pgevp ! LOGICAL, DIMENSION( its:ite ) :: flgcld REAL :: dtcld, temp, temp0, supcol, supsat, satdt, eacrs, xmi, & & diameter, delta2, delta3 INTEGER :: i, k, loop, loops REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, & & qs10, qs11, qs20, qs21 REAL :: fq, fqc, fqi, fqr, fqs, fqg, fallsum INTRINSIC MAX INTRINSIC NINT INTEGER :: x1 !================================================================= ! CALL WSM6RINIT() !---------------------------------------------------------------- ! paddint 0 for negative values generated by dynamics ! DO k=kts,kte DO i=its,ite IF (q(i, k) .LT. 0.) THEN g_q(i, k) = 0.0_8 q(i, k) = 0. ELSE q(i, k) = q(i, k) END IF IF (qci(i, k, 1) .LT. 0.) THEN g_qci(i, k, 1) = 0.0_8 qci(i, k, 1) = 0. ELSE qci(i, k, 1) = qci(i, k, 1) END IF IF (qrs(i, k, 1) .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) END IF IF (qci(i, k, 2) .LT. 0.) THEN g_qci(i, k, 2) = 0.0_8 qci(i, k, 2) = 0. ELSE qci(i, k, 2) = qci(i, k, 2) END IF IF (qrs(i, k, 2) .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = qrs(i, k, 2) END IF IF (qrs(i, k, 3) .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = qrs(i, k, 3) END IF END DO END DO x1 = NINT(delt/dtcldcr) IF (x1 .LT. 1) THEN loops = 1 ELSE loops = x1 END IF dtcld = delt/loops IF (delt .LE. dtcldcr) THEN dtcld = delt g_fallc = 0.0_8 g_piacr = 0.0_8 g_psaci = 0.0_8 g_pgaci = 0.0_8 g_psacr = 0.0_8 g_praci = 0.0_8 g_qs = 0.0_8 g_cpm = 0.0_8 g_psacw = 0.0_8 g_pgacr = 0.0_8 g_pgacs = 0.0_8 g_pracs = 0.0_8 g_xl = 0.0_8 g_pgacw = 0.0_8 g_pigen = 0.0_8 g_pracw = 0.0_8 g_rh = 0.0_8 g_psevp = 0.0_8 g_pidep = 0.0_8 g_falk = 0.0_8 g_fall = 0.0_8 g_pgevp = 0.0_8 g_prevp = 0.0_8 g_psdep = 0.0_8 g_pseml = 0.0_8 g_pgdep = 0.0_8 g_pgeml = 0.0_8 g_psaut = 0.0_8 g_pgaut = 0.0_8 g_praut = 0.0_8 ELSE g_fallc = 0.0_8 g_piacr = 0.0_8 g_psaci = 0.0_8 g_pgaci = 0.0_8 g_psacr = 0.0_8 g_praci = 0.0_8 g_qs = 0.0_8 g_cpm = 0.0_8 g_psacw = 0.0_8 g_pgacr = 0.0_8 g_pgacs = 0.0_8 g_pracs = 0.0_8 g_xl = 0.0_8 g_pgacw = 0.0_8 g_pigen = 0.0_8 g_pracw = 0.0_8 g_rh = 0.0_8 g_psevp = 0.0_8 g_pidep = 0.0_8 g_falk = 0.0_8 g_fall = 0.0_8 g_pgevp = 0.0_8 g_prevp = 0.0_8 g_psdep = 0.0_8 g_pseml = 0.0_8 g_pgdep = 0.0_8 g_pgeml = 0.0_8 g_psaut = 0.0_8 g_pgaut = 0.0_8 g_praut = 0.0_8 END IF ! DO loop=1,loops ! !---------------------------------------------------------------- ! initialize the variables for microphysical physics CALL G_INIMP(prevp, g_prevp, psdep, g_psdep, pgdep, g_pgdep, praut& & , g_praut, psaut, g_psaut, pgaut, g_pgaut, pracw, g_pracw, & & praci, g_praci, piacr, g_piacr, psaci, g_psaci, psacw, & & g_psacw, pracs, g_pracs, psacr, g_psacr, pgacw, g_pgacw, & & pgaci, g_pgaci, pgacr, g_pgacr, pgacs, g_pgacs, pigen, & & g_pigen, pidep, g_pidep, pcond, pseml, g_pseml, pgeml, & & g_pgeml, psevp, g_psevp, pgevp, g_pgevp, falk, g_falk, fall& & , g_fall, fallc, g_fallc, xni, kts, kte, its, ite) !---------------------------------------------------------------- ! compute the fallout term: ! first, vertical terminal velosity for minor loops CALL G_FALLK(cpm, g_cpm, t, g_t, p, g_p, q, g_q, den, g_den, qrs, & & g_qrs, delz, g_delz, dtcld, falk, g_falk, fall, g_fall, kte& & , kts, its, ite, kme, kms, ims, ime) CALL G_FALLKC(qci, g_qci, fallc, g_fallc, den, g_den, delz, g_delz& & , dtcld, kte, kts, its, ite, kme, kms, ims, ime) CALL G_RAINSC(fall, g_fall, fallc, g_fallc, xl, g_xl, t, g_t, q, & & qci, g_qci, cpm, g_cpm, den, g_den, qrs, g_qrs, delz, & & g_delz, rain, g_rain, rainncv, g_rainncv, dtcld, kte, kts& & , its, ite, kme, kms, ims, ime) CALL G_WARMR(t, g_t, q, g_q, qci, g_qci, qrs, g_qrs, den, g_den, p& & , g_p, dtcld, xl, g_xl, rh, g_rh, qs, g_qs, praut, g_praut& & , pracw, g_pracw, prevp, g_prevp, ims, ime, kms, kme, its, & & ite, kts, kte) ! ! cold rain processes ! ! CALL G_ACCRET1(qci, g_qci, den, g_den, qrs, g_qrs, t, g_t, q, g_q& & , dtcld, praci, g_praci, piacr, g_piacr, psaci, g_psaci, & & pgaci, g_pgaci, psacw, g_psacw, pgacw, g_pgacw, ims, ime& & , kms, kme, its, ite, kts, kte) CALL G_ACCRET2(qrs, g_qrs, t, g_t, q, g_q, den, g_den, dtcld, & & psacw, g_psacw, pgacw, g_pgacw, pracs, g_pracs, psacr, & & g_psacr, pgacr, g_pgacr, pgacs, g_pgacs, pseml, g_pseml, & & pgeml, g_pgeml, ims, ime, kms, kme, its, ite, kts, kte) CALL G_ACCRET3(qrs, g_qrs, qci, g_qci, rh, g_rh, t, g_t, p, g_p, & & den, g_den, dtcld, q, g_q, qs, g_qs, psdep, g_psdep, & & pgdep, g_pgdep, pigen, g_pigen, psaut, g_psaut, pgaut, & & g_pgaut, psevp, g_psevp, pgevp, g_pgevp, pidep, g_pidep, & & ims, ime, kms, kme, its, ite, kts, kte) CALL G_PCONADD(t, g_t, p, g_p, q, g_q, qci, g_qci, qs, g_qs, xl, & & g_xl, cpm, g_cpm, dtcld, kte, kts, its, ite, kme, kms, & & ims, ime) END DO END SUBROUTINE G_WSM62D !======================================================================= ! !======================================================================= SUBROUTINE WSM62D(t, q, qci, qrs, den, p, delz, delt, rain, rainncv, & & ims, ime, kms, kme, its, ite, kts, kte) IMPLICIT NONE ! big loops ! !------------------------------------------------------------------- INTEGER :: ims, ime, kms, kme, its, ite, kts, kte REAL, DIMENSION(its:ite, kts:kte), INTENT(INOUT) :: t REAL, DIMENSION(its:ite, kts:kte, 2), INTENT(INOUT) :: qci REAL, DIMENSION(its:ite, kts:kte, 3), INTENT(INOUT) :: qrs REAL, DIMENSION(ims:ime, kms:kme), INTENT(INOUT) :: q REAL, DIMENSION(ims:ime, kms:kme), INTENT(IN) :: den, p, delz REAL, INTENT(IN) :: delt REAL, DIMENSION(ims:ime), INTENT(INOUT) :: rain, rainncv ! LOCAL VAR REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, rslope, rslope2, & & rslope3, rslopeb, falk, fall, work1 REAL, DIMENSION(its:ite, kts:kte) :: pracw, psacw, pgacw, pgacr, & & pgacs, psaci, praci, piacr, pracs, psacr, pgaci, pseml, pgeml, fallc& & , praut, psaut, pgaut, prevp, psdep, pgdep REAL, DIMENSION(its:ite, kts:kte) :: pigen, pidep, pcond, xl, cpm, & & psevp, xni, pgevp, n0sfac, work2 ! LOGICAL, DIMENSION( its:ite ) :: flgcld REAL :: dtcld, temp, temp0, supcol, supsat, satdt, eacrs, xmi, & & diameter, delta2, delta3 INTEGER :: i, k, loop, loops REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, & & qs10, qs11, qs20, qs21 REAL :: fq, fqc, fqi, fqr, fqs, fqg, fallsum INTRINSIC MAX INTRINSIC NINT INTEGER :: x1 !================================================================= ! CALL WSM6RINIT() !---------------------------------------------------------------- ! paddint 0 for negative values generated by dynamics ! DO k=kts,kte DO i=its,ite IF (q(i, k) .LT. 0.) THEN q(i, k) = 0. ELSE q(i, k) = q(i, k) END IF IF (qci(i, k, 1) .LT. 0.) THEN qci(i, k, 1) = 0. ELSE qci(i, k, 1) = qci(i, k, 1) END IF IF (qrs(i, k, 1) .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) END IF IF (qci(i, k, 2) .LT. 0.) THEN qci(i, k, 2) = 0. ELSE qci(i, k, 2) = qci(i, k, 2) END IF IF (qrs(i, k, 2) .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = qrs(i, k, 2) END IF IF (qrs(i, k, 3) .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = qrs(i, k, 3) END IF END DO END DO x1 = NINT(delt/dtcldcr) IF (x1 .LT. 1) THEN loops = 1 ELSE loops = x1 END IF dtcld = delt/loops IF (delt .LE. dtcldcr) dtcld = delt ! DO loop=1,loops ! !---------------------------------------------------------------- ! initialize the variables for microphysical physics CALL INIMP(prevp, psdep, pgdep, praut, psaut, pgaut, pracw, praci& & , piacr, psaci, psacw, pracs, psacr, pgacw, pgaci, pgacr, & & pgacs, pigen, pidep, pcond, pseml, pgeml, psevp, pgevp, falk& & , fall, fallc, xni, kts, kte, its, ite) !---------------------------------------------------------------- ! compute the fallout term: ! first, vertical terminal velosity for minor loops CALL FALLK(cpm, t, p, q, den, qrs, delz, dtcld, falk, fall, kte, & & kts, its, ite, kme, kms, ims, ime) CALL FALLKC(qci, fallc, den, delz, dtcld, kte, kts, its, ite, kme& & , kms, ims, ime) CALL RAINSC(fall, fallc, xl, t, q, qci, cpm, den, qrs, delz, rain& & , rainncv, dtcld, kte, kts, its, ite, kme, kms, ims, ime) CALL WARMR(t, q, qci, qrs, den, p, dtcld, xl, rh, qs, praut, pracw& & , prevp, ims, ime, kms, kme, its, ite, kts, kte) ! ! cold rain processes ! ! CALL ACCRET1(qci, den, qrs, t, q, dtcld, praci, piacr, psaci, & & pgaci, psacw, pgacw, ims, ime, kms, kme, its, ite, kts, kte& & ) CALL ACCRET2(qrs, t, q, den, dtcld, psacw, pgacw, pracs, psacr, & & pgacr, pgacs, pseml, pgeml, ims, ime, kms, kme, its, ite, & & kts, kte) CALL ACCRET3(qrs, qci, rh, t, p, den, dtcld, q, qs, psdep, pgdep, & & pigen, psaut, pgaut, psevp, pgevp, pidep, ims, ime, kms, & & kme, its, ite, kts, kte) CALL PCONADD(t, p, q, qci, qs, xl, cpm, dtcld, kte, kts, its, ite& & , kme, kms, ims, ime) END DO END SUBROUTINE WSM62D ! Differentiation of calcrh in forward (tangent) mode (with options r8): ! variations of useful results: qs rh ! with respect to varying inputs: p q t qs rh !======================================================================= ! !======================================================================= SUBROUTINE G_CALCRH(t, g_t, p, g_p, q, g_q, rh, g_rh, qs, g_qs) IMPLICIT NONE REAL, INTENT(IN) :: t, q, p REAL, INTENT(IN) :: g_t, g_q, g_p REAL, DIMENSION(3), INTENT(OUT) :: rh, qs REAL, DIMENSION(3), INTENT(OUT) :: g_rh, g_qs REAL :: tr, qs10, qs11, qs20, qs21 REAL :: g_tr, g_qs10, g_qs11, g_qs20, g_qs21 REAL, PARAMETER :: hsub=xls REAL, PARAMETER :: hvap=xlv0 REAL, PARAMETER :: cvap=cpv REAL, PARAMETER :: ttp=t0c+0.01 REAL, PARAMETER :: dldt=cvap-cliq REAL, PARAMETER :: xa=-(dldt/rv) REAL, PARAMETER :: xb=xa+hvap/(rv*ttp) REAL, PARAMETER :: dldti=cvap-cice REAL, PARAMETER :: xai=-(dldti/rv) REAL, PARAMETER :: xbi=xai+hsub/(rv*ttp) INTRINSIC LOG INTRINSIC EXP INTRINSIC MAX REAL :: max1 REAL :: g_max1 REAL :: max2 REAL :: g_max2 REAL :: arg1 REAL :: g_arg1 REAL :: temp REAL :: temp0 g_tr = -(ttp*g_t/t**2) tr = ttp/t g_arg1 = xa*g_tr/tr arg1 = LOG(tr)*xa temp = EXP(xb*(-tr+1.)) temp0 = EXP(arg1) g_qs10 = psat*(temp*EXP(arg1)*g_arg1-temp0*EXP(xb*(1.-tr))*xb*g_tr) qs10 = psat*(temp0*temp) temp0 = qs10/(p-qs10) g_qs11 = ep2*(g_qs10-temp0*(g_p-g_qs10))/(p-qs10) qs11 = ep2*temp0 g_qs(1) = g_qs11 qs(1) = qs11 IF (qs(1) .LT. qmin) THEN max1 = qmin g_max1 = 0.0_8 ELSE g_max1 = g_qs(1) max1 = qs(1) END IF g_rh(1) = (g_q-q*g_max1/max1)/max1 rh(1) = q/max1 g_arg1 = xai*g_tr/tr arg1 = LOG(tr)*xai temp0 = EXP(xbi*(-tr+1.)) temp = EXP(arg1) g_qs20 = psat*(temp0*EXP(arg1)*g_arg1-temp*EXP(xbi*(1.-tr))*xbi*g_tr& & ) qs20 = psat*(temp*temp0) temp0 = qs20/(p-qs20) g_qs21 = ep2*(g_qs20-temp0*(g_p-g_qs20))/(p-qs20) qs21 = ep2*temp0 g_qs(2) = g_qs21 qs(2) = qs21 IF (qs(2) .LT. qmin) THEN max2 = qmin g_max2 = 0.0_8 ELSE g_max2 = g_qs(2) max2 = qs(2) END IF g_rh(2) = (g_q-q*g_max2/max2)/max2 rh(2) = q/max2 END SUBROUTINE G_CALCRH !======================================================================= ! !======================================================================= SUBROUTINE CALCRH(t, p, q, rh, qs) IMPLICIT NONE REAL, INTENT(IN) :: t, q, p REAL, DIMENSION(3), INTENT(OUT) :: rh, qs REAL :: tr, qs10, qs11, qs20, qs21 REAL, PARAMETER :: hsub=xls REAL, PARAMETER :: hvap=xlv0 REAL, PARAMETER :: cvap=cpv REAL, PARAMETER :: ttp=t0c+0.01 REAL, PARAMETER :: dldt=cvap-cliq REAL, PARAMETER :: xa=-(dldt/rv) REAL, PARAMETER :: xb=xa+hvap/(rv*ttp) REAL, PARAMETER :: dldti=cvap-cice REAL, PARAMETER :: xai=-(dldti/rv) REAL, PARAMETER :: xbi=xai+hsub/(rv*ttp) INTRINSIC LOG INTRINSIC EXP INTRINSIC MAX REAL :: max1 REAL :: max2 REAL :: arg1 tr = ttp/t arg1 = LOG(tr)*xa qs10 = psat*EXP(arg1)*EXP(xb*(1.-tr)) qs11 = ep2*qs10/(p-qs10) qs(1) = qs11 IF (qs(1) .LT. qmin) THEN max1 = qmin ELSE max1 = qs(1) END IF rh(1) = q/max1 arg1 = LOG(tr)*xai qs20 = psat*EXP(arg1)*EXP(xbi*(1.-tr)) qs21 = ep2*qs20/(p-qs20) qs(2) = qs21 IF (qs(2) .LT. qmin) THEN max2 = qmin ELSE max2 = qs(2) END IF rh(2) = q/max2 END SUBROUTINE CALCRH ! !======================================================================= ! !======================================================================= SUBROUTINE WSM6RINIT() IMPLICIT NONE INTRINSIC ATAN INTRINSIC SQRT REAL :: pwx1 REAL :: pwr1 REAL :: pwr2 REAL :: pwy1 REAL :: result1 REAL :: result2 REAL :: result3 !------------------------------------------------------------------- !.... constants which may not be tunable pi = 4.*ATAN(1.) xlv1 = cliq - cpv ! 0.419e-3 -- .61e-3 qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 7.03 pwx1 = xncr*denr pwr1 = pwx1**(1./3.) pwr2 = den0**(4./3.) qck1 = .104*9.8*peaut/pwr1/xmyu*pwr2 bvtr1 = 1. + bvtr bvtr2 = 2.5 + .5*bvtr bvtr3 = 3. + bvtr bvtr4 = 4. + bvtr bvtr6 = 6. + bvtr g1pbr = RGMMA(bvtr1) g3pbr = RGMMA(bvtr3) ! 17.837825 g4pbr = RGMMA(bvtr4) g6pbr = RGMMA(bvtr6) ! 1.8273 g5pbro2 = RGMMA(bvtr2) pvtr = avtr*g4pbr/6. roqimax = 2.08e22*dimax**8 ! bvts1 = 1. + bvts bvts2 = 2.5 + .5*bvts bvts3 = 3. + bvts bvts4 = 4. + bvts !.8875 g1pbs = RGMMA(bvts1) g3pbs = RGMMA(bvts3) ! 12.0786 g4pbs = RGMMA(bvts4) g5pbso2 = RGMMA(bvts2) pvts = avts*g4pbs/6. pidn0r = pi*denr*n0r pidn0s = pi*dens*n0s bvtg1 = 1. + bvtg bvtg2 = 2.5 + .5*bvtg bvtg3 = 3. + bvtg bvtg4 = 4. + bvtg g1pbg = RGMMA(bvtg1) g3pbg = RGMMA(bvtg3) g4pbg = RGMMA(bvtg4) g5pbgo2 = RGMMA(bvtg2) pvtg = avtg*g4pbg/6. pidn0g = pi*deng*n0g pwy1 = -(bvtr/4.) pwr1 = pidn0r**pwy1 result1 = SQRT(den0) vt2r_a = pvtr*pwr1*result1 pwy1 = -(bvts/4.) pwr1 = pidn0s**pwy1 result1 = SQRT(den0) vt2s_a = pvts*pwr1*result1 pwy1 = -(bvtg/4.) pwr1 = pidn0g**pwy1 result1 = SQRT(den0) vt2g_a = pvtg*pwr1*result1 vt2i_a = 3.3 fallr_a = vt2r_a falls_a = vt2s_a fallg_a = vt2g_a falli_a = vt2i_a result1 = SQRT(pidn0r) prevp_a = 1.56*pi*n0r/result1 result1 = SQRT(avtr) pwy1 = -((5.+bvtr)/8.) pwr1 = pidn0r**pwy1 result2 = SQRT(den0) result3 = SQRT(result2) prevp_b = 130.37*pi*result1*n0r*pwr1*result3*g5pbro2 result1 = SQRT(pidn0s) psdep_a = 2.6*n0s/result1 result1 = SQRT(avts) pwy1 = -((5.+bvts)/8.) pwr1 = pidn0s**pwy1 result2 = SQRT(den0) result3 = SQRT(result2) psdep_b = 370.08*result1*n0s*pwr1*result3*g5pbso2 psevp_a = psdep_a psevp_b = psdep_b result1 = SQRT(pidn0g) pgdep_a = 1.56*pi*n0g/result1 result1 = SQRT(avtg) pwy1 = -((5.+bvtg)/8.) pwr1 = pidn0g**pwy1 result2 = SQRT(den0) result3 = SQRT(result2) pgdep_b = 130.37*pi*result1*n0g*pwr1*result3*g5pbgo2 pgevp_a = pgdep_a pgevp_b = pgdep_b result1 = SQRT(pidn0s) psmlt_a = 2.75e-3*pi*n0s/result1/xlf0 result1 = SQRT(den0) result2 = SQRT(result1) result3 = SQRT(avts) pwy1 = -((5.+bvts)/8.) pwr1 = pidn0s**pwy1 psmlt_b = 0.391*pi*n0s*result2*result3*pwr1*g5pbso2/xlf0 result1 = SQRT(pidn0g) pgmlt_a = 3.3e-3*pi*n0g/result1/xlf0 result1 = SQRT(den0) result2 = SQRT(result1) result3 = SQRT(avtg) pwy1 = -((5.+bvtg)/8.) pwr1 = pidn0g**pwy1 pgmlt_b = 0.276*pi*n0g*result2*result3*pwr1*g5pbgo2/xlf0 praci_a = pi*n0r/4. pwr1 = pidn0r**(3./4.) praci_b = 2./pwr1 result1 = SQRT(pidn0r) praci_c = 3.245e-3/result1 result1 = SQRT(pidn0r) result2 = SQRT(result1) praci_d = 2.633e-6/result2 psaci_a = pi*n0s/4. pwr1 = pidn0s**(3./4.) psaci_b = 2./pwr1 result1 = SQRT(pidn0s) psaci_c = 3.245e-3/result1 result1 = SQRT(pidn0s) result2 = SQRT(result1) psaci_d = 2.633e-6/result2 pgaci_a = pi*n0g/4. pwr1 = pidn0g**(3./4.) pgaci_b = 2./pwr1 result1 = SQRT(pidn0g) pgaci_c = 3.245e-3/result1 result1 = SQRT(pidn0g) result2 = SQRT(result1) pgaci_d = 2.633e-6/result2 pracs_a = pi*n0r*pidn0s pwr1 = pidn0s**(3./2.) result1 = SQRT(pidn0r) result2 = SQRT(result1) pracs_b = 5./pwr1/result2 pwr1 = pidn0s**(5./4.) result1 = SQRT(pidn0r) pracs_c = 2./pwr1/result1 pwr1 = pidn0r**(3./4.) pracs_d = .5/pidn0s/pwr1 psacr_a = pi*n0s*pidn0r pwr1 = pidn0r**(3./2.) result1 = SQRT(pidn0s) result2 = SQRT(result1) psacr_b = 5./pwr1/result2 pwr1 = pidn0r**(5./4.) result1 = SQRT(pidn0s) psacr_c = 2./pwr1/result1 pwr1 = pidn0s**(3./4.) psacr_d = .5/pidn0r/pwr1 pgacr_a = pi*n0g*pidn0r pwr1 = pidn0r**(3./2.) result1 = SQRT(pidn0g) result2 = SQRT(result1) pgacr_b = 5./pwr1/result2 pwr1 = pidn0r**(5./4.) result1 = SQRT(pidn0g) pgacr_c = 2./pwr1/result1 pwr1 = pidn0g**(3./4.) pgacr_d = .5/pidn0r/pwr1 pgacs_a = pi*n0g*pidn0s pwr1 = pidn0s**(3./2.) result1 = SQRT(pidn0g) result2 = SQRT(result1) pgacs_b = 5./pwr1/result2 pwr1 = pidn0s**(5./4.) result1 = SQRT(pidn0g) pgacs_c = 2./pwr1/result1 pwr1 = pidn0g**(3./4.) pgacs_d = .5/pidn0s/pwr1 pidep_a = 3.4927e5 diffac_a = 4.7274e2 diffac_b = 1.1371e4 pwr1 = pidn0r**(3./4.) pgfrz_a = 20.*pi*pfrz1/pwr1 result1 = SQRT(den0) pwy1 = -((6.+bvtr)/4.) pwr1 = pidn0r**pwy1 piacr_a = 5.38e7*pi*avtr*pidn0r*g6pbr*result1*pwr1/24. result1 = SQRT(den0) pwy1 = -((3.+bvtr)/4.) pwr1 = pidn0r**pwy1 pracw_a = .25*pi*avtr*n0r*g3pbr*result1*pwr1 result1 = SQRT(den0) pwy1 = -((3.+bvts)/4.) pwr1 = pidn0s**pwy1 psacw_a = .25*pi*avts*n0s*g3pbs*result1*pwr1 result1 = SQRT(den0) pwy1 = -((3.+bvtg)/4.) pwr1 = pidn0g**pwy1 pgacw_a = .25*pi*avtg*n0g*g3pbg*result1*pwr1 END SUBROUTINE WSM6RINIT ! Differentiation of inimp in forward (tangent) mode (with options r8): ! variations of useful results: fallc piacr psaci pgaci psacr ! praci psacw pgacr pgacs pracs pgacw pigen pracw ! psevp pidep falk fall pgevp prevp psdep pseml ! pgdep pgeml psaut pgaut praut ! with respect to varying inputs: fallc piacr psaci pgaci psacr ! praci psacw pgacr pgacs pracs pgacw pigen pracw ! psevp pidep falk fall pgevp prevp psdep pseml ! pgdep pgeml psaut pgaut praut !======================================================================= ! !======================================================================= SUBROUTINE G_INIMP(prevp, g_prevp, psdep, g_psdep, pgdep, g_pgdep, & & praut, g_praut, psaut, g_psaut, pgaut, g_pgaut, pracw, g_pracw, & & praci, g_praci, piacr, g_piacr, psaci, g_psaci, psacw, g_psacw, & & pracs, g_pracs, psacr, g_psacr, pgacw, g_pgacw, pgaci, g_pgaci, & & pgacr, g_pgacr, pgacs, g_pgacs, pigen, g_pigen, pidep, g_pidep, & & pcond, pseml, g_pseml, pgeml, g_pgeml, psevp, g_psevp, pgevp, & & g_pgevp, falk, g_falk, fall, g_fall, fallc, g_fallc, xni, kts, kte, & & its, ite) IMPLICIT NONE INTEGER :: kts, kte, its, ite, k, i REAL, DIMENSION(its:ite, kts:kte, 3) :: falk, fall REAL, DIMENSION(its:ite, kts:kte, 3) :: g_falk, g_fall REAL, DIMENSION(its:ite, kts:kte) :: xni, pgevp, pigen, pidep, pcond& & , fallc, pracw, psacw, pgacw, pgacr, pgacs, psaci, praci, piacr, & & pracs, psacr, pgaci, pseml, pgeml, psevp, praut, psaut, pgaut, prevp& & , psdep, pgdep REAL, DIMENSION(its:ite, kts:kte) :: g_pgevp, g_pigen, g_pidep, & & g_fallc, g_pracw, g_psacw, g_pgacw, g_pgacr, g_pgacs, g_psaci, & & g_praci, g_piacr, g_pracs, g_psacr, g_pgaci, g_pseml, g_pgeml, & & g_psevp, g_praut, g_psaut, g_pgaut, g_prevp, g_psdep, g_pgdep DO k=kts,kte DO i=its,ite g_prevp(i, k) = 0.0_8 prevp(i, k) = 0. g_psdep(i, k) = 0.0_8 psdep(i, k) = 0. g_pgdep(i, k) = 0.0_8 pgdep(i, k) = 0. g_praut(i, k) = 0.0_8 praut(i, k) = 0. g_psaut(i, k) = 0.0_8 psaut(i, k) = 0. g_pgaut(i, k) = 0.0_8 pgaut(i, k) = 0. g_pracw(i, k) = 0.0_8 pracw(i, k) = 0. g_praci(i, k) = 0.0_8 praci(i, k) = 0. g_piacr(i, k) = 0.0_8 piacr(i, k) = 0. g_psaci(i, k) = 0.0_8 psaci(i, k) = 0. g_psacw(i, k) = 0.0_8 psacw(i, k) = 0. g_pracs(i, k) = 0.0_8 pracs(i, k) = 0. g_psacr(i, k) = 0.0_8 psacr(i, k) = 0. g_pgacw(i, k) = 0.0_8 pgacw(i, k) = 0. g_pgaci(i, k) = 0.0_8 pgaci(i, k) = 0. g_pgacr(i, k) = 0.0_8 pgacr(i, k) = 0. g_pgacs(i, k) = 0.0_8 pgacs(i, k) = 0. g_pigen(i, k) = 0.0_8 pigen(i, k) = 0. g_pidep(i, k) = 0.0_8 pidep(i, k) = 0. pcond(i, k) = 0. g_pseml(i, k) = 0.0_8 pseml(i, k) = 0. g_pgeml(i, k) = 0.0_8 pgeml(i, k) = 0. g_psevp(i, k) = 0.0_8 psevp(i, k) = 0. g_pgevp(i, k) = 0.0_8 pgevp(i, k) = 0. g_falk(i, k, 1) = 0.0_8 falk(i, k, 1) = 0. g_falk(i, k, 2) = 0.0_8 falk(i, k, 2) = 0. g_falk(i, k, 3) = 0.0_8 falk(i, k, 3) = 0. g_fall(i, k, 1) = 0.0_8 fall(i, k, 1) = 0. g_fall(i, k, 2) = 0.0_8 fall(i, k, 2) = 0. g_fall(i, k, 3) = 0.0_8 fall(i, k, 3) = 0. g_fallc(i, k) = 0.0_8 fallc(i, k) = 0. xni(i, k) = 1.e3 END DO END DO END SUBROUTINE G_INIMP !======================================================================= ! !======================================================================= SUBROUTINE INIMP(prevp, psdep, pgdep, praut, psaut, pgaut, pracw, & & praci, piacr, psaci, psacw, pracs, psacr, pgacw, pgaci, pgacr, pgacs& & , pigen, pidep, pcond, pseml, pgeml, psevp, pgevp, falk, fall, fallc& & , xni, kts, kte, its, ite) IMPLICIT NONE INTEGER :: kts, kte, its, ite, k, i REAL, DIMENSION(its:ite, kts:kte, 3) :: falk, fall REAL, DIMENSION(its:ite, kts:kte) :: xni, pgevp, pigen, pidep, pcond& & , fallc, pracw, psacw, pgacw, pgacr, pgacs, psaci, praci, piacr, & & pracs, psacr, pgaci, pseml, pgeml, psevp, praut, psaut, pgaut, prevp& & , psdep, pgdep DO k=kts,kte DO i=its,ite prevp(i, k) = 0. psdep(i, k) = 0. pgdep(i, k) = 0. praut(i, k) = 0. psaut(i, k) = 0. pgaut(i, k) = 0. pracw(i, k) = 0. praci(i, k) = 0. piacr(i, k) = 0. psaci(i, k) = 0. psacw(i, k) = 0. pracs(i, k) = 0. psacr(i, k) = 0. pgacw(i, k) = 0. pgaci(i, k) = 0. pgacr(i, k) = 0. pgacs(i, k) = 0. pigen(i, k) = 0. pidep(i, k) = 0. pcond(i, k) = 0. pseml(i, k) = 0. pgeml(i, k) = 0. psevp(i, k) = 0. pgevp(i, k) = 0. falk(i, k, 1) = 0. falk(i, k, 2) = 0. falk(i, k, 3) = 0. fall(i, k, 1) = 0. fall(i, k, 2) = 0. fall(i, k, 3) = 0. fallc(i, k) = 0. xni(i, k) = 1.e3 END DO END DO END SUBROUTINE INIMP ! Differentiation of fallk in forward (tangent) mode (with options r8): ! variations of useful results: t cpm qrs falk fall ! with respect to varying inputs: p q t cpm delz den qrs falk ! fall !======================================================================= ! !======================================================================= SUBROUTINE G_FALLK(cpm, g_cpm, t, g_t, p, g_p, q, g_q, den, g_den, qrs& & , g_qrs, delz, g_delz, dtcld, falk, g_falk, fall, g_fall, kte, kts, & & its, ite, kme, kms, ims, ime) IMPLICIT NONE INTEGER :: kte, kts, its, ite, kme, kms, ims, ime REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, falk, fall, work1 REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs, g_falk, g_fall, & & g_work1 REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, p, q REAL, DIMENSION(ims:ime, kms:kme) :: g_delz, g_den, g_p, g_q REAL, DIMENSION(its:ite, kts:kte) :: psmlt, pgmlt, t, work2, cpm REAL, DIMENSION(its:ite, kts:kte) :: g_psmlt, g_pgmlt, g_t, g_cpm INTEGER, DIMENSION(its:ite) :: mstep, numdt REAL :: dtcld, coeres1, coeres2, coeresi, coeresh, xlf, psmlt0, & & pgmlt0, help_i, help_h, w1 REAL :: g_psmlt0, g_pgmlt0 REAL :: tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7, tmp8 REAL :: g_tmp1, g_tmp2, g_tmp3, g_tmp4, g_tmp5, g_tmp6, g_tmp7, & & g_tmp8 INTEGER :: mstepmax, k, i, n, nw, jj REAL :: fqs, fqg, supcol, a, b, c, d REAL :: g_a, g_b, g_c, g_d INTRINSIC MAX INTRINSIC MIN INTRINSIC EXP INTRINSIC NINT INTRINSIC ABS INTRINSIC SQRT REAL :: x1 REAL :: g_x1 REAL :: y1 REAL :: g_y1 REAL :: y2 REAL :: g_y2 REAL :: y3 REAL :: g_y3 REAL :: max1 REAL :: g_max1 REAL :: max2 REAL :: g_max2 REAL :: max3 REAL :: g_max3 REAL :: abs0 REAL :: abs1 REAL :: max4 REAL :: g_max4 REAL :: max5 REAL :: g_max5 REAL :: max6 REAL :: g_max6 REAL :: abs2 REAL :: max7 REAL :: g_max7 REAL :: abs3 REAL :: max8 REAL :: g_max8 REAL :: max9 REAL :: g_max9 REAL :: max10 REAL :: g_max10 REAL :: pwy1 REAL :: pwr1 REAL :: g_pwr1 REAL :: pwy2 REAL :: pwr2 REAL :: g_pwr2 REAL :: arg1 REAL :: g_arg1 REAL :: pwx2 REAL :: g_pwx2 REAL :: result1 REAL :: g_result1 REAL :: pwy3 REAL :: pwr3 REAL :: g_pwr3 REAL :: temp REAL :: temp0 mstep = 1 mstepmax = 1 numdt = 1 g_work1 = 0.0_8 DO k=kte,kts,-1 DO i=its,ite IF (qcrmin .LT. qrs(i, k, 1)) THEN g_max1 = g_qrs(i, k, 1) max1 = qrs(i, k, 1) ELSE max1 = qcrmin g_max1 = 0.0_8 END IF pwy1 = (bvtr-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvtr/4. IF (max1 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max1**(pwy2-1)*g_max1 END IF pwr2 = max1**pwy2 temp = pwr1*pwr2/delz(i, k) g_work1(i, k, 1) = vt2r_a*(pwr2*g_pwr1+pwr1*g_pwr2-temp*g_delz(i& & , k))/delz(i, k) work1(i, k, 1) = vt2r_a*temp IF (qcrmin .LT. qrs(i, k, 2)) THEN g_max2 = g_qrs(i, k, 2) max2 = qrs(i, k, 2) ELSE max2 = qcrmin g_max2 = 0.0_8 END IF IF (90. .GT. t0c - t(i, k)) THEN g_y3 = -g_t(i, k) y3 = t0c - t(i, k) ELSE y3 = 90. g_y3 = 0.0_8 END IF IF (0. .LT. y3) THEN g_max8 = g_y3 max8 = y3 ELSE max8 = 0. g_max8 = 0.0_8 END IF pwy1 = (bvts-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvts/4. IF (max2 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max2**(pwy2-1)*g_max2 END IF pwr2 = max2**pwy2 g_arg1 = -(bvts*alpha*g_max8/4.) arg1 = -(bvts*alpha*max8/4.) temp = EXP(arg1) temp0 = pwr1*pwr2/delz(i, k) g_work1(i, k, 2) = vt2s_a*(temp*(pwr2*g_pwr1+pwr1*g_pwr2-temp0*& & g_delz(i, k))/delz(i, k)+temp0*EXP(arg1)*g_arg1) work1(i, k, 2) = vt2s_a*(temp0*temp) IF (qcrmin .LT. qrs(i, k, 3)) THEN g_max3 = g_qrs(i, k, 3) max3 = qrs(i, k, 3) ELSE max3 = qcrmin g_max3 = 0.0_8 END IF pwy1 = (bvtg-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvtg/4. IF (max3 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max3**(pwy2-1)*g_max3 END IF pwr2 = max3**pwy2 temp0 = pwr1*pwr2/delz(i, k) g_work1(i, k, 3) = vt2g_a*(pwr2*g_pwr1+pwr1*g_pwr2-temp0*g_delz(& & i, k))/delz(i, k) work1(i, k, 3) = vt2g_a*temp0 IF (work1(i, k, 1) .GE. work1(i, k, 2) .AND. work1(i, k, 1) .GE.& & work1(i, k, 3)) THEN w1 = work1(i, k, 1) ELSE IF (work1(i, k, 2) .GE. work1(i, k, 1) .AND. work1(i, k, 2)& & .GE. work1(i, k, 3)) THEN w1 = work1(i, k, 2) ELSE w1 = work1(i, k, 3) END IF nw = NINT(w1*dtcld + .5) IF (nw .GT. 1) THEN numdt(i) = nw ELSE numdt(i) = 1 END IF IF (numdt(i) .GE. mstep(i)) mstep(i) = numdt(i) END DO END DO DO i=its,ite IF (mstepmax .LE. mstep(i)) mstepmax = mstep(i) END DO g_psmlt = 0.0_8 g_pgmlt = 0.0_8 DO n=1,mstepmax DO i=its,ite IF (n .LE. mstep(i)) THEN k = kte temp0 = qrs(i, k, 1)*work1(i, k, 1) temp = den(i, k)/mstep(i) g_falk(i, k, 1) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i, & & k, 1)*g_qrs(i, k, 1)+qrs(i, k, 1)*g_work1(i, k, 1)) falk(i, k, 1) = temp*temp0 temp0 = qrs(i, k, 2)*work1(i, k, 2) temp = den(i, k)/mstep(i) g_falk(i, k, 2) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i, & & k, 2)*g_qrs(i, k, 2)+qrs(i, k, 2)*g_work1(i, k, 2)) falk(i, k, 2) = temp*temp0 temp0 = qrs(i, k, 3)*work1(i, k, 3) temp = den(i, k)/mstep(i) g_falk(i, k, 3) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i, & & k, 3)*g_qrs(i, k, 3)+qrs(i, k, 3)*g_work1(i, k, 3)) falk(i, k, 3) = temp*temp0 g_fall(i, k, 1) = g_fall(i, k, 1) + g_falk(i, k, 1) fall(i, k, 1) = fall(i, k, 1) + falk(i, k, 1) g_fall(i, k, 2) = g_fall(i, k, 2) + g_falk(i, k, 2) fall(i, k, 2) = fall(i, k, 2) + falk(i, k, 2) g_fall(i, k, 3) = g_fall(i, k, 3) + g_falk(i, k, 3) fall(i, k, 3) = fall(i, k, 3) + falk(i, k, 3) DO jj=1,3 temp0 = falk(i, k, jj)/den(i, k) g_x1 = dtcld*(g_falk(i, k, jj)-temp0*g_den(i, k))/den(i, k) x1 = dtcld*temp0 IF (x1 .GT. qrs(i, k, jj)) THEN g_tmp1 = g_qrs(i, k, jj) tmp1 = qrs(i, k, jj) ELSE g_tmp1 = g_x1 tmp1 = x1 END IF IF (tmp1 .GE. 0.) THEN abs0 = tmp1 ELSE abs0 = -tmp1 END IF IF (abs0 .LT. qmin) THEN tmp1 = 0. g_tmp1 = 0.0_8 END IF g_qrs(i, k, jj) = g_qrs(i, k, jj) - g_tmp1 qrs(i, k, jj) = qrs(i, k, jj) - tmp1 END DO END IF END DO DO k=kte-1,kts,-1 DO i=its,ite IF (n .LE. mstep(i)) THEN temp0 = qrs(i, k, 1)*work1(i, k, 1) temp = den(i, k)/mstep(i) g_falk(i, k, 1) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i& & , k, 1)*g_qrs(i, k, 1)+qrs(i, k, 1)*g_work1(i, k, 1)) falk(i, k, 1) = temp*temp0 temp0 = qrs(i, k, 2)*work1(i, k, 2) temp = den(i, k)/mstep(i) g_falk(i, k, 2) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i& & , k, 2)*g_qrs(i, k, 2)+qrs(i, k, 2)*g_work1(i, k, 2)) falk(i, k, 2) = temp*temp0 temp0 = qrs(i, k, 3)*work1(i, k, 3) temp = den(i, k)/mstep(i) g_falk(i, k, 3) = temp0*g_den(i, k)/mstep(i) + temp*(work1(i& & , k, 3)*g_qrs(i, k, 3)+qrs(i, k, 3)*g_work1(i, k, 3)) falk(i, k, 3) = temp*temp0 g_fall(i, k, 1) = g_fall(i, k, 1) + g_falk(i, k, 1) fall(i, k, 1) = fall(i, k, 1) + falk(i, k, 1) g_fall(i, k, 2) = g_fall(i, k, 2) + g_falk(i, k, 2) fall(i, k, 2) = fall(i, k, 2) + falk(i, k, 2) g_fall(i, k, 3) = g_fall(i, k, 3) + g_falk(i, k, 3) fall(i, k, 3) = fall(i, k, 3) + falk(i, k, 3) DO jj=1,3 IF ((falk(i, k, jj)-falk(i, k+1, jj)*delz(i, k+1)/delz(i, & & k))*dtcld/den(i, k) .GT. qrs(i, k, jj)) THEN g_tmp2 = g_qrs(i, k, jj) tmp2 = qrs(i, k, jj) ELSE temp0 = delz(i, k+1)/delz(i, k) temp = (falk(i, k, jj)-falk(i, k+1, jj)*temp0)/den(i, k) g_tmp2 = dtcld*(g_falk(i, k, jj)-temp0*g_falk(i, k+1, jj& & )-falk(i, k+1, jj)*(g_delz(i, k+1)-temp0*g_delz(i, k))& & /delz(i, k)-temp*g_den(i, k))/den(i, k) tmp2 = dtcld*temp END IF IF (tmp2 .GE. 0.) THEN abs1 = tmp2 ELSE abs1 = -tmp2 END IF IF (abs1 .LT. qmin) THEN tmp2 = 0. g_tmp2 = 0.0_8 END IF g_qrs(i, k, jj) = g_qrs(i, k, jj) - g_tmp2 qrs(i, k, jj) = qrs(i, k, jj) - tmp2 END DO END IF END DO END DO DO k=kte,kts,-1 DO i=its,ite IF (n .LE. mstep(i)) THEN ! !--------------------------------------------------------------- ! psmlt: melting of snow [RH83 A25] ! (T>T0: S->R) psmlt<0: min=-qrs(i,k,2), max=0 !--------------------------------------------------------------- !update xl, cpm g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k)) xlf = xlf0 IF (90. .GT. t0c - t(i, k)) THEN g_y1 = -g_t(i, k) y1 = t0c - t(i, k) ELSE y1 = 90. g_y1 = 0.0_8 END IF IF (0. .LT. y1) THEN g_max4 = g_y1 max4 = y1 ELSE max4 = 0. g_max4 = 0.0_8 END IF temp0 = alpha*max4/2. g_a = EXP(temp0)*alpha*g_max4/2. a = EXP(temp0) IF (90. .GT. t0c - t(i, k)) THEN g_y2 = -g_t(i, k) y2 = t0c - t(i, k) ELSE y2 = 90. g_y2 = 0.0_8 END IF IF (0. .LT. y2) THEN g_max5 = g_y2 max5 = y2 ELSE max5 = 0. g_max5 = 0.0_8 END IF g_arg1 = alpha*(3-bvts)*g_max5/8. arg1 = alpha*max5*(3-bvts)/8. g_b = EXP(arg1)*g_arg1 b = EXP(arg1) temp0 = (t0c-t(i, k))/(t(i, k)+120.) temp = t(i, k)**1.5 g_c = (temp0*1.5*t(i, k)**0.5-temp*(temp0+1.0)/(t(i, k)+120.& & ))*g_t(i, k) c = temp*temp0 IF (t(i, k) .LE. 0.0_8 .AND. (3.88/6. .EQ. 0.0_8 .OR. 3.88/& & 6. .NE. INT(3.88/6.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.88*t(i, k)**(3.88/6.-1)*g_t(i, k)/6. END IF pwr1 = t(i, k)**(3.88/6.) g_pwx2 = g_t(i, k) pwx2 = t(i, k) + 120. IF (pwx2 .LE. 0.0_8 .AND. (5./6. .EQ. 0.0_8 .OR. 5./6. .NE. & & INT(5./6.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 5.*pwx2**(5./6.-1)*g_pwx2/6. END IF pwr2 = pwx2**(5./6.) temp0 = pwr1/pwr2 g_d = (t0c-t(i, k))*(g_pwr1-temp0*g_pwr2)/pwr2 - temp0*g_t(i& & , k) d = (t0c-t(i, k))*temp0 IF (qrs(i, k, 2) .LT. qcrmin) THEN max6 = qcrmin g_max6 = 0.0_8 ELSE g_max6 = g_qrs(i, k, 2) max6 = qrs(i, k, 2) END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max9 = qcrmin g_max9 = 0.0_8 ELSE g_max9 = g_qrs(i, k, 2) max9 = qrs(i, k, 2) END IF g_arg1 = max6*g_den(i, k) + den(i, k)*g_max6 arg1 = den(i, k)*max6 temp0 = SQRT(arg1) IF (arg1 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_arg1/(2.0*temp0) END IF result1 = temp0 IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. & & .NE. INT(1.0/3.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3. END IF pwr1 = p(i, k)**(1./3.) pwy2 = (13.+3*bvts)/24. IF (den(i, k) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 & & .NE. INT(pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*den(i, k)**(pwy2-1)*g_den(i, k) END IF pwr2 = den(i, k)**pwy2 pwy3 = (5.+bvts)/8. IF (max9 .LE. 0.0_8 .AND. (pwy3 .EQ. 0.0_8 .OR. pwy3 .NE. & & INT(pwy3))) THEN g_pwr3 = 0.0_8 ELSE g_pwr3 = pwy3*max9**(pwy3-1)*g_max9 END IF pwr3 = max9**pwy3 temp0 = b*d*pwr3 g_psmlt0 = psmlt_a*(result1*(c*g_a+a*g_c)+a*c*g_result1) + & & psmlt_b*(pwr1*pwr2*(pwr3*(d*g_b+b*g_d)+b*d*g_pwr3)+temp0*(& & pwr2*g_pwr1+pwr1*g_pwr2)) psmlt0 = psmlt_a*(a*c*result1) + psmlt_b*(temp0*(pwr1*pwr2)) g_tmp3 = dtcld*g_psmlt0/mstep(i) tmp3 = psmlt0*dtcld/mstep(i) g_tmp4 = -(g_qrs(i, k, 2)/mstep(i)) tmp4 = -(qrs(i, k, 2)/mstep(i)) IF (tmp3 .GT. tmp4) THEN g_tmp5 = g_tmp3 tmp5 = tmp3 ELSE g_tmp5 = g_tmp4 tmp5 = tmp4 END IF IF (tmp5 .LT. 0.) THEN g_psmlt(i, k) = g_tmp5 psmlt(i, k) = tmp5 ELSE g_psmlt(i, k) = 0.0_8 psmlt(i, k) = 0. END IF IF (psmlt(i, k) .GE. 0.) THEN abs2 = psmlt(i, k) ELSE abs2 = -psmlt(i, k) END IF IF (abs2 .LT. qmin) THEN g_psmlt(i, k) = 0.0_8 psmlt(i, k) = 0. END IF IF (qrs(i, k, 2) + psmlt(i, k) .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_qrs(i, k, 2) + g_psmlt(i, k) qrs(i, k, 2) = qrs(i, k, 2) + psmlt(i, k) END IF IF (qrs(i, k, 1) - psmlt(i, k) .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_qrs(i, k, 1) - g_psmlt(i, k) qrs(i, k, 1) = qrs(i, k, 1) - psmlt(i, k) END IF temp0 = psmlt(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + xlf*(g_psmlt(i, k)-temp0*g_cpm(i, k)& & )/cpm(i, k) t(i, k) = t(i, k) + xlf*temp0 END IF END DO END DO !--------------------------------------------------------------- ! pgmlt: melting of graupel [LFO 47] ! (T>T0: G->R) pgmlt<0: min=-qrs(i,k,3), max=0 !--------------------------------------------------------------- DO k=kte,kts,-1 DO i=its,ite IF (n .LE. mstep(i)) THEN !update xl, cpm xlf = xlf0 ! cpm(i,k)=cpmcal(q(i,k)) ! not change temp0 = (t0c-t(i, k))/(t(i, k)+120.) temp = t(i, k)**1.5 g_c = (temp0*1.5*t(i, k)**0.5-temp*(temp0+1.0)/(t(i, k)+120.& & ))*g_t(i, k) c = temp*temp0 IF (t(i, k) .LE. 0.0_8 .AND. (3.88/6. .EQ. 0.0_8 .OR. 3.88/& & 6. .NE. INT(3.88/6.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.88*t(i, k)**(3.88/6.-1)*g_t(i, k)/6. END IF pwr1 = t(i, k)**(3.88/6.) g_pwx2 = g_t(i, k) pwx2 = t(i, k) + 120. IF (pwx2 .LE. 0.0_8 .AND. (5./6. .EQ. 0.0_8 .OR. 5./6. .NE. & & INT(5./6.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 5.*pwx2**(5./6.-1)*g_pwx2/6. END IF pwr2 = pwx2**(5./6.) temp0 = pwr1/pwr2 g_d = (t0c-t(i, k))*(g_pwr1-temp0*g_pwr2)/pwr2 - temp0*g_t(i& & , k) d = (t0c-t(i, k))*temp0 IF (qrs(i, k, 3) .LT. qcrmin) THEN max7 = qcrmin g_max7 = 0.0_8 ELSE g_max7 = g_qrs(i, k, 3) max7 = qrs(i, k, 3) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max10 = qcrmin g_max10 = 0.0_8 ELSE g_max10 = g_qrs(i, k, 3) max10 = qrs(i, k, 3) END IF g_arg1 = max7*g_den(i, k) + den(i, k)*g_max7 arg1 = den(i, k)*max7 temp0 = SQRT(arg1) IF (arg1 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_arg1/(2.0*temp0) END IF result1 = temp0 IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. & & .NE. INT(1.0/3.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3. END IF pwr1 = p(i, k)**(1./3.) pwy2 = (13.+3*bvtg)/24. IF (den(i, k) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 & & .NE. INT(pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*den(i, k)**(pwy2-1)*g_den(i, k) END IF pwr2 = den(i, k)**pwy2 pwy3 = (5.+bvtg)/8. IF (max10 .LE. 0.0_8 .AND. (pwy3 .EQ. 0.0_8 .OR. pwy3 .NE. & & INT(pwy3))) THEN g_pwr3 = 0.0_8 ELSE g_pwr3 = pwy3*max10**(pwy3-1)*g_max10 END IF pwr3 = max10**pwy3 g_pgmlt0 = pgmlt_a*(result1*g_c+c*g_result1) + pgmlt_b*(pwr2& & *pwr3*(pwr1*g_d+d*g_pwr1)+d*pwr1*(pwr3*g_pwr2+pwr2*g_pwr3)& & ) pgmlt0 = pgmlt_a*c*result1 + pgmlt_b*d*pwr1*pwr2*pwr3 g_tmp6 = dtcld*g_pgmlt0/mstep(i) tmp6 = pgmlt0*dtcld/mstep(i) g_tmp7 = -(g_qrs(i, k, 3)/mstep(i)) tmp7 = -(qrs(i, k, 3)/mstep(i)) IF (tmp6 .GT. tmp7) THEN g_tmp8 = g_tmp6 tmp8 = tmp6 ELSE g_tmp8 = g_tmp7 tmp8 = tmp7 END IF IF (tmp8 .LT. 0.) THEN g_pgmlt(i, k) = g_tmp8 pgmlt(i, k) = tmp8 ELSE g_pgmlt(i, k) = 0.0_8 pgmlt(i, k) = 0. END IF IF (pgmlt(i, k) .GE. 0.) THEN abs3 = pgmlt(i, k) ELSE abs3 = -pgmlt(i, k) END IF IF (abs3 .LT. qmin) THEN g_pgmlt(i, k) = 0.0_8 pgmlt(i, k) = 0. END IF IF (qrs(i, k, 3) + pgmlt(i, k) .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_qrs(i, k, 3) + g_pgmlt(i, k) qrs(i, k, 3) = qrs(i, k, 3) + pgmlt(i, k) END IF IF (qrs(i, k, 1) - pgmlt(i, k) .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_qrs(i, k, 1) - g_pgmlt(i, k) qrs(i, k, 1) = qrs(i, k, 1) - pgmlt(i, k) END IF temp0 = pgmlt(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + xlf*(g_pgmlt(i, k)-temp0*g_cpm(i, k)& & )/cpm(i, k) t(i, k) = t(i, k) + xlf*temp0 END IF END DO END DO END DO END SUBROUTINE G_FALLK !======================================================================= ! !======================================================================= SUBROUTINE FALLK(cpm, t, p, q, den, qrs, delz, dtcld, falk, fall, kte& & , kts, its, ite, kme, kms, ims, ime) IMPLICIT NONE INTEGER :: kte, kts, its, ite, kme, kms, ims, ime REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, falk, fall, work1 REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, p, q REAL, DIMENSION(its:ite, kts:kte) :: psmlt, pgmlt, t, work2, cpm INTEGER, DIMENSION(its:ite) :: mstep, numdt REAL :: dtcld, coeres1, coeres2, coeresi, coeresh, xlf, psmlt0, & & pgmlt0, help_i, help_h, w1 REAL :: tmp1, tmp2, tmp3, tmp4, tmp5, tmp6, tmp7, tmp8 INTEGER :: mstepmax, k, i, n, nw, jj REAL :: fqs, fqg, supcol, a, b, c, d INTRINSIC MAX INTRINSIC MIN INTRINSIC EXP INTRINSIC NINT INTRINSIC ABS INTRINSIC SQRT REAL :: x1 REAL :: y1 REAL :: y2 REAL :: y3 REAL :: max1 REAL :: max2 REAL :: max3 REAL :: abs0 REAL :: abs1 REAL :: max4 REAL :: max5 REAL :: max6 REAL :: abs2 REAL :: max7 REAL :: abs3 REAL :: max8 REAL :: max9 REAL :: max10 REAL :: pwy1 REAL :: pwr1 REAL :: pwy2 REAL :: pwr2 REAL :: arg1 REAL :: pwx2 REAL :: result1 REAL :: pwy3 REAL :: pwr3 mstep = 1 mstepmax = 1 numdt = 1 DO k=kte,kts,-1 DO i=its,ite IF (qcrmin .LT. qrs(i, k, 1)) THEN max1 = qrs(i, k, 1) ELSE max1 = qcrmin END IF pwy1 = (bvtr-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvtr/4. pwr2 = max1**pwy2 work1(i, k, 1) = vt2r_a*pwr1*pwr2/delz(i, k) IF (qcrmin .LT. qrs(i, k, 2)) THEN max2 = qrs(i, k, 2) ELSE max2 = qcrmin END IF IF (90. .GT. t0c - t(i, k)) THEN y3 = t0c - t(i, k) ELSE y3 = 90. END IF IF (0. .LT. y3) THEN max8 = y3 ELSE max8 = 0. END IF pwy1 = (bvts-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvts/4. pwr2 = max2**pwy2 arg1 = -(bvts*alpha*max8/4.) work1(i, k, 2) = vt2s_a*pwr1*pwr2/delz(i, k)*EXP(arg1) IF (qcrmin .LT. qrs(i, k, 3)) THEN max3 = qrs(i, k, 3) ELSE max3 = qcrmin END IF pwy1 = (bvtg-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvtg/4. pwr2 = max3**pwy2 work1(i, k, 3) = vt2g_a*pwr1*pwr2/delz(i, k) IF (work1(i, k, 1) .GE. work1(i, k, 2) .AND. work1(i, k, 1) .GE.& & work1(i, k, 3)) THEN w1 = work1(i, k, 1) ELSE IF (work1(i, k, 2) .GE. work1(i, k, 1) .AND. work1(i, k, 2)& & .GE. work1(i, k, 3)) THEN w1 = work1(i, k, 2) ELSE w1 = work1(i, k, 3) END IF nw = NINT(w1*dtcld + .5) IF (nw .GT. 1) THEN numdt(i) = nw ELSE numdt(i) = 1 END IF IF (numdt(i) .GE. mstep(i)) mstep(i) = numdt(i) END DO END DO DO i=its,ite IF (mstepmax .LE. mstep(i)) mstepmax = mstep(i) END DO DO n=1,mstepmax DO i=its,ite IF (n .LE. mstep(i)) THEN k = kte falk(i, k, 1) = den(i, k)*qrs(i, k, 1)*work1(i, k, 1)/mstep(i) falk(i, k, 2) = den(i, k)*qrs(i, k, 2)*work1(i, k, 2)/mstep(i) falk(i, k, 3) = den(i, k)*qrs(i, k, 3)*work1(i, k, 3)/mstep(i) fall(i, k, 1) = fall(i, k, 1) + falk(i, k, 1) fall(i, k, 2) = fall(i, k, 2) + falk(i, k, 2) fall(i, k, 3) = fall(i, k, 3) + falk(i, k, 3) DO jj=1,3 x1 = falk(i, k, jj)*dtcld/den(i, k) IF (x1 .GT. qrs(i, k, jj)) THEN tmp1 = qrs(i, k, jj) ELSE tmp1 = x1 END IF IF (tmp1 .GE. 0.) THEN abs0 = tmp1 ELSE abs0 = -tmp1 END IF IF (abs0 .LT. qmin) tmp1 = 0. qrs(i, k, jj) = qrs(i, k, jj) - tmp1 END DO END IF END DO DO k=kte-1,kts,-1 DO i=its,ite IF (n .LE. mstep(i)) THEN falk(i, k, 1) = den(i, k)*qrs(i, k, 1)*work1(i, k, 1)/mstep(& & i) falk(i, k, 2) = den(i, k)*qrs(i, k, 2)*work1(i, k, 2)/mstep(& & i) falk(i, k, 3) = den(i, k)*qrs(i, k, 3)*work1(i, k, 3)/mstep(& & i) fall(i, k, 1) = fall(i, k, 1) + falk(i, k, 1) fall(i, k, 2) = fall(i, k, 2) + falk(i, k, 2) fall(i, k, 3) = fall(i, k, 3) + falk(i, k, 3) DO jj=1,3 IF ((falk(i, k, jj)-falk(i, k+1, jj)*delz(i, k+1)/delz(i, & & k))*dtcld/den(i, k) .GT. qrs(i, k, jj)) THEN tmp2 = qrs(i, k, jj) ELSE tmp2 = (falk(i, k, jj)-falk(i, k+1, jj)*delz(i, k+1)/& & delz(i, k))*dtcld/den(i, k) END IF IF (tmp2 .GE. 0.) THEN abs1 = tmp2 ELSE abs1 = -tmp2 END IF IF (abs1 .LT. qmin) tmp2 = 0. qrs(i, k, jj) = qrs(i, k, jj) - tmp2 END DO END IF END DO END DO DO k=kte,kts,-1 DO i=its,ite IF (n .LE. mstep(i)) THEN ! !--------------------------------------------------------------- ! psmlt: melting of snow [RH83 A25] ! (T>T0: S->R) psmlt<0: min=-qrs(i,k,2), max=0 !--------------------------------------------------------------- !update xl, cpm cpm(i, k) = CPMCAL(q(i, k)) xlf = xlf0 IF (90. .GT. t0c - t(i, k)) THEN y1 = t0c - t(i, k) ELSE y1 = 90. END IF IF (0. .LT. y1) THEN max4 = y1 ELSE max4 = 0. END IF a = EXP(alpha*max4/2.) IF (90. .GT. t0c - t(i, k)) THEN y2 = t0c - t(i, k) ELSE y2 = 90. END IF IF (0. .LT. y2) THEN max5 = y2 ELSE max5 = 0. END IF arg1 = alpha*max5*(3-bvts)/8. b = EXP(arg1) c = t(i, k)**1.5*(t0c-t(i, k))/(t(i, k)+120.) pwr1 = t(i, k)**(3.88/6.) pwx2 = t(i, k) + 120. pwr2 = pwx2**(5./6.) d = pwr1*(t0c-t(i, k))/pwr2 IF (qrs(i, k, 2) .LT. qcrmin) THEN max6 = qcrmin ELSE max6 = qrs(i, k, 2) END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max9 = qcrmin ELSE max9 = qrs(i, k, 2) END IF arg1 = den(i, k)*max6 result1 = SQRT(arg1) pwr1 = p(i, k)**(1./3.) pwy2 = (13.+3*bvts)/24. pwr2 = den(i, k)**pwy2 pwy3 = (5.+bvts)/8. pwr3 = max9**pwy3 psmlt0 = psmlt_a*a*c*result1 + psmlt_b*b*d*pwr1*pwr2*pwr3 tmp3 = psmlt0*dtcld/mstep(i) tmp4 = -(qrs(i, k, 2)/mstep(i)) IF (tmp3 .GT. tmp4) THEN tmp5 = tmp3 ELSE tmp5 = tmp4 END IF IF (tmp5 .LT. 0.) THEN psmlt(i, k) = tmp5 ELSE psmlt(i, k) = 0. END IF IF (psmlt(i, k) .GE. 0.) THEN abs2 = psmlt(i, k) ELSE abs2 = -psmlt(i, k) END IF IF (abs2 .LT. qmin) psmlt(i, k) = 0. IF (qrs(i, k, 2) + psmlt(i, k) .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = qrs(i, k, 2) + psmlt(i, k) END IF IF (qrs(i, k, 1) - psmlt(i, k) .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) - psmlt(i, k) END IF t(i, k) = t(i, k) + xlf/cpm(i, k)*psmlt(i, k) END IF END DO END DO !--------------------------------------------------------------- ! pgmlt: melting of graupel [LFO 47] ! (T>T0: G->R) pgmlt<0: min=-qrs(i,k,3), max=0 !--------------------------------------------------------------- DO k=kte,kts,-1 DO i=its,ite IF (n .LE. mstep(i)) THEN !update xl, cpm xlf = xlf0 ! cpm(i,k)=cpmcal(q(i,k)) ! not change c = t(i, k)**1.5*(t0c-t(i, k))/(t(i, k)+120.) pwr1 = t(i, k)**(3.88/6.) pwx2 = t(i, k) + 120. pwr2 = pwx2**(5./6.) d = pwr1*(t0c-t(i, k))/pwr2 IF (qrs(i, k, 3) .LT. qcrmin) THEN max7 = qcrmin ELSE max7 = qrs(i, k, 3) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max10 = qcrmin ELSE max10 = qrs(i, k, 3) END IF arg1 = den(i, k)*max7 result1 = SQRT(arg1) pwr1 = p(i, k)**(1./3.) pwy2 = (13.+3*bvtg)/24. pwr2 = den(i, k)**pwy2 pwy3 = (5.+bvtg)/8. pwr3 = max10**pwy3 pgmlt0 = pgmlt_a*c*result1 + pgmlt_b*d*pwr1*pwr2*pwr3 tmp6 = pgmlt0*dtcld/mstep(i) tmp7 = -(qrs(i, k, 3)/mstep(i)) IF (tmp6 .GT. tmp7) THEN tmp8 = tmp6 ELSE tmp8 = tmp7 END IF IF (tmp8 .LT. 0.) THEN pgmlt(i, k) = tmp8 ELSE pgmlt(i, k) = 0. END IF IF (pgmlt(i, k) .GE. 0.) THEN abs3 = pgmlt(i, k) ELSE abs3 = -pgmlt(i, k) END IF IF (abs3 .LT. qmin) pgmlt(i, k) = 0. IF (qrs(i, k, 3) + pgmlt(i, k) .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = qrs(i, k, 3) + pgmlt(i, k) END IF IF (qrs(i, k, 1) - pgmlt(i, k) .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) - pgmlt(i, k) END IF t(i, k) = t(i, k) + xlf/cpm(i, k)*pgmlt(i, k) END IF END DO END DO END DO END SUBROUTINE FALLK ! Differentiation of fallkc in forward (tangent) mode (with options r8): ! variations of useful results: fallc qci ! with respect to varying inputs: fallc delz den qci !======================================================================= ! !======================================================================= SUBROUTINE G_FALLKC(qci, g_qci, fallc, g_fallc, den, g_den, delz, & & g_delz, dtcld, kte, kts, its, ite, kme, kms, ims, ime) IMPLICIT NONE INTEGER :: kte, kts, its, ite, kme, kms, ims, ime REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci REAL, DIMENSION(ims:ime, kms:kme) :: delz, den REAL, DIMENSION(ims:ime, kms:kme) :: g_delz, g_den REAL, DIMENSION(its:ite, kts:kte) :: falkc, work1c, work2c, xni, & & fallc REAL, DIMENSION(its:ite, kts:kte) :: g_falkc, g_fallc INTEGER, DIMENSION(its:ite) :: mstep, numdt REAL :: dtcld, xmi, diameter, temp1, temp2, temp3, temp4, temp5, & & temp0 REAL :: g_temp3, g_temp4 INTEGER :: mstepmax, k, i, n INTRINSIC NINT INTRINSIC MAX INTRINSIC MIN INTRINSIC ABS INTEGER :: x1 REAL :: x2 REAL :: g_x2 REAL :: abs0 REAL :: abs1 REAL :: pwx1 REAL :: g_pwx1 REAL :: pwr1 REAL :: g_pwr1 REAL :: temp REAL :: temp6 mstepmax = 1 mstep = 1 numdt = 1 DO k=kte,kts,-1 DO i=its,ite pwx1 = den(i, k)*qci(i, k, 2) pwr1 = pwx1**(1.31/8.) work1c(i, k) = vt2i_a*pwr1 work2c(i, k) = work1c(i, k)/delz(i, k) x1 = NINT(work2c(i, k)*dtcld + .5) IF (x1 .LT. 1) THEN numdt(i) = 1 ELSE numdt(i) = x1 END IF IF (numdt(i) .GE. mstep(i)) mstep(i) = numdt(i) END DO END DO DO i=its,ite IF (mstepmax .LE. mstep(i)) mstepmax = mstep(i) END DO g_falkc = 0.0_8 DO n=1,mstepmax k = kte DO i=its,ite IF (n .LE. mstep(i)) THEN g_pwx1 = qci(i, k, 2)*g_den(i, k) + den(i, k)*g_qci(i, k, 2) pwx1 = den(i, k)*qci(i, k, 2) IF (pwx1 .LE. 0.0_8 .AND. (9.31/8. .EQ. 0.0_8 .OR. 9.31/8. & & .NE. INT(9.31/8.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 9.31*pwx1**(9.31/8.-1)*g_pwx1/8. END IF pwr1 = pwx1**(9.31/8.) temp = mstep(i)*delz(i, k) g_falkc(i, k) = falli_a*(g_pwr1-pwr1*mstep(i)*g_delz(i, k)/& & temp)/temp falkc(i, k) = falli_a*(pwr1/temp) g_fallc(i, k) = g_fallc(i, k) + g_falkc(i, k) fallc(i, k) = fallc(i, k) + falkc(i, k) temp = falkc(i, k)/den(i, k) g_x2 = dtcld*(g_falkc(i, k)-temp*g_den(i, k))/den(i, k) x2 = dtcld*temp IF (x2 .GT. qci(i, k, 2)) THEN g_temp3 = g_qci(i, k, 2) temp3 = qci(i, k, 2) ELSE g_temp3 = g_x2 temp3 = x2 END IF IF (temp3 .GE. 0.) THEN abs0 = temp3 ELSE abs0 = -temp3 END IF IF (abs0 .LT. qmin) THEN temp3 = 0. g_temp3 = 0.0_8 END IF g_qci(i, k, 2) = g_qci(i, k, 2) - g_temp3 qci(i, k, 2) = qci(i, k, 2) - temp3 END IF END DO DO k=kte-1,kts,-1 DO i=its,ite IF (n .LE. mstep(i)) THEN g_pwx1 = qci(i, k, 2)*g_den(i, k) + den(i, k)*g_qci(i, k, 2) pwx1 = den(i, k)*qci(i, k, 2) IF (pwx1 .LE. 0.0_8 .AND. (9.31/8. .EQ. 0.0_8 .OR. 9.31/8. & & .NE. INT(9.31/8.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 9.31*pwx1**(9.31/8.-1)*g_pwx1/8. END IF pwr1 = pwx1**(9.31/8.) temp = mstep(i)*delz(i, k) g_falkc(i, k) = falli_a*(g_pwr1-pwr1*mstep(i)*g_delz(i, k)/& & temp)/temp falkc(i, k) = falli_a*(pwr1/temp) g_fallc(i, k) = g_fallc(i, k) + g_falkc(i, k) fallc(i, k) = fallc(i, k) + falkc(i, k) IF ((falkc(i, k)-falkc(i, k+1)*delz(i, k+1)/delz(i, k))*& & dtcld/den(i, k) .GT. qci(i, k, 2)) THEN g_temp4 = g_qci(i, k, 2) temp4 = qci(i, k, 2) ELSE temp = falkc(i, k+1)/delz(i, k) temp6 = (falkc(i, k)-temp*delz(i, k+1))/den(i, k) g_temp4 = dtcld*(g_falkc(i, k)-delz(i, k+1)*(g_falkc(i, k+& & 1)-temp*g_delz(i, k))/delz(i, k)-temp*g_delz(i, k+1)-& & temp6*g_den(i, k))/den(i, k) temp4 = dtcld*temp6 END IF IF (temp4 .GE. 0.) THEN abs1 = temp4 ELSE abs1 = -temp4 END IF IF (abs1 .LT. qmin) THEN temp4 = 0. g_temp4 = 0.0_8 END IF g_qci(i, k, 2) = g_qci(i, k, 2) - g_temp4 qci(i, k, 2) = qci(i, k, 2) - temp4 END IF END DO END DO END DO END SUBROUTINE G_FALLKC !======================================================================= ! !======================================================================= SUBROUTINE FALLKC(qci, fallc, den, delz, dtcld, kte, kts, its, ite, & & kme, kms, ims, ime) IMPLICIT NONE INTEGER :: kte, kts, its, ite, kme, kms, ims, ime REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(ims:ime, kms:kme) :: delz, den REAL, DIMENSION(its:ite, kts:kte) :: falkc, work1c, work2c, xni, & & fallc INTEGER, DIMENSION(its:ite) :: mstep, numdt REAL :: dtcld, xmi, diameter, temp1, temp2, temp3, temp4, temp5, & & temp0 INTEGER :: mstepmax, k, i, n INTRINSIC NINT INTRINSIC MAX INTRINSIC MIN INTRINSIC ABS INTEGER :: x1 REAL :: x2 REAL :: abs0 REAL :: abs1 REAL :: pwx1 REAL :: pwr1 mstepmax = 1 mstep = 1 numdt = 1 DO k=kte,kts,-1 DO i=its,ite pwx1 = den(i, k)*qci(i, k, 2) pwr1 = pwx1**(1.31/8.) work1c(i, k) = vt2i_a*pwr1 work2c(i, k) = work1c(i, k)/delz(i, k) x1 = NINT(work2c(i, k)*dtcld + .5) IF (x1 .LT. 1) THEN numdt(i) = 1 ELSE numdt(i) = x1 END IF IF (numdt(i) .GE. mstep(i)) mstep(i) = numdt(i) END DO END DO DO i=its,ite IF (mstepmax .LE. mstep(i)) mstepmax = mstep(i) END DO DO n=1,mstepmax k = kte DO i=its,ite IF (n .LE. mstep(i)) THEN pwx1 = den(i, k)*qci(i, k, 2) pwr1 = pwx1**(9.31/8.) falkc(i, k) = falli_a*pwr1/delz(i, k)/mstep(i) fallc(i, k) = fallc(i, k) + falkc(i, k) x2 = falkc(i, k)*dtcld/den(i, k) IF (x2 .GT. qci(i, k, 2)) THEN temp3 = qci(i, k, 2) ELSE temp3 = x2 END IF IF (temp3 .GE. 0.) THEN abs0 = temp3 ELSE abs0 = -temp3 END IF IF (abs0 .LT. qmin) temp3 = 0. qci(i, k, 2) = qci(i, k, 2) - temp3 END IF END DO DO k=kte-1,kts,-1 DO i=its,ite IF (n .LE. mstep(i)) THEN pwx1 = den(i, k)*qci(i, k, 2) pwr1 = pwx1**(9.31/8.) falkc(i, k) = falli_a*pwr1/delz(i, k)/mstep(i) fallc(i, k) = fallc(i, k) + falkc(i, k) IF ((falkc(i, k)-falkc(i, k+1)*delz(i, k+1)/delz(i, k))*& & dtcld/den(i, k) .GT. qci(i, k, 2)) THEN temp4 = qci(i, k, 2) ELSE temp4 = (falkc(i, k)-falkc(i, k+1)*delz(i, k+1)/delz(i, k)& & )*dtcld/den(i, k) END IF IF (temp4 .GE. 0.) THEN abs1 = temp4 ELSE abs1 = -temp4 END IF IF (abs1 .LT. qmin) temp4 = 0. qci(i, k, 2) = qci(i, k, 2) - temp4 END IF END DO END DO END DO END SUBROUTINE FALLKC ! Differentiation of rainsc in forward (tangent) mode (with options r8): ! variations of useful results: t xl qrs rain qci rainncv ! with respect to varying inputs: fallc t cpm xl delz den qrs ! fall rain qci rainncv !======================================================================= ! !======================================================================= SUBROUTINE G_RAINSC(fall, g_fall, fallc, g_fallc, xl, g_xl, t, g_t, q& & , qci, g_qci, cpm, g_cpm, den, g_den, qrs, g_qrs, delz, g_delz, rain& & , g_rain, rainncv, g_rainncv, dtcld, kte, kts, its, ite, kme, kms, & & ims, ime) IMPLICIT NONE INTEGER :: kte, kts, its, ite, kme, kms, ims, ime REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, fall REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs, g_fall REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, q REAL, DIMENSION(ims:ime, kms:kme) :: g_delz, g_den REAL, DIMENSION(its:ite, kts:kte) :: xl, t, cpm, fallc REAL, DIMENSION(its:ite, kts:kte) :: g_xl, g_t, g_cpm, g_fallc REAL, DIMENSION(ims:ime) :: rain, rainncv REAL, DIMENSION(ims:ime) :: g_rain, g_rainncv INTEGER :: k, i REAL :: dtcld, fallsum, supcol, xlf, temp, temp0, pfrzdtr, pfrzdtc REAL :: g_fallsum, g_supcol, g_xlf, g_temp, g_pfrzdtr, g_pfrzdtc REAL :: ft0, ft40, fsupcol, fqc, fqi, fqr, qtmp REAL :: g_ft0, g_ft40, g_qtmp INTRINSIC MAX INTRINSIC ABS INTRINSIC EXP INTRINSIC MIN REAL :: x1 REAL :: g_x1 REAL :: max1 REAL :: g_max1 REAL :: abs0 REAL :: abs1 REAL :: abs2 REAL :: abs3 REAL :: pwr1 REAL :: g_pwr1 REAL :: pwr2 REAL :: g_pwr2 REAL :: temp1 REAL :: temp2 REAL :: temp3 DO i=its,ite g_fallsum = g_fall(i, kts, 1) + g_fall(i, kts, 2) + g_fall(i, kts& & , 3) + g_fallc(i, kts) fallsum = fall(i, kts, 1) + fall(i, kts, 2) + fall(i, kts, 3) + & & fallc(i, kts) IF (fallsum .GT. qmin) THEN !rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf g_rainncv(i) = dtcld*1000.*(fallsum*g_delz(i, kts)/denr+delz(i, & & kts)*g_fallsum/denr) rainncv(i) = fallsum*delz(i, kts)/denr*dtcld*1000. g_rain(i) = dtcld*1000.*(fallsum*g_delz(i, kts)/denr+delz(i, kts& & )*g_fallsum/denr) + g_rain(i) rain(i) = fallsum*delz(i, kts)/denr*dtcld*1000. + rain(i) END IF END DO DO k=kts,kte DO i=its,ite !--------------------------------------------------------------- ! pimlt: instantaneous melting of cloud ice [RH83 A28] ! (T>T0: I->C) pimlt=qci(i,k,2) t- !--------------------------------------------------------------- !update xl, cpm g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) ! cpm(i,k)=cpmcal(q(i,k)) !not change g_xlf = -g_xl(i, k) xlf = xls - xl(i, k) supcol = t0c - t(i, k) IF (supcol .LT. 0.) THEN xlf = xlf0 g_xlf = 0.0_8 END IF CALL G_SMOOTHIF(t(i, k), g_t(i, k), t0c, ft0, g_ft0, 't0') IF (qci(i, k, 2) .LT. 0.) THEN max1 = 0. g_max1 = 0.0_8 ELSE g_max1 = g_qci(i, k, 2) max1 = qci(i, k, 2) END IF g_qtmp = max1*g_ft0 + ft0*g_max1 qtmp = ft0*max1 IF (qtmp .GE. 0.) THEN abs0 = qtmp ELSE abs0 = -qtmp END IF IF (abs0 .LT. qmin) THEN qtmp = 0. g_qtmp = 0.0_8 END IF IF (qci(i, k, 1) + qtmp .LT. 0.) THEN g_qci(i, k, 1) = 0.0_8 qci(i, k, 1) = 0. ELSE g_qci(i, k, 1) = g_qci(i, k, 1) + g_qtmp qci(i, k, 1) = qci(i, k, 1) + qtmp END IF IF (qci(i, k, 2) - qtmp .LT. 0.) THEN g_qci(i, k, 2) = 0.0_8 qci(i, k, 2) = 0. ELSE g_qci(i, k, 2) = g_qci(i, k, 2) - g_qtmp qci(i, k, 2) = qci(i, k, 2) - qtmp END IF temp1 = xlf*qtmp/cpm(i, k) g_t(i, k) = g_t(i, k) - (qtmp*g_xlf+xlf*g_qtmp-temp1*g_cpm(i, k)& & )/cpm(i, k) t(i, k) = t(i, k) - temp1 !--------------------------------------------------------------- ! pihmf: homogeneous freezing of cloud water below -40c ! (T<-40C: C->I) min=0,pihmf=qci(i,k,1) t+ !--------------------------------------------------------------- !update xl, cpm g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) ! cpm(i,k)=cpmcal(q(i,k)) !not change g_xlf = -g_xl(i, k) xlf = xls - xl(i, k) g_supcol = -g_t(i, k) supcol = t0c - t(i, k) IF (supcol .LT. 0.) THEN xlf = xlf0 g_xlf = 0.0_8 END IF CALL G_SMOOTHIF(supcol, g_supcol, 40., ft40, g_ft40, 't0') IF (ft40*qci(i, k, 1) .LT. 0.) THEN qtmp = 0. g_qtmp = 0.0_8 ELSE g_qtmp = qci(i, k, 1)*g_ft40 + ft40*g_qci(i, k, 1) qtmp = ft40*qci(i, k, 1) END IF IF (qtmp .GE. 0.) THEN abs1 = qtmp ELSE abs1 = -qtmp END IF !update qc, qi, t IF (abs1 .LT. qmin) THEN qtmp = 0. g_qtmp = 0.0_8 END IF IF (qci(i, k, 2) + qtmp .LT. 0.) THEN g_qci(i, k, 2) = 0.0_8 qci(i, k, 2) = 0. ELSE g_qci(i, k, 2) = g_qci(i, k, 2) + g_qtmp qci(i, k, 2) = qci(i, k, 2) + qtmp END IF IF (qci(i, k, 1) - qtmp .LT. 0.) THEN g_qci(i, k, 1) = 0.0_8 qci(i, k, 1) = 0. ELSE g_qci(i, k, 1) = g_qci(i, k, 1) - g_qtmp qci(i, k, 1) = qci(i, k, 1) - qtmp END IF temp1 = xlf*qtmp/cpm(i, k) g_t(i, k) = g_t(i, k) + (qtmp*g_xlf+xlf*g_qtmp-temp1*g_cpm(i, k)& & )/cpm(i, k) t(i, k) = t(i, k) + temp1 !--------------------------------------------------------------- ! pihtf: heterogeneous freezing of cloud water ! (T0>T>-40C: C->I) max=qci(i,k,1),min=0. t+ !--------------------------------------------------------------- !update xl, cpm g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) ! cpm(i,k)=cpmcal(q(i,k)) !not change g_xlf = -g_xl(i, k) xlf = xls - xl(i, k) g_supcol = -g_t(i, k) supcol = t0c - t(i, k) IF (supcol .LT. 0.) THEN xlf = xlf0 g_xlf = 0.0_8 END IF !t>-40C=t0c-40,t0c-t<40, supcol<40,-supcol>-40 CALL G_SMOOTHIF(-supcol, -g_supcol, -40., ft40, g_ft40, 't0') temp1 = den(i, k)/(denr*xncr) temp2 = qci(i, k, 1)*qci(i, k, 1) temp3 = EXP(pfrz2*supcol) - 1. g_x1 = pfrz1*dtcld*(temp2*temp1*EXP(pfrz2*supcol)*pfrz2*g_supcol& & +temp3*(temp1*2*qci(i, k, 1)*g_qci(i, k, 1)+temp2*g_den(i, k)/& & (denr*xncr))) x1 = pfrz1*dtcld*(temp3*(temp2*temp1)) IF (x1 .GT. qci(i, k, 1)) THEN g_pfrzdtc = g_qci(i, k, 1) pfrzdtc = qci(i, k, 1) ELSE g_pfrzdtc = g_x1 pfrzdtc = x1 END IF IF (ft40*pfrzdtc .LT. 0.) THEN qtmp = 0. g_qtmp = 0.0_8 ELSE g_qtmp = pfrzdtc*g_ft40 + ft40*g_pfrzdtc qtmp = ft40*pfrzdtc END IF IF (qtmp .GE. 0.) THEN abs2 = qtmp ELSE abs2 = -qtmp END IF !update qc, qi, t IF (abs2 .LT. qmin) THEN qtmp = 0. g_qtmp = 0.0_8 END IF IF (qci(i, k, 2) + qtmp .LT. 0.) THEN g_qci(i, k, 2) = 0.0_8 qci(i, k, 2) = 0. ELSE g_qci(i, k, 2) = g_qci(i, k, 2) + g_qtmp qci(i, k, 2) = qci(i, k, 2) + qtmp END IF IF (qci(i, k, 1) - qtmp .LT. 0.) THEN g_qci(i, k, 1) = 0.0_8 qci(i, k, 1) = 0. ELSE g_qci(i, k, 1) = g_qci(i, k, 1) - g_qtmp qci(i, k, 1) = qci(i, k, 1) - qtmp END IF temp3 = xlf*qtmp/cpm(i, k) g_t(i, k) = g_t(i, k) + (qtmp*g_xlf+xlf*g_qtmp-temp3*g_cpm(i, k)& & )/cpm(i, k) t(i, k) = t(i, k) + temp3 !--------------------------------------------------------------- ! pgfrz: freezing of rain water [LFO 45] ! (TG) max=qrs(i,k,1),min=0. t+ !--------------------------------------------------------------- !update xl, cpm g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) ! cpm(i,k)=cpmcal(q(i,k))!not change g_xlf = -g_xl(i, k) xlf = xls - xl(i, k) g_supcol = -g_t(i, k) supcol = t0c - t(i, k) IF (supcol .LT. 0.) THEN xlf = xlf0 g_xlf = 0.0_8 END IF IF (qrs(i, k, 1) .GT. 0.) THEN IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. & & .NE. INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (qrs(i, k, 1) .LE. 0.0_8 .AND. (7./4. .EQ. 0.0_8 .OR. 7./4.& & .NE. INT(7./4.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 7.*qrs(i, k, 1)**(7./4.-1)*g_qrs(i, k, 1)/4. END IF pwr2 = qrs(i, k, 1)**(7./4.) temp3 = EXP(pfrz2*supcol) - 1. g_temp = pgfrz_a*(pwr1*pwr2*EXP(pfrz2*supcol)*pfrz2*g_supcol+& & temp3*(pwr2*g_pwr1+pwr1*g_pwr2)) temp = pgfrz_a*(temp3*(pwr1*pwr2)) ELSE temp = 0. g_temp = 0.0_8 END IF IF (temp*dtcld .GT. qrs(i, k, 1)) THEN g_pfrzdtr = g_qrs(i, k, 1) pfrzdtr = qrs(i, k, 1) ELSE g_pfrzdtr = dtcld*g_temp pfrzdtr = temp*dtcld END IF IF (pfrzdtr .LT. 0.) THEN qtmp = 0. g_qtmp = 0.0_8 ELSE g_qtmp = g_pfrzdtr qtmp = pfrzdtr END IF IF (qtmp .GE. 0.) THEN abs3 = qtmp ELSE abs3 = -qtmp END IF IF (abs3 .LT. qmin) THEN qtmp = 0. g_qtmp = 0.0_8 END IF IF (qrs(i, k, 3) + qtmp .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_qrs(i, k, 3) + g_qtmp qrs(i, k, 3) = qrs(i, k, 3) + qtmp END IF IF (qrs(i, k, 1) - qtmp .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_qrs(i, k, 1) - g_qtmp qrs(i, k, 1) = qrs(i, k, 1) - qtmp END IF temp3 = xlf*qtmp/cpm(i, k) g_t(i, k) = g_t(i, k) + (qtmp*g_xlf+xlf*g_qtmp-temp3*g_cpm(i, k)& & )/cpm(i, k) t(i, k) = t(i, k) + temp3 END DO END DO END SUBROUTINE G_RAINSC !======================================================================= ! !======================================================================= SUBROUTINE RAINSC(fall, fallc, xl, t, q, qci, cpm, den, qrs, delz, & & rain, rainncv, dtcld, kte, kts, its, ite, kme, kms, ims, ime) IMPLICIT NONE INTEGER :: kte, kts, its, ite, kme, kms, ims, ime REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, fall REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(ims:ime, kms:kme) :: delz, den, q REAL, DIMENSION(its:ite, kts:kte) :: xl, t, cpm, fallc REAL, DIMENSION(ims:ime) :: rain, rainncv INTEGER :: k, i REAL :: dtcld, fallsum, supcol, xlf, temp, temp0, pfrzdtr, pfrzdtc REAL :: ft0, ft40, fsupcol, fqc, fqi, fqr, qtmp INTRINSIC MAX INTRINSIC ABS INTRINSIC EXP INTRINSIC MIN REAL :: x1 REAL :: max1 REAL :: abs0 REAL :: abs1 REAL :: abs2 REAL :: abs3 REAL :: pwr1 REAL :: pwr2 DO i=its,ite fallsum = fall(i, kts, 1) + fall(i, kts, 2) + fall(i, kts, 3) + & & fallc(i, kts) IF (fallsum .GT. qmin) THEN !rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf rainncv(i) = fallsum*delz(i, kts)/denr*dtcld*1000. rain(i) = fallsum*delz(i, kts)/denr*dtcld*1000. + rain(i) END IF END DO DO k=kts,kte DO i=its,ite !--------------------------------------------------------------- ! pimlt: instantaneous melting of cloud ice [RH83 A28] ! (T>T0: I->C) pimlt=qci(i,k,2) t- !--------------------------------------------------------------- !update xl, cpm xl(i, k) = XLCAL(t(i, k)) ! cpm(i,k)=cpmcal(q(i,k)) !not change xlf = xls - xl(i, k) supcol = t0c - t(i, k) IF (supcol .LT. 0.) xlf = xlf0 CALL SMOOTHIF(t(i, k), t0c, ft0, 't0') IF (qci(i, k, 2) .LT. 0.) THEN max1 = 0. ELSE max1 = qci(i, k, 2) END IF qtmp = ft0*max1 IF (qtmp .GE. 0.) THEN abs0 = qtmp ELSE abs0 = -qtmp END IF IF (abs0 .LT. qmin) qtmp = 0. IF (qci(i, k, 1) + qtmp .LT. 0.) THEN qci(i, k, 1) = 0. ELSE qci(i, k, 1) = qci(i, k, 1) + qtmp END IF IF (qci(i, k, 2) - qtmp .LT. 0.) THEN qci(i, k, 2) = 0. ELSE qci(i, k, 2) = qci(i, k, 2) - qtmp END IF t(i, k) = t(i, k) - xlf/cpm(i, k)*qtmp !--------------------------------------------------------------- ! pihmf: homogeneous freezing of cloud water below -40c ! (T<-40C: C->I) min=0,pihmf=qci(i,k,1) t+ !--------------------------------------------------------------- !update xl, cpm xl(i, k) = XLCAL(t(i, k)) ! cpm(i,k)=cpmcal(q(i,k)) !not change xlf = xls - xl(i, k) supcol = t0c - t(i, k) IF (supcol .LT. 0.) xlf = xlf0 CALL SMOOTHIF(supcol, 40., ft40, 't0') IF (ft40*qci(i, k, 1) .LT. 0.) THEN qtmp = 0. ELSE qtmp = ft40*qci(i, k, 1) END IF IF (qtmp .GE. 0.) THEN abs1 = qtmp ELSE abs1 = -qtmp END IF !update qc, qi, t IF (abs1 .LT. qmin) qtmp = 0. IF (qci(i, k, 2) + qtmp .LT. 0.) THEN qci(i, k, 2) = 0. ELSE qci(i, k, 2) = qci(i, k, 2) + qtmp END IF IF (qci(i, k, 1) - qtmp .LT. 0.) THEN qci(i, k, 1) = 0. ELSE qci(i, k, 1) = qci(i, k, 1) - qtmp END IF t(i, k) = t(i, k) + xlf/cpm(i, k)*qtmp !--------------------------------------------------------------- ! pihtf: heterogeneous freezing of cloud water ! (T0>T>-40C: C->I) max=qci(i,k,1),min=0. t+ !--------------------------------------------------------------- !update xl, cpm xl(i, k) = XLCAL(t(i, k)) ! cpm(i,k)=cpmcal(q(i,k)) !not change xlf = xls - xl(i, k) supcol = t0c - t(i, k) IF (supcol .LT. 0.) xlf = xlf0 !t>-40C=t0c-40,t0c-t<40, supcol<40,-supcol>-40 CALL SMOOTHIF(-supcol, -40., ft40, 't0') x1 = pfrz1*(EXP(pfrz2*supcol)-1.)*den(i, k)/denr/xncr*qci(i, k, & & 1)*qci(i, k, 1)*dtcld IF (x1 .GT. qci(i, k, 1)) THEN pfrzdtc = qci(i, k, 1) ELSE pfrzdtc = x1 END IF IF (ft40*pfrzdtc .LT. 0.) THEN qtmp = 0. ELSE qtmp = ft40*pfrzdtc END IF IF (qtmp .GE. 0.) THEN abs2 = qtmp ELSE abs2 = -qtmp END IF !update qc, qi, t IF (abs2 .LT. qmin) qtmp = 0. IF (qci(i, k, 2) + qtmp .LT. 0.) THEN qci(i, k, 2) = 0. ELSE qci(i, k, 2) = qci(i, k, 2) + qtmp END IF IF (qci(i, k, 1) - qtmp .LT. 0.) THEN qci(i, k, 1) = 0. ELSE qci(i, k, 1) = qci(i, k, 1) - qtmp END IF t(i, k) = t(i, k) + xlf/cpm(i, k)*qtmp !--------------------------------------------------------------- ! pgfrz: freezing of rain water [LFO 45] ! (TG) max=qrs(i,k,1),min=0. t+ !--------------------------------------------------------------- !update xl, cpm xl(i, k) = XLCAL(t(i, k)) ! cpm(i,k)=cpmcal(q(i,k))!not change xlf = xls - xl(i, k) supcol = t0c - t(i, k) IF (supcol .LT. 0.) xlf = xlf0 IF (qrs(i, k, 1) .GT. 0.) THEN pwr1 = den(i, k)**(3./4.) pwr2 = qrs(i, k, 1)**(7./4.) temp = pgfrz_a*(EXP(pfrz2*supcol)-1.)*pwr1*pwr2 ELSE temp = 0. END IF IF (temp*dtcld .GT. qrs(i, k, 1)) THEN pfrzdtr = qrs(i, k, 1) ELSE pfrzdtr = temp*dtcld END IF IF (pfrzdtr .LT. 0.) THEN qtmp = 0. ELSE qtmp = pfrzdtr END IF IF (qtmp .GE. 0.) THEN abs3 = qtmp ELSE abs3 = -qtmp END IF IF (abs3 .LT. qmin) qtmp = 0. IF (qrs(i, k, 3) + qtmp .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = qrs(i, k, 3) + qtmp END IF IF (qrs(i, k, 1) - qtmp .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) - qtmp END IF t(i, k) = t(i, k) + xlf/cpm(i, k)*qtmp END DO END DO END SUBROUTINE RAINSC ! Differentiation of warmr in forward (tangent) mode (with options r8): ! variations of useful results: q t qs xl pracw rh qrs prevp ! qci praut ! with respect to varying inputs: p q t qs xl pracw rh den qrs ! prevp qci praut !======================================================================= ! !======================================================================= SUBROUTINE G_WARMR(t, g_t, q, g_q, qci, g_qci, qrs, g_qrs, den, g_den& & , p, g_p, dtcld, xl, g_xl, rh, g_rh, qs, g_qs, praut, g_praut, pracw& & , g_pracw, prevp, g_prevp, ims, ime, kms, kme, its, ite, kts, kte) IMPLICIT NONE INTEGER :: ims, ime, kms, kme, its, ite, kts, kte !------------------------------------------------------------------ REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci REAL, DIMENSION(ims:ime, kms:kme) :: q, den, p REAL, DIMENSION(ims:ime, kms:kme) :: g_q, g_den, g_p REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, qrs, work1 REAL, DIMENSION(its:ite, kts:kte, 3) :: g_rh, g_qs, g_qrs REAL, DIMENSION(its:ite, kts:kte) :: praut, prevp, pracw, xl, denfac& & , t, cpm REAL, DIMENSION(its:ite, kts:kte) :: g_praut, g_prevp, g_pracw, g_xl& & , g_t, g_cpm REAL :: coeres, supsat, satdt, dtcld, praut1 REAL :: g_supsat, g_satdt, g_praut1 INTEGER :: i, k REAL :: fqv, fqc, fqr, fqc0, fprevp, prevp0, prevp1, temp, a, b, c, & & d, e REAL :: g_fqc0, g_a, g_b, g_c, g_d, g_e INTRINSIC LOG INTRINSIC EXP INTRINSIC MIN INTRINSIC ABS INTRINSIC MAX INTRINSIC SQRT REAL :: x1 REAL :: g_x1 REAL :: x2 REAL :: g_x2 REAL :: x3 REAL :: g_x3 REAL :: abs0 REAL :: abs1 REAL :: max1 REAL :: g_max1 REAL :: max2 REAL :: g_max2 REAL :: abs2 REAL :: arg1 REAL :: g_arg1 REAL :: pwy1 REAL :: pwr1 REAL :: g_pwr1 REAL :: pwy2 REAL :: pwr2 REAL :: g_pwr2 REAL :: pwx1 REAL :: g_pwx1 REAL :: pwr3 REAL :: g_pwr3 REAL :: pwy4 REAL :: pwr4 REAL :: g_pwr4 REAL :: pwy5 REAL :: pwr5 REAL :: g_pwr5 REAL :: temp0 REAL :: temp1 REAL :: temp2 REAL :: temp3 g_cpm = 0.0_8 DO k=kts,kte DO i=its,ite !--------------------------------------------------------------- ! praut: auto conversion rate from cloud to rain [HDC 16] ! (C->R) praut>0 max=qci(i,k,1)/dtcld, min=0. !--------------------------------------------------------------- CALL G_SMOOTHIF(qci(i, k, 1), g_qci(i, k, 1), qc0, fqc0, g_fqc0& & , 'q0') !qc0=5.03e-4 IF (qci(i, k, 1) .GT. 0.) THEN ! x**a need x>0 !(qci(i,k,1)**(7./3.)) g_arg1 = 7.*g_qci(i, k, 1)/(3.*qci(i, k, 1)) arg1 = LOG(qci(i, k, 1))*(7./3.) temp0 = EXP(arg1) g_praut1 = qck1*(temp0*g_fqc0+fqc0*EXP(arg1)*g_arg1) praut1 = qck1*(fqc0*temp0) ELSE praut1 = 0. g_praut1 = 0.0_8 END IF IF (praut1 .GT. qci(i, k, 1)/dtcld) THEN g_praut(i, k) = g_qci(i, k, 1)/dtcld praut(i, k) = qci(i, k, 1)/dtcld ELSE g_praut(i, k) = g_praut1 praut(i, k) = praut1 END IF IF (praut(i, k) .GE. 0.) THEN abs0 = praut(i, k) ELSE abs0 = -praut(i, k) END IF IF (abs0 .LT. qmin/dtcld) THEN g_praut(i, k) = 0.0_8 praut(i, k) = 0. END IF IF (qci(i, k, 1) - praut(i, k)*dtcld .LT. 0.) THEN g_qci(i, k, 1) = 0.0_8 qci(i, k, 1) = 0. ELSE g_qci(i, k, 1) = g_qci(i, k, 1) - dtcld*g_praut(i, k) qci(i, k, 1) = qci(i, k, 1) - praut(i, k)*dtcld END IF IF (qrs(i, k, 1) + praut(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_qrs(i, k, 1) + dtcld*g_praut(i, k) qrs(i, k, 1) = qrs(i, k, 1) + praut(i, k)*dtcld END IF g_praut(i, k) = 0.0_8 praut(i, k) = 0. !--------------------------------------------------------------- ! pracw: accretion of cloud water by rain [LFO 51] ! (C->R) max=qci(i,k,1)/dtcld, min=0. !--------------------------------------------------------------- !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0') !call smoothif(qci(i,k,1),qmin ,fqc,'q0') IF (qrs(i, k, 1) .GT. 0 .AND. qci(i, k, 1) .GT. 0.) THEN pwy1 = (1.+bvtr)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE.& & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = (3.+bvtr)/4. IF (qrs(i, k, 1) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 & & .NE. INT(pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*qrs(i, k, 1)**(pwy2-1)*g_qrs(i, k, 1) END IF pwr2 = qrs(i, k, 1)**pwy2 g_pracw(i, k) = pracw_a*(qci(i, k, 1)*(pwr2*g_pwr1+pwr1*g_pwr2& & )+pwr1*pwr2*g_qci(i, k, 1)) pracw(i, k) = pracw_a*pwr1*pwr2*qci(i, k, 1) ELSE g_pracw(i, k) = 0.0_8 pracw(i, k) = 0. END IF IF (pracw(i, k) .GT. qci(i, k, 1)/dtcld) THEN g_x1 = g_qci(i, k, 1)/dtcld x1 = qci(i, k, 1)/dtcld ELSE g_x1 = g_pracw(i, k) x1 = pracw(i, k) END IF IF (x1 .LT. 0.) THEN g_pracw(i, k) = 0.0_8 pracw(i, k) = 0. ELSE g_pracw(i, k) = g_x1 pracw(i, k) = x1 END IF IF (pracw(i, k) .GE. 0.) THEN abs1 = pracw(i, k) ELSE abs1 = -pracw(i, k) END IF IF (abs1 .LT. qmin/dtcld) THEN g_pracw(i, k) = 0.0_8 pracw(i, k) = 0. END IF IF (qci(i, k, 1) - pracw(i, k)*dtcld .LT. 0.) THEN g_qci(i, k, 1) = 0.0_8 qci(i, k, 1) = 0. ELSE g_qci(i, k, 1) = g_qci(i, k, 1) - dtcld*g_pracw(i, k) qci(i, k, 1) = qci(i, k, 1) - pracw(i, k)*dtcld END IF IF (qrs(i, k, 1) + pracw(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_qrs(i, k, 1) + dtcld*g_pracw(i, k) qrs(i, k, 1) = qrs(i, k, 1) + pracw(i, k)*dtcld END IF g_pracw(i, k) = 0.0_8 pracw(i, k) = 0. ! !--------------------------------------------------------------- ! prevp: evaporation/condensation rate of rain [HDC 14] ! (V->R or R->V) rh(i,k,1)>1., prevp>0, V->R, min=0., max=satdt ; ! rh(i,k,1)<1., prevp<0, R->V, min=-qrs(i,k,1)/dtcld, max=0. !--------------------------------------------------------------- !update rh CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), & & g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs& & (i, k, :)) !update xl, cpm g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k)) g_supsat = g_q(i, k) - g_qs(i, k, 1) supsat = q(i, k) - qs(i, k, 1) g_satdt = g_supsat/dtcld satdt = supsat/dtcld IF (qrs(i, k, 1) .LT. qcrmin) THEN max1 = qcrmin g_max1 = 0.0_8 ELSE g_max1 = g_qrs(i, k, 1) max1 = qrs(i, k, 1) END IF temp0 = den(i, k)*max1 temp1 = SQRT(temp0) IF (temp0 .EQ. 0.0_8) THEN g_a = 0.0_8 ELSE g_a = (max1*g_den(i, k)+den(i, k)*g_max1)/(2.0*temp1) END IF a = temp1 IF (qrs(i, k, 1) .LT. qcrmin) THEN max2 = qcrmin g_max2 = 0.0_8 ELSE g_max2 = g_qrs(i, k, 1) max2 = qrs(i, k, 1) END IF g_pwx1 = g_t(i, k) pwx1 = t(i, k) + 120. IF (pwx1 .LE. 0.0_8 .AND. (1.0/6. .EQ. 0.0_8 .OR. 1.0/6. .NE. & & INT(1.0/6.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwx1**(1.0/6.-1)*g_pwx1/6. END IF pwr1 = pwx1**(1./6.) IF (t(i, k) .LE. 0.0_8 .AND. (5.12/6. .EQ. 0.0_8 .OR. 5.12/6. & & .NE. INT(5.12/6.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 5.12*t(i, k)**(5.12/6.-1)*g_t(i, k)/6. END IF pwr2 = t(i, k)**(5.12/6.) IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. .NE.& & INT(1.0/3.))) THEN g_pwr3 = 0.0_8 ELSE g_pwr3 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3. END IF pwr3 = p(i, k)**(1./3.) pwy4 = (13.+3.*bvtr)/24. IF (den(i, k) .LE. 0.0_8 .AND. (pwy4 .EQ. 0.0_8 .OR. pwy4 .NE. & & INT(pwy4))) THEN g_pwr4 = 0.0_8 ELSE g_pwr4 = pwy4*den(i, k)**(pwy4-1)*g_den(i, k) END IF pwr4 = den(i, k)**pwy4 pwy5 = (5.+bvtr)/8. IF (max2 .LE. 0.0_8 .AND. (pwy5 .EQ. 0.0_8 .OR. pwy5 .NE. INT(& & pwy5))) THEN g_pwr5 = 0.0_8 ELSE g_pwr5 = pwy5*max2**(pwy5-1)*g_max2 END IF pwr5 = max2**pwy5 temp1 = pwr1*pwr3/pwr2 g_b = pwr4*pwr5*(pwr3*g_pwr1+pwr1*g_pwr3-temp1*g_pwr2)/pwr2 + & & temp1*(pwr5*g_pwr4+pwr4*g_pwr5) b = temp1*(pwr4*pwr5) temp1 = rv*t(i, k)**3.5 temp0 = den(i, k)*(t(i, k)+120.) temp2 = xl(i, k)*xl(i, k) temp3 = temp2*temp0/temp1 g_c = diffac_a*(temp0*2*xl(i, k)*g_xl(i, k)+temp2*((t(i, k)+120.& & )*g_den(i, k)+den(i, k)*g_t(i, k))-temp3*rv*3.5*t(i, k)**2.5*& & g_t(i, k))/temp1 c = diffac_a*temp3 temp3 = t(i, k)**1.81 temp2 = temp3*qs(i, k, 1) temp1 = p(i, k)/temp2 g_d = diffac_b*(g_p(i, k)-temp1*(qs(i, k, 1)*1.81*t(i, k)**0.81*& & g_t(i, k)+temp3*g_qs(i, k, 1)))/temp2 d = diffac_b*temp1 temp3 = (rh(i, k, 1)-1.)/(c+d) g_e = (g_rh(i, k, 1)-temp3*(g_c+g_d))/(c+d) e = temp3 temp3 = prevp_a*a + prevp_b*b g_prevp(i, k) = e*(prevp_a*g_a+prevp_b*g_b) + temp3*g_e prevp(i, k) = temp3*e IF (prevp(i, k) .LT. 0.) THEN IF (prevp(i, k) .LT. -(qrs(i, k, 1)/dtcld)) THEN g_x2 = -(g_qrs(i, k, 1)/dtcld) x2 = -(qrs(i, k, 1)/dtcld) ELSE g_x2 = g_prevp(i, k) x2 = prevp(i, k) END IF IF (x2 .GT. 0.) THEN g_prevp(i, k) = 0.0_8 prevp(i, k) = 0. ELSE g_prevp(i, k) = g_x2 prevp(i, k) = x2 END IF ELSE IF (prevp(i, k) .GT. satdt) THEN g_x3 = g_satdt x3 = satdt ELSE g_x3 = g_prevp(i, k) x3 = prevp(i, k) END IF IF (x3 .LT. 0.) THEN g_prevp(i, k) = 0.0_8 prevp(i, k) = 0. ELSE g_prevp(i, k) = g_x3 prevp(i, k) = x3 END IF END IF IF (prevp(i, k) .GE. 0.) THEN abs2 = prevp(i, k) ELSE abs2 = -prevp(i, k) END IF IF (abs2 .LT. qmin/dtcld) THEN g_prevp(i, k) = 0.0_8 prevp(i, k) = 0. END IF IF (q(i, k) - prevp(i, k)*dtcld .LT. 0.) THEN g_q(i, k) = 0.0_8 q(i, k) = 0. ELSE g_q(i, k) = g_q(i, k) - dtcld*g_prevp(i, k) q(i, k) = q(i, k) - prevp(i, k)*dtcld END IF IF (qrs(i, k, 1) + prevp(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_qrs(i, k, 1) + dtcld*g_prevp(i, k) qrs(i, k, 1) = qrs(i, k, 1) + prevp(i, k)*dtcld END IF temp3 = prevp(i, k)*xl(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*(xl(i, k)*g_prevp(i, k)+prevp(i, k& & )*g_xl(i, k)-temp3*g_cpm(i, k))/cpm(i, k) t(i, k) = t(i, k) + dtcld*temp3 g_prevp(i, k) = 0.0_8 prevp(i, k) = 0. END DO END DO END SUBROUTINE G_WARMR !======================================================================= ! !======================================================================= SUBROUTINE WARMR(t, q, qci, qrs, den, p, dtcld, xl, rh, qs, praut, & & pracw, prevp, ims, ime, kms, kme, its, ite, kts, kte) IMPLICIT NONE INTEGER :: ims, ime, kms, kme, its, ite, kts, kte !------------------------------------------------------------------ REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(ims:ime, kms:kme) :: q, den, p REAL, DIMENSION(its:ite, kts:kte, 3) :: rh, qs, qrs, work1 REAL, DIMENSION(its:ite, kts:kte) :: praut, prevp, pracw, xl, denfac& & , t, cpm REAL :: coeres, supsat, satdt, dtcld, praut1 INTEGER :: i, k REAL :: fqv, fqc, fqr, fqc0, fprevp, prevp0, prevp1, temp, a, b, c, & & d, e INTRINSIC LOG INTRINSIC EXP INTRINSIC MIN INTRINSIC ABS INTRINSIC MAX INTRINSIC SQRT REAL :: x1 REAL :: x2 REAL :: x3 REAL :: abs0 REAL :: abs1 REAL :: max1 REAL :: max2 REAL :: abs2 REAL :: arg1 REAL :: pwy1 REAL :: pwr1 REAL :: pwy2 REAL :: pwr2 REAL :: pwx1 REAL :: pwr3 REAL :: pwy4 REAL :: pwr4 REAL :: pwy5 REAL :: pwr5 DO k=kts,kte DO i=its,ite !--------------------------------------------------------------- ! praut: auto conversion rate from cloud to rain [HDC 16] ! (C->R) praut>0 max=qci(i,k,1)/dtcld, min=0. !--------------------------------------------------------------- CALL SMOOTHIF(qci(i, k, 1), qc0, fqc0, 'q0') !qc0=5.03e-4 IF (qci(i, k, 1) .GT. 0.) THEN ! x**a need x>0 !(qci(i,k,1)**(7./3.)) arg1 = LOG(qci(i, k, 1))*(7./3.) praut1 = fqc0*qck1*EXP(arg1) ELSE praut1 = 0. END IF IF (praut1 .GT. qci(i, k, 1)/dtcld) THEN praut(i, k) = qci(i, k, 1)/dtcld ELSE praut(i, k) = praut1 END IF IF (praut(i, k) .GE. 0.) THEN abs0 = praut(i, k) ELSE abs0 = -praut(i, k) END IF IF (abs0 .LT. qmin/dtcld) praut(i, k) = 0. IF (qci(i, k, 1) - praut(i, k)*dtcld .LT. 0.) THEN qci(i, k, 1) = 0. ELSE qci(i, k, 1) = qci(i, k, 1) - praut(i, k)*dtcld END IF IF (qrs(i, k, 1) + praut(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) + praut(i, k)*dtcld END IF praut(i, k) = 0. !--------------------------------------------------------------- ! pracw: accretion of cloud water by rain [LFO 51] ! (C->R) max=qci(i,k,1)/dtcld, min=0. !--------------------------------------------------------------- !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0') !call smoothif(qci(i,k,1),qmin ,fqc,'q0') IF (qrs(i, k, 1) .GT. 0 .AND. qci(i, k, 1) .GT. 0.) THEN pwy1 = (1.+bvtr)/4. pwr1 = den(i, k)**pwy1 pwy2 = (3.+bvtr)/4. pwr2 = qrs(i, k, 1)**pwy2 pracw(i, k) = pracw_a*pwr1*pwr2*qci(i, k, 1) ELSE pracw(i, k) = 0. END IF IF (pracw(i, k) .GT. qci(i, k, 1)/dtcld) THEN x1 = qci(i, k, 1)/dtcld ELSE x1 = pracw(i, k) END IF IF (x1 .LT. 0.) THEN pracw(i, k) = 0. ELSE pracw(i, k) = x1 END IF IF (pracw(i, k) .GE. 0.) THEN abs1 = pracw(i, k) ELSE abs1 = -pracw(i, k) END IF IF (abs1 .LT. qmin/dtcld) pracw(i, k) = 0. IF (qci(i, k, 1) - pracw(i, k)*dtcld .LT. 0.) THEN qci(i, k, 1) = 0. ELSE qci(i, k, 1) = qci(i, k, 1) - pracw(i, k)*dtcld END IF IF (qrs(i, k, 1) + pracw(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) + pracw(i, k)*dtcld END IF pracw(i, k) = 0. ! !--------------------------------------------------------------- ! prevp: evaporation/condensation rate of rain [HDC 14] ! (V->R or R->V) rh(i,k,1)>1., prevp>0, V->R, min=0., max=satdt ; ! rh(i,k,1)<1., prevp<0, R->V, min=-qrs(i,k,1)/dtcld, max=0. !--------------------------------------------------------------- !update rh CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :)) !update xl, cpm xl(i, k) = XLCAL(t(i, k)) cpm(i, k) = CPMCAL(q(i, k)) supsat = q(i, k) - qs(i, k, 1) satdt = supsat/dtcld IF (qrs(i, k, 1) .LT. qcrmin) THEN max1 = qcrmin ELSE max1 = qrs(i, k, 1) END IF a = SQRT(den(i, k)*max1) IF (qrs(i, k, 1) .LT. qcrmin) THEN max2 = qcrmin ELSE max2 = qrs(i, k, 1) END IF pwx1 = t(i, k) + 120. pwr1 = pwx1**(1./6.) pwr2 = t(i, k)**(5.12/6.) pwr3 = p(i, k)**(1./3.) pwy4 = (13.+3.*bvtr)/24. pwr4 = den(i, k)**pwy4 pwy5 = (5.+bvtr)/8. pwr5 = max2**pwy5 b = pwr1/pwr2*pwr3*pwr4*pwr5 c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, & & k)**3.5 d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1) e = (rh(i, k, 1)-1.)/(c+d) prevp(i, k) = (prevp_a*a+prevp_b*b)*e IF (prevp(i, k) .LT. 0.) THEN IF (prevp(i, k) .LT. -(qrs(i, k, 1)/dtcld)) THEN x2 = -(qrs(i, k, 1)/dtcld) ELSE x2 = prevp(i, k) END IF IF (x2 .GT. 0.) THEN prevp(i, k) = 0. ELSE prevp(i, k) = x2 END IF ELSE IF (prevp(i, k) .GT. satdt) THEN x3 = satdt ELSE x3 = prevp(i, k) END IF IF (x3 .LT. 0.) THEN prevp(i, k) = 0. ELSE prevp(i, k) = x3 END IF END IF IF (prevp(i, k) .GE. 0.) THEN abs2 = prevp(i, k) ELSE abs2 = -prevp(i, k) END IF IF (abs2 .LT. qmin/dtcld) prevp(i, k) = 0. IF (q(i, k) - prevp(i, k)*dtcld .LT. 0.) THEN q(i, k) = 0. ELSE q(i, k) = q(i, k) - prevp(i, k)*dtcld END IF IF (qrs(i, k, 1) + prevp(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) + prevp(i, k)*dtcld END IF t(i, k) = t(i, k) + prevp(i, k)*dtcld*xl(i, k)/cpm(i, k) prevp(i, k) = 0. END DO END DO END SUBROUTINE WARMR ! Differentiation of accret1 in forward (tangent) mode (with options r8): ! variations of useful results: piacr psaci pgaci t praci psacw ! pgacw qrs qci ! with respect to varying inputs: piacr psaci q pgaci t praci ! psacw pgacw den qrs qci !=================================================================== SUBROUTINE G_ACCRET1(qci, g_qci, den, g_den, qrs, g_qrs, t, g_t, q, & & g_q, dtcld, praci, g_praci, piacr, g_piacr, psaci, g_psaci, pgaci, & & g_pgaci, psacw, g_psacw, pgacw, g_pgacw, ims, ime, kms, kme, its, & & ite, kts, kte) IMPLICIT NONE INTEGER :: ims, ime, kms, kme, its, ite, kts, kte !------------------------------------------------------------------- REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs REAL, DIMENSION(ims:ime, kms:kme) :: den, q REAL, DIMENSION(ims:ime, kms:kme) :: g_den, g_q REAL, DIMENSION(its:ite, kts:kte) :: praci, piacr, psaci, pgaci, & & psacw, pgacw, t, xl, cpm REAL, DIMENSION(its:ite, kts:kte) :: g_praci, g_piacr, g_psaci, & & g_pgaci, g_psacw, g_pgacw, g_t, g_xl, g_cpm REAL :: supcol, dtcld, eacrs, egi, praci1, piacr1, psaci1, pgaci1, & & temp, temp0 REAL :: g_supcol, g_eacrs, g_egi, g_praci1, g_piacr1, g_psaci1, & & g_pgaci1 INTEGER :: i, k REAL :: fsupcol, fqc, fqi, fqr, fqs, fqg, delta3, xlf, a, b, c, d, e REAL :: g_fsupcol, g_xlf, g_a, g_b, g_c, g_d INTRINSIC MAX INTRINSIC SQRT INTRINSIC ABS INTRINSIC MIN INTRINSIC EXP REAL :: x1 REAL :: g_x1 REAL :: x2 REAL :: g_x2 REAL :: x3 REAL :: g_x3 REAL :: x4 REAL :: g_x4 REAL :: x5 REAL :: g_x5 REAL :: y1 REAL :: g_y1 REAL :: y2 REAL :: g_y2 REAL :: y3 REAL :: g_y3 REAL :: y4 REAL :: g_y4 REAL :: y5 REAL :: g_y5 REAL :: x6 REAL :: g_x6 REAL :: x7 REAL :: g_x7 REAL :: x8 REAL :: g_x8 REAL :: x9 REAL :: g_x9 REAL :: x10 REAL :: g_x10 REAL :: x11 REAL :: g_x11 REAL :: y6 REAL :: g_y6 REAL :: max1 REAL :: g_max1 REAL :: max2 REAL :: g_max2 REAL :: max3 REAL :: g_max3 REAL :: max4 REAL :: g_max4 REAL :: max5 REAL :: g_max5 REAL :: abs0 REAL :: g_abs0 REAL :: abs1 REAL :: abs2 REAL :: max6 REAL :: g_max6 REAL :: max7 REAL :: g_max7 REAL :: max8 REAL :: g_max8 REAL :: max9 REAL :: g_max9 REAL :: max10 REAL :: g_max10 REAL :: max11 REAL :: g_max11 REAL :: abs3 REAL :: g_abs3 REAL :: abs4 REAL :: max12 REAL :: g_max12 REAL :: max13 REAL :: g_max13 REAL :: max14 REAL :: g_max14 REAL :: max15 REAL :: g_max15 REAL :: max16 REAL :: g_max16 REAL :: abs5 REAL :: g_abs5 REAL :: abs6 REAL :: max17 REAL :: g_max17 REAL :: abs7 REAL :: abs8 REAL :: max18 REAL :: g_max18 REAL :: max19 REAL :: g_max19 REAL :: max20 REAL :: g_max20 REAL :: max21 REAL :: g_max21 REAL :: max22 REAL :: g_max22 REAL :: max23 REAL :: g_max23 REAL :: max24 REAL :: g_max24 REAL :: max25 REAL :: g_max25 REAL :: max26 REAL :: g_max26 REAL :: max27 REAL :: g_max27 REAL :: max28 REAL :: g_max28 REAL :: max29 REAL :: g_max29 REAL :: max30 REAL :: g_max30 REAL :: pwy1 REAL :: pwr1 REAL :: g_pwr1 REAL :: pwy2 REAL :: pwr2 REAL :: g_pwr2 REAL :: pwx1 REAL :: g_pwx1 REAL :: result1 REAL :: g_result1 REAL :: result2 REAL :: g_result2 REAL :: result3 REAL :: g_result3 REAL :: arg1 REAL :: g_arg1 REAL :: temp1 REAL :: temp2 g_cpm = 0.0_8 g_xl = 0.0_8 DO k=kts,kte DO i=its,ite !------------------------------------------------------------- ! praci: Accretion of cloud ice by rain [LFO 25] ! (TS or I->G) praci: min=0,max=qci(i,k,2)/dtcld !------------------------------------------------------------- g_supcol = -g_t(i, k) supcol = t0c - t(i, k) CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0') IF (qrs(i, k, 1) .LT. qcrmin) THEN max1 = qcrmin g_max1 = 0.0_8 ELSE g_max1 = g_qrs(i, k, 1) max1 = qrs(i, k, 1) END IF pwy1 = (bvtr-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvtr/4. IF (max1 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max1**(pwy2-1)*g_max1 END IF pwr2 = max1**pwy2 g_vt2r = vt2r_a*(pwr2*g_pwr1+pwr1*g_pwr2) vt2r = vt2r_a*pwr1*pwr2 IF (qci(i, k, 2) .LT. qmin) THEN max2 = qmin g_max2 = 0.0_8 ELSE g_max2 = g_qci(i, k, 2) max2 = qci(i, k, 2) END IF g_pwx1 = max2*g_den(i, k) + den(i, k)*g_max2 pwx1 = den(i, k)*max2 IF (pwx1 .LE. 0.0_8 .AND. (1.31/8. .EQ. 0.0_8 .OR. 1.31/8. .NE. & & INT(1.31/8.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 1.31*pwx1**(1.31/8.-1)*g_pwx1/8. END IF pwr1 = pwx1**(1.31/8.) g_vt2i = vt2i_a*g_pwr1 vt2i = vt2i_a*pwr1 IF (qrs(i, k, 1) .LT. qcrmin) THEN max3 = qcrmin g_max3 = 0.0_8 ELSE g_max3 = g_qrs(i, k, 1) max3 = qrs(i, k, 1) END IF IF (qci(i, k, 2) .LT. qmin) THEN max18 = qmin g_max18 = 0.0_8 ELSE g_max18 = g_qci(i, k, 2) max18 = qci(i, k, 2) END IF g_pwx1 = max3*g_den(i, k) + den(i, k)*g_max3 pwx1 = den(i, k)*max3 IF (pwx1 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT(& & 3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*pwx1**(3./4.-1)*g_pwx1/4. END IF pwr1 = pwx1**(3./4.) g_b = max18*g_pwr1 + pwr1*g_max18 b = pwr1*max18 IF (qrs(i, k, 1) .LT. qcrmin) THEN max4 = qcrmin g_max4 = 0.0_8 ELSE g_max4 = g_qrs(i, k, 1) max4 = qrs(i, k, 1) END IF IF (qci(i, k, 2) .LT. qmin) THEN max19 = qmin g_max19 = 0.0_8 ELSE g_max19 = g_qci(i, k, 2) max19 = qci(i, k, 2) END IF IF (den(i, k) .LE. 0.0_8 .AND. (5./8. .EQ. 0.0_8 .OR. 5./8. .NE.& & INT(5./8.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 5.*den(i, k)**(5./8.-1)*g_den(i, k)/8. END IF pwr1 = den(i, k)**(5./8.) temp1 = SQRT(max4) IF (max4 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_max4/(2.0*temp1) END IF result1 = temp1 IF (max19 .LE. 0.0_8 .AND. (9./8. .EQ. 0.0_8 .OR. 9./8. .NE. INT& & (9./8.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 9.*max19**(9./8.-1)*g_max19/8. END IF pwr2 = max19**(9./8.) g_c = pwr2*(result1*g_pwr1+pwr1*g_result1) + pwr1*result1*g_pwr2 c = pwr1*result1*pwr2 IF (qrs(i, k, 1) .LT. qcrmin) THEN max5 = qcrmin g_max5 = 0.0_8 ELSE g_max5 = g_qrs(i, k, 1) max5 = qrs(i, k, 1) END IF IF (qci(i, k, 2) .LT. qmin) THEN max20 = qmin g_max20 = 0.0_8 ELSE g_max20 = g_qci(i, k, 2) max20 = qci(i, k, 2) END IF temp1 = SQRT(den(i, k)) IF (den(i, k) .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_den(i, k)/(2.0*temp1) END IF result1 = temp1 temp1 = SQRT(max5) IF (max5 .EQ. 0.0_8) THEN g_result2 = 0.0_8 ELSE g_result2 = g_max5/(2.0*temp1) END IF result2 = temp1 temp1 = SQRT(result2) IF (result2 .EQ. 0.0_8) THEN g_result3 = 0.0_8 ELSE g_result3 = g_result2/(2.0*temp1) END IF result3 = temp1 IF (max20 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT& & (5./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 5.*max20**(5./4.-1)*g_max20/4. END IF pwr1 = max20**(5./4.) g_d = pwr1*(result3*g_result1+result1*g_result3) + result1*& & result3*g_pwr1 d = result1*result3*pwr1 IF (vt2r - vt2i .GE. 0.) THEN g_abs0 = g_vt2r - g_vt2i abs0 = vt2r - vt2i ELSE g_abs0 = g_vt2i - g_vt2r abs0 = -(vt2r-vt2i) END IF temp1 = praci_b*b + praci_c*c + praci_d*d g_praci1 = praci_a*(temp1*g_abs0+abs0*(praci_b*g_b+praci_c*g_c+& & praci_d*g_d)) praci1 = praci_a*(abs0*temp1) IF (praci1 .GT. qci(i, k, 2)/dtcld) THEN g_praci(i, k) = g_qci(i, k, 2)/dtcld praci(i, k) = qci(i, k, 2)/dtcld ELSE g_praci(i, k) = g_praci1 praci(i, k) = praci1 END IF g_praci(i, k) = praci(i, k)*g_fsupcol + fsupcol*g_praci(i, k) praci(i, k) = fsupcol*praci(i, k) !update qi, qs, qg IF (qrs(i, k, 1) .LT. 1.e-4) THEN delta3 = 1. ELSE delta3 = 0. END IF IF (praci(i, k) .GE. 0.) THEN abs1 = praci(i, k) ELSE abs1 = -praci(i, k) END IF IF (abs1 .LT. qmin/dtcld) THEN g_praci(i, k) = 0.0_8 praci(i, k) = 0. END IF IF (qci(i, k, 2) - praci(i, k)*dtcld .LT. 0.) THEN g_qci(i, k, 2) = 0.0_8 qci(i, k, 2) = 0. ELSE g_qci(i, k, 2) = g_qci(i, k, 2) - dtcld*g_praci(i, k) qci(i, k, 2) = qci(i, k, 2) - praci(i, k)*dtcld END IF g_x1 = g_qrs(i, k, 2) + delta3*dtcld*g_praci(i, k) x1 = qrs(i, k, 2) + praci(i, k)*delta3*dtcld IF (x1 .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_x1 qrs(i, k, 2) = x1 END IF g_x2 = g_qrs(i, k, 3) + (1-delta3)*dtcld*g_praci(i, k) x2 = qrs(i, k, 3) + praci(i, k)*(1-delta3)*dtcld IF (x2 .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_x2 qrs(i, k, 3) = x2 END IF g_praci(i, k) = 0.0_8 praci(i, k) = 0. !------------------------------------------------------------- ! piacr: Accretion of rain by cloud ice [LFO 26] ! (TS or R->G) piacr: min=0,max=qrs(i,k,1)/dtcld !------------------------------------------------------------- ! supcol = t0c-t(i,k) !not change CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0') !call smoothif(qci(i,k,2),qmin ,fqi,'q0') !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0') !update cpm g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k)) g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_xlf = -g_xl(i, k) xlf = xls - xl(i, k) IF (supcol .LT. 0.) THEN xlf = xlf0 g_xlf = 0.0_8 END IF IF (qci(i, k, 2) .GT. 0. .AND. qrs(i, k, 1) .GT. 0.) THEN !piacr_a=1.75e5 pwy1 = (3.+bvtr)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE.& & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = (6.+bvtr)/4. IF (qrs(i, k, 1) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 & & .NE. INT(pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*qrs(i, k, 1)**(pwy2-1)*g_qrs(i, k, 1) END IF pwr2 = qrs(i, k, 1)**pwy2 temp1 = qci(i, k, 2)**0.75 g_piacr1 = piacr_a*(pwr1*pwr2*0.75*qci(i, k, 2)**(-0.25)*g_qci& & (i, k, 2)+temp1*(pwr2*g_pwr1+pwr1*g_pwr2)) piacr1 = piacr_a*(temp1*(pwr1*pwr2)) ELSE piacr1 = 0. g_piacr1 = 0.0_8 END IF IF (piacr1 .GT. qrs(i, k, 1)/dtcld) THEN g_piacr(i, k) = g_qrs(i, k, 1)/dtcld piacr(i, k) = qrs(i, k, 1)/dtcld ELSE g_piacr(i, k) = g_piacr1 piacr(i, k) = piacr1 END IF g_piacr(i, k) = piacr(i, k)*g_fsupcol + fsupcol*g_piacr(i, k) piacr(i, k) = fsupcol*piacr(i, k) ! update qr,qs,qg,t IF (qrs(i, k, 1) .LT. 1.e-4) THEN delta3 = 1. ELSE delta3 = 0. END IF IF (piacr(i, k) .GE. 0.) THEN abs2 = piacr(i, k) ELSE abs2 = -piacr(i, k) END IF IF (abs2 .LT. qmin/dtcld) THEN g_piacr(i, k) = 0.0_8 piacr(i, k) = 0. END IF IF (qrs(i, k, 1) - piacr(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_qrs(i, k, 1) - dtcld*g_piacr(i, k) qrs(i, k, 1) = qrs(i, k, 1) - piacr(i, k)*dtcld END IF g_x3 = g_qrs(i, k, 2) + delta3*dtcld*g_piacr(i, k) x3 = qrs(i, k, 2) + piacr(i, k)*delta3*dtcld IF (x3 .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_x3 qrs(i, k, 2) = x3 END IF g_x4 = g_qrs(i, k, 3) + (1-delta3)*dtcld*g_piacr(i, k) x4 = qrs(i, k, 3) + piacr(i, k)*(1-delta3)*dtcld IF (x4 .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_x4 qrs(i, k, 3) = x4 END IF temp1 = piacr(i, k)*xlf/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*(xlf*g_piacr(i, k)+piacr(i, k)*& & g_xlf-temp1*g_cpm(i, k))/cpm(i, k) t(i, k) = t(i, k) + dtcld*temp1 g_piacr(i, k) = 0.0_8 piacr(i, k) = 0. !------------------------------------------------------------- ! psaci: Accretion of cloud ice by snow [HDC 10] ! (TS) psaci: min=0, max=qci(i,k,2)/dtcld !------------------------------------------------------------- g_supcol = -g_t(i, k) supcol = t0c - t(i, k) CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0') g_x5 = -(EXP(-(0.07*supcol))*0.07*g_supcol) x5 = EXP(0.07*(-supcol)) IF (x5 .GT. 1.) THEN eacrs = 1. g_eacrs = 0.0_8 ELSE g_eacrs = g_x5 eacrs = x5 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max6 = qcrmin g_max6 = 0.0_8 ELSE g_max6 = g_qrs(i, k, 2) max6 = qrs(i, k, 2) END IF IF (90. .GT. t0c - t(i, k)) THEN g_y6 = -g_t(i, k) y6 = t0c - t(i, k) ELSE y6 = 90. g_y6 = 0.0_8 END IF IF (0. .LT. y6) THEN g_max21 = g_y6 max21 = y6 ELSE max21 = 0. g_max21 = 0.0_8 END IF pwy1 = (bvts-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvts/4. IF (max6 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max6**(pwy2-1)*g_max6 END IF pwr2 = max6**pwy2 g_arg1 = -(alpha*bvts*g_max21/4.) arg1 = -(alpha*bvts*max21/4.) temp1 = EXP(arg1) g_vt2s = vt2s_a*(temp1*(pwr2*g_pwr1+pwr1*g_pwr2)+pwr1*pwr2*EXP(& & arg1)*g_arg1) vt2s = vt2s_a*(pwr1*pwr2*temp1) IF (qci(i, k, 2) .LT. qmin) THEN max7 = qmin g_max7 = 0.0_8 ELSE g_max7 = g_qci(i, k, 2) max7 = qci(i, k, 2) END IF g_pwx1 = max7*g_den(i, k) + den(i, k)*g_max7 pwx1 = den(i, k)*max7 IF (pwx1 .LE. 0.0_8 .AND. (1.31/8. .EQ. 0.0_8 .OR. 1.31/8. .NE. & & INT(1.31/8.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 1.31*pwx1**(1.31/8.-1)*g_pwx1/8. END IF pwr1 = pwx1**(1.31/8.) g_vt2i = vt2i_a*g_pwr1 vt2i = vt2i_a*pwr1 IF (90. .GT. t0c - t(i, k)) THEN g_y1 = -g_t(i, k) y1 = t0c - t(i, k) ELSE y1 = 90. g_y1 = 0.0_8 END IF IF (0. .LT. y1) THEN g_max8 = g_y1 max8 = y1 ELSE max8 = 0. g_max8 = 0.0_8 END IF g_a = EXP(alpha*max8)*alpha*g_max8 a = EXP(alpha*max8) IF (90. .GT. t0c - t(i, k)) THEN g_y2 = -g_t(i, k) y2 = t0c - t(i, k) ELSE y2 = 90. g_y2 = 0.0_8 END IF IF (0. .LT. y2) THEN g_max9 = g_y2 max9 = y2 ELSE max9 = 0. g_max9 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max22 = qcrmin g_max22 = 0.0_8 ELSE g_max22 = g_qrs(i, k, 2) max22 = qrs(i, k, 2) END IF IF (qci(i, k, 2) .LT. qmin) THEN max28 = qmin g_max28 = 0.0_8 ELSE g_max28 = g_qci(i, k, 2) max28 = qci(i, k, 2) END IF g_arg1 = -(alpha*3.*g_max9/4.) arg1 = -(3.*alpha*max9/4.) g_pwx1 = max22*g_den(i, k) + den(i, k)*g_max22 pwx1 = den(i, k)*max22 IF (pwx1 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT(& & 3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*pwx1**(3./4.-1)*g_pwx1/4. END IF pwr1 = pwx1**(3./4.) temp1 = EXP(arg1) g_b = pwr1*max28*EXP(arg1)*g_arg1 + temp1*(max28*g_pwr1+pwr1*& & g_max28) b = temp1*(pwr1*max28) IF (90. .GT. t0c - t(i, k)) THEN g_y3 = -g_t(i, k) y3 = t0c - t(i, k) ELSE y3 = 90. g_y3 = 0.0_8 END IF IF (0. .LT. y3) THEN g_max10 = g_y3 max10 = y3 ELSE max10 = 0. g_max10 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max23 = qcrmin g_max23 = 0.0_8 ELSE g_max23 = g_qrs(i, k, 2) max23 = qrs(i, k, 2) END IF IF (qci(i, k, 2) .LT. qmin) THEN max29 = qmin g_max29 = 0.0_8 ELSE g_max29 = g_qci(i, k, 2) max29 = qci(i, k, 2) END IF g_arg1 = -(alpha*g_max10/2.) arg1 = -(alpha*max10/2.) IF (den(i, k) .LE. 0.0_8 .AND. (5./8. .EQ. 0.0_8 .OR. 5./8. .NE.& & INT(5./8.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 5.*den(i, k)**(5./8.-1)*g_den(i, k)/8. END IF pwr1 = den(i, k)**(5./8.) temp1 = SQRT(max23) IF (max23 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_max23/(2.0*temp1) END IF result1 = temp1 IF (max29 .LE. 0.0_8 .AND. (9./8. .EQ. 0.0_8 .OR. 9./8. .NE. INT& & (9./8.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 9.*max29**(9./8.-1)*g_max29/8. END IF pwr2 = max29**(9./8.) temp1 = pwr1*result1*pwr2 temp2 = EXP(arg1) g_c = temp1*EXP(arg1)*g_arg1 + temp2*(pwr2*(result1*g_pwr1+pwr1*& & g_result1)+pwr1*result1*g_pwr2) c = temp2*temp1 IF (90. .GT. t0c - t(i, k)) THEN g_y4 = -g_t(i, k) y4 = t0c - t(i, k) ELSE y4 = 90. g_y4 = 0.0_8 END IF IF (0. .LT. y4) THEN g_max11 = g_y4 max11 = y4 ELSE max11 = 0. g_max11 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max24 = qcrmin g_max24 = 0.0_8 ELSE g_max24 = g_qrs(i, k, 2) max24 = qrs(i, k, 2) END IF IF (qci(i, k, 2) .LT. qmin) THEN max30 = qmin g_max30 = 0.0_8 ELSE g_max30 = g_qci(i, k, 2) max30 = qci(i, k, 2) END IF g_arg1 = -(alpha*g_max11/4.) arg1 = -(alpha*max11/4.) temp2 = SQRT(den(i, k)) IF (den(i, k) .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_den(i, k)/(2.0*temp2) END IF result1 = temp2 temp2 = SQRT(max24) IF (max24 .EQ. 0.0_8) THEN g_result2 = 0.0_8 ELSE g_result2 = g_max24/(2.0*temp2) END IF result2 = temp2 temp2 = SQRT(result2) IF (result2 .EQ. 0.0_8) THEN g_result3 = 0.0_8 ELSE g_result3 = g_result2/(2.0*temp2) END IF result3 = temp2 IF (max30 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT& & (5./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 5.*max30**(5./4.-1)*g_max30/4. END IF pwr1 = max30**(5./4.) temp2 = result1*result3*pwr1 temp1 = EXP(arg1) g_d = temp2*EXP(arg1)*g_arg1 + temp1*(pwr1*(result3*g_result1+& & result1*g_result3)+result1*result3*g_pwr1) d = temp1*temp2 IF (vt2s - vt2i .GE. 0.) THEN g_abs3 = g_vt2s - g_vt2i abs3 = vt2s - vt2i ELSE g_abs3 = g_vt2i - g_vt2s abs3 = -(vt2s-vt2i) END IF temp2 = psaci_b*b + psaci_c*c + psaci_d*d temp1 = a*abs3*eacrs g_psaci1 = psaci_a*(temp2*(eacrs*(abs3*g_a+a*g_abs3)+a*abs3*& & g_eacrs)+temp1*(psaci_b*g_b+psaci_c*g_c+psaci_d*g_d)) psaci1 = psaci_a*(temp1*temp2) IF (psaci1 .GT. qci(i, k, 2)/dtcld) THEN g_psaci(i, k) = g_qci(i, k, 2)/dtcld psaci(i, k) = qci(i, k, 2)/dtcld ELSE g_psaci(i, k) = g_psaci1 psaci(i, k) = psaci1 END IF g_psaci(i, k) = psaci(i, k)*g_fsupcol + fsupcol*g_psaci(i, k) psaci(i, k) = fsupcol*psaci(i, k) IF (psaci(i, k) .GE. 0.) THEN abs4 = psaci(i, k) ELSE abs4 = -psaci(i, k) END IF IF (abs4 .LT. qmin/dtcld) THEN g_psaci(i, k) = 0.0_8 psaci(i, k) = 0. END IF IF (qci(i, k, 2) - psaci(i, k)*dtcld .LT. 0.) THEN g_qci(i, k, 2) = 0.0_8 qci(i, k, 2) = 0. ELSE g_qci(i, k, 2) = g_qci(i, k, 2) - dtcld*g_psaci(i, k) qci(i, k, 2) = qci(i, k, 2) - psaci(i, k)*dtcld END IF IF (qrs(i, k, 2) + psaci(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_qrs(i, k, 2) + dtcld*g_psaci(i, k) qrs(i, k, 2) = qrs(i, k, 2) + psaci(i, k)*dtcld END IF g_psaci(i, k) = 0.0_8 psaci(i, k) = 0. !------------------------------------------------------------- ! pgaci: Accretion of cloud ice by graupel [LFO 41] ! (TG) pgaci:min=0,max=qci(i,k,2)/dtcld !------------------------------------------------------------- ! supcol = t0c-t(i,k) !not change ! call smoothif(supcol, 0.,fsupcol,'t0') !call smoothif(qci(i,k,2),qmin ,fqi,'q0') !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0') !min(exp(0.07*(-supcol)),1.) g_egi = g_eacrs egi = eacrs IF (qrs(i, k, 3) .LT. qcrmin) THEN max12 = qcrmin g_max12 = 0.0_8 ELSE g_max12 = g_qrs(i, k, 3) max12 = qrs(i, k, 3) END IF pwy1 = (bvtg-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvtg/4. IF (max12 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max12**(pwy2-1)*g_max12 END IF pwr2 = max12**pwy2 g_vt2g = vt2g_a*(pwr2*g_pwr1+pwr1*g_pwr2) vt2g = vt2g_a*pwr1*pwr2 IF (qci(i, k, 2) .LT. qmin) THEN max13 = qmin g_max13 = 0.0_8 ELSE g_max13 = g_qci(i, k, 2) max13 = qci(i, k, 2) END IF g_pwx1 = max13*g_den(i, k) + den(i, k)*g_max13 pwx1 = den(i, k)*max13 IF (pwx1 .LE. 0.0_8 .AND. (1.31/8. .EQ. 0.0_8 .OR. 1.31/8. .NE. & & INT(1.31/8.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 1.31*pwx1**(1.31/8.-1)*g_pwx1/8. END IF pwr1 = pwx1**(1.31/8.) g_vt2i = vt2i_a*g_pwr1 vt2i = vt2i_a*pwr1 IF (qrs(i, k, 3) .LT. qcrmin) THEN max14 = qcrmin g_max14 = 0.0_8 ELSE g_max14 = g_qrs(i, k, 3) max14 = qrs(i, k, 3) END IF IF (qci(i, k, 2) .LT. qmin) THEN max25 = qmin g_max25 = 0.0_8 ELSE g_max25 = g_qci(i, k, 2) max25 = qci(i, k, 2) END IF g_pwx1 = max14*g_den(i, k) + den(i, k)*g_max14 pwx1 = den(i, k)*max14 IF (pwx1 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT(& & 3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*pwx1**(3./4.-1)*g_pwx1/4. END IF pwr1 = pwx1**(3./4.) g_b = max25*g_pwr1 + pwr1*g_max25 b = pwr1*max25 IF (qrs(i, k, 3) .LT. qcrmin) THEN max15 = qcrmin g_max15 = 0.0_8 ELSE g_max15 = g_qrs(i, k, 3) max15 = qrs(i, k, 3) END IF IF (qci(i, k, 2) .LT. qmin) THEN max26 = qmin g_max26 = 0.0_8 ELSE g_max26 = g_qci(i, k, 2) max26 = qci(i, k, 2) END IF IF (den(i, k) .LE. 0.0_8 .AND. (5./8. .EQ. 0.0_8 .OR. 5./8. .NE.& & INT(5./8.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 5.*den(i, k)**(5./8.-1)*g_den(i, k)/8. END IF pwr1 = den(i, k)**(5./8.) temp2 = SQRT(max15) IF (max15 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_max15/(2.0*temp2) END IF result1 = temp2 IF (max26 .LE. 0.0_8 .AND. (9./8. .EQ. 0.0_8 .OR. 9./8. .NE. INT& & (9./8.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 9.*max26**(9./8.-1)*g_max26/8. END IF pwr2 = max26**(9./8.) g_c = pwr2*(result1*g_pwr1+pwr1*g_result1) + pwr1*result1*g_pwr2 c = pwr1*result1*pwr2 IF (qrs(i, k, 3) .LT. qcrmin) THEN max16 = qcrmin g_max16 = 0.0_8 ELSE g_max16 = g_qrs(i, k, 3) max16 = qrs(i, k, 3) END IF IF (qci(i, k, 2) .LT. qmin) THEN max27 = qmin g_max27 = 0.0_8 ELSE g_max27 = g_qci(i, k, 2) max27 = qci(i, k, 2) END IF temp2 = SQRT(den(i, k)) IF (den(i, k) .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_den(i, k)/(2.0*temp2) END IF result1 = temp2 temp2 = SQRT(max16) IF (max16 .EQ. 0.0_8) THEN g_result2 = 0.0_8 ELSE g_result2 = g_max16/(2.0*temp2) END IF result2 = temp2 temp2 = SQRT(result2) IF (result2 .EQ. 0.0_8) THEN g_result3 = 0.0_8 ELSE g_result3 = g_result2/(2.0*temp2) END IF result3 = temp2 IF (max27 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT& & (5./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 5.*max27**(5./4.-1)*g_max27/4. END IF pwr1 = max27**(5./4.) g_d = pwr1*(result3*g_result1+result1*g_result3) + result1*& & result3*g_pwr1 d = result1*result3*pwr1 IF (vt2g - vt2i .GE. 0.) THEN g_abs5 = g_vt2g - g_vt2i abs5 = vt2g - vt2i ELSE g_abs5 = g_vt2i - g_vt2g abs5 = -(vt2g-vt2i) END IF temp2 = pgaci_b*b + pgaci_c*c + pgaci_d*d g_pgaci1 = pgaci_a*(abs5*egi*(pgaci_b*g_b+pgaci_c*g_c+pgaci_d*& & g_d)+temp2*(egi*g_abs5+abs5*g_egi)) pgaci1 = pgaci_a*(temp2*(abs5*egi)) IF (pgaci1 .GT. qci(i, k, 2)/dtcld) THEN g_pgaci(i, k) = g_qci(i, k, 2)/dtcld pgaci(i, k) = qci(i, k, 2)/dtcld ELSE g_pgaci(i, k) = g_pgaci1 pgaci(i, k) = pgaci1 END IF g_pgaci(i, k) = pgaci(i, k)*g_fsupcol + fsupcol*g_pgaci(i, k) pgaci(i, k) = fsupcol*pgaci(i, k) IF (pgaci(i, k) .GE. 0.) THEN abs6 = pgaci(i, k) ELSE abs6 = -pgaci(i, k) END IF IF (abs6 .LT. qmin/dtcld) THEN g_pgaci(i, k) = 0.0_8 pgaci(i, k) = 0. END IF IF (qci(i, k, 2) - pgaci(i, k)*dtcld .LT. 0.) THEN g_qci(i, k, 2) = 0.0_8 qci(i, k, 2) = 0. ELSE g_qci(i, k, 2) = g_qci(i, k, 2) - dtcld*g_pgaci(i, k) qci(i, k, 2) = qci(i, k, 2) - pgaci(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgaci(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgaci(i, k) qrs(i, k, 3) = qrs(i, k, 3) + pgaci(i, k)*dtcld END IF g_pgaci(i, k) = 0.0_8 pgaci(i, k) = 0. !------------------------------------------------------------- ! psacw: Accretion of cloud water by snow [LFO 24] ! (TG, and T>=T0: C->R) psacw:min=0,max=qci(i,k,1)/dtcld !------------------------------------------------------------- ! supcol = t0c-t(i,k) !not change ! call smoothif(supcol, 0.,fsupcol,'t0') !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0') !call smoothif(qci(i,k,1),qmin ,fqc,'q0') !update cpm ! cpm(i,k)=cpmcal(q(i,k)) !not change g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_xlf = -g_xl(i, k) xlf = xls - xl(i, k) IF (supcol .LT. 0.) THEN xlf = xlf0 g_xlf = 0.0_8 END IF IF (qrs(i, k, 2) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN IF (90. .GT. t0c - t(i, k)) THEN g_y5 = -g_t(i, k) y5 = t0c - t(i, k) ELSE y5 = 90. g_y5 = 0.0_8 END IF IF (0. .LT. y5) THEN g_max17 = g_y5 max17 = y5 ELSE max17 = 0. g_max17 = 0.0_8 END IF g_arg1 = (1.-bvts)*alpha*g_max17/4. arg1 = (1.-bvts)*alpha*max17/4. g_a = EXP(arg1)*g_arg1 a = EXP(arg1) pwy1 = (1.+bvts)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE.& & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = (3.+bvts)/4. IF (qrs(i, k, 2) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 & & .NE. INT(pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*qrs(i, k, 2)**(pwy2-1)*g_qrs(i, k, 2) END IF pwr2 = qrs(i, k, 2)**pwy2 temp2 = a*pwr1*pwr2 g_psacw(i, k) = psacw_a*(qci(i, k, 1)*(pwr2*(pwr1*g_a+a*g_pwr1& & )+a*pwr1*g_pwr2)+temp2*g_qci(i, k, 1)) psacw(i, k) = psacw_a*(temp2*qci(i, k, 1)) ELSE g_psacw(i, k) = 0.0_8 psacw(i, k) = 0. END IF IF (psacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN g_x6 = g_qci(i, k, 1)/dtcld x6 = qci(i, k, 1)/dtcld ELSE g_x6 = g_psacw(i, k) x6 = psacw(i, k) END IF IF (x6 .LT. 0.) THEN g_psacw(i, k) = 0.0_8 psacw(i, k) = 0. ELSE g_psacw(i, k) = g_x6 psacw(i, k) = x6 END IF g_psacw(i, k) = psacw(i, k)*g_fsupcol + fsupcol*g_psacw(i, k) psacw(i, k) = fsupcol*psacw(i, k) IF (psacw(i, k) .GE. 0.) THEN abs7 = psacw(i, k) ELSE abs7 = -psacw(i, k) END IF IF (abs7 .LT. qmin/dtcld) THEN g_psacw(i, k) = 0.0_8 psacw(i, k) = 0. END IF IF (qci(i, k, 1) - psacw(i, k)*dtcld .LT. 0.) THEN g_qci(i, k, 1) = 0.0_8 qci(i, k, 1) = 0. ELSE g_qci(i, k, 1) = g_qci(i, k, 1) - dtcld*g_psacw(i, k) qci(i, k, 1) = qci(i, k, 1) - psacw(i, k)*dtcld END IF g_x7 = g_qrs(i, k, 1) + dtcld*((1.-fsupcol)*g_psacw(i, k)-psacw(& & i, k)*g_fsupcol) x7 = qrs(i, k, 1) + (1.-fsupcol)*psacw(i, k)*dtcld IF (x7 .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_x7 qrs(i, k, 1) = x7 END IF g_x8 = g_qrs(i, k, 3) + dtcld*(psacw(i, k)*g_fsupcol+fsupcol*& & g_psacw(i, k)) x8 = qrs(i, k, 3) + fsupcol*psacw(i, k)*dtcld IF (x8 .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_x8 qrs(i, k, 3) = x8 END IF temp2 = psacw(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*(temp2*(xlf*g_fsupcol+fsupcol*& & g_xlf)+fsupcol*xlf*(g_psacw(i, k)-temp2*g_cpm(i, k))/cpm(i, k)& & ) t(i, k) = t(i, k) + dtcld*(fsupcol*xlf*temp2) !t>=t0 pseml g_psacw(i, k) = (1-fsupcol)*g_psacw(i, k) - psacw(i, k)*& & g_fsupcol psacw(i, k) = (1-fsupcol)*psacw(i, k) !------------------------------------------------------------- ! pgacw: Accretion of cloud water by graupel [LFO 40] ! (TG, and T>=T0: C->R) pgacw:min=0.,max=qci(i,k,1)/dtcld !------------------------------------------------------------- g_supcol = -g_t(i, k) supcol = t0c - t(i, k) CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0') !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0') !call smoothif(qci(i,k,1),qmin ,fqc,'q0') ! cpm(i,k)=cpmcal(q(i,k)) !not change g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_xlf = -g_xl(i, k) xlf = xls - xl(i, k) IF (supcol .LT. 0.) THEN xlf = xlf0 g_xlf = 0.0_8 END IF IF (qrs(i, k, 3) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN pwy1 = (1.+bvtg)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE.& & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = (3.+bvtg)/4. IF (qrs(i, k, 3) .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 & & .NE. INT(pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*qrs(i, k, 3)**(pwy2-1)*g_qrs(i, k, 3) END IF pwr2 = qrs(i, k, 3)**pwy2 g_pgacw(i, k) = pgacw_a*(qci(i, k, 1)*(pwr2*g_pwr1+pwr1*g_pwr2& & )+pwr1*pwr2*g_qci(i, k, 1)) pgacw(i, k) = pgacw_a*pwr1*pwr2*qci(i, k, 1) ELSE g_pgacw(i, k) = 0.0_8 pgacw(i, k) = 0. END IF IF (pgacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN g_x9 = g_qci(i, k, 1)/dtcld x9 = qci(i, k, 1)/dtcld ELSE g_x9 = g_pgacw(i, k) x9 = pgacw(i, k) END IF IF (x9 .LT. 0.) THEN g_pgacw(i, k) = 0.0_8 pgacw(i, k) = 0. ELSE g_pgacw(i, k) = g_x9 pgacw(i, k) = x9 END IF IF (pgacw(i, k) .GE. 0.) THEN abs8 = pgacw(i, k) ELSE abs8 = -pgacw(i, k) END IF !pgacw(i,k)=fqg*fqc*pgacw(i,k) IF (abs8 .LT. qmin/dtcld) THEN g_pgacw(i, k) = 0.0_8 pgacw(i, k) = 0. END IF IF (qci(i, k, 1) - pgacw(i, k)*dtcld .LT. 0.) THEN g_qci(i, k, 1) = 0.0_8 qci(i, k, 1) = 0. ELSE g_qci(i, k, 1) = g_qci(i, k, 1) - dtcld*g_pgacw(i, k) qci(i, k, 1) = qci(i, k, 1) - pgacw(i, k)*dtcld END IF g_x10 = g_qrs(i, k, 1) + dtcld*((1.-fsupcol)*g_pgacw(i, k)-pgacw& & (i, k)*g_fsupcol) x10 = qrs(i, k, 1) + (1.-fsupcol)*pgacw(i, k)*dtcld IF (x10 .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_x10 qrs(i, k, 1) = x10 END IF g_x11 = g_qrs(i, k, 3) + dtcld*(pgacw(i, k)*g_fsupcol+fsupcol*& & g_pgacw(i, k)) x11 = qrs(i, k, 3) + fsupcol*pgacw(i, k)*dtcld IF (x11 .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_x11 qrs(i, k, 3) = x11 END IF temp2 = pgacw(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*(temp2*(xlf*g_fsupcol+fsupcol*& & g_xlf)+fsupcol*xlf*(g_pgacw(i, k)-temp2*g_cpm(i, k))/cpm(i, k)& & ) t(i, k) = t(i, k) + dtcld*(fsupcol*xlf*temp2) ! t>=t0 pgeml g_pgacw(i, k) = (1-fsupcol)*g_pgacw(i, k) - pgacw(i, k)*& & g_fsupcol pgacw(i, k) = (1-fsupcol)*pgacw(i, k) END DO END DO END SUBROUTINE G_ACCRET1 !=================================================================== SUBROUTINE ACCRET1(qci, den, qrs, t, q, dtcld, praci, piacr, psaci, & & pgaci, psacw, pgacw, ims, ime, kms, kme, its, ite, kts, kte) IMPLICIT NONE INTEGER :: ims, ime, kms, kme, its, ite, kts, kte !------------------------------------------------------------------- REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs REAL, DIMENSION(ims:ime, kms:kme) :: den, q REAL, DIMENSION(its:ite, kts:kte) :: praci, piacr, psaci, pgaci, & & psacw, pgacw, t, xl, cpm REAL :: supcol, dtcld, eacrs, egi, praci1, piacr1, psaci1, pgaci1, & & temp, temp0 INTEGER :: i, k REAL :: fsupcol, fqc, fqi, fqr, fqs, fqg, delta3, xlf, a, b, c, d, e INTRINSIC MAX INTRINSIC SQRT INTRINSIC ABS INTRINSIC MIN INTRINSIC EXP REAL :: x1 REAL :: x2 REAL :: x3 REAL :: x4 REAL :: x5 REAL :: y1 REAL :: y2 REAL :: y3 REAL :: y4 REAL :: y5 REAL :: x6 REAL :: x7 REAL :: x8 REAL :: x9 REAL :: x10 REAL :: x11 REAL :: y6 REAL :: max1 REAL :: max2 REAL :: max3 REAL :: max4 REAL :: max5 REAL :: abs0 REAL :: abs1 REAL :: abs2 REAL :: max6 REAL :: max7 REAL :: max8 REAL :: max9 REAL :: max10 REAL :: max11 REAL :: abs3 REAL :: abs4 REAL :: max12 REAL :: max13 REAL :: max14 REAL :: max15 REAL :: max16 REAL :: abs5 REAL :: abs6 REAL :: max17 REAL :: abs7 REAL :: abs8 REAL :: max18 REAL :: max19 REAL :: max20 REAL :: max21 REAL :: max22 REAL :: max23 REAL :: max24 REAL :: max25 REAL :: max26 REAL :: max27 REAL :: max28 REAL :: max29 REAL :: max30 REAL :: pwy1 REAL :: pwr1 REAL :: pwy2 REAL :: pwr2 REAL :: pwx1 REAL :: result1 REAL :: result2 REAL :: result3 REAL :: arg1 DO k=kts,kte DO i=its,ite !------------------------------------------------------------- ! praci: Accretion of cloud ice by rain [LFO 25] ! (TS or I->G) praci: min=0,max=qci(i,k,2)/dtcld !------------------------------------------------------------- supcol = t0c - t(i, k) CALL SMOOTHIF(supcol, 0., fsupcol, 't0') IF (qrs(i, k, 1) .LT. qcrmin) THEN max1 = qcrmin ELSE max1 = qrs(i, k, 1) END IF pwy1 = (bvtr-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvtr/4. pwr2 = max1**pwy2 vt2r = vt2r_a*pwr1*pwr2 IF (qci(i, k, 2) .LT. qmin) THEN max2 = qmin ELSE max2 = qci(i, k, 2) END IF pwx1 = den(i, k)*max2 pwr1 = pwx1**(1.31/8.) vt2i = vt2i_a*pwr1 IF (qrs(i, k, 1) .LT. qcrmin) THEN max3 = qcrmin ELSE max3 = qrs(i, k, 1) END IF IF (qci(i, k, 2) .LT. qmin) THEN max18 = qmin ELSE max18 = qci(i, k, 2) END IF pwx1 = den(i, k)*max3 pwr1 = pwx1**(3./4.) b = pwr1*max18 IF (qrs(i, k, 1) .LT. qcrmin) THEN max4 = qcrmin ELSE max4 = qrs(i, k, 1) END IF IF (qci(i, k, 2) .LT. qmin) THEN max19 = qmin ELSE max19 = qci(i, k, 2) END IF pwr1 = den(i, k)**(5./8.) result1 = SQRT(max4) pwr2 = max19**(9./8.) c = pwr1*result1*pwr2 IF (qrs(i, k, 1) .LT. qcrmin) THEN max5 = qcrmin ELSE max5 = qrs(i, k, 1) END IF IF (qci(i, k, 2) .LT. qmin) THEN max20 = qmin ELSE max20 = qci(i, k, 2) END IF result1 = SQRT(den(i, k)) result2 = SQRT(max5) result3 = SQRT(result2) pwr1 = max20**(5./4.) d = result1*result3*pwr1 IF (vt2r - vt2i .GE. 0.) THEN abs0 = vt2r - vt2i ELSE abs0 = -(vt2r-vt2i) END IF praci1 = praci_a*abs0*(praci_b*b+praci_c*c+praci_d*d) IF (praci1 .GT. qci(i, k, 2)/dtcld) THEN praci(i, k) = qci(i, k, 2)/dtcld ELSE praci(i, k) = praci1 END IF praci(i, k) = fsupcol*praci(i, k) !update qi, qs, qg IF (qrs(i, k, 1) .LT. 1.e-4) THEN delta3 = 1. ELSE delta3 = 0. END IF IF (praci(i, k) .GE. 0.) THEN abs1 = praci(i, k) ELSE abs1 = -praci(i, k) END IF IF (abs1 .LT. qmin/dtcld) praci(i, k) = 0. IF (qci(i, k, 2) - praci(i, k)*dtcld .LT. 0.) THEN qci(i, k, 2) = 0. ELSE qci(i, k, 2) = qci(i, k, 2) - praci(i, k)*dtcld END IF x1 = qrs(i, k, 2) + praci(i, k)*delta3*dtcld IF (x1 .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = x1 END IF x2 = qrs(i, k, 3) + praci(i, k)*(1-delta3)*dtcld IF (x2 .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = x2 END IF praci(i, k) = 0. !------------------------------------------------------------- ! piacr: Accretion of rain by cloud ice [LFO 26] ! (TS or R->G) piacr: min=0,max=qrs(i,k,1)/dtcld !------------------------------------------------------------- ! supcol = t0c-t(i,k) !not change CALL SMOOTHIF(supcol, 0., fsupcol, 't0') !call smoothif(qci(i,k,2),qmin ,fqi,'q0') !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0') !update cpm cpm(i, k) = CPMCAL(q(i, k)) xl(i, k) = XLCAL(t(i, k)) xlf = xls - xl(i, k) IF (supcol .LT. 0.) xlf = xlf0 IF (qci(i, k, 2) .GT. 0. .AND. qrs(i, k, 1) .GT. 0.) THEN !piacr_a=1.75e5 pwy1 = (3.+bvtr)/4. pwr1 = den(i, k)**pwy1 pwy2 = (6.+bvtr)/4. pwr2 = qrs(i, k, 1)**pwy2 piacr1 = piacr_a*pwr1*qci(i, k, 2)**0.75*pwr2 ELSE piacr1 = 0. END IF IF (piacr1 .GT. qrs(i, k, 1)/dtcld) THEN piacr(i, k) = qrs(i, k, 1)/dtcld ELSE piacr(i, k) = piacr1 END IF piacr(i, k) = fsupcol*piacr(i, k) ! update qr,qs,qg,t IF (qrs(i, k, 1) .LT. 1.e-4) THEN delta3 = 1. ELSE delta3 = 0. END IF IF (piacr(i, k) .GE. 0.) THEN abs2 = piacr(i, k) ELSE abs2 = -piacr(i, k) END IF IF (abs2 .LT. qmin/dtcld) piacr(i, k) = 0. IF (qrs(i, k, 1) - piacr(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) - piacr(i, k)*dtcld END IF x3 = qrs(i, k, 2) + piacr(i, k)*delta3*dtcld IF (x3 .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = x3 END IF x4 = qrs(i, k, 3) + piacr(i, k)*(1-delta3)*dtcld IF (x4 .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = x4 END IF t(i, k) = t(i, k) + piacr(i, k)*dtcld*xlf/cpm(i, k) piacr(i, k) = 0. !------------------------------------------------------------- ! psaci: Accretion of cloud ice by snow [HDC 10] ! (TS) psaci: min=0, max=qci(i,k,2)/dtcld !------------------------------------------------------------- supcol = t0c - t(i, k) CALL SMOOTHIF(supcol, 0., fsupcol, 't0') x5 = EXP(0.07*(-supcol)) IF (x5 .GT. 1.) THEN eacrs = 1. ELSE eacrs = x5 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max6 = qcrmin ELSE max6 = qrs(i, k, 2) END IF IF (90. .GT. t0c - t(i, k)) THEN y6 = t0c - t(i, k) ELSE y6 = 90. END IF IF (0. .LT. y6) THEN max21 = y6 ELSE max21 = 0. END IF pwy1 = (bvts-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvts/4. pwr2 = max6**pwy2 arg1 = -(alpha*bvts*max21/4.) vt2s = vt2s_a*pwr1*pwr2*EXP(arg1) IF (qci(i, k, 2) .LT. qmin) THEN max7 = qmin ELSE max7 = qci(i, k, 2) END IF pwx1 = den(i, k)*max7 pwr1 = pwx1**(1.31/8.) vt2i = vt2i_a*pwr1 IF (90. .GT. t0c - t(i, k)) THEN y1 = t0c - t(i, k) ELSE y1 = 90. END IF IF (0. .LT. y1) THEN max8 = y1 ELSE max8 = 0. END IF a = EXP(alpha*max8) IF (90. .GT. t0c - t(i, k)) THEN y2 = t0c - t(i, k) ELSE y2 = 90. END IF IF (0. .LT. y2) THEN max9 = y2 ELSE max9 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max22 = qcrmin ELSE max22 = qrs(i, k, 2) END IF IF (qci(i, k, 2) .LT. qmin) THEN max28 = qmin ELSE max28 = qci(i, k, 2) END IF arg1 = -(3.*alpha*max9/4.) pwx1 = den(i, k)*max22 pwr1 = pwx1**(3./4.) b = EXP(arg1)*pwr1*max28 IF (90. .GT. t0c - t(i, k)) THEN y3 = t0c - t(i, k) ELSE y3 = 90. END IF IF (0. .LT. y3) THEN max10 = y3 ELSE max10 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max23 = qcrmin ELSE max23 = qrs(i, k, 2) END IF IF (qci(i, k, 2) .LT. qmin) THEN max29 = qmin ELSE max29 = qci(i, k, 2) END IF arg1 = -(alpha*max10/2.) pwr1 = den(i, k)**(5./8.) result1 = SQRT(max23) pwr2 = max29**(9./8.) c = EXP(arg1)*pwr1*result1*pwr2 IF (90. .GT. t0c - t(i, k)) THEN y4 = t0c - t(i, k) ELSE y4 = 90. END IF IF (0. .LT. y4) THEN max11 = y4 ELSE max11 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max24 = qcrmin ELSE max24 = qrs(i, k, 2) END IF IF (qci(i, k, 2) .LT. qmin) THEN max30 = qmin ELSE max30 = qci(i, k, 2) END IF arg1 = -(alpha*max11/4.) result1 = SQRT(den(i, k)) result2 = SQRT(max24) result3 = SQRT(result2) pwr1 = max30**(5./4.) d = EXP(arg1)*result1*result3*pwr1 IF (vt2s - vt2i .GE. 0.) THEN abs3 = vt2s - vt2i ELSE abs3 = -(vt2s-vt2i) END IF psaci1 = psaci_a*a*abs3*(psaci_b*b+psaci_c*c+psaci_d*d)*eacrs IF (psaci1 .GT. qci(i, k, 2)/dtcld) THEN psaci(i, k) = qci(i, k, 2)/dtcld ELSE psaci(i, k) = psaci1 END IF psaci(i, k) = fsupcol*psaci(i, k) IF (psaci(i, k) .GE. 0.) THEN abs4 = psaci(i, k) ELSE abs4 = -psaci(i, k) END IF IF (abs4 .LT. qmin/dtcld) psaci(i, k) = 0. IF (qci(i, k, 2) - psaci(i, k)*dtcld .LT. 0.) THEN qci(i, k, 2) = 0. ELSE qci(i, k, 2) = qci(i, k, 2) - psaci(i, k)*dtcld END IF IF (qrs(i, k, 2) + psaci(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = qrs(i, k, 2) + psaci(i, k)*dtcld END IF psaci(i, k) = 0. !------------------------------------------------------------- ! pgaci: Accretion of cloud ice by graupel [LFO 41] ! (TG) pgaci:min=0,max=qci(i,k,2)/dtcld !------------------------------------------------------------- ! supcol = t0c-t(i,k) !not change ! call smoothif(supcol, 0.,fsupcol,'t0') !call smoothif(qci(i,k,2),qmin ,fqi,'q0') !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0') !min(exp(0.07*(-supcol)),1.) egi = eacrs IF (qrs(i, k, 3) .LT. qcrmin) THEN max12 = qcrmin ELSE max12 = qrs(i, k, 3) END IF pwy1 = (bvtg-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvtg/4. pwr2 = max12**pwy2 vt2g = vt2g_a*pwr1*pwr2 IF (qci(i, k, 2) .LT. qmin) THEN max13 = qmin ELSE max13 = qci(i, k, 2) END IF pwx1 = den(i, k)*max13 pwr1 = pwx1**(1.31/8.) vt2i = vt2i_a*pwr1 IF (qrs(i, k, 3) .LT. qcrmin) THEN max14 = qcrmin ELSE max14 = qrs(i, k, 3) END IF IF (qci(i, k, 2) .LT. qmin) THEN max25 = qmin ELSE max25 = qci(i, k, 2) END IF pwx1 = den(i, k)*max14 pwr1 = pwx1**(3./4.) b = pwr1*max25 IF (qrs(i, k, 3) .LT. qcrmin) THEN max15 = qcrmin ELSE max15 = qrs(i, k, 3) END IF IF (qci(i, k, 2) .LT. qmin) THEN max26 = qmin ELSE max26 = qci(i, k, 2) END IF pwr1 = den(i, k)**(5./8.) result1 = SQRT(max15) pwr2 = max26**(9./8.) c = pwr1*result1*pwr2 IF (qrs(i, k, 3) .LT. qcrmin) THEN max16 = qcrmin ELSE max16 = qrs(i, k, 3) END IF IF (qci(i, k, 2) .LT. qmin) THEN max27 = qmin ELSE max27 = qci(i, k, 2) END IF result1 = SQRT(den(i, k)) result2 = SQRT(max16) result3 = SQRT(result2) pwr1 = max27**(5./4.) d = result1*result3*pwr1 IF (vt2g - vt2i .GE. 0.) THEN abs5 = vt2g - vt2i ELSE abs5 = -(vt2g-vt2i) END IF pgaci1 = pgaci_a*abs5*(pgaci_b*b+pgaci_c*c+pgaci_d*d)*egi IF (pgaci1 .GT. qci(i, k, 2)/dtcld) THEN pgaci(i, k) = qci(i, k, 2)/dtcld ELSE pgaci(i, k) = pgaci1 END IF pgaci(i, k) = fsupcol*pgaci(i, k) IF (pgaci(i, k) .GE. 0.) THEN abs6 = pgaci(i, k) ELSE abs6 = -pgaci(i, k) END IF IF (abs6 .LT. qmin/dtcld) pgaci(i, k) = 0. IF (qci(i, k, 2) - pgaci(i, k)*dtcld .LT. 0.) THEN qci(i, k, 2) = 0. ELSE qci(i, k, 2) = qci(i, k, 2) - pgaci(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgaci(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = qrs(i, k, 3) + pgaci(i, k)*dtcld END IF pgaci(i, k) = 0. !------------------------------------------------------------- ! psacw: Accretion of cloud water by snow [LFO 24] ! (TG, and T>=T0: C->R) psacw:min=0,max=qci(i,k,1)/dtcld !------------------------------------------------------------- ! supcol = t0c-t(i,k) !not change ! call smoothif(supcol, 0.,fsupcol,'t0') !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0') !call smoothif(qci(i,k,1),qmin ,fqc,'q0') !update cpm ! cpm(i,k)=cpmcal(q(i,k)) !not change xl(i, k) = XLCAL(t(i, k)) xlf = xls - xl(i, k) IF (supcol .LT. 0.) xlf = xlf0 IF (qrs(i, k, 2) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN IF (90. .GT. t0c - t(i, k)) THEN y5 = t0c - t(i, k) ELSE y5 = 90. END IF IF (0. .LT. y5) THEN max17 = y5 ELSE max17 = 0. END IF arg1 = (1.-bvts)*alpha*max17/4. a = EXP(arg1) pwy1 = (1.+bvts)/4. pwr1 = den(i, k)**pwy1 pwy2 = (3.+bvts)/4. pwr2 = qrs(i, k, 2)**pwy2 psacw(i, k) = psacw_a*a*pwr1*pwr2*qci(i, k, 1) ELSE psacw(i, k) = 0. END IF IF (psacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN x6 = qci(i, k, 1)/dtcld ELSE x6 = psacw(i, k) END IF IF (x6 .LT. 0.) THEN psacw(i, k) = 0. ELSE psacw(i, k) = x6 END IF psacw(i, k) = fsupcol*psacw(i, k) IF (psacw(i, k) .GE. 0.) THEN abs7 = psacw(i, k) ELSE abs7 = -psacw(i, k) END IF IF (abs7 .LT. qmin/dtcld) psacw(i, k) = 0. IF (qci(i, k, 1) - psacw(i, k)*dtcld .LT. 0.) THEN qci(i, k, 1) = 0. ELSE qci(i, k, 1) = qci(i, k, 1) - psacw(i, k)*dtcld END IF x7 = qrs(i, k, 1) + (1.-fsupcol)*psacw(i, k)*dtcld IF (x7 .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = x7 END IF x8 = qrs(i, k, 3) + fsupcol*psacw(i, k)*dtcld IF (x8 .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = x8 END IF t(i, k) = t(i, k) + fsupcol*psacw(i, k)*dtcld*xlf/cpm(i, k) !t>=t0 pseml psacw(i, k) = (1-fsupcol)*psacw(i, k) !------------------------------------------------------------- ! pgacw: Accretion of cloud water by graupel [LFO 40] ! (TG, and T>=T0: C->R) pgacw:min=0.,max=qci(i,k,1)/dtcld !------------------------------------------------------------- supcol = t0c - t(i, k) CALL SMOOTHIF(supcol, 0., fsupcol, 't0') !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0') !call smoothif(qci(i,k,1),qmin ,fqc,'q0') ! cpm(i,k)=cpmcal(q(i,k)) !not change xl(i, k) = XLCAL(t(i, k)) xlf = xls - xl(i, k) IF (supcol .LT. 0.) xlf = xlf0 IF (qrs(i, k, 3) .GT. 0. .AND. qci(i, k, 1) .GT. 0.) THEN pwy1 = (1.+bvtg)/4. pwr1 = den(i, k)**pwy1 pwy2 = (3.+bvtg)/4. pwr2 = qrs(i, k, 3)**pwy2 pgacw(i, k) = pgacw_a*pwr1*pwr2*qci(i, k, 1) ELSE pgacw(i, k) = 0. END IF IF (pgacw(i, k) .GT. qci(i, k, 1)/dtcld) THEN x9 = qci(i, k, 1)/dtcld ELSE x9 = pgacw(i, k) END IF IF (x9 .LT. 0.) THEN pgacw(i, k) = 0. ELSE pgacw(i, k) = x9 END IF IF (pgacw(i, k) .GE. 0.) THEN abs8 = pgacw(i, k) ELSE abs8 = -pgacw(i, k) END IF !pgacw(i,k)=fqg*fqc*pgacw(i,k) IF (abs8 .LT. qmin/dtcld) pgacw(i, k) = 0. IF (qci(i, k, 1) - pgacw(i, k)*dtcld .LT. 0.) THEN qci(i, k, 1) = 0. ELSE qci(i, k, 1) = qci(i, k, 1) - pgacw(i, k)*dtcld END IF x10 = qrs(i, k, 1) + (1.-fsupcol)*pgacw(i, k)*dtcld IF (x10 .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = x10 END IF x11 = qrs(i, k, 3) + fsupcol*pgacw(i, k)*dtcld IF (x11 .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = x11 END IF t(i, k) = t(i, k) + fsupcol*pgacw(i, k)*dtcld*xlf/cpm(i, k) ! t>=t0 pgeml pgacw(i, k) = (1-fsupcol)*pgacw(i, k) END DO END DO END SUBROUTINE ACCRET1 ! Differentiation of accret2 in forward (tangent) mode (with options r8): ! variations of useful results: t psacr psacw pgacr pgacs pracs ! pgacw qrs pseml pgeml ! with respect to varying inputs: q t psacr psacw pgacr pgacs ! pracs pgacw den qrs pseml pgeml !======================================================================= ! !======================================================================= SUBROUTINE G_ACCRET2(qrs, g_qrs, t, g_t, q, g_q, den, g_den, dtcld, & & psacw, g_psacw, pgacw, g_pgacw, pracs, g_pracs, psacr, g_psacr, & & pgacr, g_pgacr, pgacs, g_pgacs, pseml, g_pseml, pgeml, g_pgeml, ims& & , ime, kms, kme, its, ite, kts, kte) IMPLICIT NONE INTEGER :: ims, ime, kms, kme, its, ite, kts, kte !------------------------------------------------------------------- REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs REAL, DIMENSION(ims:ime, kms:kme) :: den, q REAL, DIMENSION(ims:ime, kms:kme) :: g_den, g_q REAL, DIMENSION(its:ite, kts:kte) :: psacw, pgacw, pracs, psacr, & & pgacr, pgacs, pseml, pgeml, t, xl, cpm REAL, DIMENSION(its:ite, kts:kte) :: g_psacw, g_pgacw, g_pracs, & & g_psacr, g_pgacr, g_pgacs, g_pseml, g_pgeml, g_t, g_xl, g_cpm REAL :: supcol, vt2r, vt2s, vt2g, dtcld, xlf, egs REAL :: g_supcol, g_vt2r, g_vt2s, g_vt2g, g_xlf, g_egs REAL :: acrfac1, acrfac2, acrfac3, acrfac4, pracs1, psacr1, pgacr1, & & pgacs1 REAL :: g_pracs1, g_psacr1, g_pgacr1, g_pgacs1 INTEGER :: i, k REAL :: fsupcol, ft0, fqr, fqs, fqg, temp1, delta2, a, b, c, d REAL :: g_fsupcol, g_ft0, g_fqs, g_fqg, g_a, g_b, g_c, g_d INTRINSIC MAX INTRINSIC MIN INTRINSIC EXP INTRINSIC SQRT INTRINSIC ABS REAL :: y1 REAL :: g_y1 REAL :: y2 REAL :: g_y2 REAL :: y3 REAL :: g_y3 REAL :: y4 REAL :: g_y4 REAL :: y5 REAL :: g_y5 REAL :: y6 REAL :: g_y6 REAL :: y7 REAL :: g_y7 REAL :: y8 REAL :: g_y8 REAL :: x1 REAL :: g_x1 REAL :: x2 REAL :: g_x2 REAL :: x3 REAL :: g_x3 REAL :: x4 REAL :: g_x4 REAL :: y9 REAL :: g_y9 REAL :: y10 REAL :: g_y10 REAL :: y11 REAL :: g_y11 REAL :: y12 REAL :: g_y12 REAL :: x5 REAL :: g_x5 REAL :: x6 REAL :: g_x6 REAL :: y13 REAL :: g_y13 REAL :: y14 REAL :: g_y14 REAL :: y15 REAL :: g_y15 REAL :: x7 REAL :: g_x7 REAL :: x8 REAL :: g_x8 REAL :: max1 REAL :: g_max1 REAL :: max2 REAL :: g_max2 REAL :: max3 REAL :: g_max3 REAL :: max4 REAL :: g_max4 REAL :: max5 REAL :: g_max5 REAL :: max6 REAL :: g_max6 REAL :: abs0 REAL :: g_abs0 REAL :: abs1 REAL :: max7 REAL :: g_max7 REAL :: max8 REAL :: g_max8 REAL :: max9 REAL :: g_max9 REAL :: max10 REAL :: g_max10 REAL :: max11 REAL :: g_max11 REAL :: max12 REAL :: g_max12 REAL :: abs2 REAL :: g_abs2 REAL :: abs3 REAL :: max13 REAL :: g_max13 REAL :: max14 REAL :: g_max14 REAL :: max15 REAL :: g_max15 REAL :: max16 REAL :: g_max16 REAL :: max17 REAL :: g_max17 REAL :: abs4 REAL :: g_abs4 REAL :: abs5 REAL :: max18 REAL :: g_max18 REAL :: max19 REAL :: g_max19 REAL :: max20 REAL :: g_max20 REAL :: max21 REAL :: g_max21 REAL :: max22 REAL :: g_max22 REAL :: max23 REAL :: g_max23 REAL :: abs6 REAL :: g_abs6 REAL :: abs7 REAL :: abs8 REAL :: abs9 REAL :: max24 REAL :: g_max24 REAL :: max25 REAL :: g_max25 REAL :: max26 REAL :: g_max26 REAL :: max27 REAL :: g_max27 REAL :: max28 REAL :: g_max28 REAL :: max29 REAL :: g_max29 REAL :: max30 REAL :: g_max30 REAL :: max31 REAL :: g_max31 REAL :: max32 REAL :: g_max32 REAL :: max33 REAL :: g_max33 REAL :: max34 REAL :: g_max34 REAL :: max35 REAL :: g_max35 REAL :: max36 REAL :: g_max36 REAL :: max37 REAL :: g_max37 REAL :: max38 REAL :: g_max38 REAL :: max39 REAL :: g_max39 REAL :: max40 REAL :: g_max40 REAL :: max41 REAL :: g_max41 REAL :: max42 REAL :: g_max42 REAL :: max43 REAL :: g_max43 REAL :: max44 REAL :: g_max44 REAL :: max45 REAL :: g_max45 REAL :: max46 REAL :: g_max46 REAL :: max47 REAL :: g_max47 REAL :: pwy1 REAL :: pwr1 REAL :: g_pwr1 REAL :: pwy2 REAL :: pwr2 REAL :: g_pwr2 REAL :: arg1 REAL :: g_arg1 REAL :: result1 REAL :: g_result1 REAL :: result2 REAL :: g_result2 REAL :: temp REAL :: temp0 g_cpm = 0.0_8 g_xl = 0.0_8 DO k=kts,kte DO i=its,ite !------------------------------------------------------------- ! pracs: Accretion of snow by rain [LFO 27] ! (TG) pracs: min=0., max=qrs(i,k,2)/dtcld !------------------------------------------------------------- g_supcol = -g_t(i, k) supcol = t0c - t(i, k) CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0') IF (qrs(i, k, 1) .LT. qcrmin) THEN max1 = qcrmin g_max1 = 0.0_8 ELSE g_max1 = g_qrs(i, k, 1) max1 = qrs(i, k, 1) END IF !call smoothif(qrs(i,k,1),1.e-4,fqr,'q0') !call smoothif(qrs(i,k,2),1.e-4,fqs,'q0') pwy1 = (bvtr-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvtr/4. IF (max1 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max1**(pwy2-1)*g_max1 END IF pwr2 = max1**pwy2 g_vt2r = vt2r_a*(pwr2*g_pwr1+pwr1*g_pwr2) vt2r = vt2r_a*pwr1*pwr2 IF (qrs(i, k, 2) .LT. qcrmin) THEN max2 = qcrmin g_max2 = 0.0_8 ELSE g_max2 = g_qrs(i, k, 2) max2 = qrs(i, k, 2) END IF IF (90. .GT. t0c - t(i, k)) THEN g_y13 = -g_t(i, k) y13 = t0c - t(i, k) ELSE y13 = 90. g_y13 = 0.0_8 END IF IF (0. .LT. y13) THEN g_max24 = g_y13 max24 = y13 ELSE max24 = 0. g_max24 = 0.0_8 END IF pwy1 = (bvts-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvts/4. IF (max2 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max2**(pwy2-1)*g_max2 END IF pwr2 = max2**pwy2 g_arg1 = -(alpha*bvts*g_max24/4.) arg1 = -(alpha*bvts*max24/4.) temp = EXP(arg1) g_vt2s = vt2s_a*(temp*(pwr2*g_pwr1+pwr1*g_pwr2)+pwr1*pwr2*EXP(& & arg1)*g_arg1) vt2s = vt2s_a*(pwr1*pwr2*temp) IF (90. .GT. t0c - t(i, k)) THEN g_y1 = -g_t(i, k) y1 = t0c - t(i, k) ELSE y1 = 90. g_y1 = 0.0_8 END IF IF (0. .LT. y1) THEN g_max3 = g_y1 max3 = y1 ELSE max3 = 0. g_max3 = 0.0_8 END IF g_a = EXP(alpha*max3)*alpha*g_max3 a = EXP(alpha*max3) IF (90. .GT. t0c - t(i, k)) THEN g_y2 = -g_t(i, k) y2 = t0c - t(i, k) ELSE y2 = 90. g_y2 = 0.0_8 END IF IF (0. .LT. y2) THEN g_max4 = g_y2 max4 = y2 ELSE max4 = 0. g_max4 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max25 = qcrmin g_max25 = 0.0_8 ELSE g_max25 = g_qrs(i, k, 2) max25 = qrs(i, k, 2) END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max39 = qcrmin g_max39 = 0.0_8 ELSE g_max39 = g_qrs(i, k, 1) max39 = qrs(i, k, 1) END IF g_arg1 = -(alpha*3.*g_max4/2.) arg1 = -(3.*alpha*max4/2.) IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max25 .LE. 0.0_8 .AND. (3./2. .EQ. 0.0_8 .OR. 3./2. .NE. INT& & (3./2.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 3.*max25**(3./2.-1)*g_max25/2. END IF pwr2 = max25**(3./2.) temp = SQRT(max39) IF (max39 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_max39/(2.0*temp) END IF result1 = temp temp = SQRT(result1) IF (result1 .EQ. 0.0_8) THEN g_result2 = 0.0_8 ELSE g_result2 = g_result1/(2.0*temp) END IF result2 = temp temp = pwr1*pwr2*result2 temp0 = EXP(arg1) g_b = temp*EXP(arg1)*g_arg1 + temp0*(result2*(pwr2*g_pwr1+pwr1*& & g_pwr2)+pwr1*pwr2*g_result2) b = temp0*temp IF (90. .GT. t0c - t(i, k)) THEN g_y3 = -g_t(i, k) y3 = t0c - t(i, k) ELSE y3 = 90. g_y3 = 0.0_8 END IF IF (0. .LT. y3) THEN g_max5 = g_y3 max5 = y3 ELSE max5 = 0. g_max5 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max26 = qcrmin g_max26 = 0.0_8 ELSE g_max26 = g_qrs(i, k, 2) max26 = qrs(i, k, 2) END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max40 = qcrmin g_max40 = 0.0_8 ELSE g_max40 = g_qrs(i, k, 1) max40 = qrs(i, k, 1) END IF g_arg1 = -(alpha*5.*g_max5/4.) arg1 = -(5.*alpha*max5/4.) IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max26 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT& & (5./4.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 5.*max26**(5./4.-1)*g_max26/4. END IF pwr2 = max26**(5./4.) temp0 = SQRT(max40) IF (max40 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_max40/(2.0*temp0) END IF result1 = temp0 temp0 = pwr1*pwr2*result1 temp = EXP(arg1) g_c = temp0*EXP(arg1)*g_arg1 + temp*(result1*(pwr2*g_pwr1+pwr1*& & g_pwr2)+pwr1*pwr2*g_result1) c = temp*temp0 IF (90. .GT. t0c - t(i, k)) THEN g_y4 = -g_t(i, k) y4 = t0c - t(i, k) ELSE y4 = 90. g_y4 = 0.0_8 END IF IF (0. .LT. y4) THEN g_max6 = g_y4 max6 = y4 ELSE max6 = 0. g_max6 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max27 = qcrmin g_max27 = 0.0_8 ELSE g_max27 = g_qrs(i, k, 2) max27 = qrs(i, k, 2) END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max41 = qcrmin g_max41 = 0.0_8 ELSE g_max41 = g_qrs(i, k, 1) max41 = qrs(i, k, 1) END IF IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max41 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT& & (3./4.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 3.*max41**(3./4.-1)*g_max41/4. END IF pwr2 = max41**(3./4.) temp0 = pwr1*max27*pwr2 temp = EXP(-(alpha*max6)) g_d = temp*(pwr2*(max27*g_pwr1+pwr1*g_max27)+pwr1*max27*g_pwr2) & & - temp0*EXP(-(alpha*max6))*alpha*g_max6 d = temp*temp0 IF (vt2r - vt2s .GE. 0.) THEN g_abs0 = g_vt2r - g_vt2s abs0 = vt2r - vt2s ELSE g_abs0 = g_vt2s - g_vt2r abs0 = -(vt2r-vt2s) END IF temp0 = pracs_b*b + pracs_c*c + pracs_d*d g_pracs1 = pracs_a*(temp0*(abs0*g_a+a*g_abs0)+a*abs0*(pracs_b*& & g_b+pracs_c*g_c+pracs_d*g_d)) pracs1 = pracs_a*(a*abs0*temp0) IF (pracs1 .GT. qrs(i, k, 2)/dtcld) THEN g_pracs(i, k) = g_qrs(i, k, 2)/dtcld pracs(i, k) = qrs(i, k, 2)/dtcld ELSE g_pracs(i, k) = g_pracs1 pracs(i, k) = pracs1 END IF g_pracs(i, k) = pracs(i, k)*g_fsupcol + fsupcol*g_pracs(i, k) pracs(i, k) = fsupcol*pracs(i, k) IF (pracs(i, k) .GE. 0.) THEN abs1 = pracs(i, k) ELSE abs1 = -pracs(i, k) END IF IF (abs1 .LT. qmin/dtcld) THEN g_pracs(i, k) = 0.0_8 pracs(i, k) = 0. END IF IF (qrs(i, k, 2) - pracs(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_qrs(i, k, 2) - dtcld*g_pracs(i, k) qrs(i, k, 2) = qrs(i, k, 2) - pracs(i, k)*dtcld END IF IF (qrs(i, k, 3) + pracs(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pracs(i, k) qrs(i, k, 3) = qrs(i, k, 3) + pracs(i, k)*dtcld END IF g_pracs(i, k) = 0.0_8 pracs(i, k) = 0. !------------------------------------------------------------- ! psacr: Accretion of rain by snow [LFO 28] ! (T< T0: R->S or R->G) min=0.,max=qrs(i,k,1)/dtcld ! (T>=T0: S->R enhance melting of snow) min=0.,max=qrs(i,k,2)/dtcld !------------------------------------------------------------- ! supcol = t0c-t(i,k) !not change ! call smoothif(supcol,0.,fsupcol,'t0') !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0') !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0') !update cpm g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k)) g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_xlf = -g_xl(i, k) xlf = xls - xl(i, k) IF (supcol .LT. 0.) THEN xlf = xlf0 g_xlf = 0.0_8 END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max7 = qcrmin g_max7 = 0.0_8 ELSE g_max7 = g_qrs(i, k, 1) max7 = qrs(i, k, 1) END IF pwy1 = (bvtr-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvtr/4. IF (max7 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max7**(pwy2-1)*g_max7 END IF pwr2 = max7**pwy2 g_vt2r = vt2r_a*(pwr2*g_pwr1+pwr1*g_pwr2) vt2r = vt2r_a*pwr1*pwr2 IF (qrs(i, k, 2) .LT. qcrmin) THEN max8 = qcrmin g_max8 = 0.0_8 ELSE g_max8 = g_qrs(i, k, 2) max8 = qrs(i, k, 2) END IF IF (90. .GT. t0c - t(i, k)) THEN g_y14 = -g_t(i, k) y14 = t0c - t(i, k) ELSE y14 = 90. g_y14 = 0.0_8 END IF IF (0. .LT. y14) THEN g_max28 = g_y14 max28 = y14 ELSE max28 = 0. g_max28 = 0.0_8 END IF pwy1 = (bvts-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvts/4. IF (max8 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max8**(pwy2-1)*g_max8 END IF pwr2 = max8**pwy2 g_arg1 = -(alpha*bvts*g_max28/4.) arg1 = -(alpha*bvts*max28/4.) temp0 = EXP(arg1) g_vt2s = vt2s_a*(temp0*(pwr2*g_pwr1+pwr1*g_pwr2)+pwr1*pwr2*EXP(& & arg1)*g_arg1) vt2s = vt2s_a*(pwr1*pwr2*temp0) IF (90. .GT. t0c - t(i, k)) THEN g_y5 = -g_t(i, k) y5 = t0c - t(i, k) ELSE y5 = 90. g_y5 = 0.0_8 END IF IF (0. .LT. y5) THEN g_max9 = g_y5 max9 = y5 ELSE max9 = 0. g_max9 = 0.0_8 END IF g_a = EXP(alpha*max9)*alpha*g_max9 a = EXP(alpha*max9) IF (90. .GT. t0c - t(i, k)) THEN g_y6 = -g_t(i, k) y6 = t0c - t(i, k) ELSE y6 = 90. g_y6 = 0.0_8 END IF IF (0. .LT. y6) THEN g_max10 = g_y6 max10 = y6 ELSE max10 = 0. g_max10 = 0.0_8 END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max29 = qcrmin g_max29 = 0.0_8 ELSE g_max29 = g_qrs(i, k, 1) max29 = qrs(i, k, 1) END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max42 = qcrmin g_max42 = 0.0_8 ELSE g_max42 = g_qrs(i, k, 2) max42 = qrs(i, k, 2) END IF g_arg1 = -(alpha*g_max10/4.) arg1 = -(alpha*max10/4.) IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max29 .LE. 0.0_8 .AND. (3./2. .EQ. 0.0_8 .OR. 3./2. .NE. INT& & (3./2.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 3.*max29**(3./2.-1)*g_max29/2. END IF pwr2 = max29**(3./2.) temp0 = SQRT(max42) IF (max42 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_max42/(2.0*temp0) END IF result1 = temp0 temp0 = SQRT(result1) IF (result1 .EQ. 0.0_8) THEN g_result2 = 0.0_8 ELSE g_result2 = g_result1/(2.0*temp0) END IF result2 = temp0 temp0 = pwr1*pwr2*result2 temp = EXP(arg1) g_b = temp0*EXP(arg1)*g_arg1 + temp*(result2*(pwr2*g_pwr1+pwr1*& & g_pwr2)+pwr1*pwr2*g_result2) b = temp*temp0 IF (90. .GT. t0c - t(i, k)) THEN g_y7 = -g_t(i, k) y7 = t0c - t(i, k) ELSE y7 = 90. g_y7 = 0.0_8 END IF IF (0. .LT. y7) THEN g_max11 = g_y7 max11 = y7 ELSE max11 = 0. g_max11 = 0.0_8 END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max30 = qcrmin g_max30 = 0.0_8 ELSE g_max30 = g_qrs(i, k, 1) max30 = qrs(i, k, 1) END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max43 = qcrmin g_max43 = 0.0_8 ELSE g_max43 = g_qrs(i, k, 2) max43 = qrs(i, k, 2) END IF g_arg1 = -(alpha*g_max11/2.) arg1 = -(alpha*max11/2.) IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max30 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT& & (5./4.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 5.*max30**(5./4.-1)*g_max30/4. END IF pwr2 = max30**(5./4.) temp0 = SQRT(max43) IF (max43 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_max43/(2.0*temp0) END IF result1 = temp0 temp0 = pwr1*pwr2*result1 temp = EXP(arg1) g_c = temp0*EXP(arg1)*g_arg1 + temp*(result1*(pwr2*g_pwr1+pwr1*& & g_pwr2)+pwr1*pwr2*g_result1) c = temp*temp0 IF (90. .GT. t0c - t(i, k)) THEN g_y8 = -g_t(i, k) y8 = t0c - t(i, k) ELSE y8 = 90. g_y8 = 0.0_8 END IF IF (0. .LT. y8) THEN g_max12 = g_y8 max12 = y8 ELSE max12 = 0. g_max12 = 0.0_8 END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max31 = qcrmin g_max31 = 0.0_8 ELSE g_max31 = g_qrs(i, k, 1) max31 = qrs(i, k, 1) END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max44 = qcrmin g_max44 = 0.0_8 ELSE g_max44 = g_qrs(i, k, 2) max44 = qrs(i, k, 2) END IF g_arg1 = -(alpha*3.*g_max12/4.) arg1 = -(3.*alpha*max12/4.) IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max44 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT& & (3./4.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 3.*max44**(3./4.-1)*g_max44/4. END IF pwr2 = max44**(3./4.) temp0 = pwr1*max31*pwr2 temp = EXP(arg1) g_d = temp0*EXP(arg1)*g_arg1 + temp*(pwr2*(max31*g_pwr1+pwr1*& & g_max31)+pwr1*max31*g_pwr2) d = temp*temp0 IF (vt2r - vt2s .GE. 0.) THEN g_abs2 = g_vt2r - g_vt2s abs2 = vt2r - vt2s ELSE g_abs2 = g_vt2s - g_vt2r abs2 = -(vt2r-vt2s) END IF temp0 = psacr_b*b + psacr_c*c + psacr_d*d g_psacr1 = psacr_a*(temp0*(abs2*g_a+a*g_abs2)+a*abs2*(psacr_b*& & g_b+psacr_c*g_c+psacr_d*g_d)) psacr1 = psacr_a*(a*abs2*temp0) IF (supcol .GT. 0.) THEN IF (psacr1 .GT. qrs(i, k, 1)/dtcld) THEN g_psacr(i, k) = g_qrs(i, k, 1)/dtcld psacr(i, k) = qrs(i, k, 1)/dtcld ELSE g_psacr(i, k) = g_psacr1 psacr(i, k) = psacr1 END IF ELSE IF (psacr1 .GT. qrs(i, k, 2)/dtcld) THEN g_psacr(i, k) = g_qrs(i, k, 2)/dtcld psacr(i, k) = qrs(i, k, 2)/dtcld ELSE g_psacr(i, k) = g_psacr1 psacr(i, k) = psacr1 END IF IF (psacr(i, k) .GE. 0.) THEN abs3 = psacr(i, k) ELSE abs3 = -psacr(i, k) END IF !psacr(i,k)=fqr*fqs*psacr(i,k) IF (abs3 .LT. qmin/dtcld) THEN g_psacr(i, k) = 0.0_8 psacr(i, k) = 0. END IF !update qr qs qg IF (qrs(i, k, 1) .LT. 1.e-4 .AND. qrs(i, k, 2) .LT. 1.e-4) THEN delta2 = 1. ELSE delta2 = 0. END IF IF (qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_qrs(i, k, 1) - dtcld*(psacr(i, k)*g_fsupcol& & +fsupcol*g_psacr(i, k)) qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld END IF g_x1 = g_qrs(i, k, 2) + delta2*dtcld*(psacr(i, k)*g_fsupcol+& & fsupcol*g_psacr(i, k)) x1 = qrs(i, k, 2) + fsupcol*delta2*psacr(i, k)*dtcld IF (x1 .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_x1 qrs(i, k, 2) = x1 END IF g_x2 = g_qrs(i, k, 3) + (1-delta2)*dtcld*(psacr(i, k)*g_fsupcol+& & fsupcol*g_psacr(i, k)) x2 = qrs(i, k, 3) + fsupcol*(1-delta2)*psacr(i, k)*dtcld IF (x2 .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_x2 qrs(i, k, 3) = x2 END IF temp0 = psacr(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*(temp0*(xlf*g_fsupcol+fsupcol*& & g_xlf)+fsupcol*xlf*(g_psacr(i, k)-temp0*g_cpm(i, k))/cpm(i, k)& & ) t(i, k) = t(i, k) + dtcld*(fsupcol*xlf*temp0) ! t>=t0 pseml g_psacr(i, k) = (1-fsupcol)*g_psacr(i, k) - psacr(i, k)*& & g_fsupcol psacr(i, k) = (1-fsupcol)*psacr(i, k) !------------------------------------------------------------- ! pgacr: Accretion of rain by graupel [LFO 42] ! (T< T0: R->G) min=0.,max=qrs(i,k,1)/dtcld ! (T>=T0: G->R enhance melting of graupel) min=0.,max=qrs(i,k,3)/dtcld !------------------------------------------------------------- g_supcol = -g_t(i, k) supcol = t0c - t(i, k) CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't0') !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0') !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0') !update cpm ! cpm(i,k)=cpmcal(q(i,k)) !not change g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_xlf = -g_xl(i, k) xlf = xls - xl(i, k) IF (supcol .LT. 0.) THEN xlf = xlf0 g_xlf = 0.0_8 END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max13 = qcrmin g_max13 = 0.0_8 ELSE g_max13 = g_qrs(i, k, 1) max13 = qrs(i, k, 1) END IF pwy1 = (bvtr-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvtr/4. IF (max13 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max13**(pwy2-1)*g_max13 END IF pwr2 = max13**pwy2 g_vt2r = vt2r_a*(pwr2*g_pwr1+pwr1*g_pwr2) vt2r = vt2r_a*pwr1*pwr2 IF (qrs(i, k, 3) .LT. qcrmin) THEN max14 = qcrmin g_max14 = 0.0_8 ELSE g_max14 = g_qrs(i, k, 3) max14 = qrs(i, k, 3) END IF pwy1 = (bvtg-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvtg/4. IF (max14 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max14**(pwy2-1)*g_max14 END IF pwr2 = max14**pwy2 g_vt2g = vt2g_a*(pwr2*g_pwr1+pwr1*g_pwr2) vt2g = vt2g_a*pwr1*pwr2 IF (qrs(i, k, 1) .LT. qcrmin) THEN max15 = qcrmin g_max15 = 0.0_8 ELSE g_max15 = g_qrs(i, k, 1) max15 = qrs(i, k, 1) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max32 = qcrmin g_max32 = 0.0_8 ELSE g_max32 = g_qrs(i, k, 3) max32 = qrs(i, k, 3) END IF IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max15 .LE. 0.0_8 .AND. (3./2. .EQ. 0.0_8 .OR. 3./2. .NE. INT& & (3./2.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 3.*max15**(3./2.-1)*g_max15/2. END IF pwr2 = max15**(3./2.) temp0 = SQRT(max32) IF (max32 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_max32/(2.0*temp0) END IF result1 = temp0 temp0 = SQRT(result1) IF (result1 .EQ. 0.0_8) THEN g_result2 = 0.0_8 ELSE g_result2 = g_result1/(2.0*temp0) END IF result2 = temp0 g_b = result2*(pwr2*g_pwr1+pwr1*g_pwr2) + pwr1*pwr2*g_result2 b = pwr1*pwr2*result2 IF (qrs(i, k, 1) .LT. qcrmin) THEN max16 = qcrmin g_max16 = 0.0_8 ELSE g_max16 = g_qrs(i, k, 1) max16 = qrs(i, k, 1) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max33 = qcrmin g_max33 = 0.0_8 ELSE g_max33 = g_qrs(i, k, 3) max33 = qrs(i, k, 3) END IF IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max16 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT& & (5./4.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 5.*max16**(5./4.-1)*g_max16/4. END IF pwr2 = max16**(5./4.) temp0 = SQRT(max33) IF (max33 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_max33/(2.0*temp0) END IF result1 = temp0 g_c = result1*(pwr2*g_pwr1+pwr1*g_pwr2) + pwr1*pwr2*g_result1 c = pwr1*pwr2*result1 IF (qrs(i, k, 1) .LT. qcrmin) THEN max17 = qcrmin g_max17 = 0.0_8 ELSE g_max17 = g_qrs(i, k, 1) max17 = qrs(i, k, 1) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max34 = qcrmin g_max34 = 0.0_8 ELSE g_max34 = g_qrs(i, k, 3) max34 = qrs(i, k, 3) END IF IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max34 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT& & (3./4.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 3.*max34**(3./4.-1)*g_max34/4. END IF pwr2 = max34**(3./4.) g_d = pwr2*(max17*g_pwr1+pwr1*g_max17) + pwr1*max17*g_pwr2 d = pwr1*max17*pwr2 IF (vt2r - vt2g .GE. 0.) THEN g_abs4 = g_vt2r - g_vt2g abs4 = vt2r - vt2g ELSE g_abs4 = g_vt2g - g_vt2r abs4 = -(vt2r-vt2g) END IF temp0 = pgacr_b*b + pgacr_c*c + pgacr_d*d g_pgacr1 = pgacr_a*(temp0*g_abs4+abs4*(pgacr_b*g_b+pgacr_c*g_c+& & pgacr_d*g_d)) pgacr1 = pgacr_a*(abs4*temp0) IF (supcol .GT. 0.) THEN IF (pgacr1 .GT. qrs(i, k, 1)/dtcld) THEN g_pgacr(i, k) = g_qrs(i, k, 1)/dtcld pgacr(i, k) = qrs(i, k, 1)/dtcld ELSE g_pgacr(i, k) = g_pgacr1 pgacr(i, k) = pgacr1 END IF ELSE IF (pgacr1 .GT. qrs(i, k, 3)/dtcld) THEN g_pgacr(i, k) = g_qrs(i, k, 3)/dtcld pgacr(i, k) = qrs(i, k, 3)/dtcld ELSE g_pgacr(i, k) = g_pgacr1 pgacr(i, k) = pgacr1 END IF IF (pgacr(i, k) .GE. 0.) THEN abs5 = pgacr(i, k) ELSE abs5 = -pgacr(i, k) END IF !pgacr(i,k)=fqg*fqr*pgacr(i,k) IF (abs5 .LT. qmin/dtcld) THEN g_pgacr(i, k) = 0.0_8 pgacr(i, k) = 0. END IF IF (qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_qrs(i, k, 1) - dtcld*(pgacr(i, k)*g_fsupcol& & +fsupcol*g_pgacr(i, k)) qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld END IF g_x3 = g_qrs(i, k, 3) + dtcld*(pgacr(i, k)*g_fsupcol+fsupcol*& & g_pgacr(i, k)) x3 = qrs(i, k, 3) + fsupcol*pgacr(i, k)*dtcld IF (x3 .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_x3 qrs(i, k, 3) = x3 END IF temp0 = pgacr(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*(temp0*(xlf*g_fsupcol+fsupcol*& & g_xlf)+fsupcol*xlf*(g_pgacr(i, k)-temp0*g_cpm(i, k))/cpm(i, k)& & ) t(i, k) = t(i, k) + dtcld*(fsupcol*xlf*temp0) ! t>=t0 pgeml g_pgacr(i, k) = (1-fsupcol)*g_pgacr(i, k) - pgacr(i, k)*& & g_fsupcol pgacr(i, k) = (1-fsupcol)*pgacr(i, k) !------------------------------------------------------------- ! pgacs: Accretion of snow by graupel [LFO 29] ! (S->G) min=0,max=qrs(i,k,2)/dtcld !------------------------------------------------------------- g_supcol = -g_t(i, k) supcol = t0c - t(i, k) CALL SMOOTHIF(supcol, 0., fsupcol, 't0') g_x4 = -(EXP(-(0.09*supcol))*0.09*g_supcol) x4 = EXP(-(0.09*supcol)) IF (x4 .GT. 1.) THEN egs = 1. g_egs = 0.0_8 ELSE g_egs = g_x4 egs = x4 END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max18 = qcrmin g_max18 = 0.0_8 ELSE g_max18 = g_qrs(i, k, 3) max18 = qrs(i, k, 3) END IF pwy1 = (bvtg-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvtg/4. IF (max18 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max18**(pwy2-1)*g_max18 END IF pwr2 = max18**pwy2 g_vt2g = vt2g_a*(pwr2*g_pwr1+pwr1*g_pwr2) vt2g = vt2g_a*pwr1*pwr2 IF (qrs(i, k, 2) .LT. qcrmin) THEN max19 = qcrmin g_max19 = 0.0_8 ELSE g_max19 = g_qrs(i, k, 2) max19 = qrs(i, k, 2) END IF IF (90. .GT. t0c - t(i, k)) THEN g_y15 = -g_t(i, k) y15 = t0c - t(i, k) ELSE y15 = 90. g_y15 = 0.0_8 END IF IF (0. .LT. y15) THEN g_max35 = g_y15 max35 = y15 ELSE max35 = 0. g_max35 = 0.0_8 END IF pwy1 = (bvts-2.)/4. IF (den(i, k) .LE. 0.0_8 .AND. (pwy1 .EQ. 0.0_8 .OR. pwy1 .NE. & & INT(pwy1))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwy1*den(i, k)**(pwy1-1)*g_den(i, k) END IF pwr1 = den(i, k)**pwy1 pwy2 = bvts/4. IF (max19 .LE. 0.0_8 .AND. (pwy2 .EQ. 0.0_8 .OR. pwy2 .NE. INT(& & pwy2))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = pwy2*max19**(pwy2-1)*g_max19 END IF pwr2 = max19**pwy2 g_arg1 = -(alpha*bvts*g_max35/4.) arg1 = -(alpha*bvts*max35/4.) temp0 = EXP(arg1) g_vt2s = vt2s_a*(temp0*(pwr2*g_pwr1+pwr1*g_pwr2)+pwr1*pwr2*EXP(& & arg1)*g_arg1) vt2s = vt2s_a*(pwr1*pwr2*temp0) IF (90. .GT. t0c - t(i, k)) THEN g_y9 = -g_t(i, k) y9 = t0c - t(i, k) ELSE y9 = 90. g_y9 = 0.0_8 END IF IF (0. .LT. y9) THEN g_max20 = g_y9 max20 = y9 ELSE max20 = 0. g_max20 = 0.0_8 END IF g_a = EXP(alpha*max20)*alpha*g_max20 a = EXP(alpha*max20) IF (90. .GT. t0c - t(i, k)) THEN g_y10 = -g_t(i, k) y10 = t0c - t(i, k) ELSE y10 = 90. g_y10 = 0.0_8 END IF IF (0. .LT. y10) THEN g_max21 = g_y10 max21 = y10 ELSE max21 = 0. g_max21 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max36 = qcrmin g_max36 = 0.0_8 ELSE g_max36 = g_qrs(i, k, 2) max36 = qrs(i, k, 2) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max45 = qcrmin g_max45 = 0.0_8 ELSE g_max45 = g_qrs(i, k, 3) max45 = qrs(i, k, 3) END IF g_arg1 = -(alpha*3.*g_max21/2.) arg1 = -(3.*alpha*max21/2.) IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max36 .LE. 0.0_8 .AND. (3./2. .EQ. 0.0_8 .OR. 3./2. .NE. INT& & (3./2.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 3.*max36**(3./2.-1)*g_max36/2. END IF pwr2 = max36**(3./2.) temp0 = SQRT(max45) IF (max45 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_max45/(2.0*temp0) END IF result1 = temp0 temp0 = SQRT(result1) IF (result1 .EQ. 0.0_8) THEN g_result2 = 0.0_8 ELSE g_result2 = g_result1/(2.0*temp0) END IF result2 = temp0 temp0 = pwr1*pwr2*result2 temp = EXP(arg1) g_b = temp0*EXP(arg1)*g_arg1 + temp*(result2*(pwr2*g_pwr1+pwr1*& & g_pwr2)+pwr1*pwr2*g_result2) b = temp*temp0 IF (90. .GT. t0c - t(i, k)) THEN g_y11 = -g_t(i, k) y11 = t0c - t(i, k) ELSE y11 = 90. g_y11 = 0.0_8 END IF IF (0. .LT. y11) THEN g_max22 = g_y11 max22 = y11 ELSE max22 = 0. g_max22 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max37 = qcrmin g_max37 = 0.0_8 ELSE g_max37 = g_qrs(i, k, 2) max37 = qrs(i, k, 2) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max46 = qcrmin g_max46 = 0.0_8 ELSE g_max46 = g_qrs(i, k, 3) max46 = qrs(i, k, 3) END IF g_arg1 = -(alpha*5.*g_max22/4.) arg1 = -(5.*alpha*max22/4.) IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max37 .LE. 0.0_8 .AND. (5./4. .EQ. 0.0_8 .OR. 5./4. .NE. INT& & (5./4.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 5.*max37**(5./4.-1)*g_max37/4. END IF pwr2 = max37**(5./4.) temp0 = SQRT(max46) IF (max46 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_max46/(2.0*temp0) END IF result1 = temp0 temp0 = pwr1*pwr2*result1 temp = EXP(arg1) g_c = temp0*EXP(arg1)*g_arg1 + temp*(result1*(pwr2*g_pwr1+pwr1*& & g_pwr2)+pwr1*pwr2*g_result1) c = temp*temp0 IF (90. .GT. t0c - t(i, k)) THEN g_y12 = -g_t(i, k) y12 = t0c - t(i, k) ELSE y12 = 90. g_y12 = 0.0_8 END IF IF (0. .LT. y12) THEN g_max23 = g_y12 max23 = y12 ELSE max23 = 0. g_max23 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max38 = qcrmin g_max38 = 0.0_8 ELSE g_max38 = g_qrs(i, k, 2) max38 = qrs(i, k, 2) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max47 = qcrmin g_max47 = 0.0_8 ELSE g_max47 = g_qrs(i, k, 3) max47 = qrs(i, k, 3) END IF IF (den(i, k) .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE.& & INT(3./4.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 3.*den(i, k)**(3./4.-1)*g_den(i, k)/4. END IF pwr1 = den(i, k)**(3./4.) IF (max47 .LE. 0.0_8 .AND. (3./4. .EQ. 0.0_8 .OR. 3./4. .NE. INT& & (3./4.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 3.*max47**(3./4.-1)*g_max47/4. END IF pwr2 = max47**(3./4.) temp0 = pwr1*max38*pwr2 temp = EXP(-(alpha*max23)) g_d = temp*(pwr2*(max38*g_pwr1+pwr1*g_max38)+pwr1*max38*g_pwr2) & & - temp0*EXP(-(alpha*max23))*alpha*g_max23 d = temp*temp0 IF (vt2g - vt2s .GE. 0.) THEN g_abs6 = g_vt2g - g_vt2s abs6 = vt2g - vt2s ELSE g_abs6 = g_vt2s - g_vt2g abs6 = -(vt2g-vt2s) END IF temp0 = pgacs_b*b + pgacs_c*c + pgacs_d*d temp = a*abs6*egs g_pgacs1 = pgacs_a*(temp0*(egs*(abs6*g_a+a*g_abs6)+a*abs6*g_egs)& & +temp*(pgacs_b*g_b+pgacs_c*g_c+pgacs_d*g_d)) pgacs1 = pgacs_a*(temp*temp0) IF (pgacs1 .GT. qrs(i, k, 2)/dtcld) THEN g_pgacs(i, k) = g_qrs(i, k, 2)/dtcld pgacs(i, k) = qrs(i, k, 2)/dtcld ELSE g_pgacs(i, k) = g_pgacs1 pgacs(i, k) = pgacs1 END IF IF (pgacs(i, k) .GE. 0.) THEN abs7 = pgacs(i, k) ELSE abs7 = -pgacs(i, k) END IF !pgacs(i,k)=fqg*fqs*pgacs(i,k) IF (abs7 .LT. qmin/dtcld) THEN g_pgacs(i, k) = 0.0_8 pgacs(i, k) = 0. END IF IF (qrs(i, k, 2) - pgacs(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_qrs(i, k, 2) - dtcld*g_pgacs(i, k) qrs(i, k, 2) = qrs(i, k, 2) - pgacs(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgacs(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgacs(i, k) qrs(i, k, 3) = qrs(i, k, 3) + pgacs(i, k)*dtcld END IF g_pgacs(i, k) = 0.0_8 pgacs(i, k) = 0. !------------------------------------------------------------- ! pseml: Enhanced melting of snow by accretion of water ! (T>=T0: S->R) pseml<0 max=0,min=-qrs(i,k,2)/dtcld !------------------------------------------------------------- ! supcol = t0c-t(i,k) ! not change !update cpm ! cpm(i,k)=cpmcal(q(i,k)) ! not change g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_xlf = -g_xl(i, k) xlf = xls - xl(i, k) IF (supcol .LT. 0.) THEN xlf = xlf0 g_xlf = 0.0_8 END IF CALL G_SMOOTHIF(t(i, k), g_t(i, k), t0c, ft0, g_ft0, 't0') CALL G_SMOOTHIF(qrs(i, k, 2), g_qrs(i, k, 2), 0., fqs, g_fqs, & & 'q+') temp0 = supcol/xlf temp = psacw(i, k) + psacr(i, k) g_x7 = cliq*(temp0*(g_psacw(i, k)+g_psacr(i, k))+temp*(g_supcol-& & temp0*g_xlf)/xlf) x7 = cliq*(temp*temp0) IF (x7 .LT. -(qrs(i, k, 2)/dtcld)) THEN g_x5 = -(g_qrs(i, k, 2)/dtcld) x5 = -(qrs(i, k, 2)/dtcld) ELSE g_x5 = g_x7 x5 = x7 END IF IF (x5 .GT. 0.) THEN g_pseml(i, k) = 0.0_8 pseml(i, k) = 0. ELSE g_pseml(i, k) = g_x5 pseml(i, k) = x5 END IF g_pseml(i, k) = pseml(i, k)*(fqs*g_ft0+ft0*g_fqs) + ft0*fqs*& & g_pseml(i, k) pseml(i, k) = ft0*fqs*pseml(i, k) IF (pseml(i, k) .GE. 0.) THEN abs8 = pseml(i, k) ELSE abs8 = -pseml(i, k) END IF IF (abs8 .LT. qmin/dtcld) THEN g_pseml(i, k) = 0.0_8 pseml(i, k) = 0. END IF IF (qrs(i, k, 1) - pseml(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_qrs(i, k, 1) - dtcld*g_pseml(i, k) qrs(i, k, 1) = qrs(i, k, 1) - pseml(i, k)*dtcld END IF IF (qrs(i, k, 2) + pseml(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_qrs(i, k, 2) + dtcld*g_pseml(i, k) qrs(i, k, 2) = qrs(i, k, 2) + pseml(i, k)*dtcld END IF temp0 = pseml(i, k)*xlf/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*(xlf*g_pseml(i, k)+pseml(i, k)*& & g_xlf-temp0*g_cpm(i, k))/cpm(i, k) t(i, k) = t(i, k) + dtcld*temp0 g_pseml(i, k) = 0.0_8 pseml(i, k) = 0. g_psacw(i, k) = 0.0_8 psacw(i, k) = 0. g_psacr(i, k) = 0.0_8 psacr(i, k) = 0. !------------------------------------------------------------- ! pgeml: Enhanced melting of graupel by accretion of water [RH84 A21-A22] ! (T>=T0: G->R) pgeml<0 max=0,min=-qrs(i,k,3)/dtcld !------------------------------------------------------------- g_supcol = -g_t(i, k) supcol = t0c - t(i, k) !update cpm ! cpm(i,k)=cpmcal(q(i,k)) ! not change g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_xlf = -g_xl(i, k) xlf = xls - xl(i, k) IF (supcol .LT. 0.) THEN xlf = xlf0 g_xlf = 0.0_8 END IF CALL G_SMOOTHIF(t(i, k), g_t(i, k), t0c, ft0, g_ft0, 't0') CALL G_SMOOTHIF(qrs(i, k, 3), g_qrs(i, k, 3), 0., fqg, g_fqg, & & 'q+') temp0 = supcol/xlf temp = pgacw(i, k) + pgacr(i, k) g_x8 = cliq*(temp0*(g_pgacw(i, k)+g_pgacr(i, k))+temp*(g_supcol-& & temp0*g_xlf)/xlf) x8 = cliq*(temp*temp0) IF (x8 .LT. -(qrs(i, k, 3)/dtcld)) THEN g_x6 = -(g_qrs(i, k, 3)/dtcld) x6 = -(qrs(i, k, 3)/dtcld) ELSE g_x6 = g_x8 x6 = x8 END IF IF (x6 .GT. 0.) THEN g_pgeml(i, k) = 0.0_8 pgeml(i, k) = 0. ELSE g_pgeml(i, k) = g_x6 pgeml(i, k) = x6 END IF g_pgeml(i, k) = pgeml(i, k)*(fqg*g_ft0+ft0*g_fqg) + ft0*fqg*& & g_pgeml(i, k) pgeml(i, k) = ft0*fqg*pgeml(i, k) IF (pgeml(i, k) .GE. 0.) THEN abs9 = pgeml(i, k) ELSE abs9 = -pgeml(i, k) END IF IF (abs9 .LT. qmin/dtcld) THEN g_pgeml(i, k) = 0.0_8 pgeml(i, k) = 0. END IF IF (qrs(i, k, 1) - pgeml(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 1) = 0.0_8 qrs(i, k, 1) = 0. ELSE g_qrs(i, k, 1) = g_qrs(i, k, 1) - dtcld*g_pgeml(i, k) qrs(i, k, 1) = qrs(i, k, 1) - pgeml(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgeml(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgeml(i, k) qrs(i, k, 3) = qrs(i, k, 3) + pgeml(i, k)*dtcld END IF temp0 = pgeml(i, k)*xlf/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*(xlf*g_pgeml(i, k)+pgeml(i, k)*& & g_xlf-temp0*g_cpm(i, k))/cpm(i, k) t(i, k) = t(i, k) + dtcld*temp0 g_pgeml(i, k) = 0.0_8 pgeml(i, k) = 0. g_pgacw(i, k) = 0.0_8 pgacw(i, k) = 0. g_pgacr(i, k) = 0.0_8 pgacr(i, k) = 0. END DO END DO END SUBROUTINE G_ACCRET2 !======================================================================= ! !======================================================================= SUBROUTINE ACCRET2(qrs, t, q, den, dtcld, psacw, pgacw, pracs, psacr, & & pgacr, pgacs, pseml, pgeml, ims, ime, kms, kme, its, ite, kts, kte) IMPLICIT NONE INTEGER :: ims, ime, kms, kme, its, ite, kts, kte !------------------------------------------------------------------- REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs REAL, DIMENSION(ims:ime, kms:kme) :: den, q REAL, DIMENSION(its:ite, kts:kte) :: psacw, pgacw, pracs, psacr, & & pgacr, pgacs, pseml, pgeml, t, xl, cpm REAL :: supcol, vt2r, vt2s, vt2g, dtcld, xlf, egs REAL :: acrfac1, acrfac2, acrfac3, acrfac4, pracs1, psacr1, pgacr1, & & pgacs1 INTEGER :: i, k REAL :: fsupcol, ft0, fqr, fqs, fqg, temp1, delta2, a, b, c, d INTRINSIC MAX INTRINSIC MIN INTRINSIC EXP INTRINSIC SQRT INTRINSIC ABS REAL :: y1 REAL :: y2 REAL :: y3 REAL :: y4 REAL :: y5 REAL :: y6 REAL :: y7 REAL :: y8 REAL :: x1 REAL :: x2 REAL :: x3 REAL :: x4 REAL :: y9 REAL :: y10 REAL :: y11 REAL :: y12 REAL :: x5 REAL :: x6 REAL :: y13 REAL :: y14 REAL :: y15 REAL :: x7 REAL :: x8 REAL :: max1 REAL :: max2 REAL :: max3 REAL :: max4 REAL :: max5 REAL :: max6 REAL :: abs0 REAL :: abs1 REAL :: max7 REAL :: max8 REAL :: max9 REAL :: max10 REAL :: max11 REAL :: max12 REAL :: abs2 REAL :: abs3 REAL :: max13 REAL :: max14 REAL :: max15 REAL :: max16 REAL :: max17 REAL :: abs4 REAL :: abs5 REAL :: max18 REAL :: max19 REAL :: max20 REAL :: max21 REAL :: max22 REAL :: max23 REAL :: abs6 REAL :: abs7 REAL :: abs8 REAL :: abs9 REAL :: max24 REAL :: max25 REAL :: max26 REAL :: max27 REAL :: max28 REAL :: max29 REAL :: max30 REAL :: max31 REAL :: max32 REAL :: max33 REAL :: max34 REAL :: max35 REAL :: max36 REAL :: max37 REAL :: max38 REAL :: max39 REAL :: max40 REAL :: max41 REAL :: max42 REAL :: max43 REAL :: max44 REAL :: max45 REAL :: max46 REAL :: max47 REAL :: pwy1 REAL :: pwr1 REAL :: pwy2 REAL :: pwr2 REAL :: arg1 REAL :: result1 REAL :: result2 DO k=kts,kte DO i=its,ite !------------------------------------------------------------- ! pracs: Accretion of snow by rain [LFO 27] ! (TG) pracs: min=0., max=qrs(i,k,2)/dtcld !------------------------------------------------------------- supcol = t0c - t(i, k) CALL SMOOTHIF(supcol, 0., fsupcol, 't0') IF (qrs(i, k, 1) .LT. qcrmin) THEN max1 = qcrmin ELSE max1 = qrs(i, k, 1) END IF !call smoothif(qrs(i,k,1),1.e-4,fqr,'q0') !call smoothif(qrs(i,k,2),1.e-4,fqs,'q0') pwy1 = (bvtr-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvtr/4. pwr2 = max1**pwy2 vt2r = vt2r_a*pwr1*pwr2 IF (qrs(i, k, 2) .LT. qcrmin) THEN max2 = qcrmin ELSE max2 = qrs(i, k, 2) END IF IF (90. .GT. t0c - t(i, k)) THEN y13 = t0c - t(i, k) ELSE y13 = 90. END IF IF (0. .LT. y13) THEN max24 = y13 ELSE max24 = 0. END IF pwy1 = (bvts-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvts/4. pwr2 = max2**pwy2 arg1 = -(alpha*bvts*max24/4.) vt2s = vt2s_a*pwr1*pwr2*EXP(arg1) IF (90. .GT. t0c - t(i, k)) THEN y1 = t0c - t(i, k) ELSE y1 = 90. END IF IF (0. .LT. y1) THEN max3 = y1 ELSE max3 = 0. END IF a = EXP(alpha*max3) IF (90. .GT. t0c - t(i, k)) THEN y2 = t0c - t(i, k) ELSE y2 = 90. END IF IF (0. .LT. y2) THEN max4 = y2 ELSE max4 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max25 = qcrmin ELSE max25 = qrs(i, k, 2) END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max39 = qcrmin ELSE max39 = qrs(i, k, 1) END IF arg1 = -(3.*alpha*max4/2.) pwr1 = den(i, k)**(3./4.) pwr2 = max25**(3./2.) result1 = SQRT(max39) result2 = SQRT(result1) b = EXP(arg1)*pwr1*pwr2*result2 IF (90. .GT. t0c - t(i, k)) THEN y3 = t0c - t(i, k) ELSE y3 = 90. END IF IF (0. .LT. y3) THEN max5 = y3 ELSE max5 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max26 = qcrmin ELSE max26 = qrs(i, k, 2) END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max40 = qcrmin ELSE max40 = qrs(i, k, 1) END IF arg1 = -(5.*alpha*max5/4.) pwr1 = den(i, k)**(3./4.) pwr2 = max26**(5./4.) result1 = SQRT(max40) c = EXP(arg1)*pwr1*pwr2*result1 IF (90. .GT. t0c - t(i, k)) THEN y4 = t0c - t(i, k) ELSE y4 = 90. END IF IF (0. .LT. y4) THEN max6 = y4 ELSE max6 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max27 = qcrmin ELSE max27 = qrs(i, k, 2) END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max41 = qcrmin ELSE max41 = qrs(i, k, 1) END IF pwr1 = den(i, k)**(3./4.) pwr2 = max41**(3./4.) d = EXP(-(alpha*max6))*pwr1*max27*pwr2 IF (vt2r - vt2s .GE. 0.) THEN abs0 = vt2r - vt2s ELSE abs0 = -(vt2r-vt2s) END IF pracs1 = pracs_a*a*abs0*(pracs_b*b+pracs_c*c+pracs_d*d) IF (pracs1 .GT. qrs(i, k, 2)/dtcld) THEN pracs(i, k) = qrs(i, k, 2)/dtcld ELSE pracs(i, k) = pracs1 END IF pracs(i, k) = fsupcol*pracs(i, k) IF (pracs(i, k) .GE. 0.) THEN abs1 = pracs(i, k) ELSE abs1 = -pracs(i, k) END IF IF (abs1 .LT. qmin/dtcld) pracs(i, k) = 0. IF (qrs(i, k, 2) - pracs(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = qrs(i, k, 2) - pracs(i, k)*dtcld END IF IF (qrs(i, k, 3) + pracs(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = qrs(i, k, 3) + pracs(i, k)*dtcld END IF pracs(i, k) = 0. !------------------------------------------------------------- ! psacr: Accretion of rain by snow [LFO 28] ! (T< T0: R->S or R->G) min=0.,max=qrs(i,k,1)/dtcld ! (T>=T0: S->R enhance melting of snow) min=0.,max=qrs(i,k,2)/dtcld !------------------------------------------------------------- ! supcol = t0c-t(i,k) !not change ! call smoothif(supcol,0.,fsupcol,'t0') !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0') !call smoothif(qrs(i,k,2),qcrmin,fqs,'q0') !update cpm cpm(i, k) = CPMCAL(q(i, k)) xl(i, k) = XLCAL(t(i, k)) xlf = xls - xl(i, k) IF (supcol .LT. 0.) xlf = xlf0 IF (qrs(i, k, 1) .LT. qcrmin) THEN max7 = qcrmin ELSE max7 = qrs(i, k, 1) END IF pwy1 = (bvtr-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvtr/4. pwr2 = max7**pwy2 vt2r = vt2r_a*pwr1*pwr2 IF (qrs(i, k, 2) .LT. qcrmin) THEN max8 = qcrmin ELSE max8 = qrs(i, k, 2) END IF IF (90. .GT. t0c - t(i, k)) THEN y14 = t0c - t(i, k) ELSE y14 = 90. END IF IF (0. .LT. y14) THEN max28 = y14 ELSE max28 = 0. END IF pwy1 = (bvts-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvts/4. pwr2 = max8**pwy2 arg1 = -(alpha*bvts*max28/4.) vt2s = vt2s_a*pwr1*pwr2*EXP(arg1) IF (90. .GT. t0c - t(i, k)) THEN y5 = t0c - t(i, k) ELSE y5 = 90. END IF IF (0. .LT. y5) THEN max9 = y5 ELSE max9 = 0. END IF a = EXP(alpha*max9) IF (90. .GT. t0c - t(i, k)) THEN y6 = t0c - t(i, k) ELSE y6 = 90. END IF IF (0. .LT. y6) THEN max10 = y6 ELSE max10 = 0. END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max29 = qcrmin ELSE max29 = qrs(i, k, 1) END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max42 = qcrmin ELSE max42 = qrs(i, k, 2) END IF arg1 = -(alpha*max10/4.) pwr1 = den(i, k)**(3./4.) pwr2 = max29**(3./2.) result1 = SQRT(max42) result2 = SQRT(result1) b = EXP(arg1)*pwr1*pwr2*result2 IF (90. .GT. t0c - t(i, k)) THEN y7 = t0c - t(i, k) ELSE y7 = 90. END IF IF (0. .LT. y7) THEN max11 = y7 ELSE max11 = 0. END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max30 = qcrmin ELSE max30 = qrs(i, k, 1) END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max43 = qcrmin ELSE max43 = qrs(i, k, 2) END IF arg1 = -(alpha*max11/2.) pwr1 = den(i, k)**(3./4.) pwr2 = max30**(5./4.) result1 = SQRT(max43) c = EXP(arg1)*pwr1*pwr2*result1 IF (90. .GT. t0c - t(i, k)) THEN y8 = t0c - t(i, k) ELSE y8 = 90. END IF IF (0. .LT. y8) THEN max12 = y8 ELSE max12 = 0. END IF IF (qrs(i, k, 1) .LT. qcrmin) THEN max31 = qcrmin ELSE max31 = qrs(i, k, 1) END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max44 = qcrmin ELSE max44 = qrs(i, k, 2) END IF arg1 = -(3.*alpha*max12/4.) pwr1 = den(i, k)**(3./4.) pwr2 = max44**(3./4.) d = EXP(arg1)*pwr1*max31*pwr2 IF (vt2r - vt2s .GE. 0.) THEN abs2 = vt2r - vt2s ELSE abs2 = -(vt2r-vt2s) END IF psacr1 = psacr_a*a*abs2*(psacr_b*b+psacr_c*c+psacr_d*d) IF (supcol .GT. 0.) THEN IF (psacr1 .GT. qrs(i, k, 1)/dtcld) THEN psacr(i, k) = qrs(i, k, 1)/dtcld ELSE psacr(i, k) = psacr1 END IF ELSE IF (psacr1 .GT. qrs(i, k, 2)/dtcld) THEN psacr(i, k) = qrs(i, k, 2)/dtcld ELSE psacr(i, k) = psacr1 END IF IF (psacr(i, k) .GE. 0.) THEN abs3 = psacr(i, k) ELSE abs3 = -psacr(i, k) END IF !psacr(i,k)=fqr*fqs*psacr(i,k) IF (abs3 .LT. qmin/dtcld) psacr(i, k) = 0. !update qr qs qg IF (qrs(i, k, 1) .LT. 1.e-4 .AND. qrs(i, k, 2) .LT. 1.e-4) THEN delta2 = 1. ELSE delta2 = 0. END IF IF (qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*psacr(i, k)*dtcld END IF x1 = qrs(i, k, 2) + fsupcol*delta2*psacr(i, k)*dtcld IF (x1 .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = x1 END IF x2 = qrs(i, k, 3) + fsupcol*(1-delta2)*psacr(i, k)*dtcld IF (x2 .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = x2 END IF t(i, k) = t(i, k) + fsupcol*psacr(i, k)*dtcld*xlf/cpm(i, k) ! t>=t0 pseml psacr(i, k) = (1-fsupcol)*psacr(i, k) !------------------------------------------------------------- ! pgacr: Accretion of rain by graupel [LFO 42] ! (T< T0: R->G) min=0.,max=qrs(i,k,1)/dtcld ! (T>=T0: G->R enhance melting of graupel) min=0.,max=qrs(i,k,3)/dtcld !------------------------------------------------------------- supcol = t0c - t(i, k) CALL SMOOTHIF(supcol, 0., fsupcol, 't0') !call smoothif(qrs(i,k,3),qcrmin,fqg,'q0') !call smoothif(qrs(i,k,1),qcrmin,fqr,'q0') !update cpm ! cpm(i,k)=cpmcal(q(i,k)) !not change xl(i, k) = XLCAL(t(i, k)) xlf = xls - xl(i, k) IF (supcol .LT. 0.) xlf = xlf0 IF (qrs(i, k, 1) .LT. qcrmin) THEN max13 = qcrmin ELSE max13 = qrs(i, k, 1) END IF pwy1 = (bvtr-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvtr/4. pwr2 = max13**pwy2 vt2r = vt2r_a*pwr1*pwr2 IF (qrs(i, k, 3) .LT. qcrmin) THEN max14 = qcrmin ELSE max14 = qrs(i, k, 3) END IF pwy1 = (bvtg-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvtg/4. pwr2 = max14**pwy2 vt2g = vt2g_a*pwr1*pwr2 IF (qrs(i, k, 1) .LT. qcrmin) THEN max15 = qcrmin ELSE max15 = qrs(i, k, 1) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max32 = qcrmin ELSE max32 = qrs(i, k, 3) END IF pwr1 = den(i, k)**(3./4.) pwr2 = max15**(3./2.) result1 = SQRT(max32) result2 = SQRT(result1) b = pwr1*pwr2*result2 IF (qrs(i, k, 1) .LT. qcrmin) THEN max16 = qcrmin ELSE max16 = qrs(i, k, 1) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max33 = qcrmin ELSE max33 = qrs(i, k, 3) END IF pwr1 = den(i, k)**(3./4.) pwr2 = max16**(5./4.) result1 = SQRT(max33) c = pwr1*pwr2*result1 IF (qrs(i, k, 1) .LT. qcrmin) THEN max17 = qcrmin ELSE max17 = qrs(i, k, 1) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max34 = qcrmin ELSE max34 = qrs(i, k, 3) END IF pwr1 = den(i, k)**(3./4.) pwr2 = max34**(3./4.) d = pwr1*max17*pwr2 IF (vt2r - vt2g .GE. 0.) THEN abs4 = vt2r - vt2g ELSE abs4 = -(vt2r-vt2g) END IF pgacr1 = pgacr_a*abs4*(pgacr_b*b+pgacr_c*c+pgacr_d*d) IF (supcol .GT. 0.) THEN IF (pgacr1 .GT. qrs(i, k, 1)/dtcld) THEN pgacr(i, k) = qrs(i, k, 1)/dtcld ELSE pgacr(i, k) = pgacr1 END IF ELSE IF (pgacr1 .GT. qrs(i, k, 3)/dtcld) THEN pgacr(i, k) = qrs(i, k, 3)/dtcld ELSE pgacr(i, k) = pgacr1 END IF IF (pgacr(i, k) .GE. 0.) THEN abs5 = pgacr(i, k) ELSE abs5 = -pgacr(i, k) END IF !pgacr(i,k)=fqg*fqr*pgacr(i,k) IF (abs5 .LT. qmin/dtcld) pgacr(i, k) = 0. IF (qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) - fsupcol*pgacr(i, k)*dtcld END IF x3 = qrs(i, k, 3) + fsupcol*pgacr(i, k)*dtcld IF (x3 .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = x3 END IF t(i, k) = t(i, k) + fsupcol*pgacr(i, k)*dtcld*xlf/cpm(i, k) ! t>=t0 pgeml pgacr(i, k) = (1-fsupcol)*pgacr(i, k) !------------------------------------------------------------- ! pgacs: Accretion of snow by graupel [LFO 29] ! (S->G) min=0,max=qrs(i,k,2)/dtcld !------------------------------------------------------------- supcol = t0c - t(i, k) CALL SMOOTHIF(supcol, 0., fsupcol, 't0') x4 = EXP(-(0.09*supcol)) IF (x4 .GT. 1.) THEN egs = 1. ELSE egs = x4 END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max18 = qcrmin ELSE max18 = qrs(i, k, 3) END IF pwy1 = (bvtg-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvtg/4. pwr2 = max18**pwy2 vt2g = vt2g_a*pwr1*pwr2 IF (qrs(i, k, 2) .LT. qcrmin) THEN max19 = qcrmin ELSE max19 = qrs(i, k, 2) END IF IF (90. .GT. t0c - t(i, k)) THEN y15 = t0c - t(i, k) ELSE y15 = 90. END IF IF (0. .LT. y15) THEN max35 = y15 ELSE max35 = 0. END IF pwy1 = (bvts-2.)/4. pwr1 = den(i, k)**pwy1 pwy2 = bvts/4. pwr2 = max19**pwy2 arg1 = -(alpha*bvts*max35/4.) vt2s = vt2s_a*pwr1*pwr2*EXP(arg1) IF (90. .GT. t0c - t(i, k)) THEN y9 = t0c - t(i, k) ELSE y9 = 90. END IF IF (0. .LT. y9) THEN max20 = y9 ELSE max20 = 0. END IF a = EXP(alpha*max20) IF (90. .GT. t0c - t(i, k)) THEN y10 = t0c - t(i, k) ELSE y10 = 90. END IF IF (0. .LT. y10) THEN max21 = y10 ELSE max21 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max36 = qcrmin ELSE max36 = qrs(i, k, 2) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max45 = qcrmin ELSE max45 = qrs(i, k, 3) END IF arg1 = -(3.*alpha*max21/2.) pwr1 = den(i, k)**(3./4.) pwr2 = max36**(3./2.) result1 = SQRT(max45) result2 = SQRT(result1) b = EXP(arg1)*pwr1*pwr2*result2 IF (90. .GT. t0c - t(i, k)) THEN y11 = t0c - t(i, k) ELSE y11 = 90. END IF IF (0. .LT. y11) THEN max22 = y11 ELSE max22 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max37 = qcrmin ELSE max37 = qrs(i, k, 2) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max46 = qcrmin ELSE max46 = qrs(i, k, 3) END IF arg1 = -(5.*alpha*max22/4.) pwr1 = den(i, k)**(3./4.) pwr2 = max37**(5./4.) result1 = SQRT(max46) c = EXP(arg1)*pwr1*pwr2*result1 IF (90. .GT. t0c - t(i, k)) THEN y12 = t0c - t(i, k) ELSE y12 = 90. END IF IF (0. .LT. y12) THEN max23 = y12 ELSE max23 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max38 = qcrmin ELSE max38 = qrs(i, k, 2) END IF IF (qrs(i, k, 3) .LT. qcrmin) THEN max47 = qcrmin ELSE max47 = qrs(i, k, 3) END IF pwr1 = den(i, k)**(3./4.) pwr2 = max47**(3./4.) d = EXP(-(alpha*max23))*pwr1*max38*pwr2 IF (vt2g - vt2s .GE. 0.) THEN abs6 = vt2g - vt2s ELSE abs6 = -(vt2g-vt2s) END IF pgacs1 = pgacs_a*a*abs6*(pgacs_b*b+pgacs_c*c+pgacs_d*d)*egs IF (pgacs1 .GT. qrs(i, k, 2)/dtcld) THEN pgacs(i, k) = qrs(i, k, 2)/dtcld ELSE pgacs(i, k) = pgacs1 END IF IF (pgacs(i, k) .GE. 0.) THEN abs7 = pgacs(i, k) ELSE abs7 = -pgacs(i, k) END IF !pgacs(i,k)=fqg*fqs*pgacs(i,k) IF (abs7 .LT. qmin/dtcld) pgacs(i, k) = 0. IF (qrs(i, k, 2) - pgacs(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = qrs(i, k, 2) - pgacs(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgacs(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = qrs(i, k, 3) + pgacs(i, k)*dtcld END IF pgacs(i, k) = 0. !------------------------------------------------------------- ! pseml: Enhanced melting of snow by accretion of water ! (T>=T0: S->R) pseml<0 max=0,min=-qrs(i,k,2)/dtcld !------------------------------------------------------------- ! supcol = t0c-t(i,k) ! not change !update cpm ! cpm(i,k)=cpmcal(q(i,k)) ! not change xl(i, k) = XLCAL(t(i, k)) xlf = xls - xl(i, k) IF (supcol .LT. 0.) xlf = xlf0 CALL SMOOTHIF(t(i, k), t0c, ft0, 't0') CALL SMOOTHIF(qrs(i, k, 2), 0., fqs, 'q+') x7 = cliq*supcol*(psacw(i, k)+psacr(i, k))/xlf IF (x7 .LT. -(qrs(i, k, 2)/dtcld)) THEN x5 = -(qrs(i, k, 2)/dtcld) ELSE x5 = x7 END IF IF (x5 .GT. 0.) THEN pseml(i, k) = 0. ELSE pseml(i, k) = x5 END IF pseml(i, k) = ft0*fqs*pseml(i, k) IF (pseml(i, k) .GE. 0.) THEN abs8 = pseml(i, k) ELSE abs8 = -pseml(i, k) END IF IF (abs8 .LT. qmin/dtcld) pseml(i, k) = 0. IF (qrs(i, k, 1) - pseml(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) - pseml(i, k)*dtcld END IF IF (qrs(i, k, 2) + pseml(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = qrs(i, k, 2) + pseml(i, k)*dtcld END IF t(i, k) = t(i, k) + pseml(i, k)*dtcld*xlf/cpm(i, k) pseml(i, k) = 0. psacw(i, k) = 0. psacr(i, k) = 0. !------------------------------------------------------------- ! pgeml: Enhanced melting of graupel by accretion of water [RH84 A21-A22] ! (T>=T0: G->R) pgeml<0 max=0,min=-qrs(i,k,3)/dtcld !------------------------------------------------------------- supcol = t0c - t(i, k) !update cpm ! cpm(i,k)=cpmcal(q(i,k)) ! not change xl(i, k) = XLCAL(t(i, k)) xlf = xls - xl(i, k) IF (supcol .LT. 0.) xlf = xlf0 CALL SMOOTHIF(t(i, k), t0c, ft0, 't0') CALL SMOOTHIF(qrs(i, k, 3), 0., fqg, 'q+') x8 = cliq*supcol*(pgacw(i, k)+pgacr(i, k))/xlf IF (x8 .LT. -(qrs(i, k, 3)/dtcld)) THEN x6 = -(qrs(i, k, 3)/dtcld) ELSE x6 = x8 END IF IF (x6 .GT. 0.) THEN pgeml(i, k) = 0. ELSE pgeml(i, k) = x6 END IF pgeml(i, k) = ft0*fqg*pgeml(i, k) IF (pgeml(i, k) .GE. 0.) THEN abs9 = pgeml(i, k) ELSE abs9 = -pgeml(i, k) END IF IF (abs9 .LT. qmin/dtcld) pgeml(i, k) = 0. IF (qrs(i, k, 1) - pgeml(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 1) = 0. ELSE qrs(i, k, 1) = qrs(i, k, 1) - pgeml(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgeml(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = qrs(i, k, 3) + pgeml(i, k)*dtcld END IF t(i, k) = t(i, k) + pgeml(i, k)*dtcld*xlf/cpm(i, k) pgeml(i, k) = 0. pgacw(i, k) = 0. pgacr(i, k) = 0. END DO END DO END SUBROUTINE ACCRET2 ! Differentiation of accret3 in forward (tangent) mode (with options r8): ! variations of useful results: q t qs pigen rh qrs psevp pidep ! pgevp psdep qci pgdep psaut pgaut ! with respect to varying inputs: p q t qs pigen rh den qrs psevp ! pidep pgevp psdep qci pgdep psaut pgaut !======================================================================= ! !======================================================================= SUBROUTINE G_ACCRET3(qrs, g_qrs, qci, g_qci, rh, g_rh, t, g_t, p, g_p& & , den, g_den, dtcld, q, g_q, qs, g_qs, psdep, g_psdep, pgdep, & & g_pgdep, pigen, g_pigen, psaut, g_psaut, pgaut, g_pgaut, psevp, & & g_psevp, pgevp, g_pgevp, pidep, g_pidep, ims, ime, kms, kme, its, & & ite, kts, kte) IMPLICIT NONE INTEGER :: ims, ime, kms, kme, its, ite, kts, kte !------------------------------------------------------------------- REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci REAL, DIMENSION(ims:ime, kms:kme) :: den, q, p REAL, DIMENSION(ims:ime, kms:kme) :: g_den, g_q, g_p REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, rh, qs REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qrs, g_rh, g_qs REAL, DIMENSION(its:ite, kts:kte) :: pigen, psevp, pgevp, pidep, t, & & xl, cpm, psdep, pgdep, psaut, pgaut REAL, DIMENSION(its:ite, kts:kte) :: g_pigen, g_psevp, g_pgevp, & & g_pidep, g_t, g_xl, g_cpm, g_psdep, g_pgdep, g_psaut, g_pgaut REAL :: supcol, dtcld, satdt, supsat, qimax, diameter, xni0, roqi0, & & supice1, supice2, supice3, supice4, alpha2 REAL :: g_supcol, g_satdt, g_supsat, g_qimax, g_xni0, g_roqi0, & & g_alpha2 REAL :: pidep0, pidep1, psdep0, pgdep3, pigen0, psevp0, pgevp0, & & coeres1, coeres2, coeres3, coeres4 REAL :: g_pidep0, g_psdep0, g_pgdep3, g_pigen0, g_psevp0, g_pgevp0 REAL :: temp0, temp, xmi INTEGER :: i, k REAL :: fqi, fqr, fqv, fqs, fqg, frh, ft0, fpidep, fpsdep, fpgdep, & & fsupcol, fsupsat, pidep2 REAL :: g_ft0, g_fsupcol, g_fsupsat REAL :: value01, factor01, source01, vice, a, b, c, d, e, f, g REAL :: g_a, g_b, g_c, g_d, g_e INTRINSIC MAX INTRINSIC MIN INTRINSIC ABS INTRINSIC EXP INTRINSIC SQRT REAL :: x1 REAL :: g_x1 REAL :: x2 REAL :: g_x2 REAL :: y1 REAL :: g_y1 REAL :: y2 REAL :: g_y2 REAL :: x3 REAL :: g_x3 REAL :: x4 REAL :: g_x4 REAL :: x5 REAL :: g_x5 REAL :: x6 REAL :: g_x6 REAL :: x7 REAL :: g_x7 REAL :: x8 REAL :: g_x8 REAL :: y3 REAL :: g_y3 REAL :: y4 REAL :: g_y4 REAL :: x9 REAL :: g_x9 REAL :: x10 REAL :: g_x10 REAL :: abs0 REAL :: max1 REAL :: g_max1 REAL :: max2 REAL :: g_max2 REAL :: abs1 REAL :: max3 REAL :: g_max3 REAL :: max4 REAL :: g_max4 REAL :: abs2 REAL :: abs3 REAL :: abs4 REAL :: abs5 REAL :: max5 REAL :: g_max5 REAL :: max6 REAL :: g_max6 REAL :: abs6 REAL :: max7 REAL :: g_max7 REAL :: max8 REAL :: g_max8 REAL :: abs7 REAL :: max9 REAL :: g_max9 REAL :: max10 REAL :: g_max10 REAL :: max11 REAL :: g_max11 REAL :: max12 REAL :: g_max12 REAL :: max13 REAL :: g_max13 REAL :: pwx1 REAL :: g_pwx1 REAL :: pwr1 REAL :: g_pwr1 REAL :: arg1 REAL :: g_arg1 REAL :: arg2 REAL :: g_arg2 REAL :: result1 REAL :: g_result1 REAL :: pwr2 REAL :: g_pwr2 REAL :: pwr3 REAL :: g_pwr3 REAL :: pwy4 REAL :: pwr4 REAL :: g_pwr4 REAL :: pwy5 REAL :: pwr5 REAL :: g_pwr5 REAL :: temp1 REAL :: temp2 REAL :: temp3 REAL :: temp4 g_cpm = 0.0_8 g_xl = 0.0_8 DO k=kts,kte DO i=its,ite ! !------------------------------------------------------------- ! pidep: Deposition/Sublimation rate of ice [HDC 9] ! (TI or I->V) ! rh(i,k,2)>1.,pidep>0: V->I, min=0, max=satdt ! rh(i,k,2)<1.,pidep<0: I->V, min=-qi/dtcld,max=0, !------------------------------------------------------------- !update supcol g_supcol = -g_t(i, k) supcol = t0c - t(i, k) !update rh qs CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), & & g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs& & (i, k, :)) !update satdt g_supsat = g_q(i, k) - g_qs(i, k, 2) supsat = q(i, k) - qs(i, k, 2) g_satdt = g_supsat/dtcld satdt = supsat/dtcld !update xl, cpm g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k)) CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't+') IF (qci(i, k, 2) .GT. 0.) THEN temp1 = diffac_a*(xls*xls) temp2 = rv*t(i, k)**3.5 temp3 = den(i, k)*(t(i, k)+120.)/temp2 g_b = temp1*((t(i, k)+120.)*g_den(i, k)+(den(i, k)-temp3*rv*& & 3.5*t(i, k)**2.5)*g_t(i, k))/temp2 b = temp1*temp3 temp3 = t(i, k)**1.81 temp2 = temp3*qs(i, k, 2) temp1 = p(i, k)/temp2 g_c = diffac_b*(g_p(i, k)-temp1*(qs(i, k, 2)*1.81*t(i, k)**& & 0.81*g_t(i, k)+temp3*g_qs(i, k, 2)))/temp2 c = diffac_b*temp1 temp3 = (rh(i, k, 2)-1.)/(b+c) g_a = (g_rh(i, k, 2)-temp3*(g_b+g_c))/(b+c) a = temp3 g_pwx1 = qci(i, k, 2)*g_den(i, k) + den(i, k)*g_qci(i, k, 2) pwx1 = den(i, k)*qci(i, k, 2) IF (pwx1 .LE. 0.0_8 .AND. (7./8. .EQ. 0.0_8 .OR. 7./8. .NE. & & INT(7./8.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = 7.*pwx1**(7./8.-1)*g_pwx1/8. END IF pwr1 = pwx1**(7./8.) g_pidep0 = pidep_a*(pwr1*g_a+a*g_pwr1) pidep0 = pidep_a*a*pwr1 ELSE pidep0 = 0. g_pidep0 = 0.0_8 END IF IF (pidep0 .LT. 0.) THEN IF (pidep0 .LT. -(qci(i, k, 2)/dtcld)) THEN g_x1 = -(g_qci(i, k, 2)/dtcld) x1 = -(qci(i, k, 2)/dtcld) ELSE g_x1 = g_pidep0 x1 = pidep0 END IF IF (x1 .GT. 0.) THEN g_pidep(i, k) = 0.0_8 pidep(i, k) = 0. ELSE g_pidep(i, k) = g_x1 pidep(i, k) = x1 END IF ELSE IF (pidep0 .GT. satdt) THEN g_x2 = g_satdt x2 = satdt ELSE g_x2 = g_pidep0 x2 = pidep0 END IF IF (x2 .LT. 0.) THEN g_pidep(i, k) = 0.0_8 pidep(i, k) = 0. ELSE g_pidep(i, k) = g_x2 pidep(i, k) = x2 END IF END IF g_pidep(i, k) = pidep(i, k)*g_fsupcol + fsupcol*g_pidep(i, k) pidep(i, k) = fsupcol*pidep(i, k) IF (pidep(i, k) .GE. 0.) THEN abs0 = pidep(i, k) ELSE abs0 = -pidep(i, k) END IF IF (abs0 .LT. qmin/dtcld) THEN g_pidep(i, k) = 0.0_8 pidep(i, k) = 0. END IF IF (q(i, k) - pidep(i, k)*dtcld .LT. 0.) THEN g_q(i, k) = 0.0_8 q(i, k) = 0. ELSE g_q(i, k) = g_q(i, k) - dtcld*g_pidep(i, k) q(i, k) = q(i, k) - pidep(i, k)*dtcld END IF IF (qci(i, k, 2) + pidep(i, k)*dtcld .LT. 0.) THEN g_qci(i, k, 2) = 0.0_8 qci(i, k, 2) = 0. ELSE g_qci(i, k, 2) = g_qci(i, k, 2) + dtcld*g_pidep(i, k) qci(i, k, 2) = qci(i, k, 2) + pidep(i, k)*dtcld END IF temp3 = pidep(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*xls*(g_pidep(i, k)-temp3*g_cpm(i, & & k))/cpm(i, k) t(i, k) = t(i, k) + dtcld*xls*temp3 g_pidep(i, k) = 0.0_8 pidep(i, k) = 0. ! !------------------------------------------------------------- ! psdep: deposition/sublimation rate of snow [HDC 14] ! (TS or S->V) ! rh(i,k,2)>1.,psdep>0: V->S, min=0, max=satdt ! rh(i,k,2)<1.,psdep<0: S->V, min=-qs/dtcld,max=0, !------------------------------------------------------------- !update supcol g_supcol = -g_t(i, k) supcol = t0c - t(i, k) !update rh qs CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), & & g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs& & (i, k, :)) !update satdt g_supsat = g_q(i, k) - g_qs(i, k, 2) supsat = q(i, k) - qs(i, k, 2) g_satdt = g_supsat/dtcld satdt = supsat/dtcld !update xl, cpm g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k)) CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't+') IF (90. .GT. t0c - t(i, k)) THEN g_y1 = -g_t(i, k) y1 = t0c - t(i, k) ELSE y1 = 90. g_y1 = 0.0_8 END IF IF (0. .LT. y1) THEN g_max1 = g_y1 max1 = y1 ELSE max1 = 0. g_max1 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max9 = qcrmin g_max9 = 0.0_8 ELSE g_max9 = g_qrs(i, k, 2) max9 = qrs(i, k, 2) END IF ! call smoothif(qrs(i,k,2),0.,fqs,'q+') ! call smoothif(q (i,k ),0.,fqv,'q+') g_arg1 = alpha*g_max1/2. arg1 = alpha*max1/2. g_arg2 = max9*g_den(i, k) + den(i, k)*g_max9 arg2 = den(i, k)*max9 temp3 = SQRT(arg2) IF (arg2 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_arg2/(2.0*temp3) END IF result1 = temp3 temp3 = EXP(arg1) g_a = result1*EXP(arg1)*g_arg1 + temp3*g_result1 a = temp3*result1 IF (90. .GT. t0c - t(i, k)) THEN g_y2 = -g_t(i, k) y2 = t0c - t(i, k) ELSE y2 = 90. g_y2 = 0.0_8 END IF IF (0. .LT. y2) THEN g_max2 = g_y2 max2 = y2 ELSE max2 = 0. g_max2 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max10 = qcrmin g_max10 = 0.0_8 ELSE g_max10 = g_qrs(i, k, 2) max10 = qrs(i, k, 2) END IF g_arg1 = (3.-bvts)*alpha*g_max2/8. arg1 = (3.-bvts)*alpha*max2/8. g_pwx1 = g_t(i, k) pwx1 = t(i, k) + 120. IF (pwx1 .LE. 0.0_8 .AND. (1.0/6. .EQ. 0.0_8 .OR. 1.0/6. .NE. & & INT(1.0/6.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwx1**(1.0/6.-1)*g_pwx1/6. END IF pwr1 = pwx1**(1./6.) IF (t(i, k) .LE. 0.0_8 .AND. (5.12/6. .EQ. 0.0_8 .OR. 5.12/6. & & .NE. INT(5.12/6.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 5.12*t(i, k)**(5.12/6.-1)*g_t(i, k)/6. END IF pwr2 = t(i, k)**(5.12/6.) IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. .NE.& & INT(1.0/3.))) THEN g_pwr3 = 0.0_8 ELSE g_pwr3 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3. END IF pwr3 = p(i, k)**(1./3.) pwy4 = (13.+3.*bvts)/24. IF (den(i, k) .LE. 0.0_8 .AND. (pwy4 .EQ. 0.0_8 .OR. pwy4 .NE. & & INT(pwy4))) THEN g_pwr4 = 0.0_8 ELSE g_pwr4 = pwy4*den(i, k)**(pwy4-1)*g_den(i, k) END IF pwr4 = den(i, k)**pwy4 pwy5 = (5.+bvts)/8. IF (max10 .LE. 0.0_8 .AND. (pwy5 .EQ. 0.0_8 .OR. pwy5 .NE. INT(& & pwy5))) THEN g_pwr5 = 0.0_8 ELSE g_pwr5 = pwy5*max10**(pwy5-1)*g_max10 END IF pwr5 = max10**pwy5 temp3 = pwr1*pwr3/pwr2 temp2 = temp3*pwr4*pwr5 temp1 = EXP(arg1) g_b = temp2*EXP(arg1)*g_arg1 + temp1*(pwr4*pwr5*(pwr3*g_pwr1+& & pwr1*g_pwr3-temp3*g_pwr2)/pwr2+temp3*(pwr5*g_pwr4+pwr4*g_pwr5)& & ) b = temp1*temp2 temp3 = diffac_a*(xls*xls) temp2 = rv*t(i, k)**3.5 temp1 = den(i, k)*(t(i, k)+120.)/temp2 g_c = temp3*((t(i, k)+120.)*g_den(i, k)+(den(i, k)-temp1*rv*3.5*& & t(i, k)**2.5)*g_t(i, k))/temp2 c = temp3*temp1 temp3 = t(i, k)**1.81 temp2 = temp3*qs(i, k, 2) temp1 = p(i, k)/temp2 g_d = diffac_b*(g_p(i, k)-temp1*(qs(i, k, 2)*1.81*t(i, k)**0.81*& & g_t(i, k)+temp3*g_qs(i, k, 2)))/temp2 d = diffac_b*temp1 temp3 = (rh(i, k, 2)-1.)/(c+d) g_e = (g_rh(i, k, 2)-temp3*(g_c+g_d))/(c+d) e = temp3 temp3 = psdep_a*a + psdep_b*b g_psdep0 = temp3*g_e + e*(psdep_a*g_a+psdep_b*g_b) psdep0 = e*temp3 IF (psdep0 .LT. 0.) THEN IF (psdep0 .LT. -(qrs(i, k, 2)/dtcld)) THEN g_x3 = -(g_qrs(i, k, 2)/dtcld) x3 = -(qrs(i, k, 2)/dtcld) ELSE g_x3 = g_psdep0 x3 = psdep0 END IF IF (x3 .GT. 0.) THEN g_psdep(i, k) = 0.0_8 psdep(i, k) = 0. ELSE g_psdep(i, k) = g_x3 psdep(i, k) = x3 END IF ELSE IF (psdep0 .GT. satdt) THEN g_x4 = g_satdt x4 = satdt ELSE g_x4 = g_psdep0 x4 = psdep0 END IF IF (x4 .LT. 0.) THEN g_psdep(i, k) = 0.0_8 psdep(i, k) = 0. ELSE g_psdep(i, k) = g_x4 psdep(i, k) = x4 END IF END IF g_psdep(i, k) = psdep(i, k)*g_fsupcol + fsupcol*g_psdep(i, k) psdep(i, k) = fsupcol*psdep(i, k) IF (psdep(i, k) .GE. 0.) THEN abs1 = psdep(i, k) ELSE abs1 = -psdep(i, k) END IF IF (abs1 .LT. qmin/dtcld) THEN g_psdep(i, k) = 0.0_8 psdep(i, k) = 0. END IF IF (q(i, k) - psdep(i, k)*dtcld .LT. 0.) THEN g_q(i, k) = 0.0_8 q(i, k) = 0. ELSE g_q(i, k) = g_q(i, k) - dtcld*g_psdep(i, k) q(i, k) = q(i, k) - psdep(i, k)*dtcld END IF IF (qrs(i, k, 2) + psdep(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_qrs(i, k, 2) + dtcld*g_psdep(i, k) qrs(i, k, 2) = qrs(i, k, 2) + psdep(i, k)*dtcld END IF temp3 = psdep(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*xls*(g_psdep(i, k)-temp3*g_cpm(i, & & k))/cpm(i, k) t(i, k) = t(i, k) + dtcld*xls*temp3 g_psdep(i, k) = 0.0_8 psdep(i, k) = 0. ! !------------------------------------------------------------ ! pgdep: deposition/sublimation rate of graupel [LFO 46] ! (TG or G->V) ! rh(i,k,2)>1.,pgdep>0: V->G, min=0, max=satdt ! rh(i,k,2)<1.,pgdep<0: G->V, min=-qg/dtcld,max=0, !------------------------------------------------------------ !update supcol g_supcol = -g_t(i, k) supcol = t0c - t(i, k) !update rh qs CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), & & g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs& & (i, k, :)) !update satdt g_supsat = g_q(i, k) - g_qs(i, k, 2) supsat = q(i, k) - qs(i, k, 2) g_satdt = g_supsat/dtcld satdt = supsat/dtcld !update xl, cpm g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k)) CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't+') IF (qrs(i, k, 3) .LT. qcrmin) THEN max3 = qcrmin g_max3 = 0.0_8 ELSE g_max3 = g_qrs(i, k, 3) max3 = qrs(i, k, 3) END IF ! call smoothif(qrs(i,k,3),0.,fqg,'q+') ! call smoothif(q (i,k ),0.,fqv,'q+') temp3 = den(i, k)*max3 temp2 = SQRT(temp3) IF (temp3 .EQ. 0.0_8) THEN g_a = 0.0_8 ELSE g_a = (max3*g_den(i, k)+den(i, k)*g_max3)/(2.0*temp2) END IF a = temp2 IF (qrs(i, k, 3) .LT. qcrmin) THEN max4 = qcrmin g_max4 = 0.0_8 ELSE g_max4 = g_qrs(i, k, 3) max4 = qrs(i, k, 3) END IF g_pwx1 = g_t(i, k) pwx1 = t(i, k) + 120. IF (pwx1 .LE. 0.0_8 .AND. (1.0/6. .EQ. 0.0_8 .OR. 1.0/6. .NE. & & INT(1.0/6.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwx1**(1.0/6.-1)*g_pwx1/6. END IF pwr1 = pwx1**(1./6.) IF (t(i, k) .LE. 0.0_8 .AND. (5.12/6. .EQ. 0.0_8 .OR. 5.12/6. & & .NE. INT(5.12/6.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 5.12*t(i, k)**(5.12/6.-1)*g_t(i, k)/6. END IF pwr2 = t(i, k)**(5.12/6.) IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. .NE.& & INT(1.0/3.))) THEN g_pwr3 = 0.0_8 ELSE g_pwr3 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3. END IF pwr3 = p(i, k)**(1./3.) pwy4 = (13.+3.*bvtg)/24. IF (den(i, k) .LE. 0.0_8 .AND. (pwy4 .EQ. 0.0_8 .OR. pwy4 .NE. & & INT(pwy4))) THEN g_pwr4 = 0.0_8 ELSE g_pwr4 = pwy4*den(i, k)**(pwy4-1)*g_den(i, k) END IF pwr4 = den(i, k)**pwy4 pwy5 = (5.+bvtg)/8. IF (max4 .LE. 0.0_8 .AND. (pwy5 .EQ. 0.0_8 .OR. pwy5 .NE. INT(& & pwy5))) THEN g_pwr5 = 0.0_8 ELSE g_pwr5 = pwy5*max4**(pwy5-1)*g_max4 END IF pwr5 = max4**pwy5 temp3 = pwr1*pwr3/pwr2 g_b = pwr4*pwr5*(pwr3*g_pwr1+pwr1*g_pwr3-temp3*g_pwr2)/pwr2 + & & temp3*(pwr5*g_pwr4+pwr4*g_pwr5) b = temp3*(pwr4*pwr5) temp3 = diffac_a*(xls*xls) temp2 = rv*t(i, k)**3.5 temp1 = den(i, k)*(t(i, k)+120.)/temp2 g_c = temp3*((t(i, k)+120.)*g_den(i, k)+(den(i, k)-temp1*rv*3.5*& & t(i, k)**2.5)*g_t(i, k))/temp2 c = temp3*temp1 temp3 = t(i, k)**1.81 temp2 = temp3*qs(i, k, 2) temp1 = p(i, k)/temp2 g_d = diffac_b*(g_p(i, k)-temp1*(qs(i, k, 2)*1.81*t(i, k)**0.81*& & g_t(i, k)+temp3*g_qs(i, k, 2)))/temp2 d = diffac_b*temp1 temp3 = (rh(i, k, 2)-1.)/(c+d) g_e = (g_rh(i, k, 2)-temp3*(g_c+g_d))/(c+d) e = temp3 temp3 = pgdep_a*a + pgdep_b*b g_pgdep3 = temp3*g_e + e*(pgdep_a*g_a+pgdep_b*g_b) pgdep3 = e*temp3 IF (pgdep3 .LT. 0.) THEN IF (pgdep3 .LT. -(qrs(i, k, 3)/dtcld)) THEN g_x5 = -(g_qrs(i, k, 3)/dtcld) x5 = -(qrs(i, k, 3)/dtcld) ELSE g_x5 = g_pgdep3 x5 = pgdep3 END IF IF (x5 .GT. 0.) THEN g_pgdep(i, k) = 0.0_8 pgdep(i, k) = 0. ELSE g_pgdep(i, k) = g_x5 pgdep(i, k) = x5 END IF ELSE IF (pgdep3 .GT. satdt) THEN g_x6 = g_satdt x6 = satdt ELSE g_x6 = g_pgdep3 x6 = pgdep3 END IF IF (x6 .LT. 0.) THEN g_pgdep(i, k) = 0.0_8 pgdep(i, k) = 0. ELSE g_pgdep(i, k) = g_x6 pgdep(i, k) = x6 END IF END IF g_pgdep(i, k) = pgdep(i, k)*g_fsupcol + fsupcol*g_pgdep(i, k) pgdep(i, k) = fsupcol*pgdep(i, k) IF (pgdep(i, k) .GE. 0.) THEN abs2 = pgdep(i, k) ELSE abs2 = -pgdep(i, k) END IF IF (abs2 .LT. qmin/dtcld) THEN g_pgdep(i, k) = 0.0_8 pgdep(i, k) = 0. END IF IF (q(i, k) - pgdep(i, k)*dtcld .LT. 0.) THEN g_q(i, k) = 0.0_8 q(i, k) = 0. ELSE g_q(i, k) = g_q(i, k) - dtcld*g_pgdep(i, k) q(i, k) = q(i, k) - pgdep(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgdep(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgdep(i, k) qrs(i, k, 3) = qrs(i, k, 3) + pgdep(i, k)*dtcld END IF temp3 = pgdep(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*xls*(g_pgdep(i, k)-temp3*g_cpm(i, & & k))/cpm(i, k) t(i, k) = t(i, k) + dtcld*xls*temp3 g_pgdep(i, k) = 0.0_8 pgdep(i, k) = 0. !------------------------------------------------------------- ! pigen: generation(nucleation) of ice from vapor [HDC 7-8] ! (TI) min=0,max=min(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld,satdt) !------------------------------------------------------------- !update supcol g_supcol = -g_t(i, k) supcol = t0c - t(i, k) g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k)) !update rh qs CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), & & g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs& & (i, k, :)) !update satdt g_supsat = g_q(i, k) - g_qs(i, k, 2) supsat = q(i, k) - qs(i, k, 2) g_satdt = g_supsat/dtcld satdt = supsat/dtcld CALL G_SMOOTHIF(supsat, g_supsat, 0., fsupsat, g_fsupsat, 'q+') CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't+') g_xni0 = 1.e3*EXP(0.1*supcol)*0.1*g_supcol xni0 = 1.e3*EXP(0.1*supcol) g_roqi0 = 4.92e-11*1.33*xni0**0.33*g_xni0 roqi0 = 4.92e-11*xni0**1.33 IF (qci(i, k, 2) .LT. 0.) THEN max11 = 0. g_max11 = 0.0_8 ELSE g_max11 = g_qci(i, k, 2) max11 = qci(i, k, 2) END IF temp3 = roqi0/den(i, k) g_x7 = ((g_roqi0-temp3*g_den(i, k))/den(i, k)-g_max11)/dtcld x7 = (temp3-max11)/dtcld IF (x7 .GT. satdt) THEN g_pigen0 = g_satdt pigen0 = satdt ELSE g_pigen0 = g_x7 pigen0 = x7 END IF IF (pigen0 .LT. 0.) THEN g_pigen(i, k) = 0.0_8 pigen(i, k) = 0. ELSE g_pigen(i, k) = g_pigen0 pigen(i, k) = pigen0 END IF g_pigen(i, k) = pigen(i, k)*(fsupsat*g_fsupcol+fsupcol*g_fsupsat& & ) + fsupcol*fsupsat*g_pigen(i, k) pigen(i, k) = fsupcol*fsupsat*pigen(i, k) IF (pigen(i, k) .GE. 0.) THEN abs3 = pigen(i, k) ELSE abs3 = -pigen(i, k) END IF IF (abs3 .LT. qmin/dtcld) THEN g_pigen(i, k) = 0.0_8 pigen(i, k) = 0. END IF IF (q(i, k) - pigen(i, k)*dtcld .LT. 0.) THEN g_q(i, k) = 0.0_8 q(i, k) = 0. ELSE g_q(i, k) = g_q(i, k) - dtcld*g_pigen(i, k) q(i, k) = q(i, k) - pigen(i, k)*dtcld END IF IF (qci(i, k, 2) + pigen(i, k)*dtcld .LT. 0.) THEN g_qci(i, k, 2) = 0.0_8 qci(i, k, 2) = 0. ELSE g_qci(i, k, 2) = g_qci(i, k, 2) + dtcld*g_pigen(i, k) qci(i, k, 2) = qci(i, k, 2) + pigen(i, k)*dtcld END IF temp3 = pigen(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*xls*(g_pigen(i, k)-temp3*g_cpm(i, & & k))/cpm(i, k) t(i, k) = t(i, k) + dtcld*xls*temp3 g_pigen(i, k) = 0.0_8 pigen(i, k) = 0. ! !------------------------------------------------------------ ! psaut: conversion(aggregation) of ice to snow [HDC 12] ! (TS) psaut>0, min=0,max=(qci(i,k,2)-qimax)/dtcld !------------------------------------------------------------- !update supcol g_supcol = -g_t(i, k) supcol = t0c - t(i, k) CALL G_SMOOTHIF(supcol, g_supcol, 0., fsupcol, g_fsupcol, 't+') ! call smoothif(qci(i,k,2),0.,fqi,'q+') temp3 = roqimax/den(i, k) g_qimax = -(temp3*g_den(i, k)/den(i, k)) qimax = temp3 IF (0. .LT. (qci(i, k, 2)-qimax)/dtcld) THEN g_psaut(i, k) = (g_qci(i, k, 2)-g_qimax)/dtcld psaut(i, k) = (qci(i, k, 2)-qimax)/dtcld ELSE g_psaut(i, k) = 0.0_8 psaut(i, k) = 0. END IF g_psaut(i, k) = psaut(i, k)*g_fsupcol + fsupcol*g_psaut(i, k) psaut(i, k) = fsupcol*psaut(i, k) IF (psaut(i, k) .GE. 0.) THEN abs4 = psaut(i, k) ELSE abs4 = -psaut(i, k) END IF IF (abs4 .LT. qmin/dtcld) THEN g_psaut(i, k) = 0.0_8 psaut(i, k) = 0. END IF IF (qci(i, k, 2) - psaut(i, k)*dtcld .LT. 0.) THEN g_qci(i, k, 2) = 0.0_8 qci(i, k, 2) = 0. ELSE g_qci(i, k, 2) = g_qci(i, k, 2) - dtcld*g_psaut(i, k) qci(i, k, 2) = qci(i, k, 2) - psaut(i, k)*dtcld END IF IF (qrs(i, k, 2) + psaut(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_qrs(i, k, 2) + dtcld*g_psaut(i, k) qrs(i, k, 2) = qrs(i, k, 2) + psaut(i, k)*dtcld END IF g_psaut(i, k) = 0.0_8 psaut(i, k) = 0. ! !------------------------------------------------------------- ! pgaut: conversion(aggregation) of snow to graupel [LFO 37] ! (TG) pgaut>0 min=0.,max=qrs(i,k,2)/dtcld !------------------------------------------------------------- !update supcol ! supcol = t0c-t(i,k) ! not change ! call smoothif(supcol,0.,fsupcol,'t0') ! call smoothif(qrs(i,k,2),0.,fqs,'q+') g_alpha2 = -(1.e-3*EXP(-(0.09*supcol))*0.09*g_supcol) alpha2 = 1.e-3*EXP(0.09*(-supcol)) IF (0. .LT. alpha2*(qrs(i, k, 2)-qs0)) THEN g_x8 = (qrs(i, k, 2)-qs0)*g_alpha2 + alpha2*g_qrs(i, k, 2) x8 = alpha2*(qrs(i, k, 2)-qs0) ELSE x8 = 0. g_x8 = 0.0_8 END IF IF (x8 .GT. qrs(i, k, 2)/dtcld) THEN g_pgaut(i, k) = g_qrs(i, k, 2)/dtcld pgaut(i, k) = qrs(i, k, 2)/dtcld ELSE g_pgaut(i, k) = g_x8 pgaut(i, k) = x8 END IF g_pgaut(i, k) = pgaut(i, k)*g_fsupcol + fsupcol*g_pgaut(i, k) pgaut(i, k) = fsupcol*pgaut(i, k) IF (pgaut(i, k) .GE. 0.) THEN abs5 = pgaut(i, k) ELSE abs5 = -pgaut(i, k) END IF IF (abs5 .LT. qmin/dtcld) THEN g_pgaut(i, k) = 0.0_8 pgaut(i, k) = 0. END IF IF (qrs(i, k, 2) - pgaut(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_qrs(i, k, 2) - dtcld*g_pgaut(i, k) qrs(i, k, 2) = qrs(i, k, 2) - pgaut(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgaut(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgaut(i, k) qrs(i, k, 3) = qrs(i, k, 3) + pgaut(i, k)*dtcld END IF g_pgaut(i, k) = 0.0_8 pgaut(i, k) = 0. ! !------------------------------------------------------------- ! psevp: Evaporation of melting snow [RH83 A27] ! (T>=T0: S->V) rh<1., psevp<0, min=-qrs(i,k,2)/dtcld, max=0. !------------------------------------------------------------- ! supcol = t0c-t(i,k) ! not change !update rh qs CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), & & g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs& & (i, k, :)) !update xl, cpm g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k)) CALL G_SMOOTHIF(t(i, k), g_t(i, k), t0c, ft0, g_ft0, 't+') IF (90. .GT. t0c - t(i, k)) THEN g_y3 = -g_t(i, k) y3 = t0c - t(i, k) ELSE y3 = 90. g_y3 = 0.0_8 END IF IF (0. .LT. y3) THEN g_max5 = g_y3 max5 = y3 ELSE max5 = 0. g_max5 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max12 = qcrmin g_max12 = 0.0_8 ELSE g_max12 = g_qrs(i, k, 2) max12 = qrs(i, k, 2) END IF g_arg1 = alpha*g_max5/2. arg1 = alpha*max5/2. g_arg2 = max12*g_den(i, k) + den(i, k)*g_max12 arg2 = den(i, k)*max12 temp3 = SQRT(arg2) IF (arg2 .EQ. 0.0_8) THEN g_result1 = 0.0_8 ELSE g_result1 = g_arg2/(2.0*temp3) END IF result1 = temp3 temp3 = EXP(arg1) g_a = result1*EXP(arg1)*g_arg1 + temp3*g_result1 a = temp3*result1 IF (90. .GT. t0c - t(i, k)) THEN g_y4 = -g_t(i, k) y4 = t0c - t(i, k) ELSE y4 = 90. g_y4 = 0.0_8 END IF IF (0. .LT. y4) THEN g_max6 = g_y4 max6 = y4 ELSE max6 = 0. g_max6 = 0.0_8 END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max13 = qcrmin g_max13 = 0.0_8 ELSE g_max13 = g_qrs(i, k, 2) max13 = qrs(i, k, 2) END IF g_arg1 = (3.-bvts)*alpha*g_max6/8. arg1 = (3.-bvts)*alpha*max6/8. g_pwx1 = g_t(i, k) pwx1 = t(i, k) + 120. IF (pwx1 .LE. 0.0_8 .AND. (1.0/6. .EQ. 0.0_8 .OR. 1.0/6. .NE. & & INT(1.0/6.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwx1**(1.0/6.-1)*g_pwx1/6. END IF pwr1 = pwx1**(1./6.) IF (t(i, k) .LE. 0.0_8 .AND. (5.12/6. .EQ. 0.0_8 .OR. 5.12/6. & & .NE. INT(5.12/6.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 5.12*t(i, k)**(5.12/6.-1)*g_t(i, k)/6. END IF pwr2 = t(i, k)**(5.12/6.) IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. .NE.& & INT(1.0/3.))) THEN g_pwr3 = 0.0_8 ELSE g_pwr3 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3. END IF pwr3 = p(i, k)**(1./3.) pwy4 = (13.+3.*bvts)/24. IF (den(i, k) .LE. 0.0_8 .AND. (pwy4 .EQ. 0.0_8 .OR. pwy4 .NE. & & INT(pwy4))) THEN g_pwr4 = 0.0_8 ELSE g_pwr4 = pwy4*den(i, k)**(pwy4-1)*g_den(i, k) END IF pwr4 = den(i, k)**pwy4 pwy5 = (5.+bvts)/8. IF (max13 .LE. 0.0_8 .AND. (pwy5 .EQ. 0.0_8 .OR. pwy5 .NE. INT(& & pwy5))) THEN g_pwr5 = 0.0_8 ELSE g_pwr5 = pwy5*max13**(pwy5-1)*g_max13 END IF pwr5 = max13**pwy5 temp3 = pwr1*pwr3/pwr2 temp2 = temp3*pwr4*pwr5 temp1 = EXP(arg1) g_b = temp2*EXP(arg1)*g_arg1 + temp1*(pwr4*pwr5*(pwr3*g_pwr1+& & pwr1*g_pwr3-temp3*g_pwr2)/pwr2+temp3*(pwr5*g_pwr4+pwr4*g_pwr5)& & ) b = temp1*temp2 temp3 = rv*t(i, k)**3.5 temp2 = den(i, k)*(t(i, k)+120.) temp1 = xl(i, k)*xl(i, k) temp4 = temp1*temp2/temp3 g_c = diffac_a*(temp2*2*xl(i, k)*g_xl(i, k)+temp1*((t(i, k)+120.& & )*g_den(i, k)+den(i, k)*g_t(i, k))-temp4*rv*3.5*t(i, k)**2.5*& & g_t(i, k))/temp3 c = diffac_a*temp4 temp4 = t(i, k)**1.81 temp3 = temp4*qs(i, k, 1) temp2 = p(i, k)/temp3 g_d = diffac_b*(g_p(i, k)-temp2*(qs(i, k, 1)*1.81*t(i, k)**0.81*& & g_t(i, k)+temp4*g_qs(i, k, 1)))/temp3 d = diffac_b*temp2 temp4 = (rh(i, k, 1)-1.)/(c+d) g_e = (g_rh(i, k, 1)-temp4*(g_c+g_d))/(c+d) e = temp4 temp4 = psevp_a*a + psevp_b*b g_psevp0 = temp4*g_e + e*(psevp_a*g_a+psevp_b*g_b) psevp0 = e*temp4 IF (psevp0 .LT. -(qrs(i, k, 2)/dtcld)) THEN g_x9 = -(g_qrs(i, k, 2)/dtcld) x9 = -(qrs(i, k, 2)/dtcld) ELSE g_x9 = g_psevp0 x9 = psevp0 END IF IF (x9 .GT. 0.) THEN g_psevp(i, k) = 0.0_8 psevp(i, k) = 0. ELSE g_psevp(i, k) = g_x9 psevp(i, k) = x9 END IF g_psevp(i, k) = psevp(i, k)*g_ft0 + ft0*g_psevp(i, k) psevp(i, k) = ft0*psevp(i, k) IF (psevp(i, k) .GE. 0.) THEN abs6 = psevp(i, k) ELSE abs6 = -psevp(i, k) END IF IF (abs6 .LT. qmin/dtcld) THEN g_psevp(i, k) = 0.0_8 psevp(i, k) = 0. END IF IF (q(i, k) - psevp(i, k)*dtcld .LT. 0.) THEN g_q(i, k) = 0.0_8 q(i, k) = 0. ELSE g_q(i, k) = g_q(i, k) - dtcld*g_psevp(i, k) q(i, k) = q(i, k) - psevp(i, k)*dtcld END IF IF (qrs(i, k, 2) + psevp(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 2) = 0.0_8 qrs(i, k, 2) = 0. ELSE g_qrs(i, k, 2) = g_qrs(i, k, 2) + dtcld*g_psevp(i, k) qrs(i, k, 2) = qrs(i, k, 2) + psevp(i, k)*dtcld END IF temp4 = psevp(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*xls*(g_psevp(i, k)-temp4*g_cpm(i, & & k))/cpm(i, k) t(i, k) = t(i, k) + dtcld*xls*temp4 g_psevp(i, k) = 0.0_8 psevp(i, k) = 0. ! !------------------------------------------------------------- ! pgevp: Evaporation of melting graupel [RH84 A19] ! (T>=T0: G->V) rh<1., pgevp<0, min=-qrs(i,k,3)/dtcld, max=0. !------------------------------------------------------------- supcol = t0c - t(i, k) !update rh qs CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), & & g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs& & (i, k, :)) !update xl, cpm g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k)) CALL G_SMOOTHIF(t(i, k), g_t(i, k), t0c, ft0, g_ft0, 't0') IF (qrs(i, k, 3) .LT. qcrmin) THEN max7 = qcrmin g_max7 = 0.0_8 ELSE g_max7 = g_qrs(i, k, 3) max7 = qrs(i, k, 3) END IF temp4 = den(i, k)*max7 temp3 = SQRT(temp4) IF (temp4 .EQ. 0.0_8) THEN g_a = 0.0_8 ELSE g_a = (max7*g_den(i, k)+den(i, k)*g_max7)/(2.0*temp3) END IF a = temp3 IF (qrs(i, k, 3) .LT. qcrmin) THEN max8 = qcrmin g_max8 = 0.0_8 ELSE g_max8 = g_qrs(i, k, 3) max8 = qrs(i, k, 3) END IF g_pwx1 = g_t(i, k) pwx1 = t(i, k) + 120. IF (pwx1 .LE. 0.0_8 .AND. (1.0/6. .EQ. 0.0_8 .OR. 1.0/6. .NE. & & INT(1.0/6.))) THEN g_pwr1 = 0.0_8 ELSE g_pwr1 = pwx1**(1.0/6.-1)*g_pwx1/6. END IF pwr1 = pwx1**(1./6.) IF (t(i, k) .LE. 0.0_8 .AND. (5.12/6. .EQ. 0.0_8 .OR. 5.12/6. & & .NE. INT(5.12/6.))) THEN g_pwr2 = 0.0_8 ELSE g_pwr2 = 5.12*t(i, k)**(5.12/6.-1)*g_t(i, k)/6. END IF pwr2 = t(i, k)**(5.12/6.) IF (p(i, k) .LE. 0.0_8 .AND. (1.0/3. .EQ. 0.0_8 .OR. 1.0/3. .NE.& & INT(1.0/3.))) THEN g_pwr3 = 0.0_8 ELSE g_pwr3 = p(i, k)**(1.0/3.-1)*g_p(i, k)/3. END IF pwr3 = p(i, k)**(1./3.) pwy4 = (13.+3.*bvtg)/24. IF (den(i, k) .LE. 0.0_8 .AND. (pwy4 .EQ. 0.0_8 .OR. pwy4 .NE. & & INT(pwy4))) THEN g_pwr4 = 0.0_8 ELSE g_pwr4 = pwy4*den(i, k)**(pwy4-1)*g_den(i, k) END IF pwr4 = den(i, k)**pwy4 pwy5 = (5.+bvtg)/8. IF (max8 .LE. 0.0_8 .AND. (pwy5 .EQ. 0.0_8 .OR. pwy5 .NE. INT(& & pwy5))) THEN g_pwr5 = 0.0_8 ELSE g_pwr5 = pwy5*max8**(pwy5-1)*g_max8 END IF pwr5 = max8**pwy5 temp4 = pwr1*pwr3/pwr2 g_b = pwr4*pwr5*(pwr3*g_pwr1+pwr1*g_pwr3-temp4*g_pwr2)/pwr2 + & & temp4*(pwr5*g_pwr4+pwr4*g_pwr5) b = temp4*(pwr4*pwr5) temp4 = rv*t(i, k)**3.5 temp3 = den(i, k)*(t(i, k)+120.) temp2 = xl(i, k)*xl(i, k) temp1 = temp2*temp3/temp4 g_c = diffac_a*(temp3*2*xl(i, k)*g_xl(i, k)+temp2*((t(i, k)+120.& & )*g_den(i, k)+den(i, k)*g_t(i, k))-temp1*rv*3.5*t(i, k)**2.5*& & g_t(i, k))/temp4 c = diffac_a*temp1 temp4 = t(i, k)**1.81 temp3 = temp4*qs(i, k, 1) temp2 = p(i, k)/temp3 g_d = diffac_b*(g_p(i, k)-temp2*(qs(i, k, 1)*1.81*t(i, k)**0.81*& & g_t(i, k)+temp4*g_qs(i, k, 1)))/temp3 d = diffac_b*temp2 temp4 = (rh(i, k, 1)-1.)/(c+d) g_e = (g_rh(i, k, 1)-temp4*(g_c+g_d))/(c+d) e = temp4 temp4 = pgevp_a*a + pgevp_b*b g_pgevp0 = temp4*g_e + e*(pgevp_a*g_a+pgevp_b*g_b) pgevp0 = e*temp4 IF (pgevp0 .LT. -(qrs(i, k, 3)/dtcld)) THEN g_x10 = -(g_qrs(i, k, 3)/dtcld) x10 = -(qrs(i, k, 3)/dtcld) ELSE g_x10 = g_pgevp0 x10 = pgevp0 END IF IF (x10 .GT. 0.) THEN g_pgevp(i, k) = 0.0_8 pgevp(i, k) = 0. ELSE g_pgevp(i, k) = g_x10 pgevp(i, k) = x10 END IF g_pgevp(i, k) = pgevp(i, k)*g_ft0 + ft0*g_pgevp(i, k) pgevp(i, k) = ft0*pgevp(i, k) IF (pgevp(i, k) .GE. 0.) THEN abs7 = pgevp(i, k) ELSE abs7 = -pgevp(i, k) END IF IF (abs7 .LT. qmin/dtcld) THEN g_pgevp(i, k) = 0.0_8 pgevp(i, k) = 0. END IF IF (q(i, k) - pgevp(i, k)*dtcld .LT. 0.) THEN g_q(i, k) = 0.0_8 q(i, k) = 0. ELSE g_q(i, k) = g_q(i, k) - dtcld*g_pgevp(i, k) q(i, k) = q(i, k) - pgevp(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgevp(i, k)*dtcld .LT. 0.) THEN g_qrs(i, k, 3) = 0.0_8 qrs(i, k, 3) = 0. ELSE g_qrs(i, k, 3) = g_qrs(i, k, 3) + dtcld*g_pgevp(i, k) qrs(i, k, 3) = qrs(i, k, 3) + pgevp(i, k)*dtcld END IF temp4 = pgevp(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*xls*(g_pgevp(i, k)-temp4*g_cpm(i, & & k))/cpm(i, k) t(i, k) = t(i, k) + dtcld*xls*temp4 g_pgevp(i, k) = 0.0_8 pgevp(i, k) = 0. END DO END DO END SUBROUTINE G_ACCRET3 !======================================================================= ! !======================================================================= SUBROUTINE ACCRET3(qrs, qci, rh, t, p, den, dtcld, q, qs, psdep, pgdep& & , pigen, psaut, pgaut, psevp, pgevp, pidep, ims, ime, kms, kme, its& & , ite, kts, kte) IMPLICIT NONE INTEGER :: ims, ime, kms, kme, its, ite, kts, kte !------------------------------------------------------------------- REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(ims:ime, kms:kme) :: den, q, p REAL, DIMENSION(its:ite, kts:kte, 3) :: qrs, rh, qs REAL, DIMENSION(its:ite, kts:kte) :: pigen, psevp, pgevp, pidep, t, & & xl, cpm, psdep, pgdep, psaut, pgaut REAL :: supcol, dtcld, satdt, supsat, qimax, diameter, xni0, roqi0, & & supice1, supice2, supice3, supice4, alpha2 REAL :: pidep0, pidep1, psdep0, pgdep3, pigen0, psevp0, pgevp0, & & coeres1, coeres2, coeres3, coeres4 REAL :: temp0, temp, xmi INTEGER :: i, k REAL :: fqi, fqr, fqv, fqs, fqg, frh, ft0, fpidep, fpsdep, fpgdep, & & fsupcol, fsupsat, pidep2 REAL :: value01, factor01, source01, vice, a, b, c, d, e, f, g INTRINSIC MAX INTRINSIC MIN INTRINSIC ABS INTRINSIC EXP INTRINSIC SQRT REAL :: x1 REAL :: x2 REAL :: y1 REAL :: y2 REAL :: x3 REAL :: x4 REAL :: x5 REAL :: x6 REAL :: x7 REAL :: x8 REAL :: y3 REAL :: y4 REAL :: x9 REAL :: x10 REAL :: abs0 REAL :: max1 REAL :: max2 REAL :: abs1 REAL :: max3 REAL :: max4 REAL :: abs2 REAL :: abs3 REAL :: abs4 REAL :: abs5 REAL :: max5 REAL :: max6 REAL :: abs6 REAL :: max7 REAL :: max8 REAL :: abs7 REAL :: max9 REAL :: max10 REAL :: max11 REAL :: max12 REAL :: max13 REAL :: pwx1 REAL :: pwr1 REAL :: arg1 REAL :: arg2 REAL :: result1 REAL :: pwr2 REAL :: pwr3 REAL :: pwy4 REAL :: pwr4 REAL :: pwy5 REAL :: pwr5 DO k=kts,kte DO i=its,ite ! !------------------------------------------------------------- ! pidep: Deposition/Sublimation rate of ice [HDC 9] ! (TI or I->V) ! rh(i,k,2)>1.,pidep>0: V->I, min=0, max=satdt ! rh(i,k,2)<1.,pidep<0: I->V, min=-qi/dtcld,max=0, !------------------------------------------------------------- !update supcol supcol = t0c - t(i, k) !update rh qs CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :)) !update satdt supsat = q(i, k) - qs(i, k, 2) satdt = supsat/dtcld !update xl, cpm xl(i, k) = XLCAL(t(i, k)) cpm(i, k) = CPMCAL(q(i, k)) CALL SMOOTHIF(supcol, 0., fsupcol, 't+') IF (qci(i, k, 2) .GT. 0.) THEN b = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5 c = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2) a = (rh(i, k, 2)-1.)/(b+c) pwx1 = den(i, k)*qci(i, k, 2) pwr1 = pwx1**(7./8.) pidep0 = pidep_a*a*pwr1 ELSE pidep0 = 0. END IF IF (pidep0 .LT. 0.) THEN IF (pidep0 .LT. -(qci(i, k, 2)/dtcld)) THEN x1 = -(qci(i, k, 2)/dtcld) ELSE x1 = pidep0 END IF IF (x1 .GT. 0.) THEN pidep(i, k) = 0. ELSE pidep(i, k) = x1 END IF ELSE IF (pidep0 .GT. satdt) THEN x2 = satdt ELSE x2 = pidep0 END IF IF (x2 .LT. 0.) THEN pidep(i, k) = 0. ELSE pidep(i, k) = x2 END IF END IF pidep(i, k) = fsupcol*pidep(i, k) IF (pidep(i, k) .GE. 0.) THEN abs0 = pidep(i, k) ELSE abs0 = -pidep(i, k) END IF IF (abs0 .LT. qmin/dtcld) pidep(i, k) = 0. IF (q(i, k) - pidep(i, k)*dtcld .LT. 0.) THEN q(i, k) = 0. ELSE q(i, k) = q(i, k) - pidep(i, k)*dtcld END IF IF (qci(i, k, 2) + pidep(i, k)*dtcld .LT. 0.) THEN qci(i, k, 2) = 0. ELSE qci(i, k, 2) = qci(i, k, 2) + pidep(i, k)*dtcld END IF t(i, k) = t(i, k) + pidep(i, k)*dtcld*xls/cpm(i, k) pidep(i, k) = 0. ! !------------------------------------------------------------- ! psdep: deposition/sublimation rate of snow [HDC 14] ! (TS or S->V) ! rh(i,k,2)>1.,psdep>0: V->S, min=0, max=satdt ! rh(i,k,2)<1.,psdep<0: S->V, min=-qs/dtcld,max=0, !------------------------------------------------------------- !update supcol supcol = t0c - t(i, k) !update rh qs CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :)) !update satdt supsat = q(i, k) - qs(i, k, 2) satdt = supsat/dtcld !update xl, cpm xl(i, k) = XLCAL(t(i, k)) cpm(i, k) = CPMCAL(q(i, k)) CALL SMOOTHIF(supcol, 0., fsupcol, 't+') IF (90. .GT. t0c - t(i, k)) THEN y1 = t0c - t(i, k) ELSE y1 = 90. END IF IF (0. .LT. y1) THEN max1 = y1 ELSE max1 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max9 = qcrmin ELSE max9 = qrs(i, k, 2) END IF ! call smoothif(qrs(i,k,2),0.,fqs,'q+') ! call smoothif(q (i,k ),0.,fqv,'q+') arg1 = alpha*max1/2. arg2 = den(i, k)*max9 result1 = SQRT(arg2) a = EXP(arg1)*result1 IF (90. .GT. t0c - t(i, k)) THEN y2 = t0c - t(i, k) ELSE y2 = 90. END IF IF (0. .LT. y2) THEN max2 = y2 ELSE max2 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max10 = qcrmin ELSE max10 = qrs(i, k, 2) END IF arg1 = (3.-bvts)*alpha*max2/8. pwx1 = t(i, k) + 120. pwr1 = pwx1**(1./6.) pwr2 = t(i, k)**(5.12/6.) pwr3 = p(i, k)**(1./3.) pwy4 = (13.+3.*bvts)/24. pwr4 = den(i, k)**pwy4 pwy5 = (5.+bvts)/8. pwr5 = max10**pwy5 b = EXP(arg1)*pwr1/pwr2*pwr3*pwr4*pwr5 c = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5 d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2) e = (rh(i, k, 2)-1.)/(c+d) psdep0 = e*(psdep_a*a+psdep_b*b) IF (psdep0 .LT. 0.) THEN IF (psdep0 .LT. -(qrs(i, k, 2)/dtcld)) THEN x3 = -(qrs(i, k, 2)/dtcld) ELSE x3 = psdep0 END IF IF (x3 .GT. 0.) THEN psdep(i, k) = 0. ELSE psdep(i, k) = x3 END IF ELSE IF (psdep0 .GT. satdt) THEN x4 = satdt ELSE x4 = psdep0 END IF IF (x4 .LT. 0.) THEN psdep(i, k) = 0. ELSE psdep(i, k) = x4 END IF END IF psdep(i, k) = fsupcol*psdep(i, k) IF (psdep(i, k) .GE. 0.) THEN abs1 = psdep(i, k) ELSE abs1 = -psdep(i, k) END IF IF (abs1 .LT. qmin/dtcld) psdep(i, k) = 0. IF (q(i, k) - psdep(i, k)*dtcld .LT. 0.) THEN q(i, k) = 0. ELSE q(i, k) = q(i, k) - psdep(i, k)*dtcld END IF IF (qrs(i, k, 2) + psdep(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = qrs(i, k, 2) + psdep(i, k)*dtcld END IF t(i, k) = t(i, k) + psdep(i, k)*dtcld*xls/cpm(i, k) psdep(i, k) = 0. ! !------------------------------------------------------------ ! pgdep: deposition/sublimation rate of graupel [LFO 46] ! (TG or G->V) ! rh(i,k,2)>1.,pgdep>0: V->G, min=0, max=satdt ! rh(i,k,2)<1.,pgdep<0: G->V, min=-qg/dtcld,max=0, !------------------------------------------------------------ !update supcol supcol = t0c - t(i, k) !update rh qs CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :)) !update satdt supsat = q(i, k) - qs(i, k, 2) satdt = supsat/dtcld !update xl, cpm xl(i, k) = XLCAL(t(i, k)) cpm(i, k) = CPMCAL(q(i, k)) CALL SMOOTHIF(supcol, 0., fsupcol, 't+') IF (qrs(i, k, 3) .LT. qcrmin) THEN max3 = qcrmin ELSE max3 = qrs(i, k, 3) END IF ! call smoothif(qrs(i,k,3),0.,fqg,'q+') ! call smoothif(q (i,k ),0.,fqv,'q+') a = SQRT(den(i, k)*max3) IF (qrs(i, k, 3) .LT. qcrmin) THEN max4 = qcrmin ELSE max4 = qrs(i, k, 3) END IF pwx1 = t(i, k) + 120. pwr1 = pwx1**(1./6.) pwr2 = t(i, k)**(5.12/6.) pwr3 = p(i, k)**(1./3.) pwy4 = (13.+3.*bvtg)/24. pwr4 = den(i, k)**pwy4 pwy5 = (5.+bvtg)/8. pwr5 = max4**pwy5 b = pwr1/pwr2*pwr3*pwr4*pwr5 c = diffac_a*den(i, k)*xls*xls*(t(i, k)+120.)/rv/t(i, k)**3.5 d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 2) e = (rh(i, k, 2)-1.)/(c+d) pgdep3 = e*(pgdep_a*a+pgdep_b*b) IF (pgdep3 .LT. 0.) THEN IF (pgdep3 .LT. -(qrs(i, k, 3)/dtcld)) THEN x5 = -(qrs(i, k, 3)/dtcld) ELSE x5 = pgdep3 END IF IF (x5 .GT. 0.) THEN pgdep(i, k) = 0. ELSE pgdep(i, k) = x5 END IF ELSE IF (pgdep3 .GT. satdt) THEN x6 = satdt ELSE x6 = pgdep3 END IF IF (x6 .LT. 0.) THEN pgdep(i, k) = 0. ELSE pgdep(i, k) = x6 END IF END IF pgdep(i, k) = fsupcol*pgdep(i, k) IF (pgdep(i, k) .GE. 0.) THEN abs2 = pgdep(i, k) ELSE abs2 = -pgdep(i, k) END IF IF (abs2 .LT. qmin/dtcld) pgdep(i, k) = 0. IF (q(i, k) - pgdep(i, k)*dtcld .LT. 0.) THEN q(i, k) = 0. ELSE q(i, k) = q(i, k) - pgdep(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgdep(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = qrs(i, k, 3) + pgdep(i, k)*dtcld END IF t(i, k) = t(i, k) + pgdep(i, k)*dtcld*xls/cpm(i, k) pgdep(i, k) = 0. !------------------------------------------------------------- ! pigen: generation(nucleation) of ice from vapor [HDC 7-8] ! (TI) min=0,max=min(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld,satdt) !------------------------------------------------------------- !update supcol supcol = t0c - t(i, k) cpm(i, k) = CPMCAL(q(i, k)) !update rh qs CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :)) !update satdt supsat = q(i, k) - qs(i, k, 2) satdt = supsat/dtcld CALL SMOOTHIF(supsat, 0., fsupsat, 'q+') CALL SMOOTHIF(supcol, 0., fsupcol, 't+') xni0 = 1.e3*EXP(0.1*supcol) roqi0 = 4.92e-11*xni0**1.33 IF (qci(i, k, 2) .LT. 0.) THEN max11 = 0. ELSE max11 = qci(i, k, 2) END IF x7 = (roqi0/den(i, k)-max11)/dtcld IF (x7 .GT. satdt) THEN pigen0 = satdt ELSE pigen0 = x7 END IF IF (pigen0 .LT. 0.) THEN pigen(i, k) = 0. ELSE pigen(i, k) = pigen0 END IF pigen(i, k) = fsupcol*fsupsat*pigen(i, k) IF (pigen(i, k) .GE. 0.) THEN abs3 = pigen(i, k) ELSE abs3 = -pigen(i, k) END IF IF (abs3 .LT. qmin/dtcld) pigen(i, k) = 0. IF (q(i, k) - pigen(i, k)*dtcld .LT. 0.) THEN q(i, k) = 0. ELSE q(i, k) = q(i, k) - pigen(i, k)*dtcld END IF IF (qci(i, k, 2) + pigen(i, k)*dtcld .LT. 0.) THEN qci(i, k, 2) = 0. ELSE qci(i, k, 2) = qci(i, k, 2) + pigen(i, k)*dtcld END IF t(i, k) = t(i, k) + pigen(i, k)*dtcld*xls/cpm(i, k) pigen(i, k) = 0. ! !------------------------------------------------------------ ! psaut: conversion(aggregation) of ice to snow [HDC 12] ! (TS) psaut>0, min=0,max=(qci(i,k,2)-qimax)/dtcld !------------------------------------------------------------- !update supcol supcol = t0c - t(i, k) CALL SMOOTHIF(supcol, 0., fsupcol, 't+') ! call smoothif(qci(i,k,2),0.,fqi,'q+') qimax = roqimax/den(i, k) IF (0. .LT. (qci(i, k, 2)-qimax)/dtcld) THEN psaut(i, k) = (qci(i, k, 2)-qimax)/dtcld ELSE psaut(i, k) = 0. END IF psaut(i, k) = fsupcol*psaut(i, k) IF (psaut(i, k) .GE. 0.) THEN abs4 = psaut(i, k) ELSE abs4 = -psaut(i, k) END IF IF (abs4 .LT. qmin/dtcld) psaut(i, k) = 0. IF (qci(i, k, 2) - psaut(i, k)*dtcld .LT. 0.) THEN qci(i, k, 2) = 0. ELSE qci(i, k, 2) = qci(i, k, 2) - psaut(i, k)*dtcld END IF IF (qrs(i, k, 2) + psaut(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = qrs(i, k, 2) + psaut(i, k)*dtcld END IF psaut(i, k) = 0. ! !------------------------------------------------------------- ! pgaut: conversion(aggregation) of snow to graupel [LFO 37] ! (TG) pgaut>0 min=0.,max=qrs(i,k,2)/dtcld !------------------------------------------------------------- !update supcol ! supcol = t0c-t(i,k) ! not change ! call smoothif(supcol,0.,fsupcol,'t0') ! call smoothif(qrs(i,k,2),0.,fqs,'q+') alpha2 = 1.e-3*EXP(0.09*(-supcol)) IF (0. .LT. alpha2*(qrs(i, k, 2)-qs0)) THEN x8 = alpha2*(qrs(i, k, 2)-qs0) ELSE x8 = 0. END IF IF (x8 .GT. qrs(i, k, 2)/dtcld) THEN pgaut(i, k) = qrs(i, k, 2)/dtcld ELSE pgaut(i, k) = x8 END IF pgaut(i, k) = fsupcol*pgaut(i, k) IF (pgaut(i, k) .GE. 0.) THEN abs5 = pgaut(i, k) ELSE abs5 = -pgaut(i, k) END IF IF (abs5 .LT. qmin/dtcld) pgaut(i, k) = 0. IF (qrs(i, k, 2) - pgaut(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = qrs(i, k, 2) - pgaut(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgaut(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = qrs(i, k, 3) + pgaut(i, k)*dtcld END IF pgaut(i, k) = 0. ! !------------------------------------------------------------- ! psevp: Evaporation of melting snow [RH83 A27] ! (T>=T0: S->V) rh<1., psevp<0, min=-qrs(i,k,2)/dtcld, max=0. !------------------------------------------------------------- ! supcol = t0c-t(i,k) ! not change !update rh qs CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :)) !update xl, cpm xl(i, k) = XLCAL(t(i, k)) cpm(i, k) = CPMCAL(q(i, k)) CALL SMOOTHIF(t(i, k), t0c, ft0, 't+') IF (90. .GT. t0c - t(i, k)) THEN y3 = t0c - t(i, k) ELSE y3 = 90. END IF IF (0. .LT. y3) THEN max5 = y3 ELSE max5 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max12 = qcrmin ELSE max12 = qrs(i, k, 2) END IF arg1 = alpha*max5/2. arg2 = den(i, k)*max12 result1 = SQRT(arg2) a = EXP(arg1)*result1 IF (90. .GT. t0c - t(i, k)) THEN y4 = t0c - t(i, k) ELSE y4 = 90. END IF IF (0. .LT. y4) THEN max6 = y4 ELSE max6 = 0. END IF IF (qrs(i, k, 2) .LT. qcrmin) THEN max13 = qcrmin ELSE max13 = qrs(i, k, 2) END IF arg1 = (3.-bvts)*alpha*max6/8. pwx1 = t(i, k) + 120. pwr1 = pwx1**(1./6.) pwr2 = t(i, k)**(5.12/6.) pwr3 = p(i, k)**(1./3.) pwy4 = (13.+3.*bvts)/24. pwr4 = den(i, k)**pwy4 pwy5 = (5.+bvts)/8. pwr5 = max13**pwy5 b = EXP(arg1)*pwr1/pwr2*pwr3*pwr4*pwr5 c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, & & k)**3.5 d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1) e = (rh(i, k, 1)-1.)/(c+d) psevp0 = e*(psevp_a*a+psevp_b*b) IF (psevp0 .LT. -(qrs(i, k, 2)/dtcld)) THEN x9 = -(qrs(i, k, 2)/dtcld) ELSE x9 = psevp0 END IF IF (x9 .GT. 0.) THEN psevp(i, k) = 0. ELSE psevp(i, k) = x9 END IF psevp(i, k) = ft0*psevp(i, k) IF (psevp(i, k) .GE. 0.) THEN abs6 = psevp(i, k) ELSE abs6 = -psevp(i, k) END IF IF (abs6 .LT. qmin/dtcld) psevp(i, k) = 0. IF (q(i, k) - psevp(i, k)*dtcld .LT. 0.) THEN q(i, k) = 0. ELSE q(i, k) = q(i, k) - psevp(i, k)*dtcld END IF IF (qrs(i, k, 2) + psevp(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 2) = 0. ELSE qrs(i, k, 2) = qrs(i, k, 2) + psevp(i, k)*dtcld END IF t(i, k) = t(i, k) + psevp(i, k)*dtcld*xls/cpm(i, k) psevp(i, k) = 0. ! !------------------------------------------------------------- ! pgevp: Evaporation of melting graupel [RH84 A19] ! (T>=T0: G->V) rh<1., pgevp<0, min=-qrs(i,k,3)/dtcld, max=0. !------------------------------------------------------------- supcol = t0c - t(i, k) !update rh qs CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :)) !update xl, cpm xl(i, k) = XLCAL(t(i, k)) cpm(i, k) = CPMCAL(q(i, k)) CALL SMOOTHIF(t(i, k), t0c, ft0, 't0') IF (qrs(i, k, 3) .LT. qcrmin) THEN max7 = qcrmin ELSE max7 = qrs(i, k, 3) END IF a = SQRT(den(i, k)*max7) IF (qrs(i, k, 3) .LT. qcrmin) THEN max8 = qcrmin ELSE max8 = qrs(i, k, 3) END IF pwx1 = t(i, k) + 120. pwr1 = pwx1**(1./6.) pwr2 = t(i, k)**(5.12/6.) pwr3 = p(i, k)**(1./3.) pwy4 = (13.+3.*bvtg)/24. pwr4 = den(i, k)**pwy4 pwy5 = (5.+bvtg)/8. pwr5 = max8**pwy5 b = pwr1/pwr2*pwr3*pwr4*pwr5 c = diffac_a*den(i, k)*xl(i, k)*xl(i, k)*(t(i, k)+120.)/rv/t(i, & & k)**3.5 d = diffac_b*p(i, k)/t(i, k)**1.81/qs(i, k, 1) e = (rh(i, k, 1)-1.)/(c+d) pgevp0 = e*(pgevp_a*a+pgevp_b*b) IF (pgevp0 .LT. -(qrs(i, k, 3)/dtcld)) THEN x10 = -(qrs(i, k, 3)/dtcld) ELSE x10 = pgevp0 END IF IF (x10 .GT. 0.) THEN pgevp(i, k) = 0. ELSE pgevp(i, k) = x10 END IF pgevp(i, k) = ft0*pgevp(i, k) IF (pgevp(i, k) .GE. 0.) THEN abs7 = pgevp(i, k) ELSE abs7 = -pgevp(i, k) END IF IF (abs7 .LT. qmin/dtcld) pgevp(i, k) = 0. IF (q(i, k) - pgevp(i, k)*dtcld .LT. 0.) THEN q(i, k) = 0. ELSE q(i, k) = q(i, k) - pgevp(i, k)*dtcld END IF IF (qrs(i, k, 3) + pgevp(i, k)*dtcld .LT. 0.) THEN qrs(i, k, 3) = 0. ELSE qrs(i, k, 3) = qrs(i, k, 3) + pgevp(i, k)*dtcld END IF t(i, k) = t(i, k) + pgevp(i, k)*dtcld*xls/cpm(i, k) pgevp(i, k) = 0. END DO END DO END SUBROUTINE ACCRET3 ! Differentiation of pconadd in forward (tangent) mode (with options r8): ! variations of useful results: q t qs cpm xl qci ! with respect to varying inputs: p q t qs cpm xl qci !======================================================================= ! !======================================================================= SUBROUTINE G_PCONADD(t, g_t, p, g_p, q, g_q, qci, g_qci, qs, g_qs, xl& & , g_xl, cpm, g_cpm, dtcld, kte, kts, its, ite, kme, kms, ims, ime) IMPLICIT NONE INTEGER :: ims, ime, kms, kme, its, ite, kts, kte REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(its:ite, kts:kte, 2) :: g_qci REAL, DIMENSION(its:ite, kts:kte) :: t, xl, pcond, work2, cpm REAL, DIMENSION(its:ite, kts:kte) :: g_t, g_xl, g_pcond, g_cpm REAL, DIMENSION(its:ite, kts:kte, 3) :: qs, work1, rh REAL, DIMENSION(its:ite, kts:kte, 3) :: g_qs, g_work1, g_rh REAL, DIMENSION(ims:ime, kms:kme) :: q, p REAL, DIMENSION(ims:ime, kms:kme) :: g_q, g_p INTEGER :: k, i REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, & & dtcld, qs1, qs2, qs3, qs4, w1, q1 REAL :: tmp1, tmp2, f1, f2, qs0 INTRINSIC MAX INTRINSIC MIN INTRINSIC ABS REAL :: y1 REAL :: g_y1 REAL :: min1 REAL :: g_min1 REAL :: max1 REAL :: g_max1 REAL :: abs0 REAL :: temp g_work1 = 0.0_8 g_pcond = 0.0_8 DO k=kts,kte DO i=its,ite !update qs g_rh = 0.0_8 CALL G_CALCRH(t(i, k), g_t(i, k), p(i, k), g_p(i, k), q(i, k), & & g_q(i, k), rh(i, k, :), g_rh(i, k, :), qs(i, k, :), g_qs& & (i, k, :)) !update xl, cpm g_xl(i, k) = G_XLCAL(t(i, k), g_t(i, k), xl(i, k)) g_cpm(i, k) = G_CPMCAL(q(i, k), g_q(i, k), cpm(i, k)) !---------------------------------------------------------------- ! pcond: condensational/evaporational rate of cloud water [RH83 A6] ! if there exists additional water vapor condensated/if ! evaporation of cloud water is not enough to remove subsaturation !q>qs, work1>0, pcond>0 V->C min=0, max=q(i,k)/dtcld !qV min=-qci(i,k,1)/dtcld, max=0, g_work1(i, k, 1) = G_CONDEN(t(i, k), g_t(i, k), q(i, k), g_q(i, & & k), qs(i, k, 1), g_qs(i, k, 1), xl(i, k), g_xl(i, k), cpm(i, k& & ), g_cpm(i, k), work1(i, k, 1)) IF (work1(i, k, 1) .GT. 0.) THEN IF (q(i, k) .LT. 0.) THEN y1 = 0. g_y1 = 0.0_8 ELSE g_y1 = g_q(i, k) y1 = q(i, k) END IF IF (work1(i, k, 1) .GT. y1) THEN g_min1 = g_y1 min1 = y1 ELSE g_min1 = g_work1(i, k, 1) min1 = work1(i, k, 1) END IF g_pcond(i, k) = g_min1/dtcld pcond(i, k) = min1/dtcld ELSE IF (work1(i, k, 1) .LT. -qci(i, k, 1)) THEN g_max1 = -g_qci(i, k, 1) max1 = -qci(i, k, 1) ELSE g_max1 = g_work1(i, k, 1) max1 = work1(i, k, 1) END IF g_pcond(i, k) = g_max1/dtcld pcond(i, k) = max1/dtcld END IF IF (pcond(i, k) .GE. 0.) THEN abs0 = pcond(i, k) ELSE abs0 = -pcond(i, k) END IF IF (abs0 .LT. qmin/dtcld) THEN g_pcond(i, k) = 0.0_8 pcond(i, k) = 0. END IF IF (q(i, k) - pcond(i, k)*dtcld .LT. 0.) THEN g_q(i, k) = 0.0_8 q(i, k) = 0. ELSE g_q(i, k) = g_q(i, k) - dtcld*g_pcond(i, k) q(i, k) = q(i, k) - pcond(i, k)*dtcld END IF IF (qci(i, k, 1) + pcond(i, k)*dtcld .LT. 0.) THEN g_qci(i, k, 1) = 0.0_8 qci(i, k, 1) = 0. ELSE g_qci(i, k, 1) = g_qci(i, k, 1) + dtcld*g_pcond(i, k) qci(i, k, 1) = qci(i, k, 1) + pcond(i, k)*dtcld END IF temp = pcond(i, k)*xl(i, k)/cpm(i, k) g_t(i, k) = g_t(i, k) + dtcld*(xl(i, k)*g_pcond(i, k)+pcond(i, k& & )*g_xl(i, k)-temp*g_cpm(i, k))/cpm(i, k) t(i, k) = t(i, k) + dtcld*temp g_pcond(i, k) = 0.0_8 pcond(i, k) = 0. END DO END DO END SUBROUTINE G_PCONADD !======================================================================= ! !======================================================================= SUBROUTINE PCONADD(t, p, q, qci, qs, xl, cpm, dtcld, kte, kts, its, & & ite, kme, kms, ims, ime) IMPLICIT NONE INTEGER :: ims, ime, kms, kme, its, ite, kts, kte REAL, DIMENSION(its:ite, kts:kte, 2) :: qci REAL, DIMENSION(its:ite, kts:kte) :: t, xl, pcond, work2, cpm REAL, DIMENSION(its:ite, kts:kte, 3) :: qs, work1, rh REAL, DIMENSION(ims:ime, kms:kme) :: q, p INTEGER :: k, i REAL :: hsub, hvap, cvap, ttp, dldt, xa, xb, dldti, xai, xbi, tr, & & dtcld, qs1, qs2, qs3, qs4, w1, q1 REAL :: tmp1, tmp2, f1, f2, qs0 INTRINSIC MAX INTRINSIC MIN INTRINSIC ABS REAL :: y1 REAL :: min1 REAL :: max1 REAL :: abs0 DO k=kts,kte DO i=its,ite !update qs CALL CALCRH(t(i, k), p(i, k), q(i, k), rh(i, k, :), qs(i, k, :)) !update xl, cpm xl(i, k) = XLCAL(t(i, k)) cpm(i, k) = CPMCAL(q(i, k)) !---------------------------------------------------------------- ! pcond: condensational/evaporational rate of cloud water [RH83 A6] ! if there exists additional water vapor condensated/if ! evaporation of cloud water is not enough to remove subsaturation !q>qs, work1>0, pcond>0 V->C min=0, max=q(i,k)/dtcld !qV min=-qci(i,k,1)/dtcld, max=0, work1(i, k, 1) = CONDEN(t(i, k), q(i, k), qs(i, k, 1), xl(i, k)& & , cpm(i, k)) IF (work1(i, k, 1) .GT. 0.) THEN IF (q(i, k) .LT. 0.) THEN y1 = 0. ELSE y1 = q(i, k) END IF IF (work1(i, k, 1) .GT. y1) THEN min1 = y1 ELSE min1 = work1(i, k, 1) END IF pcond(i, k) = min1/dtcld ELSE IF (work1(i, k, 1) .LT. -qci(i, k, 1)) THEN max1 = -qci(i, k, 1) ELSE max1 = work1(i, k, 1) END IF pcond(i, k) = max1/dtcld END IF IF (pcond(i, k) .GE. 0.) THEN abs0 = pcond(i, k) ELSE abs0 = -pcond(i, k) END IF IF (abs0 .LT. qmin/dtcld) pcond(i, k) = 0. IF (q(i, k) - pcond(i, k)*dtcld .LT. 0.) THEN q(i, k) = 0. ELSE q(i, k) = q(i, k) - pcond(i, k)*dtcld END IF IF (qci(i, k, 1) + pcond(i, k)*dtcld .LT. 0.) THEN qci(i, k, 1) = 0. ELSE qci(i, k, 1) = qci(i, k, 1) + pcond(i, k)*dtcld END IF t(i, k) = t(i, k) + pcond(i, k)*dtcld*xl(i, k)/cpm(i, k) pcond(i, k) = 0. END DO END DO END SUBROUTINE PCONADD ! Differentiation of smoothif in forward (tangent) mode (with options r8): ! variations of useful results: f ! with respect to varying inputs: x !======================================================================= ! !======================================================================= SUBROUTINE G_SMOOTHIF(x, g_x, a, f, g_f, opt) IMPLICIT NONE REAL, INTENT(IN) :: x, a REAL, INTENT(IN) :: g_x CHARACTER(len=2), INTENT(IN) :: opt REAL, INTENT(OUT) :: f REAL, INTENT(OUT) :: g_f REAL(kind=8) :: k1, a1, x1, c1, f1, k, b REAL(kind=8) :: g_x1, g_f1, g_k INTRINSIC EXP INTRINSIC REAL REAL(kind=8) :: temp1, temp2 g_x1 = g_x x1 = x a1 = a IF (opt(1:1) .EQ. 'q') THEN c1 = 1.e-15 ELSE c1 = 1.e-9 END IF !f=1/(1+exp(-k*(x-b)) k1 = 747./c1 IF (opt(2:2) .EQ. '+') THEN b = a1 + 710./k1 ELSE b = a1 END IF g_k = -(k1*g_x1) k = -(k1*(x1-b)) temp1 = 1.0/(EXP(k)+1.) temp2 = 1.0/(EXP(-k)+1.) g_f1 = -(temp1*temp2*g_k) f1 = temp1 g_f = g_f1 !REAL(g_f1, 4) f = f1 !REAL(f1, 4) END SUBROUTINE G_SMOOTHIF !======================================================================= ! !======================================================================= SUBROUTINE SMOOTHIF(x, a, f, opt) IMPLICIT NONE REAL, INTENT(IN) :: x, a CHARACTER(len=2), INTENT(IN) :: opt REAL, INTENT(OUT) :: f REAL(kind=8) :: k1, a1, x1, c1, f1, k, b INTRINSIC EXP x1 = x a1 = a IF (opt(1:1) .EQ. 'q') THEN c1 = 1.e-15 ELSE c1 = 1.e-9 END IF k1 = 747./c1 IF (opt(2:2) .EQ. '+') THEN b = a1 + 710./k1 ELSE b = a1 END IF k = -(k1*(x1-b)) f1 = 1./(1.+EXP(k)) f = f1 END SUBROUTINE SMOOTHIF ! ! !======================================================================= ! !======================================================================= REAL FUNCTION RGMMA(x) IMPLICIT NONE !------------------------------------------------------------------- ! rgmma function: use infinite product form REAL :: euler PARAMETER (euler=0.577215664901532) REAL :: x, y INTEGER :: i INTRINSIC EXP INTRINSIC FLOAT IF (x .EQ. 1.) THEN rgmma = 0. ELSE rgmma = x*EXP(euler*x) DO i=1,10000 y = FLOAT(i) rgmma = rgmma*(1.000+x/y)*EXP(-(x/y)) END DO rgmma = 1./rgmma END IF END FUNCTION RGMMA ! Differentiation of cpmcal in forward (tangent) mode (with options r8): ! variations of useful results: cpmcal ! with respect to varying inputs: x ! ! !======================================================================= ! !======================================================================= ! compute internal functions FUNCTION G_CPMCAL(x, g_x, cpmcal) IMPLICIT NONE REAL :: cpmcal, x REAL :: g_cpmcal, g_x g_cpmcal = (cpv-cpd)*g_x cpmcal = cpd + x*(cpv-cpd) END FUNCTION G_CPMCAL ! ! !======================================================================= ! !======================================================================= ! compute internal functions FUNCTION CPMCAL(x) IMPLICIT NONE REAL :: cpmcal, x cpmcal = cpd + x*(cpv-cpd) END FUNCTION CPMCAL ! Differentiation of xlcal in forward (tangent) mode (with options r8): ! variations of useful results: xlcal ! with respect to varying inputs: x ! !======================================================================= ! !======================================================================= FUNCTION G_XLCAL(x, g_x, xlcal) IMPLICIT NONE REAL :: xlcal, x REAL :: g_xlcal, g_x g_xlcal = -(xlv1*g_x) xlcal = xlv0 - xlv1*(x-t0c) END FUNCTION G_XLCAL ! !======================================================================= ! !======================================================================= FUNCTION XLCAL(x) IMPLICIT NONE REAL :: xlcal, x xlcal = xlv0 - xlv1*(x-t0c) END FUNCTION XLCAL ! Differentiation of conden in forward (tangent) mode (with options r8): ! variations of useful results: conden ! with respect to varying inputs: d e a b c !======================================================================= ! a:t, b:q, c:qs, d:xl, e:cpm !======================================================================= FUNCTION G_CONDEN(a, g_a, b, g_b, c, g_c, d, g_d, e, g_e, conden) IMPLICIT NONE REAL :: conden, a, b, c, d, e REAL :: g_conden, g_a, g_b, g_c, g_d, g_e REAL :: f REAL :: temp REAL :: temp0 REAL :: temp1 temp = rv*e*(a*a) temp0 = d*d*c/temp temp1 = (b-c)/(temp0+1.) g_conden = (g_b-g_c-temp1*(c*2*d*g_d+d**2*g_c-temp0*(a**2*rv*g_e+rv*& & e*2*a*g_a))/temp)/(temp0+1.) conden = temp1 END FUNCTION G_CONDEN !======================================================================= ! a:t, b:q, c:qs, d:xl, e:cpm !======================================================================= FUNCTION CONDEN(a, b, c, d, e) IMPLICIT NONE REAL :: conden, a, b, c, d, e REAL :: f conden = (b-c)/(1.+d*d/(rv*e)*c/(a*a)) END FUNCTION CONDEN END MODULE G_MODULE_MP_WSM6R !