wrftladj/module_bl_surface_drag_tl.F

   1 !        Generated by TAPENADE     (INRIA, Tropics team)
   2 !  Tapenade 3.7 (r4786) - 21 Feb 2013 15:53
   3 !
   4 !  Differentiation of surface_drag in forward (tangent) mode (with options r8):
   5 !   variations   of useful results: rublten rvblten
   6 !   with respect to varying inputs: v_phy rublten z rvblten u_phy
   7 !-------------------------------------------------------------------
   8 !WRF:MODEL_LAYER:PHYSICS
   9 MODULE g_module_bl_surface_drag
  10 CONTAINS
  11
  12 SUBROUTINE G_SURFACE_DRAG(rublten, rubltend, rvblten, rvbltend, u_phy, &
  13 &  u_phyd, v_phy, v_phyd, xland, z, zd, ht, kpbl2d, ids, ide, jds, jde, &
  14 &  kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
  15   IMPLICIT NONE
  16   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
  17 &  jme, kms, kme, its, ite, jts, jte, kts, kte
  18   INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: kpbl2d
  19   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rublten, &
  20 &  rvblten
  21   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rubltend&
  22 &  , rvbltend
  23   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u_phy, v_phy&
  24 &  , z
  25   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u_phyd, &
  26 &  v_phyd, zd
  27   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: xland, ht
  28 ! Local
  29   REAL :: v0, tao_xz, tao_yz, cd, zh, zwt
  30   REAL :: v0d, tao_xzd, tao_yzd, cdd, zhd, zwtd
  31   INTEGER :: i, j, i_start, i_end, i_endu, j_start, j_end, j_endv, k
  32   REAL :: arg1
  33   REAL :: arg1d
  34   REAL :: abs1
  35   REAL :: abs0
  36 ! End declarations.
  37 !-----------------------------------------------------------------------
  38   i_start = its
  39   IF (ite .GT. ide - 1) THEN
  40     i_end = ide - 1
  41   ELSE
  42     i_end = ite
  43   END IF
  44   i_endu = ite
  45   j_start = jts
  46   IF (jte .GT. jde - 1) THEN
  47     j_end = jde - 1
  48   ELSE
  49     j_end = jte
  50   END IF
  51   j_endv = jte
  52   DO j=j_start,j_end
  53     DO i=i_start,i_endu
  54       arg1d = 2*u_phy(i, kts, j)*u_phyd(i, kts, j) + 2*v_phy(i, kts, j)*&
  55 &        v_phyd(i, kts, j)
  56       arg1 = u_phy(i, kts, j)**2 + v_phy(i, kts, j)**2
  57       IF (arg1 .EQ. 0.0_8) THEN
  58         v0d = 0.0_8
  59       ELSE
  60         v0d = arg1d/(2.0*SQRT(arg1))
  61       END IF
  62       v0 = SQRT(arg1)
  63       IF (xland(i, j) - xland(i-1, j) .GE. 0.) THEN
  64         abs0 = xland(i, j) - xland(i-1, j)
  65       ELSE
  66         abs0 = -(xland(i, j)-xland(i-1, j))
  67       END IF
  68       IF (abs0 .LT. 1.0e-10) THEN
  69         IF (xland(i, j) .LT. 1.5) THEN
  70 ! land
  71           cd = 0.01
  72           cdd = 0.0_8
  73         ELSE
  74 ! water
  75           cd = 0.001
  76           IF (cd .LT. 1.e-4*v0) THEN
  77             cdd = 1.e-4*v0d
  78             cd = 1.e-4*v0
  79           ELSE
  80             cd = cd
  81             cdd = 0.0_8
  82           END IF
  83           IF (cd .GT. 0.003) THEN
  84             cd = 0.003
  85             cdd = 0.0_8
  86           ELSE
  87             cd = cd
  88           END IF
  89         END IF
  90       ELSE
  91 ! coast
  92         cd = 0.003
  93         cdd = 0.0_8
  94       END IF
  95       tao_xzd = (cdd*v0+cd*v0d)*u_phy(i, kts, j) + cd*v0*u_phyd(i, kts, &
  96 &        j)
  97       tao_xz = cd*v0*u_phy(i, kts, j)
  98       DO k=kts,kte
  99         zhd = zd(i, k, j)
 100         zh = z(i, k, j) - ht(i, j)
 101         IF (zh .LT. 1000.) THEN
 102           zwtd = (-(2.*zhd))/1000.
 103           zwt = 2.*(1000.-zh)/1000.
 104           rubltend(i, k, j) = rubltend(i, k, j) - 0.5*(zwtd*tao_xz+zwt*&
 105 &            tao_xzd)/1000.
 106           rublten(i, k, j) = rublten(i, k, j) - zwt*0.5*tao_xz/1000.
 107           kpbl2d(i, j) = k
 108         END IF
 109       END DO
 110     END DO
 111   END DO
 112 !
 113   DO j=j_start,j_endv
 114     DO i=i_start,i_end
 115       arg1d = 2*u_phy(i, kts, j)*u_phyd(i, kts, j) + 2*v_phy(i, kts, j)*&
 116 &        v_phyd(i, kts, j)
 117       arg1 = u_phy(i, kts, j)**2 + v_phy(i, kts, j)**2
 118       IF (arg1 .EQ. 0.0_8) THEN
 119         v0d = 0.0_8
 120       ELSE
 121         v0d = arg1d/(2.0*SQRT(arg1))
 122       END IF
 123       v0 = SQRT(arg1)
 124       IF (xland(i, j) - xland(i, j-1) .GE. 0.) THEN
 125         abs1 = xland(i, j) - xland(i, j-1)
 126       ELSE
 127         abs1 = -(xland(i, j)-xland(i, j-1))
 128       END IF
 129       IF (abs1 .LT. 1.0e-10) THEN
 130         IF (xland(i, j) .LT. 1.5) THEN
 131 ! land
 132           cd = 0.01
 133           cdd = 0.0_8
 134         ELSE
 135 ! water
 136           cd = 0.001
 137           IF (cd .LT. 1.e-4*v0) THEN
 138             cdd = 1.e-4*v0d
 139             cd = 1.e-4*v0
 140           ELSE
 141             cd = cd
 142             cdd = 0.0_8
 143           END IF
 144           IF (cd .GT. 0.003) THEN
 145             cd = 0.003
 146             cdd = 0.0_8
 147           ELSE
 148             cd = cd
 149           END IF
 150         END IF
 151       ELSE
 152 ! coast
 153         cd = 0.003
 154         cdd = 0.0_8
 155       END IF
 156       tao_yzd = (cdd*v0+cd*v0d)*v_phy(i, kts, j) + cd*v0*v_phyd(i, kts, &
 157 &        j)
 158       tao_yz = cd*v0*v_phy(i, kts, j)
 159       DO k=kts,kte
 160         zhd = zd(i, k, j)
 161         zh = z(i, k, j) - ht(i, j)
 162         IF (zh .LT. 1000.) THEN
 163           zwtd = (-(2.*zhd))/1000.
 164           zwt = 2.*(1000.-zh)/1000.
 165           rvbltend(i, k, j) = rvbltend(i, k, j) - 0.5*(zwtd*tao_yz+zwt*&
 166 &            tao_yzd)/1000.
 167           rvblten(i, k, j) = rvblten(i, k, j) - zwt*0.5*tao_yz/1000.
 168         END IF
 169       END DO
 170     END DO
 171   END DO
 172 END SUBROUTINE G_SURFACE_DRAG
 173
 174 !        Generated by TAPENADE     (INRIA, Tropics team)
 175 !  Tapenade 3.6 (r4343) - 10 Feb 2012 10:52
 176 !
 177 !  Differentiation of surface_drag_init in forward (tangent) mode:
 178 !   variations   of useful results: rublten rqvblten rvblten rthblten
 179 !   with respect to varying inputs: rublten rqvblten rvblten rthblten
 180 SUBROUTINE SURFACE_DRAG_INIT_D(rublten, rubltend, rvblten, rvbltend, &
 181 &  rthblten, rthbltend, rqvblten, rqvbltend, restart, ids, ide, jds, jde&
 182 &  , kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte&
 183 &)
 184   IMPLICIT NONE
 185 !-------------------------------------------------------------------
 186   LOGICAL, INTENT(IN) :: restart
 187   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 188 &  jme, kms, kme, its, ite, jts, jte, kts, kte
 189   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rublten, &
 190 &  rvblten, rthblten, rqvblten
 191   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rubltend, &
 192 &  rvbltend, rthbltend, rqvbltend
 193   INTEGER :: i, j, k, itf, jtf, ktf
 194   INTRINSIC MIN0
 195   IF (jte .GT. jde - 1) THEN
 196     jtf = jde - 1
 197   ELSE
 198     jtf = jte
 199   END IF
 200   IF (kte .GT. kde - 1) THEN
 201     ktf = kde - 1
 202   ELSE
 203     ktf = kte
 204   END IF
 205   IF (ite .GT. ide - 1) THEN
 206     itf = ide - 1
 207   ELSE
 208     itf = ite
 209   END IF
 210   IF (.NOT.restart) THEN
 211     DO j=jts,jtf
 212       DO k=kts,ktf
 213         DO i=its,itf
 214           rubltend(i, k, j) = 0.0
 215           rublten(i, k, j) = 0.
 216           rvbltend(i, k, j) = 0.0
 217           rvblten(i, k, j) = 0.
 218           rthbltend(i, k, j) = 0.0
 219           rthblten(i, k, j) = 0.
 220           rqvbltend(i, k, j) = 0.0
 221           rqvblten(i, k, j) = 0.
 222         END DO
 223       END DO
 224     END DO
 225   END IF
 226 END SUBROUTINE SURFACE_DRAG_INIT_D
 227
 228 END MODULE g_module_bl_surface_drag