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_mono   ( field, field_old, tendency,    &
7712                                   h_tendency, z_tendency,        &
7713                                   ru, rv, rom,                   &
7714                                   mut, mub, mu_old,              &
7715                                   config_flags,                  &
7716                                   tenddec,                       &
7717                                   msfux, msfuy, msfvx, msfvy,    &
7718                                   msftx, msfty,                  &
7719                                   fzm, fzp,                      &
7720                                   rdx, rdy, rdzw, dt,            &
7721                                   ids, ide, jds, jde, kds, kde,  &
7722                                   ims, ime, jms, jme, kms, kme,  &
7723                                   its, ite, jts, jte, kts, kte  )
7724
7725 !  monotonic advection option
7726 !  for scalars in WRF RK3 advection.  This version is memory intensive ->
7727 !  we save 3d arrays of x, y and z both high and low order fluxes
7728 !  (six in all).  Alternatively, we could sweep in a direction
7729 !  and lower the cost considerably.
7730
7731 !  uses the Smolarkiewicz MWR 1989 approach, with addition of first-order
7732 !  fluxes initially
7733
7734    IMPLICIT NONE
7735
7736    ! Input data
7737
7738    TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
7739
7740    LOGICAL ,                 INTENT(IN   ) :: tenddec ! tendency flag
7741
7742    INTEGER ,                 INTENT(IN   ) :: ids, ide, jds, jde, kds, kde, &
7743                                               ims, ime, jms, jme, kms, kme, &
7744                                               its, ite, jts, jte, kts, kte
7745
7746    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: field,     &
7747                                                                       field_old, &
7748                                                                       ru,    &
7749                                                                       rv,    &
7750                                                                       rom
7751
7752    REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: mut, mub, mu_old
7753    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency
7754    REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(  OUT) :: h_tendency, z_tendency
7755
7756    REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
7757                                                                     msfuy,  &
7758                                                                     msfvx,  &
7759                                                                     msfvy,  &
7760                                                                     msftx,  &
7761                                                                     msfty
7762
7763    REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
7764                                                                   fzp,  &
7765                                                                   rdzw
7766
7767    REAL ,                                        INTENT(IN   ) :: rdx,  &
7768                                                                   rdy,  &
7769                                                                   dt
7770
7771    ! Local data
7772
7773    INTEGER :: i, j, k, itf, jtf, ktf
7774    INTEGER :: i_start, i_end, j_start, j_end
7775    INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
7776    INTEGER :: jmin, jmax, jp, jm, imin, imax
7777
7778    REAL    :: mrdx, mrdy, ub, vb, uw, vw, mu
7779    REAL , DIMENSION(its:ite, kts:kte) :: vflux
7780
7781
7782 !  storage for high and low order fluxes
7783
7784    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: fqx, fqy, fqz
7785    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: fqxl, fqyl, fqzl
7786    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: qmin, qmax
7787    REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: scale_in, scale_out
7788    REAL :: ph_upwind
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, flux_in, ph_hi, scale
7798    REAL, PARAMETER :: eps=1.e-20
7799
7800
7801 ! definition of flux operators, 3rd, 4rth, 5th or 6th order
7802
7803    REAL    :: flux3, flux4, flux5, flux6, flux_upwind
7804    REAL    :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
7805
7806       flux4(q_im2, q_im1, q_i, q_ip1, ua) =                     &
7807             (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2)
7808
7809       flux3(q_im2, q_im1, q_i, q_ip1, ua) =                     &
7810            flux4(q_im2, q_im1, q_i, q_ip1, ua) +                &
7811            sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1))
7812
7813       flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
7814             (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2)      &
7815             +(1./60.)*(q_ip2+q_im3)
7816
7817       flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) =       &
7818            flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua)    &
7819             -sign(1.,ua)*(1./60.)*(                             &
7820               (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) )
7821
7822 !      flux_upwind(q_im1, q_i, cr ) = 0.
7823       flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
7824                                     +0.5*(1.-sign(1.,cr))*q_i
7825
7826     LOGICAL, PARAMETER :: mono_limit = .true.
7827
7828 ! set order for the advection schemes
7829
7830   ktf=MIN(kte,kde-1)
7831   horz_order = config_flags%h_sca_adv_order
7832   vert_order = config_flags%v_sca_adv_order
7833
7834   do j=jts-2,jte+2
7835   do k=kts,kte
7836   do i=its-2,ite+2
7837     qmin(i,k,j) = field_old(i,k,j)
7838     qmax(i,k,j) = field_old(i,k,j)
7839     scale_in(i,k,j) = 1.
7840     scale_out(i,k,j) = 1.
7841     fqx(i,k,j) = 0.
7842     fqy(i,k,j) = 0.
7843     fqz(i,k,j) = 0.
7844     fqxl(i,k,j) = 0.
7845     fqyl(i,k,j) = 0.
7846     fqzl(i,k,j) = 0.
7847   enddo
7848   enddo
7849   enddo
7850
7851 !  begin with horizontal flux divergence
7852 !  here is the choice of flux operators
7853
7854
7855   horizontal_order_test : IF( horz_order == 5 ) THEN
7856
7857 !  determine boundary mods for flux operators
7858 !  We degrade the flux operators from 3rd/4rth order
7859 !   to second order one gridpoint in from the boundaries for
7860 !   all boundary conditions except periodic and symmetry - these
7861 !   conditions have boundary zone data fill for correct application
7862 !   of the higher order flux stencils
7863
7864    degrade_xs = .true.
7865    degrade_xe = .true.
7866    degrade_ys = .true.
7867    degrade_ye = .true.
7868
7869    IF( config_flags%periodic_x   .or. &
7870        config_flags%symmetric_xs .or. &
7871        (its > ids+3)                ) degrade_xs = .false.
7872    IF( config_flags%periodic_x   .or. &
7873        config_flags%symmetric_xe .or. &
7874        (ite < ide-4)                ) degrade_xe = .false.
7875    IF( config_flags%periodic_y   .or. &
7876        config_flags%symmetric_ys .or. &
7877        (jts > jds+3)                ) degrade_ys = .false.
7878    IF( config_flags%periodic_y   .or. &
7879        config_flags%symmetric_ye .or. &
7880        (jte < jde-4)                ) degrade_ye = .false.
7881
7882 !--------------- y - advection first
7883
7884 !--  y flux compute; these bounds are for periodic and sym b.c.
7885
7886       ktf=MIN(kte,kde-1)
7887       i_start = its-1
7888       i_end   = MIN(ite,ide-1)+1
7889       j_start = jts-1
7890       j_end   = MIN(jte,jde-1)+1
7891       j_start_f = j_start
7892       j_end_f   = j_end+1
7893
7894 !--  modify loop bounds if open or specified
7895
7896 !  WCS 20090218
7897 !      IF(degrade_xs) i_start = its
7898 !      IF(degrade_xe) i_end   = MIN(ite,ide-1)
7899       IF(degrade_xs) i_start = MAX(its-1,ids)
7900       IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
7901
7902 !  WCS 20090218
7903 !      IF(degrade_ys) then
7904 !        j_start = MAX(jts,jds+1)
7905 !        j_start_f = jds+3
7906 !      ENDIF
7907 !
7908 !      IF(degrade_ye) then
7909 !        j_end = MIN(jte,jde-2)
7910 !        j_end_f = jde-3
7911 !      ENDIF
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           vel = rv(i,k,j)
7933           cr = vel
7934           fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), vel)
7935
7936           fqy( i, k, j  ) = vel*flux5(                                  &
7937                   field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
7938                   field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
7939
7940           fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7941
7942           if(cr.gt. 0) then
7943              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
7944              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
7945           else
7946              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
7947              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
7948           end if
7949
7950         ENDDO
7951         ENDDO
7952
7953       ELSE IF ( j == jds+1 ) THEN   ! 2nd order flux next to south boundary
7954
7955             DO k=kts,ktf
7956             DO i = i_start, i_end
7957
7958               vel = rv(i,k,j)
7959               cr = vel
7960               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
7961
7962               fqy(i,k, j) = 0.5*rv(i,k,j)*          &
7963                      (field(i,k,j)+field(i,k,j-1))
7964
7965               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7966
7967           if(cr.gt. 0) then
7968              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
7969              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
7970           else
7971              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
7972              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
7973           end if
7974
7975             ENDDO
7976             ENDDO
7977
7978       ELSE IF  ( j == jds+2 ) THEN  ! third of 4rth order flux 2 in from south boundary
7979
7980             DO k=kts,ktf
7981             DO i = i_start, i_end
7982
7983               vel = rv(i,k,j)
7984               cr = vel
7985               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
7986
7987               fqy( i, k, j ) = vel*flux3(              &
7988                    field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel )
7989               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
7990
7991           if(cr.gt. 0) then
7992              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
7993              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
7994           else
7995              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
7996              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
7997           end if
7998
7999             ENDDO
8000             ENDDO
8001
8002       ELSE IF ( j == jde-1 ) THEN  ! 2nd order flux next to north boundary
8003
8004             DO k=kts,ktf
8005             DO i = i_start, i_end
8006
8007               vel = rv(i,k,j)
8008               cr = vel
8009               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8010
8011               fqy(i, k, j ) = 0.5*rv(i,k,j)*      &
8012                      (field(i,k,j)+field(i,k,j-1))
8013               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8014
8015           if(cr.gt. 0) then
8016              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
8017              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
8018           else
8019              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
8020              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
8021           end if
8022
8023             ENDDO
8024             ENDDO
8025
8026       ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4rth order flux 2 in from north boundary
8027
8028             DO k=kts,ktf
8029             DO i = i_start, i_end
8030
8031               vel = rv(i,k,j)
8032               cr = vel
8033               fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), cr)
8034
8035               fqy( i, k, j) = vel*flux3(             &
8036                    field(i,k,j-2),field(i,k,j-1),    &
8037                    field(i,k,j),field(i,k,j+1),vel )
8038               fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j)
8039
8040           if(cr.gt. 0) then
8041              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
8042              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
8043           else
8044              qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
8045              qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
8046           end if
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 !  WCS 20090218
8070 !      IF(degrade_ys) j_start = jts
8071 !      IF(degrade_ye) j_end   = MIN(jte,jde-1)
8072       IF(degrade_ys) j_start = MAX(jts-1,jds)
8073       IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
8074
8075 !  WCS 20090218
8076 !      IF(degrade_xs) then
8077 !        i_start = MAX(ids+1,its)
8078 !        i_start_f = i_start+2
8079 !      ENDIF
8080
8081 !      IF(degrade_xe) then
8082 !        i_end = MIN(ide-2,ite)
8083 !        i_end_f = ide-3
8084 !      ENDIF
8085
8086       IF(degrade_xs) then
8087         i_start = MAX(ids+1,its-1)
8088         i_start_f = ids+3
8089       ENDIF
8090
8091       IF(degrade_xe) then
8092         i_end = MIN(ide-2,ite+1)
8093         i_end_f = ide-3
8094       ENDIF
8095
8096 !  compute fluxes
8097
8098       DO j = j_start, j_end
8099
8100 !  5th or 6th order flux
8101
8102         DO k=kts,ktf
8103         DO i = i_start_f, i_end_f
8104
8105           vel = ru(i,k,j)
8106           cr = vel
8107           fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8108
8109           fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
8110                                          field(i-1,k,j), field(i  ,k,j),  &
8111                                          field(i+1,k,j), field(i+2,k,j),  &
8112                                          vel                             )
8113           fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
8114
8115           if(cr.gt. 0) then
8116              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
8117              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
8118           else
8119              qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
8120              qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
8121           end if
8122
8123         ENDDO
8124         ENDDO
8125
8126 !  lower order fluxes close to boundaries (if not periodic or symmetric)
8127
8128 !  WCS 20090218 degrade_xs and xe recoded
8129
8130         IF( degrade_xs ) THEN
8131
8132           DO i=i_start,i_start_f-1
8133
8134             IF(i == ids+1) THEN ! second order
8135               DO k=kts,ktf
8136                 vel = ru(i,k,j)
8137                 cr = vel
8138                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8139
8140                 fqx(i,k,j) = 0.5*(ru(i,k,j)) &
8141                        *(field(i,k,j)+field(i-1,k,j))
8142
8143                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
8144
8145                 if(cr.gt. 0) then
8146                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
8147                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
8148                 else
8149                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
8150                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
8151                 end if
8152               ENDDO
8153             ENDIF
8154
8155             IF(i == ids+2) THEN  ! third order
8156               DO k=kts,ktf
8157                 vel = ru(i,k,j)
8158                 cr = vel
8159                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8160                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
8161                                           field(i  ,k,j), field(i+1,k,j),  &
8162                                           vel                             )
8163                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
8164
8165                 if(cr.gt. 0) then
8166                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
8167                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
8168                 else
8169                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
8170                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
8171                 end if
8172               ENDDO
8173             ENDIF
8174
8175           ENDDO
8176
8177         ENDIF
8178
8179         IF( degrade_xe ) THEN
8180
8181           DO i = i_end_f+1, i_end+1
8182
8183             IF( i == ide-1 ) THEN ! second order flux next to the boundary
8184               DO k=kts,ktf
8185                 vel = ru(i,k,j)
8186                 cr = vel
8187                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8188                 fqx(i,k,j) = 0.5*(ru(i,k,j))      &
8189                        *(field(i,k,j)+field(i-1,k,j))
8190                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
8191
8192                 if(cr.gt. 0) then
8193                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
8194                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
8195                 else
8196                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
8197                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
8198                 end if
8199               ENDDO
8200             ENDIF
8201
8202             IF( i == ide-2 ) THEN ! third order flux one in from the boundary
8203               DO k=kts,ktf
8204                 vel = ru(i,k,j)
8205                 cr = vel
8206                 fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j  ), cr)
8207                 fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j),  &
8208                                           field(i  ,k,j), field(i+1,k,j),  &
8209                                           vel                             )
8210                 fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j)
8211
8212                 if(cr.gt. 0) then
8213                   qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
8214                   qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
8215                 else
8216                   qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
8217                   qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
8218                 end if
8219               ENDDO
8220             ENDIF
8221           ENDDO
8222         ENDIF
8223
8224       ENDDO  ! enddo for outer J loop
8225
8226    ELSE
8227
8228       WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_mono, h_order not known ',horz_order
8229       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
8230
8231    ENDIF horizontal_order_test
8232
8233 !  pick up the rest of the horizontal radiation boundary conditions.
8234 !  (these are the computations that don't require 'cb'.
8235 !  first, set to index ranges
8236
8237       i_start = its
8238       i_end   = MIN(ite,ide-1)
8239       j_start = jts
8240       j_end   = MIN(jte,jde-1)
8241
8242 !  compute x (u) conditions for v, w, or scalar
8243
8244    IF( (config_flags%open_xs) .and. (its == ids) ) THEN
8245
8246        DO j = j_start, j_end
8247        DO k = kts, ktf
8248          ub = MIN( 0.5*(ru(its,k,j)+ru(its+1,k,j)), 0. )
8249          tendency(its,k,j) = tendency(its,k,j)                     &
8250                - rdx*(                                             &
8251                        ub*(   field_old(its+1,k,j)                 &
8252                             - field_old(its  ,k,j)   ) +           &
8253                        field(its,k,j)*(ru(its+1,k,j)-ru(its,k,j))  &
8254                                                                 )
8255        ENDDO
8256        ENDDO
8257
8258    ENDIF
8259
8260    IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
8261
8262        DO j = j_start, j_end
8263        DO k = kts, ktf
8264          ub = MAX( 0.5*(ru(ite-1,k,j)+ru(ite,k,j)), 0. )
8265          tendency(i_end,k,j) = tendency(i_end,k,j)                   &
8266                - rdx*(                                               &
8267                        ub*(  field_old(i_end  ,k,j)                  &
8268                            - field_old(i_end-1,k,j) ) +              &
8269                        field(i_end,k,j)*(ru(ite,k,j)-ru(ite-1,k,j))  &
8270                                                                     )
8271        ENDDO
8272        ENDDO
8273
8274    ENDIF
8275
8276    IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
8277
8278        DO i = i_start, i_end
8279        DO k = kts, ktf
8280          vb = MIN( 0.5*(rv(i,k,jts)+rv(i,k,jts+1)), 0. )
8281          tendency(i,k,jts) = tendency(i,k,jts)                     &
8282                - rdy*(                                             &
8283                        vb*(  field_old(i,k,jts+1)                  &
8284                            - field_old(i,k,jts  ) ) +              &
8285                        field(i,k,jts)*(rv(i,k,jts+1)-rv(i,k,jts))  &
8286                                                                 )
8287        ENDDO
8288        ENDDO
8289
8290    ENDIF
8291
8292    IF( (config_flags%open_ye) .and. (jte == jde)) THEN
8293
8294        DO i = i_start, i_end
8295        DO k = kts, ktf
8296          vb = MAX( 0.5*(rv(i,k,jte-1)+rv(i,k,jte)), 0. )
8297          tendency(i,k,j_end) = tendency(i,k,j_end)                   &
8298                - rdy*(                                               &
8299                        vb*(   field_old(i,k,j_end  )                 &
8300                             - field_old(i,k,j_end-1) ) +             &
8301                        field(i,k,j_end)*(rv(i,k,jte)-rv(i,k,jte-1))  &
8302                                                                     )
8303        ENDDO
8304        ENDDO
8305
8306    ENDIF
8307
8308 !-------------------- vertical advection
8309
8310 !-- loop bounds for periodic or sym conditions
8311
8312       i_start = its-1
8313       i_end   = MIN(ite,ide-1)+1
8314       j_start = jts-1
8315       j_end   = MIN(jte,jde-1)+1
8316
8317 !-- loop bounds for open or specified conditions
8318
8319 !  WCS 20090218
8320 !    IF(degrade_xs) i_start = its
8321 !    IF(degrade_xe) i_end   = MIN(ite,ide-1)
8322 !    IF(degrade_ys) j_start = jts
8323 !    IF(degrade_ye) j_end   = MIN(jte,jde-1)
8324
8325     IF(degrade_xs) i_start = MAX(its-1,ids)
8326     IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
8327     IF(degrade_ys) j_start = MAX(jts-1,jds)
8328     IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
8329
8330
8331     vert_order_test : IF (vert_order == 3) THEN
8332
8333       DO j = j_start, j_end
8334
8335          DO i = i_start, i_end
8336            fqz(i,1,j)  = 0.
8337            fqzl(i,1,j) = 0.
8338            fqz(i,kde,j)  = 0.
8339            fqzl(i,kde,j) = 0.
8340          ENDDO
8341
8342          DO k=kts+2,ktf-1
8343          DO i = i_start, i_end
8344
8345            vel = rom(i,k,j)
8346            cr = -vel
8347            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
8348
8349            fqz(i,k,j) = vel*flux3(                      &
8350                    field(i,k-2,j), field(i,k-1,j),      &
8351                    field(i,k  ,j), field(i,k+1,j),  -vel )
8352            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
8353
8354           if(cr.gt. 0) then
8355              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
8356              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
8357           else
8358              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
8359              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
8360           end if
8361
8362          ENDDO
8363          ENDDO
8364
8365          DO i = i_start, i_end
8366
8367            k=kts+1
8368            vel = rom(i,k,j)
8369            cr = -vel
8370            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
8371            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
8372            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
8373
8374           if(cr.gt. 0) then
8375              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
8376              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
8377           else
8378              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
8379              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
8380           end if
8381
8382            k=ktf
8383            vel = rom(i,k,j)
8384            cr = -vel
8385            fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j  ), cr)
8386            fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j))
8387            fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j)
8388
8389           if(cr.gt. 0) then
8390              qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
8391              qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
8392           else
8393              qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
8394              qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
8395           end if
8396          ENDDO
8397
8398       ENDDO
8399
8400    ELSE
8401
8402       WRITE (wrf_err_message,*) ' advect_scalar_mono, v_order not known ',vert_order
8403       CALL wrf_error_fatal ( wrf_err_message )
8404
8405    ENDIF vert_order_test
8406
8407    IF (mono_limit) THEN
8408
8409 ! montonic filter
8410
8411    i_start = its-1
8412    i_end   = MIN(ite,ide-1)+1
8413    j_start = jts-1
8414    j_end   = MIN(jte,jde-1)+1
8415
8416 ! WCS 20090218
8417
8418 !-- loop bounds for open or specified conditions
8419 !
8420 !   IF(degrade_xs) i_start = its
8421 !   IF(degrade_xe) i_end   = MIN(ite,ide-1)
8422 !   IF(degrade_ys) j_start = jts
8423 !   IF(degrade_ye) j_end   = MIN(jte,jde-1)
8424 !
8425 !   IF(config_flags%specified .or. config_flags%nested) THEN
8426 !     IF (degrade_xs) i_start = MAX(its,ids+1)
8427 !     IF (degrade_xe) i_end   = MIN(ite,ide-2)
8428 !     IF (degrade_ys) j_start = MAX(jts,jds+1)
8429 !     IF (degrade_ye) j_end   = MIN(jte,jde-2)
8430 !   END IF
8431 !
8432 !   IF(config_flags%open_xs) THEN
8433 !     IF (degrade_xs) i_start = MAX(its,ids+1)
8434 !   END IF
8435 !   IF(config_flags%open_xe) THEN
8436 !     IF (degrade_xe) i_end   = MIN(ite,ide-2)
8437 !   END IF
8438 !   IF(config_flags%open_ys) THEN
8439 !     IF (degrade_ys) j_start = MAX(jts,jds+1)
8440 !   END IF
8441 !   IF(config_flags%open_ye) THEN
8442 !     IF (degrade_ye) j_end   = MIN(jte,jde-2)
8443 !   END IF
8444
8445    IF(degrade_xs) i_start = MAX(its-1,ids)
8446    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
8447    IF(degrade_ys) j_start = MAX(jts-1,jds)
8448    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
8449
8450    IF(config_flags%specified .or. config_flags%nested) THEN
8451      IF (degrade_xs) i_start = MAX(its-1,ids+1)
8452      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
8453      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
8454      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
8455    END IF
8456
8457    IF(config_flags%open_xs) THEN
8458      IF (degrade_xs) i_start = MAX(its-1,ids+1)
8459    END IF
8460    IF(config_flags%open_xe) THEN
8461      IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
8462    END IF
8463    IF(config_flags%open_ys) THEN
8464      IF (degrade_ys) j_start = MAX(jts-1,jds+1)
8465    END IF
8466    IF(config_flags%open_ye) THEN
8467      IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
8468    END IF
8469
8470 !-- here is the limiter...
8471
8472    DO j=j_start, j_end
8473    DO k=kts, ktf
8474    DO i=i_start, i_end
8475
8476      ph_upwind = (mub(i,j)+mu_old(i,j))*field_old(i,k,j)        &
8477                    - dt*( msftx(i,j)*msfty(i,j)*(               &
8478                           rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
8479                           rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
8480                          +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
8481
8482      flux_in = -dt*( (msftx(i,j)*msfty(i,j))*(                   &
8483                                rdx*(  min(0.,fqx (i+1,k,j))      &
8484                                      -max(0.,fqx (i  ,k,j)) )    &
8485                               +rdy*(  min(0.,fqy (i,k,j+1))      &
8486                                      -max(0.,fqy (i,k,j  )) ) )  &
8487                +msfty(i,j)*rdzw(k)*(  max(0.,fqz (i,k+1,j))      &
8488                                      -min(0.,fqz (i,k  ,j)) )   )
8489
8490      ph_hi = mut(i,j)*qmax(i,k,j) - ph_upwind
8491      IF( flux_in .gt. ph_hi ) scale_in(i,k,j) = max(0.,ph_hi/(flux_in+eps))
8492
8493
8494      flux_out = dt*( (msftx(i,j)*msfty(i,j))*(                    &
8495                                 rdx*(  max(0.,fqx (i+1,k,j))      &
8496                                       -min(0.,fqx (i  ,k,j)) )    &
8497                                +rdy*(  max(0.,fqy (i,k,j+1))      &
8498                                       -min(0.,fqy (i,k,j  )) ) )  &
8499                 +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
8500                                       -max(0.,fqz (i,k  ,j)) )   )
8501
8502      ph_low = ph_upwind - mut(i,j)*qmin(i,k,j)
8503      IF( flux_out .gt. ph_low ) scale_out(i,k,j) = max(0.,ph_low/(flux_out+eps))
8504
8505    ENDDO
8506    ENDDO
8507    ENDDO
8508
8509    DO j=j_start, j_end
8510    DO k=kts, ktf
8511    DO i=i_start, i_end+1
8512        IF( fqx (i,k,j) .gt. 0.) then
8513          fqx(i,k,j) = min(scale_in(i,k,j),scale_out(i-1,k,j))*fqx(i,k,j)
8514        ELSE
8515          fqx(i,k,j) = min(scale_out(i,k,j),scale_in(i-1,k,j))*fqx(i,k,j)
8516        ENDIF
8517    ENDDO
8518    ENDDO
8519    ENDDO
8520
8521    DO j=j_start, j_end+1
8522    DO k=kts, ktf
8523    DO i=i_start, i_end
8524        IF( fqy (i,k,j) .gt. 0.) then
8525          fqy(i,k,j) = min(scale_in(i,k,j),scale_out(i,k,j-1))*fqy(i,k,j)
8526        ELSE
8527          fqy(i,k,j) = min(scale_out(i,k,j),scale_in(i,k,j-1))*fqy(i,k,j)
8528        ENDIF
8529    ENDDO
8530    ENDDO
8531    ENDDO
8532
8533    DO j=j_start, j_end
8534    DO k=kts+1, ktf
8535    DO i=i_start, i_end
8536        IF( fqz (i,k,j) .lt. 0.) then
8537          fqz(i,k,j) = min(scale_in(i,k,j),scale_out(i,k-1,j))*fqz(i,k,j)
8538        ELSE
8539          fqz(i,k,j) = min(scale_out(i,k,j),scale_in(i,k-1,j))*fqz(i,k,j)
8540        ENDIF
8541    ENDDO
8542    ENDDO
8543    ENDDO
8544
8545    END IF
8546
8547 ! add in the mono-limited flux divergence
8548 ! we need to fix this for open b.c set ***********
8549
8550   i_start = its
8551   i_end   = MIN(ite,ide-1)
8552   j_start = jts
8553   j_end   = MIN(jte,jde-1)
8554
8555   DO j = j_start, j_end
8556   DO k = kts, ktf
8557   DO i = i_start, i_end
8558
8559      tendency (i,k,j) = tendency(i,k,j)                           &
8560                             -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
8561                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
8562
8563   ENDDO
8564   ENDDO
8565   ENDDO
8566
8567   IF(tenddec) THEN
8568   DO j = j_start, j_end
8569   DO k = kts, ktf
8570   DO i = i_start, i_end
8571
8572      z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
8573                                       +fqzl(i,k+1,j)-fqzl(i,k,j))
8574
8575   ENDDO
8576   ENDDO
8577   ENDDO
8578   END IF
8579
8580 ! x flux divergence
8581 !
8582
8583 ! WCS 20090218
8584 !  IF(degrade_xs) i_start = i_start + 1
8585 !  IF(degrade_xe) i_end   = i_end   - 1
8586
8587   IF(degrade_xs) i_start = MAX(its,ids+1)
8588   IF(degrade_xe) i_end   = MIN(ite,ide-2)
8589
8590   DO j = j_start, j_end
8591   DO k = kts, ktf
8592   DO i = i_start, i_end
8593
8594      ! Un-"canceled" map scale factor, ADT Eq. 48
8595      tendency (i,k,j) = tendency(i,k,j)                           &
8596                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
8597                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
8598
8599   ENDDO
8600   ENDDO
8601   ENDDO
8602
8603   IF(tenddec) THEN
8604   DO j = j_start, j_end
8605   DO k = kts, ktf
8606   DO i = i_start, i_end
8607
8608      h_tendency (i,k,j) = 0.                                      &
8609                - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
8610                                    +fqxl(i+1,k,j)-fqxl(i,k,j))   )
8611
8612   ENDDO
8613   ENDDO
8614   ENDDO
8615   END IF
8616
8617 ! y flux divergence
8618 !
8619   i_start = its
8620   i_end   = MIN(ite,ide-1)
8621
8622 ! WCS 20090218
8623 !  IF(degrade_ys) j_start = j_start + 1
8624 !  IF(degrade_ye) j_end   = j_end   - 1
8625
8626   IF(degrade_ys) j_start = MAX(jts,jds+1)
8627   IF(degrade_ye) j_end   = MIN(jte,jde-2)
8628
8629   DO j = j_start, j_end
8630   DO k = kts, ktf
8631   DO i = i_start, i_end
8632
8633      ! Un-"canceled" map scale factor, ADT Eq. 48
8634      tendency (i,k,j) = tendency(i,k,j)                           &
8635                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
8636                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
8637
8638   ENDDO
8639   ENDDO
8640   ENDDO
8641
8642   IF(tenddec) THEN
8643   DO j = j_start, j_end
8644   DO k = kts, ktf
8645   DO i = i_start, i_end
8646
8647      h_tendency (i,k,j) = h_tendency (i,k,j)                      &
8648                - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
8649                                    +fqyl(i,k,j+1)-fqyl(i,k,j))   )
8650
8651   ENDDO
8652   ENDDO
8653   ENDDO
8654   END IF
8655
8656 END SUBROUTINE advect_scalar_mono
8657
8658 !-----------------------------------------------------------
8659
8660 END MODULE module_advect_em
8661