wrftladj/module_mp_nconvp_ad.F

   1 !        Generated by TAPENADE     (INRIA, Tropics team)
   2 !  Tapenade 3.7 (r4786) - 21 Feb 2013 15:53
   3 !
   4 !  Differentiation of lscond in reverse (adjoint) mode (with options r8):
   5 !   gradient     of useful results: th p qv rainnc rainncv rho
   6 !                pii dz8w
   7 !   with respect to varying inputs: th p qv rainnc rainncv rho
   8 !                pii dz8w
   9 !WRF:MODEL_LAYER:PHYSICS
  10 !
  11 MODULE a_module_mp_nconvp
  12 CONTAINS
  13 !----------------------------------------------------------------
  14 ! domain dims
  15 ! memory dims
  16 ! tile   dims
  17 SUBROUTINE LSCOND_B(th, thb, p, pb, qv, qvb, rho, rhob, pii, piib, r_v, &
  18 &  xlv, cp, ep2, svp1, svp2, svp3, svpt0, dz8w, dz8wb, rainnc, rainncb, &
  19 &  rainncv, rainncvb, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, &
  20 &  kms, kme, its, ite, jts, jte, kts, kte)
  21   IMPLICIT NONE
  22 !----------------------------------------------------------------
  23 !  based on MM5 code (JD November 2006)
  24 !----------------------------------------------------------------
  25   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
  26 &  jme, kms, kme, its, ite, jts, jte, kts, kte
  27   REAL, INTENT(IN) :: r_v, xlv, cp
  28   REAL, INTENT(IN) :: ep2, svp1, svp2, svp3, svpt0
  29   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: th, qv
  30   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: thb
  31   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rho, pii, p&
  32 &  , dz8w
  33   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rhob, piib, pb, dz8wb
  34   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rainnc, rainncv
  35   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rainncb
  36 ! local variables
  37   REAL :: ttemp, es1, qs1, dqv, cond, r1
  38   REAL :: ttempb, es1b, qs1b, dqvb, condb, r1b
  39   INTEGER :: i, j, k
  40   INTEGER :: branch
  41   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: qvb
  42   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rainncvb
  43   REAL :: temp1
  44   REAL :: temp0
  45   REAL :: temp0b
  46   REAL :: temp2b1
  47   REAL :: temp2b0
  48   REAL :: tempb
  49   REAL :: temp0b0
  50   REAL :: temp2b
  51   REAL :: temp1b
  52   REAL :: temp
  53 !----------------------------------------------------------------
  54   DO j=jts,jte
  55     DO k=kts,kte
  56       DO i=its,ite
  57         CALL PUSHREAL8(ttemp)
  58         ttemp = pii(i, k, j)*th(i, k, j)
  59         CALL PUSHREAL8(es1)
  60         es1 = 1000.*svp1*EXP(svp2*(ttemp-svpt0)/(ttemp-svp3))
  61         qs1 = ep2*es1/(p(i, k, j)-es1)
  62         CALL PUSHREAL8(dqv)
  63         dqv = qv(i, k, j) - qs1
  64         IF (dqv .GT. 0.0) THEN
  65           CALL PUSHREAL8(r1)
  66           r1 = 1. + xlv*xlv/(r_v*cp)*qs1/(ttemp*ttemp)
  67           cond = dqv/r1
  68           CALL PUSHREAL8(ttemp)
  69           ttemp = ttemp + xlv/cp*cond
  70           CALL PUSHCONTROL1B(1)
  71         ELSE
  72           CALL PUSHCONTROL1B(0)
  73         END IF
  74       END DO
  75     END DO
  76   END DO
  77   DO j=jte,jts,-1
  78     DO k=kte,kts,-1
  79       DO i=ite,its,-1
  80         CALL POPCONTROL1B(branch)
  81         IF (branch .EQ. 0) THEN
  82           qs1b = 0.0_8
  83           dqvb = 0.0_8
  84           ttempb = 0.0_8
  85         ELSE
  86           temp2b1 = thb(i, k, j)/pii(i, k, j)
  87           ttempb = temp2b1
  88           temp2b0 = dz8w(i, k, j)*rainncvb(i, j)
  89           cond = dqv/r1
  90           temp2b = dz8w(i, k, j)*rainncb(i, j)
  91           rhob(i, k, j) = rhob(i, k, j) + cond*temp2b0 + cond*temp2b
  92           condb = rho(i, k, j)*temp2b0 - qvb(i, k, j) + xlv*ttempb/cp + &
  93 &            rho(i, k, j)*temp2b
  94           dz8wb(i, k, j) = dz8wb(i, k, j) + rho(i, k, j)*cond*rainncvb(i&
  95 &            , j) + rho(i, k, j)*cond*rainncb(i, j)
  96           rainncvb(i, j) = 0.0_8
  97           piib(i, k, j) = piib(i, k, j) - ttemp*temp2b1/pii(i, k, j)
  98           thb(i, k, j) = 0.0_8
  99           qs1 = ep2*es1/(p(i, k, j)-es1)
 100           CALL POPREAL8(ttemp)
 101           dqvb = condb/r1
 102           r1b = -(dqv*condb/r1**2)
 103           CALL POPREAL8(r1)
 104           temp1 = r_v*cp*ttemp**2
 105           temp1b = xlv**2*r1b/temp1
 106           qs1b = temp1b
 107           ttempb = ttempb - r_v*cp*qs1*2*ttemp*temp1b/temp1
 108         END IF
 109         CALL POPREAL8(dqv)
 110         qvb(i, k, j) = qvb(i, k, j) + dqvb
 111         qs1b = qs1b - dqvb
 112         temp0 = p(i, k, j) - es1
 113         temp0b = ep2*qs1b/temp0
 114         temp0b0 = -(es1*temp0b/temp0)
 115         es1b = temp0b - temp0b0
 116         pb(i, k, j) = pb(i, k, j) + temp0b0
 117         CALL POPREAL8(es1)
 118         temp = (ttemp-svpt0)/(ttemp-svp3)
 119         tempb = svp2*EXP(svp2*temp)*svp1*1000.*es1b/(ttemp-svp3)
 120         ttempb = ttempb + (1.0-temp)*tempb
 121         CALL POPREAL8(ttemp)
 122         piib(i, k, j) = piib(i, k, j) + th(i, k, j)*ttempb
 123         thb(i, k, j) = thb(i, k, j) + pii(i, k, j)*ttempb
 124       END DO
 125     END DO
 126   END DO
 127 END SUBROUTINE LSCOND_B
 128 END MODULE a_module_mp_nconvp