wrfv2_fire/dyn_em/module_advect_em.F

   1 !WRF:MODEL_LAYER:DYNAMICS
   2 !
   3 MODULE module_advect_em
   4
   5   USE module_bc
   6   USE module_model_constants
   7   USE module_wrf_error
   8
   9 CONTAINS
  10
  11 !-------------------------------------------------------------------------------
  12
  13 SUBROUTINE advect_u   ( u, u_old, tendency,            &
  14                         ru, rv, rom,                   &
  15                         mut, time_step, config_flags,  &
  16                         msfux, msfuy, msfvx, msfvy,    &
  17                         msftx, msfty,                  &
  18                         fzm, fzp,                      &
  19                         rdx, rdy, rdzw,                &
  20                         ids, ide, jds, jde, kds, kde,  &
  21                         ims, ime, jms, jme, kms, kme,  &
  22                         its, ite, jts, jte, kts, kte  )
  23
  24    IMPLICIT NONE
  25
  26    ! Input data
  27
  28    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
  29
  30    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
  31                                               ims, ime, jms, jme, kms, kme, &
  32                                               its, ite, jts, jte, kts, kte
  33
  34    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: u,     &
  35                                                                       u_old, &
  36                                                                       ru,    &
  37                                                                       rv,    &
  38                                                                       rom
  39
  40    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
  41    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
  42
  43    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
  44                                                                     msfuy,  &
  45                                                                     msfvx,  &
  46                                                                     msfvy,  &
  47                                                                     msftx,  &
  48                                                                     msfty
  49
  50    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
  51                                                                   fzp,  &
  52                                                                   rdzw
  53
  54    REAL ,                                        INTENT(IN   ) :: rdx,  &
  55                                                                   rdy
  56    INTEGER ,                                     INTENT(IN   ) :: time_step
  57
  58    ! Local data
  59
  60    INTEGER :: i, j, k, itf, jtf, ktf
  61    INTEGER :: i_start, i_end, j_start, j_end
  62    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
  63    INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
  64    INTEGER :: jp1, jp0, jtmp
  65
  66    INTEGER :: horz_order, vert_order
  67
  68    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
  69    REAL , DIMENSION(its:ite, kts:kte) :: vflux
  70
  71
  72    REAL,  DIMENSION( its-1:ite+1, kts:kte ) :: fqx
  73    REAL,  DIMENSION( its:ite, kts:kte, 2) :: fqy
  74
  75    LOGICAL :: degrade_xs, degrade_ys
  76    LOGICAL :: degrade_xe, degrade_ye
  77
  78 ! definition of flux operators, 3rd, 4th, 5th or 6th order
  79
  80    REAL    :: flux3, flux4, flux5, flux6
  81    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
  82
  83    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                         &
  84           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
  85
  86    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                         &
  87             flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
  88             sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
  89
  90    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
  91                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)       &
  92                      +(q_ip2+q_im3) )/60.0
  93
  94    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
  95            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)     &
  96             -sign(1,time_step)*sign(1.,ua)*(                     &
  97               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
  98
  99
 100    LOGICAL :: specified
 101
 102    specified = .false.
 103    if(config_flags%specified .or. config_flags%nested) specified = .true.
 104
 105 !  set order for vertical and horzontal flux operators
 106
 107    horz_order = config_flags%h_mom_adv_order
 108    vert_order = config_flags%v_mom_adv_order
 109
 110    ktf=MIN(kte,kde-1)
 111
 112 !  begin with horizontal flux divergence
 113
 114    horizontal_order_test : IF( horz_order == 6 ) THEN
 115
 116 !  determine boundary mods for flux operators
 117 !  We degrade the flux operators from 3rd/4th order
 118 !   to second order one gridpoint in from the boundaries for
 119 !   all boundary conditions except periodic and symmetry - these
 120 !   conditions have boundary zone data fill for correct application
 121 !   of the higher order flux stencils
 122
 123    degrade_xs = .true.
 124    degrade_xe = .true.
 125    degrade_ys = .true.
 126    degrade_ye = .true.
 127
 128    IF( config_flags%periodic_x   .or. &
 129        config_flags%symmetric_xs .or. &
 130        (its > ids+3)                ) degrade_xs = .false.
 131    IF( config_flags%periodic_x   .or. &
 132        config_flags%symmetric_xe .or. &
 133        (ite < ide-2)                ) degrade_xe = .false.
 134    IF( config_flags%periodic_y   .or. &
 135        config_flags%symmetric_ys .or. &
 136        (jts > jds+3)                ) degrade_ys = .false.
 137    IF( config_flags%periodic_y   .or. &
 138        config_flags%symmetric_ye .or. &
 139        (jte < jde-4)                ) degrade_ye = .false.
 140
 141 !--------------- y - advection first
 142
 143       i_start = its
 144       i_end   = ite
 145       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
 146       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
 147       IF ( config_flags%periodic_x ) i_start = its
 148       IF ( config_flags%periodic_x ) i_end = ite
 149
 150       j_start = jts
 151       j_end   = MIN(jte,jde-1)
 152
 153 !  higher order flux has a 5 or 7 point stencil, so compute
 154 !  bounds so we can switch to second order flux close to the boundary
 155
 156       j_start_f = j_start
 157       j_end_f   = j_end+1
 158
 159       IF(degrade_ys) then
 160         j_start = MAX(jts,jds+1)
 161         j_start_f = jds+3
 162       ENDIF
 163
 164       IF(degrade_ye) then
 165         j_end = MIN(jte,jde-2)
 166         j_end_f = jde-3
 167       ENDIF
 168
 169       IF(config_flags%polar) j_end = MIN(jte,jde-1)
 170
 171 !  compute fluxes, 5th or 6th order
 172
 173      jp1 = 2
 174      jp0 = 1
 175
 176      j_loop_y_flux_6 : DO j = j_start, j_end+1
 177
 178       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN  ! use full stencil
 179
 180         DO k=kts,ktf
 181         DO i = i_start, i_end
 182           vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 183           fqy( i, k, jp1 ) = vel*flux6(               &
 184                   u(i,k,j-3), u(i,k,j-2), u(i,k,j-1),       &
 185                   u(i,k,j  ), u(i,k,j+1), u(i,k,j+2),  vel )
 186         ENDDO
 187         ENDDO
 188
 189 !  we must be close to some boundary where we need to reduce the order of the stencil
 190
 191       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
 192
 193             DO k=kts,ktf
 194             DO i = i_start, i_end
 195               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))  &
 196                                      *(u(i,k,j)+u(i,k,j-1))
 197             ENDDO
 198             ENDDO
 199
 200      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
 201
 202             DO k=kts,ktf
 203             DO i = i_start, i_end
 204               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 205               fqy( i, k, jp1 ) = vel*flux4(      &
 206                    u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel )
 207             ENDDO
 208             ENDDO
 209
 210      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
 211
 212             DO k=kts,ktf
 213             DO i = i_start, i_end
 214               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
 215                      *(u(i,k,j)+u(i,k,j-1))
 216             ENDDO
 217             ENDDO
 218
 219      ELSE IF ( j == jde-2 ) THEN  ! 3rd order flux 2 in from north boundary
 220
 221             DO k=kts,ktf
 222             DO i = i_start, i_end
 223               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 224               fqy( i, k, jp1 ) = vel*flux4(     &
 225                    u(i,k,j-2),u(i,k,j-1),    &
 226                    u(i,k,j),u(i,k,j+1),vel )
 227             ENDDO
 228             ENDDO
 229
 230       END IF
 231
 232 !  y flux-divergence into tendency
 233
 234         ! (j > j_start) will miss the u(,,jds) tendency
 235         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
 236           DO k=kts,ktf
 237           DO i = i_start, i_end
 238             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 239             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
 240           END DO
 241           END DO
 242         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 243         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
 244           DO k=kts,ktf
 245           DO i = i_start, i_end
 246             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 247             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
 248           END DO
 249           END DO
 250         ELSE  ! normal code
 251
 252         IF(j > j_start) THEN
 253
 254           DO k=kts,ktf
 255           DO i = i_start, i_end
 256             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 257             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
 258           ENDDO
 259           ENDDO
 260
 261         ENDIF
 262
 263         END IF
 264
 265
 266         jtmp = jp1
 267         jp1 = jp0
 268         jp0 = jtmp
 269
 270    ENDDO j_loop_y_flux_6
 271
 272 !  next, x - flux divergence
 273
 274       i_start = its
 275       i_end   = ite
 276
 277       j_start = jts
 278       j_end   = MIN(jte,jde-1)
 279
 280 !  higher order flux has a 5 or 7 point stencil, so compute
 281 !  bounds so we can switch to second order flux close to the boundary
 282
 283       i_start_f = i_start
 284       i_end_f   = i_end+1
 285
 286       IF(degrade_xs) then
 287         i_start = MAX(ids+1,its)
 288         i_start_f = ids+3
 289       ENDIF
 290
 291       IF(degrade_xe) then
 292         i_end = MIN(ide-1,ite)
 293         i_end_f = ide-2
 294       ENDIF
 295
 296 !  compute fluxes
 297
 298       DO j = j_start, j_end
 299
 300 !  5th or 6th order flux
 301
 302         DO k=kts,ktf
 303         DO i = i_start_f, i_end_f
 304           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 305           fqx( i,k ) = vel*flux6( u(i-3,k,j), u(i-2,k,j),  &
 306                                          u(i-1,k,j), u(i  ,k,j),  &
 307                                          u(i+1,k,j), u(i+2,k,j),  &
 308                                          vel                     )
 309         ENDDO
 310         ENDDO
 311
 312 !  lower order fluxes close to boundaries (if not periodic or symmetric)
 313 !  specified uses upstream normal wind at boundaries
 314
 315         IF( degrade_xs ) THEN
 316
 317           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
 318             i = ids+1
 319             DO k=kts,ktf
 320               ub = u(i-1,k,j)
 321               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
 322               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 323                      *(u(i,k,j)+ub)
 324             ENDDO
 325           END IF
 326
 327           i = ids+2
 328           DO k=kts,ktf
 329             vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 330             fqx( i, k  ) = vel*flux4( u(i-2,k,j), u(i-1,k,j),  &
 331                                            u(i  ,k,j), u(i+1,k,j),  &
 332                                            vel                     )
 333           ENDDO
 334
 335         ENDIF
 336
 337         IF( degrade_xe ) THEN
 338
 339           IF( i_end == ide-1 ) THEN ! second order flux next to the boundary
 340             i = ide
 341             DO k=kts,ktf
 342               ub = u(i,k,j)
 343               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
 344               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 345                      *(u(i-1,k,j)+ub)
 346             ENDDO
 347           ENDIF
 348
 349           DO k=kts,ktf
 350           i = ide-1
 351           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 352           fqx( i,k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j),  &
 353                                          u(i  ,k,j), u(i+1,k,j),  &
 354                                          vel                     )
 355           ENDDO
 356
 357         ENDIF
 358
 359 !  x flux-divergence into tendency
 360
 361         DO k=kts,ktf
 362           DO i = i_start, i_end
 363             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
 364             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
 365           ENDDO
 366         ENDDO
 367
 368       ENDDO
 369
 370    ELSE IF( horz_order == 5 ) THEN
 371
 372 !  5th order horizontal flux calculation
 373 !  This code is EXACTLY the same as the 6th order code
 374 !  EXCEPT the 5th order and 3rd operators are used in
 375 !  place of the 6th and 4th order operators
 376
 377 !  determine boundary mods for flux operators
 378 !  We degrade the flux operators from 3rd/4th order
 379 !   to second order one gridpoint in from the boundaries for
 380 !   all boundary conditions except periodic and symmetry - these
 381 !   conditions have boundary zone data fill for correct application
 382 !   of the higher order flux stencils
 383
 384    degrade_xs = .true.
 385    degrade_xe = .true.
 386    degrade_ys = .true.
 387    degrade_ye = .true.
 388
 389    IF( config_flags%periodic_x   .or. &
 390        config_flags%symmetric_xs .or. &
 391        (its > ids+3)                ) degrade_xs = .false.
 392    IF( config_flags%periodic_x   .or. &
 393        config_flags%symmetric_xe .or. &
 394        (ite < ide-2)                ) degrade_xe = .false.
 395    IF( config_flags%periodic_y   .or. &
 396        config_flags%symmetric_ys .or. &
 397        (jts > jds+3)                ) degrade_ys = .false.
 398    IF( config_flags%periodic_y   .or. &
 399        config_flags%symmetric_ye .or. &
 400        (jte < jde-4)                ) degrade_ye = .false.
 401
 402 !--------------- y - advection first
 403
 404       i_start = its
 405       i_end   = ite
 406       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
 407       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
 408       IF ( config_flags%periodic_x ) i_start = its
 409       IF ( config_flags%periodic_x ) i_end = ite
 410
 411       j_start = jts
 412       j_end   = MIN(jte,jde-1)
 413
 414 !  higher order flux has a 5 or 7 point stencil, so compute
 415 !  bounds so we can switch to second order flux close to the boundary
 416
 417       j_start_f = j_start
 418       j_end_f   = j_end+1
 419
 420       IF(degrade_ys) then
 421         j_start = MAX(jts,jds+1)
 422         j_start_f = jds+3
 423       ENDIF
 424
 425       IF(degrade_ye) then
 426         j_end = MIN(jte,jde-2)
 427         j_end_f = jde-3
 428       ENDIF
 429
 430       IF(config_flags%polar) j_end = MIN(jte,jde-1)
 431
 432 !  compute fluxes, 5th or 6th order
 433
 434      jp1 = 2
 435      jp0 = 1
 436
 437      j_loop_y_flux_5 : DO j = j_start, j_end+1
 438
 439       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN  ! use full stencil
 440
 441         DO k=kts,ktf
 442         DO i = i_start, i_end
 443           vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 444           fqy( i, k, jp1 ) = vel*flux5(               &
 445                   u(i,k,j-3), u(i,k,j-2), u(i,k,j-1),       &
 446                   u(i,k,j  ), u(i,k,j+1), u(i,k,j+2),  vel )
 447         ENDDO
 448         ENDDO
 449
 450 !  we must be close to some boundary where we need to reduce the order of the stencil
 451
 452       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
 453
 454             DO k=kts,ktf
 455             DO i = i_start, i_end
 456               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))  &
 457                                      *(u(i,k,j)+u(i,k,j-1))
 458             ENDDO
 459             ENDDO
 460
 461      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
 462
 463             DO k=kts,ktf
 464             DO i = i_start, i_end
 465               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 466               fqy( i, k, jp1 ) = vel*flux3(      &
 467                    u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel )
 468             ENDDO
 469             ENDDO
 470
 471      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
 472
 473             DO k=kts,ktf
 474             DO i = i_start, i_end
 475               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
 476                      *(u(i,k,j)+u(i,k,j-1))
 477             ENDDO
 478             ENDDO
 479
 480      ELSE IF ( j == jde-2 ) THEN  ! 3rd order flux 2 in from north boundary
 481
 482             DO k=kts,ktf
 483             DO i = i_start, i_end
 484               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 485               fqy( i, k, jp1 ) = vel*flux3(     &
 486                    u(i,k,j-2),u(i,k,j-1),    &
 487                    u(i,k,j),u(i,k,j+1),vel )
 488             ENDDO
 489             ENDDO
 490
 491       END IF
 492
 493 !  y flux-divergence into tendency
 494
 495         ! (j > j_start) will miss the u(,,jds) tendency
 496         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
 497           DO k=kts,ktf
 498           DO i = i_start, i_end
 499             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 500             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
 501           END DO
 502           END DO
 503         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 504         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
 505           DO k=kts,ktf
 506           DO i = i_start, i_end
 507             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 508             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
 509           END DO
 510           END DO
 511         ELSE  ! normal code
 512
 513         IF(j > j_start) THEN
 514
 515           DO k=kts,ktf
 516           DO i = i_start, i_end
 517             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 518             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
 519           ENDDO
 520           ENDDO
 521
 522         ENDIF
 523
 524         END IF
 525
 526
 527         jtmp = jp1
 528         jp1 = jp0
 529         jp0 = jtmp
 530
 531    ENDDO j_loop_y_flux_5
 532
 533 !  next, x - flux divergence
 534
 535       i_start = its
 536       i_end   = ite
 537
 538       j_start = jts
 539       j_end   = MIN(jte,jde-1)
 540
 541 !  higher order flux has a 5 or 7 point stencil, so compute
 542 !  bounds so we can switch to second order flux close to the boundary
 543
 544       i_start_f = i_start
 545       i_end_f   = i_end+1
 546
 547       IF(degrade_xs) then
 548         i_start = MAX(ids+1,its)
 549         i_start_f = ids+3
 550       ENDIF
 551
 552       IF(degrade_xe) then
 553         i_end = MIN(ide-1,ite)
 554         i_end_f = ide-2
 555       ENDIF
 556
 557 !  compute fluxes
 558
 559       DO j = j_start, j_end
 560
 561 !  5th or 6th order flux
 562
 563         DO k=kts,ktf
 564         DO i = i_start_f, i_end_f
 565           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 566           fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j),  &
 567                                          u(i-1,k,j), u(i  ,k,j),  &
 568                                          u(i+1,k,j), u(i+2,k,j),  &
 569                                          vel                     )
 570         ENDDO
 571         ENDDO
 572
 573 !  lower order fluxes close to boundaries (if not periodic or symmetric)
 574 !  specified uses upstream normal wind at boundaries
 575
 576         IF( degrade_xs ) THEN
 577
 578           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
 579             i = ids+1
 580             DO k=kts,ktf
 581               ub = u(i-1,k,j)
 582               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
 583               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 584                      *(u(i,k,j)+ub)
 585             ENDDO
 586           END IF
 587
 588           i = ids+2
 589           DO k=kts,ktf
 590             vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 591             fqx( i, k  ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
 592                                            u(i  ,k,j), u(i+1,k,j),  &
 593                                            vel                     )
 594           ENDDO
 595
 596         ENDIF
 597
 598         IF( degrade_xe ) THEN
 599
 600           IF( i_end == ide-1 ) THEN ! second order flux next to the boundary
 601             i = ide
 602             DO k=kts,ktf
 603               ub = u(i,k,j)
 604               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
 605               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 606                      *(u(i-1,k,j)+ub)
 607             ENDDO
 608           ENDIF
 609
 610           DO k=kts,ktf
 611           i = ide-1
 612           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 613           fqx( i,k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
 614                                          u(i  ,k,j), u(i+1,k,j),  &
 615                                          vel                     )
 616           ENDDO
 617
 618         ENDIF
 619
 620 !  x flux-divergence into tendency
 621
 622         DO k=kts,ktf
 623           DO i = i_start, i_end
 624             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
 625             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
 626           ENDDO
 627         ENDDO
 628
 629       ENDDO
 630
 631    ELSE IF( horz_order == 4 ) THEN
 632
 633 !  determine boundary mods for flux operators
 634 !  We degrade the flux operators from 3rd/4th order
 635 !   to second order one gridpoint in from the boundaries for
 636 !   all boundary conditions except periodic and symmetry - these
 637 !   conditions have boundary zone data fill for correct application
 638 !   of the higher order flux stencils
 639
 640    degrade_xs = .true.
 641    degrade_xe = .true.
 642    degrade_ys = .true.
 643    degrade_ye = .true.
 644
 645    IF( config_flags%periodic_x   .or. &
 646        config_flags%symmetric_xs .or. &
 647        (its > ids+2)                ) degrade_xs = .false.
 648    IF( config_flags%periodic_x   .or. &
 649        config_flags%symmetric_xe .or. &
 650        (ite < ide-1)                ) degrade_xe = .false.
 651    IF( config_flags%periodic_y   .or. &
 652        config_flags%symmetric_ys .or. &
 653        (jts > jds+2)                ) degrade_ys = .false.
 654    IF( config_flags%periodic_y   .or. &
 655        config_flags%symmetric_ye .or. &
 656        (jte < jde-3)                ) degrade_ye = .false.
 657
 658 !--------------- x - advection first
 659
 660       i_start = its
 661       i_end   = ite
 662       j_start = jts
 663       j_end   = MIN(jte,jde-1)
 664
 665 !  3rd or 4th order flux has a 5 point stencil, so compute
 666 !  bounds so we can switch to second order flux close to the boundary
 667
 668       i_start_f = i_start
 669       i_end_f   = i_end+1
 670
 671       IF(degrade_xs) then
 672         i_start = ids+1
 673         i_start_f = i_start+1
 674       ENDIF
 675
 676       IF(degrade_xe) then
 677         i_end = ide-1
 678         i_end_f = ide-1
 679       ENDIF
 680
 681 !  compute fluxes
 682
 683       DO j = j_start, j_end
 684
 685         DO k=kts,ktf
 686         DO i = i_start_f, i_end_f
 687           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 688           fqx( i, k ) = vel*flux4( u(i-2,k,j), u(i-1,k,j),      &
 689                                    u(i  ,k,j), u(i+1,k,j), vel )
 690         ENDDO
 691         ENDDO
 692
 693 !  second order flux close to boundaries (if not periodic or symmetric)
 694 !  specified uses upstream normal wind at boundaries
 695
 696         IF( degrade_xs ) THEN
 697           i = i_start
 698           DO k=kts,ktf
 699               ub = u(i-1,k,j)
 700               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
 701               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 702                      *(u(i,k,j)+ub)
 703           ENDDO
 704         ENDIF
 705
 706         IF( degrade_xe ) THEN
 707           i = i_end+1
 708           DO k=kts,ktf
 709               ub = u(i,k,j)
 710               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
 711               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 712                      *(u(i-1,k,j)+ub)
 713           ENDDO
 714         ENDIF
 715
 716 !  x flux-divergence into tendency
 717
 718         DO k=kts,ktf
 719           DO i = i_start, i_end
 720             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
 721             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
 722           ENDDO
 723         ENDDO
 724
 725       ENDDO
 726
 727 !  y flux divergence
 728
 729       i_start = its
 730       i_end   = ite
 731       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
 732       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
 733       IF ( config_flags%periodic_x ) i_start = its
 734       IF ( config_flags%periodic_x ) i_end = ite
 735
 736       j_start = jts
 737       j_end   = MIN(jte,jde-1)
 738
 739 !  3rd or 4th order flux has a 5 point stencil, so compute
 740 !  bounds so we can switch to second order flux close to the boundary
 741
 742       j_start_f = j_start
 743       j_end_f   = j_end+1
 744
 745 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
 746       IF(degrade_ys) then
 747         j_start = jds+1
 748         j_start_f = j_start+1
 749       ENDIF
 750
 751       IF(degrade_ye) then
 752         j_end = jde-2
 753         j_end_f = jde-2
 754       ENDIF
 755
 756       IF(config_flags%polar) j_end = MIN(jte,jde-1)
 757
 758 !  j flux loop for v flux of u momentum
 759
 760      jp1 = 2
 761      jp0 = 1
 762
 763    DO j = j_start, j_end+1
 764
 765      IF ( (j < j_start_f) .and. degrade_ys) THEN
 766        DO k = kts, ktf
 767        DO i = i_start, i_end
 768          fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start))  &
 769                *(u(i,k,j_start)+u(i,k,j_start-1))
 770        ENDDO
 771        ENDDO
 772      ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
 773        DO k = kts, ktf
 774        DO i = i_start, i_end
 775          ! Assumes j>j_end_f is ONLY j_end+1 ...
 776 !         fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1))    &
 777 !                *(u(i,k,j_end+1)+u(i,k,j_end))
 778          fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
 779                 *(u(i,k,j)+u(i,k,j-1))
 780        ENDDO
 781        ENDDO
 782      ELSE
 783 !  3rd or 4th order flux
 784        DO k = kts, ktf
 785        DO i = i_start, i_end
 786          vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 787          fqy( i, k, jp1 ) = vel*flux4( u(i,k,j-2), u(i,k,j-1),  &
 788                                        u(i,k,j  ), u(i,k,j+1),  &
 789                                             vel                )
 790        ENDDO
 791        ENDDO
 792
 793      END IF
 794
 795 !  y flux-divergence into tendency
 796
 797      ! (j > j_start) will miss the u(,,jds) tendency
 798      IF ( config_flags%polar .AND. (j == jds+1) ) THEN
 799        DO k=kts,ktf
 800        DO i = i_start, i_end
 801          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 802          tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
 803        END DO
 804        END DO
 805        ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 806      ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
 807        DO k=kts,ktf
 808        DO i = i_start, i_end
 809          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
 810          tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
 811        END DO
 812        END DO
 813      ELSE  ! normal code
 814
 815      IF (j > j_start) THEN
 816
 817        DO k=kts,ktf
 818        DO i = i_start, i_end
 819           mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
 820           tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
 821        ENDDO
 822        ENDDO
 823
 824      END IF
 825
 826      END IF
 827
 828      jtmp = jp1
 829      jp1 = jp0
 830      jp0 = jtmp
 831
 832   ENDDO
 833
 834   ELSE IF ( horz_order == 3 ) THEN
 835
 836 !  As with the 5th and 6th order flux chioces, the 3rd and 4th order
 837 !  code is EXACTLY the same EXCEPT for the flux operator.
 838
 839 !  determine boundary mods for flux operators
 840 !  We degrade the flux operators from 3rd/4th order
 841 !   to second order one gridpoint in from the boundaries for
 842 !   all boundary conditions except periodic and symmetry - these
 843 !   conditions have boundary zone data fill for correct application
 844 !   of the higher order flux stencils
 845
 846    degrade_xs = .true.
 847    degrade_xe = .true.
 848    degrade_ys = .true.
 849    degrade_ye = .true.
 850
 851    IF( config_flags%periodic_x   .or. &
 852        config_flags%symmetric_xs .or. &
 853        (its > ids+2)                ) degrade_xs = .false.
 854    IF( config_flags%periodic_x   .or. &
 855        config_flags%symmetric_xe .or. &
 856        (ite < ide-1)                ) degrade_xe = .false.
 857    IF( config_flags%periodic_y   .or. &
 858        config_flags%symmetric_ys .or. &
 859        (jts > jds+2)                ) degrade_ys = .false.
 860    IF( config_flags%periodic_y   .or. &
 861        config_flags%symmetric_ye .or. &
 862        (jte < jde-3)                ) degrade_ye = .false.
 863
 864 !--------------- x - advection first
 865
 866       i_start = its
 867       i_end   = ite
 868       j_start = jts
 869       j_end   = MIN(jte,jde-1)
 870
 871 !  3rd or 4th order flux has a 5 point stencil, so compute
 872 !  bounds so we can switch to second order flux close to the boundary
 873
 874       i_start_f = i_start
 875       i_end_f   = i_end+1
 876
 877       IF(degrade_xs) then
 878         i_start = ids+1
 879         i_start_f = i_start+1
 880       ENDIF
 881
 882       IF(degrade_xe) then
 883         i_end = ide-1
 884         i_end_f = ide-1
 885       ENDIF
 886
 887 !  compute fluxes
 888
 889       DO j = j_start, j_end
 890
 891         DO k=kts,ktf
 892         DO i = i_start_f, i_end_f
 893           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
 894           fqx( i, k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),      &
 895                                    u(i  ,k,j), u(i+1,k,j), vel )
 896         ENDDO
 897         ENDDO
 898
 899 !  second order flux close to boundaries (if not periodic or symmetric)
 900 !  specified uses upstream normal wind at boundaries
 901
 902         IF( degrade_xs ) THEN
 903           i = i_start
 904           DO k=kts,ktf
 905               ub = u(i-1,k,j)
 906               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
 907               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 908                      *(u(i,k,j)+ub)
 909           ENDDO
 910         ENDIF
 911
 912         IF( degrade_xe ) THEN
 913           i = i_end+1
 914           DO k=kts,ktf
 915               ub = u(i,k,j)
 916               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
 917               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
 918                      *(u(i-1,k,j)+ub)
 919           ENDDO
 920         ENDIF
 921
 922 !  x flux-divergence into tendency
 923
 924         DO k=kts,ktf
 925           DO i = i_start, i_end
 926           mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
 927             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
 928           ENDDO
 929         ENDDO
 930       ENDDO
 931
 932 !  y flux divergence
 933
 934       i_start = its
 935       i_end   = ite
 936       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
 937       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
 938       IF ( config_flags%periodic_x ) i_start = its
 939       IF ( config_flags%periodic_x ) i_end = ite
 940
 941       j_start = jts
 942       j_end   = MIN(jte,jde-1)
 943
 944 !  3rd or 4th order flux has a 5 point stencil, so compute
 945 !  bounds so we can switch to second order flux close to the boundary
 946
 947       j_start_f = j_start
 948       j_end_f   = j_end+1
 949
 950 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
 951       IF(degrade_ys) then
 952         j_start = jds+1
 953         j_start_f = j_start+1
 954       ENDIF
 955
 956       IF(degrade_ye) then
 957         j_end = jde-2
 958         j_end_f = jde-2
 959       ENDIF
 960
 961       IF(config_flags%polar) j_end = MIN(jte,jde-1)
 962
 963 !  j flux loop for v flux of u momentum
 964
 965      jp1 = 2
 966      jp0 = 1
 967
 968    DO j = j_start, j_end+1
 969
 970      IF ( (j < j_start_f) .and. degrade_ys) THEN
 971        DO k = kts, ktf
 972        DO i = i_start, i_end
 973          fqy(i, k, jp1) = 0.25*(rv(i,k,j_start)+rv(i-1,k,j_start))  &
 974                *(u(i,k,j_start)+u(i,k,j_start-1))
 975        ENDDO
 976        ENDDO
 977      ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
 978        DO k = kts, ktf
 979        DO i = i_start, i_end
 980          ! Assumes j>j_end_f is ONLY j_end+1 ...
 981 !         fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1))    &
 982 !                *(u(i,k,j_end+1)+u(i,k,j_end))
 983          fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
 984                 *(u(i,k,j)+u(i,k,j-1))
 985        ENDDO
 986        ENDDO
 987      ELSE
 988 !  3rd or 4th order flux
 989        DO k = kts, ktf
 990        DO i = i_start, i_end
 991          vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
 992          fqy( i, k, jp1 ) = vel*flux3( u(i,k,j-2), u(i,k,j-1),  &
 993                                        u(i,k,j  ), u(i,k,j+1),  &
 994                                             vel                )
 995        ENDDO
 996        ENDDO
 997
 998      END IF
 999
1000 !  y flux-divergence into tendency
1001
1002      ! (j > j_start) will miss the u(,,jds) tendency
1003      IF ( config_flags%polar .AND. (j == jds+1) ) THEN
1004        DO k=kts,ktf
1005        DO i = i_start, i_end
1006          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
1007          tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
1008        END DO
1009        END DO
1010        ! This would be seen by (j > j_start) but we need to zero out the NP tendency
1011      ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
1012        DO k=kts,ktf
1013        DO i = i_start, i_end
1014          mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
1015          tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
1016        END DO
1017        END DO
1018      ELSE  ! normal code
1019
1020      IF (j > j_start) THEN
1021
1022        DO k=kts,ktf
1023        DO i = i_start, i_end
1024           mrdy=msfux(i,j-1)*rdy      ! ADT eqn 44, 2nd term on RHS
1025           tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
1026        ENDDO
1027        ENDDO
1028
1029      END IF
1030
1031      END IF
1032
1033      jtmp = jp1
1034      jp1 = jp0
1035      jp0 = jtmp
1036
1037   ENDDO
1038
1039   ELSE IF ( horz_order == 2 ) THEN
1040
1041       i_start = its
1042       i_end   = ite
1043       j_start = jts
1044       j_end   = MIN(jte,jde-1)
1045
1046       IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
1047       IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
1048       IF ( specified ) i_start = MAX(ids+2,its)
1049       IF ( specified ) i_end   = MIN(ide-2,ite)
1050       IF ( config_flags%periodic_x ) i_start = its
1051       IF ( config_flags%periodic_x ) i_end = ite
1052
1053       DO j = j_start, j_end
1054       DO k=kts,ktf
1055       DO i = i_start, i_end
1056          mrdx=msfux(i,j)*rdx         ! ADT eqn 44, 1st term on RHS
1057          tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1058                 *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) &
1059                 -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j)))
1060       ENDDO
1061       ENDDO
1062       ENDDO
1063
1064       IF ( specified .AND. its .LE. ids+1 .AND. .NOT. config_flags%periodic_x ) THEN
1065         DO j = j_start, j_end
1066         DO k=kts,ktf
1067            i = ids+1
1068            mrdx=msfux(i,j)*rdx       ! ADT eqn 44, 1st term on RHS
1069            ub = u(i-1,k,j)
1070            IF (u(i,k,j) .LT. 0.) ub = u(i,k,j)
1071            tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1072                   *((ru(i+1,k,j)+ru(i,k,j))*(u(i+1,k,j)+u(i,k,j)) &
1073                   -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+ub))
1074         ENDDO
1075         ENDDO
1076       ENDIF
1077       IF ( specified .AND. ite .GE. ide-1 .AND. .NOT. config_flags%periodic_x ) THEN
1078         DO j = j_start, j_end
1079         DO k=kts,ktf
1080            i = ide-1
1081            mrdx=msfux(i,j)*rdx       ! ADT eqn 44, 1st term on RHS
1082            ub = u(i+1,k,j)
1083            IF (u(i,k,j) .GT. 0.) ub = u(i,k,j)
1084            tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
1085                   *((ru(i+1,k,j)+ru(i,k,j))*(ub+u(i,k,j)) &
1086                   -(ru(i,k,j)+ru(i-1,k,j))*(u(i,k,j)+u(i-1,k,j)))
1087         ENDDO
1088         ENDDO
1089       ENDIF
1090
1091       IF ( config_flags%open_ys .or. specified ) j_start = MAX(jds+1,jts)
1092       IF ( config_flags%open_ye .or. specified ) j_end   = MIN(jde-2,jte)
1093
1094       DO j = j_start, j_end
1095       DO k=kts,ktf
1096       DO i = i_start, i_end
1097          mrdy=msfux(i,j)*rdy         ! ADT eqn 44, 1st term on RHS
1098          ! Comments for polar boundary condition
1099          ! Flow is only from one side for points next to poles
1100          IF ( (config_flags%polar) .AND. (j == jds) ) THEN
1101             tendency(i,k,j)=tendency(i,k,j)-mrdy*0.25 &
1102                             *(rv(i,k,j+1)+rv(i-1,k,j+1))*(u(i,k,j+1)+u(i,k,j))
1103          ELSE IF ( (config_flags%polar) .AND. (j == jde-1) ) THEN
1104             tendency(i,k,j)=tendency(i,k,j)+mrdy*0.25 &
1105                            *(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1))
1106          ELSE  ! Normal code
1107             tendency(i,k,j)=tendency(i,k,j)-mrdy*0.25 &
1108                 *((rv(i,k,j+1)+rv(i-1,k,j+1))*(u(i,k,j+1)+u(i,k,j)) &
1109                  -(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1)))
1110          ENDIF
1111       ENDDO
1112       ENDDO
1113       ENDDO
1114
1115    ELSE IF ( horz_order == 0 ) THEN
1116
1117       ! Just in case we want to turn horizontal advection off, we can do it
1118
1119    ELSE
1120
1121       WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a:  h_order not known ',horz_order
1122       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1123
1124    ENDIF horizontal_order_test
1125
1126 !  radiative lateral boundary condition in x for normal velocity (u)
1127
1128       IF ( (config_flags%open_xs) .and. its == ids ) THEN
1129
1130         j_start = jts
1131         j_end   = MIN(jte,jde-1)
1132
1133         DO j = j_start, j_end
1134         DO k = kts, ktf
1135           ub = MIN(ru(its,k,j)-cb*mut(its,j), 0.)
1136           tendency(its,k,j) = tendency(its,k,j)                    &
1137                       - rdx*ub*(u_old(its+1,k,j) - u_old(its,k,j))
1138         ENDDO
1139         ENDDO
1140
1141       ENDIF
1142
1143       IF ( (config_flags%open_xe) .and. ite == ide ) THEN
1144
1145         j_start = jts
1146         j_end   = MIN(jte,jde-1)
1147
1148         DO j = j_start, j_end
1149         DO k = kts, ktf
1150           ub = MAX(ru(ite,k,j)+cb*mut(ite-1,j), 0.)
1151           tendency(ite,k,j) = tendency(ite,k,j)                    &
1152                       - rdx*ub*(u_old(ite,k,j) - u_old(ite-1,k,j))
1153         ENDDO
1154         ENDDO
1155
1156       ENDIF
1157
1158 !  pick up the rest of the horizontal radiation boundary conditions.
1159 !  (these are the computations that don't require 'cb')
1160 !  first, set to index ranges
1161
1162       i_start = its
1163       i_end   = MIN(ite,ide)
1164       imin    = ids
1165       imax    = ide-1
1166
1167       IF (config_flags%open_xs) THEN
1168         i_start = MAX(ids+1, its)
1169         imin = ids
1170       ENDIF
1171       IF (config_flags%open_xe) THEN
1172         i_end = MIN(ite,ide-1)
1173         imax = ide-1
1174       ENDIF
1175
1176    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
1177
1178       DO i = i_start, i_end
1179
1180          mrdy=msfux(i,jts)*rdy       ! ADT eqn 44, 2nd term on RHS
1181          ip = MIN( imax, i   )
1182          im = MAX( imin, i-1 )
1183
1184          DO k=kts,ktf
1185
1186           vw = 0.5*(rv(ip,k,jts)+rv(im,k,jts))
1187           vb = MIN( vw, 0. )
1188           dvm =  rv(ip,k,jts+1)-rv(ip,k,jts)
1189           dvp =  rv(im,k,jts+1)-rv(im,k,jts)
1190           tendency(i,k,jts)=tendency(i,k,jts)-mrdy*(                &
1191                             vb*(u_old(i,k,jts+1)-u_old(i,k,jts))    &
1192                            +0.5*u(i,k,jts)*(dvm+dvp))
1193          ENDDO
1194       ENDDO
1195
1196    ENDIF
1197
1198    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
1199
1200       DO i = i_start, i_end
1201
1202          mrdy=msfux(i,jte-1)*rdy     ! ADT eqn 44, 2nd term on RHS
1203          ip = MIN( imax, i   )
1204          im = MAX( imin, i-1 )
1205
1206          DO k=kts,ktf
1207
1208           vw = 0.5*(rv(ip,k,jte)+rv(im,k,jte))
1209           vb = MAX( vw, 0. )
1210           dvm =  rv(ip,k,jte)-rv(ip,k,jte-1)
1211           dvp =  rv(im,k,jte)-rv(im,k,jte-1)
1212           tendency(i,k,jte-1)=tendency(i,k,jte-1)-mrdy*(              &
1213                               vb*(u_old(i,k,jte-1)-u_old(i,k,jte-2))  &
1214                              +0.5*u(i,k,jte-1)*(dvm+dvp))
1215          ENDDO
1216       ENDDO
1217
1218    ENDIF
1219
1220 !-------------------- vertical advection
1221 !  ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
1222 !  Here we have:  - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
1223 !  Since 'my' (map scale factor in y-direction) isn't a function of z,
1224 !  this is what we need, so leave unchanged in advect_u
1225
1226    i_start = its
1227    i_end   = ite
1228    j_start = jts
1229    j_end   = min(jte,jde-1)
1230
1231 !   IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
1232 !   IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
1233
1234    IF ( config_flags%open_ys .or. specified ) i_start = MAX(ids+1,its)
1235    IF ( config_flags%open_ye .or. specified ) i_end   = MIN(ide-1,ite)
1236       IF ( config_flags%periodic_x ) i_start = its
1237       IF ( config_flags%periodic_x ) i_end = ite
1238
1239    DO i = i_start, i_end
1240      vflux(i,kts)=0.
1241      vflux(i,kte)=0.
1242    ENDDO
1243
1244    vert_order_test : IF (vert_order == 6) THEN
1245
1246       DO j = j_start, j_end
1247
1248          DO k=kts+3,ktf-2
1249          DO i = i_start, i_end
1250            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1251            vflux(i,k) = vel*flux6(                     &
1252                    u(i,k-3,j), u(i,k-2,j), u(i,k-1,j),       &
1253                    u(i,k  ,j), u(i,k+1,j), u(i,k+2,j),  -vel )
1254          ENDDO
1255          ENDDO
1256
1257          DO i = i_start, i_end
1258
1259            k=kts+1
1260            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1261                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1262            k = kts+2
1263            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1264            vflux(i,k) = vel*flux4(       &
1265                    u(i,k-2,j), u(i,k-1,j),   &
1266                    u(i,k  ,j), u(i,k+1,j), -vel )
1267            k = ktf-1
1268            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1269            vflux(i,k) = vel*flux4(       &
1270                    u(i,k-2,j), u(i,k-1,j),   &
1271                    u(i,k  ,j), u(i,k+1,j), -vel )
1272            k=ktf
1273            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1274                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1275
1276          ENDDO
1277          DO k=kts,ktf
1278          DO i = i_start, i_end
1279             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1280          ENDDO
1281          ENDDO
1282       ENDDO
1283
1284     ELSE IF (vert_order == 5) THEN
1285
1286       DO j = j_start, j_end
1287
1288          DO k=kts+3,ktf-2
1289          DO i = i_start, i_end
1290            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1291            vflux(i,k) = vel*flux5(                     &
1292                    u(i,k-3,j), u(i,k-2,j), u(i,k-1,j),       &
1293                    u(i,k  ,j), u(i,k+1,j), u(i,k+2,j),  -vel )
1294          ENDDO
1295          ENDDO
1296
1297          DO i = i_start, i_end
1298
1299            k=kts+1
1300            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1301                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1302            k = kts+2
1303            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1304            vflux(i,k) = vel*flux3(       &
1305                    u(i,k-2,j), u(i,k-1,j),   &
1306                    u(i,k  ,j), u(i,k+1,j), -vel )
1307            k = ktf-1
1308            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
1309            vflux(i,k) = vel*flux3(       &
1310                    u(i,k-2,j), u(i,k-1,j),   &
1311                    u(i,k  ,j), u(i,k+1,j), -vel )
1312            k=ktf
1313            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1314                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1315
1316          ENDDO
1317          DO k=kts,ktf
1318          DO i = i_start, i_end
1319             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1320          ENDDO
1321          ENDDO
1322       ENDDO
1323
1324     ELSE IF (vert_order == 4) THEN
1325
1326       DO j = j_start, j_end
1327
1328          DO k=kts+2,ktf-1
1329          DO i = i_start, i_end
1330            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1331            vflux(i,k) = vel*flux4(               &
1332                    u(i,k-2,j), u(i,k-1,j),       &
1333                    u(i,k  ,j), u(i,k+1,j),  -vel )
1334          ENDDO
1335          ENDDO
1336
1337          DO i = i_start, i_end
1338
1339            k=kts+1
1340            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1341                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1342            k=ktf
1343            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1344                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1345
1346          ENDDO
1347          DO k=kts,ktf
1348          DO i = i_start, i_end
1349             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1350          ENDDO
1351          ENDDO
1352       ENDDO
1353
1354     ELSE IF (vert_order == 3) THEN
1355
1356       DO j = j_start, j_end
1357
1358          DO k=kts+2,ktf-1
1359          DO i = i_start, i_end
1360            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
1361            vflux(i,k) = vel*flux3(               &
1362                    u(i,k-2,j), u(i,k-1,j),       &
1363                    u(i,k  ,j), u(i,k+1,j),  -vel )
1364          ENDDO
1365          ENDDO
1366
1367          DO i = i_start, i_end
1368
1369            k=kts+1
1370            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
1371                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1372            k=ktf
1373            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
1374                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
1375
1376          ENDDO
1377          DO k=kts,ktf
1378          DO i = i_start, i_end
1379             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1380          ENDDO
1381          ENDDO
1382       ENDDO
1383
1384     ELSE IF (vert_order == 2) THEN
1385
1386       DO j = j_start, j_end
1387          DO k=kts+1,ktf
1388          DO i = i_start, i_end
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          ENDDO
1392          ENDDO
1393
1394
1395          DO k=kts,ktf
1396          DO i = i_start, i_end
1397                tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
1398          ENDDO
1399          ENDDO
1400
1401       ENDDO
1402
1403    ELSE
1404
1405       WRITE ( wrf_err_message , * ) 'module_advect: advect_u_6a: v_order not known ',vert_order
1406       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1407
1408    ENDIF vert_order_test
1409
1410 END SUBROUTINE advect_u
1411
1412 !-------------------------------------------------------------------------------
1413
1414 SUBROUTINE advect_v   ( v, v_old, tendency,            &
1415                         ru, rv, rom,                   &
1416                         mut, time_step, config_flags,  &
1417                         msfux, msfuy, msfvx, msfvy,    &
1418                         msftx, msfty,                  &
1419                         fzm, fzp,                      &
1420                         rdx, rdy, rdzw,                &
1421                         ids, ide, jds, jde, kds, kde,  &
1422                         ims, ime, jms, jme, kms, kme,  &
1423                         its, ite, jts, jte, kts, kte  )
1424
1425    IMPLICIT NONE
1426
1427    ! Input data
1428
1429    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
1430
1431    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
1432                                               ims, ime, jms, jme, kms, kme, &
1433                                               its, ite, jts, jte, kts, kte
1434
1435    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: v,     &
1436                                                                       v_old, &
1437                                                                       ru,    &
1438                                                                       rv,    &
1439                                                                       rom
1440
1441    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
1442    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
1443
1444    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
1445                                                                     msfuy,  &
1446                                                                     msfvx,  &
1447                                                                     msfvy,  &
1448                                                                     msftx,  &
1449                                                                     msfty
1450
1451    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
1452                                                                   fzp,  &
1453                                                                   rdzw
1454
1455    REAL ,                                        INTENT(IN   ) :: rdx,  &
1456                                                                   rdy
1457    INTEGER ,                                     INTENT(IN   ) :: time_step
1458
1459
1460    ! Local data
1461
1462    INTEGER :: i, j, k, itf, jtf, ktf
1463    INTEGER :: i_start, i_end, j_start, j_end
1464    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
1465    INTEGER :: jmin, jmax, jp, jm, imin, imax
1466
1467    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
1468    REAL , DIMENSION(its:ite, kts:kte) :: vflux
1469
1470
1471    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
1472    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
1473
1474    INTEGER :: horz_order
1475    INTEGER :: vert_order
1476
1477    LOGICAL :: degrade_xs, degrade_ys
1478    LOGICAL :: degrade_xe, degrade_ye
1479
1480    INTEGER :: jp1, jp0, jtmp
1481
1482
1483 ! definition of flux operators, 3rd, 4th, 5th or 6th order
1484
1485    REAL    :: flux3, flux4, flux5, flux6
1486    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
1487
1488    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
1489           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
1490
1491    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
1492            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
1493            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
1494
1495    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
1496                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)   &
1497                      +(q_ip2+q_im3) )/60.0
1498
1499    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
1500            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
1501             -sign(1,time_step)*sign(1.,ua)*(                    &
1502               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
1503
1504
1505
1506    LOGICAL :: specified
1507
1508    specified = .false.
1509    if(config_flags%specified .or. config_flags%nested) specified = .true.
1510
1511 ! set order for the advection schemes
1512
1513    ktf=MIN(kte,kde-1)
1514    horz_order = config_flags%h_mom_adv_order
1515    vert_order = config_flags%v_mom_adv_order
1516
1517
1518 !  here is the choice of flux operators
1519
1520
1521    horizontal_order_test : IF( horz_order == 6 ) THEN
1522
1523 !  determine boundary mods for flux operators
1524 !  We degrade the flux operators from 3rd/4th order
1525 !   to second order one gridpoint in from the boundaries for
1526 !   all boundary conditions except periodic and symmetry - these
1527 !   conditions have boundary zone data fill for correct application
1528 !   of the higher order flux stencils
1529
1530    degrade_xs = .true.
1531    degrade_xe = .true.
1532    degrade_ys = .true.
1533    degrade_ye = .true.
1534
1535    IF( config_flags%periodic_x   .or. &
1536        config_flags%symmetric_xs .or. &
1537        (its > ids+3)                ) degrade_xs = .false.
1538    IF( config_flags%periodic_x   .or. &
1539        config_flags%symmetric_xe .or. &
1540        (ite < ide-3)                ) degrade_xe = .false.
1541    IF( config_flags%periodic_y   .or. &
1542        config_flags%symmetric_ys .or. &
1543        (jts > jds+3)                ) degrade_ys = .false.
1544    IF( config_flags%periodic_y   .or. &
1545        config_flags%symmetric_ye .or. &
1546        (jte < jde-3)                ) degrade_ye = .false.
1547
1548 !--------------- y - advection first
1549
1550       i_start = its
1551       i_end   = MIN(ite,ide-1)
1552       j_start = jts
1553       j_end   = jte
1554
1555 !  higher order flux has a 5 or 7 point stencil, so compute
1556 !  bounds so we can switch to second order flux close to the boundary
1557
1558       j_start_f = j_start
1559       j_end_f   = j_end+1
1560
1561       IF(degrade_ys) then
1562         j_start = MAX(jts,jds+1)
1563         j_start_f = jds+3
1564       ENDIF
1565
1566       IF(degrade_ye) then
1567         j_end = MIN(jte,jde-1)
1568         j_end_f = jde-2
1569       ENDIF
1570
1571 !  compute fluxes, 5th or 6th order
1572
1573      jp1 = 2
1574      jp0 = 1
1575
1576      j_loop_y_flux_6 : DO j = j_start, j_end+1
1577
1578       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
1579
1580         DO k=kts,ktf
1581         DO i = i_start, i_end
1582           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1583           fqy( i, k, jp1 ) = vel*flux6(               &
1584                   v(i,k,j-3), v(i,k,j-2), v(i,k,j-1),       &
1585                   v(i,k,j  ), v(i,k,j+1), v(i,k,j+2),  vel )
1586         ENDDO
1587         ENDDO
1588
1589 !  we must be close to some boundary where we need to reduce the order of the stencil
1590 !  specified uses upstream normal wind at boundaries
1591
1592       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
1593
1594             DO k=kts,ktf
1595             DO i = i_start, i_end
1596                 vb = v(i,k,j-1)
1597                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
1598                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
1599                                  *(v(i,k,j)+vb)
1600             ENDDO
1601             ENDDO
1602
1603      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
1604
1605             DO k=kts,ktf
1606             DO i = i_start, i_end
1607               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1608               fqy( i, k, jp1 ) = vel*flux4(      &
1609                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
1610             ENDDO
1611             ENDDO
1612
1613
1614      ELSE IF ( j == jde ) THEN  ! 2nd order flux next to north boundary
1615
1616             DO k=kts,ktf
1617             DO i = i_start, i_end
1618                 vb = v(i,k,j)
1619                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
1620                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
1621                                  *(vb+v(i,k,j-1))
1622             ENDDO
1623             ENDDO
1624
1625      ELSE IF ( j == jde-1 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
1626
1627             DO k=kts,ktf
1628             DO i = i_start, i_end
1629               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1630               fqy( i, k, jp1 ) = vel*flux4(     &
1631                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
1632             ENDDO
1633             ENDDO
1634
1635       END IF
1636
1637 !  y flux-divergence into tendency
1638
1639         ! Comments on polar boundary conditions
1640         ! No advection over the poles means tendencies (held from jds [S. pole]
1641         ! to jde [N pole], i.e., on v grid) must be zero at poles
1642         ! [tendency(jds) and tendency(jde)=0]
1643         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
1644           DO k=kts,ktf
1645           DO i = i_start, i_end
1646             tendency(i,k,j-1) = 0.
1647           END DO
1648           END DO
1649         ! If j_end were set to jde in a special if statement apart from
1650         ! degrade_ye, then we would hit the next conditional.  But since
1651         ! we want the tendency to be zero anyway, not looping to jde+1
1652         ! will produce the same effect.
1653         ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
1654           DO k=kts,ktf
1655           DO i = i_start, i_end
1656             tendency(i,k,j-1) = 0.
1657           END DO
1658           END DO
1659         ELSE  ! Normal code
1660
1661         IF(j > j_start) THEN
1662
1663           DO k=kts,ktf
1664           DO i = i_start, i_end
1665             mrdy=msfvy(i,j-1)*rdy    ! ADT eqn 45, 2nd term on RHS
1666             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
1667           ENDDO
1668           ENDDO
1669
1670         ENDIF
1671
1672         END IF
1673
1674         jtmp = jp1
1675         jp1 = jp0
1676         jp0 = jtmp
1677
1678    ENDDO j_loop_y_flux_6
1679
1680 !  next, x - flux divergence
1681
1682       i_start = its
1683       i_end   = MIN(ite,ide-1)
1684
1685       j_start = jts
1686       j_end   = jte
1687       ! Polar boundary conditions are like open or specified
1688       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
1689       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
1690
1691 !  higher order flux has a 5 or 7 point stencil, so compute
1692 !  bounds so we can switch to second order flux close to the boundary
1693
1694       i_start_f = i_start
1695       i_end_f   = i_end+1
1696
1697       IF(degrade_xs) then
1698         i_start = MAX(ids+1,its)
1699 !        i_start_f = i_start+2
1700         i_start_f = MIN(i_start+2,ids+3)
1701       ENDIF
1702
1703       IF(degrade_xe) then
1704         i_end = MIN(ide-2,ite)
1705         i_end_f = ide-3
1706       ENDIF
1707
1708 !  compute fluxes
1709
1710       DO j = j_start, j_end
1711
1712 !  5th or 6th order flux
1713
1714         DO k=kts,ktf
1715         DO i = i_start_f, i_end_f
1716           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1717           fqx( i, k ) = vel*flux6( v(i-3,k,j), v(i-2,k,j),  &
1718                                          v(i-1,k,j), v(i  ,k,j),  &
1719                                          v(i+1,k,j), v(i+2,k,j),  &
1720                                          vel                     )
1721         ENDDO
1722         ENDDO
1723
1724 !  lower order fluxes close to boundaries (if not periodic or symmetric)
1725
1726         IF( degrade_xs ) THEN
1727
1728           DO i=i_start,i_start_f-1
1729
1730             IF(i == ids+1) THEN ! second order
1731               DO k=kts,ktf
1732                 fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) &
1733                                 *(v(i,k,j)+v(i-1,k,j))
1734               ENDDO
1735             ENDIF
1736
1737             IF(i == ids+2) THEN  ! third order
1738               DO k=kts,ktf
1739                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1740                 fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j),  &
1741                                         v(i  ,k,j), v(i+1,k,j),  &
1742                                         vel                     )
1743               ENDDO
1744             ENDIF
1745
1746           ENDDO
1747
1748         ENDIF
1749
1750         IF( degrade_xe ) THEN
1751
1752           DO i = i_end_f+1, i_end+1
1753
1754             IF( i == ide-1 ) THEN ! second order flux next to the boundary
1755               DO k=kts,ktf
1756                 fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
1757                                 *(v(i_end+1,k,j)+v(i_end,k,j))
1758               ENDDO
1759             ENDIF
1760
1761             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
1762               DO k=kts,ktf
1763                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1764                 fqx( i,k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j),  &
1765                                         v(i  ,k,j), v(i+1,k,j),  &
1766                                         vel                     )
1767               ENDDO
1768             ENDIF
1769
1770           ENDDO
1771
1772         ENDIF
1773
1774 !  x flux-divergence into tendency
1775
1776         DO k=kts,ktf
1777           DO i = i_start, i_end
1778             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
1779             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
1780           ENDDO
1781         ENDDO
1782
1783       ENDDO
1784
1785    ELSE IF( horz_order == 5 ) THEN
1786
1787 !  5th order horizontal flux calculation
1788 !  This code is EXACTLY the same as the 6th order code
1789 !  EXCEPT the 5th order and 3rd operators are used in
1790 !  place of the 6th and 4th order operators
1791
1792 !  determine boundary mods for flux operators
1793 !  We degrade the flux operators from 3rd/4th order
1794 !   to second order one gridpoint in from the boundaries for
1795 !   all boundary conditions except periodic and symmetry - these
1796 !   conditions have boundary zone data fill for correct application
1797 !   of the higher order flux stencils
1798
1799    degrade_xs = .true.
1800    degrade_xe = .true.
1801    degrade_ys = .true.
1802    degrade_ye = .true.
1803
1804    IF( config_flags%periodic_x   .or. &
1805        config_flags%symmetric_xs .or. &
1806        (its > ids+3)                ) degrade_xs = .false.
1807    IF( config_flags%periodic_x   .or. &
1808        config_flags%symmetric_xe .or. &
1809        (ite < ide-3)                ) degrade_xe = .false.
1810    IF( config_flags%periodic_y   .or. &
1811        config_flags%symmetric_ys .or. &
1812        (jts > jds+3)                ) degrade_ys = .false.
1813    IF( config_flags%periodic_y   .or. &
1814        config_flags%symmetric_ye .or. &
1815        (jte < jde-3)                ) degrade_ye = .false.
1816
1817 !--------------- y - advection first
1818
1819       i_start = its
1820       i_end   = MIN(ite,ide-1)
1821       j_start = jts
1822       j_end   = jte
1823
1824 !  higher order flux has a 5 or 7 point stencil, so compute
1825 !  bounds so we can switch to second order flux close to the boundary
1826
1827       j_start_f = j_start
1828       j_end_f   = j_end+1
1829
1830       IF(degrade_ys) then
1831         j_start = MAX(jts,jds+1)
1832         j_start_f = jds+3
1833       ENDIF
1834
1835       IF(degrade_ye) then
1836         j_end = MIN(jte,jde-1)
1837         j_end_f = jde-2
1838       ENDIF
1839
1840 !  compute fluxes, 5th or 6th order
1841
1842      jp1 = 2
1843      jp0 = 1
1844
1845      j_loop_y_flux_5 : DO j = j_start, j_end+1
1846
1847       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
1848
1849         DO k=kts,ktf
1850         DO i = i_start, i_end
1851           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1852           fqy( i, k, jp1 ) = vel*flux5(               &
1853                   v(i,k,j-3), v(i,k,j-2), v(i,k,j-1),       &
1854                   v(i,k,j  ), v(i,k,j+1), v(i,k,j+2),  vel )
1855         ENDDO
1856         ENDDO
1857
1858 !  we must be close to some boundary where we need to reduce the order of the stencil
1859 !  specified uses upstream normal wind at boundaries
1860
1861       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
1862
1863             DO k=kts,ktf
1864             DO i = i_start, i_end
1865                 vb = v(i,k,j-1)
1866                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
1867                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
1868                                  *(v(i,k,j)+vb)
1869             ENDDO
1870             ENDDO
1871
1872      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
1873
1874             DO k=kts,ktf
1875             DO i = i_start, i_end
1876               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1877               fqy( i, k, jp1 ) = vel*flux3(      &
1878                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
1879             ENDDO
1880             ENDDO
1881
1882
1883      ELSE IF ( j == jde ) THEN  ! 2nd order flux next to north boundary
1884
1885             DO k=kts,ktf
1886             DO i = i_start, i_end
1887                 vb = v(i,k,j)
1888                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
1889                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
1890                                  *(vb+v(i,k,j-1))
1891             ENDDO
1892             ENDDO
1893
1894      ELSE IF ( j == jde-1 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
1895
1896             DO k=kts,ktf
1897             DO i = i_start, i_end
1898               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
1899               fqy( i, k, jp1 ) = vel*flux3(     &
1900                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
1901             ENDDO
1902             ENDDO
1903
1904       END IF
1905
1906 !  y flux-divergence into tendency
1907
1908         ! Comments on polar boundary conditions
1909         ! No advection over the poles means tendencies (held from jds [S. pole]
1910         ! to jde [N pole], i.e., on v grid) must be zero at poles
1911         ! [tendency(jds) and tendency(jde)=0]
1912         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
1913           DO k=kts,ktf
1914           DO i = i_start, i_end
1915             tendency(i,k,j-1) = 0.
1916           END DO
1917           END DO
1918         ! If j_end were set to jde in a special if statement apart from
1919         ! degrade_ye, then we would hit the next conditional.  But since
1920         ! we want the tendency to be zero anyway, not looping to jde+1
1921         ! will produce the same effect.
1922         ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
1923           DO k=kts,ktf
1924           DO i = i_start, i_end
1925             tendency(i,k,j-1) = 0.
1926           END DO
1927           END DO
1928         ELSE  ! Normal code
1929
1930         IF(j > j_start) THEN
1931
1932           DO k=kts,ktf
1933           DO i = i_start, i_end
1934             mrdy=msfvy(i,j-1)*rdy    ! ADT eqn 45, 2nd term on RHS
1935             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
1936           ENDDO
1937           ENDDO
1938
1939         ENDIF
1940
1941         END IF
1942
1943         jtmp = jp1
1944         jp1 = jp0
1945         jp0 = jtmp
1946
1947    ENDDO j_loop_y_flux_5
1948
1949 !  next, x - flux divergence
1950
1951       i_start = its
1952       i_end   = MIN(ite,ide-1)
1953
1954       j_start = jts
1955       j_end   = jte
1956       ! Polar boundary conditions are like open or specified
1957       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
1958       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
1959
1960 !  higher order flux has a 5 or 7 point stencil, so compute
1961 !  bounds so we can switch to second order flux close to the boundary
1962
1963       i_start_f = i_start
1964       i_end_f   = i_end+1
1965
1966       IF(degrade_xs) then
1967         i_start = MAX(ids+1,its)
1968 !        i_start_f = i_start+2
1969         i_start_f = MIN(i_start+2,ids+3)
1970       ENDIF
1971
1972       IF(degrade_xe) then
1973         i_end = MIN(ide-2,ite)
1974         i_end_f = ide-3
1975       ENDIF
1976
1977 !  compute fluxes
1978
1979       DO j = j_start, j_end
1980
1981 !  5th or 6th order flux
1982
1983         DO k=kts,ktf
1984         DO i = i_start_f, i_end_f
1985           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
1986           fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j),  &
1987                                          v(i-1,k,j), v(i  ,k,j),  &
1988                                          v(i+1,k,j), v(i+2,k,j),  &
1989                                          vel                     )
1990         ENDDO
1991         ENDDO
1992
1993 !  lower order fluxes close to boundaries (if not periodic or symmetric)
1994
1995         IF( degrade_xs ) THEN
1996
1997           DO i=i_start,i_start_f-1
1998
1999             IF(i == ids+1) THEN ! second order
2000               DO k=kts,ktf
2001                 fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) &
2002                                 *(v(i,k,j)+v(i-1,k,j))
2003               ENDDO
2004             ENDIF
2005
2006             IF(i == ids+2) THEN  ! third order
2007               DO k=kts,ktf
2008                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2009                 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
2010                                         v(i  ,k,j), v(i+1,k,j),  &
2011                                         vel                     )
2012               ENDDO
2013             ENDIF
2014
2015           ENDDO
2016
2017         ENDIF
2018
2019         IF( degrade_xe ) THEN
2020
2021           DO i = i_end_f+1, i_end+1
2022
2023             IF( i == ide-1 ) THEN ! second order flux next to the boundary
2024               DO k=kts,ktf
2025                 fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
2026                                 *(v(i_end+1,k,j)+v(i_end,k,j))
2027               ENDDO
2028             ENDIF
2029
2030             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
2031               DO k=kts,ktf
2032                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2033                 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
2034                                         v(i  ,k,j), v(i+1,k,j),  &
2035                                         vel                     )
2036               ENDDO
2037             ENDIF
2038
2039           ENDDO
2040
2041         ENDIF
2042
2043 !  x flux-divergence into tendency
2044
2045         DO k=kts,ktf
2046           DO i = i_start, i_end
2047             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
2048             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2049           ENDDO
2050         ENDDO
2051
2052       ENDDO
2053
2054    ELSE IF( horz_order == 4 ) THEN
2055
2056 !  determine boundary mods for flux operators
2057 !  We degrade the flux operators from 3rd/4th order
2058 !   to second order one gridpoint in from the boundaries for
2059 !   all boundary conditions except periodic and symmetry - these
2060 !   conditions have boundary zone data fill for correct application
2061 !   of the higher order flux stencils
2062
2063    degrade_xs = .true.
2064    degrade_xe = .true.
2065    degrade_ys = .true.
2066    degrade_ye = .true.
2067
2068    IF( config_flags%periodic_x   .or. &
2069        config_flags%symmetric_xs .or. &
2070        (its > ids+2)                ) degrade_xs = .false.
2071    IF( config_flags%periodic_x   .or. &
2072        config_flags%symmetric_xe .or. &
2073        (ite < ide-2)                ) degrade_xe = .false.
2074    IF( config_flags%periodic_y   .or. &
2075        config_flags%symmetric_ys .or. &
2076        (jts > jds+2)                ) degrade_ys = .false.
2077    IF( config_flags%periodic_y   .or. &
2078        config_flags%symmetric_ye .or. &
2079        (jte < jde-2)                ) degrade_ye = .false.
2080
2081 !--------------- y - advection first
2082
2083
2084    ktf=MIN(kte,kde-1)
2085
2086       i_start = its
2087       i_end   = MIN(ite,ide-1)
2088       j_start = jts
2089       j_end   = jte
2090
2091 !  3rd or 4th order flux has a 5 point stencil, so compute
2092 !  bounds so we can switch to second order flux close to the boundary
2093
2094       j_start_f = j_start
2095       j_end_f   = j_end+1
2096
2097 !CJM May not work with tiling because defined in terms of domain dims
2098       IF(degrade_ys) then
2099         j_start = jds+1
2100         j_start_f = j_start+1
2101       ENDIF
2102
2103       IF(degrade_ye) then
2104         j_end = jde-1
2105         j_end_f = jde-1
2106       ENDIF
2107
2108 !  compute fluxes
2109 !  specified uses upstream normal wind at boundaries
2110
2111     jp0 = 1
2112     jp1 = 2
2113
2114     DO j = j_start, j_end+1
2115
2116       IF ((j == j_start) .and. degrade_ys) THEN
2117         DO k = kts,ktf
2118         DO i = i_start, i_end
2119                 vb = v(i,k,j-1)
2120                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
2121                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
2122                                  *(v(i,k,j)+vb)
2123         ENDDO
2124         ENDDO
2125       ELSE IF ((j == j_end+1) .and. degrade_ye) THEN
2126         DO k = kts, ktf
2127         DO i = i_start, i_end
2128                 vb = v(i,k,j)
2129                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
2130                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
2131                                  *(vb+v(i,k,j-1))
2132         ENDDO
2133         ENDDO
2134       ELSE
2135         DO k = kts, ktf
2136         DO i = i_start, i_end
2137           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2138           fqy( i,k,jp1 ) = vel*flux4( v(i,k,j-2), v(i,k,j-1),  &
2139                                      v(i,k,j  ), v(i,k,j+1),  &
2140                                       vel                        )
2141         ENDDO
2142         ENDDO
2143       END IF
2144
2145       ! Comments on polar boundary conditions
2146       ! No advection over the poles means tendencies (held from jds [S. pole]
2147       ! to jde [N pole], i.e., on v grid) must be zero at poles
2148       ! [tendency(jds) and tendency(jde)=0]
2149       IF ( config_flags%polar .AND. (j == jds+1) ) THEN
2150         DO k=kts,ktf
2151         DO i = i_start, i_end
2152           tendency(i,k,j-1) = 0.
2153         END DO
2154         END DO
2155       ! If j_end were set to jde in a special if statement apart from
2156       ! degrade_ye, then we would hit the next conditional.  But since
2157       ! we want the tendency to be zero anyway, not looping to jde+1
2158       ! will produce the same effect.
2159       ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
2160         DO k=kts,ktf
2161         DO i = i_start, i_end
2162           tendency(i,k,j-1) = 0.
2163         END DO
2164         END DO
2165       ELSE  ! Normal code
2166
2167       IF( j > j_start) THEN
2168         DO k = kts, ktf
2169         DO i = i_start, i_end
2170             mrdy=msfvy(i,j-1)*rdy     ! ADT eqn 45, 2nd term on RHS
2171             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
2172         ENDDO
2173         ENDDO
2174
2175       END IF
2176
2177       END IF
2178
2179       jtmp = jp1
2180       jp1 = jp0
2181       jp0 = jtmp
2182
2183    ENDDO
2184
2185 !  next, x - flux divergence
2186
2187
2188       i_start = its
2189       i_end   = MIN(ite,ide-1)
2190
2191       j_start = jts
2192       j_end   = jte
2193       ! Polar boundary conditions are like open or specified
2194       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2195       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
2196
2197 !  3rd or 4th order flux has a 5 point stencil, so compute
2198 !  bounds so we can switch to second order flux close to the boundary
2199
2200       i_start_f = i_start
2201       i_end_f   = i_end+1
2202
2203       IF(degrade_xs) then
2204         i_start = ids+1
2205         i_start_f = i_start+1
2206       ENDIF
2207
2208       IF(degrade_xe) then
2209         i_end = ide-2
2210         i_end_f = ide-2
2211       ENDIF
2212
2213 !  compute fluxes
2214
2215       DO j = j_start, j_end
2216
2217 !  3rd or 4th order flux
2218
2219         DO k=kts,ktf
2220         DO i = i_start_f, i_end_f
2221           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2222           fqx( i, k ) = vel*flux4( v(i-2,k,j), v(i-1,k,j),  &
2223                                   v(i  ,k,j), v(i+1,k,j),  &
2224                                   vel                     )
2225         ENDDO
2226         ENDDO
2227
2228 !  second order flux close to boundaries (if not periodic or symmetric)
2229
2230         IF( degrade_xs ) THEN
2231           DO k=kts,ktf
2232             fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) &
2233                    *(v(i_start,k,j)+v(i_start-1,k,j))
2234           ENDDO
2235         ENDIF
2236
2237         IF( degrade_xe ) THEN
2238           DO k=kts,ktf
2239             fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
2240                    *(v(i_end+1,k,j)+v(i_end,k,j))
2241           ENDDO
2242         ENDIF
2243
2244 !  x flux-divergence into tendency
2245
2246         DO k=kts,ktf
2247         DO i = i_start, i_end
2248             mrdx=msfvy(i,j)*rdx       ! ADT eqn 45, 1st term on RHS
2249             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2250         ENDDO
2251         ENDDO
2252
2253       ENDDO
2254
2255    ELSE IF( horz_order == 3 ) THEN
2256
2257 !  determine boundary mods for flux operators
2258 !  We degrade the flux operators from 3rd/4th order
2259 !   to second order one gridpoint in from the boundaries for
2260 !   all boundary conditions except periodic and symmetry - these
2261 !   conditions have boundary zone data fill for correct application
2262 !   of the higher order flux stencils
2263
2264    degrade_xs = .true.
2265    degrade_xe = .true.
2266    degrade_ys = .true.
2267    degrade_ye = .true.
2268
2269    IF( config_flags%periodic_x   .or. &
2270        config_flags%symmetric_xs .or. &
2271        (its > ids+2)                ) degrade_xs = .false.
2272    IF( config_flags%periodic_x   .or. &
2273        config_flags%symmetric_xe .or. &
2274        (ite < ide-2)                ) degrade_xe = .false.
2275    IF( config_flags%periodic_y   .or. &
2276        config_flags%symmetric_ys .or. &
2277        (jts > jds+2)                ) degrade_ys = .false.
2278    IF( config_flags%periodic_y   .or. &
2279        config_flags%symmetric_ye .or. &
2280        (jte < jde-2)                ) degrade_ye = .false.
2281
2282 !--------------- y - advection first
2283
2284
2285    ktf=MIN(kte,kde-1)
2286
2287       i_start = its
2288       i_end   = MIN(ite,ide-1)
2289       j_start = jts
2290       j_end   = jte
2291
2292 !  3rd or 4th order flux has a 5 point stencil, so compute
2293 !  bounds so we can switch to second order flux close to the boundary
2294
2295       j_start_f = j_start
2296       j_end_f   = j_end+1
2297
2298 !CJM May not work with tiling because defined in terms of domain dims
2299       IF(degrade_ys) then
2300         j_start = jds+1
2301         j_start_f = j_start+1
2302       ENDIF
2303
2304       IF(degrade_ye) then
2305         j_end = jde-1
2306         j_end_f = jde-1
2307       ENDIF
2308
2309 !  compute fluxes
2310 !  specified uses upstream normal wind at boundaries
2311
2312     jp0 = 1
2313     jp1 = 2
2314
2315     DO j = j_start, j_end+1
2316
2317       IF ((j == j_start) .and. degrade_ys) THEN
2318         DO k = kts,ktf
2319         DO i = i_start, i_end
2320                 vb = v(i,k,j-1)
2321                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
2322                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
2323                                  *(v(i,k,j)+vb)
2324         ENDDO
2325         ENDDO
2326       ELSE IF ((j == j_end+1) .and. degrade_ye) THEN
2327         DO k = kts, ktf
2328         DO i = i_start, i_end
2329                 vb = v(i,k,j)
2330                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
2331                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
2332                                  *(vb+v(i,k,j-1))
2333         ENDDO
2334         ENDDO
2335       ELSE
2336         DO k = kts, ktf
2337         DO i = i_start, i_end
2338           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
2339           fqy( i,k,jp1 ) = vel*flux3( v(i,k,j-2), v(i,k,j-1),  &
2340                                      v(i,k,j  ), v(i,k,j+1),  &
2341                                       vel                        )
2342         ENDDO
2343         ENDDO
2344       END IF
2345
2346       ! Comments on polar boundary conditions
2347       ! No advection over the poles means tendencies (held from jds [S. pole]
2348       ! to jde [N pole], i.e., on v grid) must be zero at poles
2349       ! [tendency(jds) and tendency(jde)=0]
2350       IF ( config_flags%polar .AND. (j == jds+1) ) THEN
2351         DO k=kts,ktf
2352         DO i = i_start, i_end
2353           tendency(i,k,j-1) = 0.
2354         END DO
2355         END DO
2356       ! If j_end were set to jde in a special if statement apart from
2357       ! degrade_ye, then we would hit the next conditional.  But since
2358       ! we want the tendency to be zero anyway, not looping to jde+1
2359       ! will produce the same effect.
2360       ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
2361         DO k=kts,ktf
2362         DO i = i_start, i_end
2363           tendency(i,k,j-1) = 0.
2364         END DO
2365         END DO
2366       ELSE  ! Normal code
2367
2368       IF( j > j_start) THEN
2369         DO k = kts, ktf
2370         DO i = i_start, i_end
2371             mrdy=msfvy(i,j-1)*rdy     ! ADT eqn 45, 2nd term on RHS
2372             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
2373         ENDDO
2374         ENDDO
2375
2376       END IF
2377
2378       END IF
2379
2380       jtmp = jp1
2381       jp1 = jp0
2382       jp0 = jtmp
2383
2384    ENDDO
2385
2386 !  next, x - flux divergence
2387
2388
2389       i_start = its
2390       i_end   = MIN(ite,ide-1)
2391
2392       j_start = jts
2393       j_end   = jte
2394       ! Polar boundary conditions are like open or specified
2395       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2396       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
2397
2398 !  3rd or 4th order flux has a 5 point stencil, so compute
2399 !  bounds so we can switch to second order flux close to the boundary
2400
2401       i_start_f = i_start
2402       i_end_f   = i_end+1
2403
2404       IF(degrade_xs) then
2405         i_start = ids+1
2406         i_start_f = i_start+1
2407       ENDIF
2408
2409       IF(degrade_xe) then
2410         i_end = ide-2
2411         i_end_f = ide-2
2412       ENDIF
2413
2414 !  compute fluxes
2415
2416       DO j = j_start, j_end
2417
2418 !  3rd or 4th order flux
2419
2420         DO k=kts,ktf
2421         DO i = i_start_f, i_end_f
2422           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
2423           fqx( i, k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
2424                                   v(i  ,k,j), v(i+1,k,j),  &
2425                                   vel                     )
2426         ENDDO
2427         ENDDO
2428
2429 !  second order flux close to boundaries (if not periodic or symmetric)
2430
2431         IF( degrade_xs ) THEN
2432           DO k=kts,ktf
2433             fqx(i_start,k) = 0.25*(ru(i_start,k,j)+ru(i_start,k,j-1)) &
2434                    *(v(i_start,k,j)+v(i_start-1,k,j))
2435           ENDDO
2436         ENDIF
2437
2438         IF( degrade_xe ) THEN
2439           DO k=kts,ktf
2440             fqx(i_end+1,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
2441                    *(v(i_end+1,k,j)+v(i_end,k,j))
2442           ENDDO
2443         ENDIF
2444
2445 !  x flux-divergence into tendency
2446
2447         DO k=kts,ktf
2448         DO i = i_start, i_end
2449             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
2450             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
2451         ENDDO
2452         ENDDO
2453
2454       ENDDO
2455
2456    ELSE IF( horz_order == 2 ) THEN
2457
2458
2459       i_start = its
2460       i_end   = MIN(ite,ide-1)
2461       j_start = jts
2462       j_end   = jte
2463
2464       IF ( config_flags%open_ys ) j_start = MAX(jds+1,jts)
2465       IF ( config_flags%open_ye ) j_end   = MIN(jde-1,jte)
2466       IF ( specified ) j_start = MAX(jds+2,jts)
2467       IF ( specified ) j_end   = MIN(jde-2,jte)
2468       IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
2469       IF ( config_flags%polar ) j_end   = MIN(jde-1,jte)
2470
2471       DO j = j_start, j_end
2472       DO k=kts,ktf
2473       DO i = i_start, i_end
2474
2475          mrdy=msfvy(i,j)*rdy          ! ADT eqn 45, 2nd term on RHS
2476
2477             tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2478                             *((rv(i,k,j+1)+rv(i,k,j  ))*(v(i,k,j+1)+v(i,k,j  )) &
2479                              -(rv(i,k,j  )+rv(i,k,j-1))*(v(i,k,j  )+v(i,k,j-1)))
2480
2481       ENDDO
2482       ENDDO
2483       ENDDO
2484
2485       ! Comments on polar boundary conditions
2486       ! tendencies = 0 at poles, and polar points do not contribute at points
2487       ! next to poles
2488       IF (config_flags%polar) THEN
2489          IF (jts == jds) THEN
2490             DO k=kts,ktf
2491             DO i = i_start, i_end
2492                tendency(i,k,jds) = 0.
2493             END DO
2494             END DO
2495          END IF
2496          IF (jte == jde) THEN
2497             DO k=kts,ktf
2498             DO i = i_start, i_end
2499                tendency(i,k,jde) = 0.
2500             END DO
2501             END DO
2502          END IF
2503       END IF
2504
2505 !  specified uses upstream normal wind at boundaries
2506
2507       IF ( specified .AND. jts .LE. jds+1 ) THEN
2508         j = jds+1
2509         DO k=kts,ktf
2510         DO i = i_start, i_end
2511            mrdy=msfvy(i,j)*rdy       ! ADT eqn 45, 2nd term on RHS
2512            vb = v(i,k,j-1)
2513            IF (v(i,k,j) .LT. 0.) vb = v(i,k,j)
2514
2515               tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2516                               *((rv(i,k,j+1)+rv(i,k,j  ))*(v(i,k,j+1)+v(i,k,j  )) &
2517                                -(rv(i,k,j  )+rv(i,k,j-1))*(v(i,k,j  )+vb))
2518
2519         ENDDO
2520         ENDDO
2521       ENDIF
2522
2523       IF ( specified .AND. jte .GE. jde-1 ) THEN
2524         j = jde-1
2525         DO k=kts,ktf
2526         DO i = i_start, i_end
2527
2528            mrdy=msfvy(i,j)*rdy       ! ADT eqn 45, 2nd term on RHS
2529            vb = v(i,k,j+1)
2530            IF (v(i,k,j) .GT. 0.) vb = v(i,k,j)
2531
2532               tendency(i,k,j)=tendency(i,k,j) -mrdy*0.25 &
2533                               *((rv(i,k,j+1)+rv(i,k,j  ))*(vb+v(i,k,j  )) &
2534                                -(rv(i,k,j  )+rv(i,k,j-1))*(v(i,k,j  )+v(i,k,j-1)))
2535
2536         ENDDO
2537         ENDDO
2538       ENDIF
2539
2540       IF ( .NOT. config_flags%periodic_x ) THEN
2541         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
2542         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
2543       ENDIF
2544       IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
2545       IF ( config_flags%polar ) j_end   = MIN(jde-1,jte)
2546
2547       DO j = j_start, j_end
2548       DO k=kts,ktf
2549       DO i = i_start, i_end
2550
2551          mrdx=msfvy(i,j)*rdx         ! ADT eqn 45, 1st term on RHS
2552
2553             tendency(i,k,j)=tendency(i,k,j)-mrdx*0.25 &
2554                             *((ru(i+1,k,j)+ru(i+1,k,j-1))*(v(i+1,k,j)+v(i  ,k,j)) &
2555                              -(ru(i  ,k,j)+ru(i  ,k,j-1))*(v(i  ,k,j)+v(i-1,k,j)))
2556
2557       ENDDO
2558       ENDDO
2559       ENDDO
2560
2561    ELSE IF ( horz_order == 0 ) THEN
2562
2563       ! Just in case we want to turn horizontal advection off, we can do it
2564
2565   ELSE
2566
2567
2568       WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: h_order not known ',horz_order
2569       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
2570
2571    ENDIF horizontal_order_test
2572
2573    !  Comments on polar boundary condition
2574    !  Force tendency=0 at NP and SP
2575    !  We keep setting this everywhere, but it can't hurt...
2576    IF ( config_flags%polar .AND. (jts == jds) ) THEN
2577       DO i=its,ite
2578       DO k=kts,ktf
2579          tendency(i,k,jts)=0.
2580       END DO
2581       END DO
2582    END IF
2583    IF ( config_flags%polar .AND. (jte == jde) ) THEN
2584       DO i=its,ite
2585       DO k=kts,ktf
2586          tendency(i,k,jte)=0.
2587       END DO
2588       END DO
2589    END IF
2590
2591 !  radiative lateral boundary condition in y for normal velocity (v)
2592
2593       IF ( (config_flags%open_ys) .and. jts == jds ) THEN
2594
2595         i_start = its
2596         i_end   = MIN(ite,ide-1)
2597
2598         DO i = i_start, i_end
2599         DO k = kts, ktf
2600           vb = MIN(rv(i,k,jts)-cb*mut(i,jts), 0.)
2601           tendency(i,k,jts) = tendency(i,k,jts)                    &
2602                       - rdy*vb*(v_old(i,k,jts+1) - v_old(i,k,jts))
2603         ENDDO
2604         ENDDO
2605
2606       ENDIF
2607
2608       IF ( (config_flags%open_ye) .and. jte == jde ) THEN
2609
2610         i_start = its
2611         i_end   = MIN(ite,ide-1)
2612
2613         DO i = i_start, i_end
2614         DO k = kts, ktf
2615           vb = MAX(rv(i,k,jte)+cb*mut(i,jte-1), 0.)
2616           tendency(i,k,jte) = tendency(i,k,jte)                    &
2617                       - rdy*vb*(v_old(i,k,jte) - v_old(i,k,jte-1))
2618         ENDDO
2619         ENDDO
2620
2621       ENDIF
2622
2623 !  pick up the rest of the horizontal radiation boundary conditions.
2624 !  (these are the computations that don't require 'cb'.
2625 !  first, set to index ranges
2626
2627       j_start = jts
2628       j_end   = MIN(jte,jde)
2629
2630       jmin    = jds
2631       jmax    = jde-1
2632
2633       IF (config_flags%open_ys) THEN
2634           j_start = MAX(jds+1, jts)
2635           jmin = jds
2636       ENDIF
2637       IF (config_flags%open_ye) THEN
2638           j_end = MIN(jte,jde-1)
2639           jmax = jde-1
2640       ENDIF
2641
2642 !  compute x (u) conditions for v, w, or scalar
2643
2644    IF( (config_flags%open_xs) .and. (its == ids)) THEN
2645
2646       DO j = j_start, j_end
2647
2648          mrdx=msfvy(its,j)*rdx       ! ADT eqn 45, 1st term on RHS
2649          jp = MIN( jmax, j   )
2650          jm = MAX( jmin, j-1 )
2651
2652          DO k=kts,ktf
2653
2654           uw = 0.5*(ru(its,k,jp)+ru(its,k,jm))
2655           ub = MIN( uw, 0. )
2656           dup =  ru(its+1,k,jp)-ru(its,k,jp)
2657           dum =  ru(its+1,k,jm)-ru(its,k,jm)
2658           tendency(its,k,j)=tendency(its,k,j)-mrdx*(               &
2659                             ub*(v_old(its+1,k,j)-v_old(its,k,j))   &
2660                            +0.5*v(its,k,j)*(dup+dum))
2661          ENDDO
2662       ENDDO
2663
2664    ENDIF
2665
2666    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
2667       DO j = j_start, j_end
2668
2669          mrdx=msfvy(ite-1,j)*rdx     ! ADT eqn 45, 1st term on RHS
2670          jp = MIN( jmax, j   )
2671          jm = MAX( jmin, j-1 )
2672
2673          DO k=kts,ktf
2674
2675           uw = 0.5*(ru(ite,k,jp)+ru(ite,k,jm))
2676           ub = MAX( uw, 0. )
2677           dup = ru(ite,k,jp)-ru(ite-1,k,jp)
2678           dum = ru(ite,k,jm)-ru(ite-1,k,jm)
2679
2680 !          tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
2681 !                            ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
2682 !                           +0.5*v(ite-1,k,j)*                         &
2683 !                                  ( ru(ite,k,jp)-ru(ite-1,k,jp)       &
2684 !                                   +ru(ite,k,jm)-ru(ite-1,k,jm))     )
2685           tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
2686                             ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
2687                            +0.5*v(ite-1,k,j)*(dup+dum))
2688
2689          ENDDO
2690       ENDDO
2691
2692    ENDIF
2693
2694 !-------------------- vertical advection
2695 !     ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
2696 !     Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
2697 !     We therefore need to make a correction for advect_v
2698 !     since 'my' (map scale factor in y direction) isn't a function of z,
2699 !     we can do this using *(my/mx) (see eqn. 45 for example)
2700
2701
2702       i_start = its
2703       i_end   = MIN(ite,ide-1)
2704       j_start = jts
2705       j_end   = jte
2706
2707       DO i = i_start, i_end
2708          vflux(i,kts)=0.
2709          vflux(i,kte)=0.
2710       ENDDO
2711
2712       ! Polar boundary conditions are like open or specified
2713       ! We don't want to calculate vertical v tendencies at the N or S pole
2714       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
2715       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
2716
2717     vert_order_test : IF (vert_order == 6) THEN
2718
2719       DO j = j_start, j_end
2720
2721
2722          DO k=kts+3,ktf-2
2723          DO i = i_start, i_end
2724            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2725            vflux(i,k) = vel*flux6(                       &
2726                    v(i,k-3,j), v(i,k-2,j), v(i,k-1,j),       &
2727                    v(i,k  ,j), v(i,k+1,j), v(i,k+2,j),  -vel )
2728          ENDDO
2729          ENDDO
2730
2731          DO i = i_start, i_end
2732            k=kts+1
2733            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2734                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2735            k = kts+2
2736            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2737            vflux(i,k) = vel*flux4(       &
2738                    v(i,k-2,j), v(i,k-1,j),   &
2739                    v(i,k  ,j), v(i,k+1,j), -vel )
2740            k = ktf-1
2741            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2742            vflux(i,k) = vel*flux4(       &
2743                    v(i,k-2,j), v(i,k-1,j),   &
2744                    v(i,k  ,j), v(i,k+1,j), -vel )
2745            k=ktf
2746            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2747                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2748
2749          ENDDO
2750
2751
2752          DO k=kts,ktf
2753          DO i = i_start, i_end
2754             ! We are calculating vertical fluxes on v points,
2755             ! so we must mean msf_v_x/y variables
2756             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
2757          ENDDO
2758          ENDDO
2759
2760       ENDDO
2761
2762    ELSE IF (vert_order == 5) THEN
2763
2764       DO j = j_start, j_end
2765
2766
2767          DO k=kts+3,ktf-2
2768          DO i = i_start, i_end
2769            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2770            vflux(i,k) = vel*flux5(                       &
2771                    v(i,k-3,j), v(i,k-2,j), v(i,k-1,j),       &
2772                    v(i,k  ,j), v(i,k+1,j), v(i,k+2,j),  -vel )
2773          ENDDO
2774          ENDDO
2775
2776          DO i = i_start, i_end
2777            k=kts+1
2778            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2779                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2780            k = kts+2
2781            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2782            vflux(i,k) = vel*flux3(       &
2783                    v(i,k-2,j), v(i,k-1,j),   &
2784                    v(i,k  ,j), v(i,k+1,j), -vel )
2785            k = ktf-1
2786            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2787            vflux(i,k) = vel*flux3(       &
2788                    v(i,k-2,j), v(i,k-1,j),   &
2789                    v(i,k  ,j), v(i,k+1,j), -vel )
2790            k=ktf
2791            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2792                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2793
2794          ENDDO
2795
2796
2797          DO k=kts,ktf
2798          DO i = i_start, i_end
2799             ! We are calculating vertical fluxes on v points,
2800             ! so we must mean msf_v_x/y variables
2801             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
2802          ENDDO
2803          ENDDO
2804
2805       ENDDO
2806
2807     ELSE IF (vert_order == 4) THEN
2808
2809       DO j = j_start, j_end
2810
2811
2812          DO k=kts+2,ktf-1
2813          DO i = i_start, i_end
2814            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2815            vflux(i,k) = vel*flux4(               &
2816                    v(i,k-2,j), v(i,k-1,j),       &
2817                    v(i,k  ,j), v(i,k+1,j), -vel )
2818          ENDDO
2819          ENDDO
2820
2821          DO i = i_start, i_end
2822            k=kts+1
2823            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2824                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2825            k=ktf
2826            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2827                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2828
2829          ENDDO
2830
2831
2832          DO k=kts,ktf
2833          DO i = i_start, i_end
2834             ! We are calculating vertical fluxes on v points,
2835             ! so we must mean msf_v_x/y variables
2836             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
2837          ENDDO
2838          ENDDO
2839
2840       ENDDO
2841
2842     ELSE IF (vert_order == 3) THEN
2843
2844       DO j = j_start, j_end
2845
2846
2847          DO k=kts+2,ktf-1
2848          DO i = i_start, i_end
2849            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
2850            vflux(i,k) = vel*flux3(               &
2851                    v(i,k-2,j), v(i,k-1,j),       &
2852                    v(i,k  ,j), v(i,k+1,j), -vel )
2853          ENDDO
2854          ENDDO
2855
2856          DO i = i_start, i_end
2857            k=kts+1
2858            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
2859                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2860            k=ktf
2861            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2862                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2863
2864          ENDDO
2865
2866
2867          DO k=kts,ktf
2868          DO i = i_start, i_end
2869             ! We are calculating vertical fluxes on v points,
2870             ! so we must mean msf_v_x/y variables
2871             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
2872          ENDDO
2873          ENDDO
2874
2875       ENDDO
2876
2877
2878     ELSE IF (vert_order == 2) THEN
2879
2880    DO j = j_start, j_end
2881       DO k=kts+1,ktf
2882       DO i = i_start, i_end
2883
2884             vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
2885                                     *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
2886       ENDDO
2887       ENDDO
2888
2889       DO k=kts,ktf
2890       DO i = i_start, i_end
2891             ! We are calculating vertical fluxes on v points,
2892             ! so we must mean msf_v_x/y variables
2893             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
2894       ENDDO
2895       ENDDO
2896    ENDDO
2897
2898    ELSE
2899
2900       WRITE ( wrf_err_message , * ) 'module_advect: advect_v_6a: v_order not known ',vert_order
2901       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
2902
2903    ENDIF vert_order_test
2904
2905 END SUBROUTINE advect_v
2906
2907 !-------------------------------------------------------------------
2908
2909 SUBROUTINE advect_scalar   ( field, field_old, tendency,    &
2910                              ru, rv, rom,                   &
2911                              mut, time_step, config_flags,  &
2912                              msfux, msfuy, msfvx, msfvy,    &
2913                              msftx, msfty,                  &
2914                              fzm, fzp,                      &
2915                              rdx, rdy, rdzw,                &
2916                              ids, ide, jds, jde, kds, kde,  &
2917                              ims, ime, jms, jme, kms, kme,  &
2918                              its, ite, jts, jte, kts, kte  )
2919
2920    IMPLICIT NONE
2921
2922    ! Input data
2923
2924    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
2925
2926    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
2927                                               ims, ime, jms, jme, kms, kme, &
2928                                               its, ite, jts, jte, kts, kte
2929
2930    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
2931                                                                       field_old, &
2932                                                                       ru,    &
2933                                                                       rv,    &
2934                                                                       rom
2935
2936    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
2937    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
2938
2939    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
2940                                                                     msfuy,  &
2941                                                                     msfvx,  &
2942                                                                     msfvy,  &
2943                                                                     msftx,  &
2944                                                                     msfty
2945
2946    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
2947                                                                   fzp,  &
2948                                                                   rdzw
2949
2950    REAL ,                                        INTENT(IN   ) :: rdx,  &
2951                                                                   rdy
2952    INTEGER ,                                     INTENT(IN   ) :: time_step
2953
2954
2955    ! Local data
2956
2957    INTEGER :: i, j, k, itf, jtf, ktf
2958    INTEGER :: i_start, i_end, j_start, j_end
2959    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
2960    INTEGER :: jmin, jmax, jp, jm, imin, imax
2961
2962    REAL    :: mrdx, mrdy, ub, vb, uw, vw
2963    REAL , DIMENSION(its:ite, kts:kte) :: vflux
2964
2965
2966    REAL,  DIMENSION( its:ite+1, kts:kte  ) :: fqx
2967    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
2968
2969    INTEGER :: horz_order, vert_order
2970
2971    LOGICAL :: degrade_xs, degrade_ys
2972    LOGICAL :: degrade_xe, degrade_ye
2973
2974    INTEGER :: jp1, jp0, jtmp
2975
2976
2977 ! definition of flux operators, 3rd, 4th, 5th or 6th order
2978
2979    REAL    :: flux3, flux4, flux5, flux6
2980    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
2981
2982       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
2983           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
2984
2985       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
2986            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
2987            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
2988
2989       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
2990           ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)                  &
2991             +(q_ip2+q_im3) )/60.0
2992
2993       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
2994            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
2995             -sign(1,time_step)*sign(1.,ua)*(                    &
2996               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
2997
2998
2999    LOGICAL :: specified
3000
3001    specified = .false.
3002    if(config_flags%specified .or. config_flags%nested) specified = .true.
3003
3004 ! set order for the advection schemes
3005
3006   ktf=MIN(kte,kde-1)
3007   horz_order = config_flags%h_sca_adv_order
3008   vert_order = config_flags%v_sca_adv_order
3009
3010 !  begin with horizontal flux divergence
3011 !  here is the choice of flux operators
3012
3013
3014   horizontal_order_test : IF( horz_order == 6 ) THEN
3015
3016 !  determine boundary mods for flux operators
3017 !  We degrade the flux operators from 3rd/4th order
3018 !   to second order one gridpoint in from the boundaries for
3019 !   all boundary conditions except periodic and symmetry - these
3020 !   conditions have boundary zone data fill for correct application
3021 !   of the higher order flux stencils
3022
3023    degrade_xs = .true.
3024    degrade_xe = .true.
3025    degrade_ys = .true.
3026    degrade_ye = .true.
3027
3028    IF( config_flags%periodic_x   .or. &
3029        config_flags%symmetric_xs .or. &
3030        (its > ids+3)                ) degrade_xs = .false.
3031    IF( config_flags%periodic_x   .or. &
3032        config_flags%symmetric_xe .or. &
3033        (ite < ide-3)                ) degrade_xe = .false.
3034    IF( config_flags%periodic_y   .or. &
3035        config_flags%symmetric_ys .or. &
3036        (jts > jds+3)                ) degrade_ys = .false.
3037    IF( config_flags%periodic_y   .or. &
3038        config_flags%symmetric_ye .or. &
3039        (jte < jde-4)                ) degrade_ye = .false.
3040
3041 !--------------- y - advection first
3042
3043       ktf=MIN(kte,kde-1)
3044       i_start = its
3045       i_end   = MIN(ite,ide-1)
3046       j_start = jts
3047       j_end   = MIN(jte,jde-1)
3048
3049 !  higher order flux has a 5 or 7 point stencil, so compute
3050 !  bounds so we can switch to second order flux close to the boundary
3051
3052       j_start_f = j_start
3053       j_end_f   = j_end+1
3054
3055       IF(degrade_ys) then
3056         j_start = MAX(jts,jds+1)
3057         j_start_f = jds+3
3058       ENDIF
3059
3060       IF(degrade_ye) then
3061         j_end = MIN(jte,jde-2)
3062         j_end_f = jde-3
3063       ENDIF
3064
3065       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3066
3067 !  compute fluxes, 5th or 6th order
3068
3069      jp1 = 2
3070      jp0 = 1
3071
3072      j_loop_y_flux_6 : DO j = j_start, j_end+1
3073
3074       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
3075
3076         DO k=kts,ktf
3077         DO i = i_start, i_end
3078           vel = rv(i,k,j)
3079           fqy( i, k, jp1 ) = vel*flux6(                                &
3080                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
3081                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
3082         ENDDO
3083         ENDDO
3084
3085
3086       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
3087
3088             DO k=kts,ktf
3089             DO i = i_start, i_end
3090               fqy(i,k, jp1) = 0.5*rv(i,k,j)*          &
3091                      (field(i,k,j)+field(i,k,j-1))
3092
3093             ENDDO
3094             ENDDO
3095
3096      ELSE IF  ( j == jds+2 ) THEN  ! 4th order flux 2 in from south boundary
3097
3098             DO k=kts,ktf
3099             DO i = i_start, i_end
3100               vel = rv(i,k,j)
3101               fqy( i, k, jp1 ) = vel*flux4(              &
3102                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
3103             ENDDO
3104             ENDDO
3105
3106      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
3107
3108             DO k=kts,ktf
3109             DO i = i_start, i_end
3110               fqy(i, k, jp1) = 0.5*rv(i,k,j)*      &
3111                      (field(i,k,j)+field(i,k,j-1))
3112             ENDDO
3113             ENDDO
3114
3115      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
3116
3117             DO k=kts,ktf
3118             DO i = i_start, i_end
3119               vel = rv(i,k,j)
3120               fqy( i, k, jp1) = vel*flux4(             &
3121                    field(i,k,j-2),field(i,k,j-1),    &
3122                    field(i,k,j),field(i,k,j+1),vel )
3123             ENDDO
3124             ENDDO
3125
3126      ENDIF
3127
3128 !  y flux-divergence into tendency
3129
3130         ! Comments on polar boundary conditions
3131         ! Same process as for advect_u - tendencies run from jds to jde-1
3132         ! (latitudes are as for u grid, longitudes are displaced)
3133         ! Therefore: flow is only from one side for points next to poles
3134         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3135           DO k=kts,ktf
3136           DO i = i_start, i_end
3137             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3138             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3139           END DO
3140           END DO
3141         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3142           DO k=kts,ktf
3143           DO i = i_start, i_end
3144             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3145             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3146           END DO
3147           END DO
3148         ELSE  ! normal code
3149
3150         IF(j > j_start) THEN
3151
3152           DO k=kts,ktf
3153           DO i = i_start, i_end
3154             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3155             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3156           ENDDO
3157           ENDDO
3158
3159         ENDIF
3160
3161         END IF
3162
3163         jtmp = jp1
3164         jp1 = jp0
3165         jp0 = jtmp
3166
3167       ENDDO j_loop_y_flux_6
3168
3169 !  next, x - flux divergence
3170
3171       i_start = its
3172       i_end   = MIN(ite,ide-1)
3173
3174       j_start = jts
3175       j_end   = MIN(jte,jde-1)
3176
3177 !  higher order flux has a 5 or 7 point stencil, so compute
3178 !  bounds so we can switch to second order flux close to the boundary
3179
3180       i_start_f = i_start
3181       i_end_f   = i_end+1
3182
3183       IF(degrade_xs) then
3184         i_start = MAX(ids+1,its)
3185 !        i_start_f = i_start+2
3186         i_start_f = MIN(i_start+2,ids+3)
3187       ENDIF
3188
3189       IF(degrade_xe) then
3190         i_end = MIN(ide-2,ite)
3191         i_end_f = ide-3
3192       ENDIF
3193
3194 !  compute fluxes
3195
3196       DO j = j_start, j_end
3197
3198 !  5th or 6th order flux
3199
3200         DO k=kts,ktf
3201         DO i = i_start_f, i_end_f
3202           vel = ru(i,k,j)
3203           fqx( i,k ) = vel*flux6( field(i-3,k,j), field(i-2,k,j),  &
3204                                          field(i-1,k,j), field(i  ,k,j),  &
3205                                          field(i+1,k,j), field(i+2,k,j),  &
3206                                          vel                             )
3207         ENDDO
3208         ENDDO
3209
3210 !  lower order fluxes close to boundaries (if not periodic or symmetric)
3211
3212         IF( degrade_xs ) THEN
3213
3214           DO i=i_start,i_start_f-1
3215
3216             IF(i == ids+1) THEN ! second order
3217               DO k=kts,ktf
3218                 fqx(i,k) = 0.5*(ru(i,k,j)) &
3219                        *(field(i,k,j)+field(i-1,k,j))
3220               ENDDO
3221             ENDIF
3222
3223             IF(i == ids+2) THEN  ! third order
3224               DO k=kts,ktf
3225                 vel = ru(i,k,j)
3226                 fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
3227                                               field(i  ,k,j), field(i+1,k,j),  &
3228                                               vel                     )
3229               ENDDO
3230             END IF
3231
3232           ENDDO
3233
3234         ENDIF
3235
3236         IF( degrade_xe ) THEN
3237
3238           DO i = i_end_f+1, i_end+1
3239
3240             IF( i == ide-1 ) THEN ! second order flux next to the boundary
3241               DO k=kts,ktf
3242                 fqx(i,k) = 0.5*(ru(i,k,j))      &
3243                        *(field(i,k,j)+field(i-1,k,j))
3244               ENDDO
3245            ENDIF
3246
3247            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
3248              DO k=kts,ktf
3249                vel = ru(i,k,j)
3250                fqx( i,k ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
3251                                        field(i  ,k,j), field(i+1,k,j),  &
3252                                        vel                             )
3253              ENDDO
3254            ENDIF
3255
3256          ENDDO
3257
3258        ENDIF
3259
3260 !  x flux-divergence into tendency
3261
3262           DO k=kts,ktf
3263           DO i = i_start, i_end
3264             mrdx=msftx(i,j)*rdx      ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3265             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3266           ENDDO
3267           ENDDO
3268
3269       ENDDO
3270
3271   ELSE IF( horz_order == 5 ) THEN
3272
3273 !  determine boundary mods for flux operators
3274 !  We degrade the flux operators from 3rd/4th order
3275 !   to second order one gridpoint in from the boundaries for
3276 !   all boundary conditions except periodic and symmetry - these
3277 !   conditions have boundary zone data fill for correct application
3278 !   of the higher order flux stencils
3279
3280    degrade_xs = .true.
3281    degrade_xe = .true.
3282    degrade_ys = .true.
3283    degrade_ye = .true.
3284
3285    IF( config_flags%periodic_x   .or. &
3286        config_flags%symmetric_xs .or. &
3287        (its > ids+3)                ) degrade_xs = .false.
3288    IF( config_flags%periodic_x   .or. &
3289        config_flags%symmetric_xe .or. &
3290        (ite < ide-3)                ) degrade_xe = .false.
3291    IF( config_flags%periodic_y   .or. &
3292        config_flags%symmetric_ys .or. &
3293        (jts > jds+3)                ) degrade_ys = .false.
3294    IF( config_flags%periodic_y   .or. &
3295        config_flags%symmetric_ye .or. &
3296        (jte < jde-4)                ) degrade_ye = .false.
3297
3298 !--------------- y - advection first
3299
3300       ktf=MIN(kte,kde-1)
3301       i_start = its
3302       i_end   = MIN(ite,ide-1)
3303       j_start = jts
3304       j_end   = MIN(jte,jde-1)
3305
3306 !  higher order flux has a 5 or 7 point stencil, so compute
3307 !  bounds so we can switch to second order flux close to the boundary
3308
3309       j_start_f = j_start
3310       j_end_f   = j_end+1
3311
3312       IF(degrade_ys) then
3313         j_start = MAX(jts,jds+1)
3314         j_start_f = jds+3
3315       ENDIF
3316
3317       IF(degrade_ye) then
3318         j_end = MIN(jte,jde-2)
3319         j_end_f = jde-3
3320       ENDIF
3321
3322       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3323
3324 !  compute fluxes, 5th or 6th order
3325
3326      jp1 = 2
3327      jp0 = 1
3328
3329      j_loop_y_flux_5 : DO j = j_start, j_end+1
3330
3331       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
3332
3333         DO k=kts,ktf
3334         DO i = i_start, i_end
3335           vel = rv(i,k,j)
3336           fqy( i, k, jp1 ) = vel*flux5(                                &
3337                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
3338                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
3339         ENDDO
3340         ENDDO
3341
3342
3343       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
3344
3345             DO k=kts,ktf
3346             DO i = i_start, i_end
3347               fqy(i,k, jp1) = 0.5*rv(i,k,j)*          &
3348                      (field(i,k,j)+field(i,k,j-1))
3349
3350             ENDDO
3351             ENDDO
3352
3353      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
3354
3355             DO k=kts,ktf
3356             DO i = i_start, i_end
3357               vel = rv(i,k,j)
3358               fqy( i, k, jp1 ) = vel*flux3(              &
3359                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
3360             ENDDO
3361             ENDDO
3362
3363      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
3364
3365             DO k=kts,ktf
3366             DO i = i_start, i_end
3367               fqy(i, k, jp1) = 0.5*rv(i,k,j)*      &
3368                      (field(i,k,j)+field(i,k,j-1))
3369             ENDDO
3370             ENDDO
3371
3372      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
3373
3374             DO k=kts,ktf
3375             DO i = i_start, i_end
3376               vel = rv(i,k,j)
3377               fqy( i, k, jp1) = vel*flux3(             &
3378                    field(i,k,j-2),field(i,k,j-1),    &
3379                    field(i,k,j),field(i,k,j+1),vel )
3380             ENDDO
3381             ENDDO
3382
3383      ENDIF
3384
3385 !  y flux-divergence into tendency
3386
3387         ! Comments on polar boundary conditions
3388         ! Same process as for advect_u - tendencies run from jds to jde-1
3389         ! (latitudes are as for u grid, longitudes are displaced)
3390         ! Therefore: flow is only from one side for points next to poles
3391         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3392           DO k=kts,ktf
3393           DO i = i_start, i_end
3394             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3395             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3396           END DO
3397           END DO
3398         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3399           DO k=kts,ktf
3400           DO i = i_start, i_end
3401             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3402             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3403           END DO
3404           END DO
3405         ELSE  ! normal code
3406
3407         IF(j > j_start) THEN
3408
3409           DO k=kts,ktf
3410           DO i = i_start, i_end
3411             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3412             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3413           ENDDO
3414           ENDDO
3415
3416         ENDIF
3417
3418         END IF
3419
3420         jtmp = jp1
3421         jp1 = jp0
3422         jp0 = jtmp
3423
3424       ENDDO j_loop_y_flux_5
3425
3426 !  next, x - flux divergence
3427
3428       i_start = its
3429       i_end   = MIN(ite,ide-1)
3430
3431       j_start = jts
3432       j_end   = MIN(jte,jde-1)
3433
3434 !  higher order flux has a 5 or 7 point stencil, so compute
3435 !  bounds so we can switch to second order flux close to the boundary
3436
3437       i_start_f = i_start
3438       i_end_f   = i_end+1
3439
3440       IF(degrade_xs) then
3441         i_start = MAX(ids+1,its)
3442 !        i_start_f = i_start+2
3443         i_start_f = MIN(i_start+2,ids+3)
3444       ENDIF
3445
3446       IF(degrade_xe) then
3447         i_end = MIN(ide-2,ite)
3448         i_end_f = ide-3
3449       ENDIF
3450
3451 !  compute fluxes
3452
3453       DO j = j_start, j_end
3454
3455 !  5th or 6th order flux
3456
3457         DO k=kts,ktf
3458         DO i = i_start_f, i_end_f
3459           vel = ru(i,k,j)
3460           fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
3461                                          field(i-1,k,j), field(i  ,k,j),  &
3462                                          field(i+1,k,j), field(i+2,k,j),  &
3463                                          vel                             )
3464         ENDDO
3465         ENDDO
3466
3467 !  lower order fluxes close to boundaries (if not periodic or symmetric)
3468
3469         IF( degrade_xs ) THEN
3470
3471           DO i=i_start,i_start_f-1
3472
3473             IF(i == ids+1) THEN ! second order
3474               DO k=kts,ktf
3475                 fqx(i,k) = 0.5*(ru(i,k,j)) &
3476                        *(field(i,k,j)+field(i-1,k,j))
3477               ENDDO
3478             ENDIF
3479
3480             IF(i == ids+2) THEN  ! third order
3481               DO k=kts,ktf
3482                 vel = ru(i,k,j)
3483                 fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
3484                                               field(i  ,k,j), field(i+1,k,j),  &
3485                                               vel                     )
3486               ENDDO
3487             END IF
3488
3489           ENDDO
3490
3491         ENDIF
3492
3493         IF( degrade_xe ) THEN
3494
3495           DO i = i_end_f+1, i_end+1
3496
3497             IF( i == ide-1 ) THEN ! second order flux next to the boundary
3498               DO k=kts,ktf
3499                 fqx(i,k) = 0.5*(ru(i,k,j))      &
3500                        *(field(i,k,j)+field(i-1,k,j))
3501               ENDDO
3502            ENDIF
3503
3504            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
3505              DO k=kts,ktf
3506                vel = ru(i,k,j)
3507                fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
3508                                        field(i  ,k,j), field(i+1,k,j),  &
3509                                        vel                             )
3510              ENDDO
3511            ENDIF
3512
3513          ENDDO
3514
3515        ENDIF
3516
3517 !  x flux-divergence into tendency
3518
3519           DO k=kts,ktf
3520           DO i = i_start, i_end
3521             mrdx=msftx(i,j)*rdx      ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3522             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3523           ENDDO
3524           ENDDO
3525
3526       ENDDO
3527
3528
3529    ELSE IF( horz_order == 4 ) THEN
3530
3531    degrade_xs = .true.
3532    degrade_xe = .true.
3533    degrade_ys = .true.
3534    degrade_ye = .true.
3535
3536    IF( config_flags%periodic_x   .or. &
3537        config_flags%symmetric_xs .or. &
3538        (its > ids+2)                ) degrade_xs = .false.
3539    IF( config_flags%periodic_x   .or. &
3540        config_flags%symmetric_xe .or. &
3541        (ite < ide-2)                ) degrade_xe = .false.
3542    IF( config_flags%periodic_y   .or. &
3543        config_flags%symmetric_ys .or. &
3544        (jts > jds+2)                ) degrade_ys = .false.
3545    IF( config_flags%periodic_y   .or. &
3546        config_flags%symmetric_ye .or. &
3547        (jte < jde-3)                ) degrade_ye = .false.
3548
3549 !  begin flux computations
3550 !  start with x flux divergence
3551
3552    ktf=MIN(kte,kde-1)
3553
3554       i_start = its
3555       i_end   = MIN(ite,ide-1)
3556       j_start = jts
3557       j_end   = MIN(jte,jde-1)
3558
3559 !  3rd or 4th order flux has a 5 point stencil, so compute
3560 !  bounds so we can switch to second order flux close to the boundary
3561
3562       i_start_f = i_start
3563       i_end_f   = i_end+1
3564
3565       IF(degrade_xs) then
3566         i_start = ids+1
3567         i_start_f = i_start+1
3568       ENDIF
3569
3570       IF(degrade_xe) then
3571         i_end = ide-2
3572         i_end_f = ide-2
3573       ENDIF
3574
3575 !  compute fluxes
3576
3577       DO j = j_start, j_end
3578
3579 !  3rd or 4th order flux
3580
3581         DO k=kts,ktf
3582         DO i = i_start_f, i_end_f
3583
3584           fqx( i, k) = ru(i,k,j)*flux4( field(i-2,k,j), field(i-1,k,j),  &
3585                                         field(i  ,k,j), field(i+1,k,j),  &
3586                                         ru(i,k,j)                       )
3587         ENDDO
3588         ENDDO
3589
3590 !  second order flux close to boundaries (if not periodic or symmetric)
3591
3592         IF( degrade_xs ) THEN
3593           DO k=kts,ktf
3594             fqx(i_start, k) = 0.5*ru(i_start,k,j)             &
3595                    *(field(i_start,k,j)+field(i_start-1,k,j))
3596           ENDDO
3597         ENDIF
3598
3599         IF( degrade_xe ) THEN
3600           DO k=kts,ktf
3601             fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j)          &
3602                    *(field(i_end+1,k,j)+field(i_end,k,j))
3603           ENDDO
3604         ENDIF
3605
3606 !  x flux-divergence into tendency
3607
3608         DO k=kts,ktf
3609         DO i = i_start, i_end
3610           mrdx=msftx(i,j)*rdx        ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3611           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3612         ENDDO
3613         ENDDO
3614
3615       ENDDO
3616
3617
3618 !  next -> y flux divergence calculation
3619
3620       i_start = its
3621       i_end   = MIN(ite,ide-1)
3622       j_start = jts
3623       j_end   = MIN(jte,jde-1)
3624
3625 !  3rd or 4th order flux has a 5 point stencil, so compute
3626 !  bounds so we can switch to second order flux close to the boundary
3627
3628       j_start_f = j_start
3629       j_end_f   = j_end+1
3630
3631       IF(degrade_ys) then
3632         j_start = jds+1
3633         j_start_f = j_start+1
3634       ENDIF
3635
3636       IF(degrade_ye) then
3637         j_end = jde-2
3638         j_end_f = jde-2
3639       ENDIF
3640
3641       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3642
3643     jp1 = 2
3644     jp0 = 1
3645
3646   DO j = j_start, j_end+1
3647
3648     IF ((j < j_start_f) .and. degrade_ys) THEN
3649       DO k = kts, ktf
3650       DO i = i_start, i_end
3651          fqy(i,k,jp1) = 0.5*rv(i,k,j_start)             &
3652                 *(field(i,k,j_start)+field(i,k,j_start-1))
3653       ENDDO
3654       ENDDO
3655     ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
3656       DO k = kts, ktf
3657       DO i = i_start, i_end
3658          ! Assumes j>j_end_f is ONLY j_end+1 ...
3659 !         fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1)          &
3660 !                *(field(i,k,j_end+1)+field(i,k,j_end))
3661          fqy(i,k,jp1) = 0.5*rv(i,k,j)          &
3662                 *(field(i,k,j)+field(i,k,j-1))
3663       ENDDO
3664       ENDDO
3665     ELSE
3666 !  3rd or 4th order flux
3667       DO k = kts, ktf
3668       DO i = i_start, i_end
3669          fqy( i, k, jp1 ) = rv(i,k,j)*flux4( field(i,k,j-2), field(i,k,j-1),  &
3670                                             field(i,k,j  ), field(i,k,j+1),  &
3671                                             rv(i,k,j)                       )
3672       ENDDO
3673       ENDDO
3674     END IF
3675
3676 !  y flux-divergence into tendency
3677
3678     ! Comments on polar boundary conditions
3679     ! Same process as for advect_u - tendencies run from jds to jde-1
3680     ! (latitudes are as for u grid, longitudes are displaced)
3681     ! Therefore: flow is only from one side for points next to poles
3682     IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3683       DO k=kts,ktf
3684       DO i = i_start, i_end
3685         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3686         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3687       END DO
3688       END DO
3689     ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3690       DO k=kts,ktf
3691       DO i = i_start, i_end
3692         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3693         tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3694       END DO
3695       END DO
3696     ELSE  ! normal code
3697
3698     IF ( j > j_start ) THEN
3699
3700       DO k=kts,ktf
3701       DO i = i_start, i_end
3702         mrdy=msftx(i,j-1)*rdy        ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3703         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3704       ENDDO
3705       ENDDO
3706
3707     END IF
3708
3709     END IF
3710
3711     jtmp = jp1
3712     jp1 = jp0
3713     jp0 = jtmp
3714
3715   ENDDO
3716
3717
3718    ELSE IF( horz_order == 3 ) THEN
3719
3720    degrade_xs = .true.
3721    degrade_xe = .true.
3722    degrade_ys = .true.
3723    degrade_ye = .true.
3724
3725    IF( config_flags%periodic_x   .or. &
3726        config_flags%symmetric_xs .or. &
3727        (its > ids+2)                ) degrade_xs = .false.
3728    IF( config_flags%periodic_x   .or. &
3729        config_flags%symmetric_xe .or. &
3730        (ite < ide-2)                ) degrade_xe = .false.
3731    IF( config_flags%periodic_y   .or. &
3732        config_flags%symmetric_ys .or. &
3733        (jts > jds+2)                ) degrade_ys = .false.
3734    IF( config_flags%periodic_y   .or. &
3735        config_flags%symmetric_ye .or. &
3736        (jte < jde-3)                ) degrade_ye = .false.
3737
3738 !  begin flux computations
3739 !  start with x flux divergence
3740
3741    ktf=MIN(kte,kde-1)
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       i_start_f = i_start
3752       i_end_f   = i_end+1
3753
3754       IF(degrade_xs) then
3755         i_start = ids+1
3756         i_start_f = i_start+1
3757       ENDIF
3758
3759       IF(degrade_xe) then
3760         i_end = ide-2
3761         i_end_f = ide-2
3762       ENDIF
3763
3764 !  compute fluxes
3765
3766       DO j = j_start, j_end
3767
3768 !  3rd or 4th order flux
3769
3770         DO k=kts,ktf
3771         DO i = i_start_f, i_end_f
3772
3773           fqx( i, k) = ru(i,k,j)*flux3( field(i-2,k,j), field(i-1,k,j),  &
3774                                         field(i  ,k,j), field(i+1,k,j),  &
3775                                         ru(i,k,j)                       )
3776         ENDDO
3777         ENDDO
3778
3779 !  second order flux close to boundaries (if not periodic or symmetric)
3780
3781         IF( degrade_xs ) THEN
3782           DO k=kts,ktf
3783             fqx(i_start, k) = 0.5*ru(i_start,k,j)             &
3784                    *(field(i_start,k,j)+field(i_start-1,k,j))
3785           ENDDO
3786         ENDIF
3787
3788         IF( degrade_xe ) THEN
3789           DO k=kts,ktf
3790             fqx(i_end+1,k ) = 0.5*ru(i_end+1,k,j)          &
3791                    *(field(i_end+1,k,j)+field(i_end,k,j))
3792           ENDDO
3793         ENDIF
3794
3795 !  x flux-divergence into tendency
3796
3797         DO k=kts,ktf
3798         DO i = i_start, i_end
3799           mrdx=msftx(i,j)*rdx        ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3800           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
3801         ENDDO
3802         ENDDO
3803
3804       ENDDO
3805
3806
3807 !  next -> y flux divergence calculation
3808
3809       i_start = its
3810       i_end   = MIN(ite,ide-1)
3811       j_start = jts
3812       j_end   = MIN(jte,jde-1)
3813
3814 !  3rd or 4th order flux has a 5 point stencil, so compute
3815 !  bounds so we can switch to second order flux close to the boundary
3816
3817       j_start_f = j_start
3818       j_end_f   = j_end+1
3819
3820       IF(degrade_ys) then
3821         j_start = jds+1
3822         j_start_f = j_start+1
3823       ENDIF
3824
3825       IF(degrade_ye) then
3826         j_end = jde-2
3827         j_end_f = jde-2
3828       ENDIF
3829
3830       IF(config_flags%polar) j_end = MIN(jte,jde-1)
3831
3832     jp1 = 2
3833     jp0 = 1
3834
3835   DO j = j_start, j_end+1
3836
3837     IF ((j < j_start_f) .and. degrade_ys) THEN
3838       DO k = kts, ktf
3839       DO i = i_start, i_end
3840          fqy(i,k,jp1) = 0.5*rv(i,k,j_start)             &
3841                 *(field(i,k,j_start)+field(i,k,j_start-1))
3842       ENDDO
3843       ENDDO
3844     ELSE IF ((j > j_end_f) .and. degrade_ye) THEN
3845       DO k = kts, ktf
3846       DO i = i_start, i_end
3847          ! Assumes j>j_end_f is ONLY j_end+1 ...
3848 !         fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1)          &
3849 !                *(field(i,k,j_end+1)+field(i,k,j_end))
3850          fqy(i,k,jp1) = 0.5*rv(i,k,j)          &
3851                 *(field(i,k,j)+field(i,k,j-1))
3852       ENDDO
3853       ENDDO
3854     ELSE
3855 !  3rd or 4th order flux
3856       DO k = kts, ktf
3857       DO i = i_start, i_end
3858          fqy( i, k, jp1 ) = rv(i,k,j)*flux3( field(i,k,j-2), field(i,k,j-1),  &
3859                                             field(i,k,j  ), field(i,k,j+1),  &
3860                                             rv(i,k,j)                       )
3861       ENDDO
3862       ENDDO
3863     END IF
3864
3865 !  y flux-divergence into tendency
3866
3867     ! Comments on polar boundary conditions
3868     ! Same process as for advect_u - tendencies run from jds to jde-1
3869     ! (latitudes are as for u grid, longitudes are displaced)
3870     ! Therefore: flow is only from one side for points next to poles
3871     IF ( config_flags%polar .AND. (j == jds+1) ) THEN
3872       DO k=kts,ktf
3873       DO i = i_start, i_end
3874         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3875         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
3876       END DO
3877       END DO
3878     ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
3879       DO k=kts,ktf
3880       DO i = i_start, i_end
3881         mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3882         tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
3883       END DO
3884       END DO
3885     ELSE  ! normal code
3886
3887     IF ( j > j_start ) THEN
3888
3889       DO k=kts,ktf
3890       DO i = i_start, i_end
3891         mrdy=msftx(i,j-1)*rdy        ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3892         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
3893       ENDDO
3894       ENDDO
3895
3896     END IF
3897
3898     END IF
3899
3900     jtmp = jp1
3901     jp1 = jp0
3902     jp0 = jtmp
3903
3904   ENDDO
3905
3906    ELSE IF( horz_order == 2 ) THEN
3907
3908       i_start = its
3909       i_end   = MIN(ite,ide-1)
3910       j_start = jts
3911       j_end   = MIN(jte,jde-1)
3912
3913       IF ( .NOT. config_flags%periodic_x ) THEN
3914         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
3915         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
3916       ENDIF
3917
3918       DO j = j_start, j_end
3919       DO k = kts, ktf
3920       DO i = i_start, i_end
3921          mrdx=msftx(i,j)*rdx         ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3922          tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5 &
3923                          *(ru(i+1,k,j)*(field(i+1,k,j)+field(i  ,k,j)) &
3924                           -ru(i  ,k,j)*(field(i  ,k,j)+field(i-1,k,j)))
3925       ENDDO
3926       ENDDO
3927       ENDDO
3928
3929       i_start = its
3930       i_end   = MIN(ite,ide-1)
3931
3932       ! Polar boundary conditions are like open or specified
3933       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
3934       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-2,jte)
3935
3936       DO j = j_start, j_end
3937       DO k = kts, ktf
3938       DO i = i_start, i_end
3939          mrdy=msftx(i,j)*rdy         ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3940          tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5 &
3941                          *(rv(i,k,j+1)*(field(i,k,j+1)+field(i,k,j  )) &
3942                           -rv(i,k,j  )*(field(i,k,j  )+field(i,k,j-1)))
3943       ENDDO
3944       ENDDO
3945       ENDDO
3946
3947       ! Polar boundary condtions
3948       ! These won't be covered in the loop above...
3949       IF (config_flags%polar) THEN
3950          IF (jts == jds) THEN
3951             DO k=kts,ktf
3952             DO i = i_start, i_end
3953                mrdy=msftx(i,jds)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3954                tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 &
3955                                 *rv(i,k,jds+1)*(field(i,k,jds+1)+field(i,k,jds))
3956             END DO
3957             END DO
3958          END IF
3959          IF (jte == jde) THEN
3960             DO k=kts,ktf
3961             DO i = i_start, i_end
3962                mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3963                tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 &
3964                                   *rv(i,k,jde-1)*(field(i,k,jde-1)+field(i,k,jde-2))
3965             END DO
3966             END DO
3967          END IF
3968       END IF
3969
3970    ELSE IF ( horz_order == 0 ) THEN
3971
3972       ! Just in case we want to turn horizontal advection off, we can do it
3973
3974    ELSE
3975
3976       WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_6a, h_order not known ',horz_order
3977       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
3978
3979    ENDIF horizontal_order_test
3980
3981 !  pick up the rest of the horizontal radiation boundary conditions.
3982 !  (these are the computations that don't require 'cb'.
3983 !  first, set to index ranges
3984
3985       i_start = its
3986       i_end   = MIN(ite,ide-1)
3987       j_start = jts
3988       j_end   = MIN(jte,jde-1)
3989
3990 !  compute x (u) conditions for v, w, or scalar
3991
3992    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
3993
3994        DO j = j_start, j_end
3995        DO k = kts, ktf
3996          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
3997          tendency(its,k,j) = tendency(its,k,j)                     &
3998                - rdx*(                                             &
3999                        ub*(   field_old(its+1,k,j)                 &
4000                             - field_old(its  ,k,j)   ) +           &
4001                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
4002                                                                 )
4003        ENDDO
4004        ENDDO
4005
4006    ENDIF
4007
4008    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
4009
4010        DO j = j_start, j_end
4011        DO k = kts, ktf
4012          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
4013          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
4014                - rdx*(                                               &
4015                        ub*(  field_old(i_end  ,k,j)                  &
4016                            - field_old(i_end-1,k,j) ) +              &
4017                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
4018                                                                     )
4019        ENDDO
4020        ENDDO
4021
4022    ENDIF
4023
4024    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
4025
4026        DO i = i_start, i_end
4027        DO k = kts, ktf
4028          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
4029          tendency(i,k,jts) = tendency(i,k,jts)                     &
4030                - rdy*(                                             &
4031                        vb*(  field_old(i,k,jts+1)                  &
4032                            - field_old(i,k,jts  ) ) +              &
4033                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
4034                                                                 )
4035        ENDDO
4036        ENDDO
4037
4038    ENDIF
4039
4040    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
4041
4042        DO i = i_start, i_end
4043        DO k = kts, ktf
4044          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
4045          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
4046                - rdy*(                                               &
4047                        vb*(   field_old(i,k,j_end  )                 &
4048                             - field_old(i,k,j_end-1) ) +             &
4049                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
4050                                                                     )
4051        ENDDO
4052        ENDDO
4053
4054    ENDIF
4055
4056
4057 !-------------------- vertical advection
4058 !     Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
4059 !     Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
4060 !     So we don't need to make a correction for advect_scalar
4061
4062       i_start = its
4063       i_end   = MIN(ite,ide-1)
4064       j_start = jts
4065       j_end   = MIN(jte,jde-1)
4066
4067       DO i = i_start, i_end
4068          vflux(i,kts)=0.
4069          vflux(i,kte)=0.
4070       ENDDO
4071
4072     vert_order_test : IF (vert_order == 6) THEN
4073
4074       DO j = j_start, j_end
4075
4076          DO k=kts+3,ktf-2
4077          DO i = i_start, i_end
4078            vel=rom(i,k,j)
4079            vflux(i,k) = vel*flux6(                                 &
4080                    field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
4081                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
4082          ENDDO
4083          ENDDO
4084
4085          DO i = i_start, i_end
4086
4087            k=kts+1
4088            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4089
4090            k = kts+2
4091            vel=rom(i,k,j)
4092            vflux(i,k) = vel*flux4(               &
4093                    field(i,k-2,j), field(i,k-1,j),   &
4094                    field(i,k  ,j), field(i,k+1,j), -vel )
4095            k = ktf-1
4096            vel=rom(i,k,j)
4097            vflux(i,k) = vel*flux4(               &
4098                    field(i,k-2,j), field(i,k-1,j),   &
4099                    field(i,k  ,j), field(i,k+1,j), -vel )
4100
4101            k=ktf
4102            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4103          ENDDO
4104
4105          DO k=kts,ktf
4106          DO i = i_start, i_end
4107             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4108          ENDDO
4109          ENDDO
4110
4111       ENDDO
4112
4113    ELSE IF (vert_order == 5) THEN
4114
4115       DO j = j_start, j_end
4116
4117          DO k=kts+3,ktf-2
4118          DO i = i_start, i_end
4119            vel=rom(i,k,j)
4120            vflux(i,k) = vel*flux5(                                 &
4121                    field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
4122                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
4123          ENDDO
4124          ENDDO
4125
4126          DO i = i_start, i_end
4127
4128            k=kts+1
4129            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4130
4131            k = kts+2
4132            vel=rom(i,k,j)
4133            vflux(i,k) = vel*flux3(               &
4134                    field(i,k-2,j), field(i,k-1,j),   &
4135                    field(i,k  ,j), field(i,k+1,j), -vel )
4136            k = ktf-1
4137            vel=rom(i,k,j)
4138            vflux(i,k) = vel*flux3(               &
4139                    field(i,k-2,j), field(i,k-1,j),   &
4140                    field(i,k  ,j), field(i,k+1,j), -vel )
4141
4142            k=ktf
4143            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4144          ENDDO
4145
4146          DO k=kts,ktf
4147          DO i = i_start, i_end
4148             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4149          ENDDO
4150          ENDDO
4151
4152       ENDDO
4153
4154    ELSE IF (vert_order == 4) THEN
4155
4156       DO j = j_start, j_end
4157
4158          DO k=kts+2,ktf-1
4159          DO i = i_start, i_end
4160            vel=rom(i,k,j)
4161            vflux(i,k) = vel*flux4(                                 &
4162                    field(i,k-2,j), field(i,k-1,j),       &
4163                    field(i,k  ,j), field(i,k+1,j),  -vel )
4164          ENDDO
4165          ENDDO
4166
4167          DO i = i_start, i_end
4168
4169            k=kts+1
4170            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4171            k=ktf
4172            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4173          ENDDO
4174
4175          DO k=kts,ktf
4176          DO i = i_start, i_end
4177             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4178          ENDDO
4179          ENDDO
4180
4181       ENDDO
4182
4183    ELSE IF (vert_order == 3) THEN
4184
4185       DO j = j_start, j_end
4186
4187          DO k=kts+2,ktf-1
4188          DO i = i_start, i_end
4189            vel=rom(i,k,j)
4190            vflux(i,k) = vel*flux3(                      &
4191                    field(i,k-2,j), field(i,k-1,j),      &
4192                    field(i,k  ,j), field(i,k+1,j),  -vel )
4193          ENDDO
4194          ENDDO
4195
4196          DO i = i_start, i_end
4197
4198            k=kts+1
4199            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4200            k=ktf
4201            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4202          ENDDO
4203
4204          DO k=kts,ktf
4205          DO i = i_start, i_end
4206             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4207          ENDDO
4208          ENDDO
4209
4210       ENDDO
4211
4212    ELSE IF (vert_order == 2) THEN
4213
4214   DO j = j_start, j_end
4215      DO k = kts+1, ktf
4216      DO i = i_start, i_end
4217             vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
4218      ENDDO
4219      ENDDO
4220
4221      DO k = kts, ktf
4222      DO i = i_start, i_end
4223        tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
4224      ENDDO
4225      ENDDO
4226
4227   ENDDO
4228
4229    ELSE
4230
4231       WRITE (wrf_err_message,*) ' advect_scalar_6a, v_order not known ',vert_order
4232       CALL wrf_error_fatal ( wrf_err_message )
4233
4234    ENDIF vert_order_test
4235
4236 END SUBROUTINE advect_scalar
4237
4238 !---------------------------------------------------------------------------------
4239
4240 SUBROUTINE advect_w    ( w, w_old, tendency,            &
4241                          ru, rv, rom,                   &
4242                          mut, time_step, config_flags,  &
4243                          msfux, msfuy, msfvx, msfvy,    &
4244                          msftx, msfty,                  &
4245                          fzm, fzp,                      &
4246                          rdx, rdy, rdzu,                &
4247                          ids, ide, jds, jde, kds, kde,  &
4248                          ims, ime, jms, jme, kms, kme,  &
4249                          its, ite, jts, jte, kts, kte  )
4250
4251    IMPLICIT NONE
4252
4253    ! Input data
4254
4255    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
4256
4257    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
4258                                               ims, ime, jms, jme, kms, kme, &
4259                                               its, ite, jts, jte, kts, kte
4260
4261    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: w,     &
4262                                                                       w_old, &
4263                                                                       ru,    &
4264                                                                       rv,    &
4265                                                                       rom
4266
4267    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
4268    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
4269
4270    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
4271                                                                     msfuy,  &
4272                                                                     msfvx,  &
4273                                                                     msfvy,  &
4274                                                                     msftx,  &
4275                                                                     msfty
4276
4277    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
4278                                                                   fzp,  &
4279                                                                   rdzu
4280
4281    REAL ,                                        INTENT(IN   ) :: rdx,  &
4282                                                                   rdy
4283    INTEGER ,                                     INTENT(IN   ) :: time_step
4284
4285
4286    ! Local data
4287
4288    INTEGER :: i, j, k, itf, jtf, ktf
4289    INTEGER :: i_start, i_end, j_start, j_end
4290    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
4291    INTEGER :: jmin, jmax, jp, jm, imin, imax
4292
4293    REAL    :: mrdx, mrdy, ub, vb, uw, vw
4294    REAL , DIMENSION(its:ite, kts:kte) :: vflux
4295
4296    INTEGER :: horz_order, vert_order
4297
4298    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
4299    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
4300
4301    LOGICAL :: degrade_xs, degrade_ys
4302    LOGICAL :: degrade_xe, degrade_ye
4303
4304    INTEGER :: jp1, jp0, jtmp
4305
4306 ! definition of flux operators, 3rd, 4th, 5th or 6th order
4307
4308    REAL    :: flux3, flux4, flux5, flux6
4309    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
4310
4311       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
4312           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
4313
4314       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
4315            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
4316            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
4317
4318       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
4319                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)      &
4320                      +(q_ip2+q_im3) )/60.0
4321
4322       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
4323            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
4324             -sign(1,time_step)*sign(1.,ua)*(                    &
4325               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
4326
4327
4328    LOGICAL :: specified
4329
4330    specified = .false.
4331    if(config_flags%specified .or. config_flags%nested) specified = .true.
4332
4333 !  set order for the advection scheme
4334
4335   ktf=MIN(kte,kde-1)
4336   horz_order = config_flags%h_sca_adv_order
4337   vert_order = config_flags%v_sca_adv_order
4338
4339 !  here is the choice of flux operators
4340
4341 !  begin with horizontal flux divergence
4342
4343   horizontal_order_test : IF( horz_order == 6 ) THEN
4344
4345 !  determine boundary mods for flux operators
4346 !  We degrade the flux operators from 3rd/4th order
4347 !   to second order one gridpoint in from the boundaries for
4348 !   all boundary conditions except periodic and symmetry - these
4349 !   conditions have boundary zone data fill for correct application
4350 !   of the higher order flux stencils
4351
4352    degrade_xs = .true.
4353    degrade_xe = .true.
4354    degrade_ys = .true.
4355    degrade_ye = .true.
4356
4357    IF( config_flags%periodic_x   .or. &
4358        config_flags%symmetric_xs .or. &
4359        (its > ids+3)                ) degrade_xs = .false.
4360    IF( config_flags%periodic_x   .or. &
4361        config_flags%symmetric_xe .or. &
4362        (ite < ide-3)                ) degrade_xe = .false.
4363    IF( config_flags%periodic_y   .or. &
4364        config_flags%symmetric_ys .or. &
4365        (jts > jds+3)                ) degrade_ys = .false.
4366    IF( config_flags%periodic_y   .or. &
4367        config_flags%symmetric_ye .or. &
4368        (jte < jde-4)                ) degrade_ye = .false.
4369
4370 !--------------- y - advection first
4371
4372       i_start = its
4373       i_end   = MIN(ite,ide-1)
4374       j_start = jts
4375       j_end   = MIN(jte,jde-1)
4376
4377 !  higher order flux has a 5 or 7 point stencil, so compute
4378 !  bounds so we can switch to second order flux close to the boundary
4379
4380       j_start_f = j_start
4381       j_end_f   = j_end+1
4382
4383       IF(degrade_ys) then
4384         j_start = MAX(jts,jds+1)
4385         j_start_f = jds+3
4386       ENDIF
4387
4388       IF(degrade_ye) then
4389         j_end = MIN(jte,jde-2)
4390         j_end_f = jde-3
4391       ENDIF
4392
4393       IF(config_flags%polar) j_end = MIN(jte,jde-1)
4394
4395 !  compute fluxes, 5th or 6th order
4396
4397      jp1 = 2
4398      jp0 = 1
4399
4400      j_loop_y_flux_6 : DO j = j_start, j_end+1
4401
4402       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
4403
4404         DO k=kts+1,ktf
4405         DO i = i_start, i_end
4406           vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4407           fqy( i, k, jp1 ) = vel*flux6(                     &
4408                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4409                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4410         ENDDO
4411         ENDDO
4412
4413         k = ktf+1
4414         DO i = i_start, i_end
4415           vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4416           fqy( i, k, jp1 ) = vel*flux6(                     &
4417                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4418                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4419         ENDDO
4420
4421       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
4422
4423             DO k=kts+1,ktf
4424             DO i = i_start, i_end
4425               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*          &
4426                      (w(i,k,j)+w(i,k,j-1))
4427             ENDDO
4428             ENDDO
4429
4430             k = ktf+1
4431             DO i = i_start, i_end
4432               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*          &
4433                      (w(i,k,j)+w(i,k,j-1))
4434             ENDDO
4435
4436      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
4437
4438             DO k=kts+1,ktf
4439             DO i = i_start, i_end
4440               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4441               fqy( i, k, jp1 ) = vel*flux4(              &
4442                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4443             ENDDO
4444             ENDDO
4445
4446             k = ktf+1
4447             DO i = i_start, i_end
4448               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4449               fqy( i, k, jp1 ) = vel*flux4(              &
4450                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4451             ENDDO
4452
4453      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
4454
4455             DO k=kts+1,ktf
4456             DO i = i_start, i_end
4457               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*      &
4458                      (w(i,k,j)+w(i,k,j-1))
4459             ENDDO
4460             ENDDO
4461
4462             k = ktf+1
4463             DO i = i_start, i_end
4464               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*      &
4465                      (w(i,k,j)+w(i,k,j-1))
4466             ENDDO
4467
4468      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
4469
4470             DO k=kts+1,ktf
4471             DO i = i_start, i_end
4472               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4473               fqy( i, k, jp1 ) = vel*flux4(             &
4474                    w(i,k,j-2),w(i,k,j-1),    &
4475                    w(i,k,j),w(i,k,j+1),vel )
4476             ENDDO
4477             ENDDO
4478
4479             k = ktf+1
4480             DO i = i_start, i_end
4481               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4482               fqy( i, k, jp1 ) = vel*flux4(             &
4483                    w(i,k,j-2),w(i,k,j-1),    &
4484                    w(i,k,j),w(i,k,j+1),vel )
4485             ENDDO
4486
4487      ENDIF
4488
4489 !  y flux-divergence into tendency
4490
4491         ! Comments for polar boundary conditions
4492         ! Same process as for advect_u - tendencies run from jds to jde-1
4493         ! (latitudes are as for u grid, longitudes are displaced)
4494         ! Therefore: flow is only from one side for points next to poles
4495         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
4496           DO k=kts,ktf
4497           DO i = i_start, i_end
4498             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4499             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
4500           END DO
4501           END DO
4502         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
4503           DO k=kts,ktf
4504           DO i = i_start, i_end
4505             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4506             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
4507           END DO
4508           END DO
4509         ELSE  ! normal code
4510
4511         IF(j > j_start) THEN
4512
4513           DO k=kts+1,ktf+1
4514           DO i = i_start, i_end
4515             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4516             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
4517           ENDDO
4518           ENDDO
4519
4520        ENDIF
4521
4522         END IF
4523
4524         jtmp = jp1
4525         jp1 = jp0
4526         jp0 = jtmp
4527
4528       ENDDO j_loop_y_flux_6
4529
4530 !  next, x - flux divergence
4531
4532       i_start = its
4533       i_end   = MIN(ite,ide-1)
4534
4535       j_start = jts
4536       j_end   = MIN(jte,jde-1)
4537
4538 !  higher order flux has a 5 or 7 point stencil, so compute
4539 !  bounds so we can switch to second order flux close to the boundary
4540
4541       i_start_f = i_start
4542       i_end_f   = i_end+1
4543
4544       IF(degrade_xs) then
4545         i_start = MAX(ids+1,its)
4546 !        i_start_f = i_start+2
4547         i_start_f = MIN(i_start+2,ids+3)
4548       ENDIF
4549
4550       IF(degrade_xe) then
4551         i_end = MIN(ide-2,ite)
4552         i_end_f = ide-3
4553       ENDIF
4554
4555 !  compute fluxes
4556
4557       DO j = j_start, j_end
4558
4559 !  5th or 6th order flux
4560
4561         DO k=kts+1,ktf
4562         DO i = i_start_f, i_end_f
4563           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4564           fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j),  &
4565                                   w(i-1,k,j), w(i  ,k,j),  &
4566                                   w(i+1,k,j), w(i+2,k,j),  &
4567                                   vel                     )
4568         ENDDO
4569         ENDDO
4570
4571         k = ktf+1
4572         DO i = i_start_f, i_end_f
4573           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4574           fqx( i,k ) = vel*flux6( w(i-3,k,j), w(i-2,k,j),  &
4575                                   w(i-1,k,j), w(i  ,k,j),  &
4576                                   w(i+1,k,j), w(i+2,k,j),  &
4577                                   vel                     )
4578         ENDDO
4579
4580 !  lower order fluxes close to boundaries (if not periodic or symmetric)
4581
4582         IF( degrade_xs ) THEN
4583
4584           DO i=i_start,i_start_f-1
4585
4586             IF(i == ids+1) THEN ! second order
4587               DO k=kts+1,ktf
4588                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
4589                                 *(w(i,k,j)+w(i-1,k,j))
4590               ENDDO
4591               k = ktf+1
4592               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
4593                      *(w(i,k,j)+w(i-1,k,j))
4594             ENDIF
4595
4596             IF(i == ids+2) THEN  ! third order
4597               DO k=kts+1,ktf
4598                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4599                 fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
4600                                         w(i  ,k,j), w(i+1,k,j),  &
4601                                         vel                     )
4602               ENDDO
4603               k = ktf+1
4604               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4605               fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
4606                                       w(i  ,k,j), w(i+1,k,j),  &
4607                                       vel                     )
4608             END IF
4609
4610           ENDDO
4611
4612         ENDIF
4613
4614         IF( degrade_xe ) THEN
4615
4616           DO i = i_end_f+1, i_end+1
4617
4618             IF( i == ide-1 ) THEN ! second order flux next to the boundary
4619               DO k=kts+1,ktf
4620                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
4621                                   *(w(i,k,j)+w(i-1,k,j))
4622               ENDDO
4623               k = ktf+1
4624               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))      &
4625                      *(w(i,k,j)+w(i-1,k,j))
4626             ENDIF
4627
4628             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
4629               DO k=kts+1,ktf
4630                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4631                 fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
4632                                         w(i  ,k,j), w(i+1,k,j),  &
4633                                         vel                     )
4634               ENDDO
4635               k = ktf+1
4636               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4637               fqx( i,k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
4638                                       w(i  ,k,j), w(i+1,k,j),  &
4639                                       vel                     )
4640             ENDIF
4641
4642           ENDDO
4643
4644         ENDIF
4645
4646 !  x flux-divergence into tendency
4647
4648         DO k=kts+1,ktf+1
4649           DO i = i_start, i_end
4650             mrdx=msftx(i,j)*rdx      ! see ADT eqn 46 dividing by my, 1st term RHS
4651             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
4652           ENDDO
4653         ENDDO
4654
4655       ENDDO
4656
4657 ELSE IF (horz_order == 5 ) THEN
4658
4659 !  determine boundary mods for flux operators
4660 !  We degrade the flux operators from 3rd/4th order
4661 !   to second order one gridpoint in from the boundaries for
4662 !   all boundary conditions except periodic and symmetry - these
4663 !   conditions have boundary zone data fill for correct application
4664 !   of the higher order flux stencils
4665
4666    degrade_xs = .true.
4667    degrade_xe = .true.
4668    degrade_ys = .true.
4669    degrade_ye = .true.
4670
4671    IF( config_flags%periodic_x   .or. &
4672        config_flags%symmetric_xs .or. &
4673        (its > ids+3)                ) degrade_xs = .false.
4674    IF( config_flags%periodic_x   .or. &
4675        config_flags%symmetric_xe .or. &
4676        (ite < ide-3)                ) degrade_xe = .false.
4677    IF( config_flags%periodic_y   .or. &
4678        config_flags%symmetric_ys .or. &
4679        (jts > jds+3)                ) degrade_ys = .false.
4680    IF( config_flags%periodic_y   .or. &
4681        config_flags%symmetric_ye .or. &
4682        (jte < jde-4)                ) degrade_ye = .false.
4683
4684 !--------------- y - advection first
4685
4686       i_start = its
4687       i_end   = MIN(ite,ide-1)
4688       j_start = jts
4689       j_end   = MIN(jte,jde-1)
4690
4691 !  higher order flux has a 5 or 7 point stencil, so compute
4692 !  bounds so we can switch to second order flux close to the boundary
4693
4694       j_start_f = j_start
4695       j_end_f   = j_end+1
4696
4697       IF(degrade_ys) then
4698         j_start = MAX(jts,jds+1)
4699         j_start_f = jds+3
4700       ENDIF
4701
4702       IF(degrade_ye) then
4703         j_end = MIN(jte,jde-2)
4704         j_end_f = jde-3
4705       ENDIF
4706
4707       IF(config_flags%polar) j_end = MIN(jte,jde-1)
4708
4709 !  compute fluxes, 5th or 6th order
4710
4711      jp1 = 2
4712      jp0 = 1
4713
4714      j_loop_y_flux_5 : DO j = j_start, j_end+1
4715
4716       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
4717
4718         DO k=kts+1,ktf
4719         DO i = i_start, i_end
4720           vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4721           fqy( i, k, jp1 ) = vel*flux5(                     &
4722                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4723                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4724         ENDDO
4725         ENDDO
4726
4727         k = ktf+1
4728         DO i = i_start, i_end
4729           vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4730           fqy( i, k, jp1 ) = vel*flux5(                     &
4731                   w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
4732                   w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
4733         ENDDO
4734
4735       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
4736
4737             DO k=kts+1,ktf
4738             DO i = i_start, i_end
4739               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*          &
4740                      (w(i,k,j)+w(i,k,j-1))
4741             ENDDO
4742             ENDDO
4743
4744             k = ktf+1
4745             DO i = i_start, i_end
4746               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*          &
4747                      (w(i,k,j)+w(i,k,j-1))
4748             ENDDO
4749
4750      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
4751
4752             DO k=kts+1,ktf
4753             DO i = i_start, i_end
4754               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4755               fqy( i, k, jp1 ) = vel*flux3(              &
4756                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4757             ENDDO
4758             ENDDO
4759
4760             k = ktf+1
4761             DO i = i_start, i_end
4762               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4763               fqy( i, k, jp1 ) = vel*flux3(              &
4764                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
4765             ENDDO
4766
4767      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
4768
4769             DO k=kts+1,ktf
4770             DO i = i_start, i_end
4771               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*      &
4772                      (w(i,k,j)+w(i,k,j-1))
4773             ENDDO
4774             ENDDO
4775
4776             k = ktf+1
4777             DO i = i_start, i_end
4778               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*      &
4779                      (w(i,k,j)+w(i,k,j-1))
4780             ENDDO
4781
4782      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
4783
4784             DO k=kts+1,ktf
4785             DO i = i_start, i_end
4786               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
4787               fqy( i, k, jp1 ) = vel*flux3(             &
4788                    w(i,k,j-2),w(i,k,j-1),    &
4789                    w(i,k,j),w(i,k,j+1),vel )
4790             ENDDO
4791             ENDDO
4792
4793             k = ktf+1
4794             DO i = i_start, i_end
4795               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
4796               fqy( i, k, jp1 ) = vel*flux3(             &
4797                    w(i,k,j-2),w(i,k,j-1),    &
4798                    w(i,k,j),w(i,k,j+1),vel )
4799             ENDDO
4800
4801      ENDIF
4802
4803 !  y flux-divergence into tendency
4804
4805         ! Comments for polar boundary conditions
4806         ! Same process as for advect_u - tendencies run from jds to jde-1
4807         ! (latitudes are as for u grid, longitudes are displaced)
4808         ! Therefore: flow is only from one side for points next to poles
4809         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
4810           DO k=kts,ktf
4811           DO i = i_start, i_end
4812             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4813             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
4814           END DO
4815           END DO
4816         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
4817           DO k=kts,ktf
4818           DO i = i_start, i_end
4819             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4820             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
4821           END DO
4822           END DO
4823         ELSE  ! normal code
4824
4825         IF(j > j_start) THEN
4826
4827           DO k=kts+1,ktf+1
4828           DO i = i_start, i_end
4829             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
4830             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
4831           ENDDO
4832           ENDDO
4833
4834        ENDIF
4835
4836         END IF
4837
4838         jtmp = jp1
4839         jp1 = jp0
4840         jp0 = jtmp
4841
4842       ENDDO j_loop_y_flux_5
4843
4844 !  next, x - flux divergence
4845
4846       i_start = its
4847       i_end   = MIN(ite,ide-1)
4848
4849       j_start = jts
4850       j_end   = MIN(jte,jde-1)
4851
4852 !  higher order flux has a 5 or 7 point stencil, so compute
4853 !  bounds so we can switch to second order flux close to the boundary
4854
4855       i_start_f = i_start
4856       i_end_f   = i_end+1
4857
4858       IF(degrade_xs) then
4859         i_start = MAX(ids+1,its)
4860 !        i_start_f = i_start+2
4861         i_start_f = MIN(i_start+2,ids+3)
4862       ENDIF
4863
4864       IF(degrade_xe) then
4865         i_end = MIN(ide-2,ite)
4866         i_end_f = ide-3
4867       ENDIF
4868
4869 !  compute fluxes
4870
4871       DO j = j_start, j_end
4872
4873 !  5th or 6th order flux
4874
4875         DO k=kts+1,ktf
4876         DO i = i_start_f, i_end_f
4877           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4878           fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
4879                                   w(i-1,k,j), w(i  ,k,j),  &
4880                                   w(i+1,k,j), w(i+2,k,j),  &
4881                                   vel                     )
4882         ENDDO
4883         ENDDO
4884
4885         k = ktf+1
4886         DO i = i_start_f, i_end_f
4887           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4888           fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
4889                                   w(i-1,k,j), w(i  ,k,j),  &
4890                                   w(i+1,k,j), w(i+2,k,j),  &
4891                                   vel                     )
4892         ENDDO
4893
4894 !  lower order fluxes close to boundaries (if not periodic or symmetric)
4895
4896         IF( degrade_xs ) THEN
4897
4898           DO i=i_start,i_start_f-1
4899
4900             IF(i == ids+1) THEN ! second order
4901               DO k=kts+1,ktf
4902                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
4903                                 *(w(i,k,j)+w(i-1,k,j))
4904               ENDDO
4905               k = ktf+1
4906               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
4907                      *(w(i,k,j)+w(i-1,k,j))
4908             ENDIF
4909
4910             IF(i == ids+2) THEN  ! third order
4911               DO k=kts+1,ktf
4912                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4913                 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
4914                                         w(i  ,k,j), w(i+1,k,j),  &
4915                                         vel                     )
4916               ENDDO
4917               k = ktf+1
4918               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4919               fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
4920                                       w(i  ,k,j), w(i+1,k,j),  &
4921                                       vel                     )
4922             END IF
4923
4924           ENDDO
4925
4926         ENDIF
4927
4928         IF( degrade_xe ) THEN
4929
4930           DO i = i_end_f+1, i_end+1
4931
4932             IF( i == ide-1 ) THEN ! second order flux next to the boundary
4933               DO k=kts+1,ktf
4934                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
4935                                   *(w(i,k,j)+w(i-1,k,j))
4936               ENDDO
4937               k = ktf+1
4938               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))      &
4939                      *(w(i,k,j)+w(i-1,k,j))
4940             ENDIF
4941
4942             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
4943               DO k=kts+1,ktf
4944                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
4945                 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
4946                                         w(i  ,k,j), w(i+1,k,j),  &
4947                                         vel                     )
4948               ENDDO
4949               k = ktf+1
4950               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
4951               fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
4952                                       w(i  ,k,j), w(i+1,k,j),  &
4953                                       vel                     )
4954             ENDIF
4955
4956           ENDDO
4957
4958         ENDIF
4959
4960 !  x flux-divergence into tendency
4961
4962         DO k=kts+1,ktf+1
4963           DO i = i_start, i_end
4964             mrdx=msftx(i,j)*rdx      ! see ADT eqn 46 dividing by my, 1st term RHS
4965             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
4966           ENDDO
4967         ENDDO
4968
4969       ENDDO
4970
4971 ELSE IF ( horz_order == 4 ) THEN
4972
4973    degrade_xs = .true.
4974    degrade_xe = .true.
4975    degrade_ys = .true.
4976    degrade_ye = .true.
4977
4978    IF( config_flags%periodic_x   .or. &
4979        config_flags%symmetric_xs .or. &
4980        (its > ids+2)                ) degrade_xs = .false.
4981    IF( config_flags%periodic_x   .or. &
4982        config_flags%symmetric_xe .or. &
4983        (ite < ide-2)                ) degrade_xe = .false.
4984    IF( config_flags%periodic_y   .or. &
4985        config_flags%symmetric_ys .or. &
4986        (jts > jds+2)                ) degrade_ys = .false.
4987    IF( config_flags%periodic_y   .or. &
4988        config_flags%symmetric_ye .or. &
4989        (jte < jde-3)                ) degrade_ye = .false.
4990
4991 !  begin flux computations
4992 !  start with x flux divergence
4993
4994 !---------------
4995
4996    ktf=MIN(kte,kde-1)
4997
4998       i_start = its
4999       i_end   = MIN(ite,ide-1)
5000       j_start = jts
5001       j_end   = MIN(jte,jde-1)
5002
5003 !  3rd or 4th order flux has a 5 point stencil, so compute
5004 !  bounds so we can switch to second order flux close to the boundary
5005
5006       i_start_f = i_start
5007       i_end_f   = i_end+1
5008
5009       IF(degrade_xs) then
5010         i_start = ids+1
5011         i_start_f = i_start+1
5012       ENDIF
5013
5014       IF(degrade_xe) then
5015         i_end = ide-2
5016         i_end_f = ide-2
5017       ENDIF
5018
5019 !  compute fluxes
5020
5021       DO j = j_start, j_end
5022
5023         DO k=kts+1,ktf
5024         DO i = i_start_f, i_end_f
5025           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5026           fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
5027                                   w(i  ,k,j), w(i+1,k,j),  &
5028                                   vel                     )
5029         ENDDO
5030         ENDDO
5031
5032         k = ktf+1
5033         DO i = i_start_f, i_end_f
5034           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5035           fqx( i, k ) = vel*flux4( w(i-2,k,j), w(i-1,k,j),  &
5036                                   w(i  ,k,j), w(i+1,k,j),  &
5037                                   vel                     )
5038         ENDDO
5039 !  second order flux close to boundaries (if not periodic or symmetric)
5040
5041         IF( degrade_xs ) THEN
5042           DO k=kts+1,ktf
5043             fqx(i_start, k) =                            &
5044                0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j))  &
5045                    *(w(i_start,k,j)+w(i_start-1,k,j))
5046           ENDDO
5047             k = ktf+1
5048             fqx(i_start, k) =                            &
5049                0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j))  &
5050                    *(w(i_start,k,j)+w(i_start-1,k,j))
5051         ENDIF
5052
5053         IF( degrade_xe ) THEN
5054           DO k=kts+1,ktf
5055             fqx(i_end+1, k) =                            &
5056                0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j))  &
5057                    *(w(i_end+1,k,j)+w(i_end,k,j))
5058           ENDDO
5059             k = ktf+1
5060             fqx(i_end+1, k) =                            &
5061                0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j))  &
5062                    *(w(i_end+1,k,j)+w(i_end,k,j))
5063         ENDIF
5064
5065 !  x flux-divergence into tendency
5066
5067         DO k=kts+1,ktf+1
5068         DO i = i_start, i_end
5069           mrdx=msftx(i,j)*rdx        ! see ADT eqn 46 dividing by my, 1st term RHS
5070           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
5071         ENDDO
5072         ENDDO
5073
5074       ENDDO
5075
5076 !  next -> y flux divergence calculation
5077
5078       i_start = its
5079       i_end   = MIN(ite,ide-1)
5080       j_start = jts
5081       j_end   = MIN(jte,jde-1)
5082
5083
5084 !  3rd or 4th order flux has a 5 point stencil, so compute
5085 !  bounds so we can switch to second order flux close to the boundary
5086
5087       j_start_f = j_start
5088       j_end_f   = j_end+1
5089
5090       IF(degrade_ys) then
5091         j_start = jds+1
5092         j_start_f = j_start+1
5093       ENDIF
5094
5095       IF(degrade_ye) then
5096         j_end = jde-2
5097         j_end_f = jde-2
5098       ENDIF
5099
5100       IF(config_flags%polar) j_end = MIN(jte,jde-1)
5101
5102         jp1 = 2
5103         jp0 = 1
5104
5105       DO j = j_start, j_end+1
5106
5107        IF ((j < j_start_f) .and. degrade_ys)  THEN
5108           DO k = kts+1, ktf
5109           DO i = i_start, i_end
5110             fqy(i, k, jp1) =                             &
5111                0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start))   &
5112                    *(w(i,k,j_start)+w(i,k,j_start-1))
5113           ENDDO
5114           ENDDO
5115           k = ktf+1
5116           DO i = i_start, i_end
5117             fqy(i, k, jp1) =                             &
5118                0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start))   &
5119                    *(w(i,k,j_start)+w(i,k,j_start-1))
5120           ENDDO
5121        ELSE IF ((j > j_end_f) .and. degrade_ye)  THEN
5122           DO k = kts+1, ktf
5123           DO i = i_start, i_end
5124             ! Assumes j>j_end_f is ONLY j_end+1 ...
5125 !            fqy(i, k, jp1) =                             &
5126 !               0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1))     &
5127 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5128             fqy(i, k, jp1) =                             &
5129                0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))     &
5130                    *(w(i,k,j)+w(i,k,j-1))
5131           ENDDO
5132           ENDDO
5133           k = ktf+1
5134           DO i = i_start, i_end
5135             ! Assumes j>j_end_f is ONLY j_end+1 ...
5136 !            fqy(i, k, jp1) =                                         &
5137 !               0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1))     &
5138 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5139             fqy(i, k, jp1) =                                         &
5140                0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))     &
5141                    *(w(i,k,j)+w(i,k,j-1))
5142           ENDDO
5143        ELSE
5144 !  3rd or 4th order flux
5145           DO k = kts+1, ktf
5146           DO i = i_start, i_end
5147             vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
5148             fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1),  &
5149                                     w(i,k,j  ), w(i,k,j+1),  &
5150                                     vel                     )
5151           ENDDO
5152           ENDDO
5153           k = ktf+1
5154           DO i = i_start, i_end
5155             vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
5156             fqy( i, k, jp1 ) = vel*flux4( w(i,k,j-2), w(i,k,j-1),  &
5157                                     w(i,k,j  ), w(i,k,j+1),  &
5158                                     vel                     )
5159           ENDDO
5160        END IF
5161
5162 !  y flux-divergence into tendency
5163
5164        ! Comments for polar boundary conditions
5165        ! Same process as for advect_u - tendencies run from jds to jde-1
5166        ! (latitudes are as for u grid, longitudes are displaced)
5167        ! Therefore: flow is only from one side for points next to poles
5168        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
5169          DO k=kts,ktf
5170          DO i = i_start, i_end
5171            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5172            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
5173          END DO
5174          END DO
5175        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
5176          DO k=kts,ktf
5177          DO i = i_start, i_end
5178            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5179            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
5180          END DO
5181          END DO
5182        ELSE  ! normal code
5183
5184        IF( j > j_start ) THEN
5185
5186           DO k = kts+1, ktf+1
5187           DO i = i_start, i_end
5188             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5189             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
5190           ENDDO
5191           ENDDO
5192
5193        END IF
5194
5195        END IF
5196
5197        jtmp = jp1
5198        jp1 = jp0
5199        jp0 = jtmp
5200
5201     ENDDO
5202
5203 ELSE IF ( horz_order == 3 ) THEN
5204
5205    degrade_xs = .true.
5206    degrade_xe = .true.
5207    degrade_ys = .true.
5208    degrade_ye = .true.
5209
5210    IF( config_flags%periodic_x   .or. &
5211        config_flags%symmetric_xs .or. &
5212        (its > ids+2)                ) degrade_xs = .false.
5213    IF( config_flags%periodic_x   .or. &
5214        config_flags%symmetric_xe .or. &
5215        (ite < ide-2)                ) degrade_xe = .false.
5216    IF( config_flags%periodic_y   .or. &
5217        config_flags%symmetric_ys .or. &
5218        (jts > jds+2)                ) degrade_ys = .false.
5219    IF( config_flags%periodic_y   .or. &
5220        config_flags%symmetric_ye .or. &
5221        (jte < jde-3)                ) degrade_ye = .false.
5222
5223 !  begin flux computations
5224 !  start with x flux divergence
5225
5226 !---------------
5227
5228    ktf=MIN(kte,kde-1)
5229
5230       i_start = its
5231       i_end   = MIN(ite,ide-1)
5232       j_start = jts
5233       j_end   = MIN(jte,jde-1)
5234
5235 !  3rd or 4th order flux has a 5 point stencil, so compute
5236 !  bounds so we can switch to second order flux close to the boundary
5237
5238       i_start_f = i_start
5239       i_end_f   = i_end+1
5240
5241       IF(degrade_xs) then
5242         i_start = ids+1
5243         i_start_f = i_start+1
5244       ENDIF
5245
5246       IF(degrade_xe) then
5247         i_end = ide-2
5248         i_end_f = ide-2
5249       ENDIF
5250
5251 !  compute fluxes
5252
5253       DO j = j_start, j_end
5254
5255         DO k=kts+1,ktf
5256         DO i = i_start_f, i_end_f
5257           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
5258           fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5259                                   w(i  ,k,j), w(i+1,k,j),  &
5260                                   vel                     )
5261         ENDDO
5262         ENDDO
5263         k = ktf+1
5264         DO i = i_start_f, i_end_f
5265           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
5266           fqx( i, k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
5267                                   w(i  ,k,j), w(i+1,k,j),  &
5268                                   vel                     )
5269         ENDDO
5270
5271 !  second order flux close to boundaries (if not periodic or symmetric)
5272
5273         IF( degrade_xs ) THEN
5274           DO k=kts+1,ktf
5275             fqx(i_start, k) =                            &
5276                0.5*(fzm(k)*ru(i_start,k,j)+fzp(k)*ru(i_start,k-1,j))  &
5277                    *(w(i_start,k,j)+w(i_start-1,k,j))
5278           ENDDO
5279             k = ktf+1
5280             fqx(i_start, k) =                            &
5281                0.5*((2.-fzm(k-1))*ru(i_start,k-1,j)-fzp(k-1)*ru(i_start,k-2,j))  &
5282                    *(w(i_start,k,j)+w(i_start-1,k,j))
5283         ENDIF
5284
5285         IF( degrade_xe ) THEN
5286           DO k=kts+1,ktf
5287             fqx(i_end+1, k) =                            &
5288                0.5*(fzm(k)*ru(i_end+1,k,j)+fzp(k)*ru(i_end+1,k-1,j))  &
5289                    *(w(i_end+1,k,j)+w(i_end,k,j))
5290           ENDDO
5291             k = ktf+1
5292             fqx(i_end+1, k) =                            &
5293                0.5*((2.-fzm(k-1))*ru(i_end+1,k-1,j)-fzp(k-1)*ru(i_end+1,k-2,j))  &
5294                    *(w(i_end+1,k,j)+w(i_end,k,j))
5295         ENDIF
5296
5297 !  x flux-divergence into tendency
5298
5299         DO k=kts+1,ktf+1
5300         DO i = i_start, i_end
5301           mrdx=msftx(i,j)*rdx        ! see ADT eqn 46 dividing by my, 1st term RHS
5302           tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
5303         ENDDO
5304         ENDDO
5305
5306       ENDDO
5307
5308 !  next -> y flux divergence calculation
5309
5310       i_start = its
5311       i_end   = MIN(ite,ide-1)
5312       j_start = jts
5313       j_end   = MIN(jte,jde-1)
5314
5315
5316 !  3rd or 4th order flux has a 5 point stencil, so compute
5317 !  bounds so we can switch to second order flux close to the boundary
5318
5319       j_start_f = j_start
5320       j_end_f   = j_end+1
5321
5322       IF(degrade_ys) then
5323         j_start = jds+1
5324         j_start_f = j_start+1
5325       ENDIF
5326
5327       IF(degrade_ye) then
5328         j_end = jde-2
5329         j_end_f = jde-2
5330       ENDIF
5331
5332       IF(config_flags%polar) j_end = MIN(jte,jde-1)
5333
5334         jp1 = 2
5335         jp0 = 1
5336
5337       DO j = j_start, j_end+1
5338
5339        IF ((j < j_start_f) .and. degrade_ys)  THEN
5340           DO k = kts+1, ktf
5341           DO i = i_start, i_end
5342             fqy(i, k, jp1) =                             &
5343                0.5*(fzm(k)*rv(i,k,j_start)+fzp(k)*rv(i,k-1,j_start))   &
5344                    *(w(i,k,j_start)+w(i,k,j_start-1))
5345           ENDDO
5346           ENDDO
5347           k = ktf+1
5348           DO i = i_start, i_end
5349             fqy(i, k, jp1) =                             &
5350                0.5*((2.-fzm(k-1))*rv(i,k-1,j_start)-fzp(k-1)*rv(i,k-2,j_start))   &
5351                    *(w(i,k,j_start)+w(i,k,j_start-1))
5352           ENDDO
5353        ELSE IF ((j > j_end_f) .and. degrade_ye)  THEN
5354           DO k = kts+1, ktf
5355           DO i = i_start, i_end
5356             ! Assumes j>j_end_f is ONLY j_end+1 ...
5357 !            fqy(i, k, jp1) =                             &
5358 !               0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1))     &
5359 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5360             fqy(i, k, jp1) =                             &
5361                0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))     &
5362                    *(w(i,k,j)+w(i,k,j-1))
5363           ENDDO
5364           ENDDO
5365           k = ktf+1
5366           DO i = i_start, i_end
5367             ! Assumes j>j_end_f is ONLY j_end+1 ...
5368 !            fqy(i, k, jp1) =                             &
5369 !               0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1))     &
5370 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
5371             fqy(i, k, jp1) =                             &
5372                0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))     &
5373                    *(w(i,k,j)+w(i,k,j-1))
5374           ENDDO
5375        ELSE
5376 !  3rd or 4th order flux
5377           DO k = kts+1, ktf
5378           DO i = i_start, i_end
5379             vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
5380             fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1),  &
5381                                     w(i,k,j  ), w(i,k,j+1),  &
5382                                     vel                     )
5383           ENDDO
5384           ENDDO
5385           k = ktf+1
5386           DO i = i_start, i_end
5387             vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
5388             fqy( i, k, jp1 ) = vel*flux3( w(i,k,j-2), w(i,k,j-1),  &
5389                                     w(i,k,j  ), w(i,k,j+1),  &
5390                                     vel                     )
5391           ENDDO
5392        END IF
5393
5394 !  y flux-divergence into tendency
5395
5396        ! Comments for polar boundary conditions
5397        ! Same process as for advect_u - tendencies run from jds to jde-1
5398        ! (latitudes are as for u grid, longitudes are displaced)
5399        ! Therefore: flow is only from one side for points next to poles
5400        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
5401          DO k=kts,ktf
5402          DO i = i_start, i_end
5403            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5404            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
5405          END DO
5406          END DO
5407        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
5408          DO k=kts,ktf
5409          DO i = i_start, i_end
5410            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5411            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
5412          END DO
5413          END DO
5414        ELSE  ! normal code
5415
5416        IF( j > j_start ) THEN
5417
5418           DO k = kts+1, ktf+1
5419           DO i = i_start, i_end
5420             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
5421             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
5422           ENDDO
5423           ENDDO
5424
5425        END IF
5426
5427        END IF
5428
5429        jtmp = jp1
5430        jp1 = jp0
5431        jp0 = jtmp
5432
5433     ENDDO
5434
5435 ELSE IF (horz_order == 2 ) THEN
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       IF ( .NOT. config_flags%periodic_x ) THEN
5443         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
5444         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-2,ite)
5445       ENDIF
5446
5447       DO j = j_start, j_end
5448       DO k=kts+1,ktf
5449       DO i = i_start, i_end
5450
5451          mrdx=msftx(i,j)*rdx         ! see ADT eqn 46 dividing by my, 1st term RHS
5452
5453             tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5            &
5454                    *((fzm(k)*ru(i+1,k,j)+fzp(k)*ru(i+1,k-1,j))  &
5455                                 *(w(i+1,k,j)+w(i,k,j))          &
5456                     -(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
5457                                *(w(i,k,j)+w(i-1,k,j)))
5458
5459       ENDDO
5460       ENDDO
5461
5462       k = ktf+1
5463       DO i = i_start, i_end
5464
5465          mrdx=msftx(i,j)*rdx         ! see ADT eqn 46 dividing by my, 1st term RHS
5466
5467             tendency(i,k,j)=tendency(i,k,j)-mrdx*0.5            &
5468                    *(((2.-fzm(k-1))*ru(i+1,k-1,j)-fzp(k-1)*ru(i+1,k-2,j))      &
5469                                 *(w(i+1,k,j)+w(i,k,j))          &
5470                     -((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))         &
5471                                *(w(i,k,j)+w(i-1,k,j)))
5472
5473       ENDDO
5474
5475       ENDDO
5476
5477       i_start = its
5478       i_end   = MIN(ite,ide-1)
5479       ! Polar boundary conditions are like open or specified
5480       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
5481       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-2,jte)
5482
5483       DO j = j_start, j_end
5484       DO k=kts+1,ktf
5485       DO i = i_start, i_end
5486
5487          mrdy=msftx(i,j)*rdy         !  see ADT eqn 46 dividing by my, 2nd term RHS
5488
5489             tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5           &
5490                    *((fzm(k)*rv(i,k,j+1)+fzp(k)*rv(i,k-1,j+1))* &
5491                                  (w(i,k,j+1)+w(i,k,j))          &
5492                     -(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))      &
5493                                  *(w(i,k,j)+w(i,k,j-1)))
5494
5495       ENDDO
5496       ENDDO
5497
5498       k = ktf+1
5499       DO i = i_start, i_end
5500
5501          mrdy=msftx(i,j)*rdy         ! see ADT eqn 46 dividing by my, 2nd term RHS
5502
5503             tendency(i,k,j)=tendency(i,k,j) -mrdy*0.5       &
5504                    *(((2.-fzm(k-1))*rv(i,k-1,j+1)-fzp(k-1)*rv(i,k-2,j+1))* &
5505                                  (w(i,k,j+1)+w(i,k,j))      &
5506                     -((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))      &
5507                                  *(w(i,k,j)+w(i,k,j-1)))
5508
5509       ENDDO
5510
5511       ENDDO
5512
5513       ! Polar boundary condition ... not covered in above j-loop
5514       IF (config_flags%polar) THEN
5515          IF (jts == jds) THEN
5516             DO k=kts+1,ktf
5517             DO i = i_start, i_end
5518                mrdy=msftx(i,jds)*rdy   ! see ADT eqn 46 dividing by my, 2nd term RHS
5519                tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 &
5520                           *((fzm(k)*rv(i,k,jds+1)+fzp(k)*rv(i,k-1,jds+1))* &
5521                             (w(i,k,jds+1)+w(i,k,jds)))
5522             END DO
5523             END DO
5524             k = ktf+1
5525             DO i = i_start, i_end
5526                mrdy=msftx(i,jds)*rdy   ! see ADT eqn 46 dividing by my, 2nd term RHS
5527                tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5       &
5528                    *((2.-fzm(k-1))*rv(i,k-1,jds+1)-fzp(k-1)*rv(i,k-2,jds+1))* &
5529                                  (w(i,k,jds+1)+w(i,k,jds))
5530             ENDDO
5531          END IF
5532          IF (jte == jde) THEN
5533             DO k=kts+1,ktf
5534             DO i = i_start, i_end
5535                mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5536                tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 &
5537                           *((fzm(k)*rv(i,k,jde-1)+fzp(k)*rv(i,k-1,jde-1))* &
5538                             (w(i,k,jde-1)+w(i,k,jde-2)))
5539             END DO
5540             END DO
5541             k = ktf+1
5542             DO i = i_start, i_end
5543                mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
5544                tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5       &
5545                     *((2.-fzm(k-1))*rv(i,k-1,jde-1)-fzp(k-1)*rv(i,k-2,jde-1)) &
5546                                  *(w(i,k,jde-1)+w(i,k,jde-2))
5547             ENDDO
5548          END IF
5549       END IF
5550
5551    ELSE IF ( horz_order == 0 ) THEN
5552
5553       ! Just in case we want to turn horizontal advection off, we can do it
5554
5555    ELSE
5556
5557       WRITE ( wrf_err_message ,*) ' advect_w_6a, h_order not known ',horz_order
5558       CALL wrf_error_fatal ( wrf_err_message )
5559
5560    ENDIF horizontal_order_test
5561
5562
5563 !  pick up the the horizontal radiation boundary conditions.
5564 !  (these are the computations that don't require 'cb'.
5565 !  first, set to index ranges
5566
5567
5568       i_start = its
5569       i_end   = MIN(ite,ide-1)
5570       j_start = jts
5571       j_end   = MIN(jte,jde-1)
5572
5573    IF( (config_flags%open_xs) .and. (its == ids)) THEN
5574
5575        DO j = j_start, j_end
5576        DO k = kts+1, ktf
5577
5578          uw = 0.5*(fzm(k)*(ru(its,k  ,j)+ru(its+1,k  ,j)) +  &
5579                    fzp(k)*(ru(its,k-1,j)+ru(its+1,k-1,j))   )
5580          ub = MIN( uw, 0. )
5581
5582          tendency(its,k,j) = tendency(its,k,j)                     &
5583                - rdx*(                                             &
5584                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
5585                        w(its,k,j)*(                                &
5586                        fzm(k)*(ru(its+1,k  ,j)-ru(its,k  ,j))+     &
5587                        fzp(k)*(ru(its+1,k-1,j)-ru(its,k-1,j)))     &
5588                                                                   )
5589        ENDDO
5590        ENDDO
5591
5592        k = ktf+1
5593        DO j = j_start, j_end
5594
5595          uw = 0.5*( (2.-fzm(k-1))*(ru(its,k-1,j)+ru(its+1,k-1,j))   &
5596                    -fzp(k-1)*(ru(its,k-2,j)+ru(its+1,k-2,j))   )
5597          ub = MIN( uw, 0. )
5598
5599          tendency(its,k,j) = tendency(its,k,j)                     &
5600                - rdx*(                                             &
5601                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
5602                        w(its,k,j)*(                                &
5603                              (2.-fzm(k-1))*(ru(its+1,k-1,j)-ru(its,k-1,j))-  &
5604                              fzp(k-1)*(ru(its+1,k-2,j)-ru(its,k-2,j)))  &
5605                                                                   )
5606        ENDDO
5607
5608    ENDIF
5609
5610    IF( (config_flags%open_xe) .and. (ite == ide)) THEN
5611
5612        DO j = j_start, j_end
5613        DO k = kts+1, ktf
5614
5615          uw = 0.5*(fzm(k)*(ru(ite-1,k  ,j)+ru(ite,k  ,j)) +  &
5616                    fzp(k)*(ru(ite-1,k-1,j)+ru(ite,k-1,j))   )
5617          ub = MAX( uw, 0. )
5618
5619          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
5620                - rdx*(                                                 &
5621                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
5622                        w(i_end,k,j)*(                                  &
5623                             fzm(k)*(ru(ite,k  ,j)-ru(ite-1,k  ,j)) +   &
5624                             fzp(k)*(ru(ite,k-1,j)-ru(ite-1,k-1,j)))    &
5625                                                                     )
5626        ENDDO
5627        ENDDO
5628
5629        k = ktf+1
5630        DO j = j_start, j_end
5631
5632          uw = 0.5*( (2.-fzm(k-1))*(ru(ite-1,k-1,j)+ru(ite,k-1,j))    &
5633                    -fzp(k-1)*(ru(ite-1,k-2,j)+ru(ite,k-2,j))   )
5634          ub = MAX( uw, 0. )
5635
5636          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
5637                - rdx*(                                                 &
5638                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
5639                        w(i_end,k,j)*(                                  &
5640                                (2.-fzm(k-1))*(ru(ite,k-1,j)-ru(ite-1,k-1,j)) -   &
5641                                fzp(k-1)*(ru(ite,k-2,j)-ru(ite-1,k-2,j)))    &
5642                                                                     )
5643        ENDDO
5644
5645    ENDIF
5646
5647
5648    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
5649
5650        DO i = i_start, i_end
5651        DO k = kts+1, ktf
5652
5653          vw = 0.5*( fzm(k)*(rv(i,k  ,jts)+rv(i,k  ,jts+1)) +  &
5654                     fzp(k)*(rv(i,k-1,jts)+rv(i,k-1,jts+1))   )
5655          vb = MIN( vw, 0. )
5656
5657          tendency(i,k,jts) = tendency(i,k,jts)                     &
5658                - rdy*(                                             &
5659                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
5660                        w(i,k,jts)*(                                &
5661                        fzm(k)*(rv(i,k  ,jts+1)-rv(i,k  ,jts))+     &
5662                        fzp(k)*(rv(i,k-1,jts+1)-rv(i,k-1,jts)))     &
5663                                                                 )
5664        ENDDO
5665        ENDDO
5666
5667        k = ktf+1
5668        DO i = i_start, i_end
5669          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jts)+rv(i,k-1,jts+1))    &
5670                    -fzp(k-1)*(rv(i,k-2,jts)+rv(i,k-2,jts+1))   )
5671          vb = MIN( vw, 0. )
5672
5673          tendency(i,k,jts) = tendency(i,k,jts)                     &
5674                - rdy*(                                             &
5675                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
5676                        w(i,k,jts)*(                                &
5677                           (2.-fzm(k-1))*(rv(i,k-1,jts+1)-rv(i,k-1,jts))-     &
5678                           fzp(k-1)*(rv(i,k-2,jts+1)-rv(i,k-2,jts)))     &
5679                                                                 )
5680        ENDDO
5681
5682    ENDIF
5683
5684    IF( (config_flags%open_ye) .and. (jte == jde) ) THEN
5685
5686        DO i = i_start, i_end
5687        DO k = kts+1, ktf
5688
5689          vw = 0.5*( fzm(k)*(rv(i,k  ,jte-1)+rv(i,k  ,jte)) +  &
5690                     fzp(k)*(rv(i,k-1,jte-1)+rv(i,k-1,jte))   )
5691          vb = MAX( vw, 0. )
5692
5693          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
5694                - rdy*(                                                 &
5695                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
5696                        w(i,k,j_end)*(                                  &
5697                             fzm(k)*(rv(i,k  ,jte)-rv(i,k  ,jte-1))+    &
5698                             fzp(k)*(rv(i,k-1,jte)-rv(i,k-1,jte-1)))    &
5699                                                                       )
5700        ENDDO
5701        ENDDO
5702
5703        k = ktf+1
5704        DO i = i_start, i_end
5705
5706          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jte-1)+rv(i,k-1,jte))    &
5707                    -fzp(k-1)*(rv(i,k-2,jte-1)+rv(i,k-2,jte))   )
5708          vb = MAX( vw, 0. )
5709
5710          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
5711                - rdy*(                                                 &
5712                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
5713                        w(i,k,j_end)*(                                  &
5714                                (2.-fzm(k-1))*(rv(i,k-1,jte)-rv(i,k-1,jte-1))-    &
5715                                fzp(k-1)*(rv(i,k-2,jte)-rv(i,k-2,jte-1)))    &
5716                                                                       )
5717        ENDDO
5718
5719    ENDIF
5720
5721 !-------------------- vertical advection
5722 !     ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
5723 !     Here we have:  - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
5724 !     Therefore we don't need to make a correction for advect_w
5725
5726       i_start = its
5727       i_end   = MIN(ite,ide-1)
5728       j_start = jts
5729       j_end   = MIN(jte,jde-1)
5730
5731       DO i = i_start, i_end
5732          vflux(i,kts)=0.
5733          vflux(i,kte)=0.
5734       ENDDO
5735
5736     vert_order_test : IF (vert_order == 6) THEN
5737
5738       DO j = j_start, j_end
5739
5740          DO k=kts+3,ktf-1
5741          DO i = i_start, i_end
5742            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5743            vflux(i,k) = vel*flux6(                                   &
5744                    w(i,k-3,j), w(i,k-2,j), w(i,k-1,j),       &
5745                    w(i,k  ,j), w(i,k+1,j), w(i,k+2,j),  -vel )
5746          ENDDO
5747          ENDDO
5748
5749          DO i = i_start, i_end
5750
5751            k=kts+1
5752            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5753
5754            k = kts+2
5755            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5756            vflux(i,k) = vel*flux4(               &
5757                    w(i,k-2,j), w(i,k-1,j),   &
5758                    w(i,k  ,j), w(i,k+1,j), -vel )
5759
5760            k = ktf
5761            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5762            vflux(i,k) = vel*flux4(               &
5763                    w(i,k-2,j), w(i,k-1,j),   &
5764                    w(i,k  ,j), w(i,k+1,j), -vel )
5765
5766            k=ktf+1
5767            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5768
5769          ENDDO
5770
5771          DO k=kts+1,ktf
5772          DO i = i_start, i_end
5773             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5774          ENDDO
5775          ENDDO
5776
5777 ! pick up flux contribution for w at the lid. wcs, 13 march 2004
5778          k = ktf+1
5779          DO i = i_start, i_end
5780            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5781          ENDDO
5782
5783       ENDDO
5784
5785  ELSE IF (vert_order == 5) THEN
5786
5787       DO j = j_start, j_end
5788
5789          DO k=kts+3,ktf-1
5790          DO i = i_start, i_end
5791            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5792            vflux(i,k) = vel*flux5(                                   &
5793                    w(i,k-3,j), w(i,k-2,j), w(i,k-1,j),       &
5794                    w(i,k  ,j), w(i,k+1,j), w(i,k+2,j),  -vel )
5795          ENDDO
5796          ENDDO
5797
5798          DO i = i_start, i_end
5799
5800            k=kts+1
5801            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5802
5803            k = kts+2
5804            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5805            vflux(i,k) = vel*flux3(               &
5806                    w(i,k-2,j), w(i,k-1,j),   &
5807                    w(i,k  ,j), w(i,k+1,j), -vel )
5808            k = ktf
5809            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5810            vflux(i,k) = vel*flux3(               &
5811                    w(i,k-2,j), w(i,k-1,j),   &
5812                    w(i,k  ,j), w(i,k+1,j), -vel )
5813
5814            k=ktf+1
5815            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5816
5817          ENDDO
5818
5819          DO k=kts+1,ktf
5820          DO i = i_start, i_end
5821             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5822          ENDDO
5823          ENDDO
5824
5825 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5826          k = ktf+1
5827          DO i = i_start, i_end
5828            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5829          ENDDO
5830
5831       ENDDO
5832
5833  ELSE IF (vert_order == 4) THEN
5834
5835       DO j = j_start, j_end
5836
5837          DO k=kts+2,ktf
5838          DO i = i_start, i_end
5839            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5840            vflux(i,k) = vel*flux4(              &
5841                    w(i,k-2,j), w(i,k-1,j),      &
5842                    w(i,k  ,j), w(i,k+1,j), -vel )
5843          ENDDO
5844          ENDDO
5845
5846          DO i = i_start, i_end
5847
5848            k=kts+1
5849            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5850            k=ktf+1
5851            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5852
5853          ENDDO
5854
5855          DO k=kts+1,ktf
5856          DO i = i_start, i_end
5857             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5858          ENDDO
5859          ENDDO
5860
5861 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5862          k = ktf+1
5863          DO i = i_start, i_end
5864            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5865          ENDDO
5866
5867       ENDDO
5868
5869  ELSE IF (vert_order == 3) THEN
5870
5871       DO j = j_start, j_end
5872
5873          DO k=kts+2,ktf
5874          DO i = i_start, i_end
5875            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
5876            vflux(i,k) = vel*flux3(              &
5877                    w(i,k-2,j), w(i,k-1,j),      &
5878                    w(i,k  ,j), w(i,k+1,j), -vel )
5879          ENDDO
5880          ENDDO
5881
5882          DO i = i_start, i_end
5883
5884            k=kts+1
5885            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5886            k=ktf+1
5887            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5888
5889          ENDDO
5890
5891          DO k=kts+1,ktf
5892          DO i = i_start, i_end
5893             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5894          ENDDO
5895          ENDDO
5896
5897 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5898          k = ktf+1
5899          DO i = i_start, i_end
5900            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5901          ENDDO
5902
5903       ENDDO
5904
5905  ELSE IF (vert_order == 2) THEN
5906
5907   DO j = j_start, j_end
5908      DO k=kts+1,ktf+1
5909      DO i = i_start, i_end
5910
5911             vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
5912      ENDDO
5913      ENDDO
5914      DO k=kts+1,ktf
5915      DO i = i_start, i_end
5916             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
5917
5918      ENDDO
5919      ENDDO
5920
5921 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
5922      k = ktf+1
5923      DO i = i_start, i_end
5924        tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
5925      ENDDO
5926
5927   ENDDO
5928
5929    ELSE
5930
5931       WRITE (wrf_err_message ,*) ' advect_w, v_order not known ',vert_order
5932       CALL wrf_error_fatal ( wrf_err_message )
5933
5934    ENDIF vert_order_test
5935
5936 END SUBROUTINE advect_w
5937
5938 !----------------------------------------------------------------
5939
5940 SUBROUTINE advect_scalar_pd   ( field, field_old, tendency,    &
5941                                 h_tendency, z_tendency,        &
5942                                 ru, rv, rom,                   &
5943                                 mut, mub, mu_old,              &
5944                                 time_step, config_flags,       &
5945                                 tenddec,                       &
5946                                 msfux, msfuy, msfvx, msfvy,    &
5947                                 msftx, msfty,                  &
5948                                 fzm, fzp,                      &
5949                                 rdx, rdy, rdzw, dt,            &
5950                                 ids, ide, jds, jde, kds, kde,  &
5951                                 ims, ime, jms, jme, kms, kme,  &
5952                                 its, ite, jts, jte, kts, kte  )
5953
5954 !  this is a first cut at a positive definite advection option
5955 !  for scalars in WRF.  This version is memory intensive ->
5956 !  we save 3d arrays of x, y and z both high and low order fluxes
5957 !  (six in all).  Alternatively, we could sweep in a direction
5958 !  and lower the cost considerably.
5959
5960 !  uses the Smolarkiewicz MWR 1989 approach, with addition of first-order
5961 !  fluxes initially
5962
5963 !  WCS, 3 December 2002, 24 February 2003
5964
5965    IMPLICIT NONE
5966
5967    ! Input data
5968
5969    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
5970
5971    LOGICAL ,                 INTENT(IN   ) :: tenddec  ! tendency flag
5972
5973    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
5974                                               ims, ime, jms, jme, kms, kme, &
5975                                               its, ite, jts, jte, kts, kte
5976
5977    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
5978                                                                       field_old, &
5979                                                                       ru,    &
5980                                                                       rv,    &
5981                                                                       rom
5982
5983    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut, mub, mu_old
5984    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
5985    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(  OUT) :: h_tendency, z_tendency
5986
5987    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
5988                                                                     msfuy,  &
5989                                                                     msfvx,  &
5990                                                                     msfvy,  &
5991                                                                     msftx,  &
5992                                                                     msfty
5993
5994    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
5995                                                                   fzp,  &
5996                                                                   rdzw
5997
5998    REAL ,                                        INTENT(IN   ) :: rdx,  &
5999                                                                   rdy,  &
6000                                                                   dt
6001    INTEGER ,                                     INTENT(IN   ) :: time_step
6002
6003    ! Local data
6004
6005    INTEGER :: i, j, k, itf, jtf, ktf
6006    INTEGER :: i_start, i_end, j_start, j_end
6007    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
6008    INTEGER :: jmin, jmax, jp, jm, imin, imax
6009
6010    REAL    :: mrdx, mrdy, ub, vb, uw, vw, mu
6011
6012 !  storage for high and low order fluxes
6013
6014    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqx, fqy, fqz
6015    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqxl, fqyl, fqzl
6016
6017    INTEGER :: horz_order, vert_order
6018
6019    LOGICAL :: degrade_xs, degrade_ys
6020    LOGICAL :: degrade_xe, degrade_ye
6021
6022    INTEGER :: jp1, jp0, jtmp
6023
6024    REAL :: flux_out, ph_low, scale
6025    REAL, PARAMETER :: eps=1.e-20
6026
6027
6028 ! definition of flux operators, 3rd, 4th, 5th or 6th order
6029
6030    REAL    :: flux3, flux4, flux5, flux6, flux_upwind
6031    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
6032
6033       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
6034             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
6035
6036       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
6037            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
6038            sign(1,time_step)*sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
6039
6040       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
6041             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
6042             +(1./60.)*(q_ip2+q_im3)
6043
6044       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
6045            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
6046             -sign(1,time_step)*sign(1.,ua)*(1./60.)*(           &
6047               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
6048
6049       flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 &
6050                                     +0.5*max(-1.0,(cr-abs(cr)))*q_i
6051
6052 !      flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
6053 !                                    +0.5*(1.-sign(1.,cr))*q_i
6054 !      flux_upwind(q_im1, q_i, cr ) = 0.
6055
6056     REAL     :: dx,dy,dz
6057
6058     LOGICAL, PARAMETER :: pd_limit = .true.
6059
6060 ! set order for the advection schemes
6061
6062 !  write(6,*) ' in pd advection routine '
6063
6064     ! Empty arrays just in case:
6065     IF (config_flags%polar) THEN
6066        fqx(:,:,:)  = 0.
6067        fqy(:,:,:)  = 0.
6068        fqz(:,:,:)  = 0.
6069        fqxl(:,:,:) = 0.
6070        fqyl(:,:,:) = 0.
6071        fqzl(:,:,:) = 0.
6072     END IF
6073
6074   ktf=MIN(kte,kde-1)
6075   horz_order = config_flags%h_sca_adv_order
6076   vert_order = config_flags%v_sca_adv_order
6077
6078 !  determine boundary mods for flux operators
6079 !  We degrade the flux operators from 3rd/4th order
6080 !   to second order one gridpoint in from the boundaries for
6081 !   all boundary conditions except periodic and symmetry - these
6082 !   conditions have boundary zone data fill for correct application
6083 !   of the higher order flux stencils
6084
6085    degrade_xs = .true.
6086    degrade_xe = .true.
6087    degrade_ys = .true.
6088    degrade_ye = .true.
6089
6090 !  begin with horizontal flux divergence
6091 !  here is the choice of flux operators
6092
6093
6094   horizontal_order_test : IF( horz_order == 6 ) THEN
6095
6096    IF( config_flags%periodic_x   .or. &
6097        config_flags%symmetric_xs .or. &
6098        (its > ids+3)                ) degrade_xs = .false.
6099    IF( config_flags%periodic_x   .or. &
6100        config_flags%symmetric_xe .or. &
6101        (ite < ide-4)                ) degrade_xe = .false.
6102    IF( config_flags%periodic_y   .or. &
6103        config_flags%symmetric_ys .or. &
6104        (jts > jds+3)                ) degrade_ys = .false.
6105    IF( config_flags%periodic_y   .or. &
6106        config_flags%symmetric_ye .or. &
6107        (jte < jde-4)                ) degrade_ye = .false.
6108
6109 !--------------- y - advection first
6110
6111 !--  y flux compute; these bounds are for periodic and sym b.c.
6112
6113       ktf=MIN(kte,kde-1)
6114       i_start = its-1
6115       i_end   = MIN(ite,ide-1)+1
6116       j_start = jts-1
6117       j_end   = MIN(jte,jde-1)+1
6118       j_start_f = j_start
6119       j_end_f   = j_end+1
6120
6121 !--  modify loop bounds if open or specified
6122
6123 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
6124 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
6125       IF(degrade_xs) i_start = MAX(its-1,ids)
6126       IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
6127
6128       IF(degrade_ys) then
6129         j_start = MAX(jts-1,jds+1)
6130         j_start_f = jds+3
6131       ENDIF
6132
6133       IF(degrade_ye) then
6134         j_end = MIN(jte+1,jde-2)
6135         j_end_f = jde-3
6136       ENDIF
6137
6138 !  compute fluxes, 6th order
6139
6140       j_loop_y_flux_6 : DO j = j_start, j_end+1
6141
6142       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6143
6144         DO k=kts,ktf
6145         DO i = i_start, i_end
6146
6147           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6148           mu = 0.5*(mut(i,j)+mut(i,j-1))
6149           vel = rv(i,k,j)
6150           cr = vel*dt/dy/mu
6151           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6152
6153           fqy( i, k, j  ) = vel*flux6(                                  &
6154                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
6155                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
6156
6157           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6158
6159         ENDDO
6160         ENDDO
6161
6162       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
6163
6164             DO k=kts,ktf
6165             DO i = i_start, i_end
6166
6167               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6168               mu = 0.5*(mut(i,j)+mut(i,j-1))
6169               vel = rv(i,k,j)
6170               cr = vel*dt/dy/mu
6171               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6172
6173               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
6174                      (field(i,k,j)+field(i,k,j-1))
6175
6176               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6177
6178             ENDDO
6179             ENDDO
6180
6181       ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
6182
6183             DO k=kts,ktf
6184             DO i = i_start, i_end
6185
6186               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6187               mu = 0.5*(mut(i,j)+mut(i,j-1))
6188               vel = rv(i,k,j)
6189               cr = vel*dt/dy/mu
6190               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6191
6192               fqy( i, k, j ) = vel*flux4(              &
6193                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
6194               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6195
6196             ENDDO
6197             ENDDO
6198
6199       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
6200
6201             DO k=kts,ktf
6202             DO i = i_start, i_end
6203
6204               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6205               mu = 0.5*(mut(i,j)+mut(i,j-1))
6206               vel = rv(i,k,j)
6207               cr = vel*dt/dy/mu
6208               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6209
6210               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
6211                      (field(i,k,j)+field(i,k,j-1))
6212               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6213
6214             ENDDO
6215             ENDDO
6216
6217       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
6218
6219             DO k=kts,ktf
6220             DO i = i_start, i_end
6221
6222               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6223               mu = 0.5*(mut(i,j)+mut(i,j-1))
6224               vel = rv(i,k,j)
6225               cr = vel*dt/dy/mu
6226               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6227
6228               fqy( i, k, j) = vel*flux4(             &
6229                    field(i,k,j-2),field(i,k,j-1),    &
6230                    field(i,k,j),field(i,k,j+1),vel )
6231               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6232
6233             ENDDO
6234             ENDDO
6235
6236       ENDIF
6237
6238    ENDDO j_loop_y_flux_6
6239
6240 !  next, x flux
6241
6242 !--  these bounds are for periodic and sym conditions
6243
6244       i_start = its-1
6245       i_end   = MIN(ite,ide-1)+1
6246       i_start_f = i_start
6247       i_end_f   = i_end+1
6248
6249       j_start = jts-1
6250       j_end   = MIN(jte,jde-1)+1
6251
6252 !--  modify loop bounds for open and specified b.c
6253
6254 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
6255 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
6256       IF(degrade_ys) j_start = MAX(jts-1,jds)
6257       IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
6258
6259       IF(degrade_xs) then
6260         i_start = MAX(ids+1,its-1)
6261         i_start_f = ids+3
6262       ENDIF
6263
6264       IF(degrade_xe) then
6265         i_end = MIN(ide-2,ite+1)
6266         i_end_f = ide-3
6267       ENDIF
6268
6269 !  compute fluxes
6270
6271       DO j = j_start, j_end
6272
6273 !  5th order flux
6274
6275         DO k=kts,ktf
6276         DO i = i_start_f, i_end_f
6277
6278           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6279           mu = 0.5*(mut(i,j)+mut(i-1,j))
6280           vel = ru(i,k,j)
6281           cr = vel*dt/dx/mu
6282           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6283
6284           fqx( i,k,j ) = vel*flux6( field(i-3,k,j), field(i-2,k,j),  &
6285                                          field(i-1,k,j), field(i  ,k,j),  &
6286                                          field(i+1,k,j), field(i+2,k,j),  &
6287                                          vel                             )
6288           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6289
6290         ENDDO
6291         ENDDO
6292
6293 !  lower order fluxes close to boundaries (if not periodic or symmetric)
6294
6295         IF( degrade_xs ) THEN
6296
6297           DO i=i_start,i_start_f-1
6298
6299             IF(i == ids+1) THEN ! second order
6300               DO k=kts,ktf
6301                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6302                 mu = 0.5*(mut(i,j)+mut(i-1,j))
6303                 vel = ru(i,k,j)/mu
6304                 cr = vel*dt/dx
6305                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6306                 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6307                        *(field(i,k,j)+field(i-1,k,j))
6308                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6309               ENDDO
6310             ENDIF
6311
6312             IF(i == ids+2) THEN  ! fourth order
6313               DO k=kts,ktf
6314                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6315                 mu = 0.5*(mut(i,j)+mut(i-1,j))
6316                 vel = ru(i,k,j)
6317                 cr = vel*dt/dx/mu
6318                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6319                 fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
6320                                           field(i  ,k,j), field(i+1,k,j),  &
6321                                           vel                             )
6322                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6323               ENDDO
6324             ENDIF
6325
6326           ENDDO
6327
6328         ENDIF
6329
6330         IF( degrade_xe ) THEN
6331
6332           DO i = i_end_f+1, i_end+1
6333
6334             IF( i == ide-1 ) THEN ! second order flux next to the boundary
6335               DO k=kts,ktf
6336                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6337                 mu = 0.5*(mut(i,j)+mut(i-1,j))
6338                 vel = ru(i,k,j)
6339                 cr = vel*dt/dx/mu
6340                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6341                 fqx(i,k,j) = 0.5*(ru(i,k,j))      &
6342                        *(field(i,k,j)+field(i-1,k,j))
6343                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6344               ENDDO
6345             ENDIF
6346
6347
6348             IF( i == ide-2 ) THEN ! fourth order flux one in from the boundary
6349               DO k=kts,ktf
6350                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6351                 mu = 0.5*(mut(i,j)+mut(i-1,j))
6352                 vel = ru(i,k,j)
6353                 cr = vel*dt/dx/mu
6354                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6355                 fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j),  &
6356                                           field(i  ,k,j), field(i+1,k,j),  &
6357                                           vel                             )
6358                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6359               ENDDO
6360             ENDIF
6361
6362           ENDDO
6363
6364         ENDIF
6365
6366       ENDDO  ! enddo for outer J loop
6367
6368 !--- end of 6th order horizontal flux calculation
6369
6370     ELSE IF( horz_order == 5 ) THEN
6371
6372    IF( config_flags%periodic_x   .or. &
6373        config_flags%symmetric_xs .or. &
6374        (its > ids+3)                ) degrade_xs = .false.
6375    IF( config_flags%periodic_x   .or. &
6376        config_flags%symmetric_xe .or. &
6377        (ite < ide-4)                ) degrade_xe = .false.
6378    IF( config_flags%periodic_y   .or. &
6379        config_flags%symmetric_ys .or. &
6380        (jts > jds+3)                ) degrade_ys = .false.
6381    IF( config_flags%periodic_y   .or. &
6382        config_flags%symmetric_ye .or. &
6383        (jte < jde-4)                ) degrade_ye = .false.
6384
6385 !--------------- y - advection first
6386
6387 !--  y flux compute; these bounds are for periodic and sym b.c.
6388
6389       ktf=MIN(kte,kde-1)
6390       i_start = its-1
6391       i_end   = MIN(ite,ide-1)+1
6392       j_start = jts-1
6393       j_end   = MIN(jte,jde-1)+1
6394       j_start_f = j_start
6395       j_end_f   = j_end+1
6396
6397 !--  modify loop bounds if open or specified
6398
6399 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
6400 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
6401       IF(degrade_xs) i_start = MAX(its-1,ids)
6402       IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
6403
6404       IF(degrade_ys) then
6405         j_start = MAX(jts-1,jds+1)
6406         j_start_f = jds+3
6407       ENDIF
6408
6409       IF(degrade_ye) then
6410         j_end = MIN(jte+1,jde-2)
6411         j_end_f = jde-3
6412       ENDIF
6413
6414 !  compute fluxes, 5th order
6415
6416       j_loop_y_flux_5 : DO j = j_start, j_end+1
6417
6418       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6419
6420         DO k=kts,ktf
6421         DO i = i_start, i_end
6422
6423           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6424           mu = 0.5*(mut(i,j)+mut(i,j-1))
6425           vel = rv(i,k,j)
6426           cr = vel*dt/dy/mu
6427           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6428
6429           fqy( i, k, j  ) = vel*flux5(                                  &
6430                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
6431                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
6432
6433           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6434
6435         ENDDO
6436         ENDDO
6437
6438       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
6439
6440             DO k=kts,ktf
6441             DO i = i_start, i_end
6442
6443               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6444               mu = 0.5*(mut(i,j)+mut(i,j-1))
6445               vel = rv(i,k,j)
6446               cr = vel*dt/dy/mu
6447               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6448
6449               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
6450                      (field(i,k,j)+field(i,k,j-1))
6451
6452               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6453
6454             ENDDO
6455             ENDDO
6456
6457       ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
6458
6459             DO k=kts,ktf
6460             DO i = i_start, i_end
6461
6462               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6463               mu = 0.5*(mut(i,j)+mut(i,j-1))
6464               vel = rv(i,k,j)
6465               cr = vel*dt/dy/mu
6466               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6467
6468               fqy( i, k, j ) = vel*flux3(              &
6469                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
6470               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6471
6472             ENDDO
6473             ENDDO
6474
6475       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
6476
6477             DO k=kts,ktf
6478             DO i = i_start, i_end
6479
6480               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6481               mu = 0.5*(mut(i,j)+mut(i,j-1))
6482               vel = rv(i,k,j)
6483               cr = vel*dt/dy/mu
6484               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6485
6486               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
6487                      (field(i,k,j)+field(i,k,j-1))
6488               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6489
6490             ENDDO
6491             ENDDO
6492
6493       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
6494
6495             DO k=kts,ktf
6496             DO i = i_start, i_end
6497
6498               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6499               mu = 0.5*(mut(i,j)+mut(i,j-1))
6500               vel = rv(i,k,j)
6501               cr = vel*dt/dy/mu
6502               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6503
6504               fqy( i, k, j) = vel*flux3(             &
6505                    field(i,k,j-2),field(i,k,j-1),    &
6506                    field(i,k,j),field(i,k,j+1),vel )
6507               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6508
6509             ENDDO
6510             ENDDO
6511
6512       ENDIF
6513
6514    ENDDO j_loop_y_flux_5
6515
6516 !  next, x flux
6517
6518 !--  these bounds are for periodic and sym conditions
6519
6520       i_start = its-1
6521       i_end   = MIN(ite,ide-1)+1
6522       i_start_f = i_start
6523       i_end_f   = i_end+1
6524
6525       j_start = jts-1
6526       j_end   = MIN(jte,jde-1)+1
6527
6528 !--  modify loop bounds for open and specified b.c
6529
6530 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
6531 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
6532       IF(degrade_ys) j_start = MAX(jts-1,jds)
6533       IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
6534
6535       IF(degrade_xs) then
6536         i_start = MAX(ids+1,its-1)
6537         i_start_f = ids+3
6538       ENDIF
6539
6540       IF(degrade_xe) then
6541         i_end = MIN(ide-2,ite+1)
6542         i_end_f = ide-3
6543       ENDIF
6544
6545 !  compute fluxes
6546
6547       DO j = j_start, j_end
6548
6549 !  5th order flux
6550
6551         DO k=kts,ktf
6552         DO i = i_start_f, i_end_f
6553
6554           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6555           mu = 0.5*(mut(i,j)+mut(i-1,j))
6556           vel = ru(i,k,j)
6557           cr = vel*dt/dx/mu
6558           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6559
6560           fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
6561                                          field(i-1,k,j), field(i  ,k,j),  &
6562                                          field(i+1,k,j), field(i+2,k,j),  &
6563                                          vel                             )
6564           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6565
6566         ENDDO
6567         ENDDO
6568
6569 !  lower order fluxes close to boundaries (if not periodic or symmetric)
6570
6571         IF( degrade_xs ) THEN
6572
6573           DO i=i_start,i_start_f-1
6574
6575             IF(i == ids+1) THEN ! second order
6576               DO k=kts,ktf
6577                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6578                 mu = 0.5*(mut(i,j)+mut(i-1,j))
6579                 vel = ru(i,k,j)/mu
6580                 cr = vel*dt/dx
6581                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6582                 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6583                        *(field(i,k,j)+field(i-1,k,j))
6584                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6585               ENDDO
6586             ENDIF
6587
6588             IF(i == ids+2) THEN  ! third order
6589               DO k=kts,ktf
6590                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6591                 mu = 0.5*(mut(i,j)+mut(i-1,j))
6592                 vel = ru(i,k,j)
6593                 cr = vel*dt/dx/mu
6594                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6595                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
6596                                           field(i  ,k,j), field(i+1,k,j),  &
6597                                           vel                             )
6598                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6599               ENDDO
6600             ENDIF
6601
6602           ENDDO
6603
6604         ENDIF
6605
6606         IF( degrade_xe ) THEN
6607
6608           DO i = i_end_f+1, i_end+1
6609
6610             IF( i == ide-1 ) THEN ! second order flux next to the boundary
6611               DO k=kts,ktf
6612                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6613                 mu = 0.5*(mut(i,j)+mut(i-1,j))
6614                 vel = ru(i,k,j)
6615                 cr = vel*dt/dx/mu
6616                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6617                 fqx(i,k,j) = 0.5*(ru(i,k,j))      &
6618                        *(field(i,k,j)+field(i-1,k,j))
6619                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6620               ENDDO
6621             ENDIF
6622
6623
6624             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
6625               DO k=kts,ktf
6626                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6627                 mu = 0.5*(mut(i,j)+mut(i-1,j))
6628                 vel = ru(i,k,j)
6629                 cr = vel*dt/dx/mu
6630                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6631                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
6632                                           field(i  ,k,j), field(i+1,k,j),  &
6633                                           vel                             )
6634                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6635               ENDDO
6636             ENDIF
6637
6638           ENDDO
6639
6640         ENDIF
6641
6642       ENDDO  ! enddo for outer J loop
6643
6644 !--- end of 5th order horizontal flux calculation
6645
6646     ELSE IF( horz_order == 4 ) THEN
6647
6648    IF( config_flags%periodic_x   .or. &
6649        config_flags%symmetric_xs .or. &
6650        (its > ids+1)                ) degrade_xs = .false.
6651    IF( config_flags%periodic_x   .or. &
6652        config_flags%symmetric_xe .or. &
6653        (ite < ide-2)                ) degrade_xe = .false.
6654    IF( config_flags%periodic_y   .or. &
6655        config_flags%symmetric_ys .or. &
6656        (jts > jds+1)                ) degrade_ys = .false.
6657    IF( config_flags%periodic_y   .or. &
6658        config_flags%symmetric_ye .or. &
6659        (jte < jde-2)                ) degrade_ye = .false.
6660
6661 !--------------- y - advection first
6662
6663 !--  y flux compute; these bounds are for periodic and sym b.c.
6664
6665       ktf=MIN(kte,kde-1)
6666       i_start = its-1
6667       i_end   = MIN(ite,ide-1)+1
6668       j_start = jts-1
6669       j_end   = MIN(jte,jde-1)+1
6670       j_start_f = j_start
6671       j_end_f   = j_end+1
6672
6673 !--  modify loop bounds if open or specified
6674
6675       IF(degrade_xs) i_start = its
6676       IF(degrade_xe) i_end   = MIN(ite,ide-1)
6677
6678       IF(degrade_ys) then
6679         j_start = MAX(jts,jds+1)
6680         j_start_f = jds+2
6681       ENDIF
6682
6683       IF(degrade_ye) then
6684         j_end = MIN(jte,jde-2)
6685         j_end_f = jde-2
6686       ENDIF
6687
6688 !  compute fluxes, 4th order
6689
6690       j_loop_y_flux_4 : DO j = j_start, j_end+1
6691
6692       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6693
6694         DO k=kts,ktf
6695         DO i = i_start, i_end
6696
6697           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6698           mu = 0.5*(mut(i,j)+mut(i,j-1))
6699           vel = rv(i,k,j)
6700           cr = vel*dt/dy/mu
6701           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6702
6703           fqy( i, k, j  ) = vel*flux4(  field(i,k,j-2), field(i,k,j-1),       &
6704                                         field(i,k,j  ), field(i,k,j+1), vel )
6705
6706           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6707
6708         ENDDO
6709         ENDDO
6710
6711       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
6712
6713             DO k=kts,ktf
6714             DO i = i_start, i_end
6715
6716               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6717               mu = 0.5*(mut(i,j)+mut(i,j-1))
6718               vel = rv(i,k,j)
6719               cr = vel*dt/dy/mu
6720               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6721
6722               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
6723                      (field(i,k,j)+field(i,k,j-1))
6724
6725               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6726
6727             ENDDO
6728             ENDDO
6729
6730       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
6731
6732             DO k=kts,ktf
6733             DO i = i_start, i_end
6734
6735               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6736               mu = 0.5*(mut(i,j)+mut(i,j-1))
6737               vel = rv(i,k,j)
6738               cr = vel*dt/dy/mu
6739               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6740
6741               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
6742                      (field(i,k,j)+field(i,k,j-1))
6743               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6744
6745             ENDDO
6746             ENDDO
6747
6748       ENDIF
6749
6750    ENDDO j_loop_y_flux_4
6751
6752 !  next, x flux
6753
6754 !--  these bounds are for periodic and sym conditions
6755
6756       i_start = its-1
6757       i_end   = MIN(ite,ide-1)+1
6758       i_start_f = i_start
6759       i_end_f   = i_end+1
6760
6761       j_start = jts-1
6762       j_end   = MIN(jte,jde-1)+1
6763
6764 !--  modify loop bounds for open and specified b.c
6765
6766       IF(degrade_ys) j_start = jts
6767       IF(degrade_ye) j_end   = MIN(jte,jde-1)
6768
6769       IF(degrade_xs) then
6770         i_start = MAX(ids+1,its)
6771         i_start_f = i_start+1
6772       ENDIF
6773
6774       IF(degrade_xe) then
6775         i_end = MIN(ide-2,ite)
6776         i_end_f = ide-2
6777       ENDIF
6778
6779 !  compute fluxes
6780
6781       DO j = j_start, j_end
6782
6783 !  4th order flux
6784
6785         DO k=kts,ktf
6786         DO i = i_start_f, i_end_f
6787
6788           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6789           mu = 0.5*(mut(i,j)+mut(i-1,j))
6790           vel = ru(i,k,j)
6791           cr = vel*dt/dx/mu
6792           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6793
6794           fqx( i,k,j ) = vel*flux4( field(i-2,k,j), field(i-1,k,j), &
6795                                     field(i  ,k,j), field(i+1,k,j), vel )
6796           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6797
6798         ENDDO
6799         ENDDO
6800
6801 !  lower order fluxes close to boundaries (if not periodic or symmetric)
6802
6803         IF( degrade_xs ) THEN
6804           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
6805             i = ids+1
6806             DO k=kts,ktf
6807
6808               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6809               mu = 0.5*(mut(i,j)+mut(i-1,j))
6810               vel = ru(i,k,j)/mu
6811               cr = vel*dt/dx
6812               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6813
6814               fqx(i,k,j) = 0.5*(ru(i,k,j)) &
6815                      *(field(i,k,j)+field(i-1,k,j))
6816
6817               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6818
6819             ENDDO
6820           ENDIF
6821         ENDIF
6822
6823         IF( degrade_xe ) THEN
6824           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
6825             i = ide-1
6826             DO k=kts,ktf
6827               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6828               mu = 0.5*(mut(i,j)+mut(i-1,j))
6829               vel = ru(i,k,j)
6830               cr = vel*dt/dx/mu
6831               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6832               fqx(i,k,j) = 0.5*(ru(i,k,j))      &
6833                      *(field(i,k,j)+field(i-1,k,j))
6834               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6835
6836             ENDDO
6837           ENDIF
6838         ENDIF
6839
6840       ENDDO  ! enddo for outer J loop
6841
6842 !--- end of 4th order horizontal flux calculation
6843
6844    ELSE IF( horz_order == 3 ) THEN
6845
6846    IF( config_flags%periodic_x   .or. &
6847        config_flags%symmetric_xs .or. &
6848        (its > ids+2)                ) degrade_xs = .false.
6849    IF( config_flags%periodic_x   .or. &
6850        config_flags%symmetric_xe .or. &
6851        (ite < ide-1)                ) degrade_xe = .false.
6852    IF( config_flags%periodic_y   .or. &
6853        config_flags%symmetric_ys .or. &
6854        (jts > jds+2)                ) degrade_ys = .false.
6855    IF( config_flags%periodic_y   .or. &
6856        config_flags%symmetric_ye .or. &
6857        (jte < jde-1)                ) degrade_ye = .false.
6858
6859 !--------------- y - advection first
6860
6861 !--  y flux compute; these bounds are for periodic and sym b.c.
6862
6863       ktf=MIN(kte,kde-1)
6864       i_start = its-1
6865       i_end   = MIN(ite,ide-1)+1
6866       j_start = jts-1
6867       j_end   = MIN(jte,jde-1)+1
6868       j_start_f = j_start
6869       j_end_f   = j_end+1
6870
6871 !--  modify loop bounds if open or specified
6872
6873       IF(degrade_xs) i_start = its
6874       IF(degrade_xe) i_end   = MIN(ite,ide-1)
6875
6876       IF(degrade_ys) then
6877         j_start = MAX(jts,jds+1)
6878         j_start_f = jds+2
6879       ENDIF
6880
6881       IF(degrade_ye) then
6882         j_end = MIN(jte,jde-2)
6883         j_end_f = jde-2
6884       ENDIF
6885
6886 !  compute fluxes, 3rd order
6887
6888       j_loop_y_flux_3 : DO j = j_start, j_end+1
6889
6890       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
6891
6892         DO k=kts,ktf
6893         DO i = i_start, i_end
6894
6895           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6896           mu = 0.5*(mut(i,j)+mut(i,j-1))
6897           vel = rv(i,k,j)
6898           cr = vel*dt/dy/mu
6899           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6900
6901           fqy( i, k, j  ) = vel*flux3(  field(i,k,j-2), field(i,k,j-1),       &
6902                                         field(i,k,j  ), field(i,k,j+1), vel )
6903
6904           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6905
6906         ENDDO
6907         ENDDO
6908
6909       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
6910
6911             DO k=kts,ktf
6912             DO i = i_start, i_end
6913
6914               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6915               mu = 0.5*(mut(i,j)+mut(i,j-1))
6916               vel = rv(i,k,j)
6917               cr = vel*dt/dy/mu
6918               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6919
6920               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
6921                      (field(i,k,j)+field(i,k,j-1))
6922
6923               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6924
6925             ENDDO
6926             ENDDO
6927
6928       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
6929
6930             DO k=kts,ktf
6931             DO i = i_start, i_end
6932
6933               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
6934               mu = 0.5*(mut(i,j)+mut(i,j-1))
6935               vel = rv(i,k,j)
6936               cr = vel*dt/dy/mu
6937               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
6938
6939               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
6940                      (field(i,k,j)+field(i,k,j-1))
6941               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
6942
6943             ENDDO
6944             ENDDO
6945
6946       ENDIF
6947
6948    ENDDO j_loop_y_flux_3
6949
6950 !  next, x flux
6951
6952 !--  these bounds are for periodic and sym conditions
6953
6954       i_start = its-1
6955       i_end   = MIN(ite,ide-1)+1
6956       i_start_f = i_start
6957       i_end_f   = i_end+1
6958
6959       j_start = jts-1
6960       j_end   = MIN(jte,jde-1)+1
6961
6962 !--  modify loop bounds for open and specified b.c
6963
6964       IF(degrade_ys) j_start = jts
6965       IF(degrade_ye) j_end   = MIN(jte,jde-1)
6966
6967       IF(degrade_xs) then
6968         i_start = MAX(ids+1,its)
6969         i_start_f = i_start+1
6970       ENDIF
6971
6972       IF(degrade_xe) then
6973         i_end = MIN(ide-2,ite)
6974         i_end_f = ide-2
6975       ENDIF
6976
6977 !  compute fluxes
6978
6979       DO j = j_start, j_end
6980
6981 !  4th order flux
6982
6983         DO k=kts,ktf
6984         DO i = i_start_f, i_end_f
6985
6986           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
6987           mu = 0.5*(mut(i,j)+mut(i-1,j))
6988           vel = ru(i,k,j)
6989           cr = vel*dt/dx/mu
6990           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
6991
6992           fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), &
6993                                     field(i  ,k,j), field(i+1,k,j), vel )
6994           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
6995
6996         ENDDO
6997         ENDDO
6998
6999 !  lower order fluxes close to boundaries (if not periodic or symmetric)
7000
7001         IF( degrade_xs ) THEN
7002
7003           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
7004             i = ids+1
7005             DO k=kts,ktf
7006
7007               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
7008               mu = 0.5*(mut(i,j)+mut(i-1,j))
7009               vel = ru(i,k,j)/mu
7010               cr = vel*dt/dx
7011               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
7012
7013               fqx(i,k,j) = 0.5*(ru(i,k,j)) &
7014                      *(field(i,k,j)+field(i-1,k,j))
7015
7016               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7017
7018             ENDDO
7019           ENDIF
7020         ENDIF
7021
7022         IF( degrade_xe ) THEN
7023           IF( i_end == ide-2 ) THEN ! second order flux next to the boundary
7024             i = ide-1
7025             DO k=kts,ktf
7026               dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
7027               mu = 0.5*(mut(i,j)+mut(i-1,j))
7028               vel = ru(i,k,j)
7029               cr = vel*dt/dx/mu
7030               fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
7031               fqx(i,k,j) = 0.5*(ru(i,k,j))      &
7032                      *(field(i,k,j)+field(i-1,k,j))
7033               fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7034
7035             ENDDO
7036           ENDIF
7037         ENDIF
7038
7039       ENDDO  ! enddo for outer J loop
7040
7041 !--- end of 3rd order horizontal flux calculation
7042
7043
7044    ELSE IF( horz_order == 2 ) THEN
7045
7046    IF( config_flags%periodic_x   .or. &
7047        config_flags%symmetric_xs .or. &
7048        (its > ids+1)                ) degrade_xs = .false.
7049    IF( config_flags%periodic_x   .or. &
7050        config_flags%symmetric_xe .or. &
7051        (ite < ide-2)                ) degrade_xe = .false.
7052    IF( config_flags%periodic_y   .or. &
7053        config_flags%symmetric_ys .or. &
7054        (jts > jds+1)                ) degrade_ys = .false.
7055    IF( config_flags%periodic_y   .or. &
7056        config_flags%symmetric_ye .or. &
7057        (jte < jde-2)                ) degrade_ye = .false.
7058
7059 !--  y flux compute; these bounds are for periodic and sym b.c.
7060
7061       ktf=MIN(kte,kde-1)
7062       i_start = its-1
7063       i_end   = MIN(ite,ide-1)+1
7064       j_start = jts-1
7065       j_end   = MIN(jte,jde-1)+1
7066
7067 !--  modify loop bounds if open or specified
7068
7069       IF(degrade_xs) i_start = its
7070       IF(degrade_xe) i_end   = MIN(ite,ide-1)
7071       IF(degrade_ys) j_start = MAX(jts,jds+1)
7072       IF(degrade_ye) j_end = MIN(jte,jde-2)
7073
7074 !  compute fluxes, 2nd order, y flux
7075
7076       DO j = j_start, j_end+1
7077         DO k=kts,ktf
7078         DO i = i_start, i_end
7079            dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
7080            mu = 0.5*(mut(i,j)+mut(i,j-1))
7081            vel = rv(i,k,j)
7082            cr = vel*dt/dy/mu
7083            fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
7084
7085            fqy(i,k, j) = 0.5*rv(i,k,j)*          &
7086                   (field(i,k,j)+field(i,k,j-1))
7087
7088            fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7089         ENDDO
7090         ENDDO
7091       ENDDO
7092
7093 !  next, x flux
7094
7095       DO j = j_start, j_end
7096         DO k=kts,ktf
7097         DO i = i_start, i_end+1
7098             dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
7099             mu = 0.5*(mut(i,j)+mut(i-1,j))
7100             vel = ru(i,k,j)
7101             cr = vel*dt/dx/mu
7102             fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
7103             fqx( i,k,j ) = 0.5*ru(i,k,j)*          &
7104                   (field(i,k,j)+field(i-1,k,j))
7105
7106             fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
7107         ENDDO
7108         ENDDO
7109       ENDDO
7110
7111 !--- end of 2nd order horizontal flux calculation
7112
7113    ELSE
7114
7115       WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order
7116       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
7117
7118    ENDIF horizontal_order_test
7119
7120 !  pick up the rest of the horizontal radiation boundary conditions.
7121 !  (these are the computations that don't require 'cb'.
7122 !  first, set to index ranges
7123
7124       i_start = its
7125       i_end   = MIN(ite,ide-1)
7126       j_start = jts
7127       j_end   = MIN(jte,jde-1)
7128
7129 !  compute x (u) conditions for v, w, or scalar
7130
7131    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
7132
7133        DO j = j_start, j_end
7134        DO k = kts, ktf
7135          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
7136          tendency(its,k,j) = tendency(its,k,j)                     &
7137                - rdx*(                                             &
7138                        ub*(   field_old(its+1,k,j)                 &
7139                             - field_old(its  ,k,j)   ) +           &
7140                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
7141                                                                 )
7142        ENDDO
7143        ENDDO
7144
7145    ENDIF
7146
7147    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
7148
7149        DO j = j_start, j_end
7150        DO k = kts, ktf
7151          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
7152          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
7153                - rdx*(                                               &
7154                        ub*(  field_old(i_end  ,k,j)                  &
7155                            - field_old(i_end-1,k,j) ) +              &
7156                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
7157                                                                     )
7158        ENDDO
7159        ENDDO
7160
7161    ENDIF
7162
7163    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
7164
7165        DO i = i_start, i_end
7166        DO k = kts, ktf
7167          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
7168          tendency(i,k,jts) = tendency(i,k,jts)                     &
7169                - rdy*(                                             &
7170                        vb*(  field_old(i,k,jts+1)                  &
7171                            - field_old(i,k,jts  ) ) +              &
7172                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
7173                                                                 )
7174        ENDDO
7175        ENDDO
7176
7177    ENDIF
7178
7179    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
7180
7181        DO i = i_start, i_end
7182        DO k = kts, ktf
7183          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
7184          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
7185                - rdy*(                                               &
7186                        vb*(   field_old(i,k,j_end  )                 &
7187                             - field_old(i,k,j_end-1) ) +             &
7188                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
7189                                                                     )
7190        ENDDO
7191        ENDDO
7192
7193    ENDIF
7194
7195    IF( (config_flags%polar) .and. (jts == jds) ) THEN
7196
7197        ! Assuming rv(i,k,jds) = 0.
7198        DO i = i_start, i_end
7199        DO k = kts, ktf
7200          vb = MIN( 0.5*rv(i,k,jts+1), 0. )
7201          tendency(i,k,jts) = tendency(i,k,jts)                     &
7202                - rdy*(                                             &
7203                        vb*(  field_old(i,k,jts+1)                  &
7204                            - field_old(i,k,jts  ) ) +              &
7205                        field(i,k,jts)*rv(i,k,jts+1)                &
7206                                                                 )
7207        ENDDO
7208        ENDDO
7209
7210    ENDIF
7211
7212    IF( (config_flags%polar) .and. (jte == jde)) THEN
7213
7214        ! Assuming rv(i,k,jde) = 0.
7215        DO i = i_start, i_end
7216        DO k = kts, ktf
7217          vb = MAX( 0.5*rv(i,k,jte-1), 0. )
7218          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
7219                - rdy*(                                               &
7220                        vb*(   field_old(i,k,j_end  )                 &
7221                             - field_old(i,k,j_end-1) ) +             &
7222                        field(i,k,j_end)*(-rv(i,k,jte-1))             &
7223                                                                     )
7224        ENDDO
7225        ENDDO
7226
7227    ENDIF
7228
7229 !-------------------- vertical advection
7230
7231 !-- loop bounds for periodic or sym conditions
7232
7233       i_start = its-1
7234       i_end   = MIN(ite,ide-1)+1
7235       j_start = jts-1
7236       j_end   = MIN(jte,jde-1)+1
7237
7238 !-- loop bounds for open or specified conditions
7239
7240     IF(degrade_xs) i_start = MAX(its-1,ids)
7241     IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
7242     IF(degrade_ys) j_start = MAX(jts-1,jds)
7243     IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
7244
7245     vert_order_test : IF (vert_order == 6) THEN
7246
7247       DO j = j_start, j_end
7248
7249          DO i = i_start, i_end
7250            fqz(i,1,j)  = 0.
7251            fqzl(i,1,j) = 0.
7252            fqz(i,kde,j)  = 0.
7253            fqzl(i,kde,j) = 0.
7254          ENDDO
7255
7256          DO k=kts+3,ktf-2
7257          DO i = i_start, i_end
7258            dz = 2./(rdzw(k)+rdzw(k-1))
7259            mu = 0.5*(mut(i,j)+mut(i,j))
7260            vel = rom(i,k,j)
7261            cr = vel*dt/dz/mu
7262            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7263
7264            fqz(i,k,j) = vel*flux6( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
7265                                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
7266            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7267          ENDDO
7268          ENDDO
7269
7270          DO i = i_start, i_end
7271
7272            k=kts+1
7273            dz = 2./(rdzw(k)+rdzw(k-1))
7274            mu = 0.5*(mut(i,j)+mut(i,j))
7275            vel = rom(i,k,j)
7276            cr = vel*dt/dz/mu
7277            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7278            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7279            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7280
7281            k=kts+2
7282            dz = 2./(rdzw(k)+rdzw(k-1))
7283            mu = 0.5*(mut(i,j)+mut(i,j))
7284            vel = rom(i,k,j)
7285            cr = vel*dt/dz/mu
7286            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7287
7288            fqz(i,k,j) = vel*flux4(                      &
7289                    field(i,k-2,j), field(i,k-1,j),      &
7290                    field(i,k  ,j), field(i,k+1,j),  -vel )
7291            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7292
7293            k=ktf-1
7294            dz = 2./(rdzw(k)+rdzw(k-1))
7295            mu = 0.5*(mut(i,j)+mut(i,j))
7296            vel = rom(i,k,j)
7297            cr = vel*dt/dz/mu
7298            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7299
7300            fqz(i,k,j) = vel*flux4(                      &
7301                    field(i,k-2,j), field(i,k-1,j),      &
7302                    field(i,k  ,j), field(i,k+1,j),  -vel )
7303            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7304
7305            k=ktf
7306            dz = 2./(rdzw(k)+rdzw(k-1))
7307            mu = 0.5*(mut(i,j)+mut(i,j))
7308            vel = rom(i,k,j)
7309            cr = vel*dt/dz/mu
7310            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7311            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7312            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7313
7314          ENDDO
7315
7316       ENDDO
7317
7318     ELSE IF (vert_order == 5) THEN
7319
7320       DO j = j_start, j_end
7321
7322          DO i = i_start, i_end
7323            fqz(i,1,j)  = 0.
7324            fqzl(i,1,j) = 0.
7325            fqz(i,kde,j)  = 0.
7326            fqzl(i,kde,j) = 0.
7327          ENDDO
7328
7329          DO k=kts+3,ktf-2
7330          DO i = i_start, i_end
7331            dz = 2./(rdzw(k)+rdzw(k-1))
7332            mu = 0.5*(mut(i,j)+mut(i,j))
7333            vel = rom(i,k,j)
7334            cr = vel*dt/dz/mu
7335            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7336
7337            fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
7338                                    field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
7339            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7340          ENDDO
7341          ENDDO
7342
7343          DO i = i_start, i_end
7344
7345            k=kts+1
7346            dz = 2./(rdzw(k)+rdzw(k-1))
7347            mu = 0.5*(mut(i,j)+mut(i,j))
7348            vel = rom(i,k,j)
7349            cr = vel*dt/dz/mu
7350            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7351            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7352            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7353
7354            k=kts+2
7355            dz = 2./(rdzw(k)+rdzw(k-1))
7356            mu = 0.5*(mut(i,j)+mut(i,j))
7357            vel = rom(i,k,j)
7358            cr = vel*dt/dz/mu
7359            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7360
7361            fqz(i,k,j) = vel*flux3(                      &
7362                    field(i,k-2,j), field(i,k-1,j),      &
7363                    field(i,k  ,j), field(i,k+1,j),  -vel )
7364            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7365
7366            k=ktf-1
7367            dz = 2./(rdzw(k)+rdzw(k-1))
7368            mu = 0.5*(mut(i,j)+mut(i,j))
7369            vel = rom(i,k,j)
7370            cr = vel*dt/dz/mu
7371            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7372
7373            fqz(i,k,j) = vel*flux3(                      &
7374                    field(i,k-2,j), field(i,k-1,j),      &
7375                    field(i,k  ,j), field(i,k+1,j),  -vel )
7376            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7377
7378            k=ktf
7379            dz = 2./(rdzw(k)+rdzw(k-1))
7380            mu = 0.5*(mut(i,j)+mut(i,j))
7381            vel = rom(i,k,j)
7382            cr = vel*dt/dz/mu
7383            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7384            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7385            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7386
7387          ENDDO
7388
7389       ENDDO
7390
7391     ELSE IF (vert_order == 4) THEN
7392
7393       DO j = j_start, j_end
7394
7395          DO i = i_start, i_end
7396            fqz(i,1,j)  = 0.
7397            fqzl(i,1,j) = 0.
7398            fqz(i,kde,j)  = 0.
7399            fqzl(i,kde,j) = 0.
7400          ENDDO
7401
7402          DO k=kts+2,ktf-1
7403          DO i = i_start, i_end
7404
7405            dz = 2./(rdzw(k)+rdzw(k-1))
7406            mu = 0.5*(mut(i,j)+mut(i,j))
7407            vel = rom(i,k,j)
7408            cr = vel*dt/dz/mu
7409            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7410
7411            fqz(i,k,j) = vel*flux4(                      &
7412                    field(i,k-2,j), field(i,k-1,j),      &
7413                    field(i,k  ,j), field(i,k+1,j),  -vel )
7414            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7415          ENDDO
7416          ENDDO
7417
7418          DO i = i_start, i_end
7419
7420            k=kts+1
7421            dz = 2./(rdzw(k)+rdzw(k-1))
7422            mu = 0.5*(mut(i,j)+mut(i,j))
7423            vel = rom(i,k,j)
7424            cr = vel*dt/dz/mu
7425            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7426            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7427            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7428
7429            k=ktf
7430            dz = 2./(rdzw(k)+rdzw(k-1))
7431            mu = 0.5*(mut(i,j)+mut(i,j))
7432            vel = rom(i,k,j)
7433            cr = vel*dt/dz/mu
7434            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7435            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7436            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7437
7438          ENDDO
7439
7440       ENDDO
7441
7442     ELSE IF (vert_order == 3) THEN
7443
7444       DO j = j_start, j_end
7445
7446          DO i = i_start, i_end
7447            fqz(i,1,j)  = 0.
7448            fqzl(i,1,j) = 0.
7449            fqz(i,kde,j)  = 0.
7450            fqzl(i,kde,j) = 0.
7451          ENDDO
7452
7453          DO k=kts+2,ktf-1
7454          DO i = i_start, i_end
7455
7456            dz = 2./(rdzw(k)+rdzw(k-1))
7457            mu = 0.5*(mut(i,j)+mut(i,j))
7458            vel = rom(i,k,j)
7459            cr = vel*dt/dz/mu
7460            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7461
7462            fqz(i,k,j) = vel*flux3(                      &
7463                    field(i,k-2,j), field(i,k-1,j),      &
7464                    field(i,k  ,j), field(i,k+1,j),  -vel )
7465            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7466          ENDDO
7467          ENDDO
7468
7469          DO i = i_start, i_end
7470
7471            k=kts+1
7472            dz = 2./(rdzw(k)+rdzw(k-1))
7473            mu = 0.5*(mut(i,j)+mut(i,j))
7474            vel = rom(i,k,j)
7475            cr = vel*dt/dz/mu
7476            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7477            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7478            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7479
7480            k=ktf
7481            dz = 2./(rdzw(k)+rdzw(k-1))
7482            mu = 0.5*(mut(i,j)+mut(i,j))
7483            vel = rom(i,k,j)
7484            cr = vel*dt/dz/mu
7485            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7486            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7487            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7488
7489          ENDDO
7490
7491       ENDDO
7492
7493    ELSE IF (vert_order == 2) THEN
7494
7495       DO j = j_start, j_end
7496
7497          DO i = i_start, i_end
7498            fqz(i,1,j)  = 0.
7499            fqzl(i,1,j) = 0.
7500            fqz(i,kde,j)  = 0.
7501            fqzl(i,kde,j) = 0.
7502          ENDDO
7503
7504          DO k=kts+1,ktf
7505          DO i = i_start, i_end
7506
7507            dz = 2./(rdzw(k)+rdzw(k-1))
7508            mu = 0.5*(mut(i,j)+mut(i,j))
7509            vel = rom(i,k,j)
7510            cr = vel*dt/dz/mu
7511            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
7512            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
7513            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
7514
7515         ENDDO
7516         ENDDO
7517
7518       ENDDO
7519
7520    ELSE
7521
7522       WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order
7523       CALL wrf_error_fatal ( wrf_err_message )
7524
7525    ENDIF vert_order_test
7526
7527    IF (pd_limit) THEN
7528
7529 ! positive definite filter
7530
7531    i_start = its-1
7532    i_end   = MIN(ite,ide-1)+1
7533    j_start = jts-1
7534    j_end   = MIN(jte,jde-1)+1
7535
7536 !-- loop bounds for open or specified conditions
7537
7538    IF(degrade_xs) i_start = MAX(its-1,ids)
7539    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
7540    IF(degrade_ys) j_start = MAX(jts-1,jds)
7541    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
7542
7543    IF(config_flags%specified .or. config_flags%nested) THEN
7544      IF (degrade_xs) i_start = MAX(its-1,ids+1)
7545      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
7546      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
7547      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
7548    END IF
7549
7550    IF(config_flags%open_xs) THEN
7551      IF (degrade_xs) i_start = MAX(its-1,ids+1)
7552    END IF
7553    IF(config_flags%open_xe) THEN
7554      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
7555    END IF
7556    IF(config_flags%open_ys) THEN
7557      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
7558    END IF
7559    IF(config_flags%open_ye) THEN
7560      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
7561    END IF
7562    ! ADT note:
7563    ! We don't want to change j_start and j_end
7564    ! for polar BC's since we want to calculate
7565    ! fluxes for directions other than y at the
7566    ! edge
7567
7568 !-- here is the limiter...
7569
7570    DO j=j_start, j_end
7571    DO k=kts, ktf
7572    DO i=i_start, i_end
7573
7574      ph_low = (mub(i,j)+mu_old(i,j))*field_old(i,k,j)        &
7575                 - dt*( msftx(i,j)*msfty(i,j)*(               &
7576                        rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
7577                        rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
7578                       +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
7579
7580      flux_out = dt*( (msftx(i,j)*msfty(i,j))*(                    &
7581                                 rdx*(  max(0.,fqx (i+1,k,j))      &
7582                                       -min(0.,fqx (i  ,k,j)) )    &
7583                                +rdy*(  max(0.,fqy (i,k,j+1))      &
7584                                       -min(0.,fqy (i,k,j  )) ) )  &
7585                 +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
7586                                       -max(0.,fqz (i,k  ,j)) )   )
7587
7588      IF( flux_out .gt. ph_low ) THEN
7589
7590        scale = max(0.,ph_low/(flux_out+eps))
7591        IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j)
7592        IF( fqx (i  ,k,j) .lt. 0.) fqx(i  ,k,j) = scale*fqx(i  ,k,j)
7593        IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1)
7594        IF( fqy (i,k,j  ) .lt. 0.) fqy(i,k,j  ) = scale*fqy(i,k,j  )
7595 !  note: z flux is opposite sign in mass coordinate because
7596 !  vertical coordinate decreases with increasing k
7597        IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j)
7598        IF( fqz (i,k  ,j) .gt. 0.) fqz(i,k  ,j) = scale*fqz(i,k  ,j)
7599
7600      END IF
7601
7602    ENDDO
7603    ENDDO
7604    ENDDO
7605
7606    END IF
7607
7608 ! add in the pd-limited flux divergence
7609
7610   i_start = its
7611   i_end   = MIN(ite,ide-1)
7612   j_start = jts
7613   j_end   = MIN(jte,jde-1)
7614
7615   DO j = j_start, j_end
7616   DO k = kts, ktf
7617   DO i = i_start, i_end
7618
7619      tendency (i,k,j) = tendency(i,k,j)                           &
7620                             -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
7621                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
7622
7623   ENDDO
7624   ENDDO
7625   ENDDO
7626
7627   IF(tenddec) THEN
7628   DO j = j_start, j_end
7629   DO k = kts, ktf
7630   DO i = i_start, i_end
7631
7632      z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
7633                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
7634
7635   ENDDO
7636   ENDDO
7637   ENDDO
7638   END IF
7639
7640 ! x flux divergence
7641 !
7642   IF(degrade_xs) i_start = MAX(its,ids+1)
7643   IF(degrade_xe) i_end   = MIN(ite,ide-2)
7644
7645   DO j = j_start, j_end
7646   DO k = kts, ktf
7647   DO i = i_start, i_end
7648
7649      ! Un-"canceled" map scale factor, ADT Eq. 48
7650      tendency (i,k,j) = tendency(i,k,j)                           &
7651                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
7652                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
7653
7654   ENDDO
7655   ENDDO
7656   ENDDO
7657
7658   IF(tenddec) THEN
7659   DO j = j_start, j_end
7660   DO k = kts, ktf
7661   DO i = i_start, i_end
7662
7663      h_tendency (i,k,j) = 0.                                      &
7664                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
7665                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
7666
7667   ENDDO
7668   ENDDO
7669   ENDDO
7670   END IF
7671
7672 ! y flux divergence
7673 !
7674   i_start = its
7675   i_end   = MIN(ite,ide-1)
7676   IF(degrade_ys) j_start = MAX(jts,jds+1)
7677   IF(degrade_ye) j_end   = MIN(jte,jde-2)
7678
7679   DO j = j_start, j_end
7680   DO k = kts, ktf
7681   DO i = i_start, i_end
7682
7683      ! Un-"canceled" map scale factor, ADT Eq. 48
7684      ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
7685      tendency (i,k,j) = tendency(i,k,j)                           &
7686                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
7687                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
7688
7689   ENDDO
7690   ENDDO
7691   ENDDO
7692
7693   IF(tenddec) THEN
7694   DO j = j_start, j_end
7695   DO k = kts, ktf
7696   DO i = i_start, i_end
7697
7698      h_tendency (i,k,j) = h_tendency (i,k,j)                      &
7699                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
7700                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
7701
7702   ENDDO
7703   ENDDO
7704   ENDDO
7705   END IF
7706
7707 END SUBROUTINE advect_scalar_pd
7708
7709 !----------------------------------------------------------------
7710
7711 SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency,    &
7712                                 ru, rv, rom,                   &
7713                                 mut, mub, mu_old,              &
7714                                 time_step, config_flags,       &
7715                                 msfux, msfuy, msfvx, msfvy,    &
7716                                 msftx, msfty,                  &
7717                                 fzm, fzp,                      &
7718                                 rdx, rdy, rdzw, dt,            &
7719                                 ids, ide, jds, jde, kds, kde,  &
7720                                 ims, ime, jms, jme, kms, kme,  &
7721                                 its, ite, jts, jte, kts, kte  )
7722
7723 !  this is a first cut at a positive definite advection option
7724 !  for scalars in WRF.  This version is memory intensive ->
7725 !  we save 3d arrays of x, y and z both high and low order fluxes
7726 !  (six in all).  Alternatively, we could sweep in a direction
7727 !  and lower the cost considerably.
7728
7729 !  uses the Smolarkiewicz MWR 1989 approach, with addition of first-order
7730 !  fluxes initially
7731
7732 !  WCS, 3 December 2002, 24 February 2003
7733
7734 !
7735 ! ERM Dec. 2011: replaced 5th-order fluxes with 5th-order WENO (Weighted
7736 ! Essentially Non-Oscillatory) scheme
7737 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
7738 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;
7739 !
7740
7741    IMPLICIT NONE
7742
7743    ! Input data
7744
7745    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
7746
7747    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
7748                                               ims, ime, jms, jme, kms, kme, &
7749                                               its, ite, jts, jte, kts, kte
7750
7751    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
7752                                                                       field_old, &
7753                                                                       ru,    &
7754                                                                       rv,    &
7755                                                                       rom
7756
7757    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut, mub, mu_old
7758    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
7759
7760    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
7761                                                                     msfuy,  &
7762                                                                     msfvx,  &
7763                                                                     msfvy,  &
7764                                                                     msftx,  &
7765                                                                     msfty
7766
7767    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
7768                                                                   fzp,  &
7769                                                                   rdzw
7770
7771    REAL ,                                        INTENT(IN   ) :: rdx,  &
7772                                                                   rdy,  &
7773                                                                   dt
7774    INTEGER ,                                     INTENT(IN   ) :: time_step
7775
7776    ! Local data
7777
7778    INTEGER :: i, j, k, itf, jtf, ktf
7779    INTEGER :: i_start, i_end, j_start, j_end
7780    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
7781    INTEGER :: jmin, jmax, jp, jm, imin, imax
7782
7783    REAL    :: mrdx, mrdy, ub, vb, uw, vw, mu
7784
7785 !  storage for high and low order fluxes
7786
7787    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqx, fqy, fqz
7788    REAL,  DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2  ) :: fqxl, fqyl, fqzl
7789
7790    INTEGER :: horz_order, vert_order
7791
7792    LOGICAL :: degrade_xs, degrade_ys
7793    LOGICAL :: degrade_xe, degrade_ye
7794
7795    INTEGER :: jp1, jp0, jtmp
7796
7797    REAL :: flux_out, ph_low, scale
7798    REAL, PARAMETER :: eps=1.e-20
7799
7800     real            :: dir, vv
7801     real            :: ue,vs,vn,wb,wt
7802     real, parameter :: f30 =  7./12., f31 = 1./12.
7803     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
7804
7805     real               :: qim2, qim1, qi, qip1, qip2
7806     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
7807     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps1=1.0d-18
7808     integer, parameter :: pw = 2
7809
7810
7811 ! definition of flux operators, 3rd, 4th, 5th or 6th order
7812
7813    REAL    :: flux3, flux4, flux5, flux6, flux_upwind
7814    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
7815
7816       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
7817             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
7818
7819       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
7820            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
7821            sign(1,time_step)*sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
7822
7823       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
7824             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
7825             +(1./60.)*(q_ip2+q_im3)
7826
7827       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
7828            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
7829             -sign(1,time_step)*sign(1.,ua)*(1./60.)*(           &
7830               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
7831
7832       flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 &
7833                                     +0.5*max(-1.0,(cr-abs(cr)))*q_i
7834
7835 !      flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
7836 !                                    +0.5*(1.-sign(1.,cr))*q_i
7837 !      flux_upwind(q_im1, q_i, cr ) = 0.
7838
7839     REAL     :: dx,dy,dz
7840
7841     LOGICAL, PARAMETER :: pd_limit = .true.
7842
7843 ! set order for the advection schemes
7844
7845 !  write(6,*) ' in pd advection routine '
7846
7847     ! Empty arrays just in case:
7848     IF (config_flags%polar) THEN
7849        fqx(:,:,:)  = 0.
7850        fqy(:,:,:)  = 0.
7851        fqz(:,:,:)  = 0.
7852        fqxl(:,:,:) = 0.
7853        fqyl(:,:,:) = 0.
7854        fqzl(:,:,:) = 0.
7855     END IF
7856
7857   ktf=MIN(kte,kde-1)
7858   horz_order = config_flags%h_sca_adv_order
7859   vert_order = config_flags%v_sca_adv_order
7860
7861 !  determine boundary mods for flux operators
7862 !  We degrade the flux operators from 3rd/4th order
7863 !   to second order one gridpoint in from the boundaries for
7864 !   all boundary conditions except periodic and symmetry - these
7865 !   conditions have boundary zone data fill for correct application
7866 !   of the higher order flux stencils
7867
7868    degrade_xs = .true.
7869    degrade_xe = .true.
7870    degrade_ys = .true.
7871    degrade_ye = .true.
7872
7873 !  begin with horizontal flux divergence
7874 !  here is the choice of flux operators
7875
7876
7877 !  horizontal_order_test : IF( horz_order == 6 ) THEN
7878
7879 !    ELSE IF( horz_order == 5 ) THEN
7880
7881    IF( config_flags%periodic_x   .or. &
7882        config_flags%symmetric_xs .or. &
7883        (its > ids+3)                ) degrade_xs = .false.
7884    IF( config_flags%periodic_x   .or. &
7885        config_flags%symmetric_xe .or. &
7886        (ite < ide-4)                ) degrade_xe = .false.
7887    IF( config_flags%periodic_y   .or. &
7888        config_flags%symmetric_ys .or. &
7889        (jts > jds+3)                ) degrade_ys = .false.
7890    IF( config_flags%periodic_y   .or. &
7891        config_flags%symmetric_ye .or. &
7892        (jte < jde-4)                ) degrade_ye = .false.
7893
7894 !--------------- y - advection first
7895
7896 !--  y flux compute; these bounds are for periodic and sym b.c.
7897
7898       ktf=MIN(kte,kde-1)
7899       i_start = its-1
7900       i_end   = MIN(ite,ide-1)+1
7901       j_start = jts-1
7902       j_end   = MIN(jte,jde-1)+1
7903       j_start_f = j_start
7904       j_end_f   = j_end+1
7905
7906 !--  modify loop bounds if open or specified
7907
7908 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
7909 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
7910       IF(degrade_xs) i_start = MAX(its-1,ids)
7911       IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
7912
7913       IF(degrade_ys) then
7914         j_start = MAX(jts-1,jds+1)
7915         j_start_f = jds+3
7916       ENDIF
7917
7918       IF(degrade_ye) then
7919         j_end = MIN(jte+1,jde-2)
7920         j_end_f = jde-3
7921       ENDIF
7922
7923 !  compute fluxes, 5th order
7924
7925       j_loop_y_flux_5 : DO j = j_start, j_end+1
7926
7927       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
7928
7929         DO k=kts,ktf
7930         DO i = i_start, i_end
7931
7932           dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
7933           mu = 0.5*(mut(i,j)+mut(i,j-1))
7934           vel = rv(i,k,j)
7935           cr = vel*dt/dy/mu
7936           fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
7937
7938          IF ( vel .ge. 0.0 ) THEN
7939             qip2 = field(i,k,j+1)
7940             qip1 = field(i,k,j  )
7941             qi   = field(i,k,j-1)
7942             qim1 = field(i,k,j-2)
7943             qim2 = field(i,k,j-3)
7944           ELSE
7945             qip2 = field(i,k,j-2)
7946             qip1 = field(i,k,j-1)
7947             qi   = field(i,k,j  )
7948             qim1 = field(i,k,j+1)
7949             qim2 = field(i,k,j+2)
7950          ENDIF
7951
7952          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
7953          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
7954          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
7955
7956          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
7957          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
7958          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
7959
7960          wi0 = gi0 / (eps1 + beta0)**pw
7961          wi1 = gi1 / (eps1 + beta1)**pw
7962          wi2 = gi2 / (eps1 + beta2)**pw
7963
7964          sumwk = wi0 + wi1 + wi2
7965
7966           fqy( i, k, j ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
7967
7968 !          fqy( i, k, j  ) = vel*flux5(                                  &
7969 !                  field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
7970 !                  field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
7971
7972           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7973
7974         ENDDO
7975         ENDDO
7976
7977       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
7978
7979             DO k=kts,ktf
7980             DO i = i_start, i_end
7981
7982               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
7983               mu = 0.5*(mut(i,j)+mut(i,j-1))
7984               vel = rv(i,k,j)
7985               cr = vel*dt/dy/mu
7986               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
7987
7988               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
7989                      (field(i,k,j)+field(i,k,j-1))
7990
7991               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7992
7993             ENDDO
7994             ENDDO
7995
7996       ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
7997
7998             DO k=kts,ktf
7999             DO i = i_start, i_end
8000
8001               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
8002               mu = 0.5*(mut(i,j)+mut(i,j-1))
8003               vel = rv(i,k,j)
8004               cr = vel*dt/dy/mu
8005               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8006
8007               fqy( i, k, j ) = vel*flux3(              &
8008                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
8009               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8010
8011             ENDDO
8012             ENDDO
8013
8014       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
8015
8016             DO k=kts,ktf
8017             DO i = i_start, i_end
8018
8019               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
8020               mu = 0.5*(mut(i,j)+mut(i,j-1))
8021               vel = rv(i,k,j)
8022               cr = vel*dt/dy/mu
8023               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8024
8025               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
8026                      (field(i,k,j)+field(i,k,j-1))
8027               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8028
8029             ENDDO
8030             ENDDO
8031
8032       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
8033
8034             DO k=kts,ktf
8035             DO i = i_start, i_end
8036
8037               dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
8038               mu = 0.5*(mut(i,j)+mut(i,j-1))
8039               vel = rv(i,k,j)
8040               cr = vel*dt/dy/mu
8041               fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8042
8043               fqy( i, k, j) = vel*flux3(             &
8044                    field(i,k,j-2),field(i,k,j-1),    &
8045                    field(i,k,j),field(i,k,j+1),vel )
8046               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8047
8048             ENDDO
8049             ENDDO
8050
8051       ENDIF
8052
8053    ENDDO j_loop_y_flux_5
8054
8055 !  next, x flux
8056
8057 !--  these bounds are for periodic and sym conditions
8058
8059       i_start = its-1
8060       i_end   = MIN(ite,ide-1)+1
8061       i_start_f = i_start
8062       i_end_f   = i_end+1
8063
8064       j_start = jts-1
8065       j_end   = MIN(jte,jde-1)+1
8066
8067 !--  modify loop bounds for open and specified b.c
8068
8069 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
8070 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
8071       IF(degrade_ys) j_start = MAX(jts-1,jds)
8072       IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
8073
8074       IF(degrade_xs) then
8075         i_start = MAX(ids+1,its-1)
8076         i_start_f = ids+3
8077       ENDIF
8078
8079       IF(degrade_xe) then
8080         i_end = MIN(ide-2,ite+1)
8081         i_end_f = ide-3
8082       ENDIF
8083
8084 !  compute fluxes
8085
8086       DO j = j_start, j_end
8087
8088 !  5th order flux
8089
8090         DO k=kts,ktf
8091         DO i = i_start_f, i_end_f
8092
8093           dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
8094           mu = 0.5*(mut(i,j)+mut(i-1,j))
8095           vel = ru(i,k,j)
8096           cr = vel*dt/dx/mu
8097           fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8098
8099
8100          IF ( vel .ge. 0.0 ) THEN
8101             qip2 = field(i+1,k,j)
8102             qip1 = field(i,  k,j)
8103             qi   = field(i-1,k,j)
8104             qim1 = field(i-2,k,j)
8105             qim2 = field(i-3,k,j)
8106           ELSE
8107             qip2 = field(i-2,k,j)
8108             qip1 = field(i-1,k,j)
8109             qi   = field(i,  k,j)
8110             qim1 = field(i+1,k,j)
8111             qim2 = field(i+2,k,j)
8112          ENDIF
8113
8114          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8115          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8116          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8117
8118          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8119          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8120          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8121
8122          wi0 = gi0 / (eps1 + beta0)**pw
8123          wi1 = gi1 / (eps1 + beta1)**pw
8124          wi2 = gi2 / (eps1 + beta2)**pw
8125
8126          sumwk = wi0 + wi1 + wi2
8127
8128          fqx(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8129
8130 !          fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
8131 !                                         field(i-1,k,j), field(i  ,k,j),  &
8132 !                                         field(i+1,k,j), field(i+2,k,j),  &
8133 !                                         vel                             )
8134           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
8135
8136         ENDDO
8137         ENDDO
8138
8139 !  lower order fluxes close to boundaries (if not periodic or symmetric)
8140
8141         IF( degrade_xs ) THEN
8142
8143           DO i=i_start,i_start_f-1
8144
8145             IF(i == ids+1) THEN ! second order
8146               DO k=kts,ktf
8147                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
8148                 mu = 0.5*(mut(i,j)+mut(i-1,j))
8149                 vel = ru(i,k,j)/mu
8150                 cr = vel*dt/dx
8151                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8152                 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
8153                        *(field(i,k,j)+field(i-1,k,j))
8154                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
8155               ENDDO
8156             ENDIF
8157
8158             IF(i == ids+2) THEN  ! third order
8159               DO k=kts,ktf
8160                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
8161                 mu = 0.5*(mut(i,j)+mut(i-1,j))
8162                 vel = ru(i,k,j)
8163                 cr = vel*dt/dx/mu
8164                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8165                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
8166                                           field(i  ,k,j), field(i+1,k,j),  &
8167                                           vel                             )
8168                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
8169               ENDDO
8170             ENDIF
8171
8172           ENDDO
8173
8174         ENDIF
8175
8176         IF( degrade_xe ) THEN
8177
8178           DO i = i_end_f+1, i_end+1
8179
8180             IF( i == ide-1 ) THEN ! second order flux next to the boundary
8181               DO k=kts,ktf
8182                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
8183                 mu = 0.5*(mut(i,j)+mut(i-1,j))
8184                 vel = ru(i,k,j)
8185                 cr = vel*dt/dx/mu
8186                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8187                 fqx(i,k,j) = 0.5*(ru(i,k,j))      &
8188                        *(field(i,k,j)+field(i-1,k,j))
8189                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
8190               ENDDO
8191             ENDIF
8192
8193
8194             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
8195               DO k=kts,ktf
8196                 dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
8197                 mu = 0.5*(mut(i,j)+mut(i-1,j))
8198                 vel = ru(i,k,j)
8199                 cr = vel*dt/dx/mu
8200                 fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8201                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
8202                                           field(i  ,k,j), field(i+1,k,j),  &
8203                                           vel                             )
8204                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
8205               ENDDO
8206             ENDIF
8207
8208           ENDDO
8209
8210         ENDIF
8211
8212       ENDDO  ! enddo for outer J loop
8213
8214 !--- end of 5th order horizontal flux calculation
8215
8216 !   ELSE
8217
8218 !      WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order
8219 !      CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
8220
8221 !   ENDIF horizontal_order_test
8222
8223 !  pick up the rest of the horizontal radiation boundary conditions.
8224 !  (these are the computations that don't require 'cb'.
8225 !  first, set to index ranges
8226
8227       i_start = its
8228       i_end   = MIN(ite,ide-1)
8229       j_start = jts
8230       j_end   = MIN(jte,jde-1)
8231
8232 !  compute x (u) conditions for v, w, or scalar
8233
8234    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
8235
8236        DO j = j_start, j_end
8237        DO k = kts, ktf
8238          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
8239          tendency(its,k,j) = tendency(its,k,j)                     &
8240                - rdx*(                                             &
8241                        ub*(   field_old(its+1,k,j)                 &
8242                             - field_old(its  ,k,j)   ) +           &
8243                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
8244                                                                 )
8245        ENDDO
8246        ENDDO
8247
8248    ENDIF
8249
8250    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
8251
8252        DO j = j_start, j_end
8253        DO k = kts, ktf
8254          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
8255          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
8256                - rdx*(                                               &
8257                        ub*(  field_old(i_end  ,k,j)                  &
8258                            - field_old(i_end-1,k,j) ) +              &
8259                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
8260                                                                     )
8261        ENDDO
8262        ENDDO
8263
8264    ENDIF
8265
8266    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
8267
8268        DO i = i_start, i_end
8269        DO k = kts, ktf
8270          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
8271          tendency(i,k,jts) = tendency(i,k,jts)                     &
8272                - rdy*(                                             &
8273                        vb*(  field_old(i,k,jts+1)                  &
8274                            - field_old(i,k,jts  ) ) +              &
8275                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
8276                                                                 )
8277        ENDDO
8278        ENDDO
8279
8280    ENDIF
8281
8282    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
8283
8284        DO i = i_start, i_end
8285        DO k = kts, ktf
8286          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
8287          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
8288                - rdy*(                                               &
8289                        vb*(   field_old(i,k,j_end  )                 &
8290                             - field_old(i,k,j_end-1) ) +             &
8291                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
8292                                                                     )
8293        ENDDO
8294        ENDDO
8295
8296    ENDIF
8297
8298    IF( (config_flags%polar) .and. (jts == jds) ) THEN
8299
8300        ! Assuming rv(i,k,jds) = 0.
8301        DO i = i_start, i_end
8302        DO k = kts, ktf
8303          vb = MIN( 0.5*rv(i,k,jts+1), 0. )
8304          tendency(i,k,jts) = tendency(i,k,jts)                     &
8305                - rdy*(                                             &
8306                        vb*(  field_old(i,k,jts+1)                  &
8307                            - field_old(i,k,jts  ) ) +              &
8308                        field(i,k,jts)*rv(i,k,jts+1)                &
8309                                                                 )
8310        ENDDO
8311        ENDDO
8312
8313    ENDIF
8314
8315    IF( (config_flags%polar) .and. (jte == jde)) THEN
8316
8317        ! Assuming rv(i,k,jde) = 0.
8318        DO i = i_start, i_end
8319        DO k = kts, ktf
8320          vb = MAX( 0.5*rv(i,k,jte-1), 0. )
8321          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
8322                - rdy*(                                               &
8323                        vb*(   field_old(i,k,j_end  )                 &
8324                             - field_old(i,k,j_end-1) ) +             &
8325                        field(i,k,j_end)*(-rv(i,k,jte-1))             &
8326                                                                     )
8327        ENDDO
8328        ENDDO
8329
8330    ENDIF
8331
8332 !-------------------- vertical advection
8333
8334 !-- loop bounds for periodic or sym conditions
8335
8336       i_start = its-1
8337       i_end   = MIN(ite,ide-1)+1
8338       j_start = jts-1
8339       j_end   = MIN(jte,jde-1)+1
8340
8341 !-- loop bounds for open or specified conditions
8342
8343     IF(degrade_xs) i_start = MAX(its-1,ids)
8344     IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
8345     IF(degrade_ys) j_start = MAX(jts-1,jds)
8346     IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
8347
8348 !    vert_order_test : IF (vert_order == 6) THEN
8349
8350
8351 !    ELSE IF (vert_order == 5) THEN
8352
8353       DO j = j_start, j_end
8354
8355          DO i = i_start, i_end
8356            fqz(i,1,j)  = 0.
8357            fqzl(i,1,j) = 0.
8358            fqz(i,kde,j)  = 0.
8359            fqzl(i,kde,j) = 0.
8360          ENDDO
8361
8362          DO k=kts+3,ktf-2
8363          DO i = i_start, i_end
8364            dz = 2./(rdzw(k)+rdzw(k-1))
8365            mu = 0.5*(mut(i,j)+mut(i,j))
8366            vel = rom(i,k,j)
8367            cr = vel*dt/dz/mu
8368            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
8369
8370
8371          IF( -vel .ge. 0.0 ) THEN
8372             qip2 = field(i,k+1,j)
8373             qip1 = field(i,k  ,j)
8374             qi   = field(i,k-1,j)
8375             qim1 = field(i,k-2,j)
8376             qim2 = field(i,k-3,j)
8377           ELSE
8378             qip2 = field(i,k-2,j)
8379             qip1 = field(i,k-1,j)
8380             qi   = field(i,k  ,j)
8381             qim1 = field(i,k+1,j)
8382             qim2 = field(i,k+2,j)
8383          ENDIF
8384
8385          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
8386          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
8387          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
8388
8389          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
8390          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
8391          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
8392
8393          wi0 = gi0 / (eps1 + beta0)**pw
8394          wi1 = gi1 / (eps1 + beta1)**pw
8395          wi2 = gi2 / (eps1 + beta2)**pw
8396
8397          sumwk = wi0 + wi1 + wi2
8398
8399           fqz(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
8400
8401 !           fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
8402 !                                   field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
8403            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
8404          ENDDO
8405          ENDDO
8406
8407          DO i = i_start, i_end
8408
8409            k=kts+1
8410            dz = 2./(rdzw(k)+rdzw(k-1))
8411            mu = 0.5*(mut(i,j)+mut(i,j))
8412            vel = rom(i,k,j)
8413            cr = vel*dt/dz/mu
8414            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
8415            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
8416            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
8417
8418            k=kts+2
8419            dz = 2./(rdzw(k)+rdzw(k-1))
8420            mu = 0.5*(mut(i,j)+mut(i,j))
8421            vel = rom(i,k,j)
8422            cr = vel*dt/dz/mu
8423            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
8424
8425            fqz(i,k,j) = vel*flux3(                      &
8426                    field(i,k-2,j), field(i,k-1,j),      &
8427                    field(i,k  ,j), field(i,k+1,j),  -vel )
8428            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
8429
8430            k=ktf-1
8431            dz = 2./(rdzw(k)+rdzw(k-1))
8432            mu = 0.5*(mut(i,j)+mut(i,j))
8433            vel = rom(i,k,j)
8434            cr = vel*dt/dz/mu
8435            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
8436
8437            fqz(i,k,j) = vel*flux3(                      &
8438                    field(i,k-2,j), field(i,k-1,j),      &
8439                    field(i,k  ,j), field(i,k+1,j),  -vel )
8440            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
8441
8442            k=ktf
8443            dz = 2./(rdzw(k)+rdzw(k-1))
8444            mu = 0.5*(mut(i,j)+mut(i,j))
8445            vel = rom(i,k,j)
8446            cr = vel*dt/dz/mu
8447            fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
8448            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
8449            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
8450
8451          ENDDO
8452
8453       ENDDO
8454
8455
8456 !   ELSE
8457
8458 !      WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order
8459 !      CALL wrf_error_fatal ( wrf_err_message )
8460
8461 !   ENDIF vert_order_test
8462
8463    IF (pd_limit) THEN
8464
8465 ! positive definite filter
8466
8467    i_start = its-1
8468    i_end   = MIN(ite,ide-1)+1
8469    j_start = jts-1
8470    j_end   = MIN(jte,jde-1)+1
8471
8472 !-- loop bounds for open or specified conditions
8473
8474    IF(degrade_xs) i_start = MAX(its-1,ids)
8475    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
8476    IF(degrade_ys) j_start = MAX(jts-1,jds)
8477    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
8478
8479    IF(config_flags%specified .or. config_flags%nested) THEN
8480      IF (degrade_xs) i_start = MAX(its-1,ids+1)
8481      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
8482      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
8483      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
8484    END IF
8485
8486    IF(config_flags%open_xs) THEN
8487      IF (degrade_xs) i_start = MAX(its-1,ids+1)
8488    END IF
8489    IF(config_flags%open_xe) THEN
8490      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
8491    END IF
8492    IF(config_flags%open_ys) THEN
8493      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
8494    END IF
8495    IF(config_flags%open_ye) THEN
8496      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
8497    END IF
8498    ! ADT note:
8499    ! We don't want to change j_start and j_end
8500    ! for polar BC's since we want to calculate
8501    ! fluxes for directions other than y at the
8502    ! edge
8503
8504 !-- here is the limiter...
8505
8506    DO j=j_start, j_end
8507    DO k=kts, ktf
8508    DO i=i_start, i_end
8509
8510      ph_low = (mub(i,j)+mu_old(i,j))*field_old(i,k,j)        &
8511                 - dt*( msftx(i,j)*msfty(i,j)*(               &
8512                        rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
8513                        rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
8514                       +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
8515
8516      flux_out = dt*( (msftx(i,j)*msfty(i,j))*(                    &
8517                                 rdx*(  max(0.,fqx (i+1,k,j))      &
8518                                       -min(0.,fqx (i  ,k,j)) )    &
8519                                +rdy*(  max(0.,fqy (i,k,j+1))      &
8520                                       -min(0.,fqy (i,k,j  )) ) )  &
8521                 +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
8522                                       -max(0.,fqz (i,k  ,j)) )   )
8523
8524      IF( flux_out .gt. ph_low ) THEN
8525
8526        scale = max(0.,ph_low/(flux_out+eps))
8527        IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j)
8528        IF( fqx (i  ,k,j) .lt. 0.) fqx(i  ,k,j) = scale*fqx(i  ,k,j)
8529        IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1)
8530        IF( fqy (i,k,j  ) .lt. 0.) fqy(i,k,j  ) = scale*fqy(i,k,j  )
8531 !  note: z flux is opposite sign in mass coordinate because
8532 !  vertical coordinate decreases with increasing k
8533        IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j)
8534        IF( fqz (i,k  ,j) .gt. 0.) fqz(i,k  ,j) = scale*fqz(i,k  ,j)
8535
8536      END IF
8537
8538    ENDDO
8539    ENDDO
8540    ENDDO
8541
8542    END IF
8543
8544 ! add in the pd-limited flux divergence
8545
8546   i_start = its
8547   i_end   = MIN(ite,ide-1)
8548   j_start = jts
8549   j_end   = MIN(jte,jde-1)
8550
8551   DO j = j_start, j_end
8552   DO k = kts, ktf
8553   DO i = i_start, i_end
8554
8555      tendency (i,k,j) = tendency(i,k,j)                           &
8556                             -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
8557                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
8558
8559   ENDDO
8560   ENDDO
8561   ENDDO
8562
8563 ! x flux divergence
8564 !
8565   IF(degrade_xs) i_start = MAX(its,ids+1)
8566   IF(degrade_xe) i_end   = MIN(ite,ide-2)
8567
8568   DO j = j_start, j_end
8569   DO k = kts, ktf
8570   DO i = i_start, i_end
8571
8572      ! Un-"canceled" map scale factor, ADT Eq. 48
8573      tendency (i,k,j) = tendency(i,k,j)                           &
8574                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
8575                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
8576
8577   ENDDO
8578   ENDDO
8579   ENDDO
8580
8581 ! y flux divergence
8582 !
8583   i_start = its
8584   i_end   = MIN(ite,ide-1)
8585   IF(degrade_ys) j_start = MAX(jts,jds+1)
8586   IF(degrade_ye) j_end   = MIN(jte,jde-2)
8587
8588   DO j = j_start, j_end
8589   DO k = kts, ktf
8590   DO i = i_start, i_end
8591
8592      ! Un-"canceled" map scale factor, ADT Eq. 48
8593      ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
8594      tendency (i,k,j) = tendency(i,k,j)                           &
8595                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
8596                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
8597
8598   ENDDO
8599   ENDDO
8600   ENDDO
8601
8602 END SUBROUTINE advect_scalar_wenopd
8603
8604 !----------------------------------------------------------------
8605
8606 SUBROUTINE advect_scalar_mono   ( field, field_old, tendency,    &
8607                                   h_tendency, z_tendency,        &
8608                                   ru, rv, rom,                   &
8609                                   mut, mub, mu_old,              &
8610                                   config_flags,                  &
8611                                   tenddec,                       &
8612                                   msfux, msfuy, msfvx, msfvy,    &
8613                                   msftx, msfty,                  &
8614                                   fzm, fzp,                      &
8615                                   rdx, rdy, rdzw, dt,            &
8616                                   ids, ide, jds, jde, kds, kde,  &
8617                                   ims, ime, jms, jme, kms, kme,  &
8618                                   its, ite, jts, jte, kts, kte  )
8619
8620 !  monotonic advection option
8621 !  for scalars in WRF RK3 advection.  This version is memory intensive ->
8622 !  we save 3d arrays of x, y and z both high and low order fluxes
8623 !  (six in all).  Alternatively, we could sweep in a direction
8624 !  and lower the cost considerably.
8625
8626 !  uses the Smolarkiewicz MWR 1989 approach, with addition of first-order
8627 !  fluxes initially
8628
8629    IMPLICIT NONE
8630
8631    ! Input data
8632
8633    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
8634
8635    LOGICAL ,                 INTENT(IN   ) :: tenddec ! tendency flag
8636
8637    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
8638                                               ims, ime, jms, jme, kms, kme, &
8639                                               its, ite, jts, jte, kts, kte
8640
8641    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
8642                                                                       field_old, &
8643                                                                       ru,    &
8644                                                                       rv,    &
8645                                                                       rom
8646
8647    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut, mub, mu_old
8648    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
8649    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(  OUT) :: h_tendency, z_tendency
8650
8651    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
8652                                                                     msfuy,  &
8653                                                                     msfvx,  &
8654                                                                     msfvy,  &
8655                                                                     msftx,  &
8656                                                                     msfty
8657
8658    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
8659                                                                   fzp,  &
8660                                                                   rdzw
8661
8662    REAL ,                                        INTENT(IN   ) :: rdx,  &
8663                                                                   rdy,  &
8664                                                                   dt
8665
8666    ! Local data
8667
8668    INTEGER :: i, j, k, itf, jtf, ktf
8669    INTEGER :: i_start, i_end, j_start, j_end
8670    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
8671    INTEGER :: jmin, jmax, jp, jm, imin, imax
8672
8673    REAL    :: mrdx, mrdy, ub, vb, uw, vw, mu
8674    REAL , DIMENSION(its:ite, kts:kte) :: vflux
8675
8676
8677 !  storage for high and low order fluxes
8678
8679    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: fqx, fqy, fqz
8680    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: fqxl, fqyl, fqzl
8681    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: qmin, qmax
8682    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: scale_in, scale_out
8683    REAL :: ph_upwind
8684
8685    INTEGER :: horz_order, vert_order
8686
8687    LOGICAL :: degrade_xs, degrade_ys
8688    LOGICAL :: degrade_xe, degrade_ye
8689
8690    INTEGER :: jp1, jp0, jtmp
8691
8692    REAL :: flux_out, ph_low, flux_in, ph_hi, scale
8693    REAL, PARAMETER :: eps=1.e-20
8694
8695
8696 ! definition of flux operators, 3rd, 4rth, 5th or 6th order
8697
8698    REAL    :: flux3, flux4, flux5, flux6, flux_upwind
8699    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
8700
8701       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
8702             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
8703
8704       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
8705            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
8706            sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
8707
8708       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
8709             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
8710             +(1./60.)*(q_ip2+q_im3)
8711
8712       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
8713            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
8714             -sign(1.,ua)*(1./60.)*(                             &
8715               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
8716
8717 !      flux_upwind(q_im1, q_i, cr ) = 0.
8718       flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
8719                                     +0.5*(1.-sign(1.,cr))*q_i
8720
8721     LOGICAL, PARAMETER :: mono_limit = .true.
8722
8723 ! set order for the advection schemes
8724
8725   ktf=MIN(kte,kde-1)
8726   horz_order = config_flags%h_sca_adv_order
8727   vert_order = config_flags%v_sca_adv_order
8728
8729   do j=jts-2,jte+2
8730   do k=kts,kte
8731   do i=its-2,ite+2
8732     qmin(i,k,j) = field_old(i,k,j)
8733     qmax(i,k,j) = field_old(i,k,j)
8734     scale_in(i,k,j) = 1.
8735     scale_out(i,k,j) = 1.
8736     fqx(i,k,j) = 0.
8737     fqy(i,k,j) = 0.
8738     fqz(i,k,j) = 0.
8739     fqxl(i,k,j) = 0.
8740     fqyl(i,k,j) = 0.
8741     fqzl(i,k,j) = 0.
8742   enddo
8743   enddo
8744   enddo
8745
8746 !  begin with horizontal flux divergence
8747 !  here is the choice of flux operators
8748
8749
8750   horizontal_order_test : IF( horz_order == 5 ) THEN
8751
8752 !  determine boundary mods for flux operators
8753 !  We degrade the flux operators from 3rd/4rth order
8754 !   to second order one gridpoint in from the boundaries for
8755 !   all boundary conditions except periodic and symmetry - these
8756 !   conditions have boundary zone data fill for correct application
8757 !   of the higher order flux stencils
8758
8759    degrade_xs = .true.
8760    degrade_xe = .true.
8761    degrade_ys = .true.
8762    degrade_ye = .true.
8763
8764    IF( config_flags%periodic_x   .or. &
8765        config_flags%symmetric_xs .or. &
8766        (its > ids+3)                ) degrade_xs = .false.
8767    IF( config_flags%periodic_x   .or. &
8768        config_flags%symmetric_xe .or. &
8769        (ite < ide-4)                ) degrade_xe = .false.
8770    IF( config_flags%periodic_y   .or. &
8771        config_flags%symmetric_ys .or. &
8772        (jts > jds+3)                ) degrade_ys = .false.
8773    IF( config_flags%periodic_y   .or. &
8774        config_flags%symmetric_ye .or. &
8775        (jte < jde-4)                ) degrade_ye = .false.
8776
8777 !--------------- y - advection first
8778
8779 !--  y flux compute; these bounds are for periodic and sym b.c.
8780
8781       ktf=MIN(kte,kde-1)
8782       i_start = its-1
8783       i_end   = MIN(ite,ide-1)+1
8784       j_start = jts-1
8785       j_end   = MIN(jte,jde-1)+1
8786       j_start_f = j_start
8787       j_end_f   = j_end+1
8788
8789 !--  modify loop bounds if open or specified
8790
8791 !  WCS 20090218
8792 !      IF(degrade_xs) i_start = its
8793 !      IF(degrade_xe) i_end   = MIN(ite,ide-1)
8794       IF(degrade_xs) i_start = MAX(its-1,ids)
8795       IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
8796
8797 !  WCS 20090218
8798 !      IF(degrade_ys) then
8799 !        j_start = MAX(jts,jds+1)
8800 !        j_start_f = jds+3
8801 !      ENDIF
8802 !
8803 !      IF(degrade_ye) then
8804 !        j_end = MIN(jte,jde-2)
8805 !        j_end_f = jde-3
8806 !      ENDIF
8807
8808       IF(degrade_ys) then
8809         j_start = MAX(jts-1,jds+1)
8810         j_start_f = jds+3
8811       ENDIF
8812
8813       IF(degrade_ye) then
8814         j_end = MIN(jte+1,jde-2)
8815         j_end_f = jde-3
8816       ENDIF
8817
8818 !  compute fluxes, 5th order
8819
8820       j_loop_y_flux_5 : DO j = j_start, j_end+1
8821
8822       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
8823
8824         DO k=kts,ktf
8825         DO i = i_start, i_end
8826
8827           vel = rv(i,k,j)
8828           cr = vel
8829           fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), vel)
8830
8831           fqy( i, k, j  ) = vel*flux5(                                  &
8832                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
8833                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
8834
8835           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8836
8837           if(cr.gt. 0) then
8838              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
8839              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
8840           else
8841              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
8842              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
8843           end if
8844
8845         ENDDO
8846         ENDDO
8847
8848       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
8849
8850             DO k=kts,ktf
8851             DO i = i_start, i_end
8852
8853               vel = rv(i,k,j)
8854               cr = vel
8855               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8856
8857               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
8858                      (field(i,k,j)+field(i,k,j-1))
8859
8860               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8861
8862           if(cr.gt. 0) then
8863              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
8864              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
8865           else
8866              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
8867              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
8868           end if
8869
8870             ENDDO
8871             ENDDO
8872
8873       ELSE IF  ( j == jds+2 ) THEN  ! third of 4rth order flux 2 in from south boundary
8874
8875             DO k=kts,ktf
8876             DO i = i_start, i_end
8877
8878               vel = rv(i,k,j)
8879               cr = vel
8880               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8881
8882               fqy( i, k, j ) = vel*flux3(              &
8883                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
8884               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8885
8886           if(cr.gt. 0) then
8887              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
8888              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
8889           else
8890              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
8891              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
8892           end if
8893
8894             ENDDO
8895             ENDDO
8896
8897       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
8898
8899             DO k=kts,ktf
8900             DO i = i_start, i_end
8901
8902               vel = rv(i,k,j)
8903               cr = vel
8904               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8905
8906               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
8907                      (field(i,k,j)+field(i,k,j-1))
8908               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8909
8910           if(cr.gt. 0) then
8911              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
8912              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
8913           else
8914              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
8915              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
8916           end if
8917
8918             ENDDO
8919             ENDDO
8920
8921       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4rth order flux 2 in from north boundary
8922
8923             DO k=kts,ktf
8924             DO i = i_start, i_end
8925
8926               vel = rv(i,k,j)
8927               cr = vel
8928               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8929
8930               fqy( i, k, j) = vel*flux3(             &
8931                    field(i,k,j-2),field(i,k,j-1),    &
8932                    field(i,k,j),field(i,k,j+1),vel )
8933               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8934
8935           if(cr.gt. 0) then
8936              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
8937              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
8938           else
8939              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
8940              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
8941           end if
8942
8943             ENDDO
8944             ENDDO
8945
8946       ENDIF
8947
8948    ENDDO j_loop_y_flux_5
8949
8950 !  next, x flux
8951
8952 !--  these bounds are for periodic and sym conditions
8953
8954       i_start = its-1
8955       i_end   = MIN(ite,ide-1)+1
8956       i_start_f = i_start
8957       i_end_f   = i_end+1
8958
8959       j_start = jts-1
8960       j_end   = MIN(jte,jde-1)+1
8961
8962 !--  modify loop bounds for open and specified b.c
8963
8964 !  WCS 20090218
8965 !      IF(degrade_ys) j_start = jts
8966 !      IF(degrade_ye) j_end   = MIN(jte,jde-1)
8967       IF(degrade_ys) j_start = MAX(jts-1,jds)
8968       IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
8969
8970 !  WCS 20090218
8971 !      IF(degrade_xs) then
8972 !        i_start = MAX(ids+1,its)
8973 !        i_start_f = i_start+2
8974 !      ENDIF
8975
8976 !      IF(degrade_xe) then
8977 !        i_end = MIN(ide-2,ite)
8978 !        i_end_f = ide-3
8979 !      ENDIF
8980
8981       IF(degrade_xs) then
8982         i_start = MAX(ids+1,its-1)
8983         i_start_f = ids+3
8984       ENDIF
8985
8986       IF(degrade_xe) then
8987         i_end = MIN(ide-2,ite+1)
8988         i_end_f = ide-3
8989       ENDIF
8990
8991 !  compute fluxes
8992
8993       DO j = j_start, j_end
8994
8995 !  5th or 6th order flux
8996
8997         DO k=kts,ktf
8998         DO i = i_start_f, i_end_f
8999
9000           vel = ru(i,k,j)
9001           cr = vel
9002           fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9003
9004           fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
9005                                          field(i-1,k,j), field(i  ,k,j),  &
9006                                          field(i+1,k,j), field(i+2,k,j),  &
9007                                          vel                             )
9008           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9009
9010           if(cr.gt. 0) then
9011              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9012              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9013           else
9014              qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9015              qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9016           end if
9017
9018         ENDDO
9019         ENDDO
9020
9021 !  lower order fluxes close to boundaries (if not periodic or symmetric)
9022
9023 !  WCS 20090218 degrade_xs and xe recoded
9024
9025         IF( degrade_xs ) THEN
9026
9027           DO i=i_start,i_start_f-1
9028
9029             IF(i == ids+1) THEN ! second order
9030               DO k=kts,ktf
9031                 vel = ru(i,k,j)
9032                 cr = vel
9033                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9034
9035                 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
9036                        *(field(i,k,j)+field(i-1,k,j))
9037
9038                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9039
9040                 if(cr.gt. 0) then
9041                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9042                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9043                 else
9044                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9045                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9046                 end if
9047               ENDDO
9048             ENDIF
9049
9050             IF(i == ids+2) THEN  ! third order
9051               DO k=kts,ktf
9052                 vel = ru(i,k,j)
9053                 cr = vel
9054                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9055                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
9056                                           field(i  ,k,j), field(i+1,k,j),  &
9057                                           vel                             )
9058                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9059
9060                 if(cr.gt. 0) then
9061                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9062                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9063                 else
9064                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9065                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9066                 end if
9067               ENDDO
9068             ENDIF
9069
9070           ENDDO
9071
9072         ENDIF
9073
9074         IF( degrade_xe ) THEN
9075
9076           DO i = i_end_f+1, i_end+1
9077
9078             IF( i == ide-1 ) THEN ! second order flux next to the boundary
9079               DO k=kts,ktf
9080                 vel = ru(i,k,j)
9081                 cr = vel
9082                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9083                 fqx(i,k,j) = 0.5*(ru(i,k,j))      &
9084                        *(field(i,k,j)+field(i-1,k,j))
9085                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9086
9087                 if(cr.gt. 0) then
9088                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9089                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9090                 else
9091                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9092                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9093                 end if
9094               ENDDO
9095             ENDIF
9096
9097             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
9098               DO k=kts,ktf
9099                 vel = ru(i,k,j)
9100                 cr = vel
9101                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
9102                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
9103                                           field(i  ,k,j), field(i+1,k,j),  &
9104                                           vel                             )
9105                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
9106
9107                 if(cr.gt. 0) then
9108                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
9109                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
9110                 else
9111                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
9112                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
9113                 end if
9114               ENDDO
9115             ENDIF
9116           ENDDO
9117         ENDIF
9118
9119       ENDDO  ! enddo for outer J loop
9120
9121    ELSE
9122
9123       WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_mono, h_order not known ',horz_order
9124       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
9125
9126    ENDIF horizontal_order_test
9127
9128 !  pick up the rest of the horizontal radiation boundary conditions.
9129 !  (these are the computations that don't require 'cb'.
9130 !  first, set to index ranges
9131
9132       i_start = its
9133       i_end   = MIN(ite,ide-1)
9134       j_start = jts
9135       j_end   = MIN(jte,jde-1)
9136
9137 !  compute x (u) conditions for v, w, or scalar
9138
9139    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
9140
9141        DO j = j_start, j_end
9142        DO k = kts, ktf
9143          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
9144          tendency(its,k,j) = tendency(its,k,j)                     &
9145                - rdx*(                                             &
9146                        ub*(   field_old(its+1,k,j)                 &
9147                             - field_old(its  ,k,j)   ) +           &
9148                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
9149                                                                 )
9150        ENDDO
9151        ENDDO
9152
9153    ENDIF
9154
9155    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
9156
9157        DO j = j_start, j_end
9158        DO k = kts, ktf
9159          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
9160          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
9161                - rdx*(                                               &
9162                        ub*(  field_old(i_end  ,k,j)                  &
9163                            - field_old(i_end-1,k,j) ) +              &
9164                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
9165                                                                     )
9166        ENDDO
9167        ENDDO
9168
9169    ENDIF
9170
9171    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
9172
9173        DO i = i_start, i_end
9174        DO k = kts, ktf
9175          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
9176          tendency(i,k,jts) = tendency(i,k,jts)                     &
9177                - rdy*(                                             &
9178                        vb*(  field_old(i,k,jts+1)                  &
9179                            - field_old(i,k,jts  ) ) +              &
9180                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
9181                                                                 )
9182        ENDDO
9183        ENDDO
9184
9185    ENDIF
9186
9187    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
9188
9189        DO i = i_start, i_end
9190        DO k = kts, ktf
9191          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
9192          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
9193                - rdy*(                                               &
9194                        vb*(   field_old(i,k,j_end  )                 &
9195                             - field_old(i,k,j_end-1) ) +             &
9196                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
9197                                                                     )
9198        ENDDO
9199        ENDDO
9200
9201    ENDIF
9202
9203 !-------------------- vertical advection
9204
9205 !-- loop bounds for periodic or sym conditions
9206
9207       i_start = its-1
9208       i_end   = MIN(ite,ide-1)+1
9209       j_start = jts-1
9210       j_end   = MIN(jte,jde-1)+1
9211
9212 !-- loop bounds for open or specified conditions
9213
9214 !  WCS 20090218
9215 !    IF(degrade_xs) i_start = its
9216 !    IF(degrade_xe) i_end   = MIN(ite,ide-1)
9217 !    IF(degrade_ys) j_start = jts
9218 !    IF(degrade_ye) j_end   = MIN(jte,jde-1)
9219
9220     IF(degrade_xs) i_start = MAX(its-1,ids)
9221     IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
9222     IF(degrade_ys) j_start = MAX(jts-1,jds)
9223     IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
9224
9225
9226     vert_order_test : IF (vert_order == 3) THEN
9227
9228       DO j = j_start, j_end
9229
9230          DO i = i_start, i_end
9231            fqz(i,1,j)  = 0.
9232            fqzl(i,1,j) = 0.
9233            fqz(i,kde,j)  = 0.
9234            fqzl(i,kde,j) = 0.
9235          ENDDO
9236
9237          DO k=kts+2,ktf-1
9238          DO i = i_start, i_end
9239
9240            vel = rom(i,k,j)
9241            cr = -vel
9242            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9243
9244            fqz(i,k,j) = vel*flux3(                      &
9245                    field(i,k-2,j), field(i,k-1,j),      &
9246                    field(i,k  ,j), field(i,k+1,j),  -vel )
9247            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9248
9249           if(cr.gt. 0) then
9250              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
9251              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
9252           else
9253              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
9254              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
9255           end if
9256
9257          ENDDO
9258          ENDDO
9259
9260          DO i = i_start, i_end
9261
9262            k=kts+1
9263            vel = rom(i,k,j)
9264            cr = -vel
9265            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
9266            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
9267            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
9268
9269           if(cr.gt. 0) then
9270              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
9271              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
9272           else
9273              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
9274              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
9275           end if
9276
9277            k=ktf
9278            vel = rom(i,k,j)
9279            cr = -vel
9280            fqzl(i,k,j) = vel*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           if(cr.gt. 0) then
9285              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
9286              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
9287           else
9288              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
9289              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
9290           end if
9291          ENDDO
9292
9293       ENDDO
9294
9295    ELSE
9296
9297       WRITE (wrf_err_message,*) ' advect_scalar_mono, v_order not known ',vert_order
9298       CALL wrf_error_fatal ( wrf_err_message )
9299
9300    ENDIF vert_order_test
9301
9302    IF (mono_limit) THEN
9303
9304 ! montonic filter
9305
9306    i_start = its-1
9307    i_end   = MIN(ite,ide-1)+1
9308    j_start = jts-1
9309    j_end   = MIN(jte,jde-1)+1
9310
9311 ! WCS 20090218
9312
9313 !-- loop bounds for open or specified conditions
9314 !
9315 !   IF(degrade_xs) i_start = its
9316 !   IF(degrade_xe) i_end   = MIN(ite,ide-1)
9317 !   IF(degrade_ys) j_start = jts
9318 !   IF(degrade_ye) j_end   = MIN(jte,jde-1)
9319 !
9320 !   IF(config_flags%specified .or. config_flags%nested) THEN
9321 !     IF (degrade_xs) i_start = MAX(its,ids+1)
9322 !     IF (degrade_xe) i_end   = MIN(ite,ide-2)
9323 !     IF (degrade_ys) j_start = MAX(jts,jds+1)
9324 !     IF (degrade_ye) j_end   = MIN(jte,jde-2)
9325 !   END IF
9326 !
9327 !   IF(config_flags%open_xs) THEN
9328 !     IF (degrade_xs) i_start = MAX(its,ids+1)
9329 !   END IF
9330 !   IF(config_flags%open_xe) THEN
9331 !     IF (degrade_xe) i_end   = MIN(ite,ide-2)
9332 !   END IF
9333 !   IF(config_flags%open_ys) THEN
9334 !     IF (degrade_ys) j_start = MAX(jts,jds+1)
9335 !   END IF
9336 !   IF(config_flags%open_ye) THEN
9337 !     IF (degrade_ye) j_end   = MIN(jte,jde-2)
9338 !   END IF
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
9365 !-- here is the limiter...
9366
9367    DO j=j_start, j_end
9368    DO k=kts, ktf
9369    DO i=i_start, i_end
9370
9371      ph_upwind = (mub(i,j)+mu_old(i,j))*field_old(i,k,j)        &
9372                    - dt*( msftx(i,j)*msfty(i,j)*(               &
9373                           rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
9374                           rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
9375                          +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
9376
9377      flux_in = -dt*( (msftx(i,j)*msfty(i,j))*(                   &
9378                                rdx*(  min(0.,fqx (i+1,k,j))      &
9379                                      -max(0.,fqx (i  ,k,j)) )    &
9380                               +rdy*(  min(0.,fqy (i,k,j+1))      &
9381                                      -max(0.,fqy (i,k,j  )) ) )  &
9382                +msfty(i,j)*rdzw(k)*(  max(0.,fqz (i,k+1,j))      &
9383                                      -min(0.,fqz (i,k  ,j)) )   )
9384
9385      ph_hi = mut(i,j)*qmax(i,k,j) - ph_upwind
9386      IF( flux_in .gt. ph_hi ) scale_in(i,k,j) = max(0.,ph_hi/(flux_in+eps))
9387
9388
9389      flux_out = dt*( (msftx(i,j)*msfty(i,j))*(                    &
9390                                 rdx*(  max(0.,fqx (i+1,k,j))      &
9391                                       -min(0.,fqx (i  ,k,j)) )    &
9392                                +rdy*(  max(0.,fqy (i,k,j+1))      &
9393                                       -min(0.,fqy (i,k,j  )) ) )  &
9394                 +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
9395                                       -max(0.,fqz (i,k  ,j)) )   )
9396
9397      ph_low = ph_upwind - mut(i,j)*qmin(i,k,j)
9398      IF( flux_out .gt. ph_low ) scale_out(i,k,j) = max(0.,ph_low/(flux_out+eps))
9399
9400    ENDDO
9401    ENDDO
9402    ENDDO
9403
9404    DO j=j_start, j_end
9405    DO k=kts, ktf
9406    DO i=i_start, i_end+1
9407        IF( fqx (i,k,j) .gt. 0.) then
9408          fqx(i,k,j) = min(scale_in(i,k,j),scale_out(i-1,k,j))*fqx(i,k,j)
9409        ELSE
9410          fqx(i,k,j) = min(scale_out(i,k,j),scale_in(i-1,k,j))*fqx(i,k,j)
9411        ENDIF
9412    ENDDO
9413    ENDDO
9414    ENDDO
9415
9416    DO j=j_start, j_end+1
9417    DO k=kts, ktf
9418    DO i=i_start, i_end
9419        IF( fqy (i,k,j) .gt. 0.) then
9420          fqy(i,k,j) = min(scale_in(i,k,j),scale_out(i,k,j-1))*fqy(i,k,j)
9421        ELSE
9422          fqy(i,k,j) = min(scale_out(i,k,j),scale_in(i,k,j-1))*fqy(i,k,j)
9423        ENDIF
9424    ENDDO
9425    ENDDO
9426    ENDDO
9427
9428    DO j=j_start, j_end
9429    DO k=kts+1, ktf
9430    DO i=i_start, i_end
9431        IF( fqz (i,k,j) .lt. 0.) then
9432          fqz(i,k,j) = min(scale_in(i,k,j),scale_out(i,k-1,j))*fqz(i,k,j)
9433        ELSE
9434          fqz(i,k,j) = min(scale_out(i,k,j),scale_in(i,k-1,j))*fqz(i,k,j)
9435        ENDIF
9436    ENDDO
9437    ENDDO
9438    ENDDO
9439
9440    END IF
9441
9442 ! add in the mono-limited flux divergence
9443 ! we need to fix this for open b.c set ***********
9444
9445   i_start = its
9446   i_end   = MIN(ite,ide-1)
9447   j_start = jts
9448   j_end   = MIN(jte,jde-1)
9449
9450   DO j = j_start, j_end
9451   DO k = kts, ktf
9452   DO i = i_start, i_end
9453
9454      tendency (i,k,j) = tendency(i,k,j)                           &
9455                             -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
9456                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
9457
9458   ENDDO
9459   ENDDO
9460   ENDDO
9461
9462   IF(tenddec) THEN
9463   DO j = j_start, j_end
9464   DO k = kts, ktf
9465   DO i = i_start, i_end
9466
9467      z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
9468                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
9469
9470   ENDDO
9471   ENDDO
9472   ENDDO
9473   END IF
9474
9475 ! x flux divergence
9476 !
9477
9478 ! WCS 20090218
9479 !  IF(degrade_xs) i_start = i_start + 1
9480 !  IF(degrade_xe) i_end   = i_end   - 1
9481
9482   IF(degrade_xs) i_start = MAX(its,ids+1)
9483   IF(degrade_xe) i_end   = MIN(ite,ide-2)
9484
9485   DO j = j_start, j_end
9486   DO k = kts, ktf
9487   DO i = i_start, i_end
9488
9489      ! Un-"canceled" map scale factor, ADT Eq. 48
9490      tendency (i,k,j) = tendency(i,k,j)                           &
9491                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
9492                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
9493
9494   ENDDO
9495   ENDDO
9496   ENDDO
9497
9498   IF(tenddec) THEN
9499   DO j = j_start, j_end
9500   DO k = kts, ktf
9501   DO i = i_start, i_end
9502
9503      h_tendency (i,k,j) = 0.                                      &
9504                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
9505                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
9506
9507   ENDDO
9508   ENDDO
9509   ENDDO
9510   END IF
9511
9512 ! y flux divergence
9513 !
9514   i_start = its
9515   i_end   = MIN(ite,ide-1)
9516
9517 ! WCS 20090218
9518 !  IF(degrade_ys) j_start = j_start + 1
9519 !  IF(degrade_ye) j_end   = j_end   - 1
9520
9521   IF(degrade_ys) j_start = MAX(jts,jds+1)
9522   IF(degrade_ye) j_end   = MIN(jte,jde-2)
9523
9524   DO j = j_start, j_end
9525   DO k = kts, ktf
9526   DO i = i_start, i_end
9527
9528      ! Un-"canceled" map scale factor, ADT Eq. 48
9529      tendency (i,k,j) = tendency(i,k,j)                           &
9530                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
9531                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
9532
9533   ENDDO
9534   ENDDO
9535   ENDDO
9536
9537   IF(tenddec) THEN
9538   DO j = j_start, j_end
9539   DO k = kts, ktf
9540   DO i = i_start, i_end
9541
9542      h_tendency (i,k,j) = h_tendency (i,k,j)                      &
9543                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
9544                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
9545
9546   ENDDO
9547   ENDDO
9548   ENDDO
9549   END IF
9550
9551 END SUBROUTINE advect_scalar_mono
9552
9553 !-----------------------------------------------------------
9554
9555
9556 SUBROUTINE advect_scalar_weno ( field, field_old, tendency,     &
9557                              ru, rv, rom,                   &
9558                              mut, time_step, config_flags,  &
9559                              msfux, msfuy, msfvx, msfvy,    &
9560                              msftx, msfty,                  &
9561                              fzm, fzp,                      &
9562                              rdx, rdy, rdzw,                &
9563                              ids, ide, jds, jde, kds, kde,  &
9564                              ims, ime, jms, jme, kms, kme,  &
9565                              its, ite, jts, jte, kts, kte  )
9566 !
9567 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
9568 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
9569 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
9570 !
9571    IMPLICIT NONE
9572
9573    ! Input data
9574
9575    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
9576
9577    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
9578                                               ims, ime, jms, jme, kms, kme, &
9579                                               its, ite, jts, jte, kts, kte
9580
9581    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
9582                                                                       field_old, &
9583                                                                       ru,    &
9584                                                                       rv,    &
9585                                                                       rom
9586
9587    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
9588    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
9589
9590    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
9591                                                                     msfuy,  &
9592                                                                     msfvx,  &
9593                                                                     msfvy,  &
9594                                                                     msftx,  &
9595                                                                     msfty
9596
9597    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
9598                                                                   fzp,  &
9599                                                                   rdzw
9600
9601    REAL ,                                        INTENT(IN   ) :: rdx,  &
9602                                                                   rdy
9603    INTEGER ,                                     INTENT(IN   ) :: time_step
9604
9605
9606    ! Local data
9607
9608    INTEGER :: i, j, k, itf, jtf, ktf
9609    INTEGER :: i_start, i_end, j_start, j_end
9610    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
9611    INTEGER :: jmin, jmax, jp, jm, imin, imax
9612
9613    INTEGER , PARAMETER :: is=0, js=0, ks=0
9614
9615    REAL    :: mrdx, mrdy, ub, vb, vw
9616    REAL , DIMENSION(its:ite, kts:kte) :: vflux
9617
9618
9619    REAL,  DIMENSION( its-is:ite+1, kts:kte  ) :: fqx
9620 !   REAL,  DIMENSION( its:ite+1, kts:kte  ) :: fqx
9621    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
9622
9623    INTEGER :: horz_order, vert_order
9624
9625    LOGICAL :: degrade_xs, degrade_ys
9626    LOGICAL :: degrade_xe, degrade_ye
9627
9628    INTEGER :: jp1, jp0, jtmp
9629
9630     real            :: dir, vv
9631     real            :: ue,uw,vs,vn,wb,wt
9632     real, parameter :: f30 =  7./12., f31 = 1./12.
9633     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
9634
9635
9636    integer kt,kb
9637
9638
9639     real               :: qim2, qim1, qi, qip1, qip2
9640     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
9641     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18
9642     integer, parameter :: pw = 2
9643
9644
9645 ! definition of flux operators, 3rd, 4th, 5th or 6th order
9646
9647    REAL    :: flux3, flux4, flux5, flux6
9648    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
9649
9650       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
9651             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
9652
9653       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
9654            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
9655            sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
9656
9657       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
9658             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
9659             +(1./60.)*(q_ip2+q_im3)
9660
9661       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
9662            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
9663             -sign(1,time_step)*sign(1.,ua)*(1./60.)*(           &
9664               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
9665
9666    LOGICAL :: specified
9667
9668    specified = .false.
9669    if(config_flags%specified .or. config_flags%nested) specified = .true.
9670
9671 ! set order for the advection schemes
9672
9673   ktf=MIN(kte,kde-1)
9674   horz_order = 5 ! config_flags%h_sca_adv_order
9675   vert_order = 5 ! config_flags%v_sca_adv_order
9676
9677 !  begin with horizontal flux divergence
9678 !  here is the choice of flux operators
9679
9680
9681
9682   IF( horz_order == 5 ) THEN
9683
9684 !  determine boundary mods for flux operators
9685 !  We degrade the flux operators from 3rd/4th order
9686 !   to second order one gridpoint in from the boundaries for
9687 !   all boundary conditions except periodic and symmetry - these
9688 !   conditions have boundary zone data fill for correct application
9689 !   of the higher order flux stencils
9690
9691    degrade_xs = .true.
9692    degrade_xe = .true.
9693    degrade_ys = .true.
9694    degrade_ye = .true.
9695
9696    IF( config_flags%periodic_x   .or. &
9697        config_flags%symmetric_xs .or. &
9698        (its > ids+3)                ) degrade_xs = .false.
9699    IF( config_flags%periodic_x   .or. &
9700        config_flags%symmetric_xe .or. &
9701        (ite < ide-3)                ) degrade_xe = .false.
9702    IF( config_flags%periodic_y   .or. &
9703        config_flags%symmetric_ys .or. &
9704        (jts > jds+3)                ) degrade_ys = .false.
9705    IF( config_flags%periodic_y   .or. &
9706        config_flags%symmetric_ye .or. &
9707        (jte < jde-4)                ) degrade_ye = .false.
9708
9709 !--------------- y - advection first
9710
9711       ktf=MIN(kte,kde-1)
9712       i_start = its
9713       i_end   = MIN(ite,ide-1)
9714
9715
9716 ! check for U
9717       IF ( is == 1 ) THEN
9718         i_start = its
9719         i_end   = ite
9720         IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
9721         IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
9722         IF ( config_flags%periodic_x ) i_start = its
9723         IF ( config_flags%periodic_x ) i_end = ite
9724       ENDIF
9725
9726       j_start = jts
9727       j_end   = MIN(jte,jde-1)
9728
9729 !  higher order flux has a 5 or 7 point stencil, so compute
9730 !  bounds so we can switch to second order flux close to the boundary
9731
9732       j_start_f = j_start
9733       j_end_f   = j_end+1
9734
9735       IF(degrade_ys) then
9736         j_start = MAX(jts,jds+1)
9737         j_start_f = jds+3
9738       ENDIF
9739
9740       IF(degrade_ye) then
9741         j_end = MIN(jte,jde-2)
9742         j_end_f = jde-3
9743       ENDIF
9744
9745       IF(config_flags%polar) j_end = MIN(jte,jde-1)
9746
9747 !  compute fluxes, 5th or 6th order
9748
9749      jp1 = 2
9750      jp0 = 1
9751
9752      j_loop_y_flux_5 : DO j = j_start, j_end+1
9753
9754       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil
9755
9756         DO k=kts,ktf
9757         DO i = i_start, i_end
9758 !          vel = rv(i,k,j)
9759           vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
9760
9761          IF ( vel .ge. 0.0 ) THEN
9762             qip2 = field(i,k,j+1)
9763             qip1 = field(i,k,j  )
9764             qi   = field(i,k,j-1)
9765             qim1 = field(i,k,j-2)
9766             qim2 = field(i,k,j-3)
9767           ELSE
9768             qip2 = field(i,k,j-2)
9769             qip1 = field(i,k,j-1)
9770             qi   = field(i,k,j  )
9771             qim1 = field(i,k,j+1)
9772             qim2 = field(i,k,j+2)
9773          ENDIF
9774
9775          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
9776          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
9777          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
9778
9779          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
9780          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
9781          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
9782
9783          wi0 = gi0 / (eps + beta0)**pw
9784          wi1 = gi1 / (eps + beta1)**pw
9785          wi2 = gi2 / (eps + beta2)**pw
9786
9787          sumwk = wi0 + wi1 + wi2
9788
9789           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
9790
9791 !          fqy( i, k, jp1 ) = vel*flux5(                                &
9792 !                  field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
9793 !                  field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
9794         ENDDO
9795         ENDDO
9796
9797
9798       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
9799
9800             DO k=kts,ktf
9801             DO i = i_start, i_end
9802               fqy(i,k, jp1) = 0.5*rv(i,k,j)*          &
9803 !              fqy(i,k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )*          &
9804                      (field(i,k,j)+field(i,k,j-1))
9805
9806             ENDDO
9807             ENDDO
9808
9809      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
9810
9811             DO k=kts,ktf
9812             DO i = i_start, i_end
9813 !              vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
9814               vel = rv(i,k,j)
9815               fqy( i, k, jp1 ) = vel*flux3(              &
9816                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
9817             ENDDO
9818             ENDDO
9819
9820      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
9821
9822             DO k=kts,ktf
9823             DO i = i_start, i_end
9824 !              fqy(i, k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )*      &
9825               fqy(i, k, jp1) = 0.5*rv(i,k,j)*      &
9826                      (field(i,k,j)+field(i,k,j-1))
9827             ENDDO
9828             ENDDO
9829
9830      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
9831
9832             DO k=kts,ktf
9833             DO i = i_start, i_end
9834               vel = rv(i,k,j)
9835 !              vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
9836               fqy( i, k, jp1) = vel*flux3(             &
9837                    field(i,k,j-2),field(i,k,j-1),    &
9838                    field(i,k,j),field(i,k,j+1),vel )
9839             ENDDO
9840             ENDDO
9841
9842      ENDIF
9843
9844 !  y flux-divergence into tendency
9845
9846       IF ( is == 0 ) THEN
9847         ! Comments on polar boundary conditions
9848         ! Same process as for advect_u - tendencies run from jds to jde-1
9849         ! (latitudes are as for u grid, longitudes are displaced)
9850         ! Therefore: flow is only from one side for points next to poles
9851         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
9852           DO k=kts,ktf
9853           DO i = i_start, i_end
9854             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
9855             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
9856           END DO
9857           END DO
9858         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
9859           DO k=kts,ktf
9860           DO i = i_start, i_end
9861             mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
9862             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
9863           END DO
9864           END DO
9865         ELSE  ! normal code
9866
9867         IF(j > j_start) THEN
9868
9869           DO k=kts,ktf
9870           DO i = i_start, i_end
9871             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
9872             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
9873           ENDDO
9874           ENDDO
9875
9876         ENDIF
9877         ENDIF
9878        ELSEIF ( is == 1 ) THEN
9879
9880         ! (j > j_start) will miss the u(,,jds) tendency
9881         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
9882           DO k=kts,ktf
9883           DO i = i_start, i_end
9884             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
9885             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
9886           END DO
9887           END DO
9888         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
9889         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
9890           DO k=kts,ktf
9891           DO i = i_start, i_end
9892             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
9893             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
9894           END DO
9895           END DO
9896         ELSE  ! normal code
9897
9898         IF(j > j_start) THEN
9899
9900           DO k=kts,ktf
9901           DO i = i_start, i_end
9902             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
9903             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
9904           ENDDO
9905           ENDDO
9906
9907         ENDIF
9908
9909         END IF
9910
9911        ENDIF
9912
9913         jtmp = jp1
9914         jp1 = jp0
9915         jp0 = jtmp
9916
9917       ENDDO j_loop_y_flux_5
9918
9919 !  next, x - flux divergence
9920
9921       i_start = its
9922       i_end   = MIN(ite,ide-1)
9923
9924       j_start = jts
9925       j_end   = MIN(jte,jde-1)
9926
9927 !  higher order flux has a 5 or 7 point stencil, so compute
9928 !  bounds so we can switch to second order flux close to the boundary
9929
9930       i_start_f = i_start
9931       i_end_f   = i_end+1
9932
9933       IF(degrade_xs) then
9934         i_start = MAX(ids+1,its)
9935 !        i_start_f = i_start+2
9936         i_start_f = MIN(i_start+2,ids+3)
9937       ENDIF
9938
9939       IF(degrade_xe) then
9940         i_end = MIN(ide-2,ite)
9941         i_end_f = ide-3
9942       ENDIF
9943
9944 !  compute fluxes
9945
9946       DO j = j_start, j_end
9947
9948 !  5th or 6th order flux
9949
9950         DO k=kts,ktf
9951         DO i = i_start_f, i_end_f
9952 !          vel = ru(i,k,j)
9953           vel = 0.5*( ru(i,k,j) + ru(i-is,k-ks,j-js) )
9954
9955
9956          IF ( vel .ge. 0.0 ) THEN
9957             qip2 = field(i+1,k,j)
9958             qip1 = field(i,  k,j)
9959             qi   = field(i-1,k,j)
9960             qim1 = field(i-2,k,j)
9961             qim2 = field(i-3,k,j)
9962           ELSE
9963             qip2 = field(i-2,k,j)
9964             qip1 = field(i-1,k,j)
9965             qi   = field(i,  k,j)
9966             qim1 = field(i+1,k,j)
9967             qim2 = field(i+2,k,j)
9968          ENDIF
9969
9970          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
9971          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
9972          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
9973
9974          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
9975          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
9976          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
9977
9978          wi0 = gi0 / (eps + beta0)**pw
9979          wi1 = gi1 / (eps + beta1)**pw
9980          wi2 = gi2 / (eps + beta2)**pw
9981
9982          sumwk = wi0 + wi1 + wi2
9983
9984          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
9985
9986 !          fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
9987 !                                         field(i-1,k,j), field(i  ,k,j),  &
9988 !                                         field(i+1,k,j), field(i+2,k,j),  &
9989 !                                         vel                             )
9990         ENDDO
9991         ENDDO
9992
9993 !  lower order fluxes close to boundaries (if not periodic or symmetric)
9994
9995         IF( degrade_xs ) THEN
9996
9997           DO i=i_start,i_start_f-1
9998
9999             IF(i == ids+1) THEN ! second order
10000               DO k=kts,ktf
10001                 fqx(i,k) = 0.5*(ru(i,k,j)) &
10002                        *(field(i,k,j)+field(i-1,k,j))
10003               ENDDO
10004             ENDIF
10005
10006             IF(i == ids+2) THEN  ! third order
10007               DO k=kts,ktf
10008                 vel = ru(i,k,j)
10009                 fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
10010                                               field(i  ,k,j), field(i+1,k,j),  &
10011                                               vel                     )
10012               ENDDO
10013             END IF
10014
10015           ENDDO
10016
10017         ENDIF
10018
10019         IF( degrade_xe ) THEN
10020
10021           DO i = i_end_f+1, i_end+1
10022
10023             IF( i == ide-1 ) THEN ! second order flux next to the boundary
10024               DO k=kts,ktf
10025                 fqx(i,k) = 0.5*(ru(i,k,j))      &
10026                        *(field(i,k,j)+field(i-1,k,j))
10027               ENDDO
10028            ENDIF
10029
10030            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
10031              DO k=kts,ktf
10032                vel = ru(i,k,j)
10033                fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
10034                                        field(i  ,k,j), field(i+1,k,j),  &
10035                                        vel                             )
10036              ENDDO
10037            ENDIF
10038
10039          ENDDO
10040
10041        ENDIF
10042
10043 !  x flux-divergence into tendency
10044
10045        IF ( is == 0 ) THEN
10046           DO k=kts,ktf
10047           DO i = i_start, i_end
10048             mrdx=msftx(i,j)*rdx      ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
10049             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
10050           ENDDO
10051           ENDDO
10052        ELSEIF ( is == 1 ) THEN
10053         DO k=kts,ktf
10054           DO i = i_start, i_end
10055             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
10056             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
10057           ENDDO
10058         ENDDO
10059        ENDIF
10060
10061       ENDDO
10062
10063
10064    ENDIF
10065
10066
10067 !  pick up the rest of the horizontal radiation boundary conditions.
10068 !  (these are the computations that don't require 'cb'.
10069 !  first, set to index ranges
10070
10071       i_start = its
10072       i_end   = MIN(ite,ide-1)
10073       j_start = jts
10074       j_end   = MIN(jte,jde-1)
10075
10076 !  compute x (u) conditions for v, w, or scalar
10077
10078    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
10079
10080        DO j = j_start, j_end
10081        DO k = kts, ktf
10082          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
10083          tendency(its,k,j) = tendency(its,k,j)                     &
10084                - rdx*(                                             &
10085                        ub*(   field_old(its+1,k,j)                 &
10086                             - field_old(its  ,k,j)   ) +           &
10087                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
10088                                                                 )
10089        ENDDO
10090        ENDDO
10091
10092    ENDIF
10093
10094    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
10095
10096        DO j = j_start, j_end
10097        DO k = kts, ktf
10098          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
10099          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
10100                - rdx*(                                               &
10101                        ub*(  field_old(i_end  ,k,j)                  &
10102                            - field_old(i_end-1,k,j) ) +              &
10103                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
10104                                                                     )
10105        ENDDO
10106        ENDDO
10107
10108    ENDIF
10109
10110    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
10111
10112        DO i = i_start, i_end
10113        DO k = kts, ktf
10114          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
10115          tendency(i,k,jts) = tendency(i,k,jts)                     &
10116                - rdy*(                                             &
10117                        vb*(  field_old(i,k,jts+1)                  &
10118                            - field_old(i,k,jts  ) ) +              &
10119                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
10120                                                                 )
10121        ENDDO
10122        ENDDO
10123
10124    ENDIF
10125
10126    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
10127
10128        DO i = i_start, i_end
10129        DO k = kts, ktf
10130          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
10131          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
10132                - rdy*(                                               &
10133                        vb*(   field_old(i,k,j_end  )                 &
10134                             - field_old(i,k,j_end-1) ) +             &
10135                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
10136                                                                     )
10137        ENDDO
10138        ENDDO
10139
10140    ENDIF
10141
10142
10143 !-------------------- vertical advection
10144 !     Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
10145 !     Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
10146 !     So we don't need to make a correction for advect_scalar
10147
10148       i_start = its
10149       i_end   = MIN(ite,ide-1)
10150       j_start = jts
10151       j_end   = MIN(jte,jde-1)
10152
10153       DO i = i_start, i_end
10154          vflux(i,kts)=0.
10155          vflux(i,kte)=0.
10156       ENDDO
10157
10158
10159
10160       DO j = j_start, j_end
10161
10162          DO k=kts+3,ktf-2
10163          DO i = i_start, i_end
10164 !           vel = rom(i,k,j)
10165            vel = 0.5*( rom(i,k,j) + rom(i-is,k-ks,j-js) )
10166
10167          IF( -vel .ge. 0.0 ) THEN
10168             qip2 = field(i,k+1,j)
10169             qip1 = field(i,k  ,j)
10170             qi   = field(i,k-1,j)
10171             qim1 = field(i,k-2,j)
10172             qim2 = field(i,k-3,j)
10173           ELSE
10174             qip2 = field(i,k-2,j)
10175             qip1 = field(i,k-1,j)
10176             qi   = field(i,k  ,j)
10177             qim1 = field(i,k+1,j)
10178             qim2 = field(i,k+2,j)
10179          ENDIF
10180
10181          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
10182          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
10183          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
10184
10185          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
10186          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
10187          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
10188
10189          wi0 = gi0 / (eps + beta0)**pw
10190          wi1 = gi1 / (eps + beta1)**pw
10191          wi2 = gi2 / (eps + beta2)**pw
10192
10193          sumwk = wi0 + wi1 + wi2
10194
10195           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
10196
10197 !           vflux(i,k) = vel*flux5(                                 &
10198 !                   field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
10199 !                   field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
10200          ENDDO
10201          ENDDO
10202
10203          DO i = i_start, i_end
10204
10205            k=kts+1
10206            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
10207
10208            k = kts+2
10209            vel=rom(i,k,j)
10210            vflux(i,k) = vel*flux3(               &
10211                    field(i,k-2,j), field(i,k-1,j),   &
10212                    field(i,k  ,j), field(i,k+1,j), -vel )
10213            k = ktf-1
10214            vel=rom(i,k,j)
10215            vflux(i,k) = vel*flux3(               &
10216                    field(i,k-2,j), field(i,k-1,j),   &
10217                    field(i,k  ,j), field(i,k+1,j), -vel )
10218
10219            k=ktf
10220            vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
10221          ENDDO
10222
10223          DO k=kts,ktf
10224          DO i = i_start, i_end
10225             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
10226          ENDDO
10227          ENDDO
10228
10229       ENDDO
10230
10231
10232
10233 END SUBROUTINE advect_scalar_weno
10234
10235 !---------------------------------------------------------------------------------
10236
10237 SUBROUTINE advect_weno_u ( u, u_old, tendency,            &
10238                         ru, rv, rom,                   &
10239                         mut, time_step, config_flags,  &
10240                         msfux, msfuy, msfvx, msfvy,    &
10241                         msftx, msfty,                  &
10242                         fzm, fzp,                      &
10243                         rdx, rdy, rdzw,                &
10244                         ids, ide, jds, jde, kds, kde,  &
10245                         ims, ime, jms, jme, kms, kme,  &
10246                         its, ite, jts, jte, kts, kte  )
10247
10248 !
10249 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
10250 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
10251 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
10252 !
10253
10254    IMPLICIT NONE
10255
10256    ! Input data
10257
10258    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
10259
10260    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
10261                                               ims, ime, jms, jme, kms, kme, &
10262                                               its, ite, jts, jte, kts, kte
10263
10264    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: u,     &
10265                                                                       u_old, &
10266                                                                       ru,    &
10267                                                                       rv,    &
10268                                                                       rom
10269
10270    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
10271    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
10272
10273    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
10274                                                                     msfuy,  &
10275                                                                     msfvx,  &
10276                                                                     msfvy,  &
10277                                                                     msftx,  &
10278                                                                     msfty
10279
10280    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
10281                                                                   fzp,  &
10282                                                                   rdzw
10283
10284    REAL ,                                        INTENT(IN   ) :: rdx,  &
10285                                                                   rdy
10286    INTEGER ,                                     INTENT(IN   ) :: time_step
10287
10288    ! Local data
10289
10290    INTEGER :: i, j, k, itf, jtf, ktf
10291    INTEGER :: i_start, i_end, j_start, j_end
10292    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
10293    INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
10294    INTEGER :: jp1, jp0, jtmp
10295
10296     real            :: dir, vv
10297     real            :: ue,vs,vn,wb,wt
10298     real, parameter :: f30 =  7./12., f31 = 1./12.
10299     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
10300
10301
10302    integer kt,kb
10303
10304
10305     real               :: qim2, qim1, qi, qip1, qip2
10306     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
10307     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18
10308     integer, parameter :: pw = 2
10309
10310
10311    INTEGER :: horz_order, vert_order
10312
10313    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
10314    REAL , DIMENSION(its:ite, kts:kte) :: vflux
10315
10316
10317    REAL,  DIMENSION( its-1:ite+1, kts:kte ) :: fqx
10318    REAL,  DIMENSION( its:ite, kts:kte, 2) :: fqy
10319
10320    LOGICAL :: degrade_xs, degrade_ys
10321    LOGICAL :: degrade_xe, degrade_ye
10322
10323 ! definition of flux operators, 3rd, 4th, 5th or 6th order
10324
10325    REAL    :: flux3, flux4, flux5, flux6
10326    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
10327
10328    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                         &
10329           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
10330
10331    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                         &
10332             flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
10333             sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
10334
10335    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
10336                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)       &
10337                      +(q_ip2+q_im3) )/60.0
10338
10339    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =           &
10340            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)     &
10341             -sign(1,time_step)*sign(1.,ua)*(                     &
10342               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
10343
10344
10345    LOGICAL :: specified
10346
10347    specified = .false.
10348    if(config_flags%specified .or. config_flags%nested) specified = .true.
10349
10350 !  set order for vertical and horzontal flux operators
10351
10352    horz_order = config_flags%h_mom_adv_order
10353    vert_order = config_flags%v_mom_adv_order
10354
10355    ktf=MIN(kte,kde-1)
10356
10357 !  begin with horizontal flux divergence
10358
10359 !   horizontal_order_test : IF( horz_order == 6 ) THEN
10360
10361 !   ELSE IF( horz_order == 5 ) THEN
10362
10363 !  5th order horizontal flux calculation
10364 !  This code is EXACTLY the same as the 6th order code
10365 !  EXCEPT the 5th order and 3rd operators are used in
10366 !  place of the 6th and 4th order operators
10367
10368 !  determine boundary mods for flux operators
10369 !  We degrade the flux operators from 3rd/4th order
10370 !   to second order one gridpoint in from the boundaries for
10371 !   all boundary conditions except periodic and symmetry - these
10372 !   conditions have boundary zone data fill for correct application
10373 !   of the higher order flux stencils
10374
10375    degrade_xs = .true.
10376    degrade_xe = .true.
10377    degrade_ys = .true.
10378    degrade_ye = .true.
10379
10380    IF( config_flags%periodic_x   .or. &
10381        config_flags%symmetric_xs .or. &
10382        (its > ids+3)                ) degrade_xs = .false.
10383    IF( config_flags%periodic_x   .or. &
10384        config_flags%symmetric_xe .or. &
10385        (ite < ide-2)                ) degrade_xe = .false.
10386    IF( config_flags%periodic_y   .or. &
10387        config_flags%symmetric_ys .or. &
10388        (jts > jds+3)                ) degrade_ys = .false.
10389    IF( config_flags%periodic_y   .or. &
10390        config_flags%symmetric_ye .or. &
10391        (jte < jde-4)                ) degrade_ye = .false.
10392
10393 !--------------- y - advection first
10394
10395       i_start = its
10396       i_end   = ite
10397       IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its)
10398       IF ( config_flags%open_xe .or. specified ) i_end   = MIN(ide-1,ite)
10399       IF ( config_flags%periodic_x ) i_start = its
10400       IF ( config_flags%periodic_x ) i_end = ite
10401
10402       j_start = jts
10403       j_end   = MIN(jte,jde-1)
10404
10405 !  higher order flux has a 5 or 7 point stencil, so compute
10406 !  bounds so we can switch to second order flux close to the boundary
10407
10408       j_start_f = j_start
10409       j_end_f   = j_end+1
10410
10411       IF(degrade_ys) then
10412         j_start = MAX(jts,jds+1)
10413         j_start_f = jds+3
10414       ENDIF
10415
10416       IF(degrade_ye) then
10417         j_end = MIN(jte,jde-2)
10418         j_end_f = jde-3
10419       ENDIF
10420
10421       IF(config_flags%polar) j_end = MIN(jte,jde-1)
10422
10423 !  compute fluxes, 5th or 6th order
10424
10425      jp1 = 2
10426      jp0 = 1
10427
10428      j_loop_y_flux_5 : DO j = j_start, j_end+1
10429
10430       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN  ! use full stencil
10431
10432         DO k=kts,ktf
10433         DO i = i_start, i_end
10434           vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
10435
10436          IF ( vel .ge. 0.0 ) THEN
10437             qip2 = u(i,k,j+1)
10438             qip1 = u(i,k,j  )
10439             qi   = u(i,k,j-1)
10440             qim1 = u(i,k,j-2)
10441             qim2 = u(i,k,j-3)
10442           ELSE
10443             qip2 = u(i,k,j-2)
10444             qip1 = u(i,k,j-1)
10445             qi   = u(i,k,j  )
10446             qim1 = u(i,k,j+1)
10447             qim2 = u(i,k,j+2)
10448          ENDIF
10449
10450          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
10451          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
10452          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
10453
10454          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
10455          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
10456          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
10457
10458          wi0 = gi0 / (eps + beta0)**pw
10459          wi1 = gi1 / (eps + beta1)**pw
10460          wi2 = gi2 / (eps + beta2)**pw
10461
10462          sumwk = wi0 + wi1 + wi2
10463
10464           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
10465
10466 !          fqy( i, k, jp1 ) = vel*flux5(               &
10467 !                  u(i,k,j-3), u(i,k,j-2), u(i,k,j-1),       &
10468 !                  u(i,k,j  ), u(i,k,j+1), u(i,k,j+2),  vel )
10469         ENDDO
10470         ENDDO
10471
10472 !  we must be close to some boundary where we need to reduce the order of the stencil
10473
10474       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
10475
10476             DO k=kts,ktf
10477             DO i = i_start, i_end
10478               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))  &
10479                                      *(u(i,k,j)+u(i,k,j-1))
10480             ENDDO
10481             ENDDO
10482
10483      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
10484
10485             DO k=kts,ktf
10486             DO i = i_start, i_end
10487               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
10488               fqy( i, k, jp1 ) = vel*flux3(      &
10489                    u(i,k,j-2),u(i,k,j-1), u(i,k,j),u(i,k,j+1),vel )
10490             ENDDO
10491             ENDDO
10492
10493      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
10494
10495             DO k=kts,ktf
10496             DO i = i_start, i_end
10497               fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i-1,k,j))    &
10498                      *(u(i,k,j)+u(i,k,j-1))
10499             ENDDO
10500             ENDDO
10501
10502      ELSE IF ( j == jde-2 ) THEN  ! 3rd order flux 2 in from north boundary
10503
10504             DO k=kts,ktf
10505             DO i = i_start, i_end
10506               vel = 0.5*(rv(i,k,j)+rv(i-1,k,j))
10507               fqy( i, k, jp1 ) = vel*flux3(     &
10508                    u(i,k,j-2),u(i,k,j-1),    &
10509                    u(i,k,j),u(i,k,j+1),vel )
10510             ENDDO
10511             ENDDO
10512
10513       END IF
10514
10515 !  y flux-divergence into tendency
10516
10517         ! (j > j_start) will miss the u(,,jds) tendency
10518         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
10519           DO k=kts,ktf
10520           DO i = i_start, i_end
10521             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
10522             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
10523           END DO
10524           END DO
10525         ! This would be seen by (j > j_start) but we need to zero out the NP tendency
10526         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
10527           DO k=kts,ktf
10528           DO i = i_start, i_end
10529             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
10530             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
10531           END DO
10532           END DO
10533         ELSE  ! normal code
10534
10535         IF(j > j_start) THEN
10536
10537           DO k=kts,ktf
10538           DO i = i_start, i_end
10539             mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
10540             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
10541           ENDDO
10542           ENDDO
10543
10544         ENDIF
10545
10546         END IF
10547
10548
10549         jtmp = jp1
10550         jp1 = jp0
10551         jp0 = jtmp
10552
10553    ENDDO j_loop_y_flux_5
10554
10555 !  next, x - flux divergence
10556
10557       i_start = its
10558       i_end   = ite
10559
10560       j_start = jts
10561       j_end   = MIN(jte,jde-1)
10562
10563 !  higher order flux has a 5 or 7 point stencil, so compute
10564 !  bounds so we can switch to second order flux close to the boundary
10565
10566       i_start_f = i_start
10567       i_end_f   = i_end+1
10568
10569       IF(degrade_xs) then
10570         i_start = MAX(ids+1,its)
10571         i_start_f = ids+3
10572       ENDIF
10573
10574       IF(degrade_xe) then
10575         i_end = MIN(ide-1,ite)
10576         i_end_f = ide-2
10577       ENDIF
10578
10579 !  compute fluxes
10580
10581       DO j = j_start, j_end
10582
10583 !  5th or 6th order flux
10584
10585         DO k=kts,ktf
10586         DO i = i_start_f, i_end_f
10587           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
10588
10589          IF ( vel .ge. 0.0 ) THEN
10590             qip2 = u(i+1,k,j)
10591             qip1 = u(i,  k,j)
10592             qi   = u(i-1,k,j)
10593             qim1 = u(i-2,k,j)
10594             qim2 = u(i-3,k,j)
10595           ELSE
10596             qip2 = u(i-2,k,j)
10597             qip1 = u(i-1,k,j)
10598             qi   = u(i,  k,j)
10599             qim1 = u(i+1,k,j)
10600             qim2 = u(i+2,k,j)
10601          ENDIF
10602
10603          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
10604          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
10605          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
10606
10607          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
10608          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
10609          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
10610
10611          wi0 = gi0 / (eps + beta0)**pw
10612          wi1 = gi1 / (eps + beta1)**pw
10613          wi2 = gi2 / (eps + beta2)**pw
10614
10615          sumwk = wi0 + wi1 + wi2
10616
10617          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
10618
10619 !          fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j),  &
10620 !                                         u(i-1,k,j), u(i  ,k,j),  &
10621 !                                         u(i+1,k,j), u(i+2,k,j),  &
10622 !                                         vel                     )
10623         ENDDO
10624         ENDDO
10625
10626 !  lower order fluxes close to boundaries (if not periodic or symmetric)
10627 !  specified uses upstream normal wind at boundaries
10628
10629         IF( degrade_xs ) THEN
10630
10631           IF( i_start == ids+1 ) THEN ! second order flux next to the boundary
10632             i = ids+1
10633             DO k=kts,ktf
10634               ub = u(i-1,k,j)
10635               IF (specified .AND. u(i,k,j) .LT. 0.)ub = u(i,k,j)
10636               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
10637                      *(u(i,k,j)+ub)
10638             ENDDO
10639           END IF
10640
10641           i = ids+2
10642           DO k=kts,ktf
10643             vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
10644             fqx( i, k  ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
10645                                            u(i  ,k,j), u(i+1,k,j),  &
10646                                            vel                     )
10647           ENDDO
10648
10649         ENDIF
10650
10651         IF( degrade_xe ) THEN
10652
10653           IF( i_end == ide-1 ) THEN ! second order flux next to the boundary
10654             i = ide
10655             DO k=kts,ktf
10656               ub = u(i,k,j)
10657               IF (specified .AND. u(i-1,k,j) .GT. 0.)ub = u(i-1,k,j)
10658               fqx(i, k) = 0.25*(ru(i,k,j)+ru(i-1,k,j)) &
10659                      *(u(i-1,k,j)+ub)
10660             ENDDO
10661           ENDIF
10662
10663           DO k=kts,ktf
10664           i = ide-1
10665           vel = 0.5*(ru(i,k,j)+ru(i-1,k,j))
10666           fqx( i,k ) = vel*flux3( u(i-2,k,j), u(i-1,k,j),  &
10667                                          u(i  ,k,j), u(i+1,k,j),  &
10668                                          vel                     )
10669           ENDDO
10670
10671         ENDIF
10672
10673 !  x flux-divergence into tendency
10674
10675         DO k=kts,ktf
10676           DO i = i_start, i_end
10677             mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
10678             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
10679           ENDDO
10680         ENDDO
10681
10682       ENDDO
10683
10684
10685 !  radiative lateral boundary condition in x for normal velocity (u)
10686
10687       IF ( (config_flags%open_xs) .and. its == ids ) THEN
10688
10689         j_start = jts
10690         j_end   = MIN(jte,jde-1)
10691
10692         DO j = j_start, j_end
10693         DO k = kts, ktf
10694           ub = MIN(ru(its,k,j)-cb*mut(its,j), 0.)
10695           tendency(its,k,j) = tendency(its,k,j)                    &
10696                       - rdx*ub*(u_old(its+1,k,j) - u_old(its,k,j))
10697         ENDDO
10698         ENDDO
10699
10700       ENDIF
10701
10702       IF ( (config_flags%open_xe) .and. ite == ide ) THEN
10703
10704         j_start = jts
10705         j_end   = MIN(jte,jde-1)
10706
10707         DO j = j_start, j_end
10708         DO k = kts, ktf
10709           ub = MAX(ru(ite,k,j)+cb*mut(ite-1,j), 0.)
10710           tendency(ite,k,j) = tendency(ite,k,j)                    &
10711                       - rdx*ub*(u_old(ite,k,j) - u_old(ite-1,k,j))
10712         ENDDO
10713         ENDDO
10714
10715       ENDIF
10716
10717 !  pick up the rest of the horizontal radiation boundary conditions.
10718 !  (these are the computations that don't require 'cb')
10719 !  first, set to index ranges
10720
10721       i_start = its
10722       i_end   = MIN(ite,ide)
10723       imin    = ids
10724       imax    = ide-1
10725
10726       IF (config_flags%open_xs) THEN
10727         i_start = MAX(ids+1, its)
10728         imin = ids
10729       ENDIF
10730       IF (config_flags%open_xe) THEN
10731         i_end = MIN(ite,ide-1)
10732         imax = ide-1
10733       ENDIF
10734
10735    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
10736
10737       DO i = i_start, i_end
10738
10739          mrdy=msfux(i,jts)*rdy       ! ADT eqn 44, 2nd term on RHS
10740          ip = MIN( imax, i   )
10741          im = MAX( imin, i-1 )
10742
10743          DO k=kts,ktf
10744
10745           vw = 0.5*(rv(ip,k,jts)+rv(im,k,jts))
10746           vb = MIN( vw, 0. )
10747           dvm =  rv(ip,k,jts+1)-rv(ip,k,jts)
10748           dvp =  rv(im,k,jts+1)-rv(im,k,jts)
10749           tendency(i,k,jts)=tendency(i,k,jts)-mrdy*(                &
10750                             vb*(u_old(i,k,jts+1)-u_old(i,k,jts))    &
10751                            +0.5*u(i,k,jts)*(dvm+dvp))
10752          ENDDO
10753       ENDDO
10754
10755    ENDIF
10756
10757    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
10758
10759       DO i = i_start, i_end
10760
10761          mrdy=msfux(i,jte-1)*rdy     ! ADT eqn 44, 2nd term on RHS
10762          ip = MIN( imax, i   )
10763          im = MAX( imin, i-1 )
10764
10765          DO k=kts,ktf
10766
10767           vw = 0.5*(rv(ip,k,jte)+rv(im,k,jte))
10768           vb = MAX( vw, 0. )
10769           dvm =  rv(ip,k,jte)-rv(ip,k,jte-1)
10770           dvp =  rv(im,k,jte)-rv(im,k,jte-1)
10771           tendency(i,k,jte-1)=tendency(i,k,jte-1)-mrdy*(              &
10772                               vb*(u_old(i,k,jte-1)-u_old(i,k,jte-2))  &
10773                              +0.5*u(i,k,jte-1)*(dvm+dvp))
10774          ENDDO
10775       ENDDO
10776
10777    ENDIF
10778
10779 !-------------------- vertical advection
10780 !  ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
10781 !  Here we have:  - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
10782 !  Since 'my' (map scale factor in y-direction) isn't a function of z,
10783 !  this is what we need, so leave unchanged in advect_u
10784
10785    i_start = its
10786    i_end   = ite
10787    j_start = jts
10788    j_end   = min(jte,jde-1)
10789
10790 !   IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
10791 !   IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
10792
10793    IF ( config_flags%open_ys .or. specified ) i_start = MAX(ids+1,its)
10794    IF ( config_flags%open_ye .or. specified ) i_end   = MIN(ide-1,ite)
10795       IF ( config_flags%periodic_x ) i_start = its
10796       IF ( config_flags%periodic_x ) i_end = ite
10797
10798    DO i = i_start, i_end
10799      vflux(i,kts)=0.
10800      vflux(i,kte)=0.
10801    ENDDO
10802
10803 !   vert_order_test : IF (vert_order == 6) THEN
10804
10805 !    ELSE IF (vert_order == 5) THEN
10806
10807       DO j = j_start, j_end
10808
10809          DO k=kts+3,ktf-2
10810          DO i = i_start, i_end
10811            vel=0.5*(rom(i-1,k,j)+rom(i,k,j))
10812
10813          IF( -vel .ge. 0.0 ) THEN
10814             qip2 = u(i,k+1,j)
10815             qip1 = u(i,k  ,j)
10816             qi   = u(i,k-1,j)
10817             qim1 = u(i,k-2,j)
10818             qim2 = u(i,k-3,j)
10819           ELSE
10820             qip2 = u(i,k-2,j)
10821             qip1 = u(i,k-1,j)
10822             qi   = u(i,k  ,j)
10823             qim1 = u(i,k+1,j)
10824             qim2 = u(i,k+2,j)
10825          ENDIF
10826
10827          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
10828          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
10829          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
10830
10831          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
10832          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
10833          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
10834
10835          wi0 = gi0 / (eps + beta0)**pw
10836          wi1 = gi1 / (eps + beta1)**pw
10837          wi2 = gi2 / (eps + beta2)**pw
10838
10839          sumwk = wi0 + wi1 + wi2
10840
10841           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
10842
10843 !           vflux(i,k) = vel*flux5(                     &
10844 !                   u(i,k-3,j), u(i,k-2,j), u(i,k-1,j),       &
10845 !                   u(i,k  ,j), u(i,k+1,j), u(i,k+2,j),  -vel )
10846          ENDDO
10847          ENDDO
10848
10849          DO i = i_start, i_end
10850
10851            k=kts+1
10852            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j))  &
10853                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
10854            k = kts+2
10855            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
10856            vflux(i,k) = vel*flux3(       &
10857                    u(i,k-2,j), u(i,k-1,j),   &
10858                    u(i,k  ,j), u(i,k+1,j), -vel )
10859            k = ktf-1
10860            vel=0.5*(rom(i,k,j)+rom(i-1,k,j))
10861            vflux(i,k) = vel*flux3(       &
10862                    u(i,k-2,j), u(i,k-1,j),   &
10863                    u(i,k  ,j), u(i,k+1,j), -vel )
10864            k=ktf
10865            vflux(i,k)=0.5*(rom(i,k,j)+rom(i-1,k,j)) &
10866                                    *(fzm(k)*u(i,k,j)+fzp(k)*u(i,k-1,j))
10867
10868          ENDDO
10869          DO k=kts,ktf
10870          DO i = i_start, i_end
10871             tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k))
10872          ENDDO
10873          ENDDO
10874       ENDDO
10875
10876
10877 END SUBROUTINE advect_weno_u
10878
10879 !-------------------------------------------------------------------------------
10880
10881 SUBROUTINE advect_weno_v   ( v, v_old, tendency,            &
10882                         ru, rv, rom,                   &
10883                         mut, time_step, config_flags,  &
10884                         msfux, msfuy, msfvx, msfvy,    &
10885                         msftx, msfty,                  &
10886                         fzm, fzp,                      &
10887                         rdx, rdy, rdzw,                &
10888                         ids, ide, jds, jde, kds, kde,  &
10889                         ims, ime, jms, jme, kms, kme,  &
10890                         its, ite, jts, jte, kts, kte  )
10891
10892 !
10893 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
10894 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
10895 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
10896 !
10897
10898    IMPLICIT NONE
10899
10900    ! Input data
10901
10902    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
10903
10904    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
10905                                               ims, ime, jms, jme, kms, kme, &
10906                                               its, ite, jts, jte, kts, kte
10907
10908    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: v,     &
10909                                                                       v_old, &
10910                                                                       ru,    &
10911                                                                       rv,    &
10912                                                                       rom
10913
10914    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
10915    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
10916
10917    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
10918                                                                     msfuy,  &
10919                                                                     msfvx,  &
10920                                                                     msfvy,  &
10921                                                                     msftx,  &
10922                                                                     msfty
10923
10924    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
10925                                                                   fzp,  &
10926                                                                   rdzw
10927
10928    REAL ,                                        INTENT(IN   ) :: rdx,  &
10929                                                                   rdy
10930    INTEGER ,                                     INTENT(IN   ) :: time_step
10931
10932
10933    ! Local data
10934
10935    INTEGER :: i, j, k, itf, jtf, ktf
10936    INTEGER :: i_start, i_end, j_start, j_end
10937    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
10938    INTEGER :: jmin, jmax, jp, jm, imin, imax
10939
10940     real            :: dir, vv
10941     real            :: ue,vs,vn,wb,wt
10942     real, parameter :: f30 =  7./12., f31 = 1./12.
10943     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
10944
10945
10946    integer kt,kb
10947
10948
10949     real               :: qim2, qim1, qi, qip1, qip2
10950     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
10951     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18
10952     integer, parameter :: pw = 2
10953
10954
10955    REAL    :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
10956    REAL , DIMENSION(its:ite, kts:kte) :: vflux
10957
10958
10959    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
10960    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
10961
10962    INTEGER :: horz_order
10963    INTEGER :: vert_order
10964
10965    LOGICAL :: degrade_xs, degrade_ys
10966    LOGICAL :: degrade_xe, degrade_ye
10967
10968    INTEGER :: jp1, jp0, jtmp
10969
10970
10971 ! definition of flux operators, 3rd, 4th, 5th or 6th order
10972
10973    REAL    :: flux3, flux4, flux5, flux6
10974    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
10975
10976    flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
10977           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
10978
10979    flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
10980            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
10981            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
10982
10983    flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
10984                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)   &
10985                      +(q_ip2+q_im3) )/60.0
10986
10987    flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
10988            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
10989             -sign(1,time_step)*sign(1.,ua)*(                    &
10990               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
10991
10992
10993
10994    LOGICAL :: specified
10995
10996    specified = .false.
10997    if(config_flags%specified .or. config_flags%nested) specified = .true.
10998
10999 ! set order for the advection schemes
11000
11001    ktf=MIN(kte,kde-1)
11002    horz_order = config_flags%h_mom_adv_order
11003    vert_order = config_flags%v_mom_adv_order
11004
11005
11006 !  here is the choice of flux operators
11007
11008
11009 !   horizontal_order_test : IF( horz_order == 6 ) THEN
11010 !   ELSE IF( horz_order == 5 ) THEN
11011
11012 !  5th order horizontal flux calculation
11013 !  This code is EXACTLY the same as the 6th order code
11014 !  EXCEPT the 5th order and 3rd operators are used in
11015 !  place of the 6th and 4th order operators
11016
11017 !  determine boundary mods for flux operators
11018 !  We degrade the flux operators from 3rd/4th order
11019 !   to second order one gridpoint in from the boundaries for
11020 !   all boundary conditions except periodic and symmetry - these
11021 !   conditions have boundary zone data fill for correct application
11022 !   of the higher order flux stencils
11023
11024    degrade_xs = .true.
11025    degrade_xe = .true.
11026    degrade_ys = .true.
11027    degrade_ye = .true.
11028
11029    IF( config_flags%periodic_x   .or. &
11030        config_flags%symmetric_xs .or. &
11031        (its > ids+3)                ) degrade_xs = .false.
11032    IF( config_flags%periodic_x   .or. &
11033        config_flags%symmetric_xe .or. &
11034        (ite < ide-3)                ) degrade_xe = .false.
11035    IF( config_flags%periodic_y   .or. &
11036        config_flags%symmetric_ys .or. &
11037        (jts > jds+3)                ) degrade_ys = .false.
11038    IF( config_flags%periodic_y   .or. &
11039        config_flags%symmetric_ye .or. &
11040        (jte < jde-3)                ) degrade_ye = .false.
11041
11042 !--------------- y - advection first
11043
11044       i_start = its
11045       i_end   = MIN(ite,ide-1)
11046       j_start = jts
11047       j_end   = jte
11048
11049 !  higher order flux has a 5 or 7 point stencil, so compute
11050 !  bounds so we can switch to second order flux close to the boundary
11051
11052       j_start_f = j_start
11053       j_end_f   = j_end+1
11054
11055       IF(degrade_ys) then
11056         j_start = MAX(jts,jds+1)
11057         j_start_f = jds+3
11058       ENDIF
11059
11060       IF(degrade_ye) then
11061         j_end = MIN(jte,jde-1)
11062         j_end_f = jde-2
11063       ENDIF
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
11073
11074         DO k=kts,ktf
11075         DO i = i_start, i_end
11076           vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
11077
11078          IF ( vel .ge. 0.0 ) THEN
11079             qip2 = v(i,k,j+1)
11080             qip1 = v(i,k,j  )
11081             qi   = v(i,k,j-1)
11082             qim1 = v(i,k,j-2)
11083             qim2 = v(i,k,j-3)
11084           ELSE
11085             qip2 = v(i,k,j-2)
11086             qip1 = v(i,k,j-1)
11087             qi   = v(i,k,j  )
11088             qim1 = v(i,k,j+1)
11089             qim2 = v(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
11109
11110 !          fqy( i, k, jp1 ) = vel*flux5(               &
11111 !                  v(i,k,j-3), v(i,k,j-2), v(i,k,j-1),       &
11112 !                  v(i,k,j  ), v(i,k,j+1), v(i,k,j+2),  vel )
11113         ENDDO
11114         ENDDO
11115
11116 !  we must be close to some boundary where we need to reduce the order of the stencil
11117 !  specified uses upstream normal wind at boundaries
11118
11119       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
11120
11121             DO k=kts,ktf
11122             DO i = i_start, i_end
11123                 vb = v(i,k,j-1)
11124                 IF (specified .AND. v(i,k,j) .LT. 0.)vb = v(i,k,j)
11125                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))  &
11126                                  *(v(i,k,j)+vb)
11127             ENDDO
11128             ENDDO
11129
11130      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
11131
11132             DO k=kts,ktf
11133             DO i = i_start, i_end
11134               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
11135               fqy( i, k, jp1 ) = vel*flux3(      &
11136                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
11137             ENDDO
11138             ENDDO
11139
11140
11141      ELSE IF ( j == jde ) THEN  ! 2nd order flux next to north boundary
11142
11143             DO k=kts,ktf
11144             DO i = i_start, i_end
11145                 vb = v(i,k,j)
11146                 IF (specified .AND. v(i,k,j-1) .GT. 0.)vb = v(i,k,j-1)
11147                 fqy(i, k, jp1) = 0.25*(rv(i,k,j)+rv(i,k,j-1))    &
11148                                  *(vb+v(i,k,j-1))
11149             ENDDO
11150             ENDDO
11151
11152      ELSE IF ( j == jde-1 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
11153
11154             DO k=kts,ktf
11155             DO i = i_start, i_end
11156               vel = 0.5*(rv(i,k,j)+rv(i,k,j-1))
11157               fqy( i, k, jp1 ) = vel*flux3(     &
11158                    v(i,k,j-2),v(i,k,j-1),v(i,k,j),v(i,k,j+1),vel )
11159             ENDDO
11160             ENDDO
11161
11162       END IF
11163
11164 !  y flux-divergence into tendency
11165
11166         ! Comments on polar boundary conditions
11167         ! No advection over the poles means tendencies (held from jds [S. pole]
11168         ! to jde [N pole], i.e., on v grid) must be zero at poles
11169         ! [tendency(jds) and tendency(jde)=0]
11170         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
11171           DO k=kts,ktf
11172           DO i = i_start, i_end
11173             tendency(i,k,j-1) = 0.
11174           END DO
11175           END DO
11176         ! If j_end were set to jde in a special if statement apart from
11177         ! degrade_ye, then we would hit the next conditional.  But since
11178         ! we want the tendency to be zero anyway, not looping to jde+1
11179         ! will produce the same effect.
11180         ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
11181           DO k=kts,ktf
11182           DO i = i_start, i_end
11183             tendency(i,k,j-1) = 0.
11184           END DO
11185           END DO
11186         ELSE  ! Normal code
11187
11188         IF(j > j_start) THEN
11189
11190           DO k=kts,ktf
11191           DO i = i_start, i_end
11192             mrdy=msfvy(i,j-1)*rdy    ! ADT eqn 45, 2nd term on RHS
11193             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
11194           ENDDO
11195           ENDDO
11196
11197         ENDIF
11198
11199         END IF
11200
11201         jtmp = jp1
11202         jp1 = jp0
11203         jp0 = jtmp
11204
11205    ENDDO j_loop_y_flux_5
11206
11207 !  next, x - flux divergence
11208
11209       i_start = its
11210       i_end   = MIN(ite,ide-1)
11211
11212       j_start = jts
11213       j_end   = jte
11214       ! Polar boundary conditions are like open or specified
11215       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
11216       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
11217
11218 !  higher order flux has a 5 or 7 point stencil, so compute
11219 !  bounds so we can switch to second order flux close to the boundary
11220
11221       i_start_f = i_start
11222       i_end_f   = i_end+1
11223
11224       IF(degrade_xs) then
11225         i_start = MAX(ids+1,its)
11226 !        i_start_f = i_start+2
11227         i_start_f = MIN(i_start+2,ids+3)
11228       ENDIF
11229
11230       IF(degrade_xe) then
11231         i_end = MIN(ide-2,ite)
11232         i_end_f = ide-3
11233       ENDIF
11234
11235 !  compute fluxes
11236
11237       DO j = j_start, j_end
11238
11239 !  5th or 6th order flux
11240
11241         DO k=kts,ktf
11242         DO i = i_start_f, i_end_f
11243           vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
11244
11245          IF ( vel .ge. 0.0 ) THEN
11246             qip2 = v(i+1,k,j)
11247             qip1 = v(i,  k,j)
11248             qi   = v(i-1,k,j)
11249             qim1 = v(i-2,k,j)
11250             qim2 = v(i-3,k,j)
11251           ELSE
11252             qip2 = v(i-2,k,j)
11253             qip1 = v(i-1,k,j)
11254             qi   = v(i,  k,j)
11255             qim1 = v(i+1,k,j)
11256             qim2 = v(i+2,k,j)
11257          ENDIF
11258
11259          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11260          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11261          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11262
11263          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11264          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11265          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11266
11267          wi0 = gi0 / (eps + beta0)**pw
11268          wi1 = gi1 / (eps + beta1)**pw
11269          wi2 = gi2 / (eps + beta2)**pw
11270
11271          sumwk = wi0 + wi1 + wi2
11272
11273          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11274
11275 !          fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j),  &
11276 !                                         v(i-1,k,j), v(i  ,k,j),  &
11277 !                                         v(i+1,k,j), v(i+2,k,j),  &
11278 !                                         vel                     )
11279         ENDDO
11280         ENDDO
11281
11282 !  lower order fluxes close to boundaries (if not periodic or symmetric)
11283
11284         IF( degrade_xs ) THEN
11285
11286           DO i=i_start,i_start_f-1
11287
11288             IF(i == ids+1) THEN ! second order
11289               DO k=kts,ktf
11290                 fqx(i,k) = 0.25*(ru(i,k,j)+ru(i,k,j-1)) &
11291                                 *(v(i,k,j)+v(i-1,k,j))
11292               ENDDO
11293             ENDIF
11294
11295             IF(i == ids+2) THEN  ! third order
11296               DO k=kts,ktf
11297                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
11298                 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
11299                                         v(i  ,k,j), v(i+1,k,j),  &
11300                                         vel                     )
11301               ENDDO
11302             ENDIF
11303
11304           ENDDO
11305
11306         ENDIF
11307
11308         IF( degrade_xe ) THEN
11309
11310           DO i = i_end_f+1, i_end+1
11311
11312             IF( i == ide-1 ) THEN ! second order flux next to the boundary
11313               DO k=kts,ktf
11314                 fqx(i,k) = 0.25*(ru(i_end+1,k,j)+ru(i_end+1,k,j-1))      &
11315                                 *(v(i_end+1,k,j)+v(i_end,k,j))
11316               ENDDO
11317             ENDIF
11318
11319             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
11320               DO k=kts,ktf
11321                 vel = 0.5*(ru(i,k,j)+ru(i,k,j-1))
11322                 fqx( i,k ) = vel*flux3( v(i-2,k,j), v(i-1,k,j),  &
11323                                         v(i  ,k,j), v(i+1,k,j),  &
11324                                         vel                     )
11325               ENDDO
11326             ENDIF
11327
11328           ENDDO
11329
11330         ENDIF
11331
11332 !  x flux-divergence into tendency
11333
11334         DO k=kts,ktf
11335           DO i = i_start, i_end
11336             mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
11337             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
11338           ENDDO
11339         ENDDO
11340
11341       ENDDO
11342
11343
11344    !  Comments on polar boundary condition
11345    !  Force tendency=0 at NP and SP
11346    !  We keep setting this everywhere, but it can't hurt...
11347    IF ( config_flags%polar .AND. (jts == jds) ) THEN
11348       DO i=its,ite
11349       DO k=kts,ktf
11350          tendency(i,k,jts)=0.
11351       END DO
11352       END DO
11353    END IF
11354    IF ( config_flags%polar .AND. (jte == jde) ) THEN
11355       DO i=its,ite
11356       DO k=kts,ktf
11357          tendency(i,k,jte)=0.
11358       END DO
11359       END DO
11360    END IF
11361
11362 !  radiative lateral boundary condition in y for normal velocity (v)
11363
11364       IF ( (config_flags%open_ys) .and. jts == jds ) THEN
11365
11366         i_start = its
11367         i_end   = MIN(ite,ide-1)
11368
11369         DO i = i_start, i_end
11370         DO k = kts, ktf
11371           vb = MIN(rv(i,k,jts)-cb*mut(i,jts), 0.)
11372           tendency(i,k,jts) = tendency(i,k,jts)                    &
11373                       - rdy*vb*(v_old(i,k,jts+1) - v_old(i,k,jts))
11374         ENDDO
11375         ENDDO
11376
11377       ENDIF
11378
11379       IF ( (config_flags%open_ye) .and. jte == jde ) THEN
11380
11381         i_start = its
11382         i_end   = MIN(ite,ide-1)
11383
11384         DO i = i_start, i_end
11385         DO k = kts, ktf
11386           vb = MAX(rv(i,k,jte)+cb*mut(i,jte-1), 0.)
11387           tendency(i,k,jte) = tendency(i,k,jte)                    &
11388                       - rdy*vb*(v_old(i,k,jte) - v_old(i,k,jte-1))
11389         ENDDO
11390         ENDDO
11391
11392       ENDIF
11393
11394 !  pick up the rest of the horizontal radiation boundary conditions.
11395 !  (these are the computations that don't require 'cb'.
11396 !  first, set to index ranges
11397
11398       j_start = jts
11399       j_end   = MIN(jte,jde)
11400
11401       jmin    = jds
11402       jmax    = jde-1
11403
11404       IF (config_flags%open_ys) THEN
11405           j_start = MAX(jds+1, jts)
11406           jmin = jds
11407       ENDIF
11408       IF (config_flags%open_ye) THEN
11409           j_end = MIN(jte,jde-1)
11410           jmax = jde-1
11411       ENDIF
11412
11413 !  compute x (u) conditions for v, w, or scalar
11414
11415    IF( (config_flags%open_xs) .and. (its == ids)) THEN
11416
11417       DO j = j_start, j_end
11418
11419          mrdx=msfvy(its,j)*rdx       ! ADT eqn 45, 1st term on RHS
11420          jp = MIN( jmax, j   )
11421          jm = MAX( jmin, j-1 )
11422
11423          DO k=kts,ktf
11424
11425           uw = 0.5*(ru(its,k,jp)+ru(its,k,jm))
11426           ub = MIN( uw, 0. )
11427           dup =  ru(its+1,k,jp)-ru(its,k,jp)
11428           dum =  ru(its+1,k,jm)-ru(its,k,jm)
11429           tendency(its,k,j)=tendency(its,k,j)-mrdx*(               &
11430                             ub*(v_old(its+1,k,j)-v_old(its,k,j))   &
11431                            +0.5*v(its,k,j)*(dup+dum))
11432          ENDDO
11433       ENDDO
11434
11435    ENDIF
11436
11437    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
11438       DO j = j_start, j_end
11439
11440          mrdx=msfvy(ite-1,j)*rdx     ! ADT eqn 45, 1st term on RHS
11441          jp = MIN( jmax, j   )
11442          jm = MAX( jmin, j-1 )
11443
11444          DO k=kts,ktf
11445
11446           uw = 0.5*(ru(ite,k,jp)+ru(ite,k,jm))
11447           ub = MAX( uw, 0. )
11448           dup = ru(ite,k,jp)-ru(ite-1,k,jp)
11449           dum = ru(ite,k,jm)-ru(ite-1,k,jm)
11450
11451 !          tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
11452 !                            ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
11453 !                           +0.5*v(ite-1,k,j)*                         &
11454 !                                  ( ru(ite,k,jp)-ru(ite-1,k,jp)       &
11455 !                                   +ru(ite,k,jm)-ru(ite-1,k,jm))     )
11456           tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
11457                             ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
11458                            +0.5*v(ite-1,k,j)*(dup+dum))
11459
11460          ENDDO
11461       ENDDO
11462
11463    ENDIF
11464
11465 !-------------------- vertical advection
11466 !     ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
11467 !     Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
11468 !     We therefore need to make a correction for advect_v
11469 !     since 'my' (map scale factor in y direction) isn't a function of z,
11470 !     we can do this using *(my/mx) (see eqn. 45 for example)
11471
11472
11473       i_start = its
11474       i_end   = MIN(ite,ide-1)
11475       j_start = jts
11476       j_end   = jte
11477
11478       DO i = i_start, i_end
11479          vflux(i,kts)=0.
11480          vflux(i,kte)=0.
11481       ENDDO
11482
11483       ! Polar boundary conditions are like open or specified
11484       ! We don't want to calculate vertical v tendencies at the N or S pole
11485       IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
11486       IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-1,jte)
11487
11488 !    vert_order_test : IF (vert_order == 6) THEN
11489
11490 !   ELSE IF (vert_order == 5) THEN
11491
11492       DO j = j_start, j_end
11493
11494
11495          DO k=kts+3,ktf-2
11496          DO i = i_start, i_end
11497            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
11498
11499          IF( -vel .ge. 0.0 ) THEN
11500             qip2 = v(i,k+1,j)
11501             qip1 = v(i,k  ,j)
11502             qi   = v(i,k-1,j)
11503             qim1 = v(i,k-2,j)
11504             qim2 = v(i,k-3,j)
11505           ELSE
11506             qip2 = v(i,k-2,j)
11507             qip1 = v(i,k-1,j)
11508             qi   = v(i,k  ,j)
11509             qim1 = v(i,k+1,j)
11510             qim2 = v(i,k+2,j)
11511          ENDIF
11512
11513          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11514          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11515          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11516
11517          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11518          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11519          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11520
11521          wi0 = gi0 / (eps + beta0)**pw
11522          wi1 = gi1 / (eps + beta1)**pw
11523          wi2 = gi2 / (eps + beta2)**pw
11524
11525          sumwk = wi0 + wi1 + wi2
11526
11527           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11528
11529
11530 !           vflux(i,k) = vel*flux5(                       &
11531 !                   v(i,k-3,j), v(i,k-2,j), v(i,k-1,j),       &
11532 !                   v(i,k  ,j), v(i,k+1,j), v(i,k+2,j),  -vel )
11533          ENDDO
11534          ENDDO
11535
11536          DO i = i_start, i_end
11537            k=kts+1
11538            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1))  &
11539                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
11540            k = kts+2
11541            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
11542            vflux(i,k) = vel*flux3(       &
11543                    v(i,k-2,j), v(i,k-1,j),   &
11544                    v(i,k  ,j), v(i,k+1,j), -vel )
11545            k = ktf-1
11546            vel=0.5*(rom(i,k,j)+rom(i,k,j-1))
11547            vflux(i,k) = vel*flux3(       &
11548                    v(i,k-2,j), v(i,k-1,j),   &
11549                    v(i,k  ,j), v(i,k+1,j), -vel )
11550            k=ktf
11551            vflux(i,k)=0.5*(rom(i,k,j)+rom(i,k,j-1)) &
11552                                    *(fzm(k)*v(i,k,j)+fzp(k)*v(i,k-1,j))
11553
11554          ENDDO
11555
11556
11557          DO k=kts,ktf
11558          DO i = i_start, i_end
11559             ! We are calculating vertical fluxes on v points,
11560             ! so we must mean msf_v_x/y variables
11561             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
11562          ENDDO
11563          ENDDO
11564
11565       ENDDO
11566
11567
11568 END SUBROUTINE advect_weno_v
11569
11570
11571 !---------------------------------------------------------------------------------
11572
11573 SUBROUTINE advect_weno_w    ( w, w_old, tendency,            &
11574                          ru, rv, rom,                   &
11575                          mut, time_step, config_flags,  &
11576                          msfux, msfuy, msfvx, msfvy,    &
11577                          msftx, msfty,                  &
11578                          fzm, fzp,                      &
11579                          rdx, rdy, rdzu,                &
11580                          ids, ide, jds, jde, kds, kde,  &
11581                          ims, ime, jms, jme, kms, kme,  &
11582                          its, ite, jts, jte, kts, kte  )
11583
11584 !
11585 ! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS.
11586 ! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223;
11587 ! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118;  Also used by Bryan 2005, Mon. Wea. Rev.
11588 !
11589
11590    IMPLICIT NONE
11591
11592    ! Input data
11593
11594    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
11595
11596    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
11597                                               ims, ime, jms, jme, kms, kme, &
11598                                               its, ite, jts, jte, kts, kte
11599
11600    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: w,     &
11601                                                                       w_old, &
11602                                                                       ru,    &
11603                                                                       rv,    &
11604                                                                       rom
11605
11606    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut
11607    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
11608
11609    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
11610                                                                     msfuy,  &
11611                                                                     msfvx,  &
11612                                                                     msfvy,  &
11613                                                                     msftx,  &
11614                                                                     msfty
11615
11616    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
11617                                                                   fzp,  &
11618                                                                   rdzu
11619
11620    REAL ,                                        INTENT(IN   ) :: rdx,  &
11621                                                                   rdy
11622    INTEGER ,                                     INTENT(IN   ) :: time_step
11623
11624
11625    ! Local data
11626
11627    INTEGER :: i, j, k, itf, jtf, ktf
11628    INTEGER :: i_start, i_end, j_start, j_end
11629    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
11630    INTEGER :: jmin, jmax, jp, jm, imin, imax
11631
11632    REAL    :: mrdx, mrdy, ub, vb, uw, vw
11633    REAL , DIMENSION(its:ite, kts:kte) :: vflux
11634
11635     real            :: dir, vv
11636     real            :: ue,vs,vn,wb,wt
11637     real, parameter :: f30 =  7./12., f31 = 1./12.
11638     real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60.
11639
11640
11641    integer kt,kb
11642
11643
11644     real               :: qim2, qim1, qi, qip1, qip2
11645     double precision               :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk
11646     double precision, parameter    :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-18
11647     integer, parameter :: pw = 2
11648
11649
11650
11651    INTEGER :: horz_order, vert_order
11652
11653    REAL,  DIMENSION( its:ite+1, kts:kte ) :: fqx
11654    REAL,  DIMENSION( its:ite, kts:kte, 2 ) :: fqy
11655
11656    LOGICAL :: degrade_xs, degrade_ys
11657    LOGICAL :: degrade_xe, degrade_ye
11658
11659    INTEGER :: jp1, jp0, jtmp
11660
11661 ! definition of flux operators, 3rd, 4th, 5th or 6th order
11662
11663    REAL    :: flux3, flux4, flux5, flux6
11664    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
11665
11666       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
11667           ( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
11668
11669       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
11670            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
11671            sign(1,time_step)*sign(1.,ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0
11672
11673       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
11674                       ( 37.*(q_i+q_im1) - 8.*(q_ip1+q_im2)      &
11675                      +(q_ip2+q_im3) )/60.0
11676
11677       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
11678            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
11679             -sign(1,time_step)*sign(1.,ua)*(                    &
11680               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )/60.0
11681
11682
11683    LOGICAL :: specified
11684
11685    specified = .false.
11686    if(config_flags%specified .or. config_flags%nested) specified = .true.
11687
11688 !  set order for the advection scheme
11689
11690   ktf=MIN(kte,kde-1)
11691   horz_order = config_flags%h_sca_adv_order
11692   vert_order = config_flags%v_sca_adv_order
11693
11694 !  here is the choice of flux operators
11695
11696 !  begin with horizontal flux divergence
11697
11698 !  horizontal_order_test : IF( horz_order == 6 ) THEN
11699 ! ELSE IF (horz_order == 5 ) THEN
11700
11701 !  determine boundary mods for flux operators
11702 !  We degrade the flux operators from 3rd/4th order
11703 !   to second order one gridpoint in from the boundaries for
11704 !   all boundary conditions except periodic and symmetry - these
11705 !   conditions have boundary zone data fill for correct application
11706 !   of the higher order flux stencils
11707
11708    degrade_xs = .true.
11709    degrade_xe = .true.
11710    degrade_ys = .true.
11711    degrade_ye = .true.
11712
11713    IF( config_flags%periodic_x   .or. &
11714        config_flags%symmetric_xs .or. &
11715        (its > ids+3)                ) degrade_xs = .false.
11716    IF( config_flags%periodic_x   .or. &
11717        config_flags%symmetric_xe .or. &
11718        (ite < ide-3)                ) degrade_xe = .false.
11719    IF( config_flags%periodic_y   .or. &
11720        config_flags%symmetric_ys .or. &
11721        (jts > jds+3)                ) degrade_ys = .false.
11722    IF( config_flags%periodic_y   .or. &
11723        config_flags%symmetric_ye .or. &
11724        (jte < jde-4)                ) degrade_ye = .false.
11725
11726 !--------------- y - advection first
11727
11728       i_start = its
11729       i_end   = MIN(ite,ide-1)
11730       j_start = jts
11731       j_end   = MIN(jte,jde-1)
11732
11733 !  higher order flux has a 5 or 7 point stencil, so compute
11734 !  bounds so we can switch to second order flux close to the boundary
11735
11736       j_start_f = j_start
11737       j_end_f   = j_end+1
11738
11739       IF(degrade_ys) then
11740         j_start = MAX(jts,jds+1)
11741         j_start_f = jds+3
11742       ENDIF
11743
11744       IF(degrade_ye) then
11745         j_end = MIN(jte,jde-2)
11746         j_end_f = jde-3
11747       ENDIF
11748
11749       IF(config_flags%polar) j_end = MIN(jte,jde-1)
11750
11751 !  compute fluxes, 5th or 6th order
11752
11753      jp1 = 2
11754      jp0 = 1
11755
11756      j_loop_y_flux_5 : DO j = j_start, j_end+1
11757
11758       IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
11759
11760         DO k=kts+1,ktf
11761         DO i = i_start, i_end
11762           vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
11763
11764          IF ( vel .ge. 0.0 ) THEN
11765             qip2 = w(i,k,j+1)
11766             qip1 = w(i,k,j  )
11767             qi   = w(i,k,j-1)
11768             qim1 = w(i,k,j-2)
11769             qim2 = w(i,k,j-3)
11770           ELSE
11771             qip2 = w(i,k,j-2)
11772             qip1 = w(i,k,j-1)
11773             qi   = w(i,k,j  )
11774             qim1 = w(i,k,j+1)
11775             qim2 = w(i,k,j+2)
11776          ENDIF
11777
11778          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11779          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11780          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11781
11782          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11783          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11784          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11785
11786          wi0 = gi0 / (eps + beta0)**pw
11787          wi1 = gi1 / (eps + beta1)**pw
11788          wi2 = gi2 / (eps + beta2)**pw
11789
11790          sumwk = wi0 + wi1 + wi2
11791
11792           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11793
11794 !          fqy( i, k, jp1 ) = vel*flux5(                     &
11795 !                  w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
11796 !                  w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
11797         ENDDO
11798         ENDDO
11799
11800         k = ktf+1
11801         DO i = i_start, i_end
11802           vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
11803
11804          IF ( vel .ge. 0.0 ) THEN
11805             qip2 = w(i,k,j+1)
11806             qip1 = w(i,k,j  )
11807             qi   = w(i,k,j-1)
11808             qim1 = w(i,k,j-2)
11809             qim2 = w(i,k,j-3)
11810           ELSE
11811             qip2 = w(i,k,j-2)
11812             qip1 = w(i,k,j-1)
11813             qi   = w(i,k,j  )
11814             qim1 = w(i,k,j+1)
11815             qim2 = w(i,k,j+2)
11816          ENDIF
11817
11818          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11819          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11820          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
11821
11822          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
11823          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
11824          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
11825
11826          wi0 = gi0 / (eps + beta0)**pw
11827          wi1 = gi1 / (eps + beta1)**pw
11828          wi2 = gi2 / (eps + beta2)**pw
11829
11830          sumwk = wi0 + wi1 + wi2
11831
11832           fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
11833
11834 !          fqy( i, k, jp1 ) = vel*flux5(                     &
11835 !                  w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
11836 !                  w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
11837         ENDDO
11838
11839       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
11840
11841             DO k=kts+1,ktf
11842             DO i = i_start, i_end
11843               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*          &
11844                      (w(i,k,j)+w(i,k,j-1))
11845             ENDDO
11846             ENDDO
11847
11848             k = ktf+1
11849             DO i = i_start, i_end
11850               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*          &
11851                      (w(i,k,j)+w(i,k,j-1))
11852             ENDDO
11853
11854      ELSE IF  ( j == jds+2 ) THEN  ! third of 4th order flux 2 in from south boundary
11855
11856             DO k=kts+1,ktf
11857             DO i = i_start, i_end
11858               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
11859               fqy( i, k, jp1 ) = vel*flux3(              &
11860                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
11861             ENDDO
11862             ENDDO
11863
11864             k = ktf+1
11865             DO i = i_start, i_end
11866               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
11867               fqy( i, k, jp1 ) = vel*flux3(              &
11868                    w(i,k,j-2),w(i,k,j-1),w(i,k,j),w(i,k,j+1),vel )
11869             ENDDO
11870
11871      ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
11872
11873             DO k=kts+1,ktf
11874             DO i = i_start, i_end
11875               fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j))*      &
11876                      (w(i,k,j)+w(i,k,j-1))
11877             ENDDO
11878             ENDDO
11879
11880             k = ktf+1
11881             DO i = i_start, i_end
11882               fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j))*      &
11883                      (w(i,k,j)+w(i,k,j-1))
11884             ENDDO
11885
11886      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4th order flux 2 in from north boundary
11887
11888             DO k=kts+1,ktf
11889             DO i = i_start, i_end
11890               vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j)
11891               fqy( i, k, jp1 ) = vel*flux3(             &
11892                    w(i,k,j-2),w(i,k,j-1),    &
11893                    w(i,k,j),w(i,k,j+1),vel )
11894             ENDDO
11895             ENDDO
11896
11897             k = ktf+1
11898             DO i = i_start, i_end
11899               vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j)
11900               fqy( i, k, jp1 ) = vel*flux3(             &
11901                    w(i,k,j-2),w(i,k,j-1),    &
11902                    w(i,k,j),w(i,k,j+1),vel )
11903             ENDDO
11904
11905      ENDIF
11906
11907 !  y flux-divergence into tendency
11908
11909         ! Comments for polar boundary conditions
11910         ! Same process as for advect_u - tendencies run from jds to jde-1
11911         ! (latitudes are as for u grid, longitudes are displaced)
11912         ! Therefore: flow is only from one side for points next to poles
11913         IF ( config_flags%polar .AND. (j == jds+1) ) THEN
11914           DO k=kts,ktf
11915           DO i = i_start, i_end
11916             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
11917             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
11918           END DO
11919           END DO
11920         ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
11921           DO k=kts,ktf
11922           DO i = i_start, i_end
11923             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
11924             tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
11925           END DO
11926           END DO
11927         ELSE  ! normal code
11928
11929         IF(j > j_start) THEN
11930
11931           DO k=kts+1,ktf+1
11932           DO i = i_start, i_end
11933             mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
11934             tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
11935           ENDDO
11936           ENDDO
11937
11938        ENDIF
11939
11940         END IF
11941
11942         jtmp = jp1
11943         jp1 = jp0
11944         jp0 = jtmp
11945
11946       ENDDO j_loop_y_flux_5
11947
11948 !  next, x - flux divergence
11949
11950       i_start = its
11951       i_end   = MIN(ite,ide-1)
11952
11953       j_start = jts
11954       j_end   = MIN(jte,jde-1)
11955
11956 !  higher order flux has a 5 or 7 point stencil, so compute
11957 !  bounds so we can switch to second order flux close to the boundary
11958
11959       i_start_f = i_start
11960       i_end_f   = i_end+1
11961
11962       IF(degrade_xs) then
11963         i_start = MAX(ids+1,its)
11964 !        i_start_f = i_start+2
11965         i_start_f = MIN(i_start+2,ids+3)
11966       ENDIF
11967
11968       IF(degrade_xe) then
11969         i_end = MIN(ide-2,ite)
11970         i_end_f = ide-3
11971       ENDIF
11972
11973 !  compute fluxes
11974
11975       DO j = j_start, j_end
11976
11977 !  5th or 6th order flux
11978
11979         DO k=kts+1,ktf
11980         DO i = i_start_f, i_end_f
11981           vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
11982
11983          IF ( vel .ge. 0.0 ) THEN
11984             qip2 = w(i+1,k,j)
11985             qip1 = w(i,  k,j)
11986             qi   = w(i-1,k,j)
11987             qim1 = w(i-2,k,j)
11988             qim2 = w(i-3,k,j)
11989           ELSE
11990             qip2 = w(i-2,k,j)
11991             qip1 = w(i-1,k,j)
11992             qi   = w(i,  k,j)
11993             qim1 = w(i+1,k,j)
11994             qim2 = w(i+2,k,j)
11995          ENDIF
11996
11997          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
11998          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
11999          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12000
12001          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12002          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12003          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12004
12005          wi0 = gi0 / (eps + beta0)**pw
12006          wi1 = gi1 / (eps + beta1)**pw
12007          wi2 = gi2 / (eps + beta2)**pw
12008
12009          sumwk = wi0 + wi1 + wi2
12010
12011          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12012
12013 !          fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
12014 !                                  w(i-1,k,j), w(i  ,k,j),  &
12015 !                                  w(i+1,k,j), w(i+2,k,j),  &
12016 !                                  vel                     )
12017         ENDDO
12018         ENDDO
12019
12020         k = ktf+1
12021         DO i = i_start_f, i_end_f
12022           vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
12023
12024          IF ( vel .ge. 0.0 ) THEN
12025             qip2 = w(i+1,k,j)
12026             qip1 = w(i,  k,j)
12027             qi   = w(i-1,k,j)
12028             qim1 = w(i-2,k,j)
12029             qim2 = w(i-3,k,j)
12030           ELSE
12031             qip2 = w(i-2,k,j)
12032             qip1 = w(i-1,k,j)
12033             qi   = w(i,  k,j)
12034             qim1 = w(i+1,k,j)
12035             qim2 = w(i+2,k,j)
12036          ENDIF
12037
12038          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12039          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12040          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12041
12042          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12043          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12044          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12045
12046          wi0 = gi0 / (eps + beta0)**pw
12047          wi1 = gi1 / (eps + beta1)**pw
12048          wi2 = gi2 / (eps + beta2)**pw
12049
12050          sumwk = wi0 + wi1 + wi2
12051
12052          fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12053
12054 !          fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
12055 !                                  w(i-1,k,j), w(i  ,k,j),  &
12056 !                                  w(i+1,k,j), w(i+2,k,j),  &
12057 !                                  vel                     )
12058         ENDDO
12059
12060 !  lower order fluxes close to boundaries (if not periodic or symmetric)
12061
12062         IF( degrade_xs ) THEN
12063
12064           DO i=i_start,i_start_f-1
12065
12066             IF(i == ids+1) THEN ! second order
12067               DO k=kts+1,ktf
12068                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)) &
12069                                 *(w(i,k,j)+w(i-1,k,j))
12070               ENDDO
12071               k = ktf+1
12072               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)) &
12073                      *(w(i,k,j)+w(i-1,k,j))
12074             ENDIF
12075
12076             IF(i == ids+2) THEN  ! third order
12077               DO k=kts+1,ktf
12078                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
12079                 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12080                                         w(i  ,k,j), w(i+1,k,j),  &
12081                                         vel                     )
12082               ENDDO
12083               k = ktf+1
12084               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
12085               fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12086                                       w(i  ,k,j), w(i+1,k,j),  &
12087                                       vel                     )
12088             END IF
12089
12090           ENDDO
12091
12092         ENDIF
12093
12094         IF( degrade_xe ) THEN
12095
12096           DO i = i_end_f+1, i_end+1
12097
12098             IF( i == ide-1 ) THEN ! second order flux next to the boundary
12099               DO k=kts+1,ktf
12100                 fqx(i,k) = 0.5*(fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j))      &
12101                                   *(w(i,k,j)+w(i-1,k,j))
12102               ENDDO
12103               k = ktf+1
12104               fqx(i,k) = 0.5*((2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j))      &
12105                      *(w(i,k,j)+w(i-1,k,j))
12106             ENDIF
12107
12108             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
12109               DO k=kts+1,ktf
12110                 vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j)
12111                 fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12112                                         w(i  ,k,j), w(i+1,k,j),  &
12113                                         vel                     )
12114               ENDDO
12115               k = ktf+1
12116               vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j)
12117               fqx( i,k ) = vel*flux3( w(i-2,k,j), w(i-1,k,j),  &
12118                                       w(i  ,k,j), w(i+1,k,j),  &
12119                                       vel                     )
12120             ENDIF
12121
12122           ENDDO
12123
12124         ENDIF
12125
12126 !  x flux-divergence into tendency
12127
12128         DO k=kts+1,ktf+1
12129           DO i = i_start, i_end
12130             mrdx=msftx(i,j)*rdx      ! see ADT eqn 46 dividing by my, 1st term RHS
12131             tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k))
12132           ENDDO
12133         ENDDO
12134
12135       ENDDO
12136
12137
12138 !  pick up the the horizontal radiation boundary conditions.
12139 !  (these are the computations that don't require 'cb'.
12140 !  first, set to index ranges
12141
12142
12143       i_start = its
12144       i_end   = MIN(ite,ide-1)
12145       j_start = jts
12146       j_end   = MIN(jte,jde-1)
12147
12148    IF( (config_flags%open_xs) .and. (its == ids)) THEN
12149
12150        DO j = j_start, j_end
12151        DO k = kts+1, ktf
12152
12153          uw = 0.5*(fzm(k)*(ru(its,k  ,j)+ru(its+1,k  ,j)) +  &
12154                    fzp(k)*(ru(its,k-1,j)+ru(its+1,k-1,j))   )
12155          ub = MIN( uw, 0. )
12156
12157          tendency(its,k,j) = tendency(its,k,j)                     &
12158                - rdx*(                                             &
12159                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
12160                        w(its,k,j)*(                                &
12161                        fzm(k)*(ru(its+1,k  ,j)-ru(its,k  ,j))+     &
12162                        fzp(k)*(ru(its+1,k-1,j)-ru(its,k-1,j)))     &
12163                                                                   )
12164        ENDDO
12165        ENDDO
12166
12167        k = ktf+1
12168        DO j = j_start, j_end
12169
12170          uw = 0.5*( (2.-fzm(k-1))*(ru(its,k-1,j)+ru(its+1,k-1,j))   &
12171                    -fzp(k-1)*(ru(its,k-2,j)+ru(its+1,k-2,j))   )
12172          ub = MIN( uw, 0. )
12173
12174          tendency(its,k,j) = tendency(its,k,j)                     &
12175                - rdx*(                                             &
12176                        ub*(w_old(its+1,k,j) - w_old(its,k,j)) +    &
12177                        w(its,k,j)*(                                &
12178                              (2.-fzm(k-1))*(ru(its+1,k-1,j)-ru(its,k-1,j))-  &
12179                              fzp(k-1)*(ru(its+1,k-2,j)-ru(its,k-2,j)))  &
12180                                                                   )
12181        ENDDO
12182
12183    ENDIF
12184
12185    IF( (config_flags%open_xe) .and. (ite == ide)) THEN
12186
12187        DO j = j_start, j_end
12188        DO k = kts+1, ktf
12189
12190          uw = 0.5*(fzm(k)*(ru(ite-1,k  ,j)+ru(ite,k  ,j)) +  &
12191                    fzp(k)*(ru(ite-1,k-1,j)+ru(ite,k-1,j))   )
12192          ub = MAX( uw, 0. )
12193
12194          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
12195                - rdx*(                                                 &
12196                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
12197                        w(i_end,k,j)*(                                  &
12198                             fzm(k)*(ru(ite,k  ,j)-ru(ite-1,k  ,j)) +   &
12199                             fzp(k)*(ru(ite,k-1,j)-ru(ite-1,k-1,j)))    &
12200                                                                     )
12201        ENDDO
12202        ENDDO
12203
12204        k = ktf+1
12205        DO j = j_start, j_end
12206
12207          uw = 0.5*( (2.-fzm(k-1))*(ru(ite-1,k-1,j)+ru(ite,k-1,j))    &
12208                    -fzp(k-1)*(ru(ite-1,k-2,j)+ru(ite,k-2,j))   )
12209          ub = MAX( uw, 0. )
12210
12211          tendency(i_end,k,j) = tendency(i_end,k,j)                     &
12212                - rdx*(                                                 &
12213                        ub*(w_old(i_end,k,j) - w_old(i_end-1,k,j)) +    &
12214                        w(i_end,k,j)*(                                  &
12215                                (2.-fzm(k-1))*(ru(ite,k-1,j)-ru(ite-1,k-1,j)) -   &
12216                                fzp(k-1)*(ru(ite,k-2,j)-ru(ite-1,k-2,j)))    &
12217                                                                     )
12218        ENDDO
12219
12220    ENDIF
12221
12222
12223    IF( (config_flags%open_ys) .and. (jts == jds)) THEN
12224
12225        DO i = i_start, i_end
12226        DO k = kts+1, ktf
12227
12228          vw = 0.5*( fzm(k)*(rv(i,k  ,jts)+rv(i,k  ,jts+1)) +  &
12229                     fzp(k)*(rv(i,k-1,jts)+rv(i,k-1,jts+1))   )
12230          vb = MIN( vw, 0. )
12231
12232          tendency(i,k,jts) = tendency(i,k,jts)                     &
12233                - rdy*(                                             &
12234                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
12235                        w(i,k,jts)*(                                &
12236                        fzm(k)*(rv(i,k  ,jts+1)-rv(i,k  ,jts))+     &
12237                        fzp(k)*(rv(i,k-1,jts+1)-rv(i,k-1,jts)))     &
12238                                                                 )
12239        ENDDO
12240        ENDDO
12241
12242        k = ktf+1
12243        DO i = i_start, i_end
12244          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jts)+rv(i,k-1,jts+1))    &
12245                    -fzp(k-1)*(rv(i,k-2,jts)+rv(i,k-2,jts+1))   )
12246          vb = MIN( vw, 0. )
12247
12248          tendency(i,k,jts) = tendency(i,k,jts)                     &
12249                - rdy*(                                             &
12250                        vb*(w_old(i,k,jts+1) - w_old(i,k,jts)) +    &
12251                        w(i,k,jts)*(                                &
12252                           (2.-fzm(k-1))*(rv(i,k-1,jts+1)-rv(i,k-1,jts))-     &
12253                           fzp(k-1)*(rv(i,k-2,jts+1)-rv(i,k-2,jts)))     &
12254                                                                 )
12255        ENDDO
12256
12257    ENDIF
12258
12259    IF( (config_flags%open_ye) .and. (jte == jde) ) THEN
12260
12261        DO i = i_start, i_end
12262        DO k = kts+1, ktf
12263
12264          vw = 0.5*( fzm(k)*(rv(i,k  ,jte-1)+rv(i,k  ,jte)) +  &
12265                     fzp(k)*(rv(i,k-1,jte-1)+rv(i,k-1,jte))   )
12266          vb = MAX( vw, 0. )
12267
12268          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
12269                - rdy*(                                                 &
12270                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
12271                        w(i,k,j_end)*(                                  &
12272                             fzm(k)*(rv(i,k  ,jte)-rv(i,k  ,jte-1))+    &
12273                             fzp(k)*(rv(i,k-1,jte)-rv(i,k-1,jte-1)))    &
12274                                                                       )
12275        ENDDO
12276        ENDDO
12277
12278        k = ktf+1
12279        DO i = i_start, i_end
12280
12281          vw = 0.5*( (2.-fzm(k-1))*(rv(i,k-1,jte-1)+rv(i,k-1,jte))    &
12282                    -fzp(k-1)*(rv(i,k-2,jte-1)+rv(i,k-2,jte))   )
12283          vb = MAX( vw, 0. )
12284
12285          tendency(i,k,j_end) = tendency(i,k,j_end)                     &
12286                - rdy*(                                                 &
12287                        vb*(w_old(i,k,j_end) - w_old(i,k,j_end-1)) +    &
12288                        w(i,k,j_end)*(                                  &
12289                                (2.-fzm(k-1))*(rv(i,k-1,jte)-rv(i,k-1,jte-1))-    &
12290                                fzp(k-1)*(rv(i,k-2,jte)-rv(i,k-2,jte-1)))    &
12291                                                                       )
12292        ENDDO
12293
12294    ENDIF
12295
12296 !-------------------- vertical advection
12297 !     ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
12298 !     Here we have:  - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
12299 !     Therefore we don't need to make a correction for advect_w
12300
12301       i_start = its
12302       i_end   = MIN(ite,ide-1)
12303       j_start = jts
12304       j_end   = MIN(jte,jde-1)
12305
12306       DO i = i_start, i_end
12307          vflux(i,kts)=0.
12308          vflux(i,kte)=0.
12309       ENDDO
12310
12311 !    vert_order_test : IF (vert_order == 6) THEN
12312
12313 ! ELSE IF (vert_order == 5) THEN
12314
12315       DO j = j_start, j_end
12316
12317          DO k=kts+3,ktf-1
12318          DO i = i_start, i_end
12319            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
12320
12321          IF( -vel .ge. 0.0 ) THEN
12322             qip2 = w(i,k+1,j)
12323             qip1 = w(i,k  ,j)
12324             qi   = w(i,k-1,j)
12325             qim1 = w(i,k-2,j)
12326             qim2 = w(i,k-3,j)
12327           ELSE
12328             qip2 = w(i,k-2,j)
12329             qip1 = w(i,k-1,j)
12330             qi   = w(i,k  ,j)
12331             qim1 = w(i,k+1,j)
12332             qim2 = w(i,k+2,j)
12333          ENDIF
12334
12335          f0 =  1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12336          f1 = -1./6.*qim1 + 5./6.*qi   + 1./3. *qip1
12337          f2 =  1./3.*qi   + 5./6.*qip1 - 1./6. *qip2
12338
12339          beta0 = 13./12.*(qim2 - 2.*qim1 + qi  )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2
12340          beta1 = 13./12.*(qim1 - 2.*qi   + qip1)**2 + 1./4.*(qim1 - qip1)**2
12341          beta2 = 13./12.*(qi   - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2
12342
12343          wi0 = gi0 / (eps + beta0)**pw
12344          wi1 = gi1 / (eps + beta1)**pw
12345          wi2 = gi2 / (eps + beta2)**pw
12346
12347          sumwk = wi0 + wi1 + wi2
12348
12349           vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk
12350
12351 !           vflux(i,k) = vel*flux5(                                   &
12352 !                   w(i,k-3,j), w(i,k-2,j), w(i,k-1,j),       &
12353 !                   w(i,k  ,j), w(i,k+1,j), w(i,k+2,j),  -vel )
12354          ENDDO
12355          ENDDO
12356
12357          DO i = i_start, i_end
12358
12359            k=kts+1
12360            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
12361
12362            k = kts+2
12363            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
12364            vflux(i,k) = vel*flux3(               &
12365                    w(i,k-2,j), w(i,k-1,j),   &
12366                    w(i,k  ,j), w(i,k+1,j), -vel )
12367            k = ktf
12368            vel=0.5*(rom(i,k,j)+rom(i,k-1,j))
12369            vflux(i,k) = vel*flux3(               &
12370                    w(i,k-2,j), w(i,k-1,j),   &
12371                    w(i,k  ,j), w(i,k+1,j), -vel )
12372
12373            k=ktf+1
12374            vflux(i,k)=0.25*(rom(i,k,j)+rom(i,k-1,j))*(w(i,k,j)+w(i,k-1,j))
12375
12376          ENDDO
12377
12378          DO k=kts+1,ktf
12379          DO i = i_start, i_end
12380             tendency(i,k,j)=tendency(i,k,j)-rdzu(k)*(vflux(i,k+1)-vflux(i,k))
12381          ENDDO
12382          ENDDO
12383
12384 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
12385          k = ktf+1
12386          DO i = i_start, i_end
12387            tendency(i,k,j)=tendency(i,k,j)+2.*rdzu(k-1)*(vflux(i,k))
12388          ENDDO
12389
12390       ENDDO
12391
12392
12393 END SUBROUTINE advect_weno_w
12394
12395
12396 END MODULE module_advect_em
12397