dyn_em/module_advect_em.F

   1
   2 !WRF:MODEL_LAYER:DYNAMICS
   3 !
   4 #if ( defined(ADVECT_KERNEL) )
   5 ! cpp -traditional-cpp -P -DADVECT_KERNEL module_advect_em.F > advection_kernel.f90
   6 ! gfortran -ffree-form -ffree-line-length-none advection_kernel.f90
   7 ! ./a.out
   8 MODULE advection_kernel
   9    TYPE grid_config_rec_type
  10       INTEGER :: scalar_adv_opt = 0
  11       INTEGER :: h_sca_adv_order = 5
  12       INTEGER :: v_sca_adv_order = 3
  13       LOGICAL :: periodic_x = .false.
  14       LOGICAL :: periodic_y = .false.
  15       LOGICAL :: symmetric_xs = .false.
  16       LOGICAL :: symmetric_xe = .false.
  17       LOGICAL :: symmetric_ys = .false.
  18       LOGICAL :: symmetric_ye = .false.
  19       LOGICAL :: open_xs = .false.
  20       LOGICAL :: open_xe = .false.
  21       LOGICAL :: open_ys = .false.
  22       LOGICAL :: open_ye = .false.
  23       LOGICAL :: specified = .true.
  24       LOGICAL :: nested = .false.
  25       LOGICAL :: polar = .false.
  26    END TYPE grid_config_rec_type
  27    CHARACTER (LEN=256) :: wrf_err_message
  28 CONTAINS
  29 !----------------------------------------------------------------
  30 SUBROUTINE wrf_error_fatal ( message )
  31    IMPLICIT NONE
  32    CHARACTER(LEN=*) , INTENT(IN) :: message
  33    PRINT *,'advect_scalar_pd: FATAL MESSAGE = ',TRIM(message)
  34    STOP 12345
  35 END SUBROUTINE wrf_error_fatal
  36 !----------------------------------------------------------------
  37 SUBROUTINE init ( config_flags )
  38    IMPLICIT NONE
  39    TYPE (grid_config_rec_type) :: config_flags
  40    config_flags%h_sca_adv_order = 5
  41    config_flags%v_sca_adv_order = 3
  42    config_flags%periodic_x = .true.
  43    config_flags%periodic_y = .true.
  44    config_flags%symmetric_xs = .false.
  45    config_flags%symmetric_xe = .false.
  46    config_flags%symmetric_ys = .false.
  47    config_flags%symmetric_ye = .false.
  48    config_flags%open_xs = .false.
  49    config_flags%open_xe = .false.
  50    config_flags%open_ys = .false.
  51    config_flags%open_ye = .false.
  52    config_flags%specified = .false.
  53    config_flags%nested = .false.
  54 END SUBROUTINE init
  55 !----------------------------------------------------------------
  56 SUBROUTINE tophat ( field, num_scalars , &
  57                                 ids, ide, jds, jde, kds, kde, &
  58                                 ims, ime, jms, jme, kms, kme, &
  59                                 its, ite, jts, jte, kts, kte )
  60    IMPLICIT NONE
  61    INTEGER , INTENT(IN ) :: num_scalars ,     ids, ide, jds, jde, kds, kde, &
  62                                               ims, ime, jms, jme, kms, kme, &
  63                                               its, ite, jts, jte, kts, kte
  64    REAL , DIMENSION( ims:ime , kms:kme , jms:jme , num_scalars ) , INTENT(OUT) :: field
  65    INTEGER :: i, j, k , n
  66
  67    field = 0
  68
  69    DO n = 1 , num_scalars
  70    DO j = jts , jte
  71    DO k = kts , kte
  72    DO i = its , ite
  73       IF ( i .gt. 35 .and. i.lt. 55 ) THEN
  74          field (i,k,j,n) = 1.
  75       END IF
  76    END DO
  77    END DO
  78    END DO
  79    END DO
  80 END SUBROUTINE tophat
  81 !----------------------------------------------------------------
  82 SUBROUTINE column (loop , data_list, its,ite)
  83    IMPLICIT NONE
  84    INTEGER , INTENT(IN) :: loop, its, ite
  85    REAL , INTENT(IN) , DIMENSION(its:ite) :: data_list
  86    INTEGER , DIMENSION(its:ite) :: data_int
  87    INTEGER :: i
  88    CHARACTER (len = 10 ) :: filename
  89
  90    IF ( loop.EQ.0 ) THEN
  91       OPEN (unit=7,file = "x_locations.txt" , &
  92       form = "formatted" , &
  93       access = "sequential" )
  94
  95       DO i = its,ite
  96          write (7,*) i
  97       END DO
  98       close (7)
  99    END IF
 100
 101    WRITE(filename,fmt='(i6.6,".txt")') loop
 102    OPEN (unit=7,file = filename , &
 103    form = "formatted" , &
 104    access = "sequential" )
 105
 106    data_int = NINT(data_list * 100 )
 107    DO i = its,ite
 108       write (7,*) data_int(i)
 109    END DO
 110    close (7)
 111
 112 END SUBROUTINE column
 113 !----------------------------------------------------------------
 114 #elif ( ! defined(ADVECT_KERNEL) )
 115
 116 MODULE module_advect_em
 117
 118   USE module_bc
 119   USE module_model_constants
 120   USE module_wrf_error
 121
 122 CONTAINS
 123
 124 !-------------------------------------------------------------------------------
 125
 126 SUBROUTINE advect_u   ( u, u_old, tendency,            &
 127                         ru, rv, rom,                   &
 128                         c1, c2,                        &
 129                         mut, time_step, config_flags,  &
 130                         msfux, msfuy, msfvx, msfvy,    &
 131                         msftx, msfty,                  &
 132                         fzm, fzp,                      &
 133                         rdx, rdy, rdzw,                &
 134                         ids, ide, jds, jde, kds, kde,  &
 135                         ims, ime, jms, jme, kms, kme,  &
 136                         its, ite, jts, jte, kts, kte  )
 137
 138    IMPLICIT NONE
 139
 140    ! Input data
 141
 142    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
 143
 144    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
 145                                               ims, ime, jms, jme, kms, kme, &
 146                                               its, ite, jts, jte, kts, kte
 147
 148    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: u,     &
 149                                                                       u_old, &
 150                                                                       ru,    &
 151                                                                       rv,    &
 152                                                                       rom
 153
 154    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
 155    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
 156
 157    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
 158                                                                     msfuy,  &
 159                                                                     msfvx,  &
 160                                                                     msfvy,  &
 161                                                                     msftx,  &
 162                                                                     msfty
 163
 164    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
 165                                                                   fzp,  &
 166                                                                   rdzw, &
 167                                                                   c1,   &
 168                                                                   c2
 169
 170    REAL ,                                        INTENT(IN   ) :: rdx,  &
 171                                                                   rdy
 172    INTEGER ,                                     INTENT(IN   ) :: time_step
 173
 174    ! Local data
 175
 176    INTEGER :: i, j, k, itf, jtf, ktf
 177    INTEGER :: i_start, i_end, j_start, j_end
 178    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
 179    INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
 180    INTEGER :: jp1, jp0, jtmp
 181
 182    INTEGER :: horz_order, vert_order
 183
 184    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
 185    REAL , DIMENSION(its:ite, kts:kte) :: vflux
 186
 187
 188    REAL,  DIMENSION( its-1:ite+1, kts:kte ) :: fqx
 189    REAL,  DIMENSION( its:ite, kts:kte, 2) :: fqy
 190
 191    LOGICAL :: degrade_xs, degrade_ys
 192    LOGICAL :: degrade_xe, degrade_ye
 193
 194 ! definition of flux operators, 3rd, 4th, 5th or 6th order
 195
 196    REAL    :: flux3, flux4, flux5, flux6
 197    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
 198
 199    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                         &
 200           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
 201
 202    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                         &
 203             flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
 204             sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
 205
 206    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
 207                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)       &
 208                      +(q_ip2+q_im3) )/60.0
 209
 210    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
 211            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)     &
 212             -sign(1,time_step)*sign(1.,ua)*(                     &
 213               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
 214
 215
 216    LOGICAL :: specified
 217
 218    specified = .false.
 219    if(config_flags%specified .or. config_flags%nested) specified = .true.
 220
 221 !  set order for vertical and horzontal flux operators
 222
 223    horz_order = config_flags%h_mom_adv_order
 224    vert_order = config_flags%v_mom_adv_order
 225
 226    ktf=MIN(kte,kde-1)
 227
 228 !  begin with horizontal flux divergence
 229
 230    horizontal_order_test : IF( horz_order == 6 ) THEN
 231
 232 !  determine boundary mods for flux operators
 233 !  We degrade the flux operators from 3rd/4th order
 234 !   to second order one gridpoint in from the boundaries for
 235 !   all boundary conditions except periodic and symmetry - these
 236 !   conditions have boundary zone data fill for correct application
 237 !   of the higher order flux stencils
 238
 239    degrade_xs = .true.
 240    degrade_xe = .true.
 241    degrade_ys = .true.
 242    degrade_ye = .true.
 243
 244    IF( config_flags%periodic_x   .or. &
 245        config_flags%symmetric_xs .or. &
 246        (its > ids+3)                ) degrade_xs = .false.
 247    IF( config_flags%periodic_x   .or. &
 248        config_flags%symmetric_xe .or. &
 249        (ite < ide-2)                ) degrade_xe = .false.
 250    IF( config_flags%periodic_y   .or. &
 251        config_flags%symmetric_ys .or. &
 252        (jts > jds+3)                ) degrade_ys = .false.
 253    IF( config_flags%periodic_y   .or. &
 254        config_flags%symmetric_ye .or. &
 255        (jte < jde-4)                ) degrade_ye = .false.
 256
 257 !--------------- y - advection first
 258
 259       i_start = its
 260       i_end   = ite
 261       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
 262       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
 263       IF ( config_flags%periodic_x ) i_start = its
 264       IF ( config_flags%periodic_x ) i_end = ite
 265
 266       j_start = jts
 267       j_end   = MIN(jte,jde-1)
 268
 269 !  higher order flux has a 5 or 7 point stencil, so compute
 270 !  bounds so we can switch to second order flux close to the boundary
 271
 272       j_start_f = j_start
 273       j_end_f   = j_end+1
 274
 275       IF(degrade_ys) then
 276         j_start = MAX(jts,jds+1)
 277         j_start_f = jds+3
 278       ENDIF
 279
 280       IF(degrade_ye) then
 281         j_end = MIN(jte,jde-2)
 282         j_end_f = jde-3
 283       ENDIF
 284
 285       IF(config_flags%polar) j_end = MIN(jte,jde-1)
 286
 287 !  compute fluxes, 5th or 6th order
 288
 289      jp1 = 2
 290      jp0 = 1
 291
 292      j_loop_y_flux_6 : DO j = j_start, j_end+1
 293
 294       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN  ! use full stencil
 295
 296         DO k=kts,ktf
 297         DO i = i_start, i_end
 298           vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 299           fqy( i, k, jp1 ) = vel*flux6(               &
 300                   u(i,k,j-3), u(i,k,j-2), u(i,k,j-1),       &
 301                   u(i,k,j  ), u(i,k,j+1), u(i,k,j+2),  vel )
 302         ENDDO
 303         ENDDO
 304
 305 !  we must be close to some boundary where we need to reduce the order of the stencil
 306
 307       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
 308
 309             DO k=kts,ktf
 310             DO i = i_start, i_end
 311               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))  &
 312                                      *(u(i,k,j)+u(i,k,j-1))
 313             ENDDO
 314             ENDDO
 315
 316      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
 317
 318             DO k=kts,ktf
 319             DO i = i_start, i_end
 320               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 321               fqy( i, k, jp1 ) = vel*flux4(      &
 322                    u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel )
 323             ENDDO
 324             ENDDO
 325
 326      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
 327
 328             DO k=kts,ktf
 329             DO i = i_start, i_end
 330               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
 331                      *(u(i,k,j)+u(i,k,j-1))
 332             ENDDO
 333             ENDDO
 334
 335      ELSE IF ( j == jde-2 ) THEN  ! 3rd order flux 2 in from north boundary
 336
 337             DO k=kts,ktf
 338             DO i = i_start, i_end
 339               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 340               fqy( i, k, jp1 ) = vel*flux4(     &
 341                    u(i,k,j-2),u(i,k,j-1),    &
 342                    u(i,k,j),u(i,k,j+1),vel )
 343             ENDDO
 344             ENDDO
 345
 346       END IF
 347
 348 !  y flux-divergence into tendency
 349
 350         ! (j > j_start) will miss the u(,,jds) tendency
 351         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
 352           DO k=kts,ktf
 353           DO i = i_start, i_end
 354             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 355             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
 356           END DO
 357           END DO
 358         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 359         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
 360           DO k=kts,ktf
 361           DO i = i_start, i_end
 362             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 363             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
 364           END DO
 365           END DO
 366         ELSE  ! normal code
 367
 368         IF(j > j_start) THEN
 369
 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)-fqy(i,k,jp0))
 374           ENDDO
 375           ENDDO
 376
 377         ENDIF
 378
 379         END IF
 380
 381
 382         jtmp = jp1
 383         jp1 = jp0
 384         jp0 = jtmp
 385
 386    ENDDO j_loop_y_flux_6
 387
 388 !  next, x - flux divergence
 389
 390       i_start = its
 391       i_end   = ite
 392
 393       j_start = jts
 394       j_end   = MIN(jte,jde-1)
 395
 396 !  higher order flux has a 5 or 7 point stencil, so compute
 397 !  bounds so we can switch to second order flux close to the boundary
 398
 399       i_start_f = i_start
 400       i_end_f   = i_end+1
 401
 402       IF(degrade_xs) then
 403         i_start = MAX(ids+1,its)
 404         i_start_f = ids+3
 405       ENDIF
 406
 407       IF(degrade_xe) then
 408         i_end = MIN(ide-1,ite)
 409         i_end_f = ide-2
 410       ENDIF
 411
 412 !  compute fluxes
 413
 414       DO j = j_start, j_end
 415
 416 !  5th or 6th order flux
 417
 418         DO k=kts,ktf
 419         DO i = i_start_f, i_end_f
 420           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 421           fqx( i,k ) = vel*flux6( u(i-3,k,j), u(i-2,k,j),  &
 422                                          u(i-1,k,j), u(i  ,k,j),  &
 423                                          u(i+1,k,j), u(i+2,k,j),  &
 424                                          vel                     )
 425         ENDDO
 426         ENDDO
 427
 428 !  lower order fluxes close to boundaries (if not periodic or symmetric)
 429 !  specified uses upstream normal wind at boundaries
 430
 431         IF( degrade_xs ) THEN
 432
 433           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
 434             i = ids+1
 435             DO k=kts,ktf
 436               ub = u(i-1,k,j)
 437               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
 438               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 439                      *(u(i,k,j)+ub)
 440             ENDDO
 441           END IF
 442
 443           i = ids+2
 444           DO k=kts,ktf
 445             vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 446             fqx( i, k  ) = vel*flux4( u(i-2,k,j), u(i-1,k,j),  &
 447                                            u(i  ,k,j), u(i+1,k,j),  &
 448                                            vel                     )
 449           ENDDO
 450
 451         ENDIF
 452
 453         IF( degrade_xe ) THEN
 454
 455           IF( i_end == ide-1 ) THEN ! second order flux next to the boundary
 456             i = ide
 457             DO k=kts,ktf
 458               ub = u(i,k,j)
 459               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
 460               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 461                      *(u(i-1,k,j)+ub)
 462             ENDDO
 463           ENDIF
 464
 465           DO k=kts,ktf
 466           i = ide-1
 467           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 468           fqx( i,k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j),  &
 469                                          u(i  ,k,j), u(i+1,k,j),  &
 470                                          vel                     )
 471           ENDDO
 472
 473         ENDIF
 474
 475 !  x flux-divergence into tendency
 476
 477         DO k=kts,ktf
 478           DO i = i_start, i_end
 479             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
 480             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
 481           ENDDO
 482         ENDDO
 483
 484       ENDDO
 485
 486    ELSE IF( horz_order == 5 ) THEN
 487
 488 !  5th order horizontal flux calculation
 489 !  This code is EXACTLY the same as the 6th order code
 490 !  EXCEPT the 5th order and 3rd operators are used in
 491 !  place of the 6th and 4th order operators
 492
 493 !  determine boundary mods for flux operators
 494 !  We degrade the flux operators from 3rd/4th order
 495 !   to second order one gridpoint in from the boundaries for
 496 !   all boundary conditions except periodic and symmetry - these
 497 !   conditions have boundary zone data fill for correct application
 498 !   of the higher order flux stencils
 499
 500    degrade_xs = .true.
 501    degrade_xe = .true.
 502    degrade_ys = .true.
 503    degrade_ye = .true.
 504
 505    IF( config_flags%periodic_x   .or. &
 506        config_flags%symmetric_xs .or. &
 507        (its > ids+3)                ) degrade_xs = .false.
 508    IF( config_flags%periodic_x   .or. &
 509        config_flags%symmetric_xe .or. &
 510        (ite < ide-2)                ) degrade_xe = .false.
 511    IF( config_flags%periodic_y   .or. &
 512        config_flags%symmetric_ys .or. &
 513        (jts > jds+3)                ) degrade_ys = .false.
 514    IF( config_flags%periodic_y   .or. &
 515        config_flags%symmetric_ye .or. &
 516        (jte < jde-4)                ) degrade_ye = .false.
 517
 518 !--------------- y - advection first
 519
 520       i_start = its
 521       i_end   = ite
 522       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
 523       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
 524       IF ( config_flags%periodic_x ) i_start = its
 525       IF ( config_flags%periodic_x ) i_end = ite
 526
 527       j_start = jts
 528       j_end   = MIN(jte,jde-1)
 529
 530 !  higher order flux has a 5 or 7 point stencil, so compute
 531 !  bounds so we can switch to second order flux close to the boundary
 532
 533       j_start_f = j_start
 534       j_end_f   = j_end+1
 535
 536       IF(degrade_ys) then
 537         j_start = MAX(jts,jds+1)
 538         j_start_f = jds+3
 539       ENDIF
 540
 541       IF(degrade_ye) then
 542         j_end = MIN(jte,jde-2)
 543         j_end_f = jde-3
 544       ENDIF
 545
 546       IF(config_flags%polar) j_end = MIN(jte,jde-1)
 547
 548 !  compute fluxes, 5th or 6th order
 549
 550      jp1 = 2
 551      jp0 = 1
 552
 553      j_loop_y_flux_5 : DO j = j_start, j_end+1
 554
 555       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN  ! use full stencil
 556
 557         DO k=kts,ktf
 558         DO i = i_start, i_end
 559           vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 560           fqy( i, k, jp1 ) = vel*flux5(               &
 561                   u(i,k,j-3), u(i,k,j-2), u(i,k,j-1),       &
 562                   u(i,k,j  ), u(i,k,j+1), u(i,k,j+2),  vel )
 563         ENDDO
 564         ENDDO
 565
 566 !  we must be close to some boundary where we need to reduce the order of the stencil
 567
 568       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
 569
 570             DO k=kts,ktf
 571             DO i = i_start, i_end
 572               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))  &
 573                                      *(u(i,k,j)+u(i,k,j-1))
 574             ENDDO
 575             ENDDO
 576
 577      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
 578
 579             DO k=kts,ktf
 580             DO i = i_start, i_end
 581               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 582               fqy( i, k, jp1 ) = vel*flux3(      &
 583                    u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel )
 584             ENDDO
 585             ENDDO
 586
 587      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
 588
 589             DO k=kts,ktf
 590             DO i = i_start, i_end
 591               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
 592                      *(u(i,k,j)+u(i,k,j-1))
 593             ENDDO
 594             ENDDO
 595
 596      ELSE IF ( j == jde-2 ) THEN  ! 3rd order flux 2 in from north boundary
 597
 598             DO k=kts,ktf
 599             DO i = i_start, i_end
 600               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 601               fqy( i, k, jp1 ) = vel*flux3(     &
 602                    u(i,k,j-2),u(i,k,j-1),    &
 603                    u(i,k,j),u(i,k,j+1),vel )
 604             ENDDO
 605             ENDDO
 606
 607       END IF
 608
 609 !  y flux-divergence into tendency
 610
 611         ! (j > j_start) will miss the u(,,jds) tendency
 612         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
 613           DO k=kts,ktf
 614           DO i = i_start, i_end
 615             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 616             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
 617           END DO
 618           END DO
 619         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 620         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
 621           DO k=kts,ktf
 622           DO i = i_start, i_end
 623             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 624             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
 625           END DO
 626           END DO
 627         ELSE  ! normal code
 628
 629         IF(j > j_start) THEN
 630
 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)-fqy(i,k,jp0))
 635           ENDDO
 636           ENDDO
 637
 638         ENDIF
 639
 640         END IF
 641
 642
 643         jtmp = jp1
 644         jp1 = jp0
 645         jp0 = jtmp
 646
 647    ENDDO j_loop_y_flux_5
 648
 649 !  next, x - flux divergence
 650
 651       i_start = its
 652       i_end   = ite
 653
 654       j_start = jts
 655       j_end   = MIN(jte,jde-1)
 656
 657 !  higher order flux has a 5 or 7 point stencil, so compute
 658 !  bounds so we can switch to second order flux close to the boundary
 659
 660       i_start_f = i_start
 661       i_end_f   = i_end+1
 662
 663       IF(degrade_xs) then
 664         i_start = MAX(ids+1,its)
 665         i_start_f = ids+3
 666       ENDIF
 667
 668       IF(degrade_xe) then
 669         i_end = MIN(ide-1,ite)
 670         i_end_f = ide-2
 671       ENDIF
 672
 673 !  compute fluxes
 674
 675       DO j = j_start, j_end
 676
 677 !  5th or 6th order flux
 678
 679         DO k=kts,ktf
 680         DO i = i_start_f, i_end_f
 681           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 682           fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j),  &
 683                                          u(i-1,k,j), u(i  ,k,j),  &
 684                                          u(i+1,k,j), u(i+2,k,j),  &
 685                                          vel                     )
 686         ENDDO
 687         ENDDO
 688
 689 !  lower order fluxes close to boundaries (if not periodic or symmetric)
 690 !  specified uses upstream normal wind at boundaries
 691
 692         IF( degrade_xs ) THEN
 693
 694           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
 695             i = ids+1
 696             DO k=kts,ktf
 697               ub = u(i-1,k,j)
 698               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
 699               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 700                      *(u(i,k,j)+ub)
 701             ENDDO
 702           END IF
 703
 704           i = ids+2
 705           DO k=kts,ktf
 706             vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 707             fqx( i, k  ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
 708                                            u(i  ,k,j), u(i+1,k,j),  &
 709                                            vel                     )
 710           ENDDO
 711
 712         ENDIF
 713
 714         IF( degrade_xe ) THEN
 715
 716           IF( i_end == ide-1 ) THEN ! second order flux next to the boundary
 717             i = ide
 718             DO k=kts,ktf
 719               ub = u(i,k,j)
 720               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
 721               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 722                      *(u(i-1,k,j)+ub)
 723             ENDDO
 724           ENDIF
 725
 726           DO k=kts,ktf
 727           i = ide-1
 728           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 729           fqx( i,k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
 730                                          u(i  ,k,j), u(i+1,k,j),  &
 731                                          vel                     )
 732           ENDDO
 733
 734         ENDIF
 735
 736 !  x flux-divergence into tendency
 737
 738         DO k=kts,ktf
 739           DO i = i_start, i_end
 740             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
 741             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
 742           ENDDO
 743         ENDDO
 744
 745       ENDDO
 746
 747    ELSE IF( horz_order == 4 ) THEN
 748
 749 !  determine boundary mods for flux operators
 750 !  We degrade the flux operators from 3rd/4th order
 751 !   to second order one gridpoint in from the boundaries for
 752 !   all boundary conditions except periodic and symmetry - these
 753 !   conditions have boundary zone data fill for correct application
 754 !   of the higher order flux stencils
 755
 756    degrade_xs = .true.
 757    degrade_xe = .true.
 758    degrade_ys = .true.
 759    degrade_ye = .true.
 760
 761    IF( config_flags%periodic_x   .or. &
 762        config_flags%symmetric_xs .or. &
 763        (its > ids+2)                ) degrade_xs = .false.
 764    IF( config_flags%periodic_x   .or. &
 765        config_flags%symmetric_xe .or. &
 766        (ite < ide-1)                ) degrade_xe = .false.
 767    IF( config_flags%periodic_y   .or. &
 768        config_flags%symmetric_ys .or. &
 769        (jts > jds+2)                ) degrade_ys = .false.
 770    IF( config_flags%periodic_y   .or. &
 771        config_flags%symmetric_ye .or. &
 772        (jte < jde-3)                ) degrade_ye = .false.
 773
 774 !--------------- x - advection first
 775
 776       i_start = its
 777       i_end   = ite
 778       j_start = jts
 779       j_end   = MIN(jte,jde-1)
 780
 781 !  3rd or 4th order flux has a 5 point stencil, so compute
 782 !  bounds so we can switch to second order flux close to the boundary
 783
 784       i_start_f = i_start
 785       i_end_f   = i_end+1
 786
 787       IF(degrade_xs) then
 788         i_start = ids+1
 789         i_start_f = i_start+1
 790       ENDIF
 791
 792       IF(degrade_xe) then
 793         i_end = ide-1
 794         i_end_f = ide-1
 795       ENDIF
 796
 797 !  compute fluxes
 798
 799       DO j = j_start, j_end
 800
 801         DO k=kts,ktf
 802         DO i = i_start_f, i_end_f
 803           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 804           fqx( i, k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j),      &
 805                                    u(i  ,k,j), u(i+1,k,j), vel )
 806         ENDDO
 807         ENDDO
 808
 809 !  second order flux close to boundaries (if not periodic or symmetric)
 810 !  specified uses upstream normal wind at boundaries
 811
 812         IF( degrade_xs ) THEN
 813           i = i_start
 814           DO k=kts,ktf
 815               ub = u(i-1,k,j)
 816               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
 817               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 818                      *(u(i,k,j)+ub)
 819           ENDDO
 820         ENDIF
 821
 822         IF( degrade_xe ) THEN
 823           i = i_end+1
 824           DO k=kts,ktf
 825               ub = u(i,k,j)
 826               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
 827               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 828                      *(u(i-1,k,j)+ub)
 829           ENDDO
 830         ENDIF
 831
 832 !  x flux-divergence into tendency
 833
 834         DO k=kts,ktf
 835           DO i = i_start, i_end
 836             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
 837             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
 838           ENDDO
 839         ENDDO
 840
 841       ENDDO
 842
 843 !  y flux divergence
 844
 845       i_start = its
 846       i_end   = ite
 847       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
 848       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
 849       IF ( config_flags%periodic_x ) i_start = its
 850       IF ( config_flags%periodic_x ) i_end = ite
 851
 852       j_start = jts
 853       j_end   = MIN(jte,jde-1)
 854
 855 !  3rd or 4th order flux has a 5 point stencil, so compute
 856 !  bounds so we can switch to second order flux close to the boundary
 857
 858       j_start_f = j_start
 859       j_end_f   = j_end+1
 860
 861 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
 862       IF(degrade_ys) then
 863         j_start = jds+1
 864         j_start_f = j_start+1
 865       ENDIF
 866
 867       IF(degrade_ye) then
 868         j_end = jde-2
 869         j_end_f = jde-2
 870       ENDIF
 871
 872       IF(config_flags%polar) j_end = MIN(jte,jde-1)
 873
 874 !  j flux loop for v flux of u momentum
 875
 876      jp1 = 2
 877      jp0 = 1
 878
 879    DO j = j_start, j_end+1
 880
 881      IF ( (j < j_start_f) .and. degrade_ys) THEN
 882        DO k = kts, ktf
 883        DO i = i_start, i_end
 884          fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start))  &
 885                *(u(i,k,j_start)+u(i,k,j_start-1))
 886        ENDDO
 887        ENDDO
 888      ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
 889        DO k = kts, ktf
 890        DO i = i_start, i_end
 891          ! Assumes j>j_end_f is ONLY j_end+1 ...
 892 !         fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1))    &
 893 !                *(u(i,k,j_end+1)+u(i,k,j_end))
 894          fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
 895                 *(u(i,k,j)+u(i,k,j-1))
 896        ENDDO
 897        ENDDO
 898      ELSE
 899 !  3rd or 4th order flux
 900        DO k = kts, ktf
 901        DO i = i_start, i_end
 902          vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 903          fqy( i, k, jp1 ) = vel*flux4( u(i,k,j-2), u(i,k,j-1),  &
 904                                        u(i,k,j  ), u(i,k,j+1),  &
 905                                             vel                )
 906        ENDDO
 907        ENDDO
 908
 909      END IF
 910
 911 !  y flux-divergence into tendency
 912
 913      ! (j > j_start) will miss the u(,,jds) tendency
 914      IF ( config_flags%polar .AND. (j == jds+1) ) THEN
 915        DO k=kts,ktf
 916        DO i = i_start, i_end
 917          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 918          tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
 919        END DO
 920        END DO
 921        ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 922      ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
 923        DO k=kts,ktf
 924        DO i = i_start, i_end
 925          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 926          tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
 927        END DO
 928        END DO
 929      ELSE  ! normal code
 930
 931      IF (j > j_start) THEN
 932
 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)-fqy(i,k,jp0))
 937        ENDDO
 938        ENDDO
 939
 940      END IF
 941
 942      END IF
 943
 944      jtmp = jp1
 945      jp1 = jp0
 946      jp0 = jtmp
 947
 948   ENDDO
 949
 950   ELSE IF ( horz_order == 3 ) THEN
 951
 952 !  As with the 5th and 6th order flux chioces, the 3rd and 4th order
 953 !  code is EXACTLY the same EXCEPT for the flux operator.
 954
 955 !  determine boundary mods for flux operators
 956 !  We degrade the flux operators from 3rd/4th order
 957 !   to second order one gridpoint in from the boundaries for
 958 !   all boundary conditions except periodic and symmetry - these
 959 !   conditions have boundary zone data fill for correct application
 960 !   of the higher order flux stencils
 961
 962    degrade_xs = .true.
 963    degrade_xe = .true.
 964    degrade_ys = .true.
 965    degrade_ye = .true.
 966
 967    IF( config_flags%periodic_x   .or. &
 968        config_flags%symmetric_xs .or. &
 969        (its > ids+2)                ) degrade_xs = .false.
 970    IF( config_flags%periodic_x   .or. &
 971        config_flags%symmetric_xe .or. &
 972        (ite < ide-1)                ) degrade_xe = .false.
 973    IF( config_flags%periodic_y   .or. &
 974        config_flags%symmetric_ys .or. &
 975        (jts > jds+2)                ) degrade_ys = .false.
 976    IF( config_flags%periodic_y   .or. &
 977        config_flags%symmetric_ye .or. &
 978        (jte < jde-3)                ) degrade_ye = .false.
 979
 980 !--------------- x - advection first
 981
 982       i_start = its
 983       i_end   = ite
 984       j_start = jts
 985       j_end   = MIN(jte,jde-1)
 986
 987 !  3rd or 4th order flux has a 5 point stencil, so compute
 988 !  bounds so we can switch to second order flux close to the boundary
 989
 990       i_start_f = i_start
 991       i_end_f   = i_end+1
 992
 993       IF(degrade_xs) then
 994         i_start = ids+1
 995         i_start_f = i_start+1
 996       ENDIF
 997
 998       IF(degrade_xe) then
 999         i_end = ide-1
1000         i_end_f = ide-1
1001       ENDIF
1002
1003 !  compute fluxes
1004
1005       DO j = j_start, j_end
1006
1007         DO k=kts,ktf
1008         DO i = i_start_f, i_end_f
1009           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
1010           fqx( i, k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),      &
1011                                    u(i  ,k,j), u(i+1,k,j), vel )
1012         ENDDO
1013         ENDDO
1014
1015 !  second order flux close to boundaries (if not periodic or symmetric)
1016 !  specified uses upstream normal wind at boundaries
1017
1018         IF( degrade_xs ) THEN
1019           i = i_start
1020           DO k=kts,ktf
1021               ub = u(i-1,k,j)
1022               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
1023               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
1024                      *(u(i,k,j)+ub)
1025           ENDDO
1026         ENDIF
1027
1028         IF( degrade_xe ) THEN
1029           i = i_end+1
1030           DO k=kts,ktf
1031               ub = u(i,k,j)
1032               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
1033               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
1034                      *(u(i-1,k,j)+ub)
1035           ENDDO
1036         ENDIF
1037
1038 !  x flux-divergence into tendency
1039
1040         DO k=kts,ktf
1041           DO i = i_start, i_end
1042           mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
1043             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
1044           ENDDO
1045         ENDDO
1046       ENDDO
1047
1048 !  y flux divergence
1049
1050       i_start = its
1051       i_end   = ite
1052       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
1053       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
1054       IF ( config_flags%periodic_x ) i_start = its
1055       IF ( config_flags%periodic_x ) i_end = ite
1056
1057       j_start = jts
1058       j_end   = MIN(jte,jde-1)
1059
1060 !  3rd or 4th order flux has a 5 point stencil, so compute
1061 !  bounds so we can switch to second order flux close to the boundary
1062
1063       j_start_f = j_start
1064       j_end_f   = j_end+1
1065
1066 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
1067       IF(degrade_ys) then
1068         j_start = jds+1
1069         j_start_f = j_start+1
1070       ENDIF
1071
1072       IF(degrade_ye) then
1073         j_end = jde-2
1074         j_end_f = jde-2
1075       ENDIF
1076
1077       IF(config_flags%polar) j_end = MIN(jte,jde-1)
1078
1079 !  j flux loop for v flux of u momentum
1080
1081      jp1 = 2
1082      jp0 = 1
1083
1084    DO j = j_start, j_end+1
1085
1086      IF ( (j < j_start_f) .and. degrade_ys) THEN
1087        DO k = kts, ktf
1088        DO i = i_start, i_end
1089          fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start))  &
1090                *(u(i,k,j_start)+u(i,k,j_start-1))
1091        ENDDO
1092        ENDDO
1093      ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
1094        DO k = kts, ktf
1095        DO i = i_start, i_end
1096          ! Assumes j>j_end_f is ONLY j_end+1 ...
1097 !         fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1))    &
1098 !                *(u(i,k,j_end+1)+u(i,k,j_end))
1099          fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
1100                 *(u(i,k,j)+u(i,k,j-1))
1101        ENDDO
1102        ENDDO
1103      ELSE
1104 !  3rd or 4th order flux
1105        DO k = kts, ktf
1106        DO i = i_start, i_end
1107          vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
1108          fqy( i, k, jp1 ) = vel*flux3( u(i,k,j-2), u(i,k,j-1),  &
1109                                        u(i,k,j  ), u(i,k,j+1),  &
1110                                             vel                )
1111        ENDDO
1112        ENDDO
1113
1114      END IF
1115
1116 !  y flux-divergence into tendency
1117
1118      ! (j > j_start) will miss the u(,,jds) tendency
1119      IF ( config_flags%polar .AND. (j == jds+1) ) THEN
1120        DO k=kts,ktf
1121        DO i = i_start, i_end
1122          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
1123          tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
1124        END DO
1125        END DO
1126        ! This would be seen by (j > j_start) but we need to zero out the NP tendency
1127      ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
1128        DO k=kts,ktf
1129        DO i = i_start, i_end
1130          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
1131          tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
1132        END DO
1133        END DO
1134      ELSE  ! normal code
1135
1136      IF (j > j_start) THEN
1137
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)-fqy(i,k,jp0))
1142        ENDDO
1143        ENDDO
1144
1145      END IF
1146
1147      END IF
1148
1149      jtmp = jp1
1150      jp1 = jp0
1151      jp0 = jtmp
1152
1153   ENDDO
1154
1155   ELSE IF ( horz_order == 2 ) THEN
1156
1157       i_start = its
1158       i_end   = ite
1159       j_start = jts
1160       j_end   = MIN(jte,jde-1)
1161
1162       IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
1163       IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
1164       IF ( specified ) i_start = MAX(ids+2,its)
1165       IF ( specified ) i_end   = MIN(ide-2,ite)
1166       IF ( config_flags%periodic_x ) i_start = its
1167       IF ( config_flags%periodic_x ) i_end = ite
1168
1169       DO j = j_start, j_end
1170       DO k=kts,ktf
1171       DO i = i_start, i_end
1172          mrdx=msfux(i,j)*rdx         ! ADT eqn 44, 1st term on RHS
1173          tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1174                 *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) &
1175                 -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j)))
1176       ENDDO
1177       ENDDO
1178       ENDDO
1179
1180       IF ( specified .AND. its .LE. ids+1 .AND. .NOT. config_flags%periodic_x ) THEN
1181         DO j = j_start, j_end
1182         DO k=kts,ktf
1183            i = ids+1
1184            mrdx=msfux(i,j)*rdx       ! ADT eqn 44, 1st term on RHS
1185            ub = u(i-1,k,j)
1186            IF (u(i,k,j) .LT. 0.) ub = u(i,k,j)
1187            tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1188                   *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) &
1189                   -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+ub))
1190         ENDDO
1191         ENDDO
1192       ENDIF
1193       IF ( specified .AND. ite .GE. ide-1 .AND. .NOT. config_flags%periodic_x ) THEN
1194         DO j = j_start, j_end
1195         DO k=kts,ktf
1196            i = ide-1
1197            mrdx=msfux(i,j)*rdx       ! ADT eqn 44, 1st term on RHS
1198            ub = u(i+1,k,j)
1199            IF (u(i,k,j) .GT. 0.) ub = u(i,k,j)
1200            tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1201                   *((ru(i+1,k,j)+ru(i,k,j))*(ub+u(i,k,j)) &
1202                   -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j)))
1203         ENDDO
1204         ENDDO
1205       ENDIF
1206
1207       IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
1208       IF ( config_flags%open_ye .or. specified ) j_end   = MIN(jde-2,jte)
1209
1210       DO j = j_start, j_end
1211       DO k=kts,ktf
1212       DO i = i_start, i_end
1213          mrdy=msfux(i,j)*rdy         ! ADT eqn 44, 1st term on RHS
1214          ! Comments for polar boundary condition
1215          ! Flow is only from one side for points next to poles
1216          IF ( (config_flags%polar) .AND. (j == jds) ) THEN
1217             tendency(i,k,j)=tendency(i,k,j)-mrdy*0.25 &
1218                             *(rv(i,k,j+1)+rv(i-1,k,j+1))*(u(i,k,j+1)+u(i,k,j))
1219          ELSE IF ( (config_flags%polar) .AND. (j == jde-1) ) THEN
1220             tendency(i,k,j)=tendency(i,k,j)+mrdy*0.25 &
1221                            *(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1))
1222          ELSE  ! Normal code
1223             tendency(i,k,j)=tendency(i,k,j)-mrdy*0.25 &
1224                 *((rv(i,k,j+1)+rv(i-1,k,j+1))*(u(i,k,j+1)+u(i,k,j)) &
1225                  -(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1)))
1226          ENDIF
1227       ENDDO
1228       ENDDO
1229       ENDDO
1230
1231    ELSE IF ( horz_order == 0 ) THEN
1232
1233       ! Just in case we want to turn horizontal advection off, we can do it
1234
1235    ELSE
1236
1237       WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a:  h_order not known ',horz_order
1238       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1239
1240    ENDIF horizontal_order_test
1241
1242 !  radiative lateral boundary condition in x for normal velocity (u)
1243
1244       IF ( (config_flags%open_xs) .and. its == ids ) THEN
1245
1246         j_start = jts
1247         j_end   = MIN(jte,jde-1)
1248
1249         DO j = j_start, j_end
1250         DO k = kts, ktf
1251           ub = MIN(ru(its,k,j)-cb*(c1(k)*mut(its,j)+c2(k)), 0.)
1252           tendency(its,k,j) = tendency(its,k,j)                    &
1253                       - rdx*ub*(u_old(its+1,k,j) - u_old(its,k,j))
1254         ENDDO
1255         ENDDO
1256
1257       ENDIF
1258
1259       IF ( (config_flags%open_xe) .and. ite == ide ) THEN
1260
1261         j_start = jts
1262         j_end   = MIN(jte,jde-1)
1263
1264         DO j = j_start, j_end
1265         DO k = kts, ktf
1266           ub = MAX(ru(ite,k,j)+cb*(c1(k)*mut(ite-1,j)+c2(k)), 0.)
1267           tendency(ite,k,j) = tendency(ite,k,j)                    &
1268                       - rdx*ub*(u_old(ite,k,j) - u_old(ite-1,k,j))
1269         ENDDO
1270         ENDDO
1271
1272       ENDIF
1273
1274 !  pick up the rest of the horizontal radiation boundary conditions.
1275 !  (these are the computations that don't require 'cb')
1276 !  first, set to index ranges
1277
1278       i_start = its
1279       i_end   = MIN(ite,ide)
1280       imin    = ids
1281       imax    = ide-1
1282
1283       IF (config_flags%open_xs) THEN
1284         i_start = MAX(ids+1, its)
1285         imin = ids
1286       ENDIF
1287       IF (config_flags%open_xe) THEN
1288         i_end = MIN(ite,ide-1)
1289         imax = ide-1
1290       ENDIF
1291
1292    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
1293
1294       DO i = i_start, i_end
1295
1296          mrdy=msfux(i,jts)*rdy       ! ADT eqn 44, 2nd term on RHS
1297          ip = MIN( imax, i   )
1298          im = MAX( imin, i-1 )
1299
1300          DO k=kts,ktf
1301
1302           vw = 0.5*(rv(ip,k,jts)+rv(im,k,jts))
1303           vb = MIN( vw, 0. )
1304           dvm =  rv(ip,k,jts+1)-rv(ip,k,jts)
1305           dvp =  rv(im,k,jts+1)-rv(im,k,jts)
1306           tendency(i,k,jts)=tendency(i,k,jts)-mrdy*(                &
1307                             vb*(u_old(i,k,jts+1)-u_old(i,k,jts))    &
1308                            +0.5*u(i,k,jts)*(dvm+dvp))
1309          ENDDO
1310       ENDDO
1311
1312    ENDIF
1313
1314    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
1315
1316       DO i = i_start, i_end
1317
1318          mrdy=msfux(i,jte-1)*rdy     ! ADT eqn 44, 2nd term on RHS
1319          ip = MIN( imax, i   )
1320          im = MAX( imin, i-1 )
1321
1322          DO k=kts,ktf
1323
1324           vw = 0.5*(rv(ip,k,jte)+rv(im,k,jte))
1325           vb = MAX( vw, 0. )
1326           dvm =  rv(ip,k,jte)-rv(ip,k,jte-1)
1327           dvp =  rv(im,k,jte)-rv(im,k,jte-1)
1328           tendency(i,k,jte-1)=tendency(i,k,jte-1)-mrdy*(              &
1329                               vb*(u_old(i,k,jte-1)-u_old(i,k,jte-2))  &
1330                              +0.5*u(i,k,jte-1)*(dvm+dvp))
1331          ENDDO
1332       ENDDO
1333
1334    ENDIF
1335
1336 !-------------------- vertical advection
1337 !  ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
1338 !  Here we have:  - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
1339 !  Since 'my' (map scale factor in y-direction) isn't a function of z,
1340 !  this is what we need, so leave unchanged in advect_u
1341
1342    i_start = its
1343    i_end   = ite
1344    j_start = jts
1345    j_end   = min(jte,jde-1)
1346
1347 !   IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
1348 !   IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
1349
1350    IF ( config_flags%open_ys .or. specified ) i_start = MAX(ids+1,its)
1351    IF ( config_flags%open_ye .or. specified ) i_end   = MIN(ide-1,ite)
1352    IF ( config_flags%periodic_x ) i_start = its
1353    IF ( config_flags%periodic_x ) i_end = ite
1354
1355    DO i = i_start, i_end
1356      vflux(i,kts)=0.
1357      vflux(i,kte)=0.
1358    ENDDO
1359
1360    vert_order_test : IF (vert_order == 6) THEN
1361
1362       DO j = j_start, j_end
1363
1364          DO k=kts+3,ktf-2
1365          DO i = i_start, i_end
1366            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1367            vflux(i,k) = vel*flux6(                     &
1368                    u(i,k-3,j), u(i,k-2,j), u(i,k-1,j),       &
1369                    u(i,k  ,j), u(i,k+1,j), u(i,k+2,j),  -vel )
1370          ENDDO
1371          ENDDO
1372
1373          DO i = i_start, i_end
1374
1375            k=kts+1
1376            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1377                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1378            k = kts+2
1379            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1380            vflux(i,k) = vel*flux4(       &
1381                    u(i,k-2,j), u(i,k-1,j),   &
1382                    u(i,k  ,j), u(i,k+1,j), -vel )
1383            k = ktf-1
1384            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1385            vflux(i,k) = vel*flux4(       &
1386                    u(i,k-2,j), u(i,k-1,j),   &
1387                    u(i,k  ,j), u(i,k+1,j), -vel )
1388            k=ktf
1389            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1390                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1391
1392          ENDDO
1393          DO k=kts,ktf
1394          DO i = i_start, i_end
1395             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1396          ENDDO
1397          ENDDO
1398       ENDDO
1399
1400     ELSE IF (vert_order == 5) THEN
1401
1402       DO j = j_start, j_end
1403
1404          DO k=kts+3,ktf-2
1405          DO i = i_start, i_end
1406            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1407            vflux(i,k) = vel*flux5(                     &
1408                    u(i,k-3,j), u(i,k-2,j), u(i,k-1,j),       &
1409                    u(i,k  ,j), u(i,k+1,j), u(i,k+2,j),  -vel )
1410          ENDDO
1411          ENDDO
1412
1413          DO i = i_start, i_end
1414
1415            k=kts+1
1416            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1417                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1418            k = kts+2
1419            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1420            vflux(i,k) = vel*flux3(       &
1421                    u(i,k-2,j), u(i,k-1,j),   &
1422                    u(i,k  ,j), u(i,k+1,j), -vel )
1423            k = ktf-1
1424            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1425            vflux(i,k) = vel*flux3(       &
1426                    u(i,k-2,j), u(i,k-1,j),   &
1427                    u(i,k  ,j), u(i,k+1,j), -vel )
1428            k=ktf
1429            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1430                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1431
1432          ENDDO
1433          DO k=kts,ktf
1434          DO i = i_start, i_end
1435             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1436          ENDDO
1437          ENDDO
1438       ENDDO
1439
1440     ELSE IF (vert_order == 4) THEN
1441
1442       DO j = j_start, j_end
1443
1444          DO k=kts+2,ktf-1
1445          DO i = i_start, i_end
1446            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1447            vflux(i,k) = vel*flux4(               &
1448                    u(i,k-2,j), u(i,k-1,j),       &
1449                    u(i,k  ,j), u(i,k+1,j),  -vel )
1450          ENDDO
1451          ENDDO
1452
1453          DO i = i_start, i_end
1454
1455            k=kts+1
1456            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1457                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1458            k=ktf
1459            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1460                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1461
1462          ENDDO
1463          DO k=kts,ktf
1464          DO i = i_start, i_end
1465             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1466          ENDDO
1467          ENDDO
1468       ENDDO
1469
1470     ELSE IF (vert_order == 3) THEN
1471
1472       DO j = j_start, j_end
1473
1474          DO k=kts+2,ktf-1
1475          DO i = i_start, i_end
1476            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1477            vflux(i,k) = vel*flux3(               &
1478                    u(i,k-2,j), u(i,k-1,j),       &
1479                    u(i,k  ,j), u(i,k+1,j),  -vel )
1480          ENDDO
1481          ENDDO
1482
1483          DO i = i_start, i_end
1484
1485            k=kts+1
1486            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1487                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1488            k=ktf
1489            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1490                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1491
1492          ENDDO
1493          DO k=kts,ktf
1494          DO i = i_start, i_end
1495             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1496          ENDDO
1497          ENDDO
1498       ENDDO
1499
1500     ELSE IF (vert_order == 2) THEN
1501
1502       DO j = j_start, j_end
1503          DO k=kts+1,ktf
1504          DO i = i_start, i_end
1505                vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1506                                 *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1507          ENDDO
1508          ENDDO
1509
1510
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
1517       ENDDO
1518
1519    ELSE
1520
1521       WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a: v_order not known ',vert_order
1522       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1523
1524    ENDIF vert_order_test
1525
1526 END SUBROUTINE advect_u
1527
1528 !-------------------------------------------------------------------------------
1529
1530 SUBROUTINE advect_v   ( v, v_old, tendency,            &
1531                         ru, rv, rom,                   &
1532                         c1, c2,                        &
1533                         mut, time_step, config_flags,  &
1534                         msfux, msfuy, msfvx, msfvy,    &
1535                         msftx, msfty,                  &
1536                         fzm, fzp,                      &
1537                         rdx, rdy, rdzw,                &
1538                         ids, ide, jds, jde, kds, kde,  &
1539                         ims, ime, jms, jme, kms, kme,  &
1540                         its, ite, jts, jte, kts, kte  )
1541
1542    IMPLICIT NONE
1543
1544    ! Input data
1545
1546    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
1547
1548    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
1549                                               ims, ime, jms, jme, kms, kme, &
1550                                               its, ite, jts, jte, kts, kte
1551
1552    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: v,     &
1553                                                                       v_old, &
1554                                                                       ru,    &
1555                                                                       rv,    &
1556                                                                       rom
1557
1558    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
1559    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
1560
1561    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
1562                                                                     msfuy,  &
1563                                                                     msfvx,  &
1564                                                                     msfvy,  &
1565                                                                     msftx,  &
1566                                                                     msfty
1567
1568    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
1569                                                                   fzp,  &
1570                                                                   rdzw, &
1571                                                                   c1,   &
1572                                                                   c2
1573
1574    REAL ,                                        INTENT(IN   ) :: rdx,  &
1575                                                                   rdy
1576    INTEGER ,                                     INTENT(IN   ) :: time_step
1577
1578
1579    ! Local data
1580
1581    INTEGER :: i, j, k, itf, jtf, ktf
1582    INTEGER :: i_start, i_end, j_start, j_end
1583    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
1584    INTEGER :: jmin, jmax, jp, jm, imin, imax
1585
1586    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
1587    REAL , DIMENSION(its:ite, kts:kte) :: vflux
1588
1589
1590    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
1591    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
1592
1593    INTEGER :: horz_order
1594    INTEGER :: vert_order
1595
1596    LOGICAL :: degrade_xs, degrade_ys
1597    LOGICAL :: degrade_xe, degrade_ye
1598
1599    INTEGER :: jp1, jp0, jtmp
1600
1601
1602 ! definition of flux operators, 3rd, 4th, 5th or 6th order
1603
1604    REAL    :: flux3, flux4, flux5, flux6
1605    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
1606
1607    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
1608           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
1609
1610    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
1611            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
1612            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
1613
1614    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
1615                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)   &
1616                      +(q_ip2+q_im3) )/60.0
1617
1618    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
1619            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
1620             -sign(1,time_step)*sign(1.,ua)*(                    &
1621               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
1622
1623
1624
1625    LOGICAL :: specified
1626
1627    specified = .false.
1628    if(config_flags%specified .or. config_flags%nested) specified = .true.
1629
1630 ! set order for the advection schemes
1631
1632    ktf=MIN(kte,kde-1)
1633    horz_order = config_flags%h_mom_adv_order
1634    vert_order = config_flags%v_mom_adv_order
1635
1636
1637 !  here is the choice of flux operators
1638
1639
1640    horizontal_order_test : IF( horz_order == 6 ) THEN
1641
1642 !  determine boundary mods for flux operators
1643 !  We degrade the flux operators from 3rd/4th order
1644 !   to second order one gridpoint in from the boundaries for
1645 !   all boundary conditions except periodic and symmetry - these
1646 !   conditions have boundary zone data fill for correct application
1647 !   of the higher order flux stencils
1648
1649    degrade_xs = .true.
1650    degrade_xe = .true.
1651    degrade_ys = .true.
1652    degrade_ye = .true.
1653
1654    IF( config_flags%periodic_x   .or. &
1655        config_flags%symmetric_xs .or. &
1656        (its > ids+3)                ) degrade_xs = .false.
1657    IF( config_flags%periodic_x   .or. &
1658        config_flags%symmetric_xe .or. &
1659        (ite < ide-3)                ) degrade_xe = .false.
1660    IF( config_flags%periodic_y   .or. &
1661        config_flags%symmetric_ys .or. &
1662        (jts > jds+3)                ) degrade_ys = .false.
1663    IF( config_flags%periodic_y   .or. &
1664        config_flags%symmetric_ye .or. &
1665        (jte < jde-3)                ) degrade_ye = .false.
1666
1667 !--------------- y - advection first
1668
1669       i_start = its
1670       i_end   = MIN(ite,ide-1)
1671       j_start = jts
1672       j_end   = jte
1673
1674 !  higher order flux has a 5 or 7 point stencil, so compute
1675 !  bounds so we can switch to second order flux close to the boundary
1676
1677       j_start_f = j_start
1678       j_end_f   = j_end+1
1679
1680       IF(degrade_ys) then
1681         j_start = MAX(jts,jds+1)
1682         j_start_f = jds+3
1683       ENDIF
1684
1685       IF(degrade_ye) then
1686         j_end = MIN(jte,jde-1)
1687         j_end_f = jde-2
1688       ENDIF
1689
1690 !  compute fluxes, 5th or 6th order
1691
1692      jp1 = 2
1693      jp0 = 1
1694
1695      j_loop_y_flux_6 : DO j = j_start, j_end+1
1696
1697       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
1698
1699         DO k=kts,ktf
1700         DO i = i_start, i_end
1701           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1702           fqy( i, k, jp1 ) = vel*flux6(               &
1703                   v(i,k,j-3), v(i,k,j-2), v(i,k,j-1),       &
1704                   v(i,k,j  ), v(i,k,j+1), v(i,k,j+2),  vel )
1705         ENDDO
1706         ENDDO
1707
1708 !  we must be close to some boundary where we need to reduce the order of the stencil
1709 !  specified uses upstream normal wind at boundaries
1710
1711       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
1712
1713             DO k=kts,ktf
1714             DO i = i_start, i_end
1715                 vb = v(i,k,j-1)
1716                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
1717                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
1718                                  *(v(i,k,j)+vb)
1719             ENDDO
1720             ENDDO
1721
1722      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
1723
1724             DO k=kts,ktf
1725             DO i = i_start, i_end
1726               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1727               fqy( i, k, jp1 ) = vel*flux4(      &
1728                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
1729             ENDDO
1730             ENDDO
1731
1732
1733      ELSE IF ( j == jde ) THEN  ! 2nd order flux next to north boundary
1734
1735             DO k=kts,ktf
1736             DO i = i_start, i_end
1737                 vb = v(i,k,j)
1738                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
1739                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
1740                                  *(vb+v(i,k,j-1))
1741             ENDDO
1742             ENDDO
1743
1744      ELSE IF ( j == jde-1 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
1745
1746             DO k=kts,ktf
1747             DO i = i_start, i_end
1748               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1749               fqy( i, k, jp1 ) = vel*flux4(     &
1750                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
1751             ENDDO
1752             ENDDO
1753
1754       END IF
1755
1756 !  y flux-divergence into tendency
1757
1758         ! Comments on polar boundary conditions
1759         ! No advection over the poles means tendencies (held from jds [S. pole]
1760         ! to jde [N pole], i.e., on v grid) must be zero at poles
1761         ! [tendency(jds) and tendency(jde)=0]
1762         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
1763           DO k=kts,ktf
1764           DO i = i_start, i_end
1765             tendency(i,k,j-1) = 0.
1766           END DO
1767           END DO
1768         ! If j_end were set to jde in a special if statement apart from
1769         ! degrade_ye, then we would hit the next conditional.  But since
1770         ! we want the tendency to be zero anyway, not looping to jde+1
1771         ! will produce the same effect.
1772         ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
1773           DO k=kts,ktf
1774           DO i = i_start, i_end
1775             tendency(i,k,j-1) = 0.
1776           END DO
1777           END DO
1778         ELSE  ! Normal code
1779
1780         IF(j > j_start) THEN
1781
1782           DO k=kts,ktf
1783           DO i = i_start, i_end
1784             mrdy=msfvy(i,j-1)*rdy    ! ADT eqn 45, 2nd term on RHS
1785             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
1786           ENDDO
1787           ENDDO
1788
1789         ENDIF
1790
1791         END IF
1792
1793         jtmp = jp1
1794         jp1 = jp0
1795         jp0 = jtmp
1796
1797    ENDDO j_loop_y_flux_6
1798
1799 !  next, x - flux divergence
1800
1801       i_start = its
1802       i_end   = MIN(ite,ide-1)
1803
1804       j_start = jts
1805       j_end   = jte
1806       ! Polar boundary conditions are like open or specified
1807       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
1808       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
1809
1810 !  higher order flux has a 5 or 7 point stencil, so compute
1811 !  bounds so we can switch to second order flux close to the boundary
1812
1813       i_start_f = i_start
1814       i_end_f   = i_end+1
1815
1816       IF(degrade_xs) then
1817         i_start = MAX(ids+1,its)
1818 !        i_start_f = i_start+2
1819         i_start_f = MIN(i_start+2,ids+3)
1820       ENDIF
1821
1822       IF(degrade_xe) then
1823         i_end = MIN(ide-2,ite)
1824         i_end_f = ide-3
1825       ENDIF
1826
1827 !  compute fluxes
1828
1829       DO j = j_start, j_end
1830
1831 !  5th or 6th order flux
1832
1833         DO k=kts,ktf
1834         DO i = i_start_f, i_end_f
1835           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1836           fqx( i, k ) = vel*flux6( v(i-3,k,j), v(i-2,k,j),  &
1837                                          v(i-1,k,j), v(i  ,k,j),  &
1838                                          v(i+1,k,j), v(i+2,k,j),  &
1839                                          vel                     )
1840         ENDDO
1841         ENDDO
1842
1843 !  lower order fluxes close to boundaries (if not periodic or symmetric)
1844
1845         IF( degrade_xs ) THEN
1846
1847           DO i=i_start,i_start_f-1
1848
1849             IF(i == ids+1) THEN ! second order
1850               DO k=kts,ktf
1851                 fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) &
1852                                 *(v(i,k,j)+v(i-1,k,j))
1853               ENDDO
1854             ENDIF
1855
1856             IF(i == ids+2) THEN  ! third order
1857               DO k=kts,ktf
1858                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1859                 fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j),  &
1860                                         v(i  ,k,j), v(i+1,k,j),  &
1861                                         vel                     )
1862               ENDDO
1863             ENDIF
1864
1865           ENDDO
1866
1867         ENDIF
1868
1869         IF( degrade_xe ) THEN
1870
1871           DO i = i_end_f+1, i_end+1
1872
1873             IF( i == ide-1 ) THEN ! second order flux next to the boundary
1874               DO k=kts,ktf
1875                 fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
1876                                 *(v(i_end+1,k,j)+v(i_end,k,j))
1877               ENDDO
1878             ENDIF
1879
1880             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
1881               DO k=kts,ktf
1882                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1883                 fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j),  &
1884                                         v(i  ,k,j), v(i+1,k,j),  &
1885                                         vel                     )
1886               ENDDO
1887             ENDIF
1888
1889           ENDDO
1890
1891         ENDIF
1892
1893 !  x flux-divergence into tendency
1894
1895         DO k=kts,ktf
1896           DO i = i_start, i_end
1897             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
1898             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
1899           ENDDO
1900         ENDDO
1901
1902       ENDDO
1903
1904    ELSE IF( horz_order == 5 ) THEN
1905
1906 !  5th order horizontal flux calculation
1907 !  This code is EXACTLY the same as the 6th order code
1908 !  EXCEPT the 5th order and 3rd operators are used in
1909 !  place of the 6th and 4th order operators
1910
1911 !  determine boundary mods for flux operators
1912 !  We degrade the flux operators from 3rd/4th order
1913 !   to second order one gridpoint in from the boundaries for
1914 !   all boundary conditions except periodic and symmetry - these
1915 !   conditions have boundary zone data fill for correct application
1916 !   of the higher order flux stencils
1917
1918    degrade_xs = .true.
1919    degrade_xe = .true.
1920    degrade_ys = .true.
1921    degrade_ye = .true.
1922
1923    IF( config_flags%periodic_x   .or. &
1924        config_flags%symmetric_xs .or. &
1925        (its > ids+3)                ) degrade_xs = .false.
1926    IF( config_flags%periodic_x   .or. &
1927        config_flags%symmetric_xe .or. &
1928        (ite < ide-3)                ) degrade_xe = .false.
1929    IF( config_flags%periodic_y   .or. &
1930        config_flags%symmetric_ys .or. &
1931        (jts > jds+3)                ) degrade_ys = .false.
1932    IF( config_flags%periodic_y   .or. &
1933        config_flags%symmetric_ye .or. &
1934        (jte < jde-3)                ) degrade_ye = .false.
1935
1936 !--------------- y - advection first
1937
1938       i_start = its
1939       i_end   = MIN(ite,ide-1)
1940       j_start = jts
1941       j_end   = jte
1942
1943 !  higher order flux has a 5 or 7 point stencil, so compute
1944 !  bounds so we can switch to second order flux close to the boundary
1945
1946       j_start_f = j_start
1947       j_end_f   = j_end+1
1948
1949       IF(degrade_ys) then
1950         j_start = MAX(jts,jds+1)
1951         j_start_f = jds+3
1952       ENDIF
1953
1954       IF(degrade_ye) then
1955         j_end = MIN(jte,jde-1)
1956         j_end_f = jde-2
1957       ENDIF
1958
1959 !  compute fluxes, 5th or 6th order
1960
1961      jp1 = 2
1962      jp0 = 1
1963
1964      j_loop_y_flux_5 : DO j = j_start, j_end+1
1965
1966       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
1967
1968         DO k=kts,ktf
1969         DO i = i_start, i_end
1970           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1971           fqy( i, k, jp1 ) = vel*flux5(               &
1972                   v(i,k,j-3), v(i,k,j-2), v(i,k,j-1),       &
1973                   v(i,k,j  ), v(i,k,j+1), v(i,k,j+2),  vel )
1974         ENDDO
1975         ENDDO
1976
1977 !  we must be close to some boundary where we need to reduce the order of the stencil
1978 !  specified uses upstream normal wind at boundaries
1979
1980       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
1981
1982             DO k=kts,ktf
1983             DO i = i_start, i_end
1984                 vb = v(i,k,j-1)
1985                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
1986                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
1987                                  *(v(i,k,j)+vb)
1988             ENDDO
1989             ENDDO
1990
1991      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
1992
1993             DO k=kts,ktf
1994             DO i = i_start, i_end
1995               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1996               fqy( i, k, jp1 ) = vel*flux3(      &
1997                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
1998             ENDDO
1999             ENDDO
2000
2001
2002      ELSE IF ( j == jde ) THEN  ! 2nd order flux next to north boundary
2003
2004             DO k=kts,ktf
2005             DO i = i_start, i_end
2006                 vb = v(i,k,j)
2007                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
2008                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
2009                                  *(vb+v(i,k,j-1))
2010             ENDDO
2011             ENDDO
2012
2013      ELSE IF ( j == jde-1 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
2014
2015             DO k=kts,ktf
2016             DO i = i_start, i_end
2017               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2018               fqy( i, k, jp1 ) = vel*flux3(     &
2019                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
2020             ENDDO
2021             ENDDO
2022
2023       END IF
2024
2025 !  y flux-divergence into tendency
2026
2027         ! Comments on polar boundary conditions
2028         ! No advection over the poles means tendencies (held from jds [S. pole]
2029         ! to jde [N pole], i.e., on v grid) must be zero at poles
2030         ! [tendency(jds) and tendency(jde)=0]
2031         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
2032           DO k=kts,ktf
2033           DO i = i_start, i_end
2034             tendency(i,k,j-1) = 0.
2035           END DO
2036           END DO
2037         ! If j_end were set to jde in a special if statement apart from
2038         ! degrade_ye, then we would hit the next conditional.  But since
2039         ! we want the tendency to be zero anyway, not looping to jde+1
2040         ! will produce the same effect.
2041         ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
2042           DO k=kts,ktf
2043           DO i = i_start, i_end
2044             tendency(i,k,j-1) = 0.
2045           END DO
2046           END DO
2047         ELSE  ! Normal code
2048
2049         IF(j > j_start) THEN
2050
2051           DO k=kts,ktf
2052           DO i = i_start, i_end
2053             mrdy=msfvy(i,j-1)*rdy    ! ADT eqn 45, 2nd term on RHS
2054             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
2055           ENDDO
2056           ENDDO
2057
2058         ENDIF
2059
2060         END IF
2061
2062         jtmp = jp1
2063         jp1 = jp0
2064         jp0 = jtmp
2065
2066    ENDDO j_loop_y_flux_5
2067
2068 !  next, x - flux divergence
2069
2070       i_start = its
2071       i_end   = MIN(ite,ide-1)
2072
2073       j_start = jts
2074       j_end   = jte
2075       ! Polar boundary conditions are like open or specified
2076       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2077       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
2078
2079 !  higher order flux has a 5 or 7 point stencil, so compute
2080 !  bounds so we can switch to second order flux close to the boundary
2081
2082       i_start_f = i_start
2083       i_end_f   = i_end+1
2084
2085       IF(degrade_xs) then
2086         i_start = MAX(ids+1,its)
2087 !        i_start_f = i_start+2
2088         i_start_f = MIN(i_start+2,ids+3)
2089       ENDIF
2090
2091       IF(degrade_xe) then
2092         i_end = MIN(ide-2,ite)
2093         i_end_f = ide-3
2094       ENDIF
2095
2096 !  compute fluxes
2097
2098       DO j = j_start, j_end
2099
2100 !  5th or 6th order flux
2101
2102         DO k=kts,ktf
2103         DO i = i_start_f, i_end_f
2104           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2105           fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j),  &
2106                                          v(i-1,k,j), v(i  ,k,j),  &
2107                                          v(i+1,k,j), v(i+2,k,j),  &
2108                                          vel                     )
2109         ENDDO
2110         ENDDO
2111
2112 !  lower order fluxes close to boundaries (if not periodic or symmetric)
2113
2114         IF( degrade_xs ) THEN
2115
2116           DO i=i_start,i_start_f-1
2117
2118             IF(i == ids+1) THEN ! second order
2119               DO k=kts,ktf
2120                 fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) &
2121                                 *(v(i,k,j)+v(i-1,k,j))
2122               ENDDO
2123             ENDIF
2124
2125             IF(i == ids+2) THEN  ! third order
2126               DO k=kts,ktf
2127                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2128                 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
2129                                         v(i  ,k,j), v(i+1,k,j),  &
2130                                         vel                     )
2131               ENDDO
2132             ENDIF
2133
2134           ENDDO
2135
2136         ENDIF
2137
2138         IF( degrade_xe ) THEN
2139
2140           DO i = i_end_f+1, i_end+1
2141
2142             IF( i == ide-1 ) THEN ! second order flux next to the boundary
2143               DO k=kts,ktf
2144                 fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
2145                                 *(v(i_end+1,k,j)+v(i_end,k,j))
2146               ENDDO
2147             ENDIF
2148
2149             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
2150               DO k=kts,ktf
2151                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2152                 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
2153                                         v(i  ,k,j), v(i+1,k,j),  &
2154                                         vel                     )
2155               ENDDO
2156             ENDIF
2157
2158           ENDDO
2159
2160         ENDIF
2161
2162 !  x flux-divergence into tendency
2163
2164         DO k=kts,ktf
2165           DO i = i_start, i_end
2166             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
2167             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2168           ENDDO
2169         ENDDO
2170
2171       ENDDO
2172
2173    ELSE IF( horz_order == 4 ) THEN
2174
2175 !  determine boundary mods for flux operators
2176 !  We degrade the flux operators from 3rd/4th order
2177 !   to second order one gridpoint in from the boundaries for
2178 !   all boundary conditions except periodic and symmetry - these
2179 !   conditions have boundary zone data fill for correct application
2180 !   of the higher order flux stencils
2181
2182    degrade_xs = .true.
2183    degrade_xe = .true.
2184    degrade_ys = .true.
2185    degrade_ye = .true.
2186
2187    IF( config_flags%periodic_x   .or. &
2188        config_flags%symmetric_xs .or. &
2189        (its > ids+2)                ) degrade_xs = .false.
2190    IF( config_flags%periodic_x   .or. &
2191        config_flags%symmetric_xe .or. &
2192        (ite < ide-2)                ) degrade_xe = .false.
2193    IF( config_flags%periodic_y   .or. &
2194        config_flags%symmetric_ys .or. &
2195        (jts > jds+2)                ) degrade_ys = .false.
2196    IF( config_flags%periodic_y   .or. &
2197        config_flags%symmetric_ye .or. &
2198        (jte < jde-2)                ) degrade_ye = .false.
2199
2200 !--------------- y - advection first
2201
2202
2203    ktf=MIN(kte,kde-1)
2204
2205       i_start = its
2206       i_end   = MIN(ite,ide-1)
2207       j_start = jts
2208       j_end   = jte
2209
2210 !  3rd or 4th order flux has a 5 point stencil, so compute
2211 !  bounds so we can switch to second order flux close to the boundary
2212
2213       j_start_f = j_start
2214       j_end_f   = j_end+1
2215
2216 !CJM May not work with tiling because defined in terms of domain dims
2217       IF(degrade_ys) then
2218         j_start = jds+1
2219         j_start_f = j_start+1
2220       ENDIF
2221
2222       IF(degrade_ye) then
2223         j_end = jde-1
2224         j_end_f = jde-1
2225       ENDIF
2226
2227 !  compute fluxes
2228 !  specified uses upstream normal wind at boundaries
2229
2230     jp0 = 1
2231     jp1 = 2
2232
2233     DO j = j_start, j_end+1
2234
2235       IF ((j == j_start) .and. degrade_ys) THEN
2236         DO k = kts,ktf
2237         DO i = i_start, i_end
2238                 vb = v(i,k,j-1)
2239                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
2240                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
2241                                  *(v(i,k,j)+vb)
2242         ENDDO
2243         ENDDO
2244       ELSE IF ((j == j_end+1) .and. degrade_ye) THEN
2245         DO k = kts, ktf
2246         DO i = i_start, i_end
2247                 vb = v(i,k,j)
2248                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
2249                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
2250                                  *(vb+v(i,k,j-1))
2251         ENDDO
2252         ENDDO
2253       ELSE
2254         DO k = kts, ktf
2255         DO i = i_start, i_end
2256           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2257           fqy( i,k,jp1 ) = vel*flux4( v(i,k,j-2), v(i,k,j-1),  &
2258                                      v(i,k,j  ), v(i,k,j+1),  &
2259                                       vel                        )
2260         ENDDO
2261         ENDDO
2262       END IF
2263
2264       ! Comments on polar boundary conditions
2265       ! No advection over the poles means tendencies (held from jds [S. pole]
2266       ! to jde [N pole], i.e., on v grid) must be zero at poles
2267       ! [tendency(jds) and tendency(jde)=0]
2268       IF ( config_flags%polar .AND. (j == jds+1) ) THEN
2269         DO k=kts,ktf
2270         DO i = i_start, i_end
2271           tendency(i,k,j-1) = 0.
2272         END DO
2273         END DO
2274       ! If j_end were set to jde in a special if statement apart from
2275       ! degrade_ye, then we would hit the next conditional.  But since
2276       ! we want the tendency to be zero anyway, not looping to jde+1
2277       ! will produce the same effect.
2278       ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
2279         DO k=kts,ktf
2280         DO i = i_start, i_end
2281           tendency(i,k,j-1) = 0.
2282         END DO
2283         END DO
2284       ELSE  ! Normal code
2285
2286       IF( j > j_start) THEN
2287         DO k = kts, ktf
2288         DO i = i_start, i_end
2289             mrdy=msfvy(i,j-1)*rdy     ! ADT eqn 45, 2nd term on RHS
2290             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
2291         ENDDO
2292         ENDDO
2293
2294       END IF
2295
2296       END IF
2297
2298       jtmp = jp1
2299       jp1 = jp0
2300       jp0 = jtmp
2301
2302    ENDDO
2303
2304 !  next, x - flux divergence
2305
2306
2307       i_start = its
2308       i_end   = MIN(ite,ide-1)
2309
2310       j_start = jts
2311       j_end   = jte
2312       ! Polar boundary conditions are like open or specified
2313       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2314       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
2315
2316 !  3rd or 4th order flux has a 5 point stencil, so compute
2317 !  bounds so we can switch to second order flux close to the boundary
2318
2319       i_start_f = i_start
2320       i_end_f   = i_end+1
2321
2322       IF(degrade_xs) then
2323         i_start = ids+1
2324         i_start_f = i_start+1
2325       ENDIF
2326
2327       IF(degrade_xe) then
2328         i_end = ide-2
2329         i_end_f = ide-2
2330       ENDIF
2331
2332 !  compute fluxes
2333
2334       DO j = j_start, j_end
2335
2336 !  3rd or 4th order flux
2337
2338         DO k=kts,ktf
2339         DO i = i_start_f, i_end_f
2340           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2341           fqx( i, k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j),  &
2342                                   v(i  ,k,j), v(i+1,k,j),  &
2343                                   vel                     )
2344         ENDDO
2345         ENDDO
2346
2347 !  second order flux close to boundaries (if not periodic or symmetric)
2348
2349         IF( degrade_xs ) THEN
2350           DO k=kts,ktf
2351             fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) &
2352                    *(v(i_start,k,j)+v(i_start-1,k,j))
2353           ENDDO
2354         ENDIF
2355
2356         IF( degrade_xe ) THEN
2357           DO k=kts,ktf
2358             fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
2359                    *(v(i_end+1,k,j)+v(i_end,k,j))
2360           ENDDO
2361         ENDIF
2362
2363 !  x flux-divergence into tendency
2364
2365         DO k=kts,ktf
2366         DO i = i_start, i_end
2367             mrdx=msfvy(i,j)*rdx       ! ADT eqn 45, 1st term on RHS
2368             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2369         ENDDO
2370         ENDDO
2371
2372       ENDDO
2373
2374    ELSE IF( horz_order == 3 ) THEN
2375
2376 !  determine boundary mods for flux operators
2377 !  We degrade the flux operators from 3rd/4th order
2378 !   to second order one gridpoint in from the boundaries for
2379 !   all boundary conditions except periodic and symmetry - these
2380 !   conditions have boundary zone data fill for correct application
2381 !   of the higher order flux stencils
2382
2383    degrade_xs = .true.
2384    degrade_xe = .true.
2385    degrade_ys = .true.
2386    degrade_ye = .true.
2387
2388    IF( config_flags%periodic_x   .or. &
2389        config_flags%symmetric_xs .or. &
2390        (its > ids+2)                ) degrade_xs = .false.
2391    IF( config_flags%periodic_x   .or. &
2392        config_flags%symmetric_xe .or. &
2393        (ite < ide-2)                ) degrade_xe = .false.
2394    IF( config_flags%periodic_y   .or. &
2395        config_flags%symmetric_ys .or. &
2396        (jts > jds+2)                ) degrade_ys = .false.
2397    IF( config_flags%periodic_y   .or. &
2398        config_flags%symmetric_ye .or. &
2399        (jte < jde-2)                ) degrade_ye = .false.
2400
2401 !--------------- y - advection first
2402
2403
2404    ktf=MIN(kte,kde-1)
2405
2406       i_start = its
2407       i_end   = MIN(ite,ide-1)
2408       j_start = jts
2409       j_end   = jte
2410
2411 !  3rd or 4th order flux has a 5 point stencil, so compute
2412 !  bounds so we can switch to second order flux close to the boundary
2413
2414       j_start_f = j_start
2415       j_end_f   = j_end+1
2416
2417 !CJM May not work with tiling because defined in terms of domain dims
2418       IF(degrade_ys) then
2419         j_start = jds+1
2420         j_start_f = j_start+1
2421       ENDIF
2422
2423       IF(degrade_ye) then
2424         j_end = jde-1
2425         j_end_f = jde-1
2426       ENDIF
2427
2428 !  compute fluxes
2429 !  specified uses upstream normal wind at boundaries
2430
2431     jp0 = 1
2432     jp1 = 2
2433
2434     DO j = j_start, j_end+1
2435
2436       IF ((j == j_start) .and. degrade_ys) THEN
2437         DO k = kts,ktf
2438         DO i = i_start, i_end
2439                 vb = v(i,k,j-1)
2440                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
2441                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
2442                                  *(v(i,k,j)+vb)
2443         ENDDO
2444         ENDDO
2445       ELSE IF ((j == j_end+1) .and. degrade_ye) THEN
2446         DO k = kts, ktf
2447         DO i = i_start, i_end
2448                 vb = v(i,k,j)
2449                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
2450                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
2451                                  *(vb+v(i,k,j-1))
2452         ENDDO
2453         ENDDO
2454       ELSE
2455         DO k = kts, ktf
2456         DO i = i_start, i_end
2457           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2458           fqy( i,k,jp1 ) = vel*flux3( v(i,k,j-2), v(i,k,j-1),  &
2459                                      v(i,k,j  ), v(i,k,j+1),  &
2460                                       vel                        )
2461         ENDDO
2462         ENDDO
2463       END IF
2464
2465       ! Comments on polar boundary conditions
2466       ! No advection over the poles means tendencies (held from jds [S. pole]
2467       ! to jde [N pole], i.e., on v grid) must be zero at poles
2468       ! [tendency(jds) and tendency(jde)=0]
2469       IF ( config_flags%polar .AND. (j == jds+1) ) THEN
2470         DO k=kts,ktf
2471         DO i = i_start, i_end
2472           tendency(i,k,j-1) = 0.
2473         END DO
2474         END DO
2475       ! If j_end were set to jde in a special if statement apart from
2476       ! degrade_ye, then we would hit the next conditional.  But since
2477       ! we want the tendency to be zero anyway, not looping to jde+1
2478       ! will produce the same effect.
2479       ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
2480         DO k=kts,ktf
2481         DO i = i_start, i_end
2482           tendency(i,k,j-1) = 0.
2483         END DO
2484         END DO
2485       ELSE  ! Normal code
2486
2487       IF( j > j_start) THEN
2488         DO k = kts, ktf
2489         DO i = i_start, i_end
2490             mrdy=msfvy(i,j-1)*rdy     ! ADT eqn 45, 2nd term on RHS
2491             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
2492         ENDDO
2493         ENDDO
2494
2495       END IF
2496
2497       END IF
2498
2499       jtmp = jp1
2500       jp1 = jp0
2501       jp0 = jtmp
2502
2503    ENDDO
2504
2505 !  next, x - flux divergence
2506
2507
2508       i_start = its
2509       i_end   = MIN(ite,ide-1)
2510
2511       j_start = jts
2512       j_end   = jte
2513       ! Polar boundary conditions are like open or specified
2514       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2515       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
2516
2517 !  3rd or 4th order flux has a 5 point stencil, so compute
2518 !  bounds so we can switch to second order flux close to the boundary
2519
2520       i_start_f = i_start
2521       i_end_f   = i_end+1
2522
2523       IF(degrade_xs) then
2524         i_start = ids+1
2525         i_start_f = i_start+1
2526       ENDIF
2527
2528       IF(degrade_xe) then
2529         i_end = ide-2
2530         i_end_f = ide-2
2531       ENDIF
2532
2533 !  compute fluxes
2534
2535       DO j = j_start, j_end
2536
2537 !  3rd or 4th order flux
2538
2539         DO k=kts,ktf
2540         DO i = i_start_f, i_end_f
2541           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2542           fqx( i, k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
2543                                   v(i  ,k,j), v(i+1,k,j),  &
2544                                   vel                     )
2545         ENDDO
2546         ENDDO
2547
2548 !  second order flux close to boundaries (if not periodic or symmetric)
2549
2550         IF( degrade_xs ) THEN
2551           DO k=kts,ktf
2552             fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) &
2553                    *(v(i_start,k,j)+v(i_start-1,k,j))
2554           ENDDO
2555         ENDIF
2556
2557         IF( degrade_xe ) THEN
2558           DO k=kts,ktf
2559             fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
2560                    *(v(i_end+1,k,j)+v(i_end,k,j))
2561           ENDDO
2562         ENDIF
2563
2564 !  x flux-divergence into tendency
2565
2566         DO k=kts,ktf
2567         DO i = i_start, i_end
2568             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
2569             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2570         ENDDO
2571         ENDDO
2572
2573       ENDDO
2574
2575    ELSE IF( horz_order == 2 ) THEN
2576
2577
2578       i_start = its
2579       i_end   = MIN(ite,ide-1)
2580       j_start = jts
2581       j_end   = jte
2582
2583       IF ( config_flags%open_ys ) j_start = MAX(jds+1,jts)
2584       IF ( config_flags%open_ye ) j_end   = MIN(jde-1,jte)
2585       IF ( specified ) j_start = MAX(jds+2,jts)
2586       IF ( specified ) j_end   = MIN(jde-2,jte)
2587       IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
2588       IF ( config_flags%polar ) j_end   = MIN(jde-1,jte)
2589
2590       DO j = j_start, j_end
2591       DO k=kts,ktf
2592       DO i = i_start, i_end
2593
2594          mrdy=msfvy(i,j)*rdy          ! ADT eqn 45, 2nd term on RHS
2595
2596             tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2597                             *((rv(i,k,j+1)+rv(i,k,j  ))*(v(i,k,j+1)+v(i,k,j  )) &
2598                              -(rv(i,k,j  )+rv(i,k,j-1))*(v(i,k,j  )+v(i,k,j-1)))
2599
2600       ENDDO
2601       ENDDO
2602       ENDDO
2603
2604       ! Comments on polar boundary conditions
2605       ! tendencies = 0 at poles, and polar points do not contribute at points
2606       ! next to poles
2607       IF (config_flags%polar) THEN
2608          IF (jts == jds) THEN
2609             DO k=kts,ktf
2610             DO i = i_start, i_end
2611                tendency(i,k,jds) = 0.
2612             END DO
2613             END DO
2614          END IF
2615          IF (jte == jde) THEN
2616             DO k=kts,ktf
2617             DO i = i_start, i_end
2618                tendency(i,k,jde) = 0.
2619             END DO
2620             END DO
2621          END IF
2622       END IF
2623
2624 !  specified uses upstream normal wind at boundaries
2625
2626       IF ( specified .AND. jts .LE. jds+1 ) THEN
2627         j = jds+1
2628         DO k=kts,ktf
2629         DO i = i_start, i_end
2630            mrdy=msfvy(i,j)*rdy       ! ADT eqn 45, 2nd term on RHS
2631            vb = v(i,k,j-1)
2632            IF (v(i,k,j) .LT. 0.) vb = v(i,k,j)
2633
2634               tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2635                               *((rv(i,k,j+1)+rv(i,k,j  ))*(v(i,k,j+1)+v(i,k,j  )) &
2636                                -(rv(i,k,j  )+rv(i,k,j-1))*(v(i,k,j  )+vb))
2637
2638         ENDDO
2639         ENDDO
2640       ENDIF
2641
2642       IF ( specified .AND. jte .GE. jde-1 ) THEN
2643         j = jde-1
2644         DO k=kts,ktf
2645         DO i = i_start, i_end
2646
2647            mrdy=msfvy(i,j)*rdy       ! ADT eqn 45, 2nd term on RHS
2648            vb = v(i,k,j+1)
2649            IF (v(i,k,j) .GT. 0.) vb = v(i,k,j)
2650
2651               tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2652                               *((rv(i,k,j+1)+rv(i,k,j  ))*(vb+v(i,k,j  )) &
2653                                -(rv(i,k,j  )+rv(i,k,j-1))*(v(i,k,j  )+v(i,k,j-1)))
2654
2655         ENDDO
2656         ENDDO
2657       ENDIF
2658
2659       IF ( .NOT. config_flags%periodic_x ) THEN
2660         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
2661         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
2662       ENDIF
2663       IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
2664       IF ( config_flags%polar ) j_end   = MIN(jde-1,jte)
2665
2666       DO j = j_start, j_end
2667       DO k=kts,ktf
2668       DO i = i_start, i_end
2669
2670          mrdx=msfvy(i,j)*rdx         ! ADT eqn 45, 1st term on RHS
2671
2672             tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
2673                             *((ru(i+1,k,j)+ru(i+1,k,j-1))*(v(i+1,k,j)+v(i  ,k,j)) &
2674                              -(ru(i  ,k,j)+ru(i  ,k,j-1))*(v(i  ,k,j)+v(i-1,k,j)))
2675
2676       ENDDO
2677       ENDDO
2678       ENDDO
2679
2680    ELSE IF ( horz_order == 0 ) THEN
2681
2682       ! Just in case we want to turn horizontal advection off, we can do it
2683
2684   ELSE
2685
2686
2687       WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: h_order not known ',horz_order
2688       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
2689
2690    ENDIF horizontal_order_test
2691
2692    !  Comments on polar boundary condition
2693    !  Force tendency=0 at NP and SP
2694    !  We keep setting this everywhere, but it can't hurt...
2695    IF ( config_flags%polar .AND. (jts == jds) ) THEN
2696       DO i=its,ite
2697       DO k=kts,ktf
2698          tendency(i,k,jts)=0.
2699       END DO
2700       END DO
2701    END IF
2702    IF ( config_flags%polar .AND. (jte == jde) ) THEN
2703       DO i=its,ite
2704       DO k=kts,ktf
2705          tendency(i,k,jte)=0.
2706       END DO
2707       END DO
2708    END IF
2709
2710 !  radiative lateral boundary condition in y for normal velocity (v)
2711
2712       IF ( (config_flags%open_ys) .and. jts == jds ) THEN
2713
2714         i_start = its
2715         i_end   = MIN(ite,ide-1)
2716
2717         DO i = i_start, i_end
2718         DO k = kts, ktf
2719           vb = MIN(rv(i,k,jts)-cb*(c1(k)*mut(i,jts)+c2(k)), 0.)
2720           tendency(i,k,jts) = tendency(i,k,jts)                    &
2721                       - rdy*vb*(v_old(i,k,jts+1) - v_old(i,k,jts))
2722         ENDDO
2723         ENDDO
2724
2725       ENDIF
2726
2727       IF ( (config_flags%open_ye) .and. jte == jde ) THEN
2728
2729         i_start = its
2730         i_end   = MIN(ite,ide-1)
2731
2732         DO i = i_start, i_end
2733         DO k = kts, ktf
2734           vb = MAX(rv(i,k,jte)+cb*(c1(k)*mut(i,jte-1)+c2(k)), 0.)
2735           tendency(i,k,jte) = tendency(i,k,jte)                    &
2736                       - rdy*vb*(v_old(i,k,jte) - v_old(i,k,jte-1))
2737         ENDDO
2738         ENDDO
2739
2740       ENDIF
2741
2742 !  pick up the rest of the horizontal radiation boundary conditions.
2743 !  (these are the computations that don't require 'cb'.
2744 !  first, set to index ranges
2745
2746       j_start = jts
2747       j_end   = MIN(jte,jde)
2748
2749       jmin    = jds
2750       jmax    = jde-1
2751
2752       IF (config_flags%open_ys) THEN
2753           j_start = MAX(jds+1, jts)
2754           jmin = jds
2755       ENDIF
2756       IF (config_flags%open_ye) THEN
2757           j_end = MIN(jte,jde-1)
2758           jmax = jde-1
2759       ENDIF
2760
2761 !  compute x (u) conditions for v, w, or scalar
2762
2763    IF( (config_flags%open_xs) .and. (its == ids)) THEN
2764
2765       DO j = j_start, j_end
2766
2767          mrdx=msfvy(its,j)*rdx       ! ADT eqn 45, 1st term on RHS
2768          jp = MIN( jmax, j   )
2769          jm = MAX( jmin, j-1 )
2770
2771          DO k=kts,ktf
2772
2773           uw = 0.5*(ru(its,k,jp)+ru(its,k,jm))
2774           ub = MIN( uw, 0. )
2775           dup =  ru(its+1,k,jp)-ru(its,k,jp)
2776           dum =  ru(its+1,k,jm)-ru(its,k,jm)
2777           tendency(its,k,j)=tendency(its,k,j)-mrdx*(               &
2778                             ub*(v_old(its+1,k,j)-v_old(its,k,j))   &
2779                            +0.5*v(its,k,j)*(dup+dum))
2780          ENDDO
2781       ENDDO
2782
2783    ENDIF
2784
2785    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
2786       DO j = j_start, j_end
2787
2788          mrdx=msfvy(ite-1,j)*rdx     ! ADT eqn 45, 1st term on RHS
2789          jp = MIN( jmax, j   )
2790          jm = MAX( jmin, j-1 )
2791
2792          DO k=kts,ktf
2793
2794           uw = 0.5*(ru(ite,k,jp)+ru(ite,k,jm))
2795           ub = MAX( uw, 0. )
2796           dup = ru(ite,k,jp)-ru(ite-1,k,jp)
2797           dum = ru(ite,k,jm)-ru(ite-1,k,jm)
2798
2799 !          tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
2800 !                            ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
2801 !                           +0.5*v(ite-1,k,j)*                         &
2802 !                                  ( ru(ite,k,jp)-ru(ite-1,k,jp)       &
2803 !                                   +ru(ite,k,jm)-ru(ite-1,k,jm))     )
2804           tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
2805                             ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
2806                            +0.5*v(ite-1,k,j)*(dup+dum))
2807
2808          ENDDO
2809       ENDDO
2810
2811    ENDIF
2812
2813 !-------------------- vertical advection
2814 !     ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
2815 !     Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
2816 !     We therefore need to make a correction for advect_v
2817 !     since 'my' (map scale factor in y direction) isn't a function of z,
2818 !     we can do this using *(my/mx) (see eqn. 45 for example)
2819
2820
2821     i_start = its
2822     i_end   = MIN(ite,ide-1)
2823     j_start = jts
2824     j_end   = jte
2825
2826     DO i = i_start, i_end
2827        vflux(i,kts)=0.
2828        vflux(i,kte)=0.
2829     ENDDO
2830
2831     ! Polar boundary conditions are like open or specified
2832     ! We don't want to calculate vertical v tendencies at the N or S pole
2833     IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2834     IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
2835
2836     vert_order_test : IF (vert_order == 6) THEN
2837
2838       DO j = j_start, j_end
2839
2840
2841          DO k=kts+3,ktf-2
2842          DO i = i_start, i_end
2843            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2844            vflux(i,k) = vel*flux6(                       &
2845                    v(i,k-3,j), v(i,k-2,j), v(i,k-1,j),       &
2846                    v(i,k  ,j), v(i,k+1,j), v(i,k+2,j),  -vel )
2847          ENDDO
2848          ENDDO
2849
2850          DO i = i_start, i_end
2851            k=kts+1
2852            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2853                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2854            k = kts+2
2855            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2856            vflux(i,k) = vel*flux4(       &
2857                    v(i,k-2,j), v(i,k-1,j),   &
2858                    v(i,k  ,j), v(i,k+1,j), -vel )
2859            k = ktf-1
2860            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2861            vflux(i,k) = vel*flux4(       &
2862                    v(i,k-2,j), v(i,k-1,j),   &
2863                    v(i,k  ,j), v(i,k+1,j), -vel )
2864            k=ktf
2865            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2866                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2867
2868          ENDDO
2869
2870
2871          DO k=kts,ktf
2872          DO i = i_start, i_end
2873             ! We are calculating vertical fluxes on v points,
2874             ! so we must mean msf_v_x/y variables
2875             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
2876          ENDDO
2877          ENDDO
2878
2879       ENDDO
2880
2881    ELSE IF (vert_order == 5) THEN
2882
2883       DO j = j_start, j_end
2884
2885
2886          DO k=kts+3,ktf-2
2887          DO i = i_start, i_end
2888            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2889            vflux(i,k) = vel*flux5(                       &
2890                    v(i,k-3,j), v(i,k-2,j), v(i,k-1,j),       &
2891                    v(i,k  ,j), v(i,k+1,j), v(i,k+2,j),  -vel )
2892          ENDDO
2893          ENDDO
2894
2895          DO i = i_start, i_end
2896            k=kts+1
2897            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2898                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2899            k = kts+2
2900            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2901            vflux(i,k) = vel*flux3(       &
2902                    v(i,k-2,j), v(i,k-1,j),   &
2903                    v(i,k  ,j), v(i,k+1,j), -vel )
2904            k = ktf-1
2905            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2906            vflux(i,k) = vel*flux3(       &
2907                    v(i,k-2,j), v(i,k-1,j),   &
2908                    v(i,k  ,j), v(i,k+1,j), -vel )
2909            k=ktf
2910            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2911                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2912
2913          ENDDO
2914
2915
2916          DO k=kts,ktf
2917          DO i = i_start, i_end
2918             ! We are calculating vertical fluxes on v points,
2919             ! so we must mean msf_v_x/y variables
2920             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
2921          ENDDO
2922          ENDDO
2923
2924       ENDDO
2925
2926     ELSE IF (vert_order == 4) THEN
2927
2928       DO j = j_start, j_end
2929
2930
2931          DO k=kts+2,ktf-1
2932          DO i = i_start, i_end
2933            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2934            vflux(i,k) = vel*flux4(               &
2935                    v(i,k-2,j), v(i,k-1,j),       &
2936                    v(i,k  ,j), v(i,k+1,j), -vel )
2937          ENDDO
2938          ENDDO
2939
2940          DO i = i_start, i_end
2941            k=kts+1
2942            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2943                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2944            k=ktf
2945            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2946                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2947
2948          ENDDO
2949
2950
2951          DO k=kts,ktf
2952          DO i = i_start, i_end
2953             ! We are calculating vertical fluxes on v points,
2954             ! so we must mean msf_v_x/y variables
2955             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
2956          ENDDO
2957          ENDDO
2958
2959       ENDDO
2960
2961     ELSE IF (vert_order == 3) THEN
2962
2963       DO j = j_start, j_end
2964
2965
2966          DO k=kts+2,ktf-1
2967          DO i = i_start, i_end
2968            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2969            vflux(i,k) = vel*flux3(               &
2970                    v(i,k-2,j), v(i,k-1,j),       &
2971                    v(i,k  ,j), v(i,k+1,j), -vel )
2972          ENDDO
2973          ENDDO
2974
2975          DO i = i_start, i_end
2976            k=kts+1
2977            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2978                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2979            k=ktf
2980            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2981                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2982
2983          ENDDO
2984
2985
2986          DO k=kts,ktf
2987          DO i = i_start, i_end
2988             ! We are calculating vertical fluxes on v points,
2989             ! so we must mean msf_v_x/y variables
2990             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
2991          ENDDO
2992          ENDDO
2993
2994       ENDDO
2995
2996
2997     ELSE IF (vert_order == 2) THEN
2998
2999    DO j = j_start, j_end
3000       DO k=kts+1,ktf
3001       DO i = i_start, i_end
3002
3003             vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
3004                                     *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
3005       ENDDO
3006       ENDDO
3007
3008       DO k=kts,ktf
3009       DO i = i_start, i_end
3010             ! We are calculating vertical fluxes on v points,
3011             ! so we must mean msf_v_x/y variables
3012             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
3013       ENDDO
3014       ENDDO
3015    ENDDO
3016
3017    ELSE
3018
3019       WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: v_order not known ',vert_order
3020       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
3021
3022    ENDIF vert_order_test
3023
3024 END SUBROUTINE advect_v
3025
3026 !-------------------------------------------------------------------
3027
3028 #endif
3029 SUBROUTINE advect_scalar   ( field, field_old, tendency,    &
3030                              ru, rv, rom,                   &
3031                              c1, c2,                        &
3032                              mut, time_step, config_flags,  &
3033                              msfux, msfuy, msfvx, msfvy,    &
3034                              msftx, msfty,                  &
3035                              fzm, fzp,                      &
3036                              rdx, rdy, rdzw,                &
3037                              ids, ide, jds, jde, kds, kde,  &
3038                              ims, ime, jms, jme, kms, kme,  &
3039                              its, ite, jts, jte, kts, kte  )
3040
3041    IMPLICIT NONE
3042
3043    ! Input data
3044
3045    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
3046
3047    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
3048                                               ims, ime, jms, jme, kms, kme, &
3049                                               its, ite, jts, jte, kts, kte
3050
3051    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
3052                                                                       field_old, &
3053                                                                       ru,    &
3054                                                                       rv,    &
3055                                                                       rom
3056
3057    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
3058    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
3059
3060    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
3061                                                                     msfuy,  &
3062                                                                     msfvx,  &
3063                                                                     msfvy,  &
3064                                                                     msftx,  &
3065                                                                     msfty
3066
3067    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
3068                                                                   fzp,  &
3069                                                                   rdzw, &
3070                                                                   c1,   &
3071                                                                   c2
3072
3073    REAL ,                                        INTENT(IN   ) :: rdx,  &
3074                                                                   rdy
3075    INTEGER ,                                     INTENT(IN   ) :: time_step
3076
3077
3078    ! Local data
3079
3080    INTEGER :: i, j, k, itf, jtf, ktf
3081    INTEGER :: i_start, i_end, j_start, j_end
3082    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
3083    INTEGER :: jmin, jmax, jp, jm, imin, imax
3084
3085    REAL    :: mrdx, mrdy, ub, vb, uw, vw
3086    REAL , DIMENSION(its:ite, kts:kte) :: vflux
3087
3088
3089    REAL,  DIMENSION( its:ite+1, kts:kte  ) :: fqx
3090    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
3091
3092    INTEGER :: horz_order, vert_order
3093
3094    LOGICAL :: degrade_xs, degrade_ys
3095    LOGICAL :: degrade_xe, degrade_ye
3096
3097    INTEGER :: jp1, jp0, jtmp
3098
3099
3100 ! definition of flux operators, 3rd, 4th, 5th or 6th order
3101
3102    REAL    :: flux3, flux4, flux5, flux6
3103    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
3104
3105       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
3106           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
3107
3108       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
3109            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
3110            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
3111
3112       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
3113           ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)                  &
3114             +(q_ip2+q_im3) )/60.0
3115
3116       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
3117            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
3118             -sign(1,time_step)*sign(1.,ua)*(                    &
3119               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
3120
3121
3122    LOGICAL :: specified
3123
3124    specified = .false.
3125    if(config_flags%specified .or. config_flags%nested) specified = .true.
3126
3127 ! set order for the advection schemes
3128
3129   ktf=MIN(kte,kde-1)
3130   horz_order = config_flags%h_sca_adv_order
3131   vert_order = config_flags%v_sca_adv_order
3132
3133 !  begin with horizontal flux divergence
3134 !  here is the choice of flux operators
3135
3136
3137   horizontal_order_test : IF( horz_order == 6 ) THEN
3138
3139 !  determine boundary mods for flux operators
3140 !  We degrade the flux operators from 3rd/4th order
3141 !   to second order one gridpoint in from the boundaries for
3142 !   all boundary conditions except periodic and symmetry - these
3143 !   conditions have boundary zone data fill for correct application
3144 !   of the higher order flux stencils
3145
3146    degrade_xs = .true.
3147    degrade_xe = .true.
3148    degrade_ys = .true.
3149    degrade_ye = .true.
3150
3151    IF( config_flags%periodic_x   .or. &
3152        config_flags%symmetric_xs .or. &
3153        (its > ids+3)                ) degrade_xs = .false.
3154    IF( config_flags%periodic_x   .or. &
3155        config_flags%symmetric_xe .or. &
3156        (ite < ide-3)                ) degrade_xe = .false.
3157    IF( config_flags%periodic_y   .or. &
3158        config_flags%symmetric_ys .or. &
3159        (jts > jds+3)                ) degrade_ys = .false.
3160    IF( config_flags%periodic_y   .or. &
3161        config_flags%symmetric_ye .or. &
3162        (jte < jde-4)                ) degrade_ye = .false.
3163
3164 !--------------- y - advection first
3165
3166       ktf=MIN(kte,kde-1)
3167       i_start = its
3168       i_end   = MIN(ite,ide-1)
3169       j_start = jts
3170       j_end   = MIN(jte,jde-1)
3171
3172 !  higher order flux has a 5 or 7 point stencil, so compute
3173 !  bounds so we can switch to second order flux close to the boundary
3174
3175       j_start_f = j_start
3176       j_end_f   = j_end+1
3177
3178       IF(degrade_ys) then
3179         j_start = MAX(jts,jds+1)
3180         j_start_f = jds+3
3181       ENDIF
3182
3183       IF(degrade_ye) then
3184         j_end = MIN(jte,jde-2)
3185         j_end_f = jde-3
3186       ENDIF
3187
3188       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3189
3190 !  compute fluxes, 5th or 6th order
3191
3192      jp1 = 2
3193      jp0 = 1
3194
3195      j_loop_y_flux_6 : DO j = j_start, j_end+1
3196
3197       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
3198
3199         DO k=kts,ktf
3200         DO i = i_start, i_end
3201           vel = rv(i,k,j)
3202           fqy( i, k, jp1 ) = vel*flux6(                                &
3203                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
3204                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
3205         ENDDO
3206         ENDDO
3207
3208
3209       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
3210
3211             DO k=kts,ktf
3212             DO i = i_start, i_end
3213               fqy(i,k, jp1) = 0.5*rv(i,k,j)*          &
3214                      (field(i,k,j)+field(i,k,j-1))
3215
3216             ENDDO
3217             ENDDO
3218
3219      ELSE IF  ( j == jds+2 ) THEN  ! 4th order flux 2 in from south boundary
3220
3221             DO k=kts,ktf
3222             DO i = i_start, i_end
3223               vel = rv(i,k,j)
3224               fqy( i, k, jp1 ) = vel*flux4(              &
3225                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
3226             ENDDO
3227             ENDDO
3228
3229      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
3230
3231             DO k=kts,ktf
3232             DO i = i_start, i_end
3233               fqy(i, k, jp1) = 0.5*rv(i,k,j)*      &
3234                      (field(i,k,j)+field(i,k,j-1))
3235             ENDDO
3236             ENDDO
3237
3238      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
3239
3240             DO k=kts,ktf
3241             DO i = i_start, i_end
3242               vel = rv(i,k,j)
3243               fqy( i, k, jp1) = vel*flux4(             &
3244                    field(i,k,j-2),field(i,k,j-1),    &
3245                    field(i,k,j),field(i,k,j+1),vel )
3246             ENDDO
3247             ENDDO
3248
3249      ENDIF
3250
3251 !  y flux-divergence into tendency
3252
3253         ! Comments on polar boundary conditions
3254         ! Same process as for advect_u - tendencies run from jds to jde-1
3255         ! (latitudes are as for u grid, longitudes are displaced)
3256         ! Therefore: flow is only from one side for points next to poles
3257         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3258           DO k=kts,ktf
3259           DO i = i_start, i_end
3260             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3261             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3262           END DO
3263           END DO
3264         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3265           DO k=kts,ktf
3266           DO i = i_start, i_end
3267             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3268             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3269           END DO
3270           END DO
3271         ELSE  ! normal code
3272
3273         IF(j > j_start) THEN
3274
3275           DO k=kts,ktf
3276           DO i = i_start, i_end
3277             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3278             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3279           ENDDO
3280           ENDDO
3281
3282         ENDIF
3283
3284         END IF
3285
3286         jtmp = jp1
3287         jp1 = jp0
3288         jp0 = jtmp
3289
3290       ENDDO j_loop_y_flux_6
3291
3292 !  next, x - flux divergence
3293
3294       i_start = its
3295       i_end   = MIN(ite,ide-1)
3296
3297       j_start = jts
3298       j_end   = MIN(jte,jde-1)
3299
3300 !  higher order flux has a 5 or 7 point stencil, so compute
3301 !  bounds so we can switch to second order flux close to the boundary
3302
3303       i_start_f = i_start
3304       i_end_f   = i_end+1
3305
3306       IF(degrade_xs) then
3307         i_start = MAX(ids+1,its)
3308 !        i_start_f = i_start+2
3309         i_start_f = MIN(i_start+2,ids+3)
3310       ENDIF
3311
3312       IF(degrade_xe) then
3313         i_end = MIN(ide-2,ite)
3314         i_end_f = ide-3
3315       ENDIF
3316
3317 !  compute fluxes
3318
3319       DO j = j_start, j_end
3320
3321 !  5th or 6th order flux
3322
3323         DO k=kts,ktf
3324         DO i = i_start_f, i_end_f
3325           vel = ru(i,k,j)
3326           fqx( i,k ) = vel*flux6( field(i-3,k,j), field(i-2,k,j),  &
3327                                          field(i-1,k,j), field(i  ,k,j),  &
3328                                          field(i+1,k,j), field(i+2,k,j),  &
3329                                          vel                             )
3330         ENDDO
3331         ENDDO
3332
3333 !  lower order fluxes close to boundaries (if not periodic or symmetric)
3334
3335         IF( degrade_xs ) THEN
3336
3337           DO i=i_start,i_start_f-1
3338
3339             IF(i == ids+1) THEN ! second order
3340               DO k=kts,ktf
3341                 fqx(i,k) = 0.5*(ru(i,k,j)) &
3342                        *(field(i,k,j)+field(i-1,k,j))
3343               ENDDO
3344             ENDIF
3345
3346             IF(i == ids+2) THEN  ! third order
3347               DO k=kts,ktf
3348                 vel = ru(i,k,j)
3349                 fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
3350                                               field(i  ,k,j), field(i+1,k,j),  &
3351                                               vel                     )
3352               ENDDO
3353             END IF
3354
3355           ENDDO
3356
3357         ENDIF
3358
3359         IF( degrade_xe ) THEN
3360
3361           DO i = i_end_f+1, i_end+1
3362
3363             IF( i == ide-1 ) THEN ! second order flux next to the boundary
3364               DO k=kts,ktf
3365                 fqx(i,k) = 0.5*(ru(i,k,j))      &
3366                        *(field(i,k,j)+field(i-1,k,j))
3367               ENDDO
3368            ENDIF
3369
3370            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
3371              DO k=kts,ktf
3372                vel = ru(i,k,j)
3373                fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
3374                                        field(i  ,k,j), field(i+1,k,j),  &
3375                                        vel                             )
3376              ENDDO
3377            ENDIF
3378
3379          ENDDO
3380
3381        ENDIF
3382
3383 !  x flux-divergence into tendency
3384
3385           DO k=kts,ktf
3386           DO i = i_start, i_end
3387             mrdx=msftx(i,j)*rdx      ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3388             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3389           ENDDO
3390           ENDDO
3391
3392       ENDDO
3393
3394   ELSE IF( horz_order == 5 ) THEN
3395
3396 !  determine boundary mods for flux operators
3397 !  We degrade the flux operators from 3rd/4th order
3398 !   to second order one gridpoint in from the boundaries for
3399 !   all boundary conditions except periodic and symmetry - these
3400 !   conditions have boundary zone data fill for correct application
3401 !   of the higher order flux stencils
3402
3403    degrade_xs = .true.
3404    degrade_xe = .true.
3405    degrade_ys = .true.
3406    degrade_ye = .true.
3407
3408    IF( config_flags%periodic_x   .or. &
3409        config_flags%symmetric_xs .or. &
3410        (its > ids+3)                ) degrade_xs = .false.
3411    IF( config_flags%periodic_x   .or. &
3412        config_flags%symmetric_xe .or. &
3413        (ite < ide-3)                ) degrade_xe = .false.
3414    IF( config_flags%periodic_y   .or. &
3415        config_flags%symmetric_ys .or. &
3416        (jts > jds+3)                ) degrade_ys = .false.
3417    IF( config_flags%periodic_y   .or. &
3418        config_flags%symmetric_ye .or. &
3419        (jte < jde-4)                ) degrade_ye = .false.
3420
3421 !--------------- y - advection first
3422
3423       ktf=MIN(kte,kde-1)
3424       i_start = its
3425       i_end   = MIN(ite,ide-1)
3426       j_start = jts
3427       j_end   = MIN(jte,jde-1)
3428
3429 !  higher order flux has a 5 or 7 point stencil, so compute
3430 !  bounds so we can switch to second order flux close to the boundary
3431
3432       j_start_f = j_start
3433       j_end_f   = j_end+1
3434
3435       IF(degrade_ys) then
3436         j_start = MAX(jts,jds+1)
3437         j_start_f = jds+3
3438       ENDIF
3439
3440       IF(degrade_ye) then
3441         j_end = MIN(jte,jde-2)
3442         j_end_f = jde-3
3443       ENDIF
3444
3445       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3446
3447 !  compute fluxes, 5th or 6th order
3448
3449      jp1 = 2
3450      jp0 = 1
3451
3452      j_loop_y_flux_5 : DO j = j_start, j_end+1
3453
3454       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
3455
3456         DO k=kts,ktf
3457         DO i = i_start, i_end
3458           vel = rv(i,k,j)
3459           fqy( i, k, jp1 ) = vel*flux5(                                &
3460                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
3461                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
3462         ENDDO
3463         ENDDO
3464
3465
3466       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
3467
3468             DO k=kts,ktf
3469             DO i = i_start, i_end
3470               fqy(i,k, jp1) = 0.5*rv(i,k,j)*          &
3471                      (field(i,k,j)+field(i,k,j-1))
3472
3473             ENDDO
3474             ENDDO
3475
3476      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
3477
3478             DO k=kts,ktf
3479             DO i = i_start, i_end
3480               vel = rv(i,k,j)
3481               fqy( i, k, jp1 ) = vel*flux3(              &
3482                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
3483             ENDDO
3484             ENDDO
3485
3486      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
3487
3488             DO k=kts,ktf
3489             DO i = i_start, i_end
3490               fqy(i, k, jp1) = 0.5*rv(i,k,j)*      &
3491                      (field(i,k,j)+field(i,k,j-1))
3492             ENDDO
3493             ENDDO
3494
3495      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
3496
3497             DO k=kts,ktf
3498             DO i = i_start, i_end
3499               vel = rv(i,k,j)
3500               fqy( i, k, jp1) = vel*flux3(             &
3501                    field(i,k,j-2),field(i,k,j-1),    &
3502                    field(i,k,j),field(i,k,j+1),vel )
3503             ENDDO
3504             ENDDO
3505
3506      ENDIF
3507
3508 !  y flux-divergence into tendency
3509
3510         ! Comments on polar boundary conditions
3511         ! Same process as for advect_u - tendencies run from jds to jde-1
3512         ! (latitudes are as for u grid, longitudes are displaced)
3513         ! Therefore: flow is only from one side for points next to poles
3514         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3515           DO k=kts,ktf
3516           DO i = i_start, i_end
3517             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3518             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3519           END DO
3520           END DO
3521         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3522           DO k=kts,ktf
3523           DO i = i_start, i_end
3524             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3525             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3526           END DO
3527           END DO
3528         ELSE  ! normal code
3529
3530         IF(j > j_start) THEN
3531
3532           DO k=kts,ktf
3533           DO i = i_start, i_end
3534             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3535             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3536           ENDDO
3537           ENDDO
3538
3539         ENDIF
3540
3541         END IF
3542
3543         jtmp = jp1
3544         jp1 = jp0
3545         jp0 = jtmp
3546
3547       ENDDO j_loop_y_flux_5
3548
3549 !  next, x - flux divergence
3550
3551       i_start = its
3552       i_end   = MIN(ite,ide-1)
3553
3554       j_start = jts
3555       j_end   = MIN(jte,jde-1)
3556
3557 !  higher order flux has a 5 or 7 point stencil, so compute
3558 !  bounds so we can switch to second order flux close to the boundary
3559
3560       i_start_f = i_start
3561       i_end_f   = i_end+1
3562
3563       IF(degrade_xs) then
3564         i_start = MAX(ids+1,its)
3565 !        i_start_f = i_start+2
3566         i_start_f = MIN(i_start+2,ids+3)
3567       ENDIF
3568
3569       IF(degrade_xe) then
3570         i_end = MIN(ide-2,ite)
3571         i_end_f = ide-3
3572       ENDIF
3573
3574 !  compute fluxes
3575
3576       DO j = j_start, j_end
3577
3578 !  5th or 6th order flux
3579
3580         DO k=kts,ktf
3581         DO i = i_start_f, i_end_f
3582           vel = ru(i,k,j)
3583           fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
3584                                          field(i-1,k,j), field(i  ,k,j),  &
3585                                          field(i+1,k,j), field(i+2,k,j),  &
3586                                          vel                             )
3587         ENDDO
3588         ENDDO
3589
3590 !  lower order fluxes close to boundaries (if not periodic or symmetric)
3591
3592         IF( degrade_xs ) THEN
3593
3594           DO i=i_start,i_start_f-1
3595
3596             IF(i == ids+1) THEN ! second order
3597               DO k=kts,ktf
3598                 fqx(i,k) = 0.5*(ru(i,k,j)) &
3599                        *(field(i,k,j)+field(i-1,k,j))
3600               ENDDO
3601             ENDIF
3602
3603             IF(i == ids+2) THEN  ! third order
3604               DO k=kts,ktf
3605                 vel = ru(i,k,j)
3606                 fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
3607                                               field(i  ,k,j), field(i+1,k,j),  &
3608                                               vel                     )
3609               ENDDO
3610             END IF
3611
3612           ENDDO
3613
3614         ENDIF
3615
3616         IF( degrade_xe ) THEN
3617
3618           DO i = i_end_f+1, i_end+1
3619
3620             IF( i == ide-1 ) THEN ! second order flux next to the boundary
3621               DO k=kts,ktf
3622                 fqx(i,k) = 0.5*(ru(i,k,j))      &
3623                        *(field(i,k,j)+field(i-1,k,j))
3624               ENDDO
3625            ENDIF
3626
3627            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
3628              DO k=kts,ktf
3629                vel = ru(i,k,j)
3630                fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
3631                                        field(i  ,k,j), field(i+1,k,j),  &
3632                                        vel                             )
3633              ENDDO
3634            ENDIF
3635
3636          ENDDO
3637
3638        ENDIF
3639
3640 !  x flux-divergence into tendency
3641
3642           DO k=kts,ktf
3643           DO i = i_start, i_end
3644             mrdx=msftx(i,j)*rdx      ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3645             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3646           ENDDO
3647           ENDDO
3648
3649       ENDDO
3650
3651
3652    ELSE IF( horz_order == 4 ) THEN
3653
3654    degrade_xs = .true.
3655    degrade_xe = .true.
3656    degrade_ys = .true.
3657    degrade_ye = .true.
3658
3659    IF( config_flags%periodic_x   .or. &
3660        config_flags%symmetric_xs .or. &
3661        (its > ids+2)                ) degrade_xs = .false.
3662    IF( config_flags%periodic_x   .or. &
3663        config_flags%symmetric_xe .or. &
3664        (ite < ide-2)                ) degrade_xe = .false.
3665    IF( config_flags%periodic_y   .or. &
3666        config_flags%symmetric_ys .or. &
3667        (jts > jds+2)                ) degrade_ys = .false.
3668    IF( config_flags%periodic_y   .or. &
3669        config_flags%symmetric_ye .or. &
3670        (jte < jde-3)                ) degrade_ye = .false.
3671
3672 !  begin flux computations
3673 !  start with x flux divergence
3674
3675    ktf=MIN(kte,kde-1)
3676
3677       i_start = its
3678       i_end   = MIN(ite,ide-1)
3679       j_start = jts
3680       j_end   = MIN(jte,jde-1)
3681
3682 !  3rd or 4th order flux has a 5 point stencil, so compute
3683 !  bounds so we can switch to second order flux close to the boundary
3684
3685       i_start_f = i_start
3686       i_end_f   = i_end+1
3687
3688       IF(degrade_xs) then
3689         i_start = ids+1
3690         i_start_f = i_start+1
3691       ENDIF
3692
3693       IF(degrade_xe) then
3694         i_end = ide-2
3695         i_end_f = ide-2
3696       ENDIF
3697
3698 !  compute fluxes
3699
3700       DO j = j_start, j_end
3701
3702 !  3rd or 4th order flux
3703
3704         DO k=kts,ktf
3705         DO i = i_start_f, i_end_f
3706
3707           fqx( i, k) = ru(i,k,j)*flux4( field(i-2,k,j), field(i-1,k,j),  &
3708                                         field(i  ,k,j), field(i+1,k,j),  &
3709                                         ru(i,k,j)                       )
3710         ENDDO
3711         ENDDO
3712
3713 !  second order flux close to boundaries (if not periodic or symmetric)
3714
3715         IF( degrade_xs ) THEN
3716           DO k=kts,ktf
3717             fqx(i_start, k) = 0.5*ru(i_start,k,j)             &
3718                    *(field(i_start,k,j)+field(i_start-1,k,j))
3719           ENDDO
3720         ENDIF
3721
3722         IF( degrade_xe ) THEN
3723           DO k=kts,ktf
3724             fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j)          &
3725                    *(field(i_end+1,k,j)+field(i_end,k,j))
3726           ENDDO
3727         ENDIF
3728
3729 !  x flux-divergence into tendency
3730
3731         DO k=kts,ktf
3732         DO i = i_start, i_end
3733           mrdx=msftx(i,j)*rdx        ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3734           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3735         ENDDO
3736         ENDDO
3737
3738       ENDDO
3739
3740
3741 !  next -> y flux divergence calculation
3742
3743       i_start = its
3744       i_end   = MIN(ite,ide-1)
3745       j_start = jts
3746       j_end   = MIN(jte,jde-1)
3747
3748 !  3rd or 4th order flux has a 5 point stencil, so compute
3749 !  bounds so we can switch to second order flux close to the boundary
3750
3751       j_start_f = j_start
3752       j_end_f   = j_end+1
3753
3754       IF(degrade_ys) then
3755         j_start = jds+1
3756         j_start_f = j_start+1
3757       ENDIF
3758
3759       IF(degrade_ye) then
3760         j_end = jde-2
3761         j_end_f = jde-2
3762       ENDIF
3763
3764       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3765
3766     jp1 = 2
3767     jp0 = 1
3768
3769   DO j = j_start, j_end+1
3770
3771     IF ((j < j_start_f) .and. degrade_ys) THEN
3772       DO k = kts, ktf
3773       DO i = i_start, i_end
3774          fqy(i,k,jp1) = 0.5*rv(i,k,j_start)             &
3775                 *(field(i,k,j_start)+field(i,k,j_start-1))
3776       ENDDO
3777       ENDDO
3778     ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
3779       DO k = kts, ktf
3780       DO i = i_start, i_end
3781          ! Assumes j>j_end_f is ONLY j_end+1 ...
3782 !         fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1)          &
3783 !                *(field(i,k,j_end+1)+field(i,k,j_end))
3784          fqy(i,k,jp1) = 0.5*rv(i,k,j)          &
3785                 *(field(i,k,j)+field(i,k,j-1))
3786       ENDDO
3787       ENDDO
3788     ELSE
3789 !  3rd or 4th order flux
3790       DO k = kts, ktf
3791       DO i = i_start, i_end
3792          fqy( i, k, jp1 ) = rv(i,k,j)*flux4( field(i,k,j-2), field(i,k,j-1),  &
3793                                             field(i,k,j  ), field(i,k,j+1),  &
3794                                             rv(i,k,j)                       )
3795       ENDDO
3796       ENDDO
3797     END IF
3798
3799 !  y flux-divergence into tendency
3800
3801     ! Comments on polar boundary conditions
3802     ! Same process as for advect_u - tendencies run from jds to jde-1
3803     ! (latitudes are as for u grid, longitudes are displaced)
3804     ! Therefore: flow is only from one side for points next to poles
3805     IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3806       DO k=kts,ktf
3807       DO i = i_start, i_end
3808         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3809         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3810       END DO
3811       END DO
3812     ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3813       DO k=kts,ktf
3814       DO i = i_start, i_end
3815         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3816         tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3817       END DO
3818       END DO
3819     ELSE  ! normal code
3820
3821     IF ( j > j_start ) THEN
3822
3823       DO k=kts,ktf
3824       DO i = i_start, i_end
3825         mrdy=msftx(i,j-1)*rdy        ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3826         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3827       ENDDO
3828       ENDDO
3829
3830     END IF
3831
3832     END IF
3833
3834     jtmp = jp1
3835     jp1 = jp0
3836     jp0 = jtmp
3837
3838   ENDDO
3839
3840
3841    ELSE IF( horz_order == 3 ) THEN
3842
3843    degrade_xs = .true.
3844    degrade_xe = .true.
3845    degrade_ys = .true.
3846    degrade_ye = .true.
3847
3848    IF( config_flags%periodic_x   .or. &
3849        config_flags%symmetric_xs .or. &
3850        (its > ids+2)                ) degrade_xs = .false.
3851    IF( config_flags%periodic_x   .or. &
3852        config_flags%symmetric_xe .or. &
3853        (ite < ide-2)                ) degrade_xe = .false.
3854    IF( config_flags%periodic_y   .or. &
3855        config_flags%symmetric_ys .or. &
3856        (jts > jds+2)                ) degrade_ys = .false.
3857    IF( config_flags%periodic_y   .or. &
3858        config_flags%symmetric_ye .or. &
3859        (jte < jde-3)                ) degrade_ye = .false.
3860
3861 !  begin flux computations
3862 !  start with x flux divergence
3863
3864    ktf=MIN(kte,kde-1)
3865
3866       i_start = its
3867       i_end   = MIN(ite,ide-1)
3868       j_start = jts
3869       j_end   = MIN(jte,jde-1)
3870
3871 !  3rd or 4th order flux has a 5 point stencil, so compute
3872 !  bounds so we can switch to second order flux close to the boundary
3873
3874       i_start_f = i_start
3875       i_end_f   = i_end+1
3876
3877       IF(degrade_xs) then
3878         i_start = ids+1
3879         i_start_f = i_start+1
3880       ENDIF
3881
3882       IF(degrade_xe) then
3883         i_end = ide-2
3884         i_end_f = ide-2
3885       ENDIF
3886
3887 !  compute fluxes
3888
3889       DO j = j_start, j_end
3890
3891 !  3rd or 4th order flux
3892
3893         DO k=kts,ktf
3894         DO i = i_start_f, i_end_f
3895
3896           fqx( i, k) = ru(i,k,j)*flux3( field(i-2,k,j), field(i-1,k,j),  &
3897                                         field(i  ,k,j), field(i+1,k,j),  &
3898                                         ru(i,k,j)                       )
3899         ENDDO
3900         ENDDO
3901
3902 !  second order flux close to boundaries (if not periodic or symmetric)
3903
3904         IF( degrade_xs ) THEN
3905           DO k=kts,ktf
3906             fqx(i_start, k) = 0.5*ru(i_start,k,j)             &
3907                    *(field(i_start,k,j)+field(i_start-1,k,j))
3908           ENDDO
3909         ENDIF
3910
3911         IF( degrade_xe ) THEN
3912           DO k=kts,ktf
3913             fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j)          &
3914                    *(field(i_end+1,k,j)+field(i_end,k,j))
3915           ENDDO
3916         ENDIF
3917
3918 !  x flux-divergence into tendency
3919
3920         DO k=kts,ktf
3921         DO i = i_start, i_end
3922           mrdx=msftx(i,j)*rdx        ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3923           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3924         ENDDO
3925         ENDDO
3926
3927       ENDDO
3928
3929
3930 !  next -> y flux divergence calculation
3931
3932       i_start = its
3933       i_end   = MIN(ite,ide-1)
3934       j_start = jts
3935       j_end   = MIN(jte,jde-1)
3936
3937 !  3rd or 4th order flux has a 5 point stencil, so compute
3938 !  bounds so we can switch to second order flux close to the boundary
3939
3940       j_start_f = j_start
3941       j_end_f   = j_end+1
3942
3943       IF(degrade_ys) then
3944         j_start = jds+1
3945         j_start_f = j_start+1
3946       ENDIF
3947
3948       IF(degrade_ye) then
3949         j_end = jde-2
3950         j_end_f = jde-2
3951       ENDIF
3952
3953       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3954
3955     jp1 = 2
3956     jp0 = 1
3957
3958   DO j = j_start, j_end+1
3959
3960     IF ((j < j_start_f) .and. degrade_ys) THEN
3961       DO k = kts, ktf
3962       DO i = i_start, i_end
3963          fqy(i,k,jp1) = 0.5*rv(i,k,j_start)             &
3964                 *(field(i,k,j_start)+field(i,k,j_start-1))
3965       ENDDO
3966       ENDDO
3967     ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
3968       DO k = kts, ktf
3969       DO i = i_start, i_end
3970          ! Assumes j>j_end_f is ONLY j_end+1 ...
3971 !         fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1)          &
3972 !                *(field(i,k,j_end+1)+field(i,k,j_end))
3973          fqy(i,k,jp1) = 0.5*rv(i,k,j)          &
3974                 *(field(i,k,j)+field(i,k,j-1))
3975       ENDDO
3976       ENDDO
3977     ELSE
3978 !  3rd or 4th order flux
3979       DO k = kts, ktf
3980       DO i = i_start, i_end
3981          fqy( i, k, jp1 ) = rv(i,k,j)*flux3( field(i,k,j-2), field(i,k,j-1),  &
3982                                             field(i,k,j  ), field(i,k,j+1),  &
3983                                             rv(i,k,j)                       )
3984       ENDDO
3985       ENDDO
3986     END IF
3987
3988 !  y flux-divergence into tendency
3989
3990     ! Comments on polar boundary conditions
3991     ! Same process as for advect_u - tendencies run from jds to jde-1
3992     ! (latitudes are as for u grid, longitudes are displaced)
3993     ! Therefore: flow is only from one side for points next to poles
3994     IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3995       DO k=kts,ktf
3996       DO i = i_start, i_end
3997         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3998         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3999       END DO
4000       END DO
4001     ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
4002       DO k=kts,ktf
4003       DO i = i_start, i_end
4004         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4005         tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
4006       END DO
4007       END DO
4008     ELSE  ! normal code
4009
4010     IF ( j > j_start ) THEN
4011
4012       DO k=kts,ktf
4013       DO i = i_start, i_end
4014         mrdy=msftx(i,j-1)*rdy        ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4015         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
4016       ENDDO
4017       ENDDO
4018
4019     END IF
4020
4021     END IF
4022
4023     jtmp = jp1
4024     jp1 = jp0
4025     jp0 = jtmp
4026
4027   ENDDO
4028
4029    ELSE IF( horz_order == 2 ) THEN
4030
4031       i_start = its
4032       i_end   = MIN(ite,ide-1)
4033       j_start = jts
4034       j_end   = MIN(jte,jde-1)
4035
4036       IF ( .NOT. config_flags%periodic_x ) THEN
4037         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
4038         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
4039       ENDIF
4040
4041       DO j = j_start, j_end
4042       DO k = kts, ktf
4043       DO i = i_start, i_end
4044          mrdx=msftx(i,j)*rdx         ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
4045          tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 &
4046                          *(ru(i+1,k,j)*(field(i+1,k,j)+field(i  ,k,j)) &
4047                           -ru(i  ,k,j)*(field(i  ,k,j)+field(i-1,k,j)))
4048       ENDDO
4049       ENDDO
4050       ENDDO
4051
4052       i_start = its
4053       i_end   = MIN(ite,ide-1)
4054
4055       ! Polar boundary conditions are like open or specified
4056       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
4057       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-2,jte)
4058
4059       DO j = j_start, j_end
4060       DO k = kts, ktf
4061       DO i = i_start, i_end
4062          mrdy=msftx(i,j)*rdy         ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4063          tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 &
4064                          *(rv(i,k,j+1)*(field(i,k,j+1)+field(i,k,j  )) &
4065                           -rv(i,k,j  )*(field(i,k,j  )+field(i,k,j-1)))
4066       ENDDO
4067       ENDDO
4068       ENDDO
4069
4070       ! Polar boundary condtions
4071       ! These won't be covered in the loop above...
4072       IF (config_flags%polar) THEN
4073          IF (jts == jds) THEN
4074             DO k=kts,ktf
4075             DO i = i_start, i_end
4076                mrdy=msftx(i,jds)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4077                tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 &
4078                                 *rv(i,k,jds+1)*(field(i,k,jds+1)+field(i,k,jds))
4079             END DO
4080             END DO
4081          END IF
4082          IF (jte == jde) THEN
4083             DO k=kts,ktf
4084             DO i = i_start, i_end
4085                mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4086                tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 &
4087                                   *rv(i,k,jde-1)*(field(i,k,jde-1)+field(i,k,jde-2))
4088             END DO
4089             END DO
4090          END IF
4091       END IF
4092
4093    ELSE IF ( horz_order == 0 ) THEN
4094
4095       ! Just in case we want to turn horizontal advection off, we can do it
4096
4097    ELSE
4098
4099       WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_6a, h_order not known ',horz_order
4100       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
4101
4102    ENDIF horizontal_order_test
4103
4104 !  pick up the rest of the horizontal radiation boundary conditions.
4105 !  (these are the computations that don't require 'cb'.
4106 !  first, set to index ranges
4107
4108       i_start = its
4109       i_end   = MIN(ite,ide-1)
4110       j_start = jts
4111       j_end   = MIN(jte,jde-1)
4112
4113 !  compute x (u) conditions for v, w, or scalar
4114
4115    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
4116
4117        DO j = j_start, j_end
4118        DO k = kts, ktf
4119          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
4120          tendency(its,k,j) = tendency(its,k,j)                     &
4121                - rdx*(                                             &
4122                        ub*(   field_old(its+1,k,j)                 &
4123                             - field_old(its  ,k,j)   ) +           &
4124                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
4125                                                                 )
4126        ENDDO
4127        ENDDO
4128
4129    ENDIF
4130
4131    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
4132
4133        DO j = j_start, j_end
4134        DO k = kts, ktf
4135          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
4136          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
4137                - rdx*(                                               &
4138                        ub*(  field_old(i_end  ,k,j)                  &
4139                            - field_old(i_end-1,k,j) ) +              &
4140                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
4141                                                                     )
4142        ENDDO
4143        ENDDO
4144
4145    ENDIF
4146
4147    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
4148
4149        DO i = i_start, i_end
4150        DO k = kts, ktf
4151          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
4152          tendency(i,k,jts) = tendency(i,k,jts)                     &
4153                - rdy*(                                             &
4154                        vb*(  field_old(i,k,jts+1)                  &
4155                            - field_old(i,k,jts  ) ) +              &
4156                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
4157                                                                 )
4158        ENDDO
4159        ENDDO
4160
4161    ENDIF
4162
4163    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
4164
4165        DO i = i_start, i_end
4166        DO k = kts, ktf
4167          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
4168          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
4169                - rdy*(                                               &
4170                        vb*(   field_old(i,k,j_end  )                 &
4171                             - field_old(i,k,j_end-1) ) +             &
4172                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
4173                                                                     )
4174        ENDDO
4175        ENDDO
4176
4177    ENDIF
4178
4179
4180 !-------------------- vertical advection
4181 !     Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
4182 !     Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
4183 !     So we don't need to make a correction for advect_scalar
4184
4185       i_start = its
4186       i_end   = MIN(ite,ide-1)
4187       j_start = jts
4188       j_end   = MIN(jte,jde-1)
4189
4190       DO i = i_start, i_end
4191          vflux(i,kts)=0.
4192          vflux(i,kte)=0.
4193       ENDDO
4194
4195     vert_order_test : IF (vert_order == 6) THEN
4196
4197       DO j = j_start, j_end
4198
4199          DO k=kts+3,ktf-2
4200          DO i = i_start, i_end
4201            vel=rom(i,k,j)
4202            vflux(i,k) = vel*flux6(                                 &
4203                    field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
4204                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
4205          ENDDO
4206          ENDDO
4207
4208          DO i = i_start, i_end
4209
4210            k=kts+1
4211            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4212
4213            k = kts+2
4214            vel=rom(i,k,j)
4215            vflux(i,k) = vel*flux4(               &
4216                    field(i,k-2,j), field(i,k-1,j),   &
4217                    field(i,k  ,j), field(i,k+1,j), -vel )
4218            k = ktf-1
4219            vel=rom(i,k,j)
4220            vflux(i,k) = vel*flux4(               &
4221                    field(i,k-2,j), field(i,k-1,j),   &
4222                    field(i,k  ,j), field(i,k+1,j), -vel )
4223
4224            k=ktf
4225            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4226          ENDDO
4227
4228          DO k=kts,ktf
4229          DO i = i_start, i_end
4230             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4231          ENDDO
4232          ENDDO
4233
4234       ENDDO
4235
4236    ELSE IF (vert_order == 5) THEN
4237
4238       DO j = j_start, j_end
4239
4240          DO k=kts+3,ktf-2
4241          DO i = i_start, i_end
4242            vel=rom(i,k,j)
4243            vflux(i,k) = vel*flux5(                                 &
4244                    field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
4245                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
4246          ENDDO
4247          ENDDO
4248
4249          DO i = i_start, i_end
4250
4251            k=kts+1
4252            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4253
4254            k = kts+2
4255            vel=rom(i,k,j)
4256            vflux(i,k) = vel*flux3(               &
4257                    field(i,k-2,j), field(i,k-1,j),   &
4258                    field(i,k  ,j), field(i,k+1,j), -vel )
4259            k = ktf-1
4260            vel=rom(i,k,j)
4261            vflux(i,k) = vel*flux3(               &
4262                    field(i,k-2,j), field(i,k-1,j),   &
4263                    field(i,k  ,j), field(i,k+1,j), -vel )
4264
4265            k=ktf
4266            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4267          ENDDO
4268
4269          DO k=kts,ktf
4270          DO i = i_start, i_end
4271             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4272          ENDDO
4273          ENDDO
4274
4275       ENDDO
4276
4277    ELSE IF (vert_order == 4) THEN
4278
4279       DO j = j_start, j_end
4280
4281          DO k=kts+2,ktf-1
4282          DO i = i_start, i_end
4283            vel=rom(i,k,j)
4284            vflux(i,k) = vel*flux4(                                 &
4285                    field(i,k-2,j), field(i,k-1,j),       &
4286                    field(i,k  ,j), field(i,k+1,j),  -vel )
4287          ENDDO
4288          ENDDO
4289
4290          DO i = i_start, i_end
4291
4292            k=kts+1
4293            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4294            k=ktf
4295            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4296          ENDDO
4297
4298          DO k=kts,ktf
4299          DO i = i_start, i_end
4300             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4301          ENDDO
4302          ENDDO
4303
4304       ENDDO
4305
4306    ELSE IF (vert_order == 3) THEN
4307
4308       DO j = j_start, j_end
4309
4310          DO k=kts+2,ktf-1
4311          DO i = i_start, i_end
4312            vel=rom(i,k,j)
4313            vflux(i,k) = vel*flux3(                      &
4314                    field(i,k-2,j), field(i,k-1,j),      &
4315                    field(i,k  ,j), field(i,k+1,j),  -vel )
4316          ENDDO
4317          ENDDO
4318
4319          DO i = i_start, i_end
4320
4321            k=kts+1
4322            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4323            k=ktf
4324            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4325          ENDDO
4326
4327          DO k=kts,ktf
4328          DO i = i_start, i_end
4329             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4330          ENDDO
4331          ENDDO
4332
4333       ENDDO
4334
4335    ELSE IF (vert_order == 2) THEN
4336
4337   DO j = j_start, j_end
4338      DO k = kts+1, ktf
4339      DO i = i_start, i_end
4340             vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4341      ENDDO
4342      ENDDO
4343
4344      DO k = kts, ktf
4345      DO i = i_start, i_end
4346        tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4347      ENDDO
4348      ENDDO
4349
4350   ENDDO
4351
4352    ELSE
4353
4354       WRITE (wrf_err_message,*) ' advect_scalar_6a, v_order not known ',vert_order
4355       CALL wrf_error_fatal ( wrf_err_message )
4356
4357    ENDIF vert_order_test
4358
4359 END SUBROUTINE advect_scalar
4360 #if ( ! defined(ADVECT_KERNEL) )
4361
4362 !---------------------------------------------------------------------------------
4363
4364 SUBROUTINE advect_w    ( w, w_old, tendency,            &
4365                          ru, rv, rom,                   &
4366                          c1, c2,                        &
4367                          mut, time_step, config_flags,  &
4368                          msfux, msfuy, msfvx, msfvy,    &
4369                          msftx, msfty,                  &
4370                          fzm, fzp,                      &
4371                          rdx, rdy, rdzu,                &
4372                          ids, ide, jds, jde, kds, kde,  &
4373                          ims, ime, jms, jme, kms, kme,  &
4374                          its, ite, jts, jte, kts, kte  )
4375
4376    IMPLICIT NONE
4377
4378    ! Input data
4379
4380    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
4381
4382    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
4383                                               ims, ime, jms, jme, kms, kme, &
4384                                               its, ite, jts, jte, kts, kte
4385
4386    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: w,     &
4387                                                                       w_old, &
4388                                                                       ru,    &
4389                                                                       rv,    &
4390                                                                       rom
4391
4392    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
4393    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
4394
4395    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
4396                                                                     msfuy,  &
4397                                                                     msfvx,  &
4398                                                                     msfvy,  &
4399                                                                     msftx,  &
4400                                                                     msfty
4401
4402    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
4403                                                                   fzp,  &
4404                                                                   rdzu, &
4405                                                                   c1,   &
4406                                                                   c2
4407
4408    REAL ,                                        INTENT(IN   ) :: rdx,  &
4409                                                                   rdy
4410    INTEGER ,                                     INTENT(IN   ) :: time_step
4411
4412
4413    ! Local data
4414
4415    INTEGER :: i, j, k, itf, jtf, ktf
4416    INTEGER :: i_start, i_end, j_start, j_end
4417    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
4418    INTEGER :: jmin, jmax, jp, jm, imin, imax
4419
4420    REAL    :: mrdx, mrdy, ub, vb, uw, vw
4421    REAL , DIMENSION(its:ite, kts:kte) :: vflux
4422
4423    INTEGER :: horz_order, vert_order
4424
4425    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
4426    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
4427
4428    LOGICAL :: degrade_xs, degrade_ys
4429    LOGICAL :: degrade_xe, degrade_ye
4430
4431    INTEGER :: jp1, jp0, jtmp
4432
4433 ! definition of flux operators, 3rd, 4th, 5th or 6th order
4434
4435    REAL    :: flux3, flux4, flux5, flux6
4436    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
4437
4438       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
4439           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
4440
4441       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
4442            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
4443            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
4444
4445       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
4446                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)      &
4447                      +(q_ip2+q_im3) )/60.0
4448
4449       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
4450            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
4451             -sign(1,time_step)*sign(1.,ua)*(                    &
4452               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
4453
4454
4455    LOGICAL :: specified
4456
4457    specified = .false.
4458    if(config_flags%specified .or. config_flags%nested) specified = .true.
4459
4460 !  set order for the advection scheme
4461
4462   ktf=MIN(kte,kde-1)
4463   horz_order = config_flags%h_sca_adv_order
4464   vert_order = config_flags%v_sca_adv_order
4465
4466 !  here is the choice of flux operators
4467
4468 !  begin with horizontal flux divergence
4469
4470   horizontal_order_test : IF( horz_order == 6 ) THEN
4471
4472 !  determine boundary mods for flux operators
4473 !  We degrade the flux operators from 3rd/4th order
4474 !   to second order one gridpoint in from the boundaries for
4475 !   all boundary conditions except periodic and symmetry - these
4476 !   conditions have boundary zone data fill for correct application
4477 !   of the higher order flux stencils
4478
4479    degrade_xs = .true.
4480    degrade_xe = .true.
4481    degrade_ys = .true.
4482    degrade_ye = .true.
4483
4484    IF( config_flags%periodic_x   .or. &
4485        config_flags%symmetric_xs .or. &
4486        (its > ids+3)                ) degrade_xs = .false.
4487    IF( config_flags%periodic_x   .or. &
4488        config_flags%symmetric_xe .or. &
4489        (ite < ide-3)                ) degrade_xe = .false.
4490    IF( config_flags%periodic_y   .or. &
4491        config_flags%symmetric_ys .or. &
4492        (jts > jds+3)                ) degrade_ys = .false.
4493    IF( config_flags%periodic_y   .or. &
4494        config_flags%symmetric_ye .or. &
4495        (jte < jde-4)                ) degrade_ye = .false.
4496
4497 !--------------- y - advection first
4498
4499       i_start = its
4500       i_end   = MIN(ite,ide-1)
4501       j_start = jts
4502       j_end   = MIN(jte,jde-1)
4503
4504 !  higher order flux has a 5 or 7 point stencil, so compute
4505 !  bounds so we can switch to second order flux close to the boundary
4506
4507       j_start_f = j_start
4508       j_end_f   = j_end+1
4509
4510       IF(degrade_ys) then
4511         j_start = MAX(jts,jds+1)
4512         j_start_f = jds+3
4513       ENDIF
4514
4515       IF(degrade_ye) then
4516         j_end = MIN(jte,jde-2)
4517         j_end_f = jde-3
4518       ENDIF
4519
4520       IF(config_flags%polar) j_end = MIN(jte,jde-1)
4521
4522 !  compute fluxes, 5th or 6th order
4523
4524      jp1 = 2
4525      jp0 = 1
4526
4527      j_loop_y_flux_6 : DO j = j_start, j_end+1
4528
4529       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
4530
4531         DO k=kts+1,ktf
4532         DO i = i_start, i_end
4533           vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4534           fqy( i, k, jp1 ) = vel*flux6(                     &
4535                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4536                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4537         ENDDO
4538         ENDDO
4539
4540         k = ktf+1
4541         DO i = i_start, i_end
4542           vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4543           fqy( i, k, jp1 ) = vel*flux6(                     &
4544                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4545                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4546         ENDDO
4547
4548       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
4549
4550             DO k=kts+1,ktf
4551             DO i = i_start, i_end
4552               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*          &
4553                      (w(i,k,j)+w(i,k,j-1))
4554             ENDDO
4555             ENDDO
4556
4557             k = ktf+1
4558             DO i = i_start, i_end
4559               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*          &
4560                      (w(i,k,j)+w(i,k,j-1))
4561             ENDDO
4562
4563      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
4564
4565             DO k=kts+1,ktf
4566             DO i = i_start, i_end
4567               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4568               fqy( i, k, jp1 ) = vel*flux4(              &
4569                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4570             ENDDO
4571             ENDDO
4572
4573             k = ktf+1
4574             DO i = i_start, i_end
4575               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4576               fqy( i, k, jp1 ) = vel*flux4(              &
4577                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4578             ENDDO
4579
4580      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
4581
4582             DO k=kts+1,ktf
4583             DO i = i_start, i_end
4584               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*      &
4585                      (w(i,k,j)+w(i,k,j-1))
4586             ENDDO
4587             ENDDO
4588
4589             k = ktf+1
4590             DO i = i_start, i_end
4591               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*      &
4592                      (w(i,k,j)+w(i,k,j-1))
4593             ENDDO
4594
4595      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
4596
4597             DO k=kts+1,ktf
4598             DO i = i_start, i_end
4599               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4600               fqy( i, k, jp1 ) = vel*flux4(             &
4601                    w(i,k,j-2),w(i,k,j-1),    &
4602                    w(i,k,j),w(i,k,j+1),vel )
4603             ENDDO
4604             ENDDO
4605
4606             k = ktf+1
4607             DO i = i_start, i_end
4608               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4609               fqy( i, k, jp1 ) = vel*flux4(             &
4610                    w(i,k,j-2),w(i,k,j-1),    &
4611                    w(i,k,j),w(i,k,j+1),vel )
4612             ENDDO
4613
4614      ENDIF
4615
4616 !  y flux-divergence into tendency
4617
4618         ! Comments for polar boundary conditions
4619         ! Same process as for advect_u - tendencies run from jds to jde-1
4620         ! (latitudes are as for u grid, longitudes are displaced)
4621         ! Therefore: flow is only from one side for points next to poles
4622         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
4623           DO k=kts,ktf
4624           DO i = i_start, i_end
4625             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4626             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
4627           END DO
4628           END DO
4629         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
4630           DO k=kts,ktf
4631           DO i = i_start, i_end
4632             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4633             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
4634           END DO
4635           END DO
4636         ELSE  ! normal code
4637
4638         IF(j > j_start) THEN
4639
4640           DO k=kts+1,ktf+1
4641           DO i = i_start, i_end
4642             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4643             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
4644           ENDDO
4645           ENDDO
4646
4647        ENDIF
4648
4649         END IF
4650
4651         jtmp = jp1
4652         jp1 = jp0
4653         jp0 = jtmp
4654
4655       ENDDO j_loop_y_flux_6
4656
4657 !  next, x - flux divergence
4658
4659       i_start = its
4660       i_end   = MIN(ite,ide-1)
4661
4662       j_start = jts
4663       j_end   = MIN(jte,jde-1)
4664
4665 !  higher order flux has a 5 or 7 point stencil, so compute
4666 !  bounds so we can switch to second order flux close to the boundary
4667
4668       i_start_f = i_start
4669       i_end_f   = i_end+1
4670
4671       IF(degrade_xs) then
4672         i_start = MAX(ids+1,its)
4673 !        i_start_f = i_start+2
4674         i_start_f = MIN(i_start+2,ids+3)
4675       ENDIF
4676
4677       IF(degrade_xe) then
4678         i_end = MIN(ide-2,ite)
4679         i_end_f = ide-3
4680       ENDIF
4681
4682 !  compute fluxes
4683
4684       DO j = j_start, j_end
4685
4686 !  5th or 6th order flux
4687
4688         DO k=kts+1,ktf
4689         DO i = i_start_f, i_end_f
4690           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4691           fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j),  &
4692                                   w(i-1,k,j), w(i  ,k,j),  &
4693                                   w(i+1,k,j), w(i+2,k,j),  &
4694                                   vel                     )
4695         ENDDO
4696         ENDDO
4697
4698         k = ktf+1
4699         DO i = i_start_f, i_end_f
4700           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4701           fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j),  &
4702                                   w(i-1,k,j), w(i  ,k,j),  &
4703                                   w(i+1,k,j), w(i+2,k,j),  &
4704                                   vel                     )
4705         ENDDO
4706
4707 !  lower order fluxes close to boundaries (if not periodic or symmetric)
4708
4709         IF( degrade_xs ) THEN
4710
4711           DO i=i_start,i_start_f-1
4712
4713             IF(i == ids+1) THEN ! second order
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             IF(i == ids+2) THEN  ! third order
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               k = ktf+1
4731               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4732               fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
4733                                       w(i  ,k,j), w(i+1,k,j),  &
4734                                       vel                     )
4735             END IF
4736
4737           ENDDO
4738
4739         ENDIF
4740
4741         IF( degrade_xe ) THEN
4742
4743           DO i = i_end_f+1, i_end+1
4744
4745             IF( i == ide-1 ) THEN ! second order flux next to the boundary
4746               DO k=kts+1,ktf
4747                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
4748                                   *(w(i,k,j)+w(i-1,k,j))
4749               ENDDO
4750               k = ktf+1
4751               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))      &
4752                      *(w(i,k,j)+w(i-1,k,j))
4753             ENDIF
4754
4755             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
4756               DO k=kts+1,ktf
4757                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4758                 fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
4759                                         w(i  ,k,j), w(i+1,k,j),  &
4760                                         vel                     )
4761               ENDDO
4762               k = ktf+1
4763               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4764               fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
4765                                       w(i  ,k,j), w(i+1,k,j),  &
4766                                       vel                     )
4767             ENDIF
4768
4769           ENDDO
4770
4771         ENDIF
4772
4773 !  x flux-divergence into tendency
4774
4775         DO k=kts+1,ktf+1
4776           DO i = i_start, i_end
4777             mrdx=msftx(i,j)*rdx      ! see ADT eqn 46 dividing by my, 1st term RHS
4778             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
4779           ENDDO
4780         ENDDO
4781
4782       ENDDO
4783
4784 ELSE IF (horz_order == 5 ) THEN
4785
4786 !  determine boundary mods for flux operators
4787 !  We degrade the flux operators from 3rd/4th order
4788 !   to second order one gridpoint in from the boundaries for
4789 !   all boundary conditions except periodic and symmetry - these
4790 !   conditions have boundary zone data fill for correct application
4791 !   of the higher order flux stencils
4792
4793    degrade_xs = .true.
4794    degrade_xe = .true.
4795    degrade_ys = .true.
4796    degrade_ye = .true.
4797
4798    IF( config_flags%periodic_x   .or. &
4799        config_flags%symmetric_xs .or. &
4800        (its > ids+3)                ) degrade_xs = .false.
4801    IF( config_flags%periodic_x   .or. &
4802        config_flags%symmetric_xe .or. &
4803        (ite < ide-3)                ) degrade_xe = .false.
4804    IF( config_flags%periodic_y   .or. &
4805        config_flags%symmetric_ys .or. &
4806        (jts > jds+3)                ) degrade_ys = .false.
4807    IF( config_flags%periodic_y   .or. &
4808        config_flags%symmetric_ye .or. &
4809        (jte < jde-4)                ) degrade_ye = .false.
4810
4811 !--------------- y - advection first
4812
4813       i_start = its
4814       i_end   = MIN(ite,ide-1)
4815       j_start = jts
4816       j_end   = MIN(jte,jde-1)
4817
4818 !  higher order flux has a 5 or 7 point stencil, so compute
4819 !  bounds so we can switch to second order flux close to the boundary
4820
4821       j_start_f = j_start
4822       j_end_f   = j_end+1
4823
4824       IF(degrade_ys) then
4825         j_start = MAX(jts,jds+1)
4826         j_start_f = jds+3
4827       ENDIF
4828
4829       IF(degrade_ye) then
4830         j_end = MIN(jte,jde-2)
4831         j_end_f = jde-3
4832       ENDIF
4833
4834       IF(config_flags%polar) j_end = MIN(jte,jde-1)
4835
4836 !  compute fluxes, 5th or 6th order
4837
4838      jp1 = 2
4839      jp0 = 1
4840
4841      j_loop_y_flux_5 : DO j = j_start, j_end+1
4842
4843       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
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*flux5(                     &
4849                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4850                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4851         ENDDO
4852         ENDDO
4853
4854         k = ktf+1
4855         DO i = i_start, i_end
4856           vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4857           fqy( i, k, jp1 ) = vel*flux5(                     &
4858                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4859                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4860         ENDDO
4861
4862       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
4863
4864             DO k=kts+1,ktf
4865             DO i = i_start, i_end
4866               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*          &
4867                      (w(i,k,j)+w(i,k,j-1))
4868             ENDDO
4869             ENDDO
4870
4871             k = ktf+1
4872             DO i = i_start, i_end
4873               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*          &
4874                      (w(i,k,j)+w(i,k,j-1))
4875             ENDDO
4876
4877      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
4878
4879             DO k=kts+1,ktf
4880             DO i = i_start, i_end
4881               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4882               fqy( i, k, jp1 ) = vel*flux3(              &
4883                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4884             ENDDO
4885             ENDDO
4886
4887             k = ktf+1
4888             DO i = i_start, i_end
4889               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4890               fqy( i, k, jp1 ) = vel*flux3(              &
4891                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4892             ENDDO
4893
4894      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
4895
4896             DO k=kts+1,ktf
4897             DO i = i_start, i_end
4898               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*      &
4899                      (w(i,k,j)+w(i,k,j-1))
4900             ENDDO
4901             ENDDO
4902
4903             k = ktf+1
4904             DO i = i_start, i_end
4905               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*      &
4906                      (w(i,k,j)+w(i,k,j-1))
4907             ENDDO
4908
4909      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
4910
4911             DO k=kts+1,ktf
4912             DO i = i_start, i_end
4913               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4914               fqy( i, k, jp1 ) = vel*flux3(             &
4915                    w(i,k,j-2),w(i,k,j-1),    &
4916                    w(i,k,j),w(i,k,j+1),vel )
4917             ENDDO
4918             ENDDO
4919
4920             k = ktf+1
4921             DO i = i_start, i_end
4922               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4923               fqy( i, k, jp1 ) = vel*flux3(             &
4924                    w(i,k,j-2),w(i,k,j-1),    &
4925                    w(i,k,j),w(i,k,j+1),vel )
4926             ENDDO
4927
4928      ENDIF
4929
4930 !  y flux-divergence into tendency
4931
4932         ! Comments for polar boundary conditions
4933         ! Same process as for advect_u - tendencies run from jds to jde-1
4934         ! (latitudes are as for u grid, longitudes are displaced)
4935         ! Therefore: flow is only from one side for points next to poles
4936         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
4937           DO k=kts,ktf
4938           DO i = i_start, i_end
4939             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4940             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
4941           END DO
4942           END DO
4943         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
4944           DO k=kts,ktf
4945           DO i = i_start, i_end
4946             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4947             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
4948           END DO
4949           END DO
4950         ELSE  ! normal code
4951
4952         IF(j > j_start) THEN
4953
4954           DO k=kts+1,ktf+1
4955           DO i = i_start, i_end
4956             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4957             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
4958           ENDDO
4959           ENDDO
4960
4961        ENDIF
4962
4963         END IF
4964
4965         jtmp = jp1
4966         jp1 = jp0
4967         jp0 = jtmp
4968
4969       ENDDO j_loop_y_flux_5
4970
4971 !  next, x - flux divergence
4972
4973       i_start = its
4974       i_end   = MIN(ite,ide-1)
4975
4976       j_start = jts
4977       j_end   = MIN(jte,jde-1)
4978
4979 !  higher order flux has a 5 or 7 point stencil, so compute
4980 !  bounds so we can switch to second order flux close to the boundary
4981
4982       i_start_f = i_start
4983       i_end_f   = i_end+1
4984
4985       IF(degrade_xs) then
4986         i_start = MAX(ids+1,its)
4987 !        i_start_f = i_start+2
4988         i_start_f = MIN(i_start+2,ids+3)
4989       ENDIF
4990
4991       IF(degrade_xe) then
4992         i_end = MIN(ide-2,ite)
4993         i_end_f = ide-3
4994       ENDIF
4995
4996 !  compute fluxes
4997
4998       DO j = j_start, j_end
4999
5000 !  5th or 6th order flux
5001
5002         DO k=kts+1,ktf
5003         DO i = i_start_f, i_end_f
5004           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5005           fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
5006                                   w(i-1,k,j), w(i  ,k,j),  &
5007                                   w(i+1,k,j), w(i+2,k,j),  &
5008                                   vel                     )
5009         ENDDO
5010         ENDDO
5011
5012         k = ktf+1
5013         DO i = i_start_f, i_end_f
5014           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5015           fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
5016                                   w(i-1,k,j), w(i  ,k,j),  &
5017                                   w(i+1,k,j), w(i+2,k,j),  &
5018                                   vel                     )
5019         ENDDO
5020
5021 !  lower order fluxes close to boundaries (if not periodic or symmetric)
5022
5023         IF( degrade_xs ) THEN
5024
5025           DO i=i_start,i_start_f-1
5026
5027             IF(i == ids+1) THEN ! second order
5028               DO k=kts+1,ktf
5029                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
5030                                 *(w(i,k,j)+w(i-1,k,j))
5031               ENDDO
5032               k = ktf+1
5033               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
5034                      *(w(i,k,j)+w(i-1,k,j))
5035             ENDIF
5036
5037             IF(i == ids+2) THEN  ! third order
5038               DO k=kts+1,ktf
5039                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5040                 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5041                                         w(i  ,k,j), w(i+1,k,j),  &
5042                                         vel                     )
5043               ENDDO
5044               k = ktf+1
5045               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5046               fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5047                                       w(i  ,k,j), w(i+1,k,j),  &
5048                                       vel                     )
5049             END IF
5050
5051           ENDDO
5052
5053         ENDIF
5054
5055         IF( degrade_xe ) THEN
5056
5057           DO i = i_end_f+1, i_end+1
5058
5059             IF( i == ide-1 ) THEN ! second order flux next to the boundary
5060               DO k=kts+1,ktf
5061                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
5062                                   *(w(i,k,j)+w(i-1,k,j))
5063               ENDDO
5064               k = ktf+1
5065               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))      &
5066                      *(w(i,k,j)+w(i-1,k,j))
5067             ENDIF
5068
5069             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
5070               DO k=kts+1,ktf
5071                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5072                 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5073                                         w(i  ,k,j), w(i+1,k,j),  &
5074                                         vel                     )
5075               ENDDO
5076               k = ktf+1
5077               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5078               fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5079                                       w(i  ,k,j), w(i+1,k,j),  &
5080                                       vel                     )
5081             ENDIF
5082
5083           ENDDO
5084
5085         ENDIF
5086
5087 !  x flux-divergence into tendency
5088
5089         DO k=kts+1,ktf+1
5090           DO i = i_start, i_end
5091             mrdx=msftx(i,j)*rdx      ! see ADT eqn 46 dividing by my, 1st term RHS
5092             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
5093           ENDDO
5094         ENDDO
5095
5096       ENDDO
5097
5098 ELSE IF ( horz_order == 4 ) THEN
5099
5100    degrade_xs = .true.
5101    degrade_xe = .true.
5102    degrade_ys = .true.
5103    degrade_ye = .true.
5104
5105    IF( config_flags%periodic_x   .or. &
5106        config_flags%symmetric_xs .or. &
5107        (its > ids+2)                ) degrade_xs = .false.
5108    IF( config_flags%periodic_x   .or. &
5109        config_flags%symmetric_xe .or. &
5110        (ite < ide-2)                ) degrade_xe = .false.
5111    IF( config_flags%periodic_y   .or. &
5112        config_flags%symmetric_ys .or. &
5113        (jts > jds+2)                ) degrade_ys = .false.
5114    IF( config_flags%periodic_y   .or. &
5115        config_flags%symmetric_ye .or. &
5116        (jte < jde-3)                ) degrade_ye = .false.
5117
5118 !  begin flux computations
5119 !  start with x flux divergence
5120
5121 !---------------
5122
5123    ktf=MIN(kte,kde-1)
5124
5125       i_start = its
5126       i_end   = MIN(ite,ide-1)
5127       j_start = jts
5128       j_end   = MIN(jte,jde-1)
5129
5130 !  3rd or 4th order flux has a 5 point stencil, so compute
5131 !  bounds so we can switch to second order flux close to the boundary
5132
5133       i_start_f = i_start
5134       i_end_f   = i_end+1
5135
5136       IF(degrade_xs) then
5137         i_start = ids+1
5138         i_start_f = i_start+1
5139       ENDIF
5140
5141       IF(degrade_xe) then
5142         i_end = ide-2
5143         i_end_f = ide-2
5144       ENDIF
5145
5146 !  compute fluxes
5147
5148       DO j = j_start, j_end
5149
5150         DO k=kts+1,ktf
5151         DO i = i_start_f, i_end_f
5152           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5153           fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
5154                                   w(i  ,k,j), w(i+1,k,j),  &
5155                                   vel                     )
5156         ENDDO
5157         ENDDO
5158
5159         k = ktf+1
5160         DO i = i_start_f, i_end_f
5161           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5162           fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
5163                                   w(i  ,k,j), w(i+1,k,j),  &
5164                                   vel                     )
5165         ENDDO
5166 !  second order flux close to boundaries (if not periodic or symmetric)
5167
5168         IF( degrade_xs ) THEN
5169           DO k=kts+1,ktf
5170             fqx(i_start, k) =                            &
5171                0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j))  &
5172                    *(w(i_start,k,j)+w(i_start-1,k,j))
5173           ENDDO
5174             k = ktf+1
5175             fqx(i_start, k) =                            &
5176                0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j))  &
5177                    *(w(i_start,k,j)+w(i_start-1,k,j))
5178         ENDIF
5179
5180         IF( degrade_xe ) THEN
5181           DO k=kts+1,ktf
5182             fqx(i_end+1, k) =                            &
5183                0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j))  &
5184                    *(w(i_end+1,k,j)+w(i_end,k,j))
5185           ENDDO
5186             k = ktf+1
5187             fqx(i_end+1, k) =                            &
5188                0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j))  &
5189                    *(w(i_end+1,k,j)+w(i_end,k,j))
5190         ENDIF
5191
5192 !  x flux-divergence into tendency
5193
5194         DO k=kts+1,ktf+1
5195         DO i = i_start, i_end
5196           mrdx=msftx(i,j)*rdx        ! see ADT eqn 46 dividing by my, 1st term RHS
5197           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
5198         ENDDO
5199         ENDDO
5200
5201       ENDDO
5202
5203 !  next -> y flux divergence calculation
5204
5205       i_start = its
5206       i_end   = MIN(ite,ide-1)
5207       j_start = jts
5208       j_end   = MIN(jte,jde-1)
5209
5210
5211 !  3rd or 4th order flux has a 5 point stencil, so compute
5212 !  bounds so we can switch to second order flux close to the boundary
5213
5214       j_start_f = j_start
5215       j_end_f   = j_end+1
5216
5217       IF(degrade_ys) then
5218         j_start = jds+1
5219         j_start_f = j_start+1
5220       ENDIF
5221
5222       IF(degrade_ye) then
5223         j_end = jde-2
5224         j_end_f = jde-2
5225       ENDIF
5226
5227       IF(config_flags%polar) j_end = MIN(jte,jde-1)
5228
5229         jp1 = 2
5230         jp0 = 1
5231
5232       DO j = j_start, j_end+1
5233
5234        IF ((j < j_start_f) .and. degrade_ys)  THEN
5235           DO k = kts+1, ktf
5236           DO i = i_start, i_end
5237             fqy(i, k, jp1) =                             &
5238                0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start))   &
5239                    *(w(i,k,j_start)+w(i,k,j_start-1))
5240           ENDDO
5241           ENDDO
5242           k = ktf+1
5243           DO i = i_start, i_end
5244             fqy(i, k, jp1) =                             &
5245                0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start))   &
5246                    *(w(i,k,j_start)+w(i,k,j_start-1))
5247           ENDDO
5248        ELSE IF ((j > j_end_f) .and. degrade_ye)  THEN
5249           DO k = kts+1, ktf
5250           DO i = i_start, i_end
5251             ! Assumes j>j_end_f is ONLY j_end+1 ...
5252 !            fqy(i, k, jp1) =                             &
5253 !               0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1))     &
5254 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5255             fqy(i, k, jp1) =                             &
5256                0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))     &
5257                    *(w(i,k,j)+w(i,k,j-1))
5258           ENDDO
5259           ENDDO
5260           k = ktf+1
5261           DO i = i_start, i_end
5262             ! Assumes j>j_end_f is ONLY j_end+1 ...
5263 !            fqy(i, k, jp1) =                                         &
5264 !               0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1))     &
5265 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5266             fqy(i, k, jp1) =                                         &
5267                0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))     &
5268                    *(w(i,k,j)+w(i,k,j-1))
5269           ENDDO
5270        ELSE
5271 !  3rd or 4th order flux
5272           DO k = kts+1, ktf
5273           DO i = i_start, i_end
5274             vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
5275             fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1),  &
5276                                     w(i,k,j  ), w(i,k,j+1),  &
5277                                     vel                     )
5278           ENDDO
5279           ENDDO
5280           k = ktf+1
5281           DO i = i_start, i_end
5282             vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
5283             fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1),  &
5284                                     w(i,k,j  ), w(i,k,j+1),  &
5285                                     vel                     )
5286           ENDDO
5287        END IF
5288
5289 !  y flux-divergence into tendency
5290
5291        ! Comments for polar boundary conditions
5292        ! Same process as for advect_u - tendencies run from jds to jde-1
5293        ! (latitudes are as for u grid, longitudes are displaced)
5294        ! Therefore: flow is only from one side for points next to poles
5295        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
5296          DO k=kts,ktf
5297          DO i = i_start, i_end
5298            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5299            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
5300          END DO
5301          END DO
5302        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
5303          DO k=kts,ktf
5304          DO i = i_start, i_end
5305            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5306            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
5307          END DO
5308          END DO
5309        ELSE  ! normal code
5310
5311        IF( j > j_start ) THEN
5312
5313           DO k = kts+1, ktf+1
5314           DO i = i_start, i_end
5315             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5316             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
5317           ENDDO
5318           ENDDO
5319
5320        END IF
5321
5322        END IF
5323
5324        jtmp = jp1
5325        jp1 = jp0
5326        jp0 = jtmp
5327
5328     ENDDO
5329
5330 ELSE IF ( horz_order == 3 ) THEN
5331
5332    degrade_xs = .true.
5333    degrade_xe = .true.
5334    degrade_ys = .true.
5335    degrade_ye = .true.
5336
5337    IF( config_flags%periodic_x   .or. &
5338        config_flags%symmetric_xs .or. &
5339        (its > ids+2)                ) degrade_xs = .false.
5340    IF( config_flags%periodic_x   .or. &
5341        config_flags%symmetric_xe .or. &
5342        (ite < ide-2)                ) degrade_xe = .false.
5343    IF( config_flags%periodic_y   .or. &
5344        config_flags%symmetric_ys .or. &
5345        (jts > jds+2)                ) degrade_ys = .false.
5346    IF( config_flags%periodic_y   .or. &
5347        config_flags%symmetric_ye .or. &
5348        (jte < jde-3)                ) degrade_ye = .false.
5349
5350 !  begin flux computations
5351 !  start with x flux divergence
5352
5353 !---------------
5354
5355    ktf=MIN(kte,kde-1)
5356
5357       i_start = its
5358       i_end   = MIN(ite,ide-1)
5359       j_start = jts
5360       j_end   = MIN(jte,jde-1)
5361
5362 !  3rd or 4th order flux has a 5 point stencil, so compute
5363 !  bounds so we can switch to second order flux close to the boundary
5364
5365       i_start_f = i_start
5366       i_end_f   = i_end+1
5367
5368       IF(degrade_xs) then
5369         i_start = ids+1
5370         i_start_f = i_start+1
5371       ENDIF
5372
5373       IF(degrade_xe) then
5374         i_end = ide-2
5375         i_end_f = ide-2
5376       ENDIF
5377
5378 !  compute fluxes
5379
5380       DO j = j_start, j_end
5381
5382         DO k=kts+1,ktf
5383         DO i = i_start_f, i_end_f
5384           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5385           fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5386                                   w(i  ,k,j), w(i+1,k,j),  &
5387                                   vel                     )
5388         ENDDO
5389         ENDDO
5390         k = ktf+1
5391         DO i = i_start_f, i_end_f
5392           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5393           fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5394                                   w(i  ,k,j), w(i+1,k,j),  &
5395                                   vel                     )
5396         ENDDO
5397
5398 !  second order flux close to boundaries (if not periodic or symmetric)
5399
5400         IF( degrade_xs ) THEN
5401           DO k=kts+1,ktf
5402             fqx(i_start, k) =                            &
5403                0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j))  &
5404                    *(w(i_start,k,j)+w(i_start-1,k,j))
5405           ENDDO
5406             k = ktf+1
5407             fqx(i_start, k) =                            &
5408                0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j))  &
5409                    *(w(i_start,k,j)+w(i_start-1,k,j))
5410         ENDIF
5411
5412         IF( degrade_xe ) THEN
5413           DO k=kts+1,ktf
5414             fqx(i_end+1, k) =                            &
5415                0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j))  &
5416                    *(w(i_end+1,k,j)+w(i_end,k,j))
5417           ENDDO
5418             k = ktf+1
5419             fqx(i_end+1, k) =                            &
5420                0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j))  &
5421                    *(w(i_end+1,k,j)+w(i_end,k,j))
5422         ENDIF
5423
5424 !  x flux-divergence into tendency
5425
5426         DO k=kts+1,ktf+1
5427         DO i = i_start, i_end
5428           mrdx=msftx(i,j)*rdx        ! see ADT eqn 46 dividing by my, 1st term RHS
5429           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
5430         ENDDO
5431         ENDDO
5432
5433       ENDDO
5434
5435 !  next -> y flux divergence calculation
5436
5437       i_start = its
5438       i_end   = MIN(ite,ide-1)
5439       j_start = jts
5440       j_end   = MIN(jte,jde-1)
5441
5442
5443 !  3rd or 4th order flux has a 5 point stencil, so compute
5444 !  bounds so we can switch to second order flux close to the boundary
5445
5446       j_start_f = j_start
5447       j_end_f   = j_end+1
5448
5449       IF(degrade_ys) then
5450         j_start = jds+1
5451         j_start_f = j_start+1
5452       ENDIF
5453
5454       IF(degrade_ye) then
5455         j_end = jde-2
5456         j_end_f = jde-2
5457       ENDIF
5458
5459       IF(config_flags%polar) j_end = MIN(jte,jde-1)
5460
5461         jp1 = 2
5462         jp0 = 1
5463
5464       DO j = j_start, j_end+1
5465
5466        IF ((j < j_start_f) .and. degrade_ys)  THEN
5467           DO k = kts+1, ktf
5468           DO i = i_start, i_end
5469             fqy(i, k, jp1) =                             &
5470                0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start))   &
5471                    *(w(i,k,j_start)+w(i,k,j_start-1))
5472           ENDDO
5473           ENDDO
5474           k = ktf+1
5475           DO i = i_start, i_end
5476             fqy(i, k, jp1) =                             &
5477                0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start))   &
5478                    *(w(i,k,j_start)+w(i,k,j_start-1))
5479           ENDDO
5480        ELSE IF ((j > j_end_f) .and. degrade_ye)  THEN
5481           DO k = kts+1, ktf
5482           DO i = i_start, i_end
5483             ! Assumes j>j_end_f is ONLY j_end+1 ...
5484 !            fqy(i, k, jp1) =                             &
5485 !               0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1))     &
5486 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5487             fqy(i, k, jp1) =                             &
5488                0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))     &
5489                    *(w(i,k,j)+w(i,k,j-1))
5490           ENDDO
5491           ENDDO
5492           k = ktf+1
5493           DO i = i_start, i_end
5494             ! Assumes j>j_end_f is ONLY j_end+1 ...
5495 !            fqy(i, k, jp1) =                             &
5496 !               0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1))     &
5497 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5498             fqy(i, k, jp1) =                             &
5499                0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))     &
5500                    *(w(i,k,j)+w(i,k,j-1))
5501           ENDDO
5502        ELSE
5503 !  3rd or 4th order flux
5504           DO k = kts+1, ktf
5505           DO i = i_start, i_end
5506             vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
5507             fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1),  &
5508                                     w(i,k,j  ), w(i,k,j+1),  &
5509                                     vel                     )
5510           ENDDO
5511           ENDDO
5512           k = ktf+1
5513           DO i = i_start, i_end
5514             vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
5515             fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1),  &
5516                                     w(i,k,j  ), w(i,k,j+1),  &
5517                                     vel                     )
5518           ENDDO
5519        END IF
5520
5521 !  y flux-divergence into tendency
5522
5523        ! Comments for polar boundary conditions
5524        ! Same process as for advect_u - tendencies run from jds to jde-1
5525        ! (latitudes are as for u grid, longitudes are displaced)
5526        ! Therefore: flow is only from one side for points next to poles
5527        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
5528          DO k=kts,ktf
5529          DO i = i_start, i_end
5530            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5531            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
5532          END DO
5533          END DO
5534        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
5535          DO k=kts,ktf
5536          DO i = i_start, i_end
5537            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5538            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
5539          END DO
5540          END DO
5541        ELSE  ! normal code
5542
5543        IF( j > j_start ) THEN
5544
5545           DO k = kts+1, ktf+1
5546           DO i = i_start, i_end
5547             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5548             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
5549           ENDDO
5550           ENDDO
5551
5552        END IF
5553
5554        END IF
5555
5556        jtmp = jp1
5557        jp1 = jp0
5558        jp0 = jtmp
5559
5560     ENDDO
5561
5562 ELSE IF (horz_order == 2 ) THEN
5563
5564       i_start = its
5565       i_end   = MIN(ite,ide-1)
5566       j_start = jts
5567       j_end   = MIN(jte,jde-1)
5568
5569       IF ( .NOT. config_flags%periodic_x ) THEN
5570         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
5571         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
5572       ENDIF
5573
5574       DO j = j_start, j_end
5575       DO k=kts+1,ktf
5576       DO i = i_start, i_end
5577
5578          mrdx=msftx(i,j)*rdx         ! see ADT eqn 46 dividing by my, 1st term RHS
5579
5580             tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5            &
5581                    *((fzm(k)*ru(i+1,k,j)+fzp(k)*ru(i+1,k-1,j))  &
5582                                 *(w(i+1,k,j)+w(i,k,j))          &
5583                     -(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
5584                                *(w(i,k,j)+w(i-1,k,j)))
5585
5586       ENDDO
5587       ENDDO
5588
5589       k = ktf+1
5590       DO i = i_start, i_end
5591
5592          mrdx=msftx(i,j)*rdx         ! see ADT eqn 46 dividing by my, 1st term RHS
5593
5594             tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5            &
5595                    *(((2.-fzm(k-1))*ru(i+1,k-1,j)-fzp(k-1)*ru(i+1,k-2,j))      &
5596                                 *(w(i+1,k,j)+w(i,k,j))          &
5597                     -((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))         &
5598                                *(w(i,k,j)+w(i-1,k,j)))
5599
5600       ENDDO
5601
5602       ENDDO
5603
5604       i_start = its
5605       i_end   = MIN(ite,ide-1)
5606       ! Polar boundary conditions are like open or specified
5607       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
5608       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-2,jte)
5609
5610       DO j = j_start, j_end
5611       DO k=kts+1,ktf
5612       DO i = i_start, i_end
5613
5614          mrdy=msftx(i,j)*rdy         !  see ADT eqn 46 dividing by my, 2nd term RHS
5615
5616             tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5           &
5617                    *((fzm(k)*rv(i,k,j+1)+fzp(k)*rv(i,k-1,j+1))* &
5618                                  (w(i,k,j+1)+w(i,k,j))          &
5619                     -(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))      &
5620                                  *(w(i,k,j)+w(i,k,j-1)))
5621
5622       ENDDO
5623       ENDDO
5624
5625       k = ktf+1
5626       DO i = i_start, i_end
5627
5628          mrdy=msftx(i,j)*rdy         ! see ADT eqn 46 dividing by my, 2nd term RHS
5629
5630             tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5       &
5631                    *(((2.-fzm(k-1))*rv(i,k-1,j+1)-fzp(k-1)*rv(i,k-2,j+1))* &
5632                                  (w(i,k,j+1)+w(i,k,j))      &
5633                     -((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))      &
5634                                  *(w(i,k,j)+w(i,k,j-1)))
5635
5636       ENDDO
5637
5638       ENDDO
5639
5640       ! Polar boundary condition ... not covered in above j-loop
5641       IF (config_flags%polar) THEN
5642          IF (jts == jds) THEN
5643             DO k=kts+1,ktf
5644             DO i = i_start, i_end
5645                mrdy=msftx(i,jds)*rdy   ! see ADT eqn 46 dividing by my, 2nd term RHS
5646                tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 &
5647                           *((fzm(k)*rv(i,k,jds+1)+fzp(k)*rv(i,k-1,jds+1))* &
5648                             (w(i,k,jds+1)+w(i,k,jds)))
5649             END DO
5650             END DO
5651             k = ktf+1
5652             DO i = i_start, i_end
5653                mrdy=msftx(i,jds)*rdy   ! see ADT eqn 46 dividing by my, 2nd term RHS
5654                tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5       &
5655                    *((2.-fzm(k-1))*rv(i,k-1,jds+1)-fzp(k-1)*rv(i,k-2,jds+1))* &
5656                                  (w(i,k,jds+1)+w(i,k,jds))
5657             ENDDO
5658          END IF
5659          IF (jte == jde) THEN
5660             DO k=kts+1,ktf
5661             DO i = i_start, i_end
5662                mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5663                tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 &
5664                           *((fzm(k)*rv(i,k,jde-1)+fzp(k)*rv(i,k-1,jde-1))* &
5665                             (w(i,k,jde-1)+w(i,k,jde-2)))
5666             END DO
5667             END DO
5668             k = ktf+1
5669             DO i = i_start, i_end
5670                mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5671                tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5       &
5672                     *((2.-fzm(k-1))*rv(i,k-1,jde-1)-fzp(k-1)*rv(i,k-2,jde-1)) &
5673                                  *(w(i,k,jde-1)+w(i,k,jde-2))
5674             ENDDO
5675          END IF
5676       END IF
5677
5678    ELSE IF ( horz_order == 0 ) THEN
5679
5680       ! Just in case we want to turn horizontal advection off, we can do it
5681
5682    ELSE
5683
5684       WRITE ( wrf_err_message ,*) ' advect_w_6a, h_order not known ',horz_order
5685       CALL wrf_error_fatal ( wrf_err_message )
5686
5687    ENDIF horizontal_order_test
5688
5689
5690 !  pick up the the horizontal radiation boundary conditions.
5691 !  (these are the computations that don't require 'cb'.
5692 !  first, set to index ranges
5693
5694
5695       i_start = its
5696       i_end   = MIN(ite,ide-1)
5697       j_start = jts
5698       j_end   = MIN(jte,jde-1)
5699
5700    IF( (config_flags%open_xs) .and. (its == ids)) THEN
5701
5702        DO j = j_start, j_end
5703        DO k = kts+1, ktf
5704
5705          uw = 0.5*(fzm(k)*(ru(its,k  ,j)+ru(its+1,k  ,j)) +  &
5706                    fzp(k)*(ru(its,k-1,j)+ru(its+1,k-1,j))   )
5707          ub = MIN( uw, 0. )
5708
5709          tendency(its,k,j) = tendency(its,k,j)                     &
5710                - rdx*(                                             &
5711                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
5712                        w(its,k,j)*(                                &
5713                        fzm(k)*(ru(its+1,k  ,j)-ru(its,k  ,j))+     &
5714                        fzp(k)*(ru(its+1,k-1,j)-ru(its,k-1,j)))     &
5715                                                                   )
5716        ENDDO
5717        ENDDO
5718
5719        k = ktf+1
5720        DO j = j_start, j_end
5721
5722          uw = 0.5*( (2.-fzm(k-1))*(ru(its,k-1,j)+ru(its+1,k-1,j))   &
5723                    -fzp(k-1)*(ru(its,k-2,j)+ru(its+1,k-2,j))   )
5724          ub = MIN( uw, 0. )
5725
5726          tendency(its,k,j) = tendency(its,k,j)                     &
5727                - rdx*(                                             &
5728                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
5729                        w(its,k,j)*(                                &
5730                              (2.-fzm(k-1))*(ru(its+1,k-1,j)-ru(its,k-1,j))-  &
5731                              fzp(k-1)*(ru(its+1,k-2,j)-ru(its,k-2,j)))  &
5732                                                                   )
5733        ENDDO
5734
5735    ENDIF
5736
5737    IF( (config_flags%open_xe) .and. (ite == ide)) THEN
5738
5739        DO j = j_start, j_end
5740        DO k = kts+1, ktf
5741
5742          uw = 0.5*(fzm(k)*(ru(ite-1,k  ,j)+ru(ite,k  ,j)) +  &
5743                    fzp(k)*(ru(ite-1,k-1,j)+ru(ite,k-1,j))   )
5744          ub = MAX( uw, 0. )
5745
5746          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
5747                - rdx*(                                                 &
5748                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
5749                        w(i_end,k,j)*(                                  &
5750                             fzm(k)*(ru(ite,k  ,j)-ru(ite-1,k  ,j)) +   &
5751                             fzp(k)*(ru(ite,k-1,j)-ru(ite-1,k-1,j)))    &
5752                                                                     )
5753        ENDDO
5754        ENDDO
5755
5756        k = ktf+1
5757        DO j = j_start, j_end
5758
5759          uw = 0.5*( (2.-fzm(k-1))*(ru(ite-1,k-1,j)+ru(ite,k-1,j))    &
5760                    -fzp(k-1)*(ru(ite-1,k-2,j)+ru(ite,k-2,j))   )
5761          ub = MAX( uw, 0. )
5762
5763          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
5764                - rdx*(                                                 &
5765                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
5766                        w(i_end,k,j)*(                                  &
5767                                (2.-fzm(k-1))*(ru(ite,k-1,j)-ru(ite-1,k-1,j)) -   &
5768                                fzp(k-1)*(ru(ite,k-2,j)-ru(ite-1,k-2,j)))    &
5769                                                                     )
5770        ENDDO
5771
5772    ENDIF
5773
5774
5775    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
5776
5777        DO i = i_start, i_end
5778        DO k = kts+1, ktf
5779
5780          vw = 0.5*( fzm(k)*(rv(i,k  ,jts)+rv(i,k  ,jts+1)) +  &
5781                     fzp(k)*(rv(i,k-1,jts)+rv(i,k-1,jts+1))   )
5782          vb = MIN( vw, 0. )
5783
5784          tendency(i,k,jts) = tendency(i,k,jts)                     &
5785                - rdy*(                                             &
5786                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
5787                        w(i,k,jts)*(                                &
5788                        fzm(k)*(rv(i,k  ,jts+1)-rv(i,k  ,jts))+     &
5789                        fzp(k)*(rv(i,k-1,jts+1)-rv(i,k-1,jts)))     &
5790                                                                 )
5791        ENDDO
5792        ENDDO
5793
5794        k = ktf+1
5795        DO i = i_start, i_end
5796          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jts)+rv(i,k-1,jts+1))    &
5797                    -fzp(k-1)*(rv(i,k-2,jts)+rv(i,k-2,jts+1))   )
5798          vb = MIN( vw, 0. )
5799
5800          tendency(i,k,jts) = tendency(i,k,jts)                     &
5801                - rdy*(                                             &
5802                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
5803                        w(i,k,jts)*(                                &
5804                           (2.-fzm(k-1))*(rv(i,k-1,jts+1)-rv(i,k-1,jts))-     &
5805                           fzp(k-1)*(rv(i,k-2,jts+1)-rv(i,k-2,jts)))     &
5806                                                                 )
5807        ENDDO
5808
5809    ENDIF
5810
5811    IF( (config_flags%open_ye) .and. (jte == jde) ) THEN
5812
5813        DO i = i_start, i_end
5814        DO k = kts+1, ktf
5815
5816          vw = 0.5*( fzm(k)*(rv(i,k  ,jte-1)+rv(i,k  ,jte)) +  &
5817                     fzp(k)*(rv(i,k-1,jte-1)+rv(i,k-1,jte))   )
5818          vb = MAX( vw, 0. )
5819
5820          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
5821                - rdy*(                                                 &
5822                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
5823                        w(i,k,j_end)*(                                  &
5824                             fzm(k)*(rv(i,k  ,jte)-rv(i,k  ,jte-1))+    &
5825                             fzp(k)*(rv(i,k-1,jte)-rv(i,k-1,jte-1)))    &
5826                                                                       )
5827        ENDDO
5828        ENDDO
5829
5830        k = ktf+1
5831        DO i = i_start, i_end
5832
5833          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jte-1)+rv(i,k-1,jte))    &
5834                    -fzp(k-1)*(rv(i,k-2,jte-1)+rv(i,k-2,jte))   )
5835          vb = MAX( vw, 0. )
5836
5837          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
5838                - rdy*(                                                 &
5839                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
5840                        w(i,k,j_end)*(                                  &
5841                                (2.-fzm(k-1))*(rv(i,k-1,jte)-rv(i,k-1,jte-1))-    &
5842                                fzp(k-1)*(rv(i,k-2,jte)-rv(i,k-2,jte-1)))    &
5843                                                                       )
5844        ENDDO
5845
5846    ENDIF
5847
5848 !-------------------- vertical advection
5849 !     ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
5850 !     Here we have:  - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
5851 !     Therefore we don't need to make a correction for advect_w
5852
5853     i_start = its
5854     i_end   = MIN(ite,ide-1)
5855     j_start = jts
5856     j_end   = MIN(jte,jde-1)
5857
5858     DO i = i_start, i_end
5859        vflux(i,kts)=0.
5860        vflux(i,kte)=0.
5861     ENDDO
5862
5863     vert_order_test : IF (vert_order == 6) THEN
5864
5865       DO j = j_start, j_end
5866
5867          DO k=kts+3,ktf-1
5868          DO i = i_start, i_end
5869            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5870            vflux(i,k) = vel*flux6(                                   &
5871                    w(i,k-3,j), w(i,k-2,j), w(i,k-1,j),       &
5872                    w(i,k  ,j), w(i,k+1,j), w(i,k+2,j),  -vel )
5873          ENDDO
5874          ENDDO
5875
5876          DO i = i_start, i_end
5877
5878            k=kts+1
5879            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5880
5881            k = kts+2
5882            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5883            vflux(i,k) = vel*flux4(               &
5884                    w(i,k-2,j), w(i,k-1,j),   &
5885                    w(i,k  ,j), w(i,k+1,j), -vel )
5886
5887            k = ktf
5888            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5889            vflux(i,k) = vel*flux4(               &
5890                    w(i,k-2,j), w(i,k-1,j),   &
5891                    w(i,k  ,j), w(i,k+1,j), -vel )
5892
5893            k=ktf+1
5894            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5895
5896          ENDDO
5897
5898          DO k=kts+1,ktf
5899          DO i = i_start, i_end
5900             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5901          ENDDO
5902          ENDDO
5903
5904 ! pick up flux contribution for w at the lid. wcs, 13 march 2004
5905          k = ktf+1
5906          DO i = i_start, i_end
5907            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5908          ENDDO
5909
5910       ENDDO
5911
5912  ELSE IF (vert_order == 5) THEN
5913
5914       DO j = j_start, j_end
5915
5916          DO k=kts+3,ktf-1
5917          DO i = i_start, i_end
5918            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5919            vflux(i,k) = vel*flux5(                                   &
5920                    w(i,k-3,j), w(i,k-2,j), w(i,k-1,j),       &
5921                    w(i,k  ,j), w(i,k+1,j), w(i,k+2,j),  -vel )
5922          ENDDO
5923          ENDDO
5924
5925          DO i = i_start, i_end
5926
5927            k=kts+1
5928            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5929
5930            k = kts+2
5931            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5932            vflux(i,k) = vel*flux3(               &
5933                    w(i,k-2,j), w(i,k-1,j),   &
5934                    w(i,k  ,j), w(i,k+1,j), -vel )
5935            k = ktf
5936            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5937            vflux(i,k) = vel*flux3(               &
5938                    w(i,k-2,j), w(i,k-1,j),   &
5939                    w(i,k  ,j), w(i,k+1,j), -vel )
5940
5941            k=ktf+1
5942            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5943
5944          ENDDO
5945
5946          DO k=kts+1,ktf
5947          DO i = i_start, i_end
5948             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5949          ENDDO
5950          ENDDO
5951
5952 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5953          k = ktf+1
5954          DO i = i_start, i_end
5955            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5956          ENDDO
5957
5958       ENDDO
5959
5960  ELSE IF (vert_order == 4) THEN
5961
5962       DO j = j_start, j_end
5963
5964          DO k=kts+2,ktf
5965          DO i = i_start, i_end
5966            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5967            vflux(i,k) = vel*flux4(              &
5968                    w(i,k-2,j), w(i,k-1,j),      &
5969                    w(i,k  ,j), w(i,k+1,j), -vel )
5970          ENDDO
5971          ENDDO
5972
5973          DO i = i_start, i_end
5974
5975            k=kts+1
5976            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5977            k=ktf+1
5978            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5979
5980          ENDDO
5981
5982          DO k=kts+1,ktf
5983          DO i = i_start, i_end
5984             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5985          ENDDO
5986          ENDDO
5987
5988 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5989          k = ktf+1
5990          DO i = i_start, i_end
5991            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5992          ENDDO
5993
5994       ENDDO
5995
5996  ELSE IF (vert_order == 3) THEN
5997
5998       DO j = j_start, j_end
5999
6000          DO k=kts+2,ktf
6001 !DEC$ vector always
6002          DO i = i_start, i_end
6003            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
6004            vflux(i,k) = vel*flux3(              &
6005                    w(i,k-2,j), w(i,k-1,j),      &
6006                    w(i,k  ,j), w(i,k+1,j), -vel )
6007          ENDDO
6008          ENDDO
6009
6010          DO i = i_start, i_end
6011
6012            k=kts+1
6013            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
6014            k=ktf+1
6015            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
6016
6017          ENDDO
6018
6019          DO k=kts+1,ktf
6020          DO i = i_start, i_end
6021             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
6022          ENDDO
6023          ENDDO
6024
6025 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
6026          k = ktf+1
6027          DO i = i_start, i_end
6028            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
6029          ENDDO
6030
6031       ENDDO
6032
6033  ELSE IF (vert_order == 2) THEN
6034
6035   DO j = j_start, j_end
6036      DO k=kts+1,ktf+1
6037      DO i = i_start, i_end
6038
6039             vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
6040      ENDDO
6041      ENDDO
6042      DO k=kts+1,ktf
6043      DO i = i_start, i_end
6044             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
6045
6046      ENDDO
6047      ENDDO
6048
6049 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
6050      k = ktf+1
6051      DO i = i_start, i_end
6052        tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
6053      ENDDO
6054
6055   ENDDO
6056
6057    ELSE
6058
6059       WRITE (wrf_err_message ,*) ' advect_w, v_order not known ',vert_order
6060       CALL wrf_error_fatal ( wrf_err_message )
6061
6062    ENDIF vert_order_test
6063
6064 END SUBROUTINE advect_w
6065
6066 !----------------------------------------------------------------
6067
6068 #endif
6069 SUBROUTINE advect_scalar_pd   ( field, field_old, tendency,    &
6070                                 h_tendency, z_tendency,        &
6071                                 ru, rv, rom,                   &
6072                                 c1, c2,                        &
6073                                 mut, mub, mu_old,              &
6074                                 time_step, config_flags,       &
6075                                 tenddec,                       &
6076                                 msfux, msfuy, msfvx, msfvy,    &
6077                                 msftx, msfty,                  &
6078                                 fzm, fzp,                      &
6079                                 rdx, rdy, rdzw, dt,            &
6080                                 ids, ide, jds, jde, kds, kde,  &
6081                                 ims, ime, jms, jme, kms, kme,  &
6082                                 its, ite, jts, jte, kts, kte  )
6083
6084 !  this is a first cut at a positive definite advection option
6085 !  for scalars in WRF.  This version is memory intensive ->
6086 !  we save 3d arrays of x, y and z both high and low order fluxes
6087 !  (six in all).  Alternatively, we could sweep in a direction
6088 !  and lower the cost considerably.
6089
6090 !  uses the Smolarkiewicz MWR 1989 approach, with addition of first-order
6091 !  fluxes initially
6092
6093 !  WCS, 3 December 2002, 24 February 2003
6094
6095    IMPLICIT NONE
6096
6097    ! Input data
6098
6099    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
6100
6101    LOGICAL ,                 INTENT(IN   ) :: tenddec  ! tendency flag
6102
6103    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
6104                                               ims, ime, jms, jme, kms, kme, &
6105                                               its, ite, jts, jte, kts, kte
6106
6107    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
6108                                                                       field_old, &
6109                                                                       ru,        &
6110                                                                       rv,        &
6111                                                                       rom
6112
6113    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut, mub, mu_old
6114    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
6115    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(  OUT) :: h_tendency, z_tendency
6116
6117    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
6118                                                                     msfuy,  &
6119                                                                     msfvx,  &
6120                                                                     msfvy,  &
6121                                                                     msftx,  &
6122                                                                     msfty
6123
6124    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
6125                                                                   fzp,  &
6126                                                                   rdzw, &
6127                                                                   c1,   &
6128                                                                   c2
6129
6130    REAL ,                                        INTENT(IN   ) :: rdx,  &
6131                                                                   rdy,  &
6132                                                                   dt
6133    INTEGER ,                                     INTENT(IN   ) :: time_step
6134
6135    ! Local data
6136
6137    INTEGER :: i, j, k, itf, jtf, ktf
6138    INTEGER :: i_start, i_end, j_start, j_end
6139    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
6140    INTEGER :: jmin, jmax, jp, jm, imin, imax
6141
6142    REAL    :: mrdx, mrdy, ub, vb, uw, vw, mu
6143
6144 !  storage for high and low order fluxes
6145
6146    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqx, fqy, fqz
6147
6148    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqxl, fqyl, fqzl
6149
6150    INTEGER :: horz_order, vert_order
6151
6152    LOGICAL :: degrade_xs, degrade_ys
6153    LOGICAL :: degrade_xe, degrade_ye
6154
6155    INTEGER :: jp1, jp0, jtmp
6156
6157    REAL,DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: flux_out, ph_low
6158    REAL :: scale
6159    !REAL :: flux_out, ph_low, scale
6160    REAL, PARAMETER :: eps=1.e-20
6161
6162
6163 ! definition of flux operators, 3rd, 4th, 5th or 6th order
6164
6165    REAL    :: flux3, flux4, flux5, flux6, flux_upwind
6166    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
6167
6168       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
6169             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
6170
6171       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
6172            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
6173            sign(1,time_step)*sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
6174
6175       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
6176             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
6177             +(1./60.)*(q_ip2+q_im3)
6178
6179       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
6180            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
6181             -sign(1,time_step)*sign(1.,ua)*(1./60.)*(           &
6182               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
6183
6184       flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 &
6185                                     +0.5*max(-1.0,(cr-abs(cr)))*q_i
6186
6187 !      flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
6188 !                                    +0.5*(1.-sign(1.,cr))*q_i
6189 !      flux_upwind(q_im1, q_i, cr ) = 0.
6190
6191     REAL     :: dx,dy,dz
6192
6193     LOGICAL, PARAMETER :: pd_limit = .true.
6194
6195 ! set order for the advection schemes
6196
6197 !  write(6,*) ' in pd advection routine '
6198
6199     ! Empty arrays just in case:
6200     IF (config_flags%polar) THEN
6201        fqx(:,:,:)  = 0.
6202        fqy(:,:,:)  = 0.
6203        fqz(:,:,:)  = 0.
6204        fqxl(:,:,:) = 0.
6205        fqyl(:,:,:) = 0.
6206        fqzl(:,:,:) = 0.
6207     END IF
6208
6209   ktf=MIN(kte,kde-1)
6210   horz_order = config_flags%h_sca_adv_order
6211   vert_order = config_flags%v_sca_adv_order
6212
6213 !  determine boundary mods for flux operators
6214 !  We degrade the flux operators from 3rd/4th order
6215 !   to second order one gridpoint in from the boundaries for
6216 !   all boundary conditions except periodic and symmetry - these
6217 !   conditions have boundary zone data fill for correct application
6218 !   of the higher order flux stencils
6219
6220    degrade_xs = .true.
6221    degrade_xe = .true.
6222    degrade_ys = .true.
6223    degrade_ye = .true.
6224
6225 !  begin with horizontal flux divergence
6226 !  here is the choice of flux operators
6227
6228
6229   horizontal_order_test : IF( horz_order == 6 ) THEN
6230
6231    IF( config_flags%periodic_x   .or. &
6232        config_flags%symmetric_xs .or. &
6233        (its > ids+3)                ) degrade_xs = .false.
6234    IF( config_flags%periodic_x   .or. &
6235        config_flags%symmetric_xe .or. &
6236        (ite < ide-4)                ) degrade_xe = .false.
6237    IF( config_flags%periodic_y   .or. &
6238        config_flags%symmetric_ys .or. &
6239        (jts > jds+3)                ) degrade_ys = .false.
6240    IF( config_flags%periodic_y   .or. &
6241        config_flags%symmetric_ye .or. &
6242        (jte < jde-4)                ) degrade_ye = .false.
6243
6244 !--------------- y - advection first
6245
6246 !--  y flux compute; these bounds are for periodic and sym b.c.
6247
6248       ktf=MIN(kte,kde-1)
6249       i_start = its-1
6250       i_end   = MIN(ite,ide-1)+1
6251       j_start = jts-1
6252       j_end   = MIN(jte,jde-1)+1
6253       j_start_f = j_start
6254       j_end_f   = j_end+1
6255
6256 !--  modify loop bounds if open or specified
6257
6258 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
6259 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
6260       IF(degrade_xs) i_start = MAX(its-1,ids)
6261       IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
6262
6263       IF(degrade_ys) then
6264         j_start = MAX(jts-1,jds+1)
6265         j_start_f = jds+3
6266       ENDIF
6267
6268       IF(degrade_ye) then
6269         j_end = MIN(jte+1,jde-2)
6270         j_end_f = jde-3
6271       ENDIF
6272
6273 !  compute fluxes, 6th order
6274
6275       j_loop_y_flux_6 : DO j = j_start, j_end+1
6276
6277       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6278
6279         DO k=kts,ktf
6280         DO i = i_start, i_end
6281
6282           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6283           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6284           vel = rv(i,k,j)
6285           cr = vel*dt/dy/mu
6286           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6287
6288           fqy( i, k, j  ) = vel*flux6(                                  &
6289                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
6290                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
6291
6292           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6293
6294         ENDDO
6295         ENDDO
6296
6297       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
6298
6299             DO k=kts,ktf
6300             DO i = i_start, i_end
6301
6302               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6303               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6304               vel = rv(i,k,j)
6305               cr = vel*dt/dy/mu
6306               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6307
6308               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
6309                      (field(i,k,j)+field(i,k,j-1))
6310
6311               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6312
6313             ENDDO
6314             ENDDO
6315
6316       ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
6317
6318             DO k=kts,ktf
6319             DO i = i_start, i_end
6320
6321               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6322               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6323               vel = rv(i,k,j)
6324               cr = vel*dt/dy/mu
6325               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6326
6327               fqy( i, k, j ) = vel*flux4(              &
6328                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
6329               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6330
6331             ENDDO
6332             ENDDO
6333
6334       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
6335
6336             DO k=kts,ktf
6337             DO i = i_start, i_end
6338
6339               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6340               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6341               vel = rv(i,k,j)
6342               cr = vel*dt/dy/mu
6343               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6344
6345               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
6346                      (field(i,k,j)+field(i,k,j-1))
6347               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6348
6349             ENDDO
6350             ENDDO
6351
6352       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
6353
6354             DO k=kts,ktf
6355             DO i = i_start, i_end
6356
6357               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6358               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6359               vel = rv(i,k,j)
6360               cr = vel*dt/dy/mu
6361               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6362
6363               fqy( i, k, j) = vel*flux4(             &
6364                    field(i,k,j-2),field(i,k,j-1),    &
6365                    field(i,k,j),field(i,k,j+1),vel )
6366               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6367
6368             ENDDO
6369             ENDDO
6370
6371       ENDIF
6372
6373    ENDDO j_loop_y_flux_6
6374
6375 !  next, x flux
6376
6377 !--  these bounds are for periodic and sym conditions
6378
6379       i_start = its-1
6380       i_end   = MIN(ite,ide-1)+1
6381       i_start_f = i_start
6382       i_end_f   = i_end+1
6383
6384       j_start = jts-1
6385       j_end   = MIN(jte,jde-1)+1
6386
6387 !--  modify loop bounds for open and specified b.c
6388
6389 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
6390 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
6391       IF(degrade_ys) j_start = MAX(jts-1,jds)
6392       IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
6393
6394       IF(degrade_xs) then
6395         i_start = MAX(ids+1,its-1)
6396         i_start_f = ids+3
6397       ENDIF
6398
6399       IF(degrade_xe) then
6400         i_end = MIN(ide-2,ite+1)
6401         i_end_f = ide-3
6402       ENDIF
6403
6404 !  compute fluxes
6405
6406       DO j = j_start, j_end
6407
6408 !  5th order flux
6409
6410         DO k=kts,ktf
6411         DO i = i_start_f, i_end_f
6412
6413           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6414           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6415           vel = ru(i,k,j)
6416           cr = vel*dt/dx/mu
6417           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6418
6419           fqx( i,k,j ) = vel*flux6( field(i-3,k,j), field(i-2,k,j),  &
6420                                          field(i-1,k,j), field(i  ,k,j),  &
6421                                          field(i+1,k,j), field(i+2,k,j),  &
6422                                          vel                             )
6423           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6424
6425         ENDDO
6426         ENDDO
6427
6428 !  lower order fluxes close to boundaries (if not periodic or symmetric)
6429
6430         IF( degrade_xs ) THEN
6431
6432           DO i=i_start,i_start_f-1
6433
6434             IF(i == ids+1) THEN ! second order
6435               DO k=kts,ktf
6436                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6437                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6438                 vel = ru(i,k,j)/mu
6439                 cr = vel*dt/dx
6440                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6441                 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6442                        *(field(i,k,j)+field(i-1,k,j))
6443                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6444               ENDDO
6445             ENDIF
6446
6447             IF(i == ids+2) THEN  ! fourth order
6448               DO k=kts,ktf
6449                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6450                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6451                 vel = ru(i,k,j)
6452                 cr = vel*dt/dx/mu
6453                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6454                 fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
6455                                           field(i  ,k,j), field(i+1,k,j),  &
6456                                           vel                             )
6457                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6458               ENDDO
6459             ENDIF
6460
6461           ENDDO
6462
6463         ENDIF
6464
6465         IF( degrade_xe ) THEN
6466
6467           DO i = i_end_f+1, i_end+1
6468
6469             IF( i == ide-1 ) THEN ! second order flux next to the boundary
6470               DO k=kts,ktf
6471                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6472                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6473                 vel = ru(i,k,j)
6474                 cr = vel*dt/dx/mu
6475                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6476                 fqx(i,k,j) = 0.5*(ru(i,k,j))      &
6477                        *(field(i,k,j)+field(i-1,k,j))
6478                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6479               ENDDO
6480             ENDIF
6481
6482
6483             IF( i == ide-2 ) THEN ! fourth order flux one in from the boundary
6484               DO k=kts,ktf
6485                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6486                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6487                 vel = ru(i,k,j)
6488                 cr = vel*dt/dx/mu
6489                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6490                 fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
6491                                           field(i  ,k,j), field(i+1,k,j),  &
6492                                           vel                             )
6493                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6494               ENDDO
6495             ENDIF
6496
6497           ENDDO
6498
6499         ENDIF
6500
6501       ENDDO  ! enddo for outer J loop
6502
6503 !--- end of 6th order horizontal flux calculation
6504
6505     ELSE IF( horz_order == 5 ) THEN
6506
6507    IF( config_flags%periodic_x   .or. &
6508        config_flags%symmetric_xs .or. &
6509        (its > ids+3)                ) degrade_xs = .false.
6510    IF( config_flags%periodic_x   .or. &
6511        config_flags%symmetric_xe .or. &
6512        (ite < ide-4)                ) degrade_xe = .false.
6513    IF( config_flags%periodic_y   .or. &
6514        config_flags%symmetric_ys .or. &
6515        (jts > jds+3)                ) degrade_ys = .false.
6516    IF( config_flags%periodic_y   .or. &
6517        config_flags%symmetric_ye .or. &
6518        (jte < jde-4)                ) degrade_ye = .false.
6519
6520 !--------------- y - advection first
6521
6522 !--  y flux compute; these bounds are for periodic and sym b.c.
6523
6524       ktf=MIN(kte,kde-1)
6525       i_start = its-1
6526       i_end   = MIN(ite,ide-1)+1
6527       j_start = jts-1
6528       j_end   = MIN(jte,jde-1)+1
6529       j_start_f = j_start
6530       j_end_f   = j_end+1
6531
6532 !--  modify loop bounds if open or specified
6533
6534 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
6535 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
6536       IF(degrade_xs) i_start = MAX(its-1,ids)
6537       IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
6538
6539       IF(degrade_ys) then
6540         j_start = MAX(jts-1,jds+1)
6541         j_start_f = jds+3
6542       ENDIF
6543
6544       IF(degrade_ye) then
6545         j_end = MIN(jte+1,jde-2)
6546         j_end_f = jde-3
6547       ENDIF
6548
6549 !  compute fluxes, 5th order
6550
6551       j_loop_y_flux_5 : DO j = j_start, j_end+1
6552
6553       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6554
6555         DO k=kts,ktf
6556         DO i = i_start, i_end
6557
6558           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6559           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6560           vel = rv(i,k,j)
6561           cr = vel*dt/dy/mu
6562           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6563
6564           fqy( i, k, j  ) = vel*flux5(                                  &
6565                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
6566                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
6567
6568           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6569
6570         ENDDO
6571         ENDDO
6572
6573       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
6574
6575             DO k=kts,ktf
6576             DO i = i_start, i_end
6577
6578               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6579               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6580               vel = rv(i,k,j)
6581               cr = vel*dt/dy/mu
6582               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6583
6584               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
6585                      (field(i,k,j)+field(i,k,j-1))
6586
6587               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6588
6589             ENDDO
6590             ENDDO
6591
6592       ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
6593
6594             DO k=kts,ktf
6595             DO i = i_start, i_end
6596
6597               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6598               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6599               vel = rv(i,k,j)
6600               cr = vel*dt/dy/mu
6601               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6602
6603               fqy( i, k, j ) = vel*flux3(              &
6604                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
6605               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6606
6607             ENDDO
6608             ENDDO
6609
6610       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
6611
6612             DO k=kts,ktf
6613             DO i = i_start, i_end
6614
6615               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6616               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6617               vel = rv(i,k,j)
6618               cr = vel*dt/dy/mu
6619               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6620
6621               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
6622                      (field(i,k,j)+field(i,k,j-1))
6623               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6624
6625             ENDDO
6626             ENDDO
6627
6628       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
6629
6630             DO k=kts,ktf
6631             DO i = i_start, i_end
6632
6633               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6634               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6635               vel = rv(i,k,j)
6636               cr = vel*dt/dy/mu
6637               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6638
6639               fqy( i, k, j) = vel*flux3(             &
6640                    field(i,k,j-2),field(i,k,j-1),    &
6641                    field(i,k,j),field(i,k,j+1),vel )
6642               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6643
6644             ENDDO
6645             ENDDO
6646
6647       ENDIF
6648
6649    ENDDO j_loop_y_flux_5
6650
6651 !  next, x flux
6652
6653 !--  these bounds are for periodic and sym conditions
6654
6655       i_start = its-1
6656       i_end   = MIN(ite,ide-1)+1
6657       i_start_f = i_start
6658       i_end_f   = i_end+1
6659
6660       j_start = jts-1
6661       j_end   = MIN(jte,jde-1)+1
6662
6663 !--  modify loop bounds for open and specified b.c
6664
6665 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
6666 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
6667       IF(degrade_ys) j_start = MAX(jts-1,jds)
6668       IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
6669
6670       IF(degrade_xs) then
6671         i_start = MAX(ids+1,its-1)
6672         i_start_f = ids+3
6673       ENDIF
6674
6675       IF(degrade_xe) then
6676         i_end = MIN(ide-2,ite+1)
6677         i_end_f = ide-3
6678       ENDIF
6679
6680 !  compute fluxes
6681
6682       DO j = j_start, j_end
6683
6684 !  5th order flux
6685
6686         DO k=kts,ktf
6687         DO i = i_start_f, i_end_f
6688
6689           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6690           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6691           vel = ru(i,k,j)
6692           cr = vel*dt/dx/mu
6693           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6694
6695           fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
6696                                          field(i-1,k,j), field(i  ,k,j),  &
6697                                          field(i+1,k,j), field(i+2,k,j),  &
6698                                          vel                             )
6699           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6700
6701         ENDDO
6702         ENDDO
6703
6704 !  lower order fluxes close to boundaries (if not periodic or symmetric)
6705
6706         IF( degrade_xs ) THEN
6707
6708           DO i=i_start,i_start_f-1
6709
6710             IF(i == ids+1) THEN ! second order
6711               DO k=kts,ktf
6712                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6713                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6714                 vel = ru(i,k,j)/mu
6715                 cr = vel*dt/dx
6716                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6717                 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6718                        *(field(i,k,j)+field(i-1,k,j))
6719                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6720               ENDDO
6721             ENDIF
6722
6723             IF(i == ids+2) THEN  ! third order
6724               DO k=kts,ktf
6725                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6726                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6727                 vel = ru(i,k,j)
6728                 cr = vel*dt/dx/mu
6729                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6730                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
6731                                           field(i  ,k,j), field(i+1,k,j),  &
6732                                           vel                             )
6733                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6734               ENDDO
6735             ENDIF
6736
6737           ENDDO
6738
6739         ENDIF
6740
6741         IF( degrade_xe ) THEN
6742
6743           DO i = i_end_f+1, i_end+1
6744
6745             IF( i == ide-1 ) THEN ! second order flux next to the boundary
6746               DO k=kts,ktf
6747                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6748                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6749                 vel = ru(i,k,j)
6750                 cr = vel*dt/dx/mu
6751                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6752                 fqx(i,k,j) = 0.5*(ru(i,k,j))      &
6753                        *(field(i,k,j)+field(i-1,k,j))
6754                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6755               ENDDO
6756             ENDIF
6757
6758
6759             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
6760               DO k=kts,ktf
6761                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6762                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6763                 vel = ru(i,k,j)
6764                 cr = vel*dt/dx/mu
6765                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6766                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
6767                                           field(i  ,k,j), field(i+1,k,j),  &
6768                                           vel                             )
6769                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6770               ENDDO
6771             ENDIF
6772
6773           ENDDO
6774
6775         ENDIF
6776
6777       ENDDO  ! enddo for outer J loop
6778
6779 !--- end of 5th order horizontal flux calculation
6780
6781     ELSE IF( horz_order == 4 ) THEN
6782
6783    IF( config_flags%periodic_x   .or. &
6784        config_flags%symmetric_xs .or. &
6785        (its > ids+1)                ) degrade_xs = .false.
6786    IF( config_flags%periodic_x   .or. &
6787        config_flags%symmetric_xe .or. &
6788        (ite < ide-2)                ) degrade_xe = .false.
6789    IF( config_flags%periodic_y   .or. &
6790        config_flags%symmetric_ys .or. &
6791        (jts > jds+1)                ) degrade_ys = .false.
6792    IF( config_flags%periodic_y   .or. &
6793        config_flags%symmetric_ye .or. &
6794        (jte < jde-2)                ) degrade_ye = .false.
6795
6796 !--------------- y - advection first
6797
6798 !--  y flux compute; these bounds are for periodic and sym b.c.
6799
6800       ktf=MIN(kte,kde-1)
6801       i_start = its-1
6802       i_end   = MIN(ite,ide-1)+1
6803       j_start = jts-1
6804       j_end   = MIN(jte,jde-1)+1
6805       j_start_f = j_start
6806       j_end_f   = j_end+1
6807
6808 !--  modify loop bounds if open or specified
6809
6810       IF(degrade_xs) i_start = its
6811       IF(degrade_xe) i_end   = MIN(ite,ide-1)
6812
6813       IF(degrade_ys) then
6814         j_start = MAX(jts,jds+1)
6815         j_start_f = jds+2
6816       ENDIF
6817
6818       IF(degrade_ye) then
6819         j_end = MIN(jte,jde-2)
6820         j_end_f = jde-2
6821       ENDIF
6822
6823 !  compute fluxes, 4th order
6824
6825       j_loop_y_flux_4 : DO j = j_start, j_end+1
6826
6827       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6828
6829         DO k=kts,ktf
6830         DO i = i_start, i_end
6831
6832           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6833           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6834           vel = rv(i,k,j)
6835           cr = vel*dt/dy/mu
6836           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6837
6838           fqy( i, k, j  ) = vel*flux4(  field(i,k,j-2), field(i,k,j-1),       &
6839                                         field(i,k,j  ), field(i,k,j+1), vel )
6840
6841           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6842
6843         ENDDO
6844         ENDDO
6845
6846       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
6847
6848             DO k=kts,ktf
6849             DO i = i_start, i_end
6850
6851               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6852               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6853               vel = rv(i,k,j)
6854               cr = vel*dt/dy/mu
6855               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6856
6857               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
6858                      (field(i,k,j)+field(i,k,j-1))
6859
6860               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6861
6862             ENDDO
6863             ENDDO
6864
6865       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
6866
6867             DO k=kts,ktf
6868             DO i = i_start, i_end
6869
6870               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6871               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
6872               vel = rv(i,k,j)
6873               cr = vel*dt/dy/mu
6874               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6875
6876               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
6877                      (field(i,k,j)+field(i,k,j-1))
6878               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6879
6880             ENDDO
6881             ENDDO
6882
6883       ENDIF
6884
6885    ENDDO j_loop_y_flux_4
6886
6887 !  next, x flux
6888
6889 !--  these bounds are for periodic and sym conditions
6890
6891       i_start = its-1
6892       i_end   = MIN(ite,ide-1)+1
6893       i_start_f = i_start
6894       i_end_f   = i_end+1
6895
6896       j_start = jts-1
6897       j_end   = MIN(jte,jde-1)+1
6898
6899 !--  modify loop bounds for open and specified b.c
6900
6901       IF(degrade_ys) j_start = jts
6902       IF(degrade_ye) j_end   = MIN(jte,jde-1)
6903
6904       IF(degrade_xs) then
6905         i_start = MAX(ids+1,its)
6906         i_start_f = i_start+1
6907       ENDIF
6908
6909       IF(degrade_xe) then
6910         i_end = MIN(ide-2,ite)
6911         i_end_f = ide-2
6912       ENDIF
6913
6914 !  compute fluxes
6915
6916       DO j = j_start, j_end
6917
6918 !  4th order flux
6919
6920         DO k=kts,ktf
6921         DO i = i_start_f, i_end_f
6922
6923           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6924           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6925           vel = ru(i,k,j)
6926           cr = vel*dt/dx/mu
6927           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6928
6929           fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), &
6930                                     field(i  ,k,j), field(i+1,k,j), vel )
6931           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6932
6933         ENDDO
6934         ENDDO
6935
6936 !  lower order fluxes close to boundaries (if not periodic or symmetric)
6937
6938         IF( degrade_xs ) THEN
6939           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
6940             i = ids+1
6941             DO k=kts,ktf
6942
6943               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6944               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6945               vel = ru(i,k,j)/mu
6946               cr = vel*dt/dx
6947               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6948
6949               fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6950                      *(field(i,k,j)+field(i-1,k,j))
6951
6952               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6953
6954             ENDDO
6955           ENDIF
6956         ENDIF
6957
6958         IF( degrade_xe ) THEN
6959           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
6960             i = ide-1
6961             DO k=kts,ktf
6962               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6963               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
6964               vel = ru(i,k,j)
6965               cr = vel*dt/dx/mu
6966               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6967               fqx(i,k,j) = 0.5*(ru(i,k,j))      &
6968                      *(field(i,k,j)+field(i-1,k,j))
6969               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6970
6971             ENDDO
6972           ENDIF
6973         ENDIF
6974
6975       ENDDO  ! enddo for outer J loop
6976
6977 !--- end of 4th order horizontal flux calculation
6978
6979    ELSE IF( horz_order == 3 ) THEN
6980
6981    IF( config_flags%periodic_x   .or. &
6982        config_flags%symmetric_xs .or. &
6983        (its > ids+2)                ) degrade_xs = .false.
6984    IF( config_flags%periodic_x   .or. &
6985        config_flags%symmetric_xe .or. &
6986        (ite < ide-1)                ) degrade_xe = .false.
6987    IF( config_flags%periodic_y   .or. &
6988        config_flags%symmetric_ys .or. &
6989        (jts > jds+2)                ) degrade_ys = .false.
6990    IF( config_flags%periodic_y   .or. &
6991        config_flags%symmetric_ye .or. &
6992        (jte < jde-1)                ) degrade_ye = .false.
6993
6994 !--------------- y - advection first
6995
6996 !--  y flux compute; these bounds are for periodic and sym b.c.
6997
6998       ktf=MIN(kte,kde-1)
6999       i_start = its-1
7000       i_end   = MIN(ite,ide-1)+1
7001       j_start = jts-1
7002       j_end   = MIN(jte,jde-1)+1
7003       j_start_f = j_start
7004       j_end_f   = j_end+1
7005
7006 !--  modify loop bounds if open or specified
7007
7008       IF(degrade_xs) i_start = its
7009       IF(degrade_xe) i_end   = MIN(ite,ide-1)
7010
7011       IF(degrade_ys) then
7012         j_start = MAX(jts,jds+1)
7013         j_start_f = jds+2
7014       ENDIF
7015
7016       IF(degrade_ye) then
7017         j_end = MIN(jte,jde-2)
7018         j_end_f = jde-2
7019       ENDIF
7020
7021 !  compute fluxes, 3rd order
7022
7023       j_loop_y_flux_3 : DO j = j_start, j_end+1
7024
7025       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
7026
7027         DO k=kts,ktf
7028         DO i = i_start, i_end
7029
7030           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
7031           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
7032           vel = rv(i,k,j)
7033           cr = vel*dt/dy/mu
7034           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
7035
7036           fqy( i, k, j  ) = vel*flux3(  field(i,k,j-2), field(i,k,j-1),       &
7037                                         field(i,k,j  ), field(i,k,j+1), vel )
7038
7039           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7040
7041         ENDDO
7042         ENDDO
7043
7044       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
7045
7046             DO k=kts,ktf
7047             DO i = i_start, i_end
7048
7049               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
7050               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
7051               vel = rv(i,k,j)
7052               cr = vel*dt/dy/mu
7053               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
7054
7055               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
7056                      (field(i,k,j)+field(i,k,j-1))
7057
7058               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7059
7060             ENDDO
7061             ENDDO
7062
7063       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
7064
7065             DO k=kts,ktf
7066             DO i = i_start, i_end
7067
7068               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
7069               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
7070               vel = rv(i,k,j)
7071               cr = vel*dt/dy/mu
7072               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
7073
7074               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
7075                      (field(i,k,j)+field(i,k,j-1))
7076               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7077
7078             ENDDO
7079             ENDDO
7080
7081       ENDIF
7082
7083    ENDDO j_loop_y_flux_3
7084
7085 !  next, x flux
7086
7087 !--  these bounds are for periodic and sym conditions
7088
7089       i_start = its-1
7090       i_end   = MIN(ite,ide-1)+1
7091       i_start_f = i_start
7092       i_end_f   = i_end+1
7093
7094       j_start = jts-1
7095       j_end   = MIN(jte,jde-1)+1
7096
7097 !--  modify loop bounds for open and specified b.c
7098
7099       IF(degrade_ys) j_start = jts
7100       IF(degrade_ye) j_end   = MIN(jte,jde-1)
7101
7102       IF(degrade_xs) then
7103         i_start = MAX(ids+1,its)
7104         i_start_f = i_start+1
7105       ENDIF
7106
7107       IF(degrade_xe) then
7108         i_end = MIN(ide-2,ite)
7109         i_end_f = ide-2
7110       ENDIF
7111
7112 !  compute fluxes
7113
7114       DO j = j_start, j_end
7115
7116 !  4th order flux
7117
7118         DO k=kts,ktf
7119         DO i = i_start_f, i_end_f
7120
7121           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
7122           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
7123           vel = ru(i,k,j)
7124           cr = vel*dt/dx/mu
7125           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
7126
7127           fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), &
7128                                     field(i  ,k,j), field(i+1,k,j), vel )
7129           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7130
7131         ENDDO
7132         ENDDO
7133
7134 !  lower order fluxes close to boundaries (if not periodic or symmetric)
7135
7136         IF( degrade_xs ) THEN
7137
7138           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
7139             i = ids+1
7140             DO k=kts,ktf
7141
7142               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
7143               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
7144               vel = ru(i,k,j)/mu
7145               cr = vel*dt/dx
7146               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
7147
7148               fqx(i,k,j) = 0.5*(ru(i,k,j)) &
7149                      *(field(i,k,j)+field(i-1,k,j))
7150
7151               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7152
7153             ENDDO
7154           ENDIF
7155         ENDIF
7156
7157         IF( degrade_xe ) THEN
7158           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
7159             i = ide-1
7160             DO k=kts,ktf
7161               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
7162               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
7163               vel = ru(i,k,j)
7164               cr = vel*dt/dx/mu
7165               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
7166               fqx(i,k,j) = 0.5*(ru(i,k,j))      &
7167                      *(field(i,k,j)+field(i-1,k,j))
7168               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7169
7170             ENDDO
7171           ENDIF
7172         ENDIF
7173
7174       ENDDO  ! enddo for outer J loop
7175
7176 !--- end of 3rd order horizontal flux calculation
7177
7178
7179    ELSE IF( horz_order == 2 ) THEN
7180
7181    IF( config_flags%periodic_x   .or. &
7182        config_flags%symmetric_xs .or. &
7183        (its > ids+1)                ) degrade_xs = .false.
7184    IF( config_flags%periodic_x   .or. &
7185        config_flags%symmetric_xe .or. &
7186        (ite < ide-2)                ) degrade_xe = .false.
7187    IF( config_flags%periodic_y   .or. &
7188        config_flags%symmetric_ys .or. &
7189        (jts > jds+1)                ) degrade_ys = .false.
7190    IF( config_flags%periodic_y   .or. &
7191        config_flags%symmetric_ye .or. &
7192        (jte < jde-2)                ) degrade_ye = .false.
7193
7194 !--  y flux compute; these bounds are for periodic and sym b.c.
7195
7196       ktf=MIN(kte,kde-1)
7197       i_start = its-1
7198       i_end   = MIN(ite,ide-1)+1
7199       j_start = jts-1
7200       j_end   = MIN(jte,jde-1)+1
7201
7202 !--  modify loop bounds if open or specified
7203
7204       IF(degrade_xs) i_start = its
7205       IF(degrade_xe) i_end   = MIN(ite,ide-1)
7206       IF(degrade_ys) j_start = MAX(jts,jds+1)
7207       IF(degrade_ye) j_end = MIN(jte,jde-2)
7208
7209 !  compute fluxes, 2nd order, y flux
7210
7211       DO j = j_start, j_end+1
7212         DO k=kts,ktf
7213         DO i = i_start, i_end
7214            dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
7215            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
7216            vel = rv(i,k,j)
7217            cr = vel*dt/dy/mu
7218            fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
7219
7220            fqy(i,k, j) = 0.5*rv(i,k,j)*          &
7221                   (field(i,k,j)+field(i,k,j-1))
7222
7223            fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7224         ENDDO
7225         ENDDO
7226       ENDDO
7227
7228 !  next, x flux
7229
7230       DO j = j_start, j_end
7231         DO k=kts,ktf
7232         DO i = i_start, i_end+1
7233             dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
7234             mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
7235             vel = ru(i,k,j)
7236             cr = vel*dt/dx/mu
7237             fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
7238             fqx( i,k,j ) = 0.5*ru(i,k,j)*          &
7239                   (field(i,k,j)+field(i-1,k,j))
7240
7241             fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7242         ENDDO
7243         ENDDO
7244       ENDDO
7245
7246 !--- end of 2nd order horizontal flux calculation
7247
7248    ELSE
7249
7250       WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order
7251       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
7252
7253    ENDIF horizontal_order_test
7254
7255 !  pick up the rest of the horizontal radiation boundary conditions.
7256 !  (these are the computations that don't require 'cb'.
7257 !  first, set to index ranges
7258
7259       i_start = its
7260       i_end   = MIN(ite,ide-1)
7261       j_start = jts
7262       j_end   = MIN(jte,jde-1)
7263
7264 !  compute x (u) conditions for v, w, or scalar
7265
7266    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
7267
7268        DO j = j_start, j_end
7269        DO k = kts, ktf
7270          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
7271          tendency(its,k,j) = tendency(its,k,j)                     &
7272                - rdx*(                                             &
7273                        ub*(   field_old(its+1,k,j)                 &
7274                             - field_old(its  ,k,j)   ) +           &
7275                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
7276                                                                 )
7277        ENDDO
7278        ENDDO
7279
7280    ENDIF
7281
7282    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
7283
7284        DO j = j_start, j_end
7285        DO k = kts, ktf
7286          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
7287          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
7288                - rdx*(                                               &
7289                        ub*(  field_old(i_end  ,k,j)                  &
7290                            - field_old(i_end-1,k,j) ) +              &
7291                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
7292                                                                     )
7293        ENDDO
7294        ENDDO
7295
7296    ENDIF
7297
7298    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
7299
7300        DO i = i_start, i_end
7301        DO k = kts, ktf
7302          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
7303          tendency(i,k,jts) = tendency(i,k,jts)                     &
7304                - rdy*(                                             &
7305                        vb*(  field_old(i,k,jts+1)                  &
7306                            - field_old(i,k,jts  ) ) +              &
7307                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
7308                                                                 )
7309        ENDDO
7310        ENDDO
7311
7312    ENDIF
7313
7314    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
7315
7316        DO i = i_start, i_end
7317        DO k = kts, ktf
7318          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
7319          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
7320                - rdy*(                                               &
7321                        vb*(   field_old(i,k,j_end  )                 &
7322                             - field_old(i,k,j_end-1) ) +             &
7323                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
7324                                                                     )
7325        ENDDO
7326        ENDDO
7327
7328    ENDIF
7329
7330    IF( (config_flags%polar) .and. (jts == jds) ) THEN
7331
7332        ! Assuming rv(i,k,jds) = 0.
7333        DO i = i_start, i_end
7334        DO k = kts, ktf
7335          vb = MIN( 0.5*rv(i,k,jts+1), 0. )
7336          tendency(i,k,jts) = tendency(i,k,jts)                     &
7337                - rdy*(                                             &
7338                        vb*(  field_old(i,k,jts+1)                  &
7339                            - field_old(i,k,jts  ) ) +              &
7340                        field(i,k,jts)*rv(i,k,jts+1)                &
7341                                                                 )
7342        ENDDO
7343        ENDDO
7344
7345    ENDIF
7346
7347    IF( (config_flags%polar) .and. (jte == jde)) THEN
7348
7349        ! Assuming rv(i,k,jde) = 0.
7350        DO i = i_start, i_end
7351        DO k = kts, ktf
7352          vb = MAX( 0.5*rv(i,k,jte-1), 0. )
7353          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
7354                - rdy*(                                               &
7355                        vb*(   field_old(i,k,j_end  )                 &
7356                             - field_old(i,k,j_end-1) ) +             &
7357                        field(i,k,j_end)*(-rv(i,k,jte-1))             &
7358                                                                     )
7359        ENDDO
7360        ENDDO
7361
7362    ENDIF
7363
7364 !-------------------- vertical advection
7365
7366 !-- loop bounds for periodic or sym conditions
7367
7368       i_start = its-1
7369       i_end   = MIN(ite,ide-1)+1
7370       j_start = jts-1
7371       j_end   = MIN(jte,jde-1)+1
7372
7373 !-- loop bounds for open or specified conditions
7374
7375     IF(degrade_xs) i_start = MAX(its-1,ids)
7376     IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
7377     IF(degrade_ys) j_start = MAX(jts-1,jds)
7378     IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
7379
7380     vert_order_test : IF (vert_order == 6) THEN
7381
7382       DO j = j_start, j_end
7383
7384          DO i = i_start, i_end
7385            fqz(i,1,j)  = 0.
7386            fqzl(i,1,j) = 0.
7387            fqz(i,kde,j)  = 0.
7388            fqzl(i,kde,j) = 0.
7389          ENDDO
7390
7391          DO k=kts+3,ktf-2
7392          DO i = i_start, i_end
7393            dz = 2./(rdzw(k)+rdzw(k-1))
7394            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7395            vel = rom(i,k,j)
7396            cr = vel*dt/dz/mu
7397            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7398
7399            fqz(i,k,j) = vel*flux6( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
7400                                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
7401            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7402          ENDDO
7403          ENDDO
7404
7405          DO i = i_start, i_end
7406
7407            k=kts+1
7408            dz = 2./(rdzw(k)+rdzw(k-1))
7409            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7410            vel = rom(i,k,j)
7411            cr = vel*dt/dz/mu
7412            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7413            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7414            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7415
7416            k=kts+2
7417            dz = 2./(rdzw(k)+rdzw(k-1))
7418            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7419            vel = rom(i,k,j)
7420            cr = vel*dt/dz/mu
7421            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7422
7423            fqz(i,k,j) = vel*flux4(                      &
7424                    field(i,k-2,j), field(i,k-1,j),      &
7425                    field(i,k  ,j), field(i,k+1,j),  -vel )
7426            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7427
7428            k=ktf-1
7429            dz = 2./(rdzw(k)+rdzw(k-1))
7430            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7431            vel = rom(i,k,j)
7432            cr = vel*dt/dz/mu
7433            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7434
7435            fqz(i,k,j) = vel*flux4(                      &
7436                    field(i,k-2,j), field(i,k-1,j),      &
7437                    field(i,k  ,j), field(i,k+1,j),  -vel )
7438            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7439
7440            k=ktf
7441            dz = 2./(rdzw(k)+rdzw(k-1))
7442            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7443            vel = rom(i,k,j)
7444            cr = vel*dt/dz/mu
7445            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7446            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7447            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7448
7449          ENDDO
7450
7451       ENDDO
7452
7453     ELSE IF (vert_order == 5) THEN
7454
7455       DO j = j_start, j_end
7456
7457          DO i = i_start, i_end
7458            fqz(i,1,j)  = 0.
7459            fqzl(i,1,j) = 0.
7460            fqz(i,kde,j)  = 0.
7461            fqzl(i,kde,j) = 0.
7462          ENDDO
7463
7464          DO k=kts+3,ktf-2
7465          DO i = i_start, i_end
7466            dz = 2./(rdzw(k)+rdzw(k-1))
7467            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7468            vel = rom(i,k,j)
7469            cr = vel*dt/dz/mu
7470            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7471
7472            fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
7473                                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
7474            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7475          ENDDO
7476          ENDDO
7477
7478          DO i = i_start, i_end
7479
7480            k=kts+1
7481            dz = 2./(rdzw(k)+rdzw(k-1))
7482            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7483            vel = rom(i,k,j)
7484            cr = vel*dt/dz/mu
7485            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7486            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7487            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7488
7489            k=kts+2
7490            dz = 2./(rdzw(k)+rdzw(k-1))
7491            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7492            vel = rom(i,k,j)
7493            cr = vel*dt/dz/mu
7494            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7495
7496            fqz(i,k,j) = vel*flux3(                      &
7497                    field(i,k-2,j), field(i,k-1,j),      &
7498                    field(i,k  ,j), field(i,k+1,j),  -vel )
7499            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7500
7501            k=ktf-1
7502            dz = 2./(rdzw(k)+rdzw(k-1))
7503            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7504            vel = rom(i,k,j)
7505            cr = vel*dt/dz/mu
7506            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7507
7508            fqz(i,k,j) = vel*flux3(                      &
7509                    field(i,k-2,j), field(i,k-1,j),      &
7510                    field(i,k  ,j), field(i,k+1,j),  -vel )
7511            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7512
7513            k=ktf
7514            dz = 2./(rdzw(k)+rdzw(k-1))
7515            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7516            vel = rom(i,k,j)
7517            cr = vel*dt/dz/mu
7518            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7519            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7520            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7521
7522          ENDDO
7523
7524       ENDDO
7525
7526     ELSE IF (vert_order == 4) THEN
7527
7528       DO j = j_start, j_end
7529
7530          DO i = i_start, i_end
7531            fqz(i,1,j)  = 0.
7532            fqzl(i,1,j) = 0.
7533            fqz(i,kde,j)  = 0.
7534            fqzl(i,kde,j) = 0.
7535          ENDDO
7536
7537          DO k=kts+2,ktf-1
7538          DO i = i_start, i_end
7539
7540            dz = 2./(rdzw(k)+rdzw(k-1))
7541            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7542            vel = rom(i,k,j)
7543            cr = vel*dt/dz/mu
7544            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7545
7546            fqz(i,k,j) = vel*flux4(                      &
7547                    field(i,k-2,j), field(i,k-1,j),      &
7548                    field(i,k  ,j), field(i,k+1,j),  -vel )
7549            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7550          ENDDO
7551          ENDDO
7552
7553          DO i = i_start, i_end
7554
7555            k=kts+1
7556            dz = 2./(rdzw(k)+rdzw(k-1))
7557            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7558            vel = rom(i,k,j)
7559            cr = vel*dt/dz/mu
7560            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7561            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7562            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7563
7564            k=ktf
7565            dz = 2./(rdzw(k)+rdzw(k-1))
7566            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7567            vel = rom(i,k,j)
7568            cr = vel*dt/dz/mu
7569            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7570            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7571            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7572
7573          ENDDO
7574
7575       ENDDO
7576
7577     ELSE IF (vert_order == 3) THEN
7578
7579       DO j = j_start, j_end
7580
7581          DO i = i_start, i_end
7582            fqz(i,1,j)  = 0.
7583            fqzl(i,1,j) = 0.
7584            fqz(i,kde,j)  = 0.
7585            fqzl(i,kde,j) = 0.
7586          ENDDO
7587
7588          DO k=kts+2,ktf-1
7589 !DEC$ vector always
7590          DO i = i_start, i_end
7591
7592            dz = 2./(rdzw(k)+rdzw(k-1))
7593            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7594            vel = rom(i,k,j)
7595            cr = vel*dt/dz/mu
7596            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7597
7598            fqz(i,k,j) = vel*flux3(                      &
7599                    field(i,k-2,j), field(i,k-1,j),      &
7600                    field(i,k  ,j), field(i,k+1,j),  -vel )
7601            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7602          ENDDO
7603          ENDDO
7604
7605          DO i = i_start, i_end
7606
7607            k=kts+1
7608            dz = 2./(rdzw(k)+rdzw(k-1))
7609            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7610            vel = rom(i,k,j)
7611            cr = vel*dt/dz/mu
7612            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7613            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7614            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7615
7616            k=ktf
7617            dz = 2./(rdzw(k)+rdzw(k-1))
7618            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7619            vel = rom(i,k,j)
7620            cr = vel*dt/dz/mu
7621            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7622            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7623            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7624
7625          ENDDO
7626
7627       ENDDO
7628
7629    ELSE IF (vert_order == 2) THEN
7630
7631       DO j = j_start, j_end
7632
7633          DO i = i_start, i_end
7634            fqz(i,1,j)  = 0.
7635            fqzl(i,1,j) = 0.
7636            fqz(i,kde,j)  = 0.
7637            fqzl(i,kde,j) = 0.
7638          ENDDO
7639
7640          DO k=kts+1,ktf
7641          DO i = i_start, i_end
7642
7643            dz = 2./(rdzw(k)+rdzw(k-1))
7644            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7645            vel = rom(i,k,j)
7646            cr = vel*dt/dz/mu
7647            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7648            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7649            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7650
7651         ENDDO
7652         ENDDO
7653
7654       ENDDO
7655
7656    ELSE
7657
7658       WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order
7659       CALL wrf_error_fatal ( wrf_err_message )
7660
7661    ENDIF vert_order_test
7662
7663    IF (pd_limit) THEN
7664
7665 ! positive definite filter
7666
7667    i_start = its-1
7668    i_end   = MIN(ite,ide-1)+1
7669    j_start = jts-1
7670    j_end   = MIN(jte,jde-1)+1
7671
7672 !-- loop bounds for open or specified conditions
7673
7674    IF(degrade_xs) i_start = MAX(its-1,ids)
7675    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
7676    IF(degrade_ys) j_start = MAX(jts-1,jds)
7677    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
7678
7679    IF(config_flags%specified .or. config_flags%nested) THEN
7680      IF (degrade_xs) i_start = MAX(its-1,ids+1)
7681      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
7682      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
7683      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
7684    END IF
7685
7686    IF(config_flags%open_xs) THEN
7687      IF (degrade_xs) i_start = MAX(its-1,ids+1)
7688    END IF
7689    IF(config_flags%open_xe) THEN
7690      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
7691    END IF
7692    IF(config_flags%open_ys) THEN
7693      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
7694    END IF
7695    IF(config_flags%open_ye) THEN
7696      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
7697    END IF
7698    ! ADT note:
7699    ! We don't want to change j_start and j_end
7700    ! for polar BC's since we want to calculate
7701    ! fluxes for directions other than y at the
7702    ! edge
7703
7704 !-- here is the limiter...
7705
7706    DO j=j_start, j_end
7707    DO k=kts, ktf
7708 #ifdef XEON_SIMD
7709 !DIR$ simd
7710 #else
7711 !DIR$ vector always
7712 #endif
7713    DO i=i_start, i_end
7714
7715      ph_low(i,k,j) = ((c1(k)*mub(i,j)+c2(k))+(c1(k)*mu_old(i,j)))*field_old(i,k,j) &
7716                 - dt*( msftx(i,j)*msfty(i,j)*(               &
7717                        rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
7718                        rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
7719                       +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
7720
7721    ENDDO
7722    ENDDO
7723    ENDDO
7724
7725    DO j=j_start, j_end
7726    DO k=kts, ktf
7727 !DIR$ vector always
7728    DO i=i_start, i_end
7729
7730      flux_out(i,k,j) = dt*( (msftx(i,j)*msfty(i,j))*( &
7731                                 rdx*(  max(0.,fqx (i+1,k,j))      &
7732                                       -min(0.,fqx (i  ,k,j)) )    &
7733                                +rdy*(  max(0.,fqy (i,k,j+1))      &
7734                                       -min(0.,fqy (i,k,j  )) ) )  &
7735                 +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
7736                                       -max(0.,fqz (i,k  ,j)) )   )
7737
7738    ENDDO
7739    ENDDO
7740    ENDDO
7741
7742    DO j=j_start, j_end
7743    DO k=kts, ktf
7744 !DIR$ vector always
7745    DO i=i_start, i_end
7746      IF( flux_out(i,k,j) .gt. ph_low(i,k,j) ) THEN
7747        scale = max(0.,ph_low(i,k,j)/(flux_out(i,k,j)+eps))
7748        IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j)
7749        IF( fqx (i  ,k,j) .lt. 0.) fqx(i  ,k,j) = scale*fqx(i  ,k,j)
7750        IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1)
7751        IF( fqy (i,k,j  ) .lt. 0.) fqy(i,k,j  ) = scale*fqy(i,k,j  )
7752 !  note: z flux is opposite sign in mass coordinate because
7753 !  vertical coordinate decreases with increasing k
7754        IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j)
7755        IF( fqz (i,k  ,j) .gt. 0.) fqz(i,k  ,j) = scale*fqz(i,k  ,j)
7756
7757      END IF
7758
7759    ENDDO
7760    ENDDO
7761    ENDDO
7762
7763    END IF
7764
7765 ! add in the pd-limited flux divergence
7766
7767   i_start = its
7768   i_end   = MIN(ite,ide-1)
7769   j_start = jts
7770   j_end   = MIN(jte,jde-1)
7771
7772   DO j = j_start, j_end
7773   DO k = kts, ktf
7774 !DEC$ vector always
7775   DO i = i_start, i_end
7776
7777      tendency (i,k,j) = tendency(i,k,j)                           &
7778                             -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
7779                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
7780
7781   ENDDO
7782   ENDDO
7783   ENDDO
7784
7785   IF(tenddec) THEN
7786   DO j = j_start, j_end
7787   DO k = kts, ktf
7788   DO i = i_start, i_end
7789
7790      z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
7791                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
7792
7793   ENDDO
7794   ENDDO
7795   ENDDO
7796   END IF
7797
7798 ! x flux divergence
7799 !
7800   IF(degrade_xs) i_start = MAX(its,ids+1)
7801   IF(degrade_xe) i_end   = MIN(ite,ide-2)
7802
7803   DO j = j_start, j_end
7804   DO k = kts, ktf
7805 !DEC$ vector always
7806   DO i = i_start, i_end
7807
7808      ! Un-"canceled" map scale factor, ADT Eq. 48
7809      tendency (i,k,j) = tendency(i,k,j)                           &
7810                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
7811                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
7812
7813   ENDDO
7814   ENDDO
7815   ENDDO
7816
7817   IF(tenddec) THEN
7818   DO j = j_start, j_end
7819   DO k = kts, ktf
7820   DO i = i_start, i_end
7821
7822      h_tendency (i,k,j) = 0.                                      &
7823                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
7824                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
7825
7826   ENDDO
7827   ENDDO
7828   ENDDO
7829   END IF
7830
7831 ! y flux divergence
7832 !
7833   i_start = its
7834   i_end   = MIN(ite,ide-1)
7835   IF(degrade_ys) j_start = MAX(jts,jds+1)
7836   IF(degrade_ye) j_end   = MIN(jte,jde-2)
7837
7838   DO j = j_start, j_end
7839   DO k = kts, ktf
7840 !DEC$ vector always
7841   DO i = i_start, i_end
7842
7843      ! Un-"canceled" map scale factor, ADT Eq. 48
7844      ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
7845      tendency (i,k,j) = tendency(i,k,j)                           &
7846                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
7847                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
7848
7849   ENDDO
7850   ENDDO
7851   ENDDO
7852
7853   IF(tenddec) THEN
7854   DO j = j_start, j_end
7855   DO k = kts, ktf
7856   DO i = i_start, i_end
7857
7858      h_tendency (i,k,j) = h_tendency (i,k,j)                      &
7859                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
7860                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
7861
7862   ENDDO
7863   ENDDO
7864   ENDDO
7865   END IF
7866
7867 END SUBROUTINE advect_scalar_pd
7868
7869 !----------------------------------------------------------------
7870
7871 SUBROUTINE advect_scalar_weno ( field, field_old, tendency,     &
7872                                 ru, rv, rom,                   &
7873                                 c1, c2,                        &
7874                                 mut, time_step, config_flags,  &
7875                                 msfux, msfuy, msfvx, msfvy,    &
7876                                 msftx, msfty,                  &
7877                                 fzm, fzp,                      &
7878                                 rdx, rdy, rdzw,                &
7879                                 ids, ide, jds, jde, kds, kde,  &
7880                                 ims, ime, jms, jme, kms, kme,  &
7881                                 its, ite, jts, jte, kts, kte  )
7882 !
7883 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
7884 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
7885 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
7886 !
7887    IMPLICIT NONE
7888
7889    ! Input data
7890
7891    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
7892
7893    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
7894                                               ims, ime, jms, jme, kms, kme, &
7895                                               its, ite, jts, jte, kts, kte
7896
7897    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
7898                                                                       field_old, &
7899                                                                       ru,    &
7900                                                                       rv,    &
7901                                                                       rom
7902
7903    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
7904    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
7905
7906    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
7907                                                                     msfuy,  &
7908                                                                     msfvx,  &
7909                                                                     msfvy,  &
7910                                                                     msftx,  &
7911                                                                     msfty
7912
7913    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
7914                                                                   fzp,  &
7915                                                                   rdzw, &
7916                                                                   c1,   &
7917                                                                   c2
7918
7919    REAL ,                                        INTENT(IN   ) :: rdx,  &
7920                                                                   rdy
7921    INTEGER ,                                     INTENT(IN   ) :: time_step
7922
7923
7924    ! Local data
7925
7926    INTEGER :: i, j, k, itf, jtf, ktf
7927    INTEGER :: i_start, i_end, j_start, j_end
7928    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
7929    INTEGER :: jmin, jmax, jp, jm, imin, imax
7930
7931    INTEGER , PARAMETER :: is=0, js=0, ks=0
7932
7933    REAL    :: mrdx, mrdy, ub, vb, vw
7934    REAL , DIMENSION(its:ite, kts:kte) :: vflux
7935
7936
7937    REAL,  DIMENSION( its-is:ite+1, kts:kte  ) :: fqx
7938 !   REAL,  DIMENSION( its:ite+1, kts:kte  ) :: fqx
7939    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
7940
7941    INTEGER :: horz_order, vert_order
7942
7943    LOGICAL :: degrade_xs, degrade_ys
7944    LOGICAL :: degrade_xe, degrade_ye
7945
7946    INTEGER :: jp1, jp0, jtmp
7947
7948     real            :: dir, vv
7949     real            :: ue,uw,vs,vn,wb,wt
7950     real, parameter :: f30 =  7./12., f31 = 1./12.
7951     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
7952
7953
7954    integer kt,kb
7955
7956
7957     real               :: qim2, qim1, qi, qip1, qip2
7958     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
7959     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-28
7960     integer, parameter :: pw = 2
7961
7962
7963 ! definition of flux operators, 3rd, 4th, 5th or 6th order
7964
7965    REAL    :: flux3, flux4, flux5, flux6
7966    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
7967
7968       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
7969             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
7970
7971       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
7972            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
7973            sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
7974
7975       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
7976             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
7977             +(1./60.)*(q_ip2+q_im3)
7978
7979       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
7980            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
7981             -sign(1,time_step)*sign(1.,ua)*(1./60.)*(           &
7982               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
7983
7984    LOGICAL :: specified
7985
7986    specified = .false.
7987    if(config_flags%specified .or. config_flags%nested) specified = .true.
7988
7989 ! set order for the advection schemes
7990
7991   ktf=MIN(kte,kde-1)
7992   horz_order = 5 ! config_flags%h_sca_adv_order
7993   vert_order = 5 ! config_flags%v_sca_adv_order
7994
7995 !  begin with horizontal flux divergence
7996 !  here is the choice of flux operators
7997
7998
7999
8000   IF( horz_order == 5 ) THEN
8001
8002 !  determine boundary mods for flux operators
8003 !  We degrade the flux operators from 3rd/4th order
8004 !   to second order one gridpoint in from the boundaries for
8005 !   all boundary conditions except periodic and symmetry - these
8006 !   conditions have boundary zone data fill for correct application
8007 !   of the higher order flux stencils
8008
8009    degrade_xs = .true.
8010    degrade_xe = .true.
8011    degrade_ys = .true.
8012    degrade_ye = .true.
8013
8014    IF( config_flags%periodic_x   .or. &
8015        config_flags%symmetric_xs .or. &
8016        (its > ids+3)                ) degrade_xs = .false.
8017    IF( config_flags%periodic_x   .or. &
8018        config_flags%symmetric_xe .or. &
8019        (ite < ide-3)                ) degrade_xe = .false.
8020    IF( config_flags%periodic_y   .or. &
8021        config_flags%symmetric_ys .or. &
8022        (jts > jds+3)                ) degrade_ys = .false.
8023    IF( config_flags%periodic_y   .or. &
8024        config_flags%symmetric_ye .or. &
8025        (jte < jde-4)                ) degrade_ye = .false.
8026
8027 !--------------- y - advection first
8028
8029       ktf=MIN(kte,kde-1)
8030       i_start = its
8031       i_end   = MIN(ite,ide-1)
8032
8033
8034 ! check for U
8035       IF ( is == 1 ) THEN
8036         i_start = its
8037         i_end   = ite
8038         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
8039         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
8040         IF ( config_flags%periodic_x ) i_start = its
8041         IF ( config_flags%periodic_x ) i_end = ite
8042       ENDIF
8043
8044       j_start = jts
8045       j_end   = MIN(jte,jde-1)
8046
8047 !  higher order flux has a 5 or 7 point stencil, so compute
8048 !  bounds so we can switch to second order flux close to the boundary
8049
8050       j_start_f = j_start
8051       j_end_f   = j_end+1
8052
8053       IF(degrade_ys) then
8054         j_start = MAX(jts,jds+1)
8055         j_start_f = jds+3
8056       ENDIF
8057
8058       IF(degrade_ye) then
8059         j_end = MIN(jte,jde-2)
8060         j_end_f = jde-3
8061       ENDIF
8062
8063       IF(config_flags%polar) j_end = MIN(jte,jde-1)
8064
8065 !  compute fluxes, 5th or 6th order
8066
8067      jp1 = 2
8068      jp0 = 1
8069
8070      j_loop_y_flux_5 : DO j = j_start, j_end+1
8071
8072       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
8073
8074         DO k=kts,ktf
8075         DO i = i_start, i_end
8076 !          vel = rv(i,k,j)
8077           vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
8078
8079          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
8080             qip2 = field(i,k,j+1)
8081             qip1 = field(i,k,j  )
8082             qi   = field(i,k,j-1)
8083             qim1 = field(i,k,j-2)
8084             qim2 = field(i,k,j-3)
8085           ELSE
8086             qip2 = field(i,k,j-2)
8087             qip1 = field(i,k,j-1)
8088             qi   = field(i,k,j  )
8089             qim1 = field(i,k,j+1)
8090             qim2 = field(i,k,j+2)
8091          ENDIF
8092
8093          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8094          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8095          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8096
8097          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8098          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8099          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8100
8101          wi0 = gi0 / (eps + beta0)**pw
8102          wi1 = gi1 / (eps + beta1)**pw
8103          wi2 = gi2 / (eps + beta2)**pw
8104
8105          sumwk = wi0 + wi1 + wi2
8106
8107           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8108
8109 !          fqy( i, k, jp1 ) = vel*flux5(                                &
8110 !                  field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
8111 !                  field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
8112         ENDDO
8113         ENDDO
8114
8115
8116       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
8117
8118             DO k=kts,ktf
8119             DO i = i_start, i_end
8120               fqy(i,k, jp1) = 0.5*rv(i,k,j)*          &
8121 !              fqy(i,k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )*          &
8122                      (field(i,k,j)+field(i,k,j-1))
8123
8124             ENDDO
8125             ENDDO
8126
8127      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
8128
8129             DO k=kts,ktf
8130             DO i = i_start, i_end
8131 !              vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
8132               vel = rv(i,k,j)
8133               fqy( i, k, jp1 ) = vel*flux3(              &
8134                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
8135             ENDDO
8136             ENDDO
8137
8138      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
8139
8140             DO k=kts,ktf
8141             DO i = i_start, i_end
8142 !              fqy(i, k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )*      &
8143               fqy(i, k, jp1) = 0.5*rv(i,k,j)*      &
8144                      (field(i,k,j)+field(i,k,j-1))
8145             ENDDO
8146             ENDDO
8147
8148      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
8149
8150             DO k=kts,ktf
8151             DO i = i_start, i_end
8152               vel = rv(i,k,j)
8153 !              vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
8154               fqy( i, k, jp1) = vel*flux3(             &
8155                    field(i,k,j-2),field(i,k,j-1),    &
8156                    field(i,k,j),field(i,k,j+1),vel )
8157             ENDDO
8158             ENDDO
8159
8160      ENDIF
8161
8162 !  y flux-divergence into tendency
8163
8164       IF ( is == 0 ) THEN
8165         ! Comments on polar boundary conditions
8166         ! Same process as for advect_u - tendencies run from jds to jde-1
8167         ! (latitudes are as for u grid, longitudes are displaced)
8168         ! Therefore: flow is only from one side for points next to poles
8169         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
8170           DO k=kts,ktf
8171           DO i = i_start, i_end
8172             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
8173             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
8174           END DO
8175           END DO
8176         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
8177           DO k=kts,ktf
8178           DO i = i_start, i_end
8179             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
8180             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
8181           END DO
8182           END DO
8183         ELSE  ! normal code
8184
8185         IF(j > j_start) THEN
8186
8187           DO k=kts,ktf
8188           DO i = i_start, i_end
8189             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
8190             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
8191           ENDDO
8192           ENDDO
8193
8194         ENDIF
8195         ENDIF
8196        ELSEIF ( is == 1 ) THEN
8197
8198         ! (j > j_start) will miss the u(,,jds) tendency
8199         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
8200           DO k=kts,ktf
8201           DO i = i_start, i_end
8202             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
8203             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
8204           END DO
8205           END DO
8206         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
8207         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
8208           DO k=kts,ktf
8209           DO i = i_start, i_end
8210             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
8211             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
8212           END DO
8213           END DO
8214         ELSE  ! normal code
8215
8216         IF(j > j_start) THEN
8217
8218           DO k=kts,ktf
8219           DO i = i_start, i_end
8220             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
8221             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
8222           ENDDO
8223           ENDDO
8224
8225         ENDIF
8226
8227         END IF
8228
8229        ENDIF
8230
8231         jtmp = jp1
8232         jp1 = jp0
8233         jp0 = jtmp
8234
8235       ENDDO j_loop_y_flux_5
8236
8237 !  next, x - flux divergence
8238
8239       i_start = its
8240       i_end   = MIN(ite,ide-1)
8241
8242       j_start = jts
8243       j_end   = MIN(jte,jde-1)
8244
8245 !  higher order flux has a 5 or 7 point stencil, so compute
8246 !  bounds so we can switch to second order flux close to the boundary
8247
8248       i_start_f = i_start
8249       i_end_f   = i_end+1
8250
8251       IF(degrade_xs) then
8252         i_start = MAX(ids+1,its)
8253 !        i_start_f = i_start+2
8254         i_start_f = MIN(i_start+2,ids+3)
8255       ENDIF
8256
8257       IF(degrade_xe) then
8258         i_end = MIN(ide-2,ite)
8259         i_end_f = ide-3
8260       ENDIF
8261
8262 !  compute fluxes
8263
8264       DO j = j_start, j_end
8265
8266 !  5th or 6th order flux
8267
8268         DO k=kts,ktf
8269         DO i = i_start_f, i_end_f
8270 !          vel = ru(i,k,j)
8271           vel = 0.5*( ru(i,k,j) + ru(i-is,k-ks,j-js) )
8272
8273
8274          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
8275             qip2 = field(i+1,k,j)
8276             qip1 = field(i,  k,j)
8277             qi   = field(i-1,k,j)
8278             qim1 = field(i-2,k,j)
8279             qim2 = field(i-3,k,j)
8280           ELSE
8281             qip2 = field(i-2,k,j)
8282             qip1 = field(i-1,k,j)
8283             qi   = field(i,  k,j)
8284             qim1 = field(i+1,k,j)
8285             qim2 = field(i+2,k,j)
8286          ENDIF
8287
8288          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8289          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8290          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8291
8292          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8293          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8294          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8295
8296          wi0 = gi0 / (eps + beta0)**pw
8297          wi1 = gi1 / (eps + beta1)**pw
8298          wi2 = gi2 / (eps + beta2)**pw
8299
8300          sumwk = wi0 + wi1 + wi2
8301
8302          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8303
8304 !          fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
8305 !                                         field(i-1,k,j), field(i  ,k,j),  &
8306 !                                         field(i+1,k,j), field(i+2,k,j),  &
8307 !                                         vel                             )
8308         ENDDO
8309         ENDDO
8310
8311 !  lower order fluxes close to boundaries (if not periodic or symmetric)
8312
8313         IF( degrade_xs ) THEN
8314
8315           DO i=i_start,i_start_f-1
8316
8317             IF(i == ids+1) THEN ! second order
8318               DO k=kts,ktf
8319                 fqx(i,k) = 0.5*(ru(i,k,j)) &
8320                        *(field(i,k,j)+field(i-1,k,j))
8321               ENDDO
8322             ENDIF
8323
8324             IF(i == ids+2) THEN  ! third order
8325               DO k=kts,ktf
8326                 vel = ru(i,k,j)
8327                 fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
8328                                               field(i  ,k,j), field(i+1,k,j),  &
8329                                               vel                     )
8330               ENDDO
8331             END IF
8332
8333           ENDDO
8334
8335         ENDIF
8336
8337         IF( degrade_xe ) THEN
8338
8339           DO i = i_end_f+1, i_end+1
8340
8341             IF( i == ide-1 ) THEN ! second order flux next to the boundary
8342               DO k=kts,ktf
8343                 fqx(i,k) = 0.5*(ru(i,k,j))      &
8344                        *(field(i,k,j)+field(i-1,k,j))
8345               ENDDO
8346            ENDIF
8347
8348            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
8349              DO k=kts,ktf
8350                vel = ru(i,k,j)
8351                fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
8352                                        field(i  ,k,j), field(i+1,k,j),  &
8353                                        vel                             )
8354              ENDDO
8355            ENDIF
8356
8357          ENDDO
8358
8359        ENDIF
8360
8361 !  x flux-divergence into tendency
8362
8363        IF ( is == 0 ) THEN
8364           DO k=kts,ktf
8365           DO i = i_start, i_end
8366             mrdx=msftx(i,j)*rdx      ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
8367             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
8368           ENDDO
8369           ENDDO
8370        ELSEIF ( is == 1 ) THEN
8371         DO k=kts,ktf
8372           DO i = i_start, i_end
8373             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
8374             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
8375           ENDDO
8376         ENDDO
8377        ENDIF
8378
8379       ENDDO
8380
8381
8382    ENDIF
8383
8384
8385 !  pick up the rest of the horizontal radiation boundary conditions.
8386 !  (these are the computations that don't require 'cb'.
8387 !  first, set to index ranges
8388
8389       i_start = its
8390       i_end   = MIN(ite,ide-1)
8391       j_start = jts
8392       j_end   = MIN(jte,jde-1)
8393
8394 !  compute x (u) conditions for v, w, or scalar
8395
8396    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
8397
8398        DO j = j_start, j_end
8399        DO k = kts, ktf
8400          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
8401          tendency(its,k,j) = tendency(its,k,j)                     &
8402                - rdx*(                                             &
8403                        ub*(   field_old(its+1,k,j)                 &
8404                             - field_old(its  ,k,j)   ) +           &
8405                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
8406                                                                 )
8407        ENDDO
8408        ENDDO
8409
8410    ENDIF
8411
8412    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
8413
8414        DO j = j_start, j_end
8415        DO k = kts, ktf
8416          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
8417          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
8418                - rdx*(                                               &
8419                        ub*(  field_old(i_end  ,k,j)                  &
8420                            - field_old(i_end-1,k,j) ) +              &
8421                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
8422                                                                     )
8423        ENDDO
8424        ENDDO
8425
8426    ENDIF
8427
8428    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
8429
8430        DO i = i_start, i_end
8431        DO k = kts, ktf
8432          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
8433          tendency(i,k,jts) = tendency(i,k,jts)                     &
8434                - rdy*(                                             &
8435                        vb*(  field_old(i,k,jts+1)                  &
8436                            - field_old(i,k,jts  ) ) +              &
8437                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
8438                                                                 )
8439        ENDDO
8440        ENDDO
8441
8442    ENDIF
8443
8444    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
8445
8446        DO i = i_start, i_end
8447        DO k = kts, ktf
8448          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
8449          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
8450                - rdy*(                                               &
8451                        vb*(   field_old(i,k,j_end  )                 &
8452                             - field_old(i,k,j_end-1) ) +             &
8453                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
8454                                                                     )
8455        ENDDO
8456        ENDDO
8457
8458    ENDIF
8459
8460
8461 !-------------------- vertical advection
8462 !     Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
8463 !     Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
8464 !     So we don't need to make a correction for advect_scalar
8465
8466       i_start = its
8467       i_end   = MIN(ite,ide-1)
8468       j_start = jts
8469       j_end   = MIN(jte,jde-1)
8470
8471       DO i = i_start, i_end
8472          vflux(i,kts)=0.
8473          vflux(i,kte)=0.
8474       ENDDO
8475
8476
8477
8478       DO j = j_start, j_end
8479
8480          DO k=kts+3,ktf-2
8481          DO i = i_start, i_end
8482 !           vel = rom(i,k,j)
8483            vel = 0.5*( rom(i,k,j) + rom(i-is,k-ks,j-js) )
8484
8485          IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN
8486             qip2 = field(i,k+1,j)
8487             qip1 = field(i,k  ,j)
8488             qi   = field(i,k-1,j)
8489             qim1 = field(i,k-2,j)
8490             qim2 = field(i,k-3,j)
8491           ELSE
8492             qip2 = field(i,k-2,j)
8493             qip1 = field(i,k-1,j)
8494             qi   = field(i,k  ,j)
8495             qim1 = field(i,k+1,j)
8496             qim2 = field(i,k+2,j)
8497          ENDIF
8498
8499          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8500          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8501          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8502
8503          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8504          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8505          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8506
8507          wi0 = gi0 / (eps + beta0)**pw
8508          wi1 = gi1 / (eps + beta1)**pw
8509          wi2 = gi2 / (eps + beta2)**pw
8510
8511          sumwk = wi0 + wi1 + wi2
8512
8513           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8514
8515 !           vflux(i,k) = vel*flux5(                                 &
8516 !                   field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
8517 !                   field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
8518          ENDDO
8519          ENDDO
8520
8521          DO i = i_start, i_end
8522
8523            k=kts+1
8524            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
8525
8526            k = kts+2
8527            vel=rom(i,k,j)
8528            vflux(i,k) = vel*flux3(               &
8529                    field(i,k-2,j), field(i,k-1,j),   &
8530                    field(i,k  ,j), field(i,k+1,j), -vel )
8531            k = ktf-1
8532            vel=rom(i,k,j)
8533            vflux(i,k) = vel*flux3(               &
8534                    field(i,k-2,j), field(i,k-1,j),   &
8535                    field(i,k  ,j), field(i,k+1,j), -vel )
8536
8537            k=ktf
8538            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
8539          ENDDO
8540
8541          DO k=kts,ktf
8542          DO i = i_start, i_end
8543             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
8544          ENDDO
8545          ENDDO
8546
8547       ENDDO
8548
8549
8550
8551 END SUBROUTINE advect_scalar_weno
8552
8553 !---------------------------------------------------------------------------------
8554
8555 SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency,    &
8556                                   ru, rv, rom,                   &
8557                                   c1, c2,                        &
8558                                   mut, mub, mu_old,              &
8559                                   time_step, config_flags,       &
8560                                   msfux, msfuy, msfvx, msfvy,    &
8561                                   msftx, msfty,                  &
8562                                   fzm, fzp,                      &
8563                                   rdx, rdy, rdzw, dt,            &
8564                                   ids, ide, jds, jde, kds, kde,  &
8565                                   ims, ime, jms, jme, kms, kme,  &
8566                                   its, ite, jts, jte, kts, kte  )
8567
8568 !  this is a first cut at a positive definite advection option
8569 !  for scalars in WRF.  This version is memory intensive ->
8570 !  we save 3d arrays of x, y and z both high and low order fluxes
8571 !  (six in all).  Alternatively, we could sweep in a direction
8572 !  and lower the cost considerably.
8573
8574 !  uses the Smolarkiewicz MWR 1989 approach, with addition of first-order
8575 !  fluxes initially
8576
8577 !  WCS, 3 December 2002, 24 February 2003
8578
8579 !
8580 ! ERM Dec. 2011: replaced 5th-order fluxes with 5th-order WENO (Weighted
8581 ! Essentially Non-Oscillatory) scheme
8582 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
8583 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;
8584 !
8585
8586    IMPLICIT NONE
8587
8588    ! Input data
8589
8590    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
8591
8592    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
8593                                               ims, ime, jms, jme, kms, kme, &
8594                                               its, ite, jts, jte, kts, kte
8595
8596    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
8597                                                                       field_old, &
8598                                                                       ru,        &
8599                                                                       rv,        &
8600                                                                       rom
8601
8602    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut, mub, mu_old
8603    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
8604
8605    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
8606                                                                     msfuy,  &
8607                                                                     msfvx,  &
8608                                                                     msfvy,  &
8609                                                                     msftx,  &
8610                                                                     msfty
8611
8612    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
8613                                                                   fzp,  &
8614                                                                   rdzw, &
8615                                                                   c1,   &
8616                                                                   c2
8617
8618    REAL ,                                        INTENT(IN   ) :: rdx,  &
8619                                                                   rdy,  &
8620                                                                   dt
8621    INTEGER ,                                     INTENT(IN   ) :: time_step
8622
8623    ! Local data
8624
8625    INTEGER :: i, j, k, itf, jtf, ktf
8626    INTEGER :: i_start, i_end, j_start, j_end
8627    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
8628    INTEGER :: jmin, jmax, jp, jm, imin, imax
8629
8630    REAL    :: mrdx, mrdy, ub, vb, uw, vw, mu
8631
8632 !  storage for high and low order fluxes
8633
8634    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqx, fqy, fqz
8635    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqxl, fqyl, fqzl
8636
8637    INTEGER :: horz_order, vert_order
8638
8639    LOGICAL :: degrade_xs, degrade_ys
8640    LOGICAL :: degrade_xe, degrade_ye
8641
8642    INTEGER :: jp1, jp0, jtmp
8643
8644    REAL,DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: flux_out, ph_low
8645    REAL :: scale
8646    REAL, PARAMETER :: eps=1.e-20
8647
8648     real            :: dir, vv
8649     real            :: ue,vs,vn,wb,wt
8650     real, parameter :: f30 =  7./12., f31 = 1./12.
8651     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
8652
8653     real               :: qim2, qim1, qi, qip1, qip2
8654     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
8655     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps1=1.0d-28
8656     integer, parameter :: pw = 2
8657
8658
8659 ! definition of flux operators, 3rd, 4th, 5th or 6th order
8660
8661    REAL    :: flux3, flux4, flux5, flux6, flux_upwind
8662    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
8663
8664       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
8665             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
8666
8667       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
8668            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
8669            sign(1,time_step)*sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
8670
8671       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
8672             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
8673             +(1./60.)*(q_ip2+q_im3)
8674
8675       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
8676            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
8677             -sign(1,time_step)*sign(1.,ua)*(1./60.)*(           &
8678               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
8679
8680       flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 &
8681                                     +0.5*max(-1.0,(cr-abs(cr)))*q_i
8682
8683 !      flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
8684 !                                    +0.5*(1.-sign(1.,cr))*q_i
8685 !      flux_upwind(q_im1, q_i, cr ) = 0.
8686
8687     REAL     :: dx,dy,dz
8688
8689     LOGICAL, PARAMETER :: pd_limit = .true.
8690
8691 ! set order for the advection schemes
8692
8693 !  write(6,*) ' in pd advection routine '
8694
8695     ! Empty arrays just in case:
8696     IF (config_flags%polar) THEN
8697        fqx(:,:,:)  = 0.
8698        fqy(:,:,:)  = 0.
8699        fqz(:,:,:)  = 0.
8700        fqxl(:,:,:) = 0.
8701        fqyl(:,:,:) = 0.
8702        fqzl(:,:,:) = 0.
8703     END IF
8704
8705   ktf=MIN(kte,kde-1)
8706   horz_order = config_flags%h_sca_adv_order
8707   vert_order = config_flags%v_sca_adv_order
8708
8709 !  determine boundary mods for flux operators
8710 !  We degrade the flux operators from 3rd/4th order
8711 !   to second order one gridpoint in from the boundaries for
8712 !   all boundary conditions except periodic and symmetry - these
8713 !   conditions have boundary zone data fill for correct application
8714 !   of the higher order flux stencils
8715
8716    degrade_xs = .true.
8717    degrade_xe = .true.
8718    degrade_ys = .true.
8719    degrade_ye = .true.
8720
8721 !  begin with horizontal flux divergence
8722 !  here is the choice of flux operators
8723
8724
8725 !  horizontal_order_test : IF( horz_order == 6 ) THEN
8726
8727 !    ELSE IF( horz_order == 5 ) THEN
8728
8729    IF( config_flags%periodic_x   .or. &
8730        config_flags%symmetric_xs .or. &
8731        (its > ids+3)                ) degrade_xs = .false.
8732    IF( config_flags%periodic_x   .or. &
8733        config_flags%symmetric_xe .or. &
8734        (ite < ide-4)                ) degrade_xe = .false.
8735    IF( config_flags%periodic_y   .or. &
8736        config_flags%symmetric_ys .or. &
8737        (jts > jds+3)                ) degrade_ys = .false.
8738    IF( config_flags%periodic_y   .or. &
8739        config_flags%symmetric_ye .or. &
8740        (jte < jde-4)                ) degrade_ye = .false.
8741
8742 !--------------- y - advection first
8743
8744 !--  y flux compute; these bounds are for periodic and sym b.c.
8745
8746       ktf=MIN(kte,kde-1)
8747       i_start = its-1
8748       i_end   = MIN(ite,ide-1)+1
8749       j_start = jts-1
8750       j_end   = MIN(jte,jde-1)+1
8751       j_start_f = j_start
8752       j_end_f   = j_end+1
8753
8754 !--  modify loop bounds if open or specified
8755
8756 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
8757 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
8758       IF(degrade_xs) i_start = MAX(its-1,ids)
8759       IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
8760
8761       IF(degrade_ys) then
8762         j_start = MAX(jts-1,jds+1)
8763         j_start_f = jds+3
8764       ENDIF
8765
8766       IF(degrade_ye) then
8767         j_end = MIN(jte+1,jde-2)
8768         j_end_f = jde-3
8769       ENDIF
8770
8771 !  compute fluxes, 5th order
8772
8773       j_loop_y_flux_5 : DO j = j_start, j_end+1
8774
8775       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
8776
8777         DO k=kts,ktf
8778         DO i = i_start, i_end
8779
8780           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
8781           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
8782           vel = rv(i,k,j)
8783           cr = vel*dt/dy/mu
8784           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8785
8786          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
8787             qip2 = field(i,k,j+1)
8788             qip1 = field(i,k,j  )
8789             qi   = field(i,k,j-1)
8790             qim1 = field(i,k,j-2)
8791             qim2 = field(i,k,j-3)
8792           ELSE
8793             qip2 = field(i,k,j-2)
8794             qip1 = field(i,k,j-1)
8795             qi   = field(i,k,j  )
8796             qim1 = field(i,k,j+1)
8797             qim2 = field(i,k,j+2)
8798          ENDIF
8799
8800          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8801          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8802          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8803
8804          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8805          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8806          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8807
8808          wi0 = gi0 / (eps1 + beta0)**pw
8809          wi1 = gi1 / (eps1 + beta1)**pw
8810          wi2 = gi2 / (eps1 + beta2)**pw
8811
8812          sumwk = wi0 + wi1 + wi2
8813
8814           fqy( i, k, j ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8815
8816 !          fqy( i, k, j  ) = vel*flux5(                                  &
8817 !                  field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
8818 !                  field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
8819
8820           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8821
8822         ENDDO
8823         ENDDO
8824
8825       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
8826
8827             DO k=kts,ktf
8828             DO i = i_start, i_end
8829
8830               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
8831               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
8832               vel = rv(i,k,j)
8833               cr = vel*dt/dy/mu
8834               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8835
8836               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
8837                      (field(i,k,j)+field(i,k,j-1))
8838
8839               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8840
8841             ENDDO
8842             ENDDO
8843
8844       ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
8845
8846             DO k=kts,ktf
8847             DO i = i_start, i_end
8848
8849               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
8850               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
8851               vel = rv(i,k,j)
8852               cr = vel*dt/dy/mu
8853               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8854
8855               fqy( i, k, j ) = vel*flux3(              &
8856                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
8857               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8858
8859             ENDDO
8860             ENDDO
8861
8862       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
8863
8864             DO k=kts,ktf
8865             DO i = i_start, i_end
8866
8867               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
8868               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
8869               vel = rv(i,k,j)
8870               cr = vel*dt/dy/mu
8871               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8872
8873               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
8874                      (field(i,k,j)+field(i,k,j-1))
8875               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8876
8877             ENDDO
8878             ENDDO
8879
8880       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
8881
8882             DO k=kts,ktf
8883             DO i = i_start, i_end
8884
8885               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
8886               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
8887               vel = rv(i,k,j)
8888               cr = vel*dt/dy/mu
8889               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8890
8891               fqy( i, k, j) = vel*flux3(             &
8892                    field(i,k,j-2),field(i,k,j-1),    &
8893                    field(i,k,j),field(i,k,j+1),vel )
8894               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8895
8896             ENDDO
8897             ENDDO
8898
8899       ENDIF
8900
8901    ENDDO j_loop_y_flux_5
8902
8903 !  next, x flux
8904
8905 !--  these bounds are for periodic and sym conditions
8906
8907       i_start = its-1
8908       i_end   = MIN(ite,ide-1)+1
8909       i_start_f = i_start
8910       i_end_f   = i_end+1
8911
8912       j_start = jts-1
8913       j_end   = MIN(jte,jde-1)+1
8914
8915 !--  modify loop bounds for open and specified b.c
8916
8917 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
8918 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
8919       IF(degrade_ys) j_start = MAX(jts-1,jds)
8920       IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
8921
8922       IF(degrade_xs) then
8923         i_start = MAX(ids+1,its-1)
8924         i_start_f = ids+3
8925       ENDIF
8926
8927       IF(degrade_xe) then
8928         i_end = MIN(ide-2,ite+1)
8929         i_end_f = ide-3
8930       ENDIF
8931
8932 !  compute fluxes
8933
8934       DO j = j_start, j_end
8935
8936 !  5th order flux
8937
8938         DO k=kts,ktf
8939         DO i = i_start_f, i_end_f
8940
8941           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
8942           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
8943           vel = ru(i,k,j)
8944           cr = vel*dt/dx/mu
8945           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8946
8947
8948          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
8949             qip2 = field(i+1,k,j)
8950             qip1 = field(i,  k,j)
8951             qi   = field(i-1,k,j)
8952             qim1 = field(i-2,k,j)
8953             qim2 = field(i-3,k,j)
8954           ELSE
8955             qip2 = field(i-2,k,j)
8956             qip1 = field(i-1,k,j)
8957             qi   = field(i,  k,j)
8958             qim1 = field(i+1,k,j)
8959             qim2 = field(i+2,k,j)
8960          ENDIF
8961
8962          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8963          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8964          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8965
8966          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8967          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8968          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8969
8970          wi0 = gi0 / (eps1 + beta0)**pw
8971          wi1 = gi1 / (eps1 + beta1)**pw
8972          wi2 = gi2 / (eps1 + beta2)**pw
8973
8974          sumwk = wi0 + wi1 + wi2
8975
8976          fqx(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8977
8978 !          fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
8979 !                                         field(i-1,k,j), field(i  ,k,j),  &
8980 !                                         field(i+1,k,j), field(i+2,k,j),  &
8981 !                                         vel                             )
8982           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
8983
8984         ENDDO
8985         ENDDO
8986
8987 !  lower order fluxes close to boundaries (if not periodic or symmetric)
8988
8989         IF( degrade_xs ) THEN
8990
8991           DO i=i_start,i_start_f-1
8992
8993             IF(i == ids+1) THEN ! second order
8994               DO k=kts,ktf
8995                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
8996                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
8997                 vel = ru(i,k,j)/mu
8998                 cr = vel*dt/dx
8999                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9000                 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
9001                        *(field(i,k,j)+field(i-1,k,j))
9002                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9003               ENDDO
9004             ENDIF
9005
9006             IF(i == ids+2) THEN  ! third order
9007               DO k=kts,ktf
9008                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
9009                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
9010                 vel = ru(i,k,j)
9011                 cr = vel*dt/dx/mu
9012                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9013                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
9014                                           field(i  ,k,j), field(i+1,k,j),  &
9015                                           vel                             )
9016                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9017               ENDDO
9018             ENDIF
9019
9020           ENDDO
9021
9022         ENDIF
9023
9024         IF( degrade_xe ) THEN
9025
9026           DO i = i_end_f+1, i_end+1
9027
9028             IF( i == ide-1 ) THEN ! second order flux next to the boundary
9029               DO k=kts,ktf
9030                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
9031                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
9032                 vel = ru(i,k,j)
9033                 cr = vel*dt/dx/mu
9034                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9035                 fqx(i,k,j) = 0.5*(ru(i,k,j))      &
9036                        *(field(i,k,j)+field(i-1,k,j))
9037                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9038               ENDDO
9039             ENDIF
9040
9041
9042             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
9043               DO k=kts,ktf
9044                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
9045                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
9046                 vel = ru(i,k,j)
9047                 cr = vel*dt/dx/mu
9048                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9049                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
9050                                           field(i  ,k,j), field(i+1,k,j),  &
9051                                           vel                             )
9052                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9053               ENDDO
9054             ENDIF
9055
9056           ENDDO
9057
9058         ENDIF
9059
9060       ENDDO  ! enddo for outer J loop
9061
9062 !--- end of 5th order horizontal flux calculation
9063
9064 !   ELSE
9065
9066 !      WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order
9067 !      CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
9068
9069 !   ENDIF horizontal_order_test
9070
9071 !  pick up the rest of the horizontal radiation boundary conditions.
9072 !  (these are the computations that don't require 'cb'.
9073 !  first, set to index ranges
9074
9075       i_start = its
9076       i_end   = MIN(ite,ide-1)
9077       j_start = jts
9078       j_end   = MIN(jte,jde-1)
9079
9080 !  compute x (u) conditions for v, w, or scalar
9081
9082    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
9083
9084        DO j = j_start, j_end
9085        DO k = kts, ktf
9086          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
9087          tendency(its,k,j) = tendency(its,k,j)                     &
9088                - rdx*(                                             &
9089                        ub*(   field_old(its+1,k,j)                 &
9090                             - field_old(its  ,k,j)   ) +           &
9091                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
9092                                                                 )
9093        ENDDO
9094        ENDDO
9095
9096    ENDIF
9097
9098    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
9099
9100        DO j = j_start, j_end
9101        DO k = kts, ktf
9102          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
9103          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
9104                - rdx*(                                               &
9105                        ub*(  field_old(i_end  ,k,j)                  &
9106                            - field_old(i_end-1,k,j) ) +              &
9107                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
9108                                                                     )
9109        ENDDO
9110        ENDDO
9111
9112    ENDIF
9113
9114    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
9115
9116        DO i = i_start, i_end
9117        DO k = kts, ktf
9118          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
9119          tendency(i,k,jts) = tendency(i,k,jts)                     &
9120                - rdy*(                                             &
9121                        vb*(  field_old(i,k,jts+1)                  &
9122                            - field_old(i,k,jts  ) ) +              &
9123                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
9124                                                                 )
9125        ENDDO
9126        ENDDO
9127
9128    ENDIF
9129
9130    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
9131
9132        DO i = i_start, i_end
9133        DO k = kts, ktf
9134          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
9135          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
9136                - rdy*(                                               &
9137                        vb*(   field_old(i,k,j_end  )                 &
9138                             - field_old(i,k,j_end-1) ) +             &
9139                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
9140                                                                     )
9141        ENDDO
9142        ENDDO
9143
9144    ENDIF
9145
9146    IF( (config_flags%polar) .and. (jts == jds) ) THEN
9147
9148        ! Assuming rv(i,k,jds) = 0.
9149        DO i = i_start, i_end
9150        DO k = kts, ktf
9151          vb = MIN( 0.5*rv(i,k,jts+1), 0. )
9152          tendency(i,k,jts) = tendency(i,k,jts)                     &
9153                - rdy*(                                             &
9154                        vb*(  field_old(i,k,jts+1)                  &
9155                            - field_old(i,k,jts  ) ) +              &
9156                        field(i,k,jts)*rv(i,k,jts+1)                &
9157                                                                 )
9158        ENDDO
9159        ENDDO
9160
9161    ENDIF
9162
9163    IF( (config_flags%polar) .and. (jte == jde)) THEN
9164
9165        ! Assuming rv(i,k,jde) = 0.
9166        DO i = i_start, i_end
9167        DO k = kts, ktf
9168          vb = MAX( 0.5*rv(i,k,jte-1), 0. )
9169          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
9170                - rdy*(                                               &
9171                        vb*(   field_old(i,k,j_end  )                 &
9172                             - field_old(i,k,j_end-1) ) +             &
9173                        field(i,k,j_end)*(-rv(i,k,jte-1))             &
9174                                                                     )
9175        ENDDO
9176        ENDDO
9177
9178    ENDIF
9179
9180 !-------------------- vertical advection
9181
9182 !-- loop bounds for periodic or sym conditions
9183
9184       i_start = its-1
9185       i_end   = MIN(ite,ide-1)+1
9186       j_start = jts-1
9187       j_end   = MIN(jte,jde-1)+1
9188
9189 !-- loop bounds for open or specified conditions
9190
9191     IF(degrade_xs) i_start = MAX(its-1,ids)
9192     IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
9193     IF(degrade_ys) j_start = MAX(jts-1,jds)
9194     IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
9195
9196 !    vert_order_test : IF (vert_order == 6) THEN
9197
9198
9199 !    ELSE IF (vert_order == 5) THEN
9200
9201       DO j = j_start, j_end
9202
9203          DO i = i_start, i_end
9204            fqz(i,1,j)  = 0.
9205            fqzl(i,1,j) = 0.
9206            fqz(i,kde,j)  = 0.
9207            fqzl(i,kde,j) = 0.
9208          ENDDO
9209
9210          DO k=kts+3,ktf-2
9211          DO i = i_start, i_end
9212            dz = 2./(rdzw(k)+rdzw(k-1))
9213            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
9214            vel = rom(i,k,j)
9215            cr = vel*dt/dz/mu
9216            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9217
9218
9219          IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN
9220             qip2 = field(i,k+1,j)
9221             qip1 = field(i,k  ,j)
9222             qi   = field(i,k-1,j)
9223             qim1 = field(i,k-2,j)
9224             qim2 = field(i,k-3,j)
9225           ELSE
9226             qip2 = field(i,k-2,j)
9227             qip1 = field(i,k-1,j)
9228             qi   = field(i,k  ,j)
9229             qim1 = field(i,k+1,j)
9230             qim2 = field(i,k+2,j)
9231          ENDIF
9232
9233          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
9234          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
9235          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
9236
9237          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
9238          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
9239          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
9240
9241          wi0 = gi0 / (eps1 + beta0)**pw
9242          wi1 = gi1 / (eps1 + beta1)**pw
9243          wi2 = gi2 / (eps1 + beta2)**pw
9244
9245          sumwk = wi0 + wi1 + wi2
9246
9247           fqz(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
9248
9249 !           fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
9250 !                                   field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
9251            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9252          ENDDO
9253          ENDDO
9254
9255          DO i = i_start, i_end
9256
9257            k=kts+1
9258            dz = 2./(rdzw(k)+rdzw(k-1))
9259            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
9260            vel = rom(i,k,j)
9261            cr = vel*dt/dz/mu
9262            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9263            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
9264            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9265
9266            k=kts+2
9267            dz = 2./(rdzw(k)+rdzw(k-1))
9268            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
9269            vel = rom(i,k,j)
9270            cr = vel*dt/dz/mu
9271            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9272
9273            fqz(i,k,j) = vel*flux3(                      &
9274                    field(i,k-2,j), field(i,k-1,j),      &
9275                    field(i,k  ,j), field(i,k+1,j),  -vel )
9276            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9277
9278            k=ktf-1
9279            dz = 2./(rdzw(k)+rdzw(k-1))
9280            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
9281            vel = rom(i,k,j)
9282            cr = vel*dt/dz/mu
9283            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9284
9285            fqz(i,k,j) = vel*flux3(                      &
9286                    field(i,k-2,j), field(i,k-1,j),      &
9287                    field(i,k  ,j), field(i,k+1,j),  -vel )
9288            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9289
9290            k=ktf
9291            dz = 2./(rdzw(k)+rdzw(k-1))
9292            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
9293            vel = rom(i,k,j)
9294            cr = vel*dt/dz/mu
9295            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9296            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
9297            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9298
9299          ENDDO
9300
9301       ENDDO
9302
9303
9304 !   ELSE
9305
9306 !      WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order
9307 !      CALL wrf_error_fatal ( wrf_err_message )
9308
9309 !   ENDIF vert_order_test
9310
9311    IF (pd_limit) THEN
9312
9313 ! positive definite filter
9314
9315    i_start = its-1
9316    i_end   = MIN(ite,ide-1)+1
9317    j_start = jts-1
9318    j_end   = MIN(jte,jde-1)+1
9319
9320 !-- loop bounds for open or specified conditions
9321
9322    IF(degrade_xs) i_start = MAX(its-1,ids)
9323    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
9324    IF(degrade_ys) j_start = MAX(jts-1,jds)
9325    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
9326
9327    IF(config_flags%specified .or. config_flags%nested) THEN
9328      IF (degrade_xs) i_start = MAX(its-1,ids+1)
9329      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
9330      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
9331      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
9332    END IF
9333
9334    IF(config_flags%open_xs) THEN
9335      IF (degrade_xs) i_start = MAX(its-1,ids+1)
9336    END IF
9337    IF(config_flags%open_xe) THEN
9338      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
9339    END IF
9340    IF(config_flags%open_ys) THEN
9341      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
9342    END IF
9343    IF(config_flags%open_ye) THEN
9344      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
9345    END IF
9346    ! ADT note:
9347    ! We don't want to change j_start and j_end
9348    ! for polar BC's since we want to calculate
9349    ! fluxes for directions other than y at the
9350    ! edge
9351
9352 !-- here is the limiter...
9353
9354    DO j=j_start, j_end
9355    DO k=kts, ktf
9356 #ifdef XEON_SIMD
9357 !DIR$ simd
9358 #else
9359 !DIR$ vector always
9360 #endif
9361    DO i=i_start, i_end
9362
9363      ph_low(i,k,j) = ((c1(k)*mub(i,j)+c2(k))+(c1(k)*mu_old(i,j)))*field_old(i,k,j)        &
9364                 - dt*( msftx(i,j)*msfty(i,j)*(               &
9365                        rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
9366                        rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
9367                       +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
9368
9369    ENDDO
9370    ENDDO
9371    ENDDO
9372
9373    DO j=j_start, j_end
9374    DO k=kts, ktf
9375 !DIR$ vector always
9376    DO i=i_start, i_end
9377
9378      flux_out(i,k,j) = dt*( (msftx(i,j)*msfty(i,j))*(                    &
9379                                 rdx*(  max(0.,fqx (i+1,k,j))      &
9380                                       -min(0.,fqx (i  ,k,j)) )    &
9381                                +rdy*(  max(0.,fqy (i,k,j+1))      &
9382                                       -min(0.,fqy (i,k,j  )) ) )  &
9383                 +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
9384                                       -max(0.,fqz (i,k  ,j)) )   )
9385
9386    ENDDO
9387    ENDDO
9388    ENDDO
9389
9390    DO j=j_start, j_end
9391    DO k=kts, ktf
9392 !DIR$ vector always
9393    DO i=i_start, i_end
9394
9395      IF( flux_out(i,k,j) .gt. ph_low(i,k,j) ) THEN
9396
9397        scale = max(0.,ph_low(i,k,j)/(flux_out(i,k,j)+eps))
9398        IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j)
9399        IF( fqx (i  ,k,j) .lt. 0.) fqx(i  ,k,j) = scale*fqx(i  ,k,j)
9400        IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1)
9401        IF( fqy (i,k,j  ) .lt. 0.) fqy(i,k,j  ) = scale*fqy(i,k,j  )
9402 !  note: z flux is opposite sign in mass coordinate because
9403 !  vertical coordinate decreases with increasing k
9404        IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j)
9405        IF( fqz (i,k  ,j) .gt. 0.) fqz(i,k  ,j) = scale*fqz(i,k  ,j)
9406
9407      END IF
9408
9409    ENDDO
9410    ENDDO
9411    ENDDO
9412
9413    END IF
9414
9415 ! add in the pd-limited flux divergence
9416
9417   i_start = its
9418   i_end   = MIN(ite,ide-1)
9419   j_start = jts
9420   j_end   = MIN(jte,jde-1)
9421
9422   DO j = j_start, j_end
9423   DO k = kts, ktf
9424   DO i = i_start, i_end
9425
9426      tendency (i,k,j) = tendency(i,k,j)                           &
9427                             -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
9428                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
9429
9430   ENDDO
9431   ENDDO
9432   ENDDO
9433
9434 ! x flux divergence
9435 !
9436   IF(degrade_xs) i_start = MAX(its,ids+1)
9437   IF(degrade_xe) i_end   = MIN(ite,ide-2)
9438
9439   DO j = j_start, j_end
9440   DO k = kts, ktf
9441   DO i = i_start, i_end
9442
9443      ! Un-"canceled" map scale factor, ADT Eq. 48
9444      tendency (i,k,j) = tendency(i,k,j)                           &
9445                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
9446                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
9447
9448   ENDDO
9449   ENDDO
9450   ENDDO
9451
9452 ! y flux divergence
9453 !
9454   i_start = its
9455   i_end   = MIN(ite,ide-1)
9456   IF(degrade_ys) j_start = MAX(jts,jds+1)
9457   IF(degrade_ye) j_end   = MIN(jte,jde-2)
9458
9459   DO j = j_start, j_end
9460   DO k = kts, ktf
9461   DO i = i_start, i_end
9462
9463      ! Un-"canceled" map scale factor, ADT Eq. 48
9464      ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
9465      tendency (i,k,j) = tendency(i,k,j)                           &
9466                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
9467                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
9468
9469   ENDDO
9470   ENDDO
9471   ENDDO
9472
9473 END SUBROUTINE advect_scalar_wenopd
9474
9475 !----------------------------------------------------------------
9476
9477 SUBROUTINE advect_scalar_mono   ( field, field_old, tendency,    &
9478                                   h_tendency, z_tendency,        &
9479                                   ru, rv, rom, romI,             &
9480                                   c1, c2,                        &
9481                                   mut, mub, mu_old,              &
9482                                   config_flags,                  &
9483                                   tenddec,                       &
9484                                   msfux, msfuy, msfvx, msfvy,    &
9485                                   msftx, msfty,                  &
9486                                   fzm, fzp,                      &
9487                                   rdx, rdy, rdzw, dt,            &
9488                                   ids, ide, jds, jde, kds, kde,  &
9489                                   ims, ime, jms, jme, kms, kme,  &
9490                                   its, ite, jts, jte, kts, kte  )
9491
9492 !  monotonic advection option
9493 !  for scalars in WRF RK3 advection.  This version is memory intensive ->
9494 !  we save 3d arrays of x, y and z both high and low order fluxes
9495 !  (six in all).  Alternatively, we could sweep in a direction
9496 !  and lower the cost considerably.
9497
9498 !  uses the Smolarkiewicz MWR 1989 approach, with addition of first-order
9499 !  fluxes initially
9500
9501    IMPLICIT NONE
9502
9503    ! Input data
9504
9505    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
9506
9507    LOGICAL ,                 INTENT(IN   ) :: tenddec ! tendency flag
9508
9509    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
9510                                               ims, ime, jms, jme, kms, kme, &
9511                                               its, ite, jts, jte, kts, kte
9512
9513    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
9514                                                                       field_old, &
9515                                                                       ru,        &
9516                                                                       rv,        &
9517                                                                       romI,      &
9518                                                                       rom
9519
9520    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut, mub, mu_old
9521    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
9522    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(  OUT) :: h_tendency, z_tendency
9523
9524    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
9525                                                                     msfuy,  &
9526                                                                     msfvx,  &
9527                                                                     msfvy,  &
9528                                                                     msftx,  &
9529                                                                     msfty
9530
9531    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
9532                                                                   fzp,  &
9533                                                                   rdzw, &
9534                                                                   c1,   &
9535                                                                   c2
9536
9537    REAL ,                                        INTENT(IN   ) :: rdx,  &
9538                                                                   rdy,  &
9539                                                                   dt
9540
9541    ! Local data
9542
9543    INTEGER :: i, j, k, itf, jtf, ktf
9544    INTEGER :: i_start, i_end, j_start, j_end
9545    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
9546    INTEGER :: jmin, jmax, jp, jm, imin, imax
9547
9548    REAL    :: mrdx, mrdy, ub, vb, uw, vw, mu, ieva_corr
9549    REAL , DIMENSION(its:ite, kts:kte) :: vflux
9550
9551
9552 !  storage for high and low order fluxes
9553
9554    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: fqx, fqy, fqz
9555    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: fqxl, fqyl, fqzl
9556    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: qmin, qmax
9557    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: scale_in, scale_out
9558    REAL :: ph_upwind
9559
9560    INTEGER :: horz_order, vert_order
9561
9562    LOGICAL :: degrade_xs, degrade_ys
9563    LOGICAL :: degrade_xe, degrade_ye
9564
9565    INTEGER :: jp1, jp0, jtmp
9566
9567    REAL :: flux_out, ph_low, flux_in, ph_hi, scale
9568    REAL, PARAMETER :: eps=1.e-20
9569
9570
9571 ! definition of flux operators, 3rd, 4rth, 5th or 6th order
9572
9573    REAL    :: flux3, flux4, flux5, flux6, flux_upwind
9574    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
9575
9576       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
9577             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
9578
9579       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
9580            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
9581            sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
9582
9583       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
9584             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
9585             +(1./60.)*(q_ip2+q_im3)
9586
9587       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
9588            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
9589             -sign(1.,ua)*(1./60.)*(                             &
9590               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
9591
9592 !      flux_upwind(q_im1, q_i, cr ) = 0.
9593       flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
9594                                     +0.5*(1.-sign(1.,cr))*q_i
9595
9596     LOGICAL, PARAMETER :: mono_limit = .true.
9597
9598 ! set order for the advection schemes
9599
9600   ktf=MIN(kte,kde-1)
9601   horz_order = config_flags%h_sca_adv_order
9602   vert_order = config_flags%v_sca_adv_order
9603
9604   do j=jts-2,jte+2
9605   do k=kts,kte
9606   do i=its-2,ite+2
9607     qmin(i,k,j) = field_old(i,k,j)
9608     qmax(i,k,j) = field_old(i,k,j)
9609     scale_in(i,k,j) = 1.
9610     scale_out(i,k,j) = 1.
9611     fqx(i,k,j) = 0.
9612     fqy(i,k,j) = 0.
9613     fqz(i,k,j) = 0.
9614     fqxl(i,k,j) = 0.
9615     fqyl(i,k,j) = 0.
9616     fqzl(i,k,j) = 0.
9617   enddo
9618   enddo
9619   enddo
9620
9621 !  begin with horizontal flux divergence
9622 !  here is the choice of flux operators
9623
9624
9625   horizontal_order_test : IF( horz_order == 5 ) THEN
9626
9627 !  determine boundary mods for flux operators
9628 !  We degrade the flux operators from 3rd/4rth order
9629 !   to second order one gridpoint in from the boundaries for
9630 !   all boundary conditions except periodic and symmetry - these
9631 !   conditions have boundary zone data fill for correct application
9632 !   of the higher order flux stencils
9633
9634    degrade_xs = .true.
9635    degrade_xe = .true.
9636    degrade_ys = .true.
9637    degrade_ye = .true.
9638
9639    IF( config_flags%periodic_x   .or. &
9640        config_flags%symmetric_xs .or. &
9641        (its > ids+3)                ) degrade_xs = .false.
9642    IF( config_flags%periodic_x   .or. &
9643        config_flags%symmetric_xe .or. &
9644        (ite < ide-4)                ) degrade_xe = .false.
9645    IF( config_flags%periodic_y   .or. &
9646        config_flags%symmetric_ys .or. &
9647        (jts > jds+3)                ) degrade_ys = .false.
9648    IF( config_flags%periodic_y   .or. &
9649        config_flags%symmetric_ye .or. &
9650        (jte < jde-4)                ) degrade_ye = .false.
9651
9652 !--------------- y - advection first
9653
9654 !--  y flux compute; these bounds are for periodic and sym b.c.
9655
9656       ktf=MIN(kte,kde-1)
9657       i_start = its-1
9658       i_end   = MIN(ite,ide-1)+1
9659       j_start = jts-1
9660       j_end   = MIN(jte,jde-1)+1
9661       j_start_f = j_start
9662       j_end_f   = j_end+1
9663
9664 !--  modify loop bounds if open or specified
9665
9666 !  WCS 20090218
9667 !      IF(degrade_xs) i_start = its
9668 !      IF(degrade_xe) i_end   = MIN(ite,ide-1)
9669       IF(degrade_xs) i_start = MAX(its-1,ids)
9670       IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
9671
9672 !  WCS 20090218
9673 !      IF(degrade_ys) then
9674 !        j_start = MAX(jts,jds+1)
9675 !        j_start_f = jds+3
9676 !      ENDIF
9677 !
9678 !      IF(degrade_ye) then
9679 !        j_end = MIN(jte,jde-2)
9680 !        j_end_f = jde-3
9681 !      ENDIF
9682
9683       IF(degrade_ys) then
9684         j_start = MAX(jts-1,jds+1)
9685         j_start_f = jds+3
9686       ENDIF
9687
9688       IF(degrade_ye) then
9689         j_end = MIN(jte+1,jde-2)
9690         j_end_f = jde-3
9691       ENDIF
9692
9693 !  compute fluxes, 5th order
9694
9695       j_loop_y_flux_5 : DO j = j_start, j_end+1
9696
9697       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
9698
9699         DO k=kts,ktf
9700         DO i = i_start, i_end
9701
9702           vel = rv(i,k,j)
9703           cr = vel
9704           fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), vel)
9705
9706           fqy( i, k, j  ) = vel*flux5(                                  &
9707                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
9708                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
9709
9710           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
9711
9712           if(cr.gt. 0) then
9713              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
9714              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
9715           else
9716              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
9717              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
9718           end if
9719
9720         ENDDO
9721         ENDDO
9722
9723       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
9724
9725             DO k=kts,ktf
9726             DO i = i_start, i_end
9727
9728               vel = rv(i,k,j)
9729               cr = vel
9730               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
9731
9732               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
9733                      (field(i,k,j)+field(i,k,j-1))
9734
9735               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
9736
9737           if(cr.gt. 0) then
9738              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
9739              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
9740           else
9741              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
9742              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
9743           end if
9744
9745             ENDDO
9746             ENDDO
9747
9748       ELSE IF  ( j == jds+2 ) THEN  ! third of 4rth order flux 2 in from south boundary
9749
9750             DO k=kts,ktf
9751             DO i = i_start, i_end
9752
9753               vel = rv(i,k,j)
9754               cr = vel
9755               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
9756
9757               fqy( i, k, j ) = vel*flux3(              &
9758                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
9759               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
9760
9761           if(cr.gt. 0) then
9762              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
9763              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
9764           else
9765              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
9766              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
9767           end if
9768
9769             ENDDO
9770             ENDDO
9771
9772       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
9773
9774             DO k=kts,ktf
9775             DO i = i_start, i_end
9776
9777               vel = rv(i,k,j)
9778               cr = vel
9779               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
9780
9781               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
9782                      (field(i,k,j)+field(i,k,j-1))
9783               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
9784
9785           if(cr.gt. 0) then
9786              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
9787              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
9788           else
9789              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
9790              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
9791           end if
9792
9793             ENDDO
9794             ENDDO
9795
9796       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4rth order flux 2 in from north boundary
9797
9798             DO k=kts,ktf
9799             DO i = i_start, i_end
9800
9801               vel = rv(i,k,j)
9802               cr = vel
9803               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
9804
9805               fqy( i, k, j) = vel*flux3(             &
9806                    field(i,k,j-2),field(i,k,j-1),    &
9807                    field(i,k,j),field(i,k,j+1),vel )
9808               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
9809
9810           if(cr.gt. 0) then
9811              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
9812              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
9813           else
9814              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
9815              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
9816           end if
9817
9818             ENDDO
9819             ENDDO
9820
9821       ENDIF
9822
9823    ENDDO j_loop_y_flux_5
9824
9825 !  next, x flux
9826
9827 !--  these bounds are for periodic and sym conditions
9828
9829       i_start = its-1
9830       i_end   = MIN(ite,ide-1)+1
9831       i_start_f = i_start
9832       i_end_f   = i_end+1
9833
9834       j_start = jts-1
9835       j_end   = MIN(jte,jde-1)+1
9836
9837 !--  modify loop bounds for open and specified b.c
9838
9839 !  WCS 20090218
9840 !      IF(degrade_ys) j_start = jts
9841 !      IF(degrade_ye) j_end   = MIN(jte,jde-1)
9842       IF(degrade_ys) j_start = MAX(jts-1,jds)
9843       IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
9844
9845 !  WCS 20090218
9846 !      IF(degrade_xs) then
9847 !        i_start = MAX(ids+1,its)
9848 !        i_start_f = i_start+2
9849 !      ENDIF
9850
9851 !      IF(degrade_xe) then
9852 !        i_end = MIN(ide-2,ite)
9853 !        i_end_f = ide-3
9854 !      ENDIF
9855
9856       IF(degrade_xs) then
9857         i_start = MAX(ids+1,its-1)
9858         i_start_f = ids+3
9859       ENDIF
9860
9861       IF(degrade_xe) then
9862         i_end = MIN(ide-2,ite+1)
9863         i_end_f = ide-3
9864       ENDIF
9865
9866 !  compute fluxes
9867
9868       DO j = j_start, j_end
9869
9870 !  5th or 6th order flux
9871
9872         DO k=kts,ktf
9873         DO i = i_start_f, i_end_f
9874
9875           vel = ru(i,k,j)
9876           cr = vel
9877           fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9878
9879           fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
9880                                          field(i-1,k,j), field(i  ,k,j),  &
9881                                          field(i+1,k,j), field(i+2,k,j),  &
9882                                          vel                             )
9883           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9884
9885           if(cr.gt. 0) then
9886              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9887              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9888           else
9889              qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9890              qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9891           end if
9892
9893         ENDDO
9894         ENDDO
9895
9896 !  lower order fluxes close to boundaries (if not periodic or symmetric)
9897
9898 !  WCS 20090218 degrade_xs and xe recoded
9899
9900         IF( degrade_xs ) THEN
9901
9902           DO i=i_start,i_start_f-1
9903
9904             IF(i == ids+1) THEN ! second order
9905               DO k=kts,ktf
9906                 vel = ru(i,k,j)
9907                 cr = vel
9908                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9909
9910                 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
9911                        *(field(i,k,j)+field(i-1,k,j))
9912
9913                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9914
9915                 if(cr.gt. 0) then
9916                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9917                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9918                 else
9919                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9920                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9921                 end if
9922               ENDDO
9923             ENDIF
9924
9925             IF(i == ids+2) THEN  ! third order
9926               DO k=kts,ktf
9927                 vel = ru(i,k,j)
9928                 cr = vel
9929                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9930                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
9931                                           field(i  ,k,j), field(i+1,k,j),  &
9932                                           vel                             )
9933                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9934
9935                 if(cr.gt. 0) then
9936                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9937                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9938                 else
9939                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9940                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9941                 end if
9942               ENDDO
9943             ENDIF
9944
9945           ENDDO
9946
9947         ENDIF
9948
9949         IF( degrade_xe ) THEN
9950
9951           DO i = i_end_f+1, i_end+1
9952
9953             IF( i == ide-1 ) THEN ! second order flux next to the boundary
9954               DO k=kts,ktf
9955                 vel = ru(i,k,j)
9956                 cr = vel
9957                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9958                 fqx(i,k,j) = 0.5*(ru(i,k,j))      &
9959                        *(field(i,k,j)+field(i-1,k,j))
9960                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9961
9962                 if(cr.gt. 0) then
9963                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9964                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9965                 else
9966                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9967                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9968                 end if
9969               ENDDO
9970             ENDIF
9971
9972             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
9973               DO k=kts,ktf
9974                 vel = ru(i,k,j)
9975                 cr = vel
9976                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9977                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
9978                                           field(i  ,k,j), field(i+1,k,j),  &
9979                                           vel                             )
9980                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9981
9982                 if(cr.gt. 0) then
9983                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9984                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9985                 else
9986                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9987                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9988                 end if
9989               ENDDO
9990             ENDIF
9991           ENDDO
9992         ENDIF
9993
9994       ENDDO  ! enddo for outer J loop
9995
9996    ELSE
9997
9998       WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_mono, h_order not known ',horz_order
9999       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
10000
10001    ENDIF horizontal_order_test
10002
10003 !  pick up the rest of the horizontal radiation boundary conditions.
10004 !  (these are the computations that don't require 'cb'.
10005 !  first, set to index ranges
10006
10007       i_start = its
10008       i_end   = MIN(ite,ide-1)
10009       j_start = jts
10010       j_end   = MIN(jte,jde-1)
10011
10012 !  compute x (u) conditions for v, w, or scalar
10013
10014    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
10015
10016        DO j = j_start, j_end
10017        DO k = kts, ktf
10018          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
10019          tendency(its,k,j) = tendency(its,k,j)                     &
10020                - rdx*(                                             &
10021                        ub*(   field_old(its+1,k,j)                 &
10022                             - field_old(its  ,k,j)   ) +           &
10023                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
10024                                                                 )
10025        ENDDO
10026        ENDDO
10027
10028    ENDIF
10029
10030    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
10031
10032        DO j = j_start, j_end
10033        DO k = kts, ktf
10034          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
10035          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
10036                - rdx*(                                               &
10037                        ub*(  field_old(i_end  ,k,j)                  &
10038                            - field_old(i_end-1,k,j) ) +              &
10039                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
10040                                                                     )
10041        ENDDO
10042        ENDDO
10043
10044    ENDIF
10045
10046    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
10047
10048        DO i = i_start, i_end
10049        DO k = kts, ktf
10050          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
10051          tendency(i,k,jts) = tendency(i,k,jts)                     &
10052                - rdy*(                                             &
10053                        vb*(  field_old(i,k,jts+1)                  &
10054                            - field_old(i,k,jts  ) ) +              &
10055                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
10056                                                                 )
10057        ENDDO
10058        ENDDO
10059
10060    ENDIF
10061
10062    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
10063
10064        DO i = i_start, i_end
10065        DO k = kts, ktf
10066          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
10067          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
10068                - rdy*(                                               &
10069                        vb*(   field_old(i,k,j_end  )                 &
10070                             - field_old(i,k,j_end-1) ) +             &
10071                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
10072                                                                     )
10073        ENDDO
10074        ENDDO
10075
10076    ENDIF
10077
10078 !-------------------- vertical advection
10079
10080 !-- loop bounds for periodic or sym conditions
10081
10082       i_start = its-1
10083       i_end   = MIN(ite,ide-1)+1
10084       j_start = jts-1
10085       j_end   = MIN(jte,jde-1)+1
10086
10087 !-- loop bounds for open or specified conditions
10088
10089 !  WCS 20090218
10090 !    IF(degrade_xs) i_start = its
10091 !    IF(degrade_xe) i_end   = MIN(ite,ide-1)
10092 !    IF(degrade_ys) j_start = jts
10093 !    IF(degrade_ye) j_end   = MIN(jte,jde-1)
10094
10095     IF(degrade_xs) i_start = MAX(its-1,ids)
10096     IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
10097     IF(degrade_ys) j_start = MAX(jts-1,jds)
10098     IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
10099
10100
10101     vert_order_test : IF (vert_order == 3) THEN
10102
10103       DO j = j_start, j_end
10104
10105          DO i = i_start, i_end
10106            fqz(i,1,j)  = 0.
10107            fqzl(i,1,j) = 0.
10108            fqz(i,kde,j)  = 0.
10109            fqzl(i,kde,j) = 0.
10110          ENDDO
10111
10112          DO k=kts+2,ktf-1
10113          DO i = i_start, i_end
10114
10115            vel = rom(i,k,j)
10116            cr = -vel
10117            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10118
10119            fqz(i,k,j) = vel*flux3(                      &
10120                    field(i,k-2,j), field(i,k-1,j),      &
10121                    field(i,k  ,j), field(i,k+1,j),  -vel )
10122            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10123
10124           if(cr.gt. 0) then
10125              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10126              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10127           else
10128              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10129              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10130           end if
10131
10132          ENDDO
10133          ENDDO
10134
10135          DO i = i_start, i_end
10136
10137            k=kts+1
10138            vel = rom(i,k,j)
10139            cr = -vel
10140            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10141            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
10142            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10143
10144           if(cr.gt. 0) then
10145              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10146              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10147           else
10148              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10149              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10150           end if
10151
10152            k=ktf
10153            vel = rom(i,k,j)
10154            cr = -vel
10155            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10156            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
10157            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10158
10159           if(cr.gt. 0) then
10160              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10161              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10162           else
10163              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10164              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10165           end if
10166          ENDDO
10167
10168       ENDDO
10169
10170     ELSE IF (vert_order == 5) THEN
10171
10172       DO j = j_start, j_end
10173
10174          DO i = i_start, i_end
10175            fqz(i,1,j)  = 0.
10176            fqzl(i,1,j) = 0.
10177            fqz(i,kde,j)  = 0.
10178            fqzl(i,kde,j) = 0.
10179          ENDDO
10180
10181          DO k=kts+3,ktf-2
10182          DO i = i_start, i_end
10183
10184            vel = rom(i,k,j)
10185            cr = -vel
10186            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10187
10188            fqz(i,k,j) = vel*flux5(                                 &
10189                    field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
10190                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
10191            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10192
10193           if(cr.gt. 0) then
10194              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10195              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10196           else
10197              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10198              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10199           end if
10200
10201          ENDDO
10202          ENDDO
10203
10204          DO i = i_start, i_end
10205
10206            k=kts+1
10207            vel = rom(i,k,j)
10208            cr = -vel
10209            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10210            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
10211            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10212
10213           if(cr.gt. 0) then
10214              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10215              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10216           else
10217              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10218              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10219           end if
10220
10221            k=kts+2
10222            vel = rom(i,k,j)
10223            cr = -vel
10224            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10225            fqz(i,k,j)= vel*flux3(field(i,k-2,j), field(i,k-1,j),   &
10226                                  field(i,k  ,j), field(i,k+1,j), -vel )
10227            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10228
10229           if(cr.gt. 0) then
10230              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10231              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10232           else
10233              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10234              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10235           end if
10236
10237            k=ktf-1
10238            vel = rom(i,k,j)
10239            cr = -vel
10240            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10241            fqz(i,k,j)= vel*flux3( field(i,k-2,j), field(i,k-1,j),   &
10242                                   field(i,k  ,j), field(i,k+1,j), -vel )
10243            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10244
10245           if(cr.gt. 0) then
10246              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10247              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10248           else
10249              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10250              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10251           end if
10252
10253            k=ktf
10254            vel = rom(i,k,j)
10255            cr = -vel
10256            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10257            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
10258            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10259
10260           if(cr.gt. 0) then
10261              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10262              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10263           else
10264              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10265              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10266           end if
10267
10268          ENDDO
10269
10270       ENDDO
10271
10272    ELSE
10273
10274       WRITE (wrf_err_message,*) ' advect_scalar_mono, v_order not known ',vert_order
10275       CALL wrf_error_fatal ( wrf_err_message )
10276
10277    ENDIF vert_order_test
10278
10279    IF (mono_limit) THEN
10280
10281 ! montonic filter
10282
10283    i_start = its-1
10284    i_end   = MIN(ite,ide-1)+1
10285    j_start = jts-1
10286    j_end   = MIN(jte,jde-1)+1
10287
10288 ! WCS 20090218
10289
10290 !-- loop bounds for open or specified conditions
10291 !
10292 !   IF(degrade_xs) i_start = its
10293 !   IF(degrade_xe) i_end   = MIN(ite,ide-1)
10294 !   IF(degrade_ys) j_start = jts
10295 !   IF(degrade_ye) j_end   = MIN(jte,jde-1)
10296 !
10297 !   IF(config_flags%specified .or. config_flags%nested) THEN
10298 !     IF (degrade_xs) i_start = MAX(its,ids+1)
10299 !     IF (degrade_xe) i_end   = MIN(ite,ide-2)
10300 !     IF (degrade_ys) j_start = MAX(jts,jds+1)
10301 !     IF (degrade_ye) j_end   = MIN(jte,jde-2)
10302 !   END IF
10303 !
10304 !   IF(config_flags%open_xs) THEN
10305 !     IF (degrade_xs) i_start = MAX(its,ids+1)
10306 !   END IF
10307 !   IF(config_flags%open_xe) THEN
10308 !     IF (degrade_xe) i_end   = MIN(ite,ide-2)
10309 !   END IF
10310 !   IF(config_flags%open_ys) THEN
10311 !     IF (degrade_ys) j_start = MAX(jts,jds+1)
10312 !   END IF
10313 !   IF(config_flags%open_ye) THEN
10314 !     IF (degrade_ye) j_end   = MIN(jte,jde-2)
10315 !   END IF
10316
10317    IF(degrade_xs) i_start = MAX(its-1,ids)
10318    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
10319    IF(degrade_ys) j_start = MAX(jts-1,jds)
10320    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
10321
10322    IF(config_flags%specified .or. config_flags%nested) THEN
10323      IF (degrade_xs) i_start = MAX(its-1,ids+1)
10324      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
10325      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
10326      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
10327    END IF
10328
10329    IF(config_flags%open_xs) THEN
10330      IF (degrade_xs) i_start = MAX(its-1,ids+1)
10331    END IF
10332    IF(config_flags%open_xe) THEN
10333      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
10334    END IF
10335    IF(config_flags%open_ys) THEN
10336      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
10337    END IF
10338    IF(config_flags%open_ye) THEN
10339      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
10340    END IF
10341
10342 !-- here is the limiter...
10343
10344    DO j=j_start, j_end
10345    DO k=kts, ktf
10346    DO i=i_start, i_end
10347
10348 ! ----------------------------------------------------------------------------------------------
10349 ! IEVA
10350 ! We need to correct for the partial divergence created by the IEVA scheme.
10351 ! If there is no implicit vertical advection, this term == 1.0.
10352 ! Else, it rescales the qmax & qmin value to reflect the partial divergence present in both the
10353 ! low-order and high-order fluxes because the VV field is partioned.
10354 ! ----------------------------------------------------------------------------------------------
10355
10356      ieva_corr = (c1(k)*mut(i,j)+c2(k))+dt*msfty(i,j)*rdzw(k)*(romI(i,k+1,j)-romI(i,k,j))
10357
10358 ! ----------------------------------------------------------------------------------------------
10359
10360      ph_upwind = ((c1(k)*mub(i,j)+c2(k))+(c1(k)*mu_old(i,j)))*field_old(i,k,j)        &
10361                    - dt*( msftx(i,j)*msfty(i,j)*(               &
10362                           rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
10363                           rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
10364                          +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
10365
10366      flux_in = -dt*( (msftx(i,j)*msfty(i,j))*(                   &
10367                                rdx*(  min(0.,fqx (i+1,k,j))      &
10368                                      -max(0.,fqx (i  ,k,j)) )    &
10369                               +rdy*(  min(0.,fqy (i,k,j+1))      &
10370                                      -max(0.,fqy (i,k,j  )) ) )  &
10371                +msfty(i,j)*rdzw(k)*(  max(0.,fqz (i,k+1,j))      &
10372                                      -min(0.,fqz (i,k  ,j)) )   )
10373
10374      ph_hi = ieva_corr*qmax(i,k,j) - ph_upwind
10375
10376      IF( flux_in .gt. ph_hi ) scale_in(i,k,j) = max(0.,ph_hi/(flux_in+eps))
10377
10378
10379      flux_out = dt*( (msftx(i,j)*msfty(i,j))*(                    &
10380                                 rdx*(  max(0.,fqx (i+1,k,j))      &
10381                                       -min(0.,fqx (i  ,k,j)) )    &
10382                                +rdy*(  max(0.,fqy (i,k,j+1))      &
10383                                       -min(0.,fqy (i,k,j  )) ) )  &
10384                 +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
10385                                       -max(0.,fqz (i,k  ,j)) )   )
10386
10387      ph_low = ph_upwind - ieva_corr*qmin(i,k,j)
10388
10389      IF( flux_out .gt. ph_low ) scale_out(i,k,j) = max(0.,ph_low/(flux_out+eps))
10390
10391    ENDDO
10392    ENDDO
10393    ENDDO
10394
10395    DO j=j_start, j_end
10396    DO k=kts, ktf
10397    DO i=i_start, i_end+1
10398        IF( fqx (i,k,j) .gt. 0.) then
10399          fqx(i,k,j) = min(scale_in(i,k,j),scale_out(i-1,k,j))*fqx(i,k,j)
10400        ELSE
10401          fqx(i,k,j) = min(scale_out(i,k,j),scale_in(i-1,k,j))*fqx(i,k,j)
10402        ENDIF
10403    ENDDO
10404    ENDDO
10405    ENDDO
10406
10407    DO j=j_start, j_end+1
10408    DO k=kts, ktf
10409    DO i=i_start, i_end
10410        IF( fqy (i,k,j) .gt. 0.) then
10411          fqy(i,k,j) = min(scale_in(i,k,j),scale_out(i,k,j-1))*fqy(i,k,j)
10412        ELSE
10413          fqy(i,k,j) = min(scale_out(i,k,j),scale_in(i,k,j-1))*fqy(i,k,j)
10414        ENDIF
10415    ENDDO
10416    ENDDO
10417    ENDDO
10418
10419    DO j=j_start, j_end
10420    DO k=kts+1, ktf
10421    DO i=i_start, i_end
10422        IF( fqz (i,k,j) .lt. 0.) then
10423          fqz(i,k,j) = min(scale_in(i,k,j),scale_out(i,k-1,j))*fqz(i,k,j)
10424        ELSE
10425          fqz(i,k,j) = min(scale_out(i,k,j),scale_in(i,k-1,j))*fqz(i,k,j)
10426        ENDIF
10427    ENDDO
10428    ENDDO
10429    ENDDO
10430
10431    END IF
10432
10433 ! add in the mono-limited flux divergence
10434 ! we need to fix this for open b.c set ***********
10435
10436   i_start = its
10437   i_end   = MIN(ite,ide-1)
10438   j_start = jts
10439   j_end   = MIN(jte,jde-1)
10440
10441   DO j = j_start, j_end
10442   DO k = kts, ktf
10443   DO i = i_start, i_end
10444
10445      tendency (i,k,j) = tendency(i,k,j)                           &
10446                             -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
10447                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
10448
10449   ENDDO
10450   ENDDO
10451   ENDDO
10452
10453   IF(tenddec) THEN
10454   DO j = j_start, j_end
10455   DO k = kts, ktf
10456   DO i = i_start, i_end
10457
10458      z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
10459                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
10460
10461   ENDDO
10462   ENDDO
10463   ENDDO
10464   END IF
10465
10466 ! x flux divergence
10467 !
10468
10469 ! WCS 20090218
10470 !  IF(degrade_xs) i_start = i_start + 1
10471 !  IF(degrade_xe) i_end   = i_end   - 1
10472
10473   IF(degrade_xs) i_start = MAX(its,ids+1)
10474   IF(degrade_xe) i_end   = MIN(ite,ide-2)
10475
10476   DO j = j_start, j_end
10477   DO k = kts, ktf
10478   DO i = i_start, i_end
10479
10480      ! Un-"canceled" map scale factor, ADT Eq. 48
10481      tendency (i,k,j) = tendency(i,k,j)                           &
10482                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
10483                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
10484
10485   ENDDO
10486   ENDDO
10487   ENDDO
10488
10489   IF(tenddec) THEN
10490   DO j = j_start, j_end
10491   DO k = kts, ktf
10492   DO i = i_start, i_end
10493
10494      h_tendency (i,k,j) = 0.                                      &
10495                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
10496                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
10497
10498   ENDDO
10499   ENDDO
10500   ENDDO
10501   END IF
10502
10503 ! y flux divergence
10504 !
10505   i_start = its
10506   i_end   = MIN(ite,ide-1)
10507
10508 ! WCS 20090218
10509 !  IF(degrade_ys) j_start = j_start + 1
10510 !  IF(degrade_ye) j_end   = j_end   - 1
10511
10512   IF(degrade_ys) j_start = MAX(jts,jds+1)
10513   IF(degrade_ye) j_end   = MIN(jte,jde-2)
10514
10515   DO j = j_start, j_end
10516   DO k = kts, ktf
10517   DO i = i_start, i_end
10518
10519      ! Un-"canceled" map scale factor, ADT Eq. 48
10520      tendency (i,k,j) = tendency(i,k,j)                           &
10521                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
10522                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
10523
10524   ENDDO
10525   ENDDO
10526   ENDDO
10527
10528   IF(tenddec) THEN
10529   DO j = j_start, j_end
10530   DO k = kts, ktf
10531   DO i = i_start, i_end
10532
10533      h_tendency (i,k,j) = h_tendency (i,k,j)                      &
10534                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
10535                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
10536
10537   ENDDO
10538   ENDDO
10539   ENDDO
10540   END IF
10541
10542 END SUBROUTINE advect_scalar_mono
10543
10544 !-----------------------------------------------------------
10545
10546 #if ( defined(ADVECT_KERNEL) )
10547
10548 END MODULE advection_kernel
10549 !================================================================
10550 !================================================================
10551 PROGRAM feeder
10552    USE advection_kernel
10553    IMPLICIT NONE
10554    INTEGER , PARAMETER :: MAX_SCALARS = 1
10555    TYPE(grid_config_rec_type) :: config_flags
10556    LOGICAL :: tenddec = .false.
10557    INTEGER :: ids, ide, jds, jde, kds, kde, &
10558               ims, ime, jms, jme, kms, kme, &
10559               its, ite, jts, jte, kts, kte
10560    REAL , DIMENSION( :,:,:,: ) , ALLOCATABLE :: field,    &
10561                                                 field_old
10562    REAL , DIMENSION( :,:,: ) , ALLOCATABLE ::  ru,  &
10563                                                rv,  &
10564                                                rom, &
10565                                                romI
10566    REAL , DIMENSION( :,: ), ALLOCATABLE :: mut, mub, mu_old
10567    REAL , DIMENSION( :,:,: ), ALLOCATABLE :: tendency
10568    REAL , DIMENSION( :,:,: ), ALLOCATABLE :: h_tendency, z_tendency
10569    REAL , DIMENSION( :,: ), ALLOCATABLE :: msfux, &
10570                                            msfuy, &
10571                                            msfvx, &
10572                                            msfvy, &
10573                                            msftx, &
10574                                            msfty
10575    REAL , DIMENSION( : ), ALLOCATABLE :: fzm, &
10576                                          fzp, &
10577                                          c1, c2, &
10578                                          rdzw, znw,dnw, rdnw, dn, rdn
10579    REAL :: rdx, &
10580            rdy, &
10581            dt
10582    INTEGER :: time_step, im
10583    INTEGER :: i, j, k, n, loop
10584
10585    config_flags%scalar_adv_opt = 2
10586
10587    PRINT *,'Init dimensions'
10588    ids = 1; ide = 91; jds = 1; jde = 3; kds = 1; kde =10
10589    ims = -5; ime = 96; jms = -5; jme = 8; kms = 1; kme = 10
10590    its = 1; ite = 91; jts = 1; jte = 3; kts = 1; kte = 10
10591    PRINT *,'ALLOCATE two 4d fields'
10592    PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1)*MAX_SCALARS
10593    ALLOCATE ( field(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) )
10594    ALLOCATE ( field_old(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) )
10595    PRINT *,'ALLOCATE three 3d fields U, V, W'
10596    PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1)
10597    ALLOCATE ( ru(ims:ime , kms:kme , jms:jme ) )
10598    ALLOCATE ( rv(ims:ime , kms:kme , jms:jme ) )
10599    ALLOCATE ( rom(ims:ime , kms:kme , jms:jme ) )
10600    ALLOCATE ( romI(ims:ime , kms:kme , jms:jme ) )
10601    PRINT *,'ALLOCATE three 2d MU fields'
10602    PRINT *,(ime-ims+1)*(jme-jms+1)
10603    ALLOCATE ( mut(ims:ime , jms:jme) )
10604    ALLOCATE ( mub(ims:ime , jms:jme) )
10605    ALLOCATE ( mu_old(ims:ime , jms:jme) )
10606    PRINT *,'ALLOCATE three 3d tendency'
10607    PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1)
10608    ALLOCATE ( tendency( ims:ime , kms:kme , jms:jme ) )
10609    ALLOCATE ( h_tendency( ims:ime , kms:kme , jms:jme ) )
10610    ALLOCATE ( z_tendency( ims:ime , kms:kme , jms:jme ) )
10611    PRINT *,'ALLOCATE six 2d map factors'
10612    PRINT *,(ime-ims+1)*(jme-jms+1)
10613    ALLOCATE ( msfux( ims:ime , jms:jme ) )
10614    ALLOCATE ( msfuy( ims:ime , jms:jme ) )
10615    ALLOCATE ( msfvx( ims:ime , jms:jme ) )
10616    ALLOCATE ( msfvy( ims:ime , jms:jme ) )
10617    ALLOCATE ( msftx( ims:ime , jms:jme ) )
10618    ALLOCATE ( msfty( ims:ime , jms:jme ) )
10619    PRINT *,'ALLOCATE 1d arrays'
10620    ALLOCATE ( fzm( kms:kme ) )
10621    ALLOCATE ( fzp( kms:kme ) )
10622    ALLOCATE ( rdzw( kms:kme ) )
10623    ALLOCATE ( znw( kms:kme ) )
10624    ALLOCATE ( dnw( kms:kme ) )
10625    ALLOCATE (rdnw( kms:kme ) )
10626    ALLOCATE ( dn ( kms:kme ) )
10627    ALLOCATE (rdn ( kms:kme ) )
10628    ALLOCATE ( c1 ( kms:kme ) )
10629    ALLOCATE ( c2 ( kms:kme ) )
10630    PRINT *,'CALL init'
10631    CALL init ( config_flags)
10632    CALL tophat ( field , MAX_SCALARS ,&
10633       ids, ide, jds, jde, kds, kde, &
10634       ims, ime, jms, jme, kms, kme, &
10635       its, ite, jts, jte, kts, kte )
10636    CALL tophat ( field_old , MAX_SCALARS , &
10637       ids, ide, jds, jde, kds, kde, &
10638       ims, ime, jms, jme, kms, kme, &
10639       its, ite, jts, jte, kts, kte )
10640    h_tendency = 0
10641    z_tendency = 0
10642    mub = 1
10643    mut = 1
10644    mu_old = 0
10645    ru = 90
10646    rv = 0.
10647    rom = 0.
10648    romI = 0.
10649    msfux = 1
10650    msfuy = 1
10651    msfvx = 1
10652    msfvy = 1
10653    msftx = 1
10654    msfty = 1
10655    rdx = 1/1000.
10656    rdy = 1/1000.
10657    DO k = kts, kte
10658       znw(k) = 1 - (real(k)-kts)/(real(kte)-kts)
10659    END DO
10660    DO k = kts, kte-1
10661       rdzw(k) = 1./(znw(k)-znw(k+1))
10662    END DO
10663    DO k=1, kde-1
10664     dnw(k) = znw(k+1) - znw(k)
10665     rdnw(k) = 1./dnw(k)
10666    ENDDO
10667    DO k=2, kde-1
10668     dn(k) = 0.5*(dnw(k)+dnw(k-1))
10669     rdn(k) = 1./dn(k)
10670     fzp(k) = .5* dnw(k  )/dn(k)
10671     fzm(k) = .5* dnw(k-1)/dn(k)
10672    ENDDO
10673    DO k = kts,kte
10674       c1(k) = 1. ! This is d(B)/d(eta), so assuming no hyb coord
10675       c2(k) = 0. ! This (1 - c1)*(p00 - ptop)
10676    ENDDO
10677
10678    time_step = 5
10679    dt = time_step
10680
10681    field = field_old
10682
10683    ! Loop over advection enough times to get some meaningful timings.
10684    CALL column ( 0 , field(:,1,2,1) , its, ite )
10685    DO loop = 1 , 2000
10686       ! A representative number of times to call the advection in a time period.
10687       IF ( loop .EQ. ((loop)/200)*200 )THEN
10688       PRINT *,'LOOP over scalars',loop
10689       END IF
10690       DO im = 1 , MAX_SCALARS
10691
10692          tendency = 0
10693          CALL advect_scalar    ( field(ims,kms,jms,im), &
10694                                  field_old(ims,kms,jms,im), &
10695                                  tendency(ims,kms,jms), &
10696                                  ru, rv, rom, c1, c2,           &
10697                                  mut, time_step/3, config_flags,&
10698                                  msfux, msfuy, msfvx, msfvy,    &
10699                                  msftx, msfty,                  &
10700                                  fzm, fzp,                      &
10701                                  rdx, rdy, rdzw,                &
10702                                  ids, ide, jds, jde, kds, kde,  &
10703                                  ims, ime, jms, jme, kms, kme,  &
10704                                  its, ite, jts, jte, kts, kte  )
10705          DO n = 1 , MAX_SCALARS
10706             field(:,:,:,n) = field_old(:,:,:,n) + dt * tendency(:,:,:) / 3.
10707          END DO
10708
10709          tendency = 0
10710          CALL advect_scalar    ( field(ims,kms,jms,im), &
10711                                  field_old(ims,kms,jms,im), &
10712                                  tendency(ims,kms,jms), &
10713                                  ru, rv, rom, c1, c2,           &
10714                                  mut, time_step/2, config_flags,&
10715                                  msfux, msfuy, msfvx, msfvy,    &
10716                                  msftx, msfty,                  &
10717                                  fzm, fzp,                      &
10718                                  rdx, rdy, rdzw,                &
10719                                  ids, ide, jds, jde, kds, kde,  &
10720                                  ims, ime, jms, jme, kms, kme,  &
10721                                  its, ite, jts, jte, kts, kte  )
10722          DO n = 1 , MAX_SCALARS
10723             field(:,:,:,n) = field_old(:,:,:,n) + dt * tendency(:,:,:) / 2.
10724          END DO
10725
10726          tendency = 0
10727          IF      (config_flags%scalar_adv_opt .EQ. 0 ) THEN
10728             CALL advect_scalar    ( field(ims,kms,jms,im), &
10729                                     field_old(ims,kms,jms,im), &
10730                                     tendency(ims,kms,jms), &
10731                                     ru, rv, rom, c1, c2,           &
10732                                     mut, time_step, config_flags,  &
10733                                     msfux, msfuy, msfvx, msfvy,    &
10734                                     msftx, msfty,                  &
10735                                     fzm, fzp,                      &
10736                                     rdx, rdy, rdzw,                &
10737                                     ids, ide, jds, jde, kds, kde,  &
10738                                     ims, ime, jms, jme, kms, kme,  &
10739                                     its, ite, jts, jte, kts, kte  )
10740          ELSE IF (config_flags%scalar_adv_opt .EQ. 1 ) THEN
10741             CALL advect_scalar_pd ( field(ims,kms,jms,im),            &
10742                                     field_old(ims,kms,jms,im),        &
10743                                     tendency(ims,kms,jms),            &
10744                                     h_tendency(ims,kms,jms),          &
10745                                     z_tendency(ims,kms,jms),          &
10746                                     ru, rv, rom, c1, c2,              &
10747                                     mut, mub, mu_old,                 &
10748                                     time_step, config_flags, tenddec, &
10749                                     msfux, msfuy, msfvx, msfvy,       &
10750                                     msftx, msfty, fzm, fzp,           &
10751                                     rdx, rdy, rdzw,dt,                &
10752                                     ids, ide, jds, jde, kds, kde,     &
10753                                     ims, ime, jms, jme, kms, kme,     &
10754                                     its, ite, jts, jte, kts, kte )
10755          ELSE IF (config_flags%scalar_adv_opt .EQ. 2 ) THEN
10756             CALL advect_scalar_mono ( field(ims,kms,jms,im),        &
10757                                       field_old(ims,kms,jms,im),    &
10758                                       tendency(ims,kms,jms),        &
10759                                       h_tendency(ims,kms,jms),      &
10760                                       z_tendency(ims,kms,jms),      &
10761                                       ru, rv, rom, romI,            &
10762                                       c1, c2,                       &
10763                                       mut, mub, mu_old,             &
10764                                       config_flags, tenddec,        &
10765                                       msfux, msfuy, msfvx, msfvy,   &
10766                                       msftx, msfty, fzm, fzp,       &
10767                                       rdx, rdy, rdzw,dt,            &
10768                                       ids, ide, jds, jde, kds, kde, &
10769                                       ims, ime, jms, jme, kms, kme, &
10770                                       its, ite, jts, jte, kts, kte )
10771          ELSE IF (config_flags%scalar_adv_opt .EQ. 3 ) THEN
10772             CALL advect_scalar_weno ( field(ims,kms,jms,im),         &
10773                                       field_old(ims,kms,jms,im),     &
10774                                       tendency(ims,kms,jms),         &
10775                                       ru, rv, rom,                   &
10776                                       c1, c2,                        &
10777                                       mut, time_step, config_flags,  &
10778                                       msfux, msfuy, msfvx, msfvy,    &
10779                                       msftx, msfty,                  &
10780                                       fzm, fzp,                      &
10781                                       rdx, rdy, rdzw,                &
10782                                       ids, ide, jds, jde, kds, kde,  &
10783                                       ims, ime, jms, jme, kms, kme,  &
10784                                       its, ite, jts, jte, kts, kte  )
10785          ELSE IF (config_flags%scalar_adv_opt .EQ. 4 ) THEN
10786             CALL advect_scalar_wenopd ( field(ims,kms,jms,im),         &
10787                                         field_old(ims,kms,jms,im),     &
10788                                         tendency(ims,kms,jms),         &
10789                                         ru, rv, rom,                   &
10790                                         c1, c2,                        &
10791                                         mut, mub, mu_old,              &
10792                                         time_step, config_flags,       &
10793                                         msfux, msfuy, msfvx, msfvy,    &
10794                                         msftx, msfty,                  &
10795                                         fzm, fzp,                      &
10796                                         rdx, rdy, rdzw, dt,            &
10797                                         ids, ide, jds, jde, kds, kde,  &
10798                                         ims, ime, jms, jme, kms, kme,  &
10799                                         its, ite, jts, jte, kts, kte  )
10800          END IF
10801          DO n = 1 , MAX_SCALARS
10802             field(:,:,:,n) = field_old(:,:,:,n) + dt * ( tendency(:,:,:) )
10803          END DO
10804
10805          DO k = 1 , kde
10806             field    (:,k,:,:) = field    (:,2,:,:)
10807          END DO
10808
10809          field    (:,:,2,:) = field    (:,:,1,:)
10810          field    (:,:,3,:) = field    (:,:,1,:)
10811
10812          field    (ite+0,:,:,:) = field(ids+0,:,:,:)
10813          field    (ite+1,:,:,:) = field(ids+1,:,:,:)
10814          field    (ite+2,:,:,:) = field(ids+2,:,:,:)
10815          field    (ite+3,:,:,:) = field(ids+3,:,:,:)
10816          field    (ite+4,:,:,:) = field(ids+4,:,:,:)
10817          field    (ids-0,:,:,:) = field(ite-0,:,:,:)
10818          field    (ids-1,:,:,:) = field(ite-1,:,:,:)
10819          field    (ids-2,:,:,:) = field(ite-2,:,:,:)
10820          field    (ids-3,:,:,:) = field(ite-3,:,:,:)
10821          field    (ids-4,:,:,:) = field(ite-4,:,:,:)
10822
10823          field_old = field
10824
10825          IF ( loop .EQ. (loop/200)*200 ) THEN
10826             CALL column ( loop , field(:,1,2,1) , its, ite )
10827          END IF
10828       END DO
10829    END DO
10830
10831    print *,' '
10832    print *,'=============================== '
10833    print *,' '
10834    print *,'Lines to input to gnuplot'
10835    print *,' '
10836    print *,"set terminal x11"
10837    IF      (config_flags%scalar_adv_opt .EQ. 0 ) THEN
10838       print *,'set title "Scalar Advection" font ",20"'
10839    ELSE IF (config_flags%scalar_adv_opt .EQ. 1 ) THEN
10840       print *,'set title "PD Advection" font ",20"'
10841    ELSE IF (config_flags%scalar_adv_opt .EQ. 2 ) THEN
10842       print *,'set title "Mono Advection" font ",20"'
10843    ELSE IF (config_flags%scalar_adv_opt .EQ. 3 ) THEN
10844       print *,'set title "WENO Advection" font ",20"'
10845    ELSE IF (config_flags%scalar_adv_opt .EQ. 4 ) THEN
10846       print *,'set title "WENO PD Advection" font ",20"'
10847    END IF
10848    print *,"set yrange[-20:120]"
10849    print *,"plot [0:90] '000000.txt' with lines , '000200.txt' with lines , '000400.txt' with lines , '000600.txt' with lines , '000800.txt' with lines , '001000.txt' with lines "
10850    print *,"plot [0:90] '000000.txt' with lines , '001200.txt' with lines , '001400.txt' with lines , '001600.txt' with lines , '001800.txt' with lines , '002000.txt' with lines "
10851
10852 END PROGRAM feeder
10853 #endif
10854 #if ( !defined(ADVECT_KERNEL) )
10855
10856 !---------------------------------------------------------------------------------
10857
10858 SUBROUTINE advect_weno_u ( u, u_old, tendency,            &
10859                         ru, rv, rom,                   &
10860                         c1, c2,                        &
10861                         mut, time_step, config_flags,  &
10862                         msfux, msfuy, msfvx, msfvy,    &
10863                         msftx, msfty,                  &
10864                         fzm, fzp,                      &
10865                         rdx, rdy, rdzw,                &
10866                         ids, ide, jds, jde, kds, kde,  &
10867                         ims, ime, jms, jme, kms, kme,  &
10868                         its, ite, jts, jte, kts, kte  )
10869
10870 !
10871 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
10872 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
10873 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
10874 !
10875
10876    IMPLICIT NONE
10877
10878    ! Input data
10879
10880    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
10881
10882    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
10883                                               ims, ime, jms, jme, kms, kme, &
10884                                               its, ite, jts, jte, kts, kte
10885
10886    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: u,     &
10887                                                                       u_old, &
10888                                                                       ru,    &
10889                                                                       rv,    &
10890                                                                       rom
10891
10892    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
10893    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
10894
10895    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
10896                                                                     msfuy,  &
10897                                                                     msfvx,  &
10898                                                                     msfvy,  &
10899                                                                     msftx,  &
10900                                                                     msfty
10901
10902    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
10903                                                                   fzp,  &
10904                                                                   rdzw, &
10905                                                                   c1,   &
10906                                                                   c2
10907
10908    REAL ,                                        INTENT(IN   ) :: rdx,  &
10909                                                                   rdy
10910    INTEGER ,                                     INTENT(IN   ) :: time_step
10911
10912    ! Local data
10913
10914    INTEGER :: i, j, k, itf, jtf, ktf
10915    INTEGER :: i_start, i_end, j_start, j_end
10916    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
10917    INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
10918    INTEGER :: jp1, jp0, jtmp
10919
10920     real            :: dir, vv
10921     real            :: ue,vs,vn,wb,wt
10922     real, parameter :: f30 =  7./12., f31 = 1./12.
10923     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
10924
10925
10926    integer kt,kb
10927
10928
10929     real               :: qim2, qim1, qi, qip1, qip2
10930     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
10931     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18
10932     integer, parameter :: pw = 2
10933
10934
10935    INTEGER :: horz_order, vert_order
10936
10937    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
10938    REAL , DIMENSION(its:ite, kts:kte) :: vflux
10939
10940
10941    REAL,  DIMENSION( its-1:ite+1, kts:kte ) :: fqx
10942    REAL,  DIMENSION( its:ite, kts:kte, 2) :: fqy
10943
10944    LOGICAL :: degrade_xs, degrade_ys
10945    LOGICAL :: degrade_xe, degrade_ye
10946
10947 ! definition of flux operators, 3rd, 4th, 5th or 6th order
10948
10949    REAL    :: flux3, flux4, flux5, flux6
10950    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
10951
10952    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                         &
10953           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
10954
10955    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                         &
10956             flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
10957             sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
10958
10959    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
10960                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)       &
10961                      +(q_ip2+q_im3) )/60.0
10962
10963    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
10964            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)     &
10965             -sign(1,time_step)*sign(1.,ua)*(                     &
10966               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
10967
10968
10969    LOGICAL :: specified
10970
10971    specified = .false.
10972    if(config_flags%specified .or. config_flags%nested) specified = .true.
10973
10974 !  set order for vertical and horzontal flux operators
10975
10976    horz_order = config_flags%h_mom_adv_order
10977    vert_order = config_flags%v_mom_adv_order
10978
10979    ktf=MIN(kte,kde-1)
10980
10981 !  begin with horizontal flux divergence
10982
10983 !   horizontal_order_test : IF( horz_order == 6 ) THEN
10984
10985 !   ELSE IF( horz_order == 5 ) THEN
10986
10987 !  5th order horizontal flux calculation
10988 !  This code is EXACTLY the same as the 6th order code
10989 !  EXCEPT the 5th order and 3rd operators are used in
10990 !  place of the 6th and 4th order operators
10991
10992 !  determine boundary mods for flux operators
10993 !  We degrade the flux operators from 3rd/4th order
10994 !   to second order one gridpoint in from the boundaries for
10995 !   all boundary conditions except periodic and symmetry - these
10996 !   conditions have boundary zone data fill for correct application
10997 !   of the higher order flux stencils
10998
10999    degrade_xs = .true.
11000    degrade_xe = .true.
11001    degrade_ys = .true.
11002    degrade_ye = .true.
11003
11004    IF( config_flags%periodic_x   .or. &
11005        config_flags%symmetric_xs .or. &
11006        (its > ids+3)                ) degrade_xs = .false.
11007    IF( config_flags%periodic_x   .or. &
11008        config_flags%symmetric_xe .or. &
11009        (ite < ide-2)                ) degrade_xe = .false.
11010    IF( config_flags%periodic_y   .or. &
11011        config_flags%symmetric_ys .or. &
11012        (jts > jds+3)                ) degrade_ys = .false.
11013    IF( config_flags%periodic_y   .or. &
11014        config_flags%symmetric_ye .or. &
11015        (jte < jde-4)                ) degrade_ye = .false.
11016
11017 !--------------- y - advection first
11018
11019       i_start = its
11020       i_end   = ite
11021       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
11022       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
11023       IF ( config_flags%periodic_x ) i_start = its
11024       IF ( config_flags%periodic_x ) i_end = ite
11025
11026       j_start = jts
11027       j_end   = MIN(jte,jde-1)
11028
11029 !  higher order flux has a 5 or 7 point stencil, so compute
11030 !  bounds so we can switch to second order flux close to the boundary
11031
11032       j_start_f = j_start
11033       j_end_f   = j_end+1
11034
11035       IF(degrade_ys) then
11036         j_start = MAX(jts,jds+1)
11037         j_start_f = jds+3
11038       ENDIF
11039
11040       IF(degrade_ye) then
11041         j_end = MIN(jte,jde-2)
11042         j_end_f = jde-3
11043       ENDIF
11044
11045       IF(config_flags%polar) j_end = MIN(jte,jde-1)
11046
11047 !  compute fluxes, 5th or 6th order
11048
11049      jp1 = 2
11050      jp0 = 1
11051
11052      j_loop_y_flux_5 : DO j = j_start, j_end+1
11053
11054       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN  ! use full stencil
11055
11056         DO k=kts,ktf
11057         DO i = i_start, i_end
11058           vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
11059
11060          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
11061             qip2 = u(i,k,j+1)
11062             qip1 = u(i,k,j  )
11063             qi   = u(i,k,j-1)
11064             qim1 = u(i,k,j-2)
11065             qim2 = u(i,k,j-3)
11066           ELSE
11067             qip2 = u(i,k,j-2)
11068             qip1 = u(i,k,j-1)
11069             qi   = u(i,k,j  )
11070             qim1 = u(i,k,j+1)
11071             qim2 = u(i,k,j+2)
11072          ENDIF
11073
11074          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11075          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11076          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11077
11078          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11079          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11080          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11081
11082          wi0 = gi0 / (eps + beta0)**pw
11083          wi1 = gi1 / (eps + beta1)**pw
11084          wi2 = gi2 / (eps + beta2)**pw
11085
11086          sumwk = wi0 + wi1 + wi2
11087
11088           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11089
11090 !          fqy( i, k, jp1 ) = vel*flux5(               &
11091 !                  u(i,k,j-3), u(i,k,j-2), u(i,k,j-1),       &
11092 !                  u(i,k,j  ), u(i,k,j+1), u(i,k,j+2),  vel )
11093         ENDDO
11094         ENDDO
11095
11096 !  we must be close to some boundary where we need to reduce the order of the stencil
11097
11098       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
11099
11100             DO k=kts,ktf
11101             DO i = i_start, i_end
11102               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))  &
11103                                      *(u(i,k,j)+u(i,k,j-1))
11104             ENDDO
11105             ENDDO
11106
11107      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
11108
11109             DO k=kts,ktf
11110             DO i = i_start, i_end
11111               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
11112               fqy( i, k, jp1 ) = vel*flux3(      &
11113                    u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel )
11114             ENDDO
11115             ENDDO
11116
11117      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
11118
11119             DO k=kts,ktf
11120             DO i = i_start, i_end
11121               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
11122                      *(u(i,k,j)+u(i,k,j-1))
11123             ENDDO
11124             ENDDO
11125
11126      ELSE IF ( j == jde-2 ) THEN  ! 3rd order flux 2 in from north boundary
11127
11128             DO k=kts,ktf
11129             DO i = i_start, i_end
11130               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
11131               fqy( i, k, jp1 ) = vel*flux3(     &
11132                    u(i,k,j-2),u(i,k,j-1),    &
11133                    u(i,k,j),u(i,k,j+1),vel )
11134             ENDDO
11135             ENDDO
11136
11137       END IF
11138
11139 !  y flux-divergence into tendency
11140
11141         ! (j > j_start) will miss the u(,,jds) tendency
11142         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
11143           DO k=kts,ktf
11144           DO i = i_start, i_end
11145             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
11146             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
11147           END DO
11148           END DO
11149         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
11150         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
11151           DO k=kts,ktf
11152           DO i = i_start, i_end
11153             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
11154             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
11155           END DO
11156           END DO
11157         ELSE  ! normal code
11158
11159         IF(j > j_start) THEN
11160
11161           DO k=kts,ktf
11162           DO i = i_start, i_end
11163             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
11164             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
11165           ENDDO
11166           ENDDO
11167
11168         ENDIF
11169
11170         END IF
11171
11172
11173         jtmp = jp1
11174         jp1 = jp0
11175         jp0 = jtmp
11176
11177    ENDDO j_loop_y_flux_5
11178
11179 !  next, x - flux divergence
11180
11181       i_start = its
11182       i_end   = ite
11183
11184       j_start = jts
11185       j_end   = MIN(jte,jde-1)
11186
11187 !  higher order flux has a 5 or 7 point stencil, so compute
11188 !  bounds so we can switch to second order flux close to the boundary
11189
11190       i_start_f = i_start
11191       i_end_f   = i_end+1
11192
11193       IF(degrade_xs) then
11194         i_start = MAX(ids+1,its)
11195         i_start_f = ids+3
11196       ENDIF
11197
11198       IF(degrade_xe) then
11199         i_end = MIN(ide-1,ite)
11200         i_end_f = ide-2
11201       ENDIF
11202
11203 !  compute fluxes
11204
11205       DO j = j_start, j_end
11206
11207 !  5th or 6th order flux
11208
11209         DO k=kts,ktf
11210         DO i = i_start_f, i_end_f
11211           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
11212
11213          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
11214             qip2 = u(i+1,k,j)
11215             qip1 = u(i,  k,j)
11216             qi   = u(i-1,k,j)
11217             qim1 = u(i-2,k,j)
11218             qim2 = u(i-3,k,j)
11219           ELSE
11220             qip2 = u(i-2,k,j)
11221             qip1 = u(i-1,k,j)
11222             qi   = u(i,  k,j)
11223             qim1 = u(i+1,k,j)
11224             qim2 = u(i+2,k,j)
11225          ENDIF
11226
11227          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11228          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11229          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11230
11231          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11232          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11233          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11234
11235          wi0 = gi0 / (eps + beta0)**pw
11236          wi1 = gi1 / (eps + beta1)**pw
11237          wi2 = gi2 / (eps + beta2)**pw
11238
11239          sumwk = wi0 + wi1 + wi2
11240
11241          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11242
11243 !          fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j),  &
11244 !                                         u(i-1,k,j), u(i  ,k,j),  &
11245 !                                         u(i+1,k,j), u(i+2,k,j),  &
11246 !                                         vel                     )
11247         ENDDO
11248         ENDDO
11249
11250 !  lower order fluxes close to boundaries (if not periodic or symmetric)
11251 !  specified uses upstream normal wind at boundaries
11252
11253         IF( degrade_xs ) THEN
11254
11255           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
11256             i = ids+1
11257             DO k=kts,ktf
11258               ub = u(i-1,k,j)
11259               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
11260               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
11261                      *(u(i,k,j)+ub)
11262             ENDDO
11263           END IF
11264
11265           i = ids+2
11266           DO k=kts,ktf
11267             vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
11268             fqx( i, k  ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
11269                                            u(i  ,k,j), u(i+1,k,j),  &
11270                                            vel                     )
11271           ENDDO
11272
11273         ENDIF
11274
11275         IF( degrade_xe ) THEN
11276
11277           IF( i_end == ide-1 ) THEN ! second order flux next to the boundary
11278             i = ide
11279             DO k=kts,ktf
11280               ub = u(i,k,j)
11281               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
11282               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
11283                      *(u(i-1,k,j)+ub)
11284             ENDDO
11285           ENDIF
11286
11287           DO k=kts,ktf
11288           i = ide-1
11289           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
11290           fqx( i,k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
11291                                          u(i  ,k,j), u(i+1,k,j),  &
11292                                          vel                     )
11293           ENDDO
11294
11295         ENDIF
11296
11297 !  x flux-divergence into tendency
11298
11299         DO k=kts,ktf
11300           DO i = i_start, i_end
11301             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
11302             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
11303           ENDDO
11304         ENDDO
11305
11306       ENDDO
11307
11308
11309 !  radiative lateral boundary condition in x for normal velocity (u)
11310
11311       IF ( (config_flags%open_xs) .and. its == ids ) THEN
11312
11313         j_start = jts
11314         j_end   = MIN(jte,jde-1)
11315
11316         DO j = j_start, j_end
11317         DO k = kts, ktf
11318           ub = MIN(ru(its,k,j)-cb*(c1(k)*mut(its,j)+c2(k)), 0.)
11319           tendency(its,k,j) = tendency(its,k,j)                    &
11320                       - rdx*ub*(u_old(its+1,k,j) - u_old(its,k,j))
11321         ENDDO
11322         ENDDO
11323
11324       ENDIF
11325
11326       IF ( (config_flags%open_xe) .and. ite == ide ) THEN
11327
11328         j_start = jts
11329         j_end   = MIN(jte,jde-1)
11330
11331         DO j = j_start, j_end
11332         DO k = kts, ktf
11333           ub = MAX(ru(ite,k,j)+cb*(c1(k)*mut(ite-1,j)+c2(k)), 0.)
11334           tendency(ite,k,j) = tendency(ite,k,j)                    &
11335                       - rdx*ub*(u_old(ite,k,j) - u_old(ite-1,k,j))
11336         ENDDO
11337         ENDDO
11338
11339       ENDIF
11340
11341 !  pick up the rest of the horizontal radiation boundary conditions.
11342 !  (these are the computations that don't require 'cb')
11343 !  first, set to index ranges
11344
11345       i_start = its
11346       i_end   = MIN(ite,ide)
11347       imin    = ids
11348       imax    = ide-1
11349
11350       IF (config_flags%open_xs) THEN
11351         i_start = MAX(ids+1, its)
11352         imin = ids
11353       ENDIF
11354       IF (config_flags%open_xe) THEN
11355         i_end = MIN(ite,ide-1)
11356         imax = ide-1
11357       ENDIF
11358
11359    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
11360
11361       DO i = i_start, i_end
11362
11363          mrdy=msfux(i,jts)*rdy       ! ADT eqn 44, 2nd term on RHS
11364          ip = MIN( imax, i   )
11365          im = MAX( imin, i-1 )
11366
11367          DO k=kts,ktf
11368
11369           vw = 0.5*(rv(ip,k,jts)+rv(im,k,jts))
11370           vb = MIN( vw, 0. )
11371           dvm =  rv(ip,k,jts+1)-rv(ip,k,jts)
11372           dvp =  rv(im,k,jts+1)-rv(im,k,jts)
11373           tendency(i,k,jts)=tendency(i,k,jts)-mrdy*(                &
11374                             vb*(u_old(i,k,jts+1)-u_old(i,k,jts))    &
11375                            +0.5*u(i,k,jts)*(dvm+dvp))
11376          ENDDO
11377       ENDDO
11378
11379    ENDIF
11380
11381    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
11382
11383       DO i = i_start, i_end
11384
11385          mrdy=msfux(i,jte-1)*rdy     ! ADT eqn 44, 2nd term on RHS
11386          ip = MIN( imax, i   )
11387          im = MAX( imin, i-1 )
11388
11389          DO k=kts,ktf
11390
11391           vw = 0.5*(rv(ip,k,jte)+rv(im,k,jte))
11392           vb = MAX( vw, 0. )
11393           dvm =  rv(ip,k,jte)-rv(ip,k,jte-1)
11394           dvp =  rv(im,k,jte)-rv(im,k,jte-1)
11395           tendency(i,k,jte-1)=tendency(i,k,jte-1)-mrdy*(              &
11396                               vb*(u_old(i,k,jte-1)-u_old(i,k,jte-2))  &
11397                              +0.5*u(i,k,jte-1)*(dvm+dvp))
11398          ENDDO
11399       ENDDO
11400
11401    ENDIF
11402
11403 !-------------------- vertical advection
11404 !  ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
11405 !  Here we have:  - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
11406 !  Since 'my' (map scale factor in y-direction) isn't a function of z,
11407 !  this is what we need, so leave unchanged in advect_u
11408
11409    i_start = its
11410    i_end   = ite
11411    j_start = jts
11412    j_end   = min(jte,jde-1)
11413
11414 !   IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
11415 !   IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
11416
11417    IF ( config_flags%open_ys .or. specified ) i_start = MAX(ids+1,its)
11418    IF ( config_flags%open_ye .or. specified ) i_end   = MIN(ide-1,ite)
11419    IF ( config_flags%periodic_x ) i_start = its
11420    IF ( config_flags%periodic_x ) i_end = ite
11421
11422    DO i = i_start, i_end
11423      vflux(i,kts)=0.
11424      vflux(i,kte)=0.
11425    ENDDO
11426
11427 !   vert_order_test : IF (vert_order == 6) THEN
11428
11429 !    ELSE IF (vert_order == 5) THEN
11430
11431       DO j = j_start, j_end
11432
11433          DO k=kts+3,ktf-2
11434          DO i = i_start, i_end
11435            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
11436
11437          IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN
11438             qip2 = u(i,k+1,j)
11439             qip1 = u(i,k  ,j)
11440             qi   = u(i,k-1,j)
11441             qim1 = u(i,k-2,j)
11442             qim2 = u(i,k-3,j)
11443           ELSE
11444             qip2 = u(i,k-2,j)
11445             qip1 = u(i,k-1,j)
11446             qi   = u(i,k  ,j)
11447             qim1 = u(i,k+1,j)
11448             qim2 = u(i,k+2,j)
11449          ENDIF
11450
11451          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11452          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11453          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11454
11455          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11456          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11457          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11458
11459          wi0 = gi0 / (eps + beta0)**pw
11460          wi1 = gi1 / (eps + beta1)**pw
11461          wi2 = gi2 / (eps + beta2)**pw
11462
11463          sumwk = wi0 + wi1 + wi2
11464
11465           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11466
11467 !           vflux(i,k) = vel*flux5(                     &
11468 !                   u(i,k-3,j), u(i,k-2,j), u(i,k-1,j),       &
11469 !                   u(i,k  ,j), u(i,k+1,j), u(i,k+2,j),  -vel )
11470          ENDDO
11471          ENDDO
11472
11473          DO i = i_start, i_end
11474
11475            k=kts+1
11476            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
11477                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
11478            k = kts+2
11479            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
11480            vflux(i,k) = vel*flux3(       &
11481                    u(i,k-2,j), u(i,k-1,j),   &
11482                    u(i,k  ,j), u(i,k+1,j), -vel )
11483            k = ktf-1
11484            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
11485            vflux(i,k) = vel*flux3(       &
11486                    u(i,k-2,j), u(i,k-1,j),   &
11487                    u(i,k  ,j), u(i,k+1,j), -vel )
11488            k=ktf
11489            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
11490                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
11491
11492          ENDDO
11493          DO k=kts,ktf
11494          DO i = i_start, i_end
11495             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
11496          ENDDO
11497          ENDDO
11498       ENDDO
11499
11500
11501 END SUBROUTINE advect_weno_u
11502
11503 !-------------------------------------------------------------------------------
11504
11505 SUBROUTINE advect_weno_v   ( v, v_old, tendency,            &
11506                         ru, rv, rom,                   &
11507                         c1, c2,                        &
11508                         mut, time_step, config_flags,  &
11509                         msfux, msfuy, msfvx, msfvy,    &
11510                         msftx, msfty,                  &
11511                         fzm, fzp,                      &
11512                         rdx, rdy, rdzw,                &
11513                         ids, ide, jds, jde, kds, kde,  &
11514                         ims, ime, jms, jme, kms, kme,  &
11515                         its, ite, jts, jte, kts, kte  )
11516
11517 !
11518 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
11519 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
11520 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
11521 !
11522
11523    IMPLICIT NONE
11524
11525    ! Input data
11526
11527    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
11528
11529    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
11530                                               ims, ime, jms, jme, kms, kme, &
11531                                               its, ite, jts, jte, kts, kte
11532
11533    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: v,     &
11534                                                                       v_old, &
11535                                                                       ru,    &
11536                                                                       rv,    &
11537                                                                       rom
11538
11539    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
11540    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
11541
11542    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
11543                                                                     msfuy,  &
11544                                                                     msfvx,  &
11545                                                                     msfvy,  &
11546                                                                     msftx,  &
11547                                                                     msfty
11548
11549    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
11550                                                                   fzp,  &
11551                                                                   rdzw, &
11552                                                                   c1,   &
11553                                                                   c2
11554
11555    REAL ,                                        INTENT(IN   ) :: rdx,  &
11556                                                                   rdy
11557    INTEGER ,                                     INTENT(IN   ) :: time_step
11558
11559
11560    ! Local data
11561
11562    INTEGER :: i, j, k, itf, jtf, ktf
11563    INTEGER :: i_start, i_end, j_start, j_end
11564    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
11565    INTEGER :: jmin, jmax, jp, jm, imin, imax
11566
11567     real            :: dir, vv
11568     real            :: ue,vs,vn,wb,wt
11569     real, parameter :: f30 =  7./12., f31 = 1./12.
11570     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
11571
11572
11573    integer kt,kb
11574
11575
11576     real               :: qim2, qim1, qi, qip1, qip2
11577     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
11578     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18
11579     integer, parameter :: pw = 2
11580
11581
11582    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
11583    REAL , DIMENSION(its:ite, kts:kte) :: vflux
11584
11585
11586    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
11587    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
11588
11589    INTEGER :: horz_order
11590    INTEGER :: vert_order
11591
11592    LOGICAL :: degrade_xs, degrade_ys
11593    LOGICAL :: degrade_xe, degrade_ye
11594
11595    INTEGER :: jp1, jp0, jtmp
11596
11597
11598 ! definition of flux operators, 3rd, 4th, 5th or 6th order
11599
11600    REAL    :: flux3, flux4, flux5, flux6
11601    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
11602
11603    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
11604           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
11605
11606    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
11607            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
11608            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
11609
11610    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
11611                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)   &
11612                      +(q_ip2+q_im3) )/60.0
11613
11614    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
11615            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
11616             -sign(1,time_step)*sign(1.,ua)*(                    &
11617               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
11618
11619
11620
11621    LOGICAL :: specified
11622
11623    specified = .false.
11624    if(config_flags%specified .or. config_flags%nested) specified = .true.
11625
11626 ! set order for the advection schemes
11627
11628    ktf=MIN(kte,kde-1)
11629    horz_order = config_flags%h_mom_adv_order
11630    vert_order = config_flags%v_mom_adv_order
11631
11632
11633 !  here is the choice of flux operators
11634
11635
11636 !   horizontal_order_test : IF( horz_order == 6 ) THEN
11637 !   ELSE IF( horz_order == 5 ) THEN
11638
11639 !  5th order horizontal flux calculation
11640 !  This code is EXACTLY the same as the 6th order code
11641 !  EXCEPT the 5th order and 3rd operators are used in
11642 !  place of the 6th and 4th order operators
11643
11644 !  determine boundary mods for flux operators
11645 !  We degrade the flux operators from 3rd/4th order
11646 !   to second order one gridpoint in from the boundaries for
11647 !   all boundary conditions except periodic and symmetry - these
11648 !   conditions have boundary zone data fill for correct application
11649 !   of the higher order flux stencils
11650
11651    degrade_xs = .true.
11652    degrade_xe = .true.
11653    degrade_ys = .true.
11654    degrade_ye = .true.
11655
11656    IF( config_flags%periodic_x   .or. &
11657        config_flags%symmetric_xs .or. &
11658        (its > ids+3)                ) degrade_xs = .false.
11659    IF( config_flags%periodic_x   .or. &
11660        config_flags%symmetric_xe .or. &
11661        (ite < ide-3)                ) degrade_xe = .false.
11662    IF( config_flags%periodic_y   .or. &
11663        config_flags%symmetric_ys .or. &
11664        (jts > jds+3)                ) degrade_ys = .false.
11665    IF( config_flags%periodic_y   .or. &
11666        config_flags%symmetric_ye .or. &
11667        (jte < jde-3)                ) degrade_ye = .false.
11668
11669 !--------------- y - advection first
11670
11671       i_start = its
11672       i_end   = MIN(ite,ide-1)
11673       j_start = jts
11674       j_end   = jte
11675
11676 !  higher order flux has a 5 or 7 point stencil, so compute
11677 !  bounds so we can switch to second order flux close to the boundary
11678
11679       j_start_f = j_start
11680       j_end_f   = j_end+1
11681
11682       IF(degrade_ys) then
11683         j_start = MAX(jts,jds+1)
11684         j_start_f = jds+3
11685       ENDIF
11686
11687       IF(degrade_ye) then
11688         j_end = MIN(jte,jde-1)
11689         j_end_f = jde-2
11690       ENDIF
11691
11692 !  compute fluxes, 5th or 6th order
11693
11694      jp1 = 2
11695      jp0 = 1
11696
11697      j_loop_y_flux_5 : DO j = j_start, j_end+1
11698
11699       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
11700
11701         DO k=kts,ktf
11702         DO i = i_start, i_end
11703           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
11704
11705          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
11706             qip2 = v(i,k,j+1)
11707             qip1 = v(i,k,j  )
11708             qi   = v(i,k,j-1)
11709             qim1 = v(i,k,j-2)
11710             qim2 = v(i,k,j-3)
11711           ELSE
11712             qip2 = v(i,k,j-2)
11713             qip1 = v(i,k,j-1)
11714             qi   = v(i,k,j  )
11715             qim1 = v(i,k,j+1)
11716             qim2 = v(i,k,j+2)
11717          ENDIF
11718
11719          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11720          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11721          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11722
11723          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11724          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11725          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11726
11727          wi0 = gi0 / (eps + beta0)**pw
11728          wi1 = gi1 / (eps + beta1)**pw
11729          wi2 = gi2 / (eps + beta2)**pw
11730
11731          sumwk = wi0 + wi1 + wi2
11732
11733           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11734
11735
11736
11737 !          fqy( i, k, jp1 ) = vel*flux5(               &
11738 !                  v(i,k,j-3), v(i,k,j-2), v(i,k,j-1),       &
11739 !                  v(i,k,j  ), v(i,k,j+1), v(i,k,j+2),  vel )
11740         ENDDO
11741         ENDDO
11742
11743 !  we must be close to some boundary where we need to reduce the order of the stencil
11744 !  specified uses upstream normal wind at boundaries
11745
11746       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
11747
11748             DO k=kts,ktf
11749             DO i = i_start, i_end
11750                 vb = v(i,k,j-1)
11751                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
11752                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
11753                                  *(v(i,k,j)+vb)
11754             ENDDO
11755             ENDDO
11756
11757      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
11758
11759             DO k=kts,ktf
11760             DO i = i_start, i_end
11761               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
11762               fqy( i, k, jp1 ) = vel*flux3(      &
11763                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
11764             ENDDO
11765             ENDDO
11766
11767
11768      ELSE IF ( j == jde ) THEN  ! 2nd order flux next to north boundary
11769
11770             DO k=kts,ktf
11771             DO i = i_start, i_end
11772                 vb = v(i,k,j)
11773                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
11774                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
11775                                  *(vb+v(i,k,j-1))
11776             ENDDO
11777             ENDDO
11778
11779      ELSE IF ( j == jde-1 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
11780
11781             DO k=kts,ktf
11782             DO i = i_start, i_end
11783               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
11784               fqy( i, k, jp1 ) = vel*flux3(     &
11785                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
11786             ENDDO
11787             ENDDO
11788
11789       END IF
11790
11791 !  y flux-divergence into tendency
11792
11793         ! Comments on polar boundary conditions
11794         ! No advection over the poles means tendencies (held from jds [S. pole]
11795         ! to jde [N pole], i.e., on v grid) must be zero at poles
11796         ! [tendency(jds) and tendency(jde)=0]
11797         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
11798           DO k=kts,ktf
11799           DO i = i_start, i_end
11800             tendency(i,k,j-1) = 0.
11801           END DO
11802           END DO
11803         ! If j_end were set to jde in a special if statement apart from
11804         ! degrade_ye, then we would hit the next conditional.  But since
11805         ! we want the tendency to be zero anyway, not looping to jde+1
11806         ! will produce the same effect.
11807         ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
11808           DO k=kts,ktf
11809           DO i = i_start, i_end
11810             tendency(i,k,j-1) = 0.
11811           END DO
11812           END DO
11813         ELSE  ! Normal code
11814
11815         IF(j > j_start) THEN
11816
11817           DO k=kts,ktf
11818           DO i = i_start, i_end
11819             mrdy=msfvy(i,j-1)*rdy    ! ADT eqn 45, 2nd term on RHS
11820             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
11821           ENDDO
11822           ENDDO
11823
11824         ENDIF
11825
11826         END IF
11827
11828         jtmp = jp1
11829         jp1 = jp0
11830         jp0 = jtmp
11831
11832    ENDDO j_loop_y_flux_5
11833
11834 !  next, x - flux divergence
11835
11836       i_start = its
11837       i_end   = MIN(ite,ide-1)
11838
11839       j_start = jts
11840       j_end   = jte
11841       ! Polar boundary conditions are like open or specified
11842       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
11843       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
11844
11845 !  higher order flux has a 5 or 7 point stencil, so compute
11846 !  bounds so we can switch to second order flux close to the boundary
11847
11848       i_start_f = i_start
11849       i_end_f   = i_end+1
11850
11851       IF(degrade_xs) then
11852         i_start = MAX(ids+1,its)
11853 !        i_start_f = i_start+2
11854         i_start_f = MIN(i_start+2,ids+3)
11855       ENDIF
11856
11857       IF(degrade_xe) then
11858         i_end = MIN(ide-2,ite)
11859         i_end_f = ide-3
11860       ENDIF
11861
11862 !  compute fluxes
11863
11864       DO j = j_start, j_end
11865
11866 !  5th or 6th order flux
11867
11868         DO k=kts,ktf
11869         DO i = i_start_f, i_end_f
11870           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
11871
11872          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
11873             qip2 = v(i+1,k,j)
11874             qip1 = v(i,  k,j)
11875             qi   = v(i-1,k,j)
11876             qim1 = v(i-2,k,j)
11877             qim2 = v(i-3,k,j)
11878           ELSE
11879             qip2 = v(i-2,k,j)
11880             qip1 = v(i-1,k,j)
11881             qi   = v(i,  k,j)
11882             qim1 = v(i+1,k,j)
11883             qim2 = v(i+2,k,j)
11884          ENDIF
11885
11886          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11887          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11888          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11889
11890          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11891          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11892          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11893
11894          wi0 = gi0 / (eps + beta0)**pw
11895          wi1 = gi1 / (eps + beta1)**pw
11896          wi2 = gi2 / (eps + beta2)**pw
11897
11898          sumwk = wi0 + wi1 + wi2
11899
11900          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11901
11902 !          fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j),  &
11903 !                                         v(i-1,k,j), v(i  ,k,j),  &
11904 !                                         v(i+1,k,j), v(i+2,k,j),  &
11905 !                                         vel                     )
11906         ENDDO
11907         ENDDO
11908
11909 !  lower order fluxes close to boundaries (if not periodic or symmetric)
11910
11911         IF( degrade_xs ) THEN
11912
11913           DO i=i_start,i_start_f-1
11914
11915             IF(i == ids+1) THEN ! second order
11916               DO k=kts,ktf
11917                 fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) &
11918                                 *(v(i,k,j)+v(i-1,k,j))
11919               ENDDO
11920             ENDIF
11921
11922             IF(i == ids+2) THEN  ! third order
11923               DO k=kts,ktf
11924                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
11925                 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
11926                                         v(i  ,k,j), v(i+1,k,j),  &
11927                                         vel                     )
11928               ENDDO
11929             ENDIF
11930
11931           ENDDO
11932
11933         ENDIF
11934
11935         IF( degrade_xe ) THEN
11936
11937           DO i = i_end_f+1, i_end+1
11938
11939             IF( i == ide-1 ) THEN ! second order flux next to the boundary
11940               DO k=kts,ktf
11941                 fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
11942                                 *(v(i_end+1,k,j)+v(i_end,k,j))
11943               ENDDO
11944             ENDIF
11945
11946             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
11947               DO k=kts,ktf
11948                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
11949                 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
11950                                         v(i  ,k,j), v(i+1,k,j),  &
11951                                         vel                     )
11952               ENDDO
11953             ENDIF
11954
11955           ENDDO
11956
11957         ENDIF
11958
11959 !  x flux-divergence into tendency
11960
11961         DO k=kts,ktf
11962           DO i = i_start, i_end
11963             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
11964             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
11965           ENDDO
11966         ENDDO
11967
11968       ENDDO
11969
11970
11971    !  Comments on polar boundary condition
11972    !  Force tendency=0 at NP and SP
11973    !  We keep setting this everywhere, but it can't hurt...
11974    IF ( config_flags%polar .AND. (jts == jds) ) THEN
11975       DO i=its,ite
11976       DO k=kts,ktf
11977          tendency(i,k,jts)=0.
11978       END DO
11979       END DO
11980    END IF
11981    IF ( config_flags%polar .AND. (jte == jde) ) THEN
11982       DO i=its,ite
11983       DO k=kts,ktf
11984          tendency(i,k,jte)=0.
11985       END DO
11986       END DO
11987    END IF
11988
11989 !  radiative lateral boundary condition in y for normal velocity (v)
11990
11991       IF ( (config_flags%open_ys) .and. jts == jds ) THEN
11992
11993         i_start = its
11994         i_end   = MIN(ite,ide-1)
11995
11996         DO i = i_start, i_end
11997         DO k = kts, ktf
11998           vb = MIN(rv(i,k,jts)-cb*(c1(k)*mut(i,jts)+c2(k)), 0.)
11999           tendency(i,k,jts) = tendency(i,k,jts)                    &
12000                       - rdy*vb*(v_old(i,k,jts+1) - v_old(i,k,jts))
12001         ENDDO
12002         ENDDO
12003
12004       ENDIF
12005
12006       IF ( (config_flags%open_ye) .and. jte == jde ) THEN
12007
12008         i_start = its
12009         i_end   = MIN(ite,ide-1)
12010
12011         DO i = i_start, i_end
12012         DO k = kts, ktf
12013           vb = MAX(rv(i,k,jte)+cb*(c1(k)*mut(i,jte-1)+c2(k)), 0.)
12014           tendency(i,k,jte) = tendency(i,k,jte)                    &
12015                       - rdy*vb*(v_old(i,k,jte) - v_old(i,k,jte-1))
12016         ENDDO
12017         ENDDO
12018
12019       ENDIF
12020
12021 !  pick up the rest of the horizontal radiation boundary conditions.
12022 !  (these are the computations that don't require 'cb'.
12023 !  first, set to index ranges
12024
12025       j_start = jts
12026       j_end   = MIN(jte,jde)
12027
12028       jmin    = jds
12029       jmax    = jde-1
12030
12031       IF (config_flags%open_ys) THEN
12032           j_start = MAX(jds+1, jts)
12033           jmin = jds
12034       ENDIF
12035       IF (config_flags%open_ye) THEN
12036           j_end = MIN(jte,jde-1)
12037           jmax = jde-1
12038       ENDIF
12039
12040 !  compute x (u) conditions for v, w, or scalar
12041
12042    IF( (config_flags%open_xs) .and. (its == ids)) THEN
12043
12044       DO j = j_start, j_end
12045
12046          mrdx=msfvy(its,j)*rdx       ! ADT eqn 45, 1st term on RHS
12047          jp = MIN( jmax, j   )
12048          jm = MAX( jmin, j-1 )
12049
12050          DO k=kts,ktf
12051
12052           uw = 0.5*(ru(its,k,jp)+ru(its,k,jm))
12053           ub = MIN( uw, 0. )
12054           dup =  ru(its+1,k,jp)-ru(its,k,jp)
12055           dum =  ru(its+1,k,jm)-ru(its,k,jm)
12056           tendency(its,k,j)=tendency(its,k,j)-mrdx*(               &
12057                             ub*(v_old(its+1,k,j)-v_old(its,k,j))   &
12058                            +0.5*v(its,k,j)*(dup+dum))
12059          ENDDO
12060       ENDDO
12061
12062    ENDIF
12063
12064    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
12065       DO j = j_start, j_end
12066
12067          mrdx=msfvy(ite-1,j)*rdx     ! ADT eqn 45, 1st term on RHS
12068          jp = MIN( jmax, j   )
12069          jm = MAX( jmin, j-1 )
12070
12071          DO k=kts,ktf
12072
12073           uw = 0.5*(ru(ite,k,jp)+ru(ite,k,jm))
12074           ub = MAX( uw, 0. )
12075           dup = ru(ite,k,jp)-ru(ite-1,k,jp)
12076           dum = ru(ite,k,jm)-ru(ite-1,k,jm)
12077
12078 !          tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
12079 !                            ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
12080 !                           +0.5*v(ite-1,k,j)*                         &
12081 !                                  ( ru(ite,k,jp)-ru(ite-1,k,jp)       &
12082 !                                   +ru(ite,k,jm)-ru(ite-1,k,jm))     )
12083           tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
12084                             ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
12085                            +0.5*v(ite-1,k,j)*(dup+dum))
12086
12087          ENDDO
12088       ENDDO
12089
12090    ENDIF
12091
12092 !-------------------- vertical advection
12093 !     ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
12094 !     Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
12095 !     We therefore need to make a correction for advect_v
12096 !     since 'my' (map scale factor in y direction) isn't a function of z,
12097 !     we can do this using *(my/mx) (see eqn. 45 for example)
12098
12099
12100     i_start = its
12101     i_end   = MIN(ite,ide-1)
12102     j_start = jts
12103     j_end   = jte
12104
12105     DO i = i_start, i_end
12106        vflux(i,kts)=0.
12107        vflux(i,kte)=0.
12108     ENDDO
12109
12110     ! Polar boundary conditions are like open or specified
12111     ! We don't want to calculate vertical v tendencies at the N or S pole
12112     IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
12113     IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
12114
12115 !    vert_order_test : IF (vert_order == 6) THEN
12116
12117 !   ELSE IF (vert_order == 5) THEN
12118
12119       DO j = j_start, j_end
12120
12121
12122          DO k=kts+3,ktf-2
12123          DO i = i_start, i_end
12124            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
12125
12126          IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN
12127             qip2 = v(i,k+1,j)
12128             qip1 = v(i,k  ,j)
12129             qi   = v(i,k-1,j)
12130             qim1 = v(i,k-2,j)
12131             qim2 = v(i,k-3,j)
12132           ELSE
12133             qip2 = v(i,k-2,j)
12134             qip1 = v(i,k-1,j)
12135             qi   = v(i,k  ,j)
12136             qim1 = v(i,k+1,j)
12137             qim2 = v(i,k+2,j)
12138          ENDIF
12139
12140          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12141          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12142          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12143
12144          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12145          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12146          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12147
12148          wi0 = gi0 / (eps + beta0)**pw
12149          wi1 = gi1 / (eps + beta1)**pw
12150          wi2 = gi2 / (eps + beta2)**pw
12151
12152          sumwk = wi0 + wi1 + wi2
12153
12154           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12155
12156
12157 !           vflux(i,k) = vel*flux5(                       &
12158 !                   v(i,k-3,j), v(i,k-2,j), v(i,k-1,j),       &
12159 !                   v(i,k  ,j), v(i,k+1,j), v(i,k+2,j),  -vel )
12160          ENDDO
12161          ENDDO
12162
12163          DO i = i_start, i_end
12164            k=kts+1
12165            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
12166                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
12167            k = kts+2
12168            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
12169            vflux(i,k) = vel*flux3(       &
12170                    v(i,k-2,j), v(i,k-1,j),   &
12171                    v(i,k  ,j), v(i,k+1,j), -vel )
12172            k = ktf-1
12173            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
12174            vflux(i,k) = vel*flux3(       &
12175                    v(i,k-2,j), v(i,k-1,j),   &
12176                    v(i,k  ,j), v(i,k+1,j), -vel )
12177            k=ktf
12178            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
12179                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
12180
12181          ENDDO
12182
12183
12184          DO k=kts,ktf
12185          DO i = i_start, i_end
12186             ! We are calculating vertical fluxes on v points,
12187             ! so we must mean msf_v_x/y variables
12188             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
12189          ENDDO
12190          ENDDO
12191
12192       ENDDO
12193
12194
12195 END SUBROUTINE advect_weno_v
12196
12197
12198 !---------------------------------------------------------------------------------
12199
12200 SUBROUTINE advect_weno_w    ( w, w_old, tendency,            &
12201                          ru, rv, rom,                   &
12202                          c1, c2,                        &
12203                          mut, time_step, config_flags,  &
12204                          msfux, msfuy, msfvx, msfvy,    &
12205                          msftx, msfty,                  &
12206                          fzm, fzp,                      &
12207                          rdx, rdy, rdzu,                &
12208                          ids, ide, jds, jde, kds, kde,  &
12209                          ims, ime, jms, jme, kms, kme,  &
12210                          its, ite, jts, jte, kts, kte  )
12211
12212 !
12213 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
12214 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
12215 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
12216 !
12217
12218    IMPLICIT NONE
12219
12220    ! Input data
12221
12222    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
12223
12224    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
12225                                               ims, ime, jms, jme, kms, kme, &
12226                                               its, ite, jts, jte, kts, kte
12227
12228    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: w,     &
12229                                                                       w_old, &
12230                                                                       ru,    &
12231                                                                       rv,    &
12232                                                                       rom
12233
12234    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
12235    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
12236
12237    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
12238                                                                     msfuy,  &
12239                                                                     msfvx,  &
12240                                                                     msfvy,  &
12241                                                                     msftx,  &
12242                                                                     msfty
12243
12244    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
12245                                                                   fzp,  &
12246                                                                   rdzu, &
12247                                                                   c1,   &
12248                                                                   c2
12249
12250    REAL ,                                        INTENT(IN   ) :: rdx,  &
12251                                                                   rdy
12252    INTEGER ,                                     INTENT(IN   ) :: time_step
12253
12254
12255    ! Local data
12256
12257    INTEGER :: i, j, k, itf, jtf, ktf
12258    INTEGER :: i_start, i_end, j_start, j_end
12259    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
12260    INTEGER :: jmin, jmax, jp, jm, imin, imax
12261
12262    REAL    :: mrdx, mrdy, ub, vb, uw, vw
12263    REAL , DIMENSION(its:ite, kts:kte) :: vflux
12264
12265     real            :: dir, vv
12266     real            :: ue,vs,vn,wb,wt
12267     real, parameter :: f30 =  7./12., f31 = 1./12.
12268     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
12269
12270
12271    integer kt,kb
12272
12273
12274     real               :: qim2, qim1, qi, qip1, qip2
12275     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
12276     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18
12277     integer, parameter :: pw = 2
12278
12279
12280
12281    INTEGER :: horz_order, vert_order
12282
12283    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
12284    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
12285
12286    LOGICAL :: degrade_xs, degrade_ys
12287    LOGICAL :: degrade_xe, degrade_ye
12288
12289    INTEGER :: jp1, jp0, jtmp
12290
12291 ! definition of flux operators, 3rd, 4th, 5th or 6th order
12292
12293    REAL    :: flux3, flux4, flux5, flux6
12294    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
12295
12296       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
12297           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
12298
12299       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
12300            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
12301            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
12302
12303       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
12304                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)      &
12305                      +(q_ip2+q_im3) )/60.0
12306
12307       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
12308            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
12309             -sign(1,time_step)*sign(1.,ua)*(                    &
12310               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
12311
12312
12313    LOGICAL :: specified
12314
12315    specified = .false.
12316    if(config_flags%specified .or. config_flags%nested) specified = .true.
12317
12318 !  set order for the advection scheme
12319
12320   ktf=MIN(kte,kde-1)
12321   horz_order = config_flags%h_sca_adv_order
12322   vert_order = config_flags%v_sca_adv_order
12323
12324 !  here is the choice of flux operators
12325
12326 !  begin with horizontal flux divergence
12327
12328 !  horizontal_order_test : IF( horz_order == 6 ) THEN
12329 ! ELSE IF (horz_order == 5 ) THEN
12330
12331 !  determine boundary mods for flux operators
12332 !  We degrade the flux operators from 3rd/4th order
12333 !   to second order one gridpoint in from the boundaries for
12334 !   all boundary conditions except periodic and symmetry - these
12335 !   conditions have boundary zone data fill for correct application
12336 !   of the higher order flux stencils
12337
12338    degrade_xs = .true.
12339    degrade_xe = .true.
12340    degrade_ys = .true.
12341    degrade_ye = .true.
12342
12343    IF( config_flags%periodic_x   .or. &
12344        config_flags%symmetric_xs .or. &
12345        (its > ids+3)                ) degrade_xs = .false.
12346    IF( config_flags%periodic_x   .or. &
12347        config_flags%symmetric_xe .or. &
12348        (ite < ide-3)                ) degrade_xe = .false.
12349    IF( config_flags%periodic_y   .or. &
12350        config_flags%symmetric_ys .or. &
12351        (jts > jds+3)                ) degrade_ys = .false.
12352    IF( config_flags%periodic_y   .or. &
12353        config_flags%symmetric_ye .or. &
12354        (jte < jde-4)                ) degrade_ye = .false.
12355
12356 !--------------- y - advection first
12357
12358       i_start = its
12359       i_end   = MIN(ite,ide-1)
12360       j_start = jts
12361       j_end   = MIN(jte,jde-1)
12362
12363 !  higher order flux has a 5 or 7 point stencil, so compute
12364 !  bounds so we can switch to second order flux close to the boundary
12365
12366       j_start_f = j_start
12367       j_end_f   = j_end+1
12368
12369       IF(degrade_ys) then
12370         j_start = MAX(jts,jds+1)
12371         j_start_f = jds+3
12372       ENDIF
12373
12374       IF(degrade_ye) then
12375         j_end = MIN(jte,jde-2)
12376         j_end_f = jde-3
12377       ENDIF
12378
12379       IF(config_flags%polar) j_end = MIN(jte,jde-1)
12380
12381 !  compute fluxes, 5th or 6th order
12382
12383      jp1 = 2
12384      jp0 = 1
12385
12386      j_loop_y_flux_5 : DO j = j_start, j_end+1
12387
12388       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
12389
12390         DO k=kts+1,ktf
12391         DO i = i_start, i_end
12392           vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
12393
12394          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
12395             qip2 = w(i,k,j+1)
12396             qip1 = w(i,k,j  )
12397             qi   = w(i,k,j-1)
12398             qim1 = w(i,k,j-2)
12399             qim2 = w(i,k,j-3)
12400           ELSE
12401             qip2 = w(i,k,j-2)
12402             qip1 = w(i,k,j-1)
12403             qi   = w(i,k,j  )
12404             qim1 = w(i,k,j+1)
12405             qim2 = w(i,k,j+2)
12406          ENDIF
12407
12408          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12409          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12410          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12411
12412          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12413          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12414          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12415
12416          wi0 = gi0 / (eps + beta0)**pw
12417          wi1 = gi1 / (eps + beta1)**pw
12418          wi2 = gi2 / (eps + beta2)**pw
12419
12420          sumwk = wi0 + wi1 + wi2
12421
12422           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12423
12424 !          fqy( i, k, jp1 ) = vel*flux5(                     &
12425 !                  w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
12426 !                  w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
12427         ENDDO
12428         ENDDO
12429
12430         k = ktf+1
12431         DO i = i_start, i_end
12432           vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
12433
12434          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
12435             qip2 = w(i,k,j+1)
12436             qip1 = w(i,k,j  )
12437             qi   = w(i,k,j-1)
12438             qim1 = w(i,k,j-2)
12439             qim2 = w(i,k,j-3)
12440           ELSE
12441             qip2 = w(i,k,j-2)
12442             qip1 = w(i,k,j-1)
12443             qi   = w(i,k,j  )
12444             qim1 = w(i,k,j+1)
12445             qim2 = w(i,k,j+2)
12446          ENDIF
12447
12448          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12449          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12450          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12451
12452          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12453          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12454          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12455
12456          wi0 = gi0 / (eps + beta0)**pw
12457          wi1 = gi1 / (eps + beta1)**pw
12458          wi2 = gi2 / (eps + beta2)**pw
12459
12460          sumwk = wi0 + wi1 + wi2
12461
12462           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12463
12464 !          fqy( i, k, jp1 ) = vel*flux5(                     &
12465 !                  w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
12466 !                  w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
12467         ENDDO
12468
12469       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
12470
12471             DO k=kts+1,ktf
12472             DO i = i_start, i_end
12473               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*          &
12474                      (w(i,k,j)+w(i,k,j-1))
12475             ENDDO
12476             ENDDO
12477
12478             k = ktf+1
12479             DO i = i_start, i_end
12480               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*          &
12481                      (w(i,k,j)+w(i,k,j-1))
12482             ENDDO
12483
12484      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
12485
12486             DO k=kts+1,ktf
12487             DO i = i_start, i_end
12488               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
12489               fqy( i, k, jp1 ) = vel*flux3(              &
12490                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
12491             ENDDO
12492             ENDDO
12493
12494             k = ktf+1
12495             DO i = i_start, i_end
12496               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
12497               fqy( i, k, jp1 ) = vel*flux3(              &
12498                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
12499             ENDDO
12500
12501      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
12502
12503             DO k=kts+1,ktf
12504             DO i = i_start, i_end
12505               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*      &
12506                      (w(i,k,j)+w(i,k,j-1))
12507             ENDDO
12508             ENDDO
12509
12510             k = ktf+1
12511             DO i = i_start, i_end
12512               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*      &
12513                      (w(i,k,j)+w(i,k,j-1))
12514             ENDDO
12515
12516      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
12517
12518             DO k=kts+1,ktf
12519             DO i = i_start, i_end
12520               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
12521               fqy( i, k, jp1 ) = vel*flux3(             &
12522                    w(i,k,j-2),w(i,k,j-1),    &
12523                    w(i,k,j),w(i,k,j+1),vel )
12524             ENDDO
12525             ENDDO
12526
12527             k = ktf+1
12528             DO i = i_start, i_end
12529               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
12530               fqy( i, k, jp1 ) = vel*flux3(             &
12531                    w(i,k,j-2),w(i,k,j-1),    &
12532                    w(i,k,j),w(i,k,j+1),vel )
12533             ENDDO
12534
12535      ENDIF
12536
12537 !  y flux-divergence into tendency
12538
12539         ! Comments for polar boundary conditions
12540         ! Same process as for advect_u - tendencies run from jds to jde-1
12541         ! (latitudes are as for u grid, longitudes are displaced)
12542         ! Therefore: flow is only from one side for points next to poles
12543         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
12544           DO k=kts,ktf
12545           DO i = i_start, i_end
12546             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
12547             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
12548           END DO
12549           END DO
12550         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
12551           DO k=kts,ktf
12552           DO i = i_start, i_end
12553             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
12554             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
12555           END DO
12556           END DO
12557         ELSE  ! normal code
12558
12559         IF(j > j_start) THEN
12560
12561           DO k=kts+1,ktf+1
12562           DO i = i_start, i_end
12563             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
12564             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
12565           ENDDO
12566           ENDDO
12567
12568        ENDIF
12569
12570         END IF
12571
12572         jtmp = jp1
12573         jp1 = jp0
12574         jp0 = jtmp
12575
12576       ENDDO j_loop_y_flux_5
12577
12578 !  next, x - flux divergence
12579
12580       i_start = its
12581       i_end   = MIN(ite,ide-1)
12582
12583       j_start = jts
12584       j_end   = MIN(jte,jde-1)
12585
12586 !  higher order flux has a 5 or 7 point stencil, so compute
12587 !  bounds so we can switch to second order flux close to the boundary
12588
12589       i_start_f = i_start
12590       i_end_f   = i_end+1
12591
12592       IF(degrade_xs) then
12593         i_start = MAX(ids+1,its)
12594 !        i_start_f = i_start+2
12595         i_start_f = MIN(i_start+2,ids+3)
12596       ENDIF
12597
12598       IF(degrade_xe) then
12599         i_end = MIN(ide-2,ite)
12600         i_end_f = ide-3
12601       ENDIF
12602
12603 !  compute fluxes
12604
12605       DO j = j_start, j_end
12606
12607 !  5th or 6th order flux
12608
12609         DO k=kts+1,ktf
12610         DO i = i_start_f, i_end_f
12611           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
12612
12613          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
12614             qip2 = w(i+1,k,j)
12615             qip1 = w(i,  k,j)
12616             qi   = w(i-1,k,j)
12617             qim1 = w(i-2,k,j)
12618             qim2 = w(i-3,k,j)
12619           ELSE
12620             qip2 = w(i-2,k,j)
12621             qip1 = w(i-1,k,j)
12622             qi   = w(i,  k,j)
12623             qim1 = w(i+1,k,j)
12624             qim2 = w(i+2,k,j)
12625          ENDIF
12626
12627          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12628          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12629          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12630
12631          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12632          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12633          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12634
12635          wi0 = gi0 / (eps + beta0)**pw
12636          wi1 = gi1 / (eps + beta1)**pw
12637          wi2 = gi2 / (eps + beta2)**pw
12638
12639          sumwk = wi0 + wi1 + wi2
12640
12641          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12642
12643 !          fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
12644 !                                  w(i-1,k,j), w(i  ,k,j),  &
12645 !                                  w(i+1,k,j), w(i+2,k,j),  &
12646 !                                  vel                     )
12647         ENDDO
12648         ENDDO
12649
12650         k = ktf+1
12651         DO i = i_start_f, i_end_f
12652           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
12653
12654          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
12655             qip2 = w(i+1,k,j)
12656             qip1 = w(i,  k,j)
12657             qi   = w(i-1,k,j)
12658             qim1 = w(i-2,k,j)
12659             qim2 = w(i-3,k,j)
12660           ELSE
12661             qip2 = w(i-2,k,j)
12662             qip1 = w(i-1,k,j)
12663             qi   = w(i,  k,j)
12664             qim1 = w(i+1,k,j)
12665             qim2 = w(i+2,k,j)
12666          ENDIF
12667
12668          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12669          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12670          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12671
12672          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12673          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12674          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12675
12676          wi0 = gi0 / (eps + beta0)**pw
12677          wi1 = gi1 / (eps + beta1)**pw
12678          wi2 = gi2 / (eps + beta2)**pw
12679
12680          sumwk = wi0 + wi1 + wi2
12681
12682          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12683
12684 !          fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
12685 !                                  w(i-1,k,j), w(i  ,k,j),  &
12686 !                                  w(i+1,k,j), w(i+2,k,j),  &
12687 !                                  vel                     )
12688         ENDDO
12689
12690 !  lower order fluxes close to boundaries (if not periodic or symmetric)
12691
12692         IF( degrade_xs ) THEN
12693
12694           DO i=i_start,i_start_f-1
12695
12696             IF(i == ids+1) THEN ! second order
12697               DO k=kts+1,ktf
12698                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
12699                                 *(w(i,k,j)+w(i-1,k,j))
12700               ENDDO
12701               k = ktf+1
12702               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
12703                      *(w(i,k,j)+w(i-1,k,j))
12704             ENDIF
12705
12706             IF(i == ids+2) THEN  ! third order
12707               DO k=kts+1,ktf
12708                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
12709                 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12710                                         w(i  ,k,j), w(i+1,k,j),  &
12711                                         vel                     )
12712               ENDDO
12713               k = ktf+1
12714               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
12715               fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12716                                       w(i  ,k,j), w(i+1,k,j),  &
12717                                       vel                     )
12718             END IF
12719
12720           ENDDO
12721
12722         ENDIF
12723
12724         IF( degrade_xe ) THEN
12725
12726           DO i = i_end_f+1, i_end+1
12727
12728             IF( i == ide-1 ) THEN ! second order flux next to the boundary
12729               DO k=kts+1,ktf
12730                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
12731                                   *(w(i,k,j)+w(i-1,k,j))
12732               ENDDO
12733               k = ktf+1
12734               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))      &
12735                      *(w(i,k,j)+w(i-1,k,j))
12736             ENDIF
12737
12738             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
12739               DO k=kts+1,ktf
12740                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
12741                 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12742                                         w(i  ,k,j), w(i+1,k,j),  &
12743                                         vel                     )
12744               ENDDO
12745               k = ktf+1
12746               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
12747               fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12748                                       w(i  ,k,j), w(i+1,k,j),  &
12749                                       vel                     )
12750             ENDIF
12751
12752           ENDDO
12753
12754         ENDIF
12755
12756 !  x flux-divergence into tendency
12757
12758         DO k=kts+1,ktf+1
12759           DO i = i_start, i_end
12760             mrdx=msftx(i,j)*rdx      ! see ADT eqn 46 dividing by my, 1st term RHS
12761             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
12762           ENDDO
12763         ENDDO
12764
12765       ENDDO
12766
12767
12768 !  pick up the the horizontal radiation boundary conditions.
12769 !  (these are the computations that don't require 'cb'.
12770 !  first, set to index ranges
12771
12772
12773       i_start = its
12774       i_end   = MIN(ite,ide-1)
12775       j_start = jts
12776       j_end   = MIN(jte,jde-1)
12777
12778    IF( (config_flags%open_xs) .and. (its == ids)) THEN
12779
12780        DO j = j_start, j_end
12781        DO k = kts+1, ktf
12782
12783          uw = 0.5*(fzm(k)*(ru(its,k  ,j)+ru(its+1,k  ,j)) +  &
12784                    fzp(k)*(ru(its,k-1,j)+ru(its+1,k-1,j))   )
12785          ub = MIN( uw, 0. )
12786
12787          tendency(its,k,j) = tendency(its,k,j)                     &
12788                - rdx*(                                             &
12789                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
12790                        w(its,k,j)*(                                &
12791                        fzm(k)*(ru(its+1,k  ,j)-ru(its,k  ,j))+     &
12792                        fzp(k)*(ru(its+1,k-1,j)-ru(its,k-1,j)))     &
12793                                                                   )
12794        ENDDO
12795        ENDDO
12796
12797        k = ktf+1
12798        DO j = j_start, j_end
12799
12800          uw = 0.5*( (2.-fzm(k-1))*(ru(its,k-1,j)+ru(its+1,k-1,j))   &
12801                    -fzp(k-1)*(ru(its,k-2,j)+ru(its+1,k-2,j))   )
12802          ub = MIN( uw, 0. )
12803
12804          tendency(its,k,j) = tendency(its,k,j)                     &
12805                - rdx*(                                             &
12806                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
12807                        w(its,k,j)*(                                &
12808                              (2.-fzm(k-1))*(ru(its+1,k-1,j)-ru(its,k-1,j))-  &
12809                              fzp(k-1)*(ru(its+1,k-2,j)-ru(its,k-2,j)))  &
12810                                                                   )
12811        ENDDO
12812
12813    ENDIF
12814
12815    IF( (config_flags%open_xe) .and. (ite == ide)) THEN
12816
12817        DO j = j_start, j_end
12818        DO k = kts+1, ktf
12819
12820          uw = 0.5*(fzm(k)*(ru(ite-1,k  ,j)+ru(ite,k  ,j)) +  &
12821                    fzp(k)*(ru(ite-1,k-1,j)+ru(ite,k-1,j))   )
12822          ub = MAX( uw, 0. )
12823
12824          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
12825                - rdx*(                                                 &
12826                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
12827                        w(i_end,k,j)*(                                  &
12828                             fzm(k)*(ru(ite,k  ,j)-ru(ite-1,k  ,j)) +   &
12829                             fzp(k)*(ru(ite,k-1,j)-ru(ite-1,k-1,j)))    &
12830                                                                     )
12831        ENDDO
12832        ENDDO
12833
12834        k = ktf+1
12835        DO j = j_start, j_end
12836
12837          uw = 0.5*( (2.-fzm(k-1))*(ru(ite-1,k-1,j)+ru(ite,k-1,j))    &
12838                    -fzp(k-1)*(ru(ite-1,k-2,j)+ru(ite,k-2,j))   )
12839          ub = MAX( uw, 0. )
12840
12841          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
12842                - rdx*(                                                 &
12843                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
12844                        w(i_end,k,j)*(                                  &
12845                                (2.-fzm(k-1))*(ru(ite,k-1,j)-ru(ite-1,k-1,j)) -   &
12846                                fzp(k-1)*(ru(ite,k-2,j)-ru(ite-1,k-2,j)))    &
12847                                                                     )
12848        ENDDO
12849
12850    ENDIF
12851
12852
12853    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
12854
12855        DO i = i_start, i_end
12856        DO k = kts+1, ktf
12857
12858          vw = 0.5*( fzm(k)*(rv(i,k  ,jts)+rv(i,k  ,jts+1)) +  &
12859                     fzp(k)*(rv(i,k-1,jts)+rv(i,k-1,jts+1))   )
12860          vb = MIN( vw, 0. )
12861
12862          tendency(i,k,jts) = tendency(i,k,jts)                     &
12863                - rdy*(                                             &
12864                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
12865                        w(i,k,jts)*(                                &
12866                        fzm(k)*(rv(i,k  ,jts+1)-rv(i,k  ,jts))+     &
12867                        fzp(k)*(rv(i,k-1,jts+1)-rv(i,k-1,jts)))     &
12868                                                                 )
12869        ENDDO
12870        ENDDO
12871
12872        k = ktf+1
12873        DO i = i_start, i_end
12874          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jts)+rv(i,k-1,jts+1))    &
12875                    -fzp(k-1)*(rv(i,k-2,jts)+rv(i,k-2,jts+1))   )
12876          vb = MIN( vw, 0. )
12877
12878          tendency(i,k,jts) = tendency(i,k,jts)                     &
12879                - rdy*(                                             &
12880                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
12881                        w(i,k,jts)*(                                &
12882                           (2.-fzm(k-1))*(rv(i,k-1,jts+1)-rv(i,k-1,jts))-     &
12883                           fzp(k-1)*(rv(i,k-2,jts+1)-rv(i,k-2,jts)))     &
12884                                                                 )
12885        ENDDO
12886
12887    ENDIF
12888
12889    IF( (config_flags%open_ye) .and. (jte == jde) ) THEN
12890
12891        DO i = i_start, i_end
12892        DO k = kts+1, ktf
12893
12894          vw = 0.5*( fzm(k)*(rv(i,k  ,jte-1)+rv(i,k  ,jte)) +  &
12895                     fzp(k)*(rv(i,k-1,jte-1)+rv(i,k-1,jte))   )
12896          vb = MAX( vw, 0. )
12897
12898          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
12899                - rdy*(                                                 &
12900                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
12901                        w(i,k,j_end)*(                                  &
12902                             fzm(k)*(rv(i,k  ,jte)-rv(i,k  ,jte-1))+    &
12903                             fzp(k)*(rv(i,k-1,jte)-rv(i,k-1,jte-1)))    &
12904                                                                       )
12905        ENDDO
12906        ENDDO
12907
12908        k = ktf+1
12909        DO i = i_start, i_end
12910
12911          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jte-1)+rv(i,k-1,jte))    &
12912                    -fzp(k-1)*(rv(i,k-2,jte-1)+rv(i,k-2,jte))   )
12913          vb = MAX( vw, 0. )
12914
12915          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
12916                - rdy*(                                                 &
12917                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
12918                        w(i,k,j_end)*(                                  &
12919                                (2.-fzm(k-1))*(rv(i,k-1,jte)-rv(i,k-1,jte-1))-    &
12920                                fzp(k-1)*(rv(i,k-2,jte)-rv(i,k-2,jte-1)))    &
12921                                                                       )
12922        ENDDO
12923
12924    ENDIF
12925
12926 !-------------------- vertical advection
12927 !     ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
12928 !     Here we have:  - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
12929 !     Therefore we don't need to make a correction for advect_w
12930
12931       i_start = its
12932       i_end   = MIN(ite,ide-1)
12933       j_start = jts
12934       j_end   = MIN(jte,jde-1)
12935
12936       DO i = i_start, i_end
12937          vflux(i,kts)=0.
12938          vflux(i,kte)=0.
12939       ENDDO
12940
12941 !    vert_order_test : IF (vert_order == 6) THEN
12942
12943 ! ELSE IF (vert_order == 5) THEN
12944
12945       DO j = j_start, j_end
12946
12947          DO k=kts+3,ktf-1
12948          DO i = i_start, i_end
12949            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
12950
12951          IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN
12952             qip2 = w(i,k+1,j)
12953             qip1 = w(i,k  ,j)
12954             qi   = w(i,k-1,j)
12955             qim1 = w(i,k-2,j)
12956             qim2 = w(i,k-3,j)
12957           ELSE
12958             qip2 = w(i,k-2,j)
12959             qip1 = w(i,k-1,j)
12960             qi   = w(i,k  ,j)
12961             qim1 = w(i,k+1,j)
12962             qim2 = w(i,k+2,j)
12963          ENDIF
12964
12965          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12966          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12967          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12968
12969          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12970          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12971          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12972
12973          wi0 = gi0 / (eps + beta0)**pw
12974          wi1 = gi1 / (eps + beta1)**pw
12975          wi2 = gi2 / (eps + beta2)**pw
12976
12977          sumwk = wi0 + wi1 + wi2
12978
12979           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12980
12981 !           vflux(i,k) = vel*flux5(                                   &
12982 !                   w(i,k-3,j), w(i,k-2,j), w(i,k-1,j),       &
12983 !                   w(i,k  ,j), w(i,k+1,j), w(i,k+2,j),  -vel )
12984          ENDDO
12985          ENDDO
12986
12987          DO i = i_start, i_end
12988
12989            k=kts+1
12990            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
12991
12992            k = kts+2
12993            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
12994            vflux(i,k) = vel*flux3(               &
12995                    w(i,k-2,j), w(i,k-1,j),   &
12996                    w(i,k  ,j), w(i,k+1,j), -vel )
12997            k = ktf
12998            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
12999            vflux(i,k) = vel*flux3(               &
13000                    w(i,k-2,j), w(i,k-1,j),   &
13001                    w(i,k  ,j), w(i,k+1,j), -vel )
13002
13003            k=ktf+1
13004            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
13005
13006          ENDDO
13007
13008          DO k=kts+1,ktf
13009          DO i = i_start, i_end
13010             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
13011          ENDDO
13012          ENDDO
13013
13014 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
13015          k = ktf+1
13016          DO i = i_start, i_end
13017            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
13018          ENDDO
13019
13020       ENDDO
13021
13022
13023 END SUBROUTINE advect_weno_w
13024
13025
13026 END MODULE module_advect_em
13027
13028 #endif