dyn_em/module_big_step_utilities_em.F

   1
   2 !wrf:MODEL_LAYER:DYNAMICS
   3 !
   4
   5 #if (RWORDSIZE == 4)
   6 # define VPOWX vspowx
   7 # define VPOW  vspow
   8 #else
   9 # define VPOWX vpowx
  10 # define VPOW  vpow
  11 #endif
  12
  13
  14 MODULE module_big_step_utilities_em
  15
  16    USE module_model_constants
  17    USE module_state_description, only: p_qg, p_qs, p_qi, gdscheme, tiedtkescheme, ntiedtkescheme, kfetascheme, mskfscheme, &
  18        g3scheme, gfscheme,p_qv, param_first_scalar, p_qr, p_qc, DFI_FWD
  19    USE module_configure, ONLY : grid_config_rec_type
  20    USE module_wrf_error
  21
  22 CONTAINS
  23
  24 !-------------------------------------------------------------------------------
  25
  26 SUBROUTINE calc_mu_uv ( config_flags,                 &
  27                         mu, mub, muu, muv,            &
  28                         ids, ide, jds, jde, kds, kde, &
  29                         ims, ime, jms, jme, kms, kme, &
  30                         its, ite, jts, jte, kts, kte )
  31
  32    IMPLICIT NONE
  33
  34    ! Input data
  35
  36    TYPE(grid_config_rec_type   ) ,   INTENT(IN   ) :: config_flags
  37
  38    INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
  39                                        ims, ime, jms, jme, kms, kme, &
  40                                        its, ite, jts, jte, kts, kte
  41
  42    REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(  OUT) :: muu, muv
  43    REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mu, mub
  44
  45    !  local stuff
  46
  47    INTEGER :: i, j, itf, jtf, im, jm
  48
  49 !<DESCRIPTION>
  50 !
  51 !  calc_mu_uv calculates the full column dry-air mass at the staggered
  52 !  horizontal velocity points (u,v) and places the results in muu and muv.
  53 !  This routine uses the reference state (mub) and perturbation state (mu)
  54 !
  55 !</DESCRIPTION>
  56
  57
  58       itf=ite
  59       jtf=MIN(jte,jde-1)
  60
  61       IF      ( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN
  62          DO j=jts,jtf
  63          DO i=its,itf
  64             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j))
  65          ENDDO
  66          ENDDO
  67       ELSE IF ( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN
  68          DO j=jts,jtf
  69          DO i=its+1,itf
  70             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j))
  71          ENDDO
  72          ENDDO
  73          i=its
  74          im = its
  75          if(config_flags%periodic_x) im = its-1
  76          DO j=jts,jtf
  77 !            MUU(i,j) =      MU(i,j)          +MUB(i,j)
  78 !  fix for periodic b.c., 13 march 2004, wcs
  79             MUU(i,j) = 0.5*(MU(i,j)+MU(im,j)+MUB(i,j)+MUB(im,j))
  80          ENDDO
  81       ELSE IF ( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN
  82          DO j=jts,jtf
  83          DO i=its,itf-1
  84             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j))
  85          ENDDO
  86          ENDDO
  87          i=ite
  88          im = ite-1
  89          if(config_flags%periodic_x) im = ite
  90          DO j=jts,jtf
  91 !            MUU(i,j) =      MU(i-1,j)        +MUB(i-1,j)
  92 !  fix for periodic b.c., 13 march 2004, wcs
  93             MUU(i,j) = 0.5*(MU(i-1,j)+MU(im,j)+MUB(i-1,j)+MUB(im,j))
  94          ENDDO
  95       ELSE IF ( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN
  96          DO j=jts,jtf
  97          DO i=its+1,itf-1
  98             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j))
  99          ENDDO
 100          ENDDO
 101          i=its
 102          im = its
 103          if(config_flags%periodic_x) im = its-1
 104          DO j=jts,jtf
 105 !            MUU(i,j) =      MU(i,j)          +MUB(i,j)
 106 !  fix for periodic b.c., 13 march 2004, wcs
 107             MUU(i,j) = 0.5*(MU(i,j)+MU(im,j)+MUB(i,j)+MUB(im,j))
 108          ENDDO
 109          i=ite
 110          im = ite-1
 111          if(config_flags%periodic_x) im = ite
 112          DO j=jts,jtf
 113 !            MUU(i,j) =      MU(i-1,j)        +MUB(i-1,j)
 114 !  fix for periodic b.c., 13 march 2004, wcs
 115             MUU(i,j) = 0.5*(MU(i-1,j)+MU(im,j)+MUB(i-1,j)+MUB(im,j))
 116          ENDDO
 117       END IF
 118
 119       itf=MIN(ite,ide-1)
 120       jtf=jte
 121
 122       IF      ( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN
 123          DO j=jts,jtf
 124          DO i=its,itf
 125              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1))
 126          ENDDO
 127          ENDDO
 128       ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN
 129          DO j=jts+1,jtf
 130          DO i=its,itf
 131              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1))
 132          ENDDO
 133          ENDDO
 134          j=jts
 135          jm = jts
 136          if(config_flags%periodic_y) jm = jts-1
 137          DO i=its,itf
 138 !             MUV(i,j) =      MU(i,j)          +MUB(i,j)
 139 !  fix for periodic b.c., 13 march 2004, wcs
 140              MUV(i,j) = 0.5*(MU(i,j)+MU(i,jm)+MUB(i,j)+MUB(i,jm))
 141          ENDDO
 142       ELSE IF ( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN
 143          DO j=jts,jtf-1
 144          DO i=its,itf
 145              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1))
 146          ENDDO
 147          ENDDO
 148          j=jte
 149          jm = jte-1
 150          if(config_flags%periodic_y) jm = jte
 151          DO i=its,itf
 152 !            MUV(i,j) =      MU(i,j-1)        +MUB(i,j-1)
 153 !  fix for periodic b.c., 13 march 2004, wcs
 154              MUV(i,j) = 0.5*(MU(i,j-1)+MU(i,jm)+MUB(i,j-1)+MUB(i,jm))
 155          ENDDO
 156       ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN
 157          DO j=jts+1,jtf-1
 158          DO i=its,itf
 159              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1))
 160          ENDDO
 161          ENDDO
 162          j=jts
 163          jm = jts
 164          if(config_flags%periodic_y) jm = jts-1
 165          DO i=its,itf
 166 !             MUV(i,j) =      MU(i,j)          +MUB(i,j)
 167 !  fix for periodic b.c., 13 march 2004, wcs
 168              MUV(i,j) = 0.5*(MU(i,j)+MU(i,jm)+MUB(i,j)+MUB(i,jm))
 169          ENDDO
 170          j=jte
 171          jm = jte-1
 172          if(config_flags%periodic_y) jm = jte
 173          DO i=its,itf
 174 !             MUV(i,j) =      MU(i,j-1)        +MUB(i,j-1)
 175 !  fix for periodic b.c., 13 march 2004, wcs
 176              MUV(i,j) = 0.5*(MU(i,j-1)+MU(i,jm)+MUB(i,j-1)+MUB(i,jm))
 177          ENDDO
 178       END IF
 179
 180 END SUBROUTINE calc_mu_uv
 181
 182 !-------------------------------------------------------------------------------
 183
 184 SUBROUTINE calc_mu_uv_1 ( config_flags,                 &
 185                           mu, muu, muv,                 &
 186                           ids, ide, jds, jde, kds, kde, &
 187                           ims, ime, jms, jme, kms, kme, &
 188                           its, ite, jts, jte, kts, kte )
 189
 190    IMPLICIT NONE
 191
 192    ! Input data
 193
 194    TYPE(grid_config_rec_type   ) ,   INTENT(IN   ) :: config_flags
 195
 196    INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
 197                                        ims, ime, jms, jme, kms, kme, &
 198                                        its, ite, jts, jte, kts, kte
 199
 200    REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(  OUT) :: muu, muv
 201    REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mu
 202
 203    !  local stuff
 204
 205    INTEGER :: i, j, itf, jtf, im, jm
 206
 207 !<DESCRIPTION>
 208 !
 209 !  calc_mu_uv calculates the full column dry-air mass at the staggered
 210 !  horizontal velocity points (u,v) and places the results in muu and muv.
 211 !  This routine uses the full state (mu)
 212 !
 213 !</DESCRIPTION>
 214
 215       itf=ite
 216       jtf=MIN(jte,jde-1)
 217
 218       IF      ( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN
 219          DO j=jts,jtf
 220          DO i=its,itf
 221             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j))
 222          ENDDO
 223          ENDDO
 224       ELSE IF ( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN
 225          DO j=jts,jtf
 226          DO i=its+1,itf
 227             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j))
 228          ENDDO
 229          ENDDO
 230          i=its
 231          im = its
 232          if(config_flags%periodic_x) im = its-1
 233          DO j=jts,jtf
 234             MUU(i,j) = 0.5*(MU(i,j)+MU(im,j))
 235          ENDDO
 236       ELSE IF ( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN
 237          DO j=jts,jtf
 238          DO i=its,itf-1
 239             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j))
 240          ENDDO
 241          ENDDO
 242          i=ite
 243          im = ite-1
 244          if(config_flags%periodic_x) im = ite
 245          DO j=jts,jtf
 246             MUU(i,j) = 0.5*(MU(i-1,j)+MU(im,j))
 247          ENDDO
 248       ELSE IF ( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN
 249          DO j=jts,jtf
 250          DO i=its+1,itf-1
 251             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j))
 252          ENDDO
 253          ENDDO
 254          i=its
 255          im = its
 256          if(config_flags%periodic_x) im = its-1
 257          DO j=jts,jtf
 258             MUU(i,j) = 0.5*(MU(i,j)+MU(im,j))
 259          ENDDO
 260          i=ite
 261          im = ite-1
 262          if(config_flags%periodic_x) im = ite
 263          DO j=jts,jtf
 264             MUU(i,j) = 0.5*(MU(i-1,j)+MU(im,j))
 265          ENDDO
 266       END IF
 267
 268       itf=MIN(ite,ide-1)
 269       jtf=jte
 270
 271       IF      ( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN
 272          DO j=jts,jtf
 273          DO i=its,itf
 274              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1))
 275          ENDDO
 276          ENDDO
 277       ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN
 278          DO j=jts+1,jtf
 279          DO i=its,itf
 280              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1))
 281          ENDDO
 282          ENDDO
 283          j=jts
 284          jm = jts
 285          if(config_flags%periodic_y) jm = jts-1
 286          DO i=its,itf
 287              MUV(i,j) = 0.5*(MU(i,j)+MU(i,jm))
 288          ENDDO
 289       ELSE IF ( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN
 290          DO j=jts,jtf-1
 291          DO i=its,itf
 292              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1))
 293          ENDDO
 294          ENDDO
 295          j=jte
 296          jm = jte-1
 297          if(config_flags%periodic_y) jm = jte
 298          DO i=its,itf
 299              MUV(i,j) = 0.5*(MU(i,j-1)+MU(i,jm))
 300          ENDDO
 301       ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN
 302          DO j=jts+1,jtf-1
 303          DO i=its,itf
 304              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1))
 305          ENDDO
 306          ENDDO
 307          j=jts
 308          jm = jts
 309          if(config_flags%periodic_y) jm = jts-1
 310          DO i=its,itf
 311              MUV(i,j) = 0.5*(MU(i,j)+MU(i,jm))
 312          ENDDO
 313          j=jte
 314          jm = jte-1
 315          if(config_flags%periodic_y) jm = jte
 316          DO i=its,itf
 317              MUV(i,j) = 0.5*(MU(i,j-1)+MU(i,jm))
 318          ENDDO
 319       END IF
 320
 321 END SUBROUTINE calc_mu_uv_1
 322
 323 !-------------------------------------------------------------------------------
 324
 325 ! Map scale factor comments for this routine:
 326 ! Locally not changed, but sent the correct map scale factors
 327 ! from module_em (msfuy, msfvx, msfty)
 328
 329 SUBROUTINE couple_momentum ( muu, ru, u, msfu,              &
 330                              muv, rv, v, msfv, msfv_inv,    &
 331                              mut, rw, w, msft,              &
 332                              c1h, c2h, c1f, c2f,            &
 333                              ids, ide, jds, jde, kds, kde,  &
 334                              ims, ime, jms, jme, kms, kme,  &
 335                              its, ite, jts, jte, kts, kte  )
 336
 337    IMPLICIT NONE
 338
 339    ! Input data
 340
 341    INTEGER ,             INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
 342                                           ims, ime, jms, jme, kms, kme, &
 343                                           its, ite, jts, jte, kts, kte
 344
 345    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(  OUT) :: ru, rv, rw
 346
 347    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: muu, muv, mut
 348    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: msfu, msfv, msft, msfv_inv
 349
 350    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: u, v, w
 351    REAL , DIMENSION( kms:kme ) ,    INTENT(IN   ) :: c1h, c2h, c1f, c2f
 352
 353    ! Local data
 354
 355    INTEGER :: i, j, k, itf, jtf, ktf
 356
 357 !<DESCRIPTION>
 358 !
 359 ! couple_momentum couples the velocities to the full column mass and
 360 ! the map factors.
 361 !
 362 !</DESCRIPTION>
 363
 364    ktf=MIN(kte,kde-1)
 365
 366       itf=ite
 367       jtf=MIN(jte,jde-1)
 368
 369       DO j=jts,jtf
 370       DO k=kts,ktf
 371       DO i=its,itf
 372          ru(i,k,j)=u(i,k,j)*(c1h(k)*muu(i,j)+c2h(k))/msfu(i,j)
 373       ENDDO
 374       ENDDO
 375       ENDDO
 376
 377       itf=MIN(ite,ide-1)
 378       jtf=jte
 379
 380       DO j=jts,jtf
 381       DO k=kts,ktf
 382       DO i=its,itf
 383            rv(i,k,j)=v(i,k,j)*(c1h(k)*muv(i,j)+c2h(k))*msfv_inv(i,j)
 384       ENDDO
 385       ENDDO
 386       ENDDO
 387
 388       itf=MIN(ite,ide-1)
 389       jtf=MIN(jte,jde-1)
 390
 391       DO j=jts,jtf
 392       DO k=kts,kte
 393       DO i=its,itf
 394          rw(i,k,j)=w(i,k,j)*(c1f(k)*mut(i,j)+c2f(k))/msft(i,j)
 395       ENDDO
 396       ENDDO
 397       ENDDO
 398
 399 END SUBROUTINE couple_momentum
 400
 401 !-------------------------------------------------------------------
 402
 403 SUBROUTINE calc_mu_staggered ( mu, mub, muu, muv,            &
 404                                   ids, ide, jds, jde, kds, kde, &
 405                                   ims, ime, jms, jme, kms, kme, &
 406                                   its, ite, jts, jte, kts, kte )
 407
 408    IMPLICIT NONE
 409
 410    ! Input data
 411
 412    INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
 413                                        ims, ime, jms, jme, kms, kme, &
 414                                        its, ite, jts, jte, kts, kte
 415
 416    REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(  OUT) :: muu, muv
 417    REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mu, mub
 418
 419    !  local stuff
 420
 421    INTEGER :: i, j, itf, jtf
 422
 423 !<DESCRIPTION>
 424 !
 425 ! calc_mu_staggered calculates the full dry air mass at the staggered
 426 ! velocity points (u,v).
 427 !
 428 !</DESCRIPTION>
 429
 430       itf=ite
 431       jtf=MIN(jte,jde-1)
 432
 433       IF      ( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN
 434          DO j=jts,jtf
 435          DO i=its,itf
 436             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j))
 437          ENDDO
 438          ENDDO
 439       ELSE IF ( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN
 440          DO j=jts,jtf
 441          DO i=its+1,itf
 442             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j))
 443          ENDDO
 444          ENDDO
 445          i=its
 446          DO j=jts,jtf
 447             MUU(i,j) =      MU(i,j)          +MUB(i,j)
 448          ENDDO
 449       ELSE IF ( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN
 450          DO j=jts,jtf
 451          DO i=its,itf-1
 452             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j))
 453          ENDDO
 454          ENDDO
 455          i=ite
 456          DO j=jts,jtf
 457             MUU(i,j) =      MU(i-1,j)        +MUB(i-1,j)
 458          ENDDO
 459       ELSE IF ( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN
 460          DO j=jts,jtf
 461          DO i=its+1,itf-1
 462             MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j))
 463          ENDDO
 464          ENDDO
 465          i=its
 466          DO j=jts,jtf
 467             MUU(i,j) =      MU(i,j)          +MUB(i,j)
 468          ENDDO
 469          i=ite
 470          DO j=jts,jtf
 471             MUU(i,j) =      MU(i-1,j)        +MUB(i-1,j)
 472          ENDDO
 473       END IF
 474
 475       itf=MIN(ite,ide-1)
 476       jtf=jte
 477
 478       IF      ( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN
 479          DO j=jts,jtf
 480          DO i=its,itf
 481              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1))
 482          ENDDO
 483          ENDDO
 484       ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN
 485          DO j=jts+1,jtf
 486          DO i=its,itf
 487              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1))
 488          ENDDO
 489          ENDDO
 490          j=jts
 491          DO i=its,itf
 492              MUV(i,j) =      MU(i,j)          +MUB(i,j)
 493          ENDDO
 494       ELSE IF ( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN
 495          DO j=jts,jtf-1
 496          DO i=its,itf
 497              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1))
 498          ENDDO
 499          ENDDO
 500          j=jte
 501          DO i=its,itf
 502              MUV(i,j) =      MU(i,j-1)        +MUB(i,j-1)
 503          ENDDO
 504       ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN
 505          DO j=jts+1,jtf-1
 506          DO i=its,itf
 507              MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1))
 508          ENDDO
 509          ENDDO
 510          j=jts
 511          DO i=its,itf
 512              MUV(i,j) =      MU(i,j)          +MUB(i,j)
 513          ENDDO
 514          j=jte
 515          DO i=its,itf
 516              MUV(i,j) =      MU(i,j-1)        +MUB(i,j-1)
 517          ENDDO
 518       END IF
 519
 520 END SUBROUTINE calc_mu_staggered
 521
 522 !-------------------------------------------------------------------------------
 523
 524 SUBROUTINE couple ( mu, mub, rfield, field, name, &
 525                     msf, c1h, c2h, c1, c2,        &
 526                     ids, ide, jds, jde, kds, kde, &
 527                     ims, ime, jms, jme, kms, kme, &
 528                     its, ite, jts, jte, kts, kte )
 529
 530    IMPLICIT NONE
 531
 532    ! Input data
 533
 534    INTEGER ,             INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
 535                                           ims, ime, jms, jme, kms, kme, &
 536                                           its, ite, jts, jte, kts, kte
 537
 538    CHARACTER(LEN=1) ,     INTENT(IN   ) :: name
 539
 540    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(  OUT) :: rfield
 541
 542    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mu, mub, msf
 543
 544    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field
 545
 546    REAL , DIMENSION( kms:kme ) ,    INTENT(IN   ) :: c1h, c2h, c1, c2
 547
 548    ! Local data
 549
 550    INTEGER :: i, j, k, itf, jtf, ktf
 551    REAL , DIMENSION(ims:ime,jms:jme) :: muu , muv
 552
 553 !<DESCRIPTION>
 554 !
 555 ! subroutine couple couples the input variable with the dry-air
 556 ! column mass (mu).
 557 !
 558 !</DESCRIPTION>
 559
 560
 561    ktf=MIN(kte,kde-1)
 562
 563    IF (name .EQ. 'u')THEN
 564
 565       CALL calc_mu_staggered ( mu, mub, muu, muv,            &
 566                                   ids, ide, jds, jde, kds, kde, &
 567                                   ims, ime, jms, jme, kms, kme, &
 568                                   its, ite, jts, jte, kts, kte )
 569
 570       itf=ite
 571       jtf=MIN(jte,jde-1)
 572
 573       DO j=jts,jtf
 574       DO k=kts,ktf
 575       DO i=its,itf
 576          rfield(i,k,j)=field(i,k,j)*(c1h(k)*muu(i,j)+c2h(k))/msf(i,j)
 577       ENDDO
 578       ENDDO
 579       ENDDO
 580
 581    ELSE IF (name .EQ. 'v')THEN
 582
 583       CALL calc_mu_staggered ( mu, mub, muu, muv,            &
 584                                ids, ide, jds, jde, kds, kde, &
 585                                ims, ime, jms, jme, kms, kme, &
 586                                its, ite, jts, jte, kts, kte )
 587
 588       itf=ite
 589       itf=MIN(ite,ide-1)
 590       jtf=jte
 591
 592       DO j=jts,jtf
 593       DO k=kts,ktf
 594       DO i=its,itf
 595            rfield(i,k,j)=field(i,k,j)*(c1h(k)*muv(i,j)+c2h(k))/msf(i,j)
 596       ENDDO
 597       ENDDO
 598       ENDDO
 599
 600    ELSE IF (name .EQ. 'w')THEN
 601       itf=MIN(ite,ide-1)
 602       jtf=MIN(jte,jde-1)
 603       DO j=jts,jtf
 604       DO k=kts,kte
 605       DO i=its,itf
 606          rfield(i,k,j)=field(i,k,j)*((c1(k)*mu(i,j))+(c1(k)*mub(i,j)+c2(k)))/msf(i,j)
 607       ENDDO
 608       ENDDO
 609       ENDDO
 610
 611    ELSE IF (name .EQ. 'h')THEN
 612       itf=MIN(ite,ide-1)
 613       jtf=MIN(jte,jde-1)
 614       DO j=jts,jtf
 615       DO k=kts,kte
 616       DO i=its,itf
 617          rfield(i,k,j)=field(i,k,j)*((c1(k)*mu(i,j))+(c1(k)*mub(i,j)+c2(k)))
 618       ENDDO
 619       ENDDO
 620       ENDDO
 621
 622    ELSE
 623       itf=MIN(ite,ide-1)
 624       jtf=MIN(jte,jde-1)
 625       DO j=jts,jtf
 626       DO k=kts,ktf
 627       DO i=its,itf
 628          rfield(i,k,j)=field(i,k,j)*((c1(k)*mu(i,j))+(c1(k)*mub(i,j)+c2(k)))
 629       ENDDO
 630       ENDDO
 631       ENDDO
 632
 633    ENDIF
 634
 635 END SUBROUTINE couple
 636
 637
 638 !-------------------------------------------------------------------------------
 639
 640 SUBROUTINE calc_ww_cp ( u, v, mup, mub, c1h, c2h, ww,    &
 641                         rdx, rdy, msftx, msfty,          &
 642                         msfux, msfuy, msfvx, msfvx_inv,  &
 643                         msfvy, dnw,                      &
 644                         ids, ide, jds, jde, kds, kde,    &
 645                         ims, ime, jms, jme, kms, kme,    &
 646                         its, ite, jts, jte, kts, kte    )
 647
 648    IMPLICIT NONE
 649
 650    ! Input data
 651
 652
 653    INTEGER ,    INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
 654                                  ims, ime, jms, jme, kms, kme, &
 655                                  its, ite, jts, jte, kts, kte
 656
 657    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: u, v
 658    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mup, mub, &
 659                                                             msftx, msfty, &
 660                                                             msfux, msfuy, &
 661                                                             msfvx, msfvy, &
 662                                                             msfvx_inv
 663    REAL , DIMENSION( kms:kme ) , INTENT(IN   ) :: dnw
 664    REAL , DIMENSION( kms:kme ) , INTENT(IN   ) :: c1h, c2h
 665
 666    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT  ) :: ww
 667    REAL , INTENT(IN   )  :: rdx, rdy
 668
 669    ! Local data
 670
 671    INTEGER :: i, j, k, itf, jtf, ktf
 672    REAL , DIMENSION( its:ite ) :: dmdt
 673    REAL , DIMENSION( its:ite, kts:kte ) :: divv
 674    REAL , DIMENSION( its:ite+1, jts:jte+1 ) :: muu, muv
 675
 676 !<DESCRIPTION>
 677 !
 678 !  calc_ww calculates omega using the velocities (u,v) and the dry-air
 679 !  column mass (mup+mub).
 680 !  The algorithm integrates the continuity equation through the column
 681 !  followed by a diagnosis of omega.
 682 !
 683 !</DESCRIPTION>
 684
 685 !<DESCRIPTION>
 686 !
 687 !  calc_ww_cp calculates omega using the velocities (u,v) and the
 688 !  column mass mu.
 689 !
 690 !</DESCRIPTION>
 691
 692     jtf=MIN(jte,jde-1)
 693     ktf=MIN(kte,kde-1)
 694     itf=MIN(ite,ide-1)
 695
 696 !  mu coupled with the appropriate map factor
 697
 698       DO j=jts,jtf
 699       DO i=its,min(ite+1,ide)
 700         MUU(i,j) = 0.5*(MUP(i,j)+MUB(i,j)+MUP(i-1,j)+MUB(i-1,j))
 701       ENDDO
 702       ENDDO
 703
 704       DO j=jts,min(jte+1,jde)
 705       DO i=its,itf
 706         MUV(i,j) = 0.5*(MUP(i,j)+MUB(i,j)+MUP(i,j-1)+MUB(i,j-1))
 707       ENDDO
 708       ENDDO
 709
 710       DO j=jts,jtf
 711
 712         DO i=its,ite
 713           dmdt(i) = 0.
 714           ww(i,1,j) = 0.
 715           ww(i,kte,j) = 0.
 716         ENDDO
 717
 718 !       Comments on the modifications for map scale factors
 719 !       ADT eqn 47 / my (putting rho -> 'mu') is:
 720 !       (1/my) partial d mu/dt = -mx partial d/dx(mu u/my)
 721 !                                -mx partial d/dy(mu v/mx)
 722 !                                -partial d/dz(mu w/my)
 723 !
 724 !       Using nu instead of z the last term becomes:
 725 !                                -partial d/dnu((c1(k)*mu(dnu/dt))/my)
 726 !
 727 !       Integrating with respect to nu over ALL levels, with dnu/dt=0 at top
 728 !       and bottom, the last term becomes = 0
 729 !
 730 !       Integral|bot->top[(1/my) partial d mu/dt]dnu =
 731 !       Integral|bot->top[-mx partial d/dx(mu u/my)
 732 !                         -mx partial d/dy(mu v/mx)]dnu
 733 !
 734 !       muu='mu'[on u]/my, muv='mu'[on v]/mx
 735 !       (1/my) partial d mu/dt is independent of nu
 736 !         => LHS = Integral|bot->top[con]dnu = conservation*(-1) = -dmdt
 737 !
 738 !         => dmdt = mx*Integral|bot->top[partial d/dx(mu u/my) +
 739 !                                        partial d/dy(mu v/mx)]dnu
 740 !         => dmdt = sum_bot->top[divv]
 741 !       where
 742 !         divv=mx*[partial d/dx(mu u/my) + partial d/dy(mu v/mx)]*delta nu
 743
 744         DO k=kts,ktf
 745         DO i=its,itf
 746
 747           divv(i,k) = msftx(i,j)*dnw(k)*( rdx*((c1h(k)*muu(i+1,j)+c2h(k))*u(i+1,k,j)/msfuy(i+1,j)-(c1h(k)*muu(i,j)+c2h(k))*u(i,k,j)/msfuy(i,j))  &
 748                                         +rdy*((c1h(k)*muv(i,j+1)+c2h(k))*v(i,k,j+1)*msfvx_inv(i,j+1)-(c1h(k)*muv(i,j)+c2h(k))*v(i,k,j)*msfvx_inv(i,j))   )
 749
 750 !          dmdt(i) = dmdt(i) + dnw(k)* ( rdx*(ru(i+1,k,j)-ru(i,k,j))  &
 751 !                                       +rdy*(rv(i,k,j+1)-rv(i,k,j))   )
 752
 753           dmdt(i) = dmdt(i) + divv(i,k)
 754
 755
 756         ENDDO
 757         ENDDO
 758
 759 !       Further map scale factor notes:
 760 !       Now integrate from bottom to top, level by level:
 761 !       mu dnu/dt/my [k+1] = mu dnu/dt/my [k] + [-(1/my) partial d mu/dt
 762 !                           -mx partial d/dx(mu u/my)
 763 !                           -mx partial d/dy(mu v/mx)]*dnu[k->k+1]
 764 !       ww [k+1] = ww [k] -(1/my) partial d mu/dt * dnu[k->k+1] - divv[k]
 765 !                = ww [k] -dmdt * dnw[k] - divv[k]
 766
 767         DO k=2,ktf
 768         DO i=its,itf
 769
 770 !           ww(i,k,j)=ww(i,k-1,j)                                       &
 771 !                        - dnw(k-1)* ( dmdt(i)                          &
 772 !                                     +rdx*(ru(i+1,k-1,j)-ru(i,k-1,j))  &
 773 !                                     +rdy*(rv(i,k-1,j+1)-rv(i,k-1,j)) )
 774
 775            ww(i,k,j)=ww(i,k-1,j) - dnw(k-1)*c1h(k-1)*dmdt(i) - divv(i,k-1)
 776
 777         ENDDO
 778         ENDDO
 779      ENDDO
 780
 781
 782 END SUBROUTINE calc_ww_cp
 783
 784
 785 !-------------------------------------------------------------------------------
 786
 787 SUBROUTINE calc_cq ( moist, cqu, cqv, cqw, n_moist, &
 788                      ids, ide, jds, jde, kds, kde,  &
 789                      ims, ime, jms, jme, kms, kme,  &
 790                      its, ite, jts, jte, kts, kte  )
 791
 792    IMPLICIT NONE
 793
 794    ! Input data
 795
 796    INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
 797                                        ims, ime, jms, jme, kms, kme, &
 798                                        its, ite, jts, jte, kts, kte
 799
 800    INTEGER ,          INTENT(IN   ) :: n_moist
 801
 802
 803    REAL, DIMENSION( ims:ime, kms:kme , jms:jme , n_moist ), INTENT(IN   ) :: moist
 804
 805    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(  OUT) :: cqu, cqv, cqw
 806
 807    ! Local stuff
 808
 809    ! Changes from Larry Meadows, Intel Corp.  Improve vectorization of this routine
 810    REAL :: qtot(its:ite)
 811
 812    INTEGER :: i, j, k, itf, jtf, ktf, ispe
 813
 814 !<DESCRIPTION>
 815 !
 816 !  calc_cq calculates moist coefficients for the momentum equations.
 817 !
 818 !</DESCRIPTION>
 819
 820       ktf=MIN(kte,kde-1)
 821
 822       IF(  n_moist >= PARAM_FIRST_SCALAR ) THEN
 823
 824         itf=ite
 825         jtf=MIN(jte,jde-1)
 826         DO j=jts,jtf
 827           DO k=kts,ktf
 828             qtot = 0.
 829             DO ispe=PARAM_FIRST_SCALAR,n_moist
 830               DO i=its,itf
 831                 qtot(i) = qtot(i) + moist(i,k,j,ispe) + moist(i-1,k,j,ispe)
 832               ENDDO
 833             ENDDO
 834             DO i=its,itf
 835               cqu(i,k,j) = 1./(1.+0.5*qtot(i))
 836             ENDDO
 837         ENDDO
 838         ENDDO
 839
 840         itf=MIN(ite,ide-1)
 841         jtf=jte
 842         DO j=jts,jtf
 843           DO k=kts,ktf
 844             qtot = 0.
 845             DO ispe=PARAM_FIRST_SCALAR,n_moist
 846               DO i=its,itf
 847                 qtot(i) = qtot(i) + moist(i,k,j,ispe) + moist(i,k,j-1,ispe)
 848               ENDDO
 849             ENDDO
 850             DO i = its,itf
 851                cqv(i,k,j) = 1./(1.+0.5*qtot(i))
 852             ENDDO
 853           ENDDO
 854         ENDDO
 855
 856         itf=MIN(ite,ide-1)
 857         jtf=MIN(jte,jde-1)
 858         DO j=jts,jtf
 859           DO k=kts+1,ktf
 860             qtot = 0.
 861             DO ispe=PARAM_FIRST_SCALAR,n_moist
 862               DO i=its,itf
 863                 qtot(i) = qtot(i) + moist(i,k,j,ispe) + moist(i,k-1,j,ispe)
 864               ENDDO
 865             ENDDO
 866             DO i = its,itf
 867               cqw(i,k,j) = 0.5*qtot(i)
 868             ENDDO
 869         ENDDO
 870         ENDDO
 871
 872       ELSE
 873
 874         itf=ite
 875         jtf=MIN(jte,jde-1)
 876         DO j=jts,jtf
 877         DO k=kts,ktf
 878         DO i=its,itf
 879            cqu(i,k,j) = 1.
 880         ENDDO
 881         ENDDO
 882         ENDDO
 883
 884         itf=MIN(ite,ide-1)
 885         jtf=jte
 886         DO j=jts,jtf
 887         DO k=kts,ktf
 888         DO i=its,itf
 889            cqv(i,k,j) = 1.
 890         ENDDO
 891         ENDDO
 892         ENDDO
 893
 894         itf=MIN(ite,ide-1)
 895         jtf=MIN(jte,jde-1)
 896         DO j=jts,jtf
 897         DO k=kts+1,ktf
 898         DO i=its,itf
 899            cqw(i,k,j) = 0.
 900         ENDDO
 901         ENDDO
 902         ENDDO
 903
 904       END IF
 905
 906 END SUBROUTINE calc_cq
 907
 908 !----------------------------------------------------------------------
 909
 910 SUBROUTINE calc_alt ( alt, al, alb,                  &
 911                       ids, ide, jds, jde, kds, kde,  &
 912                       ims, ime, jms, jme, kms, kme,  &
 913                       its, ite, jts, jte, kts, kte  )
 914
 915    IMPLICIT NONE
 916
 917    ! Input data
 918
 919    INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
 920                                        ims, ime, jms, jme, kms, kme, &
 921                                        its, ite, jts, jte, kts, kte
 922
 923    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN   ) :: alb, al
 924    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(  OUT) :: alt
 925
 926    ! Local stuff
 927
 928    INTEGER :: i, j, k, itf, jtf, ktf
 929
 930 !<DESCRIPTION>
 931 !
 932 ! calc_alt computes the full inverse density
 933 !
 934 !</DESCRIPTION>
 935
 936       itf=MIN(ite,ide-1)
 937       jtf=MIN(jte,jde-1)
 938       ktf=MIN(kte,kde-1)
 939
 940       DO j=jts,jtf
 941       DO k=kts,ktf
 942       DO i=its,itf
 943         alt(i,k,j) = al(i,k,j)+alb(i,k,j)
 944       ENDDO
 945       ENDDO
 946       ENDDO
 947
 948
 949 END SUBROUTINE calc_alt
 950
 951 !----------------------------------------------------------------------
 952
 953 SUBROUTINE calc_p_rho_phi ( moist, n_moist, hypsometric_opt,      &
 954                             al, alb, mu, muts,                    &
 955                             c1, c2, c3h, c4h, c3f, c4f,           &
 956                             ph, phb, p, pb,                       &
 957                             t, p0, t0, ptop, znu, znw, dnw, rdnw, &
 958                             rdn, non_hydrostatic, use_theta_m,    &
 959                             ids, ide, jds, jde, kds, kde,         &
 960                             ims, ime, jms, jme, kms, kme,         &
 961                             its, ite, jts, jte, kts, kte          )
 962
 963   IMPLICIT NONE
 964
 965    ! Input data
 966
 967   LOGICAL ,          INTENT(IN   ) :: non_hydrostatic
 968   INTEGER ,          INTENT(IN   ) :: use_theta_m
 969
 970   INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
 971                                       ims, ime, jms, jme, kms, kme, &
 972                                       its, ite, jts, jte, kts, kte
 973
 974   INTEGER ,          INTENT(IN   ) :: n_moist
 975   INTEGER ,          INTENT(IN   ) :: hypsometric_opt
 976
 977   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN   ) :: alb,  &
 978                                                                    pb,   &
 979                                                                    t
 980
 981   REAL, DIMENSION( ims:ime , kms:kme , jms:jme, n_moist ), INTENT(IN   ) :: moist
 982
 983   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(  OUT) :: al, p
 984
 985   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: ph, phb
 986
 987   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN   ) :: mu, muts
 988
 989   REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: znu, znw, dnw, rdnw, rdn
 990
 991   REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: c1, c2, c3h, c4h, c3f, c4f
 992
 993   REAL,   INTENT(IN   ) :: t0, p0, ptop
 994
 995   ! Local stuff
 996
 997   INTEGER :: i, j, k, kk, itf, jtf, ktf, ispe
 998   REAL    :: qtot, qf1, qf2, qvf
 999   REAL, DIMENSION( its:ite) :: temp,cpovcv_v
1000   REAL    :: pfu, phm, pfd
1001
1002 !<DESCRIPTION>
1003 !
1004 ! For the nonhydrostatic option, calc_p_rho_phi calculates the
1005 ! diagnostic quantities pressure and (inverse) density from the
1006 ! prognostic variables using the equation of state.
1007 !
1008 ! For the hydrostatic option, calc_p_rho_phi calculates the
1009 ! diagnostic quantities (inverse) density and geopotential from the
1010 ! prognostic variables using the equation of state and the hydrostatic
1011 ! equation.
1012 !
1013 !</DESCRIPTION>
1014
1015   itf=MIN(ite,ide-1)
1016   jtf=MIN(jte,jde-1)
1017   ktf=MIN(kte,kde-1)
1018
1019 #ifndef INTELMKL
1020   cpovcv_v = cpovcv
1021 #endif
1022
1023   nonhydro : IF (non_hydrostatic) THEN
1024
1025       hypso_nonhydro : IF (hypsometric_opt == 1) THEN
1026         DO j=jts,jtf
1027         DO k=kts,ktf
1028         DO i=its,itf
1029           al(i,k,j)=-1./(c1(k)*muts(i,j)+c2(k))*(alb(i,k,j)*(c1(k)*mu(i,j)) + rdnw(k)*(ph(i,k+1,j)-ph(i,k,j)))
1030         END DO
1031         END DO
1032         END DO
1033       ELSE IF (hypsometric_opt == 2) THEN hypso_nonhydro
1034
1035         ! The relation used to get specific volume, al, is: al = -dZ/dp,
1036         ! where dp = mut * d(eta). The pressure depth, dp, is replaced with
1037         ! p*(dp/p) ~ p*LOG((p+0.5dp)/(p-0.5dp)). Difference between dp and p*dLOG(p)
1038         ! is as follows: p*dLOG(p) - dp = 1/12*(dp/p)**3 + 1/90*(dp/p)**5 + ...
1039         ! Therefore, p*dLOG(p) is always larger than dp and the difference is
1040         ! in proportion to dp/p. TKW, 02/16/2010
1041
1042         DO j=jts,jtf
1043         DO k=kts,ktf
1044         DO i=its,itf
1045           pfu = c3f(k+1)*MUTS(i,j) + c4f(k+1) + ptop
1046           pfd = c3f(k  )*MUTS(i,j) + c4f(k  ) + ptop
1047           phm = c3h(k  )*MUTS(i,j) + c4h(k  ) + ptop
1048           al(i,k,j) = (ph(i,k+1,j)-ph(i,k,j)+phb(i,k+1,j)-phb(i,k,j))/phm/LOG(pfd/pfu)-alb(i,k,j)
1049         END DO
1050         END DO
1051         END DO
1052       ELSE hypso_nonhydro
1053         CALL wrf_error_fatal ( 'calc_p_rho_phi: hypsometric_opt should be 1 or 2' )
1054       END IF hypso_nonhydro
1055
1056       moist_nonhydro : IF (n_moist >= PARAM_FIRST_SCALAR ) THEN
1057
1058         DO j=jts,jtf
1059         DO k=kts,ktf
1060         DO i=its,itf
1061         IF ( use_theta_m .EQ. 1 ) THEN
1062           temp(i)=(r_d*(t0+t(i,k,j)))/(p0*(al(i,k,j)+alb(i,k,j)))
1063         ELSE
1064           qvf = 1.+rvovrd*moist(i,k,j,P_QV)
1065           temp(i)=(r_d*(t0+t(i,k,j))*qvf)/(p0*(al(i,k,j)+alb(i,k,j)))
1066         ENDIF
1067         ENDDO
1068 #ifdef INTELMKL
1069         CALL VPOWX ( itf-its+1, temp(its), cpovcv, p(its,k,j) )
1070 #else
1071 ! use vector version from libmassv or from compat lib in frame/libmassv.F
1072         CALL VPOW  ( p(its,k,j), temp(its), cpovcv_v(its), itf-its+1 )
1073 #endif
1074         DO i=its,itf
1075            p(i,k,j)= p(i,k,j)*p0-pb(i,k,j)
1076         ENDDO
1077         ENDDO
1078         ENDDO
1079
1080       ELSE moist_nonhydro
1081
1082         DO j=jts,jtf
1083         DO k=kts,ktf
1084         DO i=its,itf
1085           p(i,k,j)=p0*( (r_d*(t0+t(i,k,j)))/                     &
1086                         (p0*(al(i,k,j)+alb(i,k,j))) )**cpovcv  &
1087                            -pb(i,k,j)
1088         ENDDO
1089         ENDDO
1090         ENDDO
1091
1092       END IF moist_nonhydro
1093
1094    ELSE nonhydro
1095
1096 !  hydrostatic pressure, al, and ph1 calc; WCS, 5 sept 2001
1097
1098
1099       moist_hydro : IF (n_moist >= PARAM_FIRST_SCALAR ) THEN
1100
1101         DO j=jts,jtf
1102
1103           k=ktf          ! top layer
1104           DO i=its,itf
1105
1106             qtot = 0.
1107             DO ispe=PARAM_FIRST_SCALAR,n_moist
1108               qtot = qtot + moist(i,k,j,ispe)
1109             ENDDO
1110             qf2 = 1.
1111             qf1 = qtot*qf2
1112
1113             p(i,k,j) = - 0.5*((c1(k)*mu(i,j))+qf1*(c1(k)*muts(i,j)+c2(k)))/rdnw(k)/qf2
1114             IF ( use_theta_m .EQ. 1 ) THEN
1115             al(i,k,j) = (r_d/p1000mb)*(t(i,k,j)+t0)* &
1116                 (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) - alb(i,k,j)
1117             ELSE
1118             qvf = 1.+rvovrd*moist(i,k,j,P_QV)
1119             al(i,k,j) = (r_d/p1000mb)*(t(i,k,j)+t0)*qvf* &
1120                 (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) - alb(i,k,j)
1121             END IF
1122
1123           ENDDO
1124
1125           DO k=ktf-1,kts,-1  ! remaining layers, integrate down
1126             DO i=its,itf
1127
1128             qtot = 0.
1129             DO ispe=PARAM_FIRST_SCALAR,n_moist
1130               qtot = qtot + 0.5*(  moist(i,k  ,j,ispe) + moist(i,k+1,j,ispe) )
1131             ENDDO
1132             qf2 = 1.
1133             qf1 = qtot*qf2
1134
1135             p(i,k,j) = p(i,k+1,j) - ((c1(k)*mu(i,j)) + qf1*(c1(k)*muts(i,j)+c2(k)))/qf2/rdn(k+1)
1136             IF ( use_theta_m .EQ. 1 ) THEN
1137             al(i,k,j) = (r_d/p1000mb)*(t(i,k,j)+t0)* &
1138                         (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) - alb(i,k,j)
1139             ELSE
1140             qvf = 1.+rvovrd*moist(i,k,j,P_QV)
1141             al(i,k,j) = (r_d/p1000mb)*(t(i,k,j)+t0)*qvf* &
1142                         (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) - alb(i,k,j)
1143             END IF
1144             ENDDO
1145           ENDDO
1146
1147         ENDDO
1148
1149       ELSE moist_hydro
1150
1151         DO j=jts,jtf
1152
1153           k=ktf          ! top layer
1154           DO i=its,itf
1155
1156             qtot = 0.
1157             qf2 = 1.
1158             qf1 = qtot*qf2
1159
1160             p(i,k,j) = - 0.5*((c1(k)*mu(i,j))+qf1*(c1(k)*muts(i,j)+c2(k)))/rdnw(k)/qf2
1161             al(i,k,j) = (r_d/p1000mb)*(t(i,k,j)+t0)* &
1162                 (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) - alb(i,k,j)
1163
1164           ENDDO
1165
1166           DO k=ktf-1,kts,-1  ! remaining layers, integrate down
1167             DO i=its,itf
1168
1169             qtot = 0.
1170             qf2 = 1.
1171             qf1 = qtot*qf2
1172
1173             p(i,k,j) = p(i,k+1,j) - ((c1(k)*mu(i,j)) + qf1*(c1(k)*muts(i,j)+c2(k)))/qf2/rdn(k+1)
1174             al(i,k,j) = (r_d/p1000mb)*(t(i,k,j)+t0)* &
1175                         (((p(i,k,j)+pb(i,k,j))/p1000mb)**cvpm) - alb(i,k,j)
1176             ENDDO
1177           ENDDO
1178
1179         ENDDO
1180
1181      END IF moist_hydro
1182
1183      hypso_hydro : IF (hypsometric_opt == 1) THEN
1184         DO j=jts,jtf
1185           DO kk=2,ktf+1  ! integrate hydrostatic equation for geopotential
1186             k = kk-1
1187             DO i=its,itf
1188               ph(i,k+1,j) = ph(i,k,j) - (dnw(k))*(           &
1189                            ((c1(k)*muts(i,j)+c2(k)))*al(i,k,j)+            &
1190                             (c1(k)*mu(i,j))*alb(i,k,j)  )
1191             ENDDO
1192           ENDDO
1193         ENDDO
1194      ELSE hypso_hydro
1195
1196      ! Revised hypsometric eq.: dZ=-al*p*dLOG(p), where p is dry pressure
1197
1198       DO j=jts,jtf
1199         DO i=its,itf
1200            ph(i,kts,j) = phb(i,kts,j)
1201         END DO
1202
1203         DO k=kts+1,ktf+1
1204           DO i=its,itf
1205             pfu = c3f(k  )*MUTS(i,j) + c4f(k  ) + ptop
1206             pfd = c3f(k-1)*MUTS(i,j) + c4f(k-1) + ptop
1207             phm = c3h(k-1)*MUTS(i,j) + c4h(k-1) + ptop
1208             ph(i,k,j) = ph(i,k-1,j) + (al(i,k-1,j)+alb(i,k-1,j))*phm*LOG(pfd/pfu)
1209           ENDDO
1210         ENDDO
1211
1212         DO k=kts,ktf+1
1213           DO i=its,itf
1214              ph(i,k,j) = ph(i,k,j) - phb(i,k,j)
1215           END DO
1216         END DO
1217       END DO
1218
1219      END IF hypso_hydro
1220
1221    END IF nonhydro
1222
1223 END SUBROUTINE calc_p_rho_phi
1224
1225 !----------------------------------------------------------------------
1226
1227 SUBROUTINE calc_php ( php, ph, phb,                  &
1228                       ids, ide, jds, jde, kds, kde,  &
1229                       ims, ime, jms, jme, kms, kme,  &
1230                       its, ite, jts, jte, kts, kte  )
1231
1232    IMPLICIT NONE
1233
1234    ! Input data
1235
1236    INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
1237                                        ims, ime, jms, jme, kms, kme, &
1238                                        its, ite, jts, jte, kts, kte
1239
1240    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN   ) :: phb, ph
1241    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(  OUT) :: php
1242
1243    ! Local stuff
1244
1245    INTEGER :: i, j, k, itf, jtf, ktf
1246
1247 !<DESCRIPTION>
1248 !
1249 !  calc_php calculates the full geopotential from the reference state
1250 !  geopotential and the perturbation geopotential (phb_ph).
1251 !
1252 !</DESCRIPTION>
1253
1254       itf=MIN(ite,ide-1)
1255       jtf=MIN(jte,jde-1)
1256       ktf=MIN(kte,kde-1)
1257
1258       DO j=jts,jtf
1259       DO k=kts,ktf
1260       DO i=its,itf
1261         php(i,k,j) = 0.5*(phb(i,k,j)+phb(i,k+1,j)+ph(i,k,j)+ph(i,k+1,j))
1262       ENDDO
1263       ENDDO
1264       ENDDO
1265
1266 END SUBROUTINE calc_php
1267
1268 !-------------------------------------------------------------------------------
1269
1270 SUBROUTINE diagnose_w( ph_tend, ph_new, ph_old, w, mut,     &
1271                        c1f, c2f, dt,                        &
1272                        u, v, ht,                            &
1273                        cf1, cf2, cf3, rdx, rdy,             &
1274                        msftx, msfty,                        &
1275                        ids, ide, jds, jde, kds, kde,        &
1276                        ims, ime, jms, jme, kms, kme,        &
1277                        its, ite, jts, jte, kts, kte        )
1278
1279    IMPLICIT NONE
1280
1281    INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
1282                                        ims, ime, jms, jme, kms, kme, &
1283                                        its, ite, jts, jte, kts, kte
1284
1285    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN   ) ::   ph_tend, &
1286                                                                      ph_new,  &
1287                                                                      ph_old,  &
1288                                                                      u,       &
1289                                                                      v
1290
1291
1292    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(  OUT) :: w
1293
1294    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   ) :: mut, ht, msftx, msfty
1295
1296    REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: c1f, c2f
1297
1298    REAL, INTENT(IN   ) :: dt, cf1, cf2, cf3, rdx, rdy
1299
1300    INTEGER :: i, j, k, itf, jtf
1301
1302    itf=MIN(ite,ide-1)
1303    jtf=MIN(jte,jde-1)
1304
1305 !<DESCRIPTION>
1306 !
1307 ! diagnose_w diagnoses the vertical velocity from the geopoential equation.
1308 ! Used with the hydrostatic option.
1309 !
1310 !</DESCRIPTION>
1311
1312    DO j = jts, jtf
1313
1314 !  lower b.c. on w
1315
1316 !  Notes on map scale factors:
1317 !  Chain rule: if Z=Z(X,Y) [true at the surface] then
1318 !  dZ/dt = dZ/dX * dX/dt + dZ/dY * dY/dt, U=dX/dt, V=dY/dt
1319 !  Using capitals to denote actual values
1320 !  In mapped values, u=U, v=V, z=Z, 1/dX=mx/dx, 1/dY=my/dy
1321 !    => w = dz/dt = mx u dz/dx + my v dz/dy
1322 !  [where dz/dx is just the surface height change between x
1323 !   gridpoints, and dz/dy is the change between y gridpoints]
1324 !  [NB: cf1, cf2 and cf3 do vertical weighting of u or v values
1325 !   nearest the surface]
1326
1327 !  Previously msft multiplied by rdy and rdx terms.
1328 !  Now msfty multiplies rdy term, and msftx multiplies msftx term
1329      DO i = its, itf
1330          w(i,1,j)=  msfty(i,j)*.5*rdy*(                      &
1331                            (ht(i,j+1)-ht(i,j  ))             &
1332           *(cf1*v(i,1,j+1)+cf2*v(i,2,j+1)+cf3*v(i,3,j+1))    &
1333                           +(ht(i,j  )-ht(i,j-1))             &
1334           *(cf1*v(i,1,j  )+cf2*v(i,2,j  )+cf3*v(i,3,j  ))  ) &
1335                  +msftx(i,j)*.5*rdx*(                        &
1336                            (ht(i+1,j)-ht(i,j  ))             &
1337           *(cf1*u(i+1,1,j)+cf2*u(i+1,2,j)+cf3*u(i+1,3,j))    &
1338                           +(ht(i,j  )-ht(i-1,j))             &
1339           *(cf1*u(i  ,1,j)+cf2*u(i  ,2,j)+cf3*u(i  ,3,j))  )
1340      ENDDO
1341
1342 !  use geopotential equation to diagnose w
1343
1344 !  Further notes on map scale factors
1345 !  If ph_tend contains:  -mx partial d/dx(mu rho u/my)
1346 !                        -mx partial d/dy(phi mu v/mx)
1347 !                        -partial d/dz(phi mu w/my)
1348 !  then phi eqn is: partial d/dt(mu phi/my) = ph_tend + mu g w/my
1349 !    => w = [my/(mu*g)]*[partial d/dt(mu phi/my) - ph_tend]
1350
1351      DO k = 2, kte
1352      DO i = its, itf
1353        w(i,k,j) =  msfty(i,j)*(  (ph_new(i,k,j)-ph_old(i,k,j))/dt       &
1354                                - ph_tend(i,k,j)/(c1f(k)*mut(i,j)+c2f(k))        )/g
1355
1356      ENDDO
1357      ENDDO
1358
1359    ENDDO
1360
1361 END SUBROUTINE diagnose_w
1362
1363 !-------------------------------------------------------------------------------
1364
1365 SUBROUTINE rhs_ph( ph_tend, u, v, ww,               &
1366                    ph, ph_old, phb, w,              &
1367                    mut, muuf, muvf,                 &
1368                    c1f, c2f,                        &
1369                    fnm, fnp,                        &
1370                    rdnw, cfn, cfn1, rdx, rdy,       &
1371                    msfux, msfuy, msfvx,             &
1372                    msfvx_inv, msfvy,                &
1373                    msftx, msfty,                    &
1374                    non_hydrostatic,                 &
1375                    config_flags,                    &
1376                    ids, ide, jds, jde, kds, kde,    &
1377                    ims, ime, jms, jme, kms, kme,    &
1378                    its, ite, jts, jte, kts, kte    )
1379    IMPLICIT NONE
1380
1381    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
1382
1383    INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
1384                                        ims, ime, jms, jme, kms, kme, &
1385                                        its, ite, jts, jte, kts, kte
1386
1387    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN   ) ::        &
1388                                                                      u,   &
1389                                                                      v,   &
1390                                                                      ww,  &
1391                                                                      ph,  &
1392                                                                      ph_old, &
1393                                                                      phb, &
1394                                                                     w
1395
1396    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) :: ph_tend
1397
1398    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   ) :: muuf, muvf, mut,   &
1399                                                             msfux, msfuy, &
1400                                                             msfvx, msfvy, &
1401                                                             msftx, msfty, &
1402                                                             msfvx_inv
1403
1404    REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: rdnw, fnm, fnp
1405
1406    REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: c1f, c2f
1407
1408
1409    REAL,  INTENT(IN   ) :: cfn, cfn1, rdx, rdy
1410
1411    LOGICAL,  INTENT(IN   )  ::  non_hydrostatic
1412
1413    ! Local stuff
1414
1415    INTEGER :: i, j, k, itf, jtf, ktf, kz, i_start, j_start
1416    REAL    :: ur, ul, ub, vr, vl, vb
1417    REAL, DIMENSION(its:ite,kts:kte) :: wdwn
1418
1419    INTEGER :: advective_order
1420
1421    LOGICAL :: specified
1422
1423 !<DESCRIPTION>
1424 !
1425 ! rhs_ph calculates the large-timestep tendency terms for the geopotential
1426 ! equation.  These terms include the advection and "gw".  The geopotential
1427 ! equation is cast in advective form, so we don't use the flux form advection
1428 ! algorithms here.
1429 !
1430 !</DESCRIPTION>
1431
1432    specified = .false.
1433    if(config_flags%specified .or. config_flags%nested) specified = .true.
1434
1435    advective_order = config_flags%h_sca_adv_order
1436
1437    itf=MIN(ite,ide-1)
1438    jtf=MIN(jte,jde-1)
1439    ktf=MIN(kte,kde-1)
1440
1441 !  Notes on map scale factors (WCS, 2 march 2008)
1442 !  phi equation is:   mu/my d/dt(phi) = -(1/my) mx mu u  d/dx(phi)
1443 !                                       -(1/my) my mu v d/dy(phi)
1444 !                                       - omega d/d_eta(phi)
1445 !                                               +mu g w/my
1446 !
1447 !  A little further explanation...
1448 !  The tendency term we are computing here is for mu/my d/dt(phi).  It is advective form
1449 !  but it is multiplied be mu/my.  It will be decoupled from (mu/my) when the implicit w-phi
1450 !  solution is computed in subourine advance_w.  The formulation dates from the early
1451 !  days of the mass coordinate model when we were testing both a flux and an advective formulation
1452 !  for the geopotential equation and different forms of the vertical momentum equation and the
1453 !  vertically implicit solver.
1454
1455 ! advective form for the geopotential equation
1456
1457    !  RHS term 3 is: - omega partial d/dnu(phi)
1458
1459    DO j = jts, jtf
1460       IF (config_flags%phi_adv_z == 2) THEN
1461          !  First get staggered partial d/dnu(phi) and then multiply with omega
1462          !  to avoid double staggering of omega
1463
1464          DO k = 2, kte
1465          DO i = its, itf
1466               wdwn(i,k) = rdnw(k-1)*(ph(i,k,j)-ph(i,k-1,j)+phb(i,k,j)-phb(i,k-1,j))
1467          ENDDO
1468          ENDDO
1469
1470          DO k = 2, kte-1
1471          DO i = its, itf
1472               ph_tend(i,k,j) = ph_tend(i,k,j)                           &
1473                                 - ww(i,k,j)*(fnm(k)*wdwn(i,k+1)+fnp(k)*wdwn(i,k))
1474          ENDDO
1475          ENDDO
1476       ELSE
1477          !  First destagger omega and multiply with partial d/dnu(phi), then stagger the product
1478
1479          DO k = 2, kte
1480          DO i = its, itf
1481               wdwn(i,k) = .5*(ww(i,k,j)+ww(i,k-1,j))*rdnw(k-1)               &
1482                             *(ph(i,k,j)-ph(i,k-1,j)+phb(i,k,j)-phb(i,k-1,j))
1483          ENDDO
1484          ENDDO
1485
1486          DO k = 2, kte-1
1487          DO i = its, itf
1488                ph_tend(i,k,j) = ph_tend(i,k,j)                           &
1489                                  - (fnm(k)*wdwn(i,k+1)+fnp(k)*wdwn(i,k))
1490          ENDDO
1491          ENDDO
1492      ENDIF
1493
1494    ENDDO
1495
1496    IF (non_hydrostatic) THEN  ! add in "gw" term.
1497    DO j = jts, jtf            ! in hydrostatic mode, "gw" will be diagnosed
1498                               ! after the timestep to give us "w"
1499      DO i = its, itf
1500         ph_tend(i,kde,j) = 0.
1501      ENDDO
1502
1503      DO k = 2, kte
1504      DO i = its, itf
1505         ! phi equation RHS term 4
1506         ph_tend(i,k,j) = ph_tend(i,k,j) + (c1f(k)*mut(i,j)+c2f(k))*g*w(i,k,j)/msfty(i,j)
1507      ENDDO
1508      ENDDO
1509
1510    ENDDO
1511
1512    END IF
1513
1514 !  Notes on map scale factors:
1515 !  RHS terms 1 and 2 are: -(1/my) mx u mu partial d/dx(phi)
1516 !                         -(1/my) my v mu partial d/dy(phi)
1517
1518    IF (advective_order <= 2) THEN
1519
1520 !  y (v) advection
1521
1522    i_start = its
1523    j_start = jts
1524    itf=MIN(ite,ide-1)
1525    jtf=MIN(jte,jde-1)
1526
1527    IF ( (config_flags%open_ys .or. specified) .and. jts == jds ) j_start = jts+1
1528    IF ( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf = jte-2
1529
1530    DO j = j_start, jtf
1531
1532      DO k = 2, kte-1
1533      DO i = i_start, itf
1534         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*          &
1535                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)*   &
1536                   (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))   &
1537                   +(c1f(k)*muvf(i,j  )+c2f(k))*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  )*   &
1538                   (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1)) )
1539      ENDDO
1540      ENDDO
1541
1542      k = kte
1543      DO i = i_start, itf
1544         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*                        &
1545                   ( (c1f(k)*muvf(i,j+1)+c2f(k))*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)*    &
1546                    (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))               &
1547                    +(c1f(k)*muvf(i,j  )+c2f(k))*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  )*    &
1548                    (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
1549      ENDDO
1550
1551    ENDDO
1552
1553 !  x (u) advection
1554
1555    i_start = its
1556    j_start = jts
1557    itf=MIN(ite,ide-1)
1558    jtf=MIN(jte,jde-1)
1559
1560    IF ( (config_flags%open_xs .or. specified) .and. its == ids ) i_start = its+1
1561    IF ( (config_flags%open_xe .or. specified) .and. ite == ide ) itf = ite-2
1562
1563    DO j = j_start, jtf
1564
1565      DO k = 2, kte-1
1566      DO i = i_start, itf
1567         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*         &
1568                  ( (c1f(k)*muuf(i+1,j)+c2f(k))*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)*  &
1569                   (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))  &
1570                   +(c1f(k)*muuf(i  ,j)+c2f(k))*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j)*  &
1571                   (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
1572      ENDDO
1573      ENDDO
1574
1575      k = kte
1576      DO i = i_start, itf
1577         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                        &
1578                   ( (c1f(k)*muuf(i+1,j)+c2f(k))*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)*    &
1579                    (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))               &
1580                    +(c1f(k)*muuf(i  ,j)+c2f(k))*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(  i,j)*    &
1581                    (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
1582      ENDDO
1583
1584    ENDDO
1585
1586    ELSE IF (advective_order <= 4) THEN
1587
1588 !  y (v) advection
1589
1590    i_start = its
1591    j_start = jts
1592    itf=MIN(ite,ide-1)
1593    jtf=MIN(jte,jde-1)
1594
1595    IF ( (config_flags%open_ys .or. specified) .and. jts == jds ) j_start = jts+2
1596    IF ( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf = jte-3
1597
1598    DO j = j_start, jtf
1599
1600      DO k = 2, kte-1
1601      DO i = i_start, itf
1602         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*(                     &
1603                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)                &
1604                   +(c1f(k)*muvf(i,j  )+c2f(k))*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  ))* (1./12.)*(   &
1605                     8.*(ph(i,k,j+1)-ph(i,k,j-1))                                    &
1606                       -(ph(i,k,j+2)-ph(i,k,j-2))                                    &
1607                    +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                  &
1608                       -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
1609
1610
1611      ENDDO
1612      ENDDO
1613
1614      k = kte
1615      DO i = i_start, itf
1616         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*(                                 &
1617                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)                &
1618                   +(c1f(k)*muvf(i,j  )+c2f(k))*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  ))* (1./12.)*(   &
1619                     8.*(ph(i,k,j+1)-ph(i,k,j-1))                                               &
1620                       -(ph(i,k,j+2)-ph(i,k,j-2))                                               &
1621                    +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                             &
1622                       -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
1623
1624      ENDDO
1625
1626    ENDDO
1627
1628 !  pick up near boundary rows using 2nd order stencil for open and specified conditions
1629
1630    IF ( (config_flags%open_ys .or. specified) .and. jts <= jds+1 )  THEN
1631
1632      j = jds+1
1633      DO k = 2, kte-1
1634      DO i = i_start, itf
1635         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*          &
1636                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)*   &
1637                   (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))   &
1638                   +(c1f(k)*muvf(i,j  )+c2f(k))*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  )*   &
1639                   (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1)) )
1640      ENDDO
1641      ENDDO
1642
1643      k = kte
1644      DO i = i_start, itf
1645         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*                        &
1646                   ( (c1f(k)*muvf(i,j+1)+c2f(k))*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)*    &
1647                    (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))               &
1648                    +(c1f(k)*muvf(i,j  )+c2f(k))*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  )*    &
1649                    (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
1650      ENDDO
1651
1652    END IF
1653
1654    IF ( (config_flags%open_ye .or. specified) .and. jte >= jde-2 )  THEN
1655
1656      j = jde-2
1657      DO k = 2, kte-1
1658      DO i = i_start, itf
1659         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*          &
1660                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)*   &
1661                   (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))   &
1662                   +(c1f(k)*muvf(i,j  )+c2f(k))*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  )*   &
1663                   (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1)) )
1664      ENDDO
1665      ENDDO
1666
1667      k = kte
1668      DO i = i_start, itf
1669         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*                        &
1670                   ( (c1f(k)*muvf(i,j+1)+c2f(k))*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)*    &
1671                    (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))               &
1672                    +(c1f(k)*muvf(i,j  )+c2f(k))*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  )*    &
1673                    (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
1674      ENDDO
1675
1676    END IF
1677
1678 !  x (u) advection
1679
1680    i_start = its
1681    j_start = jts
1682    itf=MIN(ite,ide-1)
1683    jtf=MIN(jte,jde-1)
1684
1685    IF ( (config_flags%open_xs) .and. its == ids ) i_start = its+2
1686    IF ( (config_flags%open_xe) .and. ite == ide ) itf = ite-3
1687
1688    DO j = j_start, jtf
1689
1690      DO k = 2, kte-1
1691      DO i = i_start, itf
1692         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*(                    &
1693                  ( (c1f(k)*muuf(i+1,j)+c2f(k))*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)               &
1694                   +(c1f(k)*muuf(i,j  )+c2f(k))*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j) )* (1./12.)*( &
1695                     8.*(ph(i+1,k,j)-ph(i-1,k,j))                                   &
1696                       -(ph(i+2,k,j)-ph(i-2,k,j))                                   &
1697                    +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                 &
1698                       -(phb(i+2,k,j)-phb(i-2,k,j))  )   )
1699      ENDDO
1700      ENDDO
1701
1702      k = kte
1703      DO i = i_start, itf
1704         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*(                                 &
1705                  ( (c1f(k)*muuf(i+1,j)+c2f(k))*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)                &
1706                   +(c1f(k)*muuf(i,j  )+c2f(k))*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(i  ,j) )* (1./12.)*(  &
1707                     8.*(ph(i+1,k,j)-ph(i-1,k,j))                                               &
1708                       -(ph(i+2,k,j)-ph(i-2,k,j))                                               &
1709                    +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                             &
1710                       -(phb(i+2,k,j)-phb(i-2,k,j))  )     )
1711      ENDDO
1712
1713    ENDDO
1714
1715 !  pick up near boundary rows using 2nd order stencil for open and specified conditions
1716
1717    IF ( (config_flags%open_xs .or. specified) .and. its <= ids+1 ) THEN
1718
1719      i = ids + 1
1720
1721      DO j = j_start, jtf
1722      DO k = 2, kte-1
1723         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*         &
1724                  ( (c1f(k)*muuf(i+1,j)+c2f(k))*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)*  &
1725                   (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))  &
1726                   +(c1f(k)*muuf(i  ,j)+c2f(k))*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j)*  &
1727                   (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
1728      ENDDO
1729      ENDDO
1730
1731      k = kte
1732      DO j = j_start, jtf
1733         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                        &
1734                   ( (c1f(k)*muuf(i+1,j)+c2f(k))*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)*    &
1735                    (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))               &
1736                    +(c1f(k)*muuf(i  ,j)+c2f(k))*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(  i,j)*    &
1737                    (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
1738      ENDDO
1739
1740    END IF
1741
1742    IF ( (config_flags%open_xe .or. specified) .and. ite >= ide-2 ) THEN
1743
1744      i = ide-2
1745      DO j = j_start, jtf
1746      DO k = 2, kte-1
1747         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*         &
1748                  ( (c1f(k)*muuf(i+1,j)+c2f(k))*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)*  &
1749                   (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))  &
1750                   +(c1f(k)*muuf(i  ,j)+c2f(k))*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j)*  &
1751                   (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
1752      ENDDO
1753      ENDDO
1754
1755      k = kte
1756      DO j = j_start, jtf
1757         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                        &
1758                   ( (c1f(k)*muuf(i+1,j)+c2f(k))*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)*    &
1759                    (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))               &
1760                    +(c1f(k)*muuf(i  ,j)+c2f(k))*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(  i,j)*    &
1761                    (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
1762      ENDDO
1763
1764    END IF
1765
1766 !--------------------------
1767
1768    ELSE IF (advective_order <= 6) THEN
1769
1770 !!! NOTE: this branch has been looked at and fixed with changes for overdecomposition
1771 !!!       the branches covering the other advective_order cases have not.  20090923. JM
1772
1773 !  y (v) advection
1774
1775    i_start = its
1776    j_start = jts
1777    itf=MIN(ite,ide-1)
1778    jtf=MIN(jte,jde-1)
1779
1780    IF (config_flags%open_ys .or. specified ) j_start = max(jts,jds+3)
1781    IF (config_flags%open_ye .or. specified ) jtf     = min(jtf,jde-4)
1782
1783    DO j = j_start, jtf
1784
1785      DO k = 2, kte-1
1786      DO i = i_start, itf
1787         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* (                    &
1788                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)                &
1789                   +(c1f(k)*muvf(i,j  )+c2f(k))*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  ) )* (1./60.)*(  &
1790                    45.*(ph(i,k,j+1)-ph(i,k,j-1))                                    &
1791                    -9.*(ph(i,k,j+2)-ph(i,k,j-2))                                    &
1792                       +(ph(i,k,j+3)-ph(i,k,j-3))                                    &
1793                   +45.*(phb(i,k,j+1)-phb(i,k,j-1))                                  &
1794                    -9.*(phb(i,k,j+2)-phb(i,k,j-2))                                  &
1795                       +(phb(i,k,j+3)-phb(i,k,j-3))  )   )
1796
1797
1798      ENDDO
1799      ENDDO
1800
1801      k = kte
1802      DO i = i_start, itf
1803         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* (                                &
1804                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)                &
1805                   +(c1f(k)*muvf(i,j  )+c2f(k))*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  ) )* (1./60.)*(  &
1806                    45.*(ph(i,k,j+1)-ph(i,k,j-1))                                               &
1807                    -9.*(ph(i,k,j+2)-ph(i,k,j-2))                                               &
1808                       +(ph(i,k,j+3)-ph(i,k,j-3))                                               &
1809                   +45.*(phb(i,k,j+1)-phb(i,k,j-1))                                             &
1810                    -9.*(phb(i,k,j+2)-phb(i,k,j-2))                                             &
1811                       +(phb(i,k,j+3)-phb(i,k,j-3))  )   )
1812
1813      ENDDO
1814
1815    ENDDO
1816
1817 !  4th order stencil for open or specified conditions two in form the boundary
1818
1819    IF ( (config_flags%open_ys .or. specified) .and. jts <= jds+2 .and. jds+2 <= jte )  THEN
1820
1821      j = jds+2
1822      DO k = 2, kte-1
1823      DO i = i_start, itf
1824         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* (                     &
1825                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)                &
1826                   +(c1f(k)*muvf(i,j  )+c2f(k))*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  ) )* (1./12.)*(  &
1827                     8.*(ph(i,k,j+1)-ph(i,k,j-1))                                    &
1828                       -(ph(i,k,j+2)-ph(i,k,j-2))                                    &
1829                    +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                  &
1830                       -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
1831
1832
1833      ENDDO
1834      ENDDO
1835
1836      k = kte
1837      DO i = i_start, itf
1838         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* (                              &
1839                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)              &
1840                   +(c1f(k)*muvf(i,j  )+c2f(k))*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j) )* (1./12.)*(  &
1841                     8.*(ph(i,k,j+1)-ph(i,k,j-1))                                             &
1842                       -(ph(i,k,j+2)-ph(i,k,j-2))                                             &
1843                    +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                           &
1844                       -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
1845
1846      ENDDO
1847
1848    END IF
1849
1850    IF ( (config_flags%open_ye .or. specified) .and. jts <= jde-3 .and. jde-3 <= jte )  THEN
1851      j = jde-3
1852      DO k = 2, kte-1
1853      DO i = i_start, itf
1854         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* (                  &
1855                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)              &
1856                   +(c1f(k)*muvf(i,j  )+c2f(k))*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j) )* (1./12.)*(  &
1857                     8.*(ph(i,k,j+1)-ph(i,k,j-1))                                  &
1858                       -(ph(i,k,j+2)-ph(i,k,j-2))                                  &
1859                    +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                &
1860                       -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
1861
1862
1863      ENDDO
1864      ENDDO
1865
1866      k = kte
1867      DO i = i_start, itf
1868         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* (                              &
1869                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)              &
1870                   +(c1f(k)*muvf(i,j  )+c2f(k))*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j) )* (1./12.)*(  &
1871                     8.*(ph(i,k,j+1)-ph(i,k,j-1))                                             &
1872                       -(ph(i,k,j+2)-ph(i,k,j-2))                                             &
1873                    +8.*(phb(i,k,j+1)-phb(i,k,j-1))                                           &
1874                       -(phb(i,k,j+2)-phb(i,k,j-2))  )   )
1875
1876      ENDDO
1877
1878    END IF
1879
1880 !  2nd order stencil for open and specified conditions one row in from boundary
1881
1882    IF ( (config_flags%open_ys .or. specified) .and. jts <= jds+1 .and. jds+1 <= jte )  THEN
1883
1884      j = jds+1
1885      DO k = 2, kte-1
1886      DO i = i_start, itf
1887         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*          &
1888                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)*   &
1889                   (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))   &
1890                   +(c1f(k)*muvf(i,j  )+c2f(k))*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  )*   &
1891                   (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1)) )
1892      ENDDO
1893      ENDDO
1894
1895      k = kte
1896      DO i = i_start, itf
1897         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*                        &
1898                   ( (c1f(k)*muvf(i,j+1)+c2f(k))*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)*    &
1899                    (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))               &
1900                    +(c1f(k)*muvf(i,j  )+c2f(k))*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  )*    &
1901                    (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
1902      ENDDO
1903
1904    END IF
1905
1906    IF ( (config_flags%open_ye .or. specified) .and. jts <= jde-2 .and. jde-2 <= jte )  THEN
1907
1908      j = jde-2
1909      DO k = 2, kte-1
1910      DO i = i_start, itf
1911         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*          &
1912                  ( (c1f(k)*muvf(i,j+1)+c2f(k))*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)*   &
1913                   (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))   &
1914                   +(c1f(k)*muvf(i,j  )+c2f(k))*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,j  )*   &
1915                   (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1)) )
1916      ENDDO
1917      ENDDO
1918
1919      k = kte
1920      DO i = i_start, itf
1921         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*                        &
1922                   ( (c1f(k)*muvf(i,j+1)+c2f(k))*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)*    &
1923                    (phb(i,k,j+1)-phb(i,k,j  )+ph(i,k,j+1)-ph(i,k,j  ))               &
1924                    +(c1f(k)*muvf(i,j  )+c2f(k))*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,j  )*    &
1925                    (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
1926      ENDDO
1927
1928    END IF
1929
1930 !  x (u) advection
1931
1932    i_start = its
1933    j_start = jts
1934    itf=MIN(ite,ide-1)
1935    jtf=MIN(jte,jde-1)
1936
1937    IF (config_flags%open_xs .or. specified ) i_start = max(its,ids+3)
1938    IF (config_flags%open_xe .or. specified ) itf     = min(itf,ide-4)
1939
1940    DO j = j_start, jtf
1941
1942      DO k = 2, kte-1
1943      DO i = i_start, itf
1944         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*(                   &
1945                  ( (c1f(k)*muuf(i+1,j)+c2f(k))*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)              &
1946                   +(c1f(k)*muuf(i,j  )+c2f(k))*(u(i,k,j  )+u(i,k-1,j  ))*msfux(i,j) )* (1./60.)*(  &
1947                    45.*(ph(i+1,k,j)-ph(i-1,k,j))                                  &
1948                    -9.*(ph(i+2,k,j)-ph(i-2,k,j))                                  &
1949                       +(ph(i+3,k,j)-ph(i-3,k,j))                                  &
1950                   +45.*(phb(i+1,k,j)-phb(i-1,k,j))                                &
1951                    -9.*(phb(i+2,k,j)-phb(i-2,k,j))                                &
1952                       +(phb(i+3,k,j)-phb(i-3,k,j))  )   )
1953      ENDDO
1954      ENDDO
1955
1956      k = kte
1957      DO i = i_start, itf
1958         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*(                             &
1959                  ( (c1f(k)*muuf(i+1,j)+c2f(k))*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)            &
1960                   +(c1f(k)*muuf(i,j  )+c2f(k))*(cfn*u(i  ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) )* (1./60.)*(  &
1961                    45.*(ph(i+1,k,j)-ph(i-1,k,j))                                           &
1962                    -9.*(ph(i+2,k,j)-ph(i-2,k,j))                                           &
1963                       +(ph(i+3,k,j)-ph(i-3,k,j))                                           &
1964                   +45.*(phb(i+1,k,j)-phb(i-1,k,j))                                         &
1965                    -9.*(phb(i+2,k,j)-phb(i-2,k,j))                                         &
1966                       +(phb(i+3,k,j)-phb(i-3,k,j))  )     )
1967      ENDDO
1968
1969    ENDDO
1970
1971 !  4th order stencil two in from the boundary for open and specified conditions
1972
1973    IF ( (config_flags%open_xs) .and. its <= ids+2 .and. ids+2 <= ite ) THEN
1974      i = ids + 2
1975      DO j = j_start, jtf
1976        DO k = 2, kte-1
1977         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*(                   &
1978                  ( (c1f(k)*muuf(i+1,j)+c2f(k))*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)              &
1979                   +(c1f(k)*muuf(i,j  )+c2f(k))*(u(i,k,j  )+u(i,k-1,j  ))*msfux(i,j) )* (1./12.)*(  &
1980                     8.*(ph(i+1,k,j)-ph(i-1,k,j))                                  &
1981                       -(ph(i+2,k,j)-ph(i-2,k,j))                                  &
1982                    +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                &
1983                       -(phb(i+2,k,j)-phb(i-2,k,j))  )   )
1984        ENDDO
1985        k = kte
1986        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*(                             &
1987                 ( (c1f(k)*muuf(i+1,j)+c2f(k))*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)            &
1988                  +(c1f(k)*muuf(i,j  )+c2f(k))*(cfn*u(i  ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) )* (1./12.)*(  &
1989                    8.*(ph(i+1,k,j)-ph(i-1,k,j))                                           &
1990                      -(ph(i+2,k,j)-ph(i-2,k,j))                                           &
1991                   +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                         &
1992                      -(phb(i+2,k,j)-phb(i-2,k,j))  )     )
1993
1994      ENDDO
1995    END IF
1996
1997    IF ( (config_flags%open_xe) .and. its <= ide-3 .and. ide-3 <= ite ) THEN
1998      i = ide-3
1999      DO j = j_start, jtf
2000        DO k = 2, kte-1
2001         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*(                   &
2002                  ( (c1f(k)*muuf(i+1,j)+c2f(k))*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)              &
2003                   +(c1f(k)*muuf(i,j  )+c2f(k))*(u(i,k,j  )+u(i,k-1,j  ))*msfux(i,j) )* (1./12.)*(  &
2004                     8.*(ph(i+1,k,j)-ph(i-1,k,j))                                  &
2005                       -(ph(i+2,k,j)-ph(i-2,k,j))                                  &
2006                    +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                &
2007                       -(phb(i+2,k,j)-phb(i-2,k,j))  )   )
2008        ENDDO
2009        k = kte
2010        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*(                             &
2011                 ( (c1f(k)*muuf(i+1,j)+c2f(k))*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)            &
2012                  +(c1f(k)*muuf(i,j  )+c2f(k))*(cfn*u(i  ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) )* (1./12.)*(  &
2013                    8.*(ph(i+1,k,j)-ph(i-1,k,j))                                           &
2014                      -(ph(i+2,k,j)-ph(i-2,k,j))                                           &
2015                   +8.*(phb(i+1,k,j)-phb(i-1,k,j))                                         &
2016                      -(phb(i+2,k,j)-phb(i-2,k,j))  )     )
2017
2018      ENDDO
2019    END IF
2020
2021 !  2nd order stencil for open and specified conditions one in from the boundary
2022
2023    IF ( (config_flags%open_xs .or. specified) .and. its <= ids+1 .and. ids+1 <= ite ) THEN
2024
2025      i = ids + 1
2026
2027      DO j = j_start, jtf
2028      DO k = 2, kte-1
2029         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*         &
2030                  ( (c1f(k)*muuf(i+1,j)+c2f(k))*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)*  &
2031                   (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))  &
2032                   +(c1f(k)*muuf(i  ,j)+c2f(k))*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j)*  &
2033                   (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
2034      ENDDO
2035      ENDDO
2036
2037      k = kte
2038      DO j = j_start, jtf
2039         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                        &
2040                   ( (c1f(k)*muuf(i+1,j)+c2f(k))*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)*    &
2041                    (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))               &
2042                    +(c1f(k)*muuf(i  ,j)+c2f(k))*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(  i,j)*    &
2043                    (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
2044      ENDDO
2045
2046    END IF
2047
2048    IF ( (config_flags%open_xe .or. specified) .and. its <= ide-2 .and. ide-2 <= ite ) THEN
2049
2050      i = ide-2
2051      DO j = j_start, jtf
2052      DO k = 2, kte-1
2053         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*         &
2054                  ( (c1f(k)*muuf(i+1,j)+c2f(k))*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)*  &
2055                   (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))  &
2056                   +(c1f(k)*muuf(i  ,j)+c2f(k))*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,j)*  &
2057                   (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
2058      ENDDO
2059      ENDDO
2060
2061      k = kte
2062      DO j = j_start, jtf
2063         ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                        &
2064                   ( (c1f(k)*muuf(i+1,j)+c2f(k))*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)*    &
2065                    (phb(i+1,k,j)-phb(i  ,k,j)+ph(i+1,k,j)-ph(i  ,k,j))               &
2066                    +(c1f(k)*muuf(i  ,j)+c2f(k))*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(  i,j)*    &
2067                    (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
2068      ENDDO
2069
2070    END IF
2071
2072    END IF  ! 6th order advection
2073
2074 !  lateral open boundary conditions,
2075 !  start with north and south (y) boundaries
2076
2077    i_start = its
2078    itf=MIN(ite,ide-1)
2079
2080    !  south
2081
2082    IF ( (config_flags%open_ys) .and. jts == jds ) THEN
2083
2084      j=jts
2085
2086      DO k=2,kde
2087        kz = min(k,kde-1)
2088        DO i = its,itf
2089          vb =.5*( fnm(kz)*(v(i,kz  ,j+1)+v(i,kz  ,j  ))    &
2090                  +fnp(kz)*(v(i,kz-1,j+1)+v(i,kz-1,j  )) )
2091          vl=amin1(vb,0.)
2092          ph_tend(i,k,j)=ph_tend(i,k,j)-rdy*(c1f(k)*mut(i,j)+c2f(k))*(      &
2093                               +vl*(ph_old(i,k,j+1)-ph_old(i,k,j)))
2094        ENDDO
2095      ENDDO
2096
2097    END IF
2098
2099    ! north
2100
2101    IF ( (config_flags%open_ye) .and. jte == jde ) THEN
2102
2103      j=jte-1
2104
2105      DO k=2,kde
2106        kz = min(k,kde-1)
2107        DO i = its,itf
2108         vb=.5*( fnm(kz)*(v(i,kz  ,j+1)+v(i,kz  ,j))   &
2109                +fnp(kz)*(v(i,kz-1,j+1)+v(i,kz-1,j)) )
2110         vr=amax1(vb,0.)
2111         ph_tend(i,k,j)=ph_tend(i,k,j)-rdy*(c1f(k)*mut(i,j)+c2f(k))*(      &
2112                    +vr*(ph_old(i,k,j)-ph_old(i,k,j-1)))
2113        ENDDO
2114      ENDDO
2115
2116    END IF
2117
2118    !  now the east and west (y) boundaries
2119
2120    j_start = its
2121    jtf=MIN(jte,jde-1)
2122
2123    !  west
2124
2125    IF ( (config_flags%open_xs) .and. its == ids ) THEN
2126
2127      i=its
2128
2129      DO j = jts,jtf
2130        DO k=2,kde-1
2131          kz = k
2132          ub =.5*( fnm(kz)*(u(i+1,kz  ,j)+u(i  ,kz  ,j))     &
2133                  +fnp(kz)*(u(i+1,kz-1,j)+u(i  ,kz-1,j)) )
2134          ul=amin1(ub,0.)
2135          ph_tend(i,k,j)=ph_tend(i,k,j)-(msftx(i,j)/msfty(i,j))*rdx*(c1f(k)*mut(i,j)+c2f(k))*(       &
2136                               +ul*(ph_old(i+1,k,j)-ph_old(i,k,j)))
2137        ENDDO
2138
2139          k = kde
2140          kz = k
2141          ub =.5*( fnm(kz)*(u(i+1,kz  ,j)+u(i  ,kz  ,j))     &
2142                  +fnp(kz)*(u(i+1,kz-1,j)+u(i  ,kz-1,j)) )
2143          ul=amin1(ub,0.)
2144          ph_tend(i,k,j)=ph_tend(i,k,j)-(msftx(i,j)/msfty(i,j))*rdx*(c1f(k)*mut(i,j)+c2f(k))*(       &
2145                               +ul*(ph_old(i+1,k,j)-ph_old(i,k,j)))
2146      ENDDO
2147
2148    END IF
2149
2150    ! east
2151
2152    IF ( (config_flags%open_xe) .and. ite == ide ) THEN
2153
2154      i = ite-1
2155
2156      DO j = jts,jtf
2157        DO k=2,kde-1
2158         kz = k
2159         ub=.5*( fnm(kz)*(u(i+1,kz  ,j)+u(i,kz  ,j))  &
2160                +fnp(kz)*(u(i+1,kz-1,j)+u(i,kz-1,j)) )
2161         ur=amax1(ub,0.)
2162         ph_tend(i,k,j)=ph_tend(i,k,j)-(msftx(i,j)/msfty(i,j))*rdx*(c1f(k)*mut(i,j)+c2f(k))*( &
2163                    +ur*(ph_old(i,k,j)-ph_old(i-1,k,j)))
2164        ENDDO
2165
2166         k = kde
2167         kz = k-1
2168         ub=.5*( fnm(kz)*(u(i+1,kz  ,j)+u(i,kz  ,j))   &
2169                +fnp(kz)*(u(i+1,kz-1,j)+u(i,kz-1,j)) )
2170         ur=amax1(ub,0.)
2171         ph_tend(i,k,j)=ph_tend(i,k,j)-(msftx(i,j)/msfty(i,j))*rdx*(c1f(k)*mut(i,j)+c2f(k))*(  &
2172                    +ur*(ph_old(i,k,j)-ph_old(i-1,k,j)))
2173
2174      ENDDO
2175
2176    END IF
2177
2178   END SUBROUTINE rhs_ph
2179
2180
2181 !-------------------------------------------------------------------------------
2182
2183 SUBROUTINE horizontal_pressure_gradient( ru_tend,rv_tend,                &
2184                                          ph,alt,p,pb,al,php,cqu,cqv,     &
2185                                          muu,muv,mu,c1h,c2h,fnm,fnp,rdnw,&
2186                                          cf1,cf2,cf3,cfn,cfn1,           &
2187                                          rdx,rdy,msfux,msfuy,&
2188                                          msfvx,msfvy,msftx,msfty,        &
2189                                          config_flags, non_hydrostatic,  &
2190                                          top_lid,                        &
2191                                          ids, ide, jds, jde, kds, kde,   &
2192                                          ims, ime, jms, jme, kms, kme,   &
2193                                          its, ite, jts, jte, kts, kte   )
2194
2195    IMPLICIT NONE
2196
2197    ! Input data
2198
2199
2200    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
2201
2202    LOGICAL, INTENT (IN   ) :: non_hydrostatic, top_lid
2203
2204    INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
2205                                        ims, ime, jms, jme, kms, kme, &
2206                                        its, ite, jts, jte, kts, kte
2207
2208    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN   ) ::        &
2209                                                                      ph,  &
2210                                                                      alt, &
2211                                                                      al,  &
2212                                                                      p,   &
2213                                                                      pb,  &
2214                                                                      php, &
2215                                                                      cqu, &
2216                                                                      cqv
2217
2218
2219    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) ::           &
2220                                                                     ru_tend, &
2221                                                                     rv_tend
2222
2223    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   ) :: muu, muv, mu,    &
2224                                                             msfux, msfuy, &
2225                                                             msfvx, msfvy, &
2226                                                             msftx, msfty
2227
2228    REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: rdnw, fnm, fnp
2229
2230    REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: c1h, c2h
2231
2232    REAL,  INTENT(IN   ) :: rdx, rdy, cf1, cf2, cf3, cfn, cfn1
2233
2234    INTEGER :: i,j,k, itf, jtf, ktf, i_start, j_start
2235    REAL, DIMENSION( ims:ime, kms:kme ) :: dpn
2236    REAL :: dpx, dpy
2237    REAL, DIMENSION( kms:kme ) :: c1
2238
2239    LOGICAL :: specified
2240
2241 !<DESCRIPTION>
2242 !
2243 !  horizontal_pressure_gradient calculates the
2244 !  horizontal pressure gradient terms for the large-timestep tendency
2245 !  in the horizontal momentum equations (u,v).
2246 !
2247 !</DESCRIPTION>
2248
2249    c1 = c1h
2250    specified = .false.
2251    if(config_flags%specified .or. config_flags%nested) specified = .true.
2252
2253 !  Notes on map scale factors:
2254 !  Calculates the pressure gradient terms in ADT eqns 44 and 45
2255 !  With upper rho -> 'mu', these are:
2256 !  Eqn 30: -mu*(mx/my)*(1/rho)*partial dp/dx
2257 !  Eqn 31: -mu*(my/mx)*(1/rho)*partial dp/dy
2258 !
2259 !  As we are on nu, rather than height, surfaces:
2260 !
2261 !  mu dp/dx = mu alpha partial dp'/dx + (nu mu partial dmubar/dx) alpha'
2262 !           + mu partial dphi'/dx + (partial dphi/dx)*(partial dp'/dnu - mu')
2263 !
2264 !  mu dp/dy = mu alpha partial dp'/dy + (nu mu partial dmubar/dy) alpha'
2265 !           + mu partial dphi'/dy + (partial dphi/dy)*(partial dp'/dnu - mu')
2266
2267 ! start with the north-south (y) pressure gradient
2268
2269    itf=MIN(ite,ide-1)
2270    jtf=jte
2271    ktf=MIN(kte,kde-1)
2272    i_start = its
2273    j_start = jts
2274    IF ( (config_flags%open_ys .or. specified .or. &
2275          config_flags%nested .or. config_flags%polar ) .and. jts == jds ) j_start = jts+1
2276    IF ( (config_flags%open_ye .or. specified .or. &
2277          config_flags%nested .or. config_flags%polar ) .and. jte == jde ) jtf = jtf-1
2278
2279    DO j = j_start, jtf
2280
2281      IF ( non_hydrostatic )  THEN
2282
2283         k=1
2284
2285         DO i = i_start, itf
2286           dpn(i,k) = .5*( cf1*(p(i,k  ,j-1)+p(i,k  ,j))   &
2287                          +cf2*(p(i,k+1,j-1)+p(i,k+1,j))   &
2288                          +cf3*(p(i,k+2,j-1)+p(i,k+2,j))  )
2289           dpn(i,kde) = 0.
2290         ENDDO
2291         IF (top_lid) THEN
2292           DO i = i_start, itf
2293             dpn(i,kde) = .5*( cfn *(p(i,kde-1,j-1)+p(i,kde-1,j))   &
2294                              +cfn1*(p(i,kde-2,j-1)+p(i,kde-2,j)) )
2295           ENDDO
2296         ENDIF
2297
2298         DO k=2,ktf
2299           DO i = i_start, itf
2300             dpn(i,k) = .5*( fnm(k)*(p(i,k  ,j-1)+p(i,k  ,j))  &
2301                            +fnp(k)*(p(i,k-1,j-1)+p(i,k-1,j)) )
2302           END DO
2303         END DO
2304
2305 !       ADT eqn 45: -mu*(my/mx)*(1/rho)*partial dp/dy
2306 !       [alt, al are 1/rho terms; muv, mu are NOT coupled]
2307         DO K=1,ktf
2308           DO i = i_start, itf
2309             ! Here are mu dp/dy terms 1-3
2310             dpy = (msfvy(i,j)/msfvx(i,j))*.5*rdy*(c1h(k)*muv(i,j)+c2h(k))*(                 &
2311                      (ph (i,k+1,j)-ph (i,k+1,j-1) + ph(i,k,j)-ph(i,k,j-1))  &
2312                     +(alt(i,k  ,j)+alt(i,k  ,j-1))*(p (i,k,j)-p (i,k,j-1))  &
2313                     +(al (i,k  ,j)+al (i,k  ,j-1))*(pb(i,k,j)-pb(i,k,j-1)) )
2314             ! Here is mu dp/dy term 4
2315             dpy = dpy + (msfvy(i,j)/msfvx(i,j))*rdy*(php(i,k,j)-php(i,k,j-1))* &
2316                 (rdnw(k)*(dpn(i,k+1)-dpn(i,k))-.5*((c1(k)*mu(i,j-1))+(c1(k)*mu(i,j))))
2317             rv_tend(i,k,j) = rv_tend(i,k,j)-cqv(i,k,j)*dpy
2318           END DO
2319         END DO
2320
2321      ELSE
2322
2323 !       ADT eqn 45: -mu*(my/mx)*(1/rho)*partial dp/dy
2324 !       [alt, al are 1/rho terms; muv, mu are NOT coupled]
2325         DO K=1,ktf
2326           DO i = i_start, itf
2327             ! Here are mu dp/dy terms 1-3; term 4 not needed if hydrostatic
2328             dpy = (msfvy(i,j)/msfvx(i,j))*.5*rdy*(c1h(k)*muv(i,j)+c2h(k))*(                 &
2329                      (ph (i,k+1,j)-ph (i,k+1,j-1) + ph(i,k,j)-ph(i,k,j-1))  &
2330                     +(alt(i,k  ,j)+alt(i,k  ,j-1))*(p (i,k,j)-p (i,k,j-1))  &
2331                     +(al (i,k  ,j)+al (i,k  ,j-1))*(pb(i,k,j)-pb(i,k,j-1)) )
2332             rv_tend(i,k,j) = rv_tend(i,k,j)-dpy
2333           END DO
2334         END DO
2335
2336      END IF
2337
2338    ENDDO
2339
2340 !  now the east-west (x) pressure gradient
2341
2342    itf=ite
2343    jtf=MIN(jte,jde-1)
2344    ktf=MIN(kte,kde-1)
2345    i_start = its
2346    j_start = jts
2347    IF ( (config_flags%open_xs .or. specified .or. &
2348            config_flags%nested ) .and. its == ids ) i_start = its+1
2349    IF ( (config_flags%open_xe .or. specified .or. &
2350            config_flags%nested ) .and. ite == ide ) itf = itf-1
2351    IF ( config_flags%periodic_x ) i_start = its
2352    IF ( config_flags%periodic_x ) itf=ite
2353
2354    DO j = j_start, jtf
2355
2356      IF ( non_hydrostatic )  THEN
2357
2358         k=1
2359
2360         DO i = i_start, itf
2361           dpn(i,k) = .5*( cf1*(p(i-1,k  ,j)+p(i,k  ,j))   &
2362                          +cf2*(p(i-1,k+1,j)+p(i,k+1,j))   &
2363                          +cf3*(p(i-1,k+2,j)+p(i,k+2,j))  )
2364           dpn(i,kde) = 0.
2365         ENDDO
2366         IF (top_lid) THEN
2367           DO i = i_start, itf
2368             dpn(i,kde) = .5*( cfn *(p(i-1,kde-1,j)+p(i,kde-1,j))   &
2369                              +cfn1*(p(i-1,kde-2,j)+p(i,kde-2,j)) )
2370           ENDDO
2371         ENDIF
2372
2373         DO k=2,ktf
2374           DO i = i_start, itf
2375             dpn(i,k) = .5*( fnm(k)*(p(i-1,k  ,j)+p(i,k  ,j))  &
2376                            +fnp(k)*(p(i-1,k-1,j)+p(i,k-1,j)) )
2377           END DO
2378         END DO
2379
2380 ! ADT eqn 44: -mu*(mx/my)*(1/rho)*partial dp/dx
2381 ! [alt, al are 1/rho terms; muu, mu are NOT coupled]
2382         DO K=1,ktf
2383           DO i = i_start, itf
2384             ! Here are mu dp/dy terms 1-3
2385             dpx = (msfux(i,j)/msfuy(i,j))*.5*rdx*(c1h(k)*muu(i,j)+c2h(k))*(                    &
2386                         (ph (i,k+1,j)-ph (i-1,k+1,j) + ph(i,k,j)-ph(i-1,k,j))  &
2387                        +(alt(i,k  ,j)+alt(i-1,k  ,j))*(p (i,k,j)-p (i-1,k,j))  &
2388                        +(al (i,k  ,j)+al (i-1,k  ,j))*(pb(i,k,j)-pb(i-1,k,j)) )
2389             ! Here is mu dp/dy term 4
2390             dpx = dpx + (msfux(i,j)/msfuy(i,j))*rdx*(php(i,k,j)-php(i-1,k,j))* &
2391                 (rdnw(k)*(dpn(i,k+1)-dpn(i,k))-.5*((c1(k)*mu(i-1,j))+(c1(k)*mu(i,j))))
2392             ru_tend(i,k,j) = ru_tend(i,k,j)-cqu(i,k,j)*dpx
2393           END DO
2394         END DO
2395
2396      ELSE
2397
2398 !       ADT eqn 44: -mu*(mx/my)*(1/rho)*partial dp/dx
2399 !       [alt, al are 1/rho terms; muu, mu are NOT coupled]
2400         DO K=1,ktf
2401           DO i = i_start, itf
2402             ! Here are mu dp/dy terms 1-3; term 4 not needed if hydrostatic
2403             dpx = (msfux(i,j)/msfuy(i,j))*.5*rdx*(c1h(k)*muu(i,j)+c2h(k))*(                    &
2404                         (ph (i,k+1,j)-ph (i-1,k+1,j) + ph(i,k,j)-ph(i-1,k,j))  &
2405                        +(alt(i,k  ,j)+alt(i-1,k  ,j))*(p (i,k,j)-p (i-1,k,j))  &
2406                        +(al (i,k  ,j)+al (i-1,k  ,j))*(pb(i,k,j)-pb(i-1,k,j)) )
2407             ru_tend(i,k,j) = ru_tend(i,k,j)-dpx
2408           END DO
2409         END DO
2410
2411      END IF
2412
2413    ENDDO
2414
2415 END SUBROUTINE horizontal_pressure_gradient
2416
2417 !-------------------------------------------------------------------------------
2418
2419 SUBROUTINE pg_buoy_w( rw_tend, p, cqw, muf, mubf,     &
2420                       c1f, c2f,                       &
2421                       rdnw, rdn, g, msftx, msfty,     &
2422                       ids, ide, jds, jde, kds, kde,   &
2423                       ims, ime, jms, jme, kms, kme,   &
2424                       its, ite, jts, jte, kts, kte   )
2425
2426    IMPLICIT NONE
2427
2428    ! Input data
2429
2430    INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
2431                                        ims, ime, jms, jme, kms, kme, &
2432                                        its, ite, jts, jte, kts, kte
2433
2434    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN   ) ::   p
2435    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) ::   cqw
2436
2437
2438    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) ::  rw_tend
2439
2440    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   ) :: mubf, muf, msftx, msfty
2441
2442    REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: rdnw, rdn
2443
2444    REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: c1f, c2f
2445
2446    REAL,  INTENT(IN   ) :: g
2447
2448    INTEGER :: itf, jtf, i, j, k
2449    REAL    :: cq1, cq2
2450
2451
2452 !<DESCRIPTION>
2453 !
2454 !  pg_buoy_w calculates the
2455 !  vertical pressure gradient and buoyancy terms for the large-timestep
2456 !  tendency in the vertical momentum equation.
2457 !
2458 !</DESCRIPTION>
2459
2460 !  BUOYANCY AND PRESSURE GRADIENT TERM IN W EQUATION AT TIME T
2461
2462 !  Map scale factor notes
2463 !  ADT eqn 46 RHS terms 6 and 7 (where 7 is "-rho g")
2464 !  Dividing by my, and using mu and nu (see Klemp et al. eqns 32, 40)
2465 !  term 6: +(g/my) partial dp'/dnu
2466 !  term 7: -(g/my) mu'
2467 !
2468 !  For moisture-free atmosphere, cq1=1, cq2=0
2469 !  => (1./msft(i,j)) * g * [rdn(k)*{p(i,k,j)-p(i,k-1,j)}-(c1(k)*mu(i,j))]
2470
2471    itf=MIN(ite,ide-1)
2472    jtf=MIN(jte,jde-1)
2473
2474    DO j = jts,jtf
2475
2476      k=kde
2477      DO i=its,itf
2478        cq1 = 1./(1.+cqw(i,k-1,j))
2479        cq2 = cqw(i,k-1,j)*cq1
2480        rw_tend(i,k,j) = rw_tend(i,k,j)+(1./msfty(i,j))*g*(      &
2481                         cq1*2.*rdnw(k-1)*(  -p(i,k-1,j))  &
2482                         -(c1f(k)*muf(i,j))-cq2*(c1f(k)*mubf(i,j)+c2f(k))            )
2483      END DO
2484
2485      DO k = 2, kde-1
2486      DO i = its,itf
2487       cq1 = 1./(1.+cqw(i,k,j))
2488       cq2 = cqw(i,k,j)*cq1
2489       cqw(i,k,j) = cq1
2490       rw_tend(i,k,j) = rw_tend(i,k,j)+(1./msfty(i,j))*g*(      &
2491                        cq1*rdn(k)*(p(i,k,j)-p(i,k-1,j))  &
2492                        -(c1f(k)*muf(i,j))-cq2*(c1f(k)*mubf(i,j)+c2f(k))            )
2493      END DO
2494      ENDDO
2495
2496
2497    ENDDO
2498
2499 END SUBROUTINE pg_buoy_w
2500
2501 !-------------------------------------------------------------------------------
2502
2503 SUBROUTINE w_damp( rw_tend, max_vert_cfl,max_horiz_cfl, &
2504                    u, v, ww, w, mut, c1f, c2f, rdnw,    &
2505                    rdx, rdy, msfux, msfuy,              &
2506                    msfvx, msfvy, dt,                    &
2507                    config_flags,                        &
2508                    ids, ide, jds, jde, kds, kde,        &
2509                    ims, ime, jms, jme, kms, kme,        &
2510                    its, ite, jts, jte, kts, kte     )
2511
2512    USE module_llxy
2513    IMPLICIT NONE
2514
2515    ! Input data
2516
2517    TYPE(grid_config_rec_type   ) ,   INTENT(IN   ) :: config_flags
2518
2519    INTEGER ,          INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
2520                                        ims, ime, jms, jme, kms, kme, &
2521                                        its, ite, jts, jte, kts, kte
2522
2523    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(IN   ) ::   u, v, ww, w
2524
2525    REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) ::  rw_tend
2526
2527    REAL, INTENT(OUT) ::  max_vert_cfl
2528    REAL, INTENT(OUT) ::  max_horiz_cfl
2529    REAL              ::  horiz_cfl
2530
2531    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   ) :: mut
2532
2533    REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: rdnw
2534
2535    REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: c1f, c2f
2536
2537    REAL, INTENT(IN)    :: dt
2538    REAL, INTENT(IN)    :: rdx, rdy
2539    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux, msfuy
2540    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfvx, msfvy
2541
2542    REAL                :: vert_cfl, cf_n, cf_d, maxdub, maxdeta
2543
2544    INTEGER :: itf, jtf, i, j, k, maxi, maxj, maxk
2545    CHARACTER*512 :: temp
2546
2547    CHARACTER (LEN=256) :: time_str
2548    CHARACTER (LEN=256) :: grid_str
2549
2550    integer :: total
2551    REAL :: msfuxt , msfxffl
2552
2553    REAL    :: w_damp_on
2554    REAL    :: w_crit_cfl    = 2.0
2555    REAL    :: w_flag_cfl    = 1.2
2556    LOGICAL :: print_flag    = .true.
2557    SAVE    :: print_flag
2558    INTEGER :: some1       ! Now have two catagories of CFL information, hence some1 & some2
2559    INTEGER :: some2
2560    INTEGER :: ieva
2561
2562 !<DESCRIPTION>
2563 !
2564 !  W_damp computes a damping term for the vertical velocity when the
2565 !  vertical Courant number is too large.  This was found to be preferable to
2566 !  decreasing the timestep or increasing the diffusion in real-data applications
2567 !  that produced potentially-unstable large vertical velocities because of
2568 !  unphysically large heating rates coming from the cumulus parameterization
2569 !  schemes run at moderately high resolutions (dx ~ O(10) km).
2570 !
2571 !  Additionally, w_damp returns the maximum cfl values due to vertical motion and
2572 !  horizontal motion.  These values are returned via the max_vert_cfl and
2573 !  max_horiz_cfl variables.  (Added by T. Hutchinson, WSI, 3/5/2007)
2574 !
2575 !-----
2576 !
2577 !  W_damp modified to be more flexible with IEVA capability.
2578 !  When IEVA is on, the value of the W-CFL where damping is turned on can now be set
2579 !  in the namelist using "w_crit_cfl".
2580 !
2581 !  Typical settings for non-IEVA use:  w_crit_cfl = 1.0
2582 !  Typical settings for     IEVA use:  w_crit_cfl = 2.0
2583 !
2584 !  I also commented out a lot of code put in 8-13 years ago for timing assuming that
2585 !  this is no longer needed....there is some pretty hacky stuff.  HTH.
2586 !
2587 !      (Added by L. Wicker, NSSL, 5/4/2020)
2588 !
2589 !</DESCRIPTION>
2590
2591    itf=MIN(ite,ide-1)
2592    jtf=MIN(jte,jde-1)
2593
2594    some1 = 0
2595    some2 = 0
2596
2597    max_vert_cfl  = 0.
2598    max_horiz_cfl = 0.
2599    total = 0
2600
2601    w_crit_cfl = config_flags%w_crit_cfl
2602    ieva       = config_flags%zadvect_implicit
2603
2604    IF( ieva .gt. 0 ) THEN
2605      w_damp_on = w_crit_cfl
2606    ELSE
2607      w_damp_on = w_beta
2608    ENDIF
2609
2610    IF( print_flag ) THEN
2611      write(wrf_err_message,*) '----------------------------------------'
2612      CALL wrf_debug( 0, wrf_err_message )
2613      WRITE(temp,*) 'W-DAMPING  BEGINS AT W-COURANT NUMBER = ',w_damp_on
2614      CALL wrf_debug ( 0 , TRIM(temp) )
2615      write(wrf_err_message,*) '----------------------------------------'
2616      CALL wrf_debug( 0, wrf_err_message )
2617      print_flag = .false.
2618    ENDIF
2619
2620    IF(config_flags%polar ) then
2621      msfxffl = 1.0/COS(config_flags%fft_filter_lat*degrad)
2622    END IF
2623
2624 ! Routine has been reorganized to hopefully reduce redundant code while maintaining efficiency
2625
2626 #ifdef OPTIMIZE_CFL_TEST
2627 ! 20121025, L. Meadows vector optimization does not include special case for Cassini
2628
2629    IF(config_flags%polar ) then
2630      CALL wrf_error_fatal('module_big_step_utilities_em.F: -DOPTIMIZE_CFL_TEST option does not support global domains')
2631    END IF
2632
2633 #endif
2634
2635    DO j = jts,jtf
2636      DO k = 2,kde-1
2637        DO i = its,itf
2638
2639          vert_cfl = abs(ww(i,k,j)/(c1f(k)*mut(i,j)+c2f(k))*rdnw(k)*dt)
2640
2641 # ifdef OPTIMIZE_CFL_TEST
2642 ! L. Meadows, Intel, MIC optimization, 20121025
2643
2644          msfuxt = msfux(i,j)
2645
2646          IF ( vert_cfl > max_vert_cfl ) THEN
2647             max_vert_cfl = vert_cfl
2648          ENDIF
2649 # else
2650          IF(config_flags%polar ) THEN
2651             msfuxt = MIN(msfux(i,j), msfxffl)
2652          ELSE
2653             msfuxt = msfux(i,j)
2654          ENDIF
2655
2656          IF ( vert_cfl > max_vert_cfl ) THEN
2657             max_vert_cfl = vert_cfl ; maxi = i ; maxj = j ; maxk = k
2658             maxdub = w(i,k,j) ; maxdeta = -1./rdnw(k)
2659          ENDIF
2660 # endif
2661
2662          horiz_cfl = max( abs(u(i,k,j) * rdx * msfuxt     * dt),    &
2663                           abs(v(i,k,j) * rdy * msfvy(i,j) * dt) )
2664
2665          IF (horiz_cfl > max_horiz_cfl) THEN
2666             max_horiz_cfl = horiz_cfl
2667          ENDIF
2668
2669 ! Dump out more information without affecting performance
2670
2671 #ifndef OPTIMIZE_CFL_TEST
2672 ! This internal write is costly on newer Xeon processors because it breaks
2673 ! vectorization.  (J. Michalakes for L. Meadows at Intel, 12/13/2012)
2674
2675          IF (vert_cfl .gt. 2.) THEN
2676
2677            some1 = some1 + 1
2678
2679            WRITE(temp,FMT="(3(1x,i5,1x),'w-crit_cfl: ',f7.4,2x,'w-cfl: ',f7.4,2x,'dETA: ',f7.4)") &
2680                                          i,j,k,vert_cfl,w(i,k,j),-1./rdnw(k)
2681            CALL wrf_debug ( 100 , TRIM(temp) )
2682
2683          ENDIF
2684
2685 #endif
2686
2687          IF ((vert_cfl .gt. w_damp_on) .and. (config_flags%w_damping == 1) ) THEN
2688
2689            rw_tend(i,k,j) = rw_tend(i,k,j)-sign(1.,w(i,k,j))*w_alpha*(vert_cfl-w_crit_cfl)*(c1f(k)*mut(i,j)+c2f(k))
2690
2691          ENDIF
2692
2693        ENDDO   ! end i-loop
2694      ENDDO   ! end k-loop
2695    ENDDO   ! end j-loop
2696
2697    IF ( some1 .GT. 0 ) THEN
2698      CALL get_current_time_string( time_str )
2699      CALL get_current_grid_name( grid_str )
2700      WRITE(temp,*) some1,                                            &
2701             ' points exceeded v_cfl = 2 in domain '//TRIM(grid_str)//' at time '//TRIM(time_str)//' hours'
2702      CALL wrf_debug ( 0 , TRIM(temp) )
2703      WRITE(temp,FMT="('Max   W: ',3(1x,i5,1x),'W: ',f7.2,2x,'w-cfl: ',f7.2,2x,'dETA: ',f7.2)") &
2704                             maxi, maxj, maxk, maxdub, max_vert_cfl, maxdeta
2705      CALL wrf_debug ( 0 , TRIM(temp) )
2706 !    WRITE(temp,FMT="('Max U/V: ',3(1x,i5,1x),'U: ',f7.2,2x,'u-cfl: ',f7.2,2x,'V: ',f7.2,2x,'v-cfl: ',f7.2)") &
2707 !          maxi, maxj, maxk, u(maxi,maxk,maxj), dt*u(maxi,maxk,maxj)*rdx, v(maxi,maxk,maxj), dt*v(maxi,maxk,maxj)*rdy
2708 !    CALL wrf_debug ( 0 , TRIM(temp) )
2709    ENDIF
2710
2711 END SUBROUTINE W_DAMP
2712
2713 !-------------------------------------------------------------------------------
2714
2715 SUBROUTINE horizontal_diffusion ( name, field, tendency, MUT, c1, c2,  &
2716                                   config_flags,                        &
2717                                   msfux, msfuy, msfvx, msfvx_inv,      &
2718                                   msfvy, msftx, msfty,                 &
2719                                   khdif, xkmhd, rdx, rdy,              &
2720                                   ids, ide, jds, jde, kds, kde,        &
2721                                   ims, ime, jms, jme, kms, kme,        &
2722                                   its, ite, jts, jte, kts, kte        )
2723
2724    IMPLICIT NONE
2725
2726    ! Input data
2727
2728    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
2729
2730    INTEGER ,        INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
2731                                      ims, ime, jms, jme, kms, kme, &
2732                                      its, ite, jts, jte, kts, kte
2733
2734    CHARACTER(LEN=1) ,                          INTENT(IN   ) :: name
2735
2736    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field, xkmhd
2737
2738    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
2739
2740    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: MUT
2741
2742    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,      &
2743                                                                     msfuy,      &
2744                                                                     msfvx,      &
2745                                                                     msfvx_inv,  &
2746                                                                     msfvy,      &
2747                                                                     msftx,      &
2748                                                                     msfty
2749
2750    REAL , DIMENSION( kms:kme )           , INTENT(IN   ) :: c1, c2
2751
2752    REAL ,                                      INTENT(IN   ) :: rdx,       &
2753                                                                 rdy,       &
2754                                                                 khdif
2755
2756    ! Local data
2757
2758    INTEGER :: i, j, k, itf, jtf, ktf
2759
2760    INTEGER :: i_start, i_end, j_start, j_end
2761
2762    REAL :: mrdx, mkrdxm, mkrdxp, &
2763            mrdy, mkrdym, mkrdyp
2764
2765    LOGICAL :: specified
2766
2767 !<DESCRIPTION>
2768 !
2769 !  horizontal_diffusion computes the horizontal diffusion tendency
2770 !  on model horizontal coordinate surfaces.
2771 !
2772 !</DESCRIPTION>
2773
2774    specified = .false.
2775    if(config_flags%specified .or. config_flags%nested) specified = .true.
2776
2777    ktf=MIN(kte,kde-1)
2778
2779    IF (name .EQ. 'u') THEN
2780
2781       i_start = its
2782       i_end   = ite
2783       j_start = jts
2784       j_end   = MIN(jte,jde-1)
2785
2786       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
2787       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
2788       IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
2789       IF ( config_flags%open_ye .or. specified ) j_end   = MIN(jde-2,jte)
2790       IF ( config_flags%periodic_x ) i_start = its
2791       IF ( config_flags%periodic_x ) i_end = ite
2792
2793
2794       DO j = j_start, j_end
2795       DO k=kts,ktf
2796       DO i = i_start, i_end
2797
2798          ! The interior is grad: (m_x*d/dx), the exterior is div: (m_x*m_y*d/dx(/m_y))
2799          ! setting up different averagings of m^2 partial d/dX and m^2 partial d/dY
2800
2801          mkrdxm=(msftx(i-1,j)/msfty(i-1,j))*(c1(k)*MUT(i-1,j)+c2(k))*xkmhd(i-1,k,j)*rdx
2802          mkrdxp=(msftx(i,j)/msfty(i,j))*(c1(k)*MUT(i,j)+c2(k))*xkmhd(i,k,j)*rdx
2803          mrdx=msfux(i,j)*msfuy(i,j)*rdx
2804          mkrdym=( (msfuy(i,j)+msfuy(i,j-1))/(msfux(i,j)+msfux(i,j-1)) )* &
2805                 0.25*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i,j-1)+c2(k))+(c1(k)*MUT(i-1,j-1)+c2(k))+(c1(k)*MUT(i-1,j)+c2(k)))* &
2806                 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i-1,k,j-1)+xkmhd(i-1,k,j))*rdy
2807          mkrdyp=( (msfuy(i,j)+msfuy(i,j+1))/(msfux(i,j)+msfux(i,j+1)) )* &
2808                 0.25*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i,j+1)+c2(k))+(c1(k)*MUT(i-1,j+1)+c2(k))+(c1(k)*MUT(i-1,j)+c2(k)))* &
2809                 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j+1)+xkmhd(i-1,k,j+1)+xkmhd(i-1,k,j))*rdy
2810          ! need to do four-corners (t) for diffusion coefficient as there are
2811          ! no values at u,v points
2812          ! msfuy - has to be y as part of d/dY
2813          !         has to be u as we're at a u point
2814          mrdy=msfux(i,j)*msfuy(i,j)*rdy
2815
2816          ! correctly averaged version of rho~ * m^2 *
2817          !    [partial d/dX(partial du^/dX) + partial d/dY(partial du^/dY)]
2818             tendency(i,k,j)=tendency(i,k,j)+( &
2819                             mrdx*(mkrdxp*(field(i+1,k,j)-field(i  ,k,j))  &
2820                                  -mkrdxm*(field(i  ,k,j)-field(i-1,k,j))) &
2821                            +mrdy*(mkrdyp*(field(i,k,j+1)-field(i,k,j  ))  &
2822                                  -mkrdym*(field(i,k,j  )-field(i,k,j-1))))
2823       ENDDO
2824       ENDDO
2825       ENDDO
2826
2827    ELSE IF (name .EQ. 'v')THEN
2828
2829       i_start = its
2830       i_end   = MIN(ite,ide-1)
2831       j_start = jts
2832       j_end   = jte
2833
2834       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
2835       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
2836       IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
2837       IF ( config_flags%open_ye .or. specified ) j_end   = MIN(jde-1,jte)
2838       IF ( config_flags%periodic_x ) i_start = its
2839       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
2840       IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
2841       IF ( config_flags%polar ) j_end   = MIN(jde-1,jte)
2842
2843       DO j = j_start, j_end
2844       DO k=kts,ktf
2845       DO i = i_start, i_end
2846
2847          mkrdxm=( (msfvx(i,j)+msfvx(i-1,j))/(msfvy(i,j)+msfvy(i-1,j)) )*    &
2848                 0.25*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i,j-1)+c2(k))+(c1(k)*MUT(i-1,j-1)+c2(k))+(c1(k)*MUT(i-1,j)+c2(k)))* &
2849                 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i-1,k,j-1)+xkmhd(i-1,k,j))*rdx
2850          mkrdxp=( (msfvx(i,j)+msfvx(i+1,j))/(msfvy(i,j)+msfvy(i+1,j)) )*    &
2851                 0.25*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i,j-1)+c2(k))+(c1(k)*MUT(i+1,j-1)+c2(k))+(c1(k)*MUT(i+1,j)+c2(k)))* &
2852                 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i+1,k,j-1)+xkmhd(i+1,k,j))*rdx
2853          mrdx=msfvx(i,j)*msfvy(i,j)*rdx
2854          mkrdym=(msfty(i,j-1)/msftx(i,j-1))*xkmhd(i,k,j-1)*rdy
2855          mkrdyp=(msfty(i,j)/msftx(i,j))*xkmhd(i,k,j)*rdy
2856          mrdy=msfvx(i,j)*msfvy(i,j)*rdy
2857
2858             tendency(i,k,j)=tendency(i,k,j)+( &
2859                             mrdx*(mkrdxp*(field(i+1,k,j)-field(i  ,k,j))  &
2860                                  -mkrdxm*(field(i  ,k,j)-field(i-1,k,j))) &
2861                            +mrdy*(mkrdyp*(field(i,k,j+1)-field(i,k,j  ))  &
2862                                  -mkrdym*(field(i,k,j  )-field(i,k,j-1))))
2863       ENDDO
2864       ENDDO
2865       ENDDO
2866
2867    ELSE IF (name .EQ. 'w')THEN
2868
2869       i_start = its
2870       i_end   = MIN(ite,ide-1)
2871       j_start = jts
2872       j_end   = MIN(jte,jde-1)
2873
2874       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
2875       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
2876       IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
2877       IF ( config_flags%open_ye .or. specified ) j_end   = MIN(jde-2,jte)
2878       IF ( config_flags%periodic_x ) i_start = its
2879       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
2880
2881       DO j = j_start, j_end
2882       DO k=kts+1,ktf
2883       DO i = i_start, i_end
2884
2885          mkrdxm=(msfux(i,j)/msfuy(i,j))*   &
2886                 0.25*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i-1,j)+c2(k))+(c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i-1,j)+c2(k)))* &
2887                 0.25*(xkmhd(i,k,j)+xkmhd(i-1,k,j)+xkmhd(i,k-1,j)+xkmhd(i-1,k-1,j))*rdx
2888          mkrdxp=(msfux(i+1,j)/msfuy(i+1,j))*   &
2889                 0.25*((c1(k)*MUT(i+1,j)+c2(k))+(c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i+1,j)+c2(k))+(c1(k)*MUT(i,j)+c2(k)))* &
2890                 0.25*(xkmhd(i+1,k,j)+xkmhd(i,k,j)+xkmhd(i+1,k-1,j)+xkmhd(i,k-1,j))*rdx
2891          mrdx=msftx(i,j)*msfty(i,j)*rdx
2892 !         mkrdym=(msfvy(i,j)/msfvx(i,j))*   &
2893          mkrdym=(msfvy(i,j)*msfvx_inv(i,j))*   &
2894                 0.25*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i,j-1)+c2(k))+(c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i,j-1)+c2(k)))* &
2895                 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i,k-1,j)+xkmhd(i,k-1,j-1))*rdy
2896 !         mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*   &
2897          mkrdyp=(msfvy(i,j+1)*msfvx_inv(i,j+1))*   &
2898                 0.25*((c1(k)*MUT(i,j+1)+c2(k))+(c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i,j+1)+c2(k))+(c1(k)*MUT(i,j)+c2(k)))* &
2899                 0.25*(xkmhd(i,k,j+1)+xkmhd(i,k,j)+xkmhd(i,k-1,j+1)+xkmhd(i,k-1,j))*rdy
2900          mrdy=msftx(i,j)*msfty(i,j)*rdy
2901
2902             tendency(i,k,j)=tendency(i,k,j)+( &
2903                             mrdx*(mkrdxp*(field(i+1,k,j)-field(i  ,k,j)) &
2904                                  -mkrdxm*(field(i  ,k,j)-field(i-1,k,j))) &
2905                            +mrdy*(mkrdyp*(field(i,k,j+1)-field(i,k,j  )) &
2906                                  -mkrdym*(field(i,k,j  )-field(i,k,j-1))))
2907       ENDDO
2908       ENDDO
2909       ENDDO
2910
2911    ELSE
2912
2913
2914       i_start = its
2915       i_end   = MIN(ite,ide-1)
2916       j_start = jts
2917       j_end   = MIN(jte,jde-1)
2918
2919       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
2920       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
2921       IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
2922       IF ( config_flags%open_ye .or. specified ) j_end   = MIN(jde-2,jte)
2923       IF ( config_flags%periodic_x ) i_start = its
2924       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
2925
2926       DO j = j_start, j_end
2927       DO k=kts,ktf
2928       DO i = i_start, i_end
2929
2930          mkrdxm=(msfux(i,j)/msfuy(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i-1,k,j))*0.5*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i-1,j)+c2(k)))*rdx
2931          mkrdxp=(msfux(i+1,j)/msfuy(i+1,j))*0.5*(xkmhd(i+1,k,j)+xkmhd(i,k,j))*0.5*((c1(k)*MUT(i+1,j)+c2(k))+(c1(k)*MUT(i,j)+c2(k)))*rdx
2932          mrdx=msftx(i,j)*msfty(i,j)*rdx
2933 !         mkrdym=(msfvy(i,j)/msfvx(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i,j-1)+c2(k)))*rdy
2934          mkrdym=(msfvy(i,j)*msfvx_inv(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i,j-1)+c2(k)))*rdy
2935 !         mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*((c1(k)*MUT(i,j+1)+c2(k))+(c1(k)*MUT(i,j)+c2(k)))*rdy
2936          mkrdyp=(msfvy(i,j+1)*msfvx_inv(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*((c1(k)*MUT(i,j+1)+c2(k))+(c1(k)*MUT(i,j)+c2(k)))*rdy
2937          mrdy=msftx(i,j)*msfty(i,j)*rdy
2938
2939             tendency(i,k,j)=tendency(i,k,j)+( &
2940                             mrdx*(mkrdxp*(field(i+1,k,j)-field(i  ,k,j))  &
2941                                  -mkrdxm*(field(i  ,k,j)-field(i-1,k,j))) &
2942                            +mrdy*(mkrdyp*(field(i,k,j+1)-field(i,k,j  ))  &
2943                                  -mkrdym*(field(i,k,j  )-field(i,k,j-1))))
2944       ENDDO
2945       ENDDO
2946       ENDDO
2947
2948    ENDIF
2949
2950 END SUBROUTINE horizontal_diffusion
2951
2952 !-----------------------------------------------------------------------------------------
2953
2954 SUBROUTINE horizontal_diffusion_3dmp ( name, field, tendency, MUT, c1, c2,  &
2955                                        config_flags, base_3d,               &
2956                                        msfux, msfuy, msfvx, msfvx_inv,      &
2957                                        msfvy, msftx, msfty,                 &
2958                                        khdif, xkmhd, rdx, rdy,              &
2959                                        ids, ide, jds, jde, kds, kde,        &
2960                                        ims, ime, jms, jme, kms, kme,        &
2961                                        its, ite, jts, jte, kts, kte        )
2962
2963    IMPLICIT NONE
2964
2965    ! Input data
2966
2967    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
2968
2969    INTEGER ,        INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
2970                                      ims, ime, jms, jme, kms, kme, &
2971                                      its, ite, jts, jte, kts, kte
2972
2973    CHARACTER(LEN=1) ,                          INTENT(IN   ) :: name
2974
2975    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field, &
2976                                                                       xkmhd, &
2977                                                                       base_3d
2978
2979    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
2980
2981    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: MUT
2982
2983    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,      &
2984                                                                     msfuy,      &
2985                                                                     msfvx,      &
2986                                                                     msfvx_inv,  &
2987                                                                     msfvy,      &
2988                                                                     msftx,      &
2989                                                                     msfty
2990
2991    REAL , DIMENSION( kms:kme )           , INTENT(IN   ) :: c1, c2
2992
2993    REAL ,                                      INTENT(IN   ) :: rdx,       &
2994                                                                 rdy,       &
2995                                                                 khdif
2996
2997    ! Local data
2998
2999    INTEGER :: i, j, k, itf, jtf, ktf
3000
3001    INTEGER :: i_start, i_end, j_start, j_end
3002
3003    REAL :: mrdx, mkrdxm, mkrdxp, &
3004            mrdy, mkrdym, mkrdyp
3005
3006    LOGICAL :: specified
3007
3008 !<DESCRIPTION>
3009 !
3010 !  horizontal_diffusion_3dmp computes the horizontal diffusion tendency
3011 !  on model horizontal coordinate surfaces.  This routine computes diffusion
3012 !  a perturbation scalar (field-base_3d).
3013 !
3014 !</DESCRIPTION>
3015
3016    specified = .false.
3017    if(config_flags%specified .or. config_flags%nested) specified = .true.
3018
3019    ktf=MIN(kte,kde-1)
3020
3021       i_start = its
3022       i_end   = MIN(ite,ide-1)
3023       j_start = jts
3024       j_end   = MIN(jte,jde-1)
3025
3026       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
3027       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
3028       IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
3029       IF ( config_flags%open_ye .or. specified ) j_end   = MIN(jde-2,jte)
3030       IF ( config_flags%periodic_x ) i_start = its
3031       IF ( config_flags%periodic_x ) i_end = MIN(ite,ide-1)
3032
3033       DO j = j_start, j_end
3034       DO k=kts,ktf
3035       DO i = i_start, i_end
3036
3037          mkrdxm=(msfux(i,j)/msfuy(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i-1,k,j))*0.5*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i-1,j)+c2(k)))*rdx
3038          mkrdxp=(msfux(i+1,j)/msfuy(i+1,j))*0.5*(xkmhd(i+1,k,j)+xkmhd(i,k,j))*0.5*((c1(k)*MUT(i+1,j)+c2(k))+(c1(k)*MUT(i,j)+c2(k)))*rdx
3039          mrdx=msftx(i,j)*msfty(i,j)*rdx
3040 !         mkrdym=(msfvy(i,j)/msfvx(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i,j-1)+c2(k)))*rdy
3041 !         mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*((c1(k)*MUT(i,j+1)+c2(k))+(c1(k)*MUT(i,j)+c2(k)))*rdy
3042          mkrdym=(msfvy(i,j)*msfvx_inv(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*((c1(k)*MUT(i,j)+c2(k))+(c1(k)*MUT(i,j-1)+c2(k)))*rdy
3043          mkrdyp=(msfvy(i,j+1)*msfvx_inv(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*((c1(k)*MUT(i,j+1)+c2(k))+(c1(k)*MUT(i,j)+c2(k)))*rdy
3044          mrdy=msftx(i,j)*msfty(i,j)*rdy
3045
3046             tendency(i,k,j)=tendency(i,k,j)+(                        &
3047                     mrdx*( mkrdxp*(   field(i+1,k,j)  -field(i  ,k,j)      &
3048                                    -base_3d(i+1,k,j)+base_3d(i  ,k,j) )    &
3049                           -mkrdxm*(   field(i  ,k,j)  -field(i-1,k,j)      &
3050                                    -base_3d(i  ,k,j)+base_3d(i-1,k,j) )  ) &
3051                    +mrdy*( mkrdyp*(   field(i,k,j+1)  -field(i,k,j  )      &
3052                                    -base_3d(i,k,j+1)+base_3d(i,k,j  ) )    &
3053                           -mkrdym*(   field(i,k,j  )  -field(i,k,j-1)      &
3054                                    -base_3d(i,k,j  )+base_3d(i,k,j-1) )  ) &
3055                                                                          )
3056       ENDDO
3057       ENDDO
3058       ENDDO
3059
3060 END SUBROUTINE horizontal_diffusion_3dmp
3061
3062 !-----------------------------------------------------------------------------------------
3063
3064 SUBROUTINE vertical_diffusion ( name, field, tendency,        &
3065                                 config_flags, c1, c2,         &
3066                                 alt, MUT, rdn, rdnw, kvdif,   &
3067                                 ids, ide, jds, jde, kds, kde, &
3068                                 ims, ime, jms, jme, kms, kme, &
3069                                 its, ite, jts, jte, kts, kte )
3070
3071
3072    IMPLICIT NONE
3073
3074    ! Input data
3075
3076    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
3077
3078    INTEGER ,    INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
3079                                  ims, ime, jms, jme, kms, kme, &
3080                                  its, ite, jts, jte, kts, kte
3081
3082    CHARACTER(LEN=1) ,                          INTENT(IN   ) :: name
3083
3084    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) ,                      &
3085                                                INTENT(IN   ) :: field,    &
3086                                                                 alt
3087
3088    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
3089
3090    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: MUT
3091
3092    REAL , DIMENSION( kms:kme ) ,                   INTENT(IN   ) :: rdn, rdnw
3093
3094    REAL , DIMENSION( kms:kme )   ,                 INTENT(IN   ) :: c1, c2
3095
3096    REAL ,                                      INTENT(IN   ) :: kvdif
3097
3098    ! Local data
3099
3100    INTEGER :: i, j, k, itf, jtf, ktf
3101    INTEGER :: i_start, i_end, j_start, j_end
3102
3103    REAL , DIMENSION(its:ite, jts:jte) :: vfluxm, vfluxp, zz
3104    REAL , DIMENSION(its:ite, 0:kte+1) :: vflux
3105
3106    REAL :: rdz
3107
3108    LOGICAL :: specified
3109
3110 !<DESCRIPTION>
3111 !
3112 !  vertical_diffusion
3113 !  computes vertical diffusion tendency.
3114 !
3115 !</DESCRIPTION>
3116
3117    specified = .false.
3118    if(config_flags%specified .or. config_flags%nested) specified = .true.
3119
3120    ktf=MIN(kte,kde-1)
3121
3122    IF (name .EQ. 'w')THEN
3123
3124
3125    i_start = its
3126    i_end   = MIN(ite,ide-1)
3127    j_start = jts
3128    j_end   = MIN(jte,jde-1)
3129
3130 j_loop_w : DO j = j_start, j_end
3131
3132      DO k=kts,ktf-1
3133        DO i = i_start, i_end
3134           vflux(i,k)= (kvdif/alt(i,k,j))*rdnw(k)*(field(i,k+1,j)-field(i,k,j))
3135        ENDDO
3136      ENDDO
3137
3138      DO i = i_start, i_end
3139        vflux(i,ktf)=0.
3140      ENDDO
3141
3142      DO k=kts+1,ktf
3143        DO i = i_start, i_end
3144             tendency(i,k,j)=tendency(i,k,j)                                         &
3145                               +rdn(k)*g*g/(c1(k)*MUT(i,j)+c2(k))/(0.5*(alt(i,k,j)+alt(i,k-1,j)))  &
3146                                          *(vflux(i,k)-vflux(i,k-1))
3147        ENDDO
3148      ENDDO
3149
3150     ENDDO j_loop_w
3151
3152    ELSE IF(name .EQ. 'm')THEN
3153
3154      i_start = its
3155      i_end   = MIN(ite,ide-1)
3156      j_start = jts
3157      j_end   = MIN(jte,jde-1)
3158
3159 j_loop_s : DO j = j_start, j_end
3160
3161      DO k=kts,ktf-1
3162        DO i = i_start, i_end
3163          vflux(i,k)=kvdif*rdn(k+1)/(0.5*(alt(i,k,j)+alt(i,k+1,j)))   &
3164                   *(field(i,k+1,j)-field(i,k,j))
3165        ENDDO
3166      ENDDO
3167
3168      DO i = i_start, i_end
3169        vflux(i,0)=vflux(i,1)
3170      ENDDO
3171
3172      DO i = i_start, i_end
3173        vflux(i,ktf)=0.
3174      ENDDO
3175
3176      DO k=kts,ktf
3177        DO i = i_start, i_end
3178          tendency(i,k,j)=tendency(i,k,j)+g*g/(c1(k)*MUT(i,j)+c2(k))/alt(i,k,j)  &
3179                 *rdnw(k)*(vflux(i,k)-vflux(i,k-1))
3180        ENDDO
3181      ENDDO
3182
3183  ENDDO j_loop_s
3184
3185    ENDIF
3186
3187 END SUBROUTINE vertical_diffusion
3188
3189
3190 !-------------------------------------------------------------------------------
3191
3192 SUBROUTINE vertical_diffusion_mp ( field, tendency, config_flags, &
3193                                    base, c1, c2,                  &
3194                                    alt, MUT, rdn, rdnw, kvdif,    &
3195                                    ids, ide, jds, jde, kds, kde,  &
3196                                    ims, ime, jms, jme, kms, kme,  &
3197                                    its, ite, jts, jte, kts, kte  )
3198
3199
3200    IMPLICIT NONE
3201
3202    ! Input data
3203
3204    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
3205
3206    INTEGER ,    INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
3207                                  ims, ime, jms, jme, kms, kme, &
3208                                  its, ite, jts, jte, kts, kte
3209
3210    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) ,                      &
3211                                                INTENT(IN   ) :: field,    &
3212                                                                 alt
3213
3214    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
3215
3216    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: MUT
3217
3218    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: rdn,  &
3219                                                                   rdnw, &
3220                                                                   base
3221
3222    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: c1, c2
3223
3224    REAL ,                                      INTENT(IN   ) :: kvdif
3225
3226    ! Local data
3227
3228    INTEGER :: i, j, k, itf, jtf, ktf
3229    INTEGER :: i_start, i_end, j_start, j_end
3230
3231    REAL , DIMENSION(its:ite, 0:kte+1) :: vflux
3232
3233    REAL :: rdz
3234
3235    LOGICAL :: specified
3236
3237 !<DESCRIPTION>
3238 !
3239 !  vertical_diffusion_mp
3240 !  computes vertical diffusion tendency of a perturbation variable
3241 !  (field-base).  Note that base as a 1D (k) field.
3242 !
3243 !</DESCRIPTION>
3244
3245    specified = .false.
3246    if(config_flags%specified .or. config_flags%nested) specified = .true.
3247
3248    ktf=MIN(kte,kde-1)
3249
3250      i_start = its
3251      i_end   = MIN(ite,ide-1)
3252      j_start = jts
3253      j_end   = MIN(jte,jde-1)
3254
3255 j_loop_s : DO j = j_start, j_end
3256
3257      DO k=kts,ktf-1
3258        DO i = i_start, i_end
3259          vflux(i,k)=kvdif*rdn(k+1)/(0.5*(alt(i,k,j)+alt(i,k+1,j)))   &
3260                     *(field(i,k+1,j)-field(i,k,j)-base(k+1)+base(k))
3261        ENDDO
3262      ENDDO
3263
3264      DO i = i_start, i_end
3265        vflux(i,0)=vflux(i,1)
3266      ENDDO
3267
3268      DO i = i_start, i_end
3269        vflux(i,ktf)=0.
3270      ENDDO
3271
3272      DO k=kts,ktf
3273        DO i = i_start, i_end
3274          tendency(i,k,j)=tendency(i,k,j)+g*g/(c1(k)*MUT(i,j)+c2(k))/alt(i,k,j)  &
3275                 *rdnw(k)*(vflux(i,k)-vflux(i,k-1))
3276        ENDDO
3277      ENDDO
3278
3279  ENDDO j_loop_s
3280
3281 END SUBROUTINE vertical_diffusion_mp
3282
3283
3284 !-------------------------------------------------------------------------------
3285
3286 SUBROUTINE vertical_diffusion_3dmp ( field, tendency, config_flags, &
3287                                      base_3d, c1, c2,               &
3288                                      alt, MUT, rdn, rdnw, kvdif,    &
3289                                      ids, ide, jds, jde, kds, kde,  &
3290                                      ims, ime, jms, jme, kms, kme,  &
3291                                      its, ite, jts, jte, kts, kte  )
3292
3293
3294    IMPLICIT NONE
3295
3296    ! Input data
3297
3298    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
3299
3300    INTEGER ,    INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
3301                                  ims, ime, jms, jme, kms, kme, &
3302                                  its, ite, jts, jte, kts, kte
3303
3304    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) ,                      &
3305                                                INTENT(IN   ) :: field,    &
3306                                                                 alt,      &
3307                                                                 base_3d
3308
3309    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
3310
3311    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: MUT
3312
3313    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: rdn,  &
3314                                                                   rdnw
3315
3316    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: c1, c2
3317
3318    REAL ,                                      INTENT(IN   ) :: kvdif
3319
3320    ! Local data
3321
3322    INTEGER :: i, j, k, itf, jtf, ktf
3323    INTEGER :: i_start, i_end, j_start, j_end
3324
3325    REAL , DIMENSION(its:ite, 0:kte+1) :: vflux
3326
3327    REAL :: rdz
3328
3329    LOGICAL :: specified
3330
3331 !<DESCRIPTION>
3332 !
3333 !  vertical_diffusion_3dmp
3334 !  computes vertical diffusion tendency of a perturbation variable
3335 !  (field-base_3d).
3336 !
3337 !</DESCRIPTION>
3338
3339    specified = .false.
3340    if(config_flags%specified .or. config_flags%nested) specified = .true.
3341
3342    ktf=MIN(kte,kde-1)
3343
3344      i_start = its
3345      i_end   = MIN(ite,ide-1)
3346      j_start = jts
3347      j_end   = MIN(jte,jde-1)
3348
3349 j_loop_s : DO j = j_start, j_end
3350
3351      DO k=kts,ktf-1
3352        DO i = i_start, i_end
3353          vflux(i,k)=kvdif*rdn(k+1)/(0.5*(alt(i,k,j)+alt(i,k+1,j)))   &
3354                     *(   field(i,k+1,j)  -field(i,k,j)               &
3355                       -base_3d(i,k+1,j)+base_3d(i,k,j) )
3356        ENDDO
3357      ENDDO
3358
3359      DO i = i_start, i_end
3360        vflux(i,0)=vflux(i,1)
3361      ENDDO
3362
3363      DO i = i_start, i_end
3364        vflux(i,ktf)=0.
3365      ENDDO
3366
3367      DO k=kts,ktf
3368        DO i = i_start, i_end
3369          tendency(i,k,j)=tendency(i,k,j)+g*g/(c1(k)*MUT(i,j)+c2(k))/alt(i,k,j)  &
3370                 *rdnw(k)*(vflux(i,k)-vflux(i,k-1))
3371        ENDDO
3372      ENDDO
3373
3374  ENDDO j_loop_s
3375
3376 END SUBROUTINE vertical_diffusion_3dmp
3377
3378
3379 !-------------------------------------------------------------------------------
3380
3381
3382 SUBROUTINE vertical_diffusion_u ( field, tendency,              &
3383                                   config_flags, u_base, c1h,c2h,&
3384                                   alt, muu, rdn, rdnw, kvdif,   &
3385                                   ids, ide, jds, jde, kds, kde, &
3386                                   ims, ime, jms, jme, kms, kme, &
3387                                   its, ite, jts, jte, kts, kte )
3388
3389
3390    IMPLICIT NONE
3391
3392    ! Input data
3393
3394    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
3395
3396    INTEGER ,    INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
3397                                  ims, ime, jms, jme, kms, kme, &
3398                                  its, ite, jts, jte, kts, kte
3399
3400    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) ,                      &
3401                                                INTENT(IN   ) :: field,    &
3402                                                                 alt
3403
3404    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
3405
3406    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: muu
3407
3408    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: rdn, rdnw, u_base
3409
3410    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: c1h, c2h
3411
3412    REAL ,                                      INTENT(IN   ) :: kvdif
3413
3414    ! Local data
3415
3416    INTEGER :: i, j, k, itf, jtf, ktf
3417    INTEGER :: i_start, i_end, j_start, j_end
3418
3419    REAL , DIMENSION(its:ite, 0:kte+1) :: vflux
3420
3421    REAL :: rdz, zz
3422
3423    LOGICAL :: specified
3424
3425 !<DESCRIPTION>
3426 !
3427 !  vertical_diffusion_u computes vertical diffusion tendency for
3428 !  the u momentum equation.  This routine assumes a constant eddy
3429 !  viscosity kvdif.
3430 !
3431 !</DESCRIPTION>
3432
3433    specified = .false.
3434    if(config_flags%specified .or. config_flags%nested) specified = .true.
3435
3436    ktf=MIN(kte,kde-1)
3437
3438       i_start = its
3439       i_end   = ite
3440       j_start = jts
3441       j_end   = MIN(jte,jde-1)
3442
3443       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
3444       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
3445       IF ( config_flags%periodic_x ) i_start = its
3446       IF ( config_flags%periodic_x ) i_end = ite
3447
3448
3449 j_loop_u : DO j = j_start, j_end
3450
3451      DO k=kts,ktf-1
3452        DO i = i_start, i_end
3453          vflux(i,k)=kvdif*rdn(k+1)/(0.25*( alt(i  ,k  ,j)      &
3454                                         +alt(i-1,k  ,j)      &
3455                                         +alt(i  ,k+1,j)      &
3456                                         +alt(i-1,k+1,j) ) )  &
3457                              *(field(i,k+1,j)-field(i,k,j)   &
3458                                -u_base(k+1)   +u_base(k)  )
3459        ENDDO
3460      ENDDO
3461
3462      DO i = i_start, i_end
3463        vflux(i,0)=vflux(i,1)
3464      ENDDO
3465
3466      DO i = i_start, i_end
3467        vflux(i,ktf)=0.
3468      ENDDO
3469
3470      DO k=kts,ktf-1
3471        DO i = i_start, i_end
3472          tendency(i,k,j)=tendency(i,k,j)+                             &
3473                 g*g*rdnw(k)/(c1h(k)*muu(i,j)+c2h(k))/(0.5*(alt(i-1,k,j)+alt(i,k,j)))* &
3474                               (vflux(i,k)-vflux(i,k-1))
3475        ENDDO
3476      ENDDO
3477
3478  ENDDO j_loop_u
3479
3480 END SUBROUTINE vertical_diffusion_u
3481
3482 !-------------------------------------------------------------------------------
3483
3484
3485 SUBROUTINE vertical_diffusion_v ( field, tendency,              &
3486                                   config_flags, v_base, c1h,c2h,&
3487                                   alt, muv, rdn, rdnw, kvdif,   &
3488                                   ids, ide, jds, jde, kds, kde, &
3489                                   ims, ime, jms, jme, kms, kme, &
3490                                   its, ite, jts, jte, kts, kte )
3491
3492
3493    IMPLICIT NONE
3494
3495    ! Input data
3496
3497    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
3498
3499    INTEGER ,    INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
3500                                  ims, ime, jms, jme, kms, kme, &
3501                                  its, ite, jts, jte, kts, kte
3502
3503    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) ,                      &
3504                                                INTENT(IN   ) :: field,    &
3505                                                                 alt
3506    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: rdn, rdnw, v_base
3507
3508    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: c1h, c2h
3509
3510    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
3511
3512    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: muv
3513
3514    REAL ,                                      INTENT(IN   ) :: kvdif
3515
3516    ! Local data
3517
3518    INTEGER :: i, j, k, itf, jtf, ktf, jm1
3519    INTEGER :: i_start, i_end, j_start, j_end
3520
3521    REAL , DIMENSION(its:ite, 0:kte+1) :: vflux
3522
3523    REAL :: rdz, zz
3524
3525    LOGICAL :: specified
3526
3527 !<DESCRIPTION>
3528 !
3529 !  vertical_diffusion_v computes vertical diffusion tendency for
3530 !  the v momentum equation.  This routine assumes a constant eddy
3531 !  viscosity kvdif.
3532 !
3533 !</DESCRIPTION>
3534
3535    specified = .false.
3536    if(config_flags%specified .or. config_flags%nested) specified = .true.
3537
3538    ktf=MIN(kte,kde-1)
3539
3540       i_start = its
3541       i_end   = MIN(ite,ide-1)
3542       j_start = jts
3543       j_end   = MIN(jte,jde-1)
3544
3545       IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
3546       IF ( config_flags%open_ye .or. specified ) j_end   = MIN(jde-1,jte)
3547
3548 j_loop_v : DO j = j_start, j_end
3549 !     jm1 = max(j-1,1)
3550      jm1 = j-1
3551
3552      DO k=kts,ktf-1
3553        DO i = i_start, i_end
3554          vflux(i,k)=kvdif*rdn(k+1)/(0.25*( alt(i,k  ,j  )      &
3555                                         +alt(i,k  ,jm1)      &
3556                                         +alt(i,k+1,j  )      &
3557                                         +alt(i,k+1,jm1) ) )  &
3558                              *(field(i,k+1,j)-field(i,k,j)   &
3559                                -v_base(k+1)   +v_base(k)  )
3560        ENDDO
3561      ENDDO
3562
3563      DO i = i_start, i_end
3564        vflux(i,0)=vflux(i,1)
3565      ENDDO
3566
3567      DO i = i_start, i_end
3568        vflux(i,ktf)=0.
3569      ENDDO
3570
3571      DO k=kts,ktf-1
3572        DO i = i_start, i_end
3573          tendency(i,k,j)=tendency(i,k,j)+                              &
3574                 g*g*rdnw(k)/(c1h(k)*muv(i,j)+c2h(k))/(0.5*(alt(i,k,jm1)+alt(i,k,j)))*  &
3575                               (vflux(i,k)-vflux(i,k-1))
3576        ENDDO
3577      ENDDO
3578
3579  ENDDO j_loop_v
3580
3581 END SUBROUTINE vertical_diffusion_v
3582
3583 !***************  end new mass coordinate routines
3584
3585 !-------------------------------------------------------------------------------
3586
3587 SUBROUTINE calculate_full ( rfield, rfieldb, rfieldp,     &
3588                             ids, ide, jds, jde, kds, kde, &
3589                             ims, ime, jms, jme, kms, kme, &
3590                             its, ite, jts, jte, kts, kte )
3591
3592    IMPLICIT NONE
3593
3594    ! Input data
3595
3596    INTEGER ,      INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
3597                                    ims, ime, jms, jme, kms, kme, &
3598                                    its, ite, jts, jte, kts, kte
3599
3600    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: rfieldb, &
3601                                                                       rfieldp
3602
3603    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT  ) :: rfield
3604
3605    ! Local indices.
3606
3607    INTEGER :: i, j, k, itf, jtf, ktf, i_start, j_start
3608
3609 !<DESCRIPTION>
3610 !
3611 !  calculate_full
3612 !  calculates full 3D field from pertubation and base field.
3613 !  The input fields (mu base and perturbation mu) are communicated prior
3614 !  to this call. That fills the total field into the halo region. That
3615 !  extra row/column is only used by the IEVA scheme. Having the extra
3616 !  row/column filled with valid values is not a problem for the rest of
3617 !  the model.
3618 !
3619 !</DESCRIPTION>
3620
3621    itf=MIN(ite,ide-1)
3622    jtf=MIN(jte,jde-1)
3623    ktf=MIN(kte,kde-1)
3624
3625    i_start=its-1
3626    j_start=jts-1
3627
3628    DO j=j_start,jtf
3629    DO k=kts,ktf
3630    DO i=i_start,itf
3631       rfield(i,k,j)=rfieldb(i,k,j)+rfieldp(i,k,j)
3632    ENDDO
3633    ENDDO
3634    ENDDO
3635
3636 END SUBROUTINE calculate_full
3637
3638 !------------------------------------------------------------------------------
3639
3640 SUBROUTINE coriolis ( ru, rv, rw, ru_tend, rv_tend, rw_tend, &
3641                       config_flags,                          &
3642                       msftx, msfty, msfux, msfuy,            &
3643                       msfvx, msfvy,                          &
3644                       f, e, sina, cosa, fzm, fzp,            &
3645                       ids, ide, jds, jde, kds, kde,          &
3646                       ims, ime, jms, jme, kms, kme,          &
3647                       its, ite, jts, jte, kts, kte          )
3648
3649    IMPLICIT NONE
3650
3651    ! Input data
3652
3653    TYPE(grid_config_rec_type) ,           INTENT(IN   ) :: config_flags
3654
3655    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
3656                                               ims, ime, jms, jme, kms, kme, &
3657                                               its, ite, jts, jte, kts, kte
3658
3659    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: ru_tend, &
3660                                                                 rv_tend, &
3661                                                                 rw_tend
3662    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: ru, &
3663                                                                 rv, &
3664                                                                 rw
3665
3666    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,      &
3667                                                                 msfuy,      &
3668                                                                 msfvx,      &
3669                                                                 msfvy,      &
3670                                                                 msftx,      &
3671                                                                 msfty
3672
3673    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: f,    &
3674                                                                     e,    &
3675                                                                     sina, &
3676                                                                     cosa
3677
3678    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm, &
3679                                                                   fzp
3680
3681    ! Local indices.
3682
3683    INTEGER :: i, j , k, ktf
3684    INTEGER :: i_start, i_end, j_start, j_end
3685
3686    LOGICAL :: specified
3687
3688 !<DESCRIPTION>
3689 !
3690 !  coriolis calculates the large timestep tendency terms in the
3691 !  u, v, and w momentum equations arise from the coriolis force.
3692 !
3693 !</DESCRIPTION>
3694
3695    specified = .false.
3696    if(config_flags%specified .or. config_flags%nested) specified = .true.
3697
3698    ktf=MIN(kte,kde-1)
3699
3700 ! coriolis for u-momentum equation
3701
3702 !  Notes on map scale factor
3703 !  cosa, sina are related to rotating the coordinate frame if desired
3704 !  generally sina=0, cosa=1
3705 !  ADT eqn 44, RHS terms 6 and 7: -2 mu w omega cos(lat)/my
3706 !                                + 2 mu v omega sin(lat)/my
3707 !  Define f=2 omega sin(lat), e=2 omega cos(lat)
3708 !   => terms are: -e mu w / my + f mu v / my
3709 !  rv = mu v / mx ; rw = mu w / my
3710 !   => terms are: -e rw + f rv *mx / my
3711
3712    i_start = its
3713    i_end   = ite
3714    IF ( config_flags%open_xs .or. specified .or. &
3715         config_flags%nested) i_start = MAX(ids+1,its)
3716    IF ( config_flags%open_xe .or. specified .or. &
3717         config_flags%nested) i_end   = MIN(ide-1,ite)
3718       IF ( config_flags%periodic_x ) i_start = its
3719       IF ( config_flags%periodic_x ) i_end = ite
3720
3721    DO j = jts, MIN(jte,jde-1)
3722
3723    DO k=kts,ktf
3724    DO i = i_start, i_end
3725
3726      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)) &
3727        *0.25*(rv(i-1,k,j+1)+rv(i,k,j+1)+rv(i-1,k,j)+rv(i,k,j)) &
3728            - 0.5*(e(i,j)+e(i-1,j))*0.5*(cosa(i,j)+cosa(i-1,j)) &
3729        *0.25*(rw(i-1,k+1,j)+rw(i-1,k,j)+rw(i,k+1,j)+rw(i,k,j))
3730
3731    ENDDO
3732    ENDDO
3733
3734 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
3735 !  IF ( (config_flags%open_xs) .and. (its == ids) ) THEN
3736
3737 !    DO k=kts,ktf
3738 !
3739 !      ru_tend(its,k,j)=ru_tend(its,k,j) + (msfux(its,j)/msfuy(its,j))*0.5*(f(its,j)+f(its,j))   &
3740 !        *0.25*(rv(its,k,j+1)+rv(its,k,j+1)+rv(its,k,j)+rv(its,k,j)) &
3741 !            - 0.5*(e(its,j)+e(its,j))*0.5*(cosa(its,j)+cosa(its,j)) &
3742 !        *0.25*(rw(its,k+1,j)+rw(its,k,j)+rw(its,k+1,j)+rw(its,k,j))
3743
3744 !    ENDDO
3745
3746 !  ENDIF
3747
3748 !  IF ( (config_flags%open_xe) .and. (ite == ide) ) THEN
3749
3750 !    DO k=kts,ktf
3751 !
3752 !      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)) &
3753 !        *0.25*(rv(ite-1,k,j+1)+rv(ite-1,k,j+1)+rv(ite-1,k,j)+rv(ite-1,k,j)) &
3754 !            - 0.5*(e(ite-1,j)+e(ite-1,j))*0.5*(cosa(ite-1,j)+cosa(ite-1,j)) &
3755 !        *0.25*(rw(ite-1,k+1,j)+rw(ite-1,k,j)+rw(ite-1,k+1,j)+rw(ite-1,k,j))
3756
3757 !    ENDDO
3758
3759 !  ENDIF
3760
3761    ENDDO
3762
3763 !  coriolis term for v-momentum equation
3764
3765 !  Notes on map scale factors
3766 !  ADT eqn 45, RHS terms 6 and 6b [0 for sina=0]: -2 mu u omega sin(lat)/mx + ?
3767 !  Define f=2 omega sin(lat), e=2 omega cos(lat)
3768 !   => terms are: -f mu u / mx
3769 !  ru = mu u / my ; rw = mu w / my
3770 !   => terms are: -f ru *my / mx + ?
3771
3772    j_start = jts
3773    j_end   = jte
3774
3775    IF ( config_flags%open_ys .or. specified .or. &
3776         config_flags%nested .or. config_flags%polar) j_start = MAX(jds+1,jts)
3777    IF ( config_flags%open_ye .or. specified .or. &
3778         config_flags%nested .or. config_flags%polar) j_end   = MIN(jde-1,jte)
3779
3780 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
3781 !  IF ( (config_flags%open_ys) .and. (jts == jds) ) THEN
3782
3783 !    DO k=kts,ktf
3784 !    DO i=its,MIN(ide-1,ite)
3785 !
3786 !       rv_tend(i,k,jts)=rv_tend(i,k,jts) - (msfvy(i,jts)/msfvx(i,jts))*0.5*(f(i,jts)+f(i,jts))    &
3787 !        *0.25*(ru(i,k,jts)+ru(i+1,k,jts)+ru(i,k,jts)+ru(i+1,k,jts))   &
3788 !            + (msfvy(i,jts)/msfvx(i,jts))*0.5*(e(i,jts)+e(i,jts))*0.5*(sina(i,jts)+sina(i,jts))   &
3789 !            *0.25*(rw(i,k+1,jts)+rw(i,k,jts)+rw(i,k+1,jts)+rw(i,k,jts))
3790
3791 !    ENDDO
3792 !    ENDDO
3793
3794 !  ENDIF
3795
3796    DO j=j_start, j_end
3797    DO k=kts,ktf
3798    DO i=its,MIN(ide-1,ite)
3799
3800       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))    &
3801        *0.25*(ru(i,k,j)+ru(i+1,k,j)+ru(i,k,j-1)+ru(i+1,k,j-1)) &
3802            + (msfvy(i,j)/msfvx(i,j))*0.5*(e(i,j)+e(i,j-1))*0.5*(sina(i,j)+sina(i,j-1)) &
3803            *0.25*(rw(i,k+1,j-1)+rw(i,k,j-1)+rw(i,k+1,j)+rw(i,k,j))
3804
3805    ENDDO
3806    ENDDO
3807    ENDDO
3808
3809
3810 ! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
3811 !  IF ( (config_flags%open_ye) .and. (jte == jde) ) THEN
3812
3813 !    DO k=kts,ktf
3814 !    DO i=its,MIN(ide-1,ite)
3815 !
3816 !       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))        &
3817 !        *0.25*(ru(i,k,jte-1)+ru(i+1,k,jte-1)+ru(i,k,jte-1)+ru(i+1,k,jte-1))   &
3818 !            + (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))   &
3819 !            *0.25*(rw(i,k+1,jte-1)+rw(i,k,jte-1)+rw(i,k+1,jte-1)+rw(i,k,jte-1))
3820
3821 !    ENDDO
3822 !    ENDDO
3823
3824 !  ENDIF
3825
3826 ! coriolis term for w-mometum
3827
3828 ! Notes on map scale factors
3829 ! ADT eqn 46/my, RHS terms 5 and 5b [0 for sina=0]: 2 mu u omega cos(lat)/my +?
3830 ! Define e=2 omega cos(lat)
3831 !  => terms are: e mu u / my + ???
3832 ! ru = mu u / my ; ru = mu v / mx
3833 !  => terms are: e ru + ???
3834
3835    DO j=jts,MIN(jte, jde-1)
3836    DO k=kts+1,ktf
3837    DO i=its,MIN(ite, ide-1)
3838
3839        rw_tend(i,k,j)=rw_tend(i,k,j) + e(i,j)*           &
3840           (cosa(i,j)*0.5*(fzm(k)*(ru(i,k,j)+ru(i+1,k,j)) &
3841           +fzp(k)*(ru(i,k-1,j)+ru(i+1,k-1,j)))           &
3842           -(msftx(i,j)/msfty(i,j))*                      &
3843            sina(i,j)*0.5*(fzm(k)*(rv(i,k,j)+rv(i,k,j+1)) &
3844           +fzp(k)*(rv(i,k-1,j)+rv(i,k-1,j+1))))
3845
3846    ENDDO
3847    ENDDO
3848    ENDDO
3849
3850 END SUBROUTINE coriolis
3851
3852 !------------------------------------------------------------------------------
3853
3854 SUBROUTINE perturbation_coriolis ( ru_in, rv_in, rw, ru_tend, rv_tend, rw_tend, &
3855                                    config_flags,                                &
3856                                    u_base, v_base, z_base,                      &
3857                                    muu, muv, c1h, c2h, phb, ph,                 &
3858                                    msftx, msfty, msfux, msfuy, msfvx, msfvy,    &
3859                                    f, e, sina, cosa, fzm, fzp,                  &
3860                                    ids, ide, jds, jde, kds, kde,                &
3861                                    ims, ime, jms, jme, kms, kme,                &
3862                                    its, ite, jts, jte, kts, kte                )
3863
3864    IMPLICIT NONE
3865
3866    ! Input data
3867
3868    TYPE(grid_config_rec_type) ,           INTENT(IN   ) :: config_flags
3869
3870    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
3871                                               ims, ime, jms, jme, kms, kme, &
3872                                               its, ite, jts, jte, kts, kte
3873
3874    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: ru_tend, &
3875                                                                 rv_tend, &
3876                                                                 rw_tend
3877    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: ru_in, &
3878                                                                       rv_in, &
3879                                                                       rw,    &
3880                                                                       ph,    &
3881                                                                       phb
3882
3883
3884    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,      &
3885                                                                 msfuy,      &
3886                                                                 msfvx,      &
3887                                                                 msfvy,      &
3888                                                                 msftx,      &
3889                                                                 msfty
3890
3891    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: f,    &
3892                                                                     e,    &
3893                                                                     sina, &
3894                                                                     cosa
3895
3896    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: muu, &
3897                                                                     muv
3898
3899
3900    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm, &
3901                                                                   fzp
3902
3903    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: u_base,  &
3904                                                                   v_base,  &
3905                                                                   z_base
3906
3907    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: c1h, c2h
3908
3909    ! Local storage
3910
3911    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) :: ru, &
3912                                                       rv
3913
3914    REAL  :: z_at_u, z_at_v, wkp1, wk, wkm1
3915
3916    ! Local indices.
3917
3918    INTEGER :: i, j , k, ktf
3919    INTEGER :: i_start, i_end, j_start, j_end
3920
3921    LOGICAL :: specified
3922
3923 !<DESCRIPTION>
3924 !
3925 !  perturbation_coriolis calculates the large timestep tendency terms in the
3926 !  u, v, and w momentum equations arise from the coriolis force.  This version
3927 !  subtracts off the horizontal velocities from the initial sounding when
3928 !  computing the forcing terms, hence "perturbation" coriolis.
3929 !
3930 !</DESCRIPTION>
3931
3932    specified = .false.
3933    if(config_flags%specified .or. config_flags%nested) specified = .true.
3934
3935    ktf=MIN(kte,kde-1)
3936
3937 ! coriolis for u-momentum equation
3938
3939    i_start = its
3940    i_end   = ite
3941    IF ( config_flags%open_xs .or. specified .or. &
3942         config_flags%nested) i_start = MAX(ids+1,its)
3943    IF ( config_flags%open_xe .or. specified .or. &
3944         config_flags%nested) i_end   = MIN(ide-1,ite)
3945       IF ( config_flags%periodic_x ) i_start = its
3946       IF ( config_flags%periodic_x ) i_end = ite
3947
3948 !  compute perturbation mu*v for use in u momentum equation
3949
3950    DO j = jts, MIN(jte,jde-1)+1
3951    DO k=kts+1,ktf-1
3952    DO i = i_start-1, i_end
3953      z_at_v = 0.25*( phb(i,k,j  )+phb(i,k+1,j  )  &
3954                     +phb(i,k,j-1)+phb(i,k+1,j-1)  &
3955                     +ph(i,k,j  )+ph(i,k+1,j  )    &
3956                     +ph(i,k,j-1)+ph(i,k+1,j-1))/g
3957      wkp1 = min(1.,max(0.,z_at_v-z_base(k))/(z_base(k+1)-z_base(k)))
3958      wkm1 = min(1.,max(0.,z_base(k)-z_at_v)/(z_base(k)-z_base(k-1)))
3959      wk   = 1.-wkp1-wkm1
3960      rv(i,k,j) = rv_in(i,k,j) - (c1h(k)*muv(i,j)+c2h(k))*(            &
3961                                   wkm1*v_base(k-1)    &
3962                                  +wk  *v_base(k  )    &
3963                                  +wkp1*v_base(k+1)   )
3964    ENDDO
3965    ENDDO
3966    ENDDO
3967
3968
3969 !  pick up top and bottom v
3970
3971    DO j = jts, MIN(jte,jde-1)+1
3972    DO i = i_start-1, i_end
3973
3974      k = kts
3975      z_at_v = 0.25*( phb(i,k,j  )+phb(i,k+1,j  )  &
3976                     +phb(i,k,j-1)+phb(i,k+1,j-1)  &
3977                     +ph(i,k,j  )+ph(i,k+1,j  )    &
3978                     +ph(i,k,j-1)+ph(i,k+1,j-1))/g
3979      wkp1 = min(1.,max(0.,z_at_v-z_base(k))/(z_base(k+1)-z_base(k)))
3980      wk   = 1.-wkp1
3981      rv(i,k,j) = rv_in(i,k,j) - (c1h(k)*muv(i,j)+c2h(k))*(            &
3982                                  +wk  *v_base(k  )    &
3983                                  +wkp1*v_base(k+1)   )
3984
3985      k = ktf
3986      z_at_v = 0.25*( phb(i,k,j  )+phb(i,k+1,j  )  &
3987                     +phb(i,k,j-1)+phb(i,k+1,j-1)  &
3988                     +ph(i,k,j  )+ph(i,k+1,j  )    &
3989                     +ph(i,k,j-1)+ph(i,k+1,j-1))/g
3990      wkm1 = min(1.,max(0.,z_base(k)-z_at_v)/(z_base(k)-z_base(k-1)))
3991      wk   = 1.-wkm1
3992      rv(i,k,j) = rv_in(i,k,j) - (c1h(k)*muv(i,j)+c2h(k))*(            &
3993                                   wkm1*v_base(k-1)    &
3994                                  +wk  *v_base(k  )   )
3995
3996    ENDDO
3997    ENDDO
3998
3999 !  compute coriolis forcing for u
4000
4001 !  Map scale factors: see comments above for Coriolis
4002
4003    DO j = jts, MIN(jte,jde-1)
4004
4005    DO k=kts,ktf
4006      DO i = i_start, i_end
4007        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)) &
4008          *0.25*(rv(i-1,k,j+1)+rv(i,k,j+1)+rv(i-1,k,j)+rv(i,k,j)) &
4009              - 0.5*(e(i,j)+e(i-1,j))*0.5*(cosa(i,j)+cosa(i-1,j)) &
4010          *0.25*(rw(i-1,k+1,j)+rw(i-1,k,j)+rw(i,k+1,j)+rw(i,k,j))
4011      ENDDO
4012    ENDDO
4013
4014 ! boundary loops for perturbation coriolis is needed for open bdy  (20110225 JD)
4015    IF ( (config_flags%open_xs) .and. (its == ids) ) THEN
4016
4017      DO k=kts,ktf
4018
4019        ru_tend(its,k,j)=ru_tend(its,k,j) + (msfux(its,j)/msfuy(its,j))*0.5*(f(its,j)+f(its,j))   &
4020          *0.25*(rv(its,k,j+1)+rv(its,k,j+1)+rv(its,k,j)+rv(its,k,j)) &
4021              - 0.5*(e(its,j)+e(its,j))*0.5*(cosa(its,j)+cosa(its,j)) &
4022          *0.25*(rw(its,k+1,j)+rw(its,k,j)+rw(its,k+1,j)+rw(its,k,j))
4023
4024      ENDDO
4025
4026    ENDIF
4027
4028    IF ( (config_flags%open_xe) .and. (ite == ide) ) THEN
4029
4030      DO k=kts,ktf
4031
4032        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)) &
4033          *0.25*(rv(ite-1,k,j+1)+rv(ite-1,k,j+1)+rv(ite-1,k,j)+rv(ite-1,k,j)) &
4034              - 0.5*(e(ite-1,j)+e(ite-1,j))*0.5*(cosa(ite-1,j)+cosa(ite-1,j)) &
4035          *0.25*(rw(ite-1,k+1,j)+rw(ite-1,k,j)+rw(ite-1,k+1,j)+rw(ite-1,k,j))
4036
4037      ENDDO
4038
4039    ENDIF
4040
4041    ENDDO
4042
4043 !  coriolis term for v-momentum equation
4044 !  Map scale factors: see comments above for Coriolis
4045
4046    j_start = jts
4047    j_end   = jte
4048
4049    IF ( config_flags%open_ys .or. specified .or. &
4050         config_flags%nested .or. config_flags%polar) j_start = MAX(jds+1,jts)
4051    IF ( config_flags%open_ye .or. specified .or. &
4052         config_flags%nested .or. config_flags%polar) j_end   = MIN(jde-1,jte)
4053
4054 !  compute perturbation mu*u for use in v momentum equation
4055
4056    DO j = j_start-1,j_end
4057    DO k=kts+1,ktf-1
4058    DO i = its, MIN(ite,ide-1)+1
4059      z_at_u = 0.25*( phb(i  ,k,j)+phb(i  ,k+1,j)  &
4060                     +phb(i-1,k,j)+phb(i-1,k+1,j)  &
4061                     +ph(i  ,k,j)+ph(i  ,k+1,j)    &
4062                     +ph(i-1,k,j)+ph(i-1,k+1,j))/g
4063      wkp1 = min(1.,max(0.,z_at_u-z_base(k))/(z_base(k+1)-z_base(k)))
4064      wkm1 = min(1.,max(0.,z_base(k)-z_at_u)/(z_base(k)-z_base(k-1)))
4065      wk   = 1.-wkp1-wkm1
4066      ru(i,k,j) = ru_in(i,k,j) - (c1h(k)*muu(i,j)+c2h(k))*(            &
4067                                   wkm1*u_base(k-1)    &
4068                                  +wk  *u_base(k  )    &
4069                                  +wkp1*u_base(k+1)   )
4070    ENDDO
4071    ENDDO
4072    ENDDO
4073
4074 !  pick up top and bottom u
4075
4076    DO j = j_start-1,j_end
4077    DO i = its, MIN(ite,ide-1)+1
4078
4079      k = kts
4080      z_at_u = 0.25*( phb(i  ,k,j)+phb(i  ,k+1,j)  &
4081                     +phb(i-1,k,j)+phb(i-1,k+1,j)  &
4082                     +ph(i  ,k,j)+ph(i  ,k+1,j)    &
4083                     +ph(i-1,k,j)+ph(i-1,k+1,j))/g
4084      wkp1 = min(1.,max(0.,z_at_u-z_base(k))/(z_base(k+1)-z_base(k)))
4085      wk   = 1.-wkp1
4086      ru(i,k,j) = ru_in(i,k,j) - (c1h(k)*muu(i,j)+c2h(k))*(            &
4087                                  +wk  *u_base(k  )    &
4088                                  +wkp1*u_base(k+1)   )
4089
4090
4091      k = ktf
4092      z_at_u = 0.25*( phb(i  ,k,j)+phb(i  ,k+1,j)  &
4093                     +phb(i-1,k,j)+phb(i-1,k+1,j)  &
4094                     +ph(i  ,k,j)+ph(i  ,k+1,j)    &
4095                     +ph(i-1,k,j)+ph(i-1,k+1,j))/g
4096      wkm1 = min(1.,max(0.,z_base(k)-z_at_u)/(z_base(k)-z_base(k-1)))
4097      wk   = 1.-wkm1
4098      ru(i,k,j) = ru_in(i,k,j) - (c1h(k)*muu(i,j)+c2h(k))*(            &
4099                                   wkm1*u_base(k-1)    &
4100                                  +wk  *u_base(k  )   )
4101
4102    ENDDO
4103    ENDDO
4104
4105 !  compute coriolis forcing for v momentum equation
4106 !  Map scale factors: see comments above for Coriolis
4107
4108 ! boundary loops for perturbation coriolis is needed for open bdy  (20110225 JD)
4109    IF ( (config_flags%open_ys) .and. (jts == jds) ) THEN
4110
4111      DO k=kts,ktf
4112      DO i=its,MIN(ide-1,ite)
4113
4114         rv_tend(i,k,jts)=rv_tend(i,k,jts) - (msfvy(i,jts)/msfvx(i,jts))*0.5*(f(i,jts)+f(i,jts))    &
4115          *0.25*(ru(i,k,jts)+ru(i+1,k,jts)+ru(i,k,jts)+ru(i+1,k,jts))   &
4116              + (msfvy(i,jts)/msfvx(i,jts))*0.5*(e(i,jts)+e(i,jts))*0.5*(sina(i,jts)+sina(i,jts))   &
4117              *0.25*(rw(i,k+1,jts)+rw(i,k,jts)+rw(i,k+1,jts)+rw(i,k,jts))
4118
4119      ENDDO
4120      ENDDO
4121
4122    ENDIF
4123
4124    DO j=j_start, j_end
4125    DO k=kts,ktf
4126    DO i=its,MIN(ide-1,ite)
4127
4128       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))    &
4129        *0.25*(ru(i,k,j)+ru(i+1,k,j)+ru(i,k,j-1)+ru(i+1,k,j-1)) &
4130            + (msfvy(i,j)/msfvx(i,j))*0.5*(e(i,j)+e(i,j-1))*0.5*(sina(i,j)+sina(i,j-1)) &
4131            *0.25*(rw(i,k+1,j-1)+rw(i,k,j-1)+rw(i,k+1,j)+rw(i,k,j))
4132
4133    ENDDO
4134    ENDDO
4135    ENDDO
4136
4137
4138 ! boundary loops for perturbation coriolis is needed for open bdy  (20110225 JD)
4139    IF ( (config_flags%open_ye) .and. (jte == jde) ) THEN
4140
4141      DO k=kts,ktf
4142      DO i=its,MIN(ide-1,ite)
4143
4144         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))        &
4145          *0.25*(ru(i,k,jte-1)+ru(i+1,k,jte-1)+ru(i,k,jte-1)+ru(i+1,k,jte-1))   &
4146              + (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))   &
4147              *0.25*(rw(i,k+1,jte-1)+rw(i,k,jte-1)+rw(i,k+1,jte-1)+rw(i,k,jte-1))
4148
4149      ENDDO
4150      ENDDO
4151
4152    ENDIF
4153
4154 ! coriolis term for w-mometum
4155 !  Map scale factors: see comments above for Coriolis
4156
4157    DO j=jts,MIN(jte, jde-1)
4158    DO k=kts+1,ktf
4159    DO i=its,MIN(ite, ide-1)
4160
4161        rw_tend(i,k,j)=rw_tend(i,k,j) + e(i,j)*           &
4162           (cosa(i,j)*0.5*(fzm(k)*(ru(i,k,j)+ru(i+1,k,j)) &
4163           +fzp(k)*(ru(i,k-1,j)+ru(i+1,k-1,j)))           &
4164           -(msftx(i,j)/msfty(i,j))*sina(i,j)*0.5*(fzm(k)*(rv(i,k,j)+rv(i,k,j+1)) &
4165           +fzp(k)*(rv(i,k-1,j)+rv(i,k-1,j+1))))
4166
4167    ENDDO
4168    ENDDO
4169    ENDDO
4170
4171 END SUBROUTINE perturbation_coriolis
4172
4173 !------------------------------------------------------------------------------
4174
4175 SUBROUTINE curvature ( ru, rv, rw, u, v, w, ru_tend, rv_tend, rw_tend, &
4176                         config_flags,                                       &
4177                         msfux, msfuy, msfvx, msfvy, msftx, msfty,       &
4178                         xlat, fzm, fzp, rdx, rdy,                       &
4179                         ids, ide, jds, jde, kds, kde,                   &
4180                         ims, ime, jms, jme, kms, kme,                   &
4181                         its, ite, jts, jte, kts, kte                   )
4182
4183
4184    IMPLICIT NONE
4185
4186    ! Input data
4187
4188    TYPE(grid_config_rec_type) ,           INTENT(IN   ) :: config_flags
4189
4190    INTEGER ,                  INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
4191                                                ims, ime, jms, jme, kms, kme, &
4192                                                its, ite, jts, jte, kts, kte
4193
4194    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) ,                     &
4195                                                INTENT(INOUT) :: ru_tend, &
4196                                                                 rv_tend, &
4197                                                                 rw_tend
4198
4199    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) ,                     &
4200                                                INTENT(IN   ) :: ru,      &
4201                                                                 rv,      &
4202                                                                 rw,      &
4203                                                                 u,       &
4204                                                                 v,       &
4205                                                                 w
4206
4207    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,    &
4208                                                                 msfuy,    &
4209                                                                 msfvx,    &
4210                                                                 msfvy,    &
4211                                                                 msftx,    &
4212                                                                 msfty,    &
4213                                                                 xlat
4214
4215    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,     &
4216                                                                 fzp
4217
4218    REAL ,                                      INTENT(IN   ) :: rdx,     &
4219                                                                 rdy
4220
4221    ! Local data
4222
4223 !   INTEGER :: i, j, k, itf, jtf, ktf, kp1, im, ip, jm, jp
4224    INTEGER :: i, j, k, itf, jtf, ktf
4225    INTEGER :: i_start, i_end, j_start, j_end
4226 !   INTEGER :: irmin, irmax, jrmin, jrmax
4227
4228    REAL , DIMENSION( its-1:ite , kts:kte, jts-1:jte ) :: vxgm
4229
4230    LOGICAL :: specified
4231
4232 !<DESCRIPTION>
4233 !
4234 !  curvature calculates the large timestep tendency terms in the
4235 !  u, v, and w momentum equations arise from the curvature terms.
4236 !
4237 !</DESCRIPTION>
4238
4239    specified = .false.
4240    if(config_flags%specified .or. config_flags%nested) specified = .true.
4241
4242       itf=MIN(ite,ide-1)
4243       jtf=MIN(jte,jde-1)
4244       ktf=MIN(kte,kde-1)
4245
4246 !   irmin = ims
4247 !   irmax = ime
4248 !   jrmin = jms
4249 !   jrmax = jme
4250 !   IF ( config_flags%open_xs ) irmin = ids
4251 !   IF ( config_flags%open_xe ) irmax = ide-1
4252 !   IF ( config_flags%open_ys ) jrmin = jds
4253 !   IF ( config_flags%open_ye ) jrmax = jde-1
4254
4255 ! Define v cross grad m at scalar points - vxgm(i,j)
4256
4257    i_start = its-1
4258    i_end   = ite
4259    j_start = jts-1
4260    j_end   = jte
4261
4262    IF ( ( config_flags%open_xs .or. specified .or. &
4263         config_flags%nested) .and. (its == ids) ) i_start = its
4264    IF ( ( config_flags%open_xe .or. specified .or. &
4265         config_flags%nested) .and. (ite == ide) ) i_end   = ite-1
4266    IF ( ( config_flags%open_ys .or. specified .or. &
4267         config_flags%nested .or. config_flags%polar) .and. (jts == jds) ) j_start = jts
4268    IF ( ( config_flags%open_ye .or. specified .or. &
4269         config_flags%nested .or. config_flags%polar) .and. (jte == jde) ) j_end   = jte-1
4270       IF ( config_flags%periodic_x ) i_start = its-1
4271       IF ( config_flags%periodic_x ) i_end = ite
4272
4273    DO j=j_start, j_end
4274    DO k=kts,ktf
4275    DO i=i_start, i_end
4276 !     Map scale factor notes:
4277 !     msf...y is constant everywhere for cylindrical map projection
4278 !     msf...x varies with y only
4279 !     But we know that this is not = 0 for cylindrical,
4280 !     therefore use msfvX in 1st line
4281 !     which => by symmetry use msfuY in 2nd line - ???
4282       vxgm(i,k,j)=0.5*(u(i,k,j)+u(i+1,k,j))*(msfvx(i,j+1)-msfvx(i,j))*rdy - &
4283                   0.5*(v(i,k,j)+v(i,k,j+1))*(msfuy(i+1,j)-msfuy(i,j))*rdx
4284    ENDDO
4285    ENDDO
4286    ENDDO
4287
4288 !  Pick up the boundary rows for open (radiation) lateral b.c.
4289 !  Rather crude at present, we are assuming there is no
4290 !    variation in this term at the boundary.
4291
4292    IF ( ( config_flags%open_xs .or. (specified .AND. .NOT. config_flags%periodic_x) .or. &
4293         config_flags%nested) .and. (its == ids) ) THEN
4294
4295      DO j = jts, jte-1
4296      DO k = kts, ktf
4297        vxgm(its-1,k,j) =  vxgm(its,k,j)
4298      ENDDO
4299      ENDDO
4300
4301    ENDIF
4302
4303    IF ( ( config_flags%open_xe .or. (specified .AND. .NOT. config_flags%periodic_x) .or. &
4304         config_flags%nested) .and. (ite == ide) ) THEN
4305
4306      DO j = jts, jte-1
4307      DO k = kts, ktf
4308        vxgm(ite,k,j) =  vxgm(ite-1,k,j)
4309      ENDDO
4310      ENDDO
4311
4312    ENDIF
4313
4314 !  Polar boundary condition:
4315 !  The following change is needed in case one tries using the vxgm route with
4316 !  polar B.C.'s in the future, but not needed if 'tan' used
4317    IF ( ( config_flags%open_ys .or. specified .or. &
4318         config_flags%nested .or. config_flags%polar) .and. (jts == jds) ) THEN
4319
4320      DO k = kts, ktf
4321      DO i = its-1, ite
4322        vxgm(i,k,jts-1) =  vxgm(i,k,jts)
4323      ENDDO
4324      ENDDO
4325
4326    ENDIF
4327
4328 !  Polar boundary condition:
4329 !  The following change is needed in case one tries using the vxgm route with
4330 !  polar B.C.'s in the future, but not needed if 'tan' used
4331    IF ( ( config_flags%open_ye .or. specified .or. &
4332         config_flags%nested .or. config_flags%polar) .and. (jte == jde) ) THEN
4333
4334      DO k = kts, ktf
4335      DO i = its-1, ite
4336        vxgm(i,k,jte) =  vxgm(i,k,jte-1)
4337      ENDDO
4338      ENDDO
4339
4340    ENDIF
4341
4342 !  curvature term for u momentum eqn.
4343
4344 !  Map scale factor notes:
4345 !  ADT eqn 44, RHS terms 4 and 5, in cylindrical: mu u v tan(lat)/(a my)
4346 !                                               - mu u w /(a my)
4347 !  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
4348 !   => terms are:
4349 !  (mx/my)*u rv tan(lat) / a - u rw / a = (u/a)*[(mx/my) rv tan(lat) - rw]
4350 !  ru v tan(lat) / a - u rw / a
4351 !  xlat defined with end points half grid space from pole,
4352 !  hence are on u latitude points
4353
4354    i_start = its
4355    IF ( config_flags%open_xs .or. specified .or. &
4356         config_flags%nested) i_start = MAX ( ids+1 , its )
4357    IF ( config_flags%open_xe .or. specified .or. &
4358         config_flags%nested) i_end   = MIN ( ide-1 , ite )
4359       IF ( config_flags%periodic_x ) i_start = its
4360       IF ( config_flags%periodic_x ) i_end = ite
4361
4362 !  Polar boundary condition
4363    IF ((config_flags%map_proj == 6) .OR. (config_flags%polar)) THEN
4364
4365       DO j=jts,MIN(jde-1,jte)
4366       DO k=kts,ktf
4367       DO i=i_start,i_end
4368
4369             ru_tend(i,k,j)=ru_tend(i,k,j) + u(i,k,j)*reradius*                 ( &
4370                         (msfux(i,j)/msfuy(i,j))*0.25*(rv(i-1,k,j+1)+rv(i,k,j+1)+ &
4371                                     rv(i-1,k,j)+rv(i,k,j))*tan(xlat(i,j)*degrad) &
4372                         - 0.25*(rw(i-1,k+1,j)+rw(i-1,k,j)+rw(i,k+1,j)+rw(i,k,j)) )
4373       ENDDO
4374       ENDDO
4375       ENDDO
4376
4377    ELSE  ! normal code
4378
4379
4380       DO j=jts,MIN(jde-1,jte)
4381       DO k=kts,ktf
4382       DO i=i_start,i_end
4383
4384          ru_tend(i,k,j)=ru_tend(i,k,j) + 0.5*(vxgm(i,k,j)+vxgm(i-1,k,j)) &
4385                  *0.25*(rv(i-1,k,j+1)+rv(i,k,j+1)+rv(i-1,k,j)+rv(i,k,j)) &
4386                   - u(i,k,j)*reradius &
4387                  *0.25*(rw(i-1,k+1,j)+rw(i-1,k,j)+rw(i,k+1,j)+rw(i,k,j))
4388
4389       ENDDO
4390       ENDDO
4391       ENDDO
4392
4393    END IF
4394
4395 !  curvature term for v momentum eqn.
4396
4397 !  Map scale factor notes
4398 !  ADT eqn 45, RHS terms 4 and 5, in cylindrical:  - mu u*u tan(lat)/(a mx)
4399 !                                               - mu v w /(a mx)
4400 !  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
4401 !  terms are:
4402 !  - (my/mx)*u ru tan(lat) / a - (my/mx)*v rw / a
4403 !  = - [my/(mx*a)]*[u ru tan(lat) + v rw]
4404 !  - (1/a)*[(my/mx)*u ru tan(lat) + w rv]
4405 !  xlat defined with end points half grid space from pole, hence are on
4406 !  u latitude points => av here
4407 !
4408 !  in original wrf, there was a sign error for the rw contribution
4409
4410    j_start = jts
4411    IF ( config_flags%open_ys .or. specified .or. &
4412         config_flags%nested .or. config_flags%polar) j_start = MAX ( jds+1 , jts )
4413    IF ( config_flags%open_ye .or. specified .or. &
4414         config_flags%nested .or. config_flags%polar) j_end   = MIN ( jde-1 , jte )
4415
4416    IF ((config_flags%map_proj == 6) .OR. (config_flags%polar)) THEN
4417
4418       DO j=j_start,j_end
4419       DO k=kts,ktf
4420       DO i=its,MIN(ite,ide-1)
4421             rv_tend(i,k,j)=rv_tend(i,k,j) - (msfvy(i,j)/msfvx(i,j))*reradius*   (  &
4422                         0.25*(u(i,k,j)+u(i+1,k,j)+u(i,k,j-1)+u(i+1,k,j-1))*     &
4423                         tan((xlat(i,j)+xlat(i,j-1))*0.5*degrad)*                &
4424                         0.25*(ru(i,k,j)+ru(i+1,k,j)+ru(i,k,j-1)+ru(i+1,k,j-1))  &
4425                        + v(i,k,j)*0.25*(rw(i,k+1,j-1)+rw(i,k,j-1)+              &
4426                                                       rw(i,k+1,j)+rw(i,k,j))    )
4427       ENDDO
4428       ENDDO
4429       ENDDO
4430
4431    ELSE  ! normal code
4432
4433       DO j=j_start,j_end
4434       DO k=kts,ktf
4435       DO i=its,MIN(ite,ide-1)
4436
4437          rv_tend(i,k,j)=rv_tend(i,k,j) - 0.5*(vxgm(i,k,j)+vxgm(i,k,j-1)) &
4438                  *0.25*(ru(i,k,j)+ru(i+1,k,j)+ru(i,k,j-1)+ru(i+1,k,j-1)) &
4439                        - (msfvy(i,j)/msfvx(i,j))*v(i,k,j)*reradius       &
4440                  *0.25*(rw(i,k+1,j-1)+rw(i,k,j-1)+rw(i,k+1,j)+rw(i,k,j))
4441
4442       ENDDO
4443       ENDDO
4444       ENDDO
4445
4446    END IF
4447
4448 !  curvature term for vertical momentum eqn.
4449
4450 !  Notes on map scale factors:
4451 !  ADT eqn 46, RHS term 4: [mu/(a my)]*[u*u + v*v]
4452 !  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
4453 !  terms are: u ru / a + (mx/my)v rv / a
4454
4455    DO j=jts,MIN(jte,jde-1)
4456    DO k=MAX(2,kts),ktf
4457    DO i=its,MIN(ite,ide-1)
4458
4459       rw_tend(i,k,j)=rw_tend(i,k,j) + reradius*                              &
4460     (0.5*(fzm(k)*(ru(i,k,j)+ru(i+1,k,j))+fzp(k)*(ru(i,k-1,j)+ru(i+1,k-1,j))) &
4461     *0.5*(fzm(k)*( u(i,k,j) +u(i+1,k,j))+fzp(k)*( u(i,k-1,j) +u(i+1,k-1,j)))     &
4462     +(msftx(i,j)/msfty(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))) &
4463     *0.5*(fzm(k)*( v(i,k,j) +v(i,k,j+1))+fzp(k)*( v(i,k-1,j) +v(i,k-1,j+1))))
4464
4465    ENDDO
4466    ENDDO
4467    ENDDO
4468
4469 END SUBROUTINE curvature
4470
4471 #if 0
4472 DANGER - this is a bad routine to have laying around - someone could use it
4473 !------------------------------------------------------------------------------
4474
4475 SUBROUTINE decouple ( rr, rfield, field, name, config_flags, &
4476                       fzm, fzp,                          &
4477                       ids, ide, jds, jde, kds, kde,      &
4478                       ims, ime, jms, jme, kms, kme,      &
4479                       its, ite, jts, jte, kts, kte      )
4480
4481    IMPLICIT NONE
4482
4483    ! Input data
4484
4485    TYPE(grid_config_rec_type) ,           INTENT(IN   ) :: config_flags
4486
4487    INTEGER ,                                   INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
4488                                                                 ims, ime, jms, jme, kms, kme, &
4489                                                                 its, ite, jts, jte, kts, kte
4490
4491    CHARACTER(LEN=1) ,                          INTENT(IN   ) :: name
4492
4493    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: rfield
4494
4495    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: rr
4496
4497    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT  ) :: field
4498
4499    REAL , DIMENSION( kms:kme ) , INTENT(IN   ) :: fzm, fzp
4500
4501    ! Local data
4502
4503    INTEGER :: i, j, k, itf, jtf, ktf
4504
4505 !<DESCRIPTION>
4506 !
4507 !  decouple decouples a variable from the column dry-air mass.
4508 !
4509 !</DESCRIPTION>
4510
4511    ktf=MIN(kte,kde-1)
4512
4513    IF (name .EQ. 'u')THEN
4514       itf=ite
4515       jtf=MIN(jte,jde-1)
4516
4517       DO j=jts,jtf
4518       DO k=kts,ktf
4519       DO i=its,itf
4520          field(i,k,j)=rfield(i,k,j)/(0.5*(rr(i,k,j)+rr(i-1,k,j)))
4521       ENDDO
4522       ENDDO
4523       ENDDO
4524
4525    ELSE IF (name .EQ. 'v')THEN
4526       itf=MIN(ite,ide-1)
4527       jtf=jte
4528
4529       DO j=jts,jtf
4530       DO k=kts,ktf
4531         DO i=its,itf
4532              field(i,k,j)=rfield(i,k,j)/(0.5*(rr(i,k,j)+rr(i,k,j-1)))
4533         ENDDO
4534       ENDDO
4535       ENDDO
4536
4537    ELSE IF (name .EQ. 'w')THEN
4538       itf=MIN(ite,ide-1)
4539       jtf=MIN(jte,jde-1)
4540       DO j=jts,jtf
4541       DO k=kts+1,ktf
4542       DO i=its,itf
4543          field(i,k,j)=rfield(i,k,j)/(fzm(k)*rr(i,k,j)+fzp(k)*rr(i,k-1,j))
4544       ENDDO
4545       ENDDO
4546       ENDDO
4547
4548       DO j=jts,jtf
4549       DO i=its,itf
4550         field(i,kte,j) = 0.
4551       ENDDO
4552       ENDDO
4553
4554    ELSE
4555       itf=MIN(ite,ide-1)
4556       jtf=MIN(jte,jde-1)
4557    ! For theta we will decouple tb and tp and add them to give t afterwards
4558       DO j=jts,jtf
4559       DO k=kts,ktf
4560       DO i=its,itf
4561          field(i,k,j)=rfield(i,k,j)/rr(i,k,j)
4562       ENDDO
4563       ENDDO
4564       ENDDO
4565
4566    ENDIF
4567
4568 END SUBROUTINE decouple
4569 #endif
4570
4571 !-------------------------------------------------------------------------------
4572
4573 SUBROUTINE zero_tend ( tendency,                     &
4574                        ids, ide, jds, jde, kds, kde, &
4575                        ims, ime, jms, jme, kms, kme, &
4576                        its, ite, jts, jte, kts, kte )
4577
4578
4579    IMPLICIT NONE
4580
4581    ! Input data
4582
4583    INTEGER ,                                   INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
4584                                                                 ims, ime, jms, jme, kms, kme, &
4585                                                                 its, ite, jts, jte, kts, kte
4586
4587    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
4588
4589    ! Local data
4590
4591    INTEGER :: i, j, k, itf, jtf, ktf
4592
4593 !<DESCRIPTION>
4594 !
4595 !  zero_tend sets the input tendency array to zero.
4596 !
4597 !</DESCRIPTION>
4598
4599       DO j = jts, jte
4600       DO k = kts, kte
4601       DO i = its, ite
4602         tendency(i,k,j) = 0.
4603       ENDDO
4604       ENDDO
4605       ENDDO
4606
4607       END SUBROUTINE zero_tend
4608
4609 !-------------------------------------------------------------------------------
4610
4611 SUBROUTINE zero_tend2d( tendency,                     &
4612                        ids, ide, jds, jde, kds, kde, &
4613                        ims, ime, jms, jme, kms, kme, &
4614                        its, ite, jts, jte, kts, kte )
4615
4616
4617    IMPLICIT NONE
4618
4619    ! Input data
4620
4621    INTEGER ,                                   INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
4622                                                                 ims, ime, jms, jme, kms, kme, &
4623                                                                 its, ite, jts, jte, kts, kte
4624
4625    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: tendency
4626
4627    ! Local data
4628
4629    INTEGER :: i, j, k, itf, jtf, ktf
4630
4631 !<DESCRIPTION>
4632 !
4633 !  zero_tend sets the input tendency array to zero.
4634 !
4635 !</DESCRIPTION>
4636
4637       DO j = jts, jte
4638       DO i = its, ite
4639         tendency(i,j) = 0.
4640       ENDDO
4641       ENDDO
4642
4643       END SUBROUTINE zero_tend2d
4644
4645 !-------------------------------------------------------------------------------
4646
4647 ! Sets the an array on the polar v point(s) to zero
4648 SUBROUTINE zero_pole ( field,                        &
4649                        ids, ide, jds, jde, kds, kde, &
4650                        ims, ime, jms, jme, kms, kme, &
4651                        its, ite, jts, jte, kts, kte )
4652
4653
4654   IMPLICIT NONE
4655
4656   ! Input data
4657
4658   INTEGER , INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
4659                              ims, ime, jms, jme, kms, kme, &
4660                              its, ite, jts, jte, kts, kte
4661
4662   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: field
4663
4664   ! Local data
4665
4666   INTEGER :: i, k
4667
4668   IF (jts == jds) THEN
4669      DO k = kts, kte
4670      DO i = its-1, ite+1
4671         field(i,k,jts) = 0.
4672      END DO
4673      END DO
4674   END IF
4675   IF (jte == jde) THEN
4676      DO k = kts, kte
4677      DO i = its-1, ite+1
4678         field(i,k,jte) = 0.
4679      END DO
4680      END DO
4681   END IF
4682
4683 END SUBROUTINE zero_pole
4684
4685 !-------------------------------------------------------------------------------
4686 ! Sets the an array on the polar v point(s)
4687 SUBROUTINE pole_point_bc ( field,                        &
4688                        ids, ide, jds, jde, kds, kde, &
4689                        ims, ime, jms, jme, kms, kme, &
4690                        its, ite, jts, jte, kts, kte )
4691
4692
4693   IMPLICIT NONE
4694
4695   ! Input data
4696
4697   INTEGER , INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
4698                              ims, ime, jms, jme, kms, kme, &
4699                              its, ite, jts, jte, kts, kte
4700
4701   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: field
4702
4703   ! Local data
4704
4705   INTEGER :: i, k
4706
4707   IF (jts == jds) THEN
4708      DO k = kts, kte
4709      DO i = its, ite
4710 !        field(i,k,jts) = 2*field(i,k,jts+1) - field(i,k,jts+2)
4711         field(i,k,jts) = field(i,k,jts+1)
4712      END DO
4713      END DO
4714   END IF
4715   IF (jte == jde) THEN
4716      DO k = kts, kte
4717      DO i = its, ite
4718 !        field(i,k,jte) = 2*field(i,k,jte-1) - field(i,k,jte-2)
4719         field(i,k,jte) = field(i,k,jte-1)
4720      END DO
4721      END DO
4722   END IF
4723
4724 END SUBROUTINE pole_point_bc
4725
4726 !======================================================================
4727 !   physics prep routines
4728 !======================================================================
4729
4730    SUBROUTINE phy_prep ( config_flags,                                &  ! input
4731                          mut, muu, muv,                               &
4732                          c1h, c2h, c1f, c2f,                          &
4733                          u, v, p, pb, alt, ph,                        &  ! input
4734                          phb, t, moist, n_moist,                      &  ! input
4735                          rho, th_phy, th_phy_m_t0,                    &  ! output
4736                          p_phy , pi_phy ,                             &  ! output
4737                          u_phy, v_phy, p8w, t_phy, t8w,               &  ! output
4738                          z, z_at_w, dz8w,                             &  ! output
4739                          p_hyd, p_hyd_w, dnw,                         &  ! output
4740                          fzm, fzp, znw, p_top,                        &  ! params
4741                          ids, ide, jds, jde, kds, kde,                &
4742                          ims, ime, jms, jme, kms, kme,                &
4743                          its, ite, jts, jte, kts, kte                )
4744 !----------------------------------------------------------------------
4745    IMPLICIT NONE
4746 !----------------------------------------------------------------------
4747
4748    TYPE(grid_config_rec_type) ,     INTENT(IN   ) :: config_flags
4749
4750    INTEGER ,        INTENT(IN   ) ::   ids, ide, jds, jde, kds, kde, &
4751                                        ims, ime, jms, jme, kms, kme, &
4752                                        its, ite, jts, jte, kts, kte
4753    INTEGER ,          INTENT(IN   ) :: n_moist
4754
4755    REAL, DIMENSION( ims:ime, kms:kme , jms:jme , n_moist ), INTENT(IN) :: moist
4756
4757
4758    REAL , DIMENSION( ims:ime, jms:jme ), INTENT(IN   )   ::     mut, muu, muv
4759
4760    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) ,                 &
4761           INTENT(  OUT)                                  ::   u_phy, &
4762                                                               v_phy, &
4763                                                              pi_phy, &
4764                                                               p_phy, &
4765                                                                 p8w, &
4766                                                               t_phy, &
4767                                                              th_phy, &
4768                                                         th_phy_m_t0, &
4769                                                                 t8w, &
4770                                                                 rho, &
4771                                                                   z, &
4772                                                                dz8w, &
4773                                                               z_at_w
4774
4775    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) ,                 &
4776           INTENT(  OUT)                                  ::   p_hyd, &
4777                                                               p_hyd_w
4778
4779    REAL , INTENT(IN   )                                  ::   p_top
4780
4781    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) ,                 &
4782           INTENT(IN   )                                  ::      pb, &
4783                                                                   p, &
4784                                                                   u, &
4785                                                                   v, &
4786                                                                 alt, &
4787                                                                  ph, &
4788                                                                 phb, &
4789                                                                   t
4790
4791
4792    REAL , DIMENSION( kms:kme ) ,           INTENT(IN   ) ::     fzm,   &
4793                                                                 fzp
4794
4795    REAL , DIMENSION( kms:kme ) ,           INTENT(IN   ) ::     znw, &
4796                                                                 dnw
4797
4798    REAL, DIMENSION( kms:kme ) ,            INTENT(IN   ) ::     c1h, c2h, c1f, c2f
4799
4800    REAL, DIMENSION( kms:kme ) :: c1, c2
4801    INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, j_startv
4802    INTEGER :: i, j, k
4803    REAL    :: w1, w2, z0, z1, z2
4804    REAL    :: qtot
4805    INTEGER :: n
4806
4807 !-----------------------------------------------------------------------
4808
4809 !<DESCRIPTION>
4810 !
4811 !  phys_prep calculates a number of diagnostic quantities needed by
4812 !  the physics routines.
4813 !
4814 !</DESCRIPTION>
4815
4816     c1 = c1h
4817     c2 = c2h
4818 !  set up loop bounds for this grid's boundary conditions
4819
4820     i_start = its
4821     i_end   = min( ite,ide-1 )
4822     j_start = jts
4823     j_end   = min( jte,jde-1 )
4824
4825     k_start = kts
4826     k_end = min( kte, kde-1 )
4827
4828 !  compute thermodynamics and velocities at pressure points (or half levels)
4829
4830     IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN
4831        do j = j_start,j_end
4832        do k = k_start, k_end
4833        do i = i_start, i_end
4834          th_phy(i,k,j) = (t(i,k,j)+t0)/(1.+R_v/R_d*moist(i,k,j,P_QV))
4835        enddo
4836        enddo
4837        enddo
4838     ELSE
4839        do j = j_start,j_end
4840        do k = k_start, k_end
4841        do i = i_start, i_end
4842          th_phy(i,k,j) =  t(i,k,j)+t0
4843        enddo
4844        enddo
4845        enddo
4846     END IF
4847
4848     do j = j_start,j_end
4849     do k = k_start, k_end
4850     do i = i_start, i_end
4851
4852       th_phy_m_t0(i,k,j) = th_phy(i,k,j)-t0
4853       p_phy(i,k,j) = p(i,k,j) + pb(i,k,j)
4854       pi_phy(i,k,j) = (p_phy(i,k,j)/p1000mb)**rcp
4855       t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j)
4856       rho(i,k,j) = 1./alt(i,k,j)*(1.+moist(i,k,j,P_QV))
4857       u_phy(i,k,j) = 0.5*(u(i,k,j)+u(i+1,k,j))
4858       v_phy(i,k,j) = 0.5*(v(i,k,j)+v(i,k,j+1))
4859
4860     enddo
4861     enddo
4862     enddo
4863
4864 !  compute z at w points
4865
4866     do j = j_start,j_end
4867     do k = k_start, kte
4868     do i = i_start, i_end
4869       z_at_w(i,k,j) = (phb(i,k,j)+ph(i,k,j))/g
4870     enddo
4871     enddo
4872     enddo
4873
4874     do j = j_start,j_end
4875     do k = k_start, kte-1
4876     do i = i_start, i_end
4877       dz8w(i,k,j) = z_at_w(i,k+1,j)-z_at_w(i,k,j)
4878     enddo
4879     enddo
4880     enddo
4881
4882     do j = j_start,j_end
4883     do i = i_start, i_end
4884       dz8w(i,kte,j) = 0.
4885     enddo
4886     enddo
4887
4888 !  compute z at p points or half levels (average of z at full levels)
4889
4890     do j = j_start,j_end
4891     do k = k_start, k_end
4892     do i = i_start, i_end
4893       z(i,k,j) = 0.5*(z_at_w(i,k,j) +z_at_w(i,k+1,j) )
4894     enddo
4895     enddo
4896     enddo
4897
4898 !  interp t and p to full levels
4899
4900     do j = j_start,j_end
4901     do k = 2, k_end
4902     do i = i_start, i_end
4903       p8w(i,k,j) = fzm(k)*p_phy(i,k,j)+fzp(k)*p_phy(i,k-1,j)
4904       t8w(i,k,j) = fzm(k)*t_phy(i,k,j)+fzp(k)*t_phy(i,k-1,j)
4905     enddo
4906     enddo
4907     enddo
4908
4909 !  extrapolate p and t to surface and top.
4910 !  we'll use an extrapolation in z for now
4911
4912     do j = j_start,j_end
4913     do i = i_start, i_end
4914
4915 ! bottom
4916
4917       z0 = z_at_w(i,1,j)
4918       z1 = z(i,1,j)
4919       z2 = z(i,2,j)
4920       w1 = (z0 - z2)/(z1 - z2)
4921       w2 = 1. - w1
4922       p8w(i,1,j) = w1*p_phy(i,1,j)+w2*p_phy(i,2,j)
4923       t8w(i,1,j) = w1*t_phy(i,1,j)+w2*t_phy(i,2,j)
4924
4925 ! top
4926
4927       z0 = z_at_w(i,kte,j)
4928       z1 = z(i,k_end,j)
4929       z2 = z(i,k_end-1,j)
4930       w1 = (z0 - z2)/(z1 - z2)
4931       w2 = 1. - w1
4932
4933 !      p8w(i,kde,j) = w1*p_phy(i,kde-1,j)+w2*p_phy(i,kde-2,j)
4934 !!!  bug fix      extrapolate ln(p) so p is positive definite
4935       p8w(i,kde,j) = exp(w1*log(p_phy(i,kde-1,j))+w2*log(p_phy(i,kde-2,j)))
4936       t8w(i,kde,j) = w1*t_phy(i,kde-1,j)+w2*t_phy(i,kde-2,j)
4937
4938     enddo
4939     enddo
4940
4941 ! calculate hydrostatic pressure at both full and half levels
4942 ! first, full level p: assuming dry over model top
4943
4944     do j = j_start,j_end
4945     do i = i_start, i_end
4946        p_hyd_w(i,kte,j) = p_top
4947     enddo
4948     enddo
4949
4950     do j = j_start,j_end
4951     do k = kte-1, k_start, -1
4952     do i = i_start, i_end
4953        qtot = 0.
4954        do n = PARAM_FIRST_SCALAR,n_moist
4955               qtot = qtot + moist(i,k,j,n)
4956        enddo
4957        p_hyd_w(i,k,j) = p_hyd_w(i,k+1,j) - (1.+qtot)*(c1(k)*MUT(i,j)+c2(k))*dnw(k)
4958 !      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)
4959     enddo
4960     enddo
4961     enddo
4962
4963 ! now calculate hydrostatic pressure at half levels
4964
4965     do j = j_start,j_end
4966     do k = k_start, k_end
4967     do i = i_start, i_end
4968        p_hyd(i,k,j) = 0.5*(p_hyd_w(i,k,j)+p_hyd_w(i,k+1,j))
4969     enddo
4970     enddo
4971     enddo
4972
4973 END SUBROUTINE phy_prep
4974
4975
4976 !======================================================================
4977 !   routine to decouple physics tendencies
4978 !======================================================================
4979
4980    SUBROUTINE phy_prep_part2 ( config_flags,                          &
4981                          mut,muu,muv,                                 &
4982                          c1h, c2h, c1f, c2f,                          &
4983                          RTHRATEN,                                    &
4984                          RTHBLTEN, RUBLTEN, RVBLTEN,                  &
4985                          RQVBLTEN, RQCBLTEN, RQIBLTEN,                &
4986                          RUCUTEN,  RVCUTEN,  RTHCUTEN,                &
4987                          RQVCUTEN, RQCCUTEN, RQRCUTEN,                &
4988                          RQICUTEN, RQSCUTEN,                          &
4989                          RUSHTEN,  RVSHTEN,  RTHSHTEN,                &
4990                          RQVSHTEN, RQCSHTEN, RQRSHTEN,                &
4991                          RQISHTEN, RQSSHTEN, RQGSHTEN,                &
4992                          RTHFTEN,  RQVFTEN,                           &
4993                          RUNDGDTEN, RVNDGDTEN, RTHNDGDTEN,            &
4994                          RPHNDGDTEN,RQVNDGDTEN, RMUNDGDTEN,           &
4995                          t_new, th_phy, qv,                           &
4996                          ids, ide, jds, jde, kds, kde,                &
4997                          ims, ime, jms, jme, kms, kme,                &
4998                          its, ite, jts, jte, kts, kte                )
4999 !----------------------------------------------------------------------
5000    IMPLICIT NONE
5001 !----------------------------------------------------------------------
5002
5003    TYPE(grid_config_rec_type) ,     INTENT(IN   ) :: config_flags
5004
5005    INTEGER ,        INTENT(IN   ) ::   ids, ide, jds, jde, kds, kde, &
5006                                        ims, ime, jms, jme, kms, kme, &
5007                                        its, ite, jts, jte, kts, kte
5008
5009    REAL , DIMENSION( ims:ime, jms:jme ), INTENT(IN   )   ::     mut, muu, muv
5010
5011    REAL,  DIMENSION( ims:ime , kms:kme, jms:jme ),                   &
5012           INTENT(INOUT)   ::                               RTHRATEN
5013
5014    REAL,  DIMENSION( ims:ime , kms:kme, jms:jme ),                   &
5015           INTENT(INOUT)   ::                                RUCUTEN, &
5016                                                             RVCUTEN, &
5017                                                            RTHCUTEN, &
5018                                                            RQVCUTEN, &
5019                                                            RQCCUTEN, &
5020                                                            RQRCUTEN, &
5021                                                            RQICUTEN, &
5022                                                            RQSCUTEN, &
5023                                                             RUSHTEN, &
5024                                                             RVSHTEN, &
5025                                                            RTHSHTEN, &
5026                                                            RQVSHTEN, &
5027                                                            RQCSHTEN, &
5028                                                            RQRSHTEN, &
5029                                                            RQISHTEN, &
5030                                                            RQSSHTEN, &
5031                                                            RQGSHTEN
5032
5033    REAL,  DIMENSION( ims:ime, kms:kme, jms:jme )                   , &
5034           INTENT(INOUT)   ::                                RUBLTEN, &
5035                                                             RVBLTEN, &
5036                                                            RTHBLTEN, &
5037                                                            RQVBLTEN, &
5038                                                            RQCBLTEN, &
5039                                                            RQIBLTEN
5040
5041    REAL,  DIMENSION( ims:ime, kms:kme, jms:jme )                   , &
5042           INTENT(INOUT)   ::                                RTHFTEN, &
5043                                                             RQVFTEN
5044
5045    REAL,  DIMENSION( ims:ime, kms:kme, jms:jme )                   , &
5046           INTENT(INOUT)   ::                                RUNDGDTEN, &
5047                                                             RVNDGDTEN, &
5048                                                            RTHNDGDTEN, &
5049                                                            RPHNDGDTEN, &
5050                                                            RQVNDGDTEN
5051
5052    REAL,  DIMENSION( ims:ime, jms:jme )                            , &
5053           INTENT(INOUT)   ::                               RMUNDGDTEN
5054
5055    REAL,  DIMENSION( ims:ime, kms:kme, jms:jme )                   , &
5056           INTENT(IN   )   ::                                t_new, qv
5057
5058    REAL,  DIMENSION( ims:ime, kms:kme, jms:jme )                   , &
5059           INTENT(INOUT)   ::                                th_phy
5060
5061    REAL, DIMENSION( kms:kme ) ,            INTENT(IN   ) ::     c1h, c2h, c1f, c2f
5062
5063    REAL, DIMENSION( kms:kme ) :: c1, c2
5064
5065    INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, j_startv
5066    INTEGER :: i, j, k
5067
5068 !-----------------------------------------------------------------------
5069
5070 !<DESCRIPTION>
5071 !
5072 !  It decouples the physics tendencies from
5073 !  the column dry-air mass (the physics routines expect to see/update the
5074 !  uncoupled tendencies).
5075 !
5076 !</DESCRIPTION>
5077
5078 !  set up loop bounds for this grid's boundary conditions
5079
5080     i_start = its
5081     i_end   = min( ite,ide-1 )
5082     j_start = jts
5083     j_end   = min( jte,jde-1 )
5084
5085     k_start = kts
5086     k_end = min( kte, kde-1 )
5087
5088     c1 = c1h
5089     c2 = c2h
5090
5091 ! decouple all physics tendencies
5092
5093    IF (config_flags%ra_lw_physics .gt. 0 .or. config_flags%ra_sw_physics .gt. 0) THEN
5094
5095       DO J=j_start,j_end
5096       DO K=k_start,k_end
5097       DO I=i_start,i_end
5098          RTHRATEN(I,K,J)=RTHRATEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5099       ENDDO
5100       ENDDO
5101       ENDDO
5102
5103    ENDIF
5104
5105    IF (config_flags%cu_physics .gt. 0) THEN
5106
5107       DO J=j_start,j_end
5108       DO K=k_start,k_end
5109       DO I=i_start,i_end
5110          RUCUTEN(I,K,J) =RUCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5111          RVCUTEN(I,K,J) =RVCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5112          RTHCUTEN(I,K,J)=RTHCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5113       ENDDO
5114       ENDDO
5115       ENDDO
5116
5117       IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN
5118          DO J=j_start,j_end
5119          DO K=k_start,k_end
5120          DO I=i_start,i_end
5121             RQVCUTEN(I,K,J)=RQVCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5122          ENDDO
5123          ENDDO
5124          ENDDO
5125       ENDIF
5126
5127       IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN
5128          DO J=j_start,j_end
5129          DO K=k_start,k_end
5130          DO I=i_start,i_end
5131             RQCCUTEN(I,K,J)=RQCCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5132          ENDDO
5133          ENDDO
5134          ENDDO
5135       ENDIF
5136
5137       IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN
5138          DO J=j_start,j_end
5139          DO K=k_start,k_end
5140          DO I=i_start,i_end
5141             RQRCUTEN(I,K,J)=RQRCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5142          ENDDO
5143          ENDDO
5144          ENDDO
5145       ENDIF
5146
5147       IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN
5148          DO J=j_start,j_end
5149          DO K=k_start,k_end
5150          DO I=i_start,i_end
5151             RQICUTEN(I,K,J)=RQICUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5152          ENDDO
5153          ENDDO
5154          ENDDO
5155       ENDIF
5156
5157       IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN
5158          DO J=j_start,j_end
5159          DO K=k_start,k_end
5160          DO I=i_start,i_end
5161             RQSCUTEN(I,K,J)=RQSCUTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5162          ENDDO
5163          ENDDO
5164          ENDDO
5165       ENDIF
5166
5167    ENDIF
5168
5169    IF (config_flags%shcu_physics .gt. 0) THEN
5170
5171       DO J=j_start,j_end
5172       DO K=k_start,k_end
5173       DO I=i_start,i_end
5174          RUSHTEN(I,K,J) =RUSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5175          RVSHTEN(I,K,J) =RVSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5176          RTHSHTEN(I,K,J)=RTHSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5177       ENDDO
5178       ENDDO
5179       ENDDO
5180
5181       IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN
5182          DO J=j_start,j_end
5183          DO K=k_start,k_end
5184          DO I=i_start,i_end
5185             RQVSHTEN(I,K,J)=RQVSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5186          ENDDO
5187          ENDDO
5188          ENDDO
5189       ENDIF
5190
5191       IF (P_QC .ge. PARAM_FIRST_SCALAR)THEN
5192          DO J=j_start,j_end
5193          DO K=k_start,k_end
5194          DO I=i_start,i_end
5195             RQCSHTEN(I,K,J)=RQCSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5196          ENDDO
5197          ENDDO
5198          ENDDO
5199       ENDIF
5200
5201       IF (P_QR .ge. PARAM_FIRST_SCALAR)THEN
5202          DO J=j_start,j_end
5203          DO K=k_start,k_end
5204          DO I=i_start,i_end
5205             RQRSHTEN(I,K,J)=RQRSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5206          ENDDO
5207          ENDDO
5208          ENDDO
5209       ENDIF
5210
5211       IF (P_QI .ge. PARAM_FIRST_SCALAR)THEN
5212          DO J=j_start,j_end
5213          DO K=k_start,k_end
5214          DO I=i_start,i_end
5215             RQISHTEN(I,K,J)=RQISHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5216          ENDDO
5217          ENDDO
5218          ENDDO
5219       ENDIF
5220
5221       IF(P_QS .ge. PARAM_FIRST_SCALAR)THEN
5222          DO J=j_start,j_end
5223          DO K=k_start,k_end
5224          DO I=i_start,i_end
5225             RQSSHTEN(I,K,J)=RQSSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5226          ENDDO
5227          ENDDO
5228          ENDDO
5229       ENDIF
5230
5231       IF(P_QG .ge. PARAM_FIRST_SCALAR)THEN
5232          DO J=j_start,j_end
5233          DO K=k_start,k_end
5234          DO I=i_start,i_end
5235             RQGSHTEN(I,K,J)=RQGSHTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5236          ENDDO
5237          ENDDO
5238          ENDDO
5239       ENDIF
5240
5241    ENDIF
5242
5243    IF (config_flags%bl_pbl_physics .gt. 0) THEN
5244
5245       DO J=j_start,j_end
5246       DO K=k_start,k_end
5247       DO I=i_start,i_end
5248          RUBLTEN(I,K,J) =RUBLTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5249          RVBLTEN(I,K,J) =RVBLTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5250          RTHBLTEN(I,K,J)=RTHBLTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5251       ENDDO
5252       ENDDO
5253       ENDDO
5254
5255       IF (P_QV .ge. PARAM_FIRST_SCALAR) THEN
5256          DO J=j_start,j_end
5257          DO K=k_start,k_end
5258          DO I=i_start,i_end
5259             RQVBLTEN(I,K,J)=RQVBLTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5260          ENDDO
5261          ENDDO
5262          ENDDO
5263       ENDIF
5264
5265       IF (P_QC .ge. PARAM_FIRST_SCALAR) THEN
5266          DO J=j_start,j_end
5267          DO K=k_start,k_end
5268          DO I=i_start,i_end
5269            RQCBLTEN(I,K,J)=RQCBLTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5270          ENDDO
5271          ENDDO
5272          ENDDO
5273       ENDIF
5274
5275       IF (P_QI .ge. PARAM_FIRST_SCALAR) THEN
5276          DO J=j_start,j_end
5277          DO K=k_start,k_end
5278          DO I=i_start,i_end
5279             RQIBLTEN(I,K,J)=RQIBLTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5280          ENDDO
5281          ENDDO
5282          ENDDO
5283       ENDIF
5284
5285     ENDIF
5286
5287 !  decouple advective forcing required by a few CPS schemes
5288
5289    IF(( config_flags%cu_physics == GDSCHEME )      .OR. &
5290       ( config_flags%cu_physics == GFSCHEME )      .OR. &
5291       ( config_flags%cu_physics == G3SCHEME )      .OR. &
5292       ( config_flags%cu_physics == KFETASCHEME )   .OR. &
5293       ( config_flags%cu_physics == MSKFSCHEME )    .OR. &
5294       ( config_flags%cu_physics == TIEDTKESCHEME ) .OR. &
5295       ( config_flags%cu_physics == NTIEDTKESCHEME )) THEN
5296
5297       IF (P_QV .ge. PARAM_FIRST_SCALAR)THEN
5298          DO J=j_start,j_end
5299          DO K=k_start,k_end
5300             DO I=i_start,i_end
5301                RQVFTEN(I,K,J)=RQVFTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5302             ENDDO
5303          ENDDO
5304          ENDDO
5305       ENDIF
5306
5307    END IF
5308
5309    IF(( config_flags%cu_physics == GDSCHEME ) .OR.    &
5310       ( config_flags%cu_physics == GFSCHEME ) .OR.    &
5311       ( config_flags%cu_physics == G3SCHEME ) .OR.    &
5312       ( config_flags%cu_physics == NTIEDTKESCHEME )) THEN
5313
5314       DO J=j_start,j_end
5315       DO K=k_start,k_end
5316          DO I=i_start,i_end
5317             RTHFTEN(I,K,J)=RTHFTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5318          ENDDO
5319       ENDDO
5320       ENDDO
5321
5322 !  If using moist theta, get dry theta tendency for CPSs
5323       IF ( config_flags%use_theta_m == 1 ) THEN
5324          DO J=j_start,j_end
5325          DO K=k_start,k_end
5326             DO I=i_start,i_end
5327                th_phy(i,k,j) = (t_new(i,k,j) + t0) / (1. + (R_v/R_d) * qv(i,k,j))
5328                rthften(i,k,j) = th_phy(i,k,j)/(t_new(i,k,j)+t0) *          &
5329                                (rthften(i,k,j) - (R_v/R_d) * th_phy(i,k,j) * rqvften(i,k,j))
5330             ENDDO
5331          ENDDO
5332          ENDDO
5333       END IF
5334    END IF
5335
5336 ! fdda
5337 ! note fdda u and v tendencies are staggered, also only interior points have muu/muv,
5338 !   so only decouple those
5339
5340    IF (config_flags%grid_fdda .gt. 0) THEN
5341
5342       i_startu=MAX(its,ids+1)
5343       j_startv=MAX(jts,jds+1)
5344
5345       DO J=j_start,j_end
5346       DO K=k_start,k_end
5347       DO I=i_startu,i_end
5348          RUNDGDTEN(I,K,J) =RUNDGDTEN(I,K,J)/(c1h(k)*muu(I,J)+c2h(k))
5349       ENDDO
5350       ENDDO
5351       ENDDO
5352       DO J=j_startv,j_end
5353       DO K=k_start,k_end
5354       DO I=i_start,i_end
5355          RVNDGDTEN(I,K,J) =RVNDGDTEN(I,K,J)/(c1h(k)*muv(I,J)+c2h(k))
5356       ENDDO
5357       ENDDO
5358       ENDDO
5359       DO J=j_start,j_end
5360       DO K=k_start,k_end
5361       DO I=i_start,i_end
5362          RTHNDGDTEN(I,K,J)=RTHNDGDTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5363 !        RMUNDGDTEN(I,J) - no coupling
5364       ENDDO
5365       ENDDO
5366       ENDDO
5367
5368       IF (config_flags%grid_fdda .EQ. 2) THEN
5369       DO J=j_start,j_end
5370       DO K=k_start,kte
5371       DO I=i_start,i_end
5372          RPHNDGDTEN(I,K,J)=RPHNDGDTEN(I,K,J)/(c1f(k)*mut(I,J)+c2f(k))
5373       ENDDO
5374       ENDDO
5375       ENDDO
5376
5377       ELSE IF (config_flags%grid_fdda .GE. 1) THEN
5378       IF (P_QV .ge. PARAM_FIRST_SCALAR) THEN
5379          DO J=j_start,j_end
5380          DO K=k_start,k_end
5381          DO I=i_start,i_end
5382             RQVNDGDTEN(I,K,J)=RQVNDGDTEN(I,K,J)/(c1(k)*MUT(I,J)+c2(k))
5383          ENDDO
5384          ENDDO
5385          ENDDO
5386       ENDIF
5387       ENDIF
5388
5389     ENDIF
5390
5391 END SUBROUTINE phy_prep_part2
5392 !------------------------------------------------------------
5393
5394    SUBROUTINE moist_physics_prep_em( t_new, t_old, t0, rho, al, alb, &
5395                                      p, p8w, p0, pb, ph, phb,        &
5396                                      th_phy, pii, pf,                &
5397                                      z, z_at_w, dz8w,                &
5398                                      dt,h_diabatic,                  &
5399                                      qv,qv_diabatic,                 &
5400                                      qc,qc_diabatic,                 &
5401                                      config_flags,fzm, fzp,          &
5402                                      ids,ide, jds,jde, kds,kde,      &
5403                                      ims,ime, jms,jme, kms,kme,      &
5404                                      its,ite, jts,jte, kts,kte      )
5405
5406    IMPLICIT NONE
5407
5408 ! Here we construct full fields
5409 ! needed by the microphysics
5410
5411    TYPE(grid_config_rec_type),    INTENT(IN   )    :: config_flags
5412
5413    INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
5414    INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
5415    INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
5416
5417    REAL, INTENT(IN   )  ::  dt
5418
5419    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),        &
5420          INTENT(IN   ) ::                           al,  &
5421                                                     alb, &
5422                                                     p,   &
5423                                                     pb,  &
5424                                                     ph,  &
5425                                                     phb, &
5426                                                     qv,  &
5427                                                     qc
5428
5429
5430    REAL , DIMENSION( kms:kme ) ,           INTENT(IN   ) ::   fzm, &
5431                                                               fzp
5432
5433    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),       &
5434          INTENT(  OUT) ::                         rho,  &
5435                                                th_phy,  &
5436                                                   pii,  &
5437                                                   pf,   &
5438                                                     z,  &
5439                                                z_at_w,  &
5440                                                  dz8w,  &
5441                                                   p8w
5442
5443    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),             &
5444          INTENT(INOUT) ::                         h_diabatic, &
5445                                                  qv_diabatic, &
5446                                                  qc_diabatic
5447
5448    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),        &
5449          INTENT(INOUT) ::                         t_new, &
5450                                                   t_old
5451
5452    REAL, INTENT(IN   ) :: t0, p0
5453    REAL                :: z0,z1,z2,w1,w2
5454
5455    INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end
5456    INTEGER :: i, j, k
5457
5458 !--------------------------------------------------------------------
5459
5460 !<DESCRIPTION>
5461 !
5462 !  moist_phys_prep_em calculates a number of diagnostic quantities needed by
5463 !  the microphysics routines.
5464 !
5465 !</DESCRIPTION>
5466
5467 !  set up loop bounds for this grid's boundary conditions
5468
5469     i_start = its
5470     i_end   = min( ite,ide-1 )
5471     j_start = jts
5472     j_end   = min( jte,jde-1 )
5473
5474     k_start = kts
5475     k_end = min( kte, kde-1 )
5476
5477      DO j = j_start, j_end
5478      DO k = k_start, kte
5479      DO i = i_start, i_end
5480        z_at_w(i,k,j) = (ph(i,k,j)+phb(i,k,j))/g
5481      ENDDO
5482      ENDDO
5483      ENDDO
5484
5485     do j = j_start,j_end
5486     do k = k_start, kte-1
5487     do i = i_start, i_end
5488       dz8w(i,k,j) = z_at_w(i,k+1,j)-z_at_w(i,k,j)
5489     enddo
5490     enddo
5491     enddo
5492
5493     do j = j_start,j_end
5494     do i = i_start, i_end
5495       dz8w(i,kte,j) = 0.
5496     enddo
5497     enddo
5498
5499
5500            !  compute full pii, rho, and z at the new time-level
5501            !  (needed for physics).
5502            !  convert perturbation theta to full theta (th_phy)
5503            !  use h_diabatic to temporarily save pre-microphysics full theta
5504
5505      IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN
5506        DO j = j_start, j_end
5507        DO k = k_start, k_end
5508        DO i = i_start, i_end
5509            th_phy(i,k,j) = (t_new(i,k,j) + t0) / (1. + (R_v/R_d) * qv(i,k,j))
5510        ENDDO
5511        ENDDO
5512        ENDDO
5513      ELSE
5514        DO j = j_start, j_end
5515        DO k = k_start, k_end
5516        DO i = i_start, i_end
5517          th_phy(i,k,j) =  t_new(i,k,j) + t0
5518        ENDDO
5519        ENDDO
5520        ENDDO
5521      END IF
5522
5523      DO j = j_start, j_end
5524      DO k = k_start, k_end
5525      DO i = i_start, i_end
5526        h_diabatic(i,k,j) = th_phy(i,k,j)
5527 #if ( WRFPLUS == 1 )
5528        if ( P_QV >= PARAM_FIRST_SCALAR ) then
5529           qv_diabatic(i,k,j) = qv(i,k,j)
5530        else
5531           qv_diabatic(i,k,j) = 0.0
5532        end if
5533        if ( P_QC >= PARAM_FIRST_SCALAR ) then
5534           qc_diabatic(i,k,j) = qc(i,k,j)
5535        else
5536           qc_diabatic(i,k,j) = 0.0
5537        end if
5538 #else
5539        qv_diabatic(i,k,j) = qv(i,k,j)
5540        qc_diabatic(i,k,j) = qc(i,k,j)
5541 #endif
5542        rho(i,k,j)  = 1./(al(i,k,j)+alb(i,k,j))
5543        pii(i,k,j) = ((p(i,k,j)+pb(i,k,j))/p0)**rcp
5544        z(i,k,j) = 0.5*(z_at_w(i,k,j) +z_at_w(i,k+1,j) )
5545        pf(i,k,j) = p(i,k,j)+pb(i,k,j)
5546
5547      ENDDO
5548      ENDDO
5549      ENDDO
5550
5551 !  interp p at w points
5552
5553     do j = j_start,j_end
5554     do k = 2, k_end
5555     do i = i_start, i_end
5556       p8w(i,k,j) = fzm(k)*pf(i,k,j)+fzp(k)*pf(i,k-1,j)
5557     enddo
5558     enddo
5559     enddo
5560
5561 !  extrapolate p to surface and top.
5562 !  we'll use an extrapolation in z for now
5563
5564     do j = j_start,j_end
5565     do i = i_start, i_end
5566
5567 ! bottom
5568
5569       z0 = z_at_w(i,1,j)
5570       z1 = z(i,1,j)
5571       z2 = z(i,2,j)
5572       w1 = (z0 - z2)/(z1 - z2)
5573       w2 = 1. - w1
5574       p8w(i,1,j) = w1*pf(i,1,j)+w2*pf(i,2,j)
5575
5576 ! top
5577
5578       z0 = z_at_w(i,kte,j)
5579       z1 = z(i,k_end,j)
5580       z2 = z(i,k_end-1,j)
5581       w1 = (z0 - z2)/(z1 - z2)
5582       w2 = 1. - w1
5583 !      p8w(i,kde,j) = w1*pf(i,kde-1,j)+w2*pf(i,kde-2,j)
5584       p8w(i,kde,j) = exp(w1*log(pf(i,kde-1,j))+w2*log(pf(i,kde-2,j)))
5585
5586     enddo
5587     enddo
5588
5589    END SUBROUTINE moist_physics_prep_em
5590
5591 !------------------------------------------------------------------------------
5592
5593    SUBROUTINE moist_physics_finish_em( t_new, t_old, t0, mut,     &
5594                                        th_phy, h_diabatic, dt,    &
5595                                        qv,qv_diabatic,            &
5596                                        qc,qc_diabatic,            &
5597                                        th_phy_m_t0,               &
5598                                        config_flags,              &
5599 #if ( WRF_DFI_RADAR == 1 )
5600                                        dfi_tten_rad,dfi_stage,    &
5601 #endif
5602                                        ids,ide, jds,jde, kds,kde, &
5603                                        ims,ime, jms,jme, kms,kme, &
5604                                        its,ite, jts,jte, kts,kte )
5605
5606    IMPLICIT NONE
5607
5608 ! Here we construct full fields
5609 ! needed by the microphysics
5610
5611    TYPE(grid_config_rec_type),    INTENT(IN   )    :: config_flags
5612
5613    INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde
5614    INTEGER,      INTENT(IN   )    :: ims,ime, jms,jme, kms,kme
5615    INTEGER,      INTENT(IN   )    :: its,ite, jts,jte, kts,kte
5616
5617    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),        &
5618          INTENT(INOUT) ::                         t_new, &
5619                                                   t_old, &
5620                                                  th_phy, &
5621                                                   h_diabatic, &
5622                                                  qv_diabatic, &
5623                                                  qc_diabatic
5624
5625    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),        &
5626          INTENT(  OUT) ::                         th_phy_m_t0
5627
5628    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),        &
5629          INTENT(IN   ) ::                           qv,  &
5630                                                     qc
5631
5632 #if ( WRF_DFI_RADAR == 1 )
5633    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),        &
5634          INTENT(IN), OPTIONAL ::               dfi_tten_rad
5635    INTEGER,      INTENT(IN   ) ,OPTIONAL   :: dfi_stage
5636    REAL :: dfi_tten_max, old_max
5637 #endif
5638
5639    REAL mpten, mptenmax, mptenmin
5640    REAL :: qvten,qcten
5641
5642    REAL, DIMENSION( ims:ime , jms:jme ),  INTENT(INOUT) ::  mut
5643
5644
5645    REAL, INTENT(IN   ) :: t0, dt
5646
5647    INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end
5648    INTEGER :: i, j, k, imax, jmax, imin, jmin
5649
5650 !--------------------------------------------------------------------
5651
5652 !<DESCRIPTION>
5653 !
5654 !  moist_phys_finish_em resets theta to its perturbation value and
5655 !  computes and stores the microphysics diabatic heating term.
5656 !
5657 !</DESCRIPTION>
5658
5659 !  set up loop bounds for this grid's boundary conditions
5660
5661
5662     i_start = its
5663     i_end   = min( ite,ide-1 )
5664     j_start = jts
5665     j_end   = min( jte,jde-1 )
5666     k_start = kts
5667     k_end = min( kte, kde-1 )
5668
5669 #if ( WRF_DFI_RADAR == 1 )
5670          IF ( PRESENT(dfi_stage) .and.  PRESENT(dfi_tten_rad) ) THEN
5671             IF ( dfi_stage ==DFI_FWD ) THEN
5672                WRITE(wrf_err_message,*)'Add radar tendency: i_start,j_start: ', i_start, j_start
5673                CALL wrf_debug ( 100 , TRIM(wrf_err_message) )
5674             ENDIF
5675          ENDIF
5676      dfi_tten_max=-999
5677      old_max=-999
5678 #endif
5679
5680 !  add microphysics theta diff to perturbation theta, set h_diabatic
5681
5682      IF ( config_flags%no_mp_heating .eq. 0 ) THEN
5683        mptenmax = 0.
5684        mptenmin = 999.
5685      DO j = j_start, j_end
5686      DO k = k_start, k_end
5687      DO i = i_start, i_end
5688           mpten = th_phy(i,k,j)-h_diabatic(i,k,j)
5689 #if ( WRFPLUS == 1 )
5690           if ( P_QV >= PARAM_FIRST_SCALAR ) qvten = qv(i,k,j)-qv_diabatic(i,k,j)
5691           if ( P_QC >= PARAM_FIRST_SCALAR ) qcten = qc(i,k,j)-qc_diabatic(i,k,j)
5692 #else
5693           qvten = qv(i,k,j)-qv_diabatic(i,k,j)
5694           qcten = qc(i,k,j)-qc_diabatic(i,k,j)
5695 #endif
5696        if(mpten.gt.mptenmax) then
5697           mptenmax=mpten
5698           imax=i
5699           jmax=j
5700        endif
5701        if(mpten.lt.mptenmin) then
5702           mptenmin=mpten
5703           imin=i
5704           jmin=j
5705        endif
5706           mpten=min(config_flags%mp_tend_lim*dt, mpten)
5707           mpten=max(-config_flags%mp_tend_lim*dt, mpten)
5708
5709 #if ( WRF_DFI_RADAR == 1 )
5710 !compiler error, not handled yet
5711        if(k < k_end ) then
5712          if(dfi_tten_max < dfi_tten_rad(i,k,j) ) dfi_tten_max = dfi_tten_rad(i,k,j)
5713          if(old_max < (th_phy(i,k,j)-h_diabatic(i,k,j)) ) old_max=th_phy(i,k,j)-h_diabatic(i,k,j)
5714        endif
5715
5716        IF ( PRESENT(dfi_stage) .and. PRESENT(dfi_tten_rad) ) THEN
5717           IF ( dfi_stage == DFI_FWD .and. dfi_tten_rad(i,k,j) >= -0.1 .and. &
5718                dfi_tten_rad(i,k,j) <= 0.1 .and. k < k_end ) THEN
5719 ! add radar temp tendency
5720 ! there is radar coverage
5721                t_new(i,k,j) = t_new(i,k,j) + (dfi_tten_rad(i,k,j))*dt
5722           ELSE
5723 ! no radar coverage
5724                t_new(i,k,j) = t_new(i,k,j) + mpten
5725           ENDIF
5726        ENDIF
5727          th_phy_m_t0(i,k,j) = t_new(i,k,j)
5728          h_diabatic(i,k,j) =  mpten / dt
5729 #else
5730 ! pertubation theta_moist(new) = theta_dry(old)*(1+rv/rd qv(old))    +   ! term 1
5731 !                                delta theta_dry * (1+rv/rd qv(new)) +   ! term 2
5732 !                                (rv/rd)*delta qv * theta_dry(new)   -   ! term 3
5733 !                                300                                     ! term 4
5734 !
5735          IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN
5736             t_new(i,k,j) =  h_diabatic(i,k,j)*(1. + (R_v/R_d)*qv_diabatic(i,k,j)) + &
5737                             mpten*(1. + (R_v/R_d)*qv(i,k,j)) + &
5738                             (R_v/R_d)*qvten*th_phy(i,k,j) - T0
5739             th_phy_m_t0(i,k,j) = (t_new(i,k,j)+T0)/(1.+(R_v/R_d)*qv(i,k,j)) - T0
5740             h_diabatic(i,k,j) =  ( mpten*(1. + (R_v/R_d)*qv(i,k,j)) + &
5741                                  (R_v/R_d)*qvten*th_phy(i,k,j) ) / dt
5742          ELSE
5743             t_new(i,k,j) = t_new(i,k,j) + mpten
5744             th_phy_m_t0(i,k,j) = t_new(i,k,j)
5745             h_diabatic(i,k,j) =  mpten/dt
5746          END IF
5747 #endif
5748 !!!         ! KLUDGE:
5749 !!!         qvten = 0.0
5750 !!!         qcten = 0.0
5751 #if ( WRFPLUS == 1 )
5752          if ( P_QV >= PARAM_FIRST_SCALAR ) then
5753             qv_diabatic(i,k,j) =  qvten/dt
5754          else
5755             qv_diabatic(i,k,j) =  0.0
5756          end if
5757          if ( P_QC >= PARAM_FIRST_SCALAR ) then
5758             qc_diabatic(i,k,j) =  qcten/dt
5759          else
5760             qc_diabatic(i,k,j) =  0.0
5761          end if
5762 #else
5763          qv_diabatic(i,k,j) =  qvten/dt
5764          qc_diabatic(i,k,j) =  qcten/dt
5765 #endif
5766      ENDDO
5767      ENDDO
5768      ENDDO
5769
5770      ELSE
5771
5772      DO j = j_start, j_end
5773      DO k = k_start, k_end
5774      DO i = i_start, i_end
5775 !        t_new(i,k,j) = t_new(i,k,j)
5776          h_diabatic(i,k,j) = 0.
5777          qv_diabatic(i,k,j) = 0.
5778          qc_diabatic(i,k,j) = 0.
5779      ENDDO
5780      ENDDO
5781      ENDDO
5782      ENDIF
5783
5784    END SUBROUTINE moist_physics_finish_em
5785
5786 !----------------------------------------------------------------
5787
5788
5789    SUBROUTINE init_module_big_step
5790    END SUBROUTINE init_module_big_step
5791
5792 SUBROUTINE set_tend ( field, field_adv_tend, msf,       &
5793                       ids, ide, jds, jde, kds, kde,     &
5794                       ims, ime, jms, jme, kms, kme,     &
5795                       its, ite, jts, jte, kts, kte       )
5796
5797    IMPLICIT NONE
5798
5799    ! Input data
5800
5801    INTEGER ,  INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
5802                                ims, ime, jms, jme, kms, kme, &
5803                                its, ite, jts, jte, kts, kte
5804
5805    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: field
5806
5807    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN)  :: field_adv_tend
5808
5809    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN)  :: msf
5810
5811    ! Local data
5812
5813    INTEGER :: i, j, k, itf, jtf, ktf
5814
5815 !<DESCRIPTION>
5816 !
5817 !  set_tend copies the advective tendency array into the tendency array.
5818 !
5819 !</DESCRIPTION>
5820
5821       jtf = MIN(jte,jde-1)
5822       ktf = MIN(kte,kde-1)
5823       itf = MIN(ite,ide-1)
5824       DO j = jts, jtf
5825       DO k = kts, ktf
5826       DO i = its, itf
5827          field(i,k,j) = field_adv_tend(i,k,j)*msf(i,j)
5828       ENDDO
5829       ENDDO
5830       ENDDO
5831
5832 END SUBROUTINE set_tend
5833
5834 !------------------------------------------------------------------------------
5835
5836     SUBROUTINE rk_rayleigh_damp( ru_tendf, rv_tendf,              &
5837                                  rw_tendf, t_tendf,               &
5838                                  u, v, w, t, t_init,              &
5839                                  c1h, c2h, c1f, c2f,              &
5840                                  mut, muu, muv, ph, phb,          &
5841                                  u_base, v_base, t_base, z_base,  &
5842                                  dampcoef, zdamp,                 &
5843                                  ids, ide, jds, jde, kds, kde,    &
5844                                  ims, ime, jms, jme, kms, kme,    &
5845                                  its, ite, jts, jte, kts, kte   )
5846
5847 ! History:     Apr 2005  Modifications by George Bryan, NCAR:
5848 !                  - Generalized the code in a way that allows for
5849 !                    simulations with steep terrain.
5850 !
5851 !              Jul 2004  Modifications by George Bryan, NCAR:
5852 !                  - Modified the code to use u_base, v_base, and t_base
5853 !                    arrays for the background state.  Removed the hard-wired
5854 !                    base-state values.
5855 !                  - Modified the code to use dampcoef, zdamp, and damp_opt,
5856 !                    i.e., the upper-level damper variables in namelist.input.
5857 !                    Removed the hard-wired variables in the older version.
5858 !                    This damper is used when damp_opt = 2.
5859 !                  - Modified the code to account for the movement of the
5860 !                    model surfaces with time.  The code now obtains a base-
5861 !                    state value by interpolation using the "_base" arrays.
5862
5863 !              Nov 2003  Bug fix by Jason Knievel, NCAR
5864
5865 !              Aug 2003  Meridional dimension, some comments, and
5866 !                        changes in layout of the code added by
5867 !                        Jason Knievel, NCAR
5868
5869 !              Jul 2003  Original code by Bill Skamarock, NCAR
5870
5871 ! Purpose:     This routine applies Rayleigh damping to a layer at top
5872 !              of the model domain.
5873
5874 !-----------------------------------------------------------------------
5875 ! Begin declarations.
5876
5877     IMPLICIT NONE
5878
5879     INTEGER, INTENT( IN )  &
5880     :: ids, ide, jds, jde, kds, kde,  &
5881        ims, ime, jms, jme, kms, kme,  &
5882        its, ite, jts, jte, kts, kte
5883
5884     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
5885     :: ru_tendf, rv_tendf, rw_tendf, t_tendf
5886
5887     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
5888     :: u, v, w, t, t_init, ph, phb
5889
5890     REAL, DIMENSION( ims:ime, jms:jme ),  INTENT( IN )  &
5891     :: mut, muu, muv
5892
5893     REAL, DIMENSION( kms:kme ) ,  INTENT(IN   )  &
5894     :: u_base, v_base, t_base, z_base
5895
5896     REAL, DIMENSION( kms:kme ) ,  INTENT(IN   )  &
5897     :: c1h, c2h, c1f, c2f
5898
5899     REAL, INTENT(IN   )   &
5900     :: dampcoef, zdamp
5901
5902 ! Local variables.
5903
5904     INTEGER  &
5905     :: i_start, i_end, j_start, j_end, k_start, k_end, i, j, k, ktf, k1, k2
5906
5907     REAL, DIMENSION( kms:kme ) &
5908     :: c1, c2
5909
5910     REAL  &
5911     :: pii, dcoef, z, ztop
5912
5913     REAL :: wkp1, wk, wkm1
5914
5915     REAL, DIMENSION( kms:kme ) :: z00, u00, v00, t00
5916
5917 ! End declarations.
5918 !-----------------------------------------------------------------------
5919
5920     c1 = c1h
5921     c2 = c2h
5922
5923     pii = 2.0 * asin(1.0)
5924
5925     ktf = MIN( kte,   kde-1 )
5926
5927 !-----------------------------------------------------------------------
5928 ! Adjust u to base state.
5929
5930     DO j = jts, MIN( jte, jde-1 )
5931     DO i = its, MIN( ite, ide   )
5932
5933       ! Get height at top of model
5934       ztop = 0.5*( phb(i  ,kde,j)+phb(i-1,kde,j)   &
5935                   +ph(i  ,kde,j)+ph(i-1,kde,j) )/g
5936
5937       ! Find bottom of damping layer
5938       k1 = ktf
5939       z = ztop
5940       DO WHILE( z >= (ztop-zdamp) )
5941         z = 0.25*( phb(i  ,k1,j)+phb(i  ,k1+1,j)  &
5942                   +phb(i-1,k1,j)+phb(i-1,k1+1,j)  &
5943                   +ph(i  ,k1,j)+ph(i  ,k1+1,j)    &
5944                   +ph(i-1,k1,j)+ph(i-1,k1+1,j))/g
5945         z00(k1) = z
5946         k1 = k1 - 1
5947       ENDDO
5948       k1 = k1 + 2
5949
5950       ! Get reference state at model levels
5951       DO k = k1, ktf
5952         k2 = ktf
5953         DO WHILE( z_base(k2) .gt. z00(k) )
5954           k2 = k2 - 1
5955         ENDDO
5956         if(k2+1.gt.ktf)then
5957           u00(k) = u_base(k2) + ( u_base(k2) - u_base(k2-1) )   &
5958                               * (     z00(k) - z_base(k2)   )   &
5959                               / ( z_base(k2) - z_base(k2-1) )
5960         else
5961           u00(k) = u_base(k2) + ( u_base(k2+1) - u_base(k2) )   &
5962                               * (       z00(k) - z_base(k2) )   &
5963                               / ( z_base(k2+1) - z_base(k2) )
5964         endif
5965       ENDDO
5966
5967       ! Apply the Rayleigh damper
5968       DO k = k1, ktf
5969         dcoef = 1.0 - MIN( 1.0, ( ztop - z00(k) ) / zdamp )
5970         dcoef = (SIN( 0.5 * pii * dcoef ) )**2
5971         ru_tendf(i,k,j) = ru_tendf(i,k,j) -                    &
5972                           (c1h(k)*muu(i,j)+c2h(k)) * ( dcoef * dampcoef ) *    &
5973                           ( u(i,k,j) - u00(k) )
5974       END DO
5975
5976     END DO
5977     END DO
5978
5979 ! End adjustment of u.
5980 !-----------------------------------------------------------------------
5981
5982 !-----------------------------------------------------------------------
5983 ! Adjust v to base state.
5984
5985     DO j = jts, MIN( jte, jde   )
5986     DO i = its, MIN( ite, ide-1 )
5987
5988       ! Get height at top of model
5989       ztop = 0.5*( phb(i,kde,j  )+phb(i,kde,j-1)   &
5990                   +ph(i,kde,j  )+ph(i,kde,j-1) )/g
5991
5992       ! Find bottom of damping layer
5993       k1 = ktf
5994       z = ztop
5995       DO WHILE( z >= (ztop-zdamp) )
5996         z = 0.25*( phb(i,k1,j  )+phb(i,k1+1,j  )  &
5997                   +phb(i,k1,j-1)+phb(i,k1+1,j-1)  &
5998                   +ph(i,k1,j  )+ph(i,k1+1,j  )    &
5999                   +ph(i,k1,j-1)+ph(i,k1+1,j-1))/g
6000         z00(k1) = z
6001         k1 = k1 - 1
6002       ENDDO
6003       k1 = k1 + 2
6004
6005       ! Get reference state at model levels
6006       DO k = k1, ktf
6007         k2 = ktf
6008         DO WHILE( z_base(k2) .gt. z00(k) )
6009           k2 = k2 - 1
6010         ENDDO
6011         if(k2+1.gt.ktf)then
6012           v00(k) = v_base(k2) + ( v_base(k2) - v_base(k2-1) )   &
6013                               * (     z00(k) - z_base(k2)   )   &
6014                               / ( z_base(k2) - z_base(k2-1) )
6015         else
6016           v00(k) = v_base(k2) + ( v_base(k2+1) - v_base(k2) )   &
6017                               * (       z00(k) - z_base(k2) )   &
6018                               / ( z_base(k2+1) - z_base(k2) )
6019         endif
6020       ENDDO
6021
6022       ! Apply the Rayleigh damper
6023       DO k = k1, ktf
6024         dcoef = 1.0 - MIN( 1.0, ( ztop - z00(k) ) / zdamp )
6025         dcoef = (SIN( 0.5 * pii * dcoef ) )**2
6026         rv_tendf(i,k,j) = rv_tendf(i,k,j) -                    &
6027                           (c1h(k)*muv(i,j)+c2h(k)) * ( dcoef * dampcoef ) *    &
6028                           ( v(i,k,j) - v00(k) )
6029       END DO
6030
6031     END DO
6032     END DO
6033
6034 ! End adjustment of v.
6035 !-----------------------------------------------------------------------
6036
6037 !-----------------------------------------------------------------------
6038 ! Adjust w to base state.
6039
6040     DO j = jts, MIN( jte,   jde-1 )
6041     DO i = its, MIN( ite,   ide-1 )
6042       ztop = ( phb(i,kde,j) + ph(i,kde,j) ) / g
6043       DO k = kts, MIN( kte,   kde   )
6044         z = ( phb(i,k,j) + ph(i,k,j) ) / g
6045         IF ( z >= (ztop-zdamp) ) THEN
6046           dcoef = 1.0 - MIN( 1.0, ( ztop - z ) / zdamp )
6047           dcoef = ( SIN( 0.5 * pii * dcoef ) )**2
6048           rw_tendf(i,k,j) = rw_tendf(i,k,j) -  &
6049                             (c1f(k)*mut(i,j)+c2f(k)) * ( dcoef * dampcoef ) * w(i,k,j)
6050         END IF
6051       END DO
6052     END DO
6053     END DO
6054
6055 ! End adjustment of w.
6056 !-----------------------------------------------------------------------
6057
6058 !-----------------------------------------------------------------------
6059 ! Adjust potential temperature to base state.
6060
6061     DO j = jts, MIN( jte,   jde-1 )
6062     DO i = its, MIN( ite,   ide-1 )
6063
6064       ! Get height at top of model
6065       ztop = ( phb(i,kde,j) + ph(i,kde,j) ) / g
6066
6067       ! Find bottom of damping layer
6068       k1 = ktf
6069       z = ztop
6070       DO WHILE( z >= (ztop-zdamp) )
6071         z = 0.5 * ( phb(i,k1,j) + phb(i,k1+1,j) +  &
6072                      ph(i,k1,j) +  ph(i,k1+1,j) ) / g
6073         z00(k1) = z
6074         k1 = k1 - 1
6075       ENDDO
6076       k1 = k1 + 2
6077
6078       ! Get reference state at model levels
6079       DO k = k1, ktf
6080         k2 = ktf
6081         DO WHILE( z_base(k2) .gt. z00(k) )
6082           k2 = k2 - 1
6083         ENDDO
6084         if(k2+1.gt.ktf)then
6085           t00(k) = t_base(k2) + ( t_base(k2) - t_base(k2-1) )   &
6086                               * (     z00(k) - z_base(k2)   )   &
6087                               / ( z_base(k2) - z_base(k2-1) )
6088         else
6089           t00(k) = t_base(k2) + ( t_base(k2+1) - t_base(k2) )   &
6090                               * (       z00(k) - z_base(k2) )   &
6091                               / ( z_base(k2+1) - z_base(k2) )
6092         endif
6093       ENDDO
6094
6095       ! Apply the Rayleigh damper
6096       DO k = k1, ktf
6097         dcoef = 1.0 - MIN( 1.0, ( ztop - z00(k) ) / zdamp )
6098         dcoef = (SIN( 0.5 * pii * dcoef ) )**2
6099         t_tendf(i,k,j) = t_tendf(i,k,j) -                      &
6100                          (c1(k)*MUT(i,j)+c2(k)) * ( dcoef * dampcoef )  *    &
6101                          ( t(i,k,j) - t00(k) )
6102       END DO
6103
6104     END DO
6105     END DO
6106
6107 ! End adjustment of potential temperature.
6108 !-----------------------------------------------------------------------
6109
6110     END SUBROUTINE rk_rayleigh_damp
6111
6112 !==============================================================================
6113 !==============================================================================
6114
6115  SUBROUTINE theta_relaxation( t_tendf, t, t_init,              &
6116                               MUT, c1, c2, ph, phb,            &
6117                               t_base, z_base,                  &
6118                               ids, ide, jds, jde, kds, kde,    &
6119                               ims, ime, jms, jme, kms, kme,    &
6120                               its, ite, jts, jte, kts, kte   )
6121
6122 ! Purpose:  Newtonian relaxation on potential temperature.  Serves two
6123 !           purposes:  1) to mimic atmospheric radiation in a simple
6124 !           manner, and 2) to keep the vertical profile of temperature
6125 !           close to the initial (base-state) profile, which is useful
6126 !           for certain idealized applications.
6127
6128 ! Reference:  Rotunno and Emanuel, 1987, JAS, p. 546
6129
6130 !-----------------------------------------------------------------------
6131 ! Begin declarations.
6132
6133     IMPLICIT NONE
6134
6135     INTEGER, INTENT( IN )  &
6136     :: ids, ide, jds, jde, kds, kde,  &
6137        ims, ime, jms, jme, kms, kme,  &
6138        its, ite, jts, jte, kts, kte
6139
6140     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT )  &
6141     :: t_tendf
6142
6143     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
6144     :: t, t_init, ph, phb
6145
6146     REAL, DIMENSION( ims:ime, jms:jme ),  INTENT( IN )  &
6147     :: MUT
6148
6149     REAL, DIMENSION( kms:kme),  INTENT( IN )  &
6150     :: c1, c2
6151
6152     REAL, DIMENSION( kms:kme ) ,  INTENT(IN   )  &
6153     :: t_base, z_base
6154
6155 ! Local variables.
6156
6157     INTEGER :: i, j, k, ktf, k2
6158     REAL :: tau_r , rmax , rmin , inv_tau_r , inv_g , rterm
6159     REAL, DIMENSION( kms:kme ) :: z00,t00
6160
6161 ! End declarations.
6162 !-----------------------------------------------------------------------
6163
6164     ! set tau_r to 12 h, following RE87
6165     tau_r = 12.0*3600.0
6166
6167     ! limit rterm to +/- 2 K/day
6168     rmax =  2.0/86400.0
6169     rmin = -rmax
6170
6171     ktf = MIN( kte,   kde-1 )
6172     inv_tau_r = 1.0/tau_r
6173     inv_g = 1.0/g
6174
6175 !-----------------------------------------------------------------------
6176 ! Adjust potential temperature to base state.
6177
6178     DO j = jts, MIN( jte,   jde-1 )
6179     DO i = its, MIN( ite,   ide-1 )
6180
6181       ! Get height of model levels:
6182       DO k = kts, ktf
6183         z00(k) = 0.5 * ( phb(i,k,j) + phb(i,k+1,j) +  &
6184                           ph(i,k,j) +  ph(i,k+1,j) ) * inv_g
6185       ENDDO
6186
6187       ! Get reference state:
6188       DO k = kts, ktf
6189         k2 = ktf
6190         DO WHILE( z_base(k2) .gt. z00(k)  .and.  k2 .gt. 1 )
6191           k2 = k2 - 1
6192         ENDDO
6193         if(k2+1.gt.ktf)then
6194           t00(k) = t_base(k2) + ( t_base(k2) - t_base(k2-1) )   &
6195                               * (     z00(k) - z_base(k2)   )   &
6196                               / ( z_base(k2) - z_base(k2-1) )
6197         else
6198           t00(k) = t_base(k2) + ( t_base(k2+1) - t_base(k2) )   &
6199                               * (       z00(k) - z_base(k2) )   &
6200                               / ( z_base(k2+1) - z_base(k2) )
6201         endif
6202       ENDDO
6203
6204       ! Apply the RE87 R term:
6205       DO k = kts, ktf
6206         rterm = -( t(i,k,j) - t00(k) )*inv_tau_r
6207         ! limit rterm:
6208         rterm = min( rterm , rmax )
6209         rterm = max( rterm , rmin )
6210         t_tendf(i,k,j) = t_tendf(i,k,j) + (c1(k)*MUT(i,j)+c2(k))*rterm
6211       END DO
6212
6213     END DO
6214     END DO
6215
6216  END SUBROUTINE theta_relaxation
6217
6218 !==============================================================================
6219
6220       SUBROUTINE sixth_order_diffusion( name, field, tendency, MUT, dt,  &
6221                                         config_flags, c1, c2,            &
6222                                         diff_6th_opt, diff_6th_factor,   &
6223                                         phb, ph,                         &
6224                                         rdx, rdy,                        &
6225                                         msftx, msfty,                    &
6226                                         msfux, msfuy,                    &
6227                                         msfvx, msfvy,                    &
6228                                         ids, ide, jds, jde, kds, kde,    &
6229                                         ims, ime, jms, jme, kms, kme,    &
6230                                         its, ite, jts, jte, kts, kte )
6231
6232 ! History:       14 Nov 2006   Name of variable changed by Jason Knievel
6233 !                07 Jun 2006   Revised and generalized by Jason Knievel
6234 !                25 Apr 2005   Original code by Jason Knievel, NCAR
6235
6236 ! Purpose:       Apply 6th-order, monotonic (flux-limited), numerical
6237 !                diffusion to 3-d velocity and to scalars.
6238
6239 ! References:    Ming Xue (MWR Aug 2000)
6240 !                Durran ("Numerical Methods for Wave Equations..." 1999)
6241 !                George Bryan (personal communication)
6242
6243 !------------------------------------------------------------------------------
6244 ! Begin: Declarations.
6245
6246     IMPLICIT NONE
6247
6248     INTEGER, INTENT(IN)  &
6249     :: ids, ide, jds, jde, kds, kde,   &
6250        ims, ime, jms, jme, kms, kme,   &
6251        its, ite, jts, jte, kts, kte
6252
6253     TYPE(grid_config_rec_type), INTENT(IN)  &
6254     :: config_flags
6255
6256     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT)  &
6257     :: tendency
6258
6259     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN)  &
6260     :: field
6261
6262     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN)  &
6263     :: ph, phb
6264
6265     REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  &
6266     :: MUT
6267
6268     REAL, DIMENSION( kms:kme ), INTENT(IN)  &
6269     :: c1, c2
6270
6271     REAL, INTENT(IN)  &
6272     :: dt, rdx, rdy
6273
6274     REAL, INTENT(IN)  &
6275     :: diff_6th_factor
6276
6277     INTEGER, INTENT(IN)  &
6278     :: diff_6th_opt
6279
6280     CHARACTER(LEN=1) , INTENT(IN)  &
6281     :: name
6282
6283     INTEGER  &
6284     :: i, j, k,         &
6285        i_start, i_end,  &
6286        j_start, j_end,  &
6287        k_start, k_end,  &
6288        ktf
6289
6290     REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN   ) ::   msfux
6291     REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN   ) ::   msfuy
6292     REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN   ) ::   msfvx
6293     REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN   ) ::   msfvy
6294     REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN   ) ::   msftx
6295     REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN   ) ::   msfty
6296
6297     REAL  &
6298     :: dflux_x_p0, dflux_y_p0,  &
6299        dflux_x_p1, dflux_y_p1,  &
6300        tendency_x, tendency_y,  &
6301        mu_avg_p0, mu_avg_p1,    &
6302        diff_6th_coef
6303
6304     REAL  &
6305     :: dzmax_p0, dzmax_p1, dx, dy, slopedamp_p0, slopedamp_p1, dzthresh
6306
6307     LOGICAL  &
6308     :: specified
6309
6310 ! End: Declarations.
6311 !------------------------------------------------------------------------------
6312
6313 !------------------------------------------------------------------------------
6314 ! Begin: Translate the diffusion factor into a diffusion coefficient.  See
6315 ! Durran's text, section 2.4.3, then adjust for sixth-order diffusion (not
6316 ! fourth) and for diffusion in two dimensions (not one).  For reference, a
6317 ! factor of 1.0 would mean complete diffusion of a 2dx wave in one time step,
6318 ! although application of the flux limiter reduces somewhat the effects of
6319 ! diffusion for a given coefficient.
6320
6321     diff_6th_coef = diff_6th_factor * 0.015625 / ( 2.0 * dt )
6322
6323 ! End: Translate diffusion factor.
6324 !------------------------------------------------------------------------------
6325
6326 !------------------------------------------------------------------------------
6327 ! Begin: Assign limits of spatial loops depending on variable to be diffused.
6328 ! The halo regions outside the physical domain are not defined, hence the loop
6329 ! indices should start 3 rows and columns in for specified boundary conditions.
6330 ! Also modified to work with idealized boundary conditions.
6331
6332     ktf = MIN( kte, kde-1 )
6333     specified = .false.
6334     if(config_flags%specified .or. config_flags%nested) specified = .true.
6335
6336     IF ( name .EQ. 'u' ) THEN
6337
6338       i_start = its
6339       i_end   = ite
6340       j_start = jts
6341       j_end   = MIN(jde-1,jte)
6342       IF ( config_flags%open_xs ) THEN
6343         i_start = MAX(its,ids+3)
6344       END IF
6345       IF ( config_flags%open_ys ) THEN
6346         j_start = MAX(jts,jds+3)
6347       END IF
6348       IF ( config_flags%open_xe ) THEN
6349         i_end   = MIN(ite,ide-3)
6350       END IF
6351       IF ( config_flags%open_ye ) THEN
6352         j_end   = MIN(jte,jde-4)
6353       END IF
6354       IF ( specified ) THEN
6355         i_start = MAX(its,ids+3)
6356         i_end   = MIN(ite,ide-3)
6357         j_start = MAX(jts,jds+3)
6358         j_end   = MIN(jte,jde-4)
6359       END IF
6360       k_start = kts
6361       k_end   = ktf
6362
6363     ELSE IF ( name .EQ. 'v' ) THEN
6364
6365       i_start = its
6366       i_end   = MIN(ide-1,ite)
6367       j_start = jts
6368       j_end   = jte
6369       IF ( config_flags%open_xs ) THEN
6370         i_start = MAX(its,ids+3)
6371       END IF
6372       IF ( config_flags%open_ys ) THEN
6373         j_start = MAX(jts,jds+3)
6374       END IF
6375       IF ( config_flags%open_xe ) THEN
6376         i_end   = MIN(ite,ide-4)
6377       END IF
6378       IF ( config_flags%open_ye ) THEN
6379         j_end   = MIN(jte,jde-3)
6380       END IF
6381       IF ( config_flags%open_xs .or. specified ) THEN
6382         i_start = MAX(its,ids+3)
6383         i_end   = MIN(ite,ide-4)
6384         j_start = MAX(jts,jds+3)
6385         j_end   = MIN(jte,jde-3)
6386       END IF
6387       k_start = kts
6388       k_end   = ktf
6389
6390     ELSE IF ( name .EQ. 'w' ) THEN
6391
6392       i_start = its
6393       i_end   = MIN(ide-1,ite)
6394       j_start = jts
6395       j_end   = MIN(jde-1,jte)
6396       IF ( config_flags%open_xs ) THEN
6397         i_start = MAX(its,ids+3)
6398       END IF
6399       IF ( config_flags%open_ys ) THEN
6400         j_start = MAX(jts,jds+3)
6401       END IF
6402       IF ( config_flags%open_xe ) THEN
6403         i_end   = MIN(ite,ide-4)
6404       END IF
6405       IF ( config_flags%open_ye ) THEN
6406         j_end   = MIN(jte,jde-4)
6407       END IF
6408       IF ( specified ) THEN
6409         i_start = MAX(its,ids+3)
6410         i_end   = MIN(ide-4,ite)
6411         j_start = MAX(jts,jds+3)
6412         j_end   = MIN(jde-4,jte)
6413       END IF
6414       k_start = kts+1
6415       k_end   = ktf
6416
6417     ELSE
6418
6419       i_start = its
6420       i_end   = MIN(ide-1,ite)
6421       j_start = jts
6422       j_end   = MIN(jde-1,jte)
6423       IF ( config_flags%open_xs ) THEN
6424         i_start = MAX(its,ids+3)
6425       END IF
6426       IF ( config_flags%open_ys ) THEN
6427         j_start = MAX(jts,jds+3)
6428       END IF
6429       IF ( config_flags%open_xe ) THEN
6430         i_end   = MIN(ite,ide-4)
6431       END IF
6432       IF ( config_flags%open_ye ) THEN
6433         j_end   = MIN(jte,jde-4)
6434       END IF
6435       IF ( specified ) THEN
6436         i_start = MAX(its,ids+3)
6437         i_end   = MIN(ide-4,ite)
6438         j_start = MAX(jts,jds+3)
6439         j_end   = MIN(jde-4,jte)
6440       END IF
6441       k_start = kts
6442       k_end   = ktf
6443
6444     ENDIF
6445
6446 ! End: Assignment of limits of spatial loops.
6447 !------------------------------------------------------------------------------
6448
6449 !------------------------------------------------------------------------------
6450 ! Begin: Loop across spatial dimensions.
6451
6452     DO j = j_start, j_end
6453     DO k = k_start, k_end
6454     DO i = i_start, i_end
6455
6456 !------------------------------------------------------------------------------
6457 ! Begin: Diffusion in x (i index).
6458
6459 ! Calculate the diffusive flux in x direction (from Xue's eq. 3).
6460
6461       dflux_x_p0 = (  10.0 * ( field(i,  k,j) - field(i-1,k,j) )    &
6462                      - 5.0 * ( field(i+1,k,j) - field(i-2,k,j) )    &
6463                      +       ( field(i+2,k,j) - field(i-3,k,j) ) )
6464
6465       dflux_x_p1 = (  10.0 * ( field(i+1,k,j) - field(i  ,k,j) )    &
6466                      - 5.0 * ( field(i+2,k,j) - field(i-1,k,j) )    &
6467                      +       ( field(i+3,k,j) - field(i-2,k,j) ) )
6468
6469 ! If requested in the namelist (diff_6th_opt=2), prohibit up-gradient diffusion
6470 ! (variation on Xue's eq. 10).
6471
6472       IF ( diff_6th_opt .EQ. 2 ) THEN
6473
6474         IF ( dflux_x_p0 * ( field(i  ,k,j)-field(i-1,k,j) ) .LE. 0.0 ) THEN
6475           dflux_x_p0 = 0.0
6476         END IF
6477
6478         IF ( dflux_x_p1 * ( field(i+1,k,j)-field(i  ,k,j) ) .LE. 0.0 ) THEN
6479           dflux_x_p1 = 0.0
6480         END IF
6481
6482       END IF
6483
6484       slopedamp_p0 = 1.
6485       slopedamp_p1 = 1.
6486
6487       IF (config_flags%diff_6th_slopeopt .ge. 1) THEN
6488          dx=1./rdx
6489          dzthresh = config_flags%diff_6th_thresh*9.81*dx
6490          IF      ( name .EQ. 'u' ) THEN
6491            dzmax_p0 = MAX( ABS(phb(i  ,k,j)-phb(i-1,k,j))*msfux(i  ,j), ABS(phb(i-1,k,j)-phb(i-2,k,j))*msfux(i-1,j) )
6492            dzmax_p1 = MAX( ABS(phb(i+1,k,j)-phb(i  ,k,j))*msfux(i+1,j), ABS(phb(i  ,k,j)-phb(i-1,k,j))*msfux(i  ,j) )
6493          ELSE IF ( name .EQ. 'v' ) THEN
6494            dzmax_p0 = max( ABS(phb(i  ,k,j) - phb(i-1,k,j))*msfux(i  ,j), ABS(phb(i  ,k,j-1) - phb(i-1,k,j-1))*msfux(i  ,j-1) )
6495            dzmax_p1 = max( ABS(phb(i+1,k,j) - phb(i  ,k,j))*msfux(i+1,j), ABS(phb(i+1,k,j-1) - phb(i  ,k,j-1))*msfux(i+1,j-1) )
6496          ELSE
6497            dzmax_p0 = ABS(phb(i  ,k,j) - phb(i-1,k,j))*msfux(i,j)
6498            dzmax_p1 = ABS(phb(i+1,k,j) - phb(i  ,k,j))*msfux(i+1,j)
6499          END IF
6500          slopedamp_p0 = MAX(1.- (dzmax_p0/dzthresh) , 0.)
6501          slopedamp_p1 = MAX(1.- (dzmax_p1/dzthresh) , 0.)
6502       ENDIF
6503
6504 ! Apply 6th-order diffusion in x direction.
6505
6506       IF      ( name .EQ. 'u' ) THEN
6507         mu_avg_p0 = (c1(k)*MUT(i-1,j)+c2(k))
6508         mu_avg_p1 = (c1(k)*MUT(i  ,j)+c2(k))
6509          tendency_x = diff_6th_coef * msfux(i,j) * &
6510                    ( ( slopedamp_p1 * mu_avg_p1 * dflux_x_p1 ) - ( slopedamp_p0 * mu_avg_p0 * dflux_x_p0 ) )
6511       ELSE IF ( name .EQ. 'v' ) THEN
6512         mu_avg_p0 = 0.25 * (       &
6513                     (c1(k)*MUT(i-1,j-1)+c2(k)) +  &
6514                     (c1(k)*MUT(i  ,j-1)+c2(k)) +  &
6515                     (c1(k)*MUT(i-1,j  )+c2(k)) +  &
6516                     (c1(k)*MUT(i  ,j  )+c2(k)) )
6517         mu_avg_p1 = 0.25 * (       &
6518                     (c1(k)*MUT(i  ,j-1)+c2(k)) +  &
6519                     (c1(k)*MUT(i+1,j-1)+c2(k)) +  &
6520                     (c1(k)*MUT(i  ,j  )+c2(k)) +  &
6521                     (c1(k)*MUT(i+1,j  )+c2(k)) )
6522         tendency_x = diff_6th_coef * msfvx(i,j) * &
6523                    ( ( slopedamp_p1 * mu_avg_p1 * dflux_x_p1 ) - ( slopedamp_p0 * mu_avg_p0 * dflux_x_p0 ) )
6524       ELSE
6525         mu_avg_p0 = 0.5 * (        &
6526                     (c1(k)*MUT(i-1,j)+c2(k)) +    &
6527                     (c1(k)*MUT(i  ,j)+c2(k)) )
6528         mu_avg_p1 = 0.5 * (        &
6529                     (c1(k)*MUT(i  ,j)+c2(k)) +    &
6530                     (c1(k)*MUT(i+1,j)+c2(k)) )
6531         tendency_x = diff_6th_coef * msftx(i,j) * &
6532                  ( ( slopedamp_p1 * mu_avg_p1 * dflux_x_p1 ) - ( slopedamp_p0 * mu_avg_p0 * dflux_x_p0 ) )
6533       END IF
6534
6535 ! End: Diffusion in x.
6536 !------------------------------------------------------------------------------
6537
6538 !------------------------------------------------------------------------------
6539 ! Begin: Diffusion in y (j index).
6540
6541 ! Calculate the diffusive flux in y direction (from Xue's eq. 3).
6542
6543       dflux_y_p0 = (  10.0 * ( field(i,k,j  ) - field(i,k,j-1) )    &
6544                      - 5.0 * ( field(i,k,j+1) - field(i,k,j-2) )    &
6545                      +       ( field(i,k,j+2) - field(i,k,j-3) ) )
6546
6547       dflux_y_p1 = (  10.0 * ( field(i,k,j+1) - field(i,k,j  ) )    &
6548                      - 5.0 * ( field(i,k,j+2) - field(i,k,j-1) )    &
6549                      +       ( field(i,k,j+3) - field(i,k,j-2) ) )
6550
6551 ! If requested in the namelist (diff_6th_opt=2), prohibit up-gradient diffusion
6552 ! (variation on Xue's eq. 10).
6553
6554       IF ( diff_6th_opt .EQ. 2 ) THEN
6555
6556         IF ( dflux_y_p0 * ( field(i,k,j  )-field(i,k,j-1) ) .LE. 0.0 ) THEN
6557           dflux_y_p0 = 0.0
6558         END IF
6559
6560         IF ( dflux_y_p1 * ( field(i,k,j+1)-field(i,k,j  ) ) .LE. 0.0 ) THEN
6561           dflux_y_p1 = 0.0
6562         END IF
6563
6564       END IF
6565
6566       slopedamp_p0 = 1.
6567       slopedamp_p1 = 1.
6568
6569       IF (config_flags%diff_6th_slopeopt .ge. 1) THEN
6570          dy=1./rdy
6571          dzthresh = config_flags%diff_6th_thresh*9.81*dy
6572          IF      ( name .EQ. 'u' ) THEN
6573            dzmax_p0 = max( ABS(phb(i,k,j  ) - phb(i,k,j-1))*msfvy(i,j  ), ABS(phb(i-1,k,j  ) - phb(i-1,k,j-1))*msfvy(i-1,j  ) )
6574            dzmax_p1 = max( ABS(phb(i,k,j+1) - phb(i,k,j  ))*msfvy(i,j+1), ABS(phb(i-1,k,j+1) - phb(i-1,k,j  ))*msfvy(i-1,j+1) )
6575          ELSE IF ( name .EQ. 'v' ) THEN
6576            dzmax_p0 = MAX( ABS(phb(i,k,j  )-phb(i,k,j-1))*msfvy(i,j  ), ABS(phb(i,k,j-1)-phb(i,k,j-2))*msfvy(i,j-1) )
6577            dzmax_p1 = MAX( ABS(phb(i,k,j+1)-phb(i,k,j  ))*msfvy(i,j+1), ABS(phb(i,k,j  )-phb(i,k,j-1))*msfvy(i,j  ) )
6578          ELSE
6579            dzmax_p0 = ABS(phb(i,k,j  ) - phb(i,k,j-1))*msfvy(i,j  )
6580            dzmax_p1 = ABS(phb(i,k,j+1) - phb(i,k,j  ))*msfvy(i,j+1)
6581          END IF
6582          slopedamp_p0 = MAX(1.- (dzmax_p0/dzthresh) , 0.)
6583          slopedamp_p1 = MAX(1.- (dzmax_p1/dzthresh) , 0.)
6584       ENDIF
6585
6586 ! Apply 6th-order diffusion in y direction.
6587
6588       IF      ( name .EQ. 'u' ) THEN
6589         mu_avg_p0 = 0.25 * (       &
6590                     (c1(k)*MUT(i-1,j-1)+c2(k)) +  &
6591                     (c1(k)*MUT(i  ,j-1)+c2(k)) +  &
6592                     (c1(k)*MUT(i-1,j  )+c2(k)) +  &
6593                     (c1(k)*MUT(i  ,j  )+c2(k)) )
6594         mu_avg_p1 = 0.25 * (       &
6595                     (c1(k)*MUT(i-1,j  )+c2(k)) +  &
6596                     (c1(k)*MUT(i  ,j  )+c2(k)) +  &
6597                     (c1(k)*MUT(i-1,j+1)+c2(k)) +  &
6598                     (c1(k)*MUT(i  ,j+1)+c2(k)) )
6599         tendency_y = diff_6th_coef * msfuy(i,j) * &
6600                  ( ( slopedamp_p1 * mu_avg_p1 * dflux_y_p1 ) - ( slopedamp_p0 * mu_avg_p0 * dflux_y_p0 ) )
6601
6602       ELSE IF ( name .EQ. 'v' ) THEN
6603         mu_avg_p0 = (c1(k)*MUT(i,j-1)+c2(k))
6604         mu_avg_p1 = (c1(k)*MUT(i,j  )+c2(k))
6605         tendency_y = diff_6th_coef * msfvy(i,j) * &
6606                    ( ( slopedamp_p1 * mu_avg_p1 * dflux_y_p1 ) - ( slopedamp_p0 * mu_avg_p0 * dflux_y_p0 ) )
6607       ELSE
6608         mu_avg_p0 = 0.5 * (      &
6609                     (c1(k)*MUT(i,j-1)+c2(k)) +  &
6610                     (c1(k)*MUT(i,j  )+c2(k)) )
6611         mu_avg_p1 = 0.5 * (      &
6612                     (c1(k)*MUT(i,j  )+c2(k)) +  &
6613                     (c1(k)*MUT(i,j+1)+c2(k)) )
6614         tendency_y = diff_6th_coef * msfty(i,j) * &
6615                    ( ( slopedamp_p1 * mu_avg_p1 * dflux_y_p1 ) - ( slopedamp_p0 * mu_avg_p0 * dflux_y_p0 ) )
6616       END IF
6617
6618 ! End: Diffusion in y.
6619 !------------------------------------------------------------------------------
6620
6621 !------------------------------------------------------------------------------
6622 ! Begin: Combine diffusion in x and y.
6623
6624       tendency(i,k,j) = tendency(i,k,j) + tendency_x + tendency_y
6625
6626 ! End: Combine diffusion in x and y.
6627 !------------------------------------------------------------------------------
6628
6629     ENDDO
6630     ENDDO
6631     ENDDO
6632
6633 ! End: Loop across spatial dimensions.
6634 !------------------------------------------------------------------------------
6635
6636     END SUBROUTINE sixth_order_diffusion
6637
6638 !==============================================================================
6639
6640 SUBROUTINE initialize_moist_old ( moist_old , moist , &
6641                                   ids, ide, jds, jde, kds, kde ,   &
6642                                   ims, ime, jms, jme, kms, kme ,   &
6643                                   its, ite, jts, jte, kts, kte     )
6644
6645    !  For the theta_m option, the moist_old variable is uninitialized
6646    !  at the beginning of EACH of the RK steps.  So, just set the
6647    !  starting value of moist_old as the final value of moist from the
6648    !  previous time step.  Here "moist" is only the P_Qv index.
6649
6650    IMPLICIT NONE
6651
6652    INTEGER , INTENT(IN) ::   ids, ide, jds, jde, kds, kde ,   &
6653                              ims, ime, jms, jme, kms, kme ,   &
6654                              its, ite, jts, jte, kts, kte
6655    REAL    , INTENT(IN   ) , DIMENSION(ims:ime,kms:kme,jms:jme) :: moist
6656    REAL    , INTENT(  OUT) , DIMENSION(ims:ime,kms:kme,jms:jme) :: moist_old
6657
6658    !  Local variables
6659
6660    INTEGER :: i , j , k
6661
6662    DO j = jts , MIN(jte,jde-1)
6663       DO k = kts , kte-1
6664          DO i = its , MIN(ite,ide-1)
6665             moist_old(i,k,j) = moist(i,k,j)
6666          END DO
6667       END DO
6668    END DO
6669
6670 END SUBROUTINE initialize_moist_old
6671
6672 !==============================================================================
6673
6674 SUBROUTINE conv_t_tendf_to_moist ( t_1 , moist_old ,                &
6675                                    t_tendf  , moist_tend ,          &
6676                                    ids, ide, jds, jde, kds, kde ,   &
6677                                    ims, ime, jms, jme, kms, kme ,   &
6678                                    its, ite, jts, jte, kts, kte     )
6679
6680    !  Convert dry potential temperature to "moist" theta:
6681    !  theta_m = theta ( 1 + Rv/Rd Qv )
6682
6683    IMPLICIT NONE
6684
6685    INTEGER , INTENT(IN) ::   ids, ide, jds, jde, kds, kde ,   &
6686                              ims, ime, jms, jme, kms, kme ,   &
6687                              its, ite, jts, jte, kts, kte
6688    REAL    , INTENT(IN   ) , DIMENSION(ims:ime,kms:kme,jms:jme) :: moist_tend, moist_old, t_1
6689    REAL    , INTENT(INOUT) , DIMENSION(ims:ime,kms:kme,jms:jme) :: t_tendf
6690
6691    !  Local variables
6692
6693    INTEGER :: i , j , k
6694
6695    !  This dry tendency is from the physics packages.  It is modified immediately after the
6696    !  call to the physics schemes, and the remains constant for the remainder of the RK loops.
6697
6698    DO j = jts , MIN(jte,jde-1)
6699       DO k = kts , kte-1
6700          DO i = its , MIN(ite,ide-1)
6701             t_tendf(i,k,j) = (1. + (R_v/R_d) * moist_old(i,k,j))*t_tendf(i,k,j) + &
6702                              (R_v/R_d)*(t_1(i,k,j)+T0)/(1.+R_v/R_d*moist_old(i,k,j))*moist_tend(i,k,j)
6703          END DO
6704       END DO
6705    END DO
6706
6707 END SUBROUTINE conv_t_tendf_to_moist
6708
6709 !==============================================================================
6710
6711   subroutine Cloud_tracer_nudge (dt, dt_relax, dt_nudge, xtime, qc, qi, qs,  &
6712       tr_qc, tr_qi, tr_qs, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, &
6713       kms, kme, its, ite, jts, jte, kts, kte)
6714
6715     implicit none
6716
6717     real, intent(in) :: dt, dt_relax, dt_nudge, xtime
6718     real, dimension (ims:ime, kms:kme, jms:jme), intent (inout) :: qc, qi, qs
6719     real, dimension (ims:ime, kms:kme, jms:jme), intent(in) :: tr_qc, tr_qi, tr_qs
6720     integer, intent(in) :: ids, ide, jds, jde, kds, kde, ims,ime, jms, jme, &
6721         kms, kme, its, ite, jts, jte, kts, kte
6722
6723
6724     integer :: i, j, k, i_start, i_end, j_start, j_end, k_start, k_end
6725
6726 !--------------------------------------------------------------------
6727
6728 !<DESCRIPTION>
6729 !
6730 !  Cloud_tracer_nudge nudges qc, qi, and qs towards advected tracer values
6731 !         tr_qc, tr_qi, tr_qs
6732 !
6733 !</DESCRIPTION>
6734
6735       ! Set up loop bounds
6736     i_start = its
6737     i_end = min (ite, ide - 1)
6738     j_start = jts
6739     j_end = min (jte, jde - 1)
6740     k_start = kts
6741     k_end = min (kte, kde - 1)
6742
6743       ! Nudge
6744     if (xtime < dt_nudge) then
6745       do j = j_start, j_end
6746         do k = k_start, k_end
6747           do i = i_start, i_end
6748              qc(i, k, j) = qc(i, k, j) + (tr_qc(i, k, j) - qc(i, k, j)) * dt / dt_relax
6749              qi(i, k, j) = qi(i, k, j) + (tr_qi(i, k, j) - qi(i, k, j)) * dt / dt_relax
6750              qs(i, k, j) = qs(i, k, j) + (tr_qs(i, k, j) - qs(i, k, j)) * dt / dt_relax
6751           end do
6752         end do
6753       end do
6754     end if
6755
6756   end subroutine Cloud_tracer_nudge
6757
6758 END MODULE module_big_step_utilities_em