dyn_em/module_advect_em.F

   1
   2 !WRF:MODEL_LAYER:DYNAMICS
   3 !
   4 #ifdef 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 #else
 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 k = kts, ktf
4150        DO i = i_start, i_end
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 k = kts, ktf
4166        DO i = i_start, i_end
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 #ifndef 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+1,ktf+1
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+1,ktf+1
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+1,ktf+1
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+1,ktf+1
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+1,ktf+1
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+1,ktf+1
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+1,ktf+1
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+1,ktf+1
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 k = kts, ktf
7301        DO i = i_start, i_end
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 k = kts, ktf
7317        DO i = i_start, i_end
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 k = kts, ktf
7334        DO i = i_start, i_end
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 k = kts, ktf
7351        DO i = i_start, i_end
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          ENDDO
7416
7417          DO i = i_start, i_end
7418
7419            k=kts+2
7420            dz = 2./(rdzw(k)+rdzw(k-1))
7421            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7422            vel = rom(i,k,j)
7423            cr = vel*dt/dz/mu
7424            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7425
7426            fqz(i,k,j) = vel*flux4(                      &
7427                    field(i,k-2,j), field(i,k-1,j),      &
7428                    field(i,k  ,j), field(i,k+1,j),  -vel )
7429            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7430          ENDDO
7431
7432          DO i = i_start, i_end
7433
7434            k=ktf-1
7435            dz = 2./(rdzw(k)+rdzw(k-1))
7436            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7437            vel = rom(i,k,j)
7438            cr = vel*dt/dz/mu
7439            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7440
7441            fqz(i,k,j) = vel*flux4(                      &
7442                    field(i,k-2,j), field(i,k-1,j),      &
7443                    field(i,k  ,j), field(i,k+1,j),  -vel )
7444            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7445          ENDDO
7446
7447          DO i = i_start, i_end
7448
7449            k=ktf
7450            dz = 2./(rdzw(k)+rdzw(k-1))
7451            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7452            vel = rom(i,k,j)
7453            cr = vel*dt/dz/mu
7454            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7455            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7456            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7457
7458          ENDDO
7459
7460       ENDDO
7461
7462     ELSE IF (vert_order == 5) THEN
7463
7464       DO j = j_start, j_end
7465
7466          DO i = i_start, i_end
7467            fqz(i,1,j)  = 0.
7468            fqzl(i,1,j) = 0.
7469            fqz(i,kde,j)  = 0.
7470            fqzl(i,kde,j) = 0.
7471          ENDDO
7472
7473          DO k=kts+3,ktf-2
7474          DO i = i_start, i_end
7475            dz = 2./(rdzw(k)+rdzw(k-1))
7476            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7477            vel = rom(i,k,j)
7478            cr = vel*dt/dz/mu
7479            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7480
7481            fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
7482                                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
7483            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7484          ENDDO
7485          ENDDO
7486
7487          DO i = i_start, i_end
7488
7489            k=kts+1
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            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7496            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7497          ENDDO
7498
7499          DO i = i_start, i_end
7500
7501            k=kts+2
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          ENDDO
7513
7514          DO i = i_start, i_end
7515
7516            k=ktf-1
7517            dz = 2./(rdzw(k)+rdzw(k-1))
7518            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7519            vel = rom(i,k,j)
7520            cr = vel*dt/dz/mu
7521            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7522
7523            fqz(i,k,j) = vel*flux3(                      &
7524                    field(i,k-2,j), field(i,k-1,j),      &
7525                    field(i,k  ,j), field(i,k+1,j),  -vel )
7526            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7527          ENDDO
7528
7529          DO i = i_start, i_end
7530
7531            k=ktf
7532            dz = 2./(rdzw(k)+rdzw(k-1))
7533            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7534            vel = rom(i,k,j)
7535            cr = vel*dt/dz/mu
7536            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7537            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7538            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7539
7540          ENDDO
7541
7542       ENDDO
7543
7544     ELSE IF (vert_order == 4) THEN
7545
7546       DO j = j_start, j_end
7547
7548          DO i = i_start, i_end
7549            fqz(i,1,j)  = 0.
7550            fqzl(i,1,j) = 0.
7551            fqz(i,kde,j)  = 0.
7552            fqzl(i,kde,j) = 0.
7553          ENDDO
7554
7555          DO k=kts+2,ktf-1
7556          DO i = i_start, i_end
7557
7558            dz = 2./(rdzw(k)+rdzw(k-1))
7559            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7560            vel = rom(i,k,j)
7561            cr = vel*dt/dz/mu
7562            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7563
7564            fqz(i,k,j) = vel*flux4(                      &
7565                    field(i,k-2,j), field(i,k-1,j),      &
7566                    field(i,k  ,j), field(i,k+1,j),  -vel )
7567            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7568          ENDDO
7569          ENDDO
7570
7571          DO i = i_start, i_end
7572
7573            k=kts+1
7574            dz = 2./(rdzw(k)+rdzw(k-1))
7575            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7576            vel = rom(i,k,j)
7577            cr = vel*dt/dz/mu
7578            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7579            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7580            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7581
7582            k=ktf
7583            dz = 2./(rdzw(k)+rdzw(k-1))
7584            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7585            vel = rom(i,k,j)
7586            cr = vel*dt/dz/mu
7587            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7588            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7589            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7590
7591          ENDDO
7592
7593       ENDDO
7594
7595     ELSE IF (vert_order == 3) THEN
7596
7597       DO j = j_start, j_end
7598
7599          DO i = i_start, i_end
7600            fqz(i,1,j)  = 0.
7601            fqzl(i,1,j) = 0.
7602            fqz(i,kde,j)  = 0.
7603            fqzl(i,kde,j) = 0.
7604          ENDDO
7605
7606          DO k=kts+2,ktf-1
7607 !DEC$ vector always
7608          DO i = i_start, i_end
7609
7610            dz = 2./(rdzw(k)+rdzw(k-1))
7611            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7612            vel = rom(i,k,j)
7613            cr = vel*dt/dz/mu
7614            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7615
7616            fqz(i,k,j) = vel*flux3(                      &
7617                    field(i,k-2,j), field(i,k-1,j),      &
7618                    field(i,k  ,j), field(i,k+1,j),  -vel )
7619            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7620          ENDDO
7621          ENDDO
7622
7623          DO i = i_start, i_end
7624
7625            k=kts+1
7626            dz = 2./(rdzw(k)+rdzw(k-1))
7627            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7628            vel = rom(i,k,j)
7629            cr = vel*dt/dz/mu
7630            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7631            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7632            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7633
7634            k=ktf
7635            dz = 2./(rdzw(k)+rdzw(k-1))
7636            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7637            vel = rom(i,k,j)
7638            cr = vel*dt/dz/mu
7639            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7640            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7641            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7642
7643          ENDDO
7644
7645       ENDDO
7646
7647    ELSE IF (vert_order == 2) THEN
7648
7649       DO j = j_start, j_end
7650
7651          DO i = i_start, i_end
7652            fqz(i,1,j)  = 0.
7653            fqzl(i,1,j) = 0.
7654            fqz(i,kde,j)  = 0.
7655            fqzl(i,kde,j) = 0.
7656          ENDDO
7657
7658          DO k=kts+1,ktf
7659          DO i = i_start, i_end
7660
7661            dz = 2./(rdzw(k)+rdzw(k-1))
7662            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
7663            vel = rom(i,k,j)
7664            cr = vel*dt/dz/mu
7665            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7666            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7667            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7668
7669         ENDDO
7670         ENDDO
7671
7672       ENDDO
7673
7674    ELSE
7675
7676       WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order
7677       CALL wrf_error_fatal ( wrf_err_message )
7678
7679    ENDIF vert_order_test
7680
7681    IF (pd_limit) THEN
7682
7683 ! positive definite filter
7684
7685    i_start = its-1
7686    i_end   = MIN(ite,ide-1)+1
7687    j_start = jts-1
7688    j_end   = MIN(jte,jde-1)+1
7689
7690 !-- loop bounds for open or specified conditions
7691
7692    IF(degrade_xs) i_start = MAX(its-1,ids)
7693    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
7694    IF(degrade_ys) j_start = MAX(jts-1,jds)
7695    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
7696
7697    IF(config_flags%specified .or. config_flags%nested) THEN
7698      IF (degrade_xs) i_start = MAX(its-1,ids+1)
7699      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
7700      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
7701      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
7702    END IF
7703
7704    IF(config_flags%open_xs) THEN
7705      IF (degrade_xs) i_start = MAX(its-1,ids+1)
7706    END IF
7707    IF(config_flags%open_xe) THEN
7708      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
7709    END IF
7710    IF(config_flags%open_ys) THEN
7711      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
7712    END IF
7713    IF(config_flags%open_ye) THEN
7714      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
7715    END IF
7716    ! ADT note:
7717    ! We don't want to change j_start and j_end
7718    ! for polar BC's since we want to calculate
7719    ! fluxes for directions other than y at the
7720    ! edge
7721
7722 !-- here is the limiter...
7723
7724    DO j=j_start, j_end
7725    DO k=kts, ktf
7726 #ifdef XEON_SIMD
7727 !DIR$ simd
7728 #else
7729 !DIR$ vector always
7730 #endif
7731    DO i=i_start, i_end
7732
7733      ph_low(i,k,j) = ((c1(k)*mub(i,j)+c2(k))+(c1(k)*mu_old(i,j)))*field_old(i,k,j) &
7734                 - dt*( msftx(i,j)*msfty(i,j)*(               &
7735                        rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
7736                        rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
7737                       +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
7738
7739    ENDDO
7740    ENDDO
7741    ENDDO
7742
7743    DO j=j_start, j_end
7744    DO k=kts, ktf
7745 !DIR$ vector always
7746    DO i=i_start, i_end
7747
7748      flux_out(i,k,j) = dt*( (msftx(i,j)*msfty(i,j))*( &
7749                                 rdx*(  max(0.,fqx (i+1,k,j))      &
7750                                       -min(0.,fqx (i  ,k,j)) )    &
7751                                +rdy*(  max(0.,fqy (i,k,j+1))      &
7752                                       -min(0.,fqy (i,k,j  )) ) )  &
7753                 +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
7754                                       -max(0.,fqz (i,k  ,j)) )   )
7755
7756    ENDDO
7757    ENDDO
7758    ENDDO
7759
7760    DO j=j_start, j_end
7761    DO k=kts, ktf
7762 !DIR$ vector always
7763    DO i=i_start, i_end
7764      IF( flux_out(i,k,j) .gt. ph_low(i,k,j) ) THEN
7765        scale = max(0.,ph_low(i,k,j)/(flux_out(i,k,j)+eps))
7766        IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j)
7767        IF( fqx (i  ,k,j) .lt. 0.) fqx(i  ,k,j) = scale*fqx(i  ,k,j)
7768        IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1)
7769        IF( fqy (i,k,j  ) .lt. 0.) fqy(i,k,j  ) = scale*fqy(i,k,j  )
7770 !  note: z flux is opposite sign in mass coordinate because
7771 !  vertical coordinate decreases with increasing k
7772        IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j)
7773        IF( fqz (i,k  ,j) .gt. 0.) fqz(i,k  ,j) = scale*fqz(i,k  ,j)
7774
7775      END IF
7776
7777    ENDDO
7778    ENDDO
7779    ENDDO
7780
7781    END IF
7782
7783 ! add in the pd-limited flux divergence
7784
7785   i_start = its
7786   i_end   = MIN(ite,ide-1)
7787   j_start = jts
7788   j_end   = MIN(jte,jde-1)
7789
7790   DO j = j_start, j_end
7791   DO k = kts, ktf
7792 !DEC$ vector always
7793   DO i = i_start, i_end
7794
7795      tendency (i,k,j) = tendency(i,k,j)                           &
7796                             -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
7797                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
7798
7799   ENDDO
7800   ENDDO
7801   ENDDO
7802
7803   IF(tenddec) THEN
7804   DO j = j_start, j_end
7805   DO k = kts, ktf
7806   DO i = i_start, i_end
7807
7808      z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
7809                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
7810
7811   ENDDO
7812   ENDDO
7813   ENDDO
7814   END IF
7815
7816 ! x flux divergence
7817 !
7818   IF(degrade_xs) i_start = MAX(its,ids+1)
7819   IF(degrade_xe) i_end   = MIN(ite,ide-2)
7820
7821   DO j = j_start, j_end
7822   DO k = kts, ktf
7823 !DEC$ vector always
7824   DO i = i_start, i_end
7825
7826      ! Un-"canceled" map scale factor, ADT Eq. 48
7827      tendency (i,k,j) = tendency(i,k,j)                           &
7828                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
7829                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
7830
7831   ENDDO
7832   ENDDO
7833   ENDDO
7834
7835   IF(tenddec) THEN
7836   DO j = j_start, j_end
7837   DO k = kts, ktf
7838   DO i = i_start, i_end
7839
7840      h_tendency (i,k,j) = 0.                                      &
7841                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
7842                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
7843
7844   ENDDO
7845   ENDDO
7846   ENDDO
7847   END IF
7848
7849 ! y flux divergence
7850 !
7851   i_start = its
7852   i_end   = MIN(ite,ide-1)
7853   IF(degrade_ys) j_start = MAX(jts,jds+1)
7854   IF(degrade_ye) j_end   = MIN(jte,jde-2)
7855
7856   DO j = j_start, j_end
7857   DO k = kts, ktf
7858 !DEC$ vector always
7859   DO i = i_start, i_end
7860
7861      ! Un-"canceled" map scale factor, ADT Eq. 48
7862      ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
7863      tendency (i,k,j) = tendency(i,k,j)                           &
7864                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
7865                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
7866
7867   ENDDO
7868   ENDDO
7869   ENDDO
7870
7871   IF(tenddec) THEN
7872   DO j = j_start, j_end
7873   DO k = kts, ktf
7874   DO i = i_start, i_end
7875
7876      h_tendency (i,k,j) = h_tendency (i,k,j)                      &
7877                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
7878                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
7879
7880   ENDDO
7881   ENDDO
7882   ENDDO
7883   END IF
7884
7885 END SUBROUTINE advect_scalar_pd
7886
7887 !----------------------------------------------------------------
7888
7889 SUBROUTINE advect_scalar_weno ( field, field_old, tendency,     &
7890                                 ru, rv, rom,                   &
7891                                 c1, c2,                        &
7892                                 mut, time_step, config_flags,  &
7893                                 msfux, msfuy, msfvx, msfvy,    &
7894                                 msftx, msfty,                  &
7895                                 fzm, fzp,                      &
7896                                 rdx, rdy, rdzw,                &
7897                                 ids, ide, jds, jde, kds, kde,  &
7898                                 ims, ime, jms, jme, kms, kme,  &
7899                                 its, ite, jts, jte, kts, kte  )
7900 !
7901 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
7902 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
7903 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
7904 !
7905    IMPLICIT NONE
7906
7907    ! Input data
7908
7909    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
7910
7911    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
7912                                               ims, ime, jms, jme, kms, kme, &
7913                                               its, ite, jts, jte, kts, kte
7914
7915    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
7916                                                                       field_old, &
7917                                                                       ru,    &
7918                                                                       rv,    &
7919                                                                       rom
7920
7921    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
7922    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
7923
7924    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
7925                                                                     msfuy,  &
7926                                                                     msfvx,  &
7927                                                                     msfvy,  &
7928                                                                     msftx,  &
7929                                                                     msfty
7930
7931    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
7932                                                                   fzp,  &
7933                                                                   rdzw, &
7934                                                                   c1,   &
7935                                                                   c2
7936
7937    REAL ,                                        INTENT(IN   ) :: rdx,  &
7938                                                                   rdy
7939    INTEGER ,                                     INTENT(IN   ) :: time_step
7940
7941
7942    ! Local data
7943
7944    INTEGER :: i, j, k, itf, jtf, ktf
7945    INTEGER :: i_start, i_end, j_start, j_end
7946    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
7947    INTEGER :: jmin, jmax, jp, jm, imin, imax
7948
7949    INTEGER , PARAMETER :: is=0, js=0, ks=0
7950
7951    REAL    :: mrdx, mrdy, ub, vb, vw
7952    REAL , DIMENSION(its:ite, kts:kte) :: vflux
7953
7954
7955    REAL,  DIMENSION( its-is:ite+1, kts:kte  ) :: fqx
7956 !   REAL,  DIMENSION( its:ite+1, kts:kte  ) :: fqx
7957    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
7958
7959    INTEGER :: horz_order, vert_order
7960
7961    LOGICAL :: degrade_xs, degrade_ys
7962    LOGICAL :: degrade_xe, degrade_ye
7963
7964    INTEGER :: jp1, jp0, jtmp
7965
7966     real            :: dir, vv
7967     real            :: ue,uw,vs,vn,wb,wt
7968     real, parameter :: f30 =  7./12., f31 = 1./12.
7969     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
7970
7971
7972    integer kt,kb
7973
7974
7975     real               :: qim2, qim1, qi, qip1, qip2
7976     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
7977     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-40
7978     integer, parameter :: pw = 2
7979
7980
7981 ! definition of flux operators, 3rd, 4th, 5th or 6th order
7982
7983    REAL    :: flux3, flux4, flux5, flux6
7984    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
7985
7986       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
7987             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
7988
7989       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
7990            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
7991            sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
7992
7993       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
7994             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
7995             +(1./60.)*(q_ip2+q_im3)
7996
7997       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
7998            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
7999             -sign(1,time_step)*sign(1.,ua)*(1./60.)*(           &
8000               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
8001
8002    LOGICAL :: specified
8003
8004    specified = .false.
8005    if(config_flags%specified .or. config_flags%nested) specified = .true.
8006
8007 ! set order for the advection schemes
8008
8009   ktf=MIN(kte,kde-1)
8010   horz_order = 5 ! config_flags%h_sca_adv_order
8011   vert_order = 5 ! config_flags%v_sca_adv_order
8012
8013 !  begin with horizontal flux divergence
8014 !  here is the choice of flux operators
8015
8016
8017
8018   IF( horz_order == 5 ) THEN
8019
8020 !  determine boundary mods for flux operators
8021 !  We degrade the flux operators from 3rd/4th order
8022 !   to second order one gridpoint in from the boundaries for
8023 !   all boundary conditions except periodic and symmetry - these
8024 !   conditions have boundary zone data fill for correct application
8025 !   of the higher order flux stencils
8026
8027    degrade_xs = .true.
8028    degrade_xe = .true.
8029    degrade_ys = .true.
8030    degrade_ye = .true.
8031
8032    IF( config_flags%periodic_x   .or. &
8033        config_flags%symmetric_xs .or. &
8034        (its > ids+3)                ) degrade_xs = .false.
8035    IF( config_flags%periodic_x   .or. &
8036        config_flags%symmetric_xe .or. &
8037        (ite < ide-3)                ) degrade_xe = .false.
8038    IF( config_flags%periodic_y   .or. &
8039        config_flags%symmetric_ys .or. &
8040        (jts > jds+3)                ) degrade_ys = .false.
8041    IF( config_flags%periodic_y   .or. &
8042        config_flags%symmetric_ye .or. &
8043        (jte < jde-4)                ) degrade_ye = .false.
8044
8045 !--------------- y - advection first
8046
8047       ktf=MIN(kte,kde-1)
8048       i_start = its
8049       i_end   = MIN(ite,ide-1)
8050
8051
8052 ! check for U
8053       IF ( is == 1 ) THEN
8054         i_start = its
8055         i_end   = ite
8056         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
8057         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
8058         IF ( config_flags%periodic_x ) i_start = its
8059         IF ( config_flags%periodic_x ) i_end = ite
8060       ENDIF
8061
8062       j_start = jts
8063       j_end   = MIN(jte,jde-1)
8064
8065 !  higher order flux has a 5 or 7 point stencil, so compute
8066 !  bounds so we can switch to second order flux close to the boundary
8067
8068       j_start_f = j_start
8069       j_end_f   = j_end+1
8070
8071       IF(degrade_ys) then
8072         j_start = MAX(jts,jds+1)
8073         j_start_f = jds+3
8074       ENDIF
8075
8076       IF(degrade_ye) then
8077         j_end = MIN(jte,jde-2)
8078         j_end_f = jde-3
8079       ENDIF
8080
8081       IF(config_flags%polar) j_end = MIN(jte,jde-1)
8082
8083 !  compute fluxes, 5th or 6th order
8084
8085      jp1 = 2
8086      jp0 = 1
8087
8088      j_loop_y_flux_5 : DO j = j_start, j_end+1
8089
8090       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
8091
8092         DO k=kts,ktf
8093         DO i = i_start, i_end
8094 !          vel = rv(i,k,j)
8095           vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
8096
8097          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
8098             qip2 = field(i,k,j+1)
8099             qip1 = field(i,k,j  )
8100             qi   = field(i,k,j-1)
8101             qim1 = field(i,k,j-2)
8102             qim2 = field(i,k,j-3)
8103           ELSE
8104             qip2 = field(i,k,j-2)
8105             qip1 = field(i,k,j-1)
8106             qi   = field(i,k,j  )
8107             qim1 = field(i,k,j+1)
8108             qim2 = field(i,k,j+2)
8109          ENDIF
8110
8111          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8112          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8113          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8114
8115          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8116          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8117          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8118
8119          wi0 = gi0 / (eps + beta0)**pw
8120          wi1 = gi1 / (eps + beta1)**pw
8121          wi2 = gi2 / (eps + beta2)**pw
8122
8123          sumwk = wi0 + wi1 + wi2
8124
8125           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8126
8127 !          fqy( i, k, jp1 ) = vel*flux5(                                &
8128 !                  field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
8129 !                  field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
8130         ENDDO
8131         ENDDO
8132
8133
8134       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
8135
8136             DO k=kts,ktf
8137             DO i = i_start, i_end
8138               fqy(i,k, jp1) = 0.5*rv(i,k,j)*          &
8139 !              fqy(i,k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )*          &
8140                      (field(i,k,j)+field(i,k,j-1))
8141
8142             ENDDO
8143             ENDDO
8144
8145      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
8146
8147             DO k=kts,ktf
8148             DO i = i_start, i_end
8149 !              vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
8150               vel = rv(i,k,j)
8151               fqy( i, k, jp1 ) = vel*flux3(              &
8152                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
8153             ENDDO
8154             ENDDO
8155
8156      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
8157
8158             DO k=kts,ktf
8159             DO i = i_start, i_end
8160 !              fqy(i, k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )*      &
8161               fqy(i, k, jp1) = 0.5*rv(i,k,j)*      &
8162                      (field(i,k,j)+field(i,k,j-1))
8163             ENDDO
8164             ENDDO
8165
8166      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
8167
8168             DO k=kts,ktf
8169             DO i = i_start, i_end
8170               vel = rv(i,k,j)
8171 !              vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
8172               fqy( i, k, jp1) = vel*flux3(             &
8173                    field(i,k,j-2),field(i,k,j-1),    &
8174                    field(i,k,j),field(i,k,j+1),vel )
8175             ENDDO
8176             ENDDO
8177
8178      ENDIF
8179
8180 !  y flux-divergence into tendency
8181
8182       IF ( is == 0 ) THEN
8183         ! Comments on polar boundary conditions
8184         ! Same process as for advect_u - tendencies run from jds to jde-1
8185         ! (latitudes are as for u grid, longitudes are displaced)
8186         ! Therefore: flow is only from one side for points next to poles
8187         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
8188           DO k=kts,ktf
8189           DO i = i_start, i_end
8190             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
8191             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
8192           END DO
8193           END DO
8194         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
8195           DO k=kts,ktf
8196           DO i = i_start, i_end
8197             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
8198             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
8199           END DO
8200           END DO
8201         ELSE  ! normal code
8202
8203         IF(j > j_start) THEN
8204
8205           DO k=kts,ktf
8206           DO i = i_start, i_end
8207             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
8208             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
8209           ENDDO
8210           ENDDO
8211
8212         ENDIF
8213         ENDIF
8214        ELSEIF ( is == 1 ) THEN
8215
8216         ! (j > j_start) will miss the u(,,jds) tendency
8217         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
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)
8222           END DO
8223           END DO
8224         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
8225         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
8226           DO k=kts,ktf
8227           DO i = i_start, i_end
8228             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
8229             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
8230           END DO
8231           END DO
8232         ELSE  ! normal code
8233
8234         IF(j > j_start) THEN
8235
8236           DO k=kts,ktf
8237           DO i = i_start, i_end
8238             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
8239             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
8240           ENDDO
8241           ENDDO
8242
8243         ENDIF
8244
8245         END IF
8246
8247        ENDIF
8248
8249         jtmp = jp1
8250         jp1 = jp0
8251         jp0 = jtmp
8252
8253       ENDDO j_loop_y_flux_5
8254
8255 !  next, x - flux divergence
8256
8257       i_start = its
8258       i_end   = MIN(ite,ide-1)
8259
8260       j_start = jts
8261       j_end   = MIN(jte,jde-1)
8262
8263 !  higher order flux has a 5 or 7 point stencil, so compute
8264 !  bounds so we can switch to second order flux close to the boundary
8265
8266       i_start_f = i_start
8267       i_end_f   = i_end+1
8268
8269       IF(degrade_xs) then
8270         i_start = MAX(ids+1,its)
8271 !        i_start_f = i_start+2
8272         i_start_f = MIN(i_start+2,ids+3)
8273       ENDIF
8274
8275       IF(degrade_xe) then
8276         i_end = MIN(ide-2,ite)
8277         i_end_f = ide-3
8278       ENDIF
8279
8280 !  compute fluxes
8281
8282       DO j = j_start, j_end
8283
8284 !  5th or 6th order flux
8285
8286         DO k=kts,ktf
8287         DO i = i_start_f, i_end_f
8288 !          vel = ru(i,k,j)
8289           vel = 0.5*( ru(i,k,j) + ru(i-is,k-ks,j-js) )
8290
8291
8292          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
8293             qip2 = field(i+1,k,j)
8294             qip1 = field(i,  k,j)
8295             qi   = field(i-1,k,j)
8296             qim1 = field(i-2,k,j)
8297             qim2 = field(i-3,k,j)
8298           ELSE
8299             qip2 = field(i-2,k,j)
8300             qip1 = field(i-1,k,j)
8301             qi   = field(i,  k,j)
8302             qim1 = field(i+1,k,j)
8303             qim2 = field(i+2,k,j)
8304          ENDIF
8305
8306          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8307          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8308          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8309
8310          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8311          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8312          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8313
8314          wi0 = gi0 / (eps + beta0)**pw
8315          wi1 = gi1 / (eps + beta1)**pw
8316          wi2 = gi2 / (eps + beta2)**pw
8317
8318          sumwk = wi0 + wi1 + wi2
8319
8320          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8321
8322 !          fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
8323 !                                         field(i-1,k,j), field(i  ,k,j),  &
8324 !                                         field(i+1,k,j), field(i+2,k,j),  &
8325 !                                         vel                             )
8326         ENDDO
8327         ENDDO
8328
8329 !  lower order fluxes close to boundaries (if not periodic or symmetric)
8330
8331         IF( degrade_xs ) THEN
8332
8333           DO i=i_start,i_start_f-1
8334
8335             IF(i == ids+1) THEN ! second order
8336               DO k=kts,ktf
8337                 fqx(i,k) = 0.5*(ru(i,k,j)) &
8338                        *(field(i,k,j)+field(i-1,k,j))
8339               ENDDO
8340             ENDIF
8341
8342             IF(i == ids+2) THEN  ! third order
8343               DO k=kts,ktf
8344                 vel = ru(i,k,j)
8345                 fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
8346                                               field(i  ,k,j), field(i+1,k,j),  &
8347                                               vel                     )
8348               ENDDO
8349             END IF
8350
8351           ENDDO
8352
8353         ENDIF
8354
8355         IF( degrade_xe ) THEN
8356
8357           DO i = i_end_f+1, i_end+1
8358
8359             IF( i == ide-1 ) THEN ! second order flux next to the boundary
8360               DO k=kts,ktf
8361                 fqx(i,k) = 0.5*(ru(i,k,j))      &
8362                        *(field(i,k,j)+field(i-1,k,j))
8363               ENDDO
8364            ENDIF
8365
8366            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
8367              DO k=kts,ktf
8368                vel = ru(i,k,j)
8369                fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
8370                                        field(i  ,k,j), field(i+1,k,j),  &
8371                                        vel                             )
8372              ENDDO
8373            ENDIF
8374
8375          ENDDO
8376
8377        ENDIF
8378
8379 !  x flux-divergence into tendency
8380
8381        IF ( is == 0 ) THEN
8382           DO k=kts,ktf
8383           DO i = i_start, i_end
8384             mrdx=msftx(i,j)*rdx      ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
8385             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
8386           ENDDO
8387           ENDDO
8388        ELSEIF ( is == 1 ) THEN
8389         DO k=kts,ktf
8390           DO i = i_start, i_end
8391             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
8392             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
8393           ENDDO
8394         ENDDO
8395        ENDIF
8396
8397       ENDDO
8398
8399
8400    ENDIF
8401
8402
8403 !  pick up the rest of the horizontal radiation boundary conditions.
8404 !  (these are the computations that don't require 'cb'.
8405 !  first, set to index ranges
8406
8407       i_start = its
8408       i_end   = MIN(ite,ide-1)
8409       j_start = jts
8410       j_end   = MIN(jte,jde-1)
8411
8412 !  compute x (u) conditions for v, w, or scalar
8413
8414    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
8415
8416        DO j = j_start, j_end
8417        DO k = kts, ktf
8418          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
8419          tendency(its,k,j) = tendency(its,k,j)                     &
8420                - rdx*(                                             &
8421                        ub*(   field_old(its+1,k,j)                 &
8422                             - field_old(its  ,k,j)   ) +           &
8423                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
8424                                                                 )
8425        ENDDO
8426        ENDDO
8427
8428    ENDIF
8429
8430    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
8431
8432        DO j = j_start, j_end
8433        DO k = kts, ktf
8434          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
8435          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
8436                - rdx*(                                               &
8437                        ub*(  field_old(i_end  ,k,j)                  &
8438                            - field_old(i_end-1,k,j) ) +              &
8439                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
8440                                                                     )
8441        ENDDO
8442        ENDDO
8443
8444    ENDIF
8445
8446    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
8447
8448        DO i = i_start, i_end
8449        DO k = kts, ktf
8450          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
8451          tendency(i,k,jts) = tendency(i,k,jts)                     &
8452                - rdy*(                                             &
8453                        vb*(  field_old(i,k,jts+1)                  &
8454                            - field_old(i,k,jts  ) ) +              &
8455                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
8456                                                                 )
8457        ENDDO
8458        ENDDO
8459
8460    ENDIF
8461
8462    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
8463
8464        DO i = i_start, i_end
8465        DO k = kts, ktf
8466          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
8467          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
8468                - rdy*(                                               &
8469                        vb*(   field_old(i,k,j_end  )                 &
8470                             - field_old(i,k,j_end-1) ) +             &
8471                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
8472                                                                     )
8473        ENDDO
8474        ENDDO
8475
8476    ENDIF
8477
8478
8479 !-------------------- vertical advection
8480 !     Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
8481 !     Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
8482 !     So we don't need to make a correction for advect_scalar
8483
8484       i_start = its
8485       i_end   = MIN(ite,ide-1)
8486       j_start = jts
8487       j_end   = MIN(jte,jde-1)
8488
8489       DO i = i_start, i_end
8490          vflux(i,kts)=0.
8491          vflux(i,kte)=0.
8492       ENDDO
8493
8494
8495
8496       DO j = j_start, j_end
8497
8498          DO k=kts+3,ktf-2
8499          DO i = i_start, i_end
8500 !           vel = rom(i,k,j)
8501            vel = 0.5*( rom(i,k,j) + rom(i-is,k-ks,j-js) )
8502
8503          IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN
8504             qip2 = field(i,k+1,j)
8505             qip1 = field(i,k  ,j)
8506             qi   = field(i,k-1,j)
8507             qim1 = field(i,k-2,j)
8508             qim2 = field(i,k-3,j)
8509           ELSE
8510             qip2 = field(i,k-2,j)
8511             qip1 = field(i,k-1,j)
8512             qi   = field(i,k  ,j)
8513             qim1 = field(i,k+1,j)
8514             qim2 = field(i,k+2,j)
8515          ENDIF
8516
8517          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8518          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8519          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8520
8521          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8522          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8523          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8524
8525          wi0 = gi0 / (eps + beta0)**pw
8526          wi1 = gi1 / (eps + beta1)**pw
8527          wi2 = gi2 / (eps + beta2)**pw
8528
8529          sumwk = wi0 + wi1 + wi2
8530
8531           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8532
8533 !           vflux(i,k) = vel*flux5(                                 &
8534 !                   field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
8535 !                   field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
8536          ENDDO
8537          ENDDO
8538
8539          DO i = i_start, i_end
8540
8541            k=kts+1
8542            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
8543
8544            k = kts+2
8545            vel=rom(i,k,j)
8546            vflux(i,k) = vel*flux3(               &
8547                    field(i,k-2,j), field(i,k-1,j),   &
8548                    field(i,k  ,j), field(i,k+1,j), -vel )
8549            k = ktf-1
8550            vel=rom(i,k,j)
8551            vflux(i,k) = vel*flux3(               &
8552                    field(i,k-2,j), field(i,k-1,j),   &
8553                    field(i,k  ,j), field(i,k+1,j), -vel )
8554
8555            k=ktf
8556            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
8557          ENDDO
8558
8559          DO k=kts,ktf
8560          DO i = i_start, i_end
8561             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
8562          ENDDO
8563          ENDDO
8564
8565       ENDDO
8566
8567
8568
8569 END SUBROUTINE advect_scalar_weno
8570
8571 !---------------------------------------------------------------------------------
8572
8573 SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency,    &
8574                                   ru, rv, rom,                   &
8575                                   c1, c2,                        &
8576                                   mut, mub, mu_old,              &
8577                                   time_step, config_flags,       &
8578                                   msfux, msfuy, msfvx, msfvy,    &
8579                                   msftx, msfty,                  &
8580                                   fzm, fzp,                      &
8581                                   rdx, rdy, rdzw, dt,            &
8582                                   ids, ide, jds, jde, kds, kde,  &
8583                                   ims, ime, jms, jme, kms, kme,  &
8584                                   its, ite, jts, jte, kts, kte  )
8585
8586 !  this is a first cut at a positive definite advection option
8587 !  for scalars in WRF.  This version is memory intensive ->
8588 !  we save 3d arrays of x, y and z both high and low order fluxes
8589 !  (six in all).  Alternatively, we could sweep in a direction
8590 !  and lower the cost considerably.
8591
8592 !  uses the Smolarkiewicz MWR 1989 approach, with addition of first-order
8593 !  fluxes initially
8594
8595 !  WCS, 3 December 2002, 24 February 2003
8596
8597 !
8598 ! ERM Dec. 2011: replaced 5th-order fluxes with 5th-order WENO (Weighted
8599 ! Essentially Non-Oscillatory) scheme
8600 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
8601 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;
8602 !
8603
8604    IMPLICIT NONE
8605
8606    ! Input data
8607
8608    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
8609
8610    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
8611                                               ims, ime, jms, jme, kms, kme, &
8612                                               its, ite, jts, jte, kts, kte
8613
8614    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
8615                                                                       field_old, &
8616                                                                       ru,        &
8617                                                                       rv,        &
8618                                                                       rom
8619
8620    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut, mub, mu_old
8621    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
8622
8623    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
8624                                                                     msfuy,  &
8625                                                                     msfvx,  &
8626                                                                     msfvy,  &
8627                                                                     msftx,  &
8628                                                                     msfty
8629
8630    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
8631                                                                   fzp,  &
8632                                                                   rdzw, &
8633                                                                   c1,   &
8634                                                                   c2
8635
8636    REAL ,                                        INTENT(IN   ) :: rdx,  &
8637                                                                   rdy,  &
8638                                                                   dt
8639    INTEGER ,                                     INTENT(IN   ) :: time_step
8640
8641    ! Local data
8642
8643    INTEGER :: i, j, k, itf, jtf, ktf
8644    INTEGER :: i_start, i_end, j_start, j_end
8645    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
8646    INTEGER :: jmin, jmax, jp, jm, imin, imax
8647
8648    REAL    :: mrdx, mrdy, ub, vb, uw, vw, mu
8649
8650 !  storage for high and low order fluxes
8651
8652    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqx, fqy, fqz
8653    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqxl, fqyl, fqzl
8654
8655    INTEGER :: horz_order, vert_order
8656
8657    LOGICAL :: degrade_xs, degrade_ys
8658    LOGICAL :: degrade_xe, degrade_ye
8659
8660    INTEGER :: jp1, jp0, jtmp
8661
8662    REAL,DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: flux_out, ph_low
8663    REAL :: scale
8664    REAL, PARAMETER :: eps=1.e-20
8665
8666     real            :: dir, vv
8667     real            :: ue,vs,vn,wb,wt
8668     real, parameter :: f30 =  7./12., f31 = 1./12.
8669     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
8670
8671     real               :: qim2, qim1, qi, qip1, qip2
8672     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
8673     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps1=1.0d-40
8674     integer, parameter :: pw = 2
8675
8676
8677 ! definition of flux operators, 3rd, 4th, 5th or 6th order
8678
8679    REAL    :: flux3, flux4, flux5, flux6, flux_upwind
8680    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
8681
8682       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
8683             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
8684
8685       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
8686            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
8687            sign(1,time_step)*sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
8688
8689       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
8690             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
8691             +(1./60.)*(q_ip2+q_im3)
8692
8693       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
8694            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
8695             -sign(1,time_step)*sign(1.,ua)*(1./60.)*(           &
8696               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
8697
8698       flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 &
8699                                     +0.5*max(-1.0,(cr-abs(cr)))*q_i
8700
8701 !      flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
8702 !                                    +0.5*(1.-sign(1.,cr))*q_i
8703 !      flux_upwind(q_im1, q_i, cr ) = 0.
8704
8705     REAL     :: dx,dy,dz
8706
8707     LOGICAL, PARAMETER :: pd_limit = .true.
8708
8709 ! set order for the advection schemes
8710
8711 !  write(6,*) ' in pd advection routine '
8712
8713     ! Empty arrays just in case:
8714     IF (config_flags%polar) THEN
8715        fqx(:,:,:)  = 0.
8716        fqy(:,:,:)  = 0.
8717        fqz(:,:,:)  = 0.
8718        fqxl(:,:,:) = 0.
8719        fqyl(:,:,:) = 0.
8720        fqzl(:,:,:) = 0.
8721     END IF
8722
8723   ktf=MIN(kte,kde-1)
8724   horz_order = config_flags%h_sca_adv_order
8725   vert_order = config_flags%v_sca_adv_order
8726
8727 !  determine boundary mods for flux operators
8728 !  We degrade the flux operators from 3rd/4th order
8729 !   to second order one gridpoint in from the boundaries for
8730 !   all boundary conditions except periodic and symmetry - these
8731 !   conditions have boundary zone data fill for correct application
8732 !   of the higher order flux stencils
8733
8734    degrade_xs = .true.
8735    degrade_xe = .true.
8736    degrade_ys = .true.
8737    degrade_ye = .true.
8738
8739 !  begin with horizontal flux divergence
8740 !  here is the choice of flux operators
8741
8742
8743 !  horizontal_order_test : IF( horz_order == 6 ) THEN
8744
8745 !    ELSE IF( horz_order == 5 ) THEN
8746
8747    IF( config_flags%periodic_x   .or. &
8748        config_flags%symmetric_xs .or. &
8749        (its > ids+3)                ) degrade_xs = .false.
8750    IF( config_flags%periodic_x   .or. &
8751        config_flags%symmetric_xe .or. &
8752        (ite < ide-4)                ) degrade_xe = .false.
8753    IF( config_flags%periodic_y   .or. &
8754        config_flags%symmetric_ys .or. &
8755        (jts > jds+3)                ) degrade_ys = .false.
8756    IF( config_flags%periodic_y   .or. &
8757        config_flags%symmetric_ye .or. &
8758        (jte < jde-4)                ) degrade_ye = .false.
8759
8760 !--------------- y - advection first
8761
8762 !--  y flux compute; these bounds are for periodic and sym b.c.
8763
8764       ktf=MIN(kte,kde-1)
8765       i_start = its-1
8766       i_end   = MIN(ite,ide-1)+1
8767       j_start = jts-1
8768       j_end   = MIN(jte,jde-1)+1
8769       j_start_f = j_start
8770       j_end_f   = j_end+1
8771
8772 !--  modify loop bounds if open or specified
8773
8774 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
8775 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
8776       IF(degrade_xs) i_start = MAX(its-1,ids)
8777       IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
8778
8779       IF(degrade_ys) then
8780         j_start = MAX(jts-1,jds+1)
8781         j_start_f = jds+3
8782       ENDIF
8783
8784       IF(degrade_ye) then
8785         j_end = MIN(jte+1,jde-2)
8786         j_end_f = jde-3
8787       ENDIF
8788
8789 !  compute fluxes, 5th order
8790
8791       j_loop_y_flux_5 : DO j = j_start, j_end+1
8792
8793       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
8794
8795         DO k=kts,ktf
8796         DO i = i_start, i_end
8797
8798           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
8799           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
8800           vel = rv(i,k,j)
8801           cr = vel*dt/dy/mu
8802           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8803
8804          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
8805             qip2 = field(i,k,j+1)
8806             qip1 = field(i,k,j  )
8807             qi   = field(i,k,j-1)
8808             qim1 = field(i,k,j-2)
8809             qim2 = field(i,k,j-3)
8810           ELSE
8811             qip2 = field(i,k,j-2)
8812             qip1 = field(i,k,j-1)
8813             qi   = field(i,k,j  )
8814             qim1 = field(i,k,j+1)
8815             qim2 = field(i,k,j+2)
8816          ENDIF
8817
8818          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8819          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8820          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8821
8822          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8823          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8824          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8825
8826          wi0 = gi0 / (eps1 + beta0)**pw
8827          wi1 = gi1 / (eps1 + beta1)**pw
8828          wi2 = gi2 / (eps1 + beta2)**pw
8829
8830          sumwk = wi0 + wi1 + wi2
8831
8832           fqy( i, k, j ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8833
8834 !          fqy( i, k, j  ) = vel*flux5(                                  &
8835 !                  field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
8836 !                  field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
8837
8838           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8839
8840         ENDDO
8841         ENDDO
8842
8843       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
8844
8845             DO k=kts,ktf
8846             DO i = i_start, i_end
8847
8848               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
8849               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
8850               vel = rv(i,k,j)
8851               cr = vel*dt/dy/mu
8852               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8853
8854               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
8855                      (field(i,k,j)+field(i,k,j-1))
8856
8857               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8858
8859             ENDDO
8860             ENDDO
8861
8862       ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south 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 ) = vel*flux3(              &
8874                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
8875               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8876
8877             ENDDO
8878             ENDDO
8879
8880       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to 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 ) = 0.5*rv(i,k,j)*      &
8892                      (field(i,k,j)+field(i,k,j-1))
8893               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8894
8895             ENDDO
8896             ENDDO
8897
8898       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
8899
8900             DO k=kts,ktf
8901             DO i = i_start, i_end
8902
8903               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
8904               mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j-1)+c2(k)))
8905               vel = rv(i,k,j)
8906               cr = vel*dt/dy/mu
8907               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8908
8909               fqy( i, k, j) = vel*flux3(             &
8910                    field(i,k,j-2),field(i,k,j-1),    &
8911                    field(i,k,j),field(i,k,j+1),vel )
8912               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8913
8914             ENDDO
8915             ENDDO
8916
8917       ENDIF
8918
8919    ENDDO j_loop_y_flux_5
8920
8921 !  next, x flux
8922
8923 !--  these bounds are for periodic and sym conditions
8924
8925       i_start = its-1
8926       i_end   = MIN(ite,ide-1)+1
8927       i_start_f = i_start
8928       i_end_f   = i_end+1
8929
8930       j_start = jts-1
8931       j_end   = MIN(jte,jde-1)+1
8932
8933 !--  modify loop bounds for open and specified b.c
8934
8935 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
8936 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
8937       IF(degrade_ys) j_start = MAX(jts-1,jds)
8938       IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
8939
8940       IF(degrade_xs) then
8941         i_start = MAX(ids+1,its-1)
8942         i_start_f = ids+3
8943       ENDIF
8944
8945       IF(degrade_xe) then
8946         i_end = MIN(ide-2,ite+1)
8947         i_end_f = ide-3
8948       ENDIF
8949
8950 !  compute fluxes
8951
8952       DO j = j_start, j_end
8953
8954 !  5th order flux
8955
8956         DO k=kts,ktf
8957         DO i = i_start_f, i_end_f
8958
8959           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
8960           mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
8961           vel = ru(i,k,j)
8962           cr = vel*dt/dx/mu
8963           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8964
8965
8966          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
8967             qip2 = field(i+1,k,j)
8968             qip1 = field(i,  k,j)
8969             qi   = field(i-1,k,j)
8970             qim1 = field(i-2,k,j)
8971             qim2 = field(i-3,k,j)
8972           ELSE
8973             qip2 = field(i-2,k,j)
8974             qip1 = field(i-1,k,j)
8975             qi   = field(i,  k,j)
8976             qim1 = field(i+1,k,j)
8977             qim2 = field(i+2,k,j)
8978          ENDIF
8979
8980          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8981          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8982          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8983
8984          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8985          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8986          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8987
8988          wi0 = gi0 / (eps1 + beta0)**pw
8989          wi1 = gi1 / (eps1 + beta1)**pw
8990          wi2 = gi2 / (eps1 + beta2)**pw
8991
8992          sumwk = wi0 + wi1 + wi2
8993
8994          fqx(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8995
8996 !          fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
8997 !                                         field(i-1,k,j), field(i  ,k,j),  &
8998 !                                         field(i+1,k,j), field(i+2,k,j),  &
8999 !                                         vel                             )
9000           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9001
9002         ENDDO
9003         ENDDO
9004
9005 !  lower order fluxes close to boundaries (if not periodic or symmetric)
9006
9007         IF( degrade_xs ) THEN
9008
9009           DO i=i_start,i_start_f-1
9010
9011             IF(i == ids+1) THEN ! second order
9012               DO k=kts,ktf
9013                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
9014                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
9015                 vel = ru(i,k,j)/mu
9016                 cr = vel*dt/dx
9017                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9018                 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
9019                        *(field(i,k,j)+field(i-1,k,j))
9020                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9021               ENDDO
9022             ENDIF
9023
9024             IF(i == ids+2) THEN  ! third order
9025               DO k=kts,ktf
9026                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
9027                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
9028                 vel = ru(i,k,j)
9029                 cr = vel*dt/dx/mu
9030                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9031                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
9032                                           field(i  ,k,j), field(i+1,k,j),  &
9033                                           vel                             )
9034                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9035               ENDDO
9036             ENDIF
9037
9038           ENDDO
9039
9040         ENDIF
9041
9042         IF( degrade_xe ) THEN
9043
9044           DO i = i_end_f+1, i_end+1
9045
9046             IF( i == ide-1 ) THEN ! second order flux next to the boundary
9047               DO k=kts,ktf
9048                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
9049                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
9050                 vel = ru(i,k,j)
9051                 cr = vel*dt/dx/mu
9052                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9053                 fqx(i,k,j) = 0.5*(ru(i,k,j))      &
9054                        *(field(i,k,j)+field(i-1,k,j))
9055                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9056               ENDDO
9057             ENDIF
9058
9059
9060             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
9061               DO k=kts,ktf
9062                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
9063                 mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i-1,j)+c2(k)))
9064                 vel = ru(i,k,j)
9065                 cr = vel*dt/dx/mu
9066                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9067                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
9068                                           field(i  ,k,j), field(i+1,k,j),  &
9069                                           vel                             )
9070                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9071               ENDDO
9072             ENDIF
9073
9074           ENDDO
9075
9076         ENDIF
9077
9078       ENDDO  ! enddo for outer J loop
9079
9080 !--- end of 5th order horizontal flux calculation
9081
9082 !   ELSE
9083
9084 !      WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order
9085 !      CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
9086
9087 !   ENDIF horizontal_order_test
9088
9089 !  pick up the rest of the horizontal radiation boundary conditions.
9090 !  (these are the computations that don't require 'cb'.
9091 !  first, set to index ranges
9092
9093       i_start = its
9094       i_end   = MIN(ite,ide-1)
9095       j_start = jts
9096       j_end   = MIN(jte,jde-1)
9097
9098 !  compute x (u) conditions for v, w, or scalar
9099
9100    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
9101
9102        DO j = j_start, j_end
9103        DO k = kts, ktf
9104          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
9105          tendency(its,k,j) = tendency(its,k,j)                     &
9106                - rdx*(                                             &
9107                        ub*(   field_old(its+1,k,j)                 &
9108                             - field_old(its  ,k,j)   ) +           &
9109                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
9110                                                                 )
9111        ENDDO
9112        ENDDO
9113
9114    ENDIF
9115
9116    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
9117
9118        DO j = j_start, j_end
9119        DO k = kts, ktf
9120          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
9121          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
9122                - rdx*(                                               &
9123                        ub*(  field_old(i_end  ,k,j)                  &
9124                            - field_old(i_end-1,k,j) ) +              &
9125                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
9126                                                                     )
9127        ENDDO
9128        ENDDO
9129
9130    ENDIF
9131
9132    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
9133
9134        DO i = i_start, i_end
9135        DO k = kts, ktf
9136          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
9137          tendency(i,k,jts) = tendency(i,k,jts)                     &
9138                - rdy*(                                             &
9139                        vb*(  field_old(i,k,jts+1)                  &
9140                            - field_old(i,k,jts  ) ) +              &
9141                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
9142                                                                 )
9143        ENDDO
9144        ENDDO
9145
9146    ENDIF
9147
9148    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
9149
9150        DO i = i_start, i_end
9151        DO k = kts, ktf
9152          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
9153          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
9154                - rdy*(                                               &
9155                        vb*(   field_old(i,k,j_end  )                 &
9156                             - field_old(i,k,j_end-1) ) +             &
9157                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
9158                                                                     )
9159        ENDDO
9160        ENDDO
9161
9162    ENDIF
9163
9164    IF( (config_flags%polar) .and. (jts == jds) ) THEN
9165
9166        ! Assuming rv(i,k,jds) = 0.
9167        DO i = i_start, i_end
9168        DO k = kts, ktf
9169          vb = MIN( 0.5*rv(i,k,jts+1), 0. )
9170          tendency(i,k,jts) = tendency(i,k,jts)                     &
9171                - rdy*(                                             &
9172                        vb*(  field_old(i,k,jts+1)                  &
9173                            - field_old(i,k,jts  ) ) +              &
9174                        field(i,k,jts)*rv(i,k,jts+1)                &
9175                                                                 )
9176        ENDDO
9177        ENDDO
9178
9179    ENDIF
9180
9181    IF( (config_flags%polar) .and. (jte == jde)) THEN
9182
9183        ! Assuming rv(i,k,jde) = 0.
9184        DO i = i_start, i_end
9185        DO k = kts, ktf
9186          vb = MAX( 0.5*rv(i,k,jte-1), 0. )
9187          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
9188                - rdy*(                                               &
9189                        vb*(   field_old(i,k,j_end  )                 &
9190                             - field_old(i,k,j_end-1) ) +             &
9191                        field(i,k,j_end)*(-rv(i,k,jte-1))             &
9192                                                                     )
9193        ENDDO
9194        ENDDO
9195
9196    ENDIF
9197
9198 !-------------------- vertical advection
9199
9200 !-- loop bounds for periodic or sym conditions
9201
9202       i_start = its-1
9203       i_end   = MIN(ite,ide-1)+1
9204       j_start = jts-1
9205       j_end   = MIN(jte,jde-1)+1
9206
9207 !-- loop bounds for open or specified conditions
9208
9209     IF(degrade_xs) i_start = MAX(its-1,ids)
9210     IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
9211     IF(degrade_ys) j_start = MAX(jts-1,jds)
9212     IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
9213
9214 !    vert_order_test : IF (vert_order == 6) THEN
9215
9216
9217 !    ELSE IF (vert_order == 5) THEN
9218
9219       DO j = j_start, j_end
9220
9221          DO i = i_start, i_end
9222            fqz(i,1,j)  = 0.
9223            fqzl(i,1,j) = 0.
9224            fqz(i,kde,j)  = 0.
9225            fqzl(i,kde,j) = 0.
9226          ENDDO
9227
9228          DO k=kts+3,ktf-2
9229          DO i = i_start, i_end
9230            dz = 2./(rdzw(k)+rdzw(k-1))
9231            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
9232            vel = rom(i,k,j)
9233            cr = vel*dt/dz/mu
9234            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9235
9236
9237          IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN
9238             qip2 = field(i,k+1,j)
9239             qip1 = field(i,k  ,j)
9240             qi   = field(i,k-1,j)
9241             qim1 = field(i,k-2,j)
9242             qim2 = field(i,k-3,j)
9243           ELSE
9244             qip2 = field(i,k-2,j)
9245             qip1 = field(i,k-1,j)
9246             qi   = field(i,k  ,j)
9247             qim1 = field(i,k+1,j)
9248             qim2 = field(i,k+2,j)
9249          ENDIF
9250
9251          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
9252          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
9253          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
9254
9255          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
9256          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
9257          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
9258
9259          wi0 = gi0 / (eps1 + beta0)**pw
9260          wi1 = gi1 / (eps1 + beta1)**pw
9261          wi2 = gi2 / (eps1 + beta2)**pw
9262
9263          sumwk = wi0 + wi1 + wi2
9264
9265           fqz(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
9266
9267 !           fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
9268 !                                   field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
9269            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9270          ENDDO
9271          ENDDO
9272
9273          DO i = i_start, i_end
9274
9275            k=kts+1
9276            dz = 2./(rdzw(k)+rdzw(k-1))
9277            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
9278            vel = rom(i,k,j)
9279            cr = vel*dt/dz/mu
9280            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9281            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
9282            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9283
9284            k=kts+2
9285            dz = 2./(rdzw(k)+rdzw(k-1))
9286            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
9287            vel = rom(i,k,j)
9288            cr = vel*dt/dz/mu
9289            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9290
9291            fqz(i,k,j) = vel*flux3(                      &
9292                    field(i,k-2,j), field(i,k-1,j),      &
9293                    field(i,k  ,j), field(i,k+1,j),  -vel )
9294            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9295
9296            k=ktf-1
9297            dz = 2./(rdzw(k)+rdzw(k-1))
9298            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
9299            vel = rom(i,k,j)
9300            cr = vel*dt/dz/mu
9301            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9302
9303            fqz(i,k,j) = vel*flux3(                      &
9304                    field(i,k-2,j), field(i,k-1,j),      &
9305                    field(i,k  ,j), field(i,k+1,j),  -vel )
9306            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9307
9308            k=ktf
9309            dz = 2./(rdzw(k)+rdzw(k-1))
9310            mu = 0.5*((c1(k)*mut(i,j)+c2(k))+(c1(k)*mut(i,j)+c2(k)))
9311            vel = rom(i,k,j)
9312            cr = vel*dt/dz/mu
9313            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9314            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
9315            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9316
9317          ENDDO
9318
9319       ENDDO
9320
9321
9322 !   ELSE
9323
9324 !      WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order
9325 !      CALL wrf_error_fatal ( wrf_err_message )
9326
9327 !   ENDIF vert_order_test
9328
9329    IF (pd_limit) THEN
9330
9331 ! positive definite filter
9332
9333    i_start = its-1
9334    i_end   = MIN(ite,ide-1)+1
9335    j_start = jts-1
9336    j_end   = MIN(jte,jde-1)+1
9337
9338 !-- loop bounds for open or specified conditions
9339
9340    IF(degrade_xs) i_start = MAX(its-1,ids)
9341    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
9342    IF(degrade_ys) j_start = MAX(jts-1,jds)
9343    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
9344
9345    IF(config_flags%specified .or. config_flags%nested) THEN
9346      IF (degrade_xs) i_start = MAX(its-1,ids+1)
9347      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
9348      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
9349      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
9350    END IF
9351
9352    IF(config_flags%open_xs) THEN
9353      IF (degrade_xs) i_start = MAX(its-1,ids+1)
9354    END IF
9355    IF(config_flags%open_xe) THEN
9356      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
9357    END IF
9358    IF(config_flags%open_ys) THEN
9359      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
9360    END IF
9361    IF(config_flags%open_ye) THEN
9362      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
9363    END IF
9364    ! ADT note:
9365    ! We don't want to change j_start and j_end
9366    ! for polar BC's since we want to calculate
9367    ! fluxes for directions other than y at the
9368    ! edge
9369
9370 !-- here is the limiter...
9371
9372    DO j=j_start, j_end
9373    DO k=kts, ktf
9374 #ifdef XEON_SIMD
9375 !DIR$ simd
9376 #else
9377 !DIR$ vector always
9378 #endif
9379    DO i=i_start, i_end
9380
9381      ph_low(i,k,j) = ((c1(k)*mub(i,j)+c2(k))+(c1(k)*mu_old(i,j)))*field_old(i,k,j)        &
9382                 - dt*( msftx(i,j)*msfty(i,j)*(               &
9383                        rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
9384                        rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
9385                       +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
9386
9387    ENDDO
9388    ENDDO
9389    ENDDO
9390
9391    DO j=j_start, j_end
9392    DO k=kts, ktf
9393 !DIR$ vector always
9394    DO i=i_start, i_end
9395
9396      flux_out(i,k,j) = dt*( (msftx(i,j)*msfty(i,j))*(                    &
9397                                 rdx*(  max(0.,fqx (i+1,k,j))      &
9398                                       -min(0.,fqx (i  ,k,j)) )    &
9399                                +rdy*(  max(0.,fqy (i,k,j+1))      &
9400                                       -min(0.,fqy (i,k,j  )) ) )  &
9401                 +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
9402                                       -max(0.,fqz (i,k  ,j)) )   )
9403
9404    ENDDO
9405    ENDDO
9406    ENDDO
9407
9408    DO j=j_start, j_end
9409    DO k=kts, ktf
9410 !DIR$ vector always
9411    DO i=i_start, i_end
9412
9413      IF( flux_out(i,k,j) .gt. ph_low(i,k,j) ) THEN
9414
9415        scale = max(0.,ph_low(i,k,j)/(flux_out(i,k,j)+eps))
9416        IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j)
9417        IF( fqx (i  ,k,j) .lt. 0.) fqx(i  ,k,j) = scale*fqx(i  ,k,j)
9418        IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1)
9419        IF( fqy (i,k,j  ) .lt. 0.) fqy(i,k,j  ) = scale*fqy(i,k,j  )
9420 !  note: z flux is opposite sign in mass coordinate because
9421 !  vertical coordinate decreases with increasing k
9422        IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j)
9423        IF( fqz (i,k  ,j) .gt. 0.) fqz(i,k  ,j) = scale*fqz(i,k  ,j)
9424
9425      END IF
9426
9427    ENDDO
9428    ENDDO
9429    ENDDO
9430
9431    END IF
9432
9433 ! add in the pd-limited flux divergence
9434
9435   i_start = its
9436   i_end   = MIN(ite,ide-1)
9437   j_start = jts
9438   j_end   = MIN(jte,jde-1)
9439
9440   DO j = j_start, j_end
9441   DO k = kts, ktf
9442   DO i = i_start, i_end
9443
9444      tendency (i,k,j) = tendency(i,k,j)                           &
9445                             -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
9446                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
9447
9448   ENDDO
9449   ENDDO
9450   ENDDO
9451
9452 ! x flux divergence
9453 !
9454   IF(degrade_xs) i_start = MAX(its,ids+1)
9455   IF(degrade_xe) i_end   = MIN(ite,ide-2)
9456
9457   DO j = j_start, j_end
9458   DO k = kts, ktf
9459   DO i = i_start, i_end
9460
9461      ! Un-"canceled" map scale factor, ADT Eq. 48
9462      tendency (i,k,j) = tendency(i,k,j)                           &
9463                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
9464                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
9465
9466   ENDDO
9467   ENDDO
9468   ENDDO
9469
9470 ! y flux divergence
9471 !
9472   i_start = its
9473   i_end   = MIN(ite,ide-1)
9474   IF(degrade_ys) j_start = MAX(jts,jds+1)
9475   IF(degrade_ye) j_end   = MIN(jte,jde-2)
9476
9477   DO j = j_start, j_end
9478   DO k = kts, ktf
9479   DO i = i_start, i_end
9480
9481      ! Un-"canceled" map scale factor, ADT Eq. 48
9482      ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
9483      tendency (i,k,j) = tendency(i,k,j)                           &
9484                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
9485                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
9486
9487   ENDDO
9488   ENDDO
9489   ENDDO
9490
9491 END SUBROUTINE advect_scalar_wenopd
9492
9493 !----------------------------------------------------------------
9494
9495 SUBROUTINE advect_scalar_mono   ( field, field_old, tendency,    &
9496                                   h_tendency, z_tendency,        &
9497                                   ru, rv, rom, romI,             &
9498                                   c1, c2,                        &
9499                                   mut, mub, mu_old,              &
9500                                   config_flags,                  &
9501                                   tenddec,                       &
9502                                   msfux, msfuy, msfvx, msfvy,    &
9503                                   msftx, msfty,                  &
9504                                   fzm, fzp,                      &
9505                                   rdx, rdy, rdzw, dt,            &
9506                                   ids, ide, jds, jde, kds, kde,  &
9507                                   ims, ime, jms, jme, kms, kme,  &
9508                                   its, ite, jts, jte, kts, kte  )
9509
9510 !  monotonic advection option
9511 !  for scalars in WRF RK3 advection.  This version is memory intensive ->
9512 !  we save 3d arrays of x, y and z both high and low order fluxes
9513 !  (six in all).  Alternatively, we could sweep in a direction
9514 !  and lower the cost considerably.
9515
9516 !  uses the Smolarkiewicz MWR 1989 approach, with addition of first-order
9517 !  fluxes initially
9518
9519    IMPLICIT NONE
9520
9521    ! Input data
9522
9523    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
9524
9525    LOGICAL ,                 INTENT(IN   ) :: tenddec ! tendency flag
9526
9527    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
9528                                               ims, ime, jms, jme, kms, kme, &
9529                                               its, ite, jts, jte, kts, kte
9530
9531    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
9532                                                                       field_old, &
9533                                                                       ru,        &
9534                                                                       rv,        &
9535                                                                       romI,      &
9536                                                                       rom
9537
9538    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut, mub, mu_old
9539    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
9540    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(  OUT) :: h_tendency, z_tendency
9541
9542    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
9543                                                                     msfuy,  &
9544                                                                     msfvx,  &
9545                                                                     msfvy,  &
9546                                                                     msftx,  &
9547                                                                     msfty
9548
9549    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
9550                                                                   fzp,  &
9551                                                                   rdzw, &
9552                                                                   c1,   &
9553                                                                   c2
9554
9555    REAL ,                                        INTENT(IN   ) :: rdx,  &
9556                                                                   rdy,  &
9557                                                                   dt
9558
9559    ! Local data
9560
9561    INTEGER :: i, j, k, itf, jtf, ktf
9562    INTEGER :: i_start, i_end, j_start, j_end
9563    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
9564    INTEGER :: jmin, jmax, jp, jm, imin, imax
9565
9566    REAL    :: mrdx, mrdy, ub, vb, uw, vw, mu, ieva_corr
9567    REAL , DIMENSION(its:ite, kts:kte) :: vflux
9568
9569
9570 !  storage for high and low order fluxes
9571
9572    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: fqx, fqy, fqz
9573    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: fqxl, fqyl, fqzl
9574    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: qmin, qmax
9575    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: scale_in, scale_out
9576    REAL :: ph_upwind
9577
9578    INTEGER :: horz_order, vert_order
9579
9580    LOGICAL :: degrade_xs, degrade_ys
9581    LOGICAL :: degrade_xe, degrade_ye
9582
9583    INTEGER :: jp1, jp0, jtmp
9584
9585    REAL :: flux_out, ph_low, flux_in, ph_hi, scale
9586    REAL, PARAMETER :: eps=1.e-20
9587
9588
9589 ! definition of flux operators, 3rd, 4rth, 5th or 6th order
9590
9591    REAL    :: flux3, flux4, flux5, flux6, flux_upwind
9592    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
9593
9594       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
9595             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
9596
9597       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
9598            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
9599            sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
9600
9601       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
9602             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
9603             +(1./60.)*(q_ip2+q_im3)
9604
9605       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
9606            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
9607             -sign(1.,ua)*(1./60.)*(                             &
9608               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
9609
9610 !      flux_upwind(q_im1, q_i, cr ) = 0.
9611       flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
9612                                     +0.5*(1.-sign(1.,cr))*q_i
9613
9614     LOGICAL, PARAMETER :: mono_limit = .true.
9615
9616 ! set order for the advection schemes
9617
9618   ktf=MIN(kte,kde-1)
9619   horz_order = config_flags%h_sca_adv_order
9620   vert_order = config_flags%v_sca_adv_order
9621
9622   do j=jts-2,jte+2
9623   do k=kts,kte
9624   do i=its-2,ite+2
9625     qmin(i,k,j) = field_old(i,k,j)
9626     qmax(i,k,j) = field_old(i,k,j)
9627     scale_in(i,k,j) = 1.
9628     scale_out(i,k,j) = 1.
9629     fqx(i,k,j) = 0.
9630     fqy(i,k,j) = 0.
9631     fqz(i,k,j) = 0.
9632     fqxl(i,k,j) = 0.
9633     fqyl(i,k,j) = 0.
9634     fqzl(i,k,j) = 0.
9635   enddo
9636   enddo
9637   enddo
9638
9639 !  begin with horizontal flux divergence
9640 !  here is the choice of flux operators
9641
9642
9643   horizontal_order_test : IF( horz_order == 5 ) THEN
9644
9645 !  determine boundary mods for flux operators
9646 !  We degrade the flux operators from 3rd/4rth order
9647 !   to second order one gridpoint in from the boundaries for
9648 !   all boundary conditions except periodic and symmetry - these
9649 !   conditions have boundary zone data fill for correct application
9650 !   of the higher order flux stencils
9651
9652    degrade_xs = .true.
9653    degrade_xe = .true.
9654    degrade_ys = .true.
9655    degrade_ye = .true.
9656
9657    IF( config_flags%periodic_x   .or. &
9658        config_flags%symmetric_xs .or. &
9659        (its > ids+3)                ) degrade_xs = .false.
9660    IF( config_flags%periodic_x   .or. &
9661        config_flags%symmetric_xe .or. &
9662        (ite < ide-4)                ) degrade_xe = .false.
9663    IF( config_flags%periodic_y   .or. &
9664        config_flags%symmetric_ys .or. &
9665        (jts > jds+3)                ) degrade_ys = .false.
9666    IF( config_flags%periodic_y   .or. &
9667        config_flags%symmetric_ye .or. &
9668        (jte < jde-4)                ) degrade_ye = .false.
9669
9670 !--------------- y - advection first
9671
9672 !--  y flux compute; these bounds are for periodic and sym b.c.
9673
9674       ktf=MIN(kte,kde-1)
9675       i_start = its-1
9676       i_end   = MIN(ite,ide-1)+1
9677       j_start = jts-1
9678       j_end   = MIN(jte,jde-1)+1
9679       j_start_f = j_start
9680       j_end_f   = j_end+1
9681
9682 !--  modify loop bounds if open or specified
9683
9684 !  WCS 20090218
9685 !      IF(degrade_xs) i_start = its
9686 !      IF(degrade_xe) i_end   = MIN(ite,ide-1)
9687       IF(degrade_xs) i_start = MAX(its-1,ids)
9688       IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
9689
9690 !  WCS 20090218
9691 !      IF(degrade_ys) then
9692 !        j_start = MAX(jts,jds+1)
9693 !        j_start_f = jds+3
9694 !      ENDIF
9695 !
9696 !      IF(degrade_ye) then
9697 !        j_end = MIN(jte,jde-2)
9698 !        j_end_f = jde-3
9699 !      ENDIF
9700
9701       IF(degrade_ys) then
9702         j_start = MAX(jts-1,jds+1)
9703         j_start_f = jds+3
9704       ENDIF
9705
9706       IF(degrade_ye) then
9707         j_end = MIN(jte+1,jde-2)
9708         j_end_f = jde-3
9709       ENDIF
9710
9711 !  compute fluxes, 5th order
9712
9713       j_loop_y_flux_5 : DO j = j_start, j_end+1
9714
9715       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
9716
9717         DO k=kts,ktf
9718         DO i = i_start, i_end
9719
9720           vel = rv(i,k,j)
9721           cr = vel
9722           fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), vel)
9723
9724           fqy( i, k, j  ) = vel*flux5(                                  &
9725                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
9726                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
9727
9728           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
9729
9730           if(cr.gt. 0) then
9731              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
9732              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
9733           else
9734              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
9735              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
9736           end if
9737
9738         ENDDO
9739         ENDDO
9740
9741       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
9742
9743             DO k=kts,ktf
9744             DO i = i_start, i_end
9745
9746               vel = rv(i,k,j)
9747               cr = vel
9748               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
9749
9750               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
9751                      (field(i,k,j)+field(i,k,j-1))
9752
9753               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
9754
9755           if(cr.gt. 0) then
9756              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
9757              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
9758           else
9759              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
9760              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
9761           end if
9762
9763             ENDDO
9764             ENDDO
9765
9766       ELSE IF  ( j == jds+2 ) THEN  ! third of 4rth order flux 2 in from south boundary
9767
9768             DO k=kts,ktf
9769             DO i = i_start, i_end
9770
9771               vel = rv(i,k,j)
9772               cr = vel
9773               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
9774
9775               fqy( i, k, j ) = vel*flux3(              &
9776                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
9777               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
9778
9779           if(cr.gt. 0) then
9780              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
9781              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
9782           else
9783              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
9784              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
9785           end if
9786
9787             ENDDO
9788             ENDDO
9789
9790       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
9791
9792             DO k=kts,ktf
9793             DO i = i_start, i_end
9794
9795               vel = rv(i,k,j)
9796               cr = vel
9797               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
9798
9799               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
9800                      (field(i,k,j)+field(i,k,j-1))
9801               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
9802
9803           if(cr.gt. 0) then
9804              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
9805              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
9806           else
9807              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
9808              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
9809           end if
9810
9811             ENDDO
9812             ENDDO
9813
9814       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4rth order flux 2 in from north boundary
9815
9816             DO k=kts,ktf
9817             DO i = i_start, i_end
9818
9819               vel = rv(i,k,j)
9820               cr = vel
9821               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
9822
9823               fqy( i, k, j) = vel*flux3(             &
9824                    field(i,k,j-2),field(i,k,j-1),    &
9825                    field(i,k,j),field(i,k,j+1),vel )
9826               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
9827
9828           if(cr.gt. 0) then
9829              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
9830              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
9831           else
9832              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
9833              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
9834           end if
9835
9836             ENDDO
9837             ENDDO
9838
9839       ENDIF
9840
9841    ENDDO j_loop_y_flux_5
9842
9843 !  next, x flux
9844
9845 !--  these bounds are for periodic and sym conditions
9846
9847       i_start = its-1
9848       i_end   = MIN(ite,ide-1)+1
9849       i_start_f = i_start
9850       i_end_f   = i_end+1
9851
9852       j_start = jts-1
9853       j_end   = MIN(jte,jde-1)+1
9854
9855 !--  modify loop bounds for open and specified b.c
9856
9857 !  WCS 20090218
9858 !      IF(degrade_ys) j_start = jts
9859 !      IF(degrade_ye) j_end   = MIN(jte,jde-1)
9860       IF(degrade_ys) j_start = MAX(jts-1,jds)
9861       IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
9862
9863 !  WCS 20090218
9864 !      IF(degrade_xs) then
9865 !        i_start = MAX(ids+1,its)
9866 !        i_start_f = i_start+2
9867 !      ENDIF
9868
9869 !      IF(degrade_xe) then
9870 !        i_end = MIN(ide-2,ite)
9871 !        i_end_f = ide-3
9872 !      ENDIF
9873
9874       IF(degrade_xs) then
9875         i_start = MAX(ids+1,its-1)
9876         i_start_f = ids+3
9877       ENDIF
9878
9879       IF(degrade_xe) then
9880         i_end = MIN(ide-2,ite+1)
9881         i_end_f = ide-3
9882       ENDIF
9883
9884 !  compute fluxes
9885
9886       DO j = j_start, j_end
9887
9888 !  5th or 6th order flux
9889
9890         DO k=kts,ktf
9891         DO i = i_start_f, i_end_f
9892
9893           vel = ru(i,k,j)
9894           cr = vel
9895           fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9896
9897           fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
9898                                          field(i-1,k,j), field(i  ,k,j),  &
9899                                          field(i+1,k,j), field(i+2,k,j),  &
9900                                          vel                             )
9901           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9902
9903           if(cr.gt. 0) then
9904              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9905              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9906           else
9907              qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9908              qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9909           end if
9910
9911         ENDDO
9912         ENDDO
9913
9914 !  lower order fluxes close to boundaries (if not periodic or symmetric)
9915
9916 !  WCS 20090218 degrade_xs and xe recoded
9917
9918         IF( degrade_xs ) THEN
9919
9920           DO i=i_start,i_start_f-1
9921
9922             IF(i == ids+1) THEN ! second order
9923               DO k=kts,ktf
9924                 vel = ru(i,k,j)
9925                 cr = vel
9926                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9927
9928                 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
9929                        *(field(i,k,j)+field(i-1,k,j))
9930
9931                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9932
9933                 if(cr.gt. 0) then
9934                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9935                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9936                 else
9937                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9938                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9939                 end if
9940               ENDDO
9941             ENDIF
9942
9943             IF(i == ids+2) THEN  ! third order
9944               DO k=kts,ktf
9945                 vel = ru(i,k,j)
9946                 cr = vel
9947                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9948                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
9949                                           field(i  ,k,j), field(i+1,k,j),  &
9950                                           vel                             )
9951                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9952
9953                 if(cr.gt. 0) then
9954                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9955                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9956                 else
9957                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9958                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9959                 end if
9960               ENDDO
9961             ENDIF
9962
9963           ENDDO
9964
9965         ENDIF
9966
9967         IF( degrade_xe ) THEN
9968
9969           DO i = i_end_f+1, i_end+1
9970
9971             IF( i == ide-1 ) THEN ! second order flux next to the boundary
9972               DO k=kts,ktf
9973                 vel = ru(i,k,j)
9974                 cr = vel
9975                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9976                 fqx(i,k,j) = 0.5*(ru(i,k,j))      &
9977                        *(field(i,k,j)+field(i-1,k,j))
9978                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9979
9980                 if(cr.gt. 0) then
9981                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9982                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9983                 else
9984                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9985                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9986                 end if
9987               ENDDO
9988             ENDIF
9989
9990             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
9991               DO k=kts,ktf
9992                 vel = ru(i,k,j)
9993                 cr = vel
9994                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9995                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
9996                                           field(i  ,k,j), field(i+1,k,j),  &
9997                                           vel                             )
9998                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9999
10000                 if(cr.gt. 0) then
10001                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
10002                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
10003                 else
10004                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
10005                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
10006                 end if
10007               ENDDO
10008             ENDIF
10009           ENDDO
10010         ENDIF
10011
10012       ENDDO  ! enddo for outer J loop
10013
10014    ELSE
10015
10016       WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_mono, h_order not known ',horz_order
10017       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
10018
10019    ENDIF horizontal_order_test
10020
10021 !  pick up the rest of the horizontal radiation boundary conditions.
10022 !  (these are the computations that don't require 'cb'.
10023 !  first, set to index ranges
10024
10025       i_start = its
10026       i_end   = MIN(ite,ide-1)
10027       j_start = jts
10028       j_end   = MIN(jte,jde-1)
10029
10030 !  compute x (u) conditions for v, w, or scalar
10031
10032    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
10033
10034        DO j = j_start, j_end
10035        DO k = kts, ktf
10036          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
10037          tendency(its,k,j) = tendency(its,k,j)                     &
10038                - rdx*(                                             &
10039                        ub*(   field_old(its+1,k,j)                 &
10040                             - field_old(its  ,k,j)   ) +           &
10041                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
10042                                                                 )
10043        ENDDO
10044        ENDDO
10045
10046    ENDIF
10047
10048    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
10049
10050        DO j = j_start, j_end
10051        DO k = kts, ktf
10052          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
10053          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
10054                - rdx*(                                               &
10055                        ub*(  field_old(i_end  ,k,j)                  &
10056                            - field_old(i_end-1,k,j) ) +              &
10057                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
10058                                                                     )
10059        ENDDO
10060        ENDDO
10061
10062    ENDIF
10063
10064    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
10065
10066        DO i = i_start, i_end
10067        DO k = kts, ktf
10068          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
10069          tendency(i,k,jts) = tendency(i,k,jts)                     &
10070                - rdy*(                                             &
10071                        vb*(  field_old(i,k,jts+1)                  &
10072                            - field_old(i,k,jts  ) ) +              &
10073                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
10074                                                                 )
10075        ENDDO
10076        ENDDO
10077
10078    ENDIF
10079
10080    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
10081
10082        DO i = i_start, i_end
10083        DO k = kts, ktf
10084          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
10085          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
10086                - rdy*(                                               &
10087                        vb*(   field_old(i,k,j_end  )                 &
10088                             - field_old(i,k,j_end-1) ) +             &
10089                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
10090                                                                     )
10091        ENDDO
10092        ENDDO
10093
10094    ENDIF
10095
10096 !-------------------- vertical advection
10097
10098 !-- loop bounds for periodic or sym conditions
10099
10100       i_start = its-1
10101       i_end   = MIN(ite,ide-1)+1
10102       j_start = jts-1
10103       j_end   = MIN(jte,jde-1)+1
10104
10105 !-- loop bounds for open or specified conditions
10106
10107 !  WCS 20090218
10108 !    IF(degrade_xs) i_start = its
10109 !    IF(degrade_xe) i_end   = MIN(ite,ide-1)
10110 !    IF(degrade_ys) j_start = jts
10111 !    IF(degrade_ye) j_end   = MIN(jte,jde-1)
10112
10113     IF(degrade_xs) i_start = MAX(its-1,ids)
10114     IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
10115     IF(degrade_ys) j_start = MAX(jts-1,jds)
10116     IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
10117
10118
10119     vert_order_test : IF (vert_order == 3) THEN
10120
10121       DO j = j_start, j_end
10122
10123          DO i = i_start, i_end
10124            fqz(i,1,j)  = 0.
10125            fqzl(i,1,j) = 0.
10126            fqz(i,kde,j)  = 0.
10127            fqzl(i,kde,j) = 0.
10128          ENDDO
10129
10130          DO k=kts+2,ktf-1
10131          DO i = i_start, i_end
10132
10133            vel = rom(i,k,j)
10134            cr = -vel
10135            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10136
10137            fqz(i,k,j) = vel*flux3(                      &
10138                    field(i,k-2,j), field(i,k-1,j),      &
10139                    field(i,k  ,j), field(i,k+1,j),  -vel )
10140            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10141
10142           if(cr.gt. 0) then
10143              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10144              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10145           else
10146              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10147              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10148           end if
10149
10150          ENDDO
10151          ENDDO
10152
10153          DO i = i_start, i_end
10154
10155            k=kts+1
10156            vel = rom(i,k,j)
10157            cr = -vel
10158            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10159            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
10160            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10161
10162           if(cr.gt. 0) then
10163              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10164              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10165           else
10166              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10167              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10168           end if
10169
10170            k=ktf
10171            vel = rom(i,k,j)
10172            cr = -vel
10173            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10174            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
10175            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10176
10177           if(cr.gt. 0) then
10178              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10179              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10180           else
10181              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10182              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10183           end if
10184          ENDDO
10185
10186       ENDDO
10187
10188     ELSE IF (vert_order == 5) THEN
10189
10190       DO j = j_start, j_end
10191
10192          DO i = i_start, i_end
10193            fqz(i,1,j)  = 0.
10194            fqzl(i,1,j) = 0.
10195            fqz(i,kde,j)  = 0.
10196            fqzl(i,kde,j) = 0.
10197          ENDDO
10198
10199          DO k=kts+3,ktf-2
10200          DO i = i_start, i_end
10201
10202            vel = rom(i,k,j)
10203            cr = -vel
10204            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10205
10206            fqz(i,k,j) = vel*flux5(                                 &
10207                    field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
10208                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
10209            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10210
10211           if(cr.gt. 0) then
10212              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10213              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10214           else
10215              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10216              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10217           end if
10218
10219          ENDDO
10220          ENDDO
10221
10222          DO i = i_start, i_end
10223
10224            k=kts+1
10225            vel = rom(i,k,j)
10226            cr = -vel
10227            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10228            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
10229            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10230
10231           if(cr.gt. 0) then
10232              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10233              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10234           else
10235              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10236              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10237           end if
10238
10239            k=kts+2
10240            vel = rom(i,k,j)
10241            cr = -vel
10242            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10243            fqz(i,k,j)= vel*flux3(field(i,k-2,j), field(i,k-1,j),   &
10244                                  field(i,k  ,j), field(i,k+1,j), -vel )
10245            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10246
10247           if(cr.gt. 0) then
10248              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10249              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10250           else
10251              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10252              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10253           end if
10254
10255            k=ktf-1
10256            vel = rom(i,k,j)
10257            cr = -vel
10258            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10259            fqz(i,k,j)= vel*flux3( field(i,k-2,j), field(i,k-1,j),   &
10260                                   field(i,k  ,j), field(i,k+1,j), -vel )
10261            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10262
10263           if(cr.gt. 0) then
10264              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10265              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10266           else
10267              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10268              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10269           end if
10270
10271            k=ktf
10272            vel = rom(i,k,j)
10273            cr = -vel
10274            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
10275            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
10276            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
10277
10278           if(cr.gt. 0) then
10279              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
10280              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
10281           else
10282              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
10283              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
10284           end if
10285
10286          ENDDO
10287
10288       ENDDO
10289
10290    ELSE
10291
10292       WRITE (wrf_err_message,*) ' advect_scalar_mono, v_order not known ',vert_order
10293       CALL wrf_error_fatal ( wrf_err_message )
10294
10295    ENDIF vert_order_test
10296
10297    IF (mono_limit) THEN
10298
10299 ! montonic filter
10300
10301    i_start = its-1
10302    i_end   = MIN(ite,ide-1)+1
10303    j_start = jts-1
10304    j_end   = MIN(jte,jde-1)+1
10305
10306 ! WCS 20090218
10307
10308 !-- loop bounds for open or specified conditions
10309 !
10310 !   IF(degrade_xs) i_start = its
10311 !   IF(degrade_xe) i_end   = MIN(ite,ide-1)
10312 !   IF(degrade_ys) j_start = jts
10313 !   IF(degrade_ye) j_end   = MIN(jte,jde-1)
10314 !
10315 !   IF(config_flags%specified .or. config_flags%nested) THEN
10316 !     IF (degrade_xs) i_start = MAX(its,ids+1)
10317 !     IF (degrade_xe) i_end   = MIN(ite,ide-2)
10318 !     IF (degrade_ys) j_start = MAX(jts,jds+1)
10319 !     IF (degrade_ye) j_end   = MIN(jte,jde-2)
10320 !   END IF
10321 !
10322 !   IF(config_flags%open_xs) THEN
10323 !     IF (degrade_xs) i_start = MAX(its,ids+1)
10324 !   END IF
10325 !   IF(config_flags%open_xe) THEN
10326 !     IF (degrade_xe) i_end   = MIN(ite,ide-2)
10327 !   END IF
10328 !   IF(config_flags%open_ys) THEN
10329 !     IF (degrade_ys) j_start = MAX(jts,jds+1)
10330 !   END IF
10331 !   IF(config_flags%open_ye) THEN
10332 !     IF (degrade_ye) j_end   = MIN(jte,jde-2)
10333 !   END IF
10334
10335    IF(degrade_xs) i_start = MAX(its-1,ids)
10336    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
10337    IF(degrade_ys) j_start = MAX(jts-1,jds)
10338    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
10339
10340    IF(config_flags%specified .or. config_flags%nested) THEN
10341      IF (degrade_xs) i_start = MAX(its-1,ids+1)
10342      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
10343      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
10344      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
10345    END IF
10346
10347    IF(config_flags%open_xs) THEN
10348      IF (degrade_xs) i_start = MAX(its-1,ids+1)
10349    END IF
10350    IF(config_flags%open_xe) THEN
10351      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
10352    END IF
10353    IF(config_flags%open_ys) THEN
10354      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
10355    END IF
10356    IF(config_flags%open_ye) THEN
10357      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
10358    END IF
10359
10360 !-- here is the limiter...
10361
10362    DO j=j_start, j_end
10363    DO k=kts, ktf
10364    DO i=i_start, i_end
10365
10366 ! ----------------------------------------------------------------------------------------------
10367 ! IEVA
10368 ! We need to correct for the partial divergence created by the IEVA scheme.
10369 ! If there is no implicit vertical advection, this term == 1.0.
10370 ! Else, it rescales the qmax & qmin value to reflect the partial divergence present in both the
10371 ! low-order and high-order fluxes because the VV field is partioned.
10372 ! ----------------------------------------------------------------------------------------------
10373
10374      ieva_corr = (c1(k)*mut(i,j)+c2(k))+dt*msfty(i,j)*rdzw(k)*(romI(i,k+1,j)-romI(i,k,j))
10375
10376 ! ----------------------------------------------------------------------------------------------
10377
10378      ph_upwind = ((c1(k)*mub(i,j)+c2(k))+(c1(k)*mu_old(i,j)))*field_old(i,k,j)        &
10379                    - dt*( msftx(i,j)*msfty(i,j)*(               &
10380                           rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
10381                           rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
10382                          +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
10383
10384      flux_in = -dt*( (msftx(i,j)*msfty(i,j))*(                   &
10385                                rdx*(  min(0.,fqx (i+1,k,j))      &
10386                                      -max(0.,fqx (i  ,k,j)) )    &
10387                               +rdy*(  min(0.,fqy (i,k,j+1))      &
10388                                      -max(0.,fqy (i,k,j  )) ) )  &
10389                +msfty(i,j)*rdzw(k)*(  max(0.,fqz (i,k+1,j))      &
10390                                      -min(0.,fqz (i,k  ,j)) )   )
10391
10392      ph_hi = ieva_corr*qmax(i,k,j) - ph_upwind
10393
10394      IF( flux_in .gt. ph_hi ) scale_in(i,k,j) = max(0.,ph_hi/(flux_in+eps))
10395
10396
10397      flux_out = dt*( (msftx(i,j)*msfty(i,j))*(                    &
10398                                 rdx*(  max(0.,fqx (i+1,k,j))      &
10399                                       -min(0.,fqx (i  ,k,j)) )    &
10400                                +rdy*(  max(0.,fqy (i,k,j+1))      &
10401                                       -min(0.,fqy (i,k,j  )) ) )  &
10402                 +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
10403                                       -max(0.,fqz (i,k  ,j)) )   )
10404
10405      ph_low = ph_upwind - ieva_corr*qmin(i,k,j)
10406
10407      IF( flux_out .gt. ph_low ) scale_out(i,k,j) = max(0.,ph_low/(flux_out+eps))
10408
10409    ENDDO
10410    ENDDO
10411    ENDDO
10412
10413    DO j=j_start, j_end
10414    DO k=kts, ktf
10415    DO i=i_start, i_end+1
10416        IF( fqx (i,k,j) .gt. 0.) then
10417          fqx(i,k,j) = min(scale_in(i,k,j),scale_out(i-1,k,j))*fqx(i,k,j)
10418        ELSE
10419          fqx(i,k,j) = min(scale_out(i,k,j),scale_in(i-1,k,j))*fqx(i,k,j)
10420        ENDIF
10421    ENDDO
10422    ENDDO
10423    ENDDO
10424
10425    DO j=j_start, j_end+1
10426    DO k=kts, ktf
10427    DO i=i_start, i_end
10428        IF( fqy (i,k,j) .gt. 0.) then
10429          fqy(i,k,j) = min(scale_in(i,k,j),scale_out(i,k,j-1))*fqy(i,k,j)
10430        ELSE
10431          fqy(i,k,j) = min(scale_out(i,k,j),scale_in(i,k,j-1))*fqy(i,k,j)
10432        ENDIF
10433    ENDDO
10434    ENDDO
10435    ENDDO
10436
10437    DO j=j_start, j_end
10438    DO k=kts+1, ktf
10439    DO i=i_start, i_end
10440        IF( fqz (i,k,j) .lt. 0.) then
10441          fqz(i,k,j) = min(scale_in(i,k,j),scale_out(i,k-1,j))*fqz(i,k,j)
10442        ELSE
10443          fqz(i,k,j) = min(scale_out(i,k,j),scale_in(i,k-1,j))*fqz(i,k,j)
10444        ENDIF
10445    ENDDO
10446    ENDDO
10447    ENDDO
10448
10449    END IF
10450
10451 ! add in the mono-limited flux divergence
10452 ! we need to fix this for open b.c set ***********
10453
10454   i_start = its
10455   i_end   = MIN(ite,ide-1)
10456   j_start = jts
10457   j_end   = MIN(jte,jde-1)
10458
10459   DO j = j_start, j_end
10460   DO k = kts, ktf
10461   DO i = i_start, i_end
10462
10463      tendency (i,k,j) = tendency(i,k,j)                           &
10464                             -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
10465                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
10466
10467   ENDDO
10468   ENDDO
10469   ENDDO
10470
10471   IF(tenddec) THEN
10472   DO j = j_start, j_end
10473   DO k = kts, ktf
10474   DO i = i_start, i_end
10475
10476      z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
10477                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
10478
10479   ENDDO
10480   ENDDO
10481   ENDDO
10482   END IF
10483
10484 ! x flux divergence
10485 !
10486
10487 ! WCS 20090218
10488 !  IF(degrade_xs) i_start = i_start + 1
10489 !  IF(degrade_xe) i_end   = i_end   - 1
10490
10491   IF(degrade_xs) i_start = MAX(its,ids+1)
10492   IF(degrade_xe) i_end   = MIN(ite,ide-2)
10493
10494   DO j = j_start, j_end
10495   DO k = kts, ktf
10496   DO i = i_start, i_end
10497
10498      ! Un-"canceled" map scale factor, ADT Eq. 48
10499      tendency (i,k,j) = tendency(i,k,j)                           &
10500                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
10501                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
10502
10503   ENDDO
10504   ENDDO
10505   ENDDO
10506
10507   IF(tenddec) THEN
10508   DO j = j_start, j_end
10509   DO k = kts, ktf
10510   DO i = i_start, i_end
10511
10512      h_tendency (i,k,j) = 0.                                      &
10513                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
10514                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
10515
10516   ENDDO
10517   ENDDO
10518   ENDDO
10519   END IF
10520
10521 ! y flux divergence
10522 !
10523   i_start = its
10524   i_end   = MIN(ite,ide-1)
10525
10526 ! WCS 20090218
10527 !  IF(degrade_ys) j_start = j_start + 1
10528 !  IF(degrade_ye) j_end   = j_end   - 1
10529
10530   IF(degrade_ys) j_start = MAX(jts,jds+1)
10531   IF(degrade_ye) j_end   = MIN(jte,jde-2)
10532
10533   DO j = j_start, j_end
10534   DO k = kts, ktf
10535   DO i = i_start, i_end
10536
10537      ! Un-"canceled" map scale factor, ADT Eq. 48
10538      tendency (i,k,j) = tendency(i,k,j)                           &
10539                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
10540                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
10541
10542   ENDDO
10543   ENDDO
10544   ENDDO
10545
10546   IF(tenddec) THEN
10547   DO j = j_start, j_end
10548   DO k = kts, ktf
10549   DO i = i_start, i_end
10550
10551      h_tendency (i,k,j) = h_tendency (i,k,j)                      &
10552                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
10553                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
10554
10555   ENDDO
10556   ENDDO
10557   ENDDO
10558   END IF
10559
10560 END SUBROUTINE advect_scalar_mono
10561
10562 !-----------------------------------------------------------
10563
10564 #ifdef ADVECT_KERNEL
10565
10566 END MODULE advection_kernel
10567 !================================================================
10568 !================================================================
10569 PROGRAM feeder
10570    USE advection_kernel
10571    IMPLICIT NONE
10572    INTEGER , PARAMETER :: MAX_SCALARS = 1
10573    TYPE(grid_config_rec_type) :: config_flags
10574    LOGICAL :: tenddec = .false.
10575    INTEGER :: ids, ide, jds, jde, kds, kde, &
10576               ims, ime, jms, jme, kms, kme, &
10577               its, ite, jts, jte, kts, kte
10578    REAL , DIMENSION( :,:,:,: ) , ALLOCATABLE :: field,    &
10579                                                 field_old
10580    REAL , DIMENSION( :,:,: ) , ALLOCATABLE ::  ru,  &
10581                                                rv,  &
10582                                                rom, &
10583                                                romI
10584    REAL , DIMENSION( :,: ), ALLOCATABLE :: mut, mub, mu_old
10585    REAL , DIMENSION( :,:,: ), ALLOCATABLE :: tendency
10586    REAL , DIMENSION( :,:,: ), ALLOCATABLE :: h_tendency, z_tendency
10587    REAL , DIMENSION( :,: ), ALLOCATABLE :: msfux, &
10588                                            msfuy, &
10589                                            msfvx, &
10590                                            msfvy, &
10591                                            msftx, &
10592                                            msfty
10593    REAL , DIMENSION( : ), ALLOCATABLE :: fzm, &
10594                                          fzp, &
10595                                          c1, c2, &
10596                                          rdzw, znw,dnw, rdnw, dn, rdn
10597    REAL :: rdx, &
10598            rdy, &
10599            dt
10600    INTEGER :: time_step, im
10601    INTEGER :: i, j, k, n, loop
10602
10603    config_flags%scalar_adv_opt = 2
10604
10605    PRINT *,'Init dimensions'
10606    ids = 1; ide = 91; jds = 1; jde = 3; kds = 1; kde =10
10607    ims = -5; ime = 96; jms = -5; jme = 8; kms = 1; kme = 10
10608    its = 1; ite = 91; jts = 1; jte = 3; kts = 1; kte = 10
10609    PRINT *,'ALLOCATE two 4d fields'
10610    PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1)*MAX_SCALARS
10611    ALLOCATE ( field(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) )
10612    ALLOCATE ( field_old(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) )
10613    PRINT *,'ALLOCATE three 3d fields U, V, W'
10614    PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1)
10615    ALLOCATE ( ru(ims:ime , kms:kme , jms:jme ) )
10616    ALLOCATE ( rv(ims:ime , kms:kme , jms:jme ) )
10617    ALLOCATE ( rom(ims:ime , kms:kme , jms:jme ) )
10618    ALLOCATE ( romI(ims:ime , kms:kme , jms:jme ) )
10619    PRINT *,'ALLOCATE three 2d MU fields'
10620    PRINT *,(ime-ims+1)*(jme-jms+1)
10621    ALLOCATE ( mut(ims:ime , jms:jme) )
10622    ALLOCATE ( mub(ims:ime , jms:jme) )
10623    ALLOCATE ( mu_old(ims:ime , jms:jme) )
10624    PRINT *,'ALLOCATE three 3d tendency'
10625    PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1)
10626    ALLOCATE ( tendency( ims:ime , kms:kme , jms:jme ) )
10627    ALLOCATE ( h_tendency( ims:ime , kms:kme , jms:jme ) )
10628    ALLOCATE ( z_tendency( ims:ime , kms:kme , jms:jme ) )
10629    PRINT *,'ALLOCATE six 2d map factors'
10630    PRINT *,(ime-ims+1)*(jme-jms+1)
10631    ALLOCATE ( msfux( ims:ime , jms:jme ) )
10632    ALLOCATE ( msfuy( ims:ime , jms:jme ) )
10633    ALLOCATE ( msfvx( ims:ime , jms:jme ) )
10634    ALLOCATE ( msfvy( ims:ime , jms:jme ) )
10635    ALLOCATE ( msftx( ims:ime , jms:jme ) )
10636    ALLOCATE ( msfty( ims:ime , jms:jme ) )
10637    PRINT *,'ALLOCATE 1d arrays'
10638    ALLOCATE ( fzm( kms:kme ) )
10639    ALLOCATE ( fzp( kms:kme ) )
10640    ALLOCATE ( rdzw( kms:kme ) )
10641    ALLOCATE ( znw( kms:kme ) )
10642    ALLOCATE ( dnw( kms:kme ) )
10643    ALLOCATE (rdnw( kms:kme ) )
10644    ALLOCATE ( dn ( kms:kme ) )
10645    ALLOCATE (rdn ( kms:kme ) )
10646    ALLOCATE ( c1 ( kms:kme ) )
10647    ALLOCATE ( c2 ( kms:kme ) )
10648    PRINT *,'CALL init'
10649    CALL init ( config_flags)
10650    CALL tophat ( field , MAX_SCALARS ,&
10651       ids, ide, jds, jde, kds, kde, &
10652       ims, ime, jms, jme, kms, kme, &
10653       its, ite, jts, jte, kts, kte )
10654    CALL tophat ( field_old , MAX_SCALARS , &
10655       ids, ide, jds, jde, kds, kde, &
10656       ims, ime, jms, jme, kms, kme, &
10657       its, ite, jts, jte, kts, kte )
10658    h_tendency = 0
10659    z_tendency = 0
10660    mub = 1
10661    mut = 1
10662    mu_old = 0
10663    ru = 90
10664    rv = 0.
10665    rom = 0.
10666    romI = 0.
10667    msfux = 1
10668    msfuy = 1
10669    msfvx = 1
10670    msfvy = 1
10671    msftx = 1
10672    msfty = 1
10673    rdx = 1/1000.
10674    rdy = 1/1000.
10675    DO k = kts, kte
10676       znw(k) = 1 - (real(k)-kts)/(real(kte)-kts)
10677    END DO
10678    DO k = kts, kte-1
10679       rdzw(k) = 1./(znw(k)-znw(k+1))
10680    END DO
10681    DO k=1, kde-1
10682     dnw(k) = znw(k+1) - znw(k)
10683     rdnw(k) = 1./dnw(k)
10684    ENDDO
10685    DO k=2, kde-1
10686     dn(k) = 0.5*(dnw(k)+dnw(k-1))
10687     rdn(k) = 1./dn(k)
10688     fzp(k) = .5* dnw(k  )/dn(k)
10689     fzm(k) = .5* dnw(k-1)/dn(k)
10690    ENDDO
10691    DO k = kts,kte
10692       c1(k) = 1. ! This is d(B)/d(eta), so assuming no hyb coord
10693       c2(k) = 0. ! This (1 - c1)*(p00 - ptop)
10694    ENDDO
10695
10696    time_step = 5
10697    dt = time_step
10698
10699    field = field_old
10700
10701    ! Loop over advection enough times to get some meaningful timings.
10702    CALL column ( 0 , field(:,1,2,1) , its, ite )
10703    DO loop = 1 , 2000
10704       ! A representative number of times to call the advection in a time period.
10705       IF ( loop .EQ. ((loop)/200)*200 )THEN
10706       PRINT *,'LOOP over scalars',loop
10707       END IF
10708       DO im = 1 , MAX_SCALARS
10709
10710          tendency = 0
10711          CALL advect_scalar    ( field(ims,kms,jms,im), &
10712                                  field_old(ims,kms,jms,im), &
10713                                  tendency(ims,kms,jms), &
10714                                  ru, rv, rom, c1, c2,           &
10715                                  mut, time_step/3, config_flags,&
10716                                  msfux, msfuy, msfvx, msfvy,    &
10717                                  msftx, msfty,                  &
10718                                  fzm, fzp,                      &
10719                                  rdx, rdy, rdzw,                &
10720                                  ids, ide, jds, jde, kds, kde,  &
10721                                  ims, ime, jms, jme, kms, kme,  &
10722                                  its, ite, jts, jte, kts, kte  )
10723          DO n = 1 , MAX_SCALARS
10724             field(:,:,:,n) = field_old(:,:,:,n) + dt * tendency(:,:,:) / 3.
10725          END DO
10726
10727          tendency = 0
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/2, 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          DO n = 1 , MAX_SCALARS
10741             field(:,:,:,n) = field_old(:,:,:,n) + dt * tendency(:,:,:) / 2.
10742          END DO
10743
10744          tendency = 0
10745          IF      (config_flags%scalar_adv_opt .EQ. 0 ) THEN
10746             CALL advect_scalar    ( field(ims,kms,jms,im), &
10747                                     field_old(ims,kms,jms,im), &
10748                                     tendency(ims,kms,jms), &
10749                                     ru, rv, rom, c1, c2,           &
10750                                     mut, time_step, config_flags,  &
10751                                     msfux, msfuy, msfvx, msfvy,    &
10752                                     msftx, msfty,                  &
10753                                     fzm, fzp,                      &
10754                                     rdx, rdy, rdzw,                &
10755                                     ids, ide, jds, jde, kds, kde,  &
10756                                     ims, ime, jms, jme, kms, kme,  &
10757                                     its, ite, jts, jte, kts, kte  )
10758          ELSE IF (config_flags%scalar_adv_opt .EQ. 1 ) THEN
10759             CALL advect_scalar_pd ( field(ims,kms,jms,im),            &
10760                                     field_old(ims,kms,jms,im),        &
10761                                     tendency(ims,kms,jms),            &
10762                                     h_tendency(ims,kms,jms),          &
10763                                     z_tendency(ims,kms,jms),          &
10764                                     ru, rv, rom, c1, c2,              &
10765                                     mut, mub, mu_old,                 &
10766                                     time_step, config_flags, tenddec, &
10767                                     msfux, msfuy, msfvx, msfvy,       &
10768                                     msftx, msfty, fzm, fzp,           &
10769                                     rdx, rdy, rdzw,dt,                &
10770                                     ids, ide, jds, jde, kds, kde,     &
10771                                     ims, ime, jms, jme, kms, kme,     &
10772                                     its, ite, jts, jte, kts, kte )
10773          ELSE IF (config_flags%scalar_adv_opt .EQ. 2 ) THEN
10774             CALL advect_scalar_mono ( field(ims,kms,jms,im),        &
10775                                       field_old(ims,kms,jms,im),    &
10776                                       tendency(ims,kms,jms),        &
10777                                       h_tendency(ims,kms,jms),      &
10778                                       z_tendency(ims,kms,jms),      &
10779                                       ru, rv, rom, romI,            &
10780                                       c1, c2,                       &
10781                                       mut, mub, mu_old,             &
10782                                       config_flags, tenddec,        &
10783                                       msfux, msfuy, msfvx, msfvy,   &
10784                                       msftx, msfty, fzm, fzp,       &
10785                                       rdx, rdy, rdzw,dt,            &
10786                                       ids, ide, jds, jde, kds, kde, &
10787                                       ims, ime, jms, jme, kms, kme, &
10788                                       its, ite, jts, jte, kts, kte )
10789          ELSE IF (config_flags%scalar_adv_opt .EQ. 3 ) THEN
10790             CALL advect_scalar_weno ( field(ims,kms,jms,im),         &
10791                                       field_old(ims,kms,jms,im),     &
10792                                       tendency(ims,kms,jms),         &
10793                                       ru, rv, rom,                   &
10794                                       c1, c2,                        &
10795                                       mut, time_step, config_flags,  &
10796                                       msfux, msfuy, msfvx, msfvy,    &
10797                                       msftx, msfty,                  &
10798                                       fzm, fzp,                      &
10799                                       rdx, rdy, rdzw,                &
10800                                       ids, ide, jds, jde, kds, kde,  &
10801                                       ims, ime, jms, jme, kms, kme,  &
10802                                       its, ite, jts, jte, kts, kte  )
10803          ELSE IF (config_flags%scalar_adv_opt .EQ. 4 ) THEN
10804             CALL advect_scalar_wenopd ( field(ims,kms,jms,im),         &
10805                                         field_old(ims,kms,jms,im),     &
10806                                         tendency(ims,kms,jms),         &
10807                                         ru, rv, rom,                   &
10808                                         c1, c2,                        &
10809                                         mut, mub, mu_old,              &
10810                                         time_step, config_flags,       &
10811                                         msfux, msfuy, msfvx, msfvy,    &
10812                                         msftx, msfty,                  &
10813                                         fzm, fzp,                      &
10814                                         rdx, rdy, rdzw, dt,            &
10815                                         ids, ide, jds, jde, kds, kde,  &
10816                                         ims, ime, jms, jme, kms, kme,  &
10817                                         its, ite, jts, jte, kts, kte  )
10818          END IF
10819          DO n = 1 , MAX_SCALARS
10820             field(:,:,:,n) = field_old(:,:,:,n) + dt * ( tendency(:,:,:) )
10821          END DO
10822
10823          DO k = 1 , kde
10824             field    (:,k,:,:) = field    (:,2,:,:)
10825          END DO
10826
10827          field    (:,:,2,:) = field    (:,:,1,:)
10828          field    (:,:,3,:) = field    (:,:,1,:)
10829
10830          field    (ite+0,:,:,:) = field(ids+0,:,:,:)
10831          field    (ite+1,:,:,:) = field(ids+1,:,:,:)
10832          field    (ite+2,:,:,:) = field(ids+2,:,:,:)
10833          field    (ite+3,:,:,:) = field(ids+3,:,:,:)
10834          field    (ite+4,:,:,:) = field(ids+4,:,:,:)
10835          field    (ids-0,:,:,:) = field(ite-0,:,:,:)
10836          field    (ids-1,:,:,:) = field(ite-1,:,:,:)
10837          field    (ids-2,:,:,:) = field(ite-2,:,:,:)
10838          field    (ids-3,:,:,:) = field(ite-3,:,:,:)
10839          field    (ids-4,:,:,:) = field(ite-4,:,:,:)
10840
10841          field_old = field
10842
10843          IF ( loop .EQ. (loop/200)*200 ) THEN
10844             CALL column ( loop , field(:,1,2,1) , its, ite )
10845          END IF
10846       END DO
10847    END DO
10848
10849    print *,' '
10850    print *,'=============================== '
10851    print *,' '
10852    print *,'Lines to input to gnuplot'
10853    print *,' '
10854    print *,"set terminal x11"
10855    IF      (config_flags%scalar_adv_opt .EQ. 0 ) THEN
10856       print *,'set title "Scalar Advection" font ",20"'
10857    ELSE IF (config_flags%scalar_adv_opt .EQ. 1 ) THEN
10858       print *,'set title "PD Advection" font ",20"'
10859    ELSE IF (config_flags%scalar_adv_opt .EQ. 2 ) THEN
10860       print *,'set title "Mono Advection" font ",20"'
10861    ELSE IF (config_flags%scalar_adv_opt .EQ. 3 ) THEN
10862       print *,'set title "WENO Advection" font ",20"'
10863    ELSE IF (config_flags%scalar_adv_opt .EQ. 4 ) THEN
10864       print *,'set title "WENO PD Advection" font ",20"'
10865    END IF
10866    print *,"set yrange[-20:120]"
10867    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 "
10868    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 "
10869
10870 END PROGRAM feeder
10871 #endif
10872 #ifndef ADVECT_KERNEL
10873
10874 !---------------------------------------------------------------------------------
10875
10876 SUBROUTINE advect_weno_u ( u, u_old, tendency,            &
10877                         ru, rv, rom,                   &
10878                         c1, c2,                        &
10879                         mut, time_step, config_flags,  &
10880                         msfux, msfuy, msfvx, msfvy,    &
10881                         msftx, msfty,                  &
10882                         fzm, fzp,                      &
10883                         rdx, rdy, rdzw,                &
10884                         ids, ide, jds, jde, kds, kde,  &
10885                         ims, ime, jms, jme, kms, kme,  &
10886                         its, ite, jts, jte, kts, kte  )
10887
10888 !
10889 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
10890 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
10891 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
10892 !
10893
10894    IMPLICIT NONE
10895
10896    ! Input data
10897
10898    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
10899
10900    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
10901                                               ims, ime, jms, jme, kms, kme, &
10902                                               its, ite, jts, jte, kts, kte
10903
10904    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: u,     &
10905                                                                       u_old, &
10906                                                                       ru,    &
10907                                                                       rv,    &
10908                                                                       rom
10909
10910    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
10911    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
10912
10913    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
10914                                                                     msfuy,  &
10915                                                                     msfvx,  &
10916                                                                     msfvy,  &
10917                                                                     msftx,  &
10918                                                                     msfty
10919
10920    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
10921                                                                   fzp,  &
10922                                                                   rdzw, &
10923                                                                   c1,   &
10924                                                                   c2
10925
10926    REAL ,                                        INTENT(IN   ) :: rdx,  &
10927                                                                   rdy
10928    INTEGER ,                                     INTENT(IN   ) :: time_step
10929
10930    ! Local data
10931
10932    INTEGER :: i, j, k, itf, jtf, ktf
10933    INTEGER :: i_start, i_end, j_start, j_end
10934    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
10935    INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
10936    INTEGER :: jp1, jp0, jtmp
10937
10938     real            :: dir, vv
10939     real            :: ue,vs,vn,wb,wt
10940     real, parameter :: f30 =  7./12., f31 = 1./12.
10941     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
10942
10943
10944    integer kt,kb
10945
10946
10947     real               :: qim2, qim1, qi, qip1, qip2
10948     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
10949     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18
10950     integer, parameter :: pw = 2
10951
10952
10953    INTEGER :: horz_order, vert_order
10954
10955    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
10956    REAL , DIMENSION(its:ite, kts:kte) :: vflux
10957
10958
10959    REAL,  DIMENSION( its-1:ite+1, kts:kte ) :: fqx
10960    REAL,  DIMENSION( its:ite, kts:kte, 2) :: fqy
10961
10962    LOGICAL :: degrade_xs, degrade_ys
10963    LOGICAL :: degrade_xe, degrade_ye
10964
10965 ! definition of flux operators, 3rd, 4th, 5th or 6th order
10966
10967    REAL    :: flux3, flux4, flux5, flux6
10968    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
10969
10970    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                         &
10971           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
10972
10973    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                         &
10974             flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
10975             sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
10976
10977    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
10978                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)       &
10979                      +(q_ip2+q_im3) )/60.0
10980
10981    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
10982            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)     &
10983             -sign(1,time_step)*sign(1.,ua)*(                     &
10984               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
10985
10986
10987    LOGICAL :: specified
10988
10989    specified = .false.
10990    if(config_flags%specified .or. config_flags%nested) specified = .true.
10991
10992 !  set order for vertical and horzontal flux operators
10993
10994    horz_order = config_flags%h_mom_adv_order
10995    vert_order = config_flags%v_mom_adv_order
10996
10997    ktf=MIN(kte,kde-1)
10998
10999 !  begin with horizontal flux divergence
11000
11001 !   horizontal_order_test : IF( horz_order == 6 ) THEN
11002
11003 !   ELSE IF( horz_order == 5 ) THEN
11004
11005 !  5th order horizontal flux calculation
11006 !  This code is EXACTLY the same as the 6th order code
11007 !  EXCEPT the 5th order and 3rd operators are used in
11008 !  place of the 6th and 4th order operators
11009
11010 !  determine boundary mods for flux operators
11011 !  We degrade the flux operators from 3rd/4th order
11012 !   to second order one gridpoint in from the boundaries for
11013 !   all boundary conditions except periodic and symmetry - these
11014 !   conditions have boundary zone data fill for correct application
11015 !   of the higher order flux stencils
11016
11017    degrade_xs = .true.
11018    degrade_xe = .true.
11019    degrade_ys = .true.
11020    degrade_ye = .true.
11021
11022    IF( config_flags%periodic_x   .or. &
11023        config_flags%symmetric_xs .or. &
11024        (its > ids+3)                ) degrade_xs = .false.
11025    IF( config_flags%periodic_x   .or. &
11026        config_flags%symmetric_xe .or. &
11027        (ite < ide-2)                ) degrade_xe = .false.
11028    IF( config_flags%periodic_y   .or. &
11029        config_flags%symmetric_ys .or. &
11030        (jts > jds+3)                ) degrade_ys = .false.
11031    IF( config_flags%periodic_y   .or. &
11032        config_flags%symmetric_ye .or. &
11033        (jte < jde-4)                ) degrade_ye = .false.
11034
11035 !--------------- y - advection first
11036
11037       i_start = its
11038       i_end   = ite
11039       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
11040       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
11041       IF ( config_flags%periodic_x ) i_start = its
11042       IF ( config_flags%periodic_x ) i_end = ite
11043
11044       j_start = jts
11045       j_end   = MIN(jte,jde-1)
11046
11047 !  higher order flux has a 5 or 7 point stencil, so compute
11048 !  bounds so we can switch to second order flux close to the boundary
11049
11050       j_start_f = j_start
11051       j_end_f   = j_end+1
11052
11053       IF(degrade_ys) then
11054         j_start = MAX(jts,jds+1)
11055         j_start_f = jds+3
11056       ENDIF
11057
11058       IF(degrade_ye) then
11059         j_end = MIN(jte,jde-2)
11060         j_end_f = jde-3
11061       ENDIF
11062
11063       IF(config_flags%polar) j_end = MIN(jte,jde-1)
11064
11065 !  compute fluxes, 5th or 6th order
11066
11067      jp1 = 2
11068      jp0 = 1
11069
11070      j_loop_y_flux_5 : DO j = j_start, j_end+1
11071
11072       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN  ! use full stencil
11073
11074         DO k=kts,ktf
11075         DO i = i_start, i_end
11076           vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
11077
11078          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
11079             qip2 = u(i,k,j+1)
11080             qip1 = u(i,k,j  )
11081             qi   = u(i,k,j-1)
11082             qim1 = u(i,k,j-2)
11083             qim2 = u(i,k,j-3)
11084           ELSE
11085             qip2 = u(i,k,j-2)
11086             qip1 = u(i,k,j-1)
11087             qi   = u(i,k,j  )
11088             qim1 = u(i,k,j+1)
11089             qim2 = u(i,k,j+2)
11090          ENDIF
11091
11092          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11093          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11094          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11095
11096          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11097          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11098          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11099
11100          wi0 = gi0 / (eps + beta0)**pw
11101          wi1 = gi1 / (eps + beta1)**pw
11102          wi2 = gi2 / (eps + beta2)**pw
11103
11104          sumwk = wi0 + wi1 + wi2
11105
11106           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11107
11108 !          fqy( i, k, jp1 ) = vel*flux5(               &
11109 !                  u(i,k,j-3), u(i,k,j-2), u(i,k,j-1),       &
11110 !                  u(i,k,j  ), u(i,k,j+1), u(i,k,j+2),  vel )
11111         ENDDO
11112         ENDDO
11113
11114 !  we must be close to some boundary where we need to reduce the order of the stencil
11115
11116       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
11117
11118             DO k=kts,ktf
11119             DO i = i_start, i_end
11120               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))  &
11121                                      *(u(i,k,j)+u(i,k,j-1))
11122             ENDDO
11123             ENDDO
11124
11125      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
11126
11127             DO k=kts,ktf
11128             DO i = i_start, i_end
11129               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
11130               fqy( i, k, jp1 ) = vel*flux3(      &
11131                    u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel )
11132             ENDDO
11133             ENDDO
11134
11135      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
11136
11137             DO k=kts,ktf
11138             DO i = i_start, i_end
11139               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
11140                      *(u(i,k,j)+u(i,k,j-1))
11141             ENDDO
11142             ENDDO
11143
11144      ELSE IF ( j == jde-2 ) THEN  ! 3rd order flux 2 in from north boundary
11145
11146             DO k=kts,ktf
11147             DO i = i_start, i_end
11148               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
11149               fqy( i, k, jp1 ) = vel*flux3(     &
11150                    u(i,k,j-2),u(i,k,j-1),    &
11151                    u(i,k,j),u(i,k,j+1),vel )
11152             ENDDO
11153             ENDDO
11154
11155       END IF
11156
11157 !  y flux-divergence into tendency
11158
11159         ! (j > j_start) will miss the u(,,jds) tendency
11160         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
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)
11165           END DO
11166           END DO
11167         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
11168         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
11169           DO k=kts,ktf
11170           DO i = i_start, i_end
11171             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
11172             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
11173           END DO
11174           END DO
11175         ELSE  ! normal code
11176
11177         IF(j > j_start) THEN
11178
11179           DO k=kts,ktf
11180           DO i = i_start, i_end
11181             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
11182             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
11183           ENDDO
11184           ENDDO
11185
11186         ENDIF
11187
11188         END IF
11189
11190
11191         jtmp = jp1
11192         jp1 = jp0
11193         jp0 = jtmp
11194
11195    ENDDO j_loop_y_flux_5
11196
11197 !  next, x - flux divergence
11198
11199       i_start = its
11200       i_end   = ite
11201
11202       j_start = jts
11203       j_end   = MIN(jte,jde-1)
11204
11205 !  higher order flux has a 5 or 7 point stencil, so compute
11206 !  bounds so we can switch to second order flux close to the boundary
11207
11208       i_start_f = i_start
11209       i_end_f   = i_end+1
11210
11211       IF(degrade_xs) then
11212         i_start = MAX(ids+1,its)
11213         i_start_f = ids+3
11214       ENDIF
11215
11216       IF(degrade_xe) then
11217         i_end = MIN(ide-1,ite)
11218         i_end_f = ide-2
11219       ENDIF
11220
11221 !  compute fluxes
11222
11223       DO j = j_start, j_end
11224
11225 !  5th or 6th order flux
11226
11227         DO k=kts,ktf
11228         DO i = i_start_f, i_end_f
11229           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
11230
11231          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
11232             qip2 = u(i+1,k,j)
11233             qip1 = u(i,  k,j)
11234             qi   = u(i-1,k,j)
11235             qim1 = u(i-2,k,j)
11236             qim2 = u(i-3,k,j)
11237           ELSE
11238             qip2 = u(i-2,k,j)
11239             qip1 = u(i-1,k,j)
11240             qi   = u(i,  k,j)
11241             qim1 = u(i+1,k,j)
11242             qim2 = u(i+2,k,j)
11243          ENDIF
11244
11245          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11246          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11247          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11248
11249          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11250          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11251          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11252
11253          wi0 = gi0 / (eps + beta0)**pw
11254          wi1 = gi1 / (eps + beta1)**pw
11255          wi2 = gi2 / (eps + beta2)**pw
11256
11257          sumwk = wi0 + wi1 + wi2
11258
11259          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11260
11261 !          fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j),  &
11262 !                                         u(i-1,k,j), u(i  ,k,j),  &
11263 !                                         u(i+1,k,j), u(i+2,k,j),  &
11264 !                                         vel                     )
11265         ENDDO
11266         ENDDO
11267
11268 !  lower order fluxes close to boundaries (if not periodic or symmetric)
11269 !  specified uses upstream normal wind at boundaries
11270
11271         IF( degrade_xs ) THEN
11272
11273           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
11274             i = ids+1
11275             DO k=kts,ktf
11276               ub = u(i-1,k,j)
11277               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
11278               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
11279                      *(u(i,k,j)+ub)
11280             ENDDO
11281           END IF
11282
11283           i = ids+2
11284           DO k=kts,ktf
11285             vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
11286             fqx( i, k  ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
11287                                            u(i  ,k,j), u(i+1,k,j),  &
11288                                            vel                     )
11289           ENDDO
11290
11291         ENDIF
11292
11293         IF( degrade_xe ) THEN
11294
11295           IF( i_end == ide-1 ) THEN ! second order flux next to the boundary
11296             i = ide
11297             DO k=kts,ktf
11298               ub = u(i,k,j)
11299               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
11300               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
11301                      *(u(i-1,k,j)+ub)
11302             ENDDO
11303           ENDIF
11304
11305           DO k=kts,ktf
11306           i = ide-1
11307           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
11308           fqx( i,k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
11309                                          u(i  ,k,j), u(i+1,k,j),  &
11310                                          vel                     )
11311           ENDDO
11312
11313         ENDIF
11314
11315 !  x flux-divergence into tendency
11316
11317         DO k=kts,ktf
11318           DO i = i_start, i_end
11319             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
11320             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
11321           ENDDO
11322         ENDDO
11323
11324       ENDDO
11325
11326
11327 !  radiative lateral boundary condition in x for normal velocity (u)
11328
11329       IF ( (config_flags%open_xs) .and. its == ids ) THEN
11330
11331         j_start = jts
11332         j_end   = MIN(jte,jde-1)
11333
11334         DO j = j_start, j_end
11335         DO k = kts, ktf
11336           ub = MIN(ru(its,k,j)-cb*(c1(k)*mut(its,j)+c2(k)), 0.)
11337           tendency(its,k,j) = tendency(its,k,j)                    &
11338                       - rdx*ub*(u_old(its+1,k,j) - u_old(its,k,j))
11339         ENDDO
11340         ENDDO
11341
11342       ENDIF
11343
11344       IF ( (config_flags%open_xe) .and. ite == ide ) THEN
11345
11346         j_start = jts
11347         j_end   = MIN(jte,jde-1)
11348
11349         DO j = j_start, j_end
11350         DO k = kts, ktf
11351           ub = MAX(ru(ite,k,j)+cb*(c1(k)*mut(ite-1,j)+c2(k)), 0.)
11352           tendency(ite,k,j) = tendency(ite,k,j)                    &
11353                       - rdx*ub*(u_old(ite,k,j) - u_old(ite-1,k,j))
11354         ENDDO
11355         ENDDO
11356
11357       ENDIF
11358
11359 !  pick up the rest of the horizontal radiation boundary conditions.
11360 !  (these are the computations that don't require 'cb')
11361 !  first, set to index ranges
11362
11363       i_start = its
11364       i_end   = MIN(ite,ide)
11365       imin    = ids
11366       imax    = ide-1
11367
11368       IF (config_flags%open_xs) THEN
11369         i_start = MAX(ids+1, its)
11370         imin = ids
11371       ENDIF
11372       IF (config_flags%open_xe) THEN
11373         i_end = MIN(ite,ide-1)
11374         imax = ide-1
11375       ENDIF
11376
11377    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
11378
11379       DO i = i_start, i_end
11380
11381          mrdy=msfux(i,jts)*rdy       ! ADT eqn 44, 2nd term on RHS
11382          ip = MIN( imax, i   )
11383          im = MAX( imin, i-1 )
11384
11385          DO k=kts,ktf
11386
11387           vw = 0.5*(rv(ip,k,jts)+rv(im,k,jts))
11388           vb = MIN( vw, 0. )
11389           dvm =  rv(ip,k,jts+1)-rv(ip,k,jts)
11390           dvp =  rv(im,k,jts+1)-rv(im,k,jts)
11391           tendency(i,k,jts)=tendency(i,k,jts)-mrdy*(                &
11392                             vb*(u_old(i,k,jts+1)-u_old(i,k,jts))    &
11393                            +0.5*u(i,k,jts)*(dvm+dvp))
11394          ENDDO
11395       ENDDO
11396
11397    ENDIF
11398
11399    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
11400
11401       DO i = i_start, i_end
11402
11403          mrdy=msfux(i,jte-1)*rdy     ! ADT eqn 44, 2nd term on RHS
11404          ip = MIN( imax, i   )
11405          im = MAX( imin, i-1 )
11406
11407          DO k=kts,ktf
11408
11409           vw = 0.5*(rv(ip,k,jte)+rv(im,k,jte))
11410           vb = MAX( vw, 0. )
11411           dvm =  rv(ip,k,jte)-rv(ip,k,jte-1)
11412           dvp =  rv(im,k,jte)-rv(im,k,jte-1)
11413           tendency(i,k,jte-1)=tendency(i,k,jte-1)-mrdy*(              &
11414                               vb*(u_old(i,k,jte-1)-u_old(i,k,jte-2))  &
11415                              +0.5*u(i,k,jte-1)*(dvm+dvp))
11416          ENDDO
11417       ENDDO
11418
11419    ENDIF
11420
11421 !-------------------- vertical advection
11422 !  ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
11423 !  Here we have:  - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
11424 !  Since 'my' (map scale factor in y-direction) isn't a function of z,
11425 !  this is what we need, so leave unchanged in advect_u
11426
11427    i_start = its
11428    i_end   = ite
11429    j_start = jts
11430    j_end   = min(jte,jde-1)
11431
11432 !   IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
11433 !   IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
11434
11435    IF ( config_flags%open_ys .or. specified ) i_start = MAX(ids+1,its)
11436    IF ( config_flags%open_ye .or. specified ) i_end   = MIN(ide-1,ite)
11437    IF ( config_flags%periodic_x ) i_start = its
11438    IF ( config_flags%periodic_x ) i_end = ite
11439
11440    DO i = i_start, i_end
11441      vflux(i,kts)=0.
11442      vflux(i,kte)=0.
11443    ENDDO
11444
11445 !   vert_order_test : IF (vert_order == 6) THEN
11446
11447 !    ELSE IF (vert_order == 5) THEN
11448
11449       DO j = j_start, j_end
11450
11451          DO k=kts+3,ktf-2
11452          DO i = i_start, i_end
11453            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
11454
11455          IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN
11456             qip2 = u(i,k+1,j)
11457             qip1 = u(i,k  ,j)
11458             qi   = u(i,k-1,j)
11459             qim1 = u(i,k-2,j)
11460             qim2 = u(i,k-3,j)
11461           ELSE
11462             qip2 = u(i,k-2,j)
11463             qip1 = u(i,k-1,j)
11464             qi   = u(i,k  ,j)
11465             qim1 = u(i,k+1,j)
11466             qim2 = u(i,k+2,j)
11467          ENDIF
11468
11469          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11470          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11471          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11472
11473          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11474          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11475          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11476
11477          wi0 = gi0 / (eps + beta0)**pw
11478          wi1 = gi1 / (eps + beta1)**pw
11479          wi2 = gi2 / (eps + beta2)**pw
11480
11481          sumwk = wi0 + wi1 + wi2
11482
11483           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11484
11485 !           vflux(i,k) = vel*flux5(                     &
11486 !                   u(i,k-3,j), u(i,k-2,j), u(i,k-1,j),       &
11487 !                   u(i,k  ,j), u(i,k+1,j), u(i,k+2,j),  -vel )
11488          ENDDO
11489          ENDDO
11490
11491          DO i = i_start, i_end
11492
11493            k=kts+1
11494            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
11495                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
11496            k = kts+2
11497            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
11498            vflux(i,k) = vel*flux3(       &
11499                    u(i,k-2,j), u(i,k-1,j),   &
11500                    u(i,k  ,j), u(i,k+1,j), -vel )
11501            k = ktf-1
11502            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
11503            vflux(i,k) = vel*flux3(       &
11504                    u(i,k-2,j), u(i,k-1,j),   &
11505                    u(i,k  ,j), u(i,k+1,j), -vel )
11506            k=ktf
11507            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
11508                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
11509
11510          ENDDO
11511          DO k=kts,ktf
11512          DO i = i_start, i_end
11513             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
11514          ENDDO
11515          ENDDO
11516       ENDDO
11517
11518
11519 END SUBROUTINE advect_weno_u
11520
11521 !-------------------------------------------------------------------------------
11522
11523 SUBROUTINE advect_weno_v   ( v, v_old, tendency,            &
11524                         ru, rv, rom,                   &
11525                         c1, c2,                        &
11526                         mut, time_step, config_flags,  &
11527                         msfux, msfuy, msfvx, msfvy,    &
11528                         msftx, msfty,                  &
11529                         fzm, fzp,                      &
11530                         rdx, rdy, rdzw,                &
11531                         ids, ide, jds, jde, kds, kde,  &
11532                         ims, ime, jms, jme, kms, kme,  &
11533                         its, ite, jts, jte, kts, kte  )
11534
11535 !
11536 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
11537 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
11538 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
11539 !
11540
11541    IMPLICIT NONE
11542
11543    ! Input data
11544
11545    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
11546
11547    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
11548                                               ims, ime, jms, jme, kms, kme, &
11549                                               its, ite, jts, jte, kts, kte
11550
11551    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: v,     &
11552                                                                       v_old, &
11553                                                                       ru,    &
11554                                                                       rv,    &
11555                                                                       rom
11556
11557    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
11558    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
11559
11560    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
11561                                                                     msfuy,  &
11562                                                                     msfvx,  &
11563                                                                     msfvy,  &
11564                                                                     msftx,  &
11565                                                                     msfty
11566
11567    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
11568                                                                   fzp,  &
11569                                                                   rdzw, &
11570                                                                   c1,   &
11571                                                                   c2
11572
11573    REAL ,                                        INTENT(IN   ) :: rdx,  &
11574                                                                   rdy
11575    INTEGER ,                                     INTENT(IN   ) :: time_step
11576
11577
11578    ! Local data
11579
11580    INTEGER :: i, j, k, itf, jtf, ktf
11581    INTEGER :: i_start, i_end, j_start, j_end
11582    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
11583    INTEGER :: jmin, jmax, jp, jm, imin, imax
11584
11585     real            :: dir, vv
11586     real            :: ue,vs,vn,wb,wt
11587     real, parameter :: f30 =  7./12., f31 = 1./12.
11588     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
11589
11590
11591    integer kt,kb
11592
11593
11594     real               :: qim2, qim1, qi, qip1, qip2
11595     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
11596     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18
11597     integer, parameter :: pw = 2
11598
11599
11600    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
11601    REAL , DIMENSION(its:ite, kts:kte) :: vflux
11602
11603
11604    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
11605    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
11606
11607    INTEGER :: horz_order
11608    INTEGER :: vert_order
11609
11610    LOGICAL :: degrade_xs, degrade_ys
11611    LOGICAL :: degrade_xe, degrade_ye
11612
11613    INTEGER :: jp1, jp0, jtmp
11614
11615
11616 ! definition of flux operators, 3rd, 4th, 5th or 6th order
11617
11618    REAL    :: flux3, flux4, flux5, flux6
11619    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
11620
11621    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
11622           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
11623
11624    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
11625            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
11626            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
11627
11628    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
11629                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)   &
11630                      +(q_ip2+q_im3) )/60.0
11631
11632    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
11633            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
11634             -sign(1,time_step)*sign(1.,ua)*(                    &
11635               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
11636
11637
11638
11639    LOGICAL :: specified
11640
11641    specified = .false.
11642    if(config_flags%specified .or. config_flags%nested) specified = .true.
11643
11644 ! set order for the advection schemes
11645
11646    ktf=MIN(kte,kde-1)
11647    horz_order = config_flags%h_mom_adv_order
11648    vert_order = config_flags%v_mom_adv_order
11649
11650
11651 !  here is the choice of flux operators
11652
11653
11654 !   horizontal_order_test : IF( horz_order == 6 ) THEN
11655 !   ELSE IF( horz_order == 5 ) THEN
11656
11657 !  5th order horizontal flux calculation
11658 !  This code is EXACTLY the same as the 6th order code
11659 !  EXCEPT the 5th order and 3rd operators are used in
11660 !  place of the 6th and 4th order operators
11661
11662 !  determine boundary mods for flux operators
11663 !  We degrade the flux operators from 3rd/4th order
11664 !   to second order one gridpoint in from the boundaries for
11665 !   all boundary conditions except periodic and symmetry - these
11666 !   conditions have boundary zone data fill for correct application
11667 !   of the higher order flux stencils
11668
11669    degrade_xs = .true.
11670    degrade_xe = .true.
11671    degrade_ys = .true.
11672    degrade_ye = .true.
11673
11674    IF( config_flags%periodic_x   .or. &
11675        config_flags%symmetric_xs .or. &
11676        (its > ids+3)                ) degrade_xs = .false.
11677    IF( config_flags%periodic_x   .or. &
11678        config_flags%symmetric_xe .or. &
11679        (ite < ide-3)                ) degrade_xe = .false.
11680    IF( config_flags%periodic_y   .or. &
11681        config_flags%symmetric_ys .or. &
11682        (jts > jds+3)                ) degrade_ys = .false.
11683    IF( config_flags%periodic_y   .or. &
11684        config_flags%symmetric_ye .or. &
11685        (jte < jde-3)                ) degrade_ye = .false.
11686
11687 !--------------- y - advection first
11688
11689       i_start = its
11690       i_end   = MIN(ite,ide-1)
11691       j_start = jts
11692       j_end   = jte
11693
11694 !  higher order flux has a 5 or 7 point stencil, so compute
11695 !  bounds so we can switch to second order flux close to the boundary
11696
11697       j_start_f = j_start
11698       j_end_f   = j_end+1
11699
11700       IF(degrade_ys) then
11701         j_start = MAX(jts,jds+1)
11702         j_start_f = jds+3
11703       ENDIF
11704
11705       IF(degrade_ye) then
11706         j_end = MIN(jte,jde-1)
11707         j_end_f = jde-2
11708       ENDIF
11709
11710 !  compute fluxes, 5th or 6th order
11711
11712      jp1 = 2
11713      jp0 = 1
11714
11715      j_loop_y_flux_5 : DO j = j_start, j_end+1
11716
11717       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
11718
11719         DO k=kts,ktf
11720         DO i = i_start, i_end
11721           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
11722
11723          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
11724             qip2 = v(i,k,j+1)
11725             qip1 = v(i,k,j  )
11726             qi   = v(i,k,j-1)
11727             qim1 = v(i,k,j-2)
11728             qim2 = v(i,k,j-3)
11729           ELSE
11730             qip2 = v(i,k,j-2)
11731             qip1 = v(i,k,j-1)
11732             qi   = v(i,k,j  )
11733             qim1 = v(i,k,j+1)
11734             qim2 = v(i,k,j+2)
11735          ENDIF
11736
11737          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11738          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11739          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11740
11741          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11742          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11743          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11744
11745          wi0 = gi0 / (eps + beta0)**pw
11746          wi1 = gi1 / (eps + beta1)**pw
11747          wi2 = gi2 / (eps + beta2)**pw
11748
11749          sumwk = wi0 + wi1 + wi2
11750
11751           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11752
11753
11754
11755 !          fqy( i, k, jp1 ) = vel*flux5(               &
11756 !                  v(i,k,j-3), v(i,k,j-2), v(i,k,j-1),       &
11757 !                  v(i,k,j  ), v(i,k,j+1), v(i,k,j+2),  vel )
11758         ENDDO
11759         ENDDO
11760
11761 !  we must be close to some boundary where we need to reduce the order of the stencil
11762 !  specified uses upstream normal wind at boundaries
11763
11764       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
11765
11766             DO k=kts,ktf
11767             DO i = i_start, i_end
11768                 vb = v(i,k,j-1)
11769                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
11770                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
11771                                  *(v(i,k,j)+vb)
11772             ENDDO
11773             ENDDO
11774
11775      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
11776
11777             DO k=kts,ktf
11778             DO i = i_start, i_end
11779               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
11780               fqy( i, k, jp1 ) = vel*flux3(      &
11781                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
11782             ENDDO
11783             ENDDO
11784
11785
11786      ELSE IF ( j == jde ) THEN  ! 2nd order flux next to north boundary
11787
11788             DO k=kts,ktf
11789             DO i = i_start, i_end
11790                 vb = v(i,k,j)
11791                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
11792                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
11793                                  *(vb+v(i,k,j-1))
11794             ENDDO
11795             ENDDO
11796
11797      ELSE IF ( j == jde-1 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
11798
11799             DO k=kts,ktf
11800             DO i = i_start, i_end
11801               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
11802               fqy( i, k, jp1 ) = vel*flux3(     &
11803                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
11804             ENDDO
11805             ENDDO
11806
11807       END IF
11808
11809 !  y flux-divergence into tendency
11810
11811         ! Comments on polar boundary conditions
11812         ! No advection over the poles means tendencies (held from jds [S. pole]
11813         ! to jde [N pole], i.e., on v grid) must be zero at poles
11814         ! [tendency(jds) and tendency(jde)=0]
11815         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
11816           DO k=kts,ktf
11817           DO i = i_start, i_end
11818             tendency(i,k,j-1) = 0.
11819           END DO
11820           END DO
11821         ! If j_end were set to jde in a special if statement apart from
11822         ! degrade_ye, then we would hit the next conditional.  But since
11823         ! we want the tendency to be zero anyway, not looping to jde+1
11824         ! will produce the same effect.
11825         ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
11826           DO k=kts,ktf
11827           DO i = i_start, i_end
11828             tendency(i,k,j-1) = 0.
11829           END DO
11830           END DO
11831         ELSE  ! Normal code
11832
11833         IF(j > j_start) THEN
11834
11835           DO k=kts,ktf
11836           DO i = i_start, i_end
11837             mrdy=msfvy(i,j-1)*rdy    ! ADT eqn 45, 2nd term on RHS
11838             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
11839           ENDDO
11840           ENDDO
11841
11842         ENDIF
11843
11844         END IF
11845
11846         jtmp = jp1
11847         jp1 = jp0
11848         jp0 = jtmp
11849
11850    ENDDO j_loop_y_flux_5
11851
11852 !  next, x - flux divergence
11853
11854       i_start = its
11855       i_end   = MIN(ite,ide-1)
11856
11857       j_start = jts
11858       j_end   = jte
11859       ! Polar boundary conditions are like open or specified
11860       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
11861       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
11862
11863 !  higher order flux has a 5 or 7 point stencil, so compute
11864 !  bounds so we can switch to second order flux close to the boundary
11865
11866       i_start_f = i_start
11867       i_end_f   = i_end+1
11868
11869       IF(degrade_xs) then
11870         i_start = MAX(ids+1,its)
11871 !        i_start_f = i_start+2
11872         i_start_f = MIN(i_start+2,ids+3)
11873       ENDIF
11874
11875       IF(degrade_xe) then
11876         i_end = MIN(ide-2,ite)
11877         i_end_f = ide-3
11878       ENDIF
11879
11880 !  compute fluxes
11881
11882       DO j = j_start, j_end
11883
11884 !  5th or 6th order flux
11885
11886         DO k=kts,ktf
11887         DO i = i_start_f, i_end_f
11888           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
11889
11890          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
11891             qip2 = v(i+1,k,j)
11892             qip1 = v(i,  k,j)
11893             qi   = v(i-1,k,j)
11894             qim1 = v(i-2,k,j)
11895             qim2 = v(i-3,k,j)
11896           ELSE
11897             qip2 = v(i-2,k,j)
11898             qip1 = v(i-1,k,j)
11899             qi   = v(i,  k,j)
11900             qim1 = v(i+1,k,j)
11901             qim2 = v(i+2,k,j)
11902          ENDIF
11903
11904          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11905          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11906          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11907
11908          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11909          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11910          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11911
11912          wi0 = gi0 / (eps + beta0)**pw
11913          wi1 = gi1 / (eps + beta1)**pw
11914          wi2 = gi2 / (eps + beta2)**pw
11915
11916          sumwk = wi0 + wi1 + wi2
11917
11918          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11919
11920 !          fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j),  &
11921 !                                         v(i-1,k,j), v(i  ,k,j),  &
11922 !                                         v(i+1,k,j), v(i+2,k,j),  &
11923 !                                         vel                     )
11924         ENDDO
11925         ENDDO
11926
11927 !  lower order fluxes close to boundaries (if not periodic or symmetric)
11928
11929         IF( degrade_xs ) THEN
11930
11931           DO i=i_start,i_start_f-1
11932
11933             IF(i == ids+1) THEN ! second order
11934               DO k=kts,ktf
11935                 fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) &
11936                                 *(v(i,k,j)+v(i-1,k,j))
11937               ENDDO
11938             ENDIF
11939
11940             IF(i == ids+2) THEN  ! third order
11941               DO k=kts,ktf
11942                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
11943                 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
11944                                         v(i  ,k,j), v(i+1,k,j),  &
11945                                         vel                     )
11946               ENDDO
11947             ENDIF
11948
11949           ENDDO
11950
11951         ENDIF
11952
11953         IF( degrade_xe ) THEN
11954
11955           DO i = i_end_f+1, i_end+1
11956
11957             IF( i == ide-1 ) THEN ! second order flux next to the boundary
11958               DO k=kts,ktf
11959                 fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
11960                                 *(v(i_end+1,k,j)+v(i_end,k,j))
11961               ENDDO
11962             ENDIF
11963
11964             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
11965               DO k=kts,ktf
11966                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
11967                 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
11968                                         v(i  ,k,j), v(i+1,k,j),  &
11969                                         vel                     )
11970               ENDDO
11971             ENDIF
11972
11973           ENDDO
11974
11975         ENDIF
11976
11977 !  x flux-divergence into tendency
11978
11979         DO k=kts,ktf
11980           DO i = i_start, i_end
11981             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
11982             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
11983           ENDDO
11984         ENDDO
11985
11986       ENDDO
11987
11988
11989    !  Comments on polar boundary condition
11990    !  Force tendency=0 at NP and SP
11991    !  We keep setting this everywhere, but it can't hurt...
11992    IF ( config_flags%polar .AND. (jts == jds) ) THEN
11993       DO i=its,ite
11994       DO k=kts,ktf
11995          tendency(i,k,jts)=0.
11996       END DO
11997       END DO
11998    END IF
11999    IF ( config_flags%polar .AND. (jte == jde) ) THEN
12000       DO i=its,ite
12001       DO k=kts,ktf
12002          tendency(i,k,jte)=0.
12003       END DO
12004       END DO
12005    END IF
12006
12007 !  radiative lateral boundary condition in y for normal velocity (v)
12008
12009       IF ( (config_flags%open_ys) .and. jts == jds ) THEN
12010
12011         i_start = its
12012         i_end   = MIN(ite,ide-1)
12013
12014         DO i = i_start, i_end
12015         DO k = kts, ktf
12016           vb = MIN(rv(i,k,jts)-cb*(c1(k)*mut(i,jts)+c2(k)), 0.)
12017           tendency(i,k,jts) = tendency(i,k,jts)                    &
12018                       - rdy*vb*(v_old(i,k,jts+1) - v_old(i,k,jts))
12019         ENDDO
12020         ENDDO
12021
12022       ENDIF
12023
12024       IF ( (config_flags%open_ye) .and. jte == jde ) THEN
12025
12026         i_start = its
12027         i_end   = MIN(ite,ide-1)
12028
12029         DO i = i_start, i_end
12030         DO k = kts, ktf
12031           vb = MAX(rv(i,k,jte)+cb*(c1(k)*mut(i,jte-1)+c2(k)), 0.)
12032           tendency(i,k,jte) = tendency(i,k,jte)                    &
12033                       - rdy*vb*(v_old(i,k,jte) - v_old(i,k,jte-1))
12034         ENDDO
12035         ENDDO
12036
12037       ENDIF
12038
12039 !  pick up the rest of the horizontal radiation boundary conditions.
12040 !  (these are the computations that don't require 'cb'.
12041 !  first, set to index ranges
12042
12043       j_start = jts
12044       j_end   = MIN(jte,jde)
12045
12046       jmin    = jds
12047       jmax    = jde-1
12048
12049       IF (config_flags%open_ys) THEN
12050           j_start = MAX(jds+1, jts)
12051           jmin = jds
12052       ENDIF
12053       IF (config_flags%open_ye) THEN
12054           j_end = MIN(jte,jde-1)
12055           jmax = jde-1
12056       ENDIF
12057
12058 !  compute x (u) conditions for v, w, or scalar
12059
12060    IF( (config_flags%open_xs) .and. (its == ids)) THEN
12061
12062       DO j = j_start, j_end
12063
12064          mrdx=msfvy(its,j)*rdx       ! ADT eqn 45, 1st term on RHS
12065          jp = MIN( jmax, j   )
12066          jm = MAX( jmin, j-1 )
12067
12068          DO k=kts,ktf
12069
12070           uw = 0.5*(ru(its,k,jp)+ru(its,k,jm))
12071           ub = MIN( uw, 0. )
12072           dup =  ru(its+1,k,jp)-ru(its,k,jp)
12073           dum =  ru(its+1,k,jm)-ru(its,k,jm)
12074           tendency(its,k,j)=tendency(its,k,j)-mrdx*(               &
12075                             ub*(v_old(its+1,k,j)-v_old(its,k,j))   &
12076                            +0.5*v(its,k,j)*(dup+dum))
12077          ENDDO
12078       ENDDO
12079
12080    ENDIF
12081
12082    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
12083       DO j = j_start, j_end
12084
12085          mrdx=msfvy(ite-1,j)*rdx     ! ADT eqn 45, 1st term on RHS
12086          jp = MIN( jmax, j   )
12087          jm = MAX( jmin, j-1 )
12088
12089          DO k=kts,ktf
12090
12091           uw = 0.5*(ru(ite,k,jp)+ru(ite,k,jm))
12092           ub = MAX( uw, 0. )
12093           dup = ru(ite,k,jp)-ru(ite-1,k,jp)
12094           dum = ru(ite,k,jm)-ru(ite-1,k,jm)
12095
12096 !          tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
12097 !                            ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
12098 !                           +0.5*v(ite-1,k,j)*                         &
12099 !                                  ( ru(ite,k,jp)-ru(ite-1,k,jp)       &
12100 !                                   +ru(ite,k,jm)-ru(ite-1,k,jm))     )
12101           tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
12102                             ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
12103                            +0.5*v(ite-1,k,j)*(dup+dum))
12104
12105          ENDDO
12106       ENDDO
12107
12108    ENDIF
12109
12110 !-------------------- vertical advection
12111 !     ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
12112 !     Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
12113 !     We therefore need to make a correction for advect_v
12114 !     since 'my' (map scale factor in y direction) isn't a function of z,
12115 !     we can do this using *(my/mx) (see eqn. 45 for example)
12116
12117
12118     i_start = its
12119     i_end   = MIN(ite,ide-1)
12120     j_start = jts
12121     j_end   = jte
12122
12123     DO i = i_start, i_end
12124        vflux(i,kts)=0.
12125        vflux(i,kte)=0.
12126     ENDDO
12127
12128     ! Polar boundary conditions are like open or specified
12129     ! We don't want to calculate vertical v tendencies at the N or S pole
12130     IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
12131     IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
12132
12133 !    vert_order_test : IF (vert_order == 6) THEN
12134
12135 !   ELSE IF (vert_order == 5) THEN
12136
12137       DO j = j_start, j_end
12138
12139
12140          DO k=kts+3,ktf-2
12141          DO i = i_start, i_end
12142            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
12143
12144          IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN
12145             qip2 = v(i,k+1,j)
12146             qip1 = v(i,k  ,j)
12147             qi   = v(i,k-1,j)
12148             qim1 = v(i,k-2,j)
12149             qim2 = v(i,k-3,j)
12150           ELSE
12151             qip2 = v(i,k-2,j)
12152             qip1 = v(i,k-1,j)
12153             qi   = v(i,k  ,j)
12154             qim1 = v(i,k+1,j)
12155             qim2 = v(i,k+2,j)
12156          ENDIF
12157
12158          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12159          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12160          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12161
12162          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12163          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12164          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12165
12166          wi0 = gi0 / (eps + beta0)**pw
12167          wi1 = gi1 / (eps + beta1)**pw
12168          wi2 = gi2 / (eps + beta2)**pw
12169
12170          sumwk = wi0 + wi1 + wi2
12171
12172           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12173
12174
12175 !           vflux(i,k) = vel*flux5(                       &
12176 !                   v(i,k-3,j), v(i,k-2,j), v(i,k-1,j),       &
12177 !                   v(i,k  ,j), v(i,k+1,j), v(i,k+2,j),  -vel )
12178          ENDDO
12179          ENDDO
12180
12181          DO i = i_start, i_end
12182            k=kts+1
12183            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
12184                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
12185            k = kts+2
12186            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
12187            vflux(i,k) = vel*flux3(       &
12188                    v(i,k-2,j), v(i,k-1,j),   &
12189                    v(i,k  ,j), v(i,k+1,j), -vel )
12190            k = ktf-1
12191            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
12192            vflux(i,k) = vel*flux3(       &
12193                    v(i,k-2,j), v(i,k-1,j),   &
12194                    v(i,k  ,j), v(i,k+1,j), -vel )
12195            k=ktf
12196            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
12197                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
12198
12199          ENDDO
12200
12201
12202          DO k=kts,ktf
12203          DO i = i_start, i_end
12204             ! We are calculating vertical fluxes on v points,
12205             ! so we must mean msf_v_x/y variables
12206             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
12207          ENDDO
12208          ENDDO
12209
12210       ENDDO
12211
12212
12213 END SUBROUTINE advect_weno_v
12214
12215
12216 !---------------------------------------------------------------------------------
12217
12218 SUBROUTINE advect_weno_w    ( w, w_old, tendency,            &
12219                          ru, rv, rom,                   &
12220                          c1, c2,                        &
12221                          mut, time_step, config_flags,  &
12222                          msfux, msfuy, msfvx, msfvy,    &
12223                          msftx, msfty,                  &
12224                          fzm, fzp,                      &
12225                          rdx, rdy, rdzu,                &
12226                          ids, ide, jds, jde, kds, kde,  &
12227                          ims, ime, jms, jme, kms, kme,  &
12228                          its, ite, jts, jte, kts, kte  )
12229
12230 !
12231 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
12232 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
12233 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
12234 !
12235
12236    IMPLICIT NONE
12237
12238    ! Input data
12239
12240    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
12241
12242    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
12243                                               ims, ime, jms, jme, kms, kme, &
12244                                               its, ite, jts, jte, kts, kte
12245
12246    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: w,     &
12247                                                                       w_old, &
12248                                                                       ru,    &
12249                                                                       rv,    &
12250                                                                       rom
12251
12252    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
12253    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
12254
12255    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
12256                                                                     msfuy,  &
12257                                                                     msfvx,  &
12258                                                                     msfvy,  &
12259                                                                     msftx,  &
12260                                                                     msfty
12261
12262    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
12263                                                                   fzp,  &
12264                                                                   rdzu, &
12265                                                                   c1,   &
12266                                                                   c2
12267
12268    REAL ,                                        INTENT(IN   ) :: rdx,  &
12269                                                                   rdy
12270    INTEGER ,                                     INTENT(IN   ) :: time_step
12271
12272
12273    ! Local data
12274
12275    INTEGER :: i, j, k, itf, jtf, ktf
12276    INTEGER :: i_start, i_end, j_start, j_end
12277    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
12278    INTEGER :: jmin, jmax, jp, jm, imin, imax
12279
12280    REAL    :: mrdx, mrdy, ub, vb, uw, vw
12281    REAL , DIMENSION(its:ite, kts:kte) :: vflux
12282
12283     real            :: dir, vv
12284     real            :: ue,vs,vn,wb,wt
12285     real, parameter :: f30 =  7./12., f31 = 1./12.
12286     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
12287
12288
12289    integer kt,kb
12290
12291
12292     real               :: qim2, qim1, qi, qip1, qip2
12293     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
12294     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18
12295     integer, parameter :: pw = 2
12296
12297
12298
12299    INTEGER :: horz_order, vert_order
12300
12301    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
12302    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
12303
12304    LOGICAL :: degrade_xs, degrade_ys
12305    LOGICAL :: degrade_xe, degrade_ye
12306
12307    INTEGER :: jp1, jp0, jtmp
12308
12309 ! definition of flux operators, 3rd, 4th, 5th or 6th order
12310
12311    REAL    :: flux3, flux4, flux5, flux6
12312    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
12313
12314       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
12315           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
12316
12317       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
12318            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
12319            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
12320
12321       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
12322                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)      &
12323                      +(q_ip2+q_im3) )/60.0
12324
12325       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
12326            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
12327             -sign(1,time_step)*sign(1.,ua)*(                    &
12328               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
12329
12330
12331    LOGICAL :: specified
12332
12333    specified = .false.
12334    if(config_flags%specified .or. config_flags%nested) specified = .true.
12335
12336 !  set order for the advection scheme
12337
12338   ktf=MIN(kte,kde-1)
12339   horz_order = config_flags%h_sca_adv_order
12340   vert_order = config_flags%v_sca_adv_order
12341
12342 !  here is the choice of flux operators
12343
12344 !  begin with horizontal flux divergence
12345
12346 !  horizontal_order_test : IF( horz_order == 6 ) THEN
12347 ! ELSE IF (horz_order == 5 ) THEN
12348
12349 !  determine boundary mods for flux operators
12350 !  We degrade the flux operators from 3rd/4th order
12351 !   to second order one gridpoint in from the boundaries for
12352 !   all boundary conditions except periodic and symmetry - these
12353 !   conditions have boundary zone data fill for correct application
12354 !   of the higher order flux stencils
12355
12356    degrade_xs = .true.
12357    degrade_xe = .true.
12358    degrade_ys = .true.
12359    degrade_ye = .true.
12360
12361    IF( config_flags%periodic_x   .or. &
12362        config_flags%symmetric_xs .or. &
12363        (its > ids+3)                ) degrade_xs = .false.
12364    IF( config_flags%periodic_x   .or. &
12365        config_flags%symmetric_xe .or. &
12366        (ite < ide-3)                ) degrade_xe = .false.
12367    IF( config_flags%periodic_y   .or. &
12368        config_flags%symmetric_ys .or. &
12369        (jts > jds+3)                ) degrade_ys = .false.
12370    IF( config_flags%periodic_y   .or. &
12371        config_flags%symmetric_ye .or. &
12372        (jte < jde-4)                ) degrade_ye = .false.
12373
12374 !--------------- y - advection first
12375
12376       i_start = its
12377       i_end   = MIN(ite,ide-1)
12378       j_start = jts
12379       j_end   = MIN(jte,jde-1)
12380
12381 !  higher order flux has a 5 or 7 point stencil, so compute
12382 !  bounds so we can switch to second order flux close to the boundary
12383
12384       j_start_f = j_start
12385       j_end_f   = j_end+1
12386
12387       IF(degrade_ys) then
12388         j_start = MAX(jts,jds+1)
12389         j_start_f = jds+3
12390       ENDIF
12391
12392       IF(degrade_ye) then
12393         j_end = MIN(jte,jde-2)
12394         j_end_f = jde-3
12395       ENDIF
12396
12397       IF(config_flags%polar) j_end = MIN(jte,jde-1)
12398
12399 !  compute fluxes, 5th or 6th order
12400
12401      jp1 = 2
12402      jp0 = 1
12403
12404      j_loop_y_flux_5 : DO j = j_start, j_end+1
12405
12406       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
12407
12408         DO k=kts+1,ktf
12409         DO i = i_start, i_end
12410           vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
12411
12412          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
12413             qip2 = w(i,k,j+1)
12414             qip1 = w(i,k,j  )
12415             qi   = w(i,k,j-1)
12416             qim1 = w(i,k,j-2)
12417             qim2 = w(i,k,j-3)
12418           ELSE
12419             qip2 = w(i,k,j-2)
12420             qip1 = w(i,k,j-1)
12421             qi   = w(i,k,j  )
12422             qim1 = w(i,k,j+1)
12423             qim2 = w(i,k,j+2)
12424          ENDIF
12425
12426          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12427          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12428          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12429
12430          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12431          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12432          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12433
12434          wi0 = gi0 / (eps + beta0)**pw
12435          wi1 = gi1 / (eps + beta1)**pw
12436          wi2 = gi2 / (eps + beta2)**pw
12437
12438          sumwk = wi0 + wi1 + wi2
12439
12440           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12441
12442 !          fqy( i, k, jp1 ) = vel*flux5(                     &
12443 !                  w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
12444 !                  w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
12445         ENDDO
12446         ENDDO
12447
12448         k = ktf+1
12449         DO i = i_start, i_end
12450           vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
12451
12452          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
12453             qip2 = w(i,k,j+1)
12454             qip1 = w(i,k,j  )
12455             qi   = w(i,k,j-1)
12456             qim1 = w(i,k,j-2)
12457             qim2 = w(i,k,j-3)
12458           ELSE
12459             qip2 = w(i,k,j-2)
12460             qip1 = w(i,k,j-1)
12461             qi   = w(i,k,j  )
12462             qim1 = w(i,k,j+1)
12463             qim2 = w(i,k,j+2)
12464          ENDIF
12465
12466          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12467          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12468          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12469
12470          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12471          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12472          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12473
12474          wi0 = gi0 / (eps + beta0)**pw
12475          wi1 = gi1 / (eps + beta1)**pw
12476          wi2 = gi2 / (eps + beta2)**pw
12477
12478          sumwk = wi0 + wi1 + wi2
12479
12480           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12481
12482 !          fqy( i, k, jp1 ) = vel*flux5(                     &
12483 !                  w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
12484 !                  w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
12485         ENDDO
12486
12487       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
12488
12489             DO k=kts+1,ktf
12490             DO i = i_start, i_end
12491               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*          &
12492                      (w(i,k,j)+w(i,k,j-1))
12493             ENDDO
12494             ENDDO
12495
12496             k = ktf+1
12497             DO i = i_start, i_end
12498               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*          &
12499                      (w(i,k,j)+w(i,k,j-1))
12500             ENDDO
12501
12502      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
12503
12504             DO k=kts+1,ktf
12505             DO i = i_start, i_end
12506               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
12507               fqy( i, k, jp1 ) = vel*flux3(              &
12508                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
12509             ENDDO
12510             ENDDO
12511
12512             k = ktf+1
12513             DO i = i_start, i_end
12514               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
12515               fqy( i, k, jp1 ) = vel*flux3(              &
12516                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
12517             ENDDO
12518
12519      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
12520
12521             DO k=kts+1,ktf
12522             DO i = i_start, i_end
12523               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*      &
12524                      (w(i,k,j)+w(i,k,j-1))
12525             ENDDO
12526             ENDDO
12527
12528             k = ktf+1
12529             DO i = i_start, i_end
12530               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*      &
12531                      (w(i,k,j)+w(i,k,j-1))
12532             ENDDO
12533
12534      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
12535
12536             DO k=kts+1,ktf
12537             DO i = i_start, i_end
12538               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
12539               fqy( i, k, jp1 ) = vel*flux3(             &
12540                    w(i,k,j-2),w(i,k,j-1),    &
12541                    w(i,k,j),w(i,k,j+1),vel )
12542             ENDDO
12543             ENDDO
12544
12545             k = ktf+1
12546             DO i = i_start, i_end
12547               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
12548               fqy( i, k, jp1 ) = vel*flux3(             &
12549                    w(i,k,j-2),w(i,k,j-1),    &
12550                    w(i,k,j),w(i,k,j+1),vel )
12551             ENDDO
12552
12553      ENDIF
12554
12555 !  y flux-divergence into tendency
12556
12557         ! Comments for polar boundary conditions
12558         ! Same process as for advect_u - tendencies run from jds to jde-1
12559         ! (latitudes are as for u grid, longitudes are displaced)
12560         ! Therefore: flow is only from one side for points next to poles
12561         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
12562           DO k=kts+1,ktf+1
12563           DO i = i_start, i_end
12564             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
12565             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
12566           END DO
12567           END DO
12568         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
12569           DO k=kts+1,ktf+1
12570           DO i = i_start, i_end
12571             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
12572             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
12573           END DO
12574           END DO
12575         ELSE  ! normal code
12576
12577         IF(j > j_start) THEN
12578
12579           DO k=kts+1,ktf+1
12580           DO i = i_start, i_end
12581             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
12582             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
12583           ENDDO
12584           ENDDO
12585
12586        ENDIF
12587
12588         END IF
12589
12590         jtmp = jp1
12591         jp1 = jp0
12592         jp0 = jtmp
12593
12594       ENDDO j_loop_y_flux_5
12595
12596 !  next, x - flux divergence
12597
12598       i_start = its
12599       i_end   = MIN(ite,ide-1)
12600
12601       j_start = jts
12602       j_end   = MIN(jte,jde-1)
12603
12604 !  higher order flux has a 5 or 7 point stencil, so compute
12605 !  bounds so we can switch to second order flux close to the boundary
12606
12607       i_start_f = i_start
12608       i_end_f   = i_end+1
12609
12610       IF(degrade_xs) then
12611         i_start = MAX(ids+1,its)
12612 !        i_start_f = i_start+2
12613         i_start_f = MIN(i_start+2,ids+3)
12614       ENDIF
12615
12616       IF(degrade_xe) then
12617         i_end = MIN(ide-2,ite)
12618         i_end_f = ide-3
12619       ENDIF
12620
12621 !  compute fluxes
12622
12623       DO j = j_start, j_end
12624
12625 !  5th or 6th order flux
12626
12627         DO k=kts+1,ktf
12628         DO i = i_start_f, i_end_f
12629           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
12630
12631          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
12632             qip2 = w(i+1,k,j)
12633             qip1 = w(i,  k,j)
12634             qi   = w(i-1,k,j)
12635             qim1 = w(i-2,k,j)
12636             qim2 = w(i-3,k,j)
12637           ELSE
12638             qip2 = w(i-2,k,j)
12639             qip1 = w(i-1,k,j)
12640             qi   = w(i,  k,j)
12641             qim1 = w(i+1,k,j)
12642             qim2 = w(i+2,k,j)
12643          ENDIF
12644
12645          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12646          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12647          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12648
12649          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12650          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12651          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12652
12653          wi0 = gi0 / (eps + beta0)**pw
12654          wi1 = gi1 / (eps + beta1)**pw
12655          wi2 = gi2 / (eps + beta2)**pw
12656
12657          sumwk = wi0 + wi1 + wi2
12658
12659          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12660
12661 !          fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
12662 !                                  w(i-1,k,j), w(i  ,k,j),  &
12663 !                                  w(i+1,k,j), w(i+2,k,j),  &
12664 !                                  vel                     )
12665         ENDDO
12666         ENDDO
12667
12668         k = ktf+1
12669         DO i = i_start_f, i_end_f
12670           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
12671
12672          IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN
12673             qip2 = w(i+1,k,j)
12674             qip1 = w(i,  k,j)
12675             qi   = w(i-1,k,j)
12676             qim1 = w(i-2,k,j)
12677             qim2 = w(i-3,k,j)
12678           ELSE
12679             qip2 = w(i-2,k,j)
12680             qip1 = w(i-1,k,j)
12681             qi   = w(i,  k,j)
12682             qim1 = w(i+1,k,j)
12683             qim2 = w(i+2,k,j)
12684          ENDIF
12685
12686          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12687          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12688          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12689
12690          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12691          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12692          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12693
12694          wi0 = gi0 / (eps + beta0)**pw
12695          wi1 = gi1 / (eps + beta1)**pw
12696          wi2 = gi2 / (eps + beta2)**pw
12697
12698          sumwk = wi0 + wi1 + wi2
12699
12700          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12701
12702 !          fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
12703 !                                  w(i-1,k,j), w(i  ,k,j),  &
12704 !                                  w(i+1,k,j), w(i+2,k,j),  &
12705 !                                  vel                     )
12706         ENDDO
12707
12708 !  lower order fluxes close to boundaries (if not periodic or symmetric)
12709
12710         IF( degrade_xs ) THEN
12711
12712           DO i=i_start,i_start_f-1
12713
12714             IF(i == ids+1) THEN ! second order
12715               DO k=kts+1,ktf
12716                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
12717                                 *(w(i,k,j)+w(i-1,k,j))
12718               ENDDO
12719               k = ktf+1
12720               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
12721                      *(w(i,k,j)+w(i-1,k,j))
12722             ENDIF
12723
12724             IF(i == ids+2) THEN  ! third order
12725               DO k=kts+1,ktf
12726                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
12727                 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12728                                         w(i  ,k,j), w(i+1,k,j),  &
12729                                         vel                     )
12730               ENDDO
12731               k = ktf+1
12732               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
12733               fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12734                                       w(i  ,k,j), w(i+1,k,j),  &
12735                                       vel                     )
12736             END IF
12737
12738           ENDDO
12739
12740         ENDIF
12741
12742         IF( degrade_xe ) THEN
12743
12744           DO i = i_end_f+1, i_end+1
12745
12746             IF( i == ide-1 ) THEN ! second order flux next to the boundary
12747               DO k=kts+1,ktf
12748                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
12749                                   *(w(i,k,j)+w(i-1,k,j))
12750               ENDDO
12751               k = ktf+1
12752               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))      &
12753                      *(w(i,k,j)+w(i-1,k,j))
12754             ENDIF
12755
12756             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
12757               DO k=kts+1,ktf
12758                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
12759                 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12760                                         w(i  ,k,j), w(i+1,k,j),  &
12761                                         vel                     )
12762               ENDDO
12763               k = ktf+1
12764               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
12765               fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12766                                       w(i  ,k,j), w(i+1,k,j),  &
12767                                       vel                     )
12768             ENDIF
12769
12770           ENDDO
12771
12772         ENDIF
12773
12774 !  x flux-divergence into tendency
12775
12776         DO k=kts+1,ktf+1
12777           DO i = i_start, i_end
12778             mrdx=msftx(i,j)*rdx      ! see ADT eqn 46 dividing by my, 1st term RHS
12779             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
12780           ENDDO
12781         ENDDO
12782
12783       ENDDO
12784
12785
12786 !  pick up the the horizontal radiation boundary conditions.
12787 !  (these are the computations that don't require 'cb'.
12788 !  first, set to index ranges
12789
12790
12791       i_start = its
12792       i_end   = MIN(ite,ide-1)
12793       j_start = jts
12794       j_end   = MIN(jte,jde-1)
12795
12796    IF( (config_flags%open_xs) .and. (its == ids)) THEN
12797
12798        DO j = j_start, j_end
12799        DO k = kts+1, ktf
12800
12801          uw = 0.5*(fzm(k)*(ru(its,k  ,j)+ru(its+1,k  ,j)) +  &
12802                    fzp(k)*(ru(its,k-1,j)+ru(its+1,k-1,j))   )
12803          ub = MIN( uw, 0. )
12804
12805          tendency(its,k,j) = tendency(its,k,j)                     &
12806                - rdx*(                                             &
12807                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
12808                        w(its,k,j)*(                                &
12809                        fzm(k)*(ru(its+1,k  ,j)-ru(its,k  ,j))+     &
12810                        fzp(k)*(ru(its+1,k-1,j)-ru(its,k-1,j)))     &
12811                                                                   )
12812        ENDDO
12813        ENDDO
12814
12815        k = ktf+1
12816        DO j = j_start, j_end
12817
12818          uw = 0.5*( (2.-fzm(k-1))*(ru(its,k-1,j)+ru(its+1,k-1,j))   &
12819                    -fzp(k-1)*(ru(its,k-2,j)+ru(its+1,k-2,j))   )
12820          ub = MIN( uw, 0. )
12821
12822          tendency(its,k,j) = tendency(its,k,j)                     &
12823                - rdx*(                                             &
12824                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
12825                        w(its,k,j)*(                                &
12826                              (2.-fzm(k-1))*(ru(its+1,k-1,j)-ru(its,k-1,j))-  &
12827                              fzp(k-1)*(ru(its+1,k-2,j)-ru(its,k-2,j)))  &
12828                                                                   )
12829        ENDDO
12830
12831    ENDIF
12832
12833    IF( (config_flags%open_xe) .and. (ite == ide)) THEN
12834
12835        DO j = j_start, j_end
12836        DO k = kts+1, ktf
12837
12838          uw = 0.5*(fzm(k)*(ru(ite-1,k  ,j)+ru(ite,k  ,j)) +  &
12839                    fzp(k)*(ru(ite-1,k-1,j)+ru(ite,k-1,j))   )
12840          ub = MAX( uw, 0. )
12841
12842          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
12843                - rdx*(                                                 &
12844                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
12845                        w(i_end,k,j)*(                                  &
12846                             fzm(k)*(ru(ite,k  ,j)-ru(ite-1,k  ,j)) +   &
12847                             fzp(k)*(ru(ite,k-1,j)-ru(ite-1,k-1,j)))    &
12848                                                                     )
12849        ENDDO
12850        ENDDO
12851
12852        k = ktf+1
12853        DO j = j_start, j_end
12854
12855          uw = 0.5*( (2.-fzm(k-1))*(ru(ite-1,k-1,j)+ru(ite,k-1,j))    &
12856                    -fzp(k-1)*(ru(ite-1,k-2,j)+ru(ite,k-2,j))   )
12857          ub = MAX( uw, 0. )
12858
12859          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
12860                - rdx*(                                                 &
12861                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
12862                        w(i_end,k,j)*(                                  &
12863                                (2.-fzm(k-1))*(ru(ite,k-1,j)-ru(ite-1,k-1,j)) -   &
12864                                fzp(k-1)*(ru(ite,k-2,j)-ru(ite-1,k-2,j)))    &
12865                                                                     )
12866        ENDDO
12867
12868    ENDIF
12869
12870
12871    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
12872
12873        DO i = i_start, i_end
12874        DO k = kts+1, ktf
12875
12876          vw = 0.5*( fzm(k)*(rv(i,k  ,jts)+rv(i,k  ,jts+1)) +  &
12877                     fzp(k)*(rv(i,k-1,jts)+rv(i,k-1,jts+1))   )
12878          vb = MIN( vw, 0. )
12879
12880          tendency(i,k,jts) = tendency(i,k,jts)                     &
12881                - rdy*(                                             &
12882                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
12883                        w(i,k,jts)*(                                &
12884                        fzm(k)*(rv(i,k  ,jts+1)-rv(i,k  ,jts))+     &
12885                        fzp(k)*(rv(i,k-1,jts+1)-rv(i,k-1,jts)))     &
12886                                                                 )
12887        ENDDO
12888        ENDDO
12889
12890        k = ktf+1
12891        DO i = i_start, i_end
12892          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jts)+rv(i,k-1,jts+1))    &
12893                    -fzp(k-1)*(rv(i,k-2,jts)+rv(i,k-2,jts+1))   )
12894          vb = MIN( vw, 0. )
12895
12896          tendency(i,k,jts) = tendency(i,k,jts)                     &
12897                - rdy*(                                             &
12898                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
12899                        w(i,k,jts)*(                                &
12900                           (2.-fzm(k-1))*(rv(i,k-1,jts+1)-rv(i,k-1,jts))-     &
12901                           fzp(k-1)*(rv(i,k-2,jts+1)-rv(i,k-2,jts)))     &
12902                                                                 )
12903        ENDDO
12904
12905    ENDIF
12906
12907    IF( (config_flags%open_ye) .and. (jte == jde) ) THEN
12908
12909        DO i = i_start, i_end
12910        DO k = kts+1, ktf
12911
12912          vw = 0.5*( fzm(k)*(rv(i,k  ,jte-1)+rv(i,k  ,jte)) +  &
12913                     fzp(k)*(rv(i,k-1,jte-1)+rv(i,k-1,jte))   )
12914          vb = MAX( vw, 0. )
12915
12916          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
12917                - rdy*(                                                 &
12918                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
12919                        w(i,k,j_end)*(                                  &
12920                             fzm(k)*(rv(i,k  ,jte)-rv(i,k  ,jte-1))+    &
12921                             fzp(k)*(rv(i,k-1,jte)-rv(i,k-1,jte-1)))    &
12922                                                                       )
12923        ENDDO
12924        ENDDO
12925
12926        k = ktf+1
12927        DO i = i_start, i_end
12928
12929          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jte-1)+rv(i,k-1,jte))    &
12930                    -fzp(k-1)*(rv(i,k-2,jte-1)+rv(i,k-2,jte))   )
12931          vb = MAX( vw, 0. )
12932
12933          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
12934                - rdy*(                                                 &
12935                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
12936                        w(i,k,j_end)*(                                  &
12937                                (2.-fzm(k-1))*(rv(i,k-1,jte)-rv(i,k-1,jte-1))-    &
12938                                fzp(k-1)*(rv(i,k-2,jte)-rv(i,k-2,jte-1)))    &
12939                                                                       )
12940        ENDDO
12941
12942    ENDIF
12943
12944 !-------------------- vertical advection
12945 !     ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
12946 !     Here we have:  - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
12947 !     Therefore we don't need to make a correction for advect_w
12948
12949       i_start = its
12950       i_end   = MIN(ite,ide-1)
12951       j_start = jts
12952       j_end   = MIN(jte,jde-1)
12953
12954       DO i = i_start, i_end
12955          vflux(i,kts)=0.
12956          vflux(i,kte)=0.
12957       ENDDO
12958
12959 !    vert_order_test : IF (vert_order == 6) THEN
12960
12961 ! ELSE IF (vert_order == 5) THEN
12962
12963       DO j = j_start, j_end
12964
12965          DO k=kts+3,ktf-1
12966          DO i = i_start, i_end
12967            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
12968
12969          IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN
12970             qip2 = w(i,k+1,j)
12971             qip1 = w(i,k  ,j)
12972             qi   = w(i,k-1,j)
12973             qim1 = w(i,k-2,j)
12974             qim2 = w(i,k-3,j)
12975           ELSE
12976             qip2 = w(i,k-2,j)
12977             qip1 = w(i,k-1,j)
12978             qi   = w(i,k  ,j)
12979             qim1 = w(i,k+1,j)
12980             qim2 = w(i,k+2,j)
12981          ENDIF
12982
12983          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12984          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12985          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12986
12987          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12988          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12989          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12990
12991          wi0 = gi0 / (eps + beta0)**pw
12992          wi1 = gi1 / (eps + beta1)**pw
12993          wi2 = gi2 / (eps + beta2)**pw
12994
12995          sumwk = wi0 + wi1 + wi2
12996
12997           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12998
12999 !           vflux(i,k) = vel*flux5(                                   &
13000 !                   w(i,k-3,j), w(i,k-2,j), w(i,k-1,j),       &
13001 !                   w(i,k  ,j), w(i,k+1,j), w(i,k+2,j),  -vel )
13002          ENDDO
13003          ENDDO
13004
13005          DO i = i_start, i_end
13006
13007            k=kts+1
13008            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
13009
13010            k = kts+2
13011            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
13012            vflux(i,k) = vel*flux3(               &
13013                    w(i,k-2,j), w(i,k-1,j),   &
13014                    w(i,k  ,j), w(i,k+1,j), -vel )
13015            k = ktf
13016            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
13017            vflux(i,k) = vel*flux3(               &
13018                    w(i,k-2,j), w(i,k-1,j),   &
13019                    w(i,k  ,j), w(i,k+1,j), -vel )
13020
13021            k=ktf+1
13022            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
13023
13024          ENDDO
13025
13026          DO k=kts+1,ktf
13027          DO i = i_start, i_end
13028             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
13029          ENDDO
13030          ENDDO
13031
13032 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
13033          k = ktf+1
13034          DO i = i_start, i_end
13035            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
13036          ENDDO
13037
13038       ENDDO
13039
13040
13041 END SUBROUTINE advect_weno_w
13042
13043
13044 END MODULE module_advect_em
13045
13046 #endif