wrfv2_fire/dyn_em/module_advect_em.F

   1 !WRF:MODEL_LAYER:DYNAMICS
   2 !
   3 MODULE module_advect_em
   4
   5   USE module_bc
   6   USE module_model_constants
   7   USE module_wrf_error
   8
   9 CONTAINS
  10
  11
  12 SUBROUTINE mass_flux_divergence ( field, field_old, tendency,    &
  13                                   ru, rv, rom,                   &
  14                                   mut, config_flags,             &
  15                                   msfux, msfuy, msfvx, msfvy,    &
  16                                   msftx, msfty,                  &
  17                                   fzm, fzp,                      &
  18                                   rdx, rdy, rdzw,                &
  19                                   ids, ide, jds, jde, kds, kde,  &
  20                                   ims, ime, jms, jme, kms, kme,  &
  21                                   its, ite, jts, jte, kts, kte  )
  22
  23    IMPLICIT NONE
  24
  25    ! Input data
  26
  27    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
  28
  29    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
  30                                               ims, ime, jms, jme, kms, kme, &
  31                                               its, ite, jts, jte, kts, kte
  32
  33    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
  34                                                                       field_old, &
  35                                                                       ru,        &
  36                                                                       rv,        &
  37                                                                       rom
  38
  39    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
  40    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
  41
  42    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
  43                                                                     msfuy,  &
  44                                                                     msfvx,  &
  45                                                                     msfvy,  &
  46                                                                     msftx,  &
  47                                                                     msfty
  48
  49    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
  50                                                                   fzp,  &
  51                                                                   rdzw
  52
  53    REAL ,                                        INTENT(IN   ) :: rdx,  &
  54                                                                   rdy
  55
  56    ! Local data
  57
  58    INTEGER :: i, j, k, itf, jtf, ktf
  59    INTEGER :: i_start, i_end, j_start, j_end
  60    INTEGER :: imin, imax, jmin, jmax
  61
  62    REAL    :: mrdx, mrdy, ub, vb, uw, vw
  63    REAL , DIMENSION(its:ite,kts:kte) :: vflux
  64
  65    LOGICAL :: specified
  66
  67 !--------------- horizontal flux
  68
  69    specified = .false.
  70    if(config_flags%specified .or. config_flags%nested) specified = .true.
  71
  72    ktf=MIN(kte,kde-1)
  73    i_start = its
  74    i_end   = MIN(ite,ide-1)
  75    j_start = jts
  76    j_end   = MIN(jte,jde-1)
  77
  78    DO j = j_start, j_end
  79    DO k = kts, ktf
  80    DO i = i_start, i_end
  81       mrdx=msftx(i,j)*rdx
  82       tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 &
  83                       *(ru(i+1,k,j)*(field(i+1,k,j)+field(i  ,k,j)) &
  84                        -ru(i  ,k,j)*(field(i  ,k,j)+field(i-1,k,j)))
  85    ENDDO
  86    ENDDO
  87    ENDDO
  88
  89    DO j = j_start, j_end
  90    DO k = kts, ktf
  91    DO i = i_start, i_end
  92       mrdy=msfty(i,j)*rdy
  93       tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 &
  94                       *(rv(i,k,j+1)*(field(i,k,j+1)+field(i,k,j  )) &
  95                        -rv(i,k,j  )*(field(i,k,j  )+field(i,k,j-1)))
  96    ENDDO
  97    ENDDO
  98    ENDDO
  99
 100 !----------------  vertical flux divergence
 101
 102
 103    DO i = i_start, i_end
 104       vflux(i,kts)=0.
 105       vflux(i,kte)=0.
 106    ENDDO
 107
 108    DO j = j_start, j_end
 109
 110       DO k = kts+1, ktf
 111       DO i = i_start, i_end
 112          vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
 113       ENDDO
 114       ENDDO
 115
 116       DO k = kts, ktf
 117       DO i = i_start, i_end
 118          tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
 119       ENDDO
 120       ENDDO
 121
 122    ENDDO
 123
 124 END SUBROUTINE mass_flux_divergence
 125
 126 !-------------------------------------------------------------------------------
 127
 128 SUBROUTINE advect_u   ( u, u_old, tendency,            &
 129                         ru, rv, rom,                   &
 130                         mut, time_step, config_flags,  &
 131                         msfux, msfuy, msfvx, msfvy,    &
 132                         msftx, msfty,                  &
 133                         fzm, fzp,                      &
 134                         rdx, rdy, rdzw,                &
 135                         ids, ide, jds, jde, kds, kde,  &
 136                         ims, ime, jms, jme, kms, kme,  &
 137                         its, ite, jts, jte, kts, kte  )
 138
 139    IMPLICIT NONE
 140
 141    ! Input data
 142
 143    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
 144
 145    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
 146                                               ims, ime, jms, jme, kms, kme, &
 147                                               its, ite, jts, jte, kts, kte
 148
 149    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: u,     &
 150                                                                       u_old, &
 151                                                                       ru,    &
 152                                                                       rv,    &
 153                                                                       rom
 154
 155    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
 156    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
 157
 158    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
 159                                                                     msfuy,  &
 160                                                                     msfvx,  &
 161                                                                     msfvy,  &
 162                                                                     msftx,  &
 163                                                                     msfty
 164
 165    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
 166                                                                   fzp,  &
 167                                                                   rdzw
 168
 169    REAL ,                                        INTENT(IN   ) :: rdx,  &
 170                                                                   rdy
 171    INTEGER ,                                     INTENT(IN   ) :: time_step
 172
 173    ! Local data
 174
 175    INTEGER :: i, j, k, itf, jtf, ktf
 176    INTEGER :: i_start, i_end, j_start, j_end
 177    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
 178    INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
 179    INTEGER :: jp1, jp0, jtmp
 180
 181    INTEGER :: horz_order, vert_order
 182
 183    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
 184    REAL , DIMENSION(its:ite, kts:kte) :: vflux
 185
 186
 187    REAL,  DIMENSION( its-1:ite+1, kts:kte ) :: fqx
 188    REAL,  DIMENSION( its:ite, kts:kte, 2) :: fqy
 189
 190    LOGICAL :: degrade_xs, degrade_ys
 191    LOGICAL :: degrade_xe, degrade_ye
 192
 193 ! definition of flux operators, 3rd, 4th, 5th or 6th order
 194
 195    REAL    :: flux3, flux4, flux5, flux6
 196    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
 197
 198    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                         &
 199           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
 200
 201    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                         &
 202             flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
 203             sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
 204
 205    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
 206                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)       &
 207                      +(q_ip2+q_im3) )/60.0
 208
 209    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
 210            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)     &
 211             -sign(1,time_step)*sign(1.,ua)*(                     &
 212               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
 213
 214
 215    LOGICAL :: specified
 216
 217    specified = .false.
 218    if(config_flags%specified .or. config_flags%nested) specified = .true.
 219
 220 !  set order for vertical and horzontal flux operators
 221
 222    horz_order = config_flags%h_mom_adv_order
 223    vert_order = config_flags%v_mom_adv_order
 224
 225    ktf=MIN(kte,kde-1)
 226
 227 !  begin with horizontal flux divergence
 228
 229    horizontal_order_test : IF( horz_order == 6 ) THEN
 230
 231 !  determine boundary mods for flux operators
 232 !  We degrade the flux operators from 3rd/4th order
 233 !   to second order one gridpoint in from the boundaries for
 234 !   all boundary conditions except periodic and symmetry - these
 235 !   conditions have boundary zone data fill for correct application
 236 !   of the higher order flux stencils
 237
 238       degrade_xs = .true.
 239       degrade_xe = .true.
 240       degrade_ys = .true.
 241       degrade_ye = .true.
 242
 243       IF( config_flags%periodic_x   .or. &
 244           config_flags%symmetric_xs .or. &
 245           (its > ids+2)                ) degrade_xs = .false.
 246       IF( config_flags%periodic_x   .or. &
 247           config_flags%symmetric_xe .or. &
 248           (ite < ide-2)                ) degrade_xe = .false.
 249       IF( config_flags%periodic_y   .or. &
 250           config_flags%symmetric_ys .or. &
 251           (jts > jds+2)                ) degrade_ys = .false.
 252       IF( config_flags%periodic_y   .or. &
 253           config_flags%symmetric_ye .or. &
 254           (jte < jde-3)                ) degrade_ye = .false.
 255
 256 !--------------- y - advection first
 257
 258       i_start = its
 259       i_end   = ite
 260       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
 261       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
 262       IF ( config_flags%periodic_x ) i_start = its
 263       IF ( config_flags%periodic_x ) i_end = ite
 264
 265       j_start = jts
 266       j_end   = MIN(jte,jde-1)
 267
 268 !  higher order flux has a 5 or 7 point stencil, so compute
 269 !  bounds so we can switch to second order flux close to the boundary
 270
 271       j_start_f = j_start
 272       j_end_f   = j_end+1
 273
 274       IF(degrade_ys) then
 275         j_start = MAX(jts,jds+1)
 276         j_start_f = jds+3
 277       ENDIF
 278
 279       IF(degrade_ye) then
 280         j_end = MIN(jte,jde-2)
 281         j_end_f = jde-3
 282       ENDIF
 283
 284       IF(config_flags%polar) j_end = MIN(jte,jde-1)
 285
 286 !  compute fluxes, 5th or 6th order
 287
 288      jp1 = 2
 289      jp0 = 1
 290
 291      j_loop_y_flux_6 : DO j = j_start, j_end+1
 292
 293         IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN  ! use full stencil
 294
 295            DO k=kts,ktf
 296            DO i = i_start, i_end
 297               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 298               fqy( i, k, jp1 ) = vel*flux6(                                &
 299                                  u(i,k,j-3), u(i,k,j-2), u(i,k,j-1),       &
 300                                  u(i,k,j  ), u(i,k,j+1), u(i,k,j+2),  vel )
 301            ENDDO
 302            ENDDO
 303
 304 !  we must be close to some boundary where we need to reduce the order of the stencil
 305
 306         ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
 307
 308            DO k=kts,ktf
 309            DO i = i_start, i_end
 310               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))  &
 311                                     *(u(i,k,j)+u(i,k,j-1))
 312            ENDDO
 313            ENDDO
 314
 315         ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
 316
 317            DO k=kts,ktf
 318            DO i = i_start, i_end
 319               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 320               fqy( i, k, jp1 ) = vel*flux4(      &
 321                    u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel )
 322            ENDDO
 323            ENDDO
 324
 325         ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
 326
 327            DO k=kts,ktf
 328            DO i = i_start, i_end
 329               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
 330                      *(u(i,k,j)+u(i,k,j-1))
 331            ENDDO
 332            ENDDO
 333
 334         ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
 335
 336            DO k=kts,ktf
 337            DO i = i_start, i_end
 338               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 339               fqy( i, k, jp1 ) = vel*flux4(     &
 340                    u(i,k,j-2),u(i,k,j-1),    &
 341                    u(i,k,j),u(i,k,j+1),vel )
 342            ENDDO
 343            ENDDO
 344
 345         END IF
 346
 347 !stopped
 348
 349 !  y flux-divergence into tendency
 350
 351 !       Comments for polar boundary condition
 352 !       Flow is only from one side for points next to poles
 353 !       S. pole at j=jds, N. pole at j=jde for v-stagger points
 354 !       Tendencies affected are held at j=jds and j=jde-1 (non-stagger)
 355 !       jp0 will always hold the flux from the south, and
 356 !       jp1 will hold the flux from the north.
 357 !
 358 !       When j=jds+1 we are 1 in from S. pole, and jp1 contains fqy(jds+1), jp0 has fqy(jds)
 359 !       tendency(j-1) = - mx/dy * (u rho v (jds+1)/mx - u rho v (jds)/mx)
 360 !                       v(jds) = 0
 361 !       tendency(j-1) = - mx/dy * (u rho v (jds+1)/mx) = - mx/dy * fqy(jp1)
 362 !
 363 !       When j=jde-1 we are 1 in from N. pole, and jp1 contains fqy(jde-1), jp0 has fqy(jde-2)
 364 !       tendency(j-1) = - mx/dy * (u rho v (jde)/mx - u rho v (jde-1)/mx)
 365 !                       v(jde) = 0
 366 !       tendency(j-1) = + mx/dy * (u rho v (jde-1)/mx) = + mx/dy * fqy(jp0)
 367
 368         ! (j > j_start) will miss the u(,,jds) tendency
 369         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
 370           DO k=kts,ktf
 371           DO i = i_start, i_end
 372             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 373             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
 374           END DO
 375           END DO
 376         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 377         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
 378           DO k=kts,ktf
 379           DO i = i_start, i_end
 380             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 381             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
 382           END DO
 383           END DO
 384         ELSE  ! normal code
 385
 386         IF(j > j_start) THEN
 387
 388           DO k=kts,ktf
 389           DO i = i_start, i_end
 390             mrdy=msfux(i,j-1)*rdy                 ! ADT eqn 44, 2nd term on RHS
 391             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
 392           ENDDO
 393           ENDDO
 394
 395         ENDIF
 396
 397         END IF
 398
 399
 400         jtmp = jp1
 401         jp1 = jp0
 402         jp0 = jtmp
 403
 404    ENDDO j_loop_y_flux_6
 405
 406 !  next, x - flux divergence
 407
 408       i_start = its
 409       i_end   = ite
 410
 411       j_start = jts
 412       j_end   = MIN(jte,jde-1)
 413
 414 !  higher order flux has a 5 or 7 point stencil, so compute
 415 !  bounds so we can switch to second order flux close to the boundary
 416
 417       i_start_f = i_start
 418       i_end_f   = i_end+1
 419
 420       IF(degrade_xs) then
 421         i_start = MAX(ids+1,its)
 422         i_start_f = ids+3
 423       ENDIF
 424
 425       IF(degrade_xe) then
 426         i_end = MIN(ide-1,ite)
 427         i_end_f = ide-2
 428       ENDIF
 429
 430 !  compute fluxes
 431
 432       DO j = j_start, j_end
 433
 434 !  5th or 6th order flux
 435
 436         DO k=kts,ktf
 437         DO i = i_start_f, i_end_f
 438           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 439           fqx( i,k ) = vel*flux6( u(i-3,k,j), u(i-2,k,j),  &
 440                                          u(i-1,k,j), u(i  ,k,j),  &
 441                                          u(i+1,k,j), u(i+2,k,j),  &
 442                                          vel                     )
 443         ENDDO
 444         ENDDO
 445
 446 !  lower order fluxes close to boundaries (if not periodic or symmetric)
 447 !  specified uses upstream normal wind at boundaries
 448
 449         IF( degrade_xs ) THEN
 450
 451           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
 452             i = ids+1
 453             DO k=kts,ktf
 454               ub = u(i-1,k,j)
 455               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
 456               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 457                      *(u(i,k,j)+ub)
 458             ENDDO
 459           END IF
 460
 461           i = ids+2
 462           DO k=kts,ktf
 463             vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 464             fqx( i, k  ) = vel*flux4( u(i-2,k,j), u(i-1,k,j),  &
 465                                            u(i  ,k,j), u(i+1,k,j),  &
 466                                            vel                     )
 467           ENDDO
 468
 469         ENDIF
 470
 471         IF( degrade_xe ) THEN
 472
 473           IF( i_end == ide-1 ) THEN ! second order flux next to the boundary
 474             i = ide
 475             DO k=kts,ktf
 476               ub = u(i,k,j)
 477               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
 478               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 479                      *(u(i-1,k,j)+ub)
 480             ENDDO
 481           ENDIF
 482
 483           DO k=kts,ktf
 484           i = ide-1
 485           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 486           fqx( i,k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j),  &
 487                                          u(i  ,k,j), u(i+1,k,j),  &
 488                                          vel                     )
 489           ENDDO
 490
 491         ENDIF
 492
 493 !  x flux-divergence into tendency
 494
 495         DO k=kts,ktf
 496           DO i = i_start, i_end
 497             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
 498             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
 499           ENDDO
 500         ENDDO
 501
 502       ENDDO
 503
 504    ELSE IF( horz_order == 5 ) THEN
 505
 506 !  5th order horizontal flux calculation
 507 !  This code is EXACTLY the same as the 6th order code
 508 !  EXCEPT the 5th order and 3rd operators are used in
 509 !  place of the 6th and 4th order operators
 510
 511 !  determine boundary mods for flux operators
 512 !  We degrade the flux operators from 3rd/4th order
 513 !   to second order one gridpoint in from the boundaries for
 514 !   all boundary conditions except periodic and symmetry - these
 515 !   conditions have boundary zone data fill for correct application
 516 !   of the higher order flux stencils
 517
 518    degrade_xs = .true.
 519    degrade_xe = .true.
 520    degrade_ys = .true.
 521    degrade_ye = .true.
 522
 523    IF( config_flags%periodic_x   .or. &
 524        config_flags%symmetric_xs .or. &
 525        (its > ids+2)                ) degrade_xs = .false.
 526    IF( config_flags%periodic_x   .or. &
 527        config_flags%symmetric_xe .or. &
 528        (ite < ide-2)                ) degrade_xe = .false.
 529    IF( config_flags%periodic_y   .or. &
 530        config_flags%symmetric_ys .or. &
 531        (jts > jds+2)                ) degrade_ys = .false.
 532    IF( config_flags%periodic_y   .or. &
 533        config_flags%symmetric_ye .or. &
 534        (jte < jde-3)                ) degrade_ye = .false.
 535
 536 !--------------- y - advection first
 537
 538       i_start = its
 539       i_end   = ite
 540       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
 541       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
 542       IF ( config_flags%periodic_x ) i_start = its
 543       IF ( config_flags%periodic_x ) i_end = ite
 544
 545       j_start = jts
 546       j_end   = MIN(jte,jde-1)
 547
 548 !  higher order flux has a 5 or 7 point stencil, so compute
 549 !  bounds so we can switch to second order flux close to the boundary
 550
 551       j_start_f = j_start
 552       j_end_f   = j_end+1
 553
 554       IF(degrade_ys) then
 555         j_start = MAX(jts,jds+1)
 556         j_start_f = jds+3
 557       ENDIF
 558
 559       IF(degrade_ye) then
 560         j_end = MIN(jte,jde-2)
 561         j_end_f = jde-3
 562       ENDIF
 563
 564       IF(config_flags%polar) j_end = MIN(jte,jde-1)
 565
 566 !  compute fluxes, 5th or 6th order
 567
 568      jp1 = 2
 569      jp0 = 1
 570
 571      j_loop_y_flux_5 : DO j = j_start, j_end+1
 572
 573       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN  ! use full stencil
 574
 575         DO k=kts,ktf
 576         DO i = i_start, i_end
 577           vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 578           fqy( i, k, jp1 ) = vel*flux5(               &
 579                   u(i,k,j-3), u(i,k,j-2), u(i,k,j-1),       &
 580                   u(i,k,j  ), u(i,k,j+1), u(i,k,j+2),  vel )
 581         ENDDO
 582         ENDDO
 583
 584 !  we must be close to some boundary where we need to reduce the order of the stencil
 585
 586       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
 587
 588             DO k=kts,ktf
 589             DO i = i_start, i_end
 590               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))  &
 591                                      *(u(i,k,j)+u(i,k,j-1))
 592             ENDDO
 593             ENDDO
 594
 595      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
 596
 597             DO k=kts,ktf
 598             DO i = i_start, i_end
 599               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 600               fqy( i, k, jp1 ) = vel*flux3(      &
 601                    u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel )
 602             ENDDO
 603             ENDDO
 604
 605      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
 606
 607             DO k=kts,ktf
 608             DO i = i_start, i_end
 609               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
 610                      *(u(i,k,j)+u(i,k,j-1))
 611             ENDDO
 612             ENDDO
 613
 614      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
 615
 616             DO k=kts,ktf
 617             DO i = i_start, i_end
 618               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 619               fqy( i, k, jp1 ) = vel*flux3(     &
 620                    u(i,k,j-2),u(i,k,j-1),    &
 621                    u(i,k,j),u(i,k,j+1),vel )
 622             ENDDO
 623             ENDDO
 624
 625       END IF
 626
 627 !  y flux-divergence into tendency
 628
 629         ! (j > j_start) will miss the u(,,jds) tendency
 630         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
 631           DO k=kts,ktf
 632           DO i = i_start, i_end
 633             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 634             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
 635           END DO
 636           END DO
 637         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 638         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
 639           DO k=kts,ktf
 640           DO i = i_start, i_end
 641             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 642             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
 643           END DO
 644           END DO
 645         ELSE  ! normal code
 646
 647         IF(j > j_start) THEN
 648
 649           DO k=kts,ktf
 650           DO i = i_start, i_end
 651             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 652             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
 653           ENDDO
 654           ENDDO
 655
 656         ENDIF
 657
 658         END IF
 659
 660
 661         jtmp = jp1
 662         jp1 = jp0
 663         jp0 = jtmp
 664
 665    ENDDO j_loop_y_flux_5
 666
 667 !  next, x - flux divergence
 668
 669       i_start = its
 670       i_end   = ite
 671
 672       j_start = jts
 673       j_end   = MIN(jte,jde-1)
 674
 675 !  higher order flux has a 5 or 7 point stencil, so compute
 676 !  bounds so we can switch to second order flux close to the boundary
 677
 678       i_start_f = i_start
 679       i_end_f   = i_end+1
 680
 681       IF(degrade_xs) then
 682         i_start = MAX(ids+1,its)
 683         i_start_f = ids+3
 684       ENDIF
 685
 686       IF(degrade_xe) then
 687         i_end = MIN(ide-1,ite)
 688         i_end_f = ide-2
 689       ENDIF
 690
 691 !  compute fluxes
 692
 693       DO j = j_start, j_end
 694
 695 !  5th or 6th order flux
 696
 697         DO k=kts,ktf
 698         DO i = i_start_f, i_end_f
 699           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 700           fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j),  &
 701                                          u(i-1,k,j), u(i  ,k,j),  &
 702                                          u(i+1,k,j), u(i+2,k,j),  &
 703                                          vel                     )
 704         ENDDO
 705         ENDDO
 706
 707 !  lower order fluxes close to boundaries (if not periodic or symmetric)
 708 !  specified uses upstream normal wind at boundaries
 709
 710         IF( degrade_xs ) THEN
 711
 712           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
 713             i = ids+1
 714             DO k=kts,ktf
 715               ub = u(i-1,k,j)
 716               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
 717               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 718                      *(u(i,k,j)+ub)
 719             ENDDO
 720           END IF
 721
 722           i = ids+2
 723           DO k=kts,ktf
 724             vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 725             fqx( i, k  ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
 726                                            u(i  ,k,j), u(i+1,k,j),  &
 727                                            vel                     )
 728           ENDDO
 729
 730         ENDIF
 731
 732         IF( degrade_xe ) THEN
 733
 734           IF( i_end == ide-1 ) THEN ! second order flux next to the boundary
 735             i = ide
 736             DO k=kts,ktf
 737               ub = u(i,k,j)
 738               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
 739               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 740                      *(u(i-1,k,j)+ub)
 741             ENDDO
 742           ENDIF
 743
 744           DO k=kts,ktf
 745           i = ide-1
 746           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 747           fqx( i,k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
 748                                          u(i  ,k,j), u(i+1,k,j),  &
 749                                          vel                     )
 750           ENDDO
 751
 752         ENDIF
 753
 754 !  x flux-divergence into tendency
 755
 756         DO k=kts,ktf
 757           DO i = i_start, i_end
 758             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
 759             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
 760           ENDDO
 761         ENDDO
 762
 763       ENDDO
 764
 765    ELSE IF( horz_order == 4 ) THEN
 766
 767 !  determine boundary mods for flux operators
 768 !  We degrade the flux operators from 3rd/4th order
 769 !   to second order one gridpoint in from the boundaries for
 770 !   all boundary conditions except periodic and symmetry - these
 771 !   conditions have boundary zone data fill for correct application
 772 !   of the higher order flux stencils
 773
 774    degrade_xs = .true.
 775    degrade_xe = .true.
 776    degrade_ys = .true.
 777    degrade_ye = .true.
 778
 779    IF( config_flags%periodic_x   .or. &
 780        config_flags%symmetric_xs .or. &
 781        (its > ids+1)                ) degrade_xs = .false.
 782    IF( config_flags%periodic_x   .or. &
 783        config_flags%symmetric_xe .or. &
 784        (ite < ide-1)                ) degrade_xe = .false.
 785    IF( config_flags%periodic_y   .or. &
 786        config_flags%symmetric_ys .or. &
 787        (jts > jds+1)                ) degrade_ys = .false.
 788    IF( config_flags%periodic_y   .or. &
 789        config_flags%symmetric_ye .or. &
 790        (jte < jde-2)                ) degrade_ye = .false.
 791
 792 !--------------- x - advection first
 793
 794       i_start = its
 795       i_end   = ite
 796       j_start = jts
 797       j_end   = MIN(jte,jde-1)
 798
 799 !  3rd or 4th order flux has a 5 point stencil, so compute
 800 !  bounds so we can switch to second order flux close to the boundary
 801
 802       i_start_f = i_start
 803       i_end_f   = i_end+1
 804
 805       IF(degrade_xs) then
 806         i_start = ids+1
 807         i_start_f = i_start+1
 808       ENDIF
 809
 810       IF(degrade_xe) then
 811         i_end = ide-1
 812         i_end_f = ide-1
 813       ENDIF
 814
 815 !  compute fluxes
 816
 817       DO j = j_start, j_end
 818
 819         DO k=kts,ktf
 820         DO i = i_start_f, i_end_f
 821           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 822           fqx( i, k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j),      &
 823                                    u(i  ,k,j), u(i+1,k,j), vel )
 824         ENDDO
 825         ENDDO
 826
 827 !  second order flux close to boundaries (if not periodic or symmetric)
 828 !  specified uses upstream normal wind at boundaries
 829
 830         IF( degrade_xs ) THEN
 831           i = i_start
 832           DO k=kts,ktf
 833               ub = u(i-1,k,j)
 834               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
 835               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 836                      *(u(i,k,j)+ub)
 837           ENDDO
 838         ENDIF
 839
 840         IF( degrade_xe ) THEN
 841           i = i_end+1
 842           DO k=kts,ktf
 843               ub = u(i,k,j)
 844               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
 845               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 846                      *(u(i-1,k,j)+ub)
 847           ENDDO
 848         ENDIF
 849
 850 !  x flux-divergence into tendency
 851
 852         DO k=kts,ktf
 853           DO i = i_start, i_end
 854             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
 855             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
 856           ENDDO
 857         ENDDO
 858
 859       ENDDO
 860
 861 !  y flux divergence
 862
 863       i_start = its
 864       i_end   = ite
 865       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
 866       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
 867       IF ( config_flags%periodic_x ) i_start = its
 868       IF ( config_flags%periodic_x ) i_end = ite
 869
 870       j_start = jts
 871       j_end   = MIN(jte,jde-1)
 872
 873 !  3rd or 4th order flux has a 5 point stencil, so compute
 874 !  bounds so we can switch to second order flux close to the boundary
 875
 876       j_start_f = j_start
 877       j_end_f   = j_end+1
 878
 879 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
 880       IF(degrade_ys) then
 881         j_start = jds+1
 882         j_start_f = j_start+1
 883       ENDIF
 884
 885       IF(degrade_ye) then
 886         j_end = jde-2
 887         j_end_f = jde-2
 888       ENDIF
 889
 890       IF(config_flags%polar) j_end = MIN(jte,jde-1)
 891
 892 !  j flux loop for v flux of u momentum
 893
 894      jp1 = 2
 895      jp0 = 1
 896
 897    DO j = j_start, j_end+1
 898
 899      IF ( (j < j_start_f) .and. degrade_ys) THEN
 900        DO k = kts, ktf
 901        DO i = i_start, i_end
 902          fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start))  &
 903                *(u(i,k,j_start)+u(i,k,j_start-1))
 904        ENDDO
 905        ENDDO
 906      ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
 907        DO k = kts, ktf
 908        DO i = i_start, i_end
 909          ! Assumes j>j_end_f is ONLY j_end+1 ...
 910 !         fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1))    &
 911 !                *(u(i,k,j_end+1)+u(i,k,j_end))
 912          fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
 913                 *(u(i,k,j)+u(i,k,j-1))
 914        ENDDO
 915        ENDDO
 916      ELSE
 917 !  3rd or 4th order flux
 918        DO k = kts, ktf
 919        DO i = i_start, i_end
 920          vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 921          fqy( i, k, jp1 ) = vel*flux4( u(i,k,j-2), u(i,k,j-1),  &
 922                                        u(i,k,j  ), u(i,k,j+1),  &
 923                                             vel                )
 924        ENDDO
 925        ENDDO
 926
 927      END IF
 928
 929 !  y flux-divergence into tendency
 930
 931      ! (j > j_start) will miss the u(,,jds) tendency
 932      IF ( config_flags%polar .AND. (j == jds+1) ) THEN
 933        DO k=kts,ktf
 934        DO i = i_start, i_end
 935          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 936          tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
 937        END DO
 938        END DO
 939        ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 940      ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
 941        DO k=kts,ktf
 942        DO i = i_start, i_end
 943          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 944          tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
 945        END DO
 946        END DO
 947      ELSE  ! normal code
 948
 949      IF (j > j_start) THEN
 950
 951        DO k=kts,ktf
 952        DO i = i_start, i_end
 953           mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
 954           tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
 955        ENDDO
 956        ENDDO
 957
 958      END IF
 959
 960      END IF
 961
 962      jtmp = jp1
 963      jp1 = jp0
 964      jp0 = jtmp
 965
 966   ENDDO
 967
 968   ELSE IF ( horz_order == 3 ) THEN
 969
 970 !  As with the 5th and 6th order flux chioces, the 3rd and 4th order
 971 !  code is EXACTLY the same EXCEPT for the flux operator.
 972
 973 !  determine boundary mods for flux operators
 974 !  We degrade the flux operators from 3rd/4th order
 975 !   to second order one gridpoint in from the boundaries for
 976 !   all boundary conditions except periodic and symmetry - these
 977 !   conditions have boundary zone data fill for correct application
 978 !   of the higher order flux stencils
 979
 980    degrade_xs = .true.
 981    degrade_xe = .true.
 982    degrade_ys = .true.
 983    degrade_ye = .true.
 984
 985    IF( config_flags%periodic_x   .or. &
 986        config_flags%symmetric_xs .or. &
 987        (its > ids+1)                ) degrade_xs = .false.
 988    IF( config_flags%periodic_x   .or. &
 989        config_flags%symmetric_xe .or. &
 990        (ite < ide-1)                ) degrade_xe = .false.
 991    IF( config_flags%periodic_y   .or. &
 992        config_flags%symmetric_ys .or. &
 993        (jts > jds+1)                ) degrade_ys = .false.
 994    IF( config_flags%periodic_y   .or. &
 995        config_flags%symmetric_ye .or. &
 996        (jte < jde-2)                ) degrade_ye = .false.
 997
 998 !--------------- x - advection first
 999
1000       i_start = its
1001       i_end   = ite
1002       j_start = jts
1003       j_end   = MIN(jte,jde-1)
1004
1005 !  3rd or 4th order flux has a 5 point stencil, so compute
1006 !  bounds so we can switch to second order flux close to the boundary
1007
1008       i_start_f = i_start
1009       i_end_f   = i_end+1
1010
1011       IF(degrade_xs) then
1012         i_start = ids+1
1013         i_start_f = i_start+1
1014       ENDIF
1015
1016       IF(degrade_xe) then
1017         i_end = ide-1
1018         i_end_f = ide-1
1019       ENDIF
1020
1021 !  compute fluxes
1022
1023       DO j = j_start, j_end
1024
1025         DO k=kts,ktf
1026         DO i = i_start_f, i_end_f
1027           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
1028           fqx( i, k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),      &
1029                                    u(i  ,k,j), u(i+1,k,j), vel )
1030         ENDDO
1031         ENDDO
1032
1033 !  second order flux close to boundaries (if not periodic or symmetric)
1034 !  specified uses upstream normal wind at boundaries
1035
1036         IF( degrade_xs ) THEN
1037           i = i_start
1038           DO k=kts,ktf
1039               ub = u(i-1,k,j)
1040               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
1041               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
1042                      *(u(i,k,j)+ub)
1043           ENDDO
1044         ENDIF
1045
1046         IF( degrade_xe ) THEN
1047           i = i_end+1
1048           DO k=kts,ktf
1049               ub = u(i,k,j)
1050               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
1051               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
1052                      *(u(i-1,k,j)+ub)
1053           ENDDO
1054         ENDIF
1055
1056 !  x flux-divergence into tendency
1057
1058         DO k=kts,ktf
1059           DO i = i_start, i_end
1060           mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
1061             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
1062           ENDDO
1063         ENDDO
1064       ENDDO
1065
1066 !  y flux divergence
1067
1068       i_start = its
1069       i_end   = ite
1070       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
1071       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
1072       IF ( config_flags%periodic_x ) i_start = its
1073       IF ( config_flags%periodic_x ) i_end = ite
1074
1075       j_start = jts
1076       j_end   = MIN(jte,jde-1)
1077
1078 !  3rd or 4th order flux has a 5 point stencil, so compute
1079 !  bounds so we can switch to second order flux close to the boundary
1080
1081       j_start_f = j_start
1082       j_end_f   = j_end+1
1083
1084 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
1085       IF(degrade_ys) then
1086         j_start = jds+1
1087         j_start_f = j_start+1
1088       ENDIF
1089
1090       IF(degrade_ye) then
1091         j_end = jde-2
1092         j_end_f = jde-2
1093       ENDIF
1094
1095       IF(config_flags%polar) j_end = MIN(jte,jde-1)
1096
1097 !  j flux loop for v flux of u momentum
1098
1099      jp1 = 2
1100      jp0 = 1
1101
1102    DO j = j_start, j_end+1
1103
1104      IF ( (j < j_start_f) .and. degrade_ys) THEN
1105        DO k = kts, ktf
1106        DO i = i_start, i_end
1107          fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start))  &
1108                *(u(i,k,j_start)+u(i,k,j_start-1))
1109        ENDDO
1110        ENDDO
1111      ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
1112        DO k = kts, ktf
1113        DO i = i_start, i_end
1114          ! Assumes j>j_end_f is ONLY j_end+1 ...
1115 !         fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1))    &
1116 !                *(u(i,k,j_end+1)+u(i,k,j_end))
1117          fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
1118                 *(u(i,k,j)+u(i,k,j-1))
1119        ENDDO
1120        ENDDO
1121      ELSE
1122 !  3rd or 4th order flux
1123        DO k = kts, ktf
1124        DO i = i_start, i_end
1125          vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
1126          fqy( i, k, jp1 ) = vel*flux3( u(i,k,j-2), u(i,k,j-1),  &
1127                                        u(i,k,j  ), u(i,k,j+1),  &
1128                                             vel                )
1129        ENDDO
1130        ENDDO
1131
1132      END IF
1133
1134 !  y flux-divergence into tendency
1135
1136      ! (j > j_start) will miss the u(,,jds) tendency
1137      IF ( config_flags%polar .AND. (j == jds+1) ) THEN
1138        DO k=kts,ktf
1139        DO i = i_start, i_end
1140          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
1141          tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
1142        END DO
1143        END DO
1144        ! This would be seen by (j > j_start) but we need to zero out the NP tendency
1145      ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
1146        DO k=kts,ktf
1147        DO i = i_start, i_end
1148          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
1149          tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
1150        END DO
1151        END DO
1152      ELSE  ! normal code
1153
1154      IF (j > j_start) THEN
1155
1156        DO k=kts,ktf
1157        DO i = i_start, i_end
1158           mrdy=msfux(i,j-1)*rdy      ! ADT eqn 44, 2nd term on RHS
1159           tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
1160        ENDDO
1161        ENDDO
1162
1163      END IF
1164
1165      END IF
1166
1167      jtmp = jp1
1168      jp1 = jp0
1169      jp0 = jtmp
1170
1171   ENDDO
1172
1173   ELSE IF ( horz_order == 2 ) THEN
1174
1175       i_start = its
1176       i_end   = ite
1177       j_start = jts
1178       j_end   = MIN(jte,jde-1)
1179
1180       IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
1181       IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
1182       IF ( specified ) i_start = MAX(ids+2,its)
1183       IF ( specified ) i_end   = MIN(ide-2,ite)
1184       IF ( config_flags%periodic_x ) i_start = its
1185       IF ( config_flags%periodic_x ) i_end = ite
1186
1187       DO j = j_start, j_end
1188       DO k=kts,ktf
1189       DO i = i_start, i_end
1190          mrdx=msfux(i,j)*rdx         ! ADT eqn 44, 1st term on RHS
1191          tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1192                 *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) &
1193                 -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j)))
1194       ENDDO
1195       ENDDO
1196       ENDDO
1197
1198       IF ( specified .AND. its .LE. ids+1 .AND. .NOT. config_flags%periodic_x ) THEN
1199         DO j = j_start, j_end
1200         DO k=kts,ktf
1201            i = ids+1
1202            mrdx=msfux(i,j)*rdx       ! ADT eqn 44, 1st term on RHS
1203            ub = u(i-1,k,j)
1204            IF (u(i,k,j) .LT. 0.) ub = u(i,k,j)
1205            tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1206                   *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) &
1207                   -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+ub))
1208         ENDDO
1209         ENDDO
1210       ENDIF
1211       IF ( specified .AND. ite .GE. ide-1 .AND. .NOT. config_flags%periodic_x ) THEN
1212         DO j = j_start, j_end
1213         DO k=kts,ktf
1214            i = ide-1
1215            mrdx=msfux(i,j)*rdx       ! ADT eqn 44, 1st term on RHS
1216            ub = u(i+1,k,j)
1217            IF (u(i,k,j) .GT. 0.) ub = u(i,k,j)
1218            tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1219                   *((ru(i+1,k,j)+ru(i,k,j))*(ub+u(i,k,j)) &
1220                   -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j)))
1221         ENDDO
1222         ENDDO
1223       ENDIF
1224
1225       IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
1226       IF ( config_flags%open_ye .or. specified ) j_end   = MIN(jde-2,jte)
1227
1228       DO j = j_start, j_end
1229       DO k=kts,ktf
1230       DO i = i_start, i_end
1231          mrdy=msfux(i,j)*rdy         ! ADT eqn 44, 1st term on RHS
1232          ! Comments for polar boundary condition
1233          ! Flow is only from one side for points next to poles
1234          IF ( (config_flags%polar) .AND. (j == jds) ) THEN
1235             tendency(i,k,j)=tendency(i,k,j)-mrdy*0.25 &
1236                             *(rv(i,k,j+1)+rv(i-1,k,j+1))*(u(i,k,j+1)+u(i,k,j))
1237          ELSE IF ( (config_flags%polar) .AND. (j == jde-1) ) THEN
1238             tendency(i,k,j)=tendency(i,k,j)+mrdy*0.25 &
1239                            *(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1))
1240          ELSE  ! Normal code
1241             tendency(i,k,j)=tendency(i,k,j)-mrdy*0.25 &
1242                 *((rv(i,k,j+1)+rv(i-1,k,j+1))*(u(i,k,j+1)+u(i,k,j)) &
1243                  -(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1)))
1244          ENDIF
1245       ENDDO
1246       ENDDO
1247       ENDDO
1248
1249    ELSE IF ( horz_order == 0 ) THEN
1250
1251       ! Just in case we want to turn horizontal advection off, we can do it
1252
1253    ELSE
1254
1255       WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a:  h_order not known ',horz_order
1256       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1257
1258    ENDIF horizontal_order_test
1259
1260 !  radiative lateral boundary condition in x for normal velocity (u)
1261
1262       IF ( (config_flags%open_xs) .and. its == ids ) THEN
1263
1264         j_start = jts
1265         j_end   = MIN(jte,jde-1)
1266
1267         DO j = j_start, j_end
1268         DO k = kts, ktf
1269           ub = MIN(ru(its,k,j)-cb*mut(its,j), 0.)
1270           tendency(its,k,j) = tendency(its,k,j)                    &
1271                       - rdx*ub*(u_old(its+1,k,j) - u_old(its,k,j))
1272         ENDDO
1273         ENDDO
1274
1275       ENDIF
1276
1277       IF ( (config_flags%open_xe) .and. ite == ide ) THEN
1278
1279         j_start = jts
1280         j_end   = MIN(jte,jde-1)
1281
1282         DO j = j_start, j_end
1283         DO k = kts, ktf
1284           ub = MAX(ru(ite,k,j)+cb*mut(ite-1,j), 0.)
1285           tendency(ite,k,j) = tendency(ite,k,j)                    &
1286                       - rdx*ub*(u_old(ite,k,j) - u_old(ite-1,k,j))
1287         ENDDO
1288         ENDDO
1289
1290       ENDIF
1291
1292 !  pick up the rest of the horizontal radiation boundary conditions.
1293 !  (these are the computations that don't require 'cb')
1294 !  first, set to index ranges
1295
1296       i_start = its
1297       i_end   = MIN(ite,ide)
1298       imin    = ids
1299       imax    = ide-1
1300
1301       IF (config_flags%open_xs) THEN
1302         i_start = MAX(ids+1, its)
1303         imin = ids
1304       ENDIF
1305       IF (config_flags%open_xe) THEN
1306         i_end = MIN(ite,ide-1)
1307         imax = ide-1
1308       ENDIF
1309
1310    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
1311
1312       DO i = i_start, i_end
1313
1314          mrdy=msfux(i,jts)*rdy       ! ADT eqn 44, 2nd term on RHS
1315          ip = MIN( imax, i   )
1316          im = MAX( imin, i-1 )
1317
1318          DO k=kts,ktf
1319
1320           vw = 0.5*(rv(ip,k,jts)+rv(im,k,jts))
1321           vb = MIN( vw, 0. )
1322           dvm =  rv(ip,k,jts+1)-rv(ip,k,jts)
1323           dvp =  rv(im,k,jts+1)-rv(im,k,jts)
1324           tendency(i,k,jts)=tendency(i,k,jts)-mrdy*(                &
1325                             vb*(u_old(i,k,jts+1)-u_old(i,k,jts))    &
1326                            +0.5*u(i,k,jts)*(dvm+dvp))
1327          ENDDO
1328       ENDDO
1329
1330    ENDIF
1331
1332    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
1333
1334       DO i = i_start, i_end
1335
1336          mrdy=msfux(i,jte-1)*rdy     ! ADT eqn 44, 2nd term on RHS
1337          ip = MIN( imax, i   )
1338          im = MAX( imin, i-1 )
1339
1340          DO k=kts,ktf
1341
1342           vw = 0.5*(rv(ip,k,jte)+rv(im,k,jte))
1343           vb = MAX( vw, 0. )
1344           dvm =  rv(ip,k,jte)-rv(ip,k,jte-1)
1345           dvp =  rv(im,k,jte)-rv(im,k,jte-1)
1346           tendency(i,k,jte-1)=tendency(i,k,jte-1)-mrdy*(              &
1347                               vb*(u_old(i,k,jte-1)-u_old(i,k,jte-2))  &
1348                              +0.5*u(i,k,jte-1)*(dvm+dvp))
1349          ENDDO
1350       ENDDO
1351
1352    ENDIF
1353
1354 !-------------------- vertical advection
1355 !  ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
1356 !  Here we have:  - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
1357 !  Since 'my' (map scale factor in y-direction) isn't a function of z,
1358 !  this is what we need, so leave unchanged in advect_u
1359
1360    i_start = its
1361    i_end   = ite
1362    j_start = jts
1363    j_end   = min(jte,jde-1)
1364
1365 !   IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
1366 !   IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
1367
1368    IF ( config_flags%open_ys .or. specified ) i_start = MAX(ids+1,its)
1369    IF ( config_flags%open_ye .or. specified ) i_end   = MIN(ide-1,ite)
1370       IF ( config_flags%periodic_x ) i_start = its
1371       IF ( config_flags%periodic_x ) i_end = ite
1372
1373    DO i = i_start, i_end
1374      vflux(i,kts)=0.
1375      vflux(i,kte)=0.
1376    ENDDO
1377
1378    vert_order_test : IF (vert_order == 6) THEN
1379
1380       DO j = j_start, j_end
1381
1382          DO k=kts+3,ktf-2
1383          DO i = i_start, i_end
1384            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1385            vflux(i,k) = vel*flux6(                     &
1386                    u(i,k-3,j), u(i,k-2,j), u(i,k-1,j),       &
1387                    u(i,k  ,j), u(i,k+1,j), u(i,k+2,j),  -vel )
1388          ENDDO
1389          ENDDO
1390
1391          DO i = i_start, i_end
1392
1393            k=kts+1
1394            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1395                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1396            k = kts+2
1397            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1398            vflux(i,k) = vel*flux4(       &
1399                    u(i,k-2,j), u(i,k-1,j),   &
1400                    u(i,k  ,j), u(i,k+1,j), -vel )
1401            k = ktf-1
1402            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1403            vflux(i,k) = vel*flux4(       &
1404                    u(i,k-2,j), u(i,k-1,j),   &
1405                    u(i,k  ,j), u(i,k+1,j), -vel )
1406            k=ktf
1407            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1408                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1409
1410          ENDDO
1411          DO k=kts,ktf
1412          DO i = i_start, i_end
1413             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1414          ENDDO
1415          ENDDO
1416       ENDDO
1417
1418     ELSE IF (vert_order == 5) THEN
1419
1420       DO j = j_start, j_end
1421
1422          DO k=kts+3,ktf-2
1423          DO i = i_start, i_end
1424            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1425            vflux(i,k) = vel*flux5(                     &
1426                    u(i,k-3,j), u(i,k-2,j), u(i,k-1,j),       &
1427                    u(i,k  ,j), u(i,k+1,j), u(i,k+2,j),  -vel )
1428          ENDDO
1429          ENDDO
1430
1431          DO i = i_start, i_end
1432
1433            k=kts+1
1434            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1435                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1436            k = kts+2
1437            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1438            vflux(i,k) = vel*flux3(       &
1439                    u(i,k-2,j), u(i,k-1,j),   &
1440                    u(i,k  ,j), u(i,k+1,j), -vel )
1441            k = ktf-1
1442            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1443            vflux(i,k) = vel*flux3(       &
1444                    u(i,k-2,j), u(i,k-1,j),   &
1445                    u(i,k  ,j), u(i,k+1,j), -vel )
1446            k=ktf
1447            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1448                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1449
1450          ENDDO
1451          DO k=kts,ktf
1452          DO i = i_start, i_end
1453             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1454          ENDDO
1455          ENDDO
1456       ENDDO
1457
1458     ELSE IF (vert_order == 4) THEN
1459
1460       DO j = j_start, j_end
1461
1462          DO k=kts+2,ktf-1
1463          DO i = i_start, i_end
1464            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1465            vflux(i,k) = vel*flux4(               &
1466                    u(i,k-2,j), u(i,k-1,j),       &
1467                    u(i,k  ,j), u(i,k+1,j),  -vel )
1468          ENDDO
1469          ENDDO
1470
1471          DO i = i_start, i_end
1472
1473            k=kts+1
1474            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1475                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1476            k=ktf
1477            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1478                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1479
1480          ENDDO
1481          DO k=kts,ktf
1482          DO i = i_start, i_end
1483             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1484          ENDDO
1485          ENDDO
1486       ENDDO
1487
1488     ELSE IF (vert_order == 3) THEN
1489
1490       DO j = j_start, j_end
1491
1492          DO k=kts+2,ktf-1
1493          DO i = i_start, i_end
1494            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1495            vflux(i,k) = vel*flux3(               &
1496                    u(i,k-2,j), u(i,k-1,j),       &
1497                    u(i,k  ,j), u(i,k+1,j),  -vel )
1498          ENDDO
1499          ENDDO
1500
1501          DO i = i_start, i_end
1502
1503            k=kts+1
1504            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1505                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1506            k=ktf
1507            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1508                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1509
1510          ENDDO
1511          DO k=kts,ktf
1512          DO i = i_start, i_end
1513             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1514          ENDDO
1515          ENDDO
1516       ENDDO
1517
1518     ELSE IF (vert_order == 2) THEN
1519
1520       DO j = j_start, j_end
1521          DO k=kts+1,ktf
1522          DO i = i_start, i_end
1523                vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1524                                 *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1525          ENDDO
1526          ENDDO
1527
1528
1529          DO k=kts,ktf
1530          DO i = i_start, i_end
1531                tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1532          ENDDO
1533          ENDDO
1534
1535       ENDDO
1536
1537    ELSE
1538
1539       WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a: v_order not known ',vert_order
1540       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1541
1542    ENDIF vert_order_test
1543
1544 END SUBROUTINE advect_u
1545
1546 !-------------------------------------------------------------------------------
1547
1548 SUBROUTINE advect_v   ( v, v_old, tendency,            &
1549                         ru, rv, rom,                   &
1550                         mut, time_step, config_flags,  &
1551                         msfux, msfuy, msfvx, msfvy,    &
1552                         msftx, msfty,                  &
1553                         fzm, fzp,                      &
1554                         rdx, rdy, rdzw,                &
1555                         ids, ide, jds, jde, kds, kde,  &
1556                         ims, ime, jms, jme, kms, kme,  &
1557                         its, ite, jts, jte, kts, kte  )
1558
1559    IMPLICIT NONE
1560
1561    ! Input data
1562
1563    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
1564
1565    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
1566                                               ims, ime, jms, jme, kms, kme, &
1567                                               its, ite, jts, jte, kts, kte
1568
1569    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: v,     &
1570                                                                       v_old, &
1571                                                                       ru,    &
1572                                                                       rv,    &
1573                                                                       rom
1574
1575    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
1576    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
1577
1578    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
1579                                                                     msfuy,  &
1580                                                                     msfvx,  &
1581                                                                     msfvy,  &
1582                                                                     msftx,  &
1583                                                                     msfty
1584
1585    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
1586                                                                   fzp,  &
1587                                                                   rdzw
1588
1589    REAL ,                                        INTENT(IN   ) :: rdx,  &
1590                                                                   rdy
1591    INTEGER ,                                     INTENT(IN   ) :: time_step
1592
1593
1594    ! Local data
1595
1596    INTEGER :: i, j, k, itf, jtf, ktf
1597    INTEGER :: i_start, i_end, j_start, j_end
1598    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
1599    INTEGER :: jmin, jmax, jp, jm, imin, imax
1600
1601    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
1602    REAL , DIMENSION(its:ite, kts:kte) :: vflux
1603
1604
1605    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
1606    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
1607
1608    INTEGER :: horz_order
1609    INTEGER :: vert_order
1610
1611    LOGICAL :: degrade_xs, degrade_ys
1612    LOGICAL :: degrade_xe, degrade_ye
1613
1614    INTEGER :: jp1, jp0, jtmp
1615
1616
1617 ! definition of flux operators, 3rd, 4th, 5th or 6th order
1618
1619    REAL    :: flux3, flux4, flux5, flux6
1620    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
1621
1622    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
1623           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
1624
1625    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
1626            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
1627            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
1628
1629    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
1630                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)   &
1631                      +(q_ip2+q_im3) )/60.0
1632
1633    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
1634            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
1635             -sign(1,time_step)*sign(1.,ua)*(                    &
1636               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
1637
1638
1639
1640    LOGICAL :: specified
1641
1642    specified = .false.
1643    if(config_flags%specified .or. config_flags%nested) specified = .true.
1644
1645 ! set order for the advection schemes
1646
1647    ktf=MIN(kte,kde-1)
1648    horz_order = config_flags%h_mom_adv_order
1649    vert_order = config_flags%v_mom_adv_order
1650
1651
1652 !  here is the choice of flux operators
1653
1654
1655    horizontal_order_test : IF( horz_order == 6 ) THEN
1656
1657 !  determine boundary mods for flux operators
1658 !  We degrade the flux operators from 3rd/4th order
1659 !   to second order one gridpoint in from the boundaries for
1660 !   all boundary conditions except periodic and symmetry - these
1661 !   conditions have boundary zone data fill for correct application
1662 !   of the higher order flux stencils
1663
1664       degrade_xs = .true.
1665       degrade_xe = .true.
1666       degrade_ys = .true.
1667       degrade_ye = .true.
1668
1669       IF( config_flags%periodic_x   .or. &
1670           config_flags%symmetric_xs .or. &
1671           (its > ids+2)                ) degrade_xs = .false.
1672       IF( config_flags%periodic_x   .or. &
1673           config_flags%symmetric_xe .or. &
1674           (ite < ide-3)                ) degrade_xe = .false.
1675       IF( config_flags%periodic_y   .or. &
1676           config_flags%symmetric_ys .or. &
1677           (jts > jds+2)                ) degrade_ys = .false.
1678       IF( config_flags%periodic_y   .or. &
1679           config_flags%symmetric_ye .or. &
1680           (jte < jde-2)                ) degrade_ye = .false.
1681
1682 !--------------- y - advection first
1683
1684       ktf=MIN(kte,kde-1)
1685
1686       i_start = its
1687       i_end   = MIN(ite,ide-1)
1688       j_start = jts
1689       j_end   = jte
1690
1691 !  higher order flux has a 5 or 7 point stencil, so compute
1692 !  bounds so we can switch to second order flux close to the boundary
1693
1694       j_start_f = j_start
1695       j_end_f   = j_end+1
1696
1697       IF(degrade_ys) then
1698          j_start = MAX(jts,jds+1)
1699          j_start_f = jds+3
1700       ENDIF
1701
1702       IF(degrade_ye) then
1703          j_end = MIN(jte,jde-1)
1704          j_end_f = jde-2
1705       ENDIF
1706
1707 !  compute fluxes, 5th or 6th order
1708
1709       jp1 = 2
1710       jp0 = 1
1711
1712       j_loop_y_flux_6 : DO j = j_start, j_end+1
1713
1714          IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
1715
1716             DO k=kts,ktf
1717             DO i = i_start, i_end
1718                vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1719                fqy( i, k, jp1 ) = vel*flux6(                                &
1720                                   v(i,k,j-3), v(i,k,j-2), v(i,k,j-1),       &
1721                                   v(i,k,j  ), v(i,k,j+1), v(i,k,j+2),  vel )
1722             ENDDO
1723             ENDDO
1724
1725 !  we must be close to some boundary where we need to reduce the order of the stencil
1726 !  specified uses upstream normal wind at boundaries
1727
1728          ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
1729
1730             DO k=kts,ktf
1731             DO i = i_start, i_end
1732                 vb = v(i,k,j-1)
1733                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
1734                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
1735                                  *(v(i,k,j)+vb)
1736             ENDDO
1737             ENDDO
1738
1739          ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
1740
1741             DO k=kts,ktf
1742             DO i = i_start, i_end
1743                 vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1744                 fqy( i, k, jp1 ) = vel*flux4(      &
1745                                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
1746             ENDDO
1747             ENDDO
1748
1749
1750          ELSE IF ( j == jde ) THEN  ! 2nd order flux next to north boundary
1751
1752             DO k=kts,ktf
1753             DO i = i_start, i_end
1754                 vb = v(i,k,j)
1755                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
1756                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
1757                                  *(vb+v(i,k,j-1))
1758             ENDDO
1759             ENDDO
1760
1761          ELSE IF ( j == jde-1 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
1762
1763             DO k=kts,ktf
1764             DO i = i_start, i_end
1765                 vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1766                 fqy( i, k, jp1 ) = vel*flux4(     &
1767                                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
1768             ENDDO
1769             ENDDO
1770
1771          END IF
1772
1773 !  y flux-divergence into tendency
1774
1775          ! Comments on polar boundary conditions
1776          ! No advection over the poles means tendencies (held from jds [S. pole]
1777          ! to jde [N pole], i.e., on v grid) must be zero at poles
1778          ! [tendency(jds) and tendency(jde)=0]
1779          IF ( config_flags%polar .AND. (j == jds+1) ) THEN
1780            DO k=kts,ktf
1781            DO i = i_start, i_end
1782              tendency(i,k,j-1) = 0.
1783            END DO
1784            END DO
1785          ! If j_end were set to jde in a special if statement apart from
1786          ! degrade_ye, then we would hit the next conditional.  But since
1787          ! we want the tendency to be zero anyway, not looping to jde+1
1788          ! will produce the same effect.
1789          ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
1790            DO k=kts,ktf
1791            DO i = i_start, i_end
1792              tendency(i,k,j-1) = 0.
1793            END DO
1794            END DO
1795          ELSE  ! Normal code
1796
1797          IF(j > j_start) THEN
1798
1799             DO k=kts,ktf
1800             DO i = i_start, i_end
1801                mrdy=msfvy(i,j-1)*rdy ! ADT eqn 45, 2nd term on RHS
1802                tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
1803             ENDDO
1804             ENDDO
1805
1806          ENDIF
1807
1808          END IF
1809
1810          jtmp = jp1
1811          jp1 = jp0
1812          jp0 = jtmp
1813
1814       ENDDO j_loop_y_flux_6
1815
1816 !  next, x - flux divergence
1817
1818       i_start = its
1819       i_end   = MIN(ite,ide-1)
1820
1821       j_start = jts
1822       j_end   = jte
1823       ! Polar boundary conditions are like open or specified
1824       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
1825       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
1826
1827 !  higher order flux has a 5 or 7 point stencil, so compute
1828 !  bounds so we can switch to second order flux close to the boundary
1829
1830       i_start_f = i_start
1831       i_end_f   = i_end+1
1832
1833       IF(degrade_xs) then
1834          i_start = MAX(ids+1,its)
1835          i_start_f = i_start+2
1836       ENDIF
1837
1838       IF(degrade_xe) then
1839          i_end = MIN(ide-2,ite)
1840          i_end_f = ide-3
1841       ENDIF
1842
1843 !  compute fluxes
1844
1845       DO j = j_start, j_end
1846
1847 !  5th or 6th order flux
1848
1849          DO k=kts,ktf
1850          DO i = i_start_f, i_end_f
1851             vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1852             fqx( i, k ) = vel*flux6( v(i-3,k,j), v(i-2,k,j),  &
1853                                      v(i-1,k,j), v(i  ,k,j),  &
1854                                      v(i+1,k,j), v(i+2,k,j),  &
1855                                      vel                     )
1856          ENDDO
1857          ENDDO
1858
1859 !  lower order fluxes close to boundaries (if not periodic or symmetric)
1860
1861          IF( degrade_xs ) THEN
1862
1863             IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
1864                i = ids+1
1865                DO k=kts,ktf
1866                   fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) &
1867                                  *(v(i,k,j)+v(i-1,k,j))
1868                ENDDO
1869             ENDIF
1870
1871             i = ids+2
1872             DO k=kts,ktf
1873                vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1874                fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j),  &
1875                                        v(i  ,k,j), v(i+1,k,j),  &
1876                                        vel                     )
1877             ENDDO
1878
1879          ENDIF
1880
1881          IF( degrade_xe ) THEN
1882
1883             IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
1884                i = ide-1
1885                DO k=kts,ktf
1886                   fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
1887                                  *(v(i_end+1,k,j)+v(i_end,k,j))
1888                ENDDO
1889             ENDIF
1890
1891             i = ide-2
1892             DO k=kts,ktf
1893                vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1894                fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j),  &
1895                                        v(i  ,k,j), v(i+1,k,j),  &
1896                                        vel                     )
1897             ENDDO
1898
1899          ENDIF
1900
1901 !  x flux-divergence into tendency
1902
1903          DO k=kts,ktf
1904             DO i = i_start, i_end
1905             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
1906             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
1907          ENDDO
1908       ENDDO
1909
1910    ENDDO
1911
1912    ELSE IF( horz_order == 5 ) THEN
1913
1914 !  5th order horizontal flux calculation
1915 !  This code is EXACTLY the same as the 6th order code
1916 !  EXCEPT the 5th order and 3rd operators are used in
1917 !  place of the 6th and 4th order operators
1918
1919 !  determine boundary mods for flux operators
1920 !  We degrade the flux operators from 3rd/4th order
1921 !   to second order one gridpoint in from the boundaries for
1922 !   all boundary conditions except periodic and symmetry - these
1923 !   conditions have boundary zone data fill for correct application
1924 !   of the higher order flux stencils
1925
1926    degrade_xs = .true.
1927    degrade_xe = .true.
1928    degrade_ys = .true.
1929    degrade_ye = .true.
1930
1931    IF( config_flags%periodic_x   .or. &
1932        config_flags%symmetric_xs .or. &
1933        (its > ids+2)                ) degrade_xs = .false.
1934    IF( config_flags%periodic_x   .or. &
1935        config_flags%symmetric_xe .or. &
1936        (ite < ide-3)                ) degrade_xe = .false.
1937    IF( config_flags%periodic_y   .or. &
1938        config_flags%symmetric_ys .or. &
1939        (jts > jds+2)                ) degrade_ys = .false.
1940    IF( config_flags%periodic_y   .or. &
1941        config_flags%symmetric_ye .or. &
1942        (jte < jde-2)                ) degrade_ye = .false.
1943
1944 !--------------- y - advection first
1945
1946       i_start = its
1947       i_end   = MIN(ite,ide-1)
1948       j_start = jts
1949       j_end   = jte
1950
1951 !  higher order flux has a 5 or 7 point stencil, so compute
1952 !  bounds so we can switch to second order flux close to the boundary
1953
1954       j_start_f = j_start
1955       j_end_f   = j_end+1
1956
1957       IF(degrade_ys) then
1958         j_start = MAX(jts,jds+1)
1959         j_start_f = jds+3
1960       ENDIF
1961
1962       IF(degrade_ye) then
1963         j_end = MIN(jte,jde-1)
1964         j_end_f = jde-2
1965       ENDIF
1966
1967 !  compute fluxes, 5th or 6th order
1968
1969      jp1 = 2
1970      jp0 = 1
1971
1972      j_loop_y_flux_5 : DO j = j_start, j_end+1
1973
1974       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
1975
1976         DO k=kts,ktf
1977         DO i = i_start, i_end
1978           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1979           fqy( i, k, jp1 ) = vel*flux5(               &
1980                   v(i,k,j-3), v(i,k,j-2), v(i,k,j-1),       &
1981                   v(i,k,j  ), v(i,k,j+1), v(i,k,j+2),  vel )
1982         ENDDO
1983         ENDDO
1984
1985 !  we must be close to some boundary where we need to reduce the order of the stencil
1986 !  specified uses upstream normal wind at boundaries
1987
1988       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
1989
1990             DO k=kts,ktf
1991             DO i = i_start, i_end
1992                 vb = v(i,k,j-1)
1993                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
1994                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
1995                                  *(v(i,k,j)+vb)
1996             ENDDO
1997             ENDDO
1998
1999      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
2000
2001             DO k=kts,ktf
2002             DO i = i_start, i_end
2003               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2004               fqy( i, k, jp1 ) = vel*flux3(      &
2005                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
2006             ENDDO
2007             ENDDO
2008
2009
2010      ELSE IF ( j == jde ) THEN  ! 2nd order flux next to north boundary
2011
2012             DO k=kts,ktf
2013             DO i = i_start, i_end
2014                 vb = v(i,k,j)
2015                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
2016                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
2017                                  *(vb+v(i,k,j-1))
2018             ENDDO
2019             ENDDO
2020
2021      ELSE IF ( j == jde-1 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
2022
2023             DO k=kts,ktf
2024             DO i = i_start, i_end
2025               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2026               fqy( i, k, jp1 ) = vel*flux3(     &
2027                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
2028             ENDDO
2029             ENDDO
2030
2031       END IF
2032
2033 !  y flux-divergence into tendency
2034
2035         ! Comments on polar boundary conditions
2036         ! No advection over the poles means tendencies (held from jds [S. pole]
2037         ! to jde [N pole], i.e., on v grid) must be zero at poles
2038         ! [tendency(jds) and tendency(jde)=0]
2039         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
2040           DO k=kts,ktf
2041           DO i = i_start, i_end
2042             tendency(i,k,j-1) = 0.
2043           END DO
2044           END DO
2045         ! If j_end were set to jde in a special if statement apart from
2046         ! degrade_ye, then we would hit the next conditional.  But since
2047         ! we want the tendency to be zero anyway, not looping to jde+1
2048         ! will produce the same effect.
2049         ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
2050           DO k=kts,ktf
2051           DO i = i_start, i_end
2052             tendency(i,k,j-1) = 0.
2053           END DO
2054           END DO
2055         ELSE  ! Normal code
2056
2057         IF(j > j_start) THEN
2058
2059           DO k=kts,ktf
2060           DO i = i_start, i_end
2061             mrdy=msfvy(i,j-1)*rdy    ! ADT eqn 45, 2nd term on RHS
2062             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
2063           ENDDO
2064           ENDDO
2065
2066         ENDIF
2067
2068         END IF
2069
2070         jtmp = jp1
2071         jp1 = jp0
2072         jp0 = jtmp
2073
2074    ENDDO j_loop_y_flux_5
2075
2076 !  next, x - flux divergence
2077
2078       i_start = its
2079       i_end   = MIN(ite,ide-1)
2080
2081       j_start = jts
2082       j_end   = jte
2083       ! Polar boundary conditions are like open or specified
2084       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2085       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
2086
2087 !  higher order flux has a 5 or 7 point stencil, so compute
2088 !  bounds so we can switch to second order flux close to the boundary
2089
2090       i_start_f = i_start
2091       i_end_f   = i_end+1
2092
2093       IF(degrade_xs) then
2094         i_start = MAX(ids+1,its)
2095         i_start_f = i_start+2
2096       ENDIF
2097
2098       IF(degrade_xe) then
2099         i_end = MIN(ide-2,ite)
2100         i_end_f = ide-3
2101       ENDIF
2102
2103 !  compute fluxes
2104
2105       DO j = j_start, j_end
2106
2107 !  5th or 6th order flux
2108
2109         DO k=kts,ktf
2110         DO i = i_start_f, i_end_f
2111           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2112           fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j),  &
2113                                          v(i-1,k,j), v(i  ,k,j),  &
2114                                          v(i+1,k,j), v(i+2,k,j),  &
2115                                          vel                     )
2116         ENDDO
2117         ENDDO
2118
2119 !  lower order fluxes close to boundaries (if not periodic or symmetric)
2120
2121         IF( degrade_xs ) THEN
2122
2123           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
2124             i = ids+1
2125             DO k=kts,ktf
2126             fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) &
2127                    *(v(i,k,j)+v(i-1,k,j))
2128             ENDDO
2129          ENDIF
2130
2131           i = ids+2
2132           DO k=kts,ktf
2133             vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2134             fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
2135                                           v(i  ,k,j), v(i+1,k,j),  &
2136                                           vel                     )
2137           ENDDO
2138
2139         ENDIF
2140
2141         IF( degrade_xe ) THEN
2142
2143           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
2144             i = ide-1
2145             DO k=kts,ktf
2146               fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
2147                               *(v(i_end+1,k,j)+v(i_end,k,j))
2148             ENDDO
2149           ENDIF
2150
2151           i = ide-2
2152           DO k=kts,ktf
2153           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2154           fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
2155                                         v(i  ,k,j), v(i+1,k,j),  &
2156                                         vel                     )
2157           ENDDO
2158
2159         ENDIF
2160
2161 !  x flux-divergence into tendency
2162
2163         DO k=kts,ktf
2164           DO i = i_start, i_end
2165             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
2166             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2167           ENDDO
2168         ENDDO
2169
2170       ENDDO
2171
2172    ELSE IF( horz_order == 4 ) THEN
2173
2174 !  determine boundary mods for flux operators
2175 !  We degrade the flux operators from 3rd/4th order
2176 !   to second order one gridpoint in from the boundaries for
2177 !   all boundary conditions except periodic and symmetry - these
2178 !   conditions have boundary zone data fill for correct application
2179 !   of the higher order flux stencils
2180
2181    degrade_xs = .true.
2182    degrade_xe = .true.
2183    degrade_ys = .true.
2184    degrade_ye = .true.
2185
2186    IF( config_flags%periodic_x   .or. &
2187        config_flags%symmetric_xs .or. &
2188        (its > ids+1)                ) degrade_xs = .false.
2189    IF( config_flags%periodic_x   .or. &
2190        config_flags%symmetric_xe .or. &
2191        (ite < ide-2)                ) degrade_xe = .false.
2192    IF( config_flags%periodic_y   .or. &
2193        config_flags%symmetric_ys .or. &
2194        (jts > jds+1)                ) degrade_ys = .false.
2195    IF( config_flags%periodic_y   .or. &
2196        config_flags%symmetric_ye .or. &
2197        (jte < jde-1)                ) degrade_ye = .false.
2198
2199 !--------------- y - advection first
2200
2201
2202    ktf=MIN(kte,kde-1)
2203
2204       i_start = its
2205       i_end   = MIN(ite,ide-1)
2206       j_start = jts
2207       j_end   = jte
2208
2209 !  3rd or 4th order flux has a 5 point stencil, so compute
2210 !  bounds so we can switch to second order flux close to the boundary
2211
2212       j_start_f = j_start
2213       j_end_f   = j_end+1
2214
2215 !CJM May not work with tiling because defined in terms of domain dims
2216       IF(degrade_ys) then
2217         j_start = jds+1
2218         j_start_f = j_start+1
2219       ENDIF
2220
2221       IF(degrade_ye) then
2222         j_end = jde-1
2223         j_end_f = jde-1
2224       ENDIF
2225
2226 !  compute fluxes
2227 !  specified uses upstream normal wind at boundaries
2228
2229     jp0 = 1
2230     jp1 = 2
2231
2232     DO j = j_start, j_end+1
2233
2234       IF ((j == j_start) .and. degrade_ys) THEN
2235         DO k = kts,ktf
2236         DO i = i_start, i_end
2237                 vb = v(i,k,j-1)
2238                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
2239                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
2240                                  *(v(i,k,j)+vb)
2241         ENDDO
2242         ENDDO
2243       ELSE IF ((j == j_end+1) .and. degrade_ye) THEN
2244         DO k = kts, ktf
2245         DO i = i_start, i_end
2246                 vb = v(i,k,j)
2247                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
2248                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
2249                                  *(vb+v(i,k,j-1))
2250         ENDDO
2251         ENDDO
2252       ELSE
2253         DO k = kts, ktf
2254         DO i = i_start, i_end
2255           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2256           fqy( i,k,jp1 ) = vel*flux4( v(i,k,j-2), v(i,k,j-1),  &
2257                                      v(i,k,j  ), v(i,k,j+1),  &
2258                                       vel                        )
2259         ENDDO
2260         ENDDO
2261       END IF
2262
2263       ! Comments on polar boundary conditions
2264       ! No advection over the poles means tendencies (held from jds [S. pole]
2265       ! to jde [N pole], i.e., on v grid) must be zero at poles
2266       ! [tendency(jds) and tendency(jde)=0]
2267       IF ( config_flags%polar .AND. (j == jds+1) ) THEN
2268         DO k=kts,ktf
2269         DO i = i_start, i_end
2270           tendency(i,k,j-1) = 0.
2271         END DO
2272         END DO
2273       ! If j_end were set to jde in a special if statement apart from
2274       ! degrade_ye, then we would hit the next conditional.  But since
2275       ! we want the tendency to be zero anyway, not looping to jde+1
2276       ! will produce the same effect.
2277       ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
2278         DO k=kts,ktf
2279         DO i = i_start, i_end
2280           tendency(i,k,j-1) = 0.
2281         END DO
2282         END DO
2283       ELSE  ! Normal code
2284
2285       IF( j > j_start) THEN
2286         DO k = kts, ktf
2287         DO i = i_start, i_end
2288             mrdy=msfvy(i,j-1)*rdy     ! ADT eqn 45, 2nd term on RHS
2289             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
2290         ENDDO
2291         ENDDO
2292
2293       END IF
2294
2295       END IF
2296
2297       jtmp = jp1
2298       jp1 = jp0
2299       jp0 = jtmp
2300
2301    ENDDO
2302
2303 !  next, x - flux divergence
2304
2305
2306       i_start = its
2307       i_end   = MIN(ite,ide-1)
2308
2309       j_start = jts
2310       j_end   = jte
2311       ! Polar boundary conditions are like open or specified
2312       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2313       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
2314
2315 !  3rd or 4th order flux has a 5 point stencil, so compute
2316 !  bounds so we can switch to second order flux close to the boundary
2317
2318       i_start_f = i_start
2319       i_end_f   = i_end+1
2320
2321       IF(degrade_xs) then
2322         i_start = ids+1
2323         i_start_f = i_start+1
2324       ENDIF
2325
2326       IF(degrade_xe) then
2327         i_end = ide-2
2328         i_end_f = ide-2
2329       ENDIF
2330
2331 !  compute fluxes
2332
2333       DO j = j_start, j_end
2334
2335 !  3rd or 4th order flux
2336
2337         DO k=kts,ktf
2338         DO i = i_start_f, i_end_f
2339           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2340           fqx( i, k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j),  &
2341                                   v(i  ,k,j), v(i+1,k,j),  &
2342                                   vel                     )
2343         ENDDO
2344         ENDDO
2345
2346 !  second order flux close to boundaries (if not periodic or symmetric)
2347
2348         IF( degrade_xs ) THEN
2349           DO k=kts,ktf
2350             fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) &
2351                    *(v(i_start,k,j)+v(i_start-1,k,j))
2352           ENDDO
2353         ENDIF
2354
2355         IF( degrade_xe ) THEN
2356           DO k=kts,ktf
2357             fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
2358                    *(v(i_end+1,k,j)+v(i_end,k,j))
2359           ENDDO
2360         ENDIF
2361
2362 !  x flux-divergence into tendency
2363
2364         DO k=kts,ktf
2365         DO i = i_start, i_end
2366             mrdx=msfvy(i,j)*rdx       ! ADT eqn 45, 1st term on RHS
2367             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2368         ENDDO
2369         ENDDO
2370
2371       ENDDO
2372
2373    ELSE IF( horz_order == 3 ) THEN
2374
2375 !  determine boundary mods for flux operators
2376 !  We degrade the flux operators from 3rd/4th order
2377 !   to second order one gridpoint in from the boundaries for
2378 !   all boundary conditions except periodic and symmetry - these
2379 !   conditions have boundary zone data fill for correct application
2380 !   of the higher order flux stencils
2381
2382    degrade_xs = .true.
2383    degrade_xe = .true.
2384    degrade_ys = .true.
2385    degrade_ye = .true.
2386
2387    IF( config_flags%periodic_x   .or. &
2388        config_flags%symmetric_xs .or. &
2389        (its > ids+1)                ) degrade_xs = .false.
2390    IF( config_flags%periodic_x   .or. &
2391        config_flags%symmetric_xe .or. &
2392        (ite < ide-2)                ) degrade_xe = .false.
2393    IF( config_flags%periodic_y   .or. &
2394        config_flags%symmetric_ys .or. &
2395        (jts > jds+1)                ) degrade_ys = .false.
2396    IF( config_flags%periodic_y   .or. &
2397        config_flags%symmetric_ye .or. &
2398        (jte < jde-1)                ) degrade_ye = .false.
2399
2400 !--------------- y - advection first
2401
2402
2403    ktf=MIN(kte,kde-1)
2404
2405       i_start = its
2406       i_end   = MIN(ite,ide-1)
2407       j_start = jts
2408       j_end   = jte
2409
2410 !  3rd or 4th order flux has a 5 point stencil, so compute
2411 !  bounds so we can switch to second order flux close to the boundary
2412
2413       j_start_f = j_start
2414       j_end_f   = j_end+1
2415
2416 !CJM May not work with tiling because defined in terms of domain dims
2417       IF(degrade_ys) then
2418         j_start = jds+1
2419         j_start_f = j_start+1
2420       ENDIF
2421
2422       IF(degrade_ye) then
2423         j_end = jde-1
2424         j_end_f = jde-1
2425       ENDIF
2426
2427 !  compute fluxes
2428 !  specified uses upstream normal wind at boundaries
2429
2430     jp0 = 1
2431     jp1 = 2
2432
2433     DO j = j_start, j_end+1
2434
2435       IF ((j == j_start) .and. degrade_ys) THEN
2436         DO k = kts,ktf
2437         DO i = i_start, i_end
2438                 vb = v(i,k,j-1)
2439                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
2440                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
2441                                  *(v(i,k,j)+vb)
2442         ENDDO
2443         ENDDO
2444       ELSE IF ((j == j_end+1) .and. degrade_ye) THEN
2445         DO k = kts, ktf
2446         DO i = i_start, i_end
2447                 vb = v(i,k,j)
2448                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
2449                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
2450                                  *(vb+v(i,k,j-1))
2451         ENDDO
2452         ENDDO
2453       ELSE
2454         DO k = kts, ktf
2455         DO i = i_start, i_end
2456           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2457           fqy( i,k,jp1 ) = vel*flux3( v(i,k,j-2), v(i,k,j-1),  &
2458                                      v(i,k,j  ), v(i,k,j+1),  &
2459                                       vel                        )
2460         ENDDO
2461         ENDDO
2462       END IF
2463
2464       ! Comments on polar boundary conditions
2465       ! No advection over the poles means tendencies (held from jds [S. pole]
2466       ! to jde [N pole], i.e., on v grid) must be zero at poles
2467       ! [tendency(jds) and tendency(jde)=0]
2468       IF ( config_flags%polar .AND. (j == jds+1) ) THEN
2469         DO k=kts,ktf
2470         DO i = i_start, i_end
2471           tendency(i,k,j-1) = 0.
2472         END DO
2473         END DO
2474       ! If j_end were set to jde in a special if statement apart from
2475       ! degrade_ye, then we would hit the next conditional.  But since
2476       ! we want the tendency to be zero anyway, not looping to jde+1
2477       ! will produce the same effect.
2478       ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
2479         DO k=kts,ktf
2480         DO i = i_start, i_end
2481           tendency(i,k,j-1) = 0.
2482         END DO
2483         END DO
2484       ELSE  ! Normal code
2485
2486       IF( j > j_start) THEN
2487         DO k = kts, ktf
2488         DO i = i_start, i_end
2489             mrdy=msfvy(i,j-1)*rdy     ! ADT eqn 45, 2nd term on RHS
2490             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
2491         ENDDO
2492         ENDDO
2493
2494       END IF
2495
2496       END IF
2497
2498       jtmp = jp1
2499       jp1 = jp0
2500       jp0 = jtmp
2501
2502    ENDDO
2503
2504 !  next, x - flux divergence
2505
2506
2507       i_start = its
2508       i_end   = MIN(ite,ide-1)
2509
2510       j_start = jts
2511       j_end   = jte
2512       ! Polar boundary conditions are like open or specified
2513       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2514       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
2515
2516 !  3rd or 4th order flux has a 5 point stencil, so compute
2517 !  bounds so we can switch to second order flux close to the boundary
2518
2519       i_start_f = i_start
2520       i_end_f   = i_end+1
2521
2522       IF(degrade_xs) then
2523         i_start = ids+1
2524         i_start_f = i_start+1
2525       ENDIF
2526
2527       IF(degrade_xe) then
2528         i_end = ide-2
2529         i_end_f = ide-2
2530       ENDIF
2531
2532 !  compute fluxes
2533
2534       DO j = j_start, j_end
2535
2536 !  3rd or 4th order flux
2537
2538         DO k=kts,ktf
2539         DO i = i_start_f, i_end_f
2540           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2541           fqx( i, k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
2542                                   v(i  ,k,j), v(i+1,k,j),  &
2543                                   vel                     )
2544         ENDDO
2545         ENDDO
2546
2547 !  second order flux close to boundaries (if not periodic or symmetric)
2548
2549         IF( degrade_xs ) THEN
2550           DO k=kts,ktf
2551             fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) &
2552                    *(v(i_start,k,j)+v(i_start-1,k,j))
2553           ENDDO
2554         ENDIF
2555
2556         IF( degrade_xe ) THEN
2557           DO k=kts,ktf
2558             fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
2559                    *(v(i_end+1,k,j)+v(i_end,k,j))
2560           ENDDO
2561         ENDIF
2562
2563 !  x flux-divergence into tendency
2564
2565         DO k=kts,ktf
2566         DO i = i_start, i_end
2567             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
2568             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2569         ENDDO
2570         ENDDO
2571
2572       ENDDO
2573
2574    ELSE IF( horz_order == 2 ) THEN
2575
2576
2577       i_start = its
2578       i_end   = MIN(ite,ide-1)
2579       j_start = jts
2580       j_end   = jte
2581
2582       IF ( config_flags%open_ys ) j_start = MAX(jds+1,jts)
2583       IF ( config_flags%open_ye ) j_end   = MIN(jde-1,jte)
2584       IF ( specified ) j_start = MAX(jds+2,jts)
2585       IF ( specified ) j_end   = MIN(jde-2,jte)
2586       IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
2587       IF ( config_flags%polar ) j_end   = MIN(jde-1,jte)
2588
2589       DO j = j_start, j_end
2590       DO k=kts,ktf
2591       DO i = i_start, i_end
2592
2593          mrdy=msfvy(i,j)*rdy          ! ADT eqn 45, 2nd term on RHS
2594
2595             tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2596                             *((rv(i,k,j+1)+rv(i,k,j  ))*(v(i,k,j+1)+v(i,k,j  )) &
2597                              -(rv(i,k,j  )+rv(i,k,j-1))*(v(i,k,j  )+v(i,k,j-1)))
2598
2599       ENDDO
2600       ENDDO
2601       ENDDO
2602
2603       ! Comments on polar boundary conditions
2604       ! tendencies = 0 at poles, and polar points do not contribute at points
2605       ! next to poles
2606       IF (config_flags%polar) THEN
2607          IF (jts == jds) THEN
2608             DO k=kts,ktf
2609             DO i = i_start, i_end
2610                tendency(i,k,jds) = 0.
2611             END DO
2612             END DO
2613          END IF
2614          IF (jte == jde) THEN
2615             DO k=kts,ktf
2616             DO i = i_start, i_end
2617                tendency(i,k,jde) = 0.
2618             END DO
2619             END DO
2620          END IF
2621       END IF
2622
2623 !  specified uses upstream normal wind at boundaries
2624
2625       IF ( specified .AND. jts .LE. jds+1 ) THEN
2626         j = jds+1
2627         DO k=kts,ktf
2628         DO i = i_start, i_end
2629            mrdy=msfvy(i,j)*rdy       ! ADT eqn 45, 2nd term on RHS
2630            vb = v(i,k,j-1)
2631            IF (v(i,k,j) .LT. 0.) vb = v(i,k,j)
2632
2633               tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2634                               *((rv(i,k,j+1)+rv(i,k,j  ))*(v(i,k,j+1)+v(i,k,j  )) &
2635                                -(rv(i,k,j  )+rv(i,k,j-1))*(v(i,k,j  )+vb))
2636
2637         ENDDO
2638         ENDDO
2639       ENDIF
2640
2641       IF ( specified .AND. jte .GE. jde-1 ) THEN
2642         j = jde-1
2643         DO k=kts,ktf
2644         DO i = i_start, i_end
2645
2646            mrdy=msfvy(i,j)*rdy       ! ADT eqn 45, 2nd term on RHS
2647            vb = v(i,k,j+1)
2648            IF (v(i,k,j) .GT. 0.) vb = v(i,k,j)
2649
2650               tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2651                               *((rv(i,k,j+1)+rv(i,k,j  ))*(vb+v(i,k,j  )) &
2652                                -(rv(i,k,j  )+rv(i,k,j-1))*(v(i,k,j  )+v(i,k,j-1)))
2653
2654         ENDDO
2655         ENDDO
2656       ENDIF
2657
2658       IF ( .NOT. config_flags%periodic_x ) THEN
2659         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
2660         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
2661       ENDIF
2662       IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
2663       IF ( config_flags%polar ) j_end   = MIN(jde-1,jte)
2664
2665       DO j = j_start, j_end
2666       DO k=kts,ktf
2667       DO i = i_start, i_end
2668
2669          mrdx=msfvy(i,j)*rdx         ! ADT eqn 45, 1st term on RHS
2670
2671             tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
2672                             *((ru(i+1,k,j)+ru(i+1,k,j-1))*(v(i+1,k,j)+v(i  ,k,j)) &
2673                              -(ru(i  ,k,j)+ru(i  ,k,j-1))*(v(i  ,k,j)+v(i-1,k,j)))
2674
2675       ENDDO
2676       ENDDO
2677       ENDDO
2678
2679    ELSE IF ( horz_order == 0 ) THEN
2680
2681       ! Just in case we want to turn horizontal advection off, we can do it
2682
2683   ELSE
2684
2685
2686       WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: h_order not known ',horz_order
2687       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
2688
2689    ENDIF horizontal_order_test
2690
2691    !  Comments on polar boundary condition
2692    !  Force tendency=0 at NP and SP
2693    !  We keep setting this everywhere, but it can't hurt...
2694    IF ( config_flags%polar .AND. (jts == jds) ) THEN
2695       DO i=its,ite
2696       DO k=kts,ktf
2697          tendency(i,k,jts)=0.
2698       END DO
2699       END DO
2700    END IF
2701    IF ( config_flags%polar .AND. (jte == jde) ) THEN
2702       DO i=its,ite
2703       DO k=kts,ktf
2704          tendency(i,k,jte)=0.
2705       END DO
2706       END DO
2707    END IF
2708
2709 !  radiative lateral boundary condition in y for normal velocity (v)
2710
2711       IF ( (config_flags%open_ys) .and. jts == jds ) THEN
2712
2713         i_start = its
2714         i_end   = MIN(ite,ide-1)
2715
2716         DO i = i_start, i_end
2717         DO k = kts, ktf
2718           vb = MIN(rv(i,k,jts)-cb*mut(i,jts), 0.)
2719           tendency(i,k,jts) = tendency(i,k,jts)                    &
2720                       - rdy*vb*(v_old(i,k,jts+1) - v_old(i,k,jts))
2721         ENDDO
2722         ENDDO
2723
2724       ENDIF
2725
2726       IF ( (config_flags%open_ye) .and. jte == jde ) THEN
2727
2728         i_start = its
2729         i_end   = MIN(ite,ide-1)
2730
2731         DO i = i_start, i_end
2732         DO k = kts, ktf
2733           vb = MAX(rv(i,k,jte)+cb*mut(i,jte-1), 0.)
2734           tendency(i,k,jte) = tendency(i,k,jte)                    &
2735                       - rdy*vb*(v_old(i,k,jte) - v_old(i,k,jte-1))
2736         ENDDO
2737         ENDDO
2738
2739       ENDIF
2740
2741 !  pick up the rest of the horizontal radiation boundary conditions.
2742 !  (these are the computations that don't require 'cb'.
2743 !  first, set to index ranges
2744
2745       j_start = jts
2746       j_end   = MIN(jte,jde)
2747
2748       jmin    = jds
2749       jmax    = jde-1
2750
2751       IF (config_flags%open_ys) THEN
2752           j_start = MAX(jds+1, jts)
2753           jmin = jds
2754       ENDIF
2755       IF (config_flags%open_ye) THEN
2756           j_end = MIN(jte,jde-1)
2757           jmax = jde-1
2758       ENDIF
2759
2760 !  compute x (u) conditions for v, w, or scalar
2761
2762    IF( (config_flags%open_xs) .and. (its == ids)) THEN
2763
2764       DO j = j_start, j_end
2765
2766          mrdx=msfvy(its,j)*rdx       ! ADT eqn 45, 1st term on RHS
2767          jp = MIN( jmax, j   )
2768          jm = MAX( jmin, j-1 )
2769
2770          DO k=kts,ktf
2771
2772           uw = 0.5*(ru(its,k,jp)+ru(its,k,jm))
2773           ub = MIN( uw, 0. )
2774           dup =  ru(its+1,k,jp)-ru(its,k,jp)
2775           dum =  ru(its+1,k,jm)-ru(its,k,jm)
2776           tendency(its,k,j)=tendency(its,k,j)-mrdx*(               &
2777                             ub*(v_old(its+1,k,j)-v_old(its,k,j))   &
2778                            +0.5*v(its,k,j)*(dup+dum))
2779          ENDDO
2780       ENDDO
2781
2782    ENDIF
2783
2784    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
2785       DO j = j_start, j_end
2786
2787          mrdx=msfvy(ite-1,j)*rdx     ! ADT eqn 45, 1st term on RHS
2788          jp = MIN( jmax, j   )
2789          jm = MAX( jmin, j-1 )
2790
2791          DO k=kts,ktf
2792
2793           uw = 0.5*(ru(ite,k,jp)+ru(ite,k,jm))
2794           ub = MAX( uw, 0. )
2795           dup = ru(ite,k,jp)-ru(ite-1,k,jp)
2796           dum = ru(ite,k,jm)-ru(ite-1,k,jm)
2797
2798 !          tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
2799 !                            ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
2800 !                           +0.5*v(ite-1,k,j)*                         &
2801 !                                  ( ru(ite,k,jp)-ru(ite-1,k,jp)       &
2802 !                                   +ru(ite,k,jm)-ru(ite-1,k,jm))     )
2803           tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
2804                             ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
2805                            +0.5*v(ite-1,k,j)*(dup+dum))
2806
2807          ENDDO
2808       ENDDO
2809
2810    ENDIF
2811
2812 !-------------------- vertical advection
2813 !     ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
2814 !     Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
2815 !     We therefore need to make a correction for advect_v
2816 !     since 'my' (map scale factor in y direction) isn't a function of z,
2817 !     we can do this using *(my/mx) (see eqn. 45 for example)
2818
2819
2820       i_start = its
2821       i_end   = MIN(ite,ide-1)
2822       j_start = jts
2823       j_end   = jte
2824
2825       DO i = i_start, i_end
2826          vflux(i,kts)=0.
2827          vflux(i,kte)=0.
2828       ENDDO
2829
2830       ! Polar boundary conditions are like open or specified
2831       ! We don't want to calculate vertical v tendencies at the N or S pole
2832       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2833       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
2834
2835     vert_order_test : IF (vert_order == 6) THEN
2836
2837       DO j = j_start, j_end
2838
2839
2840          DO k=kts+3,ktf-2
2841          DO i = i_start, i_end
2842            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2843            vflux(i,k) = vel*flux6(                       &
2844                    v(i,k-3,j), v(i,k-2,j), v(i,k-1,j),       &
2845                    v(i,k  ,j), v(i,k+1,j), v(i,k+2,j),  -vel )
2846          ENDDO
2847          ENDDO
2848
2849          DO i = i_start, i_end
2850            k=kts+1
2851            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2852                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2853            k = kts+2
2854            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2855            vflux(i,k) = vel*flux4(       &
2856                    v(i,k-2,j), v(i,k-1,j),   &
2857                    v(i,k  ,j), v(i,k+1,j), -vel )
2858            k = ktf-1
2859            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2860            vflux(i,k) = vel*flux4(       &
2861                    v(i,k-2,j), v(i,k-1,j),   &
2862                    v(i,k  ,j), v(i,k+1,j), -vel )
2863            k=ktf
2864            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2865                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2866
2867          ENDDO
2868
2869
2870          DO k=kts,ktf
2871          DO i = i_start, i_end
2872             ! We are calculating vertical fluxes on v points,
2873             ! so we must mean msf_v_x/y variables
2874             tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
2875          ENDDO
2876          ENDDO
2877
2878       ENDDO
2879
2880    ELSE IF (vert_order == 5) THEN
2881
2882       DO j = j_start, j_end
2883
2884
2885          DO k=kts+3,ktf-2
2886          DO i = i_start, i_end
2887            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2888            vflux(i,k) = vel*flux5(                       &
2889                    v(i,k-3,j), v(i,k-2,j), v(i,k-1,j),       &
2890                    v(i,k  ,j), v(i,k+1,j), v(i,k+2,j),  -vel )
2891          ENDDO
2892          ENDDO
2893
2894          DO i = i_start, i_end
2895            k=kts+1
2896            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2897                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2898            k = kts+2
2899            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2900            vflux(i,k) = vel*flux3(       &
2901                    v(i,k-2,j), v(i,k-1,j),   &
2902                    v(i,k  ,j), v(i,k+1,j), -vel )
2903            k = ktf-1
2904            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2905            vflux(i,k) = vel*flux3(       &
2906                    v(i,k-2,j), v(i,k-1,j),   &
2907                    v(i,k  ,j), v(i,k+1,j), -vel )
2908            k=ktf
2909            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2910                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2911
2912          ENDDO
2913
2914
2915          DO k=kts,ktf
2916          DO i = i_start, i_end
2917             ! We are calculating vertical fluxes on v points,
2918             ! so we must mean msf_v_x/y variables
2919             tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
2920          ENDDO
2921          ENDDO
2922
2923       ENDDO
2924
2925     ELSE IF (vert_order == 4) THEN
2926
2927       DO j = j_start, j_end
2928
2929
2930          DO k=kts+2,ktf-1
2931          DO i = i_start, i_end
2932            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2933            vflux(i,k) = vel*flux4(               &
2934                    v(i,k-2,j), v(i,k-1,j),       &
2935                    v(i,k  ,j), v(i,k+1,j), -vel )
2936          ENDDO
2937          ENDDO
2938
2939          DO i = i_start, i_end
2940            k=kts+1
2941            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2942                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2943            k=ktf
2944            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2945                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2946
2947          ENDDO
2948
2949
2950          DO k=kts,ktf
2951          DO i = i_start, i_end
2952             ! We are calculating vertical fluxes on v points,
2953             ! so we must mean msf_v_x/y variables
2954             tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
2955          ENDDO
2956          ENDDO
2957
2958       ENDDO
2959
2960     ELSE IF (vert_order == 3) THEN
2961
2962       DO j = j_start, j_end
2963
2964
2965          DO k=kts+2,ktf-1
2966          DO i = i_start, i_end
2967            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2968            vflux(i,k) = vel*flux3(               &
2969                    v(i,k-2,j), v(i,k-1,j),       &
2970                    v(i,k  ,j), v(i,k+1,j), -vel )
2971          ENDDO
2972          ENDDO
2973
2974          DO i = i_start, i_end
2975            k=kts+1
2976            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2977                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2978            k=ktf
2979            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2980                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2981
2982          ENDDO
2983
2984
2985          DO k=kts,ktf
2986          DO i = i_start, i_end
2987             ! We are calculating vertical fluxes on v points,
2988             ! so we must mean msf_v_x/y variables
2989             tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
2990          ENDDO
2991          ENDDO
2992
2993       ENDDO
2994
2995
2996     ELSE IF (vert_order == 2) THEN
2997
2998    DO j = j_start, j_end
2999       DO k=kts+1,ktf
3000       DO i = i_start, i_end
3001
3002             vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
3003                                     *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
3004       ENDDO
3005       ENDDO
3006
3007       DO k=kts,ktf
3008       DO i = i_start, i_end
3009             ! We are calculating vertical fluxes on v points,
3010             ! so we must mean msf_v_x/y variables
3011             tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
3012       ENDDO
3013       ENDDO
3014    ENDDO
3015
3016    ELSE
3017
3018       WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: v_order not known ',vert_order
3019       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
3020
3021    ENDIF vert_order_test
3022
3023 END SUBROUTINE advect_v
3024
3025 !-------------------------------------------------------------------
3026
3027 SUBROUTINE advect_scalar   ( field, field_old, tendency,    &
3028                              ru, rv, rom,                   &
3029                              mut, time_step, config_flags,  &
3030                              msfux, msfuy, msfvx, msfvy,    &
3031                              msftx, msfty,                  &
3032                              fzm, fzp,                      &
3033                              rdx, rdy, rdzw,                &
3034                              ids, ide, jds, jde, kds, kde,  &
3035                              ims, ime, jms, jme, kms, kme,  &
3036                              its, ite, jts, jte, kts, kte  )
3037
3038    IMPLICIT NONE
3039
3040    ! Input data
3041
3042    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
3043
3044    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
3045                                               ims, ime, jms, jme, kms, kme, &
3046                                               its, ite, jts, jte, kts, kte
3047
3048    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
3049                                                                       field_old, &
3050                                                                       ru,    &
3051                                                                       rv,    &
3052                                                                       rom
3053
3054    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
3055    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
3056
3057    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
3058                                                                     msfuy,  &
3059                                                                     msfvx,  &
3060                                                                     msfvy,  &
3061                                                                     msftx,  &
3062                                                                     msfty
3063
3064    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
3065                                                                   fzp,  &
3066                                                                   rdzw
3067
3068    REAL ,                                        INTENT(IN   ) :: rdx,  &
3069                                                                   rdy
3070    INTEGER ,                                     INTENT(IN   ) :: time_step
3071
3072
3073    ! Local data
3074
3075    INTEGER :: i, j, k, itf, jtf, ktf
3076    INTEGER :: i_start, i_end, j_start, j_end
3077    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
3078    INTEGER :: jmin, jmax, jp, jm, imin, imax
3079
3080    REAL    :: mrdx, mrdy, ub, vb, uw, vw
3081    REAL , DIMENSION(its:ite, kts:kte) :: vflux
3082
3083
3084    REAL,  DIMENSION( its:ite+1, kts:kte  ) :: fqx
3085    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
3086
3087    INTEGER :: horz_order, vert_order
3088
3089    LOGICAL :: degrade_xs, degrade_ys
3090    LOGICAL :: degrade_xe, degrade_ye
3091
3092    INTEGER :: jp1, jp0, jtmp
3093
3094
3095 ! definition of flux operators, 3rd, 4th, 5th or 6th order
3096
3097    REAL    :: flux3, flux4, flux5, flux6
3098    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
3099
3100       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
3101           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
3102
3103       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
3104            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
3105            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
3106
3107       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
3108           ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)                  &
3109             +(q_ip2+q_im3) )/60.0
3110
3111       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
3112            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
3113             -sign(1,time_step)*sign(1.,ua)*(                    &
3114               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
3115
3116
3117    LOGICAL :: specified
3118
3119    specified = .false.
3120    if(config_flags%specified .or. config_flags%nested) specified = .true.
3121
3122 ! set order for the advection schemes
3123
3124   ktf=MIN(kte,kde-1)
3125   horz_order = config_flags%h_sca_adv_order
3126   vert_order = config_flags%v_sca_adv_order
3127
3128 !  begin with horizontal flux divergence
3129 !  here is the choice of flux operators
3130
3131
3132   horizontal_order_test : IF( horz_order == 6 ) THEN
3133
3134 !  determine boundary mods for flux operators
3135 !  We degrade the flux operators from 3rd/4th order
3136 !   to second order one gridpoint in from the boundaries for
3137 !   all boundary conditions except periodic and symmetry - these
3138 !   conditions have boundary zone data fill for correct application
3139 !   of the higher order flux stencils
3140
3141    degrade_xs = .true.
3142    degrade_xe = .true.
3143    degrade_ys = .true.
3144    degrade_ye = .true.
3145
3146    IF( config_flags%periodic_x   .or. &
3147        config_flags%symmetric_xs .or. &
3148        (its > ids+2)                ) degrade_xs = .false.
3149    IF( config_flags%periodic_x   .or. &
3150        config_flags%symmetric_xe .or. &
3151        (ite < ide-3)                ) degrade_xe = .false.
3152    IF( config_flags%periodic_y   .or. &
3153        config_flags%symmetric_ys .or. &
3154        (jts > jds+2)                ) degrade_ys = .false.
3155    IF( config_flags%periodic_y   .or. &
3156        config_flags%symmetric_ye .or. &
3157        (jte < jde-3)                ) degrade_ye = .false.
3158
3159 !--------------- y - advection first
3160
3161       ktf=MIN(kte,kde-1)
3162       i_start = its
3163       i_end   = MIN(ite,ide-1)
3164       j_start = jts
3165       j_end   = MIN(jte,jde-1)
3166
3167 !  higher order flux has a 5 or 7 point stencil, so compute
3168 !  bounds so we can switch to second order flux close to the boundary
3169
3170       j_start_f = j_start
3171       j_end_f   = j_end+1
3172
3173       IF(degrade_ys) then
3174         j_start = MAX(jts,jds+1)
3175         j_start_f = jds+3
3176       ENDIF
3177
3178       IF(degrade_ye) then
3179         j_end = MIN(jte,jde-2)
3180         j_end_f = jde-3
3181       ENDIF
3182
3183       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3184
3185 !  compute fluxes, 5th or 6th order
3186
3187      jp1 = 2
3188      jp0 = 1
3189
3190      j_loop_y_flux_6 : DO j = j_start, j_end+1
3191
3192       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
3193
3194         DO k=kts,ktf
3195         DO i = i_start, i_end
3196           vel = rv(i,k,j)
3197           fqy( i, k, jp1 ) = vel*flux6(                                &
3198                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
3199                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
3200         ENDDO
3201         ENDDO
3202
3203       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
3204
3205             DO k=kts,ktf
3206             DO i = i_start, i_end
3207               fqy(i,k, jp1) = 0.5*rv(i,k,j)*          &
3208                      (field(i,k,j)+field(i,k,j-1))
3209
3210             ENDDO
3211             ENDDO
3212
3213      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
3214
3215             DO k=kts,ktf
3216             DO i = i_start, i_end
3217               vel = rv(i,k,j)
3218               fqy( i, k, jp1 ) = vel*flux4(              &
3219                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
3220             ENDDO
3221             ENDDO
3222
3223      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
3224
3225             DO k=kts,ktf
3226             DO i = i_start, i_end
3227               fqy(i, k, jp1) = 0.5*rv(i,k,j)*      &
3228                      (field(i,k,j)+field(i,k,j-1))
3229             ENDDO
3230             ENDDO
3231
3232      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
3233
3234             DO k=kts,ktf
3235             DO i = i_start, i_end
3236               vel = rv(i,k,j)
3237               fqy( i, k, jp1) = vel*flux4(             &
3238                    field(i,k,j-2),field(i,k,j-1),    &
3239                    field(i,k,j),field(i,k,j+1),vel )
3240             ENDDO
3241             ENDDO
3242
3243      ENDIF
3244
3245 !  y flux-divergence into tendency
3246
3247         ! Comments on polar boundary conditions
3248         ! Same process as for advect_u - tendencies run from jds to jde-1
3249         ! (latitudes are as for u grid, longitudes are displaced)
3250         ! Therefore: flow is only from one side for points next to poles
3251         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3252           DO k=kts,ktf
3253           DO i = i_start, i_end
3254             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3255             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3256           END DO
3257           END DO
3258         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3259           DO k=kts,ktf
3260           DO i = i_start, i_end
3261             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3262             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3263           END DO
3264           END DO
3265         ELSE  ! normal code
3266
3267         IF(j > j_start) THEN
3268
3269           DO k=kts,ktf
3270           DO i = i_start, i_end
3271             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3272             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3273           ENDDO
3274           ENDDO
3275
3276         ENDIF
3277
3278         END IF
3279
3280         jtmp = jp1
3281         jp1 = jp0
3282         jp0 = jtmp
3283
3284       ENDDO j_loop_y_flux_6
3285
3286 !  next, x - flux divergence
3287
3288       i_start = its
3289       i_end   = MIN(ite,ide-1)
3290
3291       j_start = jts
3292       j_end   = MIN(jte,jde-1)
3293
3294 !  higher order flux has a 5 or 7 point stencil, so compute
3295 !  bounds so we can switch to second order flux close to the boundary
3296
3297       i_start_f = i_start
3298       i_end_f   = i_end+1
3299
3300       IF(degrade_xs) then
3301         i_start = MAX(ids+1,its)
3302         i_start_f = i_start+2
3303       ENDIF
3304
3305       IF(degrade_xe) then
3306         i_end = MIN(ide-2,ite)
3307         i_end_f = ide-3
3308       ENDIF
3309
3310 !  compute fluxes
3311
3312       DO j = j_start, j_end
3313
3314 !  5th or 6th order flux
3315
3316         DO k=kts,ktf
3317         DO i = i_start_f, i_end_f
3318           vel = ru(i,k,j)
3319           fqx( i,k ) = vel*flux6( field(i-3,k,j), field(i-2,k,j),  &
3320                                          field(i-1,k,j), field(i  ,k,j),  &
3321                                          field(i+1,k,j), field(i+2,k,j),  &
3322                                          vel                             )
3323         ENDDO
3324         ENDDO
3325
3326 !  lower order fluxes close to boundaries (if not periodic or symmetric)
3327
3328         IF( degrade_xs ) THEN
3329
3330           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
3331             i = ids+1
3332             DO k=kts,ktf
3333               fqx(i,k) = 0.5*(ru(i,k,j)) &
3334                      *(field(i,k,j)+field(i-1,k,j))
3335
3336             ENDDO
3337           ENDIF
3338
3339           i = ids+2
3340           DO k=kts,ktf
3341             vel = ru(i,k,j)
3342             fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
3343                                           field(i  ,k,j), field(i+1,k,j),  &
3344                                           vel                     )
3345           ENDDO
3346
3347         ENDIF
3348
3349         IF( degrade_xe ) THEN
3350
3351           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
3352             i = ide-1
3353             DO k=kts,ktf
3354               fqx(i,k) = 0.5*(ru(i,k,j))      &
3355                      *(field(i,k,j)+field(i-1,k,j))
3356             ENDDO
3357          ENDIF
3358
3359           i = ide-2
3360           DO k=kts,ktf
3361             vel = ru(i,k,j)
3362             fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
3363                                           field(i  ,k,j), field(i+1,k,j),  &
3364                                           vel                             )
3365           ENDDO
3366
3367         ENDIF
3368
3369 !  x flux-divergence into tendency
3370
3371           DO k=kts,ktf
3372           DO i = i_start, i_end
3373             mrdx=msftx(i,j)*rdx      ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3374             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3375           ENDDO
3376           ENDDO
3377
3378       ENDDO
3379
3380   ELSE IF( horz_order == 5 ) THEN
3381
3382 !  determine boundary mods for flux operators
3383 !  We degrade the flux operators from 3rd/4th order
3384 !   to second order one gridpoint in from the boundaries for
3385 !   all boundary conditions except periodic and symmetry - these
3386 !   conditions have boundary zone data fill for correct application
3387 !   of the higher order flux stencils
3388
3389    degrade_xs = .true.
3390    degrade_xe = .true.
3391    degrade_ys = .true.
3392    degrade_ye = .true.
3393
3394    IF( config_flags%periodic_x   .or. &
3395        config_flags%symmetric_xs .or. &
3396        (its > ids+2)                ) degrade_xs = .false.
3397    IF( config_flags%periodic_x   .or. &
3398        config_flags%symmetric_xe .or. &
3399        (ite < ide-3)                ) degrade_xe = .false.
3400    IF( config_flags%periodic_y   .or. &
3401        config_flags%symmetric_ys .or. &
3402        (jts > jds+2)                ) degrade_ys = .false.
3403    IF( config_flags%periodic_y   .or. &
3404        config_flags%symmetric_ye .or. &
3405        (jte < jde-3)                ) degrade_ye = .false.
3406
3407 !--------------- y - advection first
3408
3409       ktf=MIN(kte,kde-1)
3410       i_start = its
3411       i_end   = MIN(ite,ide-1)
3412       j_start = jts
3413       j_end   = MIN(jte,jde-1)
3414
3415 !  higher order flux has a 5 or 7 point stencil, so compute
3416 !  bounds so we can switch to second order flux close to the boundary
3417
3418       j_start_f = j_start
3419       j_end_f   = j_end+1
3420
3421       IF(degrade_ys) then
3422         j_start = MAX(jts,jds+1)
3423         j_start_f = jds+3
3424       ENDIF
3425
3426       IF(degrade_ye) then
3427         j_end = MIN(jte,jde-2)
3428         j_end_f = jde-3
3429       ENDIF
3430
3431       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3432
3433 !  compute fluxes, 5th or 6th order
3434
3435      jp1 = 2
3436      jp0 = 1
3437
3438      j_loop_y_flux_5 : DO j = j_start, j_end+1
3439
3440       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
3441
3442         DO k=kts,ktf
3443         DO i = i_start, i_end
3444           vel = rv(i,k,j)
3445           fqy( i, k, jp1 ) = vel*flux5(                                &
3446                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
3447                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
3448         ENDDO
3449         ENDDO
3450
3451       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
3452
3453             DO k=kts,ktf
3454             DO i = i_start, i_end
3455               fqy(i,k, jp1) = 0.5*rv(i,k,j)*          &
3456                      (field(i,k,j)+field(i,k,j-1))
3457
3458             ENDDO
3459             ENDDO
3460
3461      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
3462
3463             DO k=kts,ktf
3464             DO i = i_start, i_end
3465               vel = rv(i,k,j)
3466               fqy( i, k, jp1 ) = vel*flux3(              &
3467                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
3468             ENDDO
3469             ENDDO
3470
3471      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
3472
3473             DO k=kts,ktf
3474             DO i = i_start, i_end
3475               fqy(i, k, jp1) = 0.5*rv(i,k,j)*      &
3476                      (field(i,k,j)+field(i,k,j-1))
3477             ENDDO
3478             ENDDO
3479
3480      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
3481
3482             DO k=kts,ktf
3483             DO i = i_start, i_end
3484               vel = rv(i,k,j)
3485               fqy( i, k, jp1) = vel*flux3(             &
3486                    field(i,k,j-2),field(i,k,j-1),    &
3487                    field(i,k,j),field(i,k,j+1),vel )
3488             ENDDO
3489             ENDDO
3490
3491      ENDIF
3492
3493 !  y flux-divergence into tendency
3494
3495         ! Comments on polar boundary conditions
3496         ! Same process as for advect_u - tendencies run from jds to jde-1
3497         ! (latitudes are as for u grid, longitudes are displaced)
3498         ! Therefore: flow is only from one side for points next to poles
3499         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3500           DO k=kts,ktf
3501           DO i = i_start, i_end
3502             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3503             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3504           END DO
3505           END DO
3506         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3507           DO k=kts,ktf
3508           DO i = i_start, i_end
3509             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3510             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3511           END DO
3512           END DO
3513         ELSE  ! normal code
3514
3515         IF(j > j_start) THEN
3516
3517           DO k=kts,ktf
3518           DO i = i_start, i_end
3519             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3520             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3521           ENDDO
3522           ENDDO
3523
3524         ENDIF
3525
3526         END IF
3527
3528         jtmp = jp1
3529         jp1 = jp0
3530         jp0 = jtmp
3531
3532       ENDDO j_loop_y_flux_5
3533
3534 !  next, x - flux divergence
3535
3536       i_start = its
3537       i_end   = MIN(ite,ide-1)
3538
3539       j_start = jts
3540       j_end   = MIN(jte,jde-1)
3541
3542 !  higher order flux has a 5 or 7 point stencil, so compute
3543 !  bounds so we can switch to second order flux close to the boundary
3544
3545       i_start_f = i_start
3546       i_end_f   = i_end+1
3547
3548       IF(degrade_xs) then
3549         i_start = MAX(ids+1,its)
3550         i_start_f = i_start+2
3551       ENDIF
3552
3553       IF(degrade_xe) then
3554         i_end = MIN(ide-2,ite)
3555         i_end_f = ide-3
3556       ENDIF
3557
3558 !  compute fluxes
3559
3560       DO j = j_start, j_end
3561
3562 !  5th or 6th order flux
3563
3564         DO k=kts,ktf
3565         DO i = i_start_f, i_end_f
3566           vel = ru(i,k,j)
3567           fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
3568                                          field(i-1,k,j), field(i  ,k,j),  &
3569                                          field(i+1,k,j), field(i+2,k,j),  &
3570                                          vel                             )
3571         ENDDO
3572         ENDDO
3573
3574 !  lower order fluxes close to boundaries (if not periodic or symmetric)
3575
3576         IF( degrade_xs ) THEN
3577
3578           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
3579             i = ids+1
3580             DO k=kts,ktf
3581               fqx(i,k) = 0.5*(ru(i,k,j)) &
3582                      *(field(i,k,j)+field(i-1,k,j))
3583
3584             ENDDO
3585           ENDIF
3586
3587           i = ids+2
3588           DO k=kts,ktf
3589             vel = ru(i,k,j)
3590             fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
3591                                           field(i  ,k,j), field(i+1,k,j),  &
3592                                           vel                     )
3593           ENDDO
3594
3595         ENDIF
3596
3597         IF( degrade_xe ) THEN
3598
3599           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
3600             i = ide-1
3601             DO k=kts,ktf
3602               fqx(i,k) = 0.5*(ru(i,k,j))      &
3603                      *(field(i,k,j)+field(i-1,k,j))
3604             ENDDO
3605          ENDIF
3606
3607           i = ide-2
3608           DO k=kts,ktf
3609             vel = ru(i,k,j)
3610             fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
3611                                           field(i  ,k,j), field(i+1,k,j),  &
3612                                           vel                             )
3613           ENDDO
3614
3615         ENDIF
3616
3617 !  x flux-divergence into tendency
3618
3619           DO k=kts,ktf
3620           DO i = i_start, i_end
3621             mrdx=msftx(i,j)*rdx      ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3622             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3623           ENDDO
3624           ENDDO
3625
3626       ENDDO
3627
3628
3629    ELSE IF( horz_order == 4 ) THEN
3630
3631    degrade_xs = .true.
3632    degrade_xe = .true.
3633    degrade_ys = .true.
3634    degrade_ye = .true.
3635
3636    IF( config_flags%periodic_x   .or. &
3637        config_flags%symmetric_xs .or. &
3638        (its > ids+1)                ) degrade_xs = .false.
3639    IF( config_flags%periodic_x   .or. &
3640        config_flags%symmetric_xe .or. &
3641        (ite < ide-2)                ) degrade_xe = .false.
3642    IF( config_flags%periodic_y   .or. &
3643        config_flags%symmetric_ys .or. &
3644        (jts > jds+1)                ) degrade_ys = .false.
3645    IF( config_flags%periodic_y   .or. &
3646        config_flags%symmetric_ye .or. &
3647        (jte < jde-2)                ) degrade_ye = .false.
3648
3649 !  begin flux computations
3650 !  start with x flux divergence
3651
3652    ktf=MIN(kte,kde-1)
3653
3654       i_start = its
3655       i_end   = MIN(ite,ide-1)
3656       j_start = jts
3657       j_end   = MIN(jte,jde-1)
3658
3659 !  3rd or 4th order flux has a 5 point stencil, so compute
3660 !  bounds so we can switch to second order flux close to the boundary
3661
3662       i_start_f = i_start
3663       i_end_f   = i_end+1
3664
3665       IF(degrade_xs) then
3666         i_start = ids+1
3667         i_start_f = i_start+1
3668       ENDIF
3669
3670       IF(degrade_xe) then
3671         i_end = ide-2
3672         i_end_f = ide-2
3673       ENDIF
3674
3675 !  compute fluxes
3676
3677       DO j = j_start, j_end
3678
3679 !  3rd or 4th order flux
3680
3681         DO k=kts,ktf
3682         DO i = i_start_f, i_end_f
3683
3684           fqx( i, k) = ru(i,k,j)*flux4( field(i-2,k,j), field(i-1,k,j),  &
3685                                         field(i  ,k,j), field(i+1,k,j),  &
3686                                         ru(i,k,j)                       )
3687         ENDDO
3688         ENDDO
3689
3690 !  second order flux close to boundaries (if not periodic or symmetric)
3691
3692         IF( degrade_xs ) THEN
3693           DO k=kts,ktf
3694             fqx(i_start, k) = 0.5*ru(i_start,k,j)             &
3695                    *(field(i_start,k,j)+field(i_start-1,k,j))
3696           ENDDO
3697         ENDIF
3698
3699         IF( degrade_xe ) THEN
3700           DO k=kts,ktf
3701             fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j)          &
3702                    *(field(i_end+1,k,j)+field(i_end,k,j))
3703           ENDDO
3704         ENDIF
3705
3706 !  x flux-divergence into tendency
3707
3708         DO k=kts,ktf
3709         DO i = i_start, i_end
3710           mrdx=msftx(i,j)*rdx        ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3711           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3712         ENDDO
3713         ENDDO
3714
3715       ENDDO
3716
3717
3718 !  next -> y flux divergence calculation
3719
3720       i_start = its
3721       i_end   = MIN(ite,ide-1)
3722       j_start = jts
3723       j_end   = MIN(jte,jde-1)
3724
3725 !  3rd or 4th order flux has a 5 point stencil, so compute
3726 !  bounds so we can switch to second order flux close to the boundary
3727
3728       j_start_f = j_start
3729       j_end_f   = j_end+1
3730
3731       IF(degrade_ys) then
3732         j_start = jds+1
3733         j_start_f = j_start+1
3734       ENDIF
3735
3736       IF(degrade_ye) then
3737         j_end = jde-2
3738         j_end_f = jde-2
3739       ENDIF
3740
3741       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3742
3743     jp1 = 2
3744     jp0 = 1
3745
3746   DO j = j_start, j_end+1
3747
3748     IF ((j < j_start_f) .and. degrade_ys) THEN
3749       DO k = kts, ktf
3750       DO i = i_start, i_end
3751          fqy(i,k,jp1) = 0.5*rv(i,k,j_start)             &
3752                 *(field(i,k,j_start)+field(i,k,j_start-1))
3753       ENDDO
3754       ENDDO
3755     ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
3756       DO k = kts, ktf
3757       DO i = i_start, i_end
3758          ! Assumes j>j_end_f is ONLY j_end+1 ...
3759 !         fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1)          &
3760 !                *(field(i,k,j_end+1)+field(i,k,j_end))
3761          fqy(i,k,jp1) = 0.5*rv(i,k,j)          &
3762                 *(field(i,k,j)+field(i,k,j-1))
3763       ENDDO
3764       ENDDO
3765     ELSE
3766 !  3rd or 4th order flux
3767       DO k = kts, ktf
3768       DO i = i_start, i_end
3769          fqy( i, k, jp1 ) = rv(i,k,j)*flux4( field(i,k,j-2), field(i,k,j-1),  &
3770                                             field(i,k,j  ), field(i,k,j+1),  &
3771                                             rv(i,k,j)                       )
3772       ENDDO
3773       ENDDO
3774     END IF
3775
3776 !  y flux-divergence into tendency
3777
3778     ! Comments on polar boundary conditions
3779     ! Same process as for advect_u - tendencies run from jds to jde-1
3780     ! (latitudes are as for u grid, longitudes are displaced)
3781     ! Therefore: flow is only from one side for points next to poles
3782     IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3783       DO k=kts,ktf
3784       DO i = i_start, i_end
3785         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3786         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3787       END DO
3788       END DO
3789     ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3790       DO k=kts,ktf
3791       DO i = i_start, i_end
3792         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3793         tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3794       END DO
3795       END DO
3796     ELSE  ! normal code
3797
3798     IF ( j > j_start ) THEN
3799
3800       DO k=kts,ktf
3801       DO i = i_start, i_end
3802         mrdy=msftx(i,j-1)*rdy        ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3803         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3804       ENDDO
3805       ENDDO
3806
3807     END IF
3808
3809     END IF
3810
3811     jtmp = jp1
3812     jp1 = jp0
3813     jp0 = jtmp
3814
3815   ENDDO
3816
3817
3818    ELSE IF( horz_order == 3 ) THEN
3819
3820    degrade_xs = .true.
3821    degrade_xe = .true.
3822    degrade_ys = .true.
3823    degrade_ye = .true.
3824
3825    IF( config_flags%periodic_x   .or. &
3826        config_flags%symmetric_xs .or. &
3827        (its > ids+1)                ) degrade_xs = .false.
3828    IF( config_flags%periodic_x   .or. &
3829        config_flags%symmetric_xe .or. &
3830        (ite < ide-2)                ) degrade_xe = .false.
3831    IF( config_flags%periodic_y   .or. &
3832        config_flags%symmetric_ys .or. &
3833        (jts > jds+1)                ) degrade_ys = .false.
3834    IF( config_flags%periodic_y   .or. &
3835        config_flags%symmetric_ye .or. &
3836        (jte < jde-2)                ) degrade_ye = .false.
3837
3838 !  begin flux computations
3839 !  start with x flux divergence
3840
3841    ktf=MIN(kte,kde-1)
3842
3843       i_start = its
3844       i_end   = MIN(ite,ide-1)
3845       j_start = jts
3846       j_end   = MIN(jte,jde-1)
3847
3848 !  3rd or 4th order flux has a 5 point stencil, so compute
3849 !  bounds so we can switch to second order flux close to the boundary
3850
3851       i_start_f = i_start
3852       i_end_f   = i_end+1
3853
3854       IF(degrade_xs) then
3855         i_start = ids+1
3856         i_start_f = i_start+1
3857       ENDIF
3858
3859       IF(degrade_xe) then
3860         i_end = ide-2
3861         i_end_f = ide-2
3862       ENDIF
3863
3864 !  compute fluxes
3865
3866       DO j = j_start, j_end
3867
3868 !  3rd or 4th order flux
3869
3870         DO k=kts,ktf
3871         DO i = i_start_f, i_end_f
3872
3873           fqx( i, k) = ru(i,k,j)*flux3( field(i-2,k,j), field(i-1,k,j),  &
3874                                         field(i  ,k,j), field(i+1,k,j),  &
3875                                         ru(i,k,j)                       )
3876         ENDDO
3877         ENDDO
3878
3879 !  second order flux close to boundaries (if not periodic or symmetric)
3880
3881         IF( degrade_xs ) THEN
3882           DO k=kts,ktf
3883             fqx(i_start, k) = 0.5*ru(i_start,k,j)             &
3884                    *(field(i_start,k,j)+field(i_start-1,k,j))
3885           ENDDO
3886         ENDIF
3887
3888         IF( degrade_xe ) THEN
3889           DO k=kts,ktf
3890             fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j)          &
3891                    *(field(i_end+1,k,j)+field(i_end,k,j))
3892           ENDDO
3893         ENDIF
3894
3895 !  x flux-divergence into tendency
3896
3897         DO k=kts,ktf
3898         DO i = i_start, i_end
3899           mrdx=msftx(i,j)*rdx        ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3900           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3901         ENDDO
3902         ENDDO
3903
3904       ENDDO
3905
3906
3907 !  next -> y flux divergence calculation
3908
3909       i_start = its
3910       i_end   = MIN(ite,ide-1)
3911       j_start = jts
3912       j_end   = MIN(jte,jde-1)
3913
3914 !  3rd or 4th order flux has a 5 point stencil, so compute
3915 !  bounds so we can switch to second order flux close to the boundary
3916
3917       j_start_f = j_start
3918       j_end_f   = j_end+1
3919
3920       IF(degrade_ys) then
3921         j_start = jds+1
3922         j_start_f = j_start+1
3923       ENDIF
3924
3925       IF(degrade_ye) then
3926         j_end = jde-2
3927         j_end_f = jde-2
3928       ENDIF
3929
3930       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3931
3932     jp1 = 2
3933     jp0 = 1
3934
3935   DO j = j_start, j_end+1
3936
3937     IF ((j < j_start_f) .and. degrade_ys) THEN
3938       DO k = kts, ktf
3939       DO i = i_start, i_end
3940          fqy(i,k,jp1) = 0.5*rv(i,k,j_start)             &
3941                 *(field(i,k,j_start)+field(i,k,j_start-1))
3942       ENDDO
3943       ENDDO
3944     ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
3945       DO k = kts, ktf
3946       DO i = i_start, i_end
3947          ! Assumes j>j_end_f is ONLY j_end+1 ...
3948 !         fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1)          &
3949 !                *(field(i,k,j_end+1)+field(i,k,j_end))
3950          fqy(i,k,jp1) = 0.5*rv(i,k,j)          &
3951                 *(field(i,k,j)+field(i,k,j-1))
3952       ENDDO
3953       ENDDO
3954     ELSE
3955 !  3rd or 4th order flux
3956       DO k = kts, ktf
3957       DO i = i_start, i_end
3958          fqy( i, k, jp1 ) = rv(i,k,j)*flux3( field(i,k,j-2), field(i,k,j-1),  &
3959                                             field(i,k,j  ), field(i,k,j+1),  &
3960                                             rv(i,k,j)                       )
3961       ENDDO
3962       ENDDO
3963     END IF
3964
3965 !  y flux-divergence into tendency
3966
3967     ! Comments on polar boundary conditions
3968     ! Same process as for advect_u - tendencies run from jds to jde-1
3969     ! (latitudes are as for u grid, longitudes are displaced)
3970     ! Therefore: flow is only from one side for points next to poles
3971     IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3972       DO k=kts,ktf
3973       DO i = i_start, i_end
3974         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3975         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3976       END DO
3977       END DO
3978     ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3979       DO k=kts,ktf
3980       DO i = i_start, i_end
3981         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3982         tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3983       END DO
3984       END DO
3985     ELSE  ! normal code
3986
3987     IF ( j > j_start ) THEN
3988
3989       DO k=kts,ktf
3990       DO i = i_start, i_end
3991         mrdy=msftx(i,j-1)*rdy        ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3992         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3993       ENDDO
3994       ENDDO
3995
3996     END IF
3997
3998     END IF
3999
4000     jtmp = jp1
4001     jp1 = jp0
4002     jp0 = jtmp
4003
4004   ENDDO
4005
4006    ELSE IF( horz_order == 2 ) THEN
4007
4008       i_start = its
4009       i_end   = MIN(ite,ide-1)
4010       j_start = jts
4011       j_end   = MIN(jte,jde-1)
4012
4013       IF ( .NOT. config_flags%periodic_x ) THEN
4014         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
4015         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
4016       ENDIF
4017
4018       DO j = j_start, j_end
4019       DO k = kts, ktf
4020       DO i = i_start, i_end
4021          mrdx=msftx(i,j)*rdx         ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
4022          tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 &
4023                          *(ru(i+1,k,j)*(field(i+1,k,j)+field(i  ,k,j)) &
4024                           -ru(i  ,k,j)*(field(i  ,k,j)+field(i-1,k,j)))
4025       ENDDO
4026       ENDDO
4027       ENDDO
4028
4029       i_start = its
4030       i_end   = MIN(ite,ide-1)
4031
4032       ! Polar boundary conditions are like open or specified
4033       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
4034       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-2,jte)
4035
4036       DO j = j_start, j_end
4037       DO k = kts, ktf
4038       DO i = i_start, i_end
4039          mrdy=msftx(i,j)*rdy         ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4040          tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 &
4041                          *(rv(i,k,j+1)*(field(i,k,j+1)+field(i,k,j  )) &
4042                           -rv(i,k,j  )*(field(i,k,j  )+field(i,k,j-1)))
4043       ENDDO
4044       ENDDO
4045       ENDDO
4046
4047       ! Polar boundary condtions
4048       ! These won't be covered in the loop above...
4049       IF (config_flags%polar) THEN
4050          IF (jts == jds) THEN
4051             DO k=kts,ktf
4052             DO i = i_start, i_end
4053                mrdy=msftx(i,jds)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4054                tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 &
4055                                 *rv(i,k,jds+1)*(field(i,k,jds+1)+field(i,k,jds))
4056             END DO
4057             END DO
4058          END IF
4059          IF (jte == jde) THEN
4060             DO k=kts,ktf
4061             DO i = i_start, i_end
4062                mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4063                tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 &
4064                                   *rv(i,k,jde-1)*(field(i,k,jde-1)+field(i,k,jde-2))
4065             END DO
4066             END DO
4067          END IF
4068       END IF
4069
4070    ELSE IF ( horz_order == 0 ) THEN
4071
4072       ! Just in case we want to turn horizontal advection off, we can do it
4073
4074    ELSE
4075
4076       WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_6a, h_order not known ',horz_order
4077       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
4078
4079    ENDIF horizontal_order_test
4080
4081 !  pick up the rest of the horizontal radiation boundary conditions.
4082 !  (these are the computations that don't require 'cb'.
4083 !  first, set to index ranges
4084
4085       i_start = its
4086       i_end   = MIN(ite,ide-1)
4087       j_start = jts
4088       j_end   = MIN(jte,jde-1)
4089
4090 !  compute x (u) conditions for v, w, or scalar
4091
4092    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
4093
4094        DO j = j_start, j_end
4095        DO k = kts, ktf
4096          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
4097          tendency(its,k,j) = tendency(its,k,j)                     &
4098                - rdx*(                                             &
4099                        ub*(   field_old(its+1,k,j)                 &
4100                             - field_old(its  ,k,j)   ) +           &
4101                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
4102                                                                 )
4103        ENDDO
4104        ENDDO
4105
4106    ENDIF
4107
4108    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
4109
4110        DO j = j_start, j_end
4111        DO k = kts, ktf
4112          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
4113          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
4114                - rdx*(                                               &
4115                        ub*(  field_old(i_end  ,k,j)                  &
4116                            - field_old(i_end-1,k,j) ) +              &
4117                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
4118                                                                     )
4119        ENDDO
4120        ENDDO
4121
4122    ENDIF
4123
4124    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
4125
4126        DO i = i_start, i_end
4127        DO k = kts, ktf
4128          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
4129          tendency(i,k,jts) = tendency(i,k,jts)                     &
4130                - rdy*(                                             &
4131                        vb*(  field_old(i,k,jts+1)                  &
4132                            - field_old(i,k,jts  ) ) +              &
4133                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
4134                                                                 )
4135        ENDDO
4136        ENDDO
4137
4138    ENDIF
4139
4140    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
4141
4142        DO i = i_start, i_end
4143        DO k = kts, ktf
4144          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
4145          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
4146                - rdy*(                                               &
4147                        vb*(   field_old(i,k,j_end  )                 &
4148                             - field_old(i,k,j_end-1) ) +             &
4149                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
4150                                                                     )
4151        ENDDO
4152        ENDDO
4153
4154    ENDIF
4155
4156
4157 !-------------------- vertical advection
4158 !     Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
4159 !     Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
4160 !     So we don't need to make a correction for advect_scalar
4161
4162       i_start = its
4163       i_end   = MIN(ite,ide-1)
4164       j_start = jts
4165       j_end   = MIN(jte,jde-1)
4166
4167       DO i = i_start, i_end
4168          vflux(i,kts)=0.
4169          vflux(i,kte)=0.
4170       ENDDO
4171
4172     vert_order_test : IF (vert_order == 6) THEN
4173
4174       DO j = j_start, j_end
4175
4176          DO k=kts+3,ktf-2
4177          DO i = i_start, i_end
4178            vel=rom(i,k,j)
4179            vflux(i,k) = vel*flux6(                                 &
4180                    field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
4181                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
4182          ENDDO
4183          ENDDO
4184
4185          DO i = i_start, i_end
4186
4187            k=kts+1
4188            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4189
4190            k = kts+2
4191            vel=rom(i,k,j)
4192            vflux(i,k) = vel*flux4(               &
4193                    field(i,k-2,j), field(i,k-1,j),   &
4194                    field(i,k  ,j), field(i,k+1,j), -vel )
4195            k = ktf-1
4196            vel=rom(i,k,j)
4197            vflux(i,k) = vel*flux4(               &
4198                    field(i,k-2,j), field(i,k-1,j),   &
4199                    field(i,k  ,j), field(i,k+1,j), -vel )
4200
4201            k=ktf
4202            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4203          ENDDO
4204
4205          DO k=kts,ktf
4206          DO i = i_start, i_end
4207             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4208          ENDDO
4209          ENDDO
4210
4211       ENDDO
4212
4213    ELSE IF (vert_order == 5) THEN
4214
4215       DO j = j_start, j_end
4216
4217          DO k=kts+3,ktf-2
4218          DO i = i_start, i_end
4219            vel=rom(i,k,j)
4220            vflux(i,k) = vel*flux5(                                 &
4221                    field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
4222                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
4223          ENDDO
4224          ENDDO
4225
4226          DO i = i_start, i_end
4227
4228            k=kts+1
4229            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4230
4231            k = kts+2
4232            vel=rom(i,k,j)
4233            vflux(i,k) = vel*flux3(               &
4234                    field(i,k-2,j), field(i,k-1,j),   &
4235                    field(i,k  ,j), field(i,k+1,j), -vel )
4236            k = ktf-1
4237            vel=rom(i,k,j)
4238            vflux(i,k) = vel*flux3(               &
4239                    field(i,k-2,j), field(i,k-1,j),   &
4240                    field(i,k  ,j), field(i,k+1,j), -vel )
4241
4242            k=ktf
4243            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4244          ENDDO
4245
4246          DO k=kts,ktf
4247          DO i = i_start, i_end
4248             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4249          ENDDO
4250          ENDDO
4251
4252       ENDDO
4253
4254    ELSE IF (vert_order == 4) THEN
4255
4256       DO j = j_start, j_end
4257
4258          DO k=kts+2,ktf-1
4259          DO i = i_start, i_end
4260            vel=rom(i,k,j)
4261            vflux(i,k) = vel*flux4(                                 &
4262                    field(i,k-2,j), field(i,k-1,j),       &
4263                    field(i,k  ,j), field(i,k+1,j),  -vel )
4264          ENDDO
4265          ENDDO
4266
4267          DO i = i_start, i_end
4268
4269            k=kts+1
4270            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4271            k=ktf
4272            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4273          ENDDO
4274
4275          DO k=kts,ktf
4276          DO i = i_start, i_end
4277             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4278          ENDDO
4279          ENDDO
4280
4281       ENDDO
4282
4283    ELSE IF (vert_order == 3) THEN
4284
4285       DO j = j_start, j_end
4286
4287          DO k=kts+2,ktf-1
4288          DO i = i_start, i_end
4289            vel=rom(i,k,j)
4290            vflux(i,k) = vel*flux3(                      &
4291                    field(i,k-2,j), field(i,k-1,j),      &
4292                    field(i,k  ,j), field(i,k+1,j),  -vel )
4293          ENDDO
4294          ENDDO
4295
4296          DO i = i_start, i_end
4297
4298            k=kts+1
4299            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4300            k=ktf
4301            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4302          ENDDO
4303
4304          DO k=kts,ktf
4305          DO i = i_start, i_end
4306             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4307          ENDDO
4308          ENDDO
4309
4310       ENDDO
4311
4312
4313    ELSE IF (vert_order == 2) THEN
4314
4315   DO j = j_start, j_end
4316      DO k = kts+1, ktf
4317      DO i = i_start, i_end
4318             vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4319      ENDDO
4320      ENDDO
4321
4322      DO k = kts, ktf
4323      DO i = i_start, i_end
4324        tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4325      ENDDO
4326      ENDDO
4327
4328   ENDDO
4329
4330    ELSE
4331
4332       WRITE (wrf_err_message,*) ' advect_scalar_6a, v_order not known ',vert_order
4333       CALL wrf_error_fatal ( wrf_err_message )
4334
4335    ENDIF vert_order_test
4336
4337 END SUBROUTINE advect_scalar
4338
4339 !---------------------------------------------------------------------------------
4340
4341 SUBROUTINE advect_w    ( w, w_old, tendency,            &
4342                          ru, rv, rom,                   &
4343                          mut, time_step, config_flags,  &
4344                          msfux, msfuy, msfvx, msfvy,    &
4345                          msftx, msfty,                  &
4346                          fzm, fzp,                      &
4347                          rdx, rdy, rdzu,                &
4348                          ids, ide, jds, jde, kds, kde,  &
4349                          ims, ime, jms, jme, kms, kme,  &
4350                          its, ite, jts, jte, kts, kte  )
4351
4352    IMPLICIT NONE
4353
4354    ! Input data
4355
4356    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
4357
4358    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
4359                                               ims, ime, jms, jme, kms, kme, &
4360                                               its, ite, jts, jte, kts, kte
4361
4362    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: w,     &
4363                                                                       w_old, &
4364                                                                       ru,    &
4365                                                                       rv,    &
4366                                                                       rom
4367
4368    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
4369    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
4370
4371    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
4372                                                                     msfuy,  &
4373                                                                     msfvx,  &
4374                                                                     msfvy,  &
4375                                                                     msftx,  &
4376                                                                     msfty
4377
4378    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
4379                                                                   fzp,  &
4380                                                                   rdzu
4381
4382    REAL ,                                        INTENT(IN   ) :: rdx,  &
4383                                                                   rdy
4384    INTEGER ,                                     INTENT(IN   ) :: time_step
4385
4386
4387    ! Local data
4388
4389    INTEGER :: i, j, k, itf, jtf, ktf
4390    INTEGER :: i_start, i_end, j_start, j_end
4391    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
4392    INTEGER :: jmin, jmax, jp, jm, imin, imax
4393
4394    REAL    :: mrdx, mrdy, ub, vb, uw, vw
4395    REAL , DIMENSION(its:ite, kts:kte) :: vflux
4396
4397    INTEGER :: horz_order, vert_order
4398
4399    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
4400    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
4401
4402    LOGICAL :: degrade_xs, degrade_ys
4403    LOGICAL :: degrade_xe, degrade_ye
4404
4405    INTEGER :: jp1, jp0, jtmp
4406
4407 ! definition of flux operators, 3rd, 4th, 5th or 6th order
4408
4409    REAL    :: flux3, flux4, flux5, flux6
4410    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
4411
4412       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
4413           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
4414
4415       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
4416            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
4417            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
4418
4419       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
4420                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)      &
4421                      +(q_ip2+q_im3) )/60.0
4422
4423       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
4424            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
4425             -sign(1,time_step)*sign(1.,ua)*(                    &
4426               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
4427
4428
4429    LOGICAL :: specified
4430
4431    specified = .false.
4432    if(config_flags%specified .or. config_flags%nested) specified = .true.
4433
4434 !  set order for the advection scheme
4435
4436   ktf=MIN(kte,kde-1)
4437   horz_order = config_flags%h_sca_adv_order
4438   vert_order = config_flags%v_sca_adv_order
4439
4440 !  here is the choice of flux operators
4441
4442 !  begin with horizontal flux divergence
4443
4444   horizontal_order_test : IF( horz_order == 6 ) THEN
4445
4446 !  determine boundary mods for flux operators
4447 !  We degrade the flux operators from 3rd/4th order
4448 !   to second order one gridpoint in from the boundaries for
4449 !   all boundary conditions except periodic and symmetry - these
4450 !   conditions have boundary zone data fill for correct application
4451 !   of the higher order flux stencils
4452
4453    degrade_xs = .true.
4454    degrade_xe = .true.
4455    degrade_ys = .true.
4456    degrade_ye = .true.
4457
4458    IF( config_flags%periodic_x   .or. &
4459        config_flags%symmetric_xs .or. &
4460        (its > ids+2)                ) degrade_xs = .false.
4461    IF( config_flags%periodic_x   .or. &
4462        config_flags%symmetric_xe .or. &
4463        (ite < ide-3)                ) degrade_xe = .false.
4464    IF( config_flags%periodic_y   .or. &
4465        config_flags%symmetric_ys .or. &
4466        (jts > jds+2)                ) degrade_ys = .false.
4467    IF( config_flags%periodic_y   .or. &
4468        config_flags%symmetric_ye .or. &
4469        (jte < jde-3)                ) degrade_ye = .false.
4470
4471 !--------------- y - advection first
4472
4473       i_start = its
4474       i_end   = MIN(ite,ide-1)
4475       j_start = jts
4476       j_end   = MIN(jte,jde-1)
4477
4478 !  higher order flux has a 5 or 7 point stencil, so compute
4479 !  bounds so we can switch to second order flux close to the boundary
4480
4481       j_start_f = j_start
4482       j_end_f   = j_end+1
4483
4484       IF(degrade_ys) then
4485         j_start = MAX(jts,jds+1)
4486         j_start_f = jds+3
4487       ENDIF
4488
4489       IF(degrade_ye) then
4490         j_end = MIN(jte,jde-2)
4491         j_end_f = jde-3
4492       ENDIF
4493
4494       IF(config_flags%polar) j_end = MIN(jte,jde-1)
4495
4496 !  compute fluxes, 5th or 6th order
4497
4498      jp1 = 2
4499      jp0 = 1
4500
4501      j_loop_y_flux_6 : DO j = j_start, j_end+1
4502
4503       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
4504
4505         DO k=kts+1,ktf
4506         DO i = i_start, i_end
4507           vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4508           fqy( i, k, jp1 ) = vel*flux6(                     &
4509                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4510                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4511         ENDDO
4512         ENDDO
4513
4514         k = ktf+1
4515         DO i = i_start, i_end
4516           vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4517           fqy( i, k, jp1 ) = vel*flux6(                     &
4518                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4519                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4520         ENDDO
4521
4522       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
4523
4524             DO k=kts+1,ktf
4525             DO i = i_start, i_end
4526               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*          &
4527                      (w(i,k,j)+w(i,k,j-1))
4528             ENDDO
4529             ENDDO
4530
4531             k = ktf+1
4532             DO i = i_start, i_end
4533               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))* &
4534                      (w(i,k,j)+w(i,k,j-1))
4535             ENDDO
4536
4537      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
4538
4539             DO k=kts+1,ktf
4540             DO i = i_start, i_end
4541               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4542               fqy( i, k, jp1 ) = vel*flux4(              &
4543                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4544             ENDDO
4545             ENDDO
4546
4547             k = ktf+1
4548             DO i = i_start, i_end
4549               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4550               fqy( i, k, jp1 ) = vel*flux4(              &
4551                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4552             ENDDO
4553
4554      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
4555
4556             DO k=kts+1,ktf
4557             DO i = i_start, i_end
4558               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*      &
4559                      (w(i,k,j)+w(i,k,j-1))
4560             ENDDO
4561             ENDDO
4562
4563             k = ktf+1
4564             DO i = i_start, i_end
4565               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*      &
4566                      (w(i,k,j)+w(i,k,j-1))
4567             ENDDO
4568
4569      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
4570
4571             DO k=kts+1,ktf
4572             DO i = i_start, i_end
4573               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4574               fqy( i, k, jp1 ) = vel*flux4(             &
4575                    w(i,k,j-2),w(i,k,j-1),    &
4576                    w(i,k,j),w(i,k,j+1),vel )
4577             ENDDO
4578             ENDDO
4579
4580             k = ktf+1
4581             DO i = i_start, i_end
4582               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4583               fqy( i, k, jp1 ) = vel*flux4(             &
4584                    w(i,k,j-2),w(i,k,j-1),    &
4585                    w(i,k,j),w(i,k,j+1),vel )
4586             ENDDO
4587
4588      ENDIF
4589
4590 !  y flux-divergence into tendency
4591
4592         ! Comments for polar boundary conditions
4593         ! Same process as for advect_u - tendencies run from jds to jde-1
4594         ! (latitudes are as for u grid, longitudes are displaced)
4595         ! Therefore: flow is only from one side for points next to poles
4596         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
4597           DO k=kts,ktf
4598           DO i = i_start, i_end
4599             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4600             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
4601           ENDDO
4602           ENDDO
4603         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
4604           DO k=kts,ktf
4605           DO i = i_start, i_end
4606             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4607             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
4608           END DO
4609           END DO
4610         ELSE  ! normal code
4611
4612         IF(j > j_start) THEN
4613
4614           DO k=kts+1,ktf+1
4615           DO i = i_start, i_end
4616             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4617             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
4618           ENDDO
4619           ENDDO
4620
4621        ENDIF
4622
4623        ENDIF
4624
4625         jtmp = jp1
4626         jp1 = jp0
4627         jp0 = jtmp
4628
4629       ENDDO j_loop_y_flux_6
4630
4631 !  next, x - flux divergence
4632
4633       i_start = its
4634       i_end   = MIN(ite,ide-1)
4635
4636       j_start = jts
4637       j_end   = MIN(jte,jde-1)
4638
4639 !  higher order flux has a 5 or 7 point stencil, so compute
4640 !  bounds so we can switch to second order flux close to the boundary
4641
4642       i_start_f = i_start
4643       i_end_f   = i_end+1
4644
4645       IF(degrade_xs) then
4646         i_start = MAX(ids+1,its)
4647         i_start_f = i_start+2
4648       ENDIF
4649
4650       IF(degrade_xe) then
4651         i_end = MIN(ide-2,ite)
4652         i_end_f = ide-3
4653       ENDIF
4654
4655 !  compute fluxes
4656
4657       DO j = j_start, j_end
4658
4659 !  5th or 6th order flux
4660
4661         DO k=kts+1,ktf
4662         DO i = i_start_f, i_end_f
4663           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4664           fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j),  &
4665                                          w(i-1,k,j), w(i  ,k,j),  &
4666                                          w(i+1,k,j), w(i+2,k,j),  &
4667                                          vel                             )
4668         ENDDO
4669         ENDDO
4670
4671         k = ktf+1
4672         DO i = i_start_f, i_end_f
4673           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4674           fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j),  &
4675                                          w(i-1,k,j), w(i  ,k,j),  &
4676                                          w(i+1,k,j), w(i+2,k,j),  &
4677                                          vel                             )
4678         ENDDO
4679
4680 !  lower order fluxes close to boundaries (if not periodic or symmetric)
4681
4682         IF( degrade_xs ) THEN
4683
4684           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
4685             i = ids+1
4686             DO k=kts+1,ktf
4687               fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
4688                      *(w(i,k,j)+w(i-1,k,j))
4689             ENDDO
4690               k = ktf+1
4691               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
4692                      *(w(i,k,j)+w(i-1,k,j))
4693           ENDIF
4694
4695           DO k=kts+1,ktf
4696             i = i_start+1
4697             vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4698             fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
4699                                           w(i  ,k,j), w(i+1,k,j),  &
4700                                           vel                     )
4701           ENDDO
4702
4703             k = ktf+1
4704             vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4705             fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
4706                                           w(i  ,k,j), w(i+1,k,j),  &
4707                                           vel                     )
4708         ENDIF
4709
4710         IF( degrade_xe ) THEN
4711
4712           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
4713             i = ide-1
4714             DO k=kts+1,ktf
4715               fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
4716                      *(w(i,k,j)+w(i-1,k,j))
4717             ENDDO
4718               k = ktf+1
4719               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))      &
4720                      *(w(i,k,j)+w(i-1,k,j))
4721           ENDIF
4722
4723           i = ide-2
4724           DO k=kts+1,ktf
4725             vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4726             fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
4727                                           w(i  ,k,j), w(i+1,k,j),  &
4728                                           vel                             )
4729           ENDDO
4730
4731             k = ktf+1
4732             vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4733             fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
4734                                           w(i  ,k,j), w(i+1,k,j),  &
4735                                           vel                             )
4736         ENDIF
4737
4738 !  x flux-divergence into tendency
4739
4740         DO k=kts+1,ktf+1
4741           DO i = i_start, i_end
4742             mrdx=msftx(i,j)*rdx      ! see ADT eqn 46 dividing by my, 1st term RHS
4743             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
4744           ENDDO
4745         ENDDO
4746
4747       ENDDO
4748
4749
4750 ELSE IF (horz_order == 5 ) THEN
4751
4752 !  determine boundary mods for flux operators
4753 !  We degrade the flux operators from 3rd/4th order
4754 !   to second order one gridpoint in from the boundaries for
4755 !   all boundary conditions except periodic and symmetry - these
4756 !   conditions have boundary zone data fill for correct application
4757 !   of the higher order flux stencils
4758
4759    degrade_xs = .true.
4760    degrade_xe = .true.
4761    degrade_ys = .true.
4762    degrade_ye = .true.
4763
4764    IF( config_flags%periodic_x   .or. &
4765        config_flags%symmetric_xs .or. &
4766        (its > ids+2)                ) degrade_xs = .false.
4767    IF( config_flags%periodic_x   .or. &
4768        config_flags%symmetric_xe .or. &
4769        (ite < ide-3)                ) degrade_xe = .false.
4770    IF( config_flags%periodic_y   .or. &
4771        config_flags%symmetric_ys .or. &
4772        (jts > jds+2)                ) degrade_ys = .false.
4773    IF( config_flags%periodic_y   .or. &
4774        config_flags%symmetric_ye .or. &
4775        (jte < jde-3)                ) degrade_ye = .false.
4776
4777 !--------------- y - advection first
4778
4779       i_start = its
4780       i_end   = MIN(ite,ide-1)
4781       j_start = jts
4782       j_end   = MIN(jte,jde-1)
4783
4784 !  higher order flux has a 5 or 7 point stencil, so compute
4785 !  bounds so we can switch to second order flux close to the boundary
4786
4787       j_start_f = j_start
4788       j_end_f   = j_end+1
4789
4790       IF(degrade_ys) then
4791         j_start = MAX(jts,jds+1)
4792         j_start_f = jds+3
4793       ENDIF
4794
4795       IF(degrade_ye) then
4796         j_end = MIN(jte,jde-2)
4797         j_end_f = jde-3
4798       ENDIF
4799
4800       IF(config_flags%polar) j_end = MIN(jte,jde-1)
4801
4802 !  compute fluxes, 5th or 6th order
4803
4804      jp1 = 2
4805      jp0 = 1
4806
4807      j_loop_y_flux_5 : DO j = j_start, j_end+1
4808
4809       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
4810
4811         DO k=kts+1,ktf
4812         DO i = i_start, i_end
4813           vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4814           fqy( i, k, jp1 ) = vel*flux5(                     &
4815                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4816                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4817         ENDDO
4818         ENDDO
4819
4820         k = ktf+1
4821         DO i = i_start, i_end
4822           vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4823           fqy( i, k, jp1 ) = vel*flux5(                     &
4824                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4825                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4826         ENDDO
4827
4828       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
4829
4830             DO k=kts+1,ktf
4831             DO i = i_start, i_end
4832               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*          &
4833                      (w(i,k,j)+w(i,k,j-1))
4834             ENDDO
4835             ENDDO
4836
4837             k = ktf+1
4838             DO i = i_start, i_end
4839               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*          &
4840                      (w(i,k,j)+w(i,k,j-1))
4841             ENDDO
4842
4843      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
4844
4845             DO k=kts+1,ktf
4846             DO i = i_start, i_end
4847               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4848               fqy( i, k, jp1 ) = vel*flux3(              &
4849                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4850             ENDDO
4851             ENDDO
4852
4853             k = ktf+1
4854             DO i = i_start, i_end
4855               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4856               fqy( i, k, jp1 ) = vel*flux3(              &
4857                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4858             ENDDO
4859
4860      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
4861
4862             DO k=kts+1,ktf
4863             DO i = i_start, i_end
4864               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*      &
4865                      (w(i,k,j)+w(i,k,j-1))
4866             ENDDO
4867             ENDDO
4868
4869             k = ktf+1
4870             DO i = i_start, i_end
4871               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*      &
4872                      (w(i,k,j)+w(i,k,j-1))
4873             ENDDO
4874
4875      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
4876
4877             DO k=kts+1,ktf
4878             DO i = i_start, i_end
4879               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4880               fqy( i, k, jp1 ) = vel*flux3(             &
4881                    w(i,k,j-2),w(i,k,j-1),    &
4882                    w(i,k,j),w(i,k,j+1),vel )
4883             ENDDO
4884             ENDDO
4885
4886             k = ktf+1
4887             DO i = i_start, i_end
4888               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4889               fqy( i, k, jp1 ) = vel*flux3(             &
4890                    w(i,k,j-2),w(i,k,j-1),    &
4891                    w(i,k,j),w(i,k,j+1),vel )
4892             ENDDO
4893
4894      ENDIF
4895
4896 !  y flux-divergence into tendency
4897
4898         ! Comments for polar boundary conditions
4899         ! Same process as for advect_u - tendencies run from jds to jde-1
4900         ! (latitudes are as for u grid, longitudes are displaced)
4901         ! Therefore: flow is only from one side for points next to poles
4902         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
4903           DO k=kts,ktf
4904           DO i = i_start, i_end
4905             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4906             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
4907           END DO
4908           END DO
4909         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
4910           DO k=kts,ktf
4911           DO i = i_start, i_end
4912             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4913             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
4914           END DO
4915           END DO
4916         ELSE  ! normal code
4917
4918         IF(j > j_start) THEN
4919
4920           DO k=kts+1,ktf+1
4921           DO i = i_start, i_end
4922             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4923             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
4924           ENDDO
4925           ENDDO
4926
4927        ENDIF
4928
4929         END IF
4930
4931         jtmp = jp1
4932         jp1 = jp0
4933         jp0 = jtmp
4934
4935       ENDDO j_loop_y_flux_5
4936
4937 !  next, x - flux divergence
4938
4939       i_start = its
4940       i_end   = MIN(ite,ide-1)
4941
4942       j_start = jts
4943       j_end   = MIN(jte,jde-1)
4944
4945 !  higher order flux has a 5 or 7 point stencil, so compute
4946 !  bounds so we can switch to second order flux close to the boundary
4947
4948       i_start_f = i_start
4949       i_end_f   = i_end+1
4950
4951       IF(degrade_xs) then
4952         i_start = MAX(ids+1,its)
4953         i_start_f = i_start+2
4954       ENDIF
4955
4956       IF(degrade_xe) then
4957         i_end = MIN(ide-2,ite)
4958         i_end_f = ide-3
4959       ENDIF
4960
4961 !  compute fluxes
4962
4963       DO j = j_start, j_end
4964
4965 !  5th or 6th order flux
4966
4967         DO k=kts+1,ktf
4968         DO i = i_start_f, i_end_f
4969           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4970           fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
4971                                   w(i-1,k,j), w(i  ,k,j),  &
4972                                   w(i+1,k,j), w(i+2,k,j),  &
4973                           vel                             )
4974         ENDDO
4975         ENDDO
4976
4977         k = ktf+1
4978         DO i = i_start_f, i_end_f
4979           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4980           fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
4981                                   w(i-1,k,j), w(i  ,k,j),  &
4982                                   w(i+1,k,j), w(i+2,k,j),  &
4983                           vel                             )
4984         ENDDO
4985
4986 !  lower order fluxes close to boundaries (if not periodic or symmetric)
4987
4988         IF( degrade_xs ) THEN
4989
4990           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
4991             i = ids+1
4992             DO k=kts+1,ktf
4993               fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
4994                      *(w(i,k,j)+w(i-1,k,j))
4995             ENDDO
4996               k = ktf+1
4997               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
4998                      *(w(i,k,j)+w(i-1,k,j))
4999           ENDIF
5000
5001           i = i_start+1
5002           DO k=kts+1,ktf
5003             vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5004             fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5005                                     w(i  ,k,j), w(i+1,k,j),  &
5006                                           vel                     )
5007           ENDDO
5008             k = ktf+1
5009             vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5010             fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5011                                     w(i  ,k,j), w(i+1,k,j),  &
5012                                           vel                     )
5013
5014         ENDIF
5015
5016         IF( degrade_xe ) THEN
5017
5018           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
5019             i = ide-1
5020             DO k=kts+1,ktf
5021               fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
5022                      *(w(i,k,j)+w(i-1,k,j))
5023             ENDDO
5024               k = ktf+1
5025               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))      &
5026                      *(w(i,k,j)+w(i-1,k,j))
5027           ENDIF
5028
5029           i = ide-2
5030           DO k=kts+1,ktf
5031             vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5032             fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5033                                           w(i  ,k,j), w(i+1,k,j),  &
5034                                           vel                             )
5035           ENDDO
5036             k = ktf+1
5037             vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5038             fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5039                                           w(i  ,k,j), w(i+1,k,j),  &
5040                                           vel                             )
5041         ENDIF
5042
5043 !  x flux-divergence into tendency
5044
5045         DO k=kts+1,ktf+1
5046           DO i = i_start, i_end
5047             mrdx=msftx(i,j)*rdx      ! see ADT eqn 46 dividing by my, 1st term RHS
5048             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
5049           ENDDO
5050         ENDDO
5051
5052       ENDDO
5053
5054 ELSE IF ( horz_order == 4 ) THEN
5055
5056    degrade_xs = .true.
5057    degrade_xe = .true.
5058    degrade_ys = .true.
5059    degrade_ye = .true.
5060
5061    IF( config_flags%periodic_x   .or. &
5062        config_flags%symmetric_xs .or. &
5063        (its > ids+1)                ) degrade_xs = .false.
5064    IF( config_flags%periodic_x   .or. &
5065        config_flags%symmetric_xe .or. &
5066        (ite < ide-2)                ) degrade_xe = .false.
5067    IF( config_flags%periodic_y   .or. &
5068        config_flags%symmetric_ys .or. &
5069        (jts > jds+1)                ) degrade_ys = .false.
5070    IF( config_flags%periodic_y   .or. &
5071        config_flags%symmetric_ye .or. &
5072        (jte < jde-2)                ) degrade_ye = .false.
5073
5074 !  begin flux computations
5075 !  start with x flux divergence
5076
5077 !---------------
5078
5079    ktf=MIN(kte,kde-1)
5080
5081       i_start = its
5082       i_end   = MIN(ite,ide-1)
5083       j_start = jts
5084       j_end   = MIN(jte,jde-1)
5085
5086 !  3rd or 4th order flux has a 5 point stencil, so compute
5087 !  bounds so we can switch to second order flux close to the boundary
5088
5089       i_start_f = i_start
5090       i_end_f   = i_end+1
5091
5092       IF(degrade_xs) then
5093         i_start = ids+1
5094         i_start_f = i_start+1
5095       ENDIF
5096
5097       IF(degrade_xe) then
5098         i_end = ide-2
5099         i_end_f = ide-2
5100       ENDIF
5101
5102 !  compute fluxes
5103
5104       DO j = j_start, j_end
5105
5106         DO k=kts+1,ktf
5107         DO i = i_start_f, i_end_f
5108           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5109           fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
5110                                   w(i  ,k,j), w(i+1,k,j),  &
5111                                   vel                     )
5112         ENDDO
5113         ENDDO
5114
5115         k = ktf+1
5116         DO i = i_start_f, i_end_f
5117           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5118           fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
5119                                   w(i  ,k,j), w(i+1,k,j),  &
5120                                   vel                     )
5121         ENDDO
5122 !  second order flux close to boundaries (if not periodic or symmetric)
5123
5124         IF( degrade_xs ) THEN
5125           DO k=kts+1,ktf
5126             fqx(i_start, k) =                            &
5127                0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j))  &
5128                    *(w(i_start,k,j)+w(i_start-1,k,j))
5129           ENDDO
5130             k = ktf+1
5131             fqx(i_start, k) =                            &
5132                0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j))  &
5133                    *(w(i_start,k,j)+w(i_start-1,k,j))
5134         ENDIF
5135
5136         IF( degrade_xe ) THEN
5137           DO k=kts+1,ktf
5138             fqx(i_end+1, k) =                            &
5139                0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j))  &
5140                    *(w(i_end+1,k,j)+w(i_end,k,j))
5141           ENDDO
5142             k = ktf+1
5143             fqx(i_end+1, k) =                            &
5144                0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j))  &
5145                    *(w(i_end+1,k,j)+w(i_end,k,j))
5146         ENDIF
5147
5148 !  x flux-divergence into tendency
5149
5150         DO k=kts+1,ktf+1
5151         DO i = i_start, i_end
5152           mrdx=msftx(i,j)*rdx        ! see ADT eqn 46 dividing by my, 1st term RHS
5153           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
5154         ENDDO
5155         ENDDO
5156
5157       ENDDO
5158
5159 !  next -> y flux divergence calculation
5160
5161       i_start = its
5162       i_end   = MIN(ite,ide-1)
5163       j_start = jts
5164       j_end   = MIN(jte,jde-1)
5165
5166
5167 !  3rd or 4th order flux has a 5 point stencil, so compute
5168 !  bounds so we can switch to second order flux close to the boundary
5169
5170       j_start_f = j_start
5171       j_end_f   = j_end+1
5172
5173       IF(degrade_ys) then
5174         j_start = jds+1
5175         j_start_f = j_start+1
5176       ENDIF
5177
5178       IF(degrade_ye) then
5179         j_end = jde-2
5180         j_end_f = jde-2
5181       ENDIF
5182
5183       IF(config_flags%polar) j_end = MIN(jte,jde-1)
5184
5185         jp1 = 2
5186         jp0 = 1
5187
5188       DO j = j_start, j_end+1
5189
5190        IF ((j < j_start_f) .and. degrade_ys)  THEN
5191           DO k = kts+1, ktf
5192           DO i = i_start, i_end
5193             fqy(i, k, jp1) =                             &
5194                0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start))   &
5195                    *(w(i,k,j_start)+w(i,k,j_start-1))
5196           ENDDO
5197           ENDDO
5198           k = ktf+1
5199           DO i = i_start, i_end
5200             fqy(i, k, jp1) =                             &
5201                0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start))   &
5202                    *(w(i,k,j_start)+w(i,k,j_start-1))
5203           ENDDO
5204        ELSE IF ((j > j_end_f) .and. degrade_ye)  THEN
5205           DO k = kts+1, ktf
5206           DO i = i_start, i_end
5207             ! Assumes j>j_end_f is ONLY j_end+1 ...
5208 !            fqy(i, k, jp1) =                             &
5209 !               0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1))     &
5210 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5211             fqy(i, k, jp1) =                             &
5212                0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))     &
5213                    *(w(i,k,j)+w(i,k,j-1))
5214           ENDDO
5215           ENDDO
5216           k = ktf+1
5217           DO i = i_start, i_end
5218             ! Assumes j>j_end_f is ONLY j_end+1 ...
5219 !            fqy(i, k, jp1) =                                         &
5220 !               0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1))     &
5221 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5222             fqy(i, k, jp1) =                                         &
5223                0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))     &
5224                    *(w(i,k,j)+w(i,k,j-1))
5225           ENDDO
5226        ELSE
5227 !  3rd or 4th order flux
5228           DO k = kts+1, ktf
5229           DO i = i_start, i_end
5230             vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
5231             fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1),  &
5232                                     w(i,k,j  ), w(i,k,j+1),  &
5233                                     vel                     )
5234           ENDDO
5235           ENDDO
5236           k = ktf+1
5237           DO i = i_start, i_end
5238             vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
5239             fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1),  &
5240                                     w(i,k,j  ), w(i,k,j+1),  &
5241                                     vel                     )
5242           ENDDO
5243        END IF
5244
5245 !  y flux-divergence into tendency
5246
5247        ! Comments for polar boundary conditions
5248        ! Same process as for advect_u - tendencies run from jds to jde-1
5249        ! (latitudes are as for u grid, longitudes are displaced)
5250        ! Therefore: flow is only from one side for points next to poles
5251        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
5252          DO k=kts,ktf
5253          DO i = i_start, i_end
5254            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5255            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
5256          END DO
5257          END DO
5258        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
5259          DO k=kts,ktf
5260          DO i = i_start, i_end
5261            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5262            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
5263          END DO
5264          END DO
5265        ELSE  ! normal code
5266
5267        IF( j > j_start ) THEN
5268
5269           DO k = kts+1, ktf+1
5270           DO i = i_start, i_end
5271             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5272             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
5273           ENDDO
5274           ENDDO
5275
5276        END IF
5277
5278        END IF
5279
5280        jtmp = jp1
5281        jp1 = jp0
5282        jp0 = jtmp
5283
5284     ENDDO
5285
5286 ELSE IF ( horz_order == 3 ) THEN
5287
5288    degrade_xs = .true.
5289    degrade_xe = .true.
5290    degrade_ys = .true.
5291    degrade_ye = .true.
5292
5293    IF( config_flags%periodic_x   .or. &
5294        config_flags%symmetric_xs .or. &
5295        (its > ids+1)                ) degrade_xs = .false.
5296    IF( config_flags%periodic_x   .or. &
5297        config_flags%symmetric_xe .or. &
5298        (ite < ide-2)                ) degrade_xe = .false.
5299    IF( config_flags%periodic_y   .or. &
5300        config_flags%symmetric_ys .or. &
5301        (jts > jds+1)                ) degrade_ys = .false.
5302    IF( config_flags%periodic_y   .or. &
5303        config_flags%symmetric_ye .or. &
5304        (jte < jde-2)                ) degrade_ye = .false.
5305
5306 !  begin flux computations
5307 !  start with x flux divergence
5308
5309 !---------------
5310
5311    ktf=MIN(kte,kde-1)
5312
5313       i_start = its
5314       i_end   = MIN(ite,ide-1)
5315       j_start = jts
5316       j_end   = MIN(jte,jde-1)
5317
5318 !  3rd or 4th order flux has a 5 point stencil, so compute
5319 !  bounds so we can switch to second order flux close to the boundary
5320
5321       i_start_f = i_start
5322       i_end_f   = i_end+1
5323
5324       IF(degrade_xs) then
5325         i_start = ids+1
5326         i_start_f = i_start+1
5327       ENDIF
5328
5329       IF(degrade_xe) then
5330         i_end = ide-2
5331         i_end_f = ide-2
5332       ENDIF
5333
5334 !  compute fluxes
5335
5336       DO j = j_start, j_end
5337
5338         DO k=kts+1,ktf
5339         DO i = i_start_f, i_end_f
5340           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5341           fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5342                                   w(i  ,k,j), w(i+1,k,j),  &
5343                                   vel                     )
5344         ENDDO
5345         ENDDO
5346         k = ktf+1
5347         DO i = i_start_f, i_end_f
5348           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5349           fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5350                                   w(i  ,k,j), w(i+1,k,j),  &
5351                                   vel                     )
5352         ENDDO
5353
5354 !  second order flux close to boundaries (if not periodic or symmetric)
5355
5356         IF( degrade_xs ) THEN
5357           DO k=kts+1,ktf
5358             fqx(i_start, k) =                            &
5359                0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j))  &
5360                    *(w(i_start,k,j)+w(i_start-1,k,j))
5361           ENDDO
5362             k = ktf+1
5363             fqx(i_start, k) =                            &
5364                0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j))  &
5365                    *(w(i_start,k,j)+w(i_start-1,k,j))
5366         ENDIF
5367
5368         IF( degrade_xe ) THEN
5369           DO k=kts+1,ktf
5370             fqx(i_end+1, k) =                            &
5371                0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j))  &
5372                    *(w(i_end+1,k,j)+w(i_end,k,j))
5373           ENDDO
5374             k = ktf+1
5375             fqx(i_end+1, k) =                            &
5376                0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j))  &
5377                    *(w(i_end+1,k,j)+w(i_end,k,j))
5378         ENDIF
5379
5380 !  x flux-divergence into tendency
5381
5382         DO k=kts+1,ktf+1
5383         DO i = i_start, i_end
5384           mrdx=msftx(i,j)*rdx        ! see ADT eqn 46 dividing by my, 1st term RHS
5385           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
5386         ENDDO
5387         ENDDO
5388
5389       ENDDO
5390
5391 !  next -> y flux divergence calculation
5392
5393       i_start = its
5394       i_end   = MIN(ite,ide-1)
5395       j_start = jts
5396       j_end   = MIN(jte,jde-1)
5397
5398
5399 !  3rd or 4th order flux has a 5 point stencil, so compute
5400 !  bounds so we can switch to second order flux close to the boundary
5401
5402       j_start_f = j_start
5403       j_end_f   = j_end+1
5404
5405       IF(degrade_ys) then
5406         j_start = jds+1
5407         j_start_f = j_start+1
5408       ENDIF
5409
5410       IF(degrade_ye) then
5411         j_end = jde-2
5412         j_end_f = jde-2
5413       ENDIF
5414
5415       IF(config_flags%polar) j_end = MIN(jte,jde-1)
5416
5417         jp1 = 2
5418         jp0 = 1
5419
5420       DO j = j_start, j_end+1
5421
5422        IF ((j < j_start_f) .and. degrade_ys)  THEN
5423           DO k = kts+1, ktf
5424           DO i = i_start, i_end
5425             fqy(i, k, jp1) =                             &
5426                0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start))   &
5427                    *(w(i,k,j_start)+w(i,k,j_start-1))
5428           ENDDO
5429           ENDDO
5430           k = ktf+1
5431           DO i = i_start, i_end
5432             fqy(i, k, jp1) =                             &
5433                0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start))   &
5434                    *(w(i,k,j_start)+w(i,k,j_start-1))
5435           ENDDO
5436        ELSE IF ((j > j_end_f) .and. degrade_ye)  THEN
5437           DO k = kts+1, ktf
5438           DO i = i_start, i_end
5439             ! Assumes j>j_end_f is ONLY j_end+1 ...
5440 !            fqy(i, k, jp1) =                             &
5441 !               0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1))     &
5442 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5443             fqy(i, k, jp1) =                             &
5444                0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))     &
5445                    *(w(i,k,j)+w(i,k,j-1))
5446           ENDDO
5447           ENDDO
5448           k = ktf+1
5449           DO i = i_start, i_end
5450             ! Assumes j>j_end_f is ONLY j_end+1 ...
5451 !            fqy(i, k, jp1) =                             &
5452 !               0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1))     &
5453 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5454             fqy(i, k, jp1) =                             &
5455                0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))     &
5456                    *(w(i,k,j)+w(i,k,j-1))
5457           ENDDO
5458        ELSE
5459 !  3rd or 4th order flux
5460           DO k = kts+1, ktf
5461           DO i = i_start, i_end
5462             vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
5463             fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1),  &
5464                                     w(i,k,j  ), w(i,k,j+1),  &
5465                                     vel                     )
5466           ENDDO
5467           ENDDO
5468           k = ktf+1
5469           DO i = i_start, i_end
5470             vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
5471             fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1),  &
5472                                     w(i,k,j  ), w(i,k,j+1),  &
5473                                     vel                     )
5474           ENDDO
5475        END IF
5476
5477 !  y flux-divergence into tendency
5478
5479        ! Comments for polar boundary conditions
5480        ! Same process as for advect_u - tendencies run from jds to jde-1
5481        ! (latitudes are as for u grid, longitudes are displaced)
5482        ! Therefore: flow is only from one side for points next to poles
5483        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
5484          DO k=kts,ktf
5485          DO i = i_start, i_end
5486            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5487            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
5488          END DO
5489          END DO
5490        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
5491          DO k=kts,ktf
5492          DO i = i_start, i_end
5493            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5494            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
5495          END DO
5496          END DO
5497        ELSE  ! normal code
5498
5499        IF( j > j_start ) THEN
5500
5501           DO k = kts+1, ktf+1
5502           DO i = i_start, i_end
5503             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5504             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
5505           ENDDO
5506           ENDDO
5507
5508        END IF
5509
5510        END IF
5511
5512        jtmp = jp1
5513        jp1 = jp0
5514        jp0 = jtmp
5515
5516     ENDDO
5517
5518 ELSE IF (horz_order == 2 ) THEN
5519
5520       i_start = its
5521       i_end   = MIN(ite,ide-1)
5522       j_start = jts
5523       j_end   = MIN(jte,jde-1)
5524
5525       IF ( .NOT. config_flags%periodic_x ) THEN
5526         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
5527         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
5528       ENDIF
5529
5530       DO j = j_start, j_end
5531       DO k=kts+1,ktf
5532       DO i = i_start, i_end
5533
5534          mrdx=msftx(i,j)*rdx         ! see ADT eqn 46 dividing by my, 1st term RHS
5535
5536             tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5            &
5537                    *((fzm(k)*ru(i+1,k,j)+fzp(k)*ru(i+1,k-1,j))  &
5538                                 *(w(i+1,k,j)+w(i,k,j))          &
5539                     -(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
5540                                *(w(i,k,j)+w(i-1,k,j)))
5541
5542       ENDDO
5543       ENDDO
5544
5545       k = ktf+1
5546       DO i = i_start, i_end
5547
5548          mrdx=msftx(i,j)*rdx         ! see ADT eqn 46 dividing by my, 1st term RHS
5549
5550             tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5            &
5551                    *(((2.-fzm(k-1))*ru(i+1,k-1,j)-fzp(k-1)*ru(i+1,k-2,j))      &
5552                                 *(w(i+1,k,j)+w(i,k,j))          &
5553                     -((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))         &
5554                                *(w(i,k,j)+w(i-1,k,j)))
5555
5556       ENDDO
5557
5558       ENDDO
5559
5560       i_start = its
5561       i_end   = MIN(ite,ide-1)
5562       ! Polar boundary conditions are like open or specified
5563       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
5564       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-2,jte)
5565
5566       DO j = j_start, j_end
5567       DO k=kts+1,ktf
5568       DO i = i_start, i_end
5569
5570          mrdy=msftx(i,j)*rdy         !  see ADT eqn 46 dividing by my, 2nd term RHS
5571
5572             tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5           &
5573                    *((fzm(k)*rv(i,k,j+1)+fzp(k)*rv(i,k-1,j+1))* &
5574                                  (w(i,k,j+1)+w(i,k,j))          &
5575                     -(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))      &
5576                                  *(w(i,k,j)+w(i,k,j-1)))
5577
5578       ENDDO
5579       ENDDO
5580
5581       k = ktf+1
5582       DO i = i_start, i_end
5583
5584          mrdy=msftx(i,j)*rdy         ! see ADT eqn 46 dividing by my, 2nd term RHS
5585
5586             tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5       &
5587                    *(((2.-fzm(k-1))*rv(i,k-1,j+1)-fzp(k-1)*rv(i,k-2,j+1))* &
5588                                  (w(i,k,j+1)+w(i,k,j))      &
5589                     -((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))      &
5590                                  *(w(i,k,j)+w(i,k,j-1)))
5591
5592       ENDDO
5593
5594       ENDDO
5595
5596       ! Polar boundary condition ... not covered in above j-loop
5597       IF (config_flags%polar) THEN
5598          IF (jts == jds) THEN
5599             DO k=kts+1,ktf
5600             DO i = i_start, i_end
5601                mrdy=msftx(i,jds)*rdy   ! see ADT eqn 46 dividing by my, 2nd term RHS
5602                tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 &
5603                           *((fzm(k)*rv(i,k,jds+1)+fzp(k)*rv(i,k-1,jds+1))* &
5604                             (w(i,k,jds+1)+w(i,k,jds)))
5605             END DO
5606             END DO
5607             k = ktf+1
5608             DO i = i_start, i_end
5609                mrdy=msftx(i,jds)*rdy   ! see ADT eqn 46 dividing by my, 2nd term RHS
5610                tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5       &
5611                    *((2.-fzm(k-1))*rv(i,k-1,jds+1)-fzp(k-1)*rv(i,k-2,jds+1))* &
5612                                  (w(i,k,jds+1)+w(i,k,jds))
5613             ENDDO
5614          END IF
5615          IF (jte == jde) THEN
5616             DO k=kts+1,ktf
5617             DO i = i_start, i_end
5618                mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5619                tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 &
5620                           *((fzm(k)*rv(i,k,jde-1)+fzp(k)*rv(i,k-1,jde-1))* &
5621                             (w(i,k,jde-1)+w(i,k,jde-2)))
5622             END DO
5623             END DO
5624             k = ktf+1
5625             DO i = i_start, i_end
5626                mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5627                tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5       &
5628                     *((2.-fzm(k-1))*rv(i,k-1,jde-1)-fzp(k-1)*rv(i,k-2,jde-1)) &
5629                                  *(w(i,k,jde-1)+w(i,k,jde-2))
5630             ENDDO
5631          END IF
5632       END IF
5633
5634    ELSE IF ( horz_order == 0 ) THEN
5635
5636       ! Just in case we want to turn horizontal advection off, we can do it
5637
5638    ELSE
5639
5640       WRITE ( wrf_err_message ,*) ' advect_w_6a, h_order not known ',horz_order
5641       CALL wrf_error_fatal ( wrf_err_message )
5642
5643    ENDIF horizontal_order_test
5644
5645
5646 !  pick up the the horizontal radiation boundary conditions.
5647 !  (these are the computations that don't require 'cb'.
5648 !  first, set to index ranges
5649
5650
5651       i_start = its
5652       i_end   = MIN(ite,ide-1)
5653       j_start = jts
5654       j_end   = MIN(jte,jde-1)
5655
5656    IF( (config_flags%open_xs) .and. (its == ids)) THEN
5657
5658        DO j = j_start, j_end
5659        DO k = kts+1, ktf
5660
5661          uw = 0.5*(fzm(k)*(ru(its,k  ,j)+ru(its+1,k  ,j)) +  &
5662                    fzp(k)*(ru(its,k-1,j)+ru(its+1,k-1,j))   )
5663          ub = MIN( uw, 0. )
5664
5665          tendency(its,k,j) = tendency(its,k,j)                     &
5666                - rdx*(                                             &
5667                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
5668                        w(its,k,j)*(                                &
5669                        fzm(k)*(ru(its+1,k  ,j)-ru(its,k  ,j))+     &
5670                        fzp(k)*(ru(its+1,k-1,j)-ru(its,k-1,j)))     &
5671                                                                   )
5672        ENDDO
5673        ENDDO
5674
5675        k = ktf+1
5676        DO j = j_start, j_end
5677
5678          uw = 0.5*( (2.-fzm(k-1))*(ru(its,k-1,j)+ru(its+1,k-1,j))   &
5679                    -fzp(k-1)*(ru(its,k-2,j)+ru(its+1,k-2,j))   )
5680          ub = MIN( uw, 0. )
5681
5682          tendency(its,k,j) = tendency(its,k,j)                     &
5683                - rdx*(                                             &
5684                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
5685                        w(its,k,j)*(                                &
5686                              (2.-fzm(k-1))*(ru(its+1,k-1,j)-ru(its,k-1,j))-  &
5687                              fzp(k-1)*(ru(its+1,k-2,j)-ru(its,k-2,j)))  &
5688                                                                   )
5689        ENDDO
5690
5691    ENDIF
5692
5693    IF( (config_flags%open_xe) .and. (ite == ide)) THEN
5694
5695        DO j = j_start, j_end
5696        DO k = kts+1, ktf
5697
5698          uw = 0.5*(fzm(k)*(ru(ite-1,k  ,j)+ru(ite,k  ,j)) +  &
5699                    fzp(k)*(ru(ite-1,k-1,j)+ru(ite,k-1,j))   )
5700          ub = MAX( uw, 0. )
5701
5702          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
5703                - rdx*(                                                 &
5704                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
5705                        w(i_end,k,j)*(                                  &
5706                             fzm(k)*(ru(ite,k  ,j)-ru(ite-1,k  ,j)) +   &
5707                             fzp(k)*(ru(ite,k-1,j)-ru(ite-1,k-1,j)))    &
5708                                                                     )
5709        ENDDO
5710        ENDDO
5711
5712        k = ktf+1
5713        DO j = j_start, j_end
5714
5715          uw = 0.5*( (2.-fzm(k-1))*(ru(ite-1,k-1,j)+ru(ite,k-1,j))    &
5716                    -fzp(k-1)*(ru(ite-1,k-2,j)+ru(ite,k-2,j))   )
5717          ub = MAX( uw, 0. )
5718
5719          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
5720                - rdx*(                                                 &
5721                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
5722                        w(i_end,k,j)*(                                  &
5723                                (2.-fzm(k-1))*(ru(ite,k-1,j)-ru(ite-1,k-1,j)) -   &
5724                                fzp(k-1)*(ru(ite,k-2,j)-ru(ite-1,k-2,j)))    &
5725                                                                     )
5726        ENDDO
5727
5728    ENDIF
5729
5730
5731    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
5732
5733        DO i = i_start, i_end
5734        DO k = kts+1, ktf
5735
5736          vw = 0.5*( fzm(k)*(rv(i,k  ,jts)+rv(i,k  ,jts+1)) +  &
5737                     fzp(k)*(rv(i,k-1,jts)+rv(i,k-1,jts+1))   )
5738          vb = MIN( vw, 0. )
5739
5740          tendency(i,k,jts) = tendency(i,k,jts)                     &
5741                - rdy*(                                             &
5742                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
5743                        w(i,k,jts)*(                                &
5744                        fzm(k)*(rv(i,k  ,jts+1)-rv(i,k  ,jts))+     &
5745                        fzp(k)*(rv(i,k-1,jts+1)-rv(i,k-1,jts)))     &
5746                                                                 )
5747        ENDDO
5748        ENDDO
5749
5750        k = ktf+1
5751        DO i = i_start, i_end
5752          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jts)+rv(i,k-1,jts+1))    &
5753                    -fzp(k-1)*(rv(i,k-2,jts)+rv(i,k-2,jts+1))   )
5754          vb = MIN( vw, 0. )
5755
5756          tendency(i,k,jts) = tendency(i,k,jts)                     &
5757                - rdy*(                                             &
5758                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
5759                        w(i,k,jts)*(                                &
5760                           (2.-fzm(k-1))*(rv(i,k-1,jts+1)-rv(i,k-1,jts))-     &
5761                           fzp(k-1)*(rv(i,k-2,jts+1)-rv(i,k-2,jts)))     &
5762                                                                 )
5763        ENDDO
5764
5765    ENDIF
5766
5767    IF( (config_flags%open_ye) .and. (jte == jde) ) THEN
5768
5769        DO i = i_start, i_end
5770        DO k = kts+1, ktf
5771
5772          vw = 0.5*( fzm(k)*(rv(i,k  ,jte-1)+rv(i,k  ,jte)) +  &
5773                     fzp(k)*(rv(i,k-1,jte-1)+rv(i,k-1,jte))   )
5774          vb = MAX( vw, 0. )
5775
5776          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
5777                - rdy*(                                                 &
5778                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
5779                        w(i,k,j_end)*(                                  &
5780                             fzm(k)*(rv(i,k  ,jte)-rv(i,k  ,jte-1))+    &
5781                             fzp(k)*(rv(i,k-1,jte)-rv(i,k-1,jte-1)))    &
5782                                                                       )
5783        ENDDO
5784        ENDDO
5785
5786        k = ktf+1
5787        DO i = i_start, i_end
5788
5789          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jte-1)+rv(i,k-1,jte))    &
5790                    -fzp(k-1)*(rv(i,k-2,jte-1)+rv(i,k-2,jte))   )
5791          vb = MAX( vw, 0. )
5792
5793          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
5794                - rdy*(                                                 &
5795                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
5796                        w(i,k,j_end)*(                                  &
5797                                (2.-fzm(k-1))*(rv(i,k-1,jte)-rv(i,k-1,jte-1))-    &
5798                                fzp(k-1)*(rv(i,k-2,jte)-rv(i,k-2,jte-1)))    &
5799                                                                       )
5800        ENDDO
5801
5802    ENDIF
5803
5804 !-------------------- vertical advection
5805 !     ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
5806 !     Here we have:  - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
5807 !     Therefore we don't need to make a correction for advect_w
5808
5809       i_start = its
5810       i_end   = MIN(ite,ide-1)
5811       j_start = jts
5812       j_end   = MIN(jte,jde-1)
5813
5814       DO i = i_start, i_end
5815          vflux(i,kts)=0.
5816          vflux(i,kte)=0.
5817       ENDDO
5818
5819     vert_order_test : IF (vert_order == 6) THEN
5820
5821       DO j = j_start, j_end
5822
5823          DO k=kts+3,ktf-1
5824          DO i = i_start, i_end
5825            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5826            vflux(i,k) = vel*flux6(                                   &
5827                    w(i,k-3,j), w(i,k-2,j), w(i,k-1,j),       &
5828                    w(i,k  ,j), w(i,k+1,j), w(i,k+2,j),  -vel )
5829          ENDDO
5830          ENDDO
5831
5832          DO i = i_start, i_end
5833
5834            k=kts+1
5835            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5836
5837            k = kts+2
5838            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5839            vflux(i,k) = vel*flux4(               &
5840                    w(i,k-2,j), w(i,k-1,j),   &
5841                    w(i,k  ,j), w(i,k+1,j), -vel )
5842
5843            k = ktf
5844            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5845            vflux(i,k) = vel*flux4(               &
5846                    w(i,k-2,j), w(i,k-1,j),   &
5847                    w(i,k  ,j), w(i,k+1,j), -vel )
5848
5849            k=ktf+1
5850            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5851
5852          ENDDO
5853
5854          DO k=kts+1,ktf
5855          DO i = i_start, i_end
5856             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5857          ENDDO
5858          ENDDO
5859
5860 ! pick up flux contribution for w at the lid. wcs, 13 march 2004
5861          k = ktf+1
5862          DO i = i_start, i_end
5863            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5864          ENDDO
5865
5866       ENDDO
5867
5868  ELSE IF (vert_order == 5) THEN
5869
5870       DO j = j_start, j_end
5871
5872          DO k=kts+3,ktf-1
5873          DO i = i_start, i_end
5874            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5875            vflux(i,k) = vel*flux5(                                   &
5876                    w(i,k-3,j), w(i,k-2,j), w(i,k-1,j),       &
5877                    w(i,k  ,j), w(i,k+1,j), w(i,k+2,j),  -vel )
5878          ENDDO
5879          ENDDO
5880
5881          DO i = i_start, i_end
5882
5883            k=kts+1
5884            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5885
5886            k = kts+2
5887            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5888            vflux(i,k) = vel*flux3(               &
5889                    w(i,k-2,j), w(i,k-1,j),   &
5890                    w(i,k  ,j), w(i,k+1,j), -vel )
5891            k = ktf
5892            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5893            vflux(i,k) = vel*flux3(               &
5894                    w(i,k-2,j), w(i,k-1,j),   &
5895                    w(i,k  ,j), w(i,k+1,j), -vel )
5896
5897            k=ktf+1
5898            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5899
5900          ENDDO
5901
5902          DO k=kts+1,ktf
5903          DO i = i_start, i_end
5904             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5905          ENDDO
5906          ENDDO
5907
5908 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5909          k = ktf+1
5910          DO i = i_start, i_end
5911            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5912          ENDDO
5913
5914       ENDDO
5915
5916  ELSE IF (vert_order == 4) THEN
5917
5918       DO j = j_start, j_end
5919
5920          DO k=kts+2,ktf
5921          DO i = i_start, i_end
5922            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5923            vflux(i,k) = vel*flux4(              &
5924                    w(i,k-2,j), w(i,k-1,j),      &
5925                    w(i,k  ,j), w(i,k+1,j), -vel )
5926          ENDDO
5927          ENDDO
5928
5929          DO i = i_start, i_end
5930
5931            k=kts+1
5932            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5933            k=ktf+1
5934            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5935
5936          ENDDO
5937
5938          DO k=kts+1,ktf
5939          DO i = i_start, i_end
5940             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5941          ENDDO
5942          ENDDO
5943
5944 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5945          k = ktf+1
5946          DO i = i_start, i_end
5947            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5948          ENDDO
5949
5950       ENDDO
5951
5952  ELSE IF (vert_order == 3) THEN
5953
5954       DO j = j_start, j_end
5955
5956          DO k=kts+2,ktf
5957          DO i = i_start, i_end
5958            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5959            vflux(i,k) = vel*flux3(              &
5960                    w(i,k-2,j), w(i,k-1,j),      &
5961                    w(i,k  ,j), w(i,k+1,j), -vel )
5962          ENDDO
5963          ENDDO
5964
5965          DO i = i_start, i_end
5966
5967            k=kts+1
5968            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5969            k=ktf+1
5970            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5971
5972          ENDDO
5973
5974          DO k=kts+1,ktf
5975          DO i = i_start, i_end
5976             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5977          ENDDO
5978          ENDDO
5979
5980 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5981          k = ktf+1
5982          DO i = i_start, i_end
5983            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5984          ENDDO
5985
5986       ENDDO
5987
5988  ELSE IF (vert_order == 2) THEN
5989
5990   DO j = j_start, j_end
5991      DO k=kts+1,ktf+1
5992      DO i = i_start, i_end
5993
5994             vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5995      ENDDO
5996      ENDDO
5997      DO k=kts+1,ktf
5998      DO i = i_start, i_end
5999             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
6000
6001      ENDDO
6002      ENDDO
6003
6004 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
6005      k = ktf+1
6006      DO i = i_start, i_end
6007        tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
6008      ENDDO
6009
6010   ENDDO
6011
6012    ELSE
6013
6014       WRITE (wrf_err_message ,*) ' advect_w, v_order not known ',vert_order
6015       CALL wrf_error_fatal ( wrf_err_message )
6016
6017    ENDIF vert_order_test
6018
6019 END SUBROUTINE advect_w
6020
6021 !----------------------------------------------------------------
6022
6023 SUBROUTINE advect_scalar_pd   ( field, field_old, tendency,    &
6024                                 ru, rv, rom,                   &
6025                                 mut, mub, mu_old,              &
6026                                 config_flags,                  &
6027                                 msfux, msfuy, msfvx, msfvy,    &
6028                                 msftx, msfty,                  &
6029                                 fzm, fzp,                      &
6030                                 rdx, rdy, rdzw, dt,            &
6031                                 ids, ide, jds, jde, kds, kde,  &
6032                                 ims, ime, jms, jme, kms, kme,  &
6033                                 its, ite, jts, jte, kts, kte  )
6034
6035 !  this is a first cut at a positive definite advection option
6036 !  for scalars in WRF.  This version is memory intensive ->
6037 !  we save 3d arrays of x, y and z both high and low order fluxes
6038 !  (six in all).  Alternatively, we could sweep in a direction
6039 !  and lower the cost considerably.
6040
6041 !  uses the Smolarkiewicz MWR 1989 approach, with addition of first-order
6042 !  fluxes initially
6043
6044 !  WCS, 3 December 2002, 24 February 2003
6045
6046    IMPLICIT NONE
6047
6048    ! Input data
6049
6050    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
6051
6052    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
6053                                               ims, ime, jms, jme, kms, kme, &
6054                                               its, ite, jts, jte, kts, kte
6055
6056    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
6057                                                                       field_old, &
6058                                                                       ru,    &
6059                                                                       rv,    &
6060                                                                       rom
6061
6062    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut, mub, mu_old
6063    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
6064
6065    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
6066                                                                     msfuy,  &
6067                                                                     msfvx,  &
6068                                                                     msfvy,  &
6069                                                                     msftx,  &
6070                                                                     msfty
6071
6072    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
6073                                                                   fzp,  &
6074                                                                   rdzw
6075
6076    REAL ,                                        INTENT(IN   ) :: rdx,  &
6077                                                                   rdy,  &
6078                                                                   dt
6079
6080    ! Local data
6081
6082    INTEGER :: i, j, k, itf, jtf, ktf
6083    INTEGER :: i_start, i_end, j_start, j_end
6084    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
6085    INTEGER :: jmin, jmax, jp, jm, imin, imax
6086
6087    REAL    :: mrdx, mrdy, ub, vb, uw, vw, mu
6088
6089 !  storage for high and low order fluxes
6090
6091    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqx, fqy, fqz
6092    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqxl, fqyl, fqzl
6093
6094    INTEGER :: horz_order, vert_order
6095
6096    LOGICAL :: degrade_xs, degrade_ys
6097    LOGICAL :: degrade_xe, degrade_ye
6098
6099    INTEGER :: jp1, jp0, jtmp
6100
6101    REAL :: flux_out, ph_low, scale
6102    REAL, PARAMETER :: eps=1.e-20
6103
6104
6105 ! definition of flux operators, 3rd, 4th, 5th or 6th order
6106
6107    REAL    :: flux3, flux4, flux5, flux6, flux_upwind
6108    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
6109
6110       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
6111             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
6112
6113       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
6114            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
6115            sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
6116
6117       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
6118             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
6119             +(1./60.)*(q_ip2+q_im3)
6120
6121       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
6122            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
6123             -sign(1.,ua)*(1./60.)*(                             &
6124               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
6125
6126       flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 &
6127                                     +0.5*max(-1.0,(cr-abs(cr)))*q_i
6128 !      flux_upwind(q_im1, q_i, cr ) = 0.
6129
6130     REAL     :: dx,dy,dz
6131
6132     LOGICAL, PARAMETER :: pd_limit = .true.
6133
6134 ! set order for the advection schemes
6135
6136 !  write(6,*) ' in pd advection routine '
6137
6138     ! Empty arrays just in case:
6139     IF (config_flags%polar) THEN
6140        fqx(:,:,:)  = 0.
6141        fqy(:,:,:)  = 0.
6142        fqz(:,:,:)  = 0.
6143        fqxl(:,:,:) = 0.
6144        fqyl(:,:,:) = 0.
6145        fqzl(:,:,:) = 0.
6146     END IF
6147
6148   ktf=MIN(kte,kde-1)
6149   horz_order = config_flags%h_sca_adv_order
6150   vert_order = config_flags%v_sca_adv_order
6151
6152 !  determine boundary mods for flux operators
6153 !  We degrade the flux operators from 3rd/4th order
6154 !   to second order one gridpoint in from the boundaries for
6155 !   all boundary conditions except periodic and symmetry - these
6156 !   conditions have boundary zone data fill for correct application
6157 !   of the higher order flux stencils
6158
6159    degrade_xs = .true.
6160    degrade_xe = .true.
6161    degrade_ys = .true.
6162    degrade_ye = .true.
6163
6164 !  begin with horizontal flux divergence
6165 !  here is the choice of flux operators
6166
6167
6168   horizontal_order_test : IF( horz_order == 6 ) THEN
6169
6170    IF( config_flags%periodic_x   .or. &
6171        config_flags%symmetric_xs .or. &
6172        (its > ids+2)                ) degrade_xs = .false.
6173    IF( config_flags%periodic_x   .or. &
6174        config_flags%symmetric_xe .or. &
6175        (ite < ide-3)                ) degrade_xe = .false.
6176    IF( config_flags%periodic_y   .or. &
6177        config_flags%symmetric_ys .or. &
6178        (jts > jds+2)                ) degrade_ys = .false.
6179    IF( config_flags%periodic_y   .or. &
6180        config_flags%symmetric_ye .or. &
6181        (jte < jde-3)                ) degrade_ye = .false.
6182
6183 !--------------- y - advection first
6184
6185 !--  y flux compute; these bounds are for periodic and sym b.c.
6186
6187       ktf=MIN(kte,kde-1)
6188       i_start = its-1
6189       i_end   = MIN(ite,ide-1)+1
6190       j_start = jts-1
6191       j_end   = MIN(jte,jde-1)+1
6192       j_start_f = j_start
6193       j_end_f   = j_end+1
6194
6195 !--  modify loop bounds if open or specified
6196
6197       IF(degrade_xs) i_start = its
6198       IF(degrade_xe) i_end   = MIN(ite,ide-1)
6199
6200       IF(degrade_ys) then
6201         j_start = MAX(jts,jds+1)
6202         j_start_f = jds+3
6203       ENDIF
6204
6205       IF(degrade_ye) then
6206         j_end = MIN(jte,jde-2)
6207         j_end_f = jde-3
6208       ENDIF
6209
6210 !  compute fluxes, 6th order
6211
6212       j_loop_y_flux_6 : DO j = j_start, j_end+1
6213
6214       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6215
6216         DO k=kts,ktf
6217         DO i = i_start, i_end
6218
6219           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6220           mu = 0.5*(mut(i,j)+mut(i,j-1))
6221           vel = rv(i,k,j)
6222           cr = vel*dt/dy/mu
6223           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6224
6225           fqy( i, k, j  ) = vel*flux6(                                  &
6226                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
6227                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
6228
6229           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6230
6231         ENDDO
6232         ENDDO
6233
6234       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
6235
6236             DO k=kts,ktf
6237             DO i = i_start, i_end
6238
6239               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6240               mu = 0.5*(mut(i,j)+mut(i,j-1))
6241               vel = rv(i,k,j)
6242               cr = vel*dt/dy/mu
6243               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6244
6245               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
6246                      (field(i,k,j)+field(i,k,j-1))
6247
6248               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6249
6250             ENDDO
6251             ENDDO
6252
6253       ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
6254
6255             DO k=kts,ktf
6256             DO i = i_start, i_end
6257
6258               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6259               mu = 0.5*(mut(i,j)+mut(i,j-1))
6260               vel = rv(i,k,j)
6261               cr = vel*dt/dy/mu
6262               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6263
6264               fqy( i, k, j ) = vel*flux4(              &
6265                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
6266               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6267
6268             ENDDO
6269             ENDDO
6270
6271       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
6272
6273             DO k=kts,ktf
6274             DO i = i_start, i_end
6275
6276               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6277               mu = 0.5*(mut(i,j)+mut(i,j-1))
6278               vel = rv(i,k,j)
6279               cr = vel*dt/dy/mu
6280               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6281
6282               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
6283                      (field(i,k,j)+field(i,k,j-1))
6284               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6285
6286             ENDDO
6287             ENDDO
6288
6289       ELSE IF ( j == jde-2 ) THEN  ! 4th order flux 2 in from north boundary
6290
6291             DO k=kts,ktf
6292             DO i = i_start, i_end
6293
6294               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6295               mu = 0.5*(mut(i,j)+mut(i,j-1))
6296               vel = rv(i,k,j)
6297               cr = vel*dt/dy/mu
6298               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6299
6300               fqy( i, k, j) = vel*flux4(             &
6301                    field(i,k,j-2),field(i,k,j-1),    &
6302                    field(i,k,j),field(i,k,j+1),vel )
6303               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6304
6305             ENDDO
6306             ENDDO
6307
6308       ENDIF
6309
6310     ENDDO j_loop_y_flux_6
6311
6312 !  next, x flux
6313
6314 !--  these bounds are for periodic and sym conditions
6315
6316       i_start = its-1
6317       i_end   = MIN(ite,ide-1)+1
6318       i_start_f = i_start
6319       i_end_f   = i_end+1
6320
6321       j_start = jts-1
6322       j_end   = MIN(jte,jde-1)+1
6323
6324 !--  modify loop bounds for open and specified b.c
6325
6326       IF(degrade_ys) j_start = jts
6327       IF(degrade_ye) j_end   = MIN(jte,jde-1)
6328
6329       IF(degrade_xs) then
6330         i_start = MAX(ids+1,its)
6331         i_start_f = i_start+2
6332       ENDIF
6333
6334       IF(degrade_xe) then
6335         i_end = MIN(ide-2,ite)
6336         i_end_f = ide-3
6337       ENDIF
6338
6339 !  compute fluxes
6340
6341       DO j = j_start, j_end
6342
6343 !  6th order flux
6344
6345         DO k=kts,ktf
6346         DO i = i_start_f, i_end_f
6347
6348           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6349           mu = 0.5*(mut(i,j)+mut(i-1,j))
6350           vel = ru(i,k,j)
6351           cr = vel*dt/dx/mu
6352           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6353
6354           fqx( i,k,j ) = vel*flux6( field(i-3,k,j), field(i-2,k,j),  &
6355                                          field(i-1,k,j), field(i  ,k,j),  &
6356                                          field(i+1,k,j), field(i+2,k,j),  &
6357                                          vel                             )
6358           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6359
6360         ENDDO
6361         ENDDO
6362
6363 !  lower order fluxes close to boundaries (if not periodic or symmetric)
6364
6365         IF( degrade_xs ) THEN
6366
6367           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
6368             i = ids+1
6369             DO k=kts,ktf
6370
6371               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6372               mu = 0.5*(mut(i,j)+mut(i-1,j))
6373               vel = ru(i,k,j)/mu
6374               cr = vel*dt/dx
6375               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6376
6377               fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6378                      *(field(i,k,j)+field(i-1,k,j))
6379
6380               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6381
6382             ENDDO
6383           ENDIF
6384
6385           i = ids+2
6386           DO k=kts,ktf
6387             dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6388             mu = 0.5*(mut(i,j)+mut(i-1,j))
6389             vel = ru(i,k,j)
6390             cr = vel*dt/dx/mu
6391             fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6392             fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
6393                                           field(i  ,k,j), field(i+1,k,j),  &
6394                                           vel                     )
6395             fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6396
6397           ENDDO
6398
6399         ENDIF
6400
6401         IF( degrade_xe ) THEN
6402
6403           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
6404             i = ide-1
6405             DO k=kts,ktf
6406               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6407               mu = 0.5*(mut(i,j)+mut(i-1,j))
6408               vel = ru(i,k,j)
6409               cr = vel*dt/dx/mu
6410               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6411               fqx(i,k,j) = 0.5*(ru(i,k,j))      &
6412                      *(field(i,k,j)+field(i-1,k,j))
6413               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6414
6415             ENDDO
6416           ENDIF
6417
6418           i = ide-2
6419           DO k=kts,ktf
6420
6421             dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6422             mu = 0.5*(mut(i,j)+mut(i-1,j))
6423             vel = ru(i,k,j)
6424             cr = vel*dt/dx/mu
6425             fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6426             fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
6427                                           field(i  ,k,j), field(i+1,k,j),  &
6428                                           vel                             )
6429             fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6430
6431           ENDDO
6432
6433         ENDIF
6434
6435       ENDDO  ! enddo for outer J loop
6436
6437 !--- end of 6th order horizontal flux calculation
6438
6439     ELSE IF( horz_order == 5 ) THEN
6440
6441    IF( config_flags%periodic_x   .or. &
6442        config_flags%symmetric_xs .or. &
6443        (its > ids+2)                ) degrade_xs = .false.
6444    IF( config_flags%periodic_x   .or. &
6445        config_flags%symmetric_xe .or. &
6446        (ite < ide-3)                ) degrade_xe = .false.
6447    IF( config_flags%periodic_y   .or. &
6448        config_flags%symmetric_ys .or. &
6449        (jts > jds+2)                ) degrade_ys = .false.
6450    IF( config_flags%periodic_y   .or. &
6451        config_flags%symmetric_ye .or. &
6452        (jte < jde-3)                ) degrade_ye = .false.
6453
6454 !--------------- y - advection first
6455
6456 !--  y flux compute; these bounds are for periodic and sym b.c.
6457
6458       ktf=MIN(kte,kde-1)
6459       i_start = its-1
6460       i_end   = MIN(ite,ide-1)+1
6461       j_start = jts-1
6462       j_end   = MIN(jte,jde-1)+1
6463       j_start_f = j_start
6464       j_end_f   = j_end+1
6465
6466 !--  modify loop bounds if open or specified
6467
6468       IF(degrade_xs) i_start = its
6469       IF(degrade_xe) i_end   = MIN(ite,ide-1)
6470
6471       IF(degrade_ys) then
6472         j_start = MAX(jts,jds+1)
6473         j_start_f = jds+3
6474       ENDIF
6475
6476       IF(degrade_ye) then
6477         j_end = MIN(jte,jde-2)
6478         j_end_f = jde-3
6479       ENDIF
6480
6481 !  compute fluxes, 5th order
6482
6483       j_loop_y_flux_5 : DO j = j_start, j_end+1
6484
6485       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6486
6487         DO k=kts,ktf
6488         DO i = i_start, i_end
6489
6490           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6491           mu = 0.5*(mut(i,j)+mut(i,j-1))
6492           vel = rv(i,k,j)
6493           cr = vel*dt/dy/mu
6494           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6495
6496           fqy( i, k, j  ) = vel*flux5(                                  &
6497                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
6498                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
6499
6500           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6501
6502         ENDDO
6503         ENDDO
6504
6505       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
6506
6507             DO k=kts,ktf
6508             DO i = i_start, i_end
6509
6510               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6511               mu = 0.5*(mut(i,j)+mut(i,j-1))
6512               vel = rv(i,k,j)
6513               cr = vel*dt/dy/mu
6514               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6515
6516               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
6517                      (field(i,k,j)+field(i,k,j-1))
6518
6519               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6520
6521             ENDDO
6522             ENDDO
6523
6524       ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
6525
6526             DO k=kts,ktf
6527             DO i = i_start, i_end
6528
6529               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6530               mu = 0.5*(mut(i,j)+mut(i,j-1))
6531               vel = rv(i,k,j)
6532               cr = vel*dt/dy/mu
6533               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6534
6535               fqy( i, k, j ) = vel*flux3(              &
6536                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
6537               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6538
6539             ENDDO
6540             ENDDO
6541
6542       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
6543
6544             DO k=kts,ktf
6545             DO i = i_start, i_end
6546
6547               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6548               mu = 0.5*(mut(i,j)+mut(i,j-1))
6549               vel = rv(i,k,j)
6550               cr = vel*dt/dy/mu
6551               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6552
6553               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
6554                      (field(i,k,j)+field(i,k,j-1))
6555               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6556
6557             ENDDO
6558             ENDDO
6559
6560       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
6561
6562             DO k=kts,ktf
6563             DO i = i_start, i_end
6564
6565               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6566               mu = 0.5*(mut(i,j)+mut(i,j-1))
6567               vel = rv(i,k,j)
6568               cr = vel*dt/dy/mu
6569               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6570
6571               fqy( i, k, j) = vel*flux3(             &
6572                    field(i,k,j-2),field(i,k,j-1),    &
6573                    field(i,k,j),field(i,k,j+1),vel )
6574               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6575
6576             ENDDO
6577             ENDDO
6578
6579       ENDIF
6580
6581    ENDDO j_loop_y_flux_5
6582
6583 !  next, x flux
6584
6585 !--  these bounds are for periodic and sym conditions
6586
6587       i_start = its-1
6588       i_end   = MIN(ite,ide-1)+1
6589       i_start_f = i_start
6590       i_end_f   = i_end+1
6591
6592       j_start = jts-1
6593       j_end   = MIN(jte,jde-1)+1
6594
6595 !--  modify loop bounds for open and specified b.c
6596
6597       IF(degrade_ys) j_start = jts
6598       IF(degrade_ye) j_end   = MIN(jte,jde-1)
6599
6600       IF(degrade_xs) then
6601         i_start = MAX(ids+1,its)
6602         i_start_f = i_start+2
6603       ENDIF
6604
6605       IF(degrade_xe) then
6606         i_end = MIN(ide-2,ite)
6607         i_end_f = ide-3
6608       ENDIF
6609
6610 !  compute fluxes
6611
6612       DO j = j_start, j_end
6613
6614 !  5th order flux
6615
6616         DO k=kts,ktf
6617         DO i = i_start_f, i_end_f
6618
6619           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6620           mu = 0.5*(mut(i,j)+mut(i-1,j))
6621           vel = ru(i,k,j)
6622           cr = vel*dt/dx/mu
6623           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6624
6625           fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
6626                                          field(i-1,k,j), field(i  ,k,j),  &
6627                                          field(i+1,k,j), field(i+2,k,j),  &
6628                                          vel                             )
6629           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6630
6631         ENDDO
6632         ENDDO
6633
6634 !  lower order fluxes close to boundaries (if not periodic or symmetric)
6635
6636         IF( degrade_xs ) THEN
6637
6638           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
6639             i = ids+1
6640             DO k=kts,ktf
6641
6642               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6643               mu = 0.5*(mut(i,j)+mut(i-1,j))
6644               vel = ru(i,k,j)/mu
6645               cr = vel*dt/dx
6646               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6647
6648               fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6649                      *(field(i,k,j)+field(i-1,k,j))
6650
6651               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6652
6653             ENDDO
6654           ENDIF
6655
6656           i = ids+2
6657           DO k=kts,ktf
6658             dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6659             mu = 0.5*(mut(i,j)+mut(i-1,j))
6660             vel = ru(i,k,j)
6661             cr = vel*dt/dx/mu
6662             fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6663             fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
6664                                           field(i  ,k,j), field(i+1,k,j),  &
6665                                           vel                     )
6666             fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6667
6668           ENDDO
6669
6670         ENDIF
6671
6672         IF( degrade_xe ) THEN
6673
6674           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
6675             i = ide-1
6676             DO k=kts,ktf
6677               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6678               mu = 0.5*(mut(i,j)+mut(i-1,j))
6679               vel = ru(i,k,j)
6680               cr = vel*dt/dx/mu
6681               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6682               fqx(i,k,j) = 0.5*(ru(i,k,j))      &
6683                      *(field(i,k,j)+field(i-1,k,j))
6684               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6685
6686             ENDDO
6687           ENDIF
6688
6689           i = ide-2
6690           DO k=kts,ktf
6691
6692             dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6693             mu = 0.5*(mut(i,j)+mut(i-1,j))
6694             vel = ru(i,k,j)
6695             cr = vel*dt/dx/mu
6696             fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6697             fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
6698                                           field(i  ,k,j), field(i+1,k,j),  &
6699                                           vel                             )
6700             fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6701
6702           ENDDO
6703
6704         ENDIF
6705
6706       ENDDO  ! enddo for outer J loop
6707
6708 !--- end of 5th order horizontal flux calculation
6709
6710     ELSE IF( horz_order == 4 ) THEN
6711
6712    IF( config_flags%periodic_x   .or. &
6713        config_flags%symmetric_xs .or. &
6714        (its > ids+1)                ) degrade_xs = .false.
6715    IF( config_flags%periodic_x   .or. &
6716        config_flags%symmetric_xe .or. &
6717        (ite < ide-2)                ) degrade_xe = .false.
6718    IF( config_flags%periodic_y   .or. &
6719        config_flags%symmetric_ys .or. &
6720        (jts > jds+1)                ) degrade_ys = .false.
6721    IF( config_flags%periodic_y   .or. &
6722        config_flags%symmetric_ye .or. &
6723        (jte < jde-2)                ) degrade_ye = .false.
6724
6725 !--------------- y - advection first
6726
6727 !--  y flux compute; these bounds are for periodic and sym b.c.
6728
6729       ktf=MIN(kte,kde-1)
6730       i_start = its-1
6731       i_end   = MIN(ite,ide-1)+1
6732       j_start = jts-1
6733       j_end   = MIN(jte,jde-1)+1
6734       j_start_f = j_start
6735       j_end_f   = j_end+1
6736
6737 !--  modify loop bounds if open or specified
6738
6739       IF(degrade_xs) i_start = its
6740       IF(degrade_xe) i_end   = MIN(ite,ide-1)
6741
6742       IF(degrade_ys) then
6743         j_start = MAX(jts,jds+1)
6744         j_start_f = jds+2
6745       ENDIF
6746
6747       IF(degrade_ye) then
6748         j_end = MIN(jte,jde-2)
6749         j_end_f = jde-2
6750       ENDIF
6751
6752 !  compute fluxes, 4th order
6753
6754       j_loop_y_flux_4 : DO j = j_start, j_end+1
6755
6756       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6757
6758         DO k=kts,ktf
6759         DO i = i_start, i_end
6760
6761           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6762           mu = 0.5*(mut(i,j)+mut(i,j-1))
6763           vel = rv(i,k,j)
6764           cr = vel*dt/dy/mu
6765           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6766
6767           fqy( i, k, j  ) = vel*flux4(  field(i,k,j-2), field(i,k,j-1),       &
6768                                         field(i,k,j  ), field(i,k,j+1), vel )
6769
6770           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6771
6772         ENDDO
6773         ENDDO
6774
6775       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
6776
6777             DO k=kts,ktf
6778             DO i = i_start, i_end
6779
6780               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6781               mu = 0.5*(mut(i,j)+mut(i,j-1))
6782               vel = rv(i,k,j)
6783               cr = vel*dt/dy/mu
6784               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6785
6786               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
6787                      (field(i,k,j)+field(i,k,j-1))
6788
6789               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6790
6791             ENDDO
6792             ENDDO
6793
6794       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
6795
6796             DO k=kts,ktf
6797             DO i = i_start, i_end
6798
6799               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6800               mu = 0.5*(mut(i,j)+mut(i,j-1))
6801               vel = rv(i,k,j)
6802               cr = vel*dt/dy/mu
6803               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6804
6805               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
6806                      (field(i,k,j)+field(i,k,j-1))
6807               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6808
6809             ENDDO
6810             ENDDO
6811
6812       ENDIF
6813
6814    ENDDO j_loop_y_flux_4
6815
6816 !  next, x flux
6817
6818 !--  these bounds are for periodic and sym conditions
6819
6820       i_start = its-1
6821       i_end   = MIN(ite,ide-1)+1
6822       i_start_f = i_start
6823       i_end_f   = i_end+1
6824
6825       j_start = jts-1
6826       j_end   = MIN(jte,jde-1)+1
6827
6828 !--  modify loop bounds for open and specified b.c
6829
6830       IF(degrade_ys) j_start = jts
6831       IF(degrade_ye) j_end   = MIN(jte,jde-1)
6832
6833       IF(degrade_xs) then
6834         i_start = MAX(ids+1,its)
6835         i_start_f = i_start+1
6836       ENDIF
6837
6838       IF(degrade_xe) then
6839         i_end = MIN(ide-2,ite)
6840         i_end_f = ide-2
6841       ENDIF
6842
6843 !  compute fluxes
6844
6845       DO j = j_start, j_end
6846
6847 !  4th order flux
6848
6849         DO k=kts,ktf
6850         DO i = i_start_f, i_end_f
6851
6852           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6853           mu = 0.5*(mut(i,j)+mut(i-1,j))
6854           vel = ru(i,k,j)
6855           cr = vel*dt/dx/mu
6856           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6857
6858           fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), &
6859                                     field(i  ,k,j), field(i+1,k,j), vel )
6860           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6861
6862         ENDDO
6863         ENDDO
6864
6865 !  lower order fluxes close to boundaries (if not periodic or symmetric)
6866
6867         IF( degrade_xs ) THEN
6868           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
6869             i = ids+1
6870             DO k=kts,ktf
6871
6872               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6873               mu = 0.5*(mut(i,j)+mut(i-1,j))
6874               vel = ru(i,k,j)/mu
6875               cr = vel*dt/dx
6876               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6877
6878               fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6879                      *(field(i,k,j)+field(i-1,k,j))
6880
6881               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6882
6883             ENDDO
6884           ENDIF
6885         ENDIF
6886
6887         IF( degrade_xe ) THEN
6888           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
6889             i = ide-1
6890             DO k=kts,ktf
6891               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6892               mu = 0.5*(mut(i,j)+mut(i-1,j))
6893               vel = ru(i,k,j)
6894               cr = vel*dt/dx/mu
6895               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6896               fqx(i,k,j) = 0.5*(ru(i,k,j))      &
6897                      *(field(i,k,j)+field(i-1,k,j))
6898               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6899
6900             ENDDO
6901           ENDIF
6902         ENDIF
6903
6904       ENDDO  ! enddo for outer J loop
6905
6906 !--- end of 4th order horizontal flux calculation
6907
6908    ELSE IF( horz_order == 3 ) THEN
6909
6910    IF( config_flags%periodic_x   .or. &
6911        config_flags%symmetric_xs .or. &
6912        (its > ids+1)                ) degrade_xs = .false.
6913    IF( config_flags%periodic_x   .or. &
6914        config_flags%symmetric_xe .or. &
6915        (ite < ide-2)                ) degrade_xe = .false.
6916    IF( config_flags%periodic_y   .or. &
6917        config_flags%symmetric_ys .or. &
6918        (jts > jds+1)                ) degrade_ys = .false.
6919    IF( config_flags%periodic_y   .or. &
6920        config_flags%symmetric_ye .or. &
6921        (jte < jde-2)                ) degrade_ye = .false.
6922
6923 !--------------- y - advection first
6924
6925 !--  y flux compute; these bounds are for periodic and sym b.c.
6926
6927       ktf=MIN(kte,kde-1)
6928       i_start = its-1
6929       i_end   = MIN(ite,ide-1)+1
6930       j_start = jts-1
6931       j_end   = MIN(jte,jde-1)+1
6932       j_start_f = j_start
6933       j_end_f   = j_end+1
6934
6935 !--  modify loop bounds if open or specified
6936
6937       IF(degrade_xs) i_start = its
6938       IF(degrade_xe) i_end   = MIN(ite,ide-1)
6939
6940       IF(degrade_ys) then
6941         j_start = MAX(jts,jds+1)
6942         j_start_f = jds+2
6943       ENDIF
6944
6945       IF(degrade_ye) then
6946         j_end = MIN(jte,jde-2)
6947         j_end_f = jde-2
6948       ENDIF
6949
6950 !  compute fluxes, 3rd order
6951
6952       j_loop_y_flux_3 : DO j = j_start, j_end+1
6953
6954       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6955
6956         DO k=kts,ktf
6957         DO i = i_start, i_end
6958
6959           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6960           mu = 0.5*(mut(i,j)+mut(i,j-1))
6961           vel = rv(i,k,j)
6962           cr = vel*dt/dy/mu
6963           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6964
6965           fqy( i, k, j  ) = vel*flux3(  field(i,k,j-2), field(i,k,j-1),       &
6966                                         field(i,k,j  ), field(i,k,j+1), vel )
6967
6968           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6969
6970         ENDDO
6971         ENDDO
6972
6973       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
6974
6975             DO k=kts,ktf
6976             DO i = i_start, i_end
6977
6978               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6979               mu = 0.5*(mut(i,j)+mut(i,j-1))
6980               vel = rv(i,k,j)
6981               cr = vel*dt/dy/mu
6982               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6983
6984               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
6985                      (field(i,k,j)+field(i,k,j-1))
6986
6987               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6988
6989             ENDDO
6990             ENDDO
6991
6992       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
6993
6994             DO k=kts,ktf
6995             DO i = i_start, i_end
6996
6997               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6998               mu = 0.5*(mut(i,j)+mut(i,j-1))
6999               vel = rv(i,k,j)
7000               cr = vel*dt/dy/mu
7001               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
7002
7003               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
7004                      (field(i,k,j)+field(i,k,j-1))
7005               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7006
7007             ENDDO
7008             ENDDO
7009
7010       ENDIF
7011
7012    ENDDO j_loop_y_flux_3
7013
7014 !  next, x flux
7015
7016 !--  these bounds are for periodic and sym conditions
7017
7018       i_start = its-1
7019       i_end   = MIN(ite,ide-1)+1
7020       i_start_f = i_start
7021       i_end_f   = i_end+1
7022
7023       j_start = jts-1
7024       j_end   = MIN(jte,jde-1)+1
7025
7026 !--  modify loop bounds for open and specified b.c
7027
7028       IF(degrade_ys) j_start = jts
7029       IF(degrade_ye) j_end   = MIN(jte,jde-1)
7030
7031       IF(degrade_xs) then
7032         i_start = MAX(ids+1,its)
7033         i_start_f = i_start+1
7034       ENDIF
7035
7036       IF(degrade_xe) then
7037         i_end = MIN(ide-2,ite)
7038         i_end_f = ide-2
7039       ENDIF
7040
7041 !  compute fluxes
7042
7043       DO j = j_start, j_end
7044
7045 !  4th order flux
7046
7047         DO k=kts,ktf
7048         DO i = i_start_f, i_end_f
7049
7050           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
7051           mu = 0.5*(mut(i,j)+mut(i-1,j))
7052           vel = ru(i,k,j)
7053           cr = vel*dt/dx/mu
7054           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
7055
7056           fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), &
7057                                     field(i  ,k,j), field(i+1,k,j), vel )
7058           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7059
7060         ENDDO
7061         ENDDO
7062
7063 !  lower order fluxes close to boundaries (if not periodic or symmetric)
7064
7065         IF( degrade_xs ) THEN
7066
7067           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
7068             i = ids+1
7069             DO k=kts,ktf
7070
7071               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
7072               mu = 0.5*(mut(i,j)+mut(i-1,j))
7073               vel = ru(i,k,j)/mu
7074               cr = vel*dt/dx
7075               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
7076
7077               fqx(i,k,j) = 0.5*(ru(i,k,j)) &
7078                      *(field(i,k,j)+field(i-1,k,j))
7079
7080               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7081
7082             ENDDO
7083           ENDIF
7084         ENDIF
7085
7086         IF( degrade_xe ) THEN
7087           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
7088             i = ide-1
7089             DO k=kts,ktf
7090               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
7091               mu = 0.5*(mut(i,j)+mut(i-1,j))
7092               vel = ru(i,k,j)
7093               cr = vel*dt/dx/mu
7094               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
7095               fqx(i,k,j) = 0.5*(ru(i,k,j))      &
7096                      *(field(i,k,j)+field(i-1,k,j))
7097               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7098
7099             ENDDO
7100           ENDIF
7101         ENDIF
7102
7103       ENDDO  ! enddo for outer J loop
7104
7105 !--- end of 3rd order horizontal flux calculation
7106
7107
7108    ELSE IF( horz_order == 2 ) THEN
7109
7110    IF( config_flags%periodic_x   .or. &
7111        config_flags%symmetric_xs .or. &
7112        (its > ids)                ) degrade_xs = .false.
7113    IF( config_flags%periodic_x   .or. &
7114        config_flags%symmetric_xe .or. &
7115        (ite < ide-1)                ) degrade_xe = .false.
7116    IF( config_flags%periodic_y   .or. &
7117        config_flags%symmetric_ys .or. &
7118        (jts > jds)                ) degrade_ys = .false.
7119    IF( config_flags%periodic_y   .or. &
7120        config_flags%symmetric_ye .or. &
7121        (jte < jde-1)                ) degrade_ye = .false.
7122
7123 !--  y flux compute; these bounds are for periodic and sym b.c.
7124
7125       ktf=MIN(kte,kde-1)
7126       i_start = its-1
7127       i_end   = MIN(ite,ide-1)+1
7128       j_start = jts-1
7129       j_end   = MIN(jte,jde-1)+1
7130
7131 !--  modify loop bounds if open or specified
7132
7133       IF(degrade_xs) i_start = its
7134       IF(degrade_xe) i_end   = MIN(ite,ide-1)
7135       IF(degrade_ys) j_start = MAX(jts,jds+1)
7136       IF(degrade_ye) j_end = MIN(jte,jde-2)
7137
7138 !  compute fluxes, 2nd order, y flux
7139
7140       DO j = j_start, j_end+1
7141         DO k=kts,ktf
7142         DO i = i_start, i_end
7143            dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
7144            mu = 0.5*(mut(i,j)+mut(i,j-1))
7145            vel = rv(i,k,j)
7146            cr = vel*dt/dy/mu
7147            fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
7148
7149            fqy(i,k, j) = 0.5*rv(i,k,j)*          &
7150                   (field(i,k,j)+field(i,k,j-1))
7151
7152            fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7153         ENDDO
7154         ENDDO
7155       ENDDO
7156
7157 !  next, x flux
7158
7159       DO j = j_start, j_end
7160         DO k=kts,ktf
7161         DO i = i_start, i_end+1
7162             dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
7163             mu = 0.5*(mut(i,j)+mut(i-1,j))
7164             vel = ru(i,k,j)
7165             cr = vel*dt/dx/mu
7166             fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
7167             fqx( i,k,j ) = 0.5*ru(i,k,j)*          &
7168                   (field(i,k,j)+field(i-1,k,j))
7169
7170             fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7171         ENDDO
7172         ENDDO
7173       ENDDO
7174
7175 !--- end of 2nd order horizontal flux calculation
7176
7177    ELSE
7178
7179       WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order
7180       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
7181
7182    ENDIF horizontal_order_test
7183
7184 !  pick up the rest of the horizontal radiation boundary conditions.
7185 !  (these are the computations that don't require 'cb'.
7186 !  first, set to index ranges
7187
7188       i_start = its
7189       i_end   = MIN(ite,ide-1)
7190       j_start = jts
7191       j_end   = MIN(jte,jde-1)
7192
7193 !  compute x (u) conditions for v, w, or scalar
7194
7195    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
7196
7197        DO j = j_start, j_end
7198        DO k = kts, ktf
7199          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
7200          tendency(its,k,j) = tendency(its,k,j)                     &
7201                - rdx*(                                             &
7202                        ub*(   field_old(its+1,k,j)                 &
7203                             - field_old(its  ,k,j)   ) +           &
7204                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
7205                                                                 )
7206        ENDDO
7207        ENDDO
7208
7209    ENDIF
7210
7211    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
7212
7213        DO j = j_start, j_end
7214        DO k = kts, ktf
7215          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
7216          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
7217                - rdx*(                                               &
7218                        ub*(  field_old(i_end  ,k,j)                  &
7219                            - field_old(i_end-1,k,j) ) +              &
7220                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
7221                                                                     )
7222        ENDDO
7223        ENDDO
7224
7225    ENDIF
7226
7227    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
7228
7229        DO i = i_start, i_end
7230        DO k = kts, ktf
7231          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
7232          tendency(i,k,jts) = tendency(i,k,jts)                     &
7233                - rdy*(                                             &
7234                        vb*(  field_old(i,k,jts+1)                  &
7235                            - field_old(i,k,jts  ) ) +              &
7236                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
7237                                                                 )
7238        ENDDO
7239        ENDDO
7240
7241    ENDIF
7242
7243    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
7244
7245        DO i = i_start, i_end
7246        DO k = kts, ktf
7247          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
7248          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
7249                - rdy*(                                               &
7250                        vb*(   field_old(i,k,j_end  )                 &
7251                             - field_old(i,k,j_end-1) ) +             &
7252                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
7253                                                                     )
7254        ENDDO
7255        ENDDO
7256
7257    ENDIF
7258
7259    IF( (config_flags%polar) .and. (jts == jds) ) THEN
7260
7261        ! Assuming rv(i,k,jds) = 0.
7262        DO i = i_start, i_end
7263        DO k = kts, ktf
7264          vb = MIN( 0.5*rv(i,k,jts+1), 0. )
7265          tendency(i,k,jts) = tendency(i,k,jts)                     &
7266                - rdy*(                                             &
7267                        vb*(  field_old(i,k,jts+1)                  &
7268                            - field_old(i,k,jts  ) ) +              &
7269                        field(i,k,jts)*rv(i,k,jts+1)                &
7270                                                                 )
7271        ENDDO
7272        ENDDO
7273
7274    ENDIF
7275
7276    IF( (config_flags%polar) .and. (jte == jde)) THEN
7277
7278        ! Assuming rv(i,k,jde) = 0.
7279        DO i = i_start, i_end
7280        DO k = kts, ktf
7281          vb = MAX( 0.5*rv(i,k,jte-1), 0. )
7282          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
7283                - rdy*(                                               &
7284                        vb*(   field_old(i,k,j_end  )                 &
7285                             - field_old(i,k,j_end-1) ) +             &
7286                        field(i,k,j_end)*(-rv(i,k,jte-1))             &
7287                                                                     )
7288        ENDDO
7289        ENDDO
7290
7291    ENDIF
7292
7293 !-------------------- vertical advection
7294
7295 !-- loop bounds for periodic or sym conditions
7296
7297       i_start = its-1
7298       i_end   = MIN(ite,ide-1)+1
7299       j_start = jts-1
7300       j_end   = MIN(jte,jde-1)+1
7301
7302 !-- loop bounds for open or specified conditions
7303
7304     IF(degrade_xs) i_start = its
7305     IF(degrade_xe) i_end   = MIN(ite,ide-1)
7306     IF(degrade_ys) j_start = jts
7307     IF(degrade_ye) j_end   = MIN(jte,jde-1)
7308
7309     vert_order_test : IF (vert_order == 6) THEN
7310
7311       DO j = j_start, j_end
7312
7313          DO i = i_start, i_end
7314            fqz(i,1,j)  = 0.
7315            fqzl(i,1,j) = 0.
7316            fqz(i,kde,j)  = 0.
7317            fqzl(i,kde,j) = 0.
7318          ENDDO
7319
7320          DO k=kts+3,ktf-2
7321          DO i = i_start, i_end
7322            dz = 2./(rdzw(k)+rdzw(k-1))
7323            mu = 0.5*(mut(i,j)+mut(i,j))
7324            vel = rom(i,k,j)
7325            cr = vel*dt/dz/mu
7326            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7327
7328            fqz(i,k,j) = vel*flux6( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
7329                                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
7330            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7331          ENDDO
7332          ENDDO
7333
7334          DO i = i_start, i_end
7335
7336            k=kts+1
7337            dz = 2./(rdzw(k)+rdzw(k-1))
7338            mu = 0.5*(mut(i,j)+mut(i,j))
7339            vel = rom(i,k,j)
7340            cr = vel*dt/dz/mu
7341            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7342            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7343            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7344
7345            k=kts+2
7346            dz = 2./(rdzw(k)+rdzw(k-1))
7347            mu = 0.5*(mut(i,j)+mut(i,j))
7348            vel = rom(i,k,j)
7349            cr = vel*dt/dz/mu
7350            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7351
7352            fqz(i,k,j) = vel*flux4(                      &
7353                    field(i,k-2,j), field(i,k-1,j),      &
7354                    field(i,k  ,j), field(i,k+1,j),  -vel )
7355            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7356
7357            k=ktf-1
7358            dz = 2./(rdzw(k)+rdzw(k-1))
7359            mu = 0.5*(mut(i,j)+mut(i,j))
7360            vel = rom(i,k,j)
7361            cr = vel*dt/dz/mu
7362            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7363
7364            fqz(i,k,j) = vel*flux4(                      &
7365                    field(i,k-2,j), field(i,k-1,j),      &
7366                    field(i,k  ,j), field(i,k+1,j),  -vel )
7367            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7368
7369            k=ktf
7370            dz = 2./(rdzw(k)+rdzw(k-1))
7371            mu = 0.5*(mut(i,j)+mut(i,j))
7372            vel = rom(i,k,j)
7373            cr = vel*dt/dz/mu
7374            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7375            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7376            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7377
7378          ENDDO
7379
7380       ENDDO
7381
7382     ELSE IF (vert_order == 5) THEN
7383
7384       DO j = j_start, j_end
7385
7386          DO i = i_start, i_end
7387            fqz(i,1,j)  = 0.
7388            fqzl(i,1,j) = 0.
7389            fqz(i,kde,j)  = 0.
7390            fqzl(i,kde,j) = 0.
7391          ENDDO
7392
7393          DO k=kts+3,ktf-2
7394          DO i = i_start, i_end
7395            dz = 2./(rdzw(k)+rdzw(k-1))
7396            mu = 0.5*(mut(i,j)+mut(i,j))
7397            vel = rom(i,k,j)
7398            cr = vel*dt/dz/mu
7399            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7400
7401            fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
7402                                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
7403            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7404          ENDDO
7405          ENDDO
7406
7407          DO i = i_start, i_end
7408
7409            k=kts+1
7410            dz = 2./(rdzw(k)+rdzw(k-1))
7411            mu = 0.5*(mut(i,j)+mut(i,j))
7412            vel = rom(i,k,j)
7413            cr = vel*dt/dz/mu
7414            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7415            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7416            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7417
7418            k=kts+2
7419            dz = 2./(rdzw(k)+rdzw(k-1))
7420            mu = 0.5*(mut(i,j)+mut(i,j))
7421            vel = rom(i,k,j)
7422            cr = vel*dt/dz/mu
7423            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7424
7425            fqz(i,k,j) = vel*flux3(                      &
7426                    field(i,k-2,j), field(i,k-1,j),      &
7427                    field(i,k  ,j), field(i,k+1,j),  -vel )
7428            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7429
7430            k=ktf-1
7431            dz = 2./(rdzw(k)+rdzw(k-1))
7432            mu = 0.5*(mut(i,j)+mut(i,j))
7433            vel = rom(i,k,j)
7434            cr = vel*dt/dz/mu
7435            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7436
7437            fqz(i,k,j) = vel*flux3(                      &
7438                    field(i,k-2,j), field(i,k-1,j),      &
7439                    field(i,k  ,j), field(i,k+1,j),  -vel )
7440            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7441
7442            k=ktf
7443            dz = 2./(rdzw(k)+rdzw(k-1))
7444            mu = 0.5*(mut(i,j)+mut(i,j))
7445            vel = rom(i,k,j)
7446            cr = vel*dt/dz/mu
7447            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7448            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7449            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7450
7451          ENDDO
7452
7453       ENDDO
7454
7455     ELSE IF (vert_order == 4) THEN
7456
7457       DO j = j_start, j_end
7458
7459          DO i = i_start, i_end
7460            fqz(i,1,j)  = 0.
7461            fqzl(i,1,j) = 0.
7462            fqz(i,kde,j)  = 0.
7463            fqzl(i,kde,j) = 0.
7464          ENDDO
7465
7466          DO k=kts+2,ktf-1
7467          DO i = i_start, i_end
7468
7469            dz = 2./(rdzw(k)+rdzw(k-1))
7470            mu = 0.5*(mut(i,j)+mut(i,j))
7471            vel = rom(i,k,j)
7472            cr = vel*dt/dz/mu
7473            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7474
7475            fqz(i,k,j) = vel*flux4(                      &
7476                    field(i,k-2,j), field(i,k-1,j),      &
7477                    field(i,k  ,j), field(i,k+1,j),  -vel )
7478            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7479          ENDDO
7480          ENDDO
7481
7482          DO i = i_start, i_end
7483
7484            k=kts+1
7485            dz = 2./(rdzw(k)+rdzw(k-1))
7486            mu = 0.5*(mut(i,j)+mut(i,j))
7487            vel = rom(i,k,j)
7488            cr = vel*dt/dz/mu
7489            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7490            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7491            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7492
7493            k=ktf
7494            dz = 2./(rdzw(k)+rdzw(k-1))
7495            mu = 0.5*(mut(i,j)+mut(i,j))
7496            vel = rom(i,k,j)
7497            cr = vel*dt/dz/mu
7498            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7499            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7500            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7501
7502          ENDDO
7503
7504       ENDDO
7505
7506     ELSE IF (vert_order == 3) THEN
7507
7508       DO j = j_start, j_end
7509
7510          DO i = i_start, i_end
7511            fqz(i,1,j)  = 0.
7512            fqzl(i,1,j) = 0.
7513            fqz(i,kde,j)  = 0.
7514            fqzl(i,kde,j) = 0.
7515          ENDDO
7516
7517          DO k=kts+2,ktf-1
7518          DO i = i_start, i_end
7519
7520            dz = 2./(rdzw(k)+rdzw(k-1))
7521            mu = 0.5*(mut(i,j)+mut(i,j))
7522            vel = rom(i,k,j)
7523            cr = vel*dt/dz/mu
7524            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7525
7526            fqz(i,k,j) = vel*flux3(                      &
7527                    field(i,k-2,j), field(i,k-1,j),      &
7528                    field(i,k  ,j), field(i,k+1,j),  -vel )
7529            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7530          ENDDO
7531          ENDDO
7532
7533          DO i = i_start, i_end
7534
7535            k=kts+1
7536            dz = 2./(rdzw(k)+rdzw(k-1))
7537            mu = 0.5*(mut(i,j)+mut(i,j))
7538            vel = rom(i,k,j)
7539            cr = vel*dt/dz/mu
7540            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7541            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7542            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7543
7544            k=ktf
7545            dz = 2./(rdzw(k)+rdzw(k-1))
7546            mu = 0.5*(mut(i,j)+mut(i,j))
7547            vel = rom(i,k,j)
7548            cr = vel*dt/dz/mu
7549            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7550            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7551            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7552
7553          ENDDO
7554
7555       ENDDO
7556
7557    ELSE IF (vert_order == 2) THEN
7558
7559       DO j = j_start, j_end
7560
7561          DO i = i_start, i_end
7562            fqz(i,1,j)  = 0.
7563            fqzl(i,1,j) = 0.
7564            fqz(i,kde,j)  = 0.
7565            fqzl(i,kde,j) = 0.
7566          ENDDO
7567
7568          DO k=kts+1,ktf
7569          DO i = i_start, i_end
7570
7571            dz = 2./(rdzw(k)+rdzw(k-1))
7572            mu = 0.5*(mut(i,j)+mut(i,j))
7573            vel = rom(i,k,j)
7574            cr = vel*dt/dz/mu
7575            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7576            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7577            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7578
7579         ENDDO
7580         ENDDO
7581
7582       ENDDO
7583
7584    ELSE
7585
7586       WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order
7587       CALL wrf_error_fatal ( wrf_err_message )
7588
7589    ENDIF vert_order_test
7590
7591    IF (pd_limit) THEN
7592
7593 ! positive definite filter
7594
7595    i_start = its-1
7596    i_end   = MIN(ite,ide-1)+1
7597    j_start = jts-1
7598    j_end   = MIN(jte,jde-1)+1
7599
7600 !-- loop bounds for open or specified conditions
7601
7602    IF(degrade_xs) i_start = its
7603    IF(degrade_xe) i_end   = MIN(ite,ide-1)
7604    IF(degrade_ys) j_start = jts
7605    IF(degrade_ye) j_end   = MIN(jte,jde-1)
7606
7607    IF(config_flags%specified .or. config_flags%nested) THEN
7608      IF (degrade_xs) i_start = MAX(its,ids+1)
7609      IF (degrade_xe) i_end   = MIN(ite,ide-2)
7610      IF (degrade_ys) j_start = MAX(jts,jds+1)
7611      IF (degrade_ye) j_end   = MIN(jte,jde-2)
7612    END IF
7613
7614    IF(config_flags%open_xs) THEN
7615      IF (degrade_xs) i_start = MAX(its,ids+1)
7616    END IF
7617    IF(config_flags%open_xe) THEN
7618      IF (degrade_xe) i_end   = MIN(ite,ide-2)
7619    END IF
7620    IF(config_flags%open_ys) THEN
7621      IF (degrade_ys) j_start = MAX(jts,jds+1)
7622    END IF
7623    IF(config_flags%open_ye) THEN
7624      IF (degrade_ye) j_end   = MIN(jte,jde-2)
7625    END IF
7626    ! ADT note:
7627    ! We don't want to change j_start and j_end
7628    ! for polar BC's since we want to calculate
7629    ! fluxes for directions other than y at the
7630    ! edge
7631
7632 !-- here is the limiter...
7633
7634    DO j=j_start, j_end
7635    DO k=kts, ktf
7636    DO i=i_start, i_end
7637
7638      ph_low = (mub(i,j)+mu_old(i,j))*field_old(i,k,j)        &
7639                 - dt*( msftx(i,j)*msfty(i,j)*(               &
7640                        rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
7641                        rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
7642                       +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
7643
7644      flux_out = dt*( (msftx(i,j)*msfty(i,j))*(                    &
7645                                 rdx*(  max(0.,fqx (i+1,k,j))      &
7646                                       -min(0.,fqx (i  ,k,j)) )    &
7647                                +rdy*(  max(0.,fqy (i,k,j+1))      &
7648                                       -min(0.,fqy (i,k,j  )) ) )  &
7649                 +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
7650                                       -max(0.,fqz (i,k  ,j)) )   )
7651
7652      IF( flux_out .gt. ph_low ) THEN
7653
7654        scale = max(0.,ph_low/(flux_out+eps))
7655        IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j)
7656        IF( fqx (i  ,k,j) .lt. 0.) fqx(i  ,k,j) = scale*fqx(i  ,k,j)
7657        IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1)
7658        IF( fqy (i,k,j  ) .lt. 0.) fqy(i,k,j  ) = scale*fqy(i,k,j  )
7659 !  note: z flux is opposite sign in mass coordinate because
7660 !  vertical coordinate decreases with increasing k
7661        IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j)
7662        IF( fqz (i,k  ,j) .gt. 0.) fqz(i,k  ,j) = scale*fqz(i,k  ,j)
7663
7664      END IF
7665
7666    ENDDO
7667    ENDDO
7668    ENDDO
7669
7670    END IF
7671
7672 ! add in the pd-limited flux divergence
7673
7674   i_start = its
7675   i_end   = MIN(ite,ide-1)
7676   j_start = jts
7677   j_end   = MIN(jte,jde-1)
7678
7679   DO j = j_start, j_end
7680   DO k = kts, ktf
7681   DO i = i_start, i_end
7682
7683      tendency (i,k,j) = tendency(i,k,j)                           &
7684                             -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
7685                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
7686
7687   ENDDO
7688   ENDDO
7689   ENDDO
7690
7691 ! x flux divergence
7692 !
7693   IF(degrade_xs) i_start = i_start + 1
7694   IF(degrade_xe) i_end   = i_end   - 1
7695
7696   DO j = j_start, j_end
7697   DO k = kts, ktf
7698   DO i = i_start, i_end
7699
7700      ! Un-"canceled" map scale factor, ADT Eq. 48
7701      tendency (i,k,j) = tendency(i,k,j)                           &
7702                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
7703                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
7704
7705   ENDDO
7706   ENDDO
7707   ENDDO
7708
7709 ! y flux divergence
7710 !
7711   i_start = its
7712   i_end   = MIN(ite,ide-1)
7713   IF(degrade_ys) j_start = j_start + 1
7714   IF(degrade_ye) j_end   = j_end   - 1
7715
7716   DO j = j_start, j_end
7717   DO k = kts, ktf
7718   DO i = i_start, i_end
7719
7720      ! Un-"canceled" map scale factor, ADT Eq. 48
7721      ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
7722      tendency (i,k,j) = tendency(i,k,j)                           &
7723                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
7724                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
7725
7726   ENDDO
7727   ENDDO
7728   ENDDO
7729
7730 END SUBROUTINE advect_scalar_pd
7731
7732 !----------------------------------------------------------------
7733
7734 END MODULE module_advect_em
7735