wrftladj/module_bl_surface_drag_ad.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 reverse (adjoint) mode (with options r8):
   5 !   gradient     of useful results: v_phy rublten z rvblten u_phy
   6 !   with respect to varying inputs: v_phy rublten z rvblten u_phy
   7 !-------------------------------------------------------------------
   8 !WRF:MODEL_LAYER:PHYSICS
   9 MODULE a_module_bl_surface_drag
  10 CONTAINS
  11 SUBROUTINE SURFACE_DRAG_B(rublten, rubltenb, rvblten, rvbltenb, u_phy, &
  12 &  u_phyb, v_phy, v_phyb, xland, z, zb, ht, kpbl2d, ids, ide, jds, jde, &
  13 &  kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
  14   IMPLICIT NONE
  15   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
  16 &  jme, kms, kme, its, ite, jts, jte, kts, kte
  17   INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: kpbl2d
  18   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rublten, &
  19 &  rvblten
  20   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rubltenb
  21   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u_phy, v_phy&
  22 &  , z
  23   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: u_phyb, v_phyb, zb
  24   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: xland, ht
  25 ! Local
  26   REAL :: v0, tao_xz, tao_yz, cd, zh, zwt
  27   REAL :: v0b, tao_xzb, tao_yzb, cdb, zhb, zwtb
  28   INTEGER :: i, j, i_start, i_end, i_endu, j_start, j_end, j_endv, k
  29   INTEGER :: branch
  30   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rvbltenb
  31   REAL :: tempb2
  32   REAL :: tempb1
  33   REAL :: tempb0
  34   REAL :: tempb
  35   REAL :: abs1
  36   REAL :: abs0
  37 ! End declarations.
  38 !-----------------------------------------------------------------------
  39   i_start = its
  40   IF (ite .GT. ide - 1) THEN
  41     i_end = ide - 1
  42   ELSE
  43     i_end = ite
  44   END IF
  45   i_endu = ite
  46   j_start = jts
  47   IF (jte .GT. jde - 1) THEN
  48     j_end = jde - 1
  49   ELSE
  50     j_end = jte
  51   END IF
  52   j_endv = jte
  53   DO j=j_start,j_end
  54     DO i=i_start,i_endu
  55       CALL PUSHREAL8(v0)
  56       v0 = SQRT(u_phy(i, kts, j)**2 + v_phy(i, kts, j)**2)
  57       IF (xland(i, j) - xland(i-1, j) .GE. 0.) THEN
  58         abs0 = xland(i, j) - xland(i-1, j)
  59       ELSE
  60         abs0 = -(xland(i, j)-xland(i-1, j))
  61       END IF
  62       IF (abs0 .LT. 1.0e-10) THEN
  63         IF (xland(i, j) .LT. 1.5) THEN
  64           CALL PUSHREAL8(cd)
  65 ! land
  66           cd = 0.01
  67           CALL PUSHCONTROL2B(0)
  68         ELSE
  69           CALL PUSHREAL8(cd)
  70 ! water
  71           cd = 0.001
  72           IF (cd .LT. 1.e-4*v0) THEN
  73             cd = 1.e-4*v0
  74             CALL PUSHCONTROL1B(0)
  75           ELSE
  76             CALL PUSHCONTROL1B(1)
  77             cd = cd
  78           END IF
  79           IF (cd .GT. 0.003) THEN
  80             cd = 0.003
  81             CALL PUSHCONTROL2B(3)
  82           ELSE
  83             CALL PUSHCONTROL2B(2)
  84             cd = cd
  85           END IF
  86         END IF
  87       ELSE
  88         CALL PUSHREAL8(cd)
  89 ! coast
  90         cd = 0.003
  91         CALL PUSHCONTROL2B(1)
  92       END IF
  93       CALL PUSHREAL8(tao_xz)
  94       tao_xz = cd*v0*u_phy(i, kts, j)
  95       DO k=kts,kte
  96         zh = z(i, k, j) - ht(i, j)
  97         IF (zh .LT. 1000.) THEN
  98           CALL PUSHCONTROL1B(1)
  99         ELSE
 100           CALL PUSHCONTROL1B(0)
 101         END IF
 102       END DO
 103     END DO
 104   END DO
 105 !
 106   DO j=j_start,j_endv
 107     DO i=i_start,i_end
 108       CALL PUSHREAL8(v0)
 109       v0 = SQRT(u_phy(i, kts, j)**2 + v_phy(i, kts, j)**2)
 110       IF (xland(i, j) - xland(i, j-1) .GE. 0.) THEN
 111         abs1 = xland(i, j) - xland(i, j-1)
 112       ELSE
 113         abs1 = -(xland(i, j)-xland(i, j-1))
 114       END IF
 115       IF (abs1 .LT. 1.0e-10) THEN
 116         IF (xland(i, j) .LT. 1.5) THEN
 117           CALL PUSHREAL8(cd)
 118 ! land
 119           cd = 0.01
 120           CALL PUSHCONTROL2B(0)
 121         ELSE
 122           CALL PUSHREAL8(cd)
 123 ! water
 124           cd = 0.001
 125           IF (cd .LT. 1.e-4*v0) THEN
 126             cd = 1.e-4*v0
 127             CALL PUSHCONTROL1B(0)
 128           ELSE
 129             CALL PUSHCONTROL1B(1)
 130             cd = cd
 131           END IF
 132           IF (cd .GT. 0.003) THEN
 133             cd = 0.003
 134             CALL PUSHCONTROL2B(3)
 135           ELSE
 136             CALL PUSHCONTROL2B(2)
 137             cd = cd
 138           END IF
 139         END IF
 140       ELSE
 141         CALL PUSHREAL8(cd)
 142 ! coast
 143         cd = 0.003
 144         CALL PUSHCONTROL2B(1)
 145       END IF
 146       CALL PUSHREAL8(tao_yz)
 147       tao_yz = cd*v0*v_phy(i, kts, j)
 148       DO k=kts,kte
 149         zh = z(i, k, j) - ht(i, j)
 150         IF (zh .LT. 1000.) THEN
 151           CALL PUSHCONTROL1B(1)
 152         ELSE
 153           CALL PUSHCONTROL1B(0)
 154         END IF
 155       END DO
 156     END DO
 157   END DO
 158   DO j=j_endv,j_start,-1
 159     DO i=i_end,i_start,-1
 160       tao_yzb = 0.0_8
 161       DO k=kte,kts,-1
 162         CALL POPCONTROL1B(branch)
 163         IF (branch .EQ. 0) THEN
 164           zhb = 0.0_8
 165         ELSE
 166           zh = z(i, k, j) - ht(i, j)
 167           zwt = 2.*(1000.-zh)/1000.
 168           zwtb = -(tao_yz*0.5*rvbltenb(i, k, j)/1000.)
 169           tao_yzb = tao_yzb - 0.5*zwt*rvbltenb(i, k, j)/1000.
 170           zhb = -(2.*zwtb/1000.)
 171         END IF
 172         zb(i, k, j) = zb(i, k, j) + zhb
 173       END DO
 174       CALL POPREAL8(tao_yz)
 175       tempb2 = v_phy(i, kts, j)*tao_yzb
 176       cdb = v0*tempb2
 177       v0b = cd*tempb2
 178       v_phyb(i, kts, j) = v_phyb(i, kts, j) + cd*v0*tao_yzb
 179       CALL POPCONTROL2B(branch)
 180       IF (branch .LT. 2) THEN
 181         IF (branch .EQ. 0) THEN
 182           CALL POPREAL8(cd)
 183         ELSE
 184           CALL POPREAL8(cd)
 185         END IF
 186       ELSE
 187         IF (branch .NE. 2) cdb = 0.0_8
 188         CALL POPCONTROL1B(branch)
 189         IF (branch .EQ. 0) v0b = v0b + 1.e-4*cdb
 190         CALL POPREAL8(cd)
 191       END IF
 192       CALL POPREAL8(v0)
 193       IF (u_phy(i, kts, j)**2 + v_phy(i, kts, j)**2 .EQ. 0.0_8) THEN
 194         tempb1 = 0.0
 195       ELSE
 196         tempb1 = v0b/(2.0*SQRT(u_phy(i, kts, j)**2+v_phy(i, kts, j)**2))
 197       END IF
 198       u_phyb(i, kts, j) = u_phyb(i, kts, j) + 2*u_phy(i, kts, j)*tempb1
 199       v_phyb(i, kts, j) = v_phyb(i, kts, j) + 2*v_phy(i, kts, j)*tempb1
 200     END DO
 201   END DO
 202   DO j=j_end,j_start,-1
 203     DO i=i_endu,i_start,-1
 204       tao_xzb = 0.0_8
 205       DO k=kte,kts,-1
 206         CALL POPCONTROL1B(branch)
 207         IF (branch .EQ. 0) THEN
 208           zhb = 0.0_8
 209         ELSE
 210           zh = z(i, k, j) - ht(i, j)
 211           zwt = 2.*(1000.-zh)/1000.
 212           zwtb = -(tao_xz*0.5*rubltenb(i, k, j)/1000.)
 213           tao_xzb = tao_xzb - 0.5*zwt*rubltenb(i, k, j)/1000.
 214           zhb = -(2.*zwtb/1000.)
 215         END IF
 216         zb(i, k, j) = zb(i, k, j) + zhb
 217       END DO
 218       CALL POPREAL8(tao_xz)
 219       tempb0 = u_phy(i, kts, j)*tao_xzb
 220       cdb = v0*tempb0
 221       v0b = cd*tempb0
 222       u_phyb(i, kts, j) = u_phyb(i, kts, j) + cd*v0*tao_xzb
 223       CALL POPCONTROL2B(branch)
 224       IF (branch .LT. 2) THEN
 225         IF (branch .EQ. 0) THEN
 226           CALL POPREAL8(cd)
 227         ELSE
 228           CALL POPREAL8(cd)
 229         END IF
 230       ELSE
 231         IF (branch .NE. 2) cdb = 0.0_8
 232         CALL POPCONTROL1B(branch)
 233         IF (branch .EQ. 0) v0b = v0b + 1.e-4*cdb
 234         CALL POPREAL8(cd)
 235       END IF
 236       CALL POPREAL8(v0)
 237       IF (u_phy(i, kts, j)**2 + v_phy(i, kts, j)**2 .EQ. 0.0_8) THEN
 238         tempb = 0.0
 239       ELSE
 240         tempb = v0b/(2.0*SQRT(u_phy(i, kts, j)**2+v_phy(i, kts, j)**2))
 241       END IF
 242       u_phyb(i, kts, j) = u_phyb(i, kts, j) + 2*u_phy(i, kts, j)*tempb
 243       v_phyb(i, kts, j) = v_phyb(i, kts, j) + 2*v_phy(i, kts, j)*tempb
 244     END DO
 245   END DO
 246 END SUBROUTINE SURFACE_DRAG_B
 247
 248 !        Generated by TAPENADE     (INRIA, Tropics team)
 249 !  Tapenade 3.6 (r4343) - 10 Feb 2012 10:52
 250 !
 251 !  Differentiation of surface_drag_init in reverse (adjoint) mode:
 252 !   gradient     of useful results: rublten rqvblten rvblten rthblten
 253 !   with respect to varying inputs: rublten rqvblten rvblten rthblten
 254 SUBROUTINE SURFACE_DRAG_INIT_B(rublten, rubltenb, rvblten, rvbltenb, &
 255 &  rthblten, rthbltenb, rqvblten, rqvbltenb, restart, ids, ide, jds, jde&
 256 &  , kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte&
 257 &)
 258   IMPLICIT NONE
 259 !-------------------------------------------------------------------
 260   LOGICAL, INTENT(IN) :: restart
 261   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 262 &  jme, kms, kme, its, ite, jts, jte, kts, kte
 263   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rublten, rvblten, &
 264 &  rthblten, rqvblten
 265   REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: rubltenb, rvbltenb, &
 266 &  rthbltenb, rqvbltenb
 267   INTEGER :: i, j, k, itf, jtf, ktf
 268   INTRINSIC MIN0
 269   IF (jte .GT. jde - 1) THEN
 270     jtf = jde - 1
 271   ELSE
 272     jtf = jte
 273   END IF
 274   IF (kte .GT. kde - 1) THEN
 275     ktf = kde - 1
 276   ELSE
 277     ktf = kte
 278   END IF
 279   IF (ite .GT. ide - 1) THEN
 280     itf = ide - 1
 281   ELSE
 282     itf = ite
 283   END IF
 284   IF (.NOT.restart) THEN
 285     DO j=jtf,jts,-1
 286       DO k=ktf,kts,-1
 287         DO i=itf,its,-1
 288           rqvbltenb(i, k, j) = 0.0
 289           rthbltenb(i, k, j) = 0.0
 290           rvbltenb(i, k, j) = 0.0
 291           rubltenb(i, k, j) = 0.0
 292         END DO
 293       END DO
 294     END DO
 295   END IF
 296 END SUBROUTINE SURFACE_DRAG_INIT_B
 297
 298 END MODULE a_module_bl_surface_drag