wrftladj/module_big_step_utilities_em_tl.F

   1
   2 ! ======================================================================================
   3 ! This file was generated by the version 5.3.5 of DFT on 07/13/2010. The differentiation
   4 ! transforming system(DFT) was jointly developed and sponsored by LASG of IAP(1998-2010)
   5 ! and LSEC of ICMSEC, AMSS(2001-2003)
   6 ! The copyright of the DFT system was declared by Walls at LASG, 1998-2010
   7 ! ======================================================================================
   8 #if (RWORDSIZE == 4)
   9 #   define VPOWX vspowx
  10 #   define VPOW  vspow
  11 #else
  12 #   define VPOWX vpowx
  13 #   define VPOW  vpow
  14 #endif
  15
  16  MODULE g_module_big_step_utilities_em
  17
  18  USE module_model_constants
  19  USE module_state_description, only: p_qg, p_qs, p_qi, gdscheme, tiedtkescheme, ntiedtkescheme, &
  20  kfetascheme, mskfscheme, g3scheme, p_qv, param_first_scalar, p_qr, p_qc, DFI_FWD
  21  USE module_configure, ONLY : grid_config_rec_type
  22  USE module_wrf_error
  23
  24  CONTAINS
  25
  26 !        Generated by TAPENADE     (INRIA, Tropics team)
  27 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
  28 !
  29 !  Differentiation of calc_mu_uv in forward (tangent) mode:
  30 !   variations   of useful results: muu muv
  31 !   with respect to varying inputs: muu muv mu
  32 !   RW status of diff variables: muu:in-out muv:in-out mu:in
  33 SUBROUTINE G_CALC_MU_UV(config_flags, mu, mud, mub, muu, muud, muv, muvd&
  34 &  , ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite&
  35 &  , jts, jte, kts, kte)
  36   IMPLICIT NONE
  37 ! Input data
  38   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
  39   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
  40 &  jme, kms, kme, its, ite, jts, jte, kts, kte
  41   REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: muu, muv
  42   REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: muud, muvd
  43   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, mub
  44   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mud
  45 !  local stuff
  46   INTEGER :: i, j, itf, jtf, im, jm
  47   INTRINSIC MIN
  48 !<DESCRIPTION>
  49 !
  50 !  calc_mu_uv calculates the full column dry-air mass at the staggered
  51 !  horizontal velocity points (u,v) and places the results in muu and muv.
  52 !  This routine uses the reference state (mub) and perturbation state (mu)
  53 !
  54 !</DESCRIPTION>
  55   itf = ite
  56   IF (jte .GT. jde - 1) THEN
  57     jtf = jde - 1
  58   ELSE
  59     jtf = jte
  60   END IF
  61   IF (its .NE. ids .AND. ite .NE. ide) THEN
  62     DO j=jts,jtf
  63       DO i=its,itf
  64         muud(i, j) = 0.5*(mud(i, j)+mud(i-1, j))
  65         muu(i, j) = 0.5*(mu(i, j)+mu(i-1, j)+mub(i, j)+mub(i-1, j))
  66       END DO
  67     END DO
  68   ELSE IF (its .EQ. ids .AND. ite .NE. ide) THEN
  69     DO j=jts,jtf
  70       DO i=its+1,itf
  71         muud(i, j) = 0.5*(mud(i, j)+mud(i-1, j))
  72         muu(i, j) = 0.5*(mu(i, j)+mu(i-1, j)+mub(i, j)+mub(i-1, j))
  73       END DO
  74     END DO
  75     i = its
  76     im = its
  77     IF (config_flags%periodic_x) im = its - 1
  78     DO j=jts,jtf
  79 !            muu(i,j) =      mu(i,j)          +mub(i,j)
  80 !  fix for periodic b.c., 13 march 2004, wcs
  81       muud(i, j) = 0.5*(mud(i, j)+mud(im, j))
  82       muu(i, j) = 0.5*(mu(i, j)+mu(im, j)+mub(i, j)+mub(im, j))
  83     END DO
  84   ELSE IF (its .NE. ids .AND. ite .EQ. ide) THEN
  85     DO j=jts,jtf
  86       DO i=its,itf-1
  87         muud(i, j) = 0.5*(mud(i, j)+mud(i-1, j))
  88         muu(i, j) = 0.5*(mu(i, j)+mu(i-1, j)+mub(i, j)+mub(i-1, j))
  89       END DO
  90     END DO
  91     i = ite
  92     im = ite - 1
  93     IF (config_flags%periodic_x) im = ite
  94     DO j=jts,jtf
  95 !            muu(i,j) =      mu(i-1,j)        +mub(i-1,j)
  96 !  fix for periodic b.c., 13 march 2004, wcs
  97       muud(i, j) = 0.5*(mud(i-1, j)+mud(im, j))
  98       muu(i, j) = 0.5*(mu(i-1, j)+mu(im, j)+mub(i-1, j)+mub(im, j))
  99     END DO
 100   ELSE IF (its .EQ. ids .AND. ite .EQ. ide) THEN
 101     DO j=jts,jtf
 102       DO i=its+1,itf-1
 103         muud(i, j) = 0.5*(mud(i, j)+mud(i-1, j))
 104         muu(i, j) = 0.5*(mu(i, j)+mu(i-1, j)+mub(i, j)+mub(i-1, j))
 105       END DO
 106     END DO
 107     i = its
 108     im = its
 109     IF (config_flags%periodic_x) im = its - 1
 110     DO j=jts,jtf
 111 !            muu(i,j) =      mu(i,j)          +mub(i,j)
 112 !  fix for periodic b.c., 13 march 2004, wcs
 113       muud(i, j) = 0.5*(mud(i, j)+mud(im, j))
 114       muu(i, j) = 0.5*(mu(i, j)+mu(im, j)+mub(i, j)+mub(im, j))
 115     END DO
 116     i = ite
 117     im = ite - 1
 118     IF (config_flags%periodic_x) im = ite
 119     DO j=jts,jtf
 120 !            muu(i,j) =      mu(i-1,j)        +mub(i-1,j)
 121 !  fix for periodic b.c., 13 march 2004, wcs
 122       muud(i, j) = 0.5*(mud(i-1, j)+mud(im, j))
 123       muu(i, j) = 0.5*(mu(i-1, j)+mu(im, j)+mub(i-1, j)+mub(im, j))
 124     END DO
 125   END IF
 126   IF (ite .GT. ide - 1) THEN
 127     itf = ide - 1
 128   ELSE
 129     itf = ite
 130   END IF
 131   jtf = jte
 132   IF (jts .NE. jds .AND. jte .NE. jde) THEN
 133     DO j=jts,jtf
 134       DO i=its,itf
 135         muvd(i, j) = 0.5*(mud(i, j)+mud(i, j-1))
 136         muv(i, j) = 0.5*(mu(i, j)+mu(i, j-1)+mub(i, j)+mub(i, j-1))
 137       END DO
 138     END DO
 139   ELSE IF (jts .EQ. jds .AND. jte .NE. jde) THEN
 140     DO j=jts+1,jtf
 141       DO i=its,itf
 142         muvd(i, j) = 0.5*(mud(i, j)+mud(i, j-1))
 143         muv(i, j) = 0.5*(mu(i, j)+mu(i, j-1)+mub(i, j)+mub(i, j-1))
 144       END DO
 145     END DO
 146     j = jts
 147     jm = jts
 148     IF (config_flags%periodic_y) jm = jts - 1
 149     DO i=its,itf
 150 !             muv(i,j) =      mu(i,j)          +mub(i,j)
 151 !  fix for periodic b.c., 13 march 2004, wcs
 152       muvd(i, j) = 0.5*(mud(i, j)+mud(i, jm))
 153       muv(i, j) = 0.5*(mu(i, j)+mu(i, jm)+mub(i, j)+mub(i, jm))
 154     END DO
 155   ELSE IF (jts .NE. jds .AND. jte .EQ. jde) THEN
 156     DO j=jts,jtf-1
 157       DO i=its,itf
 158         muvd(i, j) = 0.5*(mud(i, j)+mud(i, j-1))
 159         muv(i, j) = 0.5*(mu(i, j)+mu(i, j-1)+mub(i, j)+mub(i, j-1))
 160       END DO
 161     END DO
 162     j = jte
 163     jm = jte - 1
 164     IF (config_flags%periodic_y) jm = jte
 165     DO i=its,itf
 166 ! comment out the following statement. NPan 05/26/10
 167 !             muv(i,j) =      mu(i,j-1)        +mub(i,j-1)
 168 !  fix for periodic b.c., 13 march 2004, wcs
 169       muvd(i, j) = 0.5*(mud(i, j-1)+mud(i, jm))
 170       muv(i, j) = 0.5*(mu(i, j-1)+mu(i, jm)+mub(i, j-1)+mub(i, jm))
 171     END DO
 172   ELSE IF (jts .EQ. jds .AND. jte .EQ. jde) THEN
 173     DO j=jts+1,jtf-1
 174       DO i=its,itf
 175         muvd(i, j) = 0.5*(mud(i, j)+mud(i, j-1))
 176         muv(i, j) = 0.5*(mu(i, j)+mu(i, j-1)+mub(i, j)+mub(i, j-1))
 177       END DO
 178     END DO
 179     j = jts
 180     jm = jts
 181     IF (config_flags%periodic_y) jm = jts - 1
 182     DO i=its,itf
 183 !             muv(i,j) =      mu(i,j)          +mub(i,j)
 184 !  fix for periodic b.c., 13 march 2004, wcs
 185       muvd(i, j) = 0.5*(mud(i, j)+mud(i, jm))
 186       muv(i, j) = 0.5*(mu(i, j)+mu(i, jm)+mub(i, j)+mub(i, jm))
 187     END DO
 188     j = jte
 189     jm = jte - 1
 190     IF (config_flags%periodic_y) jm = jte
 191     DO i=its,itf
 192 !             muv(i,j) =      mu(i,j-1)        +mub(i,j-1)
 193 !  fix for periodic b.c., 13 march 2004, wcs
 194       muvd(i, j) = 0.5*(mud(i, j-1)+mud(i, jm))
 195       muv(i, j) = 0.5*(mu(i, j-1)+mu(i, jm)+mub(i, j-1)+mub(i, jm))
 196     END DO
 197   END IF
 198 END SUBROUTINE G_CALC_MU_UV
 199
 200  SUBROUTINE g_calc_mu_uv_1(config_flags,mu,g_mu,muu,g_muu,muv,g_muv,ids, &
 201  ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
 202
 203  IMPLICIT NONE
 204
 205  REAL :: Tmpv1,g_Tmpv1
 206  TYPE(grid_config_rec_type) :: config_flags
 207  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
 208  REAL,DIMENSION(ims:ime,jms:jme) :: muu,g_muu,muv,g_muv
 209  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
 210
 211  INTEGER :: i,j,itf,jtf,im,jm
 212
 213  itf =ite
 214
 215  jtf =min(jte,jde-1)
 216
 217  IF( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN
 218
 219  DO j =jts,jtf
 220  DO i =its,itf
 221
 222  g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(i-1,j))
 223  muu(i,j) =0.5*(mu(i,j) +mu(i-1,j))
 224
 225  ENDDO
 226  ENDDO
 227  ELSE IF( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN
 228
 229  DO j =jts,jtf
 230  DO i =its+1,itf
 231
 232  g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(i-1,j))
 233  muu(i,j) =0.5*(mu(i,j) +mu(i-1,j))
 234
 235  ENDDO
 236  ENDDO
 237
 238  i =its
 239
 240  im =its
 241
 242  if(config_flags%periodic_x) im =its-1
 243
 244  DO j =jts,jtf
 245
 246  g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(im,j))
 247  muu(i,j) =0.5*(mu(i,j) +mu(im,j))
 248
 249  ENDDO
 250  ELSE IF( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN
 251
 252  DO j =jts,jtf
 253  DO i =its,itf-1
 254
 255  g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(i-1,j))
 256  muu(i,j) =0.5*(mu(i,j) +mu(i-1,j))
 257
 258  ENDDO
 259  ENDDO
 260
 261  i =ite
 262
 263  im =ite-1
 264
 265  if(config_flags%periodic_x) im =ite
 266
 267  DO j =jts,jtf
 268
 269  g_muu(i,j) =0.5*(g_mu(i-1,j) +g_mu(im,j))
 270  muu(i,j) =0.5*(mu(i-1,j) +mu(im,j))
 271
 272  ENDDO
 273  ELSE IF( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN
 274
 275  DO j =jts,jtf
 276  DO i =its+1,itf-1
 277
 278  g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(i-1,j))
 279  muu(i,j) =0.5*(mu(i,j) +mu(i-1,j))
 280
 281  ENDDO
 282  ENDDO
 283
 284  i =its
 285
 286  im =its
 287
 288  if(config_flags%periodic_x) im =its-1
 289
 290  DO j =jts,jtf
 291
 292  g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(im,j))
 293  muu(i,j) =0.5*(mu(i,j) +mu(im,j))
 294
 295  ENDDO
 296
 297  i =ite
 298
 299  im =ite-1
 300
 301  if(config_flags%periodic_x) im =ite
 302
 303  DO j =jts,jtf
 304
 305  g_muu(i,j) =0.5*(g_mu(i-1,j) +g_mu(im,j))
 306  muu(i,j) =0.5*(mu(i-1,j) +mu(im,j))
 307
 308  ENDDO
 309  END IF
 310
 311  itf =min(ite,ide-1)
 312
 313  jtf =jte
 314
 315  IF( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN
 316
 317  DO j =jts,jtf
 318  DO i =its,itf
 319
 320  g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,j-1))
 321  muv(i,j) =0.5*(mu(i,j) +mu(i,j-1))
 322
 323  ENDDO
 324  ENDDO
 325  ELSE IF( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN
 326
 327  DO j =jts+1,jtf
 328  DO i =its,itf
 329
 330  g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,j-1))
 331  muv(i,j) =0.5*(mu(i,j) +mu(i,j-1))
 332
 333  ENDDO
 334  ENDDO
 335
 336  j =jts
 337
 338  jm =jts
 339
 340  if(config_flags%periodic_y) jm =jts-1
 341
 342  DO i =its,itf
 343
 344  g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,jm))
 345  muv(i,j) =0.5*(mu(i,j) +mu(i,jm))
 346
 347  ENDDO
 348  ELSE IF( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN
 349
 350  DO j =jts,jtf-1
 351  DO i =its,itf
 352
 353  g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,j-1))
 354  muv(i,j) =0.5*(mu(i,j) +mu(i,j-1))
 355
 356  ENDDO
 357  ENDDO
 358
 359  j =jte
 360
 361  jm =jte-1
 362
 363  if(config_flags%periodic_y) jm =jte
 364
 365  DO i =its,itf
 366
 367  g_muv(i,j) =0.5*(g_mu(i,j-1) +g_mu(i,jm))
 368  muv(i,j) =0.5*(mu(i,j-1) +mu(i,jm))
 369
 370  ENDDO
 371  ELSE IF( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN
 372
 373  DO j =jts+1,jtf-1
 374  DO i =its,itf
 375
 376  g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,j-1))
 377  muv(i,j) =0.5*(mu(i,j) +mu(i,j-1))
 378
 379  ENDDO
 380  ENDDO
 381
 382  j =jts
 383
 384  jm =jts
 385
 386  if(config_flags%periodic_y) jm =jts-1
 387
 388  DO i =its,itf
 389
 390  g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,jm))
 391  muv(i,j) =0.5*(mu(i,j) +mu(i,jm))
 392
 393  ENDDO
 394
 395  j =jte
 396
 397  jm =jte-1
 398
 399  if(config_flags%periodic_y) jm =jte
 400
 401  DO i =its,itf
 402
 403  g_muv(i,j) =0.5*(g_mu(i,j-1) +g_mu(i,jm))
 404  muv(i,j) =0.5*(mu(i,j-1) +mu(i,jm))
 405
 406  ENDDO
 407  END IF
 408
 409  END SUBROUTINE g_calc_mu_uv_1
 410
 411 !        Generated by TAPENADE     (INRIA, Tropics team)
 412 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
 413 !
 414 !  Differentiation of couple_momentum in forward (tangent) mode:
 415 !   variations   of useful results: ru rv rw
 416 !   with respect to varying inputs: u v w ru rv rw mut muu muv
 417 !   RW status of diff variables: u:in v:in w:in ru:in-out rv:in-out
 418 !                rw:in-out mut:in muu:in muv:in
 419 ! Map scale factor comments for this routine:
 420 ! Locally not changed, but sent the correct map scale factors
 421 ! from module_em (msfuy, msfvx, msfty)
 422 SUBROUTINE G_COUPLE_MOMENTUM(muu, muud, ru, rud, u, ud, msfu, muv, muvd&
 423 &  , rv, rvd, v, vd, msfv, msfv_inv, mut, mutd, rw, rwd, w, wd, msft, ids&
 424 &  , ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts&
 425 &  , jte, kts, kte)
 426   IMPLICIT NONE
 427 ! Input data
 428   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 429 &  jme, kms, kme, its, ite, jts, jte, kts, kte
 430   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: ru, rv, rw
 431   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rud, rvd, &
 432 &  rwd
 433   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: muu, muv, mut
 434   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: muud, muvd, mutd
 435   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfu, msfv, msft, &
 436 &  msfv_inv
 437   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u, v, w
 438   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ud, vd, wd
 439 ! Local data
 440   INTEGER :: i, j, k, itf, jtf, ktf
 441   IF (kte .GT. kde - 1) THEN
 442     ktf = kde - 1
 443   ELSE
 444     ktf = kte
 445   END IF
 446   itf = ite
 447   IF (jte .GT. jde - 1) THEN
 448     jtf = jde - 1
 449   ELSE
 450     jtf = jte
 451   END IF
 452   DO j=jts,jtf
 453     DO k=kts,ktf
 454       DO i=its,itf
 455         rud(i, k, j) = (ud(i, k, j)*muu(i, j)+u(i, k, j)*muud(i, j))/&
 456 &          msfu(i, j)
 457         ru(i, k, j) = u(i, k, j)*muu(i, j)/msfu(i, j)
 458       END DO
 459     END DO
 460   END DO
 461   IF (ite .GT. ide - 1) THEN
 462     itf = ide - 1
 463   ELSE
 464     itf = ite
 465   END IF
 466   jtf = jte
 467   DO j=jts,jtf
 468     DO k=kts,ktf
 469       DO i=its,itf
 470         rvd(i, k, j) = msfv_inv(i, j)*(vd(i, k, j)*muv(i, j)+v(i, k, j)*&
 471 &          muvd(i, j))
 472         rv(i, k, j) = v(i, k, j)*muv(i, j)*msfv_inv(i, j)
 473       END DO
 474     END DO
 475   END DO
 476   IF (ite .GT. ide - 1) THEN
 477     itf = ide - 1
 478   ELSE
 479     itf = ite
 480   END IF
 481   IF (jte .GT. jde - 1) THEN
 482     jtf = jde - 1
 483   ELSE
 484     jtf = jte
 485   END IF
 486   DO j=jts,jtf
 487     DO k=kts,kte
 488       DO i=its,itf
 489         rwd(i, k, j) = (wd(i, k, j)*mut(i, j)+w(i, k, j)*mutd(i, j))/&
 490 &          msft(i, j)
 491         rw(i, k, j) = w(i, k, j)*mut(i, j)/msft(i, j)
 492       END DO
 493     END DO
 494   END DO
 495 END SUBROUTINE G_COUPLE_MOMENTUM
 496
 497  SUBROUTINE g_calc_ww_cp(u,g_u,v,g_v,mup,g_mup,mub,ww,g_ww,rdx,rdy, &
 498  msftx,msfty,msfux,msfuy,msfvx,msfvx_inv,msfvy,dnw,ids,ide,jds,jde,kds,kde,ims,ime, &
 499  jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
 500
 501  IMPLICIT NONE
 502
 503  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
 504  g_Tmpv5,Tmpv6,g_Tmpv6,Tmpv7,g_Tmpv7,Tmpv8,g_Tmpv8
 505  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
 506  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,g_u,v,g_v
 507  REAL,DIMENSION(ims:ime,jms:jme) :: mup,g_mup,mub,msftx,msfty,msfux,msfuy,msfvx, &
 508  msfvy,msfvx_inv
 509  REAL,DIMENSION(kms:kme) :: dnw
 510  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ww,g_ww
 511  REAL :: rdx,rdy
 512
 513  INTEGER :: i,j,k,itf,jtf,ktf
 514  REAL,DIMENSION(its:ite) :: dmdt,g_dmdt
 515  REAL,DIMENSION(its:ite,kts:kte) :: divv,g_divv
 516  REAL,DIMENSION(its:ite+1,jts:jte+1) :: muu,g_muu,muv,g_muv
 517
 518  jtf =min(jte,jde-1)
 519
 520  ktf =min(kte,kde-1)
 521
 522  itf =min(ite,ide-1)
 523
 524  DO j =jts,jtf
 525  DO i =its,min(ite+1,ide)
 526
 527  g_muu(i,j) =0.5*(g_mup(i,j) +g_mup(i-1,j))/msfuy(i,j)
 528  muu(i,j) =0.5*(mup(i,j) +mub(i,j) +mup(i-1,j) +mub(i-1,j))/msfuy(i,j)
 529
 530  ENDDO
 531  ENDDO
 532
 533  DO j =jts,min(jte+1,jde)
 534  DO i =its,itf
 535
 536  g_muv(i,j) =0.5*(g_mup(i,j) +g_mup(i,j-1))*msfvx_inv(i,j)
 537  muv(i,j) =0.5*(mup(i,j) +mub(i,j) +mup(i,j-1) +mub(i,j-1))*msfvx_inv(i,j)
 538
 539  ENDDO
 540  ENDDO
 541
 542  DO j =jts,jtf
 543  DO i =its,ite
 544
 545  g_dmdt(i) =0.0
 546  dmdt(i) =0.
 547
 548  g_ww(i,1,j) =0.0
 549  ww(i,1,j) =0.
 550
 551  g_ww(i,kte,j) =0.0
 552  ww(i,kte,j) =0.
 553
 554  ENDDO
 555
 556  DO k =kts,ktf
 557  DO i =its,itf
 558
 559  g_Tmpv1 =muu(i+1,j)*g_u(i+1,k,j) +g_muu(i+1,j)*u(i+1,k,j)
 560  Tmpv1 =muu(i+1,j)*u(i+1,k,j)
 561
 562  g_Tmpv2 =muu(i,j)*g_u(i,k,j) +g_muu(i,j)*u(i,k,j)
 563  Tmpv2 =muu(i,j)*u(i,k,j)
 564
 565  g_Tmpv3 =muv(i,j+1)*g_v(i,k,j+1) +g_muv(i,j+1)*v(i,k,j+1)
 566  Tmpv3 =muv(i,j+1)*v(i,k,j+1)
 567
 568  g_Tmpv4 =muv(i,j)*g_v(i,k,j) +g_muv(i,j)*v(i,k,j)
 569  Tmpv4 =muv(i,j)*v(i,k,j)
 570
 571  g_divv(i,k) =msftx(i,j) *dnw(k)*(rdx*(g_Tmpv1 -g_Tmpv2) +rdy*(g_Tmpv3 - &
 572  g_Tmpv4))
 573  divv(i,k) =msftx(i,j) *dnw(k)*(rdx*(Tmpv1 -Tmpv2) +rdy*(Tmpv3 -Tmpv4))
 574
 575  g_dmdt(i) =g_dmdt(i) +g_divv(i,k)
 576  dmdt(i) =dmdt(i) +divv(i,k)
 577
 578  ENDDO
 579  ENDDO
 580
 581  DO k =2,ktf
 582  DO i =its,itf
 583
 584  g_ww(i,k,j) =g_ww(i,k-1,j) -dnw(k-1)*g_dmdt(i) -g_divv(i,k-1)
 585  ww(i,k,j) =ww(i,k-1,j) -dnw(k-1)*dmdt(i) -divv(i,k-1)
 586
 587  ENDDO
 588  ENDDO
 589  ENDDO
 590
 591  END SUBROUTINE g_calc_ww_cp
 592
 593 !        Generated by TAPENADE     (INRIA, Tropics team)
 594 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
 595 !
 596 !  Differentiation of calc_cq in forward (tangent) mode:
 597 !   variations   of useful results: cqu cqv cqw
 598 !   with respect to varying inputs: cqu cqv cqw moist
 599 !   RW status of diff variables: cqu:in-out cqv:in-out cqw:in-out
 600 !                moist:in
 601 SUBROUTINE G_CALC_CQ(moist, moistd, cqu, cqud, cqv, cqvd, cqw, cqwd, &
 602 &  n_moist, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, &
 603 &  its, ite, jts, jte, kts, kte)
 604   IMPLICIT NONE
 605 ! Input data
 606   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 607 &  jme, kms, kme, its, ite, jts, jte, kts, kte
 608   INTEGER, INTENT(IN) :: n_moist
 609   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
 610 &  moist
 611   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
 612 &  moistd
 613   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: cqu, cqv, &
 614 &  cqw
 615   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: cqud, cqvd&
 616 &  , cqwd
 617 ! Local stuff
 618 ! Changes from Larry Meadows, Intel Corp.  Improve vectorization of this routine
 619   REAL :: qtot(its:ite)
 620   REAL :: qtotd(its:ite)
 621   INTEGER :: i, j, k, itf, jtf, ktf, ispe
 622   IF (kte .GT. kde - 1) THEN
 623     ktf = kde - 1
 624   ELSE
 625     ktf = kte
 626   END IF
 627   IF (n_moist .GE. param_first_scalar) THEN
 628     itf = ite
 629     IF (jte .GT. jde - 1) THEN
 630       jtf = jde - 1
 631     ELSE
 632       jtf = jte
 633     END IF
 634     DO j=jts,jtf
 635       DO k=kts,ktf
 636         qtot = 0.
 637         qtotd = 0.0
 638         DO ispe=param_first_scalar,n_moist
 639           DO i=its,itf
 640             qtotd(i) = qtotd(i) + moistd(i, k, j, ispe) + moistd(i-1, k&
 641 &              , j, ispe)
 642             qtot(i) = qtot(i) + moist(i, k, j, ispe) + moist(i-1, k, j, &
 643 &              ispe)
 644           END DO
 645         END DO
 646         DO i=its,itf
 647           cqud(i, k, j) = -(0.5*qtotd(i)/(1.+0.5*qtot(i))**2)
 648           cqu(i, k, j) = 1./(1.+0.5*qtot(i))
 649         END DO
 650       END DO
 651     END DO
 652     IF (ite .GT. ide - 1) THEN
 653       itf = ide - 1
 654     ELSE
 655       itf = ite
 656     END IF
 657     jtf = jte
 658     DO j=jts,jtf
 659       DO k=kts,ktf
 660         qtot = 0.
 661         qtotd = 0.0
 662         DO ispe=param_first_scalar,n_moist
 663           DO i=its,itf
 664             qtotd(i) = qtotd(i) + moistd(i, k, j, ispe) + moistd(i, k, j&
 665 &              -1, ispe)
 666             qtot(i) = qtot(i) + moist(i, k, j, ispe) + moist(i, k, j-1, &
 667 &              ispe)
 668           END DO
 669         END DO
 670         DO i=its,itf
 671           cqvd(i, k, j) = -(0.5*qtotd(i)/(1.+0.5*qtot(i))**2)
 672           cqv(i, k, j) = 1./(1.+0.5*qtot(i))
 673         END DO
 674       END DO
 675     END DO
 676     IF (ite .GT. ide - 1) THEN
 677       itf = ide - 1
 678     ELSE
 679       itf = ite
 680     END IF
 681     IF (jte .GT. jde - 1) THEN
 682       jtf = jde - 1
 683     ELSE
 684       jtf = jte
 685     END IF
 686     DO j=jts,jtf
 687       DO k=kts+1,ktf
 688         qtot = 0.
 689         qtotd = 0.0
 690         DO ispe=param_first_scalar,n_moist
 691           DO i=its,itf
 692             qtotd(i) = qtotd(i) + moistd(i, k, j, ispe) + moistd(i, k-1&
 693 &              , j, ispe)
 694             qtot(i) = qtot(i) + moist(i, k, j, ispe) + moist(i, k-1, j, &
 695 &              ispe)
 696           END DO
 697         END DO
 698         DO i=its,itf
 699           cqwd(i, k, j) = 0.5*qtotd(i)
 700           cqw(i, k, j) = 0.5*qtot(i)
 701         END DO
 702       END DO
 703     END DO
 704   ELSE
 705     itf = ite
 706     IF (jte .GT. jde - 1) THEN
 707       jtf = jde - 1
 708     ELSE
 709       jtf = jte
 710     END IF
 711     DO j=jts,jtf
 712       DO k=kts,ktf
 713         DO i=its,itf
 714           cqud(i, k, j) = 0.0
 715           cqu(i, k, j) = 1.
 716         END DO
 717       END DO
 718     END DO
 719     IF (ite .GT. ide - 1) THEN
 720       itf = ide - 1
 721     ELSE
 722       itf = ite
 723     END IF
 724     jtf = jte
 725     DO j=jts,jtf
 726       DO k=kts,ktf
 727         DO i=its,itf
 728           cqvd(i, k, j) = 0.0
 729           cqv(i, k, j) = 1.
 730         END DO
 731       END DO
 732     END DO
 733     IF (ite .GT. ide - 1) THEN
 734       itf = ide - 1
 735     ELSE
 736       itf = ite
 737     END IF
 738     IF (jte .GT. jde - 1) THEN
 739       jtf = jde - 1
 740     ELSE
 741       jtf = jte
 742     END IF
 743     DO j=jts,jtf
 744       DO k=kts+1,ktf
 745         DO i=its,itf
 746           cqwd(i, k, j) = 0.0
 747           cqw(i, k, j) = 0.
 748         END DO
 749       END DO
 750     END DO
 751   END IF
 752 END SUBROUTINE G_CALC_CQ
 753
 754  SUBROUTINE g_calc_alt(alt,g_alt,al,g_al,alb,ids,ide,jds,jde,kds,kde,ims,ime, &
 755  jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
 756
 757  IMPLICIT NONE
 758
 759  REAL :: Tmpv1,g_Tmpv1
 760  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
 761  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: alb,al,g_al
 762  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: alt,g_alt
 763
 764  INTEGER :: i,j,k,itf,jtf,ktf
 765
 766  itf =min(ite,ide-1)
 767
 768  jtf =min(jte,jde-1)
 769
 770  ktf =min(kte,kde-1)
 771
 772  DO j =jts,jtf
 773  DO k =kts,ktf
 774  DO i =its,itf
 775
 776  g_alt(i,k,j) =g_al(i,k,j)
 777  alt(i,k,j) =al(i,k,j) +alb(i,k,j)
 778
 779  ENDDO
 780  ENDDO
 781  ENDDO
 782
 783  END SUBROUTINE g_calc_alt
 784
 785 !        Generated by TAPENADE     (INRIA, Tropics team)
 786 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
 787 !
 788 !  Differentiation of calc_p_rho_phi in forward (tangent) mode:
 789 !   variations   of useful results: p al ph
 790 !   with respect to varying inputs: p al t muts ph moist mu
 791 !   RW status of diff variables: p:in-out al:in-out t:in muts:in
 792 !                ph:in-out moist:in mu:in
 793 SUBROUTINE G_CALC_P_RHO_PHI(moist, moistd, n_moist, hypsometric_opt, al&
 794 &  , ald, alb, mu, mud, muts, mutsd, ph, phd, phb, p, pd, pb, t, td, p0, &
 795 &  t0, ptop, znu, znw, dnw, rdnw, rdn, non_hydrostatic, ids, ide, jds, &
 796 &  jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, &
 797 &  kte)
 798   IMPLICIT NONE
 799 ! Input data
 800   LOGICAL, INTENT(IN) :: non_hydrostatic
 801   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
 802 &  jme, kms, kme, its, ite, jts, jte, kts, kte
 803   INTEGER, INTENT(IN) :: n_moist
 804   INTEGER, INTENT(IN) :: hypsometric_opt
 805   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: alb, pb, t
 806   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: td
 807   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
 808 &  moist
 809   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
 810 &  moistd
 811   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: al, p
 812   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: ald, pd
 813   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ph, phb
 814   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: phd
 815   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, muts
 816   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mud, mutsd
 817   REAL, DIMENSION(kms:kme), INTENT(IN) :: znu, znw, dnw, rdnw, rdn
 818   REAL, INTENT(IN) :: t0, p0, ptop
 819 ! Local stuff
 820   INTEGER :: i, j, k, itf, jtf, ktf, ispe
 821   REAL :: qvf, qtot, qf1, qf2
 822   REAL :: qvfd, qtotd, qf1d
 823   REAL, DIMENSION(its:ite) :: temp, cpovcv_v
 824   REAL, DIMENSION(its:ite) :: tempd
 825   REAL :: pfu, phm, pfd
 826   REAL :: pfud, phmd, pfdd
 827   REAL :: pwx1
 828   REAL :: pwx1d
 829   REAL :: pwr1
 830   REAL :: pwr1d
 831   IF (ite .GT. ide - 1) THEN
 832     itf = ide - 1
 833   ELSE
 834     itf = ite
 835   END IF
 836   IF (jte .GT. jde - 1) THEN
 837     jtf = jde - 1
 838   ELSE
 839     jtf = jte
 840   END IF
 841   IF (kte .GT. kde - 1) THEN
 842     ktf = kde - 1
 843   ELSE
 844     ktf = kte
 845   END IF
 846 !#ifndef INTELMKL
 847   cpovcv_v = cpovcv
 848 !#endif
 849   IF (non_hydrostatic) THEN
 850     IF (hypsometric_opt .EQ. 1) THEN
 851       DO j=jts,jtf
 852         DO k=kts,ktf
 853           DO i=its,itf
 854             ald(i, k, j) = -((alb(i, k, j)*mud(i, j)+rdnw(k)*(phd(i, k+1&
 855 &              , j)-phd(i, k, j)))/muts(i, j)-mutsd(i, j)*(alb(i, k, j)*&
 856 &              mu(i, j)+rdnw(k)*(ph(i, k+1, j)-ph(i, k, j)))/muts(i, j)**&
 857 &              2)
 858             al(i, k, j) = -(1./muts(i, j)*(alb(i, k, j)*mu(i, j)+rdnw(k)&
 859 &              *(ph(i, k+1, j)-ph(i, k, j))))
 860           END DO
 861         END DO
 862       END DO
 863     ELSE IF (hypsometric_opt .EQ. 2) THEN
 864 ! The relation used to get specific volume, al, is: al = -dZ/dp,
 865 ! where dp = mut * d(eta). The pressure depth, dp, is replaced with
 866 ! p*(dp/p) ~ p*LOG((p+0.5dp)/(p-0.5dp)). Difference between dp and p*dLOG(p)
 867 ! is as follows: p*dLOG(p) - dp = 1/12*(dp/p)**3 + 1/90*(dp/p)**5 + ...
 868 ! Therefore, p*dLOG(p) is always larger than dp and the difference is
 869 ! in proportion to dp/p. TKW, 02/16/2010
 870       DO j=jts,jtf
 871         DO k=kts,ktf
 872           DO i=its,itf
 873             pfud = znw(k+1)*mutsd(i, j)
 874             pfu = muts(i, j)*znw(k+1) + ptop
 875             pfdd = znw(k)*mutsd(i, j)
 876             pfd = muts(i, j)*znw(k) + ptop
 877             phmd = znu(k)*mutsd(i, j)
 878             phm = muts(i, j)*znu(k) + ptop
 879             ald(i, k, j) = (((phd(i, k+1, j)-phd(i, k, j))*phm-(ph(i, k+&
 880 &              1, j)-ph(i, k, j)+phb(i, k+1, j)-phb(i, k, j))*phmd)*LOG(&
 881 &              pfd/pfu)/phm**2-(ph(i, k+1, j)-ph(i, k, j)+phb(i, k+1, j)-&
 882 &              phb(i, k, j))*(pfdd*pfu-pfd*pfud)/(phm*pfu*pfd))/LOG(pfd/&
 883 &              pfu)**2
 884             al(i, k, j) = (ph(i, k+1, j)-ph(i, k, j)+phb(i, k+1, j)-phb(&
 885 &              i, k, j))/phm/LOG(pfd/pfu) - alb(i, k, j)
 886           END DO
 887         END DO
 888       END DO
 889     ELSE
 890       CALL WRF_ERROR_FATAL(&
 891 &                     'calc_p_rho_phi: hypsometric_opt should be 1 or 2')
 892     END IF
 893     IF (n_moist .GE. param_first_scalar) THEN
 894       tempd = 0.0
 895       DO j=jts,jtf
 896         DO k=kts,ktf
 897           DO i=its,itf
 898             qvfd = rvovrd*moistd(i, k, j, p_qv)
 899             qvf = 1. + rvovrd*moist(i, k, j, p_qv)
 900             tempd(i) = (r_d*(td(i, k, j)*qvf+(t0+t(i, k, j))*qvfd)*p0*(&
 901 &              al(i, k, j)+alb(i, k, j))-r_d*(t0+t(i, k, j))*qvf*p0*ald(i&
 902 &              , k, j))/(p0*(al(i, k, j)+alb(i, k, j)))**2
 903             temp(i) = r_d*(t0+t(i, k, j))*qvf/(p0*(al(i, k, j)+alb(i, k&
 904 &              , j)))
 905           END DO
 906 !#ifdef INTELMKL
 907 !       CALL VPOWX ( itf-its+1, temp(its), cpovcv, p(its,k,j) )
 908 !#else
 909 ! use vector version from libmassv or from compat lib in frame/libmassv.F
 910           CALL G_VPOW(p(its, k, j), pd(its, k, j), temp(its), tempd(its)&
 911 &                , cpovcv_v(its), itf - its + 1)
 912 !#endif
 913           DO i=its,itf
 914             pd(i, k, j) = p0*pd(i, k, j)
 915             p(i, k, j) = p(i, k, j)*p0 - pb(i, k, j)
 916           END DO
 917         END DO
 918       END DO
 919     ELSE
 920       DO j=jts,jtf
 921         DO k=kts,ktf
 922           DO i=its,itf
 923             pwx1d = (r_d*td(i, k, j)*p0*(al(i, k, j)+alb(i, k, j))-r_d*(&
 924 &              t0+t(i, k, j))*p0*ald(i, k, j))/(p0*(al(i, k, j)+alb(i, k&
 925 &              , j)))**2
 926             pwx1 = r_d*(t0+t(i, k, j))/(p0*(al(i, k, j)+alb(i, k, j)))
 927             IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. cpovcv .EQ. INT(&
 928 &                cpovcv))) THEN
 929               pwr1d = cpovcv*pwx1**(cpovcv-1)*pwx1d
 930             ELSE IF (pwx1 .EQ. 0.0 .AND. cpovcv .EQ. 1.0) THEN
 931               pwr1d = pwx1d
 932             ELSE
 933               pwr1d = 0.0
 934             END IF
 935             pwr1 = pwx1**cpovcv
 936             pd(i, k, j) = p0*pwr1d
 937             p(i, k, j) = p0*pwr1 - pb(i, k, j)
 938           END DO
 939         END DO
 940       END DO
 941     END IF
 942   ELSE
 943 !  hydrostatic pressure, al, and ph1 calc; WCS, 5 sept 2001
 944     IF (n_moist .GE. param_first_scalar) THEN
 945       DO j=jts,jtf
 946 ! top layer
 947         k = ktf
 948         DO i=its,itf
 949           qtot = 0.
 950           qtotd = 0.0
 951           DO ispe=param_first_scalar,n_moist
 952             qtotd = qtotd + moistd(i, k, j, ispe)
 953             qtot = qtot + moist(i, k, j, ispe)
 954           END DO
 955           qf2 = 1.
 956           qf1d = qf2*qtotd
 957           qf1 = qtot*qf2
 958           pd(i, k, j) = -(0.5*(mud(i, j)+qf1d*muts(i, j)+qf1*mutsd(i, j)&
 959 &            )/rdnw(k)/qf2)
 960           p(i, k, j) = -(0.5*(mu(i, j)+qf1*muts(i, j))/rdnw(k)/qf2)
 961           qvfd = rvovrd*moistd(i, k, j, p_qv)
 962           qvf = 1. + rvovrd*moist(i, k, j, p_qv)
 963           pwx1d = pd(i, k, j)/p1000mb
 964           pwx1 = (p(i, k, j)+pb(i, k, j))/p1000mb
 965           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. cvpm .EQ. INT(cvpm&
 966 &              ))) THEN
 967             pwr1d = cvpm*pwx1**(cvpm-1)*pwx1d
 968           ELSE IF (pwx1 .EQ. 0.0 .AND. cvpm .EQ. 1.0) THEN
 969             pwr1d = pwx1d
 970           ELSE
 971             pwr1d = 0.0
 972           END IF
 973           pwr1 = pwx1**cvpm
 974           ald(i, k, j) = r_d*(td(i, k, j)*qvf*pwr1+(t(i, k, j)+t0)*(qvfd&
 975 &            *pwr1+qvf*pwr1d))/p1000mb
 976           al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*pwr1 - alb(i, k&
 977 &            , j)
 978         END DO
 979 ! remaining layers, integrate down
 980         DO k=ktf-1,kts,-1
 981           DO i=its,itf
 982             qtot = 0.
 983             qtotd = 0.0
 984             DO ispe=param_first_scalar,n_moist
 985               qtotd = qtotd + 0.5*(moistd(i, k, j, ispe)+moistd(i, k+1, &
 986 &                j, ispe))
 987               qtot = qtot + 0.5*(moist(i, k, j, ispe)+moist(i, k+1, j, &
 988 &                ispe))
 989             END DO
 990             qf2 = 1.
 991             qf1d = qf2*qtotd
 992             qf1 = qtot*qf2
 993             pd(i, k, j) = pd(i, k+1, j) - (mud(i, j)+qf1d*muts(i, j)+qf1&
 994 &              *mutsd(i, j))/qf2/rdn(k+1)
 995             p(i, k, j) = p(i, k+1, j) - (mu(i, j)+qf1*muts(i, j))/qf2/&
 996 &              rdn(k+1)
 997             qvfd = rvovrd*moistd(i, k, j, p_qv)
 998             qvf = 1. + rvovrd*moist(i, k, j, p_qv)
 999             pwx1d = pd(i, k, j)/p1000mb
1000             pwx1 = (p(i, k, j)+pb(i, k, j))/p1000mb
1001             IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. cvpm .EQ. INT(&
1002 &                cvpm))) THEN
1003               pwr1d = cvpm*pwx1**(cvpm-1)*pwx1d
1004             ELSE IF (pwx1 .EQ. 0.0 .AND. cvpm .EQ. 1.0) THEN
1005               pwr1d = pwx1d
1006             ELSE
1007               pwr1d = 0.0
1008             END IF
1009             pwr1 = pwx1**cvpm
1010             ald(i, k, j) = r_d*(td(i, k, j)*qvf*pwr1+(t(i, k, j)+t0)*(&
1011 &              qvfd*pwr1+qvf*pwr1d))/p1000mb
1012             al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*pwr1 - alb(i, &
1013 &              k, j)
1014           END DO
1015         END DO
1016       END DO
1017     ELSE
1018       DO j=jts,jtf
1019 ! top layer
1020         k = ktf
1021         DO i=its,itf
1022           qtot = 0.
1023           qf2 = 1.
1024           qf1 = qtot*qf2
1025           pd(i, k, j) = -(0.5*(mud(i, j)+qf1*mutsd(i, j))/rdnw(k)/qf2)
1026           p(i, k, j) = -(0.5*(mu(i, j)+qf1*muts(i, j))/rdnw(k)/qf2)
1027           qvf = 1.
1028           pwx1d = pd(i, k, j)/p1000mb
1029           pwx1 = (p(i, k, j)+pb(i, k, j))/p1000mb
1030           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. cvpm .EQ. INT(cvpm&
1031 &              ))) THEN
1032             pwr1d = cvpm*pwx1**(cvpm-1)*pwx1d
1033           ELSE IF (pwx1 .EQ. 0.0 .AND. cvpm .EQ. 1.0) THEN
1034             pwr1d = pwx1d
1035           ELSE
1036             pwr1d = 0.0
1037           END IF
1038           pwr1 = pwx1**cvpm
1039           ald(i, k, j) = r_d*qvf*(td(i, k, j)*pwr1+(t(i, k, j)+t0)*pwr1d&
1040 &            )/p1000mb
1041           al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*pwr1 - alb(i, k&
1042 &            , j)
1043         END DO
1044 ! remaining layers, integrate down
1045         DO k=ktf-1,kts,-1
1046           DO i=its,itf
1047             qtot = 0.
1048             qf2 = 1.
1049             qf1 = qtot*qf2
1050             pd(i, k, j) = pd(i, k+1, j) - (mud(i, j)+qf1*mutsd(i, j))/&
1051 &              qf2/rdn(k+1)
1052             p(i, k, j) = p(i, k+1, j) - (mu(i, j)+qf1*muts(i, j))/qf2/&
1053 &              rdn(k+1)
1054             qvf = 1.
1055             pwx1d = pd(i, k, j)/p1000mb
1056             pwx1 = (p(i, k, j)+pb(i, k, j))/p1000mb
1057             IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. cvpm .EQ. INT(&
1058 &                cvpm))) THEN
1059               pwr1d = cvpm*pwx1**(cvpm-1)*pwx1d
1060             ELSE IF (pwx1 .EQ. 0.0 .AND. cvpm .EQ. 1.0) THEN
1061               pwr1d = pwx1d
1062             ELSE
1063               pwr1d = 0.0
1064             END IF
1065             pwr1 = pwx1**cvpm
1066             ald(i, k, j) = r_d*qvf*(td(i, k, j)*pwr1+(t(i, k, j)+t0)*&
1067 &              pwr1d)/p1000mb
1068             al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*pwr1 - alb(i, &
1069 &              k, j)
1070           END DO
1071         END DO
1072       END DO
1073     END IF
1074     IF (hypsometric_opt .EQ. 1) THEN
1075       DO j=jts,jtf
1076 ! integrate hydrostatic equation for geopotential
1077         DO k=2,ktf+1
1078           DO i=its,itf
1079             phd(i, k, j) = phd(i, k-1, j) - dnw(k-1)*(mutsd(i, j)*al(i, &
1080 &              k-1, j)+muts(i, j)*ald(i, k-1, j)+alb(i, k-1, j)*mud(i, j)&
1081 &              )
1082             ph(i, k, j) = ph(i, k-1, j) - dnw(k-1)*(muts(i, j)*al(i, k-1&
1083 &              , j)+mu(i, j)*alb(i, k-1, j))
1084           END DO
1085         END DO
1086       END DO
1087     ELSE
1088 ! Revised hypsometric eq.: dZ=-al*p*dLOG(p), where p is dry pressure
1089       DO j=jts,jtf
1090         DO i=its,itf
1091           phd(i, kts, j) = 0.0
1092           ph(i, kts, j) = phb(i, kts, j)
1093         END DO
1094         DO k=kts+1,ktf+1
1095           DO i=its,itf
1096             pfud = znw(k)*mutsd(i, j)
1097             pfu = muts(i, j)*znw(k) + ptop
1098             pfdd = znw(k-1)*mutsd(i, j)
1099             pfd = muts(i, j)*znw(k-1) + ptop
1100             phmd = znu(k-1)*mutsd(i, j)
1101             phm = muts(i, j)*znu(k-1) + ptop
1102             phd(i, k, j) = phd(i, k-1, j) + (ald(i, k-1, j)*phm+(al(i, k&
1103 &              -1, j)+alb(i, k-1, j))*phmd)*LOG(pfd/pfu) + (al(i, k-1, j)&
1104 &              +alb(i, k-1, j))*phm*(pfdd*pfu-pfd*pfud)/(pfu*pfd)
1105             ph(i, k, j) = ph(i, k-1, j) + (al(i, k-1, j)+alb(i, k-1, j))&
1106 &              *phm*LOG(pfd/pfu)
1107           END DO
1108         END DO
1109         DO k=kts,ktf+1
1110           DO i=its,itf
1111             ph(i, k, j) = ph(i, k, j) - phb(i, k, j)
1112           END DO
1113         END DO
1114       END DO
1115     END IF
1116   END IF
1117 END SUBROUTINE G_CALC_P_RHO_PHI
1118
1119 !        Generated by TAPENADE     (INRIA, Tropics team)
1120 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
1121 !
1122 !  Differentiation of vpow in forward (tangent) mode:
1123 !   variations   of useful results: z
1124 !   with respect to varying inputs: y z
1125 SUBROUTINE G_VPOW(z, zd, y, yd, x, n)
1126   IMPLICIT NONE
1127   REAL :: x(*), y(*), z(*)
1128   REAL :: yd(*), zd(*)
1129   INTEGER :: j
1130   INTEGER :: n
1131   DO j=1,n
1132     IF (y(j) .GT. 0.0 .OR. (y(j) .LT. 0.0 .AND. x(j) .EQ. INT(x(j)))) &
1133 &    THEN
1134       zd(j) = x(j)*y(j)**(x(j)-1)*yd(j)
1135     ELSE IF (y(j) .EQ. 0.0 .AND. x(j) .EQ. 1.0) THEN
1136       zd(j) = yd(j)
1137     ELSE
1138       zd(j) = 0.0
1139     END IF
1140     z(j) = y(j)**x(j)
1141   END DO
1142   RETURN
1143 END SUBROUTINE G_VPOW
1144
1145  SUBROUTINE g_calc_php(php,g_php,ph,g_ph,phb,ids,ide,jds,jde,kds,kde,ims,ime, &
1146  jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1147
1148  IMPLICIT NONE
1149
1150  REAL :: Tmpv1,g_Tmpv1
1151  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
1152  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: phb,ph,g_ph
1153  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: php,g_php
1154
1155  INTEGER :: i,j,k,itf,jtf,ktf
1156
1157  itf =min(ite,ide-1)
1158
1159  jtf =min(jte,jde-1)
1160
1161  ktf =min(kte,kde-1)
1162
1163  DO j =jts,jtf
1164  DO k =kts,ktf
1165  DO i =its,itf
1166
1167  g_php(i,k,j) =0.5*(g_ph(i,k,j) +g_ph(i,k+1,j))
1168  php(i,k,j) =0.5*(phb(i,k,j)+phb(i,k+1,j) +ph(i,k,j) +ph(i,k+1,j))
1169
1170  ENDDO
1171  ENDDO
1172  ENDDO
1173
1174  END SUBROUTINE g_calc_php
1175
1176  SUBROUTINE g_diagnose_w(ph_tend,g_ph_tend,ph_new,g_ph_new,ph_old, &
1177  g_ph_old,w,g_w,mu,g_mu,dt,u,g_u,v,g_v,ht,cf1,cf2,cf3,rdx,rdy,msftx, &
1178  msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1179
1180  IMPLICIT NONE
1181
1182  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
1183  g_Tmpv5,Tmpv6,g_Tmpv6,Tmpv7,g_Tmpv7,Tmpv8,g_Tmpv8,Tmpv9,g_Tmpv9, &
1184  Tmpv10,g_Tmpv10,Tmpv11,g_Tmpv11,Tmpv12,g_Tmpv12,Tmpv13,g_Tmpv13,Tmpv14, &
1185  g_Tmpv14,Tmpv15,g_Tmpv15,Tmpv16,g_Tmpv16,Tmpv17,g_Tmpv17,Tmpv18, &
1186  g_Tmpv18,Tmpv19,g_Tmpv19,Tmpv20,g_Tmpv20
1187  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
1188  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ph_tend,g_ph_tend,ph_new,g_ph_new, &
1189  ph_old,g_ph_old,u,g_u,v,g_v
1190  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: w,g_w
1191  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu,ht,msftx,msfty
1192  REAL :: dt,cf1,cf2,cf3,rdx,rdy
1193  INTEGER :: i,j,k,itf,jtf
1194
1195  itf =min(ite,ide-1)
1196
1197  jtf =min(jte,jde-1)
1198
1199  DO j =jts,jtf
1200  DO i =its,itf
1201
1202  g_w(i,1,j) =msfty(i,j) *.5 *rdy*((ht(i,j+1)-ht(i,j))*(cf1*g_v(i,1,j+1) &
1203  +cf2*g_v(i,2,j+1) +cf3*g_v(i,3,j+1)) +(ht(i,j)-ht(i,j-1))*(cf1*g_v(i,1,j) &
1204  +cf2*g_v(i,2,j) +cf3*g_v(i,3,j))) +msftx(i,j) *.5 *rdx*((ht(i+1,j)-ht(i,j)) &
1205 *(cf1*g_u(i+1,1,j) +cf2*g_u(i+1,2,j) +cf3*g_u(i+1,3,j)) +(ht(i,j)-ht(i-1,j)) &
1206 *(cf1*g_u(i,1,j) +cf2*g_u(i,2,j) +cf3*g_u(i,3,j)))
1207  w(i,1,j) =msfty(i,j) *.5 *rdy*((ht(i,j+1)-ht(i,j))*(cf1*v(i,1,j+1) +cf2*v(i,2,j+1) &
1208  +cf3*v(i,3,j+1)) +(ht(i,j)-ht(i,j-1))*(cf1*v(i,1,j) +cf2*v(i,2,j) +cf3*v(i,3,j))) &
1209  +msftx(i,j) *.5 *rdx*((ht(i+1,j)-ht(i,j))*(cf1*u(i+1,1,j) +cf2*u(i+1,2,j) &
1210  +cf3*u(i+1,3,j)) +(ht(i,j)-ht(i-1,j))*(cf1*u(i,1,j) +cf2*u(i,2,j) +cf3*u(i,3,j)))
1211
1212  ENDDO
1213
1214  DO k =2,kte
1215  DO i =its,itf
1216
1217  g_Tmpv1 =(g_ph_tend(i,k,j)*mu(i,j) -g_mu(i,j)*ph_tend(i,k,j))/(mu(i,j)*mu(i,j))
1218  Tmpv1 =ph_tend(i,k,j)/mu(i,j)
1219
1220  g_w(i,k,j) =msfty(i,j)*((g_ph_new(i,k,j) -g_ph_old(i,k,j))/dt -g_Tmpv1)/g
1221  w(i,k,j) =msfty(i,j)*((ph_new(i,k,j) -ph_old(i,k,j))/dt -Tmpv1)/g
1222
1223  ENDDO
1224  ENDDO
1225  ENDDO
1226
1227  END SUBROUTINE g_diagnose_w
1228
1229  SUBROUTINE g_rhs_ph(ph_tend,g_ph_tend,u,g_u,v,g_v,ww,g_ww,ph,g_ph, &
1230  ph_old,g_ph_old,phb,w,g_w,mut,g_mut,muu,g_muu,muv,g_muv,fnm,fnp,rdnw, &
1231  cfn,cfn1,rdx,rdy,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,non_hydrostatic, &
1232  config_flags,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
1233
1234  IMPLICIT NONE
1235
1236  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
1237  g_Tmpv5,Tmpv6,g_Tmpv6,Tmpv7,g_Tmpv7,Tmpv8,g_Tmpv8,Tmpv9,g_Tmpv9, &
1238  Tmpv10,g_Tmpv10,Tmpv11,g_Tmpv11,Tmpv12,g_Tmpv12
1239  TYPE(grid_config_rec_type) :: config_flags
1240  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
1241  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,g_u,v,g_v,ww,g_ww,ph,g_ph, &
1242  ph_old,g_ph_old,phb,w,g_w
1243  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ph_tend,g_ph_tend
1244  REAL,DIMENSION(ims:ime,jms:jme) :: muu,g_muu,muv,g_muv,mut,g_mut,msfux, &
1245  msfuy,msfvx,msfvy,msftx,msfty,msfvx_inv
1246  REAL,DIMENSION(kms:kme) :: rdnw,fnm,fnp
1247  REAL :: cfn,cfn1,rdx,rdy
1248  LOGICAL :: non_hydrostatic
1249
1250  INTEGER :: i,j,k,itf,jtf,ktf,kz,i_start,j_start
1251  REAL :: ur,g_ur,ul,g_ul,ub,g_ub,vr,g_vr,vl,g_vl,vb,g_vb
1252  REAL,DIMENSION(its:ite,kts:kte) :: wdwn,g_wdwn
1253  INTEGER :: advective_order
1254  LOGICAL :: specified
1255
1256  specified =.false.
1257
1258  if(config_flags%specified .or. config_flags%nested) specified =.true.
1259
1260  advective_order =config_flags%h_sca_adv_order
1261
1262  itf =min(ite,ide-1)
1263
1264  jtf =min(jte,jde-1)
1265
1266  ktf =min(kte,kde-1)
1267
1268  DO j =jts,jtf
1269  DO k =2,kte
1270  DO i =its,itf
1271
1272  g_Tmpv1 =.5*(ww(i,k,j) +ww(i,k-1,j))*rdnw(k-1)*(g_ph(i,k,j) -g_ph(i,k-1,j)) &
1273  +.5*(g_ww(i,k,j) +g_ww(i,k-1,j))*rdnw(k-1)*(ph(i,k,j) -ph(i,k-1,j) +phb(i,k,j) &
1274  -phb(i,k-1,j))
1275  Tmpv1 =.5*(ww(i,k,j) +ww(i,k-1,j))*rdnw(k-1)*(ph(i,k,j) -ph(i,k-1,j) +phb(i,k,j) &
1276  -phb(i,k-1,j))
1277
1278  g_wdwn(i,k) =g_Tmpv1
1279  wdwn(i,k) =Tmpv1
1280
1281  ENDDO
1282  ENDDO
1283
1284  DO k =2,kte-1
1285  DO i =its,itf
1286
1287  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(fnm(k)*g_wdwn(i,k+1) +fnp(k)*g_wdwn(i,k))
1288  ph_tend(i,k,j) =ph_tend(i,k,j) -(fnm(k)*wdwn(i,k+1) +fnp(k)*wdwn(i,k))
1289
1290  ENDDO
1291  ENDDO
1292  ENDDO
1293
1294  IF(non_hydrostatic) THEN
1295
1296  DO j =jts,jtf
1297
1298  DO i =its,itf
1299
1300  g_ph_tend(i,kde,j) =0.0
1301  ph_tend(i,kde,j) =0.
1302
1303  ENDDO
1304
1305  DO k =2,kte
1306  DO i =its,itf
1307
1308  g_Tmpv1 =mut(i,j)*g*g_w(i,k,j) +g_mut(i,j)*g*w(i,k,j)
1309  Tmpv1 =mut(i,j)*g*w(i,k,j)
1310
1311  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) +(g_Tmpv1/msfty(i,j))
1312  ph_tend(i,k,j) =ph_tend(i,k,j) +Tmpv1/msfty(i,j)
1313
1314  ENDDO
1315  ENDDO
1316  ENDDO
1317  END IF
1318
1319  IF(advective_order <= 2) THEN
1320
1321  i_start =its
1322
1323  j_start =jts
1324
1325  itf =min(ite,ide-1)
1326
1327  jtf =min(jte,jde-1)
1328
1329  IF( (config_flags%open_ys .or. specified) .and. jts == jds ) j_start =jts+1
1330
1331  IF( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf =jtf-2
1332
1333  DO j =j_start,jtf
1334  DO k =2,kte-1
1335  DO i =i_start,itf
1336
1337  g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
1338 *(v(i,k,j+1) +v(i,k-1,j+1))
1339  Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))
1340
1341  g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
1342  i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1343  Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1344
1345  g_Tmpv3 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1346  Tmpv3 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1347
1348  g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
1349  j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1350  Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1351
1352  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1353  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)
1354
1355  ENDDO
1356  ENDDO
1357
1358  k =kte
1359
1360  DO i =i_start,itf
1361
1362  g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
1363  +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1364  Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1365
1366  g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
1367  i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1368  Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1369
1370  g_Tmpv3 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
1371 *(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1372  Tmpv3 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1373
1374  g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
1375  j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1376  Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1377
1378  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1379  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)
1380
1381  ENDDO
1382  ENDDO
1383
1384  i_start =its
1385
1386  j_start =jts
1387
1388  itf =min(ite,ide-1)
1389
1390  jtf =min(jte,jde-1)
1391
1392  IF( (config_flags%open_xs .or. specified) .and. its == ids ) i_start =its+1
1393
1394  IF( (config_flags%open_xe .or. specified) .and. ite == ide ) itf =itf-2
1395
1396  DO j =j_start,jtf
1397  DO k =2,kte-1
1398  DO i =i_start,itf
1399
1400  g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
1401 *(u(i+1,k,j) +u(i+1,k-1,j))
1402  Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))
1403
1404  g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
1405  i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1406  Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1407
1408  g_Tmpv3 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j))
1409  Tmpv3 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))
1410
1411  g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
1412  j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1413  Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1414
1415  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1416  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)
1417
1418  ENDDO
1419  ENDDO
1420
1421  k =kte
1422
1423  DO i =i_start,itf
1424
1425  g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
1426  +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
1427  Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
1428
1429  g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
1430  i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1431  Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1432
1433  g_Tmpv3 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
1434 *(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
1435  Tmpv3 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
1436
1437  g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
1438  j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1439  Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1440
1441  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1442  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)
1443
1444  ENDDO
1445  ENDDO
1446  ELSE IF(advective_order <= 4) THEN
1447
1448  i_start =its
1449
1450  j_start =jts
1451
1452  itf =min(ite,ide-1)
1453
1454  jtf =min(jte,jde-1)
1455
1456  IF( (config_flags%open_ys .or. specified) .and. jts == jds ) j_start =jts+2
1457
1458  IF( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf =jtf-3
1459
1460  DO j =j_start,jtf
1461  DO k =2,kte-1
1462  DO i =i_start,itf
1463
1464  g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
1465 *(v(i,k,j+1) +v(i,k-1,j+1))
1466  Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))
1467
1468  g_Tmpv2 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1469  Tmpv2 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1470
1471  g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
1472  -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
1473  +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
1474  -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2)))
1475  Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
1476  -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
1477  -(phb(i,k,j+2)-phb(i,k,j-2)))
1478
1479  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv3)
1480  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv3)
1481
1482  ENDDO
1483  ENDDO
1484
1485  k =kte
1486
1487  DO i =i_start,itf
1488
1489  g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
1490  +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1491  Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1492
1493  g_Tmpv2 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
1494 *(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1495  Tmpv2 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1496
1497  g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
1498  -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
1499  +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
1500  -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2)))
1501  Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
1502  -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
1503  -(phb(i,k,j+2)-phb(i,k,j-2)))
1504
1505  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv3)
1506  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv3)
1507
1508  ENDDO
1509  ENDDO
1510
1511  IF( (config_flags%open_ys .or. specified) .and. jts <= jds+1 ) THEN
1512
1513  j =jds+1
1514
1515  DO k =2,kte-1
1516  DO i =i_start,itf
1517
1518  g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
1519 *(v(i,k,j+1) +v(i,k-1,j+1))
1520  Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))
1521
1522  g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
1523  i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1524  Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1525
1526  g_Tmpv3 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1527  Tmpv3 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1528
1529  g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
1530  j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1531  Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1532
1533  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1534  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)
1535
1536  ENDDO
1537  ENDDO
1538
1539  k =kte
1540
1541  DO i =i_start,itf
1542
1543  g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
1544  +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1545  Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1546
1547  g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
1548  i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1549  Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1550
1551  g_Tmpv3 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
1552 *(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1553  Tmpv3 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1554
1555  g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
1556  j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1557  Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1558
1559  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1560  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)
1561
1562  ENDDO
1563  END IF
1564
1565  IF( (config_flags%open_ye .or. specified) .and. jte >= jde-2 ) THEN
1566
1567  j =jde-2
1568
1569  DO k =2,kte-1
1570  DO i =i_start,itf
1571
1572  g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
1573 *(v(i,k,j+1) +v(i,k-1,j+1))
1574  Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))
1575
1576  g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
1577  i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1578  Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1579
1580  g_Tmpv3 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1581  Tmpv3 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1582
1583  g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
1584  j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1585  Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1586
1587  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1588  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)
1589
1590  ENDDO
1591  ENDDO
1592
1593  k =kte
1594
1595  DO i =i_start,itf
1596
1597  g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
1598  +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1599  Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1600
1601  g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
1602  i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1603  Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1604
1605  g_Tmpv3 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
1606 *(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1607  Tmpv3 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1608
1609  g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
1610  j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1611  Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1612
1613  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1614  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)
1615
1616  ENDDO
1617  END IF
1618
1619  i_start =its
1620
1621  j_start =jts
1622
1623  itf =min(ite,ide-1)
1624
1625  jtf =min(jte,jde-1)
1626
1627  IF( (config_flags%open_xs) .and. its == ids ) i_start =its+2
1628
1629  IF( (config_flags%open_xe) .and. ite == ide ) itf =itf-3
1630
1631  DO j =j_start,jtf
1632  DO k =2,kte-1
1633  DO i =i_start,itf
1634
1635  g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
1636 *(u(i+1,k,j) +u(i+1,k-1,j))
1637  Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))
1638
1639  g_Tmpv2 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j))
1640  Tmpv2 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))
1641
1642  g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
1643  -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
1644  +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
1645  -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j)))
1646  Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
1647  -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
1648  -(phb(i+2,k,j)-phb(i-2,k,j)))
1649
1650  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv3)
1651  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv3)
1652
1653  ENDDO
1654  ENDDO
1655
1656  k =kte
1657
1658  DO i =i_start,itf
1659
1660  g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
1661  +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
1662  Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
1663
1664  g_Tmpv2 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
1665 *(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
1666  Tmpv2 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
1667
1668  g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
1669  -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
1670  +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
1671  -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j)))
1672  Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
1673  -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
1674  -(phb(i+2,k,j)-phb(i-2,k,j)))
1675
1676  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv3)
1677  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv3)
1678
1679  ENDDO
1680  ENDDO
1681
1682  IF( (config_flags%open_xs .or. specified) .and. its <= ids+1 ) THEN
1683
1684  i =ids+1
1685
1686  DO j =j_start,jtf
1687  DO k =2,kte-1
1688
1689  g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
1690 *(u(i+1,k,j) +u(i+1,k-1,j))
1691  Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))
1692
1693  g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
1694  i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1695  Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1696
1697  g_Tmpv3 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j))
1698  Tmpv3 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))
1699
1700  g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
1701  j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1702  Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1703
1704  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1705  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)
1706
1707  ENDDO
1708  ENDDO
1709
1710  k =kte
1711
1712  DO j =j_start,jtf
1713
1714  g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
1715  +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
1716  Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
1717
1718  g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
1719  i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1720  Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1721
1722  g_Tmpv3 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
1723 *(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
1724  Tmpv3 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
1725
1726  g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
1727  j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1728  Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1729
1730  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1731  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)
1732
1733  ENDDO
1734  END IF
1735
1736  IF( (config_flags%open_xe .or. specified) .and. ite >= ide-2 ) THEN
1737
1738  i =ide-2
1739
1740  DO j =j_start,jtf
1741  DO k =2,kte-1
1742
1743  g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
1744 *(u(i+1,k,j) +u(i+1,k-1,j))
1745  Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))
1746
1747  g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
1748  i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1749  Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1750
1751  g_Tmpv3 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j))
1752  Tmpv3 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))
1753
1754  g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
1755  j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1756  Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1757
1758  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1759  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)
1760
1761  ENDDO
1762  ENDDO
1763
1764  k =kte
1765
1766  DO j =j_start,jtf
1767
1768  g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
1769  +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
1770  Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
1771
1772  g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
1773  i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1774  Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
1775
1776  g_Tmpv3 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
1777 *(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
1778  Tmpv3 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
1779
1780  g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
1781  j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1782  Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
1783
1784  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1785  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)
1786
1787  ENDDO
1788  END IF
1789  ELSE IF(advective_order <= 6) THEN
1790
1791  i_start =its
1792
1793  j_start =jts
1794
1795  itf =min(ite,ide-1)
1796
1797  jtf =min(jte,jde-1)
1798
1799  IF(config_flags%open_ys .or. specified ) j_start =max(jts,jds+3)
1800
1801  IF(config_flags%open_ye .or. specified ) jtf =min(jtf,jde-4)
1802
1803  DO j =j_start,jtf
1804  DO k =2,kte-1
1805  DO i =i_start,itf
1806
1807  g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
1808 *(v(i,k,j+1) +v(i,k-1,j+1))
1809  Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))
1810
1811  g_Tmpv2 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1812  Tmpv2 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1813
1814  g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./60.)*(45.*(g_ph(i,k,j+1) &
1815  -g_ph(i,k,j-1)) -9.*(g_ph(i,k,j+2) -g_ph(i,k,j-2)) +(g_ph(i,k,j+3) &
1816  -g_ph(i,k,j-3))) +(g_Tmpv1*msfvy(i,j+1) +g_Tmpv2*msfvy(i,j))*(1./60.) &
1817 *(45.*(ph(i,k,j+1) -ph(i,k,j-1)) -9.*(ph(i,k,j+2) -ph(i,k,j-2)) +(ph(i,k,j+3) &
1818  -ph(i,k,j-3)) +45. *(phb(i,k,j+1)-phb(i,k,j-1)) -9. *(phb(i,k,j+2)-phb(i,k,j-2)) &
1819  +(phb(i,k,j+3)-phb(i,k,j-3)))
1820  Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./60.)*(45.*(ph(i,k,j+1) &
1821  -ph(i,k,j-1)) -9.*(ph(i,k,j+2) -ph(i,k,j-2)) +(ph(i,k,j+3) -ph(i,k,j-3)) &
1822  +45. *(phb(i,k,j+1)-phb(i,k,j-1)) -9. *(phb(i,k,j+2)-phb(i,k,j-2)) +(phb(i,k,j+3) &
1823 -phb(i,k,j-3)))
1824
1825  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv3)
1826  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv3)
1827
1828  ENDDO
1829  ENDDO
1830
1831  k =kte
1832
1833  DO i =i_start,itf
1834
1835  g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
1836  +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1837  Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1838
1839  g_Tmpv2 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
1840 *(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1841  Tmpv2 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1842
1843  g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./60.)*(45.*(g_ph(i,k,j+1) &
1844  -g_ph(i,k,j-1)) -9.*(g_ph(i,k,j+2) -g_ph(i,k,j-2)) +(g_ph(i,k,j+3) &
1845  -g_ph(i,k,j-3))) +(g_Tmpv1*msfvy(i,j+1) +g_Tmpv2*msfvy(i,j))*(1./60.) &
1846 *(45.*(ph(i,k,j+1) -ph(i,k,j-1)) -9.*(ph(i,k,j+2) -ph(i,k,j-2)) +(ph(i,k,j+3) &
1847  -ph(i,k,j-3)) +45. *(phb(i,k,j+1)-phb(i,k,j-1)) -9. *(phb(i,k,j+2)-phb(i,k,j-2)) &
1848  +(phb(i,k,j+3)-phb(i,k,j-3)))
1849  Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./60.)*(45.*(ph(i,k,j+1) &
1850  -ph(i,k,j-1)) -9.*(ph(i,k,j+2) -ph(i,k,j-2)) +(ph(i,k,j+3) -ph(i,k,j-3)) &
1851  +45. *(phb(i,k,j+1)-phb(i,k,j-1)) -9. *(phb(i,k,j+2)-phb(i,k,j-2)) +(phb(i,k,j+3) &
1852 -phb(i,k,j-3)))
1853
1854  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv3)
1855  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv3)
1856
1857  ENDDO
1858  ENDDO
1859
1860  IF( (config_flags%open_ys .or. specified) .and. jts <= jds+2 .and. jds+2 <= jte ) THEN
1861
1862  j =jds+2
1863
1864  DO k =2,kte-1
1865  DO i =i_start,itf
1866
1867  g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
1868 *(v(i,k,j+1) +v(i,k-1,j+1))
1869  Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))
1870
1871  g_Tmpv2 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1872  Tmpv2 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1873
1874  g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
1875  -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
1876  +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
1877  -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2)))
1878  Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
1879  -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
1880  -(phb(i,k,j+2)-phb(i,k,j-2)))
1881
1882  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv3)
1883  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv3)
1884
1885  ENDDO
1886  ENDDO
1887
1888  k =kte
1889
1890  DO i =i_start,itf
1891
1892  g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
1893  +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1894  Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1895
1896  g_Tmpv2 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
1897 *(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1898  Tmpv2 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1899
1900  g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
1901  -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
1902  +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
1903  -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2)))
1904  Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
1905  -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
1906  -(phb(i,k,j+2)-phb(i,k,j-2)))
1907
1908  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv3)
1909  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv3)
1910
1911  ENDDO
1912  END IF
1913
1914  IF( (config_flags%open_ye .or. specified) .and. jts <= jde-3 .and. jde-3 <= jte ) THEN
1915
1916  j =jde-3
1917
1918  DO k =2,kte-1
1919  DO i =i_start,itf
1920
1921  g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
1922 *(v(i,k,j+1) +v(i,k-1,j+1))
1923  Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))
1924
1925  g_Tmpv2 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1926  Tmpv2 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1927
1928  g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
1929  -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
1930  +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
1931  -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2)))
1932  Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
1933  -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
1934  -(phb(i,k,j+2)-phb(i,k,j-2)))
1935
1936  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv3)
1937  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv3)
1938
1939  ENDDO
1940  ENDDO
1941
1942  k =kte
1943
1944  DO i =i_start,itf
1945
1946  g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
1947  +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1948  Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
1949
1950  g_Tmpv2 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
1951 *(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1952  Tmpv2 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
1953
1954  g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
1955  -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
1956  +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
1957  -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2)))
1958  Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
1959  -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
1960  -(phb(i,k,j+2)-phb(i,k,j-2)))
1961
1962  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv3)
1963  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv3)
1964
1965  ENDDO
1966  END IF
1967
1968  IF( (config_flags%open_ys .or. specified) .and. jts <= jds+1 .and. jds+1 <= jte ) THEN
1969
1970  j =jds+1
1971
1972  DO k =2,kte-1
1973  DO i =i_start,itf
1974
1975  g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
1976 *(v(i,k,j+1) +v(i,k-1,j+1))
1977  Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))
1978
1979  g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
1980  i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1981  Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
1982
1983  g_Tmpv3 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1984  Tmpv3 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))
1985
1986  g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
1987  j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1988  Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
1989
1990  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
1991  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)
1992
1993  ENDDO
1994  ENDDO
1995
1996  k =kte
1997
1998  DO i =i_start,itf
1999
2000  g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
2001  +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
2002  Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
2003
2004  g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
2005  i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
2006  Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
2007
2008  g_Tmpv3 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
2009 *(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
2010  Tmpv3 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
2011
2012  g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
2013  j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
2014  Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
2015
2016  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
2017  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)
2018
2019  ENDDO
2020  END IF
2021
2022  IF( (config_flags%open_ye .or. specified) .and. jts <= jde-2 .and. jde-2 <= jte ) THEN
2023
2024  j =jde-2
2025
2026  DO k =2,kte-1
2027  DO i =i_start,itf
2028
2029  g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
2030 *(v(i,k,j+1) +v(i,k-1,j+1))
2031  Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))
2032
2033  g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
2034  i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
2035  Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
2036
2037  g_Tmpv3 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j))
2038  Tmpv3 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))
2039
2040  g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
2041  j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
2042  Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
2043
2044  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
2045  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)
2046
2047  ENDDO
2048  ENDDO
2049
2050  k =kte
2051
2052  DO i =i_start,itf
2053
2054  g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
2055  +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
2056  Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))
2057
2058  g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
2059  i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
2060  Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))
2061
2062  g_Tmpv3 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
2063 *(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
2064  Tmpv3 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))
2065
2066  g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
2067  j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
2068  Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))
2069
2070  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
2071  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)
2072
2073  ENDDO
2074  END IF
2075
2076  i_start =its
2077
2078  j_start =jts
2079
2080  itf =min(ite,ide-1)
2081
2082  jtf =min(jte,jde-1)
2083
2084  IF(config_flags%open_xs .or. specified ) i_start =max(its,ids+3)
2085
2086  IF(config_flags%open_xe .or. specified ) itf =min(itf,ide-4)
2087
2088  DO j =j_start,jtf
2089  DO k =2,kte-1
2090  DO i =i_start,itf
2091
2092  g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
2093 *(u(i+1,k,j) +u(i+1,k-1,j))
2094  Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))
2095
2096  g_Tmpv2 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j))
2097  Tmpv2 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))
2098
2099  g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./60.)*(45.*(g_ph(i+1,k,j) &
2100  -g_ph(i-1,k,j)) -9.*(g_ph(i+2,k,j) -g_ph(i-2,k,j)) +(g_ph(i+3,k,j) &
2101  -g_ph(i-3,k,j))) +(g_Tmpv1*msfux(i+1,j) +g_Tmpv2*msfux(i,j))*(1./60.) &
2102 *(45.*(ph(i+1,k,j) -ph(i-1,k,j)) -9.*(ph(i+2,k,j) -ph(i-2,k,j)) +(ph(i+3,k,j) &
2103  -ph(i-3,k,j)) +45. *(phb(i+1,k,j)-phb(i-1,k,j)) -9. *(phb(i+2,k,j)-phb(i-2,k,j)) &
2104  +(phb(i+3,k,j)-phb(i-3,k,j)))
2105  Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./60.)*(45.*(ph(i+1,k,j) &
2106  -ph(i-1,k,j)) -9.*(ph(i+2,k,j) -ph(i-2,k,j)) +(ph(i+3,k,j) -ph(i-3,k,j)) &
2107  +45. *(phb(i+1,k,j)-phb(i-1,k,j)) -9. *(phb(i+2,k,j)-phb(i-2,k,j)) +(phb(i+3,k,j) &
2108 -phb(i-3,k,j)))
2109
2110  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv3)
2111  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv3)
2112
2113  ENDDO
2114  ENDDO
2115
2116  k =kte
2117
2118  DO i =i_start,itf
2119
2120  g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
2121  +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
2122  Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
2123
2124  g_Tmpv2 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
2125 *(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
2126  Tmpv2 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
2127
2128  g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./60.)*(45.*(g_ph(i+1,k,j) &
2129  -g_ph(i-1,k,j)) -9.*(g_ph(i+2,k,j) -g_ph(i-2,k,j)) +(g_ph(i+3,k,j) &
2130  -g_ph(i-3,k,j))) +(g_Tmpv1*msfux(i+1,j) +g_Tmpv2*msfux(i,j))*(1./60.) &
2131 *(45.*(ph(i+1,k,j) -ph(i-1,k,j)) -9.*(ph(i+2,k,j) -ph(i-2,k,j)) +(ph(i+3,k,j) &
2132  -ph(i-3,k,j)) +45. *(phb(i+1,k,j)-phb(i-1,k,j)) -9. *(phb(i+2,k,j)-phb(i-2,k,j)) &
2133  +(phb(i+3,k,j)-phb(i-3,k,j)))
2134  Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./60.)*(45.*(ph(i+1,k,j) &
2135  -ph(i-1,k,j)) -9.*(ph(i+2,k,j) -ph(i-2,k,j)) +(ph(i+3,k,j) -ph(i-3,k,j)) &
2136  +45. *(phb(i+1,k,j)-phb(i-1,k,j)) -9. *(phb(i+2,k,j)-phb(i-2,k,j)) +(phb(i+3,k,j) &
2137 -phb(i-3,k,j)))
2138
2139  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv3)
2140  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv3)
2141
2142  ENDDO
2143  ENDDO
2144
2145  IF( (config_flags%open_xs) .and. its <= ids+2 .and. ids+2 <= ite ) THEN
2146
2147  i =ids+2
2148
2149  DO j =j_start,jtf
2150  DO k =2,kte-1
2151
2152  g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
2153 *(u(i+1,k,j) +u(i+1,k-1,j))
2154  Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))
2155
2156  g_Tmpv2 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j))
2157  Tmpv2 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))
2158
2159  g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
2160  -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
2161  +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
2162  -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j)))
2163  Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
2164  -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
2165  -(phb(i+2,k,j)-phb(i-2,k,j)))
2166
2167  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv3)
2168  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv3)
2169
2170  ENDDO
2171
2172  k =kte
2173
2174  g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
2175  +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
2176  Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
2177
2178  g_Tmpv2 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
2179 *(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
2180  Tmpv2 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
2181
2182  g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
2183  -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
2184  +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
2185  -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j)))
2186  Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
2187  -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
2188  -(phb(i+2,k,j)-phb(i-2,k,j)))
2189
2190  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv3)
2191  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv3)
2192
2193  ENDDO
2194  END IF
2195
2196  IF( (config_flags%open_xe) .and. its <= ide-3 .and. ide-3 <= ite ) THEN
2197
2198  i =ide-3
2199
2200  DO j =j_start,jtf
2201  DO k =2,kte-1
2202
2203  g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
2204 *(u(i+1,k,j) +u(i+1,k-1,j))
2205  Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))
2206
2207  g_Tmpv2 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j))
2208  Tmpv2 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))
2209
2210  g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
2211  -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
2212  +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
2213  -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j)))
2214  Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
2215  -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
2216  -(phb(i+2,k,j)-phb(i-2,k,j)))
2217
2218  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv3)
2219  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv3)
2220
2221  ENDDO
2222
2223  k =kte
2224
2225  g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
2226  +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
2227  Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
2228
2229  g_Tmpv2 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
2230 *(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
2231  Tmpv2 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
2232
2233  g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
2234  -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
2235  +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
2236  -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j)))
2237  Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
2238  -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
2239  -(phb(i+2,k,j)-phb(i-2,k,j)))
2240
2241  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv3)
2242  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv3)
2243
2244  ENDDO
2245  END IF
2246
2247  IF( (config_flags%open_xs .or. specified) .and. its <= ids+1 .and. ids+1 <= ite ) THEN
2248
2249  i =ids+1
2250
2251  DO j =j_start,jtf
2252  DO k =2,kte-1
2253
2254  g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
2255 *(u(i+1,k,j) +u(i+1,k-1,j))
2256  Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))
2257
2258  g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
2259  i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
2260  Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
2261
2262  g_Tmpv3 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j))
2263  Tmpv3 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))
2264
2265  g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
2266  j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
2267  Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
2268
2269  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
2270  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)
2271
2272  ENDDO
2273  ENDDO
2274
2275  k =kte
2276
2277  DO j =j_start,jtf
2278
2279  g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
2280  +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
2281  Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
2282
2283  g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
2284  i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
2285  Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
2286
2287  g_Tmpv3 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
2288 *(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
2289  Tmpv3 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
2290
2291  g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
2292  j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
2293  Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
2294
2295  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
2296  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)
2297
2298  ENDDO
2299  END IF
2300
2301  IF( (config_flags%open_xe .or. specified) .and. its <= ide-2 .and. ide-2 <= ite ) THEN
2302
2303  i =ide-2
2304
2305  DO j =j_start,jtf
2306  DO k =2,kte-1
2307
2308  g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
2309 *(u(i+1,k,j) +u(i+1,k-1,j))
2310  Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))
2311
2312  g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
2313  i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
2314  Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
2315
2316  g_Tmpv3 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j))
2317  Tmpv3 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))
2318
2319  g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
2320  j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
2321  Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
2322
2323  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
2324  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)
2325
2326  ENDDO
2327  ENDDO
2328
2329  k =kte
2330
2331  DO j =j_start,jtf
2332
2333  g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
2334  +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
2335  Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))
2336
2337  g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
2338  i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
2339  Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))
2340
2341  g_Tmpv3 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
2342 *(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
2343  Tmpv3 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))
2344
2345  g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
2346  j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
2347  Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))
2348
2349  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
2350  ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)
2351
2352  ENDDO
2353  END IF
2354
2355  END IF
2356
2357  i_start =its
2358
2359  itf =min(ite,ide-1)
2360
2361  IF( (config_flags%open_ys) .and. jts == jds ) THEN
2362
2363  j =jts
2364
2365  DO k =2,kde
2366
2367  kz =min(k,kde-1)
2368
2369  DO i =its,itf
2370
2371  g_vb =.5*(fnm(kz)*(g_v(i,kz,j+1) +g_v(i,kz,j)) +fnp(kz)*(g_v(i,kz-1,j+1) &
2372  +g_v(i,kz-1,j)))
2373  vb =.5*(fnm(kz)*(v(i,kz,j+1) +v(i,kz,j)) +fnp(kz)*(v(i,kz-1,j+1) +v(i,kz-1,j)))
2374
2375  g_vl =(g_vb +0.0 -(g_vb -0.0)*sign(1.0, vb -(0.)))*0.5
2376 ! Revised by Ning Pan, 2010-07-21
2377 ! vl =min(vb,0.)
2378  vl =amin1(vb,0.)
2379
2380  g_Tmpv1 =vl*(g_ph_old(i,k,j+1) -g_ph_old(i,k,j)) +g_vl*(ph_old(i,k,j+1) &
2381  -ph_old(i,k,j))
2382  Tmpv1 =vl*(ph_old(i,k,j+1) -ph_old(i,k,j))
2383
2384  g_Tmpv2 =rdy*mut(i,j)*(g_Tmpv1) +rdy*g_mut(i,j)*(Tmpv1)
2385  Tmpv2 =rdy*mut(i,j)*(Tmpv1)
2386
2387  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
2388  ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2
2389
2390  ENDDO
2391  ENDDO
2392  END IF
2393
2394  IF( (config_flags%open_ye) .and. jte == jde ) THEN
2395
2396  j =jte-1
2397
2398  DO k =2,kde
2399
2400  kz =min(k,kde-1)
2401
2402  DO i =its,itf
2403
2404  g_vb =.5*(fnm(kz)*(g_v(i,kz,j+1) +g_v(i,kz,j)) +fnp(kz)*(g_v(i,kz-1,j+1) &
2405  +g_v(i,kz-1,j)))
2406  vb =.5*(fnm(kz)*(v(i,kz,j+1) +v(i,kz,j)) +fnp(kz)*(v(i,kz-1,j+1) +v(i,kz-1,j)))
2407
2408  g_vr =(g_vb +0.0 +(g_vb -0.0)*sign(1.0, vb -(0.)))*0.5
2409 ! Revised by Ning Pan, 2010-07-21
2410 ! vr =max(vb,0.)
2411  vr =amax1(vb,0.)
2412
2413  g_Tmpv1 =vr*(g_ph_old(i,k,j) -g_ph_old(i,k,j-1)) +g_vr*(ph_old(i,k,j) &
2414  -ph_old(i,k,j-1))
2415  Tmpv1 =vr*(ph_old(i,k,j) -ph_old(i,k,j-1))
2416
2417  g_Tmpv2 =rdy*mut(i,j)*(g_Tmpv1) +rdy*g_mut(i,j)*(Tmpv1)
2418  Tmpv2 =rdy*mut(i,j)*(Tmpv1)
2419
2420  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
2421  ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2
2422
2423  ENDDO
2424  ENDDO
2425  END IF
2426
2427  j_start =its
2428
2429  jtf =min(jte,jde-1)
2430
2431  IF( (config_flags%open_xs) .and. its == ids ) THEN
2432
2433  i =its
2434
2435  DO j =jts,jtf
2436  DO k =2,kde-1
2437
2438  kz =k
2439
2440  g_ub =.5*(fnm(kz)*(g_u(i+1,kz,j) +g_u(i,kz,j)) +fnp(kz)*(g_u(i+1,kz-1,j) &
2441  +g_u(i,kz-1,j)))
2442  ub =.5*(fnm(kz)*(u(i+1,kz,j) +u(i,kz,j)) +fnp(kz)*(u(i+1,kz-1,j) +u(i,kz-1,j)))
2443
2444  g_ul =(g_ub +0.0 -(g_ub -0.0)*sign(1.0, ub -(0.)))*0.5
2445 ! Revised by Ning Pan, 2010-07-20
2446 ! ul =min(ub,0.)
2447  ul =amin1(ub,0.)
2448
2449  g_Tmpv1 =ul*(g_ph_old(i+1,k,j) -g_ph_old(i,k,j)) +g_ul*(ph_old(i+1,k,j) &
2450  -ph_old(i,k,j))
2451  Tmpv1 =ul*(ph_old(i+1,k,j) -ph_old(i,k,j))
2452
2453  g_Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(g_Tmpv1) +(msftx(i,j) &
2454 /msfty(i,j)) *rdx*g_mut(i,j)*(Tmpv1)
2455  Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(Tmpv1)
2456
2457  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
2458  ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2
2459
2460  ENDDO
2461
2462  k =kde
2463
2464  kz =k
2465
2466  g_ub =.5*(fnm(kz)*(g_u(i+1,kz,j) +g_u(i,kz,j)) +fnp(kz)*(g_u(i+1,kz-1,j) &
2467  +g_u(i,kz-1,j)))
2468  ub =.5*(fnm(kz)*(u(i+1,kz,j) +u(i,kz,j)) +fnp(kz)*(u(i+1,kz-1,j) +u(i,kz-1,j)))
2469
2470  g_ul =(g_ub +0.0 -(g_ub -0.0)*sign(1.0, ub -(0.)))*0.5
2471 ! Revised by Ning Pan, 2010-07-20
2472 ! ul =min(ub,0.)
2473  ul =amin1(ub,0.)
2474
2475  g_Tmpv1 =ul*(g_ph_old(i+1,k,j) -g_ph_old(i,k,j)) +g_ul*(ph_old(i+1,k,j) &
2476  -ph_old(i,k,j))
2477  Tmpv1 =ul*(ph_old(i+1,k,j) -ph_old(i,k,j))
2478
2479  g_Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(g_Tmpv1) +(msftx(i,j) &
2480 /msfty(i,j)) *rdx*g_mut(i,j)*(Tmpv1)
2481  Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(Tmpv1)
2482
2483  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
2484  ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2
2485
2486  ENDDO
2487  END IF
2488
2489  IF( (config_flags%open_xe) .and. ite == ide ) THEN
2490
2491  i =ite-1
2492
2493  DO j =jts,jtf
2494  DO k =2,kde-1
2495
2496  kz =k
2497
2498  g_ub =.5*(fnm(kz)*(g_u(i+1,kz,j) +g_u(i,kz,j)) +fnp(kz)*(g_u(i+1,kz-1,j) &
2499  +g_u(i,kz-1,j)))
2500  ub =.5*(fnm(kz)*(u(i+1,kz,j) +u(i,kz,j)) +fnp(kz)*(u(i+1,kz-1,j) +u(i,kz-1,j)))
2501
2502  g_ur =(g_ub +0.0 +(g_ub -0.0)*sign(1.0, ub -(0.)))*0.5
2503 ! Revised by Ning Pan, 2010-07-20
2504 ! ur =max(ub,0.)
2505  ur =amax1(ub,0.)
2506
2507  g_Tmpv1 =ur*(g_ph_old(i,k,j) -g_ph_old(i-1,k,j)) +g_ur*(ph_old(i,k,j) &
2508  -ph_old(i-1,k,j))
2509  Tmpv1 =ur*(ph_old(i,k,j) -ph_old(i-1,k,j))
2510
2511  g_Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(g_Tmpv1) +(msftx(i,j) &
2512 /msfty(i,j)) *rdx*g_mut(i,j)*(Tmpv1)
2513  Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(Tmpv1)
2514
2515  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
2516  ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2
2517
2518  ENDDO
2519
2520  k =kde
2521
2522  kz =k-1
2523
2524  g_ub =.5*(fnm(kz)*(g_u(i+1,kz,j) +g_u(i,kz,j)) +fnp(kz)*(g_u(i+1,kz-1,j) &
2525  +g_u(i,kz-1,j)))
2526  ub =.5*(fnm(kz)*(u(i+1,kz,j) +u(i,kz,j)) +fnp(kz)*(u(i+1,kz-1,j) +u(i,kz-1,j)))
2527
2528  g_ur =(g_ub +0.0 +(g_ub -0.0)*sign(1.0, ub -(0.)))*0.5
2529 ! Revised by Ning Pan, 2010-07-20
2530 ! ur =max(ub,0.)
2531  ur =amax1(ub,0.)
2532
2533  g_Tmpv1 =ur*(g_ph_old(i,k,j) -g_ph_old(i-1,k,j)) +g_ur*(ph_old(i,k,j) &
2534  -ph_old(i-1,k,j))
2535  Tmpv1 =ur*(ph_old(i,k,j) -ph_old(i-1,k,j))
2536
2537  g_Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(g_Tmpv1) +(msftx(i,j) &
2538 /msfty(i,j)) *rdx*g_mut(i,j)*(Tmpv1)
2539  Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(Tmpv1)
2540
2541  g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
2542  ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2
2543
2544  ENDDO
2545  END IF
2546
2547  END SUBROUTINE g_rhs_ph
2548
2549 !        Generated by TAPENADE     (INRIA, Tropics team)
2550 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
2551 !
2552 !  Differentiation of horizontal_pressure_gradient in forward (tangent) mode:
2553 !   variations   of useful results: ru_tend rv_tend
2554 !   with respect to varying inputs: p al ru_tend cqu cqv php rv_tend
2555 !                ph alt muu muv mu
2556 !   RW status of diff variables: p:in al:in ru_tend:in-out cqu:in
2557 !                cqv:in php:in rv_tend:in-out ph:in alt:in muu:in
2558 !                muv:in mu:in
2559 SUBROUTINE G_HORIZONTAL_PRESSURE_GRADIENT(ru_tend, ru_tendd, rv_tend, &
2560 &  rv_tendd, ph, phd, alt, altd, p, pd, pb, al, ald, php, phpd, cqu, cqud&
2561 &  , cqv, cqvd, muu, muud, muv, muvd, mu, mud, fnm, fnp, rdnw, cf1, cf2, &
2562 &  cf3, cfn, cfn1,rdx, rdy, msfux, msfuy, msfvx, msfvy, msftx, msfty, config_flags&
2563 &  , non_hydrostatic, top_lid, ids, ide, jds, jde, kds, kde, ims, ime, &
2564 &  jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
2565   IMPLICIT NONE
2566 ! Input data
2567   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
2568   LOGICAL, INTENT(IN) :: non_hydrostatic, top_lid
2569   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
2570 &  jme, kms, kme, its, ite, jts, jte, kts, kte
2571   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ph, alt, al&
2572 &  , p, pb, php, cqu, cqv
2573   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: phd, altd, &
2574 &  ald, pd, phpd, cqud, cqvd
2575   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tend, &
2576 &  rv_tend
2577   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tendd&
2578 &  , rv_tendd
2579   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: muu, muv, mu, msfux, &
2580 &  msfuy, msfvx, msfvy, msftx, msfty
2581   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: muud, muvd, mud
2582   REAL, DIMENSION(kms:kme), INTENT(IN) :: rdnw, fnm, fnp
2583   REAL, INTENT(IN) :: rdx, rdy, cf1, cf2, cf3, cfn, cfn1
2584   INTEGER :: i, j, k, itf, jtf, ktf, i_start, j_start
2585   REAL, DIMENSION(ims:ime, kms:kme) :: dpn
2586   REAL, DIMENSION(ims:ime, kms:kme) :: dpnd
2587   REAL :: dpx, dpy
2588   REAL :: dpxd, dpyd
2589   LOGICAL :: specified
2590   INTRINSIC MIN
2591 !<DESCRIPTION>
2592 !
2593 !  horizontal_pressure_gradient calculates the
2594 !  horizontal pressure gradient terms for the large-timestep tendency
2595 !  in the horizontal momentum equations (u,v).
2596 !
2597 !</DESCRIPTION>
2598   specified = .false.
2599   IF (config_flags%specified .OR. config_flags%nested) specified = &
2600 &      .true.
2601   IF (ite .GT. ide - 1) THEN
2602     itf = ide - 1
2603   ELSE
2604     itf = ite
2605   END IF
2606   jtf = jte
2607   IF (kte .GT. kde - 1) THEN
2608     ktf = kde - 1
2609   ELSE
2610     ktf = kte
2611   END IF
2612   i_start = its
2613   j_start = jts
2614   IF ((((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
2615 &      .OR. config_flags%polar) .AND. jts .EQ. jds) j_start = jts + 1
2616   IF ((((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
2617 &      .OR. config_flags%polar) .AND. jte .EQ. jde) THEN
2618     jtf = jtf - 1
2619     dpnd = 0.0
2620   ELSE
2621     dpnd = 0.0
2622   END IF
2623   DO j=j_start,jtf
2624     IF (non_hydrostatic) THEN
2625       k = 1
2626       DO i=i_start,itf
2627         dpnd(i, k) = .5*(cf1*(pd(i, k, j-1)+pd(i, k, j))+cf2*(pd(i, k+1&
2628 &          , j-1)+pd(i, k+1, j))+cf3*(pd(i, k+2, j-1)+pd(i, k+2, j)))
2629         dpn(i, k) = .5*(cf1*(p(i, k, j-1)+p(i, k, j))+cf2*(p(i, k+1, j-1&
2630 &          )+p(i, k+1, j))+cf3*(p(i, k+2, j-1)+p(i, k+2, j)))
2631         dpnd(i, kde) = 0.0
2632         dpn(i, kde) = 0.
2633       END DO
2634       IF (top_lid) THEN
2635         DO i=i_start,itf
2636 !commented out for bug fix, Jan 2016
2637 !          dpnd(i, kde) = .5*(cf1*(pd(i, kde-1, j-1)+pd(i, kde-1, j))+cf2&
2638 !&            *(pd(i, kde-2, j-1)+pd(i, kde-2, j))+cf3*(pd(i, kde-3, j-1)+&
2639 !&            pd(i, kde-3, j)))
2640 !          dpn(i, kde) = .5*(cf1*(p(i, kde-1, j-1)+p(i, kde-1, j))+cf2*(p&
2641 !&            (i, kde-2, j-1)+p(i, kde-2, j))+cf3*(p(i, kde-3, j-1)+p(i, &
2642 !&            kde-3, j)))
2643             dpnd(i,kde) = .5*( cfn *(pd(i,kde-1,j-1)+pd(i,kde-1,j))   &
2644                               +cfn1*(pd(i,kde-2,j-1)+pd(i,kde-2,j)) )
2645
2646             dpn(i,kde) = .5*( cfn *(p(i,kde-1,j-1)+p(i,kde-1,j))   &
2647                              +cfn1*(p(i,kde-2,j-1)+p(i,kde-2,j)) )
2648         END DO
2649       END IF
2650       DO k=2,ktf
2651         DO i=i_start,itf
2652           dpnd(i, k) = .5*(fnm(k)*(pd(i, k, j-1)+pd(i, k, j))+fnp(k)*(pd&
2653 &            (i, k-1, j-1)+pd(i, k-1, j)))
2654           dpn(i, k) = .5*(fnm(k)*(p(i, k, j-1)+p(i, k, j))+fnp(k)*(p(i, &
2655 &            k-1, j-1)+p(i, k-1, j)))
2656         END DO
2657       END DO
2658 !       ADT eqn 45: -mu*(my/mx)*(1/rho)*partial dp/dy
2659 !       [alt, al are 1/rho terms; muv, mu are NOT coupled]
2660       DO k=1,ktf
2661         DO i=i_start,itf
2662 ! Here are mu dp/dy terms 1-3
2663           dpyd = msfvy(i, j)*.5*rdy*(muvd(i, j)*(ph(i, k+1, j)-ph(i, k+1&
2664 &            , j-1)+ph(i, k, j)-ph(i, k, j-1)+(alt(i, k, j)+alt(i, k, j-1&
2665 &            ))*(p(i, k, j)-p(i, k, j-1))+(al(i, k, j)+al(i, k, j-1))*(pb&
2666 &            (i, k, j)-pb(i, k, j-1)))+muv(i, j)*(phd(i, k+1, j)-phd(i, k&
2667 &            +1, j-1)+phd(i, k, j)-phd(i, k, j-1)+(altd(i, k, j)+altd(i, &
2668 &            k, j-1))*(p(i, k, j)-p(i, k, j-1))+(alt(i, k, j)+alt(i, k, j&
2669 &            -1))*(pd(i, k, j)-pd(i, k, j-1))+(pb(i, k, j)-pb(i, k, j-1))&
2670 &            *(ald(i, k, j)+ald(i, k, j-1))))/msfvx(i, j)
2671           dpy = msfvy(i, j)/msfvx(i, j)*.5*rdy*muv(i, j)*(ph(i, k+1, j)-&
2672 &            ph(i, k+1, j-1)+ph(i, k, j)-ph(i, k, j-1)+(alt(i, k, j)+alt(&
2673 &            i, k, j-1))*(p(i, k, j)-p(i, k, j-1))+(al(i, k, j)+al(i, k, &
2674 &            j-1))*(pb(i, k, j)-pb(i, k, j-1)))
2675 ! Here is mu dp/dy term 4
2676           dpyd = dpyd + msfvy(i, j)*rdy*((phpd(i, k, j)-phpd(i, k, j-1))&
2677 &            *(rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i, j-1)+mu(i, j)))+&
2678 &            (php(i, k, j)-php(i, k, j-1))*(rdnw(k)*(dpnd(i, k+1)-dpnd(i&
2679 &            , k))-.5*(mud(i, j-1)+mud(i, j))))/msfvx(i, j)
2680           dpy = dpy + msfvy(i, j)/msfvx(i, j)*rdy*(php(i, k, j)-php(i, k&
2681 &            , j-1))*(rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i, j-1)+mu(i&
2682 &            , j)))
2683           rv_tendd(i, k, j) = rv_tendd(i, k, j) - cqvd(i, k, j)*dpy - &
2684 &            cqv(i, k, j)*dpyd
2685           rv_tend(i, k, j) = rv_tend(i, k, j) - cqv(i, k, j)*dpy
2686         END DO
2687       END DO
2688     ELSE
2689 !       ADT eqn 45: -mu*(my/mx)*(1/rho)*partial dp/dy
2690 !       [alt, al are 1/rho terms; muv, mu are NOT coupled]
2691       DO k=1,ktf
2692         DO i=i_start,itf
2693 ! Here are mu dp/dy terms 1-3; term 4 not needed if hydrostatic
2694           dpyd = msfvy(i, j)*.5*rdy*(muvd(i, j)*(ph(i, k+1, j)-ph(i, k+1&
2695 &            , j-1)+ph(i, k, j)-ph(i, k, j-1)+(alt(i, k, j)+alt(i, k, j-1&
2696 &            ))*(p(i, k, j)-p(i, k, j-1))+(al(i, k, j)+al(i, k, j-1))*(pb&
2697 &            (i, k, j)-pb(i, k, j-1)))+muv(i, j)*(phd(i, k+1, j)-phd(i, k&
2698 &            +1, j-1)+phd(i, k, j)-phd(i, k, j-1)+(altd(i, k, j)+altd(i, &
2699 &            k, j-1))*(p(i, k, j)-p(i, k, j-1))+(alt(i, k, j)+alt(i, k, j&
2700 &            -1))*(pd(i, k, j)-pd(i, k, j-1))+(pb(i, k, j)-pb(i, k, j-1))&
2701 &            *(ald(i, k, j)+ald(i, k, j-1))))/msfvx(i, j)
2702           dpy = msfvy(i, j)/msfvx(i, j)*.5*rdy*muv(i, j)*(ph(i, k+1, j)-&
2703 &            ph(i, k+1, j-1)+ph(i, k, j)-ph(i, k, j-1)+(alt(i, k, j)+alt(&
2704 &            i, k, j-1))*(p(i, k, j)-p(i, k, j-1))+(al(i, k, j)+al(i, k, &
2705 &            j-1))*(pb(i, k, j)-pb(i, k, j-1)))
2706           rv_tendd(i, k, j) = rv_tendd(i, k, j) - dpyd
2707           rv_tend(i, k, j) = rv_tend(i, k, j) - dpy
2708         END DO
2709       END DO
2710     END IF
2711   END DO
2712 !  now the east-west (x) pressure gradient
2713   itf = ite
2714   IF (jte .GT. jde - 1) THEN
2715     jtf = jde - 1
2716   ELSE
2717     jtf = jte
2718   END IF
2719   IF (kte .GT. kde - 1) THEN
2720     ktf = kde - 1
2721   ELSE
2722     ktf = kte
2723   END IF
2724   i_start = its
2725   j_start = jts
2726   IF (((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
2727 &      .AND. its .EQ. ids) i_start = its + 1
2728   IF (((config_flags%open_xe .OR. specified) .OR. config_flags%nested) &
2729 &      .AND. ite .EQ. ide) itf = itf - 1
2730   IF (config_flags%periodic_x) i_start = its
2731   IF (config_flags%periodic_x) itf = ite
2732   DO j=j_start,jtf
2733     IF (non_hydrostatic) THEN
2734       k = 1
2735       DO i=i_start,itf
2736         dpnd(i, k) = .5*(cf1*(pd(i-1, k, j)+pd(i, k, j))+cf2*(pd(i-1, k+&
2737 &          1, j)+pd(i, k+1, j))+cf3*(pd(i-1, k+2, j)+pd(i, k+2, j)))
2738         dpn(i, k) = .5*(cf1*(p(i-1, k, j)+p(i, k, j))+cf2*(p(i-1, k+1, j&
2739 &          )+p(i, k+1, j))+cf3*(p(i-1, k+2, j)+p(i, k+2, j)))
2740         dpnd(i, kde) = 0.0
2741         dpn(i, kde) = 0.
2742       END DO
2743       IF (top_lid) THEN
2744         DO i=i_start,itf
2745 !commented out for bug fix, Jan 2016
2746 !          dpnd(i, kde) = .5*(cf1*(pd(i-1, kde-1, j)+pd(i, kde-1, j))+cf2&
2747 !&            *(pd(i-1, kde-2, j)+pd(i, kde-2, j))+cf3*(pd(i-1, kde-3, j)+&
2748 !&            pd(i, kde-3, j)))
2749 !          dpn(i, kde) = .5*(cf1*(p(i-1, kde-1, j)+p(i, kde-1, j))+cf2*(p&
2750 !&            (i-1, kde-2, j)+p(i, kde-2, j))+cf3*(p(i-1, kde-3, j)+p(i, &
2751 !&            kde-3, j)))
2752            dpnd(i,kde) = .5*( cfn *(pd(i-1,kde-1,j)+pd(i,kde-1,j))   &
2753                              +cfn1*(pd(i-1,kde-2,j)+pd(i,kde-2,j)) )
2754
2755            dpn(i,kde) = .5*( cfn *(p(i-1,kde-1,j)+p(i,kde-1,j))   &
2756                             +cfn1*(p(i-1,kde-2,j)+p(i,kde-2,j)) )
2757         END DO
2758       END IF
2759       DO k=2,ktf
2760         DO i=i_start,itf
2761           dpnd(i, k) = .5*(fnm(k)*(pd(i-1, k, j)+pd(i, k, j))+fnp(k)*(pd&
2762 &            (i-1, k-1, j)+pd(i, k-1, j)))
2763           dpn(i, k) = .5*(fnm(k)*(p(i-1, k, j)+p(i, k, j))+fnp(k)*(p(i-1&
2764 &            , k-1, j)+p(i, k-1, j)))
2765         END DO
2766       END DO
2767 ! ADT eqn 44: -mu*(mx/my)*(1/rho)*partial dp/dx
2768 ! [alt, al are 1/rho terms; muu, mu are NOT coupled]
2769       DO k=1,ktf
2770         DO i=i_start,itf
2771 ! Here are mu dp/dy terms 1-3
2772           dpxd = msfux(i, j)*.5*rdx*(muud(i, j)*(ph(i, k+1, j)-ph(i-1, k&
2773 &            +1, j)+ph(i, k, j)-ph(i-1, k, j)+(alt(i, k, j)+alt(i-1, k, j&
2774 &            ))*(p(i, k, j)-p(i-1, k, j))+(al(i, k, j)+al(i-1, k, j))*(pb&
2775 &            (i, k, j)-pb(i-1, k, j)))+muu(i, j)*(phd(i, k+1, j)-phd(i-1&
2776 &            , k+1, j)+phd(i, k, j)-phd(i-1, k, j)+(altd(i, k, j)+altd(i-&
2777 &            1, k, j))*(p(i, k, j)-p(i-1, k, j))+(alt(i, k, j)+alt(i-1, k&
2778 &            , j))*(pd(i, k, j)-pd(i-1, k, j))+(pb(i, k, j)-pb(i-1, k, j)&
2779 &            )*(ald(i, k, j)+ald(i-1, k, j))))/msfuy(i, j)
2780           dpx = msfux(i, j)/msfuy(i, j)*.5*rdx*muu(i, j)*(ph(i, k+1, j)-&
2781 &            ph(i-1, k+1, j)+ph(i, k, j)-ph(i-1, k, j)+(alt(i, k, j)+alt(&
2782 &            i-1, k, j))*(p(i, k, j)-p(i-1, k, j))+(al(i, k, j)+al(i-1, k&
2783 &            , j))*(pb(i, k, j)-pb(i-1, k, j)))
2784 ! Here is mu dp/dy term 4
2785           dpxd = dpxd + msfux(i, j)*rdx*((phpd(i, k, j)-phpd(i-1, k, j))&
2786 &            *(rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i-1, j)+mu(i, j)))+&
2787 &            (php(i, k, j)-php(i-1, k, j))*(rdnw(k)*(dpnd(i, k+1)-dpnd(i&
2788 &            , k))-.5*(mud(i-1, j)+mud(i, j))))/msfuy(i, j)
2789           dpx = dpx + msfux(i, j)/msfuy(i, j)*rdx*(php(i, k, j)-php(i-1&
2790 &            , k, j))*(rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i-1, j)+mu(&
2791 &            i, j)))
2792           ru_tendd(i, k, j) = ru_tendd(i, k, j) - cqud(i, k, j)*dpx - &
2793 &            cqu(i, k, j)*dpxd
2794           ru_tend(i, k, j) = ru_tend(i, k, j) - cqu(i, k, j)*dpx
2795         END DO
2796       END DO
2797     ELSE
2798 !       ADT eqn 44: -mu*(mx/my)*(1/rho)*partial dp/dx
2799 !       [alt, al are 1/rho terms; muu, mu are NOT coupled]
2800       DO k=1,ktf
2801         DO i=i_start,itf
2802 ! Here are mu dp/dy terms 1-3; term 4 not needed if hydrostatic
2803           dpxd = msfux(i, j)*.5*rdx*(muud(i, j)*(ph(i, k+1, j)-ph(i-1, k&
2804 &            +1, j)+ph(i, k, j)-ph(i-1, k, j)+(alt(i, k, j)+alt(i-1, k, j&
2805 &            ))*(p(i, k, j)-p(i-1, k, j))+(al(i, k, j)+al(i-1, k, j))*(pb&
2806 &            (i, k, j)-pb(i-1, k, j)))+muu(i, j)*(phd(i, k+1, j)-phd(i-1&
2807 &            , k+1, j)+phd(i, k, j)-phd(i-1, k, j)+(altd(i, k, j)+altd(i-&
2808 &            1, k, j))*(p(i, k, j)-p(i-1, k, j))+(alt(i, k, j)+alt(i-1, k&
2809 &            , j))*(pd(i, k, j)-pd(i-1, k, j))+(pb(i, k, j)-pb(i-1, k, j)&
2810 &            )*(ald(i, k, j)+ald(i-1, k, j))))/msfuy(i, j)
2811           dpx = msfux(i, j)/msfuy(i, j)*.5*rdx*muu(i, j)*(ph(i, k+1, j)-&
2812 &            ph(i-1, k+1, j)+ph(i, k, j)-ph(i-1, k, j)+(alt(i, k, j)+alt(&
2813 &            i-1, k, j))*(p(i, k, j)-p(i-1, k, j))+(al(i, k, j)+al(i-1, k&
2814 &            , j))*(pb(i, k, j)-pb(i-1, k, j)))
2815           ru_tendd(i, k, j) = ru_tendd(i, k, j) - dpxd
2816           ru_tend(i, k, j) = ru_tend(i, k, j) - dpx
2817         END DO
2818       END DO
2819     END IF
2820   END DO
2821 END SUBROUTINE G_HORIZONTAL_PRESSURE_GRADIENT
2822
2823  SUBROUTINE g_pg_buoy_w(rw_tend,g_rw_tend,p,g_p,cqw,g_cqw,mu,g_mu,mub, &
2824  rdnw,rdn,g,msftx,msfty,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts, &
2825  jte,kts,kte)
2826
2827  IMPLICIT NONE
2828
2829  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5,g_Tmpv5
2830  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
2831  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: p,g_p
2832  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: cqw,g_cqw
2833  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rw_tend,g_rw_tend
2834  REAL,DIMENSION(ims:ime,jms:jme) :: mub,mu,g_mu,msftx,msfty
2835  REAL,DIMENSION(kms:kme) :: rdnw,rdn
2836  REAL :: g
2837  INTEGER :: itf,jtf,i,j,k
2838  REAL :: cq1,g_cq1,cq2,g_cq2
2839
2840  itf =min(ite,ide-1)
2841
2842  jtf =min(jte,jde-1)
2843
2844  DO j =jts,jtf
2845
2846  k =kde
2847
2848  DO i =its,itf
2849
2850  g_cq1 =-1.*(g_cqw(i,k-1,j))/((1. +cqw(i,k-1,j))*(1. +cqw(i,k-1,j)))
2851  cq1 =1./(1. +cqw(i,k-1,j))
2852
2853  g_Tmpv1 =cqw(i,k-1,j)*g_cq1 +g_cqw(i,k-1,j)*cq1
2854  Tmpv1 =cqw(i,k-1,j)*cq1
2855
2856  g_cq2 =g_Tmpv1
2857  cq2 =Tmpv1
2858
2859  g_Tmpv1 =cq1*2.*rdnw(k-1)*(-g_p(i,k-1,j)) +g_cq1*2.*rdnw(k-1)*(-p(i,k-1,j))
2860  Tmpv1 =cq1*2.*rdnw(k-1)*(-p(i,k-1,j))
2861
2862  g_rw_tend(i,k,j) =g_rw_tend(i,k,j) +(1./msfty(i,j)) *g*(g_Tmpv1 -g_mu(i, &
2863  j) -g_cq2*mub(i,j))
2864  rw_tend(i,k,j) =rw_tend(i,k,j) +(1./msfty(i,j)) *g*(Tmpv1 -mu(i,j) -cq2*mub(i,j))
2865
2866  ENDDO
2867
2868  DO k =2,kde-1
2869  DO i =its,itf
2870
2871  g_cq1 =-1.*(g_cqw(i,k,j))/((1. +cqw(i,k,j))*(1. +cqw(i,k,j)))
2872  cq1 =1./(1. +cqw(i,k,j))
2873
2874  g_Tmpv1 =cqw(i,k,j)*g_cq1 +g_cqw(i,k,j)*cq1
2875  Tmpv1 =cqw(i,k,j)*cq1
2876
2877  g_cq2 =g_Tmpv1
2878  cq2 =Tmpv1
2879
2880  g_cqw(i,k,j) =g_cq1
2881  cqw(i,k,j) =cq1
2882
2883  g_Tmpv1 =cq1*rdn(k)*(g_p(i,k,j) -g_p(i,k-1,j)) +g_cq1*rdn(k)*(p(i,k,j) &
2884  -p(i,k-1,j))
2885  Tmpv1 =cq1*rdn(k)*(p(i,k,j) -p(i,k-1,j))
2886
2887  g_rw_tend(i,k,j) =g_rw_tend(i,k,j) +(1./msfty(i,j)) *g*(g_Tmpv1 -g_mu(i, &
2888  j) -g_cq2*mub(i,j))
2889  rw_tend(i,k,j) =rw_tend(i,k,j) +(1./msfty(i,j)) *g*(Tmpv1 -mu(i,j) -cq2*mub(i,j))
2890
2891  ENDDO
2892  ENDDO
2893  ENDDO
2894
2895  END SUBROUTINE g_pg_buoy_w
2896
2897 ! Revised by Ning Pan, 2010-07-21
2898 ! SUBROUTINE g_w_damp(rw_tend,g_rw_tend,max_vert_cfl,g_max_vert_cfl, &
2899 ! max_horiz_cfl,g_max_horiz_cfl,u,g_u,v,g_v,ww,g_ww,w,g_w,mut,g_mut, &
2900  SUBROUTINE g_w_damp(rw_tend,g_rw_tend,max_vert_cfl, &
2901  max_horiz_cfl,u,g_u,v,g_v,ww,g_ww,w,g_w,mut,g_mut, &
2902  rdnw,rdx,rdy,msfux,msfuy,msfvx,msfvy,dt,config_flags,ids,ide,jds,jde,kds,kde,ims,ime, &
2903  jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
2904
2905  USE module_llxy
2906  IMPLICIT NONE
2907
2908  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
2909  g_Tmpv5,Tmpv6,g_Tmpv6
2910  TYPE(grid_config_rec_type) :: config_flags
2911  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
2912  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,g_u,v,g_v,ww,g_ww,w,g_w
2913  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rw_tend,g_rw_tend
2914 ! Revised by Ning Pan, 2010-07-21
2915 ! REAL :: max_vert_cfl,g_max_vert_cfl
2916 ! REAL :: max_horiz_cfl,g_max_horiz_cfl
2917  REAL :: max_vert_cfl
2918  REAL :: max_horiz_cfl
2919  REAL :: horiz_cfl,g_horiz_cfl
2920  REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut
2921  REAL,DIMENSION(kms:kme) :: rdnw
2922  REAL :: dt
2923  REAL :: rdx,rdy
2924  REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy
2925  REAL,DIMENSION(ims:ime,jms:jme) :: msfvx,msfvy
2926 ! Revised by Ning Pan, 2010-07-21
2927 ! REAL :: vert_cfl,g_vert_cfl,cf_n,g_cf_n,cf_d,g_cf_d,maxdub,g_maxdub, &
2928 ! maxdeta,g_maxdeta
2929  REAL :: vert_cfl,g_vert_cfl,cf_n,g_cf_n,cf_d,g_cf_d,maxdub, &
2930  maxdeta
2931  INTEGER :: itf,jtf,i,j,k,maxi,maxj,maxk
2932  INTEGER :: some
2933  CHARACTER*512 :: temp
2934  CHARACTER (LEN=256) :: time_str
2935  CHARACTER (LEN=256) :: grid_str
2936  integer :: total
2937 ! Revised by Ning Pan, 2010-07-21
2938 ! REAL :: msfuxt,g_msfuxt,msfxffl,g_msfxffl
2939  REAL :: msfuxt,g_msfuxt,msfxffl,g_msfxffl
2940
2941  itf =min(ite,ide-1)
2942
2943  jtf =min(jte,jde-1)
2944
2945  some =0
2946
2947 ! g_max_vert_cfl =0.0  ! Remarked by Ning Pan, 2010-07-21
2948  max_vert_cfl =0.
2949
2950 ! g_max_horiz_cfl =0.0  ! Remarked by Ning Pan, 2010-07-21
2951  max_horiz_cfl =0.
2952
2953  total =0
2954
2955  IF(config_flags%polar) THEN
2956
2957 !PRINT*, 'DELETED FOR COMPILING BY WALLS' ! Remarked by Ning Pan, 2010-07-21
2958 !STOP  ! Remarked by Ning Pan, 2010-07-21
2959 !g_msfxffl =-1.0*(-g_config_flags%fft_filter_lat*degrad*sin(config_flags%fft_fil &
2960 !ter_lat*degrad))/(cos(config_flags%fft_filter_lat*degrad)*cos(config_flags%fft_filter &
2961 !_lat*degrad))
2962  msfxffl =1.0/cos(config_flags%fft_filter_lat*degrad)
2963
2964  END IF
2965
2966  IF( config_flags%w_damping == 1 ) THEN
2967
2968  DO j =jts,jtf
2969  DO k =2,kde-1
2970  DO i =its,itf
2971 #if 1
2972
2973  IF(config_flags%polar) THEN
2974
2975 ! g_msfuxt =(0.0 +g_msfxffl -(0.0 -g_msfxffl)*sign(1.0, msfux(i,j) -(msfxffl)))*0.5  ! Remarked by Ning Pan, 2010-07-21
2976  msfuxt =min(msfux(i,j),msfxffl)
2977
2978  ELSE
2979
2980 ! g_msfuxt =0.0  ! Remarked by Ning Pan, 2010-07-21
2981  msfuxt =msfux(i,j)
2982
2983  END IF
2984
2985  g_Tmpv1 =(g_ww(i,k,j)*mut(i,j) -g_mut(i,j)*ww(i,k,j))/(mut(i,j)*mut(i,j))
2986  Tmpv1 =ww(i,k,j)/mut(i,j)
2987
2988  g_vert_cfl =sign(1.0, Tmpv1*rdnw(k)*dt)*g_Tmpv1*rdnw(k)*dt
2989  vert_cfl =abs(Tmpv1*rdnw(k)*dt)
2990
2991  IF( vert_cfl > max_vert_cfl ) THEN
2992
2993 ! g_max_vert_cfl =g_vert_cfl  ! Remarked by Ning Pan, 2010-07-21
2994  max_vert_cfl =vert_cfl
2995
2996  maxi =i
2997
2998  maxj =j
2999
3000  maxk =k
3001
3002 ! g_maxdub =g_w(i,k,j)  ! Remarked by Ning Pan, 2010-07-21
3003  maxdub =w(i,k,j)
3004
3005 ! g_maxdeta =0.0  ! Remarked by Ning Pan, 2010-07-21
3006  maxdeta =-1./rdnw(k)
3007
3008  ENDIF
3009
3010 ! Revised by Ning Pan, 2010-07-21
3011 ! g_Tmpv1 =u(i,k,j)*rdx*g_msfuxt +g_u(i,k,j)*rdx*msfuxt
3012  g_Tmpv1 =g_u(i,k,j)*rdx*msfuxt
3013  Tmpv1 =u(i,k,j)*rdx*msfuxt
3014
3015  g_horiz_cfl =(sign(1.0, Tmpv1*dt)*g_Tmpv1*dt +sign(1.0, v(i,k,j)*rdy*msfvy(i,j) &
3016 *dt)*g_v(i,k,j)*rdy*msfvy(i,j)*dt +(sign(1.0, Tmpv1*dt)*g_Tmpv1*dt -sign(1.0, &
3017  v(i,k,j)*rdy*msfvy(i,j)*dt)*g_v(i,k,j)*rdy*msfvy(i,j)*dt)*sign(1.0, abs(Tmpv1*dt) &
3018  -(abs(v(i,k,j)*rdy*msfvy(i,j)*dt))))*0.5
3019  horiz_cfl =max(abs(Tmpv1*dt),abs(v(i,k,j)*rdy*msfvy(i,j)*dt))
3020
3021  IF(horiz_cfl > max_horiz_cfl) THEN
3022
3023 ! g_max_horiz_cfl =g_horiz_cfl  ! Remarked by Ning Pan, 2010-07-21
3024  max_horiz_cfl =horiz_cfl
3025
3026  endif
3027
3028  IF(vert_cfl .gt. w_beta) THEN
3029 #else
3030
3031  g_cf_n =sign(1.0, ww(i,k,j)*rdnw(k)*dt)*g_ww(i,k,j)*rdnw(k)*dt
3032  cf_n =abs(ww(i,k,j)*rdnw(k)*dt)
3033
3034  g_cf_d =sign(1.0, mut(i,j))*g_mut(i,j)
3035  cf_d =abs(mut(i,j))
3036
3037  IF(cf_n .gt. cf_d*w_beta ) THEN
3038 #endif
3039
3040  WRITE (temp,*) i,j,k,' vert_cfl,w,d(eta)=',vert_cfl,w(i,k,j),-1./rdnw(k)
3041 !This line is fail to be recognized
3042             CALL wrf_debug ( 100 , TRIM(temp) )
3043
3044  if( vert_cfl > 2. ) some =some+1
3045
3046  g_Tmpv1 =sign(1., w(i,k,j)) *w_alpha*(vert_cfl -w_beta)*g_mut(i,j) &
3047  +sign(1., w(i,k,j)) *w_alpha*(g_vert_cfl)*mut(i,j)
3048  Tmpv1 =sign(1., w(i,k,j)) *w_alpha*(vert_cfl -w_beta)*mut(i,j)
3049
3050  g_rw_tend(i,k,j) =g_rw_tend(i,k,j) -g_Tmpv1
3051  rw_tend(i,k,j) =rw_tend(i,k,j) -Tmpv1
3052
3053  endif
3054  ENDDO
3055  ENDDO
3056  ENDDO
3057  ELSE
3058 ! Remark all the computation of perturbation because this part (w_damping=0)
3059 !   is just for print (w_damping=0). Ning Pan, 2010-07-21
3060  DO j =jts,jtf
3061  DO k =2,kde-1
3062  DO i =its,itf
3063 #if 1
3064
3065  IF(config_flags%polar) THEN
3066
3067 ! g_msfuxt =(0.0 +g_msfxffl -(0.0 -g_msfxffl)*sign(1.0, msfux(i,j) -(msfxffl)))*0.5
3068  msfuxt =min(msfux(i,j),msfxffl)
3069
3070  ELSE
3071
3072 ! g_msfuxt =0.0
3073  msfuxt =msfux(i,j)
3074
3075  END IF
3076
3077 ! g_Tmpv1 =(g_ww(i,k,j)*mut(i,j) -g_mut(i,j)*ww(i,k,j))/(mut(i,j)*mut(i,j))
3078  Tmpv1 =ww(i,k,j)/mut(i,j)
3079
3080 ! g_vert_cfl =sign(1.0, Tmpv1*rdnw(k)*dt)*g_Tmpv1*rdnw(k)*dt
3081  vert_cfl =abs(Tmpv1*rdnw(k)*dt)
3082
3083  IF( vert_cfl > max_vert_cfl ) THEN
3084
3085 ! g_max_vert_cfl =g_vert_cfl  ! Remarked by Ning Pan, 2010-07-21
3086  max_vert_cfl =vert_cfl
3087
3088  maxi =i
3089
3090  maxj =j
3091
3092  maxk =k
3093
3094 ! g_maxdub =g_w(i,k,j)
3095  maxdub =w(i,k,j)
3096
3097 ! g_maxdeta =0.0
3098  maxdeta =-1./rdnw(k)
3099
3100  ENDIF
3101
3102 ! g_Tmpv1 =u(i,k,j)*rdx*g_msfuxt +g_u(i,k,j)*rdx*msfuxt
3103  Tmpv1 =u(i,k,j)*rdx*msfuxt
3104
3105 ! g_horiz_cfl =(sign(1.0, Tmpv1*dt)*g_Tmpv1*dt +sign(1.0, v(i,k,j)*rdy*msfvy(i,j) &
3106 !*dt)*g_v(i,k,j)*rdy*msfvy(i,j)*dt +(sign(1.0, Tmpv1*dt)*g_Tmpv1*dt -sign(1.0, &
3107 ! v(i,k,j)*rdy*msfvy(i,j)*dt)*g_v(i,k,j)*rdy*msfvy(i,j)*dt)*sign(1.0, abs(Tmpv1*dt) &
3108 ! -(abs(v(i,k,j)*rdy*msfvy(i,j)*dt))))*0.5
3109  horiz_cfl =max(abs(Tmpv1*dt),abs(v(i,k,j)*rdy*msfvy(i,j)*dt))
3110
3111  IF(horiz_cfl > max_horiz_cfl) THEN
3112
3113 ! g_max_horiz_cfl =g_horiz_cfl
3114  max_horiz_cfl =horiz_cfl
3115
3116  endif
3117
3118  IF(vert_cfl .gt. w_beta) THEN
3119 #else
3120
3121 ! g_cf_n =sign(1.0, ww(i,k,j)*rdnw(k)*dt)*g_ww(i,k,j)*rdnw(k)*dt
3122  cf_n =abs(ww(i,k,j)*rdnw(k)*dt)
3123
3124 ! g_cf_d =sign(1.0, mut(i,j))*g_mut(i,j)
3125  cf_d =abs(mut(i,j))
3126
3127  IF(cf_n .gt. cf_d*w_beta ) THEN
3128 #endif
3129
3130  WRITE (temp,*) i,j,k,' vert_cfl,w,d(eta)=',vert_cfl,w(i,k,j),-1./rdnw(k)
3131 !This line is fail to be recognized
3132             CALL wrf_debug ( 100 , TRIM(temp) )
3133
3134  if( vert_cfl > 2. ) some =some+1
3135   endif
3136  ENDDO
3137  ENDDO
3138  ENDDO
3139  ENDIF
3140
3141  IF( some .GT. 0 ) THEN
3142 !This line is fail to be recognized
3143       CALL get_current_time_string( time_str )
3144 !This line is fail to be recognized
3145       CALL get_current_grid_name( grid_str )
3146
3147  WRITE (temp,*) some,' points exceeded cfl=2 in domain '//Trim(grid_str) &
3148 //' at time '//Trim(time_str)//' hours'
3149 !This line is fail to be recognized
3150       CALL wrf_debug ( 0 , TRIM(temp) )
3151
3152 !REVISED BY WALLS
3153 ! WRITE (temp,*) 'MAX AT i,j,k: ',maxi,maxj,maxk,' vert_cfl,w,d(eta) &
3154 !=',max_vert_cfl,maxdub,maxdeta
3155 !This line is fail to be recognized
3156       CALL wrf_debug ( 0 , TRIM(temp) )
3157  ENDIF
3158
3159  END SUBROUTINE g_w_damp
3160
3161 !        Generated by TAPENADE     (INRIA, Tropics team)
3162 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
3163 !
3164 !  Differentiation of horizontal_diffusion in forward (tangent) mode:
3165 !   variations   of useful results: tendency
3166 !   with respect to varying inputs: field tendency xkmhd mu
3167 !   RW status of diff variables: field:in tendency:in-out xkmhd:in
3168 !                mu:in
3169 SUBROUTINE G_HORIZONTAL_DIFFUSION(name, field, fieldd, tendency, &
3170 &  tendencyd, mu, mud, config_flags, msfux, msfuy, msfvx, msfvx_inv, &
3171 &  msfvy, msftx, msfty, khdif, xkmhd, xkmhdd, rdx, rdy, ids, ide, jds, &
3172 &  jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, &
3173 &  kte)
3174   IMPLICIT NONE
3175 ! Input data
3176   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
3177   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
3178 &  jme, kms, kme, its, ite, jts, jte, kts, kte
3179   CHARACTER(len=1), INTENT(IN) :: name
3180   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, xkmhd
3181   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: fieldd, &
3182 &  xkmhdd
3183   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
3184   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
3185   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu
3186   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mud
3187   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
3188 &  msfvx_inv, msfvy, msftx, msfty
3189   REAL, INTENT(IN) :: rdx, rdy, khdif
3190 ! Local data
3191   INTEGER :: i, j, k, itf, jtf, ktf
3192   INTEGER :: i_start, i_end, j_start, j_end
3193   REAL :: mrdx, mkrdxm, mkrdxp, mrdy, mkrdym, mkrdyp
3194   REAL :: mkrdxmd, mkrdxpd, mkrdymd, mkrdypd
3195   LOGICAL :: specified
3196 !<DESCRIPTION>
3197 !
3198 !  horizontal_diffusion computes the horizontal diffusion tendency
3199 !  on model horizontal coordinate surfaces.
3200 !
3201 !</DESCRIPTION>
3202   specified = .false.
3203   IF (config_flags%specified .OR. config_flags%nested) specified = &
3204 &      .true.
3205   IF (kte .GT. kde - 1) THEN
3206     ktf = kde - 1
3207   ELSE
3208     ktf = kte
3209   END IF
3210   IF (name .EQ. 'u') THEN
3211     i_start = its
3212     i_end = ite
3213     j_start = jts
3214     IF (jte .GT. jde - 1) THEN
3215       j_end = jde - 1
3216     ELSE
3217       j_end = jte
3218     END IF
3219     IF (config_flags%open_xs .OR. specified) THEN
3220       IF (ids + 1 .LT. its) THEN
3221         i_start = its
3222       ELSE
3223         i_start = ids + 1
3224       END IF
3225     END IF
3226     IF (config_flags%open_xe .OR. specified) THEN
3227       IF (ide - 1 .GT. ite) THEN
3228         i_end = ite
3229       ELSE
3230         i_end = ide - 1
3231       END IF
3232     END IF
3233     IF (config_flags%open_ys .OR. specified) THEN
3234       IF (jds + 1 .LT. jts) THEN
3235         j_start = jts
3236       ELSE
3237         j_start = jds + 1
3238       END IF
3239     END IF
3240     IF (config_flags%open_ye .OR. specified) THEN
3241       IF (jde - 2 .GT. jte) THEN
3242         j_end = jte
3243       ELSE
3244         j_end = jde - 2
3245       END IF
3246     END IF
3247     IF (config_flags%periodic_x) i_start = its
3248     IF (config_flags%periodic_x) i_end = ite
3249     DO j=j_start,j_end
3250       DO k=kts,ktf
3251         DO i=i_start,i_end
3252 ! The interior is grad: (m_x*d/dx), the exterior is div: (m_x*m_y*d/dx(/m_y))
3253 ! setting up different averagings of m^2 partial d/dX and m^2 partial d/dY
3254           mkrdxmd = msftx(i-1, j)*rdx*(mud(i-1, j)*xkmhd(i-1, k, j)+mu(i&
3255 &            -1, j)*xkmhdd(i-1, k, j))/msfty(i-1, j)
3256           mkrdxm = msftx(i-1, j)/msfty(i-1, j)*mu(i-1, j)*xkmhd(i-1, k, &
3257 &            j)*rdx
3258           mkrdxpd = msftx(i, j)*rdx*(mud(i, j)*xkmhd(i, k, j)+mu(i, j)*&
3259 &            xkmhdd(i, k, j))/msfty(i, j)
3260           mkrdxp = msftx(i, j)/msfty(i, j)*mu(i, j)*xkmhd(i, k, j)*rdx
3261           mrdx = msfux(i, j)*msfuy(i, j)*rdx
3262           mkrdymd = (msfuy(i, j)+msfuy(i, j-1))*0.25**2*rdy*((mud(i, j)+&
3263 &            mud(i, j-1)+mud(i-1, j-1)+mud(i-1, j))*(xkmhd(i, k, j)+xkmhd&
3264 &            (i, k, j-1)+xkmhd(i-1, k, j-1)+xkmhd(i-1, k, j))+(mu(i, j)+&
3265 &            mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*(xkmhdd(i, k, j)+xkmhdd(&
3266 &            i, k, j-1)+xkmhdd(i-1, k, j-1)+xkmhdd(i-1, k, j)))/(msfux(i&
3267 &            , j)+msfux(i, j-1))
3268           mkrdym = (msfuy(i, j)+msfuy(i, j-1))/(msfux(i, j)+msfux(i, j-1&
3269 &            ))*0.25*(mu(i, j)+mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*0.25*(&
3270 &            xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i-1, k, j-1)+xkmhd(i-1&
3271 &            , k, j))*rdy
3272           mkrdypd = (msfuy(i, j)+msfuy(i, j+1))*0.25**2*rdy*((mud(i, j)+&
3273 &            mud(i, j+1)+mud(i-1, j+1)+mud(i-1, j))*(xkmhd(i, k, j)+xkmhd&
3274 &            (i, k, j+1)+xkmhd(i-1, k, j+1)+xkmhd(i-1, k, j))+(mu(i, j)+&
3275 &            mu(i, j+1)+mu(i-1, j+1)+mu(i-1, j))*(xkmhdd(i, k, j)+xkmhdd(&
3276 &            i, k, j+1)+xkmhdd(i-1, k, j+1)+xkmhdd(i-1, k, j)))/(msfux(i&
3277 &            , j)+msfux(i, j+1))
3278           mkrdyp = (msfuy(i, j)+msfuy(i, j+1))/(msfux(i, j)+msfux(i, j+1&
3279 &            ))*0.25*(mu(i, j)+mu(i, j+1)+mu(i-1, j+1)+mu(i-1, j))*0.25*(&
3280 &            xkmhd(i, k, j)+xkmhd(i, k, j+1)+xkmhd(i-1, k, j+1)+xkmhd(i-1&
3281 &            , k, j))*rdy
3282 ! need to do four-corners (t) for diffusion coefficient as there are
3283 ! no values at u,v points
3284 ! msfuy - has to be y as part of d/dY
3285 !         has to be u as we're at a u point
3286           mrdy = msfux(i, j)*msfuy(i, j)*rdy
3287 ! correctly averaged version of rho~ * m^2 *
3288 !    [partial d/dX(partial du^/dX) + partial d/dY(partial du^/dY)]
3289           tendencyd(i, k, j) = tendencyd(i, k, j) + mrdx*(mkrdxpd*(field&
3290 &            (i+1, k, j)-field(i, k, j))+mkrdxp*(fieldd(i+1, k, j)-fieldd&
3291 &            (i, k, j))-mkrdxmd*(field(i, k, j)-field(i-1, k, j))-mkrdxm*&
3292 &            (fieldd(i, k, j)-fieldd(i-1, k, j))) + mrdy*(mkrdypd*(field(&
3293 &            i, k, j+1)-field(i, k, j))+mkrdyp*(fieldd(i, k, j+1)-fieldd(&
3294 &            i, k, j))-mkrdymd*(field(i, k, j)-field(i, k, j-1))-mkrdym*(&
3295 &            fieldd(i, k, j)-fieldd(i, k, j-1)))
3296           tendency(i, k, j) = tendency(i, k, j) + (mrdx*(mkrdxp*(field(i&
3297 &            +1, k, j)-field(i, k, j))-mkrdxm*(field(i, k, j)-field(i-1, &
3298 &            k, j)))+mrdy*(mkrdyp*(field(i, k, j+1)-field(i, k, j))-&
3299 &            mkrdym*(field(i, k, j)-field(i, k, j-1))))
3300         END DO
3301       END DO
3302     END DO
3303   ELSE IF (name .EQ. 'v') THEN
3304     i_start = its
3305     IF (ite .GT. ide - 1) THEN
3306       i_end = ide - 1
3307     ELSE
3308       i_end = ite
3309     END IF
3310     j_start = jts
3311     j_end = jte
3312     IF (config_flags%open_xs .OR. specified) THEN
3313       IF (ids + 1 .LT. its) THEN
3314         i_start = its
3315       ELSE
3316         i_start = ids + 1
3317       END IF
3318     END IF
3319     IF (config_flags%open_xe .OR. specified) THEN
3320       IF (ide - 2 .GT. ite) THEN
3321         i_end = ite
3322       ELSE
3323         i_end = ide - 2
3324       END IF
3325     END IF
3326     IF (config_flags%open_ys .OR. specified) THEN
3327       IF (jds + 1 .LT. jts) THEN
3328         j_start = jts
3329       ELSE
3330         j_start = jds + 1
3331       END IF
3332     END IF
3333     IF (config_flags%open_ye .OR. specified) THEN
3334       IF (jde - 1 .GT. jte) THEN
3335         j_end = jte
3336       ELSE
3337         j_end = jde - 1
3338       END IF
3339     END IF
3340     IF (config_flags%periodic_x) i_start = its
3341     IF (config_flags%periodic_x) THEN
3342       IF (ite .GT. ide - 1) THEN
3343         i_end = ide - 1
3344       ELSE
3345         i_end = ite
3346       END IF
3347     END IF
3348     IF (config_flags%polar) THEN
3349       IF (jds + 1 .LT. jts) THEN
3350         j_start = jts
3351       ELSE
3352         j_start = jds + 1
3353       END IF
3354     END IF
3355     IF (config_flags%polar) THEN
3356       IF (jde - 1 .GT. jte) THEN
3357         j_end = jte
3358       ELSE
3359         j_end = jde - 1
3360       END IF
3361     END IF
3362     DO j=j_start,j_end
3363       DO k=kts,ktf
3364         DO i=i_start,i_end
3365           mkrdxmd = (msfvx(i, j)+msfvx(i-1, j))*0.25**2*rdx*((mud(i, j)+&
3366 &            mud(i, j-1)+mud(i-1, j-1)+mud(i-1, j))*(xkmhd(i, k, j)+xkmhd&
3367 &            (i, k, j-1)+xkmhd(i-1, k, j-1)+xkmhd(i-1, k, j))+(mu(i, j)+&
3368 &            mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*(xkmhdd(i, k, j)+xkmhdd(&
3369 &            i, k, j-1)+xkmhdd(i-1, k, j-1)+xkmhdd(i-1, k, j)))/(msfvy(i&
3370 &            , j)+msfvy(i-1, j))
3371           mkrdxm = (msfvx(i, j)+msfvx(i-1, j))/(msfvy(i, j)+msfvy(i-1, j&
3372 &            ))*0.25*(mu(i, j)+mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*0.25*(&
3373 &            xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i-1, k, j-1)+xkmhd(i-1&
3374 &            , k, j))*rdx
3375           mkrdxpd = (msfvx(i, j)+msfvx(i+1, j))*0.25**2*rdx*((mud(i, j)+&
3376 &            mud(i, j-1)+mud(i+1, j-1)+mud(i+1, j))*(xkmhd(i, k, j)+xkmhd&
3377 &            (i, k, j-1)+xkmhd(i+1, k, j-1)+xkmhd(i+1, k, j))+(mu(i, j)+&
3378 &            mu(i, j-1)+mu(i+1, j-1)+mu(i+1, j))*(xkmhdd(i, k, j)+xkmhdd(&
3379 &            i, k, j-1)+xkmhdd(i+1, k, j-1)+xkmhdd(i+1, k, j)))/(msfvy(i&
3380 &            , j)+msfvy(i+1, j))
3381           mkrdxp = (msfvx(i, j)+msfvx(i+1, j))/(msfvy(i, j)+msfvy(i+1, j&
3382 &            ))*0.25*(mu(i, j)+mu(i, j-1)+mu(i+1, j-1)+mu(i+1, j))*0.25*(&
3383 &            xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i+1, k, j-1)+xkmhd(i+1&
3384 &            , k, j))*rdx
3385           mrdx = msfvx(i, j)*msfvy(i, j)*rdx
3386           mkrdymd = msfty(i, j-1)*rdy*xkmhdd(i, k, j-1)/msftx(i, j-1)
3387           mkrdym = msfty(i, j-1)/msftx(i, j-1)*xkmhd(i, k, j-1)*rdy
3388           mkrdypd = msfty(i, j)*rdy*xkmhdd(i, k, j)/msftx(i, j)
3389           mkrdyp = msfty(i, j)/msftx(i, j)*xkmhd(i, k, j)*rdy
3390           mrdy = msfvx(i, j)*msfvy(i, j)*rdy
3391           tendencyd(i, k, j) = tendencyd(i, k, j) + mrdx*(mkrdxpd*(field&
3392 &            (i+1, k, j)-field(i, k, j))+mkrdxp*(fieldd(i+1, k, j)-fieldd&
3393 &            (i, k, j))-mkrdxmd*(field(i, k, j)-field(i-1, k, j))-mkrdxm*&
3394 &            (fieldd(i, k, j)-fieldd(i-1, k, j))) + mrdy*(mkrdypd*(field(&
3395 &            i, k, j+1)-field(i, k, j))+mkrdyp*(fieldd(i, k, j+1)-fieldd(&
3396 &            i, k, j))-mkrdymd*(field(i, k, j)-field(i, k, j-1))-mkrdym*(&
3397 &            fieldd(i, k, j)-fieldd(i, k, j-1)))
3398           tendency(i, k, j) = tendency(i, k, j) + (mrdx*(mkrdxp*(field(i&
3399 &            +1, k, j)-field(i, k, j))-mkrdxm*(field(i, k, j)-field(i-1, &
3400 &            k, j)))+mrdy*(mkrdyp*(field(i, k, j+1)-field(i, k, j))-&
3401 &            mkrdym*(field(i, k, j)-field(i, k, j-1))))
3402         END DO
3403       END DO
3404     END DO
3405   ELSE IF (name .EQ. 'w') THEN
3406     i_start = its
3407     IF (ite .GT. ide - 1) THEN
3408       i_end = ide - 1
3409     ELSE
3410       i_end = ite
3411     END IF
3412     j_start = jts
3413     IF (jte .GT. jde - 1) THEN
3414       j_end = jde - 1
3415     ELSE
3416       j_end = jte
3417     END IF
3418     IF (config_flags%open_xs .OR. specified) THEN
3419       IF (ids + 1 .LT. its) THEN
3420         i_start = its
3421       ELSE
3422         i_start = ids + 1
3423       END IF
3424     END IF
3425     IF (config_flags%open_xe .OR. specified) THEN
3426       IF (ide - 2 .GT. ite) THEN
3427         i_end = ite
3428       ELSE
3429         i_end = ide - 2
3430       END IF
3431     END IF
3432     IF (config_flags%open_ys .OR. specified) THEN
3433       IF (jds + 1 .LT. jts) THEN
3434         j_start = jts
3435       ELSE
3436         j_start = jds + 1
3437       END IF
3438     END IF
3439     IF (config_flags%open_ye .OR. specified) THEN
3440       IF (jde - 2 .GT. jte) THEN
3441         j_end = jte
3442       ELSE
3443         j_end = jde - 2
3444       END IF
3445     END IF
3446     IF (config_flags%periodic_x) i_start = its
3447     IF (config_flags%periodic_x) THEN
3448       IF (ite .GT. ide - 1) THEN
3449         i_end = ide - 1
3450       ELSE
3451         i_end = ite
3452       END IF
3453     END IF
3454     DO j=j_start,j_end
3455       DO k=kts+1,ktf
3456         DO i=i_start,i_end
3457           mkrdxmd = msfux(i, j)*0.25**2*rdx*((2*mud(i, j)+2*mud(i-1, j))&
3458 &            *(xkmhd(i, k, j)+xkmhd(i-1, k, j)+xkmhd(i, k-1, j)+xkmhd(i-1&
3459 &            , k-1, j))+(mu(i, j)+mu(i-1, j)+mu(i, j)+mu(i-1, j))*(xkmhdd&
3460 &            (i, k, j)+xkmhdd(i-1, k, j)+xkmhdd(i, k-1, j)+xkmhdd(i-1, k-&
3461 &            1, j)))/msfuy(i, j)
3462           mkrdxm = msfux(i, j)/msfuy(i, j)*0.25*(mu(i, j)+mu(i-1, j)+mu(&
3463 &            i, j)+mu(i-1, j))*0.25*(xkmhd(i, k, j)+xkmhd(i-1, k, j)+&
3464 &            xkmhd(i, k-1, j)+xkmhd(i-1, k-1, j))*rdx
3465           mkrdxpd = msfux(i+1, j)*0.25**2*rdx*((2*mud(i+1, j)+2*mud(i, j&
3466 &            ))*(xkmhd(i+1, k, j)+xkmhd(i, k, j)+xkmhd(i+1, k-1, j)+xkmhd&
3467 &            (i, k-1, j))+(mu(i+1, j)+mu(i, j)+mu(i+1, j)+mu(i, j))*(&
3468 &            xkmhdd(i+1, k, j)+xkmhdd(i, k, j)+xkmhdd(i+1, k-1, j)+xkmhdd&
3469 &            (i, k-1, j)))/msfuy(i+1, j)
3470           mkrdxp = msfux(i+1, j)/msfuy(i+1, j)*0.25*(mu(i+1, j)+mu(i, j)&
3471 &            +mu(i+1, j)+mu(i, j))*0.25*(xkmhd(i+1, k, j)+xkmhd(i, k, j)+&
3472 &            xkmhd(i+1, k-1, j)+xkmhd(i, k-1, j))*rdx
3473           mrdx = msftx(i, j)*msfty(i, j)*rdx
3474 !         mkrdym=(msfvy(i,j)/msfvx(i,j))*   &
3475           mkrdymd = msfvy(i, j)*msfvx_inv(i, j)*0.25**2*rdy*((2*mud(i, j&
3476 &            )+2*mud(i, j-1))*(xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i, k&
3477 &            -1, j)+xkmhd(i, k-1, j-1))+(mu(i, j)+mu(i, j-1)+mu(i, j)+mu(&
3478 &            i, j-1))*(xkmhdd(i, k, j)+xkmhdd(i, k, j-1)+xkmhdd(i, k-1, j&
3479 &            )+xkmhdd(i, k-1, j-1)))
3480           mkrdym = msfvy(i, j)*msfvx_inv(i, j)*0.25*(mu(i, j)+mu(i, j-1)&
3481 &            +mu(i, j)+mu(i, j-1))*0.25*(xkmhd(i, k, j)+xkmhd(i, k, j-1)+&
3482 &            xkmhd(i, k-1, j)+xkmhd(i, k-1, j-1))*rdy
3483 !         mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*   &
3484           mkrdypd = msfvy(i, j+1)*msfvx_inv(i, j+1)*0.25**2*rdy*((2*mud(&
3485 &            i, j+1)+2*mud(i, j))*(xkmhd(i, k, j+1)+xkmhd(i, k, j)+xkmhd(&
3486 &            i, k-1, j+1)+xkmhd(i, k-1, j))+(mu(i, j+1)+mu(i, j)+mu(i, j+&
3487 &            1)+mu(i, j))*(xkmhdd(i, k, j+1)+xkmhdd(i, k, j)+xkmhdd(i, k-&
3488 &            1, j+1)+xkmhdd(i, k-1, j)))
3489           mkrdyp = msfvy(i, j+1)*msfvx_inv(i, j+1)*0.25*(mu(i, j+1)+mu(i&
3490 &            , j)+mu(i, j+1)+mu(i, j))*0.25*(xkmhd(i, k, j+1)+xkmhd(i, k&
3491 &            , j)+xkmhd(i, k-1, j+1)+xkmhd(i, k-1, j))*rdy
3492           mrdy = msftx(i, j)*msfty(i, j)*rdy
3493           tendencyd(i, k, j) = tendencyd(i, k, j) + mrdx*(mkrdxpd*(field&
3494 &            (i+1, k, j)-field(i, k, j))+mkrdxp*(fieldd(i+1, k, j)-fieldd&
3495 &            (i, k, j))-mkrdxmd*(field(i, k, j)-field(i-1, k, j))-mkrdxm*&
3496 &            (fieldd(i, k, j)-fieldd(i-1, k, j))) + mrdy*(mkrdypd*(field(&
3497 &            i, k, j+1)-field(i, k, j))+mkrdyp*(fieldd(i, k, j+1)-fieldd(&
3498 &            i, k, j))-mkrdymd*(field(i, k, j)-field(i, k, j-1))-mkrdym*(&
3499 &            fieldd(i, k, j)-fieldd(i, k, j-1)))
3500           tendency(i, k, j) = tendency(i, k, j) + (mrdx*(mkrdxp*(field(i&
3501 &            +1, k, j)-field(i, k, j))-mkrdxm*(field(i, k, j)-field(i-1, &
3502 &            k, j)))+mrdy*(mkrdyp*(field(i, k, j+1)-field(i, k, j))-&
3503 &            mkrdym*(field(i, k, j)-field(i, k, j-1))))
3504         END DO
3505       END DO
3506     END DO
3507   ELSE
3508     i_start = its
3509     IF (ite .GT. ide - 1) THEN
3510       i_end = ide - 1
3511     ELSE
3512       i_end = ite
3513     END IF
3514     j_start = jts
3515     IF (jte .GT. jde - 1) THEN
3516       j_end = jde - 1
3517     ELSE
3518       j_end = jte
3519     END IF
3520     IF (config_flags%open_xs .OR. specified) THEN
3521       IF (ids + 1 .LT. its) THEN
3522         i_start = its
3523       ELSE
3524         i_start = ids + 1
3525       END IF
3526     END IF
3527     IF (config_flags%open_xe .OR. specified) THEN
3528       IF (ide - 2 .GT. ite) THEN
3529         i_end = ite
3530       ELSE
3531         i_end = ide - 2
3532       END IF
3533     END IF
3534     IF (config_flags%open_ys .OR. specified) THEN
3535       IF (jds + 1 .LT. jts) THEN
3536         j_start = jts
3537       ELSE
3538         j_start = jds + 1
3539       END IF
3540     END IF
3541     IF (config_flags%open_ye .OR. specified) THEN
3542       IF (jde - 2 .GT. jte) THEN
3543         j_end = jte
3544       ELSE
3545         j_end = jde - 2
3546       END IF
3547     END IF
3548     IF (config_flags%periodic_x) i_start = its
3549     IF (config_flags%periodic_x) THEN
3550       IF (ite .GT. ide - 1) THEN
3551         i_end = ide - 1
3552       ELSE
3553         i_end = ite
3554       END IF
3555     END IF
3556     DO j=j_start,j_end
3557       DO k=kts,ktf
3558         DO i=i_start,i_end
3559           mkrdxmd = msfux(i, j)*0.5**2*rdx*((xkmhdd(i, k, j)+xkmhdd(i-1&
3560 &            , k, j))*(mu(i, j)+mu(i-1, j))+(xkmhd(i, k, j)+xkmhd(i-1, k&
3561 &            , j))*(mud(i, j)+mud(i-1, j)))/msfuy(i, j)
3562           mkrdxm = msfux(i, j)/msfuy(i, j)*0.5*(xkmhd(i, k, j)+xkmhd(i-1&
3563 &            , k, j))*0.5*(mu(i, j)+mu(i-1, j))*rdx
3564           mkrdxpd = msfux(i+1, j)*0.5**2*rdx*((xkmhdd(i+1, k, j)+xkmhdd(&
3565 &            i, k, j))*(mu(i+1, j)+mu(i, j))+(xkmhd(i+1, k, j)+xkmhd(i, k&
3566 &            , j))*(mud(i+1, j)+mud(i, j)))/msfuy(i+1, j)
3567           mkrdxp = msfux(i+1, j)/msfuy(i+1, j)*0.5*(xkmhd(i+1, k, j)+&
3568 &            xkmhd(i, k, j))*0.5*(mu(i+1, j)+mu(i, j))*rdx
3569           mrdx = msftx(i, j)*msfty(i, j)*rdx
3570 !         mkrdym=(msfvy(i,j)/msfvx(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy
3571           mkrdymd = msfvy(i, j)*msfvx_inv(i, j)*0.5**2*rdy*((xkmhdd(i, k&
3572 &            , j)+xkmhdd(i, k, j-1))*(mu(i, j)+mu(i, j-1))+(xkmhd(i, k, j&
3573 &            )+xkmhd(i, k, j-1))*(mud(i, j)+mud(i, j-1)))
3574           mkrdym = msfvy(i, j)*msfvx_inv(i, j)*0.5*(xkmhd(i, k, j)+xkmhd&
3575 &            (i, k, j-1))*0.5*(mu(i, j)+mu(i, j-1))*rdy
3576 !         mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy
3577           mkrdypd = msfvy(i, j+1)*msfvx_inv(i, j+1)*0.5**2*rdy*((xkmhdd(&
3578 &            i, k, j+1)+xkmhdd(i, k, j))*(mu(i, j+1)+mu(i, j))+(xkmhd(i, &
3579 &            k, j+1)+xkmhd(i, k, j))*(mud(i, j+1)+mud(i, j)))
3580           mkrdyp = msfvy(i, j+1)*msfvx_inv(i, j+1)*0.5*(xkmhd(i, k, j+1)&
3581 &            +xkmhd(i, k, j))*0.5*(mu(i, j+1)+mu(i, j))*rdy
3582           mrdy = msftx(i, j)*msfty(i, j)*rdy
3583           tendencyd(i, k, j) = tendencyd(i, k, j) + mrdx*(mkrdxpd*(field&
3584 &            (i+1, k, j)-field(i, k, j))+mkrdxp*(fieldd(i+1, k, j)-fieldd&
3585 &            (i, k, j))-mkrdxmd*(field(i, k, j)-field(i-1, k, j))-mkrdxm*&
3586 &            (fieldd(i, k, j)-fieldd(i-1, k, j))) + mrdy*(mkrdypd*(field(&
3587 &            i, k, j+1)-field(i, k, j))+mkrdyp*(fieldd(i, k, j+1)-fieldd(&
3588 &            i, k, j))-mkrdymd*(field(i, k, j)-field(i, k, j-1))-mkrdym*(&
3589 &            fieldd(i, k, j)-fieldd(i, k, j-1)))
3590           tendency(i, k, j) = tendency(i, k, j) + (mrdx*(mkrdxp*(field(i&
3591 &            +1, k, j)-field(i, k, j))-mkrdxm*(field(i, k, j)-field(i-1, &
3592 &            k, j)))+mrdy*(mkrdyp*(field(i, k, j+1)-field(i, k, j))-&
3593 &            mkrdym*(field(i, k, j)-field(i, k, j-1))))
3594         END DO
3595       END DO
3596     END DO
3597   END IF
3598 END SUBROUTINE G_HORIZONTAL_DIFFUSION
3599
3600  SUBROUTINE g_horizontal_diffusion_3dmp(name,field,g_field,tendency, &
3601  g_tendency,mu,g_mu,config_flags,base_3d,msfux,msfuy,msfvx,msfvx_inv,msfvy, &
3602  msftx,msfty,khdif,xkmhd,g_xkmhd,rdx,rdy,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
3603  kms,kme,its,ite,jts,jte,kts,kte)
3604
3605  IMPLICIT NONE
3606
3607  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
3608  g_Tmpv5,Tmpv6,g_Tmpv6
3609  TYPE(grid_config_rec_type) :: config_flags
3610  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
3611  CHARACTER (LEN=1) :: name
3612  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field,xkmhd,g_xkmhd,base_3d
3613  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
3614  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
3615  REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty
3616  REAL :: rdx,rdy,khdif
3617
3618  INTEGER :: i,j,k,itf,jtf,ktf
3619  INTEGER :: i_start,i_end,j_start,j_end
3620 ! Revised by Ning Pan, 2010-07-23
3621 ! REAL :: mrdx,g_mrdx,mkrdxm,g_mkrdxm,mkrdxp,g_mkrdxp,mrdy,g_mrdy,mkrdym, &
3622  REAL :: mrdx,mkrdxm,g_mkrdxm,mkrdxp,g_mkrdxp,mrdy,mkrdym, &
3623  g_mkrdym,mkrdyp,g_mkrdyp
3624  LOGICAL :: specified
3625
3626  specified =.false.
3627
3628  if(config_flags%specified .or. config_flags%nested) specified =.true.
3629
3630  ktf =min(kte,kde-1)
3631
3632  i_start =its
3633
3634  i_end =min(ite,ide-1)
3635
3636  j_start =jts
3637
3638  j_end =min(jte,jde-1)
3639
3640  IF( config_flags%open_xs .or. specified ) i_start =max(ids+1,its)
3641
3642  IF( config_flags%open_xe .or. specified ) i_end =min(ide-2,ite)
3643
3644  IF( config_flags%open_ys .or. specified ) j_start =max(jds+1,jts)
3645
3646  IF( config_flags%open_ye .or. specified ) j_end =min(jde-2,jte)
3647
3648  IF( config_flags%periodic_x ) i_start =its
3649
3650  IF( config_flags%periodic_x ) i_end =min(ite,ide-1)
3651
3652  DO j =j_start,j_end
3653  DO k =kts,ktf
3654  DO i =i_start,i_end
3655
3656  g_Tmpv1 =(msfux(i,j)/msfuy(i,j)) *0.5*(xkmhd(i,k,j) +xkmhd(i-1,k,j)) &
3657 *0.5*(g_mu(i,j) +g_mu(i-1,j)) +(msfux(i,j)/msfuy(i,j)) *0.5*(g_xkmhd(i,k,j) &
3658  +g_xkmhd(i-1,k,j))*0.5*(mu(i,j) +mu(i-1,j))
3659  Tmpv1 =(msfux(i,j)/msfuy(i,j)) *0.5*(xkmhd(i,k,j) +xkmhd(i-1,k,j))*0.5*(mu(i,j) +mu(i-1,j))
3660
3661  g_mkrdxm =g_Tmpv1*rdx
3662  mkrdxm =Tmpv1*rdx
3663
3664  g_Tmpv1 =(msfux(i+1,j)/msfuy(i+1,j)) *0.5*(xkmhd(i+1,k,j) +xkmhd(i,k,j)) &
3665 *0.5*(g_mu(i+1,j) +g_mu(i,j)) +(msfux(i+1,j)/msfuy(i+1,j)) *0.5*(g_xkmhd(i+ &
3666  1,k,j) +g_xkmhd(i,k,j))*0.5*(mu(i+1,j) +mu(i,j))
3667  Tmpv1 =(msfux(i+1,j)/msfuy(i+1,j)) *0.5*(xkmhd(i+1,k,j) +xkmhd(i,k,j)) &
3668 *0.5*(mu(i+1,j) +mu(i,j))
3669
3670  g_mkrdxp =g_Tmpv1*rdx
3671  mkrdxp =Tmpv1*rdx
3672
3673 ! g_mrdx =0.0  ! Remarked by Ning Pan, 2010-07-23
3674  mrdx =msftx(i,j) *msfty(i,j) *rdx
3675
3676  g_Tmpv1 =(msfvy(i,j) *msfvx_inv(i,j)) *0.5*(xkmhd(i,k,j) +xkmhd(i,k,j-1)) &
3677 *0.5*(g_mu(i,j) +g_mu(i,j-1)) +(msfvy(i,j) *msfvx_inv(i,j)) *0.5*(g_xkmhd(i, &
3678  k,j) +g_xkmhd(i,k,j-1))*0.5*(mu(i,j) +mu(i,j-1))
3679  Tmpv1 =(msfvy(i,j) *msfvx_inv(i,j)) *0.5*(xkmhd(i,k,j) +xkmhd(i,k,j-1))*0.5*(mu(i,j) &
3680  +mu(i,j-1))
3681
3682  g_mkrdym =g_Tmpv1*rdy
3683  mkrdym =Tmpv1*rdy
3684
3685  g_Tmpv1 =(msfvy(i,j+1) *msfvx_inv(i,j+1)) *0.5*(xkmhd(i,k,j+1) +xkmhd(i,k,j)) &
3686 *0.5*(g_mu(i,j+1) +g_mu(i,j)) +(msfvy(i,j+1) *msfvx_inv(i,j+1)) *0.5*( &
3687  g_xkmhd(i,k,j+1) +g_xkmhd(i,k,j))*0.5*(mu(i,j+1) +mu(i,j))
3688  Tmpv1 =(msfvy(i,j+1) *msfvx_inv(i,j+1)) *0.5*(xkmhd(i,k,j+1) +xkmhd(i,k,j)) &
3689 *0.5*(mu(i,j+1) +mu(i,j))
3690
3691  g_mkrdyp =g_Tmpv1*rdy
3692  mkrdyp =Tmpv1*rdy
3693
3694 ! g_mrdy =0.0  ! Remarked by Ning Pan, 2010-07-23
3695  mrdy =msftx(i,j) *msfty(i,j) *rdy
3696
3697  g_Tmpv1 =mkrdxp*(g_field(i+1,k,j) -g_field(i,k,j)) +g_mkrdxp*(field(i+1, &
3698  k,j) -field(i,k,j) -base_3d(i+1,k,j) +base_3d(i,k,j))
3699  Tmpv1 =mkrdxp*(field(i+1,k,j) -field(i,k,j) -base_3d(i+1,k,j) +base_3d(i,k,j))
3700
3701  g_Tmpv2 =mkrdxm*(g_field(i,k,j) -g_field(i-1,k,j)) +g_mkrdxm*(field(i,k, &
3702  j) -field(i-1,k,j) -base_3d(i,k,j) +base_3d(i-1,k,j))
3703  Tmpv2 =mkrdxm*(field(i,k,j) -field(i-1,k,j) -base_3d(i,k,j) +base_3d(i-1,k,j))
3704
3705 ! Revised by Ning Pan, 2010-07-23
3706 ! g_Tmpv3 =mrdx*(g_Tmpv1 -g_Tmpv2) +g_mrdx*(Tmpv1 -Tmpv2)
3707  g_Tmpv3 =mrdx*(g_Tmpv1 -g_Tmpv2)
3708  Tmpv3 =mrdx*(Tmpv1 -Tmpv2)
3709
3710  g_Tmpv4 =mkrdyp*(g_field(i,k,j+1) -g_field(i,k,j)) +g_mkrdyp*(field(i,k, &
3711  j+1) -field(i,k,j) -base_3d(i,k,j+1) +base_3d(i,k,j))
3712  Tmpv4 =mkrdyp*(field(i,k,j+1) -field(i,k,j) -base_3d(i,k,j+1) +base_3d(i,k,j))
3713
3714  g_Tmpv5 =mkrdym*(g_field(i,k,j) -g_field(i,k,j-1)) +g_mkrdym*(field(i,k, &
3715  j) -field(i,k,j-1) -base_3d(i,k,j) +base_3d(i,k,j-1))
3716  Tmpv5 =mkrdym*(field(i,k,j) -field(i,k,j-1) -base_3d(i,k,j) +base_3d(i,k,j-1))
3717
3718 ! Revised by Ning Pan, 2010-07-23
3719 ! g_Tmpv6 =mrdy*(g_Tmpv4 -g_Tmpv5) +g_mrdy*(Tmpv4 -Tmpv5)
3720  g_Tmpv6 =mrdy*(g_Tmpv4 -g_Tmpv5)
3721  Tmpv6 =mrdy*(Tmpv4 -Tmpv5)
3722
3723  g_tendency(i,k,j) =g_tendency(i,k,j) +(g_Tmpv3 +g_Tmpv6)
3724  tendency(i,k,j) =tendency(i,k,j) +(Tmpv3 +Tmpv6)
3725
3726  ENDDO
3727  ENDDO
3728  ENDDO
3729
3730  END SUBROUTINE g_horizontal_diffusion_3dmp
3731
3732  SUBROUTINE g_vertical_diffusion(name,field,g_field,tendency,g_tendency, &
3733  config_flags,alt,g_alt,mut,g_mut,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde,ims, &
3734  ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
3735
3736  IMPLICIT NONE
3737
3738  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3
3739  TYPE(grid_config_rec_type) :: config_flags
3740  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
3741  CHARACTER (LEN=1) :: name
3742  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field,alt,g_alt
3743  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
3744  REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut
3745  REAL,DIMENSION(kms:kme) :: rdn,rdnw
3746  REAL :: kvdif
3747
3748  INTEGER :: i,j,k,itf,jtf,ktf
3749  INTEGER :: i_start,i_end,j_start,j_end
3750 ! REAL,DIMENSION(its:ite,jts:jte) :: vfluxm,g_vfluxm,vfluxp,g_vfluxp,zz,g_zz  ! Remarked by Ning Pan, 2010-07-23
3751  REAL,DIMENSION(its:ite,0:kte+1) :: vflux,g_vflux
3752 ! REAL :: rdz,g_rdz  ! Remarked by Ning Pan, 2010-07-23
3753  LOGICAL :: specified
3754
3755  specified =.false.
3756
3757  if(config_flags%specified .or. config_flags%nested) specified =.true.
3758
3759  ktf =min(kte,kde-1)
3760
3761  IF(name .EQ. 'w') THEN
3762
3763  i_start =its
3764
3765  i_end =min(ite,ide-1)
3766
3767  j_start =jts
3768
3769  j_end =min(jte,jde-1)
3770
3771  DO j =j_start,j_end
3772  DO k =kts,ktf-1
3773  DO i =i_start,i_end
3774
3775  g_Tmpv1 =(kvdif/alt(i,k,j))*rdnw(k)*(g_field(i,k+1,j) -g_field(i,k,j)) &
3776  +(-kvdif*g_alt(i,k,j)/(alt(i,k,j)*alt(i,k,j)))*rdnw(k)*(field(i,k+1,j) -field(i,k,j))
3777  Tmpv1 =(kvdif/alt(i,k,j))*rdnw(k)*(field(i,k+1,j) -field(i,k,j))
3778
3779  g_vflux(i,k) =g_Tmpv1
3780  vflux(i,k) =Tmpv1
3781
3782  ENDDO
3783  ENDDO
3784
3785  DO i =i_start,i_end
3786
3787  g_vflux(i,ktf) =0.0
3788  vflux(i,ktf) =0.
3789
3790  ENDDO
3791
3792  DO k =kts+1,ktf
3793  DO i =i_start,i_end
3794
3795  g_Tmpv1 =((-rdn(k) *g *g*g_mut(i,j)/(mut(i,j)*mut(i,j)))*(0.5*(alt(i,k,j) &
3796  +alt(i,k-1,j))) -(0.5*(g_alt(i,k,j) +g_alt(i,k-1,j)))*rdn(k) *g *g/mut(i,j)) &
3797 /((0.5*(alt(i,k,j) +alt(i,k-1,j)))*(0.5*(alt(i,k,j) +alt(i,k-1,j))))
3798  Tmpv1 =rdn(k) *g *g/mut(i,j)/(0.5*(alt(i,k,j) +alt(i,k-1,j)))
3799
3800  g_Tmpv2 =Tmpv1*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*(vflux(i,k) -vflux(i,k-1))
3801  Tmpv2 =Tmpv1*(vflux(i,k) -vflux(i,k-1))
3802
3803  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
3804  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
3805
3806  ENDDO
3807  ENDDO
3808  ENDDO
3809  ELSE IF(name .EQ. 'm') THEN
3810
3811  i_start =its
3812
3813  i_end =min(ite,ide-1)
3814
3815  j_start =jts
3816
3817  j_end =min(jte,jde-1)
3818
3819  DO j =j_start,j_end
3820  DO k =kts,ktf-1
3821  DO i =i_start,i_end
3822
3823  g_Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(g_field(i,k+1,j) &
3824  -g_field(i,k,j)) +(-kvdif *rdn(k+1)*(0.5*(g_alt(i,k,j) +g_alt(i,k+1,j))) &
3825 /((0.5*(alt(i,k,j) +alt(i,k+1,j)))*(0.5*(alt(i,k,j) +alt(i,k+1,j)))))*(field(i,k+1,j) &
3826  -field(i,k,j))
3827  Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(field(i,k+1,j) -field(i,k,j))
3828
3829  g_vflux(i,k) =g_Tmpv1
3830  vflux(i,k) =Tmpv1
3831
3832  ENDDO
3833  ENDDO
3834
3835  DO i =i_start,i_end
3836
3837  g_vflux(i,0) =g_vflux(i,1)
3838  vflux(i,0) =vflux(i,1)
3839
3840  ENDDO
3841
3842  DO i =i_start,i_end
3843
3844  g_vflux(i,ktf) =0.0
3845  vflux(i,ktf) =0.
3846
3847  ENDDO
3848
3849  DO k =kts,ktf
3850  DO i =i_start,i_end
3851
3852  g_Tmpv1 =((-g *g*g_mut(i,j)/(mut(i,j)*mut(i,j)))*alt(i,k,j) -g_alt(i,k,j) &
3853 *g *g/mut(i,j))/(alt(i,k,j)*alt(i,k,j))
3854  Tmpv1 =g *g/mut(i,j)/alt(i,k,j)
3855
3856  g_Tmpv2 =Tmpv1*rdnw(k)*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*rdnw(k) &
3857 *(vflux(i,k) -vflux(i,k-1))
3858  Tmpv2 =Tmpv1*rdnw(k)*(vflux(i,k) -vflux(i,k-1))
3859
3860  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
3861  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
3862
3863  ENDDO
3864  ENDDO
3865  ENDDO
3866  ENDIF
3867
3868  END SUBROUTINE g_vertical_diffusion
3869
3870  SUBROUTINE g_vertical_diffusion_mp(field,g_field,tendency,g_tendency, &
3871  config_flags,base,alt,g_alt,mut,g_mut,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde, &
3872  ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
3873
3874  IMPLICIT NONE
3875
3876  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3
3877  TYPE(grid_config_rec_type) :: config_flags
3878  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
3879  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field,alt,g_alt
3880  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
3881  REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut
3882  REAL,DIMENSION(kms:kme) :: rdn,rdnw,base
3883  REAL :: kvdif
3884
3885  INTEGER :: i,j,k,itf,jtf,ktf
3886  INTEGER :: i_start,i_end,j_start,j_end
3887  REAL,DIMENSION(its:ite,0:kte+1) :: vflux,g_vflux
3888  REAL :: rdz,g_rdz
3889  LOGICAL :: specified
3890
3891  specified =.false.
3892
3893  if(config_flags%specified .or. config_flags%nested) specified =.true.
3894
3895  ktf =min(kte,kde-1)
3896
3897  i_start =its
3898
3899  i_end =min(ite,ide-1)
3900
3901  j_start =jts
3902
3903  j_end =min(jte,jde-1)
3904
3905  DO j =j_start,j_end
3906  DO k =kts,ktf-1
3907  DO i =i_start,i_end
3908
3909  g_Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(g_field(i,k+1,j) &
3910  -g_field(i,k,j)) +(-kvdif *rdn(k+1)*(0.5*(g_alt(i,k,j) +g_alt(i,k+1,j))) &
3911 /((0.5*(alt(i,k,j) +alt(i,k+1,j)))*(0.5*(alt(i,k,j) +alt(i,k+1,j)))))*(field(i,k+1,j) &
3912  -field(i,k,j) -base(k+1) +base(k))
3913  Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(field(i,k+1,j) &
3914  -field(i,k,j) -base(k+1) +base(k))
3915
3916  g_vflux(i,k) =g_Tmpv1
3917  vflux(i,k) =Tmpv1
3918
3919  ENDDO
3920  ENDDO
3921
3922  DO i =i_start,i_end
3923
3924  g_vflux(i,0) =g_vflux(i,1)
3925  vflux(i,0) =vflux(i,1)
3926
3927  ENDDO
3928
3929  DO i =i_start,i_end
3930
3931  g_vflux(i,ktf) =0.0
3932  vflux(i,ktf) =0.
3933
3934  ENDDO
3935
3936  DO k =kts,ktf
3937  DO i =i_start,i_end
3938
3939  g_Tmpv1 =((-g *g*g_mut(i,j)/(mut(i,j)*mut(i,j)))*alt(i,k,j) -g_alt(i,k,j) &
3940 *g *g/mut(i,j))/(alt(i,k,j)*alt(i,k,j))
3941  Tmpv1 =g *g/mut(i,j)/alt(i,k,j)
3942
3943  g_Tmpv2 =Tmpv1*rdnw(k)*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*rdnw(k) &
3944 *(vflux(i,k) -vflux(i,k-1))
3945  Tmpv2 =Tmpv1*rdnw(k)*(vflux(i,k) -vflux(i,k-1))
3946
3947  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
3948  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
3949
3950  ENDDO
3951  ENDDO
3952  ENDDO
3953
3954  END SUBROUTINE g_vertical_diffusion_mp
3955
3956  SUBROUTINE g_vertical_diffusion_3dmp(field,g_field,tendency,g_tendency, &
3957  config_flags,base_3d,alt,g_alt,mut,g_mut,rdn,rdnw,kvdif,ids,ide,jds,jde,kds, &
3958  kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
3959
3960  IMPLICIT NONE
3961
3962  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3
3963  TYPE(grid_config_rec_type) :: config_flags
3964  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
3965  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field,alt,g_alt,base_3d
3966  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
3967  REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut
3968  REAL,DIMENSION(kms:kme) :: rdn,rdnw
3969  REAL :: kvdif
3970
3971  INTEGER :: i,j,k,itf,jtf,ktf
3972  INTEGER :: i_start,i_end,j_start,j_end
3973  REAL,DIMENSION(its:ite,0:kte+1) :: vflux,g_vflux
3974 ! REAL :: rdz,g_rdz  ! Remarked by Ning Pan, 2010-07-23
3975  LOGICAL :: specified
3976
3977  specified =.false.
3978
3979  if(config_flags%specified .or. config_flags%nested) specified =.true.
3980
3981  ktf =min(kte,kde-1)
3982
3983  i_start =its
3984
3985  i_end =min(ite,ide-1)
3986
3987  j_start =jts
3988
3989  j_end =min(jte,jde-1)
3990
3991  DO j =j_start,j_end
3992  DO k =kts,ktf-1
3993  DO i =i_start,i_end
3994
3995  g_Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(g_field(i,k+1,j) &
3996  -g_field(i,k,j)) +(-kvdif *rdn(k+1)*(0.5*(g_alt(i,k,j) +g_alt(i,k+1,j))) &
3997 /((0.5*(alt(i,k,j) +alt(i,k+1,j)))*(0.5*(alt(i,k,j) +alt(i,k+1,j)))))*(field(i,k+1,j) &
3998  -field(i,k,j) -base_3d(i,k+1,j) +base_3d(i,k,j))
3999  Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(field(i,k+1,j) &
4000  -field(i,k,j) -base_3d(i,k+1,j) +base_3d(i,k,j))
4001
4002  g_vflux(i,k) =g_Tmpv1
4003  vflux(i,k) =Tmpv1
4004
4005  ENDDO
4006  ENDDO
4007
4008  DO i =i_start,i_end
4009
4010  g_vflux(i,0) =g_vflux(i,1)
4011  vflux(i,0) =vflux(i,1)
4012
4013  ENDDO
4014
4015  DO i =i_start,i_end
4016
4017  g_vflux(i,ktf) =0.0
4018  vflux(i,ktf) =0.
4019
4020  ENDDO
4021
4022  DO k =kts,ktf
4023  DO i =i_start,i_end
4024
4025  g_Tmpv1 =((-g *g*g_mut(i,j)/(mut(i,j)*mut(i,j)))*alt(i,k,j) -g_alt(i,k,j) &
4026 *g *g/mut(i,j))/(alt(i,k,j)*alt(i,k,j))
4027  Tmpv1 =g *g/mut(i,j)/alt(i,k,j)
4028
4029  g_Tmpv2 =Tmpv1*rdnw(k)*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*rdnw(k) &
4030 *(vflux(i,k) -vflux(i,k-1))
4031  Tmpv2 =Tmpv1*rdnw(k)*(vflux(i,k) -vflux(i,k-1))
4032
4033  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
4034  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
4035
4036  ENDDO
4037  ENDDO
4038  ENDDO
4039
4040  END SUBROUTINE g_vertical_diffusion_3dmp
4041
4042  SUBROUTINE g_vertical_diffusion_u(field,g_field,tendency,g_tendency, &
4043  config_flags,u_base,alt,g_alt,muu,g_muu,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde, &
4044  ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
4045
4046  IMPLICIT NONE
4047
4048  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3
4049  TYPE(grid_config_rec_type) :: config_flags
4050  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
4051  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field,alt,g_alt
4052  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
4053  REAL,DIMENSION(ims:ime,jms:jme) :: muu,g_muu
4054  REAL,DIMENSION(kms:kme) :: rdn,rdnw,u_base
4055  REAL :: kvdif
4056
4057  INTEGER :: i,j,k,itf,jtf,ktf
4058  INTEGER :: i_start,i_end,j_start,j_end
4059  REAL,DIMENSION(its:ite,0:kte+1) :: vflux,g_vflux
4060  REAL :: rdz,g_rdz,zz,g_zz
4061  LOGICAL :: specified
4062
4063  specified =.false.
4064
4065  if(config_flags%specified .or. config_flags%nested) specified =.true.
4066
4067  ktf =min(kte,kde-1)
4068
4069  i_start =its
4070
4071  i_end =ite
4072
4073  j_start =jts
4074
4075  j_end =min(jte,jde-1)
4076
4077  IF( config_flags%open_xs .or. specified ) i_start =max(ids+1,its)
4078
4079  IF( config_flags%open_xe .or. specified ) i_end =min(ide-1,ite)
4080
4081  IF( config_flags%periodic_x ) i_start =its
4082
4083  IF( config_flags%periodic_x ) i_end =ite
4084
4085  DO j =j_start,j_end
4086  DO k =kts,ktf-1
4087  DO i =i_start,i_end
4088
4089  g_Tmpv1 =kvdif *rdn(k+1)/(0.25*(alt(i,k,j) +alt(i-1,k,j) +alt(i,k+1,j) &
4090  +alt(i-1,k+1,j)))*(g_field(i,k+1,j) -g_field(i,k,j)) +(-kvdif *rdn(k+1) &
4091 *(0.25*(g_alt(i,k,j) +g_alt(i-1,k,j) +g_alt(i,k+1,j) +g_alt(i-1,k+1,j))) &
4092 /((0.25*(alt(i,k,j) +alt(i-1,k,j) +alt(i,k+1,j) +alt(i-1,k+1,j)))*(0.25*(alt(i,k,j) &
4093  +alt(i-1,k,j) +alt(i,k+1,j) +alt(i-1,k+1,j)))))*(field(i,k+1,j) -field(i,k,j) &
4094  -u_base(k+1) +u_base(k))
4095  Tmpv1 =kvdif *rdn(k+1)/(0.25*(alt(i,k,j) +alt(i-1,k,j) +alt(i,k+1,j) +alt(i-1,k+1, &
4096  j)))*(field(i,k+1,j) -field(i,k,j) -u_base(k+1) +u_base(k))
4097
4098  g_vflux(i,k) =g_Tmpv1
4099  vflux(i,k) =Tmpv1
4100
4101  ENDDO
4102  ENDDO
4103
4104  DO i =i_start,i_end
4105
4106  g_vflux(i,0) =g_vflux(i,1)
4107  vflux(i,0) =vflux(i,1)
4108
4109  ENDDO
4110
4111  DO i =i_start,i_end
4112
4113  g_vflux(i,ktf) =0.0
4114  vflux(i,ktf) =0.
4115
4116  ENDDO
4117
4118  DO k =kts,ktf-1
4119  DO i =i_start,i_end
4120
4121  g_Tmpv1 =((-g *g *rdnw(k)*g_muu(i,j)/(muu(i,j)*muu(i,j)))*(0.5*(alt(i-1,k,j) &
4122  +alt(i,k,j))) -(0.5*(g_alt(i-1,k,j) +g_alt(i,k,j)))*g *g *rdnw(k)/muu(i,j)) &
4123 /((0.5*(alt(i-1,k,j) +alt(i,k,j)))*(0.5*(alt(i-1,k,j) +alt(i,k,j))))
4124  Tmpv1 =g *g *rdnw(k)/muu(i,j)/(0.5*(alt(i-1,k,j) +alt(i,k,j)))
4125
4126  g_Tmpv2 =Tmpv1*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*(vflux(i,k) -vflux(i,k-1))
4127  Tmpv2 =Tmpv1*(vflux(i,k) -vflux(i,k-1))
4128
4129  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
4130  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
4131
4132  ENDDO
4133  ENDDO
4134  ENDDO
4135
4136  END SUBROUTINE g_vertical_diffusion_u
4137
4138  SUBROUTINE g_vertical_diffusion_v(field,g_field,tendency,g_tendency, &
4139  config_flags,v_base,alt,g_alt,muv,g_muv,rdn,rdnw,kvdif,ids,ide,jds,jde,kds,kde, &
4140  ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
4141
4142  IMPLICIT NONE
4143
4144  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3
4145  TYPE(grid_config_rec_type) :: config_flags
4146  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
4147  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field,alt,g_alt
4148  REAL,DIMENSION(kms:kme) :: rdn,rdnw,v_base
4149  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
4150  REAL,DIMENSION(ims:ime,jms:jme) :: muv,g_muv
4151  REAL :: kvdif
4152
4153  INTEGER :: i,j,k,itf,jtf,ktf,jm1
4154  INTEGER :: i_start,i_end,j_start,j_end
4155  REAL,DIMENSION(its:ite,0:kte+1) :: vflux,g_vflux
4156 ! REAL :: rdz,g_rdz,zz,g_zz  ! Remarked by Ning Pan, 2010-07-23
4157  LOGICAL :: specified
4158
4159  specified =.false.
4160
4161  if(config_flags%specified .or. config_flags%nested) specified =.true.
4162
4163  ktf =min(kte,kde-1)
4164
4165  i_start =its
4166
4167  i_end =min(ite,ide-1)
4168
4169  j_start =jts
4170
4171  j_end =min(jte,jde-1)
4172
4173  IF( config_flags%open_ys .or. specified ) j_start =max(jds+1,jts)
4174
4175  IF( config_flags%open_ye .or. specified ) j_end =min(jde-1,jte)
4176
4177  DO j =j_start,j_end
4178
4179  jm1 =j-1
4180
4181  DO k =kts,ktf-1
4182  DO i =i_start,i_end
4183
4184  g_Tmpv1 =kvdif *rdn(k+1)/(0.25*(alt(i,k,j) +alt(i,k,jm1) +alt(i,k+1,j) &
4185  +alt(i,k+1,jm1)))*(g_field(i,k+1,j) -g_field(i,k,j)) +(-kvdif *rdn(k+1) &
4186 *(0.25*(g_alt(i,k,j) +g_alt(i,k,jm1) +g_alt(i,k+1,j) +g_alt(i,k+1,jm1))) &
4187 /((0.25*(alt(i,k,j) +alt(i,k,jm1) +alt(i,k+1,j) +alt(i,k+1,jm1)))*(0.25*(alt(i,k,j) &
4188  +alt(i,k,jm1) +alt(i,k+1,j) +alt(i,k+1,jm1)))))*(field(i,k+1,j) -field(i,k,j) &
4189  -v_base(k+1) +v_base(k))
4190  Tmpv1 =kvdif *rdn(k+1)/(0.25*(alt(i,k,j) +alt(i,k,jm1) +alt(i,k+1,j) +alt(i,k+1, &
4191  jm1)))*(field(i,k+1,j) -field(i,k,j) -v_base(k+1) +v_base(k))
4192
4193  g_vflux(i,k) =g_Tmpv1
4194  vflux(i,k) =Tmpv1
4195
4196  ENDDO
4197  ENDDO
4198
4199  DO i =i_start,i_end
4200
4201  g_vflux(i,0) =g_vflux(i,1)
4202  vflux(i,0) =vflux(i,1)
4203
4204  ENDDO
4205
4206  DO i =i_start,i_end
4207
4208  g_vflux(i,ktf) =0.0
4209  vflux(i,ktf) =0.
4210
4211  ENDDO
4212
4213  DO k =kts,ktf-1
4214  DO i =i_start,i_end
4215
4216  g_Tmpv1 =((-g *g *rdnw(k)*g_muv(i,j)/(muv(i,j)*muv(i,j)))*(0.5*(alt(i,k,jm1) &
4217  +alt(i,k,j))) -(0.5*(g_alt(i,k,jm1) +g_alt(i,k,j)))*g *g *rdnw(k)/muv(i,j)) &
4218 /((0.5*(alt(i,k,jm1) +alt(i,k,j)))*(0.5*(alt(i,k,jm1) +alt(i,k,j))))
4219  Tmpv1 =g *g *rdnw(k)/muv(i,j)/(0.5*(alt(i,k,jm1) +alt(i,k,j)))
4220
4221  g_Tmpv2 =Tmpv1*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*(vflux(i,k) -vflux(i,k-1))
4222  Tmpv2 =Tmpv1*(vflux(i,k) -vflux(i,k-1))
4223
4224  g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
4225  tendency(i,k,j) =tendency(i,k,j) +Tmpv2
4226
4227  ENDDO
4228  ENDDO
4229  ENDDO
4230
4231  END SUBROUTINE g_vertical_diffusion_v
4232
4233 SUBROUTINE g_calculate_full ( rfield, g_rfield, rfieldb, rfieldp, g_rfieldp, &
4234                               ids, ide, jds, jde, kds, kde, &
4235                               ims, ime, jms, jme, kms, kme, &
4236                               its, ite, jts, jte, kts, kte )
4237
4238    IMPLICIT NONE
4239
4240    ! Input data
4241
4242    INTEGER ,      INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
4243                                    ims, ime, jms, jme, kms, kme, &
4244                                    its, ite, jts, jte, kts, kte
4245
4246    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: g_rfieldp
4247    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: rfieldb, &
4248                                                                       rfieldp
4249
4250    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT  ) :: g_rfield
4251    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT  ) :: rfield
4252
4253    ! Local indices.
4254
4255    INTEGER :: i, j, k, itf, jtf, ktf
4256
4257 !<DESCRIPTION>
4258 !
4259 !  calculate_full
4260 !  calculates full 3D field from pertubation and base field.
4261 !
4262 !</DESCRIPTION>
4263
4264    itf=MIN(ite,ide-1)
4265    jtf=MIN(jte,jde-1)
4266    ktf=MIN(kte,kde-1)
4267
4268    DO j=jts,jtf
4269    DO k=kts,ktf
4270    DO i=its,itf
4271       g_rfield(i,k,j)=g_rfieldp(i,k,j)
4272       rfield(i,k,j)=rfieldb(i,k,j)+rfieldp(i,k,j)
4273    ENDDO
4274    ENDDO
4275    ENDDO
4276
4277 END SUBROUTINE g_calculate_full
4278
4279 !        Generated by TAPENADE     (INRIA, Tropics team)
4280 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
4281 !
4282 !  Differentiation of coriolis in forward (tangent) mode:
4283 !   variations   of useful results: ru_tend rw_tend rv_tend
4284 !   with respect to varying inputs: ru_tend rw_tend ru rv rw rv_tend
4285 !   RW status of diff variables: ru_tend:in-out rw_tend:in-out
4286 !                ru:in rv:in rw:in rv_tend:in-out
4287 SUBROUTINE G_CORIOLIS(ru, rud, rv, rvd, rw, rwd, ru_tend, ru_tendd, &
4288 &  rv_tend, rv_tendd, rw_tend, rw_tendd, config_flags, msftx, msfty, &
4289 &  msfux, msfuy, msfvx, msfvy, f, e, sina, cosa, fzm, fzp, ids, ide, jds&
4290 &  , jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts&
4291 &  , kte)
4292   IMPLICIT NONE
4293 ! Input data
4294   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
4295   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
4296 &  jme, kms, kme, its, ite, jts, jte, kts, kte
4297   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tend, &
4298 &  rv_tend, rw_tend
4299   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tendd&
4300 &  , rv_tendd, rw_tendd
4301   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ru, rv, rw
4302   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rud, rvd, &
4303 &  rwd
4304   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
4305 &  msfvy, msftx, msfty
4306   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: f, e, sina, cosa
4307   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
4308 ! Local indices.
4309   INTEGER :: i, j, k, ktf
4310   INTEGER :: i_start, i_end, j_start, j_end
4311   LOGICAL :: specified
4312   INTEGER :: min4
4313   INTEGER :: min3
4314   INTEGER :: min2
4315   INTEGER :: min1
4316 !<DESCRIPTION>
4317 !
4318 !  coriolis calculates the large timestep tendency terms in the
4319 !  u, v, and w momentum equations arise from the coriolis force.
4320 !
4321 !</DESCRIPTION>
4322   specified = .false.
4323   IF (config_flags%specified .OR. config_flags%nested) specified = &
4324 &      .true.
4325   IF (kte .GT. kde - 1) THEN
4326     ktf = kde - 1
4327   ELSE
4328     ktf = kte
4329   END IF
4330 ! coriolis for u-momentum equation
4331 !  Notes on map scale factor
4332 !  cosa, sina are related to rotating the coordinate frame if desired
4333 !  generally sina=0, cosa=1
4334 !  ADT eqn 44, RHS terms 6 and 7: -2 mu w omega cos(lat)/my
4335 !                                + 2 mu v omega sin(lat)/my
4336 !  Define f=2 omega sin(lat), e=2 omega cos(lat)
4337 !   => terms are: -e mu w / my + f mu v / my
4338 !  rv = mu v / mx ; rw = mu w / my
4339 !   => terms are: -e rw + f rv *mx / my
4340   i_start = its
4341   i_end = ite
4342   IF ((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
4343 &  THEN
4344     IF (ids + 1 .LT. its) THEN
4345       i_start = its
4346     ELSE
4347       i_start = ids + 1
4348     END IF
4349   END IF
4350   IF ((config_flags%open_xe .OR. specified) .OR. config_flags%nested) &
4351 &  THEN
4352     IF (ide - 1 .GT. ite) THEN
4353       i_end = ite
4354     ELSE
4355       i_end = ide - 1
4356     END IF
4357   END IF
4358   IF (config_flags%periodic_x) i_start = its
4359   IF (config_flags%periodic_x) i_end = ite
4360   IF (jte .GT. jde - 1) THEN
4361     min1 = jde - 1
4362   ELSE
4363     min1 = jte
4364   END IF
4365   DO j=jts,min1
4366     DO k=kts,ktf
4367       DO i=i_start,i_end
4368         ru_tendd(i, k, j) = ru_tendd(i, k, j) + msfux(i, j)*0.5*(f(i, j)&
4369 &          +f(i-1, j))*0.25*(rvd(i-1, k, j+1)+rvd(i, k, j+1)+rvd(i-1, k, &
4370 &          j)+rvd(i, k, j))/msfuy(i, j) - 0.5**2*(e(i, j)+e(i-1, j))*(&
4371 &          cosa(i, j)+cosa(i-1, j))*0.25*(rwd(i-1, k+1, j)+rwd(i-1, k, j)&
4372 &          +rwd(i, k+1, j)+rwd(i, k, j))
4373         ru_tend(i, k, j) = ru_tend(i, k, j) + msfux(i, j)/msfuy(i, j)*&
4374 &          0.5*(f(i, j)+f(i-1, j))*0.25*(rv(i-1, k, j+1)+rv(i, k, j+1)+rv&
4375 &          (i-1, k, j)+rv(i, k, j)) - 0.5*(e(i, j)+e(i-1, j))*0.5*(cosa(i&
4376 &          , j)+cosa(i-1, j))*0.25*(rw(i-1, k+1, j)+rw(i-1, k, j)+rw(i, k&
4377 &          +1, j)+rw(i, k, j))
4378       END DO
4379     END DO
4380   END DO
4381 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
4382 !  IF ( (config_flags%open_xs) .and. (its == ids) ) THEN
4383 !    DO k=kts,ktf
4384 !
4385 !      ru_tend(its,k,j)=ru_tend(its,k,j) + (msfux(its,j)/msfuy(its,j))*0.5*(f(its,j)+f(its,j))   &
4386 !        *0.25*(rv(its,k,j+1)+rv(its,k,j+1)+rv(its,k,j)+rv(its,k,j)) &
4387 !            - 0.5*(e(its,j)+e(its,j))*0.5*(cosa(its,j)+cosa(its,j)) &
4388 !        *0.25*(rw(its,k+1,j)+rw(its,k,j)+rw(its,k+1,j)+rw(its,k,j))
4389 !    ENDDO
4390 !  ENDIF
4391 !  IF ( (config_flags%open_xe) .and. (ite == ide) ) THEN
4392 !    DO k=kts,ktf
4393 !
4394 !      ru_tend(ite,k,j)=ru_tend(ite,k,j) + (msfux(ite,j)/msfuy(ite,j))*0.5*(f(ite-1,j)+f(ite-1,j)) &
4395 !        *0.25*(rv(ite-1,k,j+1)+rv(ite-1,k,j+1)+rv(ite-1,k,j)+rv(ite-1,k,j)) &
4396 !            - 0.5*(e(ite-1,j)+e(ite-1,j))*0.5*(cosa(ite-1,j)+cosa(ite-1,j)) &
4397 !        *0.25*(rw(ite-1,k+1,j)+rw(ite-1,k,j)+rw(ite-1,k+1,j)+rw(ite-1,k,j))
4398 !    ENDDO
4399 !  ENDIF
4400 !  coriolis term for v-momentum equation
4401 !  Notes on map scale factors
4402 !  ADT eqn 45, RHS terms 6 and 6b [0 for sina=0]: -2 mu u omega sin(lat)/mx + ?
4403 !  Define f=2 omega sin(lat), e=2 omega cos(lat)
4404 !   => terms are: -f mu u / mx
4405 !  ru = mu u / my ; rw = mu w / my
4406 !   => terms are: -f ru *my / mx + ?
4407   j_start = jts
4408   j_end = jte
4409   IF (((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
4410 &      .OR. config_flags%polar) THEN
4411     IF (jds + 1 .LT. jts) THEN
4412       j_start = jts
4413     ELSE
4414       j_start = jds + 1
4415     END IF
4416   END IF
4417   IF (((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
4418 &      .OR. config_flags%polar) THEN
4419     IF (jde - 1 .GT. jte) THEN
4420       j_end = jte
4421     ELSE
4422       j_end = jde - 1
4423     END IF
4424   END IF
4425 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
4426 !  IF ( (config_flags%open_ys) .and. (jts == jds) ) THEN
4427 !    DO k=kts,ktf
4428 !    DO i=its,MIN(ide-1,ite)
4429 !
4430 !       rv_tend(i,k,jts)=rv_tend(i,k,jts) - (msfvy(i,jts)/msfvx(i,jts))*0.5*(f(i,jts)+f(i,jts))    &
4431 !        *0.25*(ru(i,k,jts)+ru(i+1,k,jts)+ru(i,k,jts)+ru(i+1,k,jts))   &
4432 !            + (msfvy(i,jts)/msfvx(i,jts))*0.5*(e(i,jts)+e(i,jts))*0.5*(sina(i,jts)+sina(i,jts))   &
4433 !            *0.25*(rw(i,k+1,jts)+rw(i,k,jts)+rw(i,k+1,jts)+rw(i,k,jts))
4434 !    ENDDO
4435 !    ENDDO
4436 !  ENDIF
4437   DO j=j_start,j_end
4438     DO k=kts,ktf
4439       IF (ide - 1 .GT. ite) THEN
4440         min2 = ite
4441       ELSE
4442         min2 = ide - 1
4443       END IF
4444       DO i=its,min2
4445         rv_tendd(i, k, j) = rv_tendd(i, k, j) - msfvy(i, j)*0.5*(f(i, j)&
4446 &          +f(i, j-1))*0.25*(rud(i, k, j)+rud(i+1, k, j)+rud(i, k, j-1)+&
4447 &          rud(i+1, k, j-1))/msfvx(i, j) + msfvy(i, j)*0.5**2*(e(i, j)+e(&
4448 &          i, j-1))*(sina(i, j)+sina(i, j-1))*0.25*(rwd(i, k+1, j-1)+rwd(&
4449 &          i, k, j-1)+rwd(i, k+1, j)+rwd(i, k, j))/msfvx(i, j)
4450         rv_tend(i, k, j) = rv_tend(i, k, j) - msfvy(i, j)/msfvx(i, j)*&
4451 &          0.5*(f(i, j)+f(i, j-1))*0.25*(ru(i, k, j)+ru(i+1, k, j)+ru(i, &
4452 &          k, j-1)+ru(i+1, k, j-1)) + msfvy(i, j)/msfvx(i, j)*0.5*(e(i, j&
4453 &          )+e(i, j-1))*0.5*(sina(i, j)+sina(i, j-1))*0.25*(rw(i, k+1, j-&
4454 &          1)+rw(i, k, j-1)+rw(i, k+1, j)+rw(i, k, j))
4455       END DO
4456     END DO
4457   END DO
4458   IF (jte .GT. jde - 1) THEN
4459     min3 = jde - 1
4460   ELSE
4461     min3 = jte
4462   END IF
4463 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
4464 !  IF ( (config_flags%open_ye) .and. (jte == jde) ) THEN
4465 !    DO k=kts,ktf
4466 !    DO i=its,MIN(ide-1,ite)
4467 !
4468 !       rv_tend(i,k,jte)=rv_tend(i,k,jte) - (msfvy(i,jte)/msfvx(i,jte))*0.5*(f(i,jte-1)+f(i,jte-1))        &
4469 !        *0.25*(ru(i,k,jte-1)+ru(i+1,k,jte-1)+ru(i,k,jte-1)+ru(i+1,k,jte-1))   &
4470 !            + (msfvy(i,jte)/msfvx(i,jte))*0.5*(e(i,jte-1)+e(i,jte-1))*0.5*(sina(i,jte-1)+sina(i,jte-1))   &
4471 !            *0.25*(rw(i,k+1,jte-1)+rw(i,k,jte-1)+rw(i,k+1,jte-1)+rw(i,k,jte-1))
4472 !    ENDDO
4473 !    ENDDO
4474 !  ENDIF
4475 ! coriolis term for w-mometum
4476 ! Notes on map scale factors
4477 ! ADT eqn 46/my, RHS terms 5 and 5b [0 for sina=0]: 2 mu u omega cos(lat)/my +?
4478 ! Define e=2 omega cos(lat)
4479 !  => terms are: e mu u / my + ???
4480 ! ru = mu u / my ; ru = mu v / mx
4481 !  => terms are: e ru + ???
4482   DO j=jts,min3
4483     DO k=kts+1,ktf
4484       IF (ite .GT. ide - 1) THEN
4485         min4 = ide - 1
4486       ELSE
4487         min4 = ite
4488       END IF
4489       DO i=its,min4
4490         rw_tendd(i, k, j) = rw_tendd(i, k, j) + e(i, j)*(cosa(i, j)*0.5*&
4491 &          (fzm(k)*(rud(i, k, j)+rud(i+1, k, j))+fzp(k)*(rud(i, k-1, j)+&
4492 &          rud(i+1, k-1, j)))-msftx(i, j)*sina(i, j)*0.5*(fzm(k)*(rvd(i, &
4493 &          k, j)+rvd(i, k, j+1))+fzp(k)*(rvd(i, k-1, j)+rvd(i, k-1, j+1))&
4494 &          )/msfty(i, j))
4495         rw_tend(i, k, j) = rw_tend(i, k, j) + e(i, j)*(cosa(i, j)*0.5*(&
4496 &          fzm(k)*(ru(i, k, j)+ru(i+1, k, j))+fzp(k)*(ru(i, k-1, j)+ru(i+&
4497 &          1, k-1, j)))-msftx(i, j)/msfty(i, j)*sina(i, j)*0.5*(fzm(k)*(&
4498 &          rv(i, k, j)+rv(i, k, j+1))+fzp(k)*(rv(i, k-1, j)+rv(i, k-1, j+&
4499 &          1))))
4500       END DO
4501     END DO
4502   END DO
4503 END SUBROUTINE G_CORIOLIS
4504
4505  SUBROUTINE g_perturbation_coriolis(ru_in,g_ru_in,rv_in,g_rv_in,rw,g_rw, &
4506  ru_tend,g_ru_tend,rv_tend,g_rv_tend,rw_tend,g_rw_tend,config_flags,u_base, &
4507  v_base,z_base,muu,g_muu,muv,g_muv,phb,ph,g_ph,msftx,msfty,msfux,msfuy,msfvx, &
4508  msfvy,f,e,sina,cosa,fzm,fzp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite, &
4509  jts,jte,kts,kte)
4510
4511  IMPLICIT NONE
4512
4513  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
4514  g_Tmpv5,Tmpv6,g_Tmpv6,Tmpv7,g_Tmpv7,Tmpv8,g_Tmpv8,Tmpv9,g_Tmpv9
4515  TYPE(grid_config_rec_type) :: config_flags
4516  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
4517  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_tend,g_ru_tend,rv_tend,g_rv_tend, &
4518  rw_tend,g_rw_tend
4519  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_in,g_ru_in,rv_in,g_rv_in,rw, &
4520  g_rw,ph,g_ph,phb
4521  REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty
4522  REAL,DIMENSION(ims:ime,jms:jme) :: f,e,sina,cosa
4523  REAL,DIMENSION(ims:ime,jms:jme) :: muu,g_muu,muv,g_muv
4524  REAL,DIMENSION(kms:kme) :: fzm,fzp
4525  REAL,DIMENSION(kms:kme) :: u_base,v_base,z_base
4526
4527  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru,g_ru,rv,g_rv
4528  REAL :: z_at_u,g_z_at_u,z_at_v,g_z_at_v,wkp1,g_wkp1,wk,g_wk,wkm1,g_wkm1
4529
4530  INTEGER :: i,j,k,ktf
4531  INTEGER :: i_start,i_end,j_start,j_end
4532  LOGICAL :: specified
4533
4534  specified =.false.
4535
4536  if(config_flags%specified .or. config_flags%nested) specified =.true.
4537
4538  ktf =min(kte,kde-1)
4539
4540  i_start =its
4541
4542  i_end =ite
4543
4544  IF( config_flags%open_xs .or. specified .or.   &
4545         config_flags%nested) i_start =max(ids+1,its)
4546
4547  IF( config_flags%open_xe .or. specified .or.   &
4548         config_flags%nested) i_end =min(ide-1,ite)
4549
4550  IF( config_flags%periodic_x ) i_start =its
4551
4552  IF( config_flags%periodic_x ) i_end =ite
4553
4554  DO j =jts,min(jte,jde-1) +1
4555  DO k =kts+1,ktf-1
4556  DO i =i_start-1,i_end
4557
4558  g_z_at_v =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i,k,j-1) +g_ph(i,k+1,j-1))/g
4559  z_at_v =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i,k,j-1)+phb(i,k+1,j-1) +ph(i,k,j) &
4560  +ph(i,k+1,j) +ph(i,k,j-1) +ph(i,k+1,j-1))/g
4561
4562  g_wkp1 =(0.0 +((0.0 +g_z_at_v +(0.0 -g_z_at_v)*sign(1.0, 0. -(z_at_v - &
4563  z_base(k))))*0.5/(z_base(k+1)-z_base(k))) -(0.0 -((0.0 +g_z_at_v +(0.0 - &
4564  g_z_at_v)*sign(1.0, 0. -(z_at_v -z_base(k))))*0.5/(z_base(k+1)-z_base(k)))) &
4565 *sign(1.0, 1. -(max(0.,z_at_v -z_base(k))/(z_base(k+1)-z_base(k)))))*0.5
4566  wkp1 =min(1.,max(0.,z_at_v -z_base(k))/(z_base(k+1)-z_base(k)))
4567
4568 !REVISED BY WALLS
4569 !g_wkm1 =(0.0 +((0.0 +g_z_at_v +(0.0 +g_z_at_v)*sign(1.0, 0. -(z_base(k) &
4570 ! Revised by Ning Pan, 2010-07-24
4571 ! g_wkm1 =(0.0 +((0.0 +g_z_at_v +(0.0 +g_z_at_v)*sign(1.0, 0. -(z_base(k) &
4572 ! -z_at_v)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 +g_z_at_v +(0.0 + &
4573 ! g_z_at_v)*sign(1.0, 0. -(z_base(k) -z_at_v)))*0.5/(z_base(k)-z_base(k-1)))) &
4574 !*sign(1.0,! 1. -(max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))))*0.5
4575  g_wkm1 =(0.0 +((0.0 -g_z_at_v +(0.0 +g_z_at_v)*sign(1.0, 0. -(z_base(k) &
4576  -z_at_v)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 -g_z_at_v +(0.0 + &
4577  g_z_at_v)*sign(1.0, 0. -(z_base(k) -z_at_v)))*0.5/(z_base(k)-z_base(k-1)))) &
4578 *sign(1.0, 1. -(max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))))*0.5
4579  wkm1 =min(1.,max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))
4580
4581  g_wk =-g_wkp1 -g_wkm1
4582  wk =1. -wkp1 -wkm1
4583
4584  g_Tmpv1 =muv(i,j)*(g_wkm1*v_base(k-1) +g_wk*v_base(k) +g_wkp1*v_base(k+ &
4585  1)) +g_muv(i,j)*(wkm1*v_base(k-1) +wk*v_base(k) +wkp1*v_base(k+1))
4586  Tmpv1 =muv(i,j)*(wkm1*v_base(k-1) +wk*v_base(k) +wkp1*v_base(k+1))
4587
4588  g_rv(i,k,j) =g_rv_in(i,k,j) -g_Tmpv1
4589  rv(i,k,j) =rv_in(i,k,j) -Tmpv1
4590
4591  ENDDO
4592  ENDDO
4593  ENDDO
4594
4595  DO j =jts,min(jte,jde-1) +1
4596  DO i =i_start-1,i_end
4597
4598  k =kts
4599
4600  g_z_at_v =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i,k,j-1) +g_ph(i,k+1,j-1))/g
4601  z_at_v =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i,k,j-1)+phb(i,k+1,j-1) +ph(i,k,j) &
4602  +ph(i,k+1,j) +ph(i,k,j-1) +ph(i,k+1,j-1))/g
4603
4604  g_wkp1 =(0.0 +((0.0 +g_z_at_v +(0.0 -g_z_at_v)*sign(1.0, 0. -(z_at_v - &
4605  z_base(k))))*0.5/(z_base(k+1)-z_base(k))) -(0.0 -((0.0 +g_z_at_v +(0.0 - &
4606  g_z_at_v)*sign(1.0, 0. -(z_at_v -z_base(k))))*0.5/(z_base(k+1)-z_base(k)))) &
4607 *sign(1.0, 1. -(max(0.,z_at_v -z_base(k))/(z_base(k+1)-z_base(k)))))*0.5
4608  wkp1 =min(1.,max(0.,z_at_v -z_base(k))/(z_base(k+1)-z_base(k)))
4609
4610  g_wk =-g_wkp1
4611  wk =1. -wkp1
4612
4613  g_Tmpv1 =muv(i,j)*(g_wk*v_base(k) +g_wkp1*v_base(k+1)) +g_muv(i,j) &
4614 *(wk*v_base(k) +wkp1*v_base(k+1))
4615  Tmpv1 =muv(i,j)*(wk*v_base(k) +wkp1*v_base(k+1))
4616
4617  g_rv(i,k,j) =g_rv_in(i,k,j) -g_Tmpv1
4618  rv(i,k,j) =rv_in(i,k,j) -Tmpv1
4619
4620  k =ktf
4621
4622  g_z_at_v =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i,k,j-1) +g_ph(i,k+1,j-1))/g
4623  z_at_v =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i,k,j-1)+phb(i,k+1,j-1) +ph(i,k,j) &
4624  +ph(i,k+1,j) +ph(i,k,j-1) +ph(i,k+1,j-1))/g
4625
4626 ! Revised by Ning Pan, 2010-07-24
4627 ! g_wkm1 =(0.0 +((0.0 +g_z_at_v +(0.0 +g_z_at_v)*sign(1.0, 0. -(z_base(k) &
4628 ! -z_at_v)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 +g_z_at_v +(0.0 + &
4629 ! g_z_at_v)*sign(1.0, 0. -(z_base(k) -z_at_v)))*0.5/(z_base(k)-z_base(k-1)))) &
4630 !*sign(1.0,! 1. -(max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))))*0.5
4631  g_wkm1 =(0.0 +((0.0 -g_z_at_v +(0.0 +g_z_at_v)*sign(1.0, 0. -(z_base(k) &
4632  -z_at_v)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 -g_z_at_v +(0.0 + &
4633  g_z_at_v)*sign(1.0, 0. -(z_base(k) -z_at_v)))*0.5/(z_base(k)-z_base(k-1)))) &
4634 *sign(1.0, 1. -(max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))))*0.5
4635  wkm1 =min(1.,max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))
4636
4637  g_wk =-g_wkm1
4638  wk =1. -wkm1
4639
4640  g_Tmpv1 =muv(i,j)*(g_wkm1*v_base(k-1) +g_wk*v_base(k)) +g_muv(i,j) &
4641 *(wkm1*v_base(k-1) +wk*v_base(k))
4642  Tmpv1 =muv(i,j)*(wkm1*v_base(k-1) +wk*v_base(k))
4643
4644  g_rv(i,k,j) =g_rv_in(i,k,j) -g_Tmpv1
4645  rv(i,k,j) =rv_in(i,k,j) -Tmpv1
4646
4647  ENDDO
4648  ENDDO
4649
4650  DO j =jts,min(jte,jde-1)
4651  DO k =kts,ktf
4652  DO i =i_start,i_end
4653
4654  g_ru_tend(i,k,j) =g_ru_tend(i,k,j) +(msfux(i,j)/msfuy(i,j)) *0.5 *(f(i,j) &
4655 +f(i-1,j)) *0.25*(g_rv(i-1,k,j+1) +g_rv(i,k,j+1) +g_rv(i-1,k,j) &
4656  +g_rv(i,k,j)) -0.5 *(e(i,j)+e(i-1,j)) *0.5 *(cosa(i,j)+cosa(i-1,j)) &
4657  *0.25*(g_rw(i-1,k+1,j) +g_rw(i-1,k,j) +g_rw(i,k+1,j) +g_rw(i,k,j))
4658  ru_tend(i,k,j) =ru_tend(i,k,j) +(msfux(i,j)/msfuy(i,j)) *0.5 *(f(i,j)+f(i-1,j)) &
4659  *0.25*(rv(i-1,k,j+1) +rv(i,k,j+1) +rv(i-1,k,j) +rv(i,k,j)) -0.5 *(e(i,j)+e(i-1,j)) &
4660  *0.5 *(cosa(i,j)+cosa(i-1,j)) *0.25*(rw(i-1,k+1,j) +rw(i-1,k,j) +rw(i,k+1,j) +rw(i,k,j))
4661
4662  ENDDO
4663  ENDDO
4664
4665 ! boundary loops for perturbation coriolis is needed for open bdy  (20110307 XZ)
4666  IF( (config_flags%open_xs) .and. (its == ids) ) THEN
4667
4668  DO k =kts,ktf
4669
4670  g_ru_tend(its,k,j) =g_ru_tend(its,k,j) +(msfux(its,j)/msfuy(its,j)) &
4671  *0.5 *(f(its,j)+f(its,j)) *0.25*(g_rv(its,k,j+1) +g_rv(its,k,j+1) &
4672  +g_rv(its,k,j) +g_rv(its,k,j)) -0.5 *(e(its,j)+e(its,j)) *0.5 *(cosa(its,j) &
4673 +cosa(its,j)) *0.25*(g_rw(its,k+1,j) +g_rw(its,k,j) +g_rw(its,k+1,j) &
4674  +g_rw(its,k,j))
4675  ru_tend(its,k,j) =ru_tend(its,k,j) +(msfux(its,j)/msfuy(its,j)) *0.5 *(f(its,j) &
4676 +f(its,j)) *0.25*(rv(its,k,j+1) +rv(its,k,j+1) +rv(its,k,j) +rv(its,k,j)) &
4677  -0.5 *(e(its,j)+e(its,j)) *0.5 *(cosa(its,j)+cosa(its,j)) *0.25*(rw(its,k+1,j) &
4678  +rw(its,k,j) +rw(its,k+1,j) +rw(its,k,j))
4679
4680  ENDDO
4681  ENDIF
4682
4683  IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
4684
4685  DO k =kts,ktf
4686
4687  g_ru_tend(ite,k,j) =g_ru_tend(ite,k,j) +(msfux(ite,j)/msfuy(ite,j)) &
4688  *0.5 *(f(ite-1,j)+f(ite-1,j)) *0.25*(g_rv(ite-1,k,j+1) +g_rv(ite-1,k,j+1) &
4689  +g_rv(ite-1,k,j) +g_rv(ite-1,k,j)) -0.5 *(e(ite-1,j)+e(ite-1,j)) &
4690  *0.5 *(cosa(ite-1,j)+cosa(ite-1,j)) *0.25*(g_rw(ite-1,k+1,j) +g_rw(ite-1,k,j) &
4691  +g_rw(ite-1,k+1,j) +g_rw(ite-1,k,j))
4692  ru_tend(ite,k,j) =ru_tend(ite,k,j) +(msfux(ite,j)/msfuy(ite,j)) *0.5 *(f(ite-1,j) &
4693 +f(ite-1,j)) *0.25*(rv(ite-1,k,j+1) +rv(ite-1,k,j+1) +rv(ite-1,k,j) +rv(ite-1,k,j)) &
4694  -0.5 *(e(ite-1,j)+e(ite-1,j)) *0.5 *(cosa(ite-1,j)+cosa(ite-1,j)) *0.25*(rw(ite-1,k+ &
4695  1,j) +rw(ite-1,k,j) +rw(ite-1,k+1,j) +rw(ite-1,k,j))
4696
4697  ENDDO
4698  ENDIF
4699
4700  ENDDO
4701
4702  j_start =jts
4703
4704  j_end =jte
4705
4706  IF( config_flags%open_ys .or. specified .or.   &
4707         config_flags%nested .or. config_flags%polar) j_start =max(jds+1,jts)
4708
4709  IF( config_flags%open_ye .or. specified .or.   &
4710         config_flags%nested .or. config_flags%polar) j_end =min(jde-1,jte)
4711
4712  DO j =j_start-1,j_end
4713  DO k =kts+1,ktf-1
4714  DO i =its,min(ite,ide-1) +1
4715
4716  g_z_at_u =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i-1,k,j) +g_ph(i-1,k+1,j))/g
4717  z_at_u =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i-1,k,j)+phb(i-1,k+1,j) +ph(i,k,j) &
4718  +ph(i,k+1,j) +ph(i-1,k,j) +ph(i-1,k+1,j))/g
4719
4720  g_wkp1 =(0.0 +((0.0 +g_z_at_u +(0.0 -g_z_at_u)*sign(1.0, 0. -(z_at_u - &
4721  z_base(k))))*0.5/(z_base(k+1)-z_base(k))) -(0.0 -((0.0 +g_z_at_u +(0.0 - &
4722  g_z_at_u)*sign(1.0, 0. -(z_at_u -z_base(k))))*0.5/(z_base(k+1)-z_base(k)))) &
4723 *sign(1.0, 1. -(max(0.,z_at_u -z_base(k))/(z_base(k+1)-z_base(k)))))*0.5
4724  wkp1 =min(1.,max(0.,z_at_u -z_base(k))/(z_base(k+1)-z_base(k)))
4725
4726 ! Revised by Ning Pan, 2010-07-24
4727 ! g_wkm1 =(0.0 +((0.0 +g_z_at_u +(0.0 +g_z_at_u)*sign(1.0, 0. -(z_base(k) &
4728 ! -z_at_u)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 +g_z_at_u +(0.0 + &
4729 ! g_z_at_u)*sign(1.0, 0. -(z_base(k) -z_at_u)))*0.5/(z_base(k)-z_base(k-1)))) &
4730 !*sign(1.0,! 1. -(max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))))*0.5
4731  g_wkm1 =(0.0 +((0.0 -g_z_at_u +(0.0 +g_z_at_u)*sign(1.0, 0. -(z_base(k) &
4732  -z_at_u)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 -g_z_at_u +(0.0 + &
4733  g_z_at_u)*sign(1.0, 0. -(z_base(k) -z_at_u)))*0.5/(z_base(k)-z_base(k-1)))) &
4734 *sign(1.0, 1. -(max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))))*0.5
4735  wkm1 =min(1.,max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))
4736
4737  g_wk =-g_wkp1 -g_wkm1
4738  wk =1. -wkp1 -wkm1
4739
4740  g_Tmpv1 =muu(i,j)*(g_wkm1*u_base(k-1) +g_wk*u_base(k) +g_wkp1*u_base(k+ &
4741  1)) +g_muu(i,j)*(wkm1*u_base(k-1) +wk*u_base(k) +wkp1*u_base(k+1))
4742  Tmpv1 =muu(i,j)*(wkm1*u_base(k-1) +wk*u_base(k) +wkp1*u_base(k+1))
4743
4744  g_ru(i,k,j) =g_ru_in(i,k,j) -g_Tmpv1
4745  ru(i,k,j) =ru_in(i,k,j) -Tmpv1
4746
4747  ENDDO
4748  ENDDO
4749  ENDDO
4750
4751  DO j =j_start-1,j_end
4752  DO i =its,min(ite,ide-1) +1
4753
4754  k =kts
4755
4756  g_z_at_u =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i-1,k,j) +g_ph(i-1,k+1,j))/g
4757  z_at_u =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i-1,k,j)+phb(i-1,k+1,j) +ph(i,k,j) &
4758  +ph(i,k+1,j) +ph(i-1,k,j) +ph(i-1,k+1,j))/g
4759
4760  g_wkp1 =(0.0 +((0.0 +g_z_at_u +(0.0 -g_z_at_u)*sign(1.0, 0. -(z_at_u - &
4761  z_base(k))))*0.5/(z_base(k+1)-z_base(k))) -(0.0 -((0.0 +g_z_at_u +(0.0 - &
4762  g_z_at_u)*sign(1.0, 0. -(z_at_u -z_base(k))))*0.5/(z_base(k+1)-z_base(k)))) &
4763 *sign(1.0, 1. -(max(0.,z_at_u -z_base(k))/(z_base(k+1)-z_base(k)))))*0.5
4764  wkp1 =min(1.,max(0.,z_at_u -z_base(k))/(z_base(k+1)-z_base(k)))
4765
4766  g_wk =-g_wkp1
4767  wk =1. -wkp1
4768
4769  g_Tmpv1 =muu(i,j)*(g_wk*u_base(k) +g_wkp1*u_base(k+1)) +g_muu(i,j) &
4770 *(wk*u_base(k) +wkp1*u_base(k+1))
4771  Tmpv1 =muu(i,j)*(wk*u_base(k) +wkp1*u_base(k+1))
4772
4773  g_ru(i,k,j) =g_ru_in(i,k,j) -g_Tmpv1
4774  ru(i,k,j) =ru_in(i,k,j) -Tmpv1
4775
4776  k =ktf
4777
4778  g_z_at_u =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i-1,k,j) +g_ph(i-1,k+1,j))/g
4779  z_at_u =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i-1,k,j)+phb(i-1,k+1,j) +ph(i,k,j) &
4780  +ph(i,k+1,j) +ph(i-1,k,j) +ph(i-1,k+1,j))/g
4781
4782 ! Revised by Ning Pan, 2010-07-24
4783 ! g_wkm1 =(0.0 +((0.0 +g_z_at_u +(0.0 +g_z_at_u)*sign(1.0, 0. -(z_base(k) &
4784 ! -z_at_u)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 +g_z_at_u +(0.0 + &
4785 ! g_z_at_u)*sign(1.0, 0. -(z_base(k) -z_at_u)))*0.5/(z_base(k)-z_base(k-1)))) &
4786 !*sign(1.0,! 1. -(max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))))*0.5
4787  g_wkm1 =(0.0 +((0.0 -g_z_at_u +(0.0 +g_z_at_u)*sign(1.0, 0. -(z_base(k) &
4788  -z_at_u)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 -g_z_at_u +(0.0 + &
4789  g_z_at_u)*sign(1.0, 0. -(z_base(k) -z_at_u)))*0.5/(z_base(k)-z_base(k-1)))) &
4790 *sign(1.0, 1. -(max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))))*0.5
4791  wkm1 =min(1.,max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))
4792
4793  g_wk =-g_wkm1
4794  wk =1. -wkm1
4795
4796  g_Tmpv1 =muu(i,j)*(g_wkm1*u_base(k-1) +g_wk*u_base(k)) +g_muu(i,j) &
4797 *(wkm1*u_base(k-1) +wk*u_base(k))
4798  Tmpv1 =muu(i,j)*(wkm1*u_base(k-1) +wk*u_base(k))
4799
4800  g_ru(i,k,j) =g_ru_in(i,k,j) -g_Tmpv1
4801  ru(i,k,j) =ru_in(i,k,j) -Tmpv1
4802
4803  ENDDO
4804  ENDDO
4805
4806 ! boundary loops for perturbation coriolis is needed for open bdy  (20110301 XZ)
4807  IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
4808
4809  DO k =kts,ktf
4810  DO i =its,min(ide-1,ite)
4811
4812  g_rv_tend(i,k,jts) =g_rv_tend(i,k,jts) -(msfvy(i,jts)/msfvx(i,jts)) &
4813  *0.5 *(f(i,jts)+f(i,jts)) *0.25*(g_ru(i,k,jts) +g_ru(i+1,k,jts) +g_ru(i,k, &
4814  jts) +g_ru(i+1,k,jts)) +(msfvy(i,jts)/msfvx(i,jts)) *0.5 *(e(i,jts)+e(i,jts)) &
4815  *0.5 *(sina(i,jts)+sina(i,jts)) *0.25*(g_rw(i,k+1,jts) +g_rw(i,k,jts) &
4816  +g_rw(i,k+1,jts) +g_rw(i,k,jts))
4817  rv_tend(i,k,jts) =rv_tend(i,k,jts) -(msfvy(i,jts)/msfvx(i,jts)) *0.5 *(f(i,jts) &
4818 +f(i,jts)) *0.25*(ru(i,k,jts) +ru(i+1,k,jts) +ru(i,k,jts) +ru(i+1,k,jts)) &
4819  +(msfvy(i,jts)/msfvx(i,jts)) *0.5 *(e(i,jts)+e(i,jts)) *0.5 *(sina(i,jts) &
4820 +sina(i,jts)) *0.25*(rw(i,k+1,jts) +rw(i,k,jts) +rw(i,k+1,jts) +rw(i,k,jts))
4821
4822  ENDDO
4823  ENDDO
4824  ENDIF
4825
4826  DO j =j_start,j_end
4827  DO k =kts,ktf
4828  DO i =its,min(ide-1,ite)
4829
4830  g_rv_tend(i,k,j) =g_rv_tend(i,k,j) -(msfvy(i,j)/msfvx(i,j)) *0.5 *(f(i,j) &
4831 +f(i,j-1)) *0.25*(g_ru(i,k,j) +g_ru(i+1,k,j) +g_ru(i,k,j-1) +g_ru(i+1,k, &
4832  j-1)) +(msfvy(i,j)/msfvx(i,j)) *0.5 *(e(i,j)+e(i,j-1)) *0.5 *(sina(i,j)+sina(i,j-1)) &
4833  *0.25*(g_rw(i,k+1,j-1) +g_rw(i,k,j-1) +g_rw(i,k+1,j) +g_rw(i,k,j))
4834  rv_tend(i,k,j) =rv_tend(i,k,j) -(msfvy(i,j)/msfvx(i,j)) *0.5 *(f(i,j)+f(i,j-1)) &
4835  *0.25*(ru(i,k,j) +ru(i+1,k,j) +ru(i,k,j-1) +ru(i+1,k,j-1)) +(msfvy(i,j)/msfvx(i,j)) &
4836  *0.5 *(e(i,j)+e(i,j-1)) *0.5 *(sina(i,j)+sina(i,j-1)) *0.25*(rw(i,k+1,j-1) &
4837  +rw(i,k,j-1) +rw(i,k+1,j) +rw(i,k,j))
4838
4839  ENDDO
4840  ENDDO
4841  ENDDO
4842
4843 ! boundary loops for perturbation coriolis is needed for open bdy  (20110307 XZ)
4844  IF( (config_flags%open_ye) .and. (jte == jde) ) THEN
4845
4846  DO k =kts,ktf
4847  DO i =its,min(ide-1,ite)
4848
4849  g_rv_tend(i,k,jte) =g_rv_tend(i,k,jte) -(msfvy(i,jte)/msfvx(i,jte)) &
4850  *0.5 *(f(i,jte-1)+f(i,jte-1)) *0.25*(g_ru(i,k,jte-1) +g_ru(i+1,k,jte-1) &
4851  +g_ru(i,k,jte-1) +g_ru(i+1,k,jte-1)) +(msfvy(i,jte)/msfvx(i,jte)) &
4852  *0.5 *(e(i,jte-1)+e(i,jte-1)) *0.5 *(sina(i,jte-1)+sina(i,jte-1)) *0.25*(g_rw(i, &
4853  k+1,jte-1) +g_rw(i,k,jte-1) +g_rw(i,k+1,jte-1) +g_rw(i,k,jte-1))
4854  rv_tend(i,k,jte) =rv_tend(i,k,jte) -(msfvy(i,jte)/msfvx(i,jte)) *0.5 *(f(i,jte-1) &
4855 +f(i,jte-1)) *0.25*(ru(i,k,jte-1) +ru(i+1,k,jte-1) +ru(i,k,jte-1) +ru(i+1,k,jte-1)) &
4856  +(msfvy(i,jte)/msfvx(i,jte)) *0.5 *(e(i,jte-1)+e(i,jte-1)) *0.5 *(sina(i,jte-1) &
4857 +sina(i,jte-1)) *0.25*(rw(i,k+1,jte-1) +rw(i,k,jte-1) +rw(i,k+1,jte-1) +rw(i,k,jte-1))
4858
4859  ENDDO
4860  ENDDO
4861  ENDIF
4862
4863  DO j =jts,min(jte,jde-1)
4864  DO k =kts+1,ktf
4865  DO i =its,min(ite,ide-1)
4866
4867  g_rw_tend(i,k,j) =g_rw_tend(i,k,j) +e(i,j)*(cosa(i,j) *0.5*(fzm(k) &
4868 *(g_ru(i,k,j) +g_ru(i+1,k,j)) +fzp(k)*(g_ru(i,k-1,j) +g_ru(i+1,k-1,j))) &
4869  -(msftx(i,j)/msfty(i,j)) *sina(i,j) *0.5*(fzm(k)*(g_rv(i,k,j) +g_rv(i,k,j+1)) &
4870  +fzp(k)*(g_rv(i,k-1,j) +g_rv(i,k-1,j+1))))
4871  rw_tend(i,k,j) =rw_tend(i,k,j) +e(i,j)*(cosa(i,j) *0.5*(fzm(k)*(ru(i,k,j) &
4872  +ru(i+1,k,j)) +fzp(k)*(ru(i,k-1,j) +ru(i+1,k-1,j))) -(msftx(i,j)/msfty(i,j)) &
4873  *sina(i,j) *0.5*(fzm(k)*(rv(i,k,j) +rv(i,k,j+1)) +fzp(k)*(rv(i,k-1,j) +rv(i,k-1,j+1))))
4874
4875  ENDDO
4876  ENDDO
4877  ENDDO
4878
4879  END SUBROUTINE g_perturbation_coriolis
4880
4881 !        Generated by TAPENADE     (INRIA, Tropics team)
4882 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
4883 !
4884 !  Differentiation of curvature in forward (tangent) mode:
4885 !   variations   of useful results: ru_tend rw_tend rv_tend
4886 !   with respect to varying inputs: u v ru_tend rw_tend ru rv rw
4887 !                rv_tend
4888 !   RW status of diff variables: u:in v:in ru_tend:in-out rw_tend:in-out
4889 !                ru:in rv:in rw:in rv_tend:in-out
4890 SUBROUTINE G_CURVATURE(ru, rud, rv, rvd, rw, rwd, u, ud, v, vd, w, &
4891 &  ru_tend, ru_tendd, rv_tend, rv_tendd, rw_tend, rw_tendd, config_flags&
4892 &  , msfux, msfuy, msfvx, msfvy, msftx, msfty, xlat, fzm, fzp, rdx, rdy, &
4893 &  ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, &
4894 &  jts, jte, kts, kte)
4895   IMPLICIT NONE
4896 ! Input data
4897   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
4898   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
4899 &  jme, kms, kme, its, ite, jts, jte, kts, kte
4900   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tend, &
4901 &  rv_tend, rw_tend
4902   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tendd&
4903 &  , rv_tendd, rw_tendd
4904   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ru, rv, rw, &
4905 &  u, v, w
4906   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rud, rvd, &
4907 &  rwd, ud, vd
4908   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
4909 &  msfvy, msftx, msfty, xlat
4910   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
4911   REAL, INTENT(IN) :: rdx, rdy
4912 ! Local data
4913 !   INTEGER :: i, j, k, itf, jtf, ktf, kp1, im, ip, jm, jp
4914   INTEGER :: i, j, k, itf, jtf, ktf
4915   INTEGER :: i_start, i_end, j_start, j_end
4916 !   INTEGER :: irmin, irmax, jrmin, jrmax
4917   REAL, DIMENSION(its - 1:ite, kts:kte, jts - 1:jte) :: vxgm
4918   REAL, DIMENSION(its-1:ite, kts:kte, jts-1:jte) :: vxgmd
4919   LOGICAL :: specified
4920   REAL :: arg1
4921   INTEGER :: min6
4922   INTEGER :: min5
4923   INTEGER :: min4
4924   INTEGER :: min3
4925   INTEGER :: min2
4926   INTEGER :: min1
4927   INTEGER :: max1
4928 !<DESCRIPTION>
4929 !
4930 !  curvature calculates the large timestep tendency terms in the
4931 !  u, v, and w momentum equations arise from the curvature terms.
4932 !
4933 !</DESCRIPTION>
4934   specified = .false.
4935   IF (config_flags%specified .OR. config_flags%nested) specified = &
4936 &      .true.
4937   IF (ite .GT. ide - 1) THEN
4938     itf = ide - 1
4939   ELSE
4940     itf = ite
4941   END IF
4942   IF (jte .GT. jde - 1) THEN
4943     jtf = jde - 1
4944   ELSE
4945     jtf = jte
4946   END IF
4947   IF (kte .GT. kde - 1) THEN
4948     ktf = kde - 1
4949   ELSE
4950     ktf = kte
4951   END IF
4952 !   irmin = ims
4953 !   irmax = ime
4954 !   jrmin = jms
4955 !   jrmax = jme
4956 !   IF ( config_flags%open_xs ) irmin = ids
4957 !   IF ( config_flags%open_xe ) irmax = ide-1
4958 !   IF ( config_flags%open_ys ) jrmin = jds
4959 !   IF ( config_flags%open_ye ) jrmax = jde-1
4960 ! Define v cross grad m at scalar points - vxgm(i,j)
4961   i_start = its - 1
4962   i_end = ite
4963   j_start = jts - 1
4964   j_end = jte
4965   IF (((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
4966 &      .AND. its .EQ. ids) i_start = its
4967   IF (((config_flags%open_xe .OR. specified) .OR. config_flags%nested) &
4968 &      .AND. ite .EQ. ide) i_end = ite - 1
4969   IF ((((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
4970 &      .OR. config_flags%polar) .AND. jts .EQ. jds) j_start = jts
4971   IF ((((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
4972 &      .OR. config_flags%polar) .AND. jte .EQ. jde) j_end = jte - 1
4973   IF (config_flags%periodic_x) i_start = its - 1
4974   IF (config_flags%periodic_x) THEN
4975     i_end = ite
4976     vxgmd = 0.0
4977   ELSE
4978     vxgmd = 0.0
4979   END IF
4980   DO j=j_start,j_end
4981     DO k=kts,ktf
4982       DO i=i_start,i_end
4983 !     Map scale factor notes:
4984 !     msf...y is constant everywhere for cylindrical map projection
4985 !     msf...x varies with y only
4986 !     But we know that this is not = 0 for cylindrical,
4987 !     therefore use msfvX in 1st line
4988 !     which => by symmetry use msfuY in 2nd line - ???
4989         vxgmd(i, k, j) = 0.5*(msfvx(i, j+1)-msfvx(i, j))*rdy*(ud(i, k, j&
4990 &          )+ud(i+1, k, j)) - 0.5*(msfuy(i+1, j)-msfuy(i, j))*rdx*(vd(i, &
4991 &          k, j)+vd(i, k, j+1))
4992         vxgm(i, k, j) = 0.5*(u(i, k, j)+u(i+1, k, j))*(msfvx(i, j+1)-&
4993 &          msfvx(i, j))*rdy - 0.5*(v(i, k, j)+v(i, k, j+1))*(msfuy(i+1, j&
4994 &          )-msfuy(i, j))*rdx
4995       END DO
4996     END DO
4997   END DO
4998 !  Pick up the boundary rows for open (radiation) lateral b.c.
4999 !  Rather crude at present, we are assuming there is no
5000 !    variation in this term at the boundary.
5001   IF (((config_flags%open_xs .OR. (specified .AND. (.NOT.config_flags%&
5002 &      periodic_x))) .OR. config_flags%nested) .AND. its .EQ. ids) THEN
5003     DO j=jts,jte-1
5004       DO k=kts,ktf
5005         vxgmd(its-1, k, j) = vxgmd(its, k, j)
5006         vxgm(its-1, k, j) = vxgm(its, k, j)
5007       END DO
5008     END DO
5009   END IF
5010   IF (((config_flags%open_xe .OR. (specified .AND. (.NOT.config_flags%&
5011 &      periodic_x))) .OR. config_flags%nested) .AND. ite .EQ. ide) THEN
5012     DO j=jts,jte-1
5013       DO k=kts,ktf
5014         vxgmd(ite, k, j) = vxgmd(ite-1, k, j)
5015         vxgm(ite, k, j) = vxgm(ite-1, k, j)
5016       END DO
5017     END DO
5018   END IF
5019 !  Polar boundary condition:
5020 !  The following change is needed in case one tries using the vxgm route with
5021 !  polar B.C.'s in the future, but not needed if 'tan' used
5022   IF ((((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
5023 &      .OR. config_flags%polar) .AND. jts .EQ. jds) THEN
5024     DO k=kts,ktf
5025       DO i=its-1,ite
5026         vxgmd(i, k, jts-1) = vxgmd(i, k, jts)
5027         vxgm(i, k, jts-1) = vxgm(i, k, jts)
5028       END DO
5029     END DO
5030   END IF
5031 !  Polar boundary condition:
5032 !  The following change is needed in case one tries using the vxgm route with
5033 !  polar B.C.'s in the future, but not needed if 'tan' used
5034   IF ((((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
5035 &      .OR. config_flags%polar) .AND. jte .EQ. jde) THEN
5036     DO k=kts,ktf
5037       DO i=its-1,ite
5038         vxgmd(i, k, jte) = vxgmd(i, k, jte-1)
5039         vxgm(i, k, jte) = vxgm(i, k, jte-1)
5040       END DO
5041     END DO
5042   END IF
5043 !  curvature term for u momentum eqn.
5044 !  Map scale factor notes:
5045 !  ADT eqn 44, RHS terms 4 and 5, in cylindrical: mu u v tan(lat)/(a my)
5046 !                                               - mu u w /(a my)
5047 !  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
5048 !   => terms are:
5049 !  (mx/my)*u rv tan(lat) / a - u rw / a = (u/a)*[(mx/my) rv tan(lat) - rw]
5050 !  ru v tan(lat) / a - u rw / a
5051 !  xlat defined with end points half grid space from pole,
5052 !  hence are on u latitude points
5053   i_start = its
5054   IF ((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
5055 &  THEN
5056     IF (ids + 1 .LT. its) THEN
5057       i_start = its
5058     ELSE
5059       i_start = ids + 1
5060     END IF
5061   END IF
5062   IF ((config_flags%open_xe .OR. specified) .OR. config_flags%nested) &
5063 &  THEN
5064     IF (ide - 1 .GT. ite) THEN
5065       i_end = ite
5066     ELSE
5067       i_end = ide - 1
5068     END IF
5069   END IF
5070   IF (config_flags%periodic_x) i_start = its
5071   IF (config_flags%periodic_x) i_end = ite
5072 !  Polar boundary condition
5073   IF (config_flags%map_proj .EQ. 6 .OR. config_flags%polar) THEN
5074     IF (jde - 1 .GT. jte) THEN
5075       min1 = jte
5076     ELSE
5077       min1 = jde - 1
5078     END IF
5079     DO j=jts,min1
5080       DO k=kts,ktf
5081         DO i=i_start,i_end
5082           ru_tendd(i, k, j) = ru_tendd(i, k, j) + reradius*(ud(i, k, j)*&
5083 &            (msfux(i, j)/msfuy(i, j)*0.25*(rv(i-1, k, j+1)+rv(i, k, j+1)&
5084 &            +rv(i-1, k, j)+rv(i, k, j))*TAN(xlat(i, j)*degrad)-0.25*(rw(&
5085 &            i-1, k+1, j)+rw(i-1, k, j)+rw(i, k+1, j)+rw(i, k, j)))+u(i, &
5086 &            k, j)*(msfux(i, j)*0.25*TAN(xlat(i, j)*degrad)*(rvd(i-1, k, &
5087 &            j+1)+rvd(i, k, j+1)+rvd(i-1, k, j)+rvd(i, k, j))/msfuy(i, j)&
5088 &            -0.25*(rwd(i-1, k+1, j)+rwd(i-1, k, j)+rwd(i, k+1, j)+rwd(i&
5089 &            , k, j))))
5090           ru_tend(i, k, j) = ru_tend(i, k, j) + u(i, k, j)*reradius*(&
5091 &            msfux(i, j)/msfuy(i, j)*0.25*(rv(i-1, k, j+1)+rv(i, k, j+1)+&
5092 &            rv(i-1, k, j)+rv(i, k, j))*TAN(xlat(i, j)*degrad)-0.25*(rw(i&
5093 &            -1, k+1, j)+rw(i-1, k, j)+rw(i, k+1, j)+rw(i, k, j)))
5094         END DO
5095       END DO
5096     END DO
5097   ELSE
5098     IF (jde - 1 .GT. jte) THEN
5099       min2 = jte
5100     ELSE
5101       min2 = jde - 1
5102     END IF
5103 ! normal code
5104     DO j=jts,min2
5105       DO k=kts,ktf
5106         DO i=i_start,i_end
5107           ru_tendd(i, k, j) = ru_tendd(i, k, j) + 0.5*0.25*((vxgmd(i, k&
5108 &            , j)+vxgmd(i-1, k, j))*(rv(i-1, k, j+1)+rv(i, k, j+1)+rv(i-1&
5109 &            , k, j)+rv(i, k, j))+(vxgm(i, k, j)+vxgm(i-1, k, j))*(rvd(i-&
5110 &            1, k, j+1)+rvd(i, k, j+1)+rvd(i-1, k, j)+rvd(i, k, j))) - &
5111 &            reradius*0.25*(ud(i, k, j)*(rw(i-1, k+1, j)+rw(i-1, k, j)+rw&
5112 &            (i, k+1, j)+rw(i, k, j))+u(i, k, j)*(rwd(i-1, k+1, j)+rwd(i-&
5113 &            1, k, j)+rwd(i, k+1, j)+rwd(i, k, j)))
5114           ru_tend(i, k, j) = ru_tend(i, k, j) + 0.5*(vxgm(i, k, j)+vxgm(&
5115 &            i-1, k, j))*0.25*(rv(i-1, k, j+1)+rv(i, k, j+1)+rv(i-1, k, j&
5116 &            )+rv(i, k, j)) - u(i, k, j)*reradius*0.25*(rw(i-1, k+1, j)+&
5117 &            rw(i-1, k, j)+rw(i, k+1, j)+rw(i, k, j))
5118         END DO
5119       END DO
5120     END DO
5121   END IF
5122 !  curvature term for v momentum eqn.
5123 !  Map scale factor notes
5124 !  ADT eqn 45, RHS terms 4 and 5, in cylindrical:  - mu u*u tan(lat)/(a mx)
5125 !                                               - mu v w /(a mx)
5126 !  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
5127 !  terms are:
5128 !  - (my/mx)*u ru tan(lat) / a - (my/mx)*v rw / a
5129 !  = - [my/(mx*a)]*[u ru tan(lat) + v rw]
5130 !  - (1/a)*[(my/mx)*u ru tan(lat) + w rv]
5131 !  xlat defined with end points half grid space from pole, hence are on
5132 !  u latitude points => av here
5133 !
5134 !  in original wrf, there was a sign error for the rw contribution
5135   j_start = jts
5136   IF (((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
5137 &      .OR. config_flags%polar) THEN
5138     IF (jds + 1 .LT. jts) THEN
5139       j_start = jts
5140     ELSE
5141       j_start = jds + 1
5142     END IF
5143   END IF
5144   IF (((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
5145 &      .OR. config_flags%polar) THEN
5146     IF (jde - 1 .GT. jte) THEN
5147       j_end = jte
5148     ELSE
5149       j_end = jde - 1
5150     END IF
5151   END IF
5152   IF (config_flags%map_proj .EQ. 6 .OR. config_flags%polar) THEN
5153     DO j=j_start,j_end
5154       DO k=kts,ktf
5155         IF (ite .GT. ide - 1) THEN
5156           min3 = ide - 1
5157         ELSE
5158           min3 = ite
5159         END IF
5160         DO i=its,min3
5161           arg1 = (xlat(i, j)+xlat(i, j-1))*0.5*degrad
5162           rv_tendd(i, k, j) = rv_tendd(i, k, j) - msfvy(i, j)*reradius*(&
5163 &            0.25**2*TAN(arg1)*((ud(i, k, j)+ud(i+1, k, j)+ud(i, k, j-1)+&
5164 &            ud(i+1, k, j-1))*(ru(i, k, j)+ru(i+1, k, j)+ru(i, k, j-1)+ru&
5165 &            (i+1, k, j-1))+(u(i, k, j)+u(i+1, k, j)+u(i, k, j-1)+u(i+1, &
5166 &            k, j-1))*(rud(i, k, j)+rud(i+1, k, j)+rud(i, k, j-1)+rud(i+1&
5167 &            , k, j-1)))+0.25*(vd(i, k, j)*(rw(i, k+1, j-1)+rw(i, k, j-1)&
5168 &            +rw(i, k+1, j)+rw(i, k, j))+v(i, k, j)*(rwd(i, k+1, j-1)+rwd&
5169 &            (i, k, j-1)+rwd(i, k+1, j)+rwd(i, k, j))))/msfvx(i, j)
5170           rv_tend(i, k, j) = rv_tend(i, k, j) - msfvy(i, j)/msfvx(i, j)*&
5171 &            reradius*(0.25*(u(i, k, j)+u(i+1, k, j)+u(i, k, j-1)+u(i+1, &
5172 &            k, j-1))*TAN(arg1)*0.25*(ru(i, k, j)+ru(i+1, k, j)+ru(i, k, &
5173 &            j-1)+ru(i+1, k, j-1))+v(i, k, j)*0.25*(rw(i, k+1, j-1)+rw(i&
5174 &            , k, j-1)+rw(i, k+1, j)+rw(i, k, j)))
5175         END DO
5176       END DO
5177     END DO
5178   ELSE
5179 ! normal code
5180     DO j=j_start,j_end
5181       DO k=kts,ktf
5182         IF (ite .GT. ide - 1) THEN
5183           min4 = ide - 1
5184         ELSE
5185           min4 = ite
5186         END IF
5187         DO i=its,min4
5188           rv_tendd(i, k, j) = rv_tendd(i, k, j) - 0.5*0.25*((vxgmd(i, k&
5189 &            , j)+vxgmd(i, k, j-1))*(ru(i, k, j)+ru(i+1, k, j)+ru(i, k, j&
5190 &            -1)+ru(i+1, k, j-1))+(vxgm(i, k, j)+vxgm(i, k, j-1))*(rud(i&
5191 &            , k, j)+rud(i+1, k, j)+rud(i, k, j-1)+rud(i+1, k, j-1))) - &
5192 &            msfvy(i, j)*reradius*0.25*(vd(i, k, j)*(rw(i, k+1, j-1)+rw(i&
5193 &            , k, j-1)+rw(i, k+1, j)+rw(i, k, j))+v(i, k, j)*(rwd(i, k+1&
5194 &            , j-1)+rwd(i, k, j-1)+rwd(i, k+1, j)+rwd(i, k, j)))/msfvx(i&
5195 &            , j)
5196           rv_tend(i, k, j) = rv_tend(i, k, j) - 0.5*(vxgm(i, k, j)+vxgm(&
5197 &            i, k, j-1))*0.25*(ru(i, k, j)+ru(i+1, k, j)+ru(i, k, j-1)+ru&
5198 &            (i+1, k, j-1)) - msfvy(i, j)/msfvx(i, j)*v(i, k, j)*reradius&
5199 &            *0.25*(rw(i, k+1, j-1)+rw(i, k, j-1)+rw(i, k+1, j)+rw(i, k, &
5200 &            j))
5201         END DO
5202       END DO
5203     END DO
5204   END IF
5205   IF (jte .GT. jde - 1) THEN
5206     min5 = jde - 1
5207   ELSE
5208     min5 = jte
5209   END IF
5210 !  curvature term for vertical momentum eqn.
5211 !  Notes on map scale factors:
5212 !  ADT eqn 46, RHS term 4: [mu/(a my)]*[u*u + v*v]
5213 !  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
5214 !  terms are: u ru / a + (mx/my)v rv / a
5215   DO j=jts,min5
5216     IF (2 .LT. kts) THEN
5217       max1 = kts
5218     ELSE
5219       max1 = 2
5220     END IF
5221     DO k=max1,ktf
5222       IF (ite .GT. ide - 1) THEN
5223         min6 = ide - 1
5224       ELSE
5225         min6 = ite
5226       END IF
5227       DO i=its,min6
5228         rw_tendd(i, k, j) = rw_tendd(i, k, j) + reradius*(0.5**2*((fzm(k&
5229 &          )*(rud(i, k, j)+rud(i+1, k, j))+fzp(k)*(rud(i, k-1, j)+rud(i+1&
5230 &          , k-1, j)))*(fzm(k)*(u(i, k, j)+u(i+1, k, j))+fzp(k)*(u(i, k-1&
5231 &          , j)+u(i+1, k-1, j)))+(fzm(k)*(ru(i, k, j)+ru(i+1, k, j))+fzp(&
5232 &          k)*(ru(i, k-1, j)+ru(i+1, k-1, j)))*(fzm(k)*(ud(i, k, j)+ud(i+&
5233 &          1, k, j))+fzp(k)*(ud(i, k-1, j)+ud(i+1, k-1, j))))+msftx(i, j)&
5234 &          *0.5**2*((fzm(k)*(rvd(i, k, j)+rvd(i, k, j+1))+fzp(k)*(rvd(i, &
5235 &          k-1, j)+rvd(i, k-1, j+1)))*(fzm(k)*(v(i, k, j)+v(i, k, j+1))+&
5236 &          fzp(k)*(v(i, k-1, j)+v(i, k-1, j+1)))+(fzm(k)*(rv(i, k, j)+rv(&
5237 &          i, k, j+1))+fzp(k)*(rv(i, k-1, j)+rv(i, k-1, j+1)))*(fzm(k)*(&
5238 &          vd(i, k, j)+vd(i, k, j+1))+fzp(k)*(vd(i, k-1, j)+vd(i, k-1, j+&
5239 &          1))))/msfty(i, j))
5240         rw_tend(i, k, j) = rw_tend(i, k, j) + reradius*(0.5*(fzm(k)*(ru(&
5241 &          i, k, j)+ru(i+1, k, j))+fzp(k)*(ru(i, k-1, j)+ru(i+1, k-1, j))&
5242 &          )*0.5*(fzm(k)*(u(i, k, j)+u(i+1, k, j))+fzp(k)*(u(i, k-1, j)+u&
5243 &          (i+1, k-1, j)))+msftx(i, j)/msfty(i, j)*0.5*(fzm(k)*(rv(i, k, &
5244 &          j)+rv(i, k, j+1))+fzp(k)*(rv(i, k-1, j)+rv(i, k-1, j+1)))*0.5*&
5245 &          (fzm(k)*(v(i, k, j)+v(i, k, j+1))+fzp(k)*(v(i, k-1, j)+v(i, k-&
5246 &          1, j+1))))
5247       END DO
5248     END DO
5249   END DO
5250 END SUBROUTINE G_CURVATURE
5251
5252  SUBROUTINE g_zero_tend(tendency,g_tendency,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
5253  jme,kms,kme,its,ite,jts,jte,kts,kte)
5254
5255  IMPLICIT NONE
5256
5257  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
5258  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
5259
5260  INTEGER :: i,j,k,itf,jtf,ktf
5261
5262  DO j =jts,jte
5263  DO k =kts,kte
5264  DO i =its,ite
5265
5266  g_tendency(i,k,j) =0.0
5267  tendency(i,k,j) =0.
5268
5269  ENDDO
5270  ENDDO
5271  ENDDO
5272
5273  END SUBROUTINE g_zero_tend
5274
5275 !        Generated by TAPENADE     (INRIA, Tropics team)
5276 !  Tapenade 3.6 (r4343) - 10 Feb 2012 10:52
5277 !
5278 !  Differentiation of zero_tend2d in forward (tangent) mode:
5279 !   variations   of useful results: tendency
5280 !   with respect to varying inputs: tendency
5281 !   RW status of diff variables: tendency:in-out
5282 SUBROUTINE G_ZERO_TEND2D(tendency, tendencyd, ids, ide, jds, jde, kds, &
5283 &  kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
5284   IMPLICIT NONE
5285 ! Input data
5286   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
5287 &  jme, kms, kme, its, ite, jts, jte, kts, kte
5288   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: tendency
5289   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: tendencyd
5290 ! Local data
5291   INTEGER :: i, j, k, itf, jtf, ktf
5292 !<DESCRIPTION>
5293 !
5294 !  zero_tend sets the input tendency array to zero.
5295 !
5296 !</DESCRIPTION>
5297   DO j=jts,jte
5298     DO i=its,ite
5299       tendencyd(i, j) = 0.0
5300       tendency(i, j) = 0.
5301     END DO
5302   END DO
5303 END SUBROUTINE G_ZERO_TEND2D
5304
5305  SUBROUTINE g_zero_pole(field,g_field,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
5306  kms,kme,its,ite,jts,jte,kts,kte)
5307
5308  IMPLICIT NONE
5309
5310  REAL :: Tmpv1,g_Tmpv1
5311  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
5312  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field
5313
5314  INTEGER :: i,k
5315
5316  IF(jts == jds) THEN
5317
5318  DO k =kts,kte
5319  DO i =its-1,ite+1
5320
5321  g_field(i,k,jts) =0.0
5322  field(i,k,jts) =0.
5323
5324  ENDDO
5325  ENDDO
5326  END IF
5327
5328  IF(jte == jde) THEN
5329
5330  DO k =kts,kte
5331  DO i =its-1,ite+1
5332
5333  g_field(i,k,jte) =0.0
5334  field(i,k,jte) =0.
5335
5336  ENDDO
5337  ENDDO
5338  END IF
5339
5340  END SUBROUTINE g_zero_pole
5341
5342  SUBROUTINE g_pole_point_bc(field,g_field,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
5343  jme,kms,kme,its,ite,jts,jte,kts,kte)
5344
5345  IMPLICIT NONE
5346
5347  REAL :: Tmpv1,g_Tmpv1
5348  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
5349  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field
5350
5351  INTEGER :: i,k
5352
5353  IF(jts == jds) THEN
5354
5355  DO k =kts,kte
5356  DO i =its,ite
5357
5358  g_field(i,k,jts) =g_field(i,k,jts+1)
5359  field(i,k,jts) =field(i,k,jts+1)
5360
5361  ENDDO
5362  ENDDO
5363  END IF
5364
5365  IF(jte == jde) THEN
5366
5367  DO k =kts,kte
5368  DO i =its,ite
5369
5370  g_field(i,k,jte) =g_field(i,k,jte-1)
5371  field(i,k,jte) =field(i,k,jte-1)
5372
5373  ENDDO
5374  ENDDO
5375  END IF
5376
5377  END SUBROUTINE g_pole_point_bc
5378
5379 !        Generated by TAPENADE     (INRIA, Tropics team)
5380 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
5381 !
5382 !  Differentiation of phy_prep in forward (tangent) mode:
5383 !   variations   of useful results: rthndgdten rublten v_phy rqvndgdten
5384 !                rthraten rqccuten rthcuten rqicuten z th_phy rthften
5385 !                rvndgdten rqscuten t8w rqrshten rqvshten rucuten
5386 !                pi_phy rvshten rqvblten rvblten rphndgdten t_phy
5387 !                rqcshten rqvften rthshten rqgshten p_hyd_w rqishten
5388 !                p_phy rqcblten rthblten u_phy rqrcuten rqiblten
5389 !                rqsshten rqvcuten p8w z_at_w rho rvcuten p_hyd
5390 !                rushten rundgdten dz8w
5391 !   with respect to varying inputs: rthndgdten rublten v_phy rqvndgdten
5392 !                rthraten p rqccuten t rthcuten u v rqicuten z
5393 !                th_phy rthften rvndgdten rqscuten t8w rqrshten
5394 !                rqvshten rucuten pi_phy rvshten rqvblten rvblten
5395 !                rphndgdten t_phy rqcshten rqvften rthshten rqgshten
5396 !                p_hyd_w rqishten p_phy rqcblten moist ph rthblten
5397 !                u_phy rqrcuten rqiblten alt rqsshten rqvcuten
5398 !                p8w z_at_w rho rvcuten p_hyd rushten muu muv rundgdten
5399 !                mu dz8w
5400 !   RW status of diff variables: rthndgdten:in-out rublten:in-out
5401 !                v_phy:in-out rqvndgdten:in-out rthraten:in-out
5402 !                p:in rqccuten:in-out t:in rthcuten:in-out u:in
5403 !                v:in rqicuten:in-out z:in-out th_phy:in-out rthften:in-out
5404 !                rvndgdten:in-out rqscuten:in-out t8w:in-out rqrshten:in-out
5405 !                rqvshten:in-out rucuten:in-out pi_phy:in-out rvshten:in-out
5406 !                rqvblten:in-out rvblten:in-out rphndgdten:in-out
5407 !                t_phy:in-out rqcshten:in-out rqvften:in-out rthshten:in-out
5408 !                rqgshten:in-out p_hyd_w:in-out rqishten:in-out
5409 !                p_phy:in-out rqcblten:in-out moist:in ph:in rthblten:in-out
5410 !                u_phy:in-out rqrcuten:in-out rqiblten:in-out alt:in
5411 !                rqsshten:in-out rqvcuten:in-out p8w:in-out z_at_w:in-out
5412 !                rho:in-out rvcuten:in-out p_hyd:in-out rushten:in-out
5413 !                muu:in muv:in rundgdten:in-out mu:in dz8w:in-out
5414 ! input
5415 ! input
5416 ! input
5417 ! output
5418 ! output
5419 ! output
5420 ! output
5421 ! params
5422 !01/2017 decoupling mu in G_PHY_PREP is moved to G_PHY_PREP_part2
5423 SUBROUTINE G_PHY_PREP(config_flags, mu, mud, muu, muud, muv, muvd, u, ud&
5424 &  , v, vd, p, pd, pb, alt, altd, ph, phd, phb, t, td, moist, moistd&
5425 &  , n_moist, rho, rhod, th_phy, th_phyd, p_phy, p_phyd, pi_phy, pi_phyd&
5426 &  , u_phy, u_phyd, v_phy, v_phyd, p8w, p8wd, t_phy, t_phyd, t8w, t8wd, z&
5427 &  , zd, z_at_w, z_at_wd, dz8w, dz8wd, p_hyd, p_hydd, p_hyd_w, p_hyd_wd, &
5428 &  dnw, fzm, fzp, znw, p_top, &
5429 &  ids, ide, jds, jde, kds, kde, ims, ime, jms, &
5430 &  jme, kms, kme, its, ite, jts, jte, kts, kte)
5431   IMPLICIT NONE
5432 !----------------------------------------------------------------------
5433   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
5434   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
5435 &  jme, kms, kme, its, ite, jts, jte, kts, kte
5436   INTEGER, INTENT(IN) :: n_moist
5437   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
5438 &  moist
5439   REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
5440 &  moistd
5441   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, muu, muv
5442   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mud, muud, muvd
5443   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: u_phy, &
5444 &  v_phy, pi_phy, p_phy, p8w, t_phy, th_phy, t8w, rho, z, dz8w, z_at_w
5445   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: u_phyd, &
5446 &  v_phyd, pi_phyd, p_phyd, p8wd, t_phyd, th_phyd, t8wd, rhod, zd, dz8wd&
5447 &  , z_at_wd
5448   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: p_hyd, &
5449 &  p_hyd_w
5450   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: p_hydd, &
5451 &  p_hyd_wd
5452   REAL, INTENT(IN) :: p_top
5453   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: pb, p, u, v&
5454 &  , alt, ph, phb, t
5455   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: pd, ud, vd, &
5456 &  altd, phd, td
5457   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
5458   REAL, DIMENSION(kms:kme), INTENT(IN) :: znw, dnw
5459   INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, &
5460 &  j_startv
5461   INTEGER :: i, j, k
5462   REAL :: w1, w2, z0, z1, z2
5463   REAL :: w1d, w2d, z0d, z1d, z2d
5464   REAL :: qtot
5465   REAL :: qtotd
5466   INTEGER :: n
5467   REAL :: pwx1
5468   REAL :: pwx1d
5469   REAL :: arg1
5470   REAL :: arg1d
5471 !-----------------------------------------------------------------------
5472 !<DESCRIPTION>
5473 !
5474 !  phys_prep calculates a number of diagnostic quantities needed by
5475 !  the physics routines.
5476 !
5477 !</DESCRIPTION>
5478 !  set up loop bounds for this grid's boundary conditions
5479   i_start = its
5480   IF (ite .GT. ide - 1) THEN
5481     i_end = ide - 1
5482   ELSE
5483     i_end = ite
5484   END IF
5485   j_start = jts
5486   IF (jte .GT. jde - 1) THEN
5487     j_end = jde - 1
5488   ELSE
5489     j_end = jte
5490   END IF
5491   k_start = kts
5492   IF (kte .GT. kde - 1) THEN
5493     k_end = kde - 1
5494   ELSE
5495     k_end = kte
5496   END IF
5497
5498 !  compute thermodynamics and velocities at pressure points (or half levels)
5499   DO j=j_start,j_end
5500     DO k=k_start,k_end
5501       DO i=i_start,i_end
5502         th_phyd(i, k, j) = td(i, k, j)
5503         th_phy(i, k, j) = t(i, k, j) + t0
5504         p_phyd(i, k, j) = pd(i, k, j)
5505         p_phy(i, k, j) = p(i, k, j) + pb(i, k, j)
5506         pwx1d = p_phyd(i, k, j)/p1000mb
5507         pwx1 = p_phy(i, k, j)/p1000mb
5508         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. rcp .EQ. INT(rcp))) &
5509 &        THEN
5510           pi_phyd(i, k, j) = rcp*pwx1**(rcp-1)*pwx1d
5511         ELSE IF (pwx1 .EQ. 0.0 .AND. rcp .EQ. 1.0) THEN
5512           pi_phyd(i, k, j) = pwx1d
5513         ELSE
5514           pi_phyd(i, k, j) = 0.0
5515         END IF
5516         pi_phy(i, k, j) = pwx1**rcp
5517         t_phyd(i, k, j) = th_phyd(i, k, j)*pi_phy(i, k, j) + th_phy(i, k&
5518 &          , j)*pi_phyd(i, k, j)
5519         t_phy(i, k, j) = th_phy(i, k, j)*pi_phy(i, k, j)
5520         rhod(i, k, j) = moistd(i, k, j, p_qv)/alt(i, k, j) - altd(i, k, &
5521 &          j)*(1.+moist(i, k, j, p_qv))/alt(i, k, j)**2
5522         rho(i, k, j) = 1./alt(i, k, j)*(1.+moist(i, k, j, p_qv))
5523         u_phyd(i, k, j) = 0.5*(ud(i, k, j)+ud(i+1, k, j))
5524         u_phy(i, k, j) = 0.5*(u(i, k, j)+u(i+1, k, j))
5525         v_phyd(i, k, j) = 0.5*(vd(i, k, j)+vd(i, k, j+1))
5526         v_phy(i, k, j) = 0.5*(v(i, k, j)+v(i, k, j+1))
5527       END DO
5528     END DO
5529   END DO
5530 !  compute z at w points
5531   DO j=j_start,j_end
5532     DO k=k_start,kte
5533       DO i=i_start,i_end
5534         z_at_wd(i, k, j) = phd(i, k, j)/g
5535         z_at_w(i, k, j) = (phb(i, k, j)+ph(i, k, j))/g
5536       END DO
5537     END DO
5538   END DO
5539   DO j=j_start,j_end
5540     DO k=k_start,kte-1
5541       DO i=i_start,i_end
5542         dz8wd(i, k, j) = z_at_wd(i, k+1, j) - z_at_wd(i, k, j)
5543         dz8w(i, k, j) = z_at_w(i, k+1, j) - z_at_w(i, k, j)
5544       END DO
5545     END DO
5546   END DO
5547   DO j=j_start,j_end
5548     DO i=i_start,i_end
5549       dz8wd(i, kte, j) = 0.0
5550       dz8w(i, kte, j) = 0.
5551     END DO
5552   END DO
5553 !  compute z at p points or half levels (average of z at full levels)
5554   DO j=j_start,j_end
5555     DO k=k_start,k_end
5556       DO i=i_start,i_end
5557         zd(i, k, j) = 0.5*(z_at_wd(i, k, j)+z_at_wd(i, k+1, j))
5558         z(i, k, j) = 0.5*(z_at_w(i, k, j)+z_at_w(i, k+1, j))
5559       END DO
5560     END DO
5561   END DO
5562 !  interp t and p to full levels
5563   DO j=j_start,j_end
5564     DO k=2,k_end
5565       DO i=i_start,i_end
5566         p8wd(i, k, j) = fzm(k)*p_phyd(i, k, j) + fzp(k)*p_phyd(i, k-1, j&
5567 &          )
5568         p8w(i, k, j) = fzm(k)*p_phy(i, k, j) + fzp(k)*p_phy(i, k-1, j)
5569         t8wd(i, k, j) = fzm(k)*t_phyd(i, k, j) + fzp(k)*t_phyd(i, k-1, j&
5570 &          )
5571         t8w(i, k, j) = fzm(k)*t_phy(i, k, j) + fzp(k)*t_phy(i, k-1, j)
5572       END DO
5573     END DO
5574   END DO
5575 !  extrapolate p and t to surface and top.
5576 !  we'll use an extrapolation in z for now
5577   DO j=j_start,j_end
5578     DO i=i_start,i_end
5579 ! bottom
5580       z0d = z_at_wd(i, 1, j)
5581       z0 = z_at_w(i, 1, j)
5582       z1d = zd(i, 1, j)
5583       z1 = z(i, 1, j)
5584       z2d = zd(i, 2, j)
5585       z2 = z(i, 2, j)
5586       w1d = ((z0d-z2d)*(z1-z2)-(z0-z2)*(z1d-z2d))/(z1-z2)**2
5587       w1 = (z0-z2)/(z1-z2)
5588       w2d = -w1d
5589       w2 = 1. - w1
5590       p8wd(i, 1, j) = w1d*p_phy(i, 1, j) + w1*p_phyd(i, 1, j) + w2d*&
5591 &        p_phy(i, 2, j) + w2*p_phyd(i, 2, j)
5592       p8w(i, 1, j) = w1*p_phy(i, 1, j) + w2*p_phy(i, 2, j)
5593       t8wd(i, 1, j) = w1d*t_phy(i, 1, j) + w1*t_phyd(i, 1, j) + w2d*&
5594 &        t_phy(i, 2, j) + w2*t_phyd(i, 2, j)
5595       t8w(i, 1, j) = w1*t_phy(i, 1, j) + w2*t_phy(i, 2, j)
5596 ! top
5597       z0d = z_at_wd(i, kte, j)
5598       z0 = z_at_w(i, kte, j)
5599       z1d = zd(i, k_end, j)
5600       z1 = z(i, k_end, j)
5601       z2d = zd(i, k_end-1, j)
5602       z2 = z(i, k_end-1, j)
5603       w1d = ((z0d-z2d)*(z1-z2)-(z0-z2)*(z1d-z2d))/(z1-z2)**2
5604       w1 = (z0-z2)/(z1-z2)
5605       w2d = -w1d
5606       w2 = 1. - w1
5607 !      p8w(i,kde,j) = w1*p_phy(i,kde-1,j)+w2*p_phy(i,kde-2,j)
5608 !!!  bug fix      extrapolate ln(p) so p is positive definite
5609       arg1d = w1d*LOG(p_phy(i, kde-1, j)) + w1*p_phyd(i, kde-1, j)/p_phy&
5610 &        (i, kde-1, j) + w2d*LOG(p_phy(i, kde-2, j)) + w2*p_phyd(i, kde-2&
5611 &        , j)/p_phy(i, kde-2, j)
5612       arg1 = w1*LOG(p_phy(i, kde-1, j)) + w2*LOG(p_phy(i, kde-2, j))
5613       p8wd(i, kde, j) = arg1d*EXP(arg1)
5614       p8w(i, kde, j) = EXP(arg1)
5615       t8wd(i, kde, j) = w1d*t_phy(i, kde-1, j) + w1*t_phyd(i, kde-1, j) &
5616 &        + w2d*t_phy(i, kde-2, j) + w2*t_phyd(i, kde-2, j)
5617       t8w(i, kde, j) = w1*t_phy(i, kde-1, j) + w2*t_phy(i, kde-2, j)
5618     END DO
5619   END DO
5620 ! calculate hydrostatic pressure at both full and half levels
5621 ! first, full level p: assuming dry over model top
5622   DO j=j_start,j_end
5623     DO i=i_start,i_end
5624       p_hyd_wd(i, kte, j) = 0.0
5625       p_hyd_w(i, kte, j) = p_top
5626     END DO
5627   END DO
5628   DO j=j_start,j_end
5629     DO k=kte-1,k_start,-1
5630       DO i=i_start,i_end
5631         qtot = 0.
5632         qtotd = 0.0
5633         DO n=param_first_scalar,n_moist
5634           qtotd = qtotd + moistd(i, k, j, n)
5635           qtot = qtot + moist(i, k, j, n)
5636         END DO
5637         p_hyd_wd(i, k, j) = p_hyd_wd(i, k+1, j) - dnw(k)*(qtotd*mu(i, j)&
5638 &          +(1.+qtot)*mud(i, j))
5639         p_hyd_w(i, k, j) = p_hyd_w(i, k+1, j) - (1.+qtot)*mu(i, j)*dnw(k&
5640 &          )
5641       END DO
5642     END DO
5643   END DO
5644 !      p_hyd_w(i,k,j) = p_hyd_w(i,k+1,j)+1./alt(i,k,j)*(1.+moist(i,k,j,P_QV))*g*dz8w(i,k,j)
5645 ! now calculate hydrostatic pressure at half levels
5646   DO j=j_start,j_end
5647     DO k=k_start,k_end
5648       DO i=i_start,i_end
5649         p_hydd(i, k, j) = 0.5*(p_hyd_wd(i, k, j)+p_hyd_wd(i, k+1, j))
5650         p_hyd(i, k, j) = 0.5*(p_hyd_w(i, k, j)+p_hyd_w(i, k+1, j))
5651       END DO
5652     END DO
5653   END DO
5654 END SUBROUTINE G_PHY_PREP
5655
5656 SUBROUTINE G_PHY_PREP_part2(config_flags, mu, mud, muu, muud, muv, muvd, &
5657 &  rthraten, rthratend, rthblten, rthbltend, &
5658 &  rublten, rubltend, rvblten, rvbltend, rqvblten, rqvbltend, rqcblten, &
5659 &  rqcbltend, rqiblten, rqibltend, rucuten, rucutend, rvcuten, rvcutend, &
5660 &  rthcuten, rthcutend, rqvcuten, rqvcutend, rqccuten, rqccutend, &
5661 &  rqrcuten, rqrcutend, rqicuten, rqicutend, rqscuten, rqscutend, rushten&
5662 &  , rushtend, rvshten, rvshtend, rthshten, rthshtend, rqvshten, &
5663 &  rqvshtend, rqcshten, rqcshtend, rqrshten, rqrshtend, rqishten, &
5664 &  rqishtend, rqsshten, rqsshtend, rqgshten, rqgshtend, rthften, rthftend&
5665 &  , rqvften, rqvftend, rundgdten, rundgdtend, rvndgdten, rvndgdtend, &
5666 &  rthndgdten, rthndgdtend, rphndgdten, rphndgdtend, rqvndgdten, &
5667 &  rqvndgdtend, rmundgdten, ids, ide, jds, jde, kds, kde, ims, ime, jms, &
5668 &  jme, kms, kme, its, ite, jts, jte, kts, kte)
5669   IMPLICIT NONE
5670 !----------------------------------------------------------------------
5671   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
5672   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
5673 &  jme, kms, kme, its, ite, jts, jte, kts, kte
5674   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, muu, muv
5675   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mud, muud, muvd
5676   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthraten
5677   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthratend
5678   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rucuten, &
5679 &  rvcuten, rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, &
5680 &  rushten, rvshten, rthshten, rqvshten, rqcshten, rqrshten, rqishten, &
5681 &  rqsshten, rqgshten
5682   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rucutend&
5683 &  , rvcutend, rthcutend, rqvcutend, rqccutend, rqrcutend, rqicutend, &
5684 &  rqscutend, rushtend, rvshtend, rthshtend, rqvshtend, rqcshtend, &
5685 &  rqrshtend, rqishtend, rqsshtend, rqgshtend
5686   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rublten, &
5687 &  rvblten, rthblten, rqvblten, rqcblten, rqiblten
5688   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rubltend&
5689 &  , rvbltend, rthbltend, rqvbltend, rqcbltend, rqibltend
5690   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthften, &
5691 &  rqvften
5692   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthftend&
5693 &  , rqvftend
5694   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rundgdten&
5695 &  , rvndgdten, rthndgdten, rphndgdten, rqvndgdten
5696   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
5697 &  rundgdtend, rvndgdtend, rthndgdtend, rphndgdtend, rqvndgdtend
5698   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rmundgdten
5699   INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, &
5700 &  j_startv
5701   INTEGER :: i, j, k
5702 !-----------------------------------------------------------------------
5703 !<DESCRIPTION>
5704 !
5705 !  phys_prep_part2 decouples the physics tendencies from
5706 !  the column dry-air mass (the physics routines expect to see/update the
5707 !  uncoupled tendencies).
5708 !
5709 !</DESCRIPTION>
5710 !  set up loop bounds for this grid's boundary conditions
5711   i_start = its
5712   IF (ite .GT. ide - 1) THEN
5713     i_end = ide - 1
5714   ELSE
5715     i_end = ite
5716   END IF
5717   j_start = jts
5718   IF (jte .GT. jde - 1) THEN
5719     j_end = jde - 1
5720   ELSE
5721     j_end = jte
5722   END IF
5723   k_start = kts
5724   IF (kte .GT. kde - 1) THEN
5725     k_end = kde - 1
5726   ELSE
5727     k_end = kte
5728   END IF
5729
5730 ! decouple all physics tendencies
5731   IF (config_flags%ra_lw_physics .GT. 0 .OR. config_flags%ra_sw_physics &
5732 &      .GT. 0) THEN
5733     DO j=j_start,j_end
5734       DO k=k_start,k_end
5735         DO i=i_start,i_end
5736           rthratend(i, k, j) = (rthratend(i, k, j)*mu(i, j)-rthraten(i, &
5737 &            k, j)*mud(i, j))/mu(i, j)**2
5738           rthraten(i, k, j) = rthraten(i, k, j)/mu(i, j)
5739         END DO
5740       END DO
5741     END DO
5742   END IF
5743   IF (config_flags%cu_physics .GT. 0) THEN
5744     DO j=j_start,j_end
5745       DO i=i_start,i_end
5746         DO k=k_start,k_end
5747           rucutend(i, k, j) = (rucutend(i, k, j)*mu(i, j)-rucuten(i, k, &
5748 &            j)*mud(i, j))/mu(i, j)**2
5749           rucuten(i, k, j) = rucuten(i, k, j)/mu(i, j)
5750           rvcutend(i, k, j) = (rvcutend(i, k, j)*mu(i, j)-rvcuten(i, k, &
5751 &            j)*mud(i, j))/mu(i, j)**2
5752           rvcuten(i, k, j) = rvcuten(i, k, j)/mu(i, j)
5753           rthcutend(i, k, j) = (rthcutend(i, k, j)*mu(i, j)-rthcuten(i, &
5754 &            k, j)*mud(i, j))/mu(i, j)**2
5755           rthcuten(i, k, j) = rthcuten(i, k, j)/mu(i, j)
5756         END DO
5757       END DO
5758     END DO
5759     IF (p_qv .GE. param_first_scalar) THEN
5760       DO j=j_start,j_end
5761         DO i=i_start,i_end
5762           DO k=k_start,k_end
5763             rqvcutend(i, k, j) = (rqvcutend(i, k, j)*mu(i, j)-rqvcuten(i&
5764 &              , k, j)*mud(i, j))/mu(i, j)**2
5765             rqvcuten(i, k, j) = rqvcuten(i, k, j)/mu(i, j)
5766           END DO
5767         END DO
5768       END DO
5769     END IF
5770     IF (p_qc .GE. param_first_scalar) THEN
5771       DO j=j_start,j_end
5772         DO i=i_start,i_end
5773           DO k=k_start,k_end
5774             rqccutend(i, k, j) = (rqccutend(i, k, j)*mu(i, j)-rqccuten(i&
5775 &              , k, j)*mud(i, j))/mu(i, j)**2
5776             rqccuten(i, k, j) = rqccuten(i, k, j)/mu(i, j)
5777           END DO
5778         END DO
5779       END DO
5780     END IF
5781     IF (p_qr .GE. param_first_scalar) THEN
5782       DO j=j_start,j_end
5783         DO i=i_start,i_end
5784           DO k=k_start,k_end
5785             rqrcutend(i, k, j) = (rqrcutend(i, k, j)*mu(i, j)-rqrcuten(i&
5786 &              , k, j)*mud(i, j))/mu(i, j)**2
5787             rqrcuten(i, k, j) = rqrcuten(i, k, j)/mu(i, j)
5788           END DO
5789         END DO
5790       END DO
5791     END IF
5792     IF (p_qi .GE. param_first_scalar) THEN
5793       DO j=j_start,j_end
5794         DO i=i_start,i_end
5795           DO k=k_start,k_end
5796             rqicutend(i, k, j) = (rqicutend(i, k, j)*mu(i, j)-rqicuten(i&
5797 &              , k, j)*mud(i, j))/mu(i, j)**2
5798             rqicuten(i, k, j) = rqicuten(i, k, j)/mu(i, j)
5799           END DO
5800         END DO
5801       END DO
5802     END IF
5803     IF (p_qs .GE. param_first_scalar) THEN
5804       DO j=j_start,j_end
5805         DO i=i_start,i_end
5806           DO k=k_start,k_end
5807             rqscutend(i, k, j) = (rqscutend(i, k, j)*mu(i, j)-rqscuten(i&
5808 &              , k, j)*mud(i, j))/mu(i, j)**2
5809             rqscuten(i, k, j) = rqscuten(i, k, j)/mu(i, j)
5810           END DO
5811         END DO
5812       END DO
5813     END IF
5814   END IF
5815   IF (config_flags%shcu_physics .GT. 0) THEN
5816     DO j=j_start,j_end
5817       DO i=i_start,i_end
5818         DO k=k_start,k_end
5819           rushtend(i, k, j) = (rushtend(i, k, j)*mu(i, j)-rushten(i, k, &
5820 &            j)*mud(i, j))/mu(i, j)**2
5821           rushten(i, k, j) = rushten(i, k, j)/mu(i, j)
5822           rvshtend(i, k, j) = (rvshtend(i, k, j)*mu(i, j)-rvshten(i, k, &
5823 &            j)*mud(i, j))/mu(i, j)**2
5824           rvshten(i, k, j) = rvshten(i, k, j)/mu(i, j)
5825           rthshtend(i, k, j) = (rthshtend(i, k, j)*mu(i, j)-rthshten(i, &
5826 &            k, j)*mud(i, j))/mu(i, j)**2
5827           rthshten(i, k, j) = rthshten(i, k, j)/mu(i, j)
5828         END DO
5829       END DO
5830     END DO
5831     IF (p_qv .GE. param_first_scalar) THEN
5832       DO j=j_start,j_end
5833         DO i=i_start,i_end
5834           DO k=k_start,k_end
5835             rqvshtend(i, k, j) = (rqvshtend(i, k, j)*mu(i, j)-rqvshten(i&
5836 &              , k, j)*mud(i, j))/mu(i, j)**2
5837             rqvshten(i, k, j) = rqvshten(i, k, j)/mu(i, j)
5838           END DO
5839         END DO
5840       END DO
5841     END IF
5842     IF (p_qc .GE. param_first_scalar) THEN
5843       DO j=j_start,j_end
5844         DO i=i_start,i_end
5845           DO k=k_start,k_end
5846             rqcshtend(i, k, j) = (rqcshtend(i, k, j)*mu(i, j)-rqcshten(i&
5847 &              , k, j)*mud(i, j))/mu(i, j)**2
5848             rqcshten(i, k, j) = rqcshten(i, k, j)/mu(i, j)
5849           END DO
5850         END DO
5851       END DO
5852     END IF
5853     IF (p_qr .GE. param_first_scalar) THEN
5854       DO j=j_start,j_end
5855         DO i=i_start,i_end
5856           DO k=k_start,k_end
5857             rqrshtend(i, k, j) = (rqrshtend(i, k, j)*mu(i, j)-rqrshten(i&
5858 &              , k, j)*mud(i, j))/mu(i, j)**2
5859             rqrshten(i, k, j) = rqrshten(i, k, j)/mu(i, j)
5860           END DO
5861         END DO
5862       END DO
5863     END IF
5864     IF (p_qi .GE. param_first_scalar) THEN
5865       DO j=j_start,j_end
5866         DO i=i_start,i_end
5867           DO k=k_start,k_end
5868             rqishtend(i, k, j) = (rqishtend(i, k, j)*mu(i, j)-rqishten(i&
5869 &              , k, j)*mud(i, j))/mu(i, j)**2
5870             rqishten(i, k, j) = rqishten(i, k, j)/mu(i, j)
5871           END DO
5872         END DO
5873       END DO
5874     END IF
5875     IF (p_qs .GE. param_first_scalar) THEN
5876       DO j=j_start,j_end
5877         DO i=i_start,i_end
5878           DO k=k_start,k_end
5879             rqsshtend(i, k, j) = (rqsshtend(i, k, j)*mu(i, j)-rqsshten(i&
5880 &              , k, j)*mud(i, j))/mu(i, j)**2
5881             rqsshten(i, k, j) = rqsshten(i, k, j)/mu(i, j)
5882           END DO
5883         END DO
5884       END DO
5885     END IF
5886     IF (p_qg .GE. param_first_scalar) THEN
5887       DO j=j_start,j_end
5888         DO i=i_start,i_end
5889           DO k=k_start,k_end
5890             rqgshtend(i, k, j) = (rqgshtend(i, k, j)*mu(i, j)-rqgshten(i&
5891 &              , k, j)*mud(i, j))/mu(i, j)**2
5892             rqgshten(i, k, j) = rqgshten(i, k, j)/mu(i, j)
5893           END DO
5894         END DO
5895       END DO
5896     END IF
5897   END IF
5898   IF (config_flags%bl_pbl_physics .GT. 0) THEN
5899     DO j=j_start,j_end
5900       DO k=k_start,k_end
5901         DO i=i_start,i_end
5902           rubltend(i, k, j) = (rubltend(i, k, j)*mu(i, j)-rublten(i, k, &
5903 &            j)*mud(i, j))/mu(i, j)**2
5904           rublten(i, k, j) = rublten(i, k, j)/mu(i, j)
5905           rvbltend(i, k, j) = (rvbltend(i, k, j)*mu(i, j)-rvblten(i, k, &
5906 &            j)*mud(i, j))/mu(i, j)**2
5907           rvblten(i, k, j) = rvblten(i, k, j)/mu(i, j)
5908           rthbltend(i, k, j) = (rthbltend(i, k, j)*mu(i, j)-rthblten(i, &
5909 &            k, j)*mud(i, j))/mu(i, j)**2
5910           rthblten(i, k, j) = rthblten(i, k, j)/mu(i, j)
5911         END DO
5912       END DO
5913     END DO
5914     IF (p_qv .GE. param_first_scalar) THEN
5915       DO j=j_start,j_end
5916         DO k=k_start,k_end
5917           DO i=i_start,i_end
5918             rqvbltend(i, k, j) = (rqvbltend(i, k, j)*mu(i, j)-rqvblten(i&
5919 &              , k, j)*mud(i, j))/mu(i, j)**2
5920             rqvblten(i, k, j) = rqvblten(i, k, j)/mu(i, j)
5921           END DO
5922         END DO
5923       END DO
5924     END IF
5925     IF (p_qc .GE. param_first_scalar) THEN
5926       DO j=j_start,j_end
5927         DO k=k_start,k_end
5928           DO i=i_start,i_end
5929             rqcbltend(i, k, j) = (rqcbltend(i, k, j)*mu(i, j)-rqcblten(i&
5930 &              , k, j)*mud(i, j))/mu(i, j)**2
5931             rqcblten(i, k, j) = rqcblten(i, k, j)/mu(i, j)
5932           END DO
5933         END DO
5934       END DO
5935     END IF
5936     IF (p_qi .GE. param_first_scalar) THEN
5937       DO j=j_start,j_end
5938         DO k=k_start,k_end
5939           DO i=i_start,i_end
5940             rqibltend(i, k, j) = (rqibltend(i, k, j)*mu(i, j)-rqiblten(i&
5941 &              , k, j)*mud(i, j))/mu(i, j)**2
5942             rqiblten(i, k, j) = rqiblten(i, k, j)/mu(i, j)
5943           END DO
5944         END DO
5945       END DO
5946     END IF
5947   END IF
5948 !  decouple advective forcing required by Grell-Devenyi scheme
5949   IF (((config_flags%cu_physics .EQ. gdscheme .OR. config_flags%&
5950 &      cu_physics .EQ. g3scheme) .OR. config_flags%cu_physics .EQ. &
5951 &      kfetascheme) .OR. config_flags%cu_physics .EQ. tiedtkescheme .OR. &
5952 &      (config_flags%cu_physics == NTIEDTKESCHEME) .OR. &
5953 &      (config_flags%cu_physics == MSKFSCHEME) ) THEN
5954     DO j=j_start,j_end
5955       DO i=i_start,i_end
5956         DO k=k_start,k_end
5957           rthftend(i, k, j) = (rthftend(i, k, j)*mu(i, j)-rthften(i, k, &
5958 &            j)*mud(i, j))/mu(i, j)**2
5959           rthften(i, k, j) = rthften(i, k, j)/mu(i, j)
5960         END DO
5961       END DO
5962     END DO
5963     IF (p_qv .GE. param_first_scalar) THEN
5964       DO j=j_start,j_end
5965         DO i=i_start,i_end
5966           DO k=k_start,k_end
5967             rqvftend(i, k, j) = (rqvftend(i, k, j)*mu(i, j)-rqvften(i, k&
5968 &              , j)*mud(i, j))/mu(i, j)**2
5969             rqvften(i, k, j) = rqvften(i, k, j)/mu(i, j)
5970           END DO
5971         END DO
5972       END DO
5973     END IF
5974   END IF
5975 ! fdda
5976 ! note fdda u and v tendencies are staggered, also only interior points have muu/muv,
5977 !   so only decouple those
5978   IF (config_flags%grid_fdda .GT. 0) THEN
5979     IF (its .LT. ids + 1) THEN
5980       i_startu = ids + 1
5981     ELSE
5982       i_startu = its
5983     END IF
5984     IF (jts .LT. jds + 1) THEN
5985       j_startv = jds + 1
5986     ELSE
5987       j_startv = jts
5988     END IF
5989     DO j=j_start,j_end
5990       DO k=k_start,k_end
5991         DO i=i_startu,i_end
5992           rundgdtend(i, k, j) = (rundgdtend(i, k, j)*muu(i, j)-rundgdten&
5993 &            (i, k, j)*muud(i, j))/muu(i, j)**2
5994           rundgdten(i, k, j) = rundgdten(i, k, j)/muu(i, j)
5995         END DO
5996       END DO
5997     END DO
5998     DO j=j_startv,j_end
5999       DO k=k_start,k_end
6000         DO i=i_start,i_end
6001           rvndgdtend(i, k, j) = (rvndgdtend(i, k, j)*muv(i, j)-rvndgdten&
6002 &            (i, k, j)*muvd(i, j))/muv(i, j)**2
6003           rvndgdten(i, k, j) = rvndgdten(i, k, j)/muv(i, j)
6004         END DO
6005       END DO
6006     END DO
6007     DO j=j_start,j_end
6008       DO k=k_start,k_end
6009         DO i=i_start,i_end
6010           rthndgdtend(i, k, j) = (rthndgdtend(i, k, j)*mu(i, j)-&
6011 &            rthndgdten(i, k, j)*mud(i, j))/mu(i, j)**2
6012           rthndgdten(i, k, j) = rthndgdten(i, k, j)/mu(i, j)
6013         END DO
6014       END DO
6015     END DO
6016 !        RMUNDGDTEN(I,J) - no coupling
6017     IF (config_flags%grid_fdda .EQ. 2) THEN
6018       DO j=j_start,j_end
6019         DO k=k_start,kte
6020           DO i=i_start,i_end
6021             rphndgdtend(i, k, j) = (rphndgdtend(i, k, j)*mu(i, j)-&
6022 &              rphndgdten(i, k, j)*mud(i, j))/mu(i, j)**2
6023             rphndgdten(i, k, j) = rphndgdten(i, k, j)/mu(i, j)
6024           END DO
6025         END DO
6026       END DO
6027     ELSE IF (config_flags%grid_fdda .EQ. 1) THEN
6028       IF (p_qv .GE. param_first_scalar) THEN
6029         DO j=j_start,j_end
6030           DO k=k_start,k_end
6031             DO i=i_start,i_end
6032               rqvndgdtend(i, k, j) = (rqvndgdtend(i, k, j)*mu(i, j)-&
6033 &                rqvndgdten(i, k, j)*mud(i, j))/mu(i, j)**2
6034               rqvndgdten(i, k, j) = rqvndgdten(i, k, j)/mu(i, j)
6035             END DO
6036           END DO
6037         END DO
6038       END IF
6039     END IF
6040   END IF
6041 END SUBROUTINE G_PHY_PREP_part2
6042
6043 !        Generated by TAPENADE     (INRIA, Tropics team)
6044 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
6045 !
6046 !  Differentiation of moist_physics_prep_em in forward (tangent) mode:
6047 !   variations   of useful results: z th_phy h_diabatic pf p8w
6048 !                z_at_w rho pii dz8w
6049 !   with respect to varying inputs: p al t_new ph
6050 !   RW status of diff variables: p:in al:in z:out th_phy:out h_diabatic:out
6051 !                t_new:in pf:out ph:in p8w:out z_at_w:out rho:out
6052 !                pii:out dz8w:out
6053 SUBROUTINE G_MOIST_PHYSICS_PREP_EM(t_new, t_newd, t_old, t0, rho, rhod, &
6054 &  al, ald, alb, p, pd, p8w, p8wd, p0, pb, ph, phd, phb, th_phy, th_phyd&
6055 &  , pii, piid, pf, pfd, z, zd, z_at_w, z_at_wd, dz8w, dz8wd, dt, &
6056 &  h_diabatic, h_diabaticd, &
6057 &  qv, qvd, qv_diabatic, qv_diabaticd, &
6058 &  qc, qcd, qc_diabatic, qc_diabaticd, &
6059 &  config_flags, fzm, fzp, ids, ide, jds, jde, &
6060 &  kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
6061   IMPLICIT NONE
6062 ! Here we construct full fields
6063 ! needed by the microphysics
6064   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
6065   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
6066   INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
6067   INTEGER, INTENT(IN) :: its, ite, jts, jte, kts, kte
6068   REAL, INTENT(IN) :: dt
6069   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: al, alb, p, &
6070 &  pb, ph, phb, qv, qc
6071   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ald, pd, phd
6072   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: qvd, qcd
6073   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
6074   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rho, th_phy&
6075 &  , pii, pf, z, z_at_w, dz8w, p8w
6076   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rhod, &
6077 &  th_phyd, piid, pfd, zd, z_at_wd, dz8wd, p8wd
6078   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
6079 &  h_diabatic, qv_diabatic, qc_diabatic
6080   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
6081 &  h_diabaticd, qv_diabaticd, qc_diabaticd
6082   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_new, &
6083 &  t_old
6084   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_newd
6085   REAL, INTENT(IN) :: t0, p0
6086   REAL :: z0, z1, z2, w1, w2
6087   REAL :: z0d, z1d, z2d, w1d, w2d
6088   INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end
6089   INTEGER :: i, j, k
6090   REAL :: pwx1
6091   REAL :: pwx1d
6092   REAL :: arg1
6093   REAL :: arg1d
6094 !--------------------------------------------------------------------
6095 !<DESCRIPTION>
6096 !
6097 !  moist_phys_prep_em calculates a number of diagnostic quantities needed by
6098 !  the microphysics routines.
6099 !
6100 !</DESCRIPTION>
6101 !  set up loop bounds for this grid's boundary conditions
6102   i_start = its
6103   IF (ite .GT. ide - 1) THEN
6104     i_end = ide - 1
6105   ELSE
6106     i_end = ite
6107   END IF
6108   j_start = jts
6109   IF (jte .GT. jde - 1) THEN
6110     j_end = jde - 1
6111   ELSE
6112     j_end = jte
6113   END IF
6114   k_start = kts
6115   IF (kte .GT. kde - 1) THEN
6116     k_end = kde - 1
6117   ELSE
6118     k_end = kte
6119   END IF
6120   z_at_wd = 0.0
6121   DO j=j_start,j_end
6122     DO k=k_start,kte
6123       DO i=i_start,i_end
6124         z_at_wd(i, k, j) = phd(i, k, j)/g
6125         z_at_w(i, k, j) = (ph(i, k, j)+phb(i, k, j))/g
6126       END DO
6127     END DO
6128   END DO
6129   dz8wd = 0.0
6130   DO j=j_start,j_end
6131     DO k=k_start,kte-1
6132       DO i=i_start,i_end
6133         dz8wd(i, k, j) = z_at_wd(i, k+1, j) - z_at_wd(i, k, j)
6134         dz8w(i, k, j) = z_at_w(i, k+1, j) - z_at_w(i, k, j)
6135       END DO
6136     END DO
6137   END DO
6138   DO j=j_start,j_end
6139     DO i=i_start,i_end
6140       dz8wd(i, kte, j) = 0.0
6141       dz8w(i, kte, j) = 0.
6142     END DO
6143   END DO
6144   zd = 0.0
6145   th_phyd = 0.0
6146   h_diabaticd = 0.0
6147   pfd = 0.0
6148   rhod = 0.0
6149   piid = 0.0
6150 !  compute full pii, rho, and z at the new time-level
6151 !  (needed for physics).
6152 !  convert perturbation theta to full theta (th_phy)
6153 !  use h_diabatic to temporarily save pre-microphysics full theta
6154   DO j=j_start,j_end
6155     DO k=k_start,k_end
6156       DO i=i_start,i_end
6157         th_phyd(i, k, j) = t_newd(i, k, j)
6158         th_phy(i, k, j) = t_new(i, k, j) + t0
6159         h_diabaticd(i, k, j) = th_phyd(i, k, j)
6160         h_diabatic(i, k, j) = th_phy(i, k, j)
6161         if ( P_QV >= PARAM_FIRST_SCALAR ) then
6162            qv_diabaticd(i, k, j) = qvd(i, k, j)
6163            qv_diabatic(i, k, j)  = qv(i, k, j)
6164         else
6165            qv_diabaticd(i, k, j) = 0.0
6166            qv_diabatic(i, k, j)  = 0.0
6167         end if
6168         if ( P_QC >= PARAM_FIRST_SCALAR ) then
6169            qc_diabaticd(i, k, j) = qcd(i, k, j)
6170            qc_diabatic(i, k, j)  = qc(i, k, j)
6171         else
6172            qc_diabaticd(i, k, j) = 0.0
6173            qc_diabatic(i, k, j)  = 0.0
6174         end if
6175         rhod(i, k, j) = -(ald(i, k, j)/(al(i, k, j)+alb(i, k, j))**2)
6176         rho(i, k, j) = 1./(al(i, k, j)+alb(i, k, j))
6177         pwx1d = pd(i, k, j)/p0
6178         pwx1 = (p(i, k, j)+pb(i, k, j))/p0
6179         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. rcp .EQ. INT(rcp))) &
6180 &        THEN
6181           piid(i, k, j) = rcp*pwx1**(rcp-1)*pwx1d
6182         ELSE IF (pwx1 .EQ. 0.0 .AND. rcp .EQ. 1.0) THEN
6183           piid(i, k, j) = pwx1d
6184         ELSE
6185           piid(i, k, j) = 0.0
6186         END IF
6187         pii(i, k, j) = pwx1**rcp
6188         zd(i, k, j) = 0.5*(z_at_wd(i, k, j)+z_at_wd(i, k+1, j))
6189         z(i, k, j) = 0.5*(z_at_w(i, k, j)+z_at_w(i, k+1, j))
6190         pfd(i, k, j) = pd(i, k, j)
6191         pf(i, k, j) = p(i, k, j) + pb(i, k, j)
6192       END DO
6193     END DO
6194   END DO
6195   p8wd = 0.0
6196 !  interp t and p at w points
6197   DO j=j_start,j_end
6198     DO k=2,k_end
6199       DO i=i_start,i_end
6200         p8wd(i, k, j) = fzm(k)*pfd(i, k, j) + fzp(k)*pfd(i, k-1, j)
6201         p8w(i, k, j) = fzm(k)*pf(i, k, j) + fzp(k)*pf(i, k-1, j)
6202       END DO
6203     END DO
6204   END DO
6205 !  extrapolate p and t to surface and top.
6206 !  we'll use an extrapolation in z for now
6207   DO j=j_start,j_end
6208     DO i=i_start,i_end
6209 ! bottom
6210       z0d = z_at_wd(i, 1, j)
6211       z0 = z_at_w(i, 1, j)
6212       z1d = zd(i, 1, j)
6213       z1 = z(i, 1, j)
6214       z2d = zd(i, 2, j)
6215       z2 = z(i, 2, j)
6216       w1d = ((z0d-z2d)*(z1-z2)-(z0-z2)*(z1d-z2d))/(z1-z2)**2
6217       w1 = (z0-z2)/(z1-z2)
6218       w2d = -w1d
6219       w2 = 1. - w1
6220       p8wd(i, 1, j) = w1d*pf(i, 1, j) + w1*pfd(i, 1, j) + w2d*pf(i, 2, j&
6221 &        ) + w2*pfd(i, 2, j)
6222       p8w(i, 1, j) = w1*pf(i, 1, j) + w2*pf(i, 2, j)
6223 ! top
6224       z0d = z_at_wd(i, kte, j)
6225       z0 = z_at_w(i, kte, j)
6226       z1d = zd(i, k_end, j)
6227       z1 = z(i, k_end, j)
6228       z2d = zd(i, k_end-1, j)
6229       z2 = z(i, k_end-1, j)
6230       w1d = ((z0d-z2d)*(z1-z2)-(z0-z2)*(z1d-z2d))/(z1-z2)**2
6231       w1 = (z0-z2)/(z1-z2)
6232       w2d = -w1d
6233       w2 = 1. - w1
6234 !      p8w(i,kde,j) = w1*pf(i,kde-1,j)+w2*pf(i,kde-2,j)
6235       arg1d = w1d*LOG(pf(i, kde-1, j)) + w1*pfd(i, kde-1, j)/pf(i, kde-1&
6236 &        , j) + w2d*LOG(pf(i, kde-2, j)) + w2*pfd(i, kde-2, j)/pf(i, kde-&
6237 &        2, j)
6238       arg1 = w1*LOG(pf(i, kde-1, j)) + w2*LOG(pf(i, kde-2, j))
6239       p8wd(i, kde, j) = arg1d*EXP(arg1)
6240       p8w(i, kde, j) = EXP(arg1)
6241     END DO
6242   END DO
6243 END SUBROUTINE G_MOIST_PHYSICS_PREP_EM
6244
6245 !        Generated by TAPENADE     (INRIA, Tropics team)
6246 !  Tapenade 3.7 (r4786) - 21 Feb 2013 15:53
6247 !
6248 !  Differentiation of moist_physics_finish_em in forward (tangent) mode (with options i4 r8):
6249 !   variations   of useful results: h_diabatic t_new
6250 !   with respect to varying inputs: th_phy h_diabatic t_new
6251 !   RW status of diff variables: th_phy:in h_diabatic:in-out t_new:in-out
6252 SUBROUTINE G_MOIST_PHYSICS_FINISH_EM(t_new, t_newd, t_old, t0, mut, &
6253 &  th_phy, th_phyd, h_diabatic, h_diabaticd, &
6254 &  qv, qvd, qv_diabatic, qv_diabaticd, qc, qcd, qc_diabatic, qc_diabaticd, &
6255 &  dt, config_flags, ids, ide, &
6256 &  jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, &
6257 &  kts, kte)
6258   IMPLICIT NONE
6259 ! Here we construct full fields
6260 ! needed by the microphysics
6261   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
6262   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
6263   INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
6264   INTEGER, INTENT(IN) :: its, ite, jts, jte, kts, kte
6265   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_new, &
6266 &  t_old, th_phy, h_diabatic, qv_diabatic, qc_diabatic
6267   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_newd, &
6268 &  th_phyd, h_diabaticd, qv_diabaticd, qc_diabaticd
6269   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: qv, qc
6270   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: qvd, qcd
6271   REAL :: mpten, qvten, qcten
6272   REAL :: mptend, qvtend, qctend
6273   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: mut
6274   REAL, INTENT(IN) :: t0, dt
6275   INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end
6276   INTEGER :: i, j, k, imax, jmax, imin, jmin
6277 !--------------------------------------------------------------------
6278 !<DESCRIPTION>
6279 !
6280 !  moist_phys_finish_em resets theta to its perturbation value and
6281 !  computes and stores the microphysics diabatic heating term.
6282 !
6283 !</DESCRIPTION>
6284 !  set up loop bounds for this grid's boundary conditions
6285   i_start = its
6286   IF (ite .GT. ide - 1) THEN
6287     i_end = ide - 1
6288   ELSE
6289     i_end = ite
6290   END IF
6291   j_start = jts
6292   IF (jte .GT. jde - 1) THEN
6293     j_end = jde - 1
6294   ELSE
6295     j_end = jte
6296   END IF
6297   k_start = kts
6298   IF (kte .GT. kde - 1) THEN
6299     k_end = kde - 1
6300   ELSE
6301     k_end = kte
6302   END IF
6303 !  add microphysics theta diff to perturbation theta, set h_diabatic
6304   IF (config_flags%no_mp_heating .EQ. 0) THEN
6305     qvtend = 0.0
6306     qctend = 0.0
6307     DO j=j_start,j_end
6308       DO k=k_start,k_end
6309         DO i=i_start,i_end
6310           mptend = th_phyd(i, k, j) - h_diabaticd(i, k, j)
6311           mpten = th_phy(i, k, j) - h_diabatic(i, k, j)
6312           if ( P_QV >= PARAM_FIRST_SCALAR ) then
6313              qvtend = qvd(i, k, j) - qv_diabaticd(i, k, j)
6314              qvten  = qv(i, k, j)  - qv_diabatic(i, k, j)
6315           end if
6316           if ( P_QC >= PARAM_FIRST_SCALAR ) then
6317              qctend = qcd(i, k, j) - qc_diabaticd(i, k, j)
6318              qcten  = qc(i, k, j)  - qc_diabatic(i, k, j)
6319           end if
6320           IF (config_flags%mp_tend_lim*dt .GT. mpten) THEN
6321             mpten = mpten
6322           ELSE
6323             mpten = config_flags%mp_tend_lim*dt
6324             mptend = 0.0_8
6325           END IF
6326           IF (-(config_flags%mp_tend_lim*dt) .LT. mpten) THEN
6327             mpten = mpten
6328           ELSE
6329             mpten = -(config_flags%mp_tend_lim*dt)
6330             mptend = 0.0_8
6331           END IF
6332           t_newd(i, k, j) = t_newd(i, k, j) + mptend
6333           t_new(i, k, j) = t_new(i, k, j) + mpten
6334           h_diabaticd(i, k, j) = mptend/dt
6335           h_diabatic(i, k, j) = mpten/dt
6336           if ( P_QV >= PARAM_FIRST_SCALAR ) then
6337              qv_diabaticd(i, k, j) = qvtend/dt
6338              qv_diabatic(i, k, j)  = qvten/dt
6339           else
6340              qv_diabaticd(i, k, j) = 0.0
6341              qv_diabatic(i, k, j)  = 0.0
6342           end if
6343           if ( P_QC >= PARAM_FIRST_SCALAR ) then
6344              qc_diabaticd(i, k, j) = qctend/dt
6345              qc_diabatic(i, k, j)  = qcten/dt
6346           else
6347              qc_diabaticd(i, k, j) = 0.0
6348              qc_diabatic(i, k, j)  = 0.0
6349           end if
6350         END DO
6351       END DO
6352     END DO
6353   ELSE
6354     DO j=j_start,j_end
6355       DO k=k_start,k_end
6356         DO i=i_start,i_end
6357           h_diabaticd(i, k, j) = 0.0_8
6358           h_diabatic(i, k, j) = 0.
6359           qv_diabaticd(i, k, j) = 0.0
6360           qv_diabatic(i, k, j)  = 0.0
6361           qc_diabaticd(i, k, j) = 0.0
6362           qc_diabatic(i, k, j)  = 0.0
6363         END DO
6364       END DO
6365     END DO
6366   END IF
6367 END SUBROUTINE G_MOIST_PHYSICS_FINISH_EM
6368
6369 SUBROUTINE g_init_module_big_step
6370
6371  END SUBROUTINE g_init_module_big_step
6372
6373  SUBROUTINE g_set_tend(field,g_field,field_adv_tend,g_field_adv_tend,msf, &
6374 ! Revised by Ning Pan, 2010-07-19
6375 ! g_msf,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
6376  ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
6377
6378  IMPLICIT NONE
6379
6380  REAL :: Tmpv1,g_Tmpv1
6381  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
6382  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field
6383  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field_adv_tend,g_field_adv_tend
6384 ! Revised by Ning Pan, 2010-07-19
6385 ! REAL,DIMENSION(ims:ime,jms:jme) :: msf,g_msf
6386  REAL,DIMENSION(ims:ime,jms:jme) :: msf,g_msf
6387
6388  INTEGER :: i,j,k,itf,jtf,ktf
6389
6390  jtf =min(jte,jde-1)
6391
6392  ktf =min(kte,kde-1)
6393
6394  itf =min(ite,ide-1)
6395
6396  DO j =jts,jtf
6397  DO k =kts,ktf
6398  DO i =its,itf
6399
6400 ! Revised by Ning Pan, 2010-07-19
6401 ! g_Tmpv1 =field_adv_tend(i,k,j)*g_msf(i,j) +g_field_adv_tend(i,k,j)*msf(i,j)
6402  g_Tmpv1 =g_field_adv_tend(i,k,j)*msf(i,j)
6403  Tmpv1 =field_adv_tend(i,k,j)*msf(i,j)
6404
6405  g_field(i,k,j) =g_Tmpv1
6406  field(i,k,j) =Tmpv1
6407
6408  ENDDO
6409  ENDDO
6410  ENDDO
6411
6412  END SUBROUTINE g_set_tend
6413
6414  SUBROUTINE g_rk_rayleigh_damp(ru_tendf,g_ru_tendf,rv_tendf,g_rv_tendf, &
6415  rw_tendf,g_rw_tendf,t_tendf,g_t_tendf,u,g_u,v,g_v,w,g_w,t,g_t, &
6416 ! Revised by Ning Pan, 2010-07-23
6417 ! t_init,g_t_init,mut,g_mut,muu,g_muu,muv,g_muv,ph,g_ph,phb,g_phb, &
6418 ! u_base,g_u_base,v_base,g_v_base,t_base,g_t_base,z_base,g_z_base,dampcoef, &
6419 ! g_dampcoef,zdamp,g_zdamp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
6420  t_init,mut,g_mut,muu,g_muu,muv,g_muv,ph,g_ph,phb, &
6421  u_base,v_base,t_base,z_base,dampcoef, &
6422  zdamp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
6423  ite,jts,jte,kts,kte)
6424
6425  IMPLICIT NONE
6426
6427  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3
6428  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
6429  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_tendf,g_ru_tendf,rv_tendf, &
6430  g_rv_tendf,rw_tendf,g_rw_tendf,t_tendf,g_t_tendf
6431  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,g_u,v,g_v,w,g_w,t,g_t, &
6432 ! Revised by Ning Pan, 2010-07-23
6433 ! t_init,g_t_init,ph,g_ph,phb,g_phb
6434  t_init,ph,g_ph,phb
6435  REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut,muu,g_muu,muv,g_muv
6436 ! Revised by Ning Pan, 2010-07-23
6437 ! REAL,DIMENSION(kms:kme) :: u_base,g_u_base,v_base,g_v_base,t_base,g_t_base, &
6438 ! z_base,g_z_base
6439  REAL,DIMENSION(kms:kme) :: u_base,v_base,t_base,z_base
6440 ! REAL :: dampcoef,g_dampcoef,zdamp,g_zdamp
6441  REAL :: dampcoef,zdamp
6442  INTEGER :: i_start,i_end,j_start,j_end,k_start,k_end,i,j,k,ktf,k1,k2
6443 ! Revised by Ning Pan, 2010-07-23
6444 ! REAL :: pii,g_pii,dcoef,g_dcoef,z,g_z,ztop,g_ztop
6445  REAL :: pii,dcoef,g_dcoef,z,g_z,ztop,g_ztop
6446 ! REAL :: wkp1,g_wkp1,wk,g_wk,wkm1,g_wkm1  ! Remarked by Ning Pan, 2010-07-23
6447  REAL,DIMENSION(kms:kme) :: z00,g_z00,u00,g_u00,v00,g_v00,t00,g_t00
6448
6449 ! g_pii =0.0  ! Remarked by Ning Pan, 2010-07-23
6450  pii =2.0 *Asin(1.0)
6451
6452  ktf =min(kte,kde-1)
6453
6454  DO j =jts,min(jte,jde-1)
6455  DO i =its,min(ite,ide)
6456
6457 ! Revised by Ning Pan, 2010-07-23
6458 ! g_ztop =0.5*(g_phb(i,kde,j) +g_phb(i-1,kde,j) +g_ph(i,kde,j) &
6459 ! +g_ph(i-1,kde,j))/g
6460  g_ztop =0.5*(g_ph(i,kde,j) +g_ph(i-1,kde,j))/g
6461  ztop =0.5*(phb(i,kde,j) +phb(i-1,kde,j) +ph(i,kde,j) +ph(i-1,kde,j))/g
6462
6463  k1 =ktf
6464
6465  g_z =g_ztop
6466  z =ztop
6467
6468 !This line is fail to be recognized
6469        DO WHILE( z >= (ztop-zdamp) )
6470
6471 ! Revised by Ning Pan, 2010-07-23
6472 ! g_z =0.25*(g_phb(i,k1,j) +g_phb(i,k1+1,j) +g_phb(i-1,k1,j) +g_phb(i-1, &
6473 ! k1+1,j) +g_ph(i,k1,j) +g_ph(i,k1+1,j) +g_ph(i-1,k1,j) +g_ph(i-1,k1+1,j))/g
6474  g_z =0.25*(g_ph(i,k1,j) +g_ph(i,k1+1,j) +g_ph(i-1,k1,j) +g_ph(i-1,k1+1,j))/g
6475  z =0.25*(phb(i,k1,j) +phb(i,k1+1,j) +phb(i-1,k1,j) +phb(i-1,k1+1,j) +ph(i,k1,j) &
6476  +ph(i,k1+1,j) +ph(i-1,k1,j) +ph(i-1,k1+1,j))/g
6477
6478  g_z00(k1) =g_z
6479  z00(k1) =z
6480
6481  k1 =k1-1
6482  ENDDO
6483
6484  k1 =k1+2
6485
6486  DO k =k1,ktf
6487
6488  k2 =ktf
6489
6490  DO WHILE(z_base(k2) .gt. z00(k))
6491
6492  k2 =k2-1
6493  ENDDO
6494
6495  IF(k2+1.gt.ktf) THEN
6496
6497 ! Revised by Ning Pan, 2010-07-23
6498 ! g_Tmpv1 =(u_base(k2) -u_base(k2-1))*(g_z00(k) -g_z_base(k2)) +(g_u_base( &
6499 ! k2) -g_u_base(k2-1))*(z00(k) -z_base(k2))
6500  g_Tmpv1 =(u_base(k2) -u_base(k2-1))*g_z00(k)
6501  Tmpv1 =(u_base(k2) -u_base(k2-1))*(z00(k) -z_base(k2))
6502
6503 ! Revised by Ning Pan, 2010-07-23
6504 ! g_Tmpv2 =(g_Tmpv1*(z_base(k2) -z_base(k2-1)) -(g_z_base(k2) -g_z_base( &
6505 ! k2-1))*Tmpv1)/((z_base(k2) -z_base(k2-1))*(z_base(k2) -z_base(k2-1)))
6506  g_Tmpv2 =g_Tmpv1/(z_base(k2) -z_base(k2-1))
6507  Tmpv2 =Tmpv1/(z_base(k2) -z_base(k2-1))
6508
6509 ! Revised by Ning Pan, 2010-07-23
6510 ! g_u00(k) =g_u_base(k2) +g_Tmpv2
6511  g_u00(k) =g_Tmpv2
6512  u00(k) =u_base(k2) +Tmpv2
6513
6514  else
6515
6516 ! Revised by Ning Pan, 2010-07-23
6517 ! g_Tmpv1 =(u_base(k2+1) -u_base(k2))*(g_z00(k) -g_z_base(k2)) +(g_u_base( &
6518 ! k2+1) -g_u_base(k2))*(z00(k) -z_base(k2))
6519  g_Tmpv1 =(u_base(k2+1) -u_base(k2))*g_z00(k)
6520  Tmpv1 =(u_base(k2+1) -u_base(k2))*(z00(k) -z_base(k2))
6521
6522 ! Revised by Ning Pan, 2010-07-23
6523 ! g_Tmpv2 =(g_Tmpv1*(z_base(k2+1) -z_base(k2)) -(g_z_base(k2+1) &
6524 ! -g_z_base(k2))*Tmpv1)/((z_base(k2+1) -z_base(k2))*(z_base(k2+1) -z_base(k2)))
6525  g_Tmpv2 =g_Tmpv1/(z_base(k2+1) -z_base(k2))
6526  Tmpv2 =Tmpv1/(z_base(k2+1) -z_base(k2))
6527
6528 ! Revised by Ning Pan, 2010-07-23
6529 ! g_u00(k) =g_u_base(k2) +g_Tmpv2
6530  g_u00(k) =g_Tmpv2
6531  u00(k) =u_base(k2) +Tmpv2
6532
6533  endif
6534  ENDDO
6535
6536  DO k =k1,ktf
6537
6538 ! Revised by Ning Pan, 2010-07-23
6539 ! g_Tmpv1 =((g_ztop -g_z00(k))*zdamp -g_zdamp*(ztop -z00(k)))/(zdamp*zdamp)
6540  g_Tmpv1 =(g_ztop -g_z00(k))/zdamp
6541  Tmpv1 =(ztop -z00(k))/zdamp
6542
6543  g_dcoef =-(0.0 +g_Tmpv1 -(0.0 -g_Tmpv1)*sign(1.0, 1.0 -(Tmpv1)))*0.5
6544  dcoef =1.0 -min(1.0,Tmpv1)
6545
6546 ! Revised by Ning Pan, 2010-07-23
6547 ! g_Tmpv1 =0.5*pii*g_dcoef +0.5*g_pii*dcoef
6548  g_Tmpv1 =0.5*pii*g_dcoef
6549  Tmpv1 =0.5*pii*dcoef
6550
6551  g_dcoef =2.0*(g_Tmpv1*cos(Tmpv1))*(sin(Tmpv1))
6552  dcoef =(sin(Tmpv1))**2
6553
6554 ! Revised by Ning Pan, 2010-07-23
6555 ! g_Tmpv1 =dcoef*g_dampcoef +g_dcoef*dampcoef
6556  g_Tmpv1 =g_dcoef*dampcoef
6557  Tmpv1 =dcoef*dampcoef
6558
6559  g_Tmpv2 =muu(i,j)*(g_Tmpv1) +g_muu(i,j)*(Tmpv1)
6560  Tmpv2 =muu(i,j)*(Tmpv1)
6561
6562  g_Tmpv3 =Tmpv2*(g_u(i,k,j) -g_u00(k)) +g_Tmpv2*(u(i,k,j) -u00(k))
6563  Tmpv3 =Tmpv2*(u(i,k,j) -u00(k))
6564
6565  g_ru_tendf(i,k,j) =g_ru_tendf(i,k,j) -g_Tmpv3
6566  ru_tendf(i,k,j) =ru_tendf(i,k,j) -Tmpv3
6567
6568  ENDDO
6569  ENDDO
6570  ENDDO
6571
6572  DO j =jts,min(jte,jde)
6573  DO i =its,min(ite,ide-1)
6574
6575 ! Revised by Ning Pan, 2010-07-23
6576 ! g_ztop =0.5*(g_phb(i,kde,j) +g_phb(i,kde,j-1) +g_ph(i,kde,j) &
6577 ! +g_ph(i,kde,j-1))/g
6578  g_ztop =0.5*(g_ph(i,kde,j) +g_ph(i,kde,j-1))/g
6579  ztop =0.5*(phb(i,kde,j) +phb(i,kde,j-1) +ph(i,kde,j) +ph(i,kde,j-1))/g
6580
6581  k1 =ktf
6582
6583  g_z =g_ztop
6584  z =ztop
6585
6586 !This line is fail to be recognized
6587        DO WHILE( z >= (ztop-zdamp) )
6588
6589 ! Revised by Ning Pan, 2010-07-23
6590 ! g_z =0.25*(g_phb(i,k1,j) +g_phb(i,k1+1,j) +g_phb(i,k1,j-1) +g_phb(i, &
6591 ! k1+1,j-1) +g_ph(i,k1,j) +g_ph(i,k1+1,j) +g_ph(i,k1,j-1) +g_ph(i,k1+1,j-1))/g
6592  g_z =0.25*(g_ph(i,k1,j) +g_ph(i,k1+1,j) +g_ph(i,k1,j-1) +g_ph(i,k1+1,j-1))/g
6593  z =0.25*(phb(i,k1,j) +phb(i,k1+1,j) +phb(i,k1,j-1) +phb(i,k1+1,j-1) +ph(i,k1,j) &
6594  +ph(i,k1+1,j) +ph(i,k1,j-1) +ph(i,k1+1,j-1))/g
6595
6596  g_z00(k1) =g_z
6597  z00(k1) =z
6598
6599  k1 =k1-1
6600  ENDDO
6601
6602  k1 =k1+2
6603
6604  DO k =k1,ktf
6605
6606  k2 =ktf
6607
6608  DO WHILE(z_base(k2) .gt. z00(k))
6609
6610  k2 =k2-1
6611  ENDDO
6612
6613  IF(k2+1.gt.ktf) THEN
6614
6615 ! Revised by Ning Pan, 2010-07-23
6616 ! g_Tmpv1 =(v_base(k2) -v_base(k2-1))*(g_z00(k) -g_z_base(k2)) +(g_v_base( &
6617 ! k2) -g_v_base(k2-1))*(z00(k) -z_base(k2))
6618  g_Tmpv1 =(v_base(k2) -v_base(k2-1))*g_z00(k)
6619  Tmpv1 =(v_base(k2) -v_base(k2-1))*(z00(k) -z_base(k2))
6620
6621 ! Revised by Ning Pan, 2010-07-23
6622 ! g_Tmpv2 =(g_Tmpv1*(z_base(k2) -z_base(k2-1)) -(g_z_base(k2) -g_z_base( &
6623 ! k2-1))*Tmpv1)/((z_base(k2) -z_base(k2-1))*(z_base(k2) -z_base(k2-1)))
6624  g_Tmpv2 =g_Tmpv1/(z_base(k2) -z_base(k2-1))
6625  Tmpv2 =Tmpv1/(z_base(k2) -z_base(k2-1))
6626
6627 ! Revised by Ning Pan, 2010-07-23
6628 ! g_v00(k) =g_v_base(k2) +g_Tmpv2
6629  g_v00(k) =g_Tmpv2
6630  v00(k) =v_base(k2) +Tmpv2
6631
6632  else
6633
6634 ! Revised by Ning Pan, 2010-07-23
6635 ! g_Tmpv1 =(v_base(k2+1) -v_base(k2))*(g_z00(k) -g_z_base(k2)) +(g_v_base( &
6636 ! k2+1) -g_v_base(k2))*(z00(k) -z_base(k2))
6637  g_Tmpv1 =(v_base(k2+1) -v_base(k2))*g_z00(k)
6638  Tmpv1 =(v_base(k2+1) -v_base(k2))*(z00(k) -z_base(k2))
6639
6640 ! Revised by Ning Pan, 2010-07-23
6641 ! g_Tmpv2 =(g_Tmpv1*(z_base(k2+1) -z_base(k2)) -(g_z_base(k2+1) &
6642 ! -g_z_base(k2))*Tmpv1)/((z_base(k2+1) -z_base(k2))*(z_base(k2+1) -z_base(k2)))
6643  g_Tmpv2 =g_Tmpv1/(z_base(k2+1) -z_base(k2))
6644  Tmpv2 =Tmpv1/(z_base(k2+1) -z_base(k2))
6645
6646 ! Revised by Ning Pan, 2010-07-23
6647 ! g_v00(k) =g_v_base(k2) +g_Tmpv2
6648  g_v00(k) =g_Tmpv2
6649  v00(k) =v_base(k2) +Tmpv2
6650
6651  endif
6652  ENDDO
6653
6654  DO k =k1,ktf
6655
6656 ! Revised by Ning Pan, 2010-07-23
6657 ! g_Tmpv1 =((g_ztop -g_z00(k))*zdamp -g_zdamp*(ztop -z00(k)))/(zdamp*zdamp)
6658  g_Tmpv1 =(g_ztop -g_z00(k))/zdamp
6659  Tmpv1 =(ztop -z00(k))/zdamp
6660
6661  g_dcoef =-(0.0 +g_Tmpv1 -(0.0 -g_Tmpv1)*sign(1.0, 1.0 -(Tmpv1)))*0.5
6662  dcoef =1.0 -min(1.0,Tmpv1)
6663
6664 ! Revised by Ning Pan, 2010-07-23
6665 ! g_Tmpv1 =0.5*pii*g_dcoef +0.5*g_pii*dcoef
6666  g_Tmpv1 =0.5*pii*g_dcoef
6667  Tmpv1 =0.5*pii*dcoef
6668
6669  g_dcoef =2.0*(g_Tmpv1*cos(Tmpv1))*(sin(Tmpv1))
6670  dcoef =(sin(Tmpv1))**2
6671
6672 ! Revised by Ning Pan, 2010-07-23
6673 ! g_Tmpv1 =dcoef*g_dampcoef +g_dcoef*dampcoef
6674  g_Tmpv1 =g_dcoef*dampcoef
6675  Tmpv1 =dcoef*dampcoef
6676
6677  g_Tmpv2 =muv(i,j)*(g_Tmpv1) +g_muv(i,j)*(Tmpv1)
6678  Tmpv2 =muv(i,j)*(Tmpv1)
6679
6680  g_Tmpv3 =Tmpv2*(g_v(i,k,j) -g_v00(k)) +g_Tmpv2*(v(i,k,j) -v00(k))
6681  Tmpv3 =Tmpv2*(v(i,k,j) -v00(k))
6682
6683  g_rv_tendf(i,k,j) =g_rv_tendf(i,k,j) -g_Tmpv3
6684  rv_tendf(i,k,j) =rv_tendf(i,k,j) -Tmpv3
6685
6686  ENDDO
6687  ENDDO
6688  ENDDO
6689
6690  DO j =jts,min(jte,jde-1)
6691  DO i =its,min(ite,ide-1)
6692
6693 ! Revised by Ning Pan, 2010-07-23
6694 ! g_ztop =(g_phb(i,kde,j) +g_ph(i,kde,j))/g
6695  g_ztop =g_ph(i,kde,j)/g
6696  ztop =(phb(i,kde,j) +ph(i,kde,j))/g
6697
6698  DO k =kts,min(kte,kde)
6699
6700 ! Revised by Ning Pan, 2010-07-23
6701 ! g_z =(g_phb(i,k,j) +g_ph(i,k,j))/g
6702  g_z =g_ph(i,k,j)/g
6703  z =(phb(i,k,j) +ph(i,k,j))/g
6704
6705  IF( z >= (ztop-zdamp) ) THEN
6706
6707 ! Revised by Ning Pan, 2010-07-23
6708 ! g_Tmpv1 =((g_ztop -g_z)*zdamp -g_zdamp*(ztop -z))/(zdamp*zdamp)
6709  g_Tmpv1 =(g_ztop -g_z)/zdamp
6710  Tmpv1 =(ztop -z)/zdamp
6711
6712  g_dcoef =-(0.0 +g_Tmpv1 -(0.0 -g_Tmpv1)*sign(1.0, 1.0 -(Tmpv1)))*0.5
6713  dcoef =1.0 -min(1.0,Tmpv1)
6714
6715 ! Revised by Ning Pan, 2010-07-23
6716 ! g_Tmpv1 =0.5*pii*g_dcoef +0.5*g_pii*dcoef
6717  g_Tmpv1 =0.5*pii*g_dcoef
6718  Tmpv1 =0.5*pii*dcoef
6719
6720  g_dcoef =2.0*(g_Tmpv1*cos(Tmpv1))*(sin(Tmpv1))
6721  dcoef =(sin(Tmpv1))**2
6722
6723 ! Revised by Ning Pan, 2010-07-23
6724 ! g_Tmpv1 =dcoef*g_dampcoef +g_dcoef*dampcoef
6725  g_Tmpv1 =g_dcoef*dampcoef
6726  Tmpv1 =dcoef*dampcoef
6727
6728  g_Tmpv2 =mut(i,j)*(g_Tmpv1) +g_mut(i,j)*(Tmpv1)
6729  Tmpv2 =mut(i,j)*(Tmpv1)
6730
6731  g_Tmpv3 =Tmpv2*g_w(i,k,j) +g_Tmpv2*w(i,k,j)
6732  Tmpv3 =Tmpv2*w(i,k,j)
6733
6734  g_rw_tendf(i,k,j) =g_rw_tendf(i,k,j) -g_Tmpv3
6735  rw_tendf(i,k,j) =rw_tendf(i,k,j) -Tmpv3
6736
6737  END IF
6738  ENDDO
6739  ENDDO
6740  ENDDO
6741
6742  DO j =jts,min(jte,jde-1)
6743  DO i =its,min(ite,ide-1)
6744
6745 ! Revised by Ning Pan, 2010-07-23
6746 ! g_ztop =(g_phb(i,kde,j) +g_ph(i,kde,j))/g
6747  g_ztop =g_ph(i,kde,j)/g
6748  ztop =(phb(i,kde,j) +ph(i,kde,j))/g
6749
6750  k1 =ktf
6751
6752  g_z =g_ztop
6753  z =ztop
6754
6755 !This line is fail to be recognized
6756        DO WHILE( z >= (ztop-zdamp) )
6757
6758 ! Revised by Ning Pan, 2010-07-23
6759 ! g_z =0.5*(g_phb(i,k1,j) +g_phb(i,k1+1,j) +g_ph(i,k1,j) +g_ph(i,k1+1,j))/g
6760  g_z =0.5*(g_ph(i,k1,j) +g_ph(i,k1+1,j))/g
6761  z =0.5*(phb(i,k1,j) +phb(i,k1+1,j) +ph(i,k1,j) +ph(i,k1+1,j))/g
6762
6763  g_z00(k1) =g_z
6764  z00(k1) =z
6765
6766  k1 =k1-1
6767  ENDDO
6768
6769  k1 =k1+2
6770
6771  DO k =k1,ktf
6772
6773  k2 =ktf
6774
6775  DO WHILE(z_base(k2) .gt. z00(k))
6776
6777  k2 =k2-1
6778  ENDDO
6779
6780  IF(k2+1.gt.ktf) THEN
6781
6782 ! Revised by Ning Pan, 2010-07-23
6783 ! g_Tmpv1 =(t_base(k2) -t_base(k2-1))*(g_z00(k) -g_z_base(k2)) +(g_t_base( &
6784 ! k2) -g_t_base(k2-1))*(z00(k) -z_base(k2))
6785  g_Tmpv1 =(t_base(k2) -t_base(k2-1))*g_z00(k)
6786  Tmpv1 =(t_base(k2) -t_base(k2-1))*(z00(k) -z_base(k2))
6787
6788 ! Revised by Ning Pan, 2010-07-23
6789 ! g_Tmpv2 =(g_Tmpv1*(z_base(k2) -z_base(k2-1)) -(g_z_base(k2) -g_z_base( &
6790 ! k2-1))*Tmpv1)/((z_base(k2) -z_base(k2-1))*(z_base(k2) -z_base(k2-1)))
6791  g_Tmpv2 =g_Tmpv1/(z_base(k2) -z_base(k2-1))
6792  Tmpv2 =Tmpv1/(z_base(k2) -z_base(k2-1))
6793
6794 ! Revised by Ning Pan, 2010-07-23
6795 ! g_t00(k) =g_t_base(k2) +g_Tmpv2
6796  g_t00(k) =g_Tmpv2
6797  t00(k) =t_base(k2) +Tmpv2
6798
6799  else
6800
6801 ! Revised by Ning Pan, 2010-07-23
6802 ! g_Tmpv1 =(t_base(k2+1) -t_base(k2))*(g_z00(k) -g_z_base(k2)) +(g_t_base( &
6803 ! k2+1) -g_t_base(k2))*(z00(k) -z_base(k2))
6804  g_Tmpv1 =(t_base(k2+1) -t_base(k2))*g_z00(k)
6805  Tmpv1 =(t_base(k2+1) -t_base(k2))*(z00(k) -z_base(k2))
6806
6807 ! Revised by Ning Pan, 2010-07-23
6808 ! g_Tmpv2 =(g_Tmpv1*(z_base(k2+1) -z_base(k2)) -(g_z_base(k2+1) &
6809 ! -g_z_base(k2))*Tmpv1)/((z_base(k2+1) -z_base(k2))*(z_base(k2+1) -z_base(k2)))
6810  g_Tmpv2 =g_Tmpv1/(z_base(k2+1) -z_base(k2))
6811  Tmpv2 =Tmpv1/(z_base(k2+1) -z_base(k2))
6812
6813 ! Revised by Ning Pan, 2010-07-23
6814 ! g_t00(k) =g_t_base(k2) +g_Tmpv2
6815  g_t00(k) =g_Tmpv2
6816  t00(k) =t_base(k2) +Tmpv2
6817
6818  endif
6819  ENDDO
6820
6821  DO k =k1,ktf
6822
6823 ! Revised by Ning Pan, 2010-07-23
6824 ! g_Tmpv1 =((g_ztop -g_z00(k))*zdamp -g_zdamp*(ztop -z00(k)))/(zdamp*zdamp)
6825  g_Tmpv1 =(g_ztop -g_z00(k))/zdamp
6826  Tmpv1 =(ztop -z00(k))/zdamp
6827
6828  g_dcoef =-(0.0 +g_Tmpv1 -(0.0 -g_Tmpv1)*sign(1.0, 1.0 -(Tmpv1)))*0.5
6829  dcoef =1.0 -min(1.0,Tmpv1)
6830
6831 ! Revised by Ning Pan, 2010-07-23
6832 ! g_Tmpv1 =0.5*pii*g_dcoef +0.5*g_pii*dcoef
6833  g_Tmpv1 =0.5*pii*g_dcoef
6834  Tmpv1 =0.5*pii*dcoef
6835
6836  g_dcoef =2.0*(g_Tmpv1*cos(Tmpv1))*(sin(Tmpv1))
6837  dcoef =(sin(Tmpv1))**2
6838
6839 ! Revised by Ning Pan, 2010-07-23
6840 ! g_Tmpv1 =dcoef*g_dampcoef +g_dcoef*dampcoef
6841  g_Tmpv1 =g_dcoef*dampcoef
6842  Tmpv1 =dcoef*dampcoef
6843
6844  g_Tmpv2 =mut(i,j)*(g_Tmpv1) +g_mut(i,j)*(Tmpv1)
6845  Tmpv2 =mut(i,j)*(Tmpv1)
6846
6847  g_Tmpv3 =Tmpv2*(g_t(i,k,j) -g_t00(k)) +g_Tmpv2*(t(i,k,j) -t00(k))
6848  Tmpv3 =Tmpv2*(t(i,k,j) -t00(k))
6849
6850  g_t_tendf(i,k,j) =g_t_tendf(i,k,j) -g_Tmpv3
6851  t_tendf(i,k,j) =t_tendf(i,k,j) -Tmpv3
6852
6853  ENDDO
6854  ENDDO
6855  ENDDO
6856
6857  END SUBROUTINE g_rk_rayleigh_damp
6858
6859 !        Generated by TAPENADE     (INRIA, Tropics team)
6860 !  Tapenade 3.5 (r3805) - 29 Mar 2011 12:57
6861 !
6862 !  Differentiation of theta_relaxation in forward (tangent) mode:
6863 !   variations   of useful results: t_tendf
6864 !   with respect to varying inputs: t ph t_tendf mut
6865 !   RW status of diff variables: t:in ph:in t_tendf:in-out mut:in
6866 SUBROUTINE G_THETA_RELAXATION(t_tendf, t_tendfd, t, td, t_init, mut, &
6867 &  mutd, ph, phd, phb, t_base, z_base, ids, ide, jds, jde, kds, kde, ims&
6868 &  , ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
6869   IMPLICIT NONE
6870   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
6871 &  jme, kms, kme, its, ite, jts, jte, kts, kte
6872   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_tendf
6873   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_tendfd
6874   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: t, t_init, &
6875 &  ph, phb
6876   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: td, phd
6877   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
6878   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd
6879   REAL, DIMENSION(kms:kme), INTENT(IN) :: t_base, z_base
6880 ! Local variables.
6881   INTEGER :: i, j, k, ktf, k2
6882   REAL :: tau_r, rmax, rmin, inv_tau_r, inv_g, rterm
6883   REAL :: rtermd
6884   REAL, DIMENSION(kms:kme) :: z00, t00
6885   REAL, DIMENSION(kms:kme) :: z00d, t00d
6886   INTEGER :: min2
6887   INTEGER :: min1
6888 ! End declarations.
6889 !-----------------------------------------------------------------------
6890 ! set tau_r to 12 h, following RE87
6891   tau_r = 12.0*3600.0
6892 ! limit rterm to +/- 2 K/day
6893   rmax = 2.0/86400.0
6894   rmin = -rmax
6895   IF (kte .GT. kde - 1) THEN
6896     ktf = kde - 1
6897   ELSE
6898     ktf = kte
6899   END IF
6900   inv_tau_r = 1.0/tau_r
6901   inv_g = 1.0/g
6902   IF (jte .GT. jde - 1) THEN
6903     min1 = jde - 1
6904     t00d = 0.0
6905     z00d = 0.0
6906   ELSE
6907     min1 = jte
6908     t00d = 0.0
6909     z00d = 0.0
6910   END IF
6911 !-----------------------------------------------------------------------
6912 ! Adjust potential temperature to base state.
6913   DO j=jts,min1
6914     IF (ite .GT. ide - 1) THEN
6915       min2 = ide - 1
6916     ELSE
6917       min2 = ite
6918     END IF
6919     DO i=its,min2
6920 ! Get height of model levels:
6921       DO k=kts,ktf
6922         z00d(k) = 0.5*inv_g*(phd(i, k, j)+phd(i, k+1, j))
6923         z00(k) = 0.5*(phb(i, k, j)+phb(i, k+1, j)+ph(i, k, j)+ph(i, k+1&
6924 &          , j))*inv_g
6925       END DO
6926 ! Get reference state:
6927       DO k=kts,ktf
6928         k2 = ktf
6929         DO WHILE (z_base(k2) .GT. z00(k) .AND. k2 .GT. 1)
6930           k2 = k2 - 1
6931         END DO
6932         IF (k2 + 1 .GT. ktf) THEN
6933           t00d(k) = (t_base(k2)-t_base(k2-1))*z00d(k)/(z_base(k2)-z_base&
6934 &            (k2-1))
6935           t00(k) = t_base(k2) + (t_base(k2)-t_base(k2-1))*(z00(k)-z_base&
6936 &            (k2))/(z_base(k2)-z_base(k2-1))
6937         ELSE
6938           t00d(k) = (t_base(k2+1)-t_base(k2))*z00d(k)/(z_base(k2+1)-&
6939 &            z_base(k2))
6940           t00(k) = t_base(k2) + (t_base(k2+1)-t_base(k2))*(z00(k)-z_base&
6941 &            (k2))/(z_base(k2+1)-z_base(k2))
6942         END IF
6943       END DO
6944 ! Apply the RE87 R term:
6945       DO k=kts,ktf
6946         rtermd = -(inv_tau_r*(td(i, k, j)-t00d(k)))
6947         rterm = -((t(i, k, j)-t00(k))*inv_tau_r)
6948         IF (rterm .GT. rmax) THEN
6949           rterm = rmax
6950           rtermd = 0.0
6951         ELSE
6952           rterm = rterm
6953         END IF
6954         IF (rterm .LT. rmin) THEN
6955           rterm = rmin
6956           rtermd = 0.0
6957         ELSE
6958           rterm = rterm
6959         END IF
6960         t_tendfd(i, k, j) = t_tendfd(i, k, j) + mutd(i, j)*rterm + mut(i&
6961 &          , j)*rtermd
6962         t_tendf(i, k, j) = t_tendf(i, k, j) + mut(i, j)*rterm
6963       END DO
6964     END DO
6965   END DO
6966 END SUBROUTINE G_THETA_RELAXATION
6967
6968  SUBROUTINE g_sixth_order_diffusion(name,field,g_field,tendency,g_tendency, &
6969 ! Revised by Ning Pan, 2010-07-23
6970 ! mu,g_mu,dt,g_dt,config_flags,diff_6th_opt,diff_6th_factor,g_diff_6th_factor, &
6971  mu,g_mu,dt,config_flags,diff_6th_opt,diff_6th_factor, &
6972  ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
6973
6974  IMPLICIT NONE
6975
6976  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3
6977  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
6978  TYPE(grid_config_rec_type) :: config_flags
6979  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
6980  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field
6981  REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
6982 ! Revised by Ning Pan, 2010-07-23
6983 ! REAL :: dt,g_dt
6984 ! REAL :: diff_6th_factor,g_diff_6th_factor
6985  REAL :: dt
6986  REAL :: diff_6th_factor
6987  INTEGER :: diff_6th_opt
6988  CHARACTER (LEN=1) :: name
6989  INTEGER :: i,j,k,i_start,i_end,j_start,j_end,k_start,k_end,ktf
6990  REAL :: dflux_x_p0,g_dflux_x_p0,dflux_y_p0,g_dflux_y_p0,dflux_x_p1, &
6991  g_dflux_x_p1,dflux_y_p1,g_dflux_y_p1,tendency_x,g_tendency_x,tendency_y, &
6992 ! Revised by Ning Pan, 2010-07-23
6993 ! g_tendency_y,mu_avg_p0,g_mu_avg_p0,mu_avg_p1,g_mu_avg_p1,diff_6th_coef, &
6994 ! g_diff_6th_coef
6995  g_tendency_y,mu_avg_p0,g_mu_avg_p0,mu_avg_p1,g_mu_avg_p1,diff_6th_coef
6996  LOGICAL :: specified
6997
6998 ! Remarked by Ning Pan, 2010-07-23
6999 ! g_Tmpv1 =(g_diff_6th_factor*0.015625*(2.0*dt) -(2.0*g_dt)*diff_6th_factor* &
7000 ! 0.015625)/((2.0*dt)*(2.0*dt))
7001  Tmpv1 =diff_6th_factor*0.015625/(2.0*dt)
7002
7003 ! Remarked by Ning Pan, 2010-07-23
7004 ! g_diff_6th_coef =g_Tmpv1
7005  diff_6th_coef =Tmpv1
7006
7007  ktf =min(kte,kde-1)
7008
7009  IF( name .EQ. 'u' ) THEN
7010
7011  i_start =its
7012
7013  i_end =ite
7014
7015  j_start =jts
7016
7017  j_end =min(jde-1,jte)
7018
7019  k_start =kts
7020
7021  k_end =ktf
7022  ELSE IF( name .EQ. 'v' ) THEN
7023
7024  i_start =its
7025
7026  i_end =min(ide-1,ite)
7027
7028  j_start =jts
7029
7030  j_end =jte
7031
7032  k_start =kts
7033
7034  k_end =ktf
7035  ELSE IF( name .EQ. 'w' ) THEN
7036
7037  i_start =its
7038
7039  i_end =min(ide-1,ite)
7040
7041  j_start =jts
7042
7043  j_end =min(jde-1,jte)
7044
7045  k_start =kts+1
7046
7047  k_end =ktf
7048  ELSE
7049
7050  i_start =its
7051
7052  i_end =min(ide-1,ite)
7053
7054  j_start =jts
7055
7056  j_end =min(jde-1,jte)
7057
7058  k_start =kts
7059
7060  k_end =ktf
7061  ENDIF
7062
7063  DO j =j_start,j_end
7064  DO k =k_start,k_end
7065  DO i =i_start,i_end
7066
7067  g_dflux_x_p0 =(10.0*(g_field(i,k,j) -g_field(i-1,k,j)) -5.0*(g_field(i+1, &
7068  k,j) -g_field(i-2,k,j)) +(g_field(i+2,k,j) -g_field(i-3,k,j)))
7069  dflux_x_p0 =(10.0*(field(i,k,j) -field(i-1,k,j)) -5.0*(field(i+1,k,j) -field(i-2,k, &
7070  j)) +(field(i+2,k,j) -field(i-3,k,j)))
7071
7072  g_dflux_x_p1 =(10.0*(g_field(i+1,k,j) -g_field(i,k,j)) -5.0*(g_field(i+2, &
7073  k,j) -g_field(i-1,k,j)) +(g_field(i+3,k,j) -g_field(i-2,k,j)))
7074  dflux_x_p1 =(10.0*(field(i+1,k,j) -field(i,k,j)) -5.0*(field(i+2,k,j) -field(i-1,k, &
7075  j)) +(field(i+3,k,j) -field(i-2,k,j)))
7076
7077  IF( diff_6th_opt .EQ. 2 ) THEN
7078
7079  IF( dflux_x_p0 * ( field(i  ,k,j)-field(i-1,k,j) ) .LE. 0.0 ) THEN
7080
7081  g_dflux_x_p0 =0.0
7082  dflux_x_p0 =0.0
7083
7084  END IF
7085
7086  IF( dflux_x_p1 * ( field(i+1,k,j)-field(i  ,k,j) ) .LE. 0.0 ) THEN
7087
7088  g_dflux_x_p1 =0.0
7089  dflux_x_p1 =0.0
7090
7091  END IF
7092  END IF
7093
7094  IF( name .EQ. 'u' ) THEN
7095
7096  g_mu_avg_p0 =g_mu(i-1,j)
7097  mu_avg_p0 =mu(i-1,j)
7098
7099  g_mu_avg_p1 =g_mu(i,j)
7100  mu_avg_p1 =mu(i,j)
7101
7102  ELSE IF( name .EQ. 'v' ) THEN
7103
7104  g_mu_avg_p0 =0.25*(g_mu(i-1,j-1) +g_mu(i,j-1) +g_mu(i-1,j) +g_mu(i,j))
7105  mu_avg_p0 =0.25*(mu(i-1,j-1) +mu(i,j-1) +mu(i-1,j) +mu(i,j))
7106
7107  g_mu_avg_p1 =0.25*(g_mu(i,j-1) +g_mu(i+1,j-1) +g_mu(i,j) +g_mu(i+1,j))
7108  mu_avg_p1 =0.25*(mu(i,j-1) +mu(i+1,j-1) +mu(i,j) +mu(i+1,j))
7109
7110  ELSE
7111
7112  g_mu_avg_p0 =0.5*(g_mu(i-1,j) +g_mu(i,j))
7113  mu_avg_p0 =0.5*(mu(i-1,j) +mu(i,j))
7114
7115  g_mu_avg_p1 =0.5*(g_mu(i,j) +g_mu(i+1,j))
7116  mu_avg_p1 =0.5*(mu(i,j) +mu(i+1,j))
7117
7118  END IF
7119
7120  g_Tmpv1 =mu_avg_p1*g_dflux_x_p1 +g_mu_avg_p1*dflux_x_p1
7121  Tmpv1 =mu_avg_p1*dflux_x_p1
7122
7123  g_Tmpv2 =mu_avg_p0*g_dflux_x_p0 +g_mu_avg_p0*dflux_x_p0
7124  Tmpv2 =mu_avg_p0*dflux_x_p0
7125
7126 ! Revised by Ning Pan, 2010-07-23
7127 ! g_Tmpv3 =diff_6th_coef*((g_Tmpv1) -(g_Tmpv2)) +g_diff_6th_coef*((Tmpv1) -(Tmpv2))
7128  g_Tmpv3 =diff_6th_coef*((g_Tmpv1) -(g_Tmpv2))
7129  Tmpv3 =diff_6th_coef*((Tmpv1) -(Tmpv2))
7130
7131  g_tendency_x =g_Tmpv3
7132  tendency_x =Tmpv3
7133
7134  g_dflux_y_p0 =(10.0*(g_field(i,k,j) -g_field(i,k,j-1)) -5.0*(g_field(i,k, &
7135  j+1) -g_field(i,k,j-2)) +(g_field(i,k,j+2) -g_field(i,k,j-3)))
7136  dflux_y_p0 =(10.0*(field(i,k,j) -field(i,k,j-1)) -5.0*(field(i,k,j+1) -field(i,k,j- &
7137  2)) +(field(i,k,j+2) -field(i,k,j-3)))
7138
7139  g_dflux_y_p1 =(10.0*(g_field(i,k,j+1) -g_field(i,k,j)) -5.0*(g_field(i,k, &
7140  j+2) -g_field(i,k,j-1)) +(g_field(i,k,j+3) -g_field(i,k,j-2)))
7141  dflux_y_p1 =(10.0*(field(i,k,j+1) -field(i,k,j)) -5.0*(field(i,k,j+2) -field(i,k,j- &
7142  1)) +(field(i,k,j+3) -field(i,k,j-2)))
7143
7144  IF( diff_6th_opt .EQ. 2 ) THEN
7145
7146  IF( dflux_y_p0 * ( field(i,k,j  )-field(i,k,j-1) ) .LE. 0.0 ) THEN
7147
7148  g_dflux_y_p0 =0.0
7149  dflux_y_p0 =0.0
7150
7151  END IF
7152
7153  IF( dflux_y_p1 * ( field(i,k,j+1)-field(i,k,j  ) ) .LE. 0.0 ) THEN
7154
7155  g_dflux_y_p1 =0.0
7156  dflux_y_p1 =0.0
7157
7158  END IF
7159  END IF
7160
7161  IF( name .EQ. 'u' ) THEN
7162
7163  g_mu_avg_p0 =0.25*(g_mu(i-1,j-1) +g_mu(i,j-1) +g_mu(i-1,j) +g_mu(i,j))
7164  mu_avg_p0 =0.25*(mu(i-1,j-1) +mu(i,j-1) +mu(i-1,j) +mu(i,j))
7165
7166  g_mu_avg_p1 =0.25*(g_mu(i-1,j) +g_mu(i,j) +g_mu(i-1,j+1) +g_mu(i,j+1))
7167  mu_avg_p1 =0.25*(mu(i-1,j) +mu(i,j) +mu(i-1,j+1) +mu(i,j+1))
7168
7169  ELSE IF( name .EQ. 'v' ) THEN
7170
7171  g_mu_avg_p0 =g_mu(i,j-1)
7172  mu_avg_p0 =mu(i,j-1)
7173
7174  g_mu_avg_p1 =g_mu(i,j)
7175  mu_avg_p1 =mu(i,j)
7176
7177  ELSE
7178
7179  g_mu_avg_p0 =0.5*(g_mu(i,j-1) +g_mu(i,j))
7180  mu_avg_p0 =0.5*(mu(i,j-1) +mu(i,j))
7181
7182  g_mu_avg_p1 =0.5*(g_mu(i,j) +g_mu(i,j+1))
7183  mu_avg_p1 =0.5*(mu(i,j) +mu(i,j+1))
7184
7185  END IF
7186
7187  g_Tmpv1 =mu_avg_p1*g_dflux_y_p1 +g_mu_avg_p1*dflux_y_p1
7188  Tmpv1 =mu_avg_p1*dflux_y_p1
7189
7190  g_Tmpv2 =mu_avg_p0*g_dflux_y_p0 +g_mu_avg_p0*dflux_y_p0
7191  Tmpv2 =mu_avg_p0*dflux_y_p0
7192
7193 ! Revised by Ning Pan, 2010-07-23
7194 ! g_Tmpv3 =diff_6th_coef*((g_Tmpv1) -(g_Tmpv2)) +g_diff_6th_coef*((Tmpv1) -(Tmpv2))
7195  g_Tmpv3 =diff_6th_coef*((g_Tmpv1) -(g_Tmpv2))
7196  Tmpv3 =diff_6th_coef*((Tmpv1) -(Tmpv2))
7197
7198  g_tendency_y =g_Tmpv3
7199  tendency_y =Tmpv3
7200
7201  g_tendency(i,k,j) =g_tendency(i,k,j) +g_tendency_x +g_tendency_y
7202  tendency(i,k,j) =tendency(i,k,j) +tendency_x +tendency_y
7203
7204  ENDDO
7205  ENDDO
7206  ENDDO
7207
7208  END SUBROUTINE g_sixth_order_diffusion
7209
7210  END MODULE g_module_big_step_utilities_em
7211