wrftladj/module_advect_em_tl.F

   1
   2 ! ======================================================================================
   3 ! This file was generated by the version 5.3.6 of DFT on 07/15/2010. The differentiation
   4 ! transforming system(DFT) was jointly developed and sponsored by LASG of IAP(1998-2010)
   5 ! and LSEC of ICMSEC, AMSS(2001-2003)
   6 ! The copyright of the DFT system was declared by Walls at LASG, 1998-2010
   7 ! ======================================================================================
   8
   9  MODULE g_module_advect_em
  10
  11  USE module_bc !REVISED BY WALLS
  12  USE module_model_constants
  13  USE module_wrf_error
  14
  15  CONTAINS
  16
  17 !        Generated by TAPENADE     (INRIA, Tropics team)
  18 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
  19 !
  20 !  Differentiation of advect_u in forward (tangent) mode:
  21 !   variations   of useful results: tendency
  22 !   with respect to varying inputs: rom u tendency u_old ru rv
  23 !                mut
  24 !   RW status of diff variables: rom:in u:in tendency:in-out u_old:in
  25 !                ru:in rv:in mut:in
  26 SUBROUTINE G_ADVECT_U(u, ud, u_old, u_oldd, tendency, tendencyd, ru, rud&
  27 &  , rv, rvd, rom, romd, mut, mutd, time_step, config_flags, msfux, msfuy&
  28 &  , msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide, jds&
  29 &  , jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts&
  30 &  , kte)
  31   IMPLICIT NONE
  32 ! Input data
  33   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
  34   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
  35 &  jme, kms, kme, its, ite, jts, jte, kts, kte
  36   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u, u_old, ru&
  37 &  , rv, rom
  38   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ud, u_oldd, &
  39 &  rud, rvd, romd
  40   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
  41   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd
  42   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
  43   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
  44   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
  45 &  msfvy, msftx, msfty
  46   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
  47   REAL, INTENT(IN) :: rdx, rdy
  48   INTEGER, INTENT(IN) :: time_step
  49 ! Local data
  50   INTEGER :: i, j, k, itf, jtf, ktf
  51   INTEGER :: i_start, i_end, j_start, j_end
  52   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
  53   INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
  54   INTEGER :: jp1, jp0, jtmp
  55   INTEGER :: horz_order, vert_order
  56   REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
  57   REAL :: ubd, vbd, vwd, dvmd, dvpd
  58   REAL, DIMENSION(its:ite, kts:kte) :: vflux
  59   REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
  60   REAL, DIMENSION(its - 1:ite + 1, kts:kte) :: fqx
  61   REAL, DIMENSION(its-1:ite+1, kts:kte) :: fqxd
  62   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
  63   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
  64   LOGICAL :: degrade_xs, degrade_ys
  65   LOGICAL :: degrade_xe, degrade_ye
  66 ! definition of flux operators, 3rd, 4th, 5th or 6th order
  67   REAL :: flux3, flux4, flux5, flux6
  68   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
  69   REAL :: veld
  70   LOGICAL :: specified
  71
  72
  73   specified = .false.
  74   IF (config_flags%specified .OR. config_flags%nested) specified = &
  75 &      .true.
  76 !  set order for vertical and horzontal flux operators
  77   horz_order = config_flags%h_mom_adv_order
  78   vert_order = config_flags%v_mom_adv_order
  79   IF (kte .GT. kde - 1) THEN
  80     ktf = kde - 1
  81   ELSE
  82     ktf = kte
  83   END IF
  84 !  begin with horizontal flux divergence
  85   IF (horz_order .EQ. 6) THEN
  86 !  determine boundary mods for flux operators
  87 !  We degrade the flux operators from 3rd/4th order
  88 !   to second order one gridpoint in from the boundaries for
  89 !   all boundary conditions except periodic and symmetry - these
  90 !   conditions have boundary zone data fill for correct application
  91 !   of the higher order flux stencils
  92     degrade_xs = .true.
  93     degrade_xe = .true.
  94     degrade_ys = .true.
  95     degrade_ye = .true.
  96     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
  97 &        its .GT. ids + 3) degrade_xs = .false.
  98     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
  99 &        ite .LT. ide - 2) degrade_xe = .false.
 100     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
 101 &        jts .GT. jds + 3) degrade_ys = .false.
 102     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
 103 &        jte .LT. jde - 4) degrade_ye = .false.
 104 !--------------- y - advection first
 105     i_start = its
 106     i_end = ite
 107     IF (config_flags%open_xs .OR. specified) THEN
 108       IF (ids + 1 .LT. its) THEN
 109         i_start = its
 110       ELSE
 111         i_start = ids + 1
 112       END IF
 113     END IF
 114     IF (config_flags%open_xe .OR. specified) THEN
 115       IF (ide - 1 .GT. ite) THEN
 116         i_end = ite
 117       ELSE
 118         i_end = ide - 1
 119       END IF
 120     END IF
 121     IF (config_flags%periodic_x) i_start = its
 122     IF (config_flags%periodic_x) i_end = ite
 123     j_start = jts
 124     IF (jte .GT. jde - 1) THEN
 125       j_end = jde - 1
 126     ELSE
 127       j_end = jte
 128     END IF
 129 !  higher order flux has a 5 or 7 point stencil, so compute
 130 !  bounds so we can switch to second order flux close to the boundary
 131     j_start_f = j_start
 132     j_end_f = j_end + 1
 133     IF (degrade_ys) THEN
 134       IF (jts .LT. jds + 1) THEN
 135         j_start = jds + 1
 136       ELSE
 137         j_start = jts
 138       END IF
 139       j_start_f = jds + 3
 140     END IF
 141     IF (degrade_ye) THEN
 142       IF (jte .GT. jde - 2) THEN
 143         j_end = jde - 2
 144       ELSE
 145         j_end = jte
 146       END IF
 147       j_end_f = jde - 3
 148     END IF
 149     IF (config_flags%polar) THEN
 150       IF (jte .GT. jde - 1) THEN
 151         j_end = jde - 1
 152       ELSE
 153         j_end = jte
 154       END IF
 155     END IF
 156 !  compute fluxes, 5th or 6th order
 157     jp1 = 2
 158     jp0 = 1
 159     fqyd = 0.0
 160 j_loop_y_flux_6:DO j=j_start,j_end+1
 161       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
 162 ! use full stencil
 163         DO k=kts,ktf
 164           DO i=i_start,i_end
 165             veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
 166             vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
 167             fqyd(i, k, jp1) = veld*(37.*(u(i, k, j)+u(i, k, j-1))-8.*(u(&
 168 &              i, k, j+1)+u(i, k, j-2))+(u(i, k, j+2)+u(i, k, j-3)))/60.0&
 169 &              + vel*(37.*(ud(i, k, j)+ud(i, k, j-1))-8.*(ud(i, k, j+1)+&
 170 &              ud(i, k, j-2))+ud(i, k, j+2)+ud(i, k, j-3))/60.0
 171             fqy(i, k, jp1) = vel*((37.*(u(i, k, j)+u(i, k, j-1))-8.*(u(i&
 172 &              , k, j+1)+u(i, k, j-2))+(u(i, k, j+2)+u(i, k, j-3)))/60.0)
 173           END DO
 174         END DO
 175       ELSE IF (j .EQ. jds + 1) THEN
 176 !  we must be close to some boundary where we need to reduce the order of the stencil
 177 ! 2nd order flux next to south boundary
 178         DO k=kts,ktf
 179           DO i=i_start,i_end
 180             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
 181 &              k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
 182 &              j)+ud(i, k, j-1)))
 183             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
 184 &              )+u(i, k, j-1))
 185           END DO
 186         END DO
 187       ELSE IF (j .EQ. jds + 2) THEN
 188 ! third of 4th order flux 2 in from south boundary
 189         DO k=kts,ktf
 190           DO i=i_start,i_end
 191             veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
 192             vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
 193             fqyd(i, k, jp1) = veld*(7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
 194 &              , j+1)+u(i, k, j-2)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k&
 195 &              , j-1))-ud(i, k, j+1)-ud(i, k, j-2))/12.0
 196             fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
 197 &              , j+1)+u(i, k, j-2)))/12.0)
 198           END DO
 199         END DO
 200       ELSE IF (j .EQ. jde - 1) THEN
 201 ! 2nd order flux next to north boundary
 202         DO k=kts,ktf
 203           DO i=i_start,i_end
 204             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
 205 &              k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
 206 &              j)+ud(i, k, j-1)))
 207             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
 208 &              )+u(i, k, j-1))
 209           END DO
 210         END DO
 211       ELSE IF (j .EQ. jde - 2) THEN
 212 ! 3rd order flux 2 in from north boundary
 213         DO k=kts,ktf
 214           DO i=i_start,i_end
 215             veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
 216             vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
 217             fqyd(i, k, jp1) = veld*(7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
 218 &              , j+1)+u(i, k, j-2)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k&
 219 &              , j-1))-ud(i, k, j+1)-ud(i, k, j-2))/12.0
 220             fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
 221 &              , j+1)+u(i, k, j-2)))/12.0)
 222           END DO
 223         END DO
 224       END IF
 225 !  y flux-divergence into tendency
 226 ! (j > j_start) will miss the u(,,jds) tendency
 227       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
 228         DO k=kts,ktf
 229           DO i=i_start,i_end
 230 ! ADT eqn 44, 2nd term on RHS
 231             mrdy = msfux(i, j-1)*rdy
 232             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
 233 &              , jp1)
 234             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
 235 &              jp1)
 236           END DO
 237         END DO
 238       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
 239 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 240         DO k=kts,ktf
 241           DO i=i_start,i_end
 242 ! ADT eqn 44, 2nd term on RHS
 243             mrdy = msfux(i, j-1)*rdy
 244             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
 245 &              , jp0)
 246             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
 247 &              jp0)
 248           END DO
 249         END DO
 250       ELSE IF (j .GT. j_start) THEN
 251 ! normal code
 252         DO k=kts,ktf
 253           DO i=i_start,i_end
 254 ! ADT eqn 44, 2nd term on RHS
 255             mrdy = msfux(i, j-1)*rdy
 256             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
 257 &              k, jp1)-fqyd(i, k, jp0))
 258             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
 259 &              jp1)-fqy(i, k, jp0))
 260           END DO
 261         END DO
 262       END IF
 263       jtmp = jp1
 264       jp1 = jp0
 265       jp0 = jtmp
 266     END DO j_loop_y_flux_6
 267 !  next, x - flux divergence
 268     i_start = its
 269     i_end = ite
 270     j_start = jts
 271     IF (jte .GT. jde - 1) THEN
 272       j_end = jde - 1
 273     ELSE
 274       j_end = jte
 275     END IF
 276 !  higher order flux has a 5 or 7 point stencil, so compute
 277 !  bounds so we can switch to second order flux close to the boundary
 278     i_start_f = i_start
 279     i_end_f = i_end + 1
 280     IF (degrade_xs) THEN
 281       IF (ids + 1 .LT. its) THEN
 282         i_start = its
 283       ELSE
 284         i_start = ids + 1
 285       END IF
 286       i_start_f = ids + 3
 287     END IF
 288     IF (degrade_xe) THEN
 289       IF (ide - 1 .GT. ite) THEN
 290         i_end = ite
 291       ELSE
 292         i_end = ide - 1
 293       END IF
 294       i_end_f = ide - 2
 295       fqxd = 0.0
 296     ELSE
 297       fqxd = 0.0
 298     END IF
 299 !  compute fluxes
 300     DO j=j_start,j_end
 301 !  5th or 6th order flux
 302       DO k=kts,ktf
 303         DO i=i_start_f,i_end_f
 304           veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
 305           vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
 306           fqxd(i, k) = veld*(37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k&
 307 &            , j)+u(i-2, k, j))+(u(i+2, k, j)+u(i-3, k, j)))/60.0 + vel*(&
 308 &            37.*(ud(i, k, j)+ud(i-1, k, j))-8.*(ud(i+1, k, j)+ud(i-2, k&
 309 &            , j))+ud(i+2, k, j)+ud(i-3, k, j))/60.0
 310           fqx(i, k) = vel*((37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k, &
 311 &            j)+u(i-2, k, j))+(u(i+2, k, j)+u(i-3, k, j)))/60.0)
 312         END DO
 313       END DO
 314 !  lower order fluxes close to boundaries (if not periodic or symmetric)
 315 !  specified uses upstream normal wind at boundaries
 316       IF (degrade_xs) THEN
 317         IF (i_start .EQ. ids + 1) THEN
 318 ! second order flux next to the boundary
 319           i = ids + 1
 320           DO k=kts,ktf
 321             ubd = ud(i-1, k, j)
 322             ub = u(i-1, k, j)
 323             IF (specified .AND. u(i, k, j) .LT. 0.) THEN
 324               ubd = ud(i, k, j)
 325               ub = u(i, k, j)
 326             END IF
 327             fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i, k, j)&
 328 &              +ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)+ubd))
 329             fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i, k, j)+ub)
 330           END DO
 331         END IF
 332         i = ids + 2
 333         DO k=kts,ktf
 334           veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
 335           vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
 336           fqxd(i, k) = veld*(7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+&
 337 &            u(i-2, k, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i-1, k, j))-ud&
 338 &            (i+1, k, j)-ud(i-2, k, j))/12.0
 339           fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
 340 &            (i-2, k, j)))/12.0)
 341         END DO
 342       END IF
 343       IF (degrade_xe) THEN
 344         IF (i_end .EQ. ide - 1) THEN
 345 ! second order flux next to the boundary
 346           i = ide
 347           DO k=kts,ktf
 348             ubd = ud(i, k, j)
 349             ub = u(i, k, j)
 350             IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
 351               ubd = ud(i-1, k, j)
 352               ub = u(i-1, k, j)
 353             END IF
 354             fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i-1, k, &
 355 &              j)+ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i-1, k, j)+ubd))
 356             fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i-1, k, j)+&
 357 &              ub)
 358           END DO
 359         END IF
 360         DO k=kts,ktf
 361           i = ide - 1
 362           veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
 363           vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
 364           fqxd(i, k) = veld*(7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+&
 365 &            u(i-2, k, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i-1, k, j))-ud&
 366 &            (i+1, k, j)-ud(i-2, k, j))/12.0
 367           fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
 368 &            (i-2, k, j)))/12.0)
 369         END DO
 370       END IF
 371 !  x flux-divergence into tendency
 372       DO k=kts,ktf
 373         DO i=i_start,i_end
 374 ! ADT eqn 44, 1st term on RHS
 375           mrdx = msfux(i, j)*rdx
 376           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
 377 &            fqxd(i, k))
 378           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
 379 &            i, k))
 380         END DO
 381       END DO
 382     END DO
 383   ELSE IF (horz_order .EQ. 5) THEN
 384 !  5th order horizontal flux calculation
 385 !  This code is EXACTLY the same as the 6th order code
 386 !  EXCEPT the 5th order and 3rd operators are used in
 387 !  place of the 6th and 4th order operators
 388 !  determine boundary mods for flux operators
 389 !  We degrade the flux operators from 3rd/4th order
 390 !   to second order one gridpoint in from the boundaries for
 391 !   all boundary conditions except periodic and symmetry - these
 392 !   conditions have boundary zone data fill for correct application
 393 !   of the higher order flux stencils
 394     degrade_xs = .true.
 395     degrade_xe = .true.
 396     degrade_ys = .true.
 397     degrade_ye = .true.
 398     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
 399 &        its .GT. ids + 3) degrade_xs = .false.
 400     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
 401 &        ite .LT. ide - 2) degrade_xe = .false.
 402     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
 403 &        jts .GT. jds + 3) degrade_ys = .false.
 404     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
 405 &        jte .LT. jde - 4) degrade_ye = .false.
 406 !--------------- y - advection first
 407     i_start = its
 408     i_end = ite
 409     IF (config_flags%open_xs .OR. specified) THEN
 410       IF (ids + 1 .LT. its) THEN
 411         i_start = its
 412       ELSE
 413         i_start = ids + 1
 414       END IF
 415     END IF
 416     IF (config_flags%open_xe .OR. specified) THEN
 417       IF (ide - 1 .GT. ite) THEN
 418         i_end = ite
 419       ELSE
 420         i_end = ide - 1
 421       END IF
 422     END IF
 423     IF (config_flags%periodic_x) i_start = its
 424     IF (config_flags%periodic_x) i_end = ite
 425     j_start = jts
 426     IF (jte .GT. jde - 1) THEN
 427       j_end = jde - 1
 428     ELSE
 429       j_end = jte
 430     END IF
 431 !  higher order flux has a 5 or 7 point stencil, so compute
 432 !  bounds so we can switch to second order flux close to the boundary
 433     j_start_f = j_start
 434     j_end_f = j_end + 1
 435     IF (degrade_ys) THEN
 436       IF (jts .LT. jds + 1) THEN
 437         j_start = jds + 1
 438       ELSE
 439         j_start = jts
 440       END IF
 441       j_start_f = jds + 3
 442     END IF
 443     IF (degrade_ye) THEN
 444       IF (jte .GT. jde - 2) THEN
 445         j_end = jde - 2
 446       ELSE
 447         j_end = jte
 448       END IF
 449       j_end_f = jde - 3
 450     END IF
 451     IF (config_flags%polar) THEN
 452       IF (jte .GT. jde - 1) THEN
 453         j_end = jde - 1
 454       ELSE
 455         j_end = jte
 456       END IF
 457     END IF
 458 !  compute fluxes, 5th or 6th order
 459     jp1 = 2
 460     jp0 = 1
 461     fqyd = 0.0
 462 j_loop_y_flux_5:DO j=j_start,j_end+1
 463       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
 464 ! use full stencil
 465         DO k=kts,ktf
 466           DO i=i_start,i_end
 467             veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
 468             vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
 469             fqyd(i, k, jp1) = veld*((37.*(u(i, k, j)+u(i, k, j-1))-8.*(u&
 470 &              (i, k, j+1)+u(i, k, j-2))+(u(i, k, j+2)+u(i, k, j-3)))/&
 471 &              60.0-SIGN(1, time_step)*SIGN(1., vel)*(u(i, k, j+2)-u(i, k&
 472 &              , j-3)-5.*(u(i, k, j+1)-u(i, k, j-2))+10.*(u(i, k, j)-u(i&
 473 &              , k, j-1)))/60.0) + vel*((37.*(ud(i, k, j)+ud(i, k, j-1))-&
 474 &              8.*(ud(i, k, j+1)+ud(i, k, j-2))+ud(i, k, j+2)+ud(i, k, j-&
 475 &              3))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(ud(i, k, j+2)-&
 476 &              ud(i, k, j-3)-5.*(ud(i, k, j+1)-ud(i, k, j-2))+10.*(ud(i, &
 477 &              k, j)-ud(i, k, j-1)))/60.0)
 478             fqy(i, k, jp1) = vel*((37.*(u(i, k, j)+u(i, k, j-1))-8.*(u(i&
 479 &              , k, j+1)+u(i, k, j-2))+(u(i, k, j+2)+u(i, k, j-3)))/60.0-&
 480 &              SIGN(1, time_step)*SIGN(1., vel)*(u(i, k, j+2)-u(i, k, j-3&
 481 &              )-5.*(u(i, k, j+1)-u(i, k, j-2))+10.*(u(i, k, j)-u(i, k, j&
 482 &              -1)))/60.0)
 483           END DO
 484         END DO
 485       ELSE IF (j .EQ. jds + 1) THEN
 486 !  we must be close to some boundary where we need to reduce the order of the stencil
 487 ! 2nd order flux next to south boundary
 488         DO k=kts,ktf
 489           DO i=i_start,i_end
 490             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
 491 &              k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
 492 &              j)+ud(i, k, j-1)))
 493             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
 494 &              )+u(i, k, j-1))
 495           END DO
 496         END DO
 497       ELSE IF (j .EQ. jds + 2) THEN
 498 ! third of 4th order flux 2 in from south boundary
 499         DO k=kts,ktf
 500           DO i=i_start,i_end
 501             veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
 502             vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
 503             fqyd(i, k, jp1) = veld*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, &
 504 &              k, j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
 505 &              vel)*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1&
 506 &              )))/12.0) + vel*((7.*(ud(i, k, j)+ud(i, k, j-1))-ud(i, k, &
 507 &              j+1)-ud(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
 508 &              (ud(i, k, j+1)-ud(i, k, j-2)-3.*(ud(i, k, j)-ud(i, k, j-1)&
 509 &              ))/12.0)
 510             fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
 511 &              , j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
 512 &              )*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))&
 513 &              /12.0)
 514           END DO
 515         END DO
 516       ELSE IF (j .EQ. jde - 1) THEN
 517 ! 2nd order flux next to north boundary
 518         DO k=kts,ktf
 519           DO i=i_start,i_end
 520             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
 521 &              k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
 522 &              j)+ud(i, k, j-1)))
 523             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
 524 &              )+u(i, k, j-1))
 525           END DO
 526         END DO
 527       ELSE IF (j .EQ. jde - 2) THEN
 528 ! 3rd order flux 2 in from north boundary
 529         DO k=kts,ktf
 530           DO i=i_start,i_end
 531             veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
 532             vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
 533             fqyd(i, k, jp1) = veld*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, &
 534 &              k, j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
 535 &              vel)*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1&
 536 &              )))/12.0) + vel*((7.*(ud(i, k, j)+ud(i, k, j-1))-ud(i, k, &
 537 &              j+1)-ud(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
 538 &              (ud(i, k, j+1)-ud(i, k, j-2)-3.*(ud(i, k, j)-ud(i, k, j-1)&
 539 &              ))/12.0)
 540             fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
 541 &              , j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
 542 &              )*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))&
 543 &              /12.0)
 544           END DO
 545         END DO
 546       END IF
 547 !  y flux-divergence into tendency
 548 ! (j > j_start) will miss the u(,,jds) tendency
 549       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
 550         DO k=kts,ktf
 551           DO i=i_start,i_end
 552 ! ADT eqn 44, 2nd term on RHS
 553             mrdy = msfux(i, j-1)*rdy
 554             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
 555 &              , jp1)
 556             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
 557 &              jp1)
 558           END DO
 559         END DO
 560       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
 561 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 562         DO k=kts,ktf
 563           DO i=i_start,i_end
 564 ! ADT eqn 44, 2nd term on RHS
 565             mrdy = msfux(i, j-1)*rdy
 566             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
 567 &              , jp0)
 568             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
 569 &              jp0)
 570           END DO
 571         END DO
 572       ELSE IF (j .GT. j_start) THEN
 573 ! normal code
 574         DO k=kts,ktf
 575           DO i=i_start,i_end
 576 ! ADT eqn 44, 2nd term on RHS
 577             mrdy = msfux(i, j-1)*rdy
 578             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
 579 &              k, jp1)-fqyd(i, k, jp0))
 580             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
 581 &              jp1)-fqy(i, k, jp0))
 582           END DO
 583         END DO
 584       END IF
 585       jtmp = jp1
 586       jp1 = jp0
 587       jp0 = jtmp
 588     END DO j_loop_y_flux_5
 589 !  next, x - flux divergence
 590     i_start = its
 591     i_end = ite
 592     j_start = jts
 593     IF (jte .GT. jde - 1) THEN
 594       j_end = jde - 1
 595     ELSE
 596       j_end = jte
 597     END IF
 598 !  higher order flux has a 5 or 7 point stencil, so compute
 599 !  bounds so we can switch to second order flux close to the boundary
 600     i_start_f = i_start
 601     i_end_f = i_end + 1
 602     IF (degrade_xs) THEN
 603       IF (ids + 1 .LT. its) THEN
 604         i_start = its
 605       ELSE
 606         i_start = ids + 1
 607       END IF
 608       i_start_f = ids + 3
 609     END IF
 610     IF (degrade_xe) THEN
 611       IF (ide - 1 .GT. ite) THEN
 612         i_end = ite
 613       ELSE
 614         i_end = ide - 1
 615       END IF
 616       i_end_f = ide - 2
 617       fqxd = 0.0
 618     ELSE
 619       fqxd = 0.0
 620     END IF
 621 !  compute fluxes
 622     DO j=j_start,j_end
 623 !  5th or 6th order flux
 624       DO k=kts,ktf
 625         DO i=i_start_f,i_end_f
 626           veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
 627           vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
 628           fqxd(i, k) = veld*((37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k&
 629 &            , j)+u(i-2, k, j))+(u(i+2, k, j)+u(i-3, k, j)))/60.0-SIGN(1&
 630 &            , time_step)*SIGN(1., vel)*(u(i+2, k, j)-u(i-3, k, j)-5.*(u(&
 631 &            i+1, k, j)-u(i-2, k, j))+10.*(u(i, k, j)-u(i-1, k, j)))/60.0&
 632 &            ) + vel*((37.*(ud(i, k, j)+ud(i-1, k, j))-8.*(ud(i+1, k, j)+&
 633 &            ud(i-2, k, j))+ud(i+2, k, j)+ud(i-3, k, j))/60.0-SIGN(1, &
 634 &            time_step)*SIGN(1., vel)*(ud(i+2, k, j)-ud(i-3, k, j)-5.*(ud&
 635 &            (i+1, k, j)-ud(i-2, k, j))+10.*(ud(i, k, j)-ud(i-1, k, j)))/&
 636 &            60.0)
 637           fqx(i, k) = vel*((37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k, &
 638 &            j)+u(i-2, k, j))+(u(i+2, k, j)+u(i-3, k, j)))/60.0-SIGN(1, &
 639 &            time_step)*SIGN(1., vel)*(u(i+2, k, j)-u(i-3, k, j)-5.*(u(i+&
 640 &            1, k, j)-u(i-2, k, j))+10.*(u(i, k, j)-u(i-1, k, j)))/60.0)
 641         END DO
 642       END DO
 643 !  lower order fluxes close to boundaries (if not periodic or symmetric)
 644 !  specified uses upstream normal wind at boundaries
 645       IF (degrade_xs) THEN
 646         IF (i_start .EQ. ids + 1) THEN
 647 ! second order flux next to the boundary
 648           i = ids + 1
 649           DO k=kts,ktf
 650             ubd = ud(i-1, k, j)
 651             ub = u(i-1, k, j)
 652             IF (specified .AND. u(i, k, j) .LT. 0.) THEN
 653               ubd = ud(i, k, j)
 654               ub = u(i, k, j)
 655             END IF
 656             fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i, k, j)&
 657 &              +ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)+ubd))
 658             fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i, k, j)+ub)
 659           END DO
 660         END IF
 661         i = ids + 2
 662         DO k=kts,ktf
 663           veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
 664           vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
 665           fqxd(i, k) = veld*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)&
 666 &            +u(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1&
 667 &            , k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0) + &
 668 &            vel*((7.*(ud(i, k, j)+ud(i-1, k, j))-ud(i+1, k, j)-ud(i-2, k&
 669 &            , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i+1, k, j)-&
 670 &            ud(i-2, k, j)-3.*(ud(i, k, j)-ud(i-1, k, j)))/12.0)
 671           fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
 672 &            (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, &
 673 &            k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0)
 674         END DO
 675       END IF
 676       IF (degrade_xe) THEN
 677         IF (i_end .EQ. ide - 1) THEN
 678 ! second order flux next to the boundary
 679           i = ide
 680           DO k=kts,ktf
 681             ubd = ud(i, k, j)
 682             ub = u(i, k, j)
 683             IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
 684               ubd = ud(i-1, k, j)
 685               ub = u(i-1, k, j)
 686             END IF
 687             fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i-1, k, &
 688 &              j)+ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i-1, k, j)+ubd))
 689             fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i-1, k, j)+&
 690 &              ub)
 691           END DO
 692         END IF
 693         DO k=kts,ktf
 694           i = ide - 1
 695           veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
 696           vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
 697           fqxd(i, k) = veld*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)&
 698 &            +u(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1&
 699 &            , k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0) + &
 700 &            vel*((7.*(ud(i, k, j)+ud(i-1, k, j))-ud(i+1, k, j)-ud(i-2, k&
 701 &            , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i+1, k, j)-&
 702 &            ud(i-2, k, j)-3.*(ud(i, k, j)-ud(i-1, k, j)))/12.0)
 703           fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
 704 &            (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, &
 705 &            k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0)
 706         END DO
 707       END IF
 708 !  x flux-divergence into tendency
 709       DO k=kts,ktf
 710         DO i=i_start,i_end
 711 ! ADT eqn 44, 1st term on RHS
 712           mrdx = msfux(i, j)*rdx
 713           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
 714 &            fqxd(i, k))
 715           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
 716 &            i, k))
 717         END DO
 718       END DO
 719     END DO
 720   ELSE IF (horz_order .EQ. 4) THEN
 721 !  determine boundary mods for flux operators
 722 !  We degrade the flux operators from 3rd/4th order
 723 !   to second order one gridpoint in from the boundaries for
 724 !   all boundary conditions except periodic and symmetry - these
 725 !   conditions have boundary zone data fill for correct application
 726 !   of the higher order flux stencils
 727     degrade_xs = .true.
 728     degrade_xe = .true.
 729     degrade_ys = .true.
 730     degrade_ye = .true.
 731     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
 732 &        its .GT. ids + 2) degrade_xs = .false.
 733     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
 734 &        ite .LT. ide - 1) degrade_xe = .false.
 735     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
 736 &        jts .GT. jds + 2) degrade_ys = .false.
 737     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
 738 &        jte .LT. jde - 3) degrade_ye = .false.
 739 !--------------- x - advection first
 740     i_start = its
 741     i_end = ite
 742     j_start = jts
 743     IF (jte .GT. jde - 1) THEN
 744       j_end = jde - 1
 745     ELSE
 746       j_end = jte
 747     END IF
 748 !  3rd or 4th order flux has a 5 point stencil, so compute
 749 !  bounds so we can switch to second order flux close to the boundary
 750     i_start_f = i_start
 751     i_end_f = i_end + 1
 752     IF (degrade_xs) THEN
 753       i_start = ids + 1
 754       i_start_f = i_start + 1
 755     END IF
 756     IF (degrade_xe) THEN
 757       i_end = ide - 1
 758       i_end_f = ide - 1
 759       fqxd = 0.0
 760     ELSE
 761       fqxd = 0.0
 762     END IF
 763 !  compute fluxes
 764     DO j=j_start,j_end
 765       DO k=kts,ktf
 766         DO i=i_start_f,i_end_f
 767           veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
 768           vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
 769           fqxd(i, k) = veld*(7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+&
 770 &            u(i-2, k, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i-1, k, j))-ud&
 771 &            (i+1, k, j)-ud(i-2, k, j))/12.0
 772           fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
 773 &            (i-2, k, j)))/12.0)
 774         END DO
 775       END DO
 776 !  second order flux close to boundaries (if not periodic or symmetric)
 777 !  specified uses upstream normal wind at boundaries
 778       IF (degrade_xs) THEN
 779         i = i_start
 780         DO k=kts,ktf
 781           ubd = ud(i-1, k, j)
 782           ub = u(i-1, k, j)
 783           IF (specified .AND. u(i, k, j) .LT. 0.) THEN
 784             ubd = ud(i, k, j)
 785             ub = u(i, k, j)
 786           END IF
 787           fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i, k, j)+&
 788 &            ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)+ubd))
 789           fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i, k, j)+ub)
 790         END DO
 791       END IF
 792       IF (degrade_xe) THEN
 793         i = i_end + 1
 794         DO k=kts,ktf
 795           ubd = ud(i, k, j)
 796           ub = u(i, k, j)
 797           IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
 798             ubd = ud(i-1, k, j)
 799             ub = u(i-1, k, j)
 800           END IF
 801           fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i-1, k, j)&
 802 &            +ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i-1, k, j)+ubd))
 803           fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i-1, k, j)+ub)
 804         END DO
 805       END IF
 806 !  x flux-divergence into tendency
 807       DO k=kts,ktf
 808         DO i=i_start,i_end
 809 ! ADT eqn 44, 1st term on RHS
 810           mrdx = msfux(i, j)*rdx
 811           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
 812 &            fqxd(i, k))
 813           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
 814 &            i, k))
 815         END DO
 816       END DO
 817     END DO
 818 !  y flux divergence
 819     i_start = its
 820     i_end = ite
 821     IF (config_flags%open_xs .OR. specified) THEN
 822       IF (ids + 1 .LT. its) THEN
 823         i_start = its
 824       ELSE
 825         i_start = ids + 1
 826       END IF
 827     END IF
 828     IF (config_flags%open_xe .OR. specified) THEN
 829       IF (ide - 1 .GT. ite) THEN
 830         i_end = ite
 831       ELSE
 832         i_end = ide - 1
 833       END IF
 834     END IF
 835     IF (config_flags%periodic_x) i_start = its
 836     IF (config_flags%periodic_x) i_end = ite
 837     j_start = jts
 838     IF (jte .GT. jde - 1) THEN
 839       j_end = jde - 1
 840     ELSE
 841       j_end = jte
 842     END IF
 843 !  3rd or 4th order flux has a 5 point stencil, so compute
 844 !  bounds so we can switch to second order flux close to the boundary
 845     j_start_f = j_start
 846     j_end_f = j_end + 1
 847 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
 848     IF (degrade_ys) THEN
 849       j_start = jds + 1
 850       j_start_f = j_start + 1
 851     END IF
 852     IF (degrade_ye) THEN
 853       j_end = jde - 2
 854       j_end_f = jde - 2
 855     END IF
 856     IF (config_flags%polar) THEN
 857       IF (jte .GT. jde - 1) THEN
 858         j_end = jde - 1
 859       ELSE
 860         j_end = jte
 861       END IF
 862     END IF
 863 !  j flux loop for v flux of u momentum
 864     jp1 = 2
 865     jp0 = 1
 866     fqyd = 0.0
 867     DO j=j_start,j_end+1
 868       IF (j .LT. j_start_f .AND. degrade_ys) THEN
 869         DO k=kts,ktf
 870           DO i=i_start,i_end
 871             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j_start)+rvd(i-1, k, &
 872 &              j_start))*(u(i, k, j_start)+u(i, k, j_start-1))+(rv(i, k, &
 873 &              j_start)+rv(i-1, k, j_start))*(ud(i, k, j_start)+ud(i, k, &
 874 &              j_start-1)))
 875             fqy(i, k, jp1) = 0.25*(rv(i, k, j_start)+rv(i-1, k, j_start)&
 876 &              )*(u(i, k, j_start)+u(i, k, j_start-1))
 877           END DO
 878         END DO
 879       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
 880         DO k=kts,ktf
 881           DO i=i_start,i_end
 882 ! Assumes j>j_end_f is ONLY j_end+1 ...
 883 !         fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1))    &
 884 !                *(u(i,k,j_end+1)+u(i,k,j_end))
 885             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
 886 &              k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
 887 &              j)+ud(i, k, j-1)))
 888             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
 889 &              )+u(i, k, j-1))
 890           END DO
 891         END DO
 892       ELSE
 893 !  3rd or 4th order flux
 894         DO k=kts,ktf
 895           DO i=i_start,i_end
 896             veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
 897             vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
 898             fqyd(i, k, jp1) = veld*(7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
 899 &              , j+1)+u(i, k, j-2)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k&
 900 &              , j-1))-ud(i, k, j+1)-ud(i, k, j-2))/12.0
 901             fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
 902 &              , j+1)+u(i, k, j-2)))/12.0)
 903           END DO
 904         END DO
 905       END IF
 906 !  y flux-divergence into tendency
 907 ! (j > j_start) will miss the u(,,jds) tendency
 908       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
 909         DO k=kts,ktf
 910           DO i=i_start,i_end
 911 ! ADT eqn 44, 2nd term on RHS
 912             mrdy = msfux(i, j-1)*rdy
 913             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
 914 &              , jp1)
 915             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
 916 &              jp1)
 917           END DO
 918         END DO
 919       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
 920 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
 921         DO k=kts,ktf
 922           DO i=i_start,i_end
 923 ! ADT eqn 44, 2nd term on RHS
 924             mrdy = msfux(i, j-1)*rdy
 925             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
 926 &              , jp0)
 927             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
 928 &              jp0)
 929           END DO
 930         END DO
 931       ELSE IF (j .GT. j_start) THEN
 932 ! normal code
 933         DO k=kts,ktf
 934           DO i=i_start,i_end
 935 ! ADT eqn 44, 2nd term on RHS
 936             mrdy = msfux(i, j-1)*rdy
 937             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
 938 &              k, jp1)-fqyd(i, k, jp0))
 939             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
 940 &              jp1)-fqy(i, k, jp0))
 941           END DO
 942         END DO
 943       END IF
 944       jtmp = jp1
 945       jp1 = jp0
 946       jp0 = jtmp
 947     END DO
 948   ELSE IF (horz_order .EQ. 3) THEN
 949 !  As with the 5th and 6th order flux chioces, the 3rd and 4th order
 950 !  code is EXACTLY the same EXCEPT for the flux operator.
 951 !  determine boundary mods for flux operators
 952 !  We degrade the flux operators from 3rd/4th order
 953 !   to second order one gridpoint in from the boundaries for
 954 !   all boundary conditions except periodic and symmetry - these
 955 !   conditions have boundary zone data fill for correct application
 956 !   of the higher order flux stencils
 957     degrade_xs = .true.
 958     degrade_xe = .true.
 959     degrade_ys = .true.
 960     degrade_ye = .true.
 961     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
 962 &        its .GT. ids + 2) degrade_xs = .false.
 963     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
 964 &        ite .LT. ide - 1) degrade_xe = .false.
 965     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
 966 &        jts .GT. jds + 2) degrade_ys = .false.
 967     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
 968 &        jte .LT. jde - 3) degrade_ye = .false.
 969 !--------------- x - advection first
 970     i_start = its
 971     i_end = ite
 972     j_start = jts
 973     IF (jte .GT. jde - 1) THEN
 974       j_end = jde - 1
 975     ELSE
 976       j_end = jte
 977     END IF
 978 !  3rd or 4th order flux has a 5 point stencil, so compute
 979 !  bounds so we can switch to second order flux close to the boundary
 980     i_start_f = i_start
 981     i_end_f = i_end + 1
 982     IF (degrade_xs) THEN
 983       i_start = ids + 1
 984       i_start_f = i_start + 1
 985     END IF
 986     IF (degrade_xe) THEN
 987       i_end = ide - 1
 988       i_end_f = ide - 1
 989       fqxd = 0.0
 990     ELSE
 991       fqxd = 0.0
 992     END IF
 993 !  compute fluxes
 994     DO j=j_start,j_end
 995       DO k=kts,ktf
 996         DO i=i_start_f,i_end_f
 997           veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
 998           vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
 999           fqxd(i, k) = veld*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)&
1000 &            +u(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1&
1001 &            , k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0) + &
1002 &            vel*((7.*(ud(i, k, j)+ud(i-1, k, j))-ud(i+1, k, j)-ud(i-2, k&
1003 &            , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i+1, k, j)-&
1004 &            ud(i-2, k, j)-3.*(ud(i, k, j)-ud(i-1, k, j)))/12.0)
1005           fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
1006 &            (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, &
1007 &            k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0)
1008         END DO
1009       END DO
1010 !  second order flux close to boundaries (if not periodic or symmetric)
1011 !  specified uses upstream normal wind at boundaries
1012       IF (degrade_xs) THEN
1013         i = i_start
1014         DO k=kts,ktf
1015           ubd = ud(i-1, k, j)
1016           ub = u(i-1, k, j)
1017           IF (specified .AND. u(i, k, j) .LT. 0.) THEN
1018             ubd = ud(i, k, j)
1019             ub = u(i, k, j)
1020           END IF
1021           fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i, k, j)+&
1022 &            ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)+ubd))
1023           fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i, k, j)+ub)
1024         END DO
1025       END IF
1026       IF (degrade_xe) THEN
1027         i = i_end + 1
1028         DO k=kts,ktf
1029           ubd = ud(i, k, j)
1030           ub = u(i, k, j)
1031           IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
1032             ubd = ud(i-1, k, j)
1033             ub = u(i-1, k, j)
1034           END IF
1035           fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i-1, k, j)&
1036 &            +ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i-1, k, j)+ubd))
1037           fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i-1, k, j)+ub)
1038         END DO
1039       END IF
1040 !  x flux-divergence into tendency
1041       DO k=kts,ktf
1042         DO i=i_start,i_end
1043 ! ADT eqn 44, 1st term on RHS
1044           mrdx = msfux(i, j)*rdx
1045           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
1046 &            fqxd(i, k))
1047           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
1048 &            i, k))
1049         END DO
1050       END DO
1051     END DO
1052 !  y flux divergence
1053     i_start = its
1054     i_end = ite
1055     IF (config_flags%open_xs .OR. specified) THEN
1056       IF (ids + 1 .LT. its) THEN
1057         i_start = its
1058       ELSE
1059         i_start = ids + 1
1060       END IF
1061     END IF
1062     IF (config_flags%open_xe .OR. specified) THEN
1063       IF (ide - 1 .GT. ite) THEN
1064         i_end = ite
1065       ELSE
1066         i_end = ide - 1
1067       END IF
1068     END IF
1069     IF (config_flags%periodic_x) i_start = its
1070     IF (config_flags%periodic_x) i_end = ite
1071     j_start = jts
1072     IF (jte .GT. jde - 1) THEN
1073       j_end = jde - 1
1074     ELSE
1075       j_end = jte
1076     END IF
1077 !  3rd or 4th order flux has a 5 point stencil, so compute
1078 !  bounds so we can switch to second order flux close to the boundary
1079     j_start_f = j_start
1080     j_end_f = j_end + 1
1081 !CJM these may not work with tiling because they define j_start and end in terms of domain dim
1082     IF (degrade_ys) THEN
1083       j_start = jds + 1
1084       j_start_f = j_start + 1
1085     END IF
1086     IF (degrade_ye) THEN
1087       j_end = jde - 2
1088       j_end_f = jde - 2
1089     END IF
1090     IF (config_flags%polar) THEN
1091       IF (jte .GT. jde - 1) THEN
1092         j_end = jde - 1
1093       ELSE
1094         j_end = jte
1095       END IF
1096     END IF
1097 !  j flux loop for v flux of u momentum
1098     jp1 = 2
1099     jp0 = 1
1100     fqyd = 0.0
1101     DO j=j_start,j_end+1
1102       IF (j .LT. j_start_f .AND. degrade_ys) THEN
1103         DO k=kts,ktf
1104           DO i=i_start,i_end
1105             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j_start)+rvd(i-1, k, &
1106 &              j_start))*(u(i, k, j_start)+u(i, k, j_start-1))+(rv(i, k, &
1107 &              j_start)+rv(i-1, k, j_start))*(ud(i, k, j_start)+ud(i, k, &
1108 &              j_start-1)))
1109             fqy(i, k, jp1) = 0.25*(rv(i, k, j_start)+rv(i-1, k, j_start)&
1110 &              )*(u(i, k, j_start)+u(i, k, j_start-1))
1111           END DO
1112         END DO
1113       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
1114         DO k=kts,ktf
1115           DO i=i_start,i_end
1116 ! Assumes j>j_end_f is ONLY j_end+1 ...
1117 !         fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1))    &
1118 !                *(u(i,k,j_end+1)+u(i,k,j_end))
1119             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
1120 &              k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
1121 &              j)+ud(i, k, j-1)))
1122             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
1123 &              )+u(i, k, j-1))
1124           END DO
1125         END DO
1126       ELSE
1127 !  3rd or 4th order flux
1128         DO k=kts,ktf
1129           DO i=i_start,i_end
1130             veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
1131             vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
1132             fqyd(i, k, jp1) = veld*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, &
1133 &              k, j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
1134 &              vel)*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1&
1135 &              )))/12.0) + vel*((7.*(ud(i, k, j)+ud(i, k, j-1))-ud(i, k, &
1136 &              j+1)-ud(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
1137 &              (ud(i, k, j+1)-ud(i, k, j-2)-3.*(ud(i, k, j)-ud(i, k, j-1)&
1138 &              ))/12.0)
1139             fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
1140 &              , j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
1141 &              )*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))&
1142 &              /12.0)
1143           END DO
1144         END DO
1145       END IF
1146 !  y flux-divergence into tendency
1147 ! (j > j_start) will miss the u(,,jds) tendency
1148       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
1149         DO k=kts,ktf
1150           DO i=i_start,i_end
1151 ! ADT eqn 44, 2nd term on RHS
1152             mrdy = msfux(i, j-1)*rdy
1153             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
1154 &              , jp1)
1155             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
1156 &              jp1)
1157           END DO
1158         END DO
1159       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
1160 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
1161         DO k=kts,ktf
1162           DO i=i_start,i_end
1163 ! ADT eqn 44, 2nd term on RHS
1164             mrdy = msfux(i, j-1)*rdy
1165             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
1166 &              , jp0)
1167             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
1168 &              jp0)
1169           END DO
1170         END DO
1171       ELSE IF (j .GT. j_start) THEN
1172 ! normal code
1173         DO k=kts,ktf
1174           DO i=i_start,i_end
1175 ! ADT eqn 44, 2nd term on RHS
1176             mrdy = msfux(i, j-1)*rdy
1177             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
1178 &              k, jp1)-fqyd(i, k, jp0))
1179             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
1180 &              jp1)-fqy(i, k, jp0))
1181           END DO
1182         END DO
1183       END IF
1184       jtmp = jp1
1185       jp1 = jp0
1186       jp0 = jtmp
1187     END DO
1188   ELSE IF (horz_order .EQ. 2) THEN
1189     i_start = its
1190     i_end = ite
1191     j_start = jts
1192     IF (jte .GT. jde - 1) THEN
1193       j_end = jde - 1
1194     ELSE
1195       j_end = jte
1196     END IF
1197     IF (config_flags%open_xs) THEN
1198       IF (ids + 1 .LT. its) THEN
1199         i_start = its
1200       ELSE
1201         i_start = ids + 1
1202       END IF
1203     END IF
1204     IF (config_flags%open_xe) THEN
1205       IF (ide - 1 .GT. ite) THEN
1206         i_end = ite
1207       ELSE
1208         i_end = ide - 1
1209       END IF
1210     END IF
1211     IF (specified) THEN
1212       IF (ids + 2 .LT. its) THEN
1213         i_start = its
1214       ELSE
1215         i_start = ids + 2
1216       END IF
1217     END IF
1218     IF (specified) THEN
1219       IF (ide - 2 .GT. ite) THEN
1220         i_end = ite
1221       ELSE
1222         i_end = ide - 2
1223       END IF
1224     END IF
1225     IF (config_flags%periodic_x) i_start = its
1226     IF (config_flags%periodic_x) i_end = ite
1227     DO j=j_start,j_end
1228       DO k=kts,ktf
1229         DO i=i_start,i_end
1230 ! ADT eqn 44, 1st term on RHS
1231           mrdx = msfux(i, j)*rdx
1232           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.25*((rud(i+1&
1233 &            , k, j)+rud(i, k, j))*(u(i+1, k, j)+u(i, k, j))+(ru(i+1, k, &
1234 &            j)+ru(i, k, j))*(ud(i+1, k, j)+ud(i, k, j))-(rud(i, k, j)+&
1235 &            rud(i-1, k, j))*(u(i, k, j)+u(i-1, k, j))-(ru(i, k, j)+ru(i-&
1236 &            1, k, j))*(ud(i, k, j)+ud(i-1, k, j)))
1237           tendency(i, k, j) = tendency(i, k, j) - mrdx*0.25*((ru(i+1, k&
1238 &            , j)+ru(i, k, j))*(u(i+1, k, j)+u(i, k, j))-(ru(i, k, j)+ru(&
1239 &            i-1, k, j))*(u(i, k, j)+u(i-1, k, j)))
1240         END DO
1241       END DO
1242     END DO
1243     IF (specified .AND. its .LE. ids + 1 .AND. (.NOT.config_flags%&
1244 &        periodic_x)) THEN
1245       DO j=j_start,j_end
1246         DO k=kts,ktf
1247           i = ids + 1
1248 ! ADT eqn 44, 1st term on RHS
1249           mrdx = msfux(i, j)*rdx
1250           ubd = ud(i-1, k, j)
1251           ub = u(i-1, k, j)
1252           IF (u(i, k, j) .LT. 0.) THEN
1253             ubd = ud(i, k, j)
1254             ub = u(i, k, j)
1255           END IF
1256           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.25*((rud(i+1&
1257 &            , k, j)+rud(i, k, j))*(u(i+1, k, j)+u(i, k, j))+(ru(i+1, k, &
1258 &            j)+ru(i, k, j))*(ud(i+1, k, j)+ud(i, k, j))-(rud(i, k, j)+&
1259 &            rud(i-1, k, j))*(u(i, k, j)+ub)-(ru(i, k, j)+ru(i-1, k, j))*&
1260 &            (ud(i, k, j)+ubd))
1261           tendency(i, k, j) = tendency(i, k, j) - mrdx*0.25*((ru(i+1, k&
1262 &            , j)+ru(i, k, j))*(u(i+1, k, j)+u(i, k, j))-(ru(i, k, j)+ru(&
1263 &            i-1, k, j))*(u(i, k, j)+ub))
1264         END DO
1265       END DO
1266     END IF
1267     IF (specified .AND. ite .GE. ide - 1 .AND. (.NOT.config_flags%&
1268 &        periodic_x)) THEN
1269       DO j=j_start,j_end
1270         DO k=kts,ktf
1271           i = ide - 1
1272 ! ADT eqn 44, 1st term on RHS
1273           mrdx = msfux(i, j)*rdx
1274           ubd = ud(i+1, k, j)
1275           ub = u(i+1, k, j)
1276           IF (u(i, k, j) .GT. 0.) THEN
1277             ubd = ud(i, k, j)
1278             ub = u(i, k, j)
1279           END IF
1280           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.25*((rud(i+1&
1281 &            , k, j)+rud(i, k, j))*(ub+u(i, k, j))+(ru(i+1, k, j)+ru(i, k&
1282 &            , j))*(ubd+ud(i, k, j))-(rud(i, k, j)+rud(i-1, k, j))*(u(i, &
1283 &            k, j)+u(i-1, k, j))-(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)&
1284 &            +ud(i-1, k, j)))
1285           tendency(i, k, j) = tendency(i, k, j) - mrdx*0.25*((ru(i+1, k&
1286 &            , j)+ru(i, k, j))*(ub+u(i, k, j))-(ru(i, k, j)+ru(i-1, k, j)&
1287 &            )*(u(i, k, j)+u(i-1, k, j)))
1288         END DO
1289       END DO
1290     END IF
1291     IF (config_flags%open_ys .OR. specified) THEN
1292       IF (jds + 1 .LT. jts) THEN
1293         j_start = jts
1294       ELSE
1295         j_start = jds + 1
1296       END IF
1297     END IF
1298     IF (config_flags%open_ye .OR. specified) THEN
1299       IF (jde - 2 .GT. jte) THEN
1300         j_end = jte
1301       ELSE
1302         j_end = jde - 2
1303       END IF
1304     END IF
1305     DO j=j_start,j_end
1306       DO k=kts,ktf
1307         DO i=i_start,i_end
1308 ! ADT eqn 44, 1st term on RHS
1309           mrdy = msfux(i, j)*rdy
1310 ! Comments for polar boundary condition
1311 ! Flow is only from one side for points next to poles
1312           IF (config_flags%polar .AND. j .EQ. jds) THEN
1313             tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.25*((rvd(i&
1314 &              , k, j+1)+rvd(i-1, k, j+1))*(u(i, k, j+1)+u(i, k, j))+(rv(&
1315 &              i, k, j+1)+rv(i-1, k, j+1))*(ud(i, k, j+1)+ud(i, k, j)))
1316             tendency(i, k, j) = tendency(i, k, j) - mrdy*0.25*(rv(i, k, &
1317 &              j+1)+rv(i-1, k, j+1))*(u(i, k, j+1)+u(i, k, j))
1318           ELSE IF (config_flags%polar .AND. j .EQ. jde - 1) THEN
1319             tendencyd(i, k, j) = tendencyd(i, k, j) + mrdy*0.25*((rvd(i&
1320 &              , k, j)+rvd(i-1, k, j))*(u(i, k, j)+u(i, k, j-1))+(rv(i, k&
1321 &              , j)+rv(i-1, k, j))*(ud(i, k, j)+ud(i, k, j-1)))
1322             tendency(i, k, j) = tendency(i, k, j) + mrdy*0.25*(rv(i, k, &
1323 &              j)+rv(i-1, k, j))*(u(i, k, j)+u(i, k, j-1))
1324           ELSE
1325 ! Normal code
1326             tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.25*((rvd(i&
1327 &              , k, j+1)+rvd(i-1, k, j+1))*(u(i, k, j+1)+u(i, k, j))+(rv(&
1328 &              i, k, j+1)+rv(i-1, k, j+1))*(ud(i, k, j+1)+ud(i, k, j))-(&
1329 &              rvd(i, k, j)+rvd(i-1, k, j))*(u(i, k, j)+u(i, k, j-1))-(rv&
1330 &              (i, k, j)+rv(i-1, k, j))*(ud(i, k, j)+ud(i, k, j-1)))
1331             tendency(i, k, j) = tendency(i, k, j) - mrdy*0.25*((rv(i, k&
1332 &              , j+1)+rv(i-1, k, j+1))*(u(i, k, j+1)+u(i, k, j))-(rv(i, k&
1333 &              , j)+rv(i-1, k, j))*(u(i, k, j)+u(i, k, j-1)))
1334           END IF
1335         END DO
1336       END DO
1337     END DO
1338   ELSE IF (horz_order .NE. 0) THEN
1339 ! Just in case we want to turn horizontal advection off, we can do it
1340     WRITE(wrf_err_message, *) &
1341 &    'module_advect: advect_u_6a:  h_order not known ', horz_order
1342     CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
1343   END IF
1344 !  radiative lateral boundary condition in x for normal velocity (u)
1345   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
1346     j_start = jts
1347     IF (jte .GT. jde - 1) THEN
1348       j_end = jde - 1
1349     ELSE
1350       j_end = jte
1351     END IF
1352     DO j=j_start,j_end
1353       DO k=kts,ktf
1354         IF (ru(its, k, j) - cb*mut(its, j) .GT. 0.) THEN
1355           ub = 0.
1356           ubd = 0.0
1357         ELSE
1358           ubd = rud(its, k, j) - cb*mutd(its, j)
1359           ub = ru(its, k, j) - cb*mut(its, j)
1360         END IF
1361         tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(u_old(&
1362 &          its+1, k, j)-u_old(its, k, j))+ub*(u_oldd(its+1, k, j)-u_oldd(&
1363 &          its, k, j)))
1364         tendency(its, k, j) = tendency(its, k, j) - rdx*ub*(u_old(its+1&
1365 &          , k, j)-u_old(its, k, j))
1366       END DO
1367     END DO
1368   END IF
1369   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
1370     j_start = jts
1371     IF (jte .GT. jde - 1) THEN
1372       j_end = jde - 1
1373     ELSE
1374       j_end = jte
1375     END IF
1376     DO j=j_start,j_end
1377       DO k=kts,ktf
1378         IF (ru(ite, k, j) + cb*mut(ite-1, j) .LT. 0.) THEN
1379           ub = 0.
1380           ubd = 0.0
1381         ELSE
1382           ubd = rud(ite, k, j) + cb*mutd(ite-1, j)
1383           ub = ru(ite, k, j) + cb*mut(ite-1, j)
1384         END IF
1385         tendencyd(ite, k, j) = tendencyd(ite, k, j) - rdx*(ubd*(u_old(&
1386 &          ite, k, j)-u_old(ite-1, k, j))+ub*(u_oldd(ite, k, j)-u_oldd(&
1387 &          ite-1, k, j)))
1388         tendency(ite, k, j) = tendency(ite, k, j) - rdx*ub*(u_old(ite, k&
1389 &          , j)-u_old(ite-1, k, j))
1390       END DO
1391     END DO
1392   END IF
1393 !  pick up the rest of the horizontal radiation boundary conditions.
1394 !  (these are the computations that don't require 'cb')
1395 !  first, set to index ranges
1396   i_start = its
1397   IF (ite .GT. ide) THEN
1398     i_end = ide
1399   ELSE
1400     i_end = ite
1401   END IF
1402   imin = ids
1403   imax = ide - 1
1404   IF (config_flags%open_xs) THEN
1405     IF (ids + 1 .LT. its) THEN
1406       i_start = its
1407     ELSE
1408       i_start = ids + 1
1409     END IF
1410     imin = ids
1411   END IF
1412   IF (config_flags%open_xe) THEN
1413     IF (ite .GT. ide - 1) THEN
1414       i_end = ide - 1
1415     ELSE
1416       i_end = ite
1417     END IF
1418     imax = ide - 1
1419   END IF
1420   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
1421     DO i=i_start,i_end
1422 ! ADT eqn 44, 2nd term on RHS
1423       mrdy = msfux(i, jts)*rdy
1424       IF (imax .GT. i) THEN
1425         ip = i
1426       ELSE
1427         ip = imax
1428       END IF
1429       IF (imin .LT. i - 1) THEN
1430         im = i - 1
1431       ELSE
1432         im = imin
1433       END IF
1434       DO k=kts,ktf
1435         vwd = 0.5*(rvd(ip, k, jts)+rvd(im, k, jts))
1436         vw = 0.5*(rv(ip, k, jts)+rv(im, k, jts))
1437         IF (vw .GT. 0.) THEN
1438           vb = 0.
1439           vbd = 0.0
1440         ELSE
1441           vbd = vwd
1442           vb = vw
1443         END IF
1444         dvmd = rvd(ip, k, jts+1) - rvd(ip, k, jts)
1445         dvm = rv(ip, k, jts+1) - rv(ip, k, jts)
1446         dvpd = rvd(im, k, jts+1) - rvd(im, k, jts)
1447         dvp = rv(im, k, jts+1) - rv(im, k, jts)
1448         tendencyd(i, k, jts) = tendencyd(i, k, jts) - mrdy*(vbd*(u_old(i&
1449 &          , k, jts+1)-u_old(i, k, jts))+vb*(u_oldd(i, k, jts+1)-u_oldd(i&
1450 &          , k, jts))+0.5*(ud(i, k, jts)*(dvm+dvp)+u(i, k, jts)*(dvmd+&
1451 &          dvpd)))
1452         tendency(i, k, jts) = tendency(i, k, jts) - mrdy*(vb*(u_old(i, k&
1453 &          , jts+1)-u_old(i, k, jts))+0.5*u(i, k, jts)*(dvm+dvp))
1454       END DO
1455     END DO
1456   END IF
1457   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
1458     DO i=i_start,i_end
1459 ! ADT eqn 44, 2nd term on RHS
1460       mrdy = msfux(i, jte-1)*rdy
1461       IF (imax .GT. i) THEN
1462         ip = i
1463       ELSE
1464         ip = imax
1465       END IF
1466       IF (imin .LT. i - 1) THEN
1467         im = i - 1
1468       ELSE
1469         im = imin
1470       END IF
1471       DO k=kts,ktf
1472         vwd = 0.5*(rvd(ip, k, jte)+rvd(im, k, jte))
1473         vw = 0.5*(rv(ip, k, jte)+rv(im, k, jte))
1474         IF (vw .LT. 0.) THEN
1475           vb = 0.
1476           vbd = 0.0
1477         ELSE
1478           vbd = vwd
1479           vb = vw
1480         END IF
1481         dvmd = rvd(ip, k, jte) - rvd(ip, k, jte-1)
1482         dvm = rv(ip, k, jte) - rv(ip, k, jte-1)
1483         dvpd = rvd(im, k, jte) - rvd(im, k, jte-1)
1484         dvp = rv(im, k, jte) - rv(im, k, jte-1)
1485         tendencyd(i, k, jte-1) = tendencyd(i, k, jte-1) - mrdy*(vbd*(&
1486 &          u_old(i, k, jte-1)-u_old(i, k, jte-2))+vb*(u_oldd(i, k, jte-1)&
1487 &          -u_oldd(i, k, jte-2))+0.5*(ud(i, k, jte-1)*(dvm+dvp)+u(i, k, &
1488 &          jte-1)*(dvmd+dvpd)))
1489         tendency(i, k, jte-1) = tendency(i, k, jte-1) - mrdy*(vb*(u_old(&
1490 &          i, k, jte-1)-u_old(i, k, jte-2))+0.5*u(i, k, jte-1)*(dvm+dvp))
1491       END DO
1492     END DO
1493   END IF
1494 !-------------------- vertical advection
1495 !  ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
1496 !  Here we have:  - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
1497 !  Since 'my' (map scale factor in y-direction) isn't a function of z,
1498 !  this is what we need, so leave unchanged in advect_u
1499   i_start = its
1500   i_end = ite
1501   j_start = jts
1502   IF (jte .GT. jde - 1) THEN
1503     j_end = jde - 1
1504   ELSE
1505     j_end = jte
1506   END IF
1507 !   IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
1508 !   IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
1509   IF (config_flags%open_ys .OR. specified) THEN
1510     IF (ids + 1 .LT. its) THEN
1511       i_start = its
1512     ELSE
1513       i_start = ids + 1
1514     END IF
1515   END IF
1516   IF (config_flags%open_ye .OR. specified) THEN
1517     IF (ide - 1 .GT. ite) THEN
1518       i_end = ite
1519     ELSE
1520       i_end = ide - 1
1521     END IF
1522   END IF
1523   IF (config_flags%periodic_x) i_start = its
1524   IF (config_flags%periodic_x) i_end = ite
1525   DO i=i_start,i_end
1526     vfluxd(i, kts) = 0.0
1527     vflux(i, kts) = 0.
1528     vfluxd(i, kte) = 0.0
1529     vflux(i, kte) = 0.
1530   END DO
1531   IF (vert_order .EQ. 6) THEN
1532     vfluxd = 0.0
1533     DO j=j_start,j_end
1534       DO k=kts+3,ktf-2
1535         DO i=i_start,i_end
1536           veld = 0.5*(romd(i-1, k, j)+romd(i, k, j))
1537           vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
1538           vfluxd(i, k) = veld*(37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k+&
1539 &            1, j)+u(i, k-2, j))+(u(i, k+2, j)+u(i, k-3, j)))/60.0 + vel*&
1540 &            (37.*(ud(i, k, j)+ud(i, k-1, j))-8.*(ud(i, k+1, j)+ud(i, k-2&
1541 &            , j))+ud(i, k+2, j)+ud(i, k-3, j))/60.0
1542           vflux(i, k) = vel*((37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k+1&
1543 &            , j)+u(i, k-2, j))+(u(i, k+2, j)+u(i, k-3, j)))/60.0)
1544         END DO
1545       END DO
1546       DO i=i_start,i_end
1547         k = kts + 1
1548         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
1549 &          , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
1550 &          fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
1551         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
1552 &          j)+fzp(k)*u(i, k-1, j))
1553         k = kts + 2
1554         veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
1555         vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
1556         vfluxd(i, k) = veld*(7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+&
1557 &          u(i, k-2, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k-1, j))-ud(i&
1558 &          , k+1, j)-ud(i, k-2, j))/12.0
1559         vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
1560 &          (i, k-2, j)))/12.0)
1561         k = ktf - 1
1562         veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
1563         vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
1564         vfluxd(i, k) = veld*(7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+&
1565 &          u(i, k-2, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k-1, j))-ud(i&
1566 &          , k+1, j)-ud(i, k-2, j))/12.0
1567         vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
1568 &          (i, k-2, j)))/12.0)
1569         k = ktf
1570         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
1571 &          , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
1572 &          fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
1573         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
1574 &          j)+fzp(k)*u(i, k-1, j))
1575       END DO
1576       DO k=kts,ktf
1577         DO i=i_start,i_end
1578           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
1579 &            +1)-vfluxd(i, k))
1580           tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
1581 &            -vflux(i, k))
1582         END DO
1583       END DO
1584     END DO
1585   ELSE IF (vert_order .EQ. 5) THEN
1586     vfluxd = 0.0
1587     DO j=j_start,j_end
1588       DO k=kts+3,ktf-2
1589         DO i=i_start,i_end
1590           veld = 0.5*(romd(i-1, k, j)+romd(i, k, j))
1591           vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
1592           vfluxd(i, k) = veld*((37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k&
1593 &            +1, j)+u(i, k-2, j))+(u(i, k+2, j)+u(i, k-3, j)))/60.0-SIGN(&
1594 &            1, time_step)*SIGN(1., -vel)*(u(i, k+2, j)-u(i, k-3, j)-5.*(&
1595 &            u(i, k+1, j)-u(i, k-2, j))+10.*(u(i, k, j)-u(i, k-1, j)))/&
1596 &            60.0) + vel*((37.*(ud(i, k, j)+ud(i, k-1, j))-8.*(ud(i, k+1&
1597 &            , j)+ud(i, k-2, j))+ud(i, k+2, j)+ud(i, k-3, j))/60.0-SIGN(1&
1598 &            , time_step)*SIGN(1., -vel)*(ud(i, k+2, j)-ud(i, k-3, j)-5.*&
1599 &            (ud(i, k+1, j)-ud(i, k-2, j))+10.*(ud(i, k, j)-ud(i, k-1, j)&
1600 &            ))/60.0)
1601           vflux(i, k) = vel*((37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k+1&
1602 &            , j)+u(i, k-2, j))+(u(i, k+2, j)+u(i, k-3, j)))/60.0-SIGN(1&
1603 &            , time_step)*SIGN(1., -vel)*(u(i, k+2, j)-u(i, k-3, j)-5.*(u&
1604 &            (i, k+1, j)-u(i, k-2, j))+10.*(u(i, k, j)-u(i, k-1, j)))/&
1605 &            60.0)
1606         END DO
1607       END DO
1608       DO i=i_start,i_end
1609         k = kts + 1
1610         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
1611 &          , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
1612 &          fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
1613         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
1614 &          j)+fzp(k)*u(i, k-1, j))
1615         k = kts + 2
1616         veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
1617         vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
1618         vfluxd(i, k) = veld*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)&
1619 &          +u(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k&
1620 &          +1, j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0) + vel*&
1621 &          ((7.*(ud(i, k, j)+ud(i, k-1, j))-ud(i, k+1, j)-ud(i, k-2, j))/&
1622 &          12.0+SIGN(1, time_step)*SIGN(1., -vel)*(ud(i, k+1, j)-ud(i, k-&
1623 &          2, j)-3.*(ud(i, k, j)-ud(i, k-1, j)))/12.0)
1624         vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
1625 &          (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1&
1626 &          , j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0)
1627         k = ktf - 1
1628         veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
1629         vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
1630         vfluxd(i, k) = veld*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)&
1631 &          +u(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k&
1632 &          +1, j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0) + vel*&
1633 &          ((7.*(ud(i, k, j)+ud(i, k-1, j))-ud(i, k+1, j)-ud(i, k-2, j))/&
1634 &          12.0+SIGN(1, time_step)*SIGN(1., -vel)*(ud(i, k+1, j)-ud(i, k-&
1635 &          2, j)-3.*(ud(i, k, j)-ud(i, k-1, j)))/12.0)
1636         vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
1637 &          (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1&
1638 &          , j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0)
1639         k = ktf
1640         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
1641 &          , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
1642 &          fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
1643         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
1644 &          j)+fzp(k)*u(i, k-1, j))
1645       END DO
1646       DO k=kts,ktf
1647         DO i=i_start,i_end
1648           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
1649 &            +1)-vfluxd(i, k))
1650           tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
1651 &            -vflux(i, k))
1652         END DO
1653       END DO
1654     END DO
1655   ELSE IF (vert_order .EQ. 4) THEN
1656     vfluxd = 0.0
1657     DO j=j_start,j_end
1658       DO k=kts+2,ktf-1
1659         DO i=i_start,i_end
1660           veld = 0.5*(romd(i-1, k, j)+romd(i, k, j))
1661           vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
1662           vfluxd(i, k) = veld*(7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j&
1663 &            )+u(i, k-2, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k-1, j))-&
1664 &            ud(i, k+1, j)-ud(i, k-2, j))/12.0
1665           vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)&
1666 &            +u(i, k-2, j)))/12.0)
1667         END DO
1668       END DO
1669       DO i=i_start,i_end
1670         k = kts + 1
1671         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
1672 &          , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
1673 &          fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
1674         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
1675 &          j)+fzp(k)*u(i, k-1, j))
1676         k = ktf
1677         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
1678 &          , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
1679 &          fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
1680         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
1681 &          j)+fzp(k)*u(i, k-1, j))
1682       END DO
1683       DO k=kts,ktf
1684         DO i=i_start,i_end
1685           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
1686 &            +1)-vfluxd(i, k))
1687           tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
1688 &            -vflux(i, k))
1689         END DO
1690       END DO
1691     END DO
1692   ELSE IF (vert_order .EQ. 3) THEN
1693     vfluxd = 0.0
1694     DO j=j_start,j_end
1695       DO k=kts+2,ktf-1
1696         DO i=i_start,i_end
1697           veld = 0.5*(romd(i-1, k, j)+romd(i, k, j))
1698           vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
1699           vfluxd(i, k) = veld*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, &
1700 &            j)+u(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(&
1701 &            i, k+1, j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0) &
1702 &            + vel*((7.*(ud(i, k, j)+ud(i, k-1, j))-ud(i, k+1, j)-ud(i, k&
1703 &            -2, j))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(ud(i, k+1, j&
1704 &            )-ud(i, k-2, j)-3.*(ud(i, k, j)-ud(i, k-1, j)))/12.0)
1705           vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)&
1706 &            +u(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i&
1707 &            , k+1, j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0)
1708         END DO
1709       END DO
1710       DO i=i_start,i_end
1711         k = kts + 1
1712         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
1713 &          , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
1714 &          fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
1715         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
1716 &          j)+fzp(k)*u(i, k-1, j))
1717         k = ktf
1718         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
1719 &          , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
1720 &          fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
1721         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
1722 &          j)+fzp(k)*u(i, k-1, j))
1723       END DO
1724       DO k=kts,ktf
1725         DO i=i_start,i_end
1726           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
1727 &            +1)-vfluxd(i, k))
1728           tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
1729 &            -vflux(i, k))
1730         END DO
1731       END DO
1732     END DO
1733   ELSE IF (vert_order .EQ. 2) THEN
1734     vfluxd = 0.0
1735     DO j=j_start,j_end
1736       DO k=kts+1,ktf
1737         DO i=i_start,i_end
1738           vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(&
1739 &            i, k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*&
1740 &            (fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
1741           vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k&
1742 &            , j)+fzp(k)*u(i, k-1, j))
1743         END DO
1744       END DO
1745       DO k=kts,ktf
1746         DO i=i_start,i_end
1747           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
1748 &            +1)-vfluxd(i, k))
1749           tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
1750 &            -vflux(i, k))
1751         END DO
1752       END DO
1753     END DO
1754   ELSE
1755     WRITE(wrf_err_message, *) &
1756 &    'module_advect: advect_u_6a: v_order not known ', vert_order
1757     CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
1758   END IF
1759 END SUBROUTINE G_ADVECT_U
1760
1761 !        Generated by TAPENADE     (INRIA, Tropics team)
1762 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
1763 !
1764 !  Differentiation of advect_v in forward (tangent) mode:
1765 !   variations   of useful results: tendency
1766 !   with respect to varying inputs: rom tendency v v_old ru rv
1767 !                mut
1768 !   RW status of diff variables: rom:in tendency:in-out v:in v_old:in
1769 !                ru:in rv:in mut:in
1770 SUBROUTINE G_ADVECT_V(v, vd, v_old, v_oldd, tendency, tendencyd, ru, rud&
1771 &  , rv, rvd, rom, romd, mut, mutd, time_step, config_flags, msfux, msfuy&
1772 &  , msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide, jds&
1773 &  , jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts&
1774 &  , kte)
1775   IMPLICIT NONE
1776 ! Input data
1777   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
1778   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
1779 &  jme, kms, kme, its, ite, jts, jte, kts, kte
1780   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: v, v_old, ru&
1781 &  , rv, rom
1782   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: vd, v_oldd, &
1783 &  rud, rvd, romd
1784   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
1785   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd
1786   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
1787   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
1788   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
1789 &  msfvy, msftx, msfty
1790   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
1791   REAL, INTENT(IN) :: rdx, rdy
1792   INTEGER, INTENT(IN) :: time_step
1793 ! Local data
1794   INTEGER :: i, j, k, itf, jtf, ktf
1795   INTEGER :: i_start, i_end, j_start, j_end
1796   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
1797   INTEGER :: jmin, jmax, jp, jm, imin, imax
1798   REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
1799   REAL :: ubd, vbd, uwd, dupd, dumd
1800   REAL, DIMENSION(its:ite, kts:kte) :: vflux
1801   REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
1802   REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
1803   REAL, DIMENSION(its:ite+1, kts:kte) :: fqxd
1804   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
1805   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
1806   INTEGER :: horz_order
1807   INTEGER :: vert_order
1808   LOGICAL :: degrade_xs, degrade_ys
1809   LOGICAL :: degrade_xe, degrade_ye
1810   INTEGER :: jp1, jp0, jtmp
1811 ! definition of flux operators, 3rd, 4th, 5th or 6th order
1812   REAL :: flux3, flux4, flux5, flux6
1813   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
1814   REAL :: veld
1815   LOGICAL :: specified
1816   REAL :: cb
1817
1818
1819   specified = .false.
1820   IF (config_flags%specified .OR. config_flags%nested) specified = &
1821 &      .true.
1822   IF (kte .GT. kde - 1) THEN
1823     ktf = kde - 1
1824   ELSE
1825     ktf = kte
1826   END IF
1827   horz_order = config_flags%h_mom_adv_order
1828   vert_order = config_flags%v_mom_adv_order
1829 !  here is the choice of flux operators
1830   IF (horz_order .EQ. 6) THEN
1831 !  determine boundary mods for flux operators
1832 !  We degrade the flux operators from 3rd/4th order
1833 !   to second order one gridpoint in from the boundaries for
1834 !   all boundary conditions except periodic and symmetry - these
1835 !   conditions have boundary zone data fill for correct application
1836 !   of the higher order flux stencils
1837     degrade_xs = .true.
1838     degrade_xe = .true.
1839     degrade_ys = .true.
1840     degrade_ye = .true.
1841     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
1842 &        its .GT. ids + 3) degrade_xs = .false.
1843     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
1844 &        ite .LT. ide - 3) degrade_xe = .false.
1845     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
1846 &        jts .GT. jds + 3) degrade_ys = .false.
1847     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
1848 &        jte .LT. jde - 3) degrade_ye = .false.
1849 !--------------- y - advection first
1850     i_start = its
1851     IF (ite .GT. ide - 1) THEN
1852       i_end = ide - 1
1853     ELSE
1854       i_end = ite
1855     END IF
1856     j_start = jts
1857     j_end = jte
1858 !  higher order flux has a 5 or 7 point stencil, so compute
1859 !  bounds so we can switch to second order flux close to the boundary
1860     j_start_f = j_start
1861     j_end_f = j_end + 1
1862     IF (degrade_ys) THEN
1863       IF (jts .LT. jds + 1) THEN
1864         j_start = jds + 1
1865       ELSE
1866         j_start = jts
1867       END IF
1868       j_start_f = jds + 3
1869     END IF
1870     IF (degrade_ye) THEN
1871       IF (jte .GT. jde - 1) THEN
1872         j_end = jde - 1
1873       ELSE
1874         j_end = jte
1875       END IF
1876       j_end_f = jde - 2
1877     END IF
1878 !  compute fluxes, 5th or 6th order
1879     jp1 = 2
1880     jp0 = 1
1881     fqyd = 0.0
1882 j_loop_y_flux_6:DO j=j_start,j_end+1
1883       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
1884         DO k=kts,ktf
1885           DO i=i_start,i_end
1886             veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
1887             vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
1888             fqyd(i, k, jp1) = veld*(37.*(v(i, k, j)+v(i, k, j-1))-8.*(v(&
1889 &              i, k, j+1)+v(i, k, j-2))+(v(i, k, j+2)+v(i, k, j-3)))/60.0&
1890 &              + vel*(37.*(vd(i, k, j)+vd(i, k, j-1))-8.*(vd(i, k, j+1)+&
1891 &              vd(i, k, j-2))+vd(i, k, j+2)+vd(i, k, j-3))/60.0
1892             fqy(i, k, jp1) = vel*((37.*(v(i, k, j)+v(i, k, j-1))-8.*(v(i&
1893 &              , k, j+1)+v(i, k, j-2))+(v(i, k, j+2)+v(i, k, j-3)))/60.0)
1894           END DO
1895         END DO
1896       ELSE IF (j .EQ. jds + 1) THEN
1897 !  we must be close to some boundary where we need to reduce the order of the stencil
1898 !  specified uses upstream normal wind at boundaries
1899 ! 2nd order flux next to south boundary
1900         DO k=kts,ktf
1901           DO i=i_start,i_end
1902             vbd = vd(i, k, j-1)
1903             vb = v(i, k, j-1)
1904             IF (specified .AND. v(i, k, j) .LT. 0.) THEN
1905               vbd = vd(i, k, j)
1906               vb = v(i, k, j)
1907             END IF
1908             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(v(i, &
1909 &              k, j)+vb)+(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)+vbd))
1910             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(v(i, k, j&
1911 &              )+vb)
1912           END DO
1913         END DO
1914       ELSE IF (j .EQ. jds + 2) THEN
1915 ! third of 4th order flux 2 in from south boundary
1916         DO k=kts,ktf
1917           DO i=i_start,i_end
1918             veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
1919             vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
1920             fqyd(i, k, jp1) = veld*(7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
1921 &              , j+1)+v(i, k, j-2)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k&
1922 &              , j-1))-vd(i, k, j+1)-vd(i, k, j-2))/12.0
1923             fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
1924 &              , j+1)+v(i, k, j-2)))/12.0)
1925           END DO
1926         END DO
1927       ELSE IF (j .EQ. jde) THEN
1928 ! 2nd order flux next to north boundary
1929         DO k=kts,ktf
1930           DO i=i_start,i_end
1931             vbd = vd(i, k, j)
1932             vb = v(i, k, j)
1933             IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
1934               vbd = vd(i, k, j-1)
1935               vb = v(i, k, j-1)
1936             END IF
1937             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(vb+v(&
1938 &              i, k, j-1))+(rv(i, k, j)+rv(i, k, j-1))*(vbd+vd(i, k, j-1)&
1939 &              ))
1940             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(vb+v(i, k&
1941 &              , j-1))
1942           END DO
1943         END DO
1944       ELSE IF (j .EQ. jde - 1) THEN
1945 ! 3rd or 4th order flux 2 in from north boundary
1946         DO k=kts,ktf
1947           DO i=i_start,i_end
1948             veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
1949             vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
1950             fqyd(i, k, jp1) = veld*(7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
1951 &              , j+1)+v(i, k, j-2)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k&
1952 &              , j-1))-vd(i, k, j+1)-vd(i, k, j-2))/12.0
1953             fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
1954 &              , j+1)+v(i, k, j-2)))/12.0)
1955           END DO
1956         END DO
1957       END IF
1958 !  y flux-divergence into tendency
1959 ! Comments on polar boundary conditions
1960 ! No advection over the poles means tendencies (held from jds [S. pole]
1961 ! to jde [N pole], i.e., on v grid) must be zero at poles
1962 ! [tendency(jds) and tendency(jde)=0]
1963       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
1964         DO k=kts,ktf
1965           DO i=i_start,i_end
1966             tendencyd(i, k, j-1) = 0.0
1967             tendency(i, k, j-1) = 0.
1968           END DO
1969         END DO
1970       ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
1971 ! If j_end were set to jde in a special if statement apart from
1972 ! degrade_ye, then we would hit the next conditional.  But since
1973 ! we want the tendency to be zero anyway, not looping to jde+1
1974 ! will produce the same effect.
1975         DO k=kts,ktf
1976           DO i=i_start,i_end
1977             tendencyd(i, k, j-1) = 0.0
1978             tendency(i, k, j-1) = 0.
1979           END DO
1980         END DO
1981       ELSE IF (j .GT. j_start) THEN
1982 ! Normal code
1983         DO k=kts,ktf
1984           DO i=i_start,i_end
1985 ! ADT eqn 45, 2nd term on RHS
1986             mrdy = msfvy(i, j-1)*rdy
1987             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
1988 &              k, jp1)-fqyd(i, k, jp0))
1989             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
1990 &              jp1)-fqy(i, k, jp0))
1991           END DO
1992         END DO
1993       END IF
1994       jtmp = jp1
1995       jp1 = jp0
1996       jp0 = jtmp
1997     END DO j_loop_y_flux_6
1998 !  next, x - flux divergence
1999     i_start = its
2000     IF (ite .GT. ide - 1) THEN
2001       i_end = ide - 1
2002     ELSE
2003       i_end = ite
2004     END IF
2005     j_start = jts
2006     j_end = jte
2007 ! Polar boundary conditions are like open or specified
2008     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
2009 &    THEN
2010       IF (jds + 1 .LT. jts) THEN
2011         j_start = jts
2012       ELSE
2013         j_start = jds + 1
2014       END IF
2015     END IF
2016     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
2017 &    THEN
2018       IF (jde - 1 .GT. jte) THEN
2019         j_end = jte
2020       ELSE
2021         j_end = jde - 1
2022       END IF
2023     END IF
2024 !  higher order flux has a 5 or 7 point stencil, so compute
2025 !  bounds so we can switch to second order flux close to the boundary
2026     i_start_f = i_start
2027     i_end_f = i_end + 1
2028     IF (degrade_xs) THEN
2029       IF (ids + 1 .LT. its) THEN
2030         i_start = its
2031       ELSE
2032         i_start = ids + 1
2033       END IF
2034       IF (i_start + 2 .GT. ids + 3) THEN
2035         i_start_f = ids + 3
2036       ELSE
2037         i_start_f = i_start + 2
2038       END IF
2039     END IF
2040     IF (degrade_xe) THEN
2041       IF (ide - 2 .GT. ite) THEN
2042         i_end = ite
2043       ELSE
2044         i_end = ide - 2
2045       END IF
2046       i_end_f = ide - 3
2047       fqxd = 0.0
2048     ELSE
2049       fqxd = 0.0
2050     END IF
2051 !  compute fluxes
2052     DO j=j_start,j_end
2053 !  5th or 6th order flux
2054       DO k=kts,ktf
2055         DO i=i_start_f,i_end_f
2056           veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
2057           vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
2058           fqxd(i, k) = veld*(37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k&
2059 &            , j)+v(i-2, k, j))+(v(i+2, k, j)+v(i-3, k, j)))/60.0 + vel*(&
2060 &            37.*(vd(i, k, j)+vd(i-1, k, j))-8.*(vd(i+1, k, j)+vd(i-2, k&
2061 &            , j))+vd(i+2, k, j)+vd(i-3, k, j))/60.0
2062           fqx(i, k) = vel*((37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k, &
2063 &            j)+v(i-2, k, j))+(v(i+2, k, j)+v(i-3, k, j)))/60.0)
2064         END DO
2065       END DO
2066 !  lower order fluxes close to boundaries (if not periodic or symmetric)
2067       IF (degrade_xs) THEN
2068         DO i=i_start,i_start_f-1
2069           IF (i .EQ. ids + 1) THEN
2070 ! second order
2071             DO k=kts,ktf
2072               fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i, k, j-1))*(v(i, k, &
2073 &                j)+v(i-1, k, j))+(ru(i, k, j)+ru(i, k, j-1))*(vd(i, k, j&
2074 &                )+vd(i-1, k, j)))
2075               fqx(i, k) = 0.25*(ru(i, k, j)+ru(i, k, j-1))*(v(i, k, j)+v&
2076 &                (i-1, k, j))
2077             END DO
2078           END IF
2079           IF (i .EQ. ids + 2) THEN
2080 ! third order
2081             DO k=kts,ktf
2082               veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
2083               vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
2084               fqxd(i, k) = veld*(7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k&
2085 &                , j)+v(i-2, k, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i-1, &
2086 &                k, j))-vd(i+1, k, j)-vd(i-2, k, j))/12.0
2087               fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
2088 &                j)+v(i-2, k, j)))/12.0)
2089             END DO
2090           END IF
2091         END DO
2092       END IF
2093       IF (degrade_xe) THEN
2094         DO i=i_end_f+1,i_end+1
2095           IF (i .EQ. ide - 1) THEN
2096 ! second order flux next to the boundary
2097             DO k=kts,ktf
2098               fqxd(i, k) = 0.25*((rud(i_end+1, k, j)+rud(i_end+1, k, j-1&
2099 &                ))*(v(i_end+1, k, j)+v(i_end, k, j))+(ru(i_end+1, k, j)+&
2100 &                ru(i_end+1, k, j-1))*(vd(i_end+1, k, j)+vd(i_end, k, j))&
2101 &                )
2102               fqx(i, k) = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*(&
2103 &                v(i_end+1, k, j)+v(i_end, k, j))
2104             END DO
2105           END IF
2106           IF (i .EQ. ide - 2) THEN
2107 ! third order flux one in from the boundary
2108             DO k=kts,ktf
2109               veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
2110               vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
2111               fqxd(i, k) = veld*(7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k&
2112 &                , j)+v(i-2, k, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i-1, &
2113 &                k, j))-vd(i+1, k, j)-vd(i-2, k, j))/12.0
2114               fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
2115 &                j)+v(i-2, k, j)))/12.0)
2116             END DO
2117           END IF
2118         END DO
2119       END IF
2120 !  x flux-divergence into tendency
2121       DO k=kts,ktf
2122         DO i=i_start,i_end
2123 ! ADT eqn 45, 1st term on RHS
2124           mrdx = msfvy(i, j)*rdx
2125           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
2126 &            fqxd(i, k))
2127           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
2128 &            i, k))
2129         END DO
2130       END DO
2131     END DO
2132   ELSE IF (horz_order .EQ. 5) THEN
2133 !  5th order horizontal flux calculation
2134 !  This code is EXACTLY the same as the 6th order code
2135 !  EXCEPT the 5th order and 3rd operators are used in
2136 !  place of the 6th and 4th order operators
2137 !  determine boundary mods for flux operators
2138 !  We degrade the flux operators from 3rd/4th order
2139 !   to second order one gridpoint in from the boundaries for
2140 !   all boundary conditions except periodic and symmetry - these
2141 !   conditions have boundary zone data fill for correct application
2142 !   of the higher order flux stencils
2143     degrade_xs = .true.
2144     degrade_xe = .true.
2145     degrade_ys = .true.
2146     degrade_ye = .true.
2147     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
2148 &        its .GT. ids + 3) degrade_xs = .false.
2149     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
2150 &        ite .LT. ide - 3) degrade_xe = .false.
2151     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
2152 &        jts .GT. jds + 3) degrade_ys = .false.
2153     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
2154 &        jte .LT. jde - 3) degrade_ye = .false.
2155 !--------------- y - advection first
2156     i_start = its
2157     IF (ite .GT. ide - 1) THEN
2158       i_end = ide - 1
2159     ELSE
2160       i_end = ite
2161     END IF
2162     j_start = jts
2163     j_end = jte
2164 !  higher order flux has a 5 or 7 point stencil, so compute
2165 !  bounds so we can switch to second order flux close to the boundary
2166     j_start_f = j_start
2167     j_end_f = j_end + 1
2168     IF (degrade_ys) THEN
2169       IF (jts .LT. jds + 1) THEN
2170         j_start = jds + 1
2171       ELSE
2172         j_start = jts
2173       END IF
2174       j_start_f = jds + 3
2175     END IF
2176     IF (degrade_ye) THEN
2177       IF (jte .GT. jde - 1) THEN
2178         j_end = jde - 1
2179       ELSE
2180         j_end = jte
2181       END IF
2182       j_end_f = jde - 2
2183     END IF
2184 !  compute fluxes, 5th or 6th order
2185     jp1 = 2
2186     jp0 = 1
2187     fqyd = 0.0
2188 j_loop_y_flux_5:DO j=j_start,j_end+1
2189       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
2190         DO k=kts,ktf
2191           DO i=i_start,i_end
2192             veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
2193             vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
2194             fqyd(i, k, jp1) = veld*((37.*(v(i, k, j)+v(i, k, j-1))-8.*(v&
2195 &              (i, k, j+1)+v(i, k, j-2))+(v(i, k, j+2)+v(i, k, j-3)))/&
2196 &              60.0-SIGN(1, time_step)*SIGN(1., vel)*(v(i, k, j+2)-v(i, k&
2197 &              , j-3)-5.*(v(i, k, j+1)-v(i, k, j-2))+10.*(v(i, k, j)-v(i&
2198 &              , k, j-1)))/60.0) + vel*((37.*(vd(i, k, j)+vd(i, k, j-1))-&
2199 &              8.*(vd(i, k, j+1)+vd(i, k, j-2))+vd(i, k, j+2)+vd(i, k, j-&
2200 &              3))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(vd(i, k, j+2)-&
2201 &              vd(i, k, j-3)-5.*(vd(i, k, j+1)-vd(i, k, j-2))+10.*(vd(i, &
2202 &              k, j)-vd(i, k, j-1)))/60.0)
2203             fqy(i, k, jp1) = vel*((37.*(v(i, k, j)+v(i, k, j-1))-8.*(v(i&
2204 &              , k, j+1)+v(i, k, j-2))+(v(i, k, j+2)+v(i, k, j-3)))/60.0-&
2205 &              SIGN(1, time_step)*SIGN(1., vel)*(v(i, k, j+2)-v(i, k, j-3&
2206 &              )-5.*(v(i, k, j+1)-v(i, k, j-2))+10.*(v(i, k, j)-v(i, k, j&
2207 &              -1)))/60.0)
2208           END DO
2209         END DO
2210       ELSE IF (j .EQ. jds + 1) THEN
2211 !  we must be close to some boundary where we need to reduce the order of the stencil
2212 !  specified uses upstream normal wind at boundaries
2213 ! 2nd order flux next to south boundary
2214         DO k=kts,ktf
2215           DO i=i_start,i_end
2216             vbd = vd(i, k, j-1)
2217             vb = v(i, k, j-1)
2218             IF (specified .AND. v(i, k, j) .LT. 0.) THEN
2219               vbd = vd(i, k, j)
2220               vb = v(i, k, j)
2221             END IF
2222             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(v(i, &
2223 &              k, j)+vb)+(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)+vbd))
2224             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(v(i, k, j&
2225 &              )+vb)
2226           END DO
2227         END DO
2228       ELSE IF (j .EQ. jds + 2) THEN
2229 ! third of 4th order flux 2 in from south boundary
2230         DO k=kts,ktf
2231           DO i=i_start,i_end
2232             veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
2233             vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
2234             fqyd(i, k, jp1) = veld*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, &
2235 &              k, j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
2236 &              vel)*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1&
2237 &              )))/12.0) + vel*((7.*(vd(i, k, j)+vd(i, k, j-1))-vd(i, k, &
2238 &              j+1)-vd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
2239 &              (vd(i, k, j+1)-vd(i, k, j-2)-3.*(vd(i, k, j)-vd(i, k, j-1)&
2240 &              ))/12.0)
2241             fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
2242 &              , j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
2243 &              )*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))&
2244 &              /12.0)
2245           END DO
2246         END DO
2247       ELSE IF (j .EQ. jde) THEN
2248 ! 2nd order flux next to north boundary
2249         DO k=kts,ktf
2250           DO i=i_start,i_end
2251             vbd = vd(i, k, j)
2252             vb = v(i, k, j)
2253             IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
2254               vbd = vd(i, k, j-1)
2255               vb = v(i, k, j-1)
2256             END IF
2257             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(vb+v(&
2258 &              i, k, j-1))+(rv(i, k, j)+rv(i, k, j-1))*(vbd+vd(i, k, j-1)&
2259 &              ))
2260             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(vb+v(i, k&
2261 &              , j-1))
2262           END DO
2263         END DO
2264       ELSE IF (j .EQ. jde - 1) THEN
2265 ! 3rd or 4th order flux 2 in from north boundary
2266         DO k=kts,ktf
2267           DO i=i_start,i_end
2268             veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
2269             vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
2270             fqyd(i, k, jp1) = veld*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, &
2271 &              k, j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
2272 &              vel)*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1&
2273 &              )))/12.0) + vel*((7.*(vd(i, k, j)+vd(i, k, j-1))-vd(i, k, &
2274 &              j+1)-vd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
2275 &              (vd(i, k, j+1)-vd(i, k, j-2)-3.*(vd(i, k, j)-vd(i, k, j-1)&
2276 &              ))/12.0)
2277             fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
2278 &              , j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
2279 &              )*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))&
2280 &              /12.0)
2281           END DO
2282         END DO
2283       END IF
2284 !  y flux-divergence into tendency
2285 ! Comments on polar boundary conditions
2286 ! No advection over the poles means tendencies (held from jds [S. pole]
2287 ! to jde [N pole], i.e., on v grid) must be zero at poles
2288 ! [tendency(jds) and tendency(jde)=0]
2289       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
2290         DO k=kts,ktf
2291           DO i=i_start,i_end
2292             tendencyd(i, k, j-1) = 0.0
2293             tendency(i, k, j-1) = 0.
2294           END DO
2295         END DO
2296       ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
2297 ! If j_end were set to jde in a special if statement apart from
2298 ! degrade_ye, then we would hit the next conditional.  But since
2299 ! we want the tendency to be zero anyway, not looping to jde+1
2300 ! will produce the same effect.
2301         DO k=kts,ktf
2302           DO i=i_start,i_end
2303             tendencyd(i, k, j-1) = 0.0
2304             tendency(i, k, j-1) = 0.
2305           END DO
2306         END DO
2307       ELSE IF (j .GT. j_start) THEN
2308 ! Normal code
2309         DO k=kts,ktf
2310           DO i=i_start,i_end
2311 ! ADT eqn 45, 2nd term on RHS
2312             mrdy = msfvy(i, j-1)*rdy
2313             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
2314 &              k, jp1)-fqyd(i, k, jp0))
2315             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
2316 &              jp1)-fqy(i, k, jp0))
2317           END DO
2318         END DO
2319       END IF
2320       jtmp = jp1
2321       jp1 = jp0
2322       jp0 = jtmp
2323     END DO j_loop_y_flux_5
2324 !  next, x - flux divergence
2325     i_start = its
2326     IF (ite .GT. ide - 1) THEN
2327       i_end = ide - 1
2328     ELSE
2329       i_end = ite
2330     END IF
2331     j_start = jts
2332     j_end = jte
2333 ! Polar boundary conditions are like open or specified
2334     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
2335 &    THEN
2336       IF (jds + 1 .LT. jts) THEN
2337         j_start = jts
2338       ELSE
2339         j_start = jds + 1
2340       END IF
2341     END IF
2342     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
2343 &    THEN
2344       IF (jde - 1 .GT. jte) THEN
2345         j_end = jte
2346       ELSE
2347         j_end = jde - 1
2348       END IF
2349     END IF
2350 !  higher order flux has a 5 or 7 point stencil, so compute
2351 !  bounds so we can switch to second order flux close to the boundary
2352     i_start_f = i_start
2353     i_end_f = i_end + 1
2354     IF (degrade_xs) THEN
2355       IF (ids + 1 .LT. its) THEN
2356         i_start = its
2357       ELSE
2358         i_start = ids + 1
2359       END IF
2360       IF (i_start + 2 .GT. ids + 3) THEN
2361         i_start_f = ids + 3
2362       ELSE
2363         i_start_f = i_start + 2
2364       END IF
2365     END IF
2366     IF (degrade_xe) THEN
2367       IF (ide - 2 .GT. ite) THEN
2368         i_end = ite
2369       ELSE
2370         i_end = ide - 2
2371       END IF
2372       i_end_f = ide - 3
2373       fqxd = 0.0
2374     ELSE
2375       fqxd = 0.0
2376     END IF
2377 !  compute fluxes
2378     DO j=j_start,j_end
2379 !  5th or 6th order flux
2380       DO k=kts,ktf
2381         DO i=i_start_f,i_end_f
2382           veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
2383           vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
2384           fqxd(i, k) = veld*((37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k&
2385 &            , j)+v(i-2, k, j))+(v(i+2, k, j)+v(i-3, k, j)))/60.0-SIGN(1&
2386 &            , time_step)*SIGN(1., vel)*(v(i+2, k, j)-v(i-3, k, j)-5.*(v(&
2387 &            i+1, k, j)-v(i-2, k, j))+10.*(v(i, k, j)-v(i-1, k, j)))/60.0&
2388 &            ) + vel*((37.*(vd(i, k, j)+vd(i-1, k, j))-8.*(vd(i+1, k, j)+&
2389 &            vd(i-2, k, j))+vd(i+2, k, j)+vd(i-3, k, j))/60.0-SIGN(1, &
2390 &            time_step)*SIGN(1., vel)*(vd(i+2, k, j)-vd(i-3, k, j)-5.*(vd&
2391 &            (i+1, k, j)-vd(i-2, k, j))+10.*(vd(i, k, j)-vd(i-1, k, j)))/&
2392 &            60.0)
2393           fqx(i, k) = vel*((37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k, &
2394 &            j)+v(i-2, k, j))+(v(i+2, k, j)+v(i-3, k, j)))/60.0-SIGN(1, &
2395 &            time_step)*SIGN(1., vel)*(v(i+2, k, j)-v(i-3, k, j)-5.*(v(i+&
2396 &            1, k, j)-v(i-2, k, j))+10.*(v(i, k, j)-v(i-1, k, j)))/60.0)
2397         END DO
2398       END DO
2399 !  lower order fluxes close to boundaries (if not periodic or symmetric)
2400       IF (degrade_xs) THEN
2401         DO i=i_start,i_start_f-1
2402           IF (i .EQ. ids + 1) THEN
2403 ! second order
2404             DO k=kts,ktf
2405               fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i, k, j-1))*(v(i, k, &
2406 &                j)+v(i-1, k, j))+(ru(i, k, j)+ru(i, k, j-1))*(vd(i, k, j&
2407 &                )+vd(i-1, k, j)))
2408               fqx(i, k) = 0.25*(ru(i, k, j)+ru(i, k, j-1))*(v(i, k, j)+v&
2409 &                (i-1, k, j))
2410             END DO
2411           END IF
2412           IF (i .EQ. ids + 2) THEN
2413 ! third order
2414             DO k=kts,ktf
2415               veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
2416               vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
2417               fqxd(i, k) = veld*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k&
2418 &                , j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
2419 &                )*(v(i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)&
2420 &                ))/12.0) + vel*((7.*(vd(i, k, j)+vd(i-1, k, j))-vd(i+1, &
2421 &                k, j)-vd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
2422 &                vel)*(vd(i+1, k, j)-vd(i-2, k, j)-3.*(vd(i, k, j)-vd(i-1&
2423 &                , k, j)))/12.0)
2424               fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
2425 &                j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
2426 &                (v(i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))&
2427 &                /12.0)
2428             END DO
2429           END IF
2430         END DO
2431       END IF
2432       IF (degrade_xe) THEN
2433         DO i=i_end_f+1,i_end+1
2434           IF (i .EQ. ide - 1) THEN
2435 ! second order flux next to the boundary
2436             DO k=kts,ktf
2437               fqxd(i, k) = 0.25*((rud(i_end+1, k, j)+rud(i_end+1, k, j-1&
2438 &                ))*(v(i_end+1, k, j)+v(i_end, k, j))+(ru(i_end+1, k, j)+&
2439 &                ru(i_end+1, k, j-1))*(vd(i_end+1, k, j)+vd(i_end, k, j))&
2440 &                )
2441               fqx(i, k) = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*(&
2442 &                v(i_end+1, k, j)+v(i_end, k, j))
2443             END DO
2444           END IF
2445           IF (i .EQ. ide - 2) THEN
2446 ! third order flux one in from the boundary
2447             DO k=kts,ktf
2448               veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
2449               vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
2450               fqxd(i, k) = veld*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k&
2451 &                , j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
2452 &                )*(v(i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)&
2453 &                ))/12.0) + vel*((7.*(vd(i, k, j)+vd(i-1, k, j))-vd(i+1, &
2454 &                k, j)-vd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
2455 &                vel)*(vd(i+1, k, j)-vd(i-2, k, j)-3.*(vd(i, k, j)-vd(i-1&
2456 &                , k, j)))/12.0)
2457               fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
2458 &                j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
2459 &                (v(i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))&
2460 &                /12.0)
2461             END DO
2462           END IF
2463         END DO
2464       END IF
2465 !  x flux-divergence into tendency
2466       DO k=kts,ktf
2467         DO i=i_start,i_end
2468 ! ADT eqn 45, 1st term on RHS
2469           mrdx = msfvy(i, j)*rdx
2470           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
2471 &            fqxd(i, k))
2472           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
2473 &            i, k))
2474         END DO
2475       END DO
2476     END DO
2477   ELSE IF (horz_order .EQ. 4) THEN
2478 !  determine boundary mods for flux operators
2479 !  We degrade the flux operators from 3rd/4th order
2480 !   to second order one gridpoint in from the boundaries for
2481 !   all boundary conditions except periodic and symmetry - these
2482 !   conditions have boundary zone data fill for correct application
2483 !   of the higher order flux stencils
2484     degrade_xs = .true.
2485     degrade_xe = .true.
2486     degrade_ys = .true.
2487     degrade_ye = .true.
2488     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
2489 &        its .GT. ids + 2) degrade_xs = .false.
2490     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
2491 &        ite .LT. ide - 2) degrade_xe = .false.
2492     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
2493 &        jts .GT. jds + 2) degrade_ys = .false.
2494     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
2495 &        jte .LT. jde - 2) degrade_ye = .false.
2496     IF (kte .GT. kde - 1) THEN
2497       ktf = kde - 1
2498     ELSE
2499       ktf = kte
2500     END IF
2501     i_start = its
2502     IF (ite .GT. ide - 1) THEN
2503       i_end = ide - 1
2504     ELSE
2505       i_end = ite
2506     END IF
2507     j_start = jts
2508     j_end = jte
2509 !  3rd or 4th order flux has a 5 point stencil, so compute
2510 !  bounds so we can switch to second order flux close to the boundary
2511     j_start_f = j_start
2512     j_end_f = j_end + 1
2513 !CJM May not work with tiling because defined in terms of domain dims
2514     IF (degrade_ys) THEN
2515       j_start = jds + 1
2516       j_start_f = j_start + 1
2517     END IF
2518     IF (degrade_ye) THEN
2519       j_end = jde - 1
2520       j_end_f = jde - 1
2521     END IF
2522 !  compute fluxes
2523 !  specified uses upstream normal wind at boundaries
2524     jp0 = 1
2525     jp1 = 2
2526     fqyd = 0.0
2527     DO j=j_start,j_end+1
2528       IF (j .EQ. j_start .AND. degrade_ys) THEN
2529         DO k=kts,ktf
2530           DO i=i_start,i_end
2531             vbd = vd(i, k, j-1)
2532             vb = v(i, k, j-1)
2533             IF (specified .AND. v(i, k, j) .LT. 0.) THEN
2534               vbd = vd(i, k, j)
2535               vb = v(i, k, j)
2536             END IF
2537             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(v(i, &
2538 &              k, j)+vb)+(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)+vbd))
2539             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(v(i, k, j&
2540 &              )+vb)
2541           END DO
2542         END DO
2543       ELSE IF (j .EQ. j_end + 1 .AND. degrade_ye) THEN
2544         DO k=kts,ktf
2545           DO i=i_start,i_end
2546             vbd = vd(i, k, j)
2547             vb = v(i, k, j)
2548             IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
2549               vbd = vd(i, k, j-1)
2550               vb = v(i, k, j-1)
2551             END IF
2552             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(vb+v(&
2553 &              i, k, j-1))+(rv(i, k, j)+rv(i, k, j-1))*(vbd+vd(i, k, j-1)&
2554 &              ))
2555             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(vb+v(i, k&
2556 &              , j-1))
2557           END DO
2558         END DO
2559       ELSE
2560         DO k=kts,ktf
2561           DO i=i_start,i_end
2562             veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
2563             vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
2564             fqyd(i, k, jp1) = veld*(7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
2565 &              , j+1)+v(i, k, j-2)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k&
2566 &              , j-1))-vd(i, k, j+1)-vd(i, k, j-2))/12.0
2567             fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
2568 &              , j+1)+v(i, k, j-2)))/12.0)
2569           END DO
2570         END DO
2571       END IF
2572 ! Comments on polar boundary conditions
2573 ! No advection over the poles means tendencies (held from jds [S. pole]
2574 ! to jde [N pole], i.e., on v grid) must be zero at poles
2575 ! [tendency(jds) and tendency(jde)=0]
2576       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
2577         DO k=kts,ktf
2578           DO i=i_start,i_end
2579             tendencyd(i, k, j-1) = 0.0
2580             tendency(i, k, j-1) = 0.
2581           END DO
2582         END DO
2583       ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
2584 ! If j_end were set to jde in a special if statement apart from
2585 ! degrade_ye, then we would hit the next conditional.  But since
2586 ! we want the tendency to be zero anyway, not looping to jde+1
2587 ! will produce the same effect.
2588         DO k=kts,ktf
2589           DO i=i_start,i_end
2590             tendencyd(i, k, j-1) = 0.0
2591             tendency(i, k, j-1) = 0.
2592           END DO
2593         END DO
2594       ELSE IF (j .GT. j_start) THEN
2595 ! Normal code
2596         DO k=kts,ktf
2597           DO i=i_start,i_end
2598 ! ADT eqn 45, 2nd term on RHS
2599             mrdy = msfvy(i, j-1)*rdy
2600             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
2601 &              k, jp1)-fqyd(i, k, jp0))
2602             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
2603 &              jp1)-fqy(i, k, jp0))
2604           END DO
2605         END DO
2606       END IF
2607       jtmp = jp1
2608       jp1 = jp0
2609       jp0 = jtmp
2610     END DO
2611 !  next, x - flux divergence
2612     i_start = its
2613     IF (ite .GT. ide - 1) THEN
2614       i_end = ide - 1
2615     ELSE
2616       i_end = ite
2617     END IF
2618     j_start = jts
2619     j_end = jte
2620 ! Polar boundary conditions are like open or specified
2621     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
2622 &    THEN
2623       IF (jds + 1 .LT. jts) THEN
2624         j_start = jts
2625       ELSE
2626         j_start = jds + 1
2627       END IF
2628     END IF
2629     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
2630 &    THEN
2631       IF (jde - 1 .GT. jte) THEN
2632         j_end = jte
2633       ELSE
2634         j_end = jde - 1
2635       END IF
2636     END IF
2637 !  3rd or 4th order flux has a 5 point stencil, so compute
2638 !  bounds so we can switch to second order flux close to the boundary
2639     i_start_f = i_start
2640     i_end_f = i_end + 1
2641     IF (degrade_xs) THEN
2642       i_start = ids + 1
2643       i_start_f = i_start + 1
2644     END IF
2645     IF (degrade_xe) THEN
2646       i_end = ide - 2
2647       i_end_f = ide - 2
2648       fqxd = 0.0
2649     ELSE
2650       fqxd = 0.0
2651     END IF
2652 !  compute fluxes
2653     DO j=j_start,j_end
2654 !  3rd or 4th order flux
2655       DO k=kts,ktf
2656         DO i=i_start_f,i_end_f
2657           veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
2658           vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
2659           fqxd(i, k) = veld*(7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)+&
2660 &            v(i-2, k, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i-1, k, j))-vd&
2661 &            (i+1, k, j)-vd(i-2, k, j))/12.0
2662           fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)+v&
2663 &            (i-2, k, j)))/12.0)
2664         END DO
2665       END DO
2666 !  second order flux close to boundaries (if not periodic or symmetric)
2667       IF (degrade_xs) THEN
2668         DO k=kts,ktf
2669           fqxd(i_start, k) = 0.25*((rud(i_start, k, j)+rud(i_start, k, j&
2670 &            -1))*(v(i_start, k, j)+v(i_start-1, k, j))+(ru(i_start, k, j&
2671 &            )+ru(i_start, k, j-1))*(vd(i_start, k, j)+vd(i_start-1, k, j&
2672 &            )))
2673           fqx(i_start, k) = 0.25*(ru(i_start, k, j)+ru(i_start, k, j-1))&
2674 &            *(v(i_start, k, j)+v(i_start-1, k, j))
2675         END DO
2676       END IF
2677       IF (degrade_xe) THEN
2678         DO k=kts,ktf
2679           fqxd(i_end+1, k) = 0.25*((rud(i_end+1, k, j)+rud(i_end+1, k, j&
2680 &            -1))*(v(i_end+1, k, j)+v(i_end, k, j))+(ru(i_end+1, k, j)+ru&
2681 &            (i_end+1, k, j-1))*(vd(i_end+1, k, j)+vd(i_end, k, j)))
2682           fqx(i_end+1, k) = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))&
2683 &            *(v(i_end+1, k, j)+v(i_end, k, j))
2684         END DO
2685       END IF
2686 !  x flux-divergence into tendency
2687       DO k=kts,ktf
2688         DO i=i_start,i_end
2689 ! ADT eqn 45, 1st term on RHS
2690           mrdx = msfvy(i, j)*rdx
2691           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
2692 &            fqxd(i, k))
2693           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
2694 &            i, k))
2695         END DO
2696       END DO
2697     END DO
2698   ELSE IF (horz_order .EQ. 3) THEN
2699 !  determine boundary mods for flux operators
2700 !  We degrade the flux operators from 3rd/4th order
2701 !   to second order one gridpoint in from the boundaries for
2702 !   all boundary conditions except periodic and symmetry - these
2703 !   conditions have boundary zone data fill for correct application
2704 !   of the higher order flux stencils
2705     degrade_xs = .true.
2706     degrade_xe = .true.
2707     degrade_ys = .true.
2708     degrade_ye = .true.
2709     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
2710 &        its .GT. ids + 2) degrade_xs = .false.
2711     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
2712 &        ite .LT. ide - 2) degrade_xe = .false.
2713     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
2714 &        jts .GT. jds + 2) degrade_ys = .false.
2715     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
2716 &        jte .LT. jde - 2) degrade_ye = .false.
2717     IF (kte .GT. kde - 1) THEN
2718       ktf = kde - 1
2719     ELSE
2720       ktf = kte
2721     END IF
2722     i_start = its
2723     IF (ite .GT. ide - 1) THEN
2724       i_end = ide - 1
2725     ELSE
2726       i_end = ite
2727     END IF
2728     j_start = jts
2729     j_end = jte
2730 !  3rd or 4th order flux has a 5 point stencil, so compute
2731 !  bounds so we can switch to second order flux close to the boundary
2732     j_start_f = j_start
2733     j_end_f = j_end + 1
2734 !CJM May not work with tiling because defined in terms of domain dims
2735     IF (degrade_ys) THEN
2736       j_start = jds + 1
2737       j_start_f = j_start + 1
2738     END IF
2739     IF (degrade_ye) THEN
2740       j_end = jde - 1
2741       j_end_f = jde - 1
2742     END IF
2743 !  compute fluxes
2744 !  specified uses upstream normal wind at boundaries
2745     jp0 = 1
2746     jp1 = 2
2747     fqyd = 0.0
2748     DO j=j_start,j_end+1
2749       IF (j .EQ. j_start .AND. degrade_ys) THEN
2750         DO k=kts,ktf
2751           DO i=i_start,i_end
2752             vbd = vd(i, k, j-1)
2753             vb = v(i, k, j-1)
2754             IF (specified .AND. v(i, k, j) .LT. 0.) THEN
2755               vbd = vd(i, k, j)
2756               vb = v(i, k, j)
2757             END IF
2758             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(v(i, &
2759 &              k, j)+vb)+(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)+vbd))
2760             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(v(i, k, j&
2761 &              )+vb)
2762           END DO
2763         END DO
2764       ELSE IF (j .EQ. j_end + 1 .AND. degrade_ye) THEN
2765         DO k=kts,ktf
2766           DO i=i_start,i_end
2767             vbd = vd(i, k, j)
2768             vb = v(i, k, j)
2769             IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
2770               vbd = vd(i, k, j-1)
2771               vb = v(i, k, j-1)
2772             END IF
2773             fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(vb+v(&
2774 &              i, k, j-1))+(rv(i, k, j)+rv(i, k, j-1))*(vbd+vd(i, k, j-1)&
2775 &              ))
2776             fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(vb+v(i, k&
2777 &              , j-1))
2778           END DO
2779         END DO
2780       ELSE
2781         DO k=kts,ktf
2782           DO i=i_start,i_end
2783             veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
2784             vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
2785             fqyd(i, k, jp1) = veld*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, &
2786 &              k, j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
2787 &              vel)*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1&
2788 &              )))/12.0) + vel*((7.*(vd(i, k, j)+vd(i, k, j-1))-vd(i, k, &
2789 &              j+1)-vd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
2790 &              (vd(i, k, j+1)-vd(i, k, j-2)-3.*(vd(i, k, j)-vd(i, k, j-1)&
2791 &              ))/12.0)
2792             fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
2793 &              , j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
2794 &              )*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))&
2795 &              /12.0)
2796           END DO
2797         END DO
2798       END IF
2799 ! Comments on polar boundary conditions
2800 ! No advection over the poles means tendencies (held from jds [S. pole]
2801 ! to jde [N pole], i.e., on v grid) must be zero at poles
2802 ! [tendency(jds) and tendency(jde)=0]
2803       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
2804         DO k=kts,ktf
2805           DO i=i_start,i_end
2806             tendencyd(i, k, j-1) = 0.0
2807             tendency(i, k, j-1) = 0.
2808           END DO
2809         END DO
2810       ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
2811 ! If j_end were set to jde in a special if statement apart from
2812 ! degrade_ye, then we would hit the next conditional.  But since
2813 ! we want the tendency to be zero anyway, not looping to jde+1
2814 ! will produce the same effect.
2815         DO k=kts,ktf
2816           DO i=i_start,i_end
2817             tendencyd(i, k, j-1) = 0.0
2818             tendency(i, k, j-1) = 0.
2819           END DO
2820         END DO
2821       ELSE IF (j .GT. j_start) THEN
2822 ! Normal code
2823         DO k=kts,ktf
2824           DO i=i_start,i_end
2825 ! ADT eqn 45, 2nd term on RHS
2826             mrdy = msfvy(i, j-1)*rdy
2827             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
2828 &              k, jp1)-fqyd(i, k, jp0))
2829             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
2830 &              jp1)-fqy(i, k, jp0))
2831           END DO
2832         END DO
2833       END IF
2834       jtmp = jp1
2835       jp1 = jp0
2836       jp0 = jtmp
2837     END DO
2838 !  next, x - flux divergence
2839     i_start = its
2840     IF (ite .GT. ide - 1) THEN
2841       i_end = ide - 1
2842     ELSE
2843       i_end = ite
2844     END IF
2845     j_start = jts
2846     j_end = jte
2847 ! Polar boundary conditions are like open or specified
2848     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
2849 &    THEN
2850       IF (jds + 1 .LT. jts) THEN
2851         j_start = jts
2852       ELSE
2853         j_start = jds + 1
2854       END IF
2855     END IF
2856     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
2857 &    THEN
2858       IF (jde - 1 .GT. jte) THEN
2859         j_end = jte
2860       ELSE
2861         j_end = jde - 1
2862       END IF
2863     END IF
2864 !  3rd or 4th order flux has a 5 point stencil, so compute
2865 !  bounds so we can switch to second order flux close to the boundary
2866     i_start_f = i_start
2867     i_end_f = i_end + 1
2868     IF (degrade_xs) THEN
2869       i_start = ids + 1
2870       i_start_f = i_start + 1
2871     END IF
2872     IF (degrade_xe) THEN
2873       i_end = ide - 2
2874       i_end_f = ide - 2
2875       fqxd = 0.0
2876     ELSE
2877       fqxd = 0.0
2878     END IF
2879 !  compute fluxes
2880     DO j=j_start,j_end
2881 !  3rd or 4th order flux
2882       DO k=kts,ktf
2883         DO i=i_start_f,i_end_f
2884           veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
2885           vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
2886           fqxd(i, k) = veld*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)&
2887 &            +v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(i+1&
2888 &            , k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/12.0) + &
2889 &            vel*((7.*(vd(i, k, j)+vd(i-1, k, j))-vd(i+1, k, j)-vd(i-2, k&
2890 &            , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(vd(i+1, k, j)-&
2891 &            vd(i-2, k, j)-3.*(vd(i, k, j)-vd(i-1, k, j)))/12.0)
2892           fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)+v&
2893 &            (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(i+1, &
2894 &            k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/12.0)
2895         END DO
2896       END DO
2897 !  second order flux close to boundaries (if not periodic or symmetric)
2898       IF (degrade_xs) THEN
2899         DO k=kts,ktf
2900           fqxd(i_start, k) = 0.25*((rud(i_start, k, j)+rud(i_start, k, j&
2901 &            -1))*(v(i_start, k, j)+v(i_start-1, k, j))+(ru(i_start, k, j&
2902 &            )+ru(i_start, k, j-1))*(vd(i_start, k, j)+vd(i_start-1, k, j&
2903 &            )))
2904           fqx(i_start, k) = 0.25*(ru(i_start, k, j)+ru(i_start, k, j-1))&
2905 &            *(v(i_start, k, j)+v(i_start-1, k, j))
2906         END DO
2907       END IF
2908       IF (degrade_xe) THEN
2909         DO k=kts,ktf
2910           fqxd(i_end+1, k) = 0.25*((rud(i_end+1, k, j)+rud(i_end+1, k, j&
2911 &            -1))*(v(i_end+1, k, j)+v(i_end, k, j))+(ru(i_end+1, k, j)+ru&
2912 &            (i_end+1, k, j-1))*(vd(i_end+1, k, j)+vd(i_end, k, j)))
2913           fqx(i_end+1, k) = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))&
2914 &            *(v(i_end+1, k, j)+v(i_end, k, j))
2915         END DO
2916       END IF
2917 !  x flux-divergence into tendency
2918       DO k=kts,ktf
2919         DO i=i_start,i_end
2920 ! ADT eqn 45, 1st term on RHS
2921           mrdx = msfvy(i, j)*rdx
2922           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
2923 &            fqxd(i, k))
2924           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
2925 &            i, k))
2926         END DO
2927       END DO
2928     END DO
2929   ELSE IF (horz_order .EQ. 2) THEN
2930     i_start = its
2931     IF (ite .GT. ide - 1) THEN
2932       i_end = ide - 1
2933     ELSE
2934       i_end = ite
2935     END IF
2936     j_start = jts
2937     j_end = jte
2938     IF (config_flags%open_ys) THEN
2939       IF (jds + 1 .LT. jts) THEN
2940         j_start = jts
2941       ELSE
2942         j_start = jds + 1
2943       END IF
2944     END IF
2945     IF (config_flags%open_ye) THEN
2946       IF (jde - 1 .GT. jte) THEN
2947         j_end = jte
2948       ELSE
2949         j_end = jde - 1
2950       END IF
2951     END IF
2952     IF (specified) THEN
2953       IF (jds + 2 .LT. jts) THEN
2954         j_start = jts
2955       ELSE
2956         j_start = jds + 2
2957       END IF
2958     END IF
2959     IF (specified) THEN
2960       IF (jde - 2 .GT. jte) THEN
2961         j_end = jte
2962       ELSE
2963         j_end = jde - 2
2964       END IF
2965     END IF
2966     IF (config_flags%polar) THEN
2967       IF (jds + 1 .LT. jts) THEN
2968         j_start = jts
2969       ELSE
2970         j_start = jds + 1
2971       END IF
2972     END IF
2973     IF (config_flags%polar) THEN
2974       IF (jde - 1 .GT. jte) THEN
2975         j_end = jte
2976       ELSE
2977         j_end = jde - 1
2978       END IF
2979     END IF
2980     DO j=j_start,j_end
2981       DO k=kts,ktf
2982         DO i=i_start,i_end
2983 ! ADT eqn 45, 2nd term on RHS
2984           mrdy = msfvy(i, j)*rdy
2985           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.25*((rvd(i, k&
2986 &            , j+1)+rvd(i, k, j))*(v(i, k, j+1)+v(i, k, j))+(rv(i, k, j+1&
2987 &            )+rv(i, k, j))*(vd(i, k, j+1)+vd(i, k, j))-(rvd(i, k, j)+rvd&
2988 &            (i, k, j-1))*(v(i, k, j)+v(i, k, j-1))-(rv(i, k, j)+rv(i, k&
2989 &            , j-1))*(vd(i, k, j)+vd(i, k, j-1)))
2990           tendency(i, k, j) = tendency(i, k, j) - mrdy*0.25*((rv(i, k, j&
2991 &            +1)+rv(i, k, j))*(v(i, k, j+1)+v(i, k, j))-(rv(i, k, j)+rv(i&
2992 &            , k, j-1))*(v(i, k, j)+v(i, k, j-1)))
2993         END DO
2994       END DO
2995     END DO
2996 ! Comments on polar boundary conditions
2997 ! tendencies = 0 at poles, and polar points do not contribute at points
2998 ! next to poles
2999     IF (config_flags%polar) THEN
3000       IF (jts .EQ. jds) THEN
3001         DO k=kts,ktf
3002           DO i=i_start,i_end
3003             tendencyd(i, k, jds) = 0.0
3004             tendency(i, k, jds) = 0.
3005           END DO
3006         END DO
3007       END IF
3008       IF (jte .EQ. jde) THEN
3009         DO k=kts,ktf
3010           DO i=i_start,i_end
3011             tendencyd(i, k, jde) = 0.0
3012             tendency(i, k, jde) = 0.
3013           END DO
3014         END DO
3015       END IF
3016     END IF
3017 !  specified uses upstream normal wind at boundaries
3018     IF (specified .AND. jts .LE. jds + 1) THEN
3019       j = jds + 1
3020       DO k=kts,ktf
3021         DO i=i_start,i_end
3022 ! ADT eqn 45, 2nd term on RHS
3023           mrdy = msfvy(i, j)*rdy
3024           vbd = vd(i, k, j-1)
3025           vb = v(i, k, j-1)
3026           IF (v(i, k, j) .LT. 0.) THEN
3027             vbd = vd(i, k, j)
3028             vb = v(i, k, j)
3029           END IF
3030           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.25*((rvd(i, k&
3031 &            , j+1)+rvd(i, k, j))*(v(i, k, j+1)+v(i, k, j))+(rv(i, k, j+1&
3032 &            )+rv(i, k, j))*(vd(i, k, j+1)+vd(i, k, j))-(rvd(i, k, j)+rvd&
3033 &            (i, k, j-1))*(v(i, k, j)+vb)-(rv(i, k, j)+rv(i, k, j-1))*(vd&
3034 &            (i, k, j)+vbd))
3035           tendency(i, k, j) = tendency(i, k, j) - mrdy*0.25*((rv(i, k, j&
3036 &            +1)+rv(i, k, j))*(v(i, k, j+1)+v(i, k, j))-(rv(i, k, j)+rv(i&
3037 &            , k, j-1))*(v(i, k, j)+vb))
3038         END DO
3039       END DO
3040     END IF
3041     IF (specified .AND. jte .GE. jde - 1) THEN
3042       j = jde - 1
3043       DO k=kts,ktf
3044         DO i=i_start,i_end
3045 ! ADT eqn 45, 2nd term on RHS
3046           mrdy = msfvy(i, j)*rdy
3047           vbd = vd(i, k, j+1)
3048           vb = v(i, k, j+1)
3049           IF (v(i, k, j) .GT. 0.) THEN
3050             vbd = vd(i, k, j)
3051             vb = v(i, k, j)
3052           END IF
3053           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.25*((rvd(i, k&
3054 &            , j+1)+rvd(i, k, j))*(vb+v(i, k, j))+(rv(i, k, j+1)+rv(i, k&
3055 &            , j))*(vbd+vd(i, k, j))-(rvd(i, k, j)+rvd(i, k, j-1))*(v(i, &
3056 &            k, j)+v(i, k, j-1))-(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)&
3057 &            +vd(i, k, j-1)))
3058           tendency(i, k, j) = tendency(i, k, j) - mrdy*0.25*((rv(i, k, j&
3059 &            +1)+rv(i, k, j))*(vb+v(i, k, j))-(rv(i, k, j)+rv(i, k, j-1))&
3060 &            *(v(i, k, j)+v(i, k, j-1)))
3061         END DO
3062       END DO
3063     END IF
3064     IF (.NOT.config_flags%periodic_x) THEN
3065       IF (config_flags%open_xs .OR. specified) THEN
3066         IF (ids + 1 .LT. its) THEN
3067           i_start = its
3068         ELSE
3069           i_start = ids + 1
3070         END IF
3071       END IF
3072       IF (config_flags%open_xe .OR. specified) THEN
3073         IF (ide - 2 .GT. ite) THEN
3074           i_end = ite
3075         ELSE
3076           i_end = ide - 2
3077         END IF
3078       END IF
3079     END IF
3080     IF (config_flags%polar) THEN
3081       IF (jds + 1 .LT. jts) THEN
3082         j_start = jts
3083       ELSE
3084         j_start = jds + 1
3085       END IF
3086     END IF
3087     IF (config_flags%polar) THEN
3088       IF (jde - 1 .GT. jte) THEN
3089         j_end = jte
3090       ELSE
3091         j_end = jde - 1
3092       END IF
3093     END IF
3094     DO j=j_start,j_end
3095       DO k=kts,ktf
3096         DO i=i_start,i_end
3097 ! ADT eqn 45, 1st term on RHS
3098           mrdx = msfvy(i, j)*rdx
3099           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.25*((rud(i+1&
3100 &            , k, j)+rud(i+1, k, j-1))*(v(i+1, k, j)+v(i, k, j))+(ru(i+1&
3101 &            , k, j)+ru(i+1, k, j-1))*(vd(i+1, k, j)+vd(i, k, j))-(rud(i&
3102 &            , k, j)+rud(i, k, j-1))*(v(i, k, j)+v(i-1, k, j))-(ru(i, k, &
3103 &            j)+ru(i, k, j-1))*(vd(i, k, j)+vd(i-1, k, j)))
3104           tendency(i, k, j) = tendency(i, k, j) - mrdx*0.25*((ru(i+1, k&
3105 &            , j)+ru(i+1, k, j-1))*(v(i+1, k, j)+v(i, k, j))-(ru(i, k, j)&
3106 &            +ru(i, k, j-1))*(v(i, k, j)+v(i-1, k, j)))
3107         END DO
3108       END DO
3109     END DO
3110   ELSE IF (horz_order .NE. 0) THEN
3111 ! Just in case we want to turn horizontal advection off, we can do it
3112     WRITE(wrf_err_message, *) &
3113 &    'module_advect: advect_v_6a: h_order not known ', horz_order
3114     CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
3115   END IF
3116 !  Comments on polar boundary condition
3117 !  Force tendency=0 at NP and SP
3118 !  We keep setting this everywhere, but it can't hurt...
3119   IF (config_flags%polar .AND. jts .EQ. jds) THEN
3120     DO i=its,ite
3121       DO k=kts,ktf
3122         tendencyd(i, k, jts) = 0.0
3123         tendency(i, k, jts) = 0.
3124       END DO
3125     END DO
3126   END IF
3127   IF (config_flags%polar .AND. jte .EQ. jde) THEN
3128     DO i=its,ite
3129       DO k=kts,ktf
3130         tendencyd(i, k, jte) = 0.0
3131         tendency(i, k, jte) = 0.
3132       END DO
3133     END DO
3134   END IF
3135 !  radiative lateral boundary condition in y for normal velocity (v)
3136   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
3137     i_start = its
3138     IF (ite .GT. ide - 1) THEN
3139       i_end = ide - 1
3140     ELSE
3141       i_end = ite
3142     END IF
3143     DO i=i_start,i_end
3144       DO k=kts,ktf
3145         IF (rv(i, k, jts) - cb*mut(i, jts) .GT. 0.) THEN
3146           vb = 0.
3147           vbd = 0.0
3148         ELSE
3149           vbd = rvd(i, k, jts) - cb*mutd(i, jts)
3150           vb = rv(i, k, jts) - cb*mut(i, jts)
3151         END IF
3152         tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(v_old(i&
3153 &          , k, jts+1)-v_old(i, k, jts))+vb*(v_oldd(i, k, jts+1)-v_oldd(i&
3154 &          , k, jts)))
3155         tendency(i, k, jts) = tendency(i, k, jts) - rdy*vb*(v_old(i, k, &
3156 &          jts+1)-v_old(i, k, jts))
3157       END DO
3158     END DO
3159   END IF
3160   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
3161     i_start = its
3162     IF (ite .GT. ide - 1) THEN
3163       i_end = ide - 1
3164     ELSE
3165       i_end = ite
3166     END IF
3167     DO i=i_start,i_end
3168       DO k=kts,ktf
3169         IF (rv(i, k, jte) + cb*mut(i, jte-1) .LT. 0.) THEN
3170           vb = 0.
3171           vbd = 0.0
3172         ELSE
3173           vbd = rvd(i, k, jte) + cb*mutd(i, jte-1)
3174           vb = rv(i, k, jte) + cb*mut(i, jte-1)
3175         END IF
3176         tendencyd(i, k, jte) = tendencyd(i, k, jte) - rdy*(vbd*(v_old(i&
3177 &          , k, jte)-v_old(i, k, jte-1))+vb*(v_oldd(i, k, jte)-v_oldd(i, &
3178 &          k, jte-1)))
3179         tendency(i, k, jte) = tendency(i, k, jte) - rdy*vb*(v_old(i, k, &
3180 &          jte)-v_old(i, k, jte-1))
3181       END DO
3182     END DO
3183   END IF
3184 !  pick up the rest of the horizontal radiation boundary conditions.
3185 !  (these are the computations that don't require 'cb'.
3186 !  first, set to index ranges
3187   j_start = jts
3188   IF (jte .GT. jde) THEN
3189     j_end = jde
3190   ELSE
3191     j_end = jte
3192   END IF
3193   jmin = jds
3194   jmax = jde - 1
3195   IF (config_flags%open_ys) THEN
3196     IF (jds + 1 .LT. jts) THEN
3197       j_start = jts
3198     ELSE
3199       j_start = jds + 1
3200     END IF
3201     jmin = jds
3202   END IF
3203   IF (config_flags%open_ye) THEN
3204     IF (jte .GT. jde - 1) THEN
3205       j_end = jde - 1
3206     ELSE
3207       j_end = jte
3208     END IF
3209     jmax = jde - 1
3210   END IF
3211 !  compute x (u) conditions for v, w, or scalar
3212   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
3213     DO j=j_start,j_end
3214 ! ADT eqn 45, 1st term on RHS
3215       mrdx = msfvy(its, j)*rdx
3216       IF (jmax .GT. j) THEN
3217         jp = j
3218       ELSE
3219         jp = jmax
3220       END IF
3221       IF (jmin .LT. j - 1) THEN
3222         jm = j - 1
3223       ELSE
3224         jm = jmin
3225       END IF
3226       DO k=kts,ktf
3227         uwd = 0.5*(rud(its, k, jp)+rud(its, k, jm))
3228         uw = 0.5*(ru(its, k, jp)+ru(its, k, jm))
3229         IF (uw .GT. 0.) THEN
3230           ub = 0.
3231           ubd = 0.0
3232         ELSE
3233           ubd = uwd
3234           ub = uw
3235         END IF
3236         dupd = rud(its+1, k, jp) - rud(its, k, jp)
3237         dup = ru(its+1, k, jp) - ru(its, k, jp)
3238         dumd = rud(its+1, k, jm) - rud(its, k, jm)
3239         dum = ru(its+1, k, jm) - ru(its, k, jm)
3240         tendencyd(its, k, j) = tendencyd(its, k, j) - mrdx*(ubd*(v_old(&
3241 &          its+1, k, j)-v_old(its, k, j))+ub*(v_oldd(its+1, k, j)-v_oldd(&
3242 &          its, k, j))+0.5*(vd(its, k, j)*(dup+dum)+v(its, k, j)*(dupd+&
3243 &          dumd)))
3244         tendency(its, k, j) = tendency(its, k, j) - mrdx*(ub*(v_old(its+&
3245 &          1, k, j)-v_old(its, k, j))+0.5*v(its, k, j)*(dup+dum))
3246       END DO
3247     END DO
3248   END IF
3249   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
3250     DO j=j_start,j_end
3251 ! ADT eqn 45, 1st term on RHS
3252       mrdx = msfvy(ite-1, j)*rdx
3253       IF (jmax .GT. j) THEN
3254         jp = j
3255       ELSE
3256         jp = jmax
3257       END IF
3258       IF (jmin .LT. j - 1) THEN
3259         jm = j - 1
3260       ELSE
3261         jm = jmin
3262       END IF
3263       DO k=kts,ktf
3264         uwd = 0.5*(rud(ite, k, jp)+rud(ite, k, jm))
3265         uw = 0.5*(ru(ite, k, jp)+ru(ite, k, jm))
3266         IF (uw .LT. 0.) THEN
3267           ub = 0.
3268           ubd = 0.0
3269         ELSE
3270           ubd = uwd
3271           ub = uw
3272         END IF
3273         dupd = rud(ite, k, jp) - rud(ite-1, k, jp)
3274         dup = ru(ite, k, jp) - ru(ite-1, k, jp)
3275         dumd = rud(ite, k, jm) - rud(ite-1, k, jm)
3276         dum = ru(ite, k, jm) - ru(ite-1, k, jm)
3277 !          tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
3278 !                            ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
3279 !                           +0.5*v(ite-1,k,j)*                         &
3280 !                                  ( ru(ite,k,jp)-ru(ite-1,k,jp)       &
3281 !                                   +ru(ite,k,jm)-ru(ite-1,k,jm))     )
3282         tendencyd(ite-1, k, j) = tendencyd(ite-1, k, j) - mrdx*(ubd*(&
3283 &          v_old(ite-1, k, j)-v_old(ite-2, k, j))+ub*(v_oldd(ite-1, k, j)&
3284 &          -v_oldd(ite-2, k, j))+0.5*(vd(ite-1, k, j)*(dup+dum)+v(ite-1, &
3285 &          k, j)*(dupd+dumd)))
3286         tendency(ite-1, k, j) = tendency(ite-1, k, j) - mrdx*(ub*(v_old(&
3287 &          ite-1, k, j)-v_old(ite-2, k, j))+0.5*v(ite-1, k, j)*(dup+dum))
3288       END DO
3289     END DO
3290   END IF
3291 !-------------------- vertical advection
3292 !     ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
3293 !     Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
3294 !     We therefore need to make a correction for advect_v
3295 !     since 'my' (map scale factor in y direction) isn't a function of z,
3296 !     we can do this using *(my/mx) (see eqn. 45 for example)
3297   i_start = its
3298   IF (ite .GT. ide - 1) THEN
3299     i_end = ide - 1
3300   ELSE
3301     i_end = ite
3302   END IF
3303   j_start = jts
3304   j_end = jte
3305   DO i=i_start,i_end
3306     vfluxd(i, kts) = 0.0
3307     vflux(i, kts) = 0.
3308     vfluxd(i, kte) = 0.0
3309     vflux(i, kte) = 0.
3310   END DO
3311 ! Polar boundary conditions are like open or specified
3312 ! We don't want to calculate vertical v tendencies at the N or S pole
3313   IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
3314 &  THEN
3315     IF (jds + 1 .LT. jts) THEN
3316       j_start = jts
3317     ELSE
3318       j_start = jds + 1
3319     END IF
3320   END IF
3321   IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
3322 &  THEN
3323     IF (jde - 1 .GT. jte) THEN
3324       j_end = jte
3325     ELSE
3326       j_end = jde - 1
3327     END IF
3328   END IF
3329   IF (vert_order .EQ. 6) THEN
3330     vfluxd = 0.0
3331     DO j=j_start,j_end
3332       DO k=kts+3,ktf-2
3333         DO i=i_start,i_end
3334           veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
3335           vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
3336           vfluxd(i, k) = veld*(37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k+&
3337 &            1, j)+v(i, k-2, j))+(v(i, k+2, j)+v(i, k-3, j)))/60.0 + vel*&
3338 &            (37.*(vd(i, k, j)+vd(i, k-1, j))-8.*(vd(i, k+1, j)+vd(i, k-2&
3339 &            , j))+vd(i, k+2, j)+vd(i, k-3, j))/60.0
3340           vflux(i, k) = vel*((37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k+1&
3341 &            , j)+v(i, k-2, j))+(v(i, k+2, j)+v(i, k-3, j)))/60.0)
3342         END DO
3343       END DO
3344       DO i=i_start,i_end
3345         k = kts + 1
3346         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
3347 &          , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
3348 &          fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
3349         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
3350 &          j)+fzp(k)*v(i, k-1, j))
3351         k = kts + 2
3352         veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
3353         vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
3354         vfluxd(i, k) = veld*(7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+&
3355 &          v(i, k-2, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k-1, j))-vd(i&
3356 &          , k+1, j)-vd(i, k-2, j))/12.0
3357         vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
3358 &          (i, k-2, j)))/12.0)
3359         k = ktf - 1
3360         veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
3361         vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
3362         vfluxd(i, k) = veld*(7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+&
3363 &          v(i, k-2, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k-1, j))-vd(i&
3364 &          , k+1, j)-vd(i, k-2, j))/12.0
3365         vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
3366 &          (i, k-2, j)))/12.0)
3367         k = ktf
3368         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
3369 &          , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
3370 &          fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
3371         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
3372 &          j)+fzp(k)*v(i, k-1, j))
3373       END DO
3374       DO k=kts,ktf
3375         DO i=i_start,i_end
3376 ! We are calculating vertical fluxes on v points,
3377 ! so we must mean msf_v_x/y variables
3378 ! ADT eqn 45, 3rd term on RHS
3379           tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*&
3380 &            (vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
3381           tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j&
3382 &            )*rdzw(k)*(vflux(i, k+1)-vflux(i, k))
3383         END DO
3384       END DO
3385     END DO
3386   ELSE IF (vert_order .EQ. 5) THEN
3387     vfluxd = 0.0
3388     DO j=j_start,j_end
3389       DO k=kts+3,ktf-2
3390         DO i=i_start,i_end
3391           veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
3392           vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
3393           vfluxd(i, k) = veld*((37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k&
3394 &            +1, j)+v(i, k-2, j))+(v(i, k+2, j)+v(i, k-3, j)))/60.0-SIGN(&
3395 &            1, time_step)*SIGN(1., -vel)*(v(i, k+2, j)-v(i, k-3, j)-5.*(&
3396 &            v(i, k+1, j)-v(i, k-2, j))+10.*(v(i, k, j)-v(i, k-1, j)))/&
3397 &            60.0) + vel*((37.*(vd(i, k, j)+vd(i, k-1, j))-8.*(vd(i, k+1&
3398 &            , j)+vd(i, k-2, j))+vd(i, k+2, j)+vd(i, k-3, j))/60.0-SIGN(1&
3399 &            , time_step)*SIGN(1., -vel)*(vd(i, k+2, j)-vd(i, k-3, j)-5.*&
3400 &            (vd(i, k+1, j)-vd(i, k-2, j))+10.*(vd(i, k, j)-vd(i, k-1, j)&
3401 &            ))/60.0)
3402           vflux(i, k) = vel*((37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k+1&
3403 &            , j)+v(i, k-2, j))+(v(i, k+2, j)+v(i, k-3, j)))/60.0-SIGN(1&
3404 &            , time_step)*SIGN(1., -vel)*(v(i, k+2, j)-v(i, k-3, j)-5.*(v&
3405 &            (i, k+1, j)-v(i, k-2, j))+10.*(v(i, k, j)-v(i, k-1, j)))/&
3406 &            60.0)
3407         END DO
3408       END DO
3409       DO i=i_start,i_end
3410         k = kts + 1
3411         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
3412 &          , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
3413 &          fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
3414         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
3415 &          j)+fzp(k)*v(i, k-1, j))
3416         k = kts + 2
3417         veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
3418         vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
3419         vfluxd(i, k) = veld*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)&
3420 &          +v(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k&
3421 &          +1, j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0) + vel*&
3422 &          ((7.*(vd(i, k, j)+vd(i, k-1, j))-vd(i, k+1, j)-vd(i, k-2, j))/&
3423 &          12.0+SIGN(1, time_step)*SIGN(1., -vel)*(vd(i, k+1, j)-vd(i, k-&
3424 &          2, j)-3.*(vd(i, k, j)-vd(i, k-1, j)))/12.0)
3425         vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
3426 &          (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1&
3427 &          , j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0)
3428         k = ktf - 1
3429         veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
3430         vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
3431         vfluxd(i, k) = veld*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)&
3432 &          +v(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k&
3433 &          +1, j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0) + vel*&
3434 &          ((7.*(vd(i, k, j)+vd(i, k-1, j))-vd(i, k+1, j)-vd(i, k-2, j))/&
3435 &          12.0+SIGN(1, time_step)*SIGN(1., -vel)*(vd(i, k+1, j)-vd(i, k-&
3436 &          2, j)-3.*(vd(i, k, j)-vd(i, k-1, j)))/12.0)
3437         vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
3438 &          (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1&
3439 &          , j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0)
3440         k = ktf
3441         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
3442 &          , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
3443 &          fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
3444         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
3445 &          j)+fzp(k)*v(i, k-1, j))
3446       END DO
3447       DO k=kts,ktf
3448         DO i=i_start,i_end
3449 ! We are calculating vertical fluxes on v points,
3450 ! so we must mean msf_v_x/y variables
3451 ! ADT eqn 45, 3rd term on RHS
3452           tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*&
3453 &            (vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
3454           tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j&
3455 &            )*rdzw(k)*(vflux(i, k+1)-vflux(i, k))
3456         END DO
3457       END DO
3458     END DO
3459   ELSE IF (vert_order .EQ. 4) THEN
3460     vfluxd = 0.0
3461     DO j=j_start,j_end
3462       DO k=kts+2,ktf-1
3463         DO i=i_start,i_end
3464           veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
3465           vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
3466           vfluxd(i, k) = veld*(7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j&
3467 &            )+v(i, k-2, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k-1, j))-&
3468 &            vd(i, k+1, j)-vd(i, k-2, j))/12.0
3469           vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)&
3470 &            +v(i, k-2, j)))/12.0)
3471         END DO
3472       END DO
3473       DO i=i_start,i_end
3474         k = kts + 1
3475         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
3476 &          , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
3477 &          fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
3478         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
3479 &          j)+fzp(k)*v(i, k-1, j))
3480         k = ktf
3481         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
3482 &          , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
3483 &          fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
3484         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
3485 &          j)+fzp(k)*v(i, k-1, j))
3486       END DO
3487       DO k=kts,ktf
3488         DO i=i_start,i_end
3489 ! We are calculating vertical fluxes on v points,
3490 ! so we must mean msf_v_x/y variables
3491 ! ADT eqn 45, 3rd term on RHS
3492           tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*&
3493 &            (vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
3494           tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j&
3495 &            )*rdzw(k)*(vflux(i, k+1)-vflux(i, k))
3496         END DO
3497       END DO
3498     END DO
3499   ELSE IF (vert_order .EQ. 3) THEN
3500     vfluxd = 0.0
3501     DO j=j_start,j_end
3502       DO k=kts+2,ktf-1
3503         DO i=i_start,i_end
3504           veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
3505           vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
3506           vfluxd(i, k) = veld*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, &
3507 &            j)+v(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(&
3508 &            i, k+1, j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0) &
3509 &            + vel*((7.*(vd(i, k, j)+vd(i, k-1, j))-vd(i, k+1, j)-vd(i, k&
3510 &            -2, j))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(vd(i, k+1, j&
3511 &            )-vd(i, k-2, j)-3.*(vd(i, k, j)-vd(i, k-1, j)))/12.0)
3512           vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)&
3513 &            +v(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i&
3514 &            , k+1, j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0)
3515         END DO
3516       END DO
3517       DO i=i_start,i_end
3518         k = kts + 1
3519         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
3520 &          , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
3521 &          fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
3522         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
3523 &          j)+fzp(k)*v(i, k-1, j))
3524         k = ktf
3525         vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
3526 &          , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
3527 &          fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
3528         vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
3529 &          j)+fzp(k)*v(i, k-1, j))
3530       END DO
3531       DO k=kts,ktf
3532         DO i=i_start,i_end
3533 ! We are calculating vertical fluxes on v points,
3534 ! so we must mean msf_v_x/y variables
3535 ! ADT eqn 45, 3rd term on RHS
3536           tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*&
3537 &            (vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
3538           tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j&
3539 &            )*rdzw(k)*(vflux(i, k+1)-vflux(i, k))
3540         END DO
3541       END DO
3542     END DO
3543   ELSE IF (vert_order .EQ. 2) THEN
3544     vfluxd = 0.0
3545     DO j=j_start,j_end
3546       DO k=kts+1,ktf
3547         DO i=i_start,i_end
3548           vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(&
3549 &            i, k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*&
3550 &            (fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
3551           vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k&
3552 &            , j)+fzp(k)*v(i, k-1, j))
3553         END DO
3554       END DO
3555       DO k=kts,ktf
3556         DO i=i_start,i_end
3557 ! We are calculating vertical fluxes on v points,
3558 ! so we must mean msf_v_x/y variables
3559 ! ADT eqn 45, 3rd term on RHS
3560           tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*&
3561 &            (vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
3562           tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j&
3563 &            )*rdzw(k)*(vflux(i, k+1)-vflux(i, k))
3564         END DO
3565       END DO
3566     END DO
3567   ELSE
3568     WRITE(wrf_err_message, *) &
3569 &    'module_advect: advect_v_6a: v_order not known ', vert_order
3570     CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
3571   END IF
3572 END SUBROUTINE G_ADVECT_V
3573
3574 !        Generated by TAPENADE     (INRIA, Tropics team)
3575 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
3576 !
3577 !  Differentiation of advect_scalar in forward (tangent) mode:
3578 !   variations   of useful results: tendency
3579 !   with respect to varying inputs: rom field tendency ru rv field_old
3580 !   RW status of diff variables: rom:in field:in tendency:in-out
3581 !                ru:in rv:in field_old:in
3582 SUBROUTINE G_ADVECT_SCALAR(field, fieldd, field_old, field_oldd, &
3583 &  tendency, tendencyd, ru, rud, rv, rvd, rom, romd, mut, time_step, &
3584 &  config_flags, msfux, msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx&
3585 &  , rdy, rdzw, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, &
3586 &  kme, its, ite, jts, jte, kts, kte)
3587   IMPLICIT NONE
3588 ! Input data
3589   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
3590   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
3591 &  jme, kms, kme, its, ite, jts, jte, kts, kte
3592   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
3593 &  field_old, ru, rv, rom
3594   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: fieldd, &
3595 &  field_oldd, rud, rvd, romd
3596   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
3597   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
3598   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
3599   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
3600 &  msfvy, msftx, msfty
3601   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
3602   REAL, INTENT(IN) :: rdx, rdy
3603   INTEGER, INTENT(IN) :: time_step
3604 ! Local data
3605   INTEGER :: i, j, k, itf, jtf, ktf
3606   INTEGER :: i_start, i_end, j_start, j_end
3607   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
3608   INTEGER :: jmin, jmax, jp, jm, imin, imax
3609   REAL :: mrdx, mrdy, ub, vb, uw, vw
3610   REAL :: ubd, vbd
3611   REAL, DIMENSION(its:ite, kts:kte) :: vflux
3612   REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
3613   REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
3614   REAL, DIMENSION(its:ite+1, kts:kte) :: fqxd
3615   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
3616   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
3617   INTEGER :: horz_order, vert_order
3618   LOGICAL :: degrade_xs, degrade_ys
3619   LOGICAL :: degrade_xe, degrade_ye
3620   INTEGER :: jp1, jp0, jtmp
3621 ! definition of flux operators, 3rd, 4th, 5th or 6th order
3622   REAL :: flux3, flux4, flux5, flux6
3623   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
3624   REAL :: veld
3625   LOGICAL :: specified
3626
3627   specified = .false.
3628   IF (config_flags%specified .OR. config_flags%nested) specified = &
3629 &      .true.
3630   IF (kte .GT. kde - 1) THEN
3631     ktf = kde - 1
3632   ELSE
3633     ktf = kte
3634   END IF
3635   horz_order = config_flags%h_sca_adv_order
3636   vert_order = config_flags%v_sca_adv_order
3637 !  begin with horizontal flux divergence
3638 !  here is the choice of flux operators
3639   IF (horz_order .EQ. 6) THEN
3640 !  determine boundary mods for flux operators
3641 !  We degrade the flux operators from 3rd/4th order
3642 !   to second order one gridpoint in from the boundaries for
3643 !   all boundary conditions except periodic and symmetry - these
3644 !   conditions have boundary zone data fill for correct application
3645 !   of the higher order flux stencils
3646     degrade_xs = .true.
3647     degrade_xe = .true.
3648     degrade_ys = .true.
3649     degrade_ye = .true.
3650     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
3651 &        its .GT. ids + 3) degrade_xs = .false.
3652     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
3653 &        ite .LT. ide - 3) degrade_xe = .false.
3654     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
3655 &        jts .GT. jds + 3) degrade_ys = .false.
3656     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
3657 &        jte .LT. jde - 4) degrade_ye = .false.
3658     IF (kte .GT. kde - 1) THEN
3659       ktf = kde - 1
3660     ELSE
3661       ktf = kte
3662     END IF
3663     i_start = its
3664     IF (ite .GT. ide - 1) THEN
3665       i_end = ide - 1
3666     ELSE
3667       i_end = ite
3668     END IF
3669     j_start = jts
3670     IF (jte .GT. jde - 1) THEN
3671       j_end = jde - 1
3672     ELSE
3673       j_end = jte
3674     END IF
3675 !  higher order flux has a 5 or 7 point stencil, so compute
3676 !  bounds so we can switch to second order flux close to the boundary
3677     j_start_f = j_start
3678     j_end_f = j_end + 1
3679     IF (degrade_ys) THEN
3680       IF (jts .LT. jds + 1) THEN
3681         j_start = jds + 1
3682       ELSE
3683         j_start = jts
3684       END IF
3685       j_start_f = jds + 3
3686     END IF
3687     IF (degrade_ye) THEN
3688       IF (jte .GT. jde - 2) THEN
3689         j_end = jde - 2
3690       ELSE
3691         j_end = jte
3692       END IF
3693       j_end_f = jde - 3
3694     END IF
3695     IF (config_flags%polar) THEN
3696       IF (jte .GT. jde - 1) THEN
3697         j_end = jde - 1
3698       ELSE
3699         j_end = jte
3700       END IF
3701     END IF
3702 !  compute fluxes, 5th or 6th order
3703     jp1 = 2
3704     jp0 = 1
3705     fqyd = 0.0
3706 j_loop_y_flux_6:DO j=j_start,j_end+1
3707       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
3708 ! use full stencil
3709         DO k=kts,ktf
3710           DO i=i_start,i_end
3711             veld = rvd(i, k, j)
3712             vel = rv(i, k, j)
3713             fqyd(i, k, jp1) = veld*(37.*(field(i, k, j)+field(i, k, j-1)&
3714 &              )-8.*(field(i, k, j+1)+field(i, k, j-2))+(field(i, k, j+2)&
3715 &              +field(i, k, j-3)))/60.0 + vel*(37.*(fieldd(i, k, j)+&
3716 &              fieldd(i, k, j-1))-8.*(fieldd(i, k, j+1)+fieldd(i, k, j-2)&
3717 &              )+fieldd(i, k, j+2)+fieldd(i, k, j-3))/60.0
3718             fqy(i, k, jp1) = vel*((37.*(field(i, k, j)+field(i, k, j-1))&
3719 &              -8.*(field(i, k, j+1)+field(i, k, j-2))+(field(i, k, j+2)+&
3720 &              field(i, k, j-3)))/60.0)
3721           END DO
3722         END DO
3723       ELSE IF (j .EQ. jds + 1) THEN
3724 ! 2nd order flux next to south boundary
3725         DO k=kts,ktf
3726           DO i=i_start,i_end
3727             fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
3728 &              , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
3729 &              )
3730             fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
3731 &              , j-1))
3732           END DO
3733         END DO
3734       ELSE IF (j .EQ. jds + 2) THEN
3735 ! 4th order flux 2 in from south boundary
3736         DO k=kts,ktf
3737           DO i=i_start,i_end
3738             veld = rvd(i, k, j)
3739             vel = rv(i, k, j)
3740             fqyd(i, k, jp1) = veld*(7.*(field(i, k, j)+field(i, k, j-1))&
3741 &              -(field(i, k, j+1)+field(i, k, j-2)))/12.0 + vel*(7.*(&
3742 &              fieldd(i, k, j)+fieldd(i, k, j-1))-fieldd(i, k, j+1)-&
3743 &              fieldd(i, k, j-2))/12.0
3744             fqy(i, k, jp1) = vel*((7.*(field(i, k, j)+field(i, k, j-1))-&
3745 &              (field(i, k, j+1)+field(i, k, j-2)))/12.0)
3746           END DO
3747         END DO
3748       ELSE IF (j .EQ. jde - 1) THEN
3749 ! 2nd order flux next to north boundary
3750         DO k=kts,ktf
3751           DO i=i_start,i_end
3752             fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
3753 &              , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
3754 &              )
3755             fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
3756 &              , j-1))
3757           END DO
3758         END DO
3759       ELSE IF (j .EQ. jde - 2) THEN
3760 ! 3rd or 4th order flux 2 in from north boundary
3761         DO k=kts,ktf
3762           DO i=i_start,i_end
3763             veld = rvd(i, k, j)
3764             vel = rv(i, k, j)
3765             fqyd(i, k, jp1) = veld*(7.*(field(i, k, j)+field(i, k, j-1))&
3766 &              -(field(i, k, j+1)+field(i, k, j-2)))/12.0 + vel*(7.*(&
3767 &              fieldd(i, k, j)+fieldd(i, k, j-1))-fieldd(i, k, j+1)-&
3768 &              fieldd(i, k, j-2))/12.0
3769             fqy(i, k, jp1) = vel*((7.*(field(i, k, j)+field(i, k, j-1))-&
3770 &              (field(i, k, j+1)+field(i, k, j-2)))/12.0)
3771           END DO
3772         END DO
3773       END IF
3774 !  y flux-divergence into tendency
3775 ! Comments on polar boundary conditions
3776 ! Same process as for advect_u - tendencies run from jds to jde-1
3777 ! (latitudes are as for u grid, longitudes are displaced)
3778 ! Therefore: flow is only from one side for points next to poles
3779       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
3780         DO k=kts,ktf
3781           DO i=i_start,i_end
3782 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3783             mrdy = msftx(i, j-1)*rdy
3784             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
3785 &              , jp1)
3786             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
3787 &              jp1)
3788           END DO
3789         END DO
3790       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
3791         DO k=kts,ktf
3792           DO i=i_start,i_end
3793 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3794             mrdy = msftx(i, j-1)*rdy
3795             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
3796 &              , jp0)
3797             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
3798 &              jp0)
3799           END DO
3800         END DO
3801       ELSE IF (j .GT. j_start) THEN
3802 ! normal code
3803         DO k=kts,ktf
3804           DO i=i_start,i_end
3805 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
3806             mrdy = msftx(i, j-1)*rdy
3807             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
3808 &              k, jp1)-fqyd(i, k, jp0))
3809             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
3810 &              jp1)-fqy(i, k, jp0))
3811           END DO
3812         END DO
3813       END IF
3814       jtmp = jp1
3815       jp1 = jp0
3816       jp0 = jtmp
3817     END DO j_loop_y_flux_6
3818 !  next, x - flux divergence
3819     i_start = its
3820     IF (ite .GT. ide - 1) THEN
3821       i_end = ide - 1
3822     ELSE
3823       i_end = ite
3824     END IF
3825     j_start = jts
3826     IF (jte .GT. jde - 1) THEN
3827       j_end = jde - 1
3828     ELSE
3829       j_end = jte
3830     END IF
3831 !  higher order flux has a 5 or 7 point stencil, so compute
3832 !  bounds so we can switch to second order flux close to the boundary
3833     i_start_f = i_start
3834     i_end_f = i_end + 1
3835     IF (degrade_xs) THEN
3836       IF (ids + 1 .LT. its) THEN
3837         i_start = its
3838       ELSE
3839         i_start = ids + 1
3840       END IF
3841       IF (i_start + 2 .GT. ids + 3) THEN
3842         i_start_f = ids + 3
3843       ELSE
3844         i_start_f = i_start + 2
3845       END IF
3846     END IF
3847     IF (degrade_xe) THEN
3848       IF (ide - 2 .GT. ite) THEN
3849         i_end = ite
3850       ELSE
3851         i_end = ide - 2
3852       END IF
3853       i_end_f = ide - 3
3854       fqxd = 0.0
3855     ELSE
3856       fqxd = 0.0
3857     END IF
3858 !  compute fluxes
3859     DO j=j_start,j_end
3860 !  5th or 6th order flux
3861       DO k=kts,ktf
3862         DO i=i_start_f,i_end_f
3863           veld = rud(i, k, j)
3864           vel = ru(i, k, j)
3865           fqxd(i, k) = veld*(37.*(field(i, k, j)+field(i-1, k, j))-8.*(&
3866 &            field(i+1, k, j)+field(i-2, k, j))+(field(i+2, k, j)+field(i&
3867 &            -3, k, j)))/60.0 + vel*(37.*(fieldd(i, k, j)+fieldd(i-1, k, &
3868 &            j))-8.*(fieldd(i+1, k, j)+fieldd(i-2, k, j))+fieldd(i+2, k, &
3869 &            j)+fieldd(i-3, k, j))/60.0
3870           fqx(i, k) = vel*((37.*(field(i, k, j)+field(i-1, k, j))-8.*(&
3871 &            field(i+1, k, j)+field(i-2, k, j))+(field(i+2, k, j)+field(i&
3872 &            -3, k, j)))/60.0)
3873         END DO
3874       END DO
3875 !  lower order fluxes close to boundaries (if not periodic or symmetric)
3876       IF (degrade_xs) THEN
3877         DO i=i_start,i_start_f-1
3878           IF (i .EQ. ids + 1) THEN
3879 ! second order
3880             DO k=kts,ktf
3881               fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
3882 &                k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
3883               fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
3884 &                j))
3885             END DO
3886           END IF
3887           IF (i .EQ. ids + 2) THEN
3888 ! third order
3889             DO k=kts,ktf
3890               veld = rud(i, k, j)
3891               vel = ru(i, k, j)
3892               fqxd(i, k) = veld*(7.*(field(i, k, j)+field(i-1, k, j))-(&
3893 &                field(i+1, k, j)+field(i-2, k, j)))/12.0 + vel*(7.*(&
3894 &                fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k, j)-&
3895 &                fieldd(i-2, k, j))/12.0
3896               fqx(i, k) = vel*((7.*(field(i, k, j)+field(i-1, k, j))-(&
3897 &                field(i+1, k, j)+field(i-2, k, j)))/12.0)
3898             END DO
3899           END IF
3900         END DO
3901       END IF
3902       IF (degrade_xe) THEN
3903         DO i=i_end_f+1,i_end+1
3904           IF (i .EQ. ide - 1) THEN
3905 ! second order flux next to the boundary
3906             DO k=kts,ktf
3907               fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
3908 &                k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
3909               fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
3910 &                j))
3911             END DO
3912           END IF
3913           IF (i .EQ. ide - 2) THEN
3914 ! third order flux one in from the boundary
3915             DO k=kts,ktf
3916               veld = rud(i, k, j)
3917               vel = ru(i, k, j)
3918               fqxd(i, k) = veld*(7.*(field(i, k, j)+field(i-1, k, j))-(&
3919 &                field(i+1, k, j)+field(i-2, k, j)))/12.0 + vel*(7.*(&
3920 &                fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k, j)-&
3921 &                fieldd(i-2, k, j))/12.0
3922               fqx(i, k) = vel*((7.*(field(i, k, j)+field(i-1, k, j))-(&
3923 &                field(i+1, k, j)+field(i-2, k, j)))/12.0)
3924             END DO
3925           END IF
3926         END DO
3927       END IF
3928 !  x flux-divergence into tendency
3929       DO k=kts,ktf
3930         DO i=i_start,i_end
3931 ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
3932           mrdx = msftx(i, j)*rdx
3933           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
3934 &            fqxd(i, k))
3935           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
3936 &            i, k))
3937         END DO
3938       END DO
3939     END DO
3940   ELSE IF (horz_order .EQ. 5) THEN
3941 !  determine boundary mods for flux operators
3942 !  We degrade the flux operators from 3rd/4th order
3943 !   to second order one gridpoint in from the boundaries for
3944 !   all boundary conditions except periodic and symmetry - these
3945 !   conditions have boundary zone data fill for correct application
3946 !   of the higher order flux stencils
3947     degrade_xs = .true.
3948     degrade_xe = .true.
3949     degrade_ys = .true.
3950     degrade_ye = .true.
3951     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
3952 &        its .GT. ids + 3) degrade_xs = .false.
3953     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
3954 &        ite .LT. ide - 3) degrade_xe = .false.
3955     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
3956 &        jts .GT. jds + 3) degrade_ys = .false.
3957     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
3958 &        jte .LT. jde - 4) degrade_ye = .false.
3959     IF (kte .GT. kde - 1) THEN
3960       ktf = kde - 1
3961     ELSE
3962       ktf = kte
3963     END IF
3964     i_start = its
3965     IF (ite .GT. ide - 1) THEN
3966       i_end = ide - 1
3967     ELSE
3968       i_end = ite
3969     END IF
3970     j_start = jts
3971     IF (jte .GT. jde - 1) THEN
3972       j_end = jde - 1
3973     ELSE
3974       j_end = jte
3975     END IF
3976 !  higher order flux has a 5 or 7 point stencil, so compute
3977 !  bounds so we can switch to second order flux close to the boundary
3978     j_start_f = j_start
3979     j_end_f = j_end + 1
3980     IF (degrade_ys) THEN
3981       IF (jts .LT. jds + 1) THEN
3982         j_start = jds + 1
3983       ELSE
3984         j_start = jts
3985       END IF
3986       j_start_f = jds + 3
3987     END IF
3988     IF (degrade_ye) THEN
3989       IF (jte .GT. jde - 2) THEN
3990         j_end = jde - 2
3991       ELSE
3992         j_end = jte
3993       END IF
3994       j_end_f = jde - 3
3995     END IF
3996     IF (config_flags%polar) THEN
3997       IF (jte .GT. jde - 1) THEN
3998         j_end = jde - 1
3999       ELSE
4000         j_end = jte
4001       END IF
4002     END IF
4003 !  compute fluxes, 5th or 6th order
4004     jp1 = 2
4005     jp0 = 1
4006     fqyd = 0.0
4007 j_loop_y_flux_5:DO j=j_start,j_end+1
4008       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
4009 ! use full stencil
4010         DO k=kts,ktf
4011           DO i=i_start,i_end
4012             veld = rvd(i, k, j)
4013             vel = rv(i, k, j)
4014             fqyd(i, k, jp1) = veld*((37.*(field(i, k, j)+field(i, k, j-1&
4015 &              ))-8.*(field(i, k, j+1)+field(i, k, j-2))+(field(i, k, j+2&
4016 &              )+field(i, k, j-3)))/60.0-SIGN(1, time_step)*SIGN(1., vel)&
4017 &              *(field(i, k, j+2)-field(i, k, j-3)-5.*(field(i, k, j+1)-&
4018 &              field(i, k, j-2))+10.*(field(i, k, j)-field(i, k, j-1)))/&
4019 &              60.0) + vel*((37.*(fieldd(i, k, j)+fieldd(i, k, j-1))-8.*(&
4020 &              fieldd(i, k, j+1)+fieldd(i, k, j-2))+fieldd(i, k, j+2)+&
4021 &              fieldd(i, k, j-3))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(&
4022 &              fieldd(i, k, j+2)-fieldd(i, k, j-3)-5.*(fieldd(i, k, j+1)-&
4023 &              fieldd(i, k, j-2))+10.*(fieldd(i, k, j)-fieldd(i, k, j-1))&
4024 &              )/60.0)
4025             fqy(i, k, jp1) = vel*((37.*(field(i, k, j)+field(i, k, j-1))&
4026 &              -8.*(field(i, k, j+1)+field(i, k, j-2))+(field(i, k, j+2)+&
4027 &              field(i, k, j-3)))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(&
4028 &              field(i, k, j+2)-field(i, k, j-3)-5.*(field(i, k, j+1)-&
4029 &              field(i, k, j-2))+10.*(field(i, k, j)-field(i, k, j-1)))/&
4030 &              60.0)
4031           END DO
4032         END DO
4033       ELSE IF (j .EQ. jds + 1) THEN
4034 ! 2nd order flux next to south boundary
4035         DO k=kts,ktf
4036           DO i=i_start,i_end
4037             fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
4038 &              , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
4039 &              )
4040             fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
4041 &              , j-1))
4042           END DO
4043         END DO
4044       ELSE IF (j .EQ. jds + 2) THEN
4045 ! third of 4th order flux 2 in from south boundary
4046         DO k=kts,ktf
4047           DO i=i_start,i_end
4048             veld = rvd(i, k, j)
4049             vel = rv(i, k, j)
4050             fqyd(i, k, jp1) = veld*((7.*(field(i, k, j)+field(i, k, j-1)&
4051 &              )-(field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(1, &
4052 &              time_step)*SIGN(1., vel)*(field(i, k, j+1)-field(i, k, j-2&
4053 &              )-3.*(field(i, k, j)-field(i, k, j-1)))/12.0) + vel*((7.*(&
4054 &              fieldd(i, k, j)+fieldd(i, k, j-1))-fieldd(i, k, j+1)-&
4055 &              fieldd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(&
4056 &              fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)-&
4057 &              fieldd(i, k, j-1)))/12.0)
4058             fqy(i, k, jp1) = vel*((7.*(field(i, k, j)+field(i, k, j-1))-&
4059 &              (field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(1, &
4060 &              time_step)*SIGN(1., vel)*(field(i, k, j+1)-field(i, k, j-2&
4061 &              )-3.*(field(i, k, j)-field(i, k, j-1)))/12.0)
4062           END DO
4063         END DO
4064       ELSE IF (j .EQ. jde - 1) THEN
4065 ! 2nd order flux next to north boundary
4066         DO k=kts,ktf
4067           DO i=i_start,i_end
4068             fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
4069 &              , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
4070 &              )
4071             fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
4072 &              , j-1))
4073           END DO
4074         END DO
4075       ELSE IF (j .EQ. jde - 2) THEN
4076 ! 3rd or 4th order flux 2 in from north boundary
4077         DO k=kts,ktf
4078           DO i=i_start,i_end
4079             veld = rvd(i, k, j)
4080             vel = rv(i, k, j)
4081             fqyd(i, k, jp1) = veld*((7.*(field(i, k, j)+field(i, k, j-1)&
4082 &              )-(field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(1, &
4083 &              time_step)*SIGN(1., vel)*(field(i, k, j+1)-field(i, k, j-2&
4084 &              )-3.*(field(i, k, j)-field(i, k, j-1)))/12.0) + vel*((7.*(&
4085 &              fieldd(i, k, j)+fieldd(i, k, j-1))-fieldd(i, k, j+1)-&
4086 &              fieldd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(&
4087 &              fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)-&
4088 &              fieldd(i, k, j-1)))/12.0)
4089             fqy(i, k, jp1) = vel*((7.*(field(i, k, j)+field(i, k, j-1))-&
4090 &              (field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(1, &
4091 &              time_step)*SIGN(1., vel)*(field(i, k, j+1)-field(i, k, j-2&
4092 &              )-3.*(field(i, k, j)-field(i, k, j-1)))/12.0)
4093           END DO
4094         END DO
4095       END IF
4096 !  y flux-divergence into tendency
4097 ! Comments on polar boundary conditions
4098 ! Same process as for advect_u - tendencies run from jds to jde-1
4099 ! (latitudes are as for u grid, longitudes are displaced)
4100 ! Therefore: flow is only from one side for points next to poles
4101       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
4102         DO k=kts,ktf
4103           DO i=i_start,i_end
4104 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4105             mrdy = msftx(i, j-1)*rdy
4106             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
4107 &              , jp1)
4108             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
4109 &              jp1)
4110           END DO
4111         END DO
4112       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
4113         DO k=kts,ktf
4114           DO i=i_start,i_end
4115 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4116             mrdy = msftx(i, j-1)*rdy
4117             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
4118 &              , jp0)
4119             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
4120 &              jp0)
4121           END DO
4122         END DO
4123       ELSE IF (j .GT. j_start) THEN
4124 ! normal code
4125         DO k=kts,ktf
4126           DO i=i_start,i_end
4127 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4128             mrdy = msftx(i, j-1)*rdy
4129             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
4130 &              k, jp1)-fqyd(i, k, jp0))
4131             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
4132 &              jp1)-fqy(i, k, jp0))
4133           END DO
4134         END DO
4135       END IF
4136       jtmp = jp1
4137       jp1 = jp0
4138       jp0 = jtmp
4139     END DO j_loop_y_flux_5
4140 !  next, x - flux divergence
4141     i_start = its
4142     IF (ite .GT. ide - 1) THEN
4143       i_end = ide - 1
4144     ELSE
4145       i_end = ite
4146     END IF
4147     j_start = jts
4148     IF (jte .GT. jde - 1) THEN
4149       j_end = jde - 1
4150     ELSE
4151       j_end = jte
4152     END IF
4153 !  higher order flux has a 5 or 7 point stencil, so compute
4154 !  bounds so we can switch to second order flux close to the boundary
4155     i_start_f = i_start
4156     i_end_f = i_end + 1
4157     IF (degrade_xs) THEN
4158       IF (ids + 1 .LT. its) THEN
4159         i_start = its
4160       ELSE
4161         i_start = ids + 1
4162       END IF
4163       IF (i_start + 2 .GT. ids + 3) THEN
4164         i_start_f = ids + 3
4165       ELSE
4166         i_start_f = i_start + 2
4167       END IF
4168     END IF
4169     IF (degrade_xe) THEN
4170       IF (ide - 2 .GT. ite) THEN
4171         i_end = ite
4172       ELSE
4173         i_end = ide - 2
4174       END IF
4175       i_end_f = ide - 3
4176       fqxd = 0.0
4177     ELSE
4178       fqxd = 0.0
4179     END IF
4180 !  compute fluxes
4181     DO j=j_start,j_end
4182 !  5th or 6th order flux
4183       DO k=kts,ktf
4184         DO i=i_start_f,i_end_f
4185           veld = rud(i, k, j)
4186           vel = ru(i, k, j)
4187           fqxd(i, k) = veld*((37.*(field(i, k, j)+field(i-1, k, j))-8.*(&
4188 &            field(i+1, k, j)+field(i-2, k, j))+(field(i+2, k, j)+field(i&
4189 &            -3, k, j)))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(field(i+2&
4190 &            , k, j)-field(i-3, k, j)-5.*(field(i+1, k, j)-field(i-2, k, &
4191 &            j))+10.*(field(i, k, j)-field(i-1, k, j)))/60.0) + vel*((37.&
4192 &            *(fieldd(i, k, j)+fieldd(i-1, k, j))-8.*(fieldd(i+1, k, j)+&
4193 &            fieldd(i-2, k, j))+fieldd(i+2, k, j)+fieldd(i-3, k, j))/60.0&
4194 &            -SIGN(1, time_step)*SIGN(1., vel)*(fieldd(i+2, k, j)-fieldd(&
4195 &            i-3, k, j)-5.*(fieldd(i+1, k, j)-fieldd(i-2, k, j))+10.*(&
4196 &            fieldd(i, k, j)-fieldd(i-1, k, j)))/60.0)
4197           fqx(i, k) = vel*((37.*(field(i, k, j)+field(i-1, k, j))-8.*(&
4198 &            field(i+1, k, j)+field(i-2, k, j))+(field(i+2, k, j)+field(i&
4199 &            -3, k, j)))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(field(i+2&
4200 &            , k, j)-field(i-3, k, j)-5.*(field(i+1, k, j)-field(i-2, k, &
4201 &            j))+10.*(field(i, k, j)-field(i-1, k, j)))/60.0)
4202         END DO
4203       END DO
4204 !  lower order fluxes close to boundaries (if not periodic or symmetric)
4205       IF (degrade_xs) THEN
4206         DO i=i_start,i_start_f-1
4207           IF (i .EQ. ids + 1) THEN
4208 ! second order
4209             DO k=kts,ktf
4210               fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
4211 &                k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
4212               fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
4213 &                j))
4214             END DO
4215           END IF
4216           IF (i .EQ. ids + 2) THEN
4217 ! third order
4218             DO k=kts,ktf
4219               veld = rud(i, k, j)
4220               vel = ru(i, k, j)
4221               fqxd(i, k) = veld*((7.*(field(i, k, j)+field(i-1, k, j))-(&
4222 &                field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, &
4223 &                time_step)*SIGN(1., vel)*(field(i+1, k, j)-field(i-2, k&
4224 &                , j)-3.*(field(i, k, j)-field(i-1, k, j)))/12.0) + vel*(&
4225 &                (7.*(fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k, j&
4226 &                )-fieldd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
4227 &                vel)*(fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i, &
4228 &                k, j)-fieldd(i-1, k, j)))/12.0)
4229               fqx(i, k) = vel*((7.*(field(i, k, j)+field(i-1, k, j))-(&
4230 &                field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, &
4231 &                time_step)*SIGN(1., vel)*(field(i+1, k, j)-field(i-2, k&
4232 &                , j)-3.*(field(i, k, j)-field(i-1, k, j)))/12.0)
4233             END DO
4234           END IF
4235         END DO
4236       END IF
4237       IF (degrade_xe) THEN
4238         DO i=i_end_f+1,i_end+1
4239           IF (i .EQ. ide - 1) THEN
4240 ! second order flux next to the boundary
4241             DO k=kts,ktf
4242               fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
4243 &                k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
4244               fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
4245 &                j))
4246             END DO
4247           END IF
4248           IF (i .EQ. ide - 2) THEN
4249 ! third order flux one in from the boundary
4250             DO k=kts,ktf
4251               veld = rud(i, k, j)
4252               vel = ru(i, k, j)
4253               fqxd(i, k) = veld*((7.*(field(i, k, j)+field(i-1, k, j))-(&
4254 &                field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, &
4255 &                time_step)*SIGN(1., vel)*(field(i+1, k, j)-field(i-2, k&
4256 &                , j)-3.*(field(i, k, j)-field(i-1, k, j)))/12.0) + vel*(&
4257 &                (7.*(fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k, j&
4258 &                )-fieldd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
4259 &                vel)*(fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i, &
4260 &                k, j)-fieldd(i-1, k, j)))/12.0)
4261               fqx(i, k) = vel*((7.*(field(i, k, j)+field(i-1, k, j))-(&
4262 &                field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, &
4263 &                time_step)*SIGN(1., vel)*(field(i+1, k, j)-field(i-2, k&
4264 &                , j)-3.*(field(i, k, j)-field(i-1, k, j)))/12.0)
4265             END DO
4266           END IF
4267         END DO
4268       END IF
4269 !  x flux-divergence into tendency
4270       DO k=kts,ktf
4271         DO i=i_start,i_end
4272 ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
4273           mrdx = msftx(i, j)*rdx
4274           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
4275 &            fqxd(i, k))
4276           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
4277 &            i, k))
4278         END DO
4279       END DO
4280     END DO
4281   ELSE IF (horz_order .EQ. 4) THEN
4282     degrade_xs = .true.
4283     degrade_xe = .true.
4284     degrade_ys = .true.
4285     degrade_ye = .true.
4286     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
4287 &        its .GT. ids + 2) degrade_xs = .false.
4288     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
4289 &        ite .LT. ide - 2) degrade_xe = .false.
4290     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
4291 &        jts .GT. jds + 2) degrade_ys = .false.
4292     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
4293 &        jte .LT. jde - 3) degrade_ye = .false.
4294     IF (kte .GT. kde - 1) THEN
4295       ktf = kde - 1
4296     ELSE
4297       ktf = kte
4298     END IF
4299     i_start = its
4300     IF (ite .GT. ide - 1) THEN
4301       i_end = ide - 1
4302     ELSE
4303       i_end = ite
4304     END IF
4305     j_start = jts
4306     IF (jte .GT. jde - 1) THEN
4307       j_end = jde - 1
4308     ELSE
4309       j_end = jte
4310     END IF
4311 !  3rd or 4th order flux has a 5 point stencil, so compute
4312 !  bounds so we can switch to second order flux close to the boundary
4313     i_start_f = i_start
4314     i_end_f = i_end + 1
4315     IF (degrade_xs) THEN
4316       i_start = ids + 1
4317       i_start_f = i_start + 1
4318     END IF
4319     IF (degrade_xe) THEN
4320       i_end = ide - 2
4321       i_end_f = ide - 2
4322       fqxd = 0.0
4323     ELSE
4324       fqxd = 0.0
4325     END IF
4326 !  compute fluxes
4327     DO j=j_start,j_end
4328 !  3rd or 4th order flux
4329       DO k=kts,ktf
4330         DO i=i_start_f,i_end_f
4331           fqxd(i, k) = rud(i, k, j)*(7.*(field(i, k, j)+field(i-1, k, j)&
4332 &            )-(field(i+1, k, j)+field(i-2, k, j)))/12.0 + ru(i, k, j)*(&
4333 &            7.*(fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k, j)-&
4334 &            fieldd(i-2, k, j))/12.0
4335           fqx(i, k) = ru(i, k, j)*((7.*(field(i, k, j)+field(i-1, k, j))&
4336 &            -(field(i+1, k, j)+field(i-2, k, j)))/12.0)
4337         END DO
4338       END DO
4339 !  second order flux close to boundaries (if not periodic or symmetric)
4340       IF (degrade_xs) THEN
4341         DO k=kts,ktf
4342           fqxd(i_start, k) = 0.5*(rud(i_start, k, j)*(field(i_start, k, &
4343 &            j)+field(i_start-1, k, j))+ru(i_start, k, j)*(fieldd(i_start&
4344 &            , k, j)+fieldd(i_start-1, k, j)))
4345           fqx(i_start, k) = 0.5*ru(i_start, k, j)*(field(i_start, k, j)+&
4346 &            field(i_start-1, k, j))
4347         END DO
4348       END IF
4349       IF (degrade_xe) THEN
4350         DO k=kts,ktf
4351           fqxd(i_end+1, k) = 0.5*(rud(i_end+1, k, j)*(field(i_end+1, k, &
4352 &            j)+field(i_end, k, j))+ru(i_end+1, k, j)*(fieldd(i_end+1, k&
4353 &            , j)+fieldd(i_end, k, j)))
4354           fqx(i_end+1, k) = 0.5*ru(i_end+1, k, j)*(field(i_end+1, k, j)+&
4355 &            field(i_end, k, j))
4356         END DO
4357       END IF
4358 !  x flux-divergence into tendency
4359       DO k=kts,ktf
4360         DO i=i_start,i_end
4361 ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
4362           mrdx = msftx(i, j)*rdx
4363           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
4364 &            fqxd(i, k))
4365           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
4366 &            i, k))
4367         END DO
4368       END DO
4369     END DO
4370 !  next -> y flux divergence calculation
4371     i_start = its
4372     IF (ite .GT. ide - 1) THEN
4373       i_end = ide - 1
4374     ELSE
4375       i_end = ite
4376     END IF
4377     j_start = jts
4378     IF (jte .GT. jde - 1) THEN
4379       j_end = jde - 1
4380     ELSE
4381       j_end = jte
4382     END IF
4383 !  3rd or 4th order flux has a 5 point stencil, so compute
4384 !  bounds so we can switch to second order flux close to the boundary
4385     j_start_f = j_start
4386     j_end_f = j_end + 1
4387     IF (degrade_ys) THEN
4388       j_start = jds + 1
4389       j_start_f = j_start + 1
4390     END IF
4391     IF (degrade_ye) THEN
4392       j_end = jde - 2
4393       j_end_f = jde - 2
4394     END IF
4395     IF (config_flags%polar) THEN
4396       IF (jte .GT. jde - 1) THEN
4397         j_end = jde - 1
4398       ELSE
4399         j_end = jte
4400       END IF
4401     END IF
4402     jp1 = 2
4403     jp0 = 1
4404     fqyd = 0.0
4405     DO j=j_start,j_end+1
4406       IF (j .LT. j_start_f .AND. degrade_ys) THEN
4407         DO k=kts,ktf
4408           DO i=i_start,i_end
4409             fqyd(i, k, jp1) = 0.5*(rvd(i, k, j_start)*(field(i, k, &
4410 &              j_start)+field(i, k, j_start-1))+rv(i, k, j_start)*(fieldd&
4411 &              (i, k, j_start)+fieldd(i, k, j_start-1)))
4412             fqy(i, k, jp1) = 0.5*rv(i, k, j_start)*(field(i, k, j_start)&
4413 &              +field(i, k, j_start-1))
4414           END DO
4415         END DO
4416       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
4417         DO k=kts,ktf
4418           DO i=i_start,i_end
4419 ! Assumes j>j_end_f is ONLY j_end+1 ...
4420 !         fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1)          &
4421 !                *(field(i,k,j_end+1)+field(i,k,j_end))
4422             fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
4423 &              , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
4424 &              )
4425             fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
4426 &              , j-1))
4427           END DO
4428         END DO
4429       ELSE
4430 !  3rd or 4th order flux
4431         DO k=kts,ktf
4432           DO i=i_start,i_end
4433             fqyd(i, k, jp1) = rvd(i, k, j)*(7.*(field(i, k, j)+field(i, &
4434 &              k, j-1))-(field(i, k, j+1)+field(i, k, j-2)))/12.0 + rv(i&
4435 &              , k, j)*(7.*(fieldd(i, k, j)+fieldd(i, k, j-1))-fieldd(i, &
4436 &              k, j+1)-fieldd(i, k, j-2))/12.0
4437             fqy(i, k, jp1) = rv(i, k, j)*((7.*(field(i, k, j)+field(i, k&
4438 &              , j-1))-(field(i, k, j+1)+field(i, k, j-2)))/12.0)
4439           END DO
4440         END DO
4441       END IF
4442 !  y flux-divergence into tendency
4443 ! Comments on polar boundary conditions
4444 ! Same process as for advect_u - tendencies run from jds to jde-1
4445 ! (latitudes are as for u grid, longitudes are displaced)
4446 ! Therefore: flow is only from one side for points next to poles
4447       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
4448         DO k=kts,ktf
4449           DO i=i_start,i_end
4450 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4451             mrdy = msftx(i, j-1)*rdy
4452             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
4453 &              , jp1)
4454             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
4455 &              jp1)
4456           END DO
4457         END DO
4458       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
4459         DO k=kts,ktf
4460           DO i=i_start,i_end
4461 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4462             mrdy = msftx(i, j-1)*rdy
4463             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
4464 &              , jp0)
4465             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
4466 &              jp0)
4467           END DO
4468         END DO
4469       ELSE IF (j .GT. j_start) THEN
4470 ! normal code
4471         DO k=kts,ktf
4472           DO i=i_start,i_end
4473 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4474             mrdy = msftx(i, j-1)*rdy
4475             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
4476 &              k, jp1)-fqyd(i, k, jp0))
4477             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
4478 &              jp1)-fqy(i, k, jp0))
4479           END DO
4480         END DO
4481       END IF
4482       jtmp = jp1
4483       jp1 = jp0
4484       jp0 = jtmp
4485     END DO
4486   ELSE IF (horz_order .EQ. 3) THEN
4487     degrade_xs = .true.
4488     degrade_xe = .true.
4489     degrade_ys = .true.
4490     degrade_ye = .true.
4491     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
4492 &        its .GT. ids + 2) degrade_xs = .false.
4493     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
4494 &        ite .LT. ide - 2) degrade_xe = .false.
4495     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
4496 &        jts .GT. jds + 2) degrade_ys = .false.
4497     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
4498 &        jte .LT. jde - 3) degrade_ye = .false.
4499     IF (kte .GT. kde - 1) THEN
4500       ktf = kde - 1
4501     ELSE
4502       ktf = kte
4503     END IF
4504     i_start = its
4505     IF (ite .GT. ide - 1) THEN
4506       i_end = ide - 1
4507     ELSE
4508       i_end = ite
4509     END IF
4510     j_start = jts
4511     IF (jte .GT. jde - 1) THEN
4512       j_end = jde - 1
4513     ELSE
4514       j_end = jte
4515     END IF
4516 !  3rd or 4th order flux has a 5 point stencil, so compute
4517 !  bounds so we can switch to second order flux close to the boundary
4518     i_start_f = i_start
4519     i_end_f = i_end + 1
4520     IF (degrade_xs) THEN
4521       i_start = ids + 1
4522       i_start_f = i_start + 1
4523     END IF
4524     IF (degrade_xe) THEN
4525       i_end = ide - 2
4526       i_end_f = ide - 2
4527       fqxd = 0.0
4528     ELSE
4529       fqxd = 0.0
4530     END IF
4531 !  compute fluxes
4532     DO j=j_start,j_end
4533 !  3rd or 4th order flux
4534       DO k=kts,ktf
4535         DO i=i_start_f,i_end_f
4536           fqxd(i, k) = rud(i, k, j)*((7.*(field(i, k, j)+field(i-1, k, j&
4537 &            ))-(field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, &
4538 &            time_step)*SIGN(1., ru(i, k, j))*(field(i+1, k, j)-field(i-2&
4539 &            , k, j)-3.*(field(i, k, j)-field(i-1, k, j)))/12.0) + ru(i, &
4540 &            k, j)*((7.*(fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k&
4541 &            , j)-fieldd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., ru(&
4542 &            i, k, j))*(fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i&
4543 &            , k, j)-fieldd(i-1, k, j)))/12.0)
4544           fqx(i, k) = ru(i, k, j)*((7.*(field(i, k, j)+field(i-1, k, j))&
4545 &            -(field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, time_step&
4546 &            )*SIGN(1., ru(i, k, j))*(field(i+1, k, j)-field(i-2, k, j)-&
4547 &            3.*(field(i, k, j)-field(i-1, k, j)))/12.0)
4548         END DO
4549       END DO
4550 !  second order flux close to boundaries (if not periodic or symmetric)
4551       IF (degrade_xs) THEN
4552         DO k=kts,ktf
4553           fqxd(i_start, k) = 0.5*(rud(i_start, k, j)*(field(i_start, k, &
4554 &            j)+field(i_start-1, k, j))+ru(i_start, k, j)*(fieldd(i_start&
4555 &            , k, j)+fieldd(i_start-1, k, j)))
4556           fqx(i_start, k) = 0.5*ru(i_start, k, j)*(field(i_start, k, j)+&
4557 &            field(i_start-1, k, j))
4558         END DO
4559       END IF
4560       IF (degrade_xe) THEN
4561         DO k=kts,ktf
4562           fqxd(i_end+1, k) = 0.5*(rud(i_end+1, k, j)*(field(i_end+1, k, &
4563 &            j)+field(i_end, k, j))+ru(i_end+1, k, j)*(fieldd(i_end+1, k&
4564 &            , j)+fieldd(i_end, k, j)))
4565           fqx(i_end+1, k) = 0.5*ru(i_end+1, k, j)*(field(i_end+1, k, j)+&
4566 &            field(i_end, k, j))
4567         END DO
4568       END IF
4569 !  x flux-divergence into tendency
4570       DO k=kts,ktf
4571         DO i=i_start,i_end
4572 ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
4573           mrdx = msftx(i, j)*rdx
4574           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
4575 &            fqxd(i, k))
4576           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
4577 &            i, k))
4578         END DO
4579       END DO
4580     END DO
4581 !  next -> y flux divergence calculation
4582     i_start = its
4583     IF (ite .GT. ide - 1) THEN
4584       i_end = ide - 1
4585     ELSE
4586       i_end = ite
4587     END IF
4588     j_start = jts
4589     IF (jte .GT. jde - 1) THEN
4590       j_end = jde - 1
4591     ELSE
4592       j_end = jte
4593     END IF
4594 !  3rd or 4th order flux has a 5 point stencil, so compute
4595 !  bounds so we can switch to second order flux close to the boundary
4596     j_start_f = j_start
4597     j_end_f = j_end + 1
4598     IF (degrade_ys) THEN
4599       j_start = jds + 1
4600       j_start_f = j_start + 1
4601     END IF
4602     IF (degrade_ye) THEN
4603       j_end = jde - 2
4604       j_end_f = jde - 2
4605     END IF
4606     IF (config_flags%polar) THEN
4607       IF (jte .GT. jde - 1) THEN
4608         j_end = jde - 1
4609       ELSE
4610         j_end = jte
4611       END IF
4612     END IF
4613     jp1 = 2
4614     jp0 = 1
4615     fqyd = 0.0
4616     DO j=j_start,j_end+1
4617       IF (j .LT. j_start_f .AND. degrade_ys) THEN
4618         DO k=kts,ktf
4619           DO i=i_start,i_end
4620             fqyd(i, k, jp1) = 0.5*(rvd(i, k, j_start)*(field(i, k, &
4621 &              j_start)+field(i, k, j_start-1))+rv(i, k, j_start)*(fieldd&
4622 &              (i, k, j_start)+fieldd(i, k, j_start-1)))
4623             fqy(i, k, jp1) = 0.5*rv(i, k, j_start)*(field(i, k, j_start)&
4624 &              +field(i, k, j_start-1))
4625           END DO
4626         END DO
4627       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
4628         DO k=kts,ktf
4629           DO i=i_start,i_end
4630 ! Assumes j>j_end_f is ONLY j_end+1 ...
4631 !         fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1)          &
4632 !                *(field(i,k,j_end+1)+field(i,k,j_end))
4633             fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
4634 &              , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
4635 &              )
4636             fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
4637 &              , j-1))
4638           END DO
4639         END DO
4640       ELSE
4641 !  3rd or 4th order flux
4642         DO k=kts,ktf
4643           DO i=i_start,i_end
4644             fqyd(i, k, jp1) = rvd(i, k, j)*((7.*(field(i, k, j)+field(i&
4645 &              , k, j-1))-(field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(&
4646 &              1, time_step)*SIGN(1., rv(i, k, j))*(field(i, k, j+1)-&
4647 &              field(i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))/&
4648 &              12.0) + rv(i, k, j)*((7.*(fieldd(i, k, j)+fieldd(i, k, j-1&
4649 &              ))-fieldd(i, k, j+1)-fieldd(i, k, j-2))/12.0+SIGN(1, &
4650 &              time_step)*SIGN(1., rv(i, k, j))*(fieldd(i, k, j+1)-fieldd&
4651 &              (i, k, j-2)-3.*(fieldd(i, k, j)-fieldd(i, k, j-1)))/12.0)
4652             fqy(i, k, jp1) = rv(i, k, j)*((7.*(field(i, k, j)+field(i, k&
4653 &              , j-1))-(field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(1, &
4654 &              time_step)*SIGN(1., rv(i, k, j))*(field(i, k, j+1)-field(i&
4655 &              , k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))/12.0)
4656           END DO
4657         END DO
4658       END IF
4659 !  y flux-divergence into tendency
4660 ! Comments on polar boundary conditions
4661 ! Same process as for advect_u - tendencies run from jds to jde-1
4662 ! (latitudes are as for u grid, longitudes are displaced)
4663 ! Therefore: flow is only from one side for points next to poles
4664       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
4665         DO k=kts,ktf
4666           DO i=i_start,i_end
4667 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4668             mrdy = msftx(i, j-1)*rdy
4669             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
4670 &              , jp1)
4671             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
4672 &              jp1)
4673           END DO
4674         END DO
4675       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
4676         DO k=kts,ktf
4677           DO i=i_start,i_end
4678 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4679             mrdy = msftx(i, j-1)*rdy
4680             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
4681 &              , jp0)
4682             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
4683 &              jp0)
4684           END DO
4685         END DO
4686       ELSE IF (j .GT. j_start) THEN
4687 ! normal code
4688         DO k=kts,ktf
4689           DO i=i_start,i_end
4690 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4691             mrdy = msftx(i, j-1)*rdy
4692             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
4693 &              k, jp1)-fqyd(i, k, jp0))
4694             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
4695 &              jp1)-fqy(i, k, jp0))
4696           END DO
4697         END DO
4698       END IF
4699       jtmp = jp1
4700       jp1 = jp0
4701       jp0 = jtmp
4702     END DO
4703   ELSE IF (horz_order .EQ. 2) THEN
4704     i_start = its
4705     IF (ite .GT. ide - 1) THEN
4706       i_end = ide - 1
4707     ELSE
4708       i_end = ite
4709     END IF
4710     j_start = jts
4711     IF (jte .GT. jde - 1) THEN
4712       j_end = jde - 1
4713     ELSE
4714       j_end = jte
4715     END IF
4716     IF (.NOT.config_flags%periodic_x) THEN
4717       IF (config_flags%open_xs .OR. specified) THEN
4718         IF (ids + 1 .LT. its) THEN
4719           i_start = its
4720         ELSE
4721           i_start = ids + 1
4722         END IF
4723       END IF
4724       IF (config_flags%open_xe .OR. specified) THEN
4725         IF (ide - 2 .GT. ite) THEN
4726           i_end = ite
4727         ELSE
4728           i_end = ide - 2
4729         END IF
4730       END IF
4731     END IF
4732     DO j=j_start,j_end
4733       DO k=kts,ktf
4734         DO i=i_start,i_end
4735 ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
4736           mrdx = msftx(i, j)*rdx
4737           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.5*(rud(i+1, k&
4738 &            , j)*(field(i+1, k, j)+field(i, k, j))+ru(i+1, k, j)*(fieldd&
4739 &            (i+1, k, j)+fieldd(i, k, j))-rud(i, k, j)*(field(i, k, j)+&
4740 &            field(i-1, k, j))-ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k&
4741 &            , j)))
4742           tendency(i, k, j) = tendency(i, k, j) - mrdx*0.5*(ru(i+1, k, j&
4743 &            )*(field(i+1, k, j)+field(i, k, j))-ru(i, k, j)*(field(i, k&
4744 &            , j)+field(i-1, k, j)))
4745         END DO
4746       END DO
4747     END DO
4748     i_start = its
4749     IF (ite .GT. ide - 1) THEN
4750       i_end = ide - 1
4751     ELSE
4752       i_end = ite
4753     END IF
4754 ! Polar boundary conditions are like open or specified
4755     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
4756 &    THEN
4757       IF (jds + 1 .LT. jts) THEN
4758         j_start = jts
4759       ELSE
4760         j_start = jds + 1
4761       END IF
4762     END IF
4763     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
4764 &    THEN
4765       IF (jde - 2 .GT. jte) THEN
4766         j_end = jte
4767       ELSE
4768         j_end = jde - 2
4769       END IF
4770     END IF
4771     DO j=j_start,j_end
4772       DO k=kts,ktf
4773         DO i=i_start,i_end
4774 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4775           mrdy = msftx(i, j)*rdy
4776           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.5*(rvd(i, k, &
4777 &            j+1)*(field(i, k, j+1)+field(i, k, j))+rv(i, k, j+1)*(fieldd&
4778 &            (i, k, j+1)+fieldd(i, k, j))-rvd(i, k, j)*(field(i, k, j)+&
4779 &            field(i, k, j-1))-rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, &
4780 &            j-1)))
4781           tendency(i, k, j) = tendency(i, k, j) - mrdy*0.5*(rv(i, k, j+1&
4782 &            )*(field(i, k, j+1)+field(i, k, j))-rv(i, k, j)*(field(i, k&
4783 &            , j)+field(i, k, j-1)))
4784         END DO
4785       END DO
4786     END DO
4787 ! Polar boundary condtions
4788 ! These won't be covered in the loop above...
4789     IF (config_flags%polar) THEN
4790       IF (jts .EQ. jds) THEN
4791         DO k=kts,ktf
4792           DO i=i_start,i_end
4793 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4794             mrdy = msftx(i, jds)*rdy
4795             tendencyd(i, k, jds) = tendencyd(i, k, jds) - mrdy*0.5*(rvd(&
4796 &              i, k, jds+1)*(field(i, k, jds+1)+field(i, k, jds))+rv(i, k&
4797 &              , jds+1)*(fieldd(i, k, jds+1)+fieldd(i, k, jds)))
4798             tendency(i, k, jds) = tendency(i, k, jds) - mrdy*0.5*rv(i, k&
4799 &              , jds+1)*(field(i, k, jds+1)+field(i, k, jds))
4800           END DO
4801         END DO
4802       END IF
4803       IF (jte .EQ. jde) THEN
4804         DO k=kts,ktf
4805           DO i=i_start,i_end
4806 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
4807             mrdy = msftx(i, jde-1)*rdy
4808             tendencyd(i, k, jde-1) = tendencyd(i, k, jde-1) + mrdy*0.5*(&
4809 &              rvd(i, k, jde-1)*(field(i, k, jde-1)+field(i, k, jde-2))+&
4810 &              rv(i, k, jde-1)*(fieldd(i, k, jde-1)+fieldd(i, k, jde-2)))
4811             tendency(i, k, jde-1) = tendency(i, k, jde-1) + mrdy*0.5*rv(&
4812 &              i, k, jde-1)*(field(i, k, jde-1)+field(i, k, jde-2))
4813           END DO
4814         END DO
4815       END IF
4816     END IF
4817   ELSE IF (horz_order .NE. 0) THEN
4818 ! Just in case we want to turn horizontal advection off, we can do it
4819     WRITE(wrf_err_message, *) &
4820 &    'module_advect: advect_scalar_6a, h_order not known ', horz_order
4821     CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
4822   END IF
4823 !  pick up the rest of the horizontal radiation boundary conditions.
4824 !  (these are the computations that don't require 'cb'.
4825 !  first, set to index ranges
4826   i_start = its
4827   IF (ite .GT. ide - 1) THEN
4828     i_end = ide - 1
4829   ELSE
4830     i_end = ite
4831   END IF
4832   j_start = jts
4833   IF (jte .GT. jde - 1) THEN
4834     j_end = jde - 1
4835   ELSE
4836     j_end = jte
4837   END IF
4838 !  compute x (u) conditions for v, w, or scalar
4839   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
4840     DO j=j_start,j_end
4841       DO k=kts,ktf
4842         IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
4843           ub = 0.
4844           ubd = 0.0
4845         ELSE
4846           ubd = 0.5*(rud(its, k, j)+rud(its+1, k, j))
4847           ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
4848         END IF
4849         tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(&
4850 &          field_old(its+1, k, j)-field_old(its, k, j))+ub*(field_oldd(&
4851 &          its+1, k, j)-field_oldd(its, k, j))+fieldd(its, k, j)*(ru(its+&
4852 &          1, k, j)-ru(its, k, j))+field(its, k, j)*(rud(its+1, k, j)-rud&
4853 &          (its, k, j)))
4854         tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(field_old(&
4855 &          its+1, k, j)-field_old(its, k, j))+field(its, k, j)*(ru(its+1&
4856 &          , k, j)-ru(its, k, j)))
4857       END DO
4858     END DO
4859   END IF
4860   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
4861     DO j=j_start,j_end
4862       DO k=kts,ktf
4863         IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
4864           ub = 0.
4865           ubd = 0.0
4866         ELSE
4867           ubd = 0.5*(rud(ite-1, k, j)+rud(ite, k, j))
4868           ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
4869         END IF
4870         tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
4871 &          field_old(i_end, k, j)-field_old(i_end-1, k, j))+ub*(&
4872 &          field_oldd(i_end, k, j)-field_oldd(i_end-1, k, j))+fieldd(&
4873 &          i_end, k, j)*(ru(ite, k, j)-ru(ite-1, k, j))+field(i_end, k, j&
4874 &          )*(rud(ite, k, j)-rud(ite-1, k, j)))
4875         tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(&
4876 &          field_old(i_end, k, j)-field_old(i_end-1, k, j))+field(i_end, &
4877 &          k, j)*(ru(ite, k, j)-ru(ite-1, k, j)))
4878       END DO
4879     END DO
4880   END IF
4881   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
4882     DO i=i_start,i_end
4883       DO k=kts,ktf
4884         IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
4885           vb = 0.
4886           vbd = 0.0
4887         ELSE
4888           vbd = 0.5*(rvd(i, k, jts)+rvd(i, k, jts+1))
4889           vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
4890         END IF
4891         tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
4892 &          field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
4893 &          , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*(rv(i, k&
4894 &          , jts+1)-rv(i, k, jts))+field(i, k, jts)*(rvd(i, k, jts+1)-rvd&
4895 &          (i, k, jts)))
4896         tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
4897 &          , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*(rv(i, k, &
4898 &          jts+1)-rv(i, k, jts)))
4899       END DO
4900     END DO
4901   END IF
4902   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
4903     DO i=i_start,i_end
4904       DO k=kts,ktf
4905         IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
4906           vb = 0.
4907           vbd = 0.0
4908         ELSE
4909           vbd = 0.5*(rvd(i, k, jte-1)+rvd(i, k, jte))
4910           vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
4911         END IF
4912         tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
4913 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
4914 &          field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))+fieldd(i, k&
4915 &          , j_end)*(rv(i, k, jte)-rv(i, k, jte-1))+field(i, k, j_end)*(&
4916 &          rvd(i, k, jte)-rvd(i, k, jte-1)))
4917         tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
4918 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
4919 &          j_end)*(rv(i, k, jte)-rv(i, k, jte-1)))
4920       END DO
4921     END DO
4922   END IF
4923 !-------------------- vertical advection
4924 !     Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
4925 !     Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
4926 !     So we don't need to make a correction for advect_scalar
4927   i_start = its
4928   IF (ite .GT. ide - 1) THEN
4929     i_end = ide - 1
4930   ELSE
4931     i_end = ite
4932   END IF
4933   j_start = jts
4934   IF (jte .GT. jde - 1) THEN
4935     j_end = jde - 1
4936   ELSE
4937     j_end = jte
4938   END IF
4939   DO i=i_start,i_end
4940     vfluxd(i, kts) = 0.0
4941     vflux(i, kts) = 0.
4942     vfluxd(i, kte) = 0.0
4943     vflux(i, kte) = 0.
4944   END DO
4945   IF (vert_order .EQ. 6) THEN
4946     vfluxd = 0.0
4947     DO j=j_start,j_end
4948       DO k=kts+3,ktf-2
4949         DO i=i_start,i_end
4950           veld = romd(i, k, j)
4951           vel = rom(i, k, j)
4952           vfluxd(i, k) = veld*(37.*(field(i, k, j)+field(i, k-1, j))-8.*&
4953 &            (field(i, k+1, j)+field(i, k-2, j))+(field(i, k+2, j)+field(&
4954 &            i, k-3, j)))/60.0 + vel*(37.*(fieldd(i, k, j)+fieldd(i, k-1&
4955 &            , j))-8.*(fieldd(i, k+1, j)+fieldd(i, k-2, j))+fieldd(i, k+2&
4956 &            , j)+fieldd(i, k-3, j))/60.0
4957           vflux(i, k) = vel*((37.*(field(i, k, j)+field(i, k-1, j))-8.*(&
4958 &            field(i, k+1, j)+field(i, k-2, j))+(field(i, k+2, j)+field(i&
4959 &            , k-3, j)))/60.0)
4960         END DO
4961       END DO
4962       DO i=i_start,i_end
4963         k = kts + 1
4964         vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
4965 &          (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
4966 &          fieldd(i, k-1, j))
4967         vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
4968 &          , k-1, j))
4969         k = kts + 2
4970         veld = romd(i, k, j)
4971         vel = rom(i, k, j)
4972         vfluxd(i, k) = veld*(7.*(field(i, k, j)+field(i, k-1, j))-(field&
4973 &          (i, k+1, j)+field(i, k-2, j)))/12.0 + vel*(7.*(fieldd(i, k, j)&
4974 &          +fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, j))/12.0
4975         vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(field(&
4976 &          i, k+1, j)+field(i, k-2, j)))/12.0)
4977         k = ktf - 1
4978         veld = romd(i, k, j)
4979         vel = rom(i, k, j)
4980         vfluxd(i, k) = veld*(7.*(field(i, k, j)+field(i, k-1, j))-(field&
4981 &          (i, k+1, j)+field(i, k-2, j)))/12.0 + vel*(7.*(fieldd(i, k, j)&
4982 &          +fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, j))/12.0
4983         vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(field(&
4984 &          i, k+1, j)+field(i, k-2, j)))/12.0)
4985         k = ktf
4986         vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
4987 &          (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
4988 &          fieldd(i, k-1, j))
4989         vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
4990 &          , k-1, j))
4991       END DO
4992       DO k=kts,ktf
4993         DO i=i_start,i_end
4994           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
4995 &            +1)-vfluxd(i, k))
4996           tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
4997 &            -vflux(i, k))
4998         END DO
4999       END DO
5000     END DO
5001   ELSE IF (vert_order .EQ. 5) THEN
5002     vfluxd = 0.0
5003     DO j=j_start,j_end
5004       DO k=kts+3,ktf-2
5005         DO i=i_start,i_end
5006           veld = romd(i, k, j)
5007           vel = rom(i, k, j)
5008           vfluxd(i, k) = veld*((37.*(field(i, k, j)+field(i, k-1, j))-8.&
5009 &            *(field(i, k+1, j)+field(i, k-2, j))+(field(i, k+2, j)+field&
5010 &            (i, k-3, j)))/60.0-SIGN(1, time_step)*SIGN(1., -vel)*(field(&
5011 &            i, k+2, j)-field(i, k-3, j)-5.*(field(i, k+1, j)-field(i, k-&
5012 &            2, j))+10.*(field(i, k, j)-field(i, k-1, j)))/60.0) + vel*((&
5013 &            37.*(fieldd(i, k, j)+fieldd(i, k-1, j))-8.*(fieldd(i, k+1, j&
5014 &            )+fieldd(i, k-2, j))+fieldd(i, k+2, j)+fieldd(i, k-3, j))/&
5015 &            60.0-SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+2, j)-&
5016 &            fieldd(i, k-3, j)-5.*(fieldd(i, k+1, j)-fieldd(i, k-2, j))+&
5017 &            10.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/60.0)
5018           vflux(i, k) = vel*((37.*(field(i, k, j)+field(i, k-1, j))-8.*(&
5019 &            field(i, k+1, j)+field(i, k-2, j))+(field(i, k+2, j)+field(i&
5020 &            , k-3, j)))/60.0-SIGN(1, time_step)*SIGN(1., -vel)*(field(i&
5021 &            , k+2, j)-field(i, k-3, j)-5.*(field(i, k+1, j)-field(i, k-2&
5022 &            , j))+10.*(field(i, k, j)-field(i, k-1, j)))/60.0)
5023         END DO
5024       END DO
5025       DO i=i_start,i_end
5026         k = kts + 1
5027         vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
5028 &          (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
5029 &          fieldd(i, k-1, j))
5030         vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
5031 &          , k-1, j))
5032         k = kts + 2
5033         veld = romd(i, k, j)
5034         vel = rom(i, k, j)
5035         vfluxd(i, k) = veld*((7.*(field(i, k, j)+field(i, k-1, j))-(&
5036 &          field(i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*&
5037 &          SIGN(1., -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(i&
5038 &          , k, j)-field(i, k-1, j)))/12.0) + vel*((7.*(fieldd(i, k, j)+&
5039 &          fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, j))/12.0+&
5040 &          SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-fieldd(i&
5041 &          , k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.0)
5042         vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(field(&
5043 &          i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1.&
5044 &          , -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-&
5045 &          field(i, k-1, j)))/12.0)
5046         k = ktf - 1
5047         veld = romd(i, k, j)
5048         vel = rom(i, k, j)
5049         vfluxd(i, k) = veld*((7.*(field(i, k, j)+field(i, k-1, j))-(&
5050 &          field(i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*&
5051 &          SIGN(1., -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(i&
5052 &          , k, j)-field(i, k-1, j)))/12.0) + vel*((7.*(fieldd(i, k, j)+&
5053 &          fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, j))/12.0+&
5054 &          SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-fieldd(i&
5055 &          , k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.0)
5056         vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(field(&
5057 &          i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1.&
5058 &          , -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-&
5059 &          field(i, k-1, j)))/12.0)
5060         k = ktf
5061         vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
5062 &          (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
5063 &          fieldd(i, k-1, j))
5064         vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
5065 &          , k-1, j))
5066       END DO
5067       DO k=kts,ktf
5068         DO i=i_start,i_end
5069           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
5070 &            +1)-vfluxd(i, k))
5071           tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
5072 &            -vflux(i, k))
5073         END DO
5074       END DO
5075     END DO
5076   ELSE IF (vert_order .EQ. 4) THEN
5077     vfluxd = 0.0
5078     DO j=j_start,j_end
5079       DO k=kts+2,ktf-1
5080         DO i=i_start,i_end
5081           veld = romd(i, k, j)
5082           vel = rom(i, k, j)
5083           vfluxd(i, k) = veld*(7.*(field(i, k, j)+field(i, k-1, j))-(&
5084 &            field(i, k+1, j)+field(i, k-2, j)))/12.0 + vel*(7.*(fieldd(i&
5085 &            , k, j)+fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, &
5086 &            j))/12.0
5087           vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(&
5088 &            field(i, k+1, j)+field(i, k-2, j)))/12.0)
5089         END DO
5090       END DO
5091       DO i=i_start,i_end
5092         k = kts + 1
5093         vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
5094 &          (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
5095 &          fieldd(i, k-1, j))
5096         vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
5097 &          , k-1, j))
5098         k = ktf
5099         vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
5100 &          (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
5101 &          fieldd(i, k-1, j))
5102         vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
5103 &          , k-1, j))
5104       END DO
5105       DO k=kts,ktf
5106         DO i=i_start,i_end
5107           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
5108 &            +1)-vfluxd(i, k))
5109           tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
5110 &            -vflux(i, k))
5111         END DO
5112       END DO
5113     END DO
5114   ELSE IF (vert_order .EQ. 3) THEN
5115     vfluxd = 0.0
5116     DO j=j_start,j_end
5117       DO k=kts+2,ktf-1
5118         DO i=i_start,i_end
5119           veld = romd(i, k, j)
5120           vel = rom(i, k, j)
5121           vfluxd(i, k) = veld*((7.*(field(i, k, j)+field(i, k-1, j))-(&
5122 &            field(i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*&
5123 &            SIGN(1., -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
5124 &            i, k, j)-field(i, k-1, j)))/12.0) + vel*((7.*(fieldd(i, k, j&
5125 &            )+fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, j))/&
5126 &            12.0+SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-&
5127 &            fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/&
5128 &            12.0)
5129           vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(&
5130 &            field(i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*&
5131 &            SIGN(1., -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
5132 &            i, k, j)-field(i, k-1, j)))/12.0)
5133         END DO
5134       END DO
5135       DO i=i_start,i_end
5136         k = kts + 1
5137         vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
5138 &          (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
5139 &          fieldd(i, k-1, j))
5140         vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
5141 &          , k-1, j))
5142         k = ktf
5143         vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
5144 &          (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
5145 &          fieldd(i, k-1, j))
5146         vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
5147 &          , k-1, j))
5148       END DO
5149       DO k=kts,ktf
5150         DO i=i_start,i_end
5151           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
5152 &            +1)-vfluxd(i, k))
5153           tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
5154 &            -vflux(i, k))
5155         END DO
5156       END DO
5157     END DO
5158   ELSE IF (vert_order .EQ. 2) THEN
5159     vfluxd = 0.0
5160     DO j=j_start,j_end
5161       DO k=kts+1,ktf
5162         DO i=i_start,i_end
5163           vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
5164 &            field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp&
5165 &            (k)*fieldd(i, k-1, j))
5166           vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
5167 &            (i, k-1, j))
5168         END DO
5169       END DO
5170       DO k=kts,ktf
5171         DO i=i_start,i_end
5172           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
5173 &            +1)-vfluxd(i, k))
5174           tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
5175 &            -vflux(i, k))
5176         END DO
5177       END DO
5178     END DO
5179   ELSE
5180     WRITE(wrf_err_message, *) ' advect_scalar_6a, v_order not known ', &
5181 &    vert_order
5182     CALL WRF_ERROR_FATAL(wrf_err_message)
5183   END IF
5184 END SUBROUTINE G_ADVECT_SCALAR
5185
5186 !        Generated by TAPENADE     (INRIA, Tropics team)
5187 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
5188 !
5189 !  Differentiation of advect_w in forward (tangent) mode:
5190 !   variations   of useful results: tendency
5191 !   with respect to varying inputs: rom tendency w ru rv w_old
5192 !   RW status of diff variables: rom:in tendency:in-out w:in ru:in
5193 !                rv:in w_old:in
5194 SUBROUTINE G_ADVECT_W(w, wd, w_old, w_oldd, tendency, tendencyd, ru, rud&
5195 &  , rv, rvd, rom, romd, mut, time_step, config_flags, msfux, msfuy, &
5196 &  msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzu, ids, ide, jds, &
5197 &  jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, &
5198 &  kte)
5199   IMPLICIT NONE
5200 ! Input data
5201   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
5202   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
5203 &  jme, kms, kme, its, ite, jts, jte, kts, kte
5204   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: w, w_old, ru&
5205 &  , rv, rom
5206   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: wd, w_oldd, &
5207 &  rud, rvd, romd
5208   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
5209   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
5210   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
5211   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
5212 &  msfvy, msftx, msfty
5213   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzu
5214   REAL, INTENT(IN) :: rdx, rdy
5215   INTEGER, INTENT(IN) :: time_step
5216 ! Local data
5217   INTEGER :: i, j, k, itf, jtf, ktf
5218   INTEGER :: i_start, i_end, j_start, j_end
5219   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
5220   INTEGER :: jmin, jmax, jp, jm, imin, imax
5221   REAL :: mrdx, mrdy, ub, vb, uw, vw
5222   REAL :: ubd, vbd, uwd, vwd
5223   REAL, DIMENSION(its:ite, kts:kte) :: vflux
5224   REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
5225   INTEGER :: horz_order, vert_order
5226   REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
5227   REAL, DIMENSION(its:ite+1, kts:kte) :: fqxd
5228   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
5229   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
5230   LOGICAL :: degrade_xs, degrade_ys
5231   LOGICAL :: degrade_xe, degrade_ye
5232   INTEGER :: jp1, jp0, jtmp
5233 ! definition of flux operators, 3rd, 4th, 5th or 6th order
5234   REAL :: flux3, flux4, flux5, flux6
5235   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
5236   REAL :: veld
5237   LOGICAL :: specified
5238
5239
5240
5241
5242   specified = .false.
5243   IF (config_flags%specified .OR. config_flags%nested) specified = &
5244 &      .true.
5245   IF (kte .GT. kde - 1) THEN
5246     ktf = kde - 1
5247   ELSE
5248     ktf = kte
5249   END IF
5250   horz_order = config_flags%h_sca_adv_order
5251   vert_order = config_flags%v_sca_adv_order
5252 !  here is the choice of flux operators
5253 !  begin with horizontal flux divergence
5254   IF (horz_order .EQ. 6) THEN
5255 !  determine boundary mods for flux operators
5256 !  We degrade the flux operators from 3rd/4th order
5257 !   to second order one gridpoint in from the boundaries for
5258 !   all boundary conditions except periodic and symmetry - these
5259 !   conditions have boundary zone data fill for correct application
5260 !   of the higher order flux stencils
5261     degrade_xs = .true.
5262     degrade_xe = .true.
5263     degrade_ys = .true.
5264     degrade_ye = .true.
5265     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
5266 &        its .GT. ids + 3) degrade_xs = .false.
5267     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
5268 &        ite .LT. ide - 3) degrade_xe = .false.
5269     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
5270 &        jts .GT. jds + 3) degrade_ys = .false.
5271     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
5272 &        jte .LT. jde - 4) degrade_ye = .false.
5273 !--------------- y - advection first
5274     i_start = its
5275     IF (ite .GT. ide - 1) THEN
5276       i_end = ide - 1
5277     ELSE
5278       i_end = ite
5279     END IF
5280     j_start = jts
5281     IF (jte .GT. jde - 1) THEN
5282       j_end = jde - 1
5283     ELSE
5284       j_end = jte
5285     END IF
5286 !  higher order flux has a 5 or 7 point stencil, so compute
5287 !  bounds so we can switch to second order flux close to the boundary
5288     j_start_f = j_start
5289     j_end_f = j_end + 1
5290     IF (degrade_ys) THEN
5291       IF (jts .LT. jds + 1) THEN
5292         j_start = jds + 1
5293       ELSE
5294         j_start = jts
5295       END IF
5296       j_start_f = jds + 3
5297     END IF
5298     IF (degrade_ye) THEN
5299       IF (jte .GT. jde - 2) THEN
5300         j_end = jde - 2
5301       ELSE
5302         j_end = jte
5303       END IF
5304       j_end_f = jde - 3
5305     END IF
5306     IF (config_flags%polar) THEN
5307       IF (jte .GT. jde - 1) THEN
5308         j_end = jde - 1
5309       ELSE
5310         j_end = jte
5311       END IF
5312     END IF
5313 !  compute fluxes, 5th or 6th order
5314     jp1 = 2
5315     jp0 = 1
5316     fqyd = 0.0
5317 j_loop_y_flux_6:DO j=j_start,j_end+1
5318       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
5319         DO k=kts+1,ktf
5320           DO i=i_start,i_end
5321             veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
5322             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
5323             fqyd(i, k, jp1) = veld*(37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(&
5324 &              i, k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0&
5325 &              + vel*(37.*(wd(i, k, j)+wd(i, k, j-1))-8.*(wd(i, k, j+1)+&
5326 &              wd(i, k, j-2))+wd(i, k, j+2)+wd(i, k, j-3))/60.0
5327             fqy(i, k, jp1) = vel*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i&
5328 &              , k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0)
5329           END DO
5330         END DO
5331         k = ktf + 1
5332         DO i=i_start,i_end
5333           veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
5334           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
5335           fqyd(i, k, jp1) = veld*(37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i&
5336 &            , k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0 + &
5337 &            vel*(37.*(wd(i, k, j)+wd(i, k, j-1))-8.*(wd(i, k, j+1)+wd(i&
5338 &            , k, j-2))+wd(i, k, j+2)+wd(i, k, j-3))/60.0
5339           fqy(i, k, jp1) = vel*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, &
5340 &            k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0)
5341         END DO
5342       ELSE IF (j .EQ. jds + 1) THEN
5343 ! 2nd order flux next to south boundary
5344         DO k=kts+1,ktf
5345           DO i=i_start,i_end
5346             fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
5347 &              1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
5348 &              )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
5349             fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
5350 &              ))*(w(i, k, j)+w(i, k, j-1))
5351           END DO
5352         END DO
5353         k = ktf + 1
5354         DO i=i_start,i_end
5355           fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
5356 &            rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
5357 &            i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
5358 &            )))
5359           fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
5360 &            i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
5361         END DO
5362       ELSE IF (j .EQ. jds + 2) THEN
5363 ! third of 4th order flux 2 in from south boundary
5364         DO k=kts+1,ktf
5365           DO i=i_start,i_end
5366             veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
5367             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
5368             fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
5369 &              , j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k&
5370 &              , j-1))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
5371             fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
5372 &              , j+1)+w(i, k, j-2)))/12.0)
5373           END DO
5374         END DO
5375         k = ktf + 1
5376         DO i=i_start,i_end
5377           veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
5378           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
5379           fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, &
5380 &            j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k, j-1&
5381 &            ))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
5382           fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
5383 &            +1)+w(i, k, j-2)))/12.0)
5384         END DO
5385       ELSE IF (j .EQ. jde - 1) THEN
5386 ! 2nd order flux next to north boundary
5387         DO k=kts+1,ktf
5388           DO i=i_start,i_end
5389             fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
5390 &              1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
5391 &              )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
5392             fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
5393 &              ))*(w(i, k, j)+w(i, k, j-1))
5394           END DO
5395         END DO
5396         k = ktf + 1
5397         DO i=i_start,i_end
5398           fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
5399 &            rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
5400 &            i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
5401 &            )))
5402           fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
5403 &            i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
5404         END DO
5405       ELSE IF (j .EQ. jde - 2) THEN
5406 ! 3rd or 4th order flux 2 in from north boundary
5407         DO k=kts+1,ktf
5408           DO i=i_start,i_end
5409             veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
5410             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
5411             fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
5412 &              , j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k&
5413 &              , j-1))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
5414             fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
5415 &              , j+1)+w(i, k, j-2)))/12.0)
5416           END DO
5417         END DO
5418         k = ktf + 1
5419         DO i=i_start,i_end
5420           veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
5421           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
5422           fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, &
5423 &            j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k, j-1&
5424 &            ))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
5425           fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
5426 &            +1)+w(i, k, j-2)))/12.0)
5427         END DO
5428       END IF
5429 !  y flux-divergence into tendency
5430 ! Comments for polar boundary conditions
5431 ! Same process as for advect_u - tendencies run from jds to jde-1
5432 ! (latitudes are as for u grid, longitudes are displaced)
5433 ! Therefore: flow is only from one side for points next to poles
5434       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
5435         DO k=kts,ktf
5436           DO i=i_start,i_end
5437 ! see ADT eqn 46 dividing by my, 2nd term RHS
5438             mrdy = msftx(i, j-1)*rdy
5439             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
5440 &              , jp1)
5441             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
5442 &              jp1)
5443           END DO
5444         END DO
5445       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
5446         DO k=kts,ktf
5447           DO i=i_start,i_end
5448 ! see ADT eqn 46 dividing by my, 2nd term RHS
5449             mrdy = msftx(i, j-1)*rdy
5450             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
5451 &              , jp0)
5452             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
5453 &              jp0)
5454           END DO
5455         END DO
5456       ELSE IF (j .GT. j_start) THEN
5457 ! normal code
5458         DO k=kts+1,ktf+1
5459           DO i=i_start,i_end
5460 ! see ADT eqn 46 dividing by my, 2nd term RHS
5461             mrdy = msftx(i, j-1)*rdy
5462             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
5463 &              k, jp1)-fqyd(i, k, jp0))
5464             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
5465 &              jp1)-fqy(i, k, jp0))
5466           END DO
5467         END DO
5468       END IF
5469       jtmp = jp1
5470       jp1 = jp0
5471       jp0 = jtmp
5472     END DO j_loop_y_flux_6
5473 !  next, x - flux divergence
5474     i_start = its
5475     IF (ite .GT. ide - 1) THEN
5476       i_end = ide - 1
5477     ELSE
5478       i_end = ite
5479     END IF
5480     j_start = jts
5481     IF (jte .GT. jde - 1) THEN
5482       j_end = jde - 1
5483     ELSE
5484       j_end = jte
5485     END IF
5486 !  higher order flux has a 5 or 7 point stencil, so compute
5487 !  bounds so we can switch to second order flux close to the boundary
5488     i_start_f = i_start
5489     i_end_f = i_end + 1
5490     IF (degrade_xs) THEN
5491       IF (ids + 1 .LT. its) THEN
5492         i_start = its
5493       ELSE
5494         i_start = ids + 1
5495       END IF
5496       IF (i_start + 2 .GT. ids + 3) THEN
5497         i_start_f = ids + 3
5498       ELSE
5499         i_start_f = i_start + 2
5500       END IF
5501     END IF
5502     IF (degrade_xe) THEN
5503       IF (ide - 2 .GT. ite) THEN
5504         i_end = ite
5505       ELSE
5506         i_end = ide - 2
5507       END IF
5508       i_end_f = ide - 3
5509       fqxd = 0.0
5510     ELSE
5511       fqxd = 0.0
5512     END IF
5513 !  compute fluxes
5514     DO j=j_start,j_end
5515 !  5th or 6th order flux
5516       DO k=kts+1,ktf
5517         DO i=i_start_f,i_end_f
5518           veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
5519           vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
5520           fqxd(i, k) = veld*(37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k&
5521 &            , j)+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0 + vel*(&
5522 &            37.*(wd(i, k, j)+wd(i-1, k, j))-8.*(wd(i+1, k, j)+wd(i-2, k&
5523 &            , j))+wd(i+2, k, j)+wd(i-3, k, j))/60.0
5524           fqx(i, k) = vel*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, &
5525 &            j)+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0)
5526         END DO
5527       END DO
5528       k = ktf + 1
5529       DO i=i_start_f,i_end_f
5530         veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
5531         vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
5532         fqxd(i, k) = veld*(37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j&
5533 &          )+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0 + vel*(37.*(&
5534 &          wd(i, k, j)+wd(i-1, k, j))-8.*(wd(i+1, k, j)+wd(i-2, k, j))+wd&
5535 &          (i+2, k, j)+wd(i-3, k, j))/60.0
5536         fqx(i, k) = vel*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)&
5537 &          +w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0)
5538       END DO
5539 !  lower order fluxes close to boundaries (if not periodic or symmetric)
5540       IF (degrade_xs) THEN
5541         DO i=i_start,i_start_f-1
5542           IF (i .EQ. ids + 1) THEN
5543 ! second order
5544             DO k=kts+1,ktf
5545               fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, &
5546 &                j))*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)&
5547 &                *ru(i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
5548               fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
5549 &                (w(i, k, j)+w(i-1, k, j))
5550             END DO
5551             k = ktf + 1
5552             fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud&
5553 &              (i, k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i&
5554 &              , k-1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, &
5555 &              j)))
5556             fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, &
5557 &              k-2, j))*(w(i, k, j)+w(i-1, k, j))
5558           END IF
5559           IF (i .EQ. ids + 2) THEN
5560 ! third order
5561             DO k=kts+1,ktf
5562               veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
5563               vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
5564               fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k&
5565 &                , j)+w(i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, &
5566 &                k, j))-wd(i+1, k, j)-wd(i-2, k, j))/12.0
5567               fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
5568 &                j)+w(i-2, k, j)))/12.0)
5569             END DO
5570             k = ktf + 1
5571             veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j&
5572 &              )
5573             vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
5574             fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j&
5575 &              )+w(i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, k, j)&
5576 &              )-wd(i+1, k, j)-wd(i-2, k, j))/12.0
5577             fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
5578 &              +w(i-2, k, j)))/12.0)
5579           END IF
5580         END DO
5581       END IF
5582       IF (degrade_xe) THEN
5583         DO i=i_end_f+1,i_end+1
5584           IF (i .EQ. ide - 1) THEN
5585 ! second order flux next to the boundary
5586             DO k=kts+1,ktf
5587               fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, &
5588 &                j))*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)&
5589 &                *ru(i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
5590               fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
5591 &                (w(i, k, j)+w(i-1, k, j))
5592             END DO
5593             k = ktf + 1
5594             fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud&
5595 &              (i, k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i&
5596 &              , k-1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, &
5597 &              j)))
5598             fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, &
5599 &              k-2, j))*(w(i, k, j)+w(i-1, k, j))
5600           END IF
5601           IF (i .EQ. ide - 2) THEN
5602 ! third order flux one in from the boundary
5603             DO k=kts+1,ktf
5604               veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
5605               vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
5606               fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k&
5607 &                , j)+w(i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, &
5608 &                k, j))-wd(i+1, k, j)-wd(i-2, k, j))/12.0
5609               fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
5610 &                j)+w(i-2, k, j)))/12.0)
5611             END DO
5612             k = ktf + 1
5613             veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j&
5614 &              )
5615             vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
5616             fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j&
5617 &              )+w(i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, k, j)&
5618 &              )-wd(i+1, k, j)-wd(i-2, k, j))/12.0
5619             fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
5620 &              +w(i-2, k, j)))/12.0)
5621           END IF
5622         END DO
5623       END IF
5624 !  x flux-divergence into tendency
5625       DO k=kts+1,ktf+1
5626         DO i=i_start,i_end
5627 ! see ADT eqn 46 dividing by my, 1st term RHS
5628           mrdx = msftx(i, j)*rdx
5629           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
5630 &            fqxd(i, k))
5631           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
5632 &            i, k))
5633         END DO
5634       END DO
5635     END DO
5636   ELSE IF (horz_order .EQ. 5) THEN
5637 !  determine boundary mods for flux operators
5638 !  We degrade the flux operators from 3rd/4th order
5639 !   to second order one gridpoint in from the boundaries for
5640 !   all boundary conditions except periodic and symmetry - these
5641 !   conditions have boundary zone data fill for correct application
5642 !   of the higher order flux stencils
5643     degrade_xs = .true.
5644     degrade_xe = .true.
5645     degrade_ys = .true.
5646     degrade_ye = .true.
5647     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
5648 &        its .GT. ids + 3) degrade_xs = .false.
5649     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
5650 &        ite .LT. ide - 3) degrade_xe = .false.
5651     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
5652 &        jts .GT. jds + 3) degrade_ys = .false.
5653     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
5654 &        jte .LT. jde - 4) degrade_ye = .false.
5655 !--------------- y - advection first
5656     i_start = its
5657     IF (ite .GT. ide - 1) THEN
5658       i_end = ide - 1
5659     ELSE
5660       i_end = ite
5661     END IF
5662     j_start = jts
5663     IF (jte .GT. jde - 1) THEN
5664       j_end = jde - 1
5665     ELSE
5666       j_end = jte
5667     END IF
5668 !  higher order flux has a 5 or 7 point stencil, so compute
5669 !  bounds so we can switch to second order flux close to the boundary
5670     j_start_f = j_start
5671     j_end_f = j_end + 1
5672     IF (degrade_ys) THEN
5673       IF (jts .LT. jds + 1) THEN
5674         j_start = jds + 1
5675       ELSE
5676         j_start = jts
5677       END IF
5678       j_start_f = jds + 3
5679     END IF
5680     IF (degrade_ye) THEN
5681       IF (jte .GT. jde - 2) THEN
5682         j_end = jde - 2
5683       ELSE
5684         j_end = jte
5685       END IF
5686       j_end_f = jde - 3
5687     END IF
5688     IF (config_flags%polar) THEN
5689       IF (jte .GT. jde - 1) THEN
5690         j_end = jde - 1
5691       ELSE
5692         j_end = jte
5693       END IF
5694     END IF
5695 !  compute fluxes, 5th or 6th order
5696     jp1 = 2
5697     jp0 = 1
5698     fqyd = 0.0
5699 j_loop_y_flux_5:DO j=j_start,j_end+1
5700       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
5701         DO k=kts+1,ktf
5702           DO i=i_start,i_end
5703             veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
5704             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
5705             fqyd(i, k, jp1) = veld*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w&
5706 &              (i, k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/&
5707 &              60.0-SIGN(1, time_step)*SIGN(1., vel)*(w(i, k, j+2)-w(i, k&
5708 &              , j-3)-5.*(w(i, k, j+1)-w(i, k, j-2))+10.*(w(i, k, j)-w(i&
5709 &              , k, j-1)))/60.0) + vel*((37.*(wd(i, k, j)+wd(i, k, j-1))-&
5710 &              8.*(wd(i, k, j+1)+wd(i, k, j-2))+wd(i, k, j+2)+wd(i, k, j-&
5711 &              3))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(wd(i, k, j+2)-&
5712 &              wd(i, k, j-3)-5.*(wd(i, k, j+1)-wd(i, k, j-2))+10.*(wd(i, &
5713 &              k, j)-wd(i, k, j-1)))/60.0)
5714             fqy(i, k, jp1) = vel*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i&
5715 &              , k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0-&
5716 &              SIGN(1, time_step)*SIGN(1., vel)*(w(i, k, j+2)-w(i, k, j-3&
5717 &              )-5.*(w(i, k, j+1)-w(i, k, j-2))+10.*(w(i, k, j)-w(i, k, j&
5718 &              -1)))/60.0)
5719           END DO
5720         END DO
5721         k = ktf + 1
5722         DO i=i_start,i_end
5723           veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
5724           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
5725           fqyd(i, k, jp1) = veld*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i&
5726 &            , k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0-&
5727 &            SIGN(1, time_step)*SIGN(1., vel)*(w(i, k, j+2)-w(i, k, j-3)-&
5728 &            5.*(w(i, k, j+1)-w(i, k, j-2))+10.*(w(i, k, j)-w(i, k, j-1))&
5729 &            )/60.0) + vel*((37.*(wd(i, k, j)+wd(i, k, j-1))-8.*(wd(i, k&
5730 &            , j+1)+wd(i, k, j-2))+wd(i, k, j+2)+wd(i, k, j-3))/60.0-SIGN&
5731 &            (1, time_step)*SIGN(1., vel)*(wd(i, k, j+2)-wd(i, k, j-3)-5.&
5732 &            *(wd(i, k, j+1)-wd(i, k, j-2))+10.*(wd(i, k, j)-wd(i, k, j-1&
5733 &            )))/60.0)
5734           fqy(i, k, jp1) = vel*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, &
5735 &            k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0-SIGN&
5736 &            (1, time_step)*SIGN(1., vel)*(w(i, k, j+2)-w(i, k, j-3)-5.*(&
5737 &            w(i, k, j+1)-w(i, k, j-2))+10.*(w(i, k, j)-w(i, k, j-1)))/&
5738 &            60.0)
5739         END DO
5740       ELSE IF (j .EQ. jds + 1) THEN
5741 ! 2nd order flux next to south boundary
5742         DO k=kts+1,ktf
5743           DO i=i_start,i_end
5744             fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
5745 &              1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
5746 &              )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
5747             fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
5748 &              ))*(w(i, k, j)+w(i, k, j-1))
5749           END DO
5750         END DO
5751         k = ktf + 1
5752         DO i=i_start,i_end
5753           fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
5754 &            rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
5755 &            i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
5756 &            )))
5757           fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
5758 &            i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
5759         END DO
5760       ELSE IF (j .EQ. jds + 2) THEN
5761 ! third of 4th order flux 2 in from south boundary
5762         DO k=kts+1,ktf
5763           DO i=i_start,i_end
5764             veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
5765             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
5766             fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, &
5767 &              k, j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
5768 &              vel)*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1&
5769 &              )))/12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, &
5770 &              j+1)-wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
5771 &              (wd(i, k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)&
5772 &              ))/12.0)
5773             fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
5774 &              , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
5775 &              )*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))&
5776 &              /12.0)
5777           END DO
5778         END DO
5779         k = ktf + 1
5780         DO i=i_start,i_end
5781           veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
5782           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
5783           fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
5784 &            , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
5785 &            (w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/&
5786 &            12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-&
5787 &            wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, &
5788 &            k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
5789           fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
5790 &            +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(&
5791 &            i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
5792         END DO
5793       ELSE IF (j .EQ. jde - 1) THEN
5794 ! 2nd order flux next to north boundary
5795         DO k=kts+1,ktf
5796           DO i=i_start,i_end
5797             fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
5798 &              1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
5799 &              )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
5800             fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
5801 &              ))*(w(i, k, j)+w(i, k, j-1))
5802           END DO
5803         END DO
5804         k = ktf + 1
5805         DO i=i_start,i_end
5806           fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
5807 &            rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
5808 &            i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
5809 &            )))
5810           fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
5811 &            i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
5812         END DO
5813       ELSE IF (j .EQ. jde - 2) THEN
5814 ! 3rd or 4th order flux 2 in from north boundary
5815         DO k=kts+1,ktf
5816           DO i=i_start,i_end
5817             veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
5818             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
5819             fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, &
5820 &              k, j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
5821 &              vel)*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1&
5822 &              )))/12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, &
5823 &              j+1)-wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
5824 &              (wd(i, k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)&
5825 &              ))/12.0)
5826             fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
5827 &              , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
5828 &              )*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))&
5829 &              /12.0)
5830           END DO
5831         END DO
5832         k = ktf + 1
5833         DO i=i_start,i_end
5834           veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
5835           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
5836           fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
5837 &            , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
5838 &            (w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/&
5839 &            12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-&
5840 &            wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, &
5841 &            k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
5842           fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
5843 &            +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(&
5844 &            i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
5845         END DO
5846       END IF
5847 !  y flux-divergence into tendency
5848 ! Comments for polar boundary conditions
5849 ! Same process as for advect_u - tendencies run from jds to jde-1
5850 ! (latitudes are as for u grid, longitudes are displaced)
5851 ! Therefore: flow is only from one side for points next to poles
5852       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
5853         DO k=kts,ktf
5854           DO i=i_start,i_end
5855 ! see ADT eqn 46 dividing by my, 2nd term RHS
5856             mrdy = msftx(i, j-1)*rdy
5857             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
5858 &              , jp1)
5859             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
5860 &              jp1)
5861           END DO
5862         END DO
5863       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
5864         DO k=kts,ktf
5865           DO i=i_start,i_end
5866 ! see ADT eqn 46 dividing by my, 2nd term RHS
5867             mrdy = msftx(i, j-1)*rdy
5868             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
5869 &              , jp0)
5870             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
5871 &              jp0)
5872           END DO
5873         END DO
5874       ELSE IF (j .GT. j_start) THEN
5875 ! normal code
5876         DO k=kts+1,ktf+1
5877           DO i=i_start,i_end
5878 ! see ADT eqn 46 dividing by my, 2nd term RHS
5879             mrdy = msftx(i, j-1)*rdy
5880             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
5881 &              k, jp1)-fqyd(i, k, jp0))
5882             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
5883 &              jp1)-fqy(i, k, jp0))
5884           END DO
5885         END DO
5886       END IF
5887       jtmp = jp1
5888       jp1 = jp0
5889       jp0 = jtmp
5890     END DO j_loop_y_flux_5
5891 !  next, x - flux divergence
5892     i_start = its
5893     IF (ite .GT. ide - 1) THEN
5894       i_end = ide - 1
5895     ELSE
5896       i_end = ite
5897     END IF
5898     j_start = jts
5899     IF (jte .GT. jde - 1) THEN
5900       j_end = jde - 1
5901     ELSE
5902       j_end = jte
5903     END IF
5904 !  higher order flux has a 5 or 7 point stencil, so compute
5905 !  bounds so we can switch to second order flux close to the boundary
5906     i_start_f = i_start
5907     i_end_f = i_end + 1
5908     IF (degrade_xs) THEN
5909       IF (ids + 1 .LT. its) THEN
5910         i_start = its
5911       ELSE
5912         i_start = ids + 1
5913       END IF
5914       IF (i_start + 2 .GT. ids + 3) THEN
5915         i_start_f = ids + 3
5916       ELSE
5917         i_start_f = i_start + 2
5918       END IF
5919     END IF
5920     IF (degrade_xe) THEN
5921       IF (ide - 2 .GT. ite) THEN
5922         i_end = ite
5923       ELSE
5924         i_end = ide - 2
5925       END IF
5926       i_end_f = ide - 3
5927       fqxd = 0.0
5928     ELSE
5929       fqxd = 0.0
5930     END IF
5931 !  compute fluxes
5932     DO j=j_start,j_end
5933 !  5th or 6th order flux
5934       DO k=kts+1,ktf
5935         DO i=i_start_f,i_end_f
5936           veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
5937           vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
5938           fqxd(i, k) = veld*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k&
5939 &            , j)+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0-SIGN(1&
5940 &            , time_step)*SIGN(1., vel)*(w(i+2, k, j)-w(i-3, k, j)-5.*(w(&
5941 &            i+1, k, j)-w(i-2, k, j))+10.*(w(i, k, j)-w(i-1, k, j)))/60.0&
5942 &            ) + vel*((37.*(wd(i, k, j)+wd(i-1, k, j))-8.*(wd(i+1, k, j)+&
5943 &            wd(i-2, k, j))+wd(i+2, k, j)+wd(i-3, k, j))/60.0-SIGN(1, &
5944 &            time_step)*SIGN(1., vel)*(wd(i+2, k, j)-wd(i-3, k, j)-5.*(wd&
5945 &            (i+1, k, j)-wd(i-2, k, j))+10.*(wd(i, k, j)-wd(i-1, k, j)))/&
5946 &            60.0)
5947           fqx(i, k) = vel*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, &
5948 &            j)+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0-SIGN(1, &
5949 &            time_step)*SIGN(1., vel)*(w(i+2, k, j)-w(i-3, k, j)-5.*(w(i+&
5950 &            1, k, j)-w(i-2, k, j))+10.*(w(i, k, j)-w(i-1, k, j)))/60.0)
5951         END DO
5952       END DO
5953       k = ktf + 1
5954       DO i=i_start_f,i_end_f
5955         veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
5956         vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
5957         fqxd(i, k) = veld*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, &
5958 &          j)+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0-SIGN(1, &
5959 &          time_step)*SIGN(1., vel)*(w(i+2, k, j)-w(i-3, k, j)-5.*(w(i+1&
5960 &          , k, j)-w(i-2, k, j))+10.*(w(i, k, j)-w(i-1, k, j)))/60.0) + &
5961 &          vel*((37.*(wd(i, k, j)+wd(i-1, k, j))-8.*(wd(i+1, k, j)+wd(i-2&
5962 &          , k, j))+wd(i+2, k, j)+wd(i-3, k, j))/60.0-SIGN(1, time_step)*&
5963 &          SIGN(1., vel)*(wd(i+2, k, j)-wd(i-3, k, j)-5.*(wd(i+1, k, j)-&
5964 &          wd(i-2, k, j))+10.*(wd(i, k, j)-wd(i-1, k, j)))/60.0)
5965         fqx(i, k) = vel*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)&
5966 &          +w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0-SIGN(1, &
5967 &          time_step)*SIGN(1., vel)*(w(i+2, k, j)-w(i-3, k, j)-5.*(w(i+1&
5968 &          , k, j)-w(i-2, k, j))+10.*(w(i, k, j)-w(i-1, k, j)))/60.0)
5969       END DO
5970 !  lower order fluxes close to boundaries (if not periodic or symmetric)
5971       IF (degrade_xs) THEN
5972         DO i=i_start,i_start_f-1
5973           IF (i .EQ. ids + 1) THEN
5974 ! second order
5975             DO k=kts+1,ktf
5976               fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, &
5977 &                j))*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)&
5978 &                *ru(i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
5979               fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
5980 &                (w(i, k, j)+w(i-1, k, j))
5981             END DO
5982             k = ktf + 1
5983             fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud&
5984 &              (i, k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i&
5985 &              , k-1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, &
5986 &              j)))
5987             fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, &
5988 &              k-2, j))*(w(i, k, j)+w(i-1, k, j))
5989           END IF
5990           IF (i .EQ. ids + 2) THEN
5991 ! third order
5992             DO k=kts+1,ktf
5993               veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
5994               vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
5995               fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k&
5996 &                , j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
5997 &                )*(w(i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)&
5998 &                ))/12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, &
5999 &                k, j)-wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
6000 &                vel)*(wd(i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1&
6001 &                , k, j)))/12.0)
6002               fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
6003 &                j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
6004 &                (w(i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))&
6005 &                /12.0)
6006             END DO
6007             k = ktf + 1
6008             veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j&
6009 &              )
6010             vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
6011             fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
6012 &              j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w&
6013 &              (i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/&
6014 &              12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)&
6015 &              -wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(&
6016 &              i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/&
6017 &              12.0)
6018             fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
6019 &              +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
6020 &              +1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
6021           END IF
6022         END DO
6023       END IF
6024       IF (degrade_xe) THEN
6025         DO i=i_end_f+1,i_end+1
6026           IF (i .EQ. ide - 1) THEN
6027 ! second order flux next to the boundary
6028             DO k=kts+1,ktf
6029               fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, &
6030 &                j))*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)&
6031 &                *ru(i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
6032               fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
6033 &                (w(i, k, j)+w(i-1, k, j))
6034             END DO
6035             k = ktf + 1
6036             fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud&
6037 &              (i, k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i&
6038 &              , k-1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, &
6039 &              j)))
6040             fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, &
6041 &              k-2, j))*(w(i, k, j)+w(i-1, k, j))
6042           END IF
6043           IF (i .EQ. ide - 2) THEN
6044 ! third order flux one in from the boundary
6045             DO k=kts+1,ktf
6046               veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
6047               vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
6048               fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k&
6049 &                , j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
6050 &                )*(w(i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)&
6051 &                ))/12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, &
6052 &                k, j)-wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
6053 &                vel)*(wd(i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1&
6054 &                , k, j)))/12.0)
6055               fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
6056 &                j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
6057 &                (w(i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))&
6058 &                /12.0)
6059             END DO
6060             k = ktf + 1
6061             veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j&
6062 &              )
6063             vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
6064             fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
6065 &              j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w&
6066 &              (i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/&
6067 &              12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)&
6068 &              -wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(&
6069 &              i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/&
6070 &              12.0)
6071             fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
6072 &              +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
6073 &              +1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
6074           END IF
6075         END DO
6076       END IF
6077 !  x flux-divergence into tendency
6078       DO k=kts+1,ktf+1
6079         DO i=i_start,i_end
6080 ! see ADT eqn 46 dividing by my, 1st term RHS
6081           mrdx = msftx(i, j)*rdx
6082           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
6083 &            fqxd(i, k))
6084           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
6085 &            i, k))
6086         END DO
6087       END DO
6088     END DO
6089   ELSE IF (horz_order .EQ. 4) THEN
6090     degrade_xs = .true.
6091     degrade_xe = .true.
6092     degrade_ys = .true.
6093     degrade_ye = .true.
6094     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
6095 &        its .GT. ids + 2) degrade_xs = .false.
6096     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
6097 &        ite .LT. ide - 2) degrade_xe = .false.
6098     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
6099 &        jts .GT. jds + 2) degrade_ys = .false.
6100     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
6101 &        jte .LT. jde - 3) degrade_ye = .false.
6102     IF (kte .GT. kde - 1) THEN
6103       ktf = kde - 1
6104     ELSE
6105       ktf = kte
6106     END IF
6107     i_start = its
6108     IF (ite .GT. ide - 1) THEN
6109       i_end = ide - 1
6110     ELSE
6111       i_end = ite
6112     END IF
6113     j_start = jts
6114     IF (jte .GT. jde - 1) THEN
6115       j_end = jde - 1
6116     ELSE
6117       j_end = jte
6118     END IF
6119 !  3rd or 4th order flux has a 5 point stencil, so compute
6120 !  bounds so we can switch to second order flux close to the boundary
6121     i_start_f = i_start
6122     i_end_f = i_end + 1
6123     IF (degrade_xs) THEN
6124       i_start = ids + 1
6125       i_start_f = i_start + 1
6126     END IF
6127     IF (degrade_xe) THEN
6128       i_end = ide - 2
6129       i_end_f = ide - 2
6130       fqxd = 0.0
6131     ELSE
6132       fqxd = 0.0
6133     END IF
6134 !  compute fluxes
6135     DO j=j_start,j_end
6136       DO k=kts+1,ktf
6137         DO i=i_start_f,i_end_f
6138           veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
6139           vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
6140           fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+&
6141 &            w(i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, k, j))-wd&
6142 &            (i+1, k, j)-wd(i-2, k, j))/12.0
6143           fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w&
6144 &            (i-2, k, j)))/12.0)
6145         END DO
6146       END DO
6147       k = ktf + 1
6148       DO i=i_start_f,i_end_f
6149         veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
6150         vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
6151         fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w(&
6152 &          i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1&
6153 &          , k, j)-wd(i-2, k, j))/12.0
6154         fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w(i&
6155 &          -2, k, j)))/12.0)
6156       END DO
6157 !  second order flux close to boundaries (if not periodic or symmetric)
6158       IF (degrade_xs) THEN
6159         DO k=kts+1,ktf
6160           fqxd(i_start, k) = 0.5*((fzm(k)*rud(i_start, k, j)+fzp(k)*rud(&
6161 &            i_start, k-1, j))*(w(i_start, k, j)+w(i_start-1, k, j))+(fzm&
6162 &            (k)*ru(i_start, k, j)+fzp(k)*ru(i_start, k-1, j))*(wd(&
6163 &            i_start, k, j)+wd(i_start-1, k, j)))
6164           fqx(i_start, k) = 0.5*(fzm(k)*ru(i_start, k, j)+fzp(k)*ru(&
6165 &            i_start, k-1, j))*(w(i_start, k, j)+w(i_start-1, k, j))
6166         END DO
6167         k = ktf + 1
6168         fqxd(i_start, k) = 0.5*(((2.-fzm(k-1))*rud(i_start, k-1, j)-fzp(&
6169 &          k-1)*rud(i_start, k-2, j))*(w(i_start, k, j)+w(i_start-1, k, j&
6170 &          ))+((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1)*ru(i_start, k-2&
6171 &          , j))*(wd(i_start, k, j)+wd(i_start-1, k, j)))
6172         fqx(i_start, k) = 0.5*((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1&
6173 &          )*ru(i_start, k-2, j))*(w(i_start, k, j)+w(i_start-1, k, j))
6174       END IF
6175       IF (degrade_xe) THEN
6176         DO k=kts+1,ktf
6177           fqxd(i_end+1, k) = 0.5*((fzm(k)*rud(i_end+1, k, j)+fzp(k)*rud(&
6178 &            i_end+1, k-1, j))*(w(i_end+1, k, j)+w(i_end, k, j))+(fzm(k)*&
6179 &            ru(i_end+1, k, j)+fzp(k)*ru(i_end+1, k-1, j))*(wd(i_end+1, k&
6180 &            , j)+wd(i_end, k, j)))
6181           fqx(i_end+1, k) = 0.5*(fzm(k)*ru(i_end+1, k, j)+fzp(k)*ru(&
6182 &            i_end+1, k-1, j))*(w(i_end+1, k, j)+w(i_end, k, j))
6183         END DO
6184         k = ktf + 1
6185         fqxd(i_end+1, k) = 0.5*(((2.-fzm(k-1))*rud(i_end+1, k-1, j)-fzp(&
6186 &          k-1)*rud(i_end+1, k-2, j))*(w(i_end+1, k, j)+w(i_end, k, j))+(&
6187 &          (2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1)*ru(i_end+1, k-2, j)&
6188 &          )*(wd(i_end+1, k, j)+wd(i_end, k, j)))
6189         fqx(i_end+1, k) = 0.5*((2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1&
6190 &          )*ru(i_end+1, k-2, j))*(w(i_end+1, k, j)+w(i_end, k, j))
6191       END IF
6192 !  x flux-divergence into tendency
6193       DO k=kts+1,ktf+1
6194         DO i=i_start,i_end
6195 ! see ADT eqn 46 dividing by my, 1st term RHS
6196           mrdx = msftx(i, j)*rdx
6197           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
6198 &            fqxd(i, k))
6199           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
6200 &            i, k))
6201         END DO
6202       END DO
6203     END DO
6204 !  next -> y flux divergence calculation
6205     i_start = its
6206     IF (ite .GT. ide - 1) THEN
6207       i_end = ide - 1
6208     ELSE
6209       i_end = ite
6210     END IF
6211     j_start = jts
6212     IF (jte .GT. jde - 1) THEN
6213       j_end = jde - 1
6214     ELSE
6215       j_end = jte
6216     END IF
6217 !  3rd or 4th order flux has a 5 point stencil, so compute
6218 !  bounds so we can switch to second order flux close to the boundary
6219     j_start_f = j_start
6220     j_end_f = j_end + 1
6221     IF (degrade_ys) THEN
6222       j_start = jds + 1
6223       j_start_f = j_start + 1
6224     END IF
6225     IF (degrade_ye) THEN
6226       j_end = jde - 2
6227       j_end_f = jde - 2
6228     END IF
6229     IF (config_flags%polar) THEN
6230       IF (jte .GT. jde - 1) THEN
6231         j_end = jde - 1
6232       ELSE
6233         j_end = jte
6234       END IF
6235     END IF
6236     jp1 = 2
6237     jp0 = 1
6238     fqyd = 0.0
6239     DO j=j_start,j_end+1
6240       IF (j .LT. j_start_f .AND. degrade_ys) THEN
6241         DO k=kts+1,ktf
6242           DO i=i_start,i_end
6243             fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j_start)+fzp(k)*rvd&
6244 &              (i, k-1, j_start))*(w(i, k, j_start)+w(i, k, j_start-1))+(&
6245 &              fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, k-1, j_start))*(wd(i&
6246 &              , k, j_start)+wd(i, k, j_start-1)))
6247             fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, &
6248 &              k-1, j_start))*(w(i, k, j_start)+w(i, k, j_start-1))
6249           END DO
6250         END DO
6251         k = ktf + 1
6252         DO i=i_start,i_end
6253           fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j_start)-fzp&
6254 &            (k-1)*rvd(i, k-2, j_start))*(w(i, k, j_start)+w(i, k, &
6255 &            j_start-1))+((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-1)*rv(i&
6256 &            , k-2, j_start))*(wd(i, k, j_start)+wd(i, k, j_start-1)))
6257           fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-&
6258 &            1)*rv(i, k-2, j_start))*(w(i, k, j_start)+w(i, k, j_start-1)&
6259 &            )
6260         END DO
6261       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
6262         DO k=kts+1,ktf
6263           DO i=i_start,i_end
6264 ! Assumes j>j_end_f is ONLY j_end+1 ...
6265 !            fqy(i, k, jp1) =                             &
6266 !               0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1))     &
6267 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
6268             fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
6269 &              1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
6270 &              )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
6271             fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
6272 &              ))*(w(i, k, j)+w(i, k, j-1))
6273           END DO
6274         END DO
6275         k = ktf + 1
6276         DO i=i_start,i_end
6277 ! Assumes j>j_end_f is ONLY j_end+1 ...
6278 !            fqy(i, k, jp1) =                                         &
6279 !               0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1))     &
6280 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
6281           fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
6282 &            rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
6283 &            i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
6284 &            )))
6285           fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
6286 &            i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
6287         END DO
6288       ELSE
6289 !  3rd or 4th order flux
6290         DO k=kts+1,ktf
6291           DO i=i_start,i_end
6292             veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
6293             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
6294             fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
6295 &              , j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k&
6296 &              , j-1))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
6297             fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
6298 &              , j+1)+w(i, k, j-2)))/12.0)
6299           END DO
6300         END DO
6301         k = ktf + 1
6302         DO i=i_start,i_end
6303           veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
6304           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
6305           fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, &
6306 &            j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k, j-1&
6307 &            ))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
6308           fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
6309 &            +1)+w(i, k, j-2)))/12.0)
6310         END DO
6311       END IF
6312 !  y flux-divergence into tendency
6313 ! Comments for polar boundary conditions
6314 ! Same process as for advect_u - tendencies run from jds to jde-1
6315 ! (latitudes are as for u grid, longitudes are displaced)
6316 ! Therefore: flow is only from one side for points next to poles
6317       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
6318         DO k=kts,ktf
6319           DO i=i_start,i_end
6320 ! see ADT eqn 46 dividing by my, 2nd term RHS
6321             mrdy = msftx(i, j-1)*rdy
6322             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
6323 &              , jp1)
6324             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
6325 &              jp1)
6326           END DO
6327         END DO
6328       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
6329         DO k=kts,ktf
6330           DO i=i_start,i_end
6331 ! see ADT eqn 46 dividing by my, 2nd term RHS
6332             mrdy = msftx(i, j-1)*rdy
6333             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
6334 &              , jp0)
6335             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
6336 &              jp0)
6337           END DO
6338         END DO
6339       ELSE IF (j .GT. j_start) THEN
6340 ! normal code
6341         DO k=kts+1,ktf+1
6342           DO i=i_start,i_end
6343 ! see ADT eqn 46 dividing by my, 2nd term RHS
6344             mrdy = msftx(i, j-1)*rdy
6345             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
6346 &              k, jp1)-fqyd(i, k, jp0))
6347             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
6348 &              jp1)-fqy(i, k, jp0))
6349           END DO
6350         END DO
6351       END IF
6352       jtmp = jp1
6353       jp1 = jp0
6354       jp0 = jtmp
6355     END DO
6356   ELSE IF (horz_order .EQ. 3) THEN
6357     degrade_xs = .true.
6358     degrade_xe = .true.
6359     degrade_ys = .true.
6360     degrade_ye = .true.
6361     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
6362 &        its .GT. ids + 2) degrade_xs = .false.
6363     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
6364 &        ite .LT. ide - 2) degrade_xe = .false.
6365     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
6366 &        jts .GT. jds + 2) degrade_ys = .false.
6367     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
6368 &        jte .LT. jde - 3) degrade_ye = .false.
6369     IF (kte .GT. kde - 1) THEN
6370       ktf = kde - 1
6371     ELSE
6372       ktf = kte
6373     END IF
6374     i_start = its
6375     IF (ite .GT. ide - 1) THEN
6376       i_end = ide - 1
6377     ELSE
6378       i_end = ite
6379     END IF
6380     j_start = jts
6381     IF (jte .GT. jde - 1) THEN
6382       j_end = jde - 1
6383     ELSE
6384       j_end = jte
6385     END IF
6386 !  3rd or 4th order flux has a 5 point stencil, so compute
6387 !  bounds so we can switch to second order flux close to the boundary
6388     i_start_f = i_start
6389     i_end_f = i_end + 1
6390     IF (degrade_xs) THEN
6391       i_start = ids + 1
6392       i_start_f = i_start + 1
6393     END IF
6394     IF (degrade_xe) THEN
6395       i_end = ide - 2
6396       i_end_f = ide - 2
6397       fqxd = 0.0
6398     ELSE
6399       fqxd = 0.0
6400     END IF
6401 !  compute fluxes
6402     DO j=j_start,j_end
6403       DO k=kts+1,ktf
6404         DO i=i_start_f,i_end_f
6405           veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
6406           vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
6407           fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
6408 &            +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1&
6409 &            , k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0) + &
6410 &            vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)-wd(i-2, k&
6411 &            , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i+1, k, j)-&
6412 &            wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/12.0)
6413           fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w&
6414 &            (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1, &
6415 &            k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
6416         END DO
6417       END DO
6418       k = ktf + 1
6419       DO i=i_start_f,i_end_f
6420         veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
6421         vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
6422         fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w&
6423 &          (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1, k&
6424 &          , j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0) + vel*((&
6425 &          7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)-wd(i-2, k, j))/&
6426 &          12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i+1, k, j)-wd(i-2, k&
6427 &          , j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/12.0)
6428         fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w(i&
6429 &          -2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1, k, j&
6430 &          )-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
6431       END DO
6432 !  second order flux close to boundaries (if not periodic or symmetric)
6433       IF (degrade_xs) THEN
6434         DO k=kts+1,ktf
6435           fqxd(i_start, k) = 0.5*((fzm(k)*rud(i_start, k, j)+fzp(k)*rud(&
6436 &            i_start, k-1, j))*(w(i_start, k, j)+w(i_start-1, k, j))+(fzm&
6437 &            (k)*ru(i_start, k, j)+fzp(k)*ru(i_start, k-1, j))*(wd(&
6438 &            i_start, k, j)+wd(i_start-1, k, j)))
6439           fqx(i_start, k) = 0.5*(fzm(k)*ru(i_start, k, j)+fzp(k)*ru(&
6440 &            i_start, k-1, j))*(w(i_start, k, j)+w(i_start-1, k, j))
6441         END DO
6442         k = ktf + 1
6443         fqxd(i_start, k) = 0.5*(((2.-fzm(k-1))*rud(i_start, k-1, j)-fzp(&
6444 &          k-1)*rud(i_start, k-2, j))*(w(i_start, k, j)+w(i_start-1, k, j&
6445 &          ))+((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1)*ru(i_start, k-2&
6446 &          , j))*(wd(i_start, k, j)+wd(i_start-1, k, j)))
6447         fqx(i_start, k) = 0.5*((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1&
6448 &          )*ru(i_start, k-2, j))*(w(i_start, k, j)+w(i_start-1, k, j))
6449       END IF
6450       IF (degrade_xe) THEN
6451         DO k=kts+1,ktf
6452           fqxd(i_end+1, k) = 0.5*((fzm(k)*rud(i_end+1, k, j)+fzp(k)*rud(&
6453 &            i_end+1, k-1, j))*(w(i_end+1, k, j)+w(i_end, k, j))+(fzm(k)*&
6454 &            ru(i_end+1, k, j)+fzp(k)*ru(i_end+1, k-1, j))*(wd(i_end+1, k&
6455 &            , j)+wd(i_end, k, j)))
6456           fqx(i_end+1, k) = 0.5*(fzm(k)*ru(i_end+1, k, j)+fzp(k)*ru(&
6457 &            i_end+1, k-1, j))*(w(i_end+1, k, j)+w(i_end, k, j))
6458         END DO
6459         k = ktf + 1
6460         fqxd(i_end+1, k) = 0.5*(((2.-fzm(k-1))*rud(i_end+1, k-1, j)-fzp(&
6461 &          k-1)*rud(i_end+1, k-2, j))*(w(i_end+1, k, j)+w(i_end, k, j))+(&
6462 &          (2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1)*ru(i_end+1, k-2, j)&
6463 &          )*(wd(i_end+1, k, j)+wd(i_end, k, j)))
6464         fqx(i_end+1, k) = 0.5*((2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1&
6465 &          )*ru(i_end+1, k-2, j))*(w(i_end+1, k, j)+w(i_end, k, j))
6466       END IF
6467 !  x flux-divergence into tendency
6468       DO k=kts+1,ktf+1
6469         DO i=i_start,i_end
6470 ! see ADT eqn 46 dividing by my, 1st term RHS
6471           mrdx = msftx(i, j)*rdx
6472           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
6473 &            fqxd(i, k))
6474           tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
6475 &            i, k))
6476         END DO
6477       END DO
6478     END DO
6479 !  next -> y flux divergence calculation
6480     i_start = its
6481     IF (ite .GT. ide - 1) THEN
6482       i_end = ide - 1
6483     ELSE
6484       i_end = ite
6485     END IF
6486     j_start = jts
6487     IF (jte .GT. jde - 1) THEN
6488       j_end = jde - 1
6489     ELSE
6490       j_end = jte
6491     END IF
6492 !  3rd or 4th order flux has a 5 point stencil, so compute
6493 !  bounds so we can switch to second order flux close to the boundary
6494     j_start_f = j_start
6495     j_end_f = j_end + 1
6496     IF (degrade_ys) THEN
6497       j_start = jds + 1
6498       j_start_f = j_start + 1
6499     END IF
6500     IF (degrade_ye) THEN
6501       j_end = jde - 2
6502       j_end_f = jde - 2
6503     END IF
6504     IF (config_flags%polar) THEN
6505       IF (jte .GT. jde - 1) THEN
6506         j_end = jde - 1
6507       ELSE
6508         j_end = jte
6509       END IF
6510     END IF
6511     jp1 = 2
6512     jp0 = 1
6513     fqyd = 0.0
6514     DO j=j_start,j_end+1
6515       IF (j .LT. j_start_f .AND. degrade_ys) THEN
6516         DO k=kts+1,ktf
6517           DO i=i_start,i_end
6518             fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j_start)+fzp(k)*rvd&
6519 &              (i, k-1, j_start))*(w(i, k, j_start)+w(i, k, j_start-1))+(&
6520 &              fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, k-1, j_start))*(wd(i&
6521 &              , k, j_start)+wd(i, k, j_start-1)))
6522             fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, &
6523 &              k-1, j_start))*(w(i, k, j_start)+w(i, k, j_start-1))
6524           END DO
6525         END DO
6526         k = ktf + 1
6527         DO i=i_start,i_end
6528           fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j_start)-fzp&
6529 &            (k-1)*rvd(i, k-2, j_start))*(w(i, k, j_start)+w(i, k, &
6530 &            j_start-1))+((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-1)*rv(i&
6531 &            , k-2, j_start))*(wd(i, k, j_start)+wd(i, k, j_start-1)))
6532           fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-&
6533 &            1)*rv(i, k-2, j_start))*(w(i, k, j_start)+w(i, k, j_start-1)&
6534 &            )
6535         END DO
6536       ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
6537         DO k=kts+1,ktf
6538           DO i=i_start,i_end
6539 ! Assumes j>j_end_f is ONLY j_end+1 ...
6540 !            fqy(i, k, jp1) =                             &
6541 !               0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1))     &
6542 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
6543             fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
6544 &              1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
6545 &              )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
6546             fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
6547 &              ))*(w(i, k, j)+w(i, k, j-1))
6548           END DO
6549         END DO
6550         k = ktf + 1
6551         DO i=i_start,i_end
6552 ! Assumes j>j_end_f is ONLY j_end+1 ...
6553 !            fqy(i, k, jp1) =                             &
6554 !               0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1))     &
6555 !                   *(w(i,k,j_end+1)+w(i,k,j_end))
6556           fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
6557 &            rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
6558 &            i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
6559 &            )))
6560           fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
6561 &            i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
6562         END DO
6563       ELSE
6564 !  3rd or 4th order flux
6565         DO k=kts+1,ktf
6566           DO i=i_start,i_end
6567             veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
6568             vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
6569             fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, &
6570 &              k, j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
6571 &              vel)*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1&
6572 &              )))/12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, &
6573 &              j+1)-wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
6574 &              (wd(i, k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)&
6575 &              ))/12.0)
6576             fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
6577 &              , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
6578 &              )*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))&
6579 &              /12.0)
6580           END DO
6581         END DO
6582         k = ktf + 1
6583         DO i=i_start,i_end
6584           veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
6585           vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
6586           fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
6587 &            , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
6588 &            (w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/&
6589 &            12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-&
6590 &            wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, &
6591 &            k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
6592           fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
6593 &            +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(&
6594 &            i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
6595         END DO
6596       END IF
6597 !  y flux-divergence into tendency
6598 ! Comments for polar boundary conditions
6599 ! Same process as for advect_u - tendencies run from jds to jde-1
6600 ! (latitudes are as for u grid, longitudes are displaced)
6601 ! Therefore: flow is only from one side for points next to poles
6602       IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
6603         DO k=kts,ktf
6604           DO i=i_start,i_end
6605 ! see ADT eqn 46 dividing by my, 2nd term RHS
6606             mrdy = msftx(i, j-1)*rdy
6607             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
6608 &              , jp1)
6609             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
6610 &              jp1)
6611           END DO
6612         END DO
6613       ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
6614         DO k=kts,ktf
6615           DO i=i_start,i_end
6616 ! see ADT eqn 46 dividing by my, 2nd term RHS
6617             mrdy = msftx(i, j-1)*rdy
6618             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
6619 &              , jp0)
6620             tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
6621 &              jp0)
6622           END DO
6623         END DO
6624       ELSE IF (j .GT. j_start) THEN
6625 ! normal code
6626         DO k=kts+1,ktf+1
6627           DO i=i_start,i_end
6628 ! see ADT eqn 46 dividing by my, 2nd term RHS
6629             mrdy = msftx(i, j-1)*rdy
6630             tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
6631 &              k, jp1)-fqyd(i, k, jp0))
6632             tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
6633 &              jp1)-fqy(i, k, jp0))
6634           END DO
6635         END DO
6636       END IF
6637       jtmp = jp1
6638       jp1 = jp0
6639       jp0 = jtmp
6640     END DO
6641   ELSE IF (horz_order .EQ. 2) THEN
6642     i_start = its
6643     IF (ite .GT. ide - 1) THEN
6644       i_end = ide - 1
6645     ELSE
6646       i_end = ite
6647     END IF
6648     j_start = jts
6649     IF (jte .GT. jde - 1) THEN
6650       j_end = jde - 1
6651     ELSE
6652       j_end = jte
6653     END IF
6654     IF (.NOT.config_flags%periodic_x) THEN
6655       IF (config_flags%open_xs .OR. specified) THEN
6656         IF (ids + 1 .LT. its) THEN
6657           i_start = its
6658         ELSE
6659           i_start = ids + 1
6660         END IF
6661       END IF
6662       IF (config_flags%open_xe .OR. specified) THEN
6663         IF (ide - 2 .GT. ite) THEN
6664           i_end = ite
6665         ELSE
6666           i_end = ide - 2
6667         END IF
6668       END IF
6669     END IF
6670     DO j=j_start,j_end
6671       DO k=kts+1,ktf
6672         DO i=i_start,i_end
6673 ! see ADT eqn 46 dividing by my, 1st term RHS
6674           mrdx = msftx(i, j)*rdx
6675           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.5*((fzm(k)*&
6676 &            rud(i+1, k, j)+fzp(k)*rud(i+1, k-1, j))*(w(i+1, k, j)+w(i, k&
6677 &            , j))+(fzm(k)*ru(i+1, k, j)+fzp(k)*ru(i+1, k-1, j))*(wd(i+1&
6678 &            , k, j)+wd(i, k, j))-(fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1&
6679 &            , j))*(w(i, k, j)+w(i-1, k, j))-(fzm(k)*ru(i, k, j)+fzp(k)*&
6680 &            ru(i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
6681           tendency(i, k, j) = tendency(i, k, j) - mrdx*0.5*((fzm(k)*ru(i&
6682 &            +1, k, j)+fzp(k)*ru(i+1, k-1, j))*(w(i+1, k, j)+w(i, k, j))-&
6683 &            (fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*(w(i, k, j)+w(i-1&
6684 &            , k, j)))
6685         END DO
6686       END DO
6687       k = ktf + 1
6688       DO i=i_start,i_end
6689 ! see ADT eqn 46 dividing by my, 1st term RHS
6690         mrdx = msftx(i, j)*rdx
6691         tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.5*(((2.-fzm(k-1&
6692 &          ))*rud(i+1, k-1, j)-fzp(k-1)*rud(i+1, k-2, j))*(w(i+1, k, j)+w&
6693 &          (i, k, j))+((2.-fzm(k-1))*ru(i+1, k-1, j)-fzp(k-1)*ru(i+1, k-2&
6694 &          , j))*(wd(i+1, k, j)+wd(i, k, j))-((2.-fzm(k-1))*rud(i, k-1, j&
6695 &          )-fzp(k-1)*rud(i, k-2, j))*(w(i, k, j)+w(i-1, k, j))-((2.-fzm(&
6696 &          k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-&
6697 &          1, k, j)))
6698         tendency(i, k, j) = tendency(i, k, j) - mrdx*0.5*(((2.-fzm(k-1))&
6699 &          *ru(i+1, k-1, j)-fzp(k-1)*ru(i+1, k-2, j))*(w(i+1, k, j)+w(i, &
6700 &          k, j))-((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-2, j))*(w&
6701 &          (i, k, j)+w(i-1, k, j)))
6702       END DO
6703     END DO
6704     i_start = its
6705     IF (ite .GT. ide - 1) THEN
6706       i_end = ide - 1
6707     ELSE
6708       i_end = ite
6709     END IF
6710 ! Polar boundary conditions are like open or specified
6711     IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
6712 &    THEN
6713       IF (jds + 1 .LT. jts) THEN
6714         j_start = jts
6715       ELSE
6716         j_start = jds + 1
6717       END IF
6718     END IF
6719     IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
6720 &    THEN
6721       IF (jde - 2 .GT. jte) THEN
6722         j_end = jte
6723       ELSE
6724         j_end = jde - 2
6725       END IF
6726     END IF
6727     DO j=j_start,j_end
6728       DO k=kts+1,ktf
6729         DO i=i_start,i_end
6730 !  see ADT eqn 46 dividing by my, 2nd term RHS
6731           mrdy = msftx(i, j)*rdy
6732           tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.5*((fzm(k)*&
6733 &            rvd(i, k, j+1)+fzp(k)*rvd(i, k-1, j+1))*(w(i, k, j+1)+w(i, k&
6734 &            , j))+(fzm(k)*rv(i, k, j+1)+fzp(k)*rv(i, k-1, j+1))*(wd(i, k&
6735 &            , j+1)+wd(i, k, j))-(fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-1, &
6736 &            j))*(w(i, k, j)+w(i, k, j-1))-(fzm(k)*rv(i, k, j)+fzp(k)*rv(&
6737 &            i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
6738           tendency(i, k, j) = tendency(i, k, j) - mrdy*0.5*((fzm(k)*rv(i&
6739 &            , k, j+1)+fzp(k)*rv(i, k-1, j+1))*(w(i, k, j+1)+w(i, k, j))-&
6740 &            (fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*(w(i, k, j)+w(i, k&
6741 &            , j-1)))
6742         END DO
6743       END DO
6744       k = ktf + 1
6745       DO i=i_start,i_end
6746 ! see ADT eqn 46 dividing by my, 2nd term RHS
6747         mrdy = msftx(i, j)*rdy
6748         tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.5*(((2.-fzm(k-1&
6749 &          ))*rvd(i, k-1, j+1)-fzp(k-1)*rvd(i, k-2, j+1))*(w(i, k, j+1)+w&
6750 &          (i, k, j))+((2.-fzm(k-1))*rv(i, k-1, j+1)-fzp(k-1)*rv(i, k-2, &
6751 &          j+1))*(wd(i, k, j+1)+wd(i, k, j))-((2.-fzm(k-1))*rvd(i, k-1, j&
6752 &          )-fzp(k-1)*rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))-((2.-fzm(&
6753 &          k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i&
6754 &          , k, j-1)))
6755         tendency(i, k, j) = tendency(i, k, j) - mrdy*0.5*(((2.-fzm(k-1))&
6756 &          *rv(i, k-1, j+1)-fzp(k-1)*rv(i, k-2, j+1))*(w(i, k, j+1)+w(i, &
6757 &          k, j))-((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(w&
6758 &          (i, k, j)+w(i, k, j-1)))
6759       END DO
6760     END DO
6761 ! Polar boundary condition ... not covered in above j-loop
6762     IF (config_flags%polar) THEN
6763       IF (jts .EQ. jds) THEN
6764         DO k=kts+1,ktf
6765           DO i=i_start,i_end
6766 ! see ADT eqn 46 dividing by my, 2nd term RHS
6767             mrdy = msftx(i, jds)*rdy
6768             tendencyd(i, k, jds) = tendencyd(i, k, jds) - mrdy*0.5*((fzm&
6769 &              (k)*rvd(i, k, jds+1)+fzp(k)*rvd(i, k-1, jds+1))*(w(i, k, &
6770 &              jds+1)+w(i, k, jds))+(fzm(k)*rv(i, k, jds+1)+fzp(k)*rv(i, &
6771 &              k-1, jds+1))*(wd(i, k, jds+1)+wd(i, k, jds)))
6772             tendency(i, k, jds) = tendency(i, k, jds) - mrdy*0.5*((fzm(k&
6773 &              )*rv(i, k, jds+1)+fzp(k)*rv(i, k-1, jds+1))*(w(i, k, jds+1&
6774 &              )+w(i, k, jds)))
6775           END DO
6776         END DO
6777         k = ktf + 1
6778         DO i=i_start,i_end
6779 ! see ADT eqn 46 dividing by my, 2nd term RHS
6780           mrdy = msftx(i, jds)*rdy
6781           tendencyd(i, k, jds) = tendencyd(i, k, jds) - mrdy*0.5*(((2.-&
6782 &            fzm(k-1))*rvd(i, k-1, jds+1)-fzp(k-1)*rvd(i, k-2, jds+1))*(w&
6783 &            (i, k, jds+1)+w(i, k, jds))+((2.-fzm(k-1))*rv(i, k-1, jds+1)&
6784 &            -fzp(k-1)*rv(i, k-2, jds+1))*(wd(i, k, jds+1)+wd(i, k, jds))&
6785 &            )
6786           tendency(i, k, jds) = tendency(i, k, jds) - mrdy*0.5*((2.-fzm(&
6787 &            k-1))*rv(i, k-1, jds+1)-fzp(k-1)*rv(i, k-2, jds+1))*(w(i, k&
6788 &            , jds+1)+w(i, k, jds))
6789         END DO
6790       END IF
6791       IF (jte .EQ. jde) THEN
6792         DO k=kts+1,ktf
6793           DO i=i_start,i_end
6794 ! see ADT eqn 46 dividing by my, 2nd term RHS
6795             mrdy = msftx(i, jde-1)*rdy
6796             tendencyd(i, k, jde-1) = tendencyd(i, k, jde-1) + mrdy*0.5*(&
6797 &              (fzm(k)*rvd(i, k, jde-1)+fzp(k)*rvd(i, k-1, jde-1))*(w(i, &
6798 &              k, jde-1)+w(i, k, jde-2))+(fzm(k)*rv(i, k, jde-1)+fzp(k)*&
6799 &              rv(i, k-1, jde-1))*(wd(i, k, jde-1)+wd(i, k, jde-2)))
6800             tendency(i, k, jde-1) = tendency(i, k, jde-1) + mrdy*0.5*((&
6801 &              fzm(k)*rv(i, k, jde-1)+fzp(k)*rv(i, k-1, jde-1))*(w(i, k, &
6802 &              jde-1)+w(i, k, jde-2)))
6803           END DO
6804         END DO
6805         k = ktf + 1
6806         DO i=i_start,i_end
6807 ! see ADT eqn 46 dividing by my, 2nd term RHS
6808           mrdy = msftx(i, jde-1)*rdy
6809           tendencyd(i, k, jde-1) = tendencyd(i, k, jde-1) + mrdy*0.5*(((&
6810 &            2.-fzm(k-1))*rvd(i, k-1, jde-1)-fzp(k-1)*rvd(i, k-2, jde-1))&
6811 &            *(w(i, k, jde-1)+w(i, k, jde-2))+((2.-fzm(k-1))*rv(i, k-1, &
6812 &            jde-1)-fzp(k-1)*rv(i, k-2, jde-1))*(wd(i, k, jde-1)+wd(i, k&
6813 &            , jde-2)))
6814           tendency(i, k, jde-1) = tendency(i, k, jde-1) + mrdy*0.5*((2.-&
6815 &            fzm(k-1))*rv(i, k-1, jde-1)-fzp(k-1)*rv(i, k-2, jde-1))*(w(i&
6816 &            , k, jde-1)+w(i, k, jde-2))
6817         END DO
6818       END IF
6819     END IF
6820   ELSE IF (horz_order .NE. 0) THEN
6821 ! Just in case we want to turn horizontal advection off, we can do it
6822     WRITE(wrf_err_message, *) ' advect_w_6a, h_order not known ', &
6823 &    horz_order
6824     CALL WRF_ERROR_FATAL(wrf_err_message)
6825   END IF
6826 !  pick up the the horizontal radiation boundary conditions.
6827 !  (these are the computations that don't require 'cb'.
6828 !  first, set to index ranges
6829   i_start = its
6830   IF (ite .GT. ide - 1) THEN
6831     i_end = ide - 1
6832   ELSE
6833     i_end = ite
6834   END IF
6835   j_start = jts
6836   IF (jte .GT. jde - 1) THEN
6837     j_end = jde - 1
6838   ELSE
6839     j_end = jte
6840   END IF
6841   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
6842     DO j=j_start,j_end
6843       DO k=kts+1,ktf
6844         uwd = 0.5*(fzm(k)*(rud(its, k, j)+rud(its+1, k, j))+fzp(k)*(rud(&
6845 &          its, k-1, j)+rud(its+1, k-1, j)))
6846         uw = 0.5*(fzm(k)*(ru(its, k, j)+ru(its+1, k, j))+fzp(k)*(ru(its&
6847 &          , k-1, j)+ru(its+1, k-1, j)))
6848         IF (uw .GT. 0.) THEN
6849           ub = 0.
6850           ubd = 0.0
6851         ELSE
6852           ubd = uwd
6853           ub = uw
6854         END IF
6855         tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(w_old(&
6856 &          its+1, k, j)-w_old(its, k, j))+ub*(w_oldd(its+1, k, j)-w_oldd(&
6857 &          its, k, j))+wd(its, k, j)*(fzm(k)*(ru(its+1, k, j)-ru(its, k, &
6858 &          j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j)))+w(its, k, j)*(&
6859 &          fzm(k)*(rud(its+1, k, j)-rud(its, k, j))+fzp(k)*(rud(its+1, k-&
6860 &          1, j)-rud(its, k-1, j))))
6861         tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(w_old(its+1&
6862 &          , k, j)-w_old(its, k, j))+w(its, k, j)*(fzm(k)*(ru(its+1, k, j&
6863 &          )-ru(its, k, j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j))))
6864       END DO
6865     END DO
6866     k = ktf + 1
6867     DO j=j_start,j_end
6868       uwd = 0.5*((2.-fzm(k-1))*(rud(its, k-1, j)+rud(its+1, k-1, j))-fzp&
6869 &        (k-1)*(rud(its, k-2, j)+rud(its+1, k-2, j)))
6870       uw = 0.5*((2.-fzm(k-1))*(ru(its, k-1, j)+ru(its+1, k-1, j))-fzp(k-&
6871 &        1)*(ru(its, k-2, j)+ru(its+1, k-2, j)))
6872       IF (uw .GT. 0.) THEN
6873         ub = 0.
6874         ubd = 0.0
6875       ELSE
6876         ubd = uwd
6877         ub = uw
6878       END IF
6879       tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(w_old(its+&
6880 &        1, k, j)-w_old(its, k, j))+ub*(w_oldd(its+1, k, j)-w_oldd(its, k&
6881 &        , j))+wd(its, k, j)*((2.-fzm(k-1))*(ru(its+1, k-1, j)-ru(its, k-&
6882 &        1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2, j)))+w(its, k, j&
6883 &        )*((2.-fzm(k-1))*(rud(its+1, k-1, j)-rud(its, k-1, j))-fzp(k-1)*&
6884 &        (rud(its+1, k-2, j)-rud(its, k-2, j))))
6885       tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(w_old(its+1, &
6886 &        k, j)-w_old(its, k, j))+w(its, k, j)*((2.-fzm(k-1))*(ru(its+1, k&
6887 &        -1, j)-ru(its, k-1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2&
6888 &        , j))))
6889     END DO
6890   END IF
6891   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
6892     DO j=j_start,j_end
6893       DO k=kts+1,ktf
6894         uwd = 0.5*(fzm(k)*(rud(ite-1, k, j)+rud(ite, k, j))+fzp(k)*(rud(&
6895 &          ite-1, k-1, j)+rud(ite, k-1, j)))
6896         uw = 0.5*(fzm(k)*(ru(ite-1, k, j)+ru(ite, k, j))+fzp(k)*(ru(ite-&
6897 &          1, k-1, j)+ru(ite, k-1, j)))
6898         IF (uw .LT. 0.) THEN
6899           ub = 0.
6900           ubd = 0.0
6901         ELSE
6902           ubd = uwd
6903           ub = uw
6904         END IF
6905         tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
6906 &          w_old(i_end, k, j)-w_old(i_end-1, k, j))+ub*(w_oldd(i_end, k, &
6907 &          j)-w_oldd(i_end-1, k, j))+wd(i_end, k, j)*(fzm(k)*(ru(ite, k, &
6908 &          j)-ru(ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, k-1, j))&
6909 &          )+w(i_end, k, j)*(fzm(k)*(rud(ite, k, j)-rud(ite-1, k, j))+fzp&
6910 &          (k)*(rud(ite, k-1, j)-rud(ite-1, k-1, j))))
6911         tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(w_old(&
6912 &          i_end, k, j)-w_old(i_end-1, k, j))+w(i_end, k, j)*(fzm(k)*(ru(&
6913 &          ite, k, j)-ru(ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, &
6914 &          k-1, j))))
6915       END DO
6916     END DO
6917     k = ktf + 1
6918     DO j=j_start,j_end
6919       uwd = 0.5*((2.-fzm(k-1))*(rud(ite-1, k-1, j)+rud(ite, k-1, j))-fzp&
6920 &        (k-1)*(rud(ite-1, k-2, j)+rud(ite, k-2, j)))
6921       uw = 0.5*((2.-fzm(k-1))*(ru(ite-1, k-1, j)+ru(ite, k-1, j))-fzp(k-&
6922 &        1)*(ru(ite-1, k-2, j)+ru(ite, k-2, j)))
6923       IF (uw .LT. 0.) THEN
6924         ub = 0.
6925         ubd = 0.0
6926       ELSE
6927         ubd = uwd
6928         ub = uw
6929       END IF
6930       tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(w_old(&
6931 &        i_end, k, j)-w_old(i_end-1, k, j))+ub*(w_oldd(i_end, k, j)-&
6932 &        w_oldd(i_end-1, k, j))+wd(i_end, k, j)*((2.-fzm(k-1))*(ru(ite, k&
6933 &        -1, j)-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-ru(ite-1, k-&
6934 &        2, j)))+w(i_end, k, j)*((2.-fzm(k-1))*(rud(ite, k-1, j)-rud(ite-&
6935 &        1, k-1, j))-fzp(k-1)*(rud(ite, k-2, j)-rud(ite-1, k-2, j))))
6936       tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(w_old(&
6937 &        i_end, k, j)-w_old(i_end-1, k, j))+w(i_end, k, j)*((2.-fzm(k-1))&
6938 &        *(ru(ite, k-1, j)-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-&
6939 &        ru(ite-1, k-2, j))))
6940     END DO
6941   END IF
6942   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
6943     DO i=i_start,i_end
6944       DO k=kts+1,ktf
6945         vwd = 0.5*(fzm(k)*(rvd(i, k, jts)+rvd(i, k, jts+1))+fzp(k)*(rvd(&
6946 &          i, k-1, jts)+rvd(i, k-1, jts+1)))
6947         vw = 0.5*(fzm(k)*(rv(i, k, jts)+rv(i, k, jts+1))+fzp(k)*(rv(i, k&
6948 &          -1, jts)+rv(i, k-1, jts+1)))
6949         IF (vw .GT. 0.) THEN
6950           vb = 0.
6951           vbd = 0.0
6952         ELSE
6953           vbd = vwd
6954           vb = vw
6955         END IF
6956         tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(w_old(i&
6957 &          , k, jts+1)-w_old(i, k, jts))+vb*(w_oldd(i, k, jts+1)-w_oldd(i&
6958 &          , k, jts))+wd(i, k, jts)*(fzm(k)*(rv(i, k, jts+1)-rv(i, k, jts&
6959 &          ))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts)))+w(i, k, jts)*(&
6960 &          fzm(k)*(rvd(i, k, jts+1)-rvd(i, k, jts))+fzp(k)*(rvd(i, k-1, &
6961 &          jts+1)-rvd(i, k-1, jts))))
6962         tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(w_old(i, k&
6963 &          , jts+1)-w_old(i, k, jts))+w(i, k, jts)*(fzm(k)*(rv(i, k, jts+&
6964 &          1)-rv(i, k, jts))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts))))
6965       END DO
6966     END DO
6967     k = ktf + 1
6968     DO i=i_start,i_end
6969       vwd = 0.5*((2.-fzm(k-1))*(rvd(i, k-1, jts)+rvd(i, k-1, jts+1))-fzp&
6970 &        (k-1)*(rvd(i, k-2, jts)+rvd(i, k-2, jts+1)))
6971       vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jts)+rv(i, k-1, jts+1))-fzp(k-&
6972 &        1)*(rv(i, k-2, jts)+rv(i, k-2, jts+1)))
6973       IF (vw .GT. 0.) THEN
6974         vb = 0.
6975         vbd = 0.0
6976       ELSE
6977         vbd = vwd
6978         vb = vw
6979       END IF
6980       tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(w_old(i, k&
6981 &        , jts+1)-w_old(i, k, jts))+vb*(w_oldd(i, k, jts+1)-w_oldd(i, k, &
6982 &        jts))+wd(i, k, jts)*((2.-fzm(k-1))*(rv(i, k-1, jts+1)-rv(i, k-1&
6983 &        , jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2, jts)))+w(i, k, &
6984 &        jts)*((2.-fzm(k-1))*(rvd(i, k-1, jts+1)-rvd(i, k-1, jts))-fzp(k-&
6985 &        1)*(rvd(i, k-2, jts+1)-rvd(i, k-2, jts))))
6986       tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(w_old(i, k, &
6987 &        jts+1)-w_old(i, k, jts))+w(i, k, jts)*((2.-fzm(k-1))*(rv(i, k-1&
6988 &        , jts+1)-rv(i, k-1, jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2&
6989 &        , jts))))
6990     END DO
6991   END IF
6992   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
6993     DO i=i_start,i_end
6994       DO k=kts+1,ktf
6995         vwd = 0.5*(fzm(k)*(rvd(i, k, jte-1)+rvd(i, k, jte))+fzp(k)*(rvd(&
6996 &          i, k-1, jte-1)+rvd(i, k-1, jte)))
6997         vw = 0.5*(fzm(k)*(rv(i, k, jte-1)+rv(i, k, jte))+fzp(k)*(rv(i, k&
6998 &          -1, jte-1)+rv(i, k-1, jte)))
6999         IF (vw .LT. 0.) THEN
7000           vb = 0.
7001           vbd = 0.0
7002         ELSE
7003           vbd = vwd
7004           vb = vw
7005         END IF
7006         tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
7007 &          w_old(i, k, j_end)-w_old(i, k, j_end-1))+vb*(w_oldd(i, k, &
7008 &          j_end)-w_oldd(i, k, j_end-1))+wd(i, k, j_end)*(fzm(k)*(rv(i, k&
7009 &          , jte)-rv(i, k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, jte&
7010 &          -1)))+w(i, k, j_end)*(fzm(k)*(rvd(i, k, jte)-rvd(i, k, jte-1))&
7011 &          +fzp(k)*(rvd(i, k-1, jte)-rvd(i, k-1, jte-1))))
7012         tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(w_old(i&
7013 &          , k, j_end)-w_old(i, k, j_end-1))+w(i, k, j_end)*(fzm(k)*(rv(i&
7014 &          , k, jte)-rv(i, k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, &
7015 &          jte-1))))
7016       END DO
7017     END DO
7018     k = ktf + 1
7019     DO i=i_start,i_end
7020       vwd = 0.5*((2.-fzm(k-1))*(rvd(i, k-1, jte-1)+rvd(i, k-1, jte))-fzp&
7021 &        (k-1)*(rvd(i, k-2, jte-1)+rvd(i, k-2, jte)))
7022       vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jte-1)+rv(i, k-1, jte))-fzp(k-&
7023 &        1)*(rv(i, k-2, jte-1)+rv(i, k-2, jte)))
7024       IF (vw .LT. 0.) THEN
7025         vb = 0.
7026         vbd = 0.0
7027       ELSE
7028         vbd = vwd
7029         vb = vw
7030       END IF
7031       tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(w_old(&
7032 &        i, k, j_end)-w_old(i, k, j_end-1))+vb*(w_oldd(i, k, j_end)-&
7033 &        w_oldd(i, k, j_end-1))+wd(i, k, j_end)*((2.-fzm(k-1))*(rv(i, k-1&
7034 &        , jte)-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(i, k-2, &
7035 &        jte-1)))+w(i, k, j_end)*((2.-fzm(k-1))*(rvd(i, k-1, jte)-rvd(i, &
7036 &        k-1, jte-1))-fzp(k-1)*(rvd(i, k-2, jte)-rvd(i, k-2, jte-1))))
7037       tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(w_old(i, &
7038 &        k, j_end)-w_old(i, k, j_end-1))+w(i, k, j_end)*((2.-fzm(k-1))*(&
7039 &        rv(i, k-1, jte)-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(&
7040 &        i, k-2, jte-1))))
7041     END DO
7042   END IF
7043 !-------------------- vertical advection
7044 !     ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
7045 !     Here we have:  - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
7046 !     Therefore we don't need to make a correction for advect_w
7047   i_start = its
7048   IF (ite .GT. ide - 1) THEN
7049     i_end = ide - 1
7050   ELSE
7051     i_end = ite
7052   END IF
7053   j_start = jts
7054   IF (jte .GT. jde - 1) THEN
7055     j_end = jde - 1
7056   ELSE
7057     j_end = jte
7058   END IF
7059   DO i=i_start,i_end
7060     vfluxd(i, kts) = 0.0
7061     vflux(i, kts) = 0.
7062     vfluxd(i, kte) = 0.0
7063     vflux(i, kte) = 0.
7064   END DO
7065   IF (vert_order .EQ. 6) THEN
7066     vfluxd = 0.0
7067     DO j=j_start,j_end
7068       DO k=kts+3,ktf-1
7069         DO i=i_start,i_end
7070           veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
7071           vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
7072           vfluxd(i, k) = veld*(37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k+&
7073 &            1, j)+w(i, k-2, j))+(w(i, k+2, j)+w(i, k-3, j)))/60.0 + vel*&
7074 &            (37.*(wd(i, k, j)+wd(i, k-1, j))-8.*(wd(i, k+1, j)+wd(i, k-2&
7075 &            , j))+wd(i, k+2, j)+wd(i, k-3, j))/60.0
7076           vflux(i, k) = vel*((37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k+1&
7077 &            , j)+w(i, k-2, j))+(w(i, k+2, j)+w(i, k-3, j)))/60.0)
7078         END DO
7079       END DO
7080       DO i=i_start,i_end
7081         k = kts + 1
7082         vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
7083 &          +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
7084 &          , k-1, j)))
7085         vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
7086 &          , k-1, j))
7087         k = kts + 2
7088         veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
7089         vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
7090         vfluxd(i, k) = veld*(7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+&
7091 &          w(i, k-2, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k-1, j))-wd(i&
7092 &          , k+1, j)-wd(i, k-2, j))/12.0
7093         vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
7094 &          (i, k-2, j)))/12.0)
7095         k = ktf
7096         veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
7097         vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
7098         vfluxd(i, k) = veld*(7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+&
7099 &          w(i, k-2, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k-1, j))-wd(i&
7100 &          , k+1, j)-wd(i, k-2, j))/12.0
7101         vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
7102 &          (i, k-2, j)))/12.0)
7103         k = ktf + 1
7104         vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
7105 &          +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
7106 &          , k-1, j)))
7107         vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
7108 &          , k-1, j))
7109       END DO
7110       DO k=kts+1,ktf
7111         DO i=i_start,i_end
7112           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k&
7113 &            +1)-vfluxd(i, k))
7114           tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)&
7115 &            -vflux(i, k))
7116         END DO
7117       END DO
7118 ! pick up flux contribution for w at the lid. wcs, 13 march 2004
7119       k = ktf + 1
7120       DO i=i_start,i_end
7121         tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i&
7122 &          , k)
7123         tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
7124       END DO
7125     END DO
7126   ELSE IF (vert_order .EQ. 5) THEN
7127     vfluxd = 0.0
7128     DO j=j_start,j_end
7129       DO k=kts+3,ktf-1
7130         DO i=i_start,i_end
7131           veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
7132           vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
7133           vfluxd(i, k) = veld*((37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k&
7134 &            +1, j)+w(i, k-2, j))+(w(i, k+2, j)+w(i, k-3, j)))/60.0-SIGN(&
7135 &            1, time_step)*SIGN(1., -vel)*(w(i, k+2, j)-w(i, k-3, j)-5.*(&
7136 &            w(i, k+1, j)-w(i, k-2, j))+10.*(w(i, k, j)-w(i, k-1, j)))/&
7137 &            60.0) + vel*((37.*(wd(i, k, j)+wd(i, k-1, j))-8.*(wd(i, k+1&
7138 &            , j)+wd(i, k-2, j))+wd(i, k+2, j)+wd(i, k-3, j))/60.0-SIGN(1&
7139 &            , time_step)*SIGN(1., -vel)*(wd(i, k+2, j)-wd(i, k-3, j)-5.*&
7140 &            (wd(i, k+1, j)-wd(i, k-2, j))+10.*(wd(i, k, j)-wd(i, k-1, j)&
7141 &            ))/60.0)
7142           vflux(i, k) = vel*((37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k+1&
7143 &            , j)+w(i, k-2, j))+(w(i, k+2, j)+w(i, k-3, j)))/60.0-SIGN(1&
7144 &            , time_step)*SIGN(1., -vel)*(w(i, k+2, j)-w(i, k-3, j)-5.*(w&
7145 &            (i, k+1, j)-w(i, k-2, j))+10.*(w(i, k, j)-w(i, k-1, j)))/&
7146 &            60.0)
7147         END DO
7148       END DO
7149       DO i=i_start,i_end
7150         k = kts + 1
7151         vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
7152 &          +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
7153 &          , k-1, j)))
7154         vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
7155 &          , k-1, j))
7156         k = kts + 2
7157         veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
7158         vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
7159         vfluxd(i, k) = veld*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)&
7160 &          +w(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k&
7161 &          +1, j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0) + vel*&
7162 &          ((7.*(wd(i, k, j)+wd(i, k-1, j))-wd(i, k+1, j)-wd(i, k-2, j))/&
7163 &          12.0+SIGN(1, time_step)*SIGN(1., -vel)*(wd(i, k+1, j)-wd(i, k-&
7164 &          2, j)-3.*(wd(i, k, j)-wd(i, k-1, j)))/12.0)
7165         vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
7166 &          (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1&
7167 &          , j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0)
7168         k = ktf
7169         veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
7170         vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
7171         vfluxd(i, k) = veld*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)&
7172 &          +w(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k&
7173 &          +1, j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0) + vel*&
7174 &          ((7.*(wd(i, k, j)+wd(i, k-1, j))-wd(i, k+1, j)-wd(i, k-2, j))/&
7175 &          12.0+SIGN(1, time_step)*SIGN(1., -vel)*(wd(i, k+1, j)-wd(i, k-&
7176 &          2, j)-3.*(wd(i, k, j)-wd(i, k-1, j)))/12.0)
7177         vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
7178 &          (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1&
7179 &          , j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0)
7180         k = ktf + 1
7181         vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
7182 &          +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
7183 &          , k-1, j)))
7184         vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
7185 &          , k-1, j))
7186       END DO
7187       DO k=kts+1,ktf
7188         DO i=i_start,i_end
7189           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k&
7190 &            +1)-vfluxd(i, k))
7191           tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)&
7192 &            -vflux(i, k))
7193         END DO
7194       END DO
7195 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
7196       k = ktf + 1
7197       DO i=i_start,i_end
7198         tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i&
7199 &          , k)
7200         tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
7201       END DO
7202     END DO
7203   ELSE IF (vert_order .EQ. 4) THEN
7204     vfluxd = 0.0
7205     DO j=j_start,j_end
7206       DO k=kts+2,ktf
7207         DO i=i_start,i_end
7208           veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
7209           vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
7210           vfluxd(i, k) = veld*(7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j&
7211 &            )+w(i, k-2, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k-1, j))-&
7212 &            wd(i, k+1, j)-wd(i, k-2, j))/12.0
7213           vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)&
7214 &            +w(i, k-2, j)))/12.0)
7215         END DO
7216       END DO
7217       DO i=i_start,i_end
7218         k = kts + 1
7219         vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
7220 &          +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
7221 &          , k-1, j)))
7222         vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
7223 &          , k-1, j))
7224         k = ktf + 1
7225         vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
7226 &          +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
7227 &          , k-1, j)))
7228         vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
7229 &          , k-1, j))
7230       END DO
7231       DO k=kts+1,ktf
7232         DO i=i_start,i_end
7233           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k&
7234 &            +1)-vfluxd(i, k))
7235           tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)&
7236 &            -vflux(i, k))
7237         END DO
7238       END DO
7239 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
7240       k = ktf + 1
7241       DO i=i_start,i_end
7242         tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i&
7243 &          , k)
7244         tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
7245       END DO
7246     END DO
7247   ELSE IF (vert_order .EQ. 3) THEN
7248     vfluxd = 0.0
7249     DO j=j_start,j_end
7250       DO k=kts+2,ktf
7251         DO i=i_start,i_end
7252           veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
7253           vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
7254           vfluxd(i, k) = veld*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, &
7255 &            j)+w(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(&
7256 &            i, k+1, j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0) &
7257 &            + vel*((7.*(wd(i, k, j)+wd(i, k-1, j))-wd(i, k+1, j)-wd(i, k&
7258 &            -2, j))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(wd(i, k+1, j&
7259 &            )-wd(i, k-2, j)-3.*(wd(i, k, j)-wd(i, k-1, j)))/12.0)
7260           vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)&
7261 &            +w(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i&
7262 &            , k+1, j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0)
7263         END DO
7264       END DO
7265       DO i=i_start,i_end
7266         k = kts + 1
7267         vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
7268 &          +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
7269 &          , k-1, j)))
7270         vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
7271 &          , k-1, j))
7272         k = ktf + 1
7273         vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
7274 &          +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
7275 &          , k-1, j)))
7276         vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
7277 &          , k-1, j))
7278       END DO
7279       DO k=kts+1,ktf
7280         DO i=i_start,i_end
7281           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k&
7282 &            +1)-vfluxd(i, k))
7283           tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)&
7284 &            -vflux(i, k))
7285         END DO
7286       END DO
7287 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
7288       k = ktf + 1
7289       DO i=i_start,i_end
7290         tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i&
7291 &          , k)
7292         tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
7293       END DO
7294     END DO
7295   ELSE IF (vert_order .EQ. 2) THEN
7296     vfluxd = 0.0
7297     DO j=j_start,j_end
7298       DO k=kts+1,ktf+1
7299         DO i=i_start,i_end
7300           vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, &
7301 &            j)+w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+&
7302 &            wd(i, k-1, j)))
7303           vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w&
7304 &            (i, k-1, j))
7305         END DO
7306       END DO
7307       DO k=kts+1,ktf
7308         DO i=i_start,i_end
7309           tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k&
7310 &            +1)-vfluxd(i, k))
7311           tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)&
7312 &            -vflux(i, k))
7313         END DO
7314       END DO
7315 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
7316       k = ktf + 1
7317       DO i=i_start,i_end
7318         tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i&
7319 &          , k)
7320         tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
7321       END DO
7322     END DO
7323   ELSE
7324     WRITE(wrf_err_message, *) ' advect_w, v_order not known ', &
7325 &    vert_order
7326     CALL WRF_ERROR_FATAL(wrf_err_message)
7327   END IF
7328 END SUBROUTINE G_ADVECT_W
7329
7330 !        Generated by TAPENADE     (INRIA, Tropics team)
7331 !  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
7332 !
7333 !  Differentiation of advect_scalar_pd in forward (tangent) mode:
7334 !   variations   of useful results: tendency h_tendency z_tendency
7335 !   with respect to varying inputs: rom field tendency h_tendency
7336 !                z_tendency ru rv mu_old field_old mut
7337 !   RW status of diff variables: rom:in field:in tendency:in-out
7338 !                h_tendency:in-out z_tendency:in-out ru:in rv:in
7339 !                mu_old:in field_old:in mut:in
7340 SUBROUTINE G_ADVECT_SCALAR_PD(field, fieldd, field_old, field_oldd, &
7341 &  tendency, tendencyd, h_tendency, h_tendencyd, z_tendency, z_tendencyd&
7342 &  , ru, rud, rv, rvd, rom, romd, mut, mutd, mub, mu_old, mu_oldd, &
7343 &  time_step, config_flags, tenddec, msfux, msfuy, msfvx, msfvy, msftx, &
7344 &  msfty, fzm, fzp, rdx, rdy, rdzw, dt, ids, ide, jds, jde, kds, kde, ims&
7345 &  , ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
7346   IMPLICIT NONE
7347 ! Input data
7348   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
7349 ! tendency flag
7350   LOGICAL, INTENT(IN) :: tenddec
7351   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
7352 &  jme, kms, kme, its, ite, jts, jte, kts, kte
7353   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
7354 &  field_old, ru, rv, rom
7355   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: fieldd, &
7356 &  field_oldd, rud, rvd, romd
7357   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut, mub, mu_old
7358   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd, mu_oldd
7359   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
7360   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
7361   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: h_tendency&
7362 &  , z_tendency
7363   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: h_tendencyd&
7364 &  , z_tendencyd
7365   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
7366 &  msfvy, msftx, msfty
7367   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
7368   REAL, INTENT(IN) :: rdx, rdy, dt
7369   INTEGER, INTENT(IN) :: time_step
7370 ! Local data
7371   INTEGER :: i, j, k, itf, jtf, ktf
7372   INTEGER :: i_start, i_end, j_start, j_end
7373   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
7374   INTEGER :: jmin, jmax, jp, jm, imin, imax
7375   REAL :: mrdx, mrdy, ub, vb, uw, vw, mu
7376   REAL :: ubd, vbd, mud
7377 !  storage for high and low order fluxes
7378   REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqx, fqy&
7379 &  , fqz
7380   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxd, fqyd, fqzd
7381   REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqxl, &
7382 &  fqyl, fqzl
7383   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxld, fqyld, &
7384 &  fqzld
7385   INTEGER :: horz_order, vert_order
7386   LOGICAL :: degrade_xs, degrade_ys
7387   LOGICAL :: degrade_xe, degrade_ye
7388   INTEGER :: jp1, jp0, jtmp
7389   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_out, ph_low
7390   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_outd, ph_lowd
7391   REAL :: scale
7392   REAL :: scaled
7393   REAL, PARAMETER :: eps=1.e-20
7394 ! definition of flux operators, 3rd, 4th, 5th or 6th order
7395   REAL :: flux3, flux4, flux5, flux6, flux_upwind
7396   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
7397   REAL :: veld, crd
7398 !      flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
7399 !                                    +0.5*(1.-sign(1.,cr))*q_i
7400 !      flux_upwind(q_im1, q_i, cr ) = 0.
7401   REAL :: dx, dy, dz
7402   LOGICAL, PARAMETER :: pd_limit=.true.
7403   REAL :: abs30
7404   REAL :: y93
7405   REAL :: max43
7406   REAL :: abs67
7407   REAL :: abs100
7408   REAL :: abs18d
7409   REAL :: y92
7410   REAL :: max42
7411   REAL :: abs66
7412   REAL :: abs26d
7413   REAL :: max39d
7414   REAL :: y91
7415   REAL :: max41
7416   REAL :: abs65
7417   REAL :: y28d
7418   REAL :: abs34d
7419   REAL :: min5d
7420   REAL :: max10d
7421   REAL :: max47d
7422   REAL :: y90
7423   REAL :: max40
7424   REAL :: abs64
7425   REAL :: abs79d
7426   REAL :: y36d
7427   REAL :: abs42d
7428   REAL :: abs63
7429   REAL :: abs87d
7430   REAL :: y44d
7431   REAL :: abs50d
7432   REAL :: abs62
7433   REAL :: abs99
7434   REAL :: min37d
7435   REAL :: y52d
7436   REAL :: y89d
7437   REAL :: abs95d
7438   REAL :: abs61
7439   REAL :: abs98
7440   REAL :: y4d
7441   REAL :: y60d
7442   REAL :: y97d
7443   INTEGER :: min39
7444   REAL :: abs60
7445   REAL :: abs97
7446   INTEGER :: min9
7447   REAL :: min38
7448   REAL :: abs96
7449   REAL :: abs29d
7450   REAL :: min61d
7451   REAL :: abs102d
7452   INTEGER :: min8
7453   REAL :: min37
7454   REAL :: abs95
7455   REAL :: max13d
7456   REAL :: abs37d
7457   REAL :: min7
7458   REAL :: min36
7459   REAL :: abs94
7460   REAL :: max21d
7461   REAL :: abs1d
7462   REAL :: y39d
7463   REAL :: abs45d
7464   REAL :: min6
7465   INTEGER :: min35
7466   REAL :: y29
7467   REAL :: abs93
7468   REAL :: abs53d
7469   REAL :: y10d
7470   REAL :: y47d
7471   REAL :: min5
7472   INTEGER :: min34
7473   REAL :: y28
7474   REAL :: abs92
7475   REAL :: y55d
7476   REAL :: abs61d
7477   REAL :: abs98d
7478   REAL :: min4
7479   REAL :: min33
7480   REAL :: y27
7481   REAL :: abs91
7482   REAL :: y63d
7483   REAL :: min48d
7484   REAL :: max2d
7485   REAL :: y7d
7486   REAL :: min11d
7487   REAL :: min3
7488   REAL :: min32
7489   REAL :: y26
7490   REAL :: min69
7491   REAL :: abs90
7492   REAL :: y71d
7493   REAL :: min56d
7494   INTEGER :: min2
7495   REAL :: min31
7496   REAL :: y25
7497   REAL :: min68
7498   REAL :: min64d
7499   INTEGER :: min1
7500   INTEGER :: min30
7501   REAL :: y24
7502   REAL :: min67
7503   REAL :: max16d
7504   REAL :: y23
7505   REAL :: min66
7506   REAL :: abs11d
7507   REAL :: max24d
7508   REAL :: abs4d
7509   REAL :: abs48d
7510   REAL :: y22
7511   REAL :: min65
7512   REAL :: y59
7513   REAL :: y13d
7514   REAL :: max32d
7515   REAL :: abs56d
7516   REAL :: y21
7517   REAL :: min64
7518   REAL :: y58
7519   REAL :: abs64d
7520   REAL :: y21d
7521   REAL :: y58d
7522   REAL :: max40d
7523   REAL :: y20
7524   REAL :: min63
7525   REAL :: y57
7526   REAL :: y66d
7527   REAL :: abs72d
7528   REAL :: max5d
7529   REAL :: min14d
7530   REAL :: min62
7531   REAL :: y56
7532   REAL :: y74d
7533   REAL :: abs80d
7534   REAL :: min59d
7535   REAL :: y102d
7536   REAL :: min61
7537   REAL :: y55
7538   REAL :: abs29
7539   REAL :: y82d
7540   REAL :: min67d
7541   REAL :: min60
7542   REAL :: y54
7543   REAL :: abs28
7544   REAL :: max19d
7545   REAL :: y90d
7546   REAL :: min75d
7547   REAL :: y53
7548   REAL :: abs27
7549   REAL :: abs14d
7550   REAL :: max27d
7551   REAL :: abs7d
7552   REAL :: y52
7553   REAL :: abs26
7554   REAL :: y89
7555   REAL :: max39
7556   REAL :: y16d
7557   REAL :: abs22d
7558   REAL :: max35d
7559   REAL :: abs59d
7560   REAL :: y51
7561   REAL :: abs25
7562   REAL :: y88
7563   REAL :: max38
7564   REAL :: abs67d
7565   REAL :: y24d
7566   REAL :: abs30d
7567   REAL :: max43d
7568   REAL :: y50
7569   REAL :: abs24
7570   REAL :: y87
7571   REAL :: max37
7572   REAL :: min17d
7573   REAL :: y69d
7574   REAL :: abs75d
7575   REAL :: y32d
7576   REAL :: max8d
7577   REAL :: max51d
7578   REAL :: abs23
7579   REAL :: y86
7580   REAL :: max36
7581   REAL :: min25d
7582   REAL :: y77d
7583   REAL :: abs83d
7584   REAL :: y40d
7585   REAL :: abs22
7586   REAL :: y85
7587   REAL :: max35
7588   REAL :: abs59
7589   REAL :: min33d
7590   REAL :: y85d
7591   REAL :: abs91d
7592   REAL :: abs21
7593   REAL :: y84
7594   REAL :: max34
7595   REAL :: abs58
7596   REAL :: min41d
7597   REAL :: y93d
7598   REAL :: abs20
7599   REAL :: y83
7600   REAL :: max33
7601   REAL :: abs57
7602   REAL :: abs17d
7603   REAL :: y82
7604   REAL :: max32
7605   REAL :: abs56
7606   REAL :: y19d
7607   REAL :: abs25d
7608   REAL :: max38d
7609   REAL :: y81
7610   REAL :: max31
7611   REAL :: abs55
7612   REAL :: y27d
7613   REAL :: abs33d
7614   REAL :: min4d
7615   REAL :: max46d
7616   REAL :: y80
7617   REAL :: max30
7618   REAL :: abs54
7619   REAL :: abs78d
7620   REAL :: y35d
7621   REAL :: abs41d
7622   REAL :: max54d
7623   REAL :: abs53
7624   REAL :: min28d
7625   REAL :: abs86d
7626   REAL :: y43d
7627   REAL :: abs52
7628   REAL :: abs89
7629   REAL :: min36d
7630   REAL :: y88d
7631   REAL :: abs94d
7632   REAL :: y51d
7633   REAL :: abs51
7634   REAL :: abs88
7635   REAL :: y3d
7636   REAL :: y96d
7637   INTEGER :: min29
7638   REAL :: abs50
7639   REAL :: abs87
7640   REAL :: min52d
7641   REAL :: min28
7642   REAL :: abs86
7643   REAL :: abs28d
7644   REAL :: min60d
7645   REAL :: abs101d
7646   REAL :: min27
7647   REAL :: abs85
7648   REAL :: max12d
7649   REAL :: min7d
7650   REAL :: abs36d
7651   REAL :: max49d
7652   REAL :: min26
7653   REAL :: abs84
7654   REAL :: max20d
7655   REAL :: y38d
7656   REAL :: abs44d
7657   REAL :: min25
7658   REAL :: y19
7659   REAL :: abs83
7660   REAL :: abs52d
7661   REAL :: abs89d
7662   REAL :: y46d
7663   REAL :: min24
7664   REAL :: y18
7665   REAL :: abs82
7666   REAL :: y54d
7667   REAL :: abs60d
7668   REAL :: abs97d
7669   INTEGER :: min23
7670   REAL :: y17
7671   REAL :: abs81
7672   REAL :: y62d
7673   REAL :: min47d
7674   REAL :: y6d
7675   REAL :: min10d
7676   REAL :: y99d
7677   REAL :: max1d
7678   INTEGER :: min22
7679   REAL :: y16
7680   REAL :: min59
7681   REAL :: abs80
7682   REAL :: y70d
7683   REAL :: min55d
7684   REAL :: y15
7685   REAL :: min21
7686   REAL :: min58
7687   REAL :: min63d
7688   REAL :: y14
7689   REAL :: min20
7690   REAL :: min57
7691   REAL :: max15d
7692   REAL :: abs39d
7693   REAL :: min71d
7694   REAL :: y13
7695   REAL :: min56
7696   REAL :: max23d
7697   REAL :: abs3d
7698   REAL :: abs10d
7699   REAL :: abs47d
7700   REAL :: y12
7701   REAL :: min55
7702   REAL :: y49
7703   REAL :: y12d
7704   REAL :: max31d
7705   REAL :: abs55d
7706   REAL :: y49d
7707   REAL :: y11
7708   INTEGER :: min54
7709   REAL :: y48
7710   REAL :: abs63d
7711   REAL :: y20d
7712   REAL :: y57d
7713   REAL :: y10
7714   INTEGER :: min53
7715   REAL :: y47
7716   REAL :: y65d
7717   REAL :: abs71d
7718   REAL :: max4d
7719   REAL :: y9d
7720   REAL :: min13d
7721   REAL :: min52
7722   REAL :: y46
7723   REAL :: min21d
7724   REAL :: y73d
7725   REAL :: min58d
7726   REAL :: y101d
7727   REAL :: min51
7728   REAL :: y45
7729   REAL :: abs19
7730   REAL :: y81d
7731   REAL :: min66d
7732   INTEGER :: min50
7733   REAL :: y44
7734   REAL :: abs18
7735   REAL :: max18d
7736   REAL :: min74d
7737   REAL :: y43
7738   REAL :: abs17
7739   REAL :: abs13d
7740   REAL :: max26d
7741   REAL :: abs6d
7742   REAL :: y42
7743   REAL :: abs16
7744   REAL :: y79
7745   REAL :: max29
7746   REAL :: y15d
7747   REAL :: abs21d
7748   REAL :: max34d
7749   REAL :: abs58d
7750   REAL :: y41
7751   REAL :: abs15
7752   REAL :: y78
7753   REAL :: max28
7754   REAL :: abs66d
7755   REAL :: y23d
7756   REAL :: max42d
7757   REAL :: y40
7758   REAL :: abs14
7759   REAL :: y77
7760   REAL :: max27
7761   REAL :: y68d
7762   REAL :: abs74d
7763   REAL :: y31d
7764   REAL :: max7d
7765   REAL :: max50d
7766   REAL :: abs13
7767   REAL :: y76
7768   REAL :: max26
7769   REAL :: min24d
7770   REAL :: y76d
7771   REAL :: abs82d
7772   REAL :: abs12
7773   REAL :: y75
7774   REAL :: max25
7775   REAL :: abs49
7776   REAL :: min32d
7777   REAL :: y84d
7778   REAL :: abs90d
7779   REAL :: min69d
7780   REAL :: abs11
7781   REAL :: y74
7782   REAL :: max24
7783   REAL :: abs48
7784   REAL :: y102
7785   REAL :: y92d
7786   REAL :: abs10
7787   REAL :: y73
7788   REAL :: max23
7789   REAL :: abs47
7790   REAL :: y101
7791   REAL :: abs16d
7792   REAL :: max29d
7793   REAL :: abs9d
7794   REAL :: y72
7795   REAL :: max22
7796   REAL :: abs46
7797   REAL :: y100
7798   REAL :: y18d
7799   REAL :: abs24d
7800   REAL :: max37d
7801   REAL :: y71
7802   REAL :: max21
7803   REAL :: abs45
7804   REAL :: abs69d
7805   REAL :: y26d
7806   REAL :: abs32d
7807   REAL :: min3d
7808   REAL :: max45d
7809   REAL :: y70
7810   REAL :: max20
7811   REAL :: abs44
7812   REAL :: min19d
7813   REAL :: abs77d
7814   REAL :: y34d
7815   REAL :: abs40d
7816   REAL :: max53d
7817   REAL :: abs43
7818   REAL :: min27d
7819   REAL :: y79d
7820   REAL :: abs85d
7821   REAL :: y42d
7822   REAL :: abs42
7823   REAL :: abs79
7824   REAL :: y87d
7825   REAL :: abs93d
7826   REAL :: y50d
7827   REAL :: abs41
7828   REAL :: abs78
7829   REAL :: max54
7830   REAL :: min43d
7831   REAL :: y2d
7832   REAL :: y95d
7833   REAL :: min19
7834   REAL :: abs40
7835   REAL :: abs77
7836   REAL :: max53
7837   REAL :: abs19d
7838   REAL :: min51d
7839   REAL :: min18
7840   REAL :: max52
7841   REAL :: abs76
7842   REAL :: abs27d
7843   REAL :: abs100d
7844   REAL :: min17
7845   REAL :: max51
7846   REAL :: abs75
7847   REAL :: y29d
7848   REAL :: min6d
7849   REAL :: max11d
7850   REAL :: abs35d
7851   REAL :: max48d
7852   INTEGER :: min16
7853   REAL :: abs9
7854   REAL :: max50
7855   REAL :: abs74
7856   REAL :: y37d
7857   REAL :: abs43d
7858   INTEGER :: min15
7859   REAL :: abs8
7860   REAL :: abs73
7861   REAL :: abs88d
7862   REAL :: y45d
7863   REAL :: abs51d
7864   REAL :: min14
7865   REAL :: abs7
7866   REAL :: abs72
7867   REAL :: min38d
7868   REAL :: y53d
7869   REAL :: abs96d
7870   REAL :: min13
7871   REAL :: abs6
7872   REAL :: abs71
7873   REAL :: min46d
7874   REAL :: y5d
7875   REAL :: y61d
7876   REAL :: y98d
7877   REAL :: min12
7878   INTEGER :: min49
7879   REAL :: abs5
7880   REAL :: abs70
7881   REAL :: min11
7882   REAL :: min48
7883   REAL :: abs4
7884   REAL :: min62d
7885   REAL :: min10
7886   REAL :: min47
7887   REAL :: abs3
7888   REAL :: max14d
7889   REAL :: abs38d
7890   REAL :: min70d
7891   REAL :: min46
7892   REAL :: abs2
7893   REAL :: max22d
7894   REAL :: abs2d
7895   REAL :: abs46d
7896   INTEGER :: min45
7897   REAL :: y39
7898   REAL :: abs1
7899   REAL :: y11d
7900   REAL :: max30d
7901   REAL :: abs54d
7902   REAL :: y48d
7903   INTEGER :: min44
7904   REAL :: y38
7905   REAL :: abs62d
7906   REAL :: y56d
7907   REAL :: abs99d
7908   REAL :: min43
7909   REAL :: y37
7910   REAL :: y64d
7911   REAL :: abs70d
7912   REAL :: max3d
7913   REAL :: y8d
7914   REAL :: min12d
7915   REAL :: min42
7916   REAL :: y36
7917   REAL :: min20d
7918   REAL :: y72d
7919   REAL :: min57d
7920   REAL :: y100d
7921   REAL :: min41
7922   REAL :: y35
7923   REAL :: y80d
7924   REAL :: min65d
7925   INTEGER :: min40
7926   REAL :: y34
7927   REAL :: max17d
7928   REAL :: y33
7929   REAL :: max9
7930   REAL :: min76
7931   REAL :: abs12d
7932   REAL :: max25d
7933   REAL :: abs5d
7934   REAL :: abs49d
7935   REAL :: y32
7936   REAL :: max8
7937   REAL :: y69
7938   REAL :: max19
7939   REAL :: min75
7940   REAL :: y14d
7941   REAL :: abs20d
7942   REAL :: max33d
7943   REAL :: abs57d
7944   REAL :: y31
7945   REAL :: max7
7946   REAL :: y68
7947   REAL :: max18
7948   REAL :: min74
7949   REAL :: abs65d
7950   REAL :: y22d
7951   REAL :: y59d
7952   REAL :: max41d
7953   REAL :: y30
7954   INTEGER :: min73
7955   REAL :: max6
7956   REAL :: y67
7957   REAL :: max17
7958   REAL :: y67d
7959   REAL :: abs73d
7960   REAL :: y30d
7961   REAL :: max6d
7962   INTEGER :: min72
7963   REAL :: max5
7964   REAL :: y66
7965   REAL :: max16
7966   REAL :: y75d
7967   REAL :: abs81d
7968   REAL :: y9
7969   REAL :: min71
7970   REAL :: max4
7971   REAL :: y65
7972   REAL :: max15
7973   REAL :: abs39
7974   REAL :: min31d
7975   REAL :: y83d
7976   REAL :: min68d
7977   REAL :: y8
7978   REAL :: min70
7979   REAL :: max3
7980   REAL :: y64
7981   REAL :: max14
7982   REAL :: abs38
7983   REAL :: y91d
7984   REAL :: min76d
7985   REAL :: y7
7986   REAL :: max2
7987   REAL :: y63
7988   REAL :: max13
7989   REAL :: abs37
7990   REAL :: abs15d
7991   REAL :: max28d
7992   REAL :: abs8d
7993   REAL :: y6
7994   REAL :: max1
7995   REAL :: y62
7996   REAL :: max12
7997   REAL :: abs36
7998   REAL :: y99
7999   REAL :: max49
8000   REAL :: y17d
8001   REAL :: abs23d
8002   REAL :: max36d
8003   REAL :: y5
8004   REAL :: y61
8005   REAL :: max11
8006   REAL :: abs35
8007   REAL :: y98
8008   REAL :: max48
8009   REAL :: abs68d
8010   REAL :: y25d
8011   REAL :: abs31d
8012   REAL :: max44d
8013   REAL :: y4
8014   REAL :: y60
8015   REAL :: max10
8016   REAL :: abs34
8017   REAL :: y97
8018   REAL :: max47
8019   REAL :: min18d
8020   REAL :: abs76d
8021   REAL :: y33d
8022   REAL :: max9d
8023   REAL :: max52d
8024   REAL :: y3
8025   REAL :: abs33
8026   REAL :: y96
8027   REAL :: max46
8028   REAL :: min26d
8029   REAL :: y78d
8030   REAL :: abs84d
8031   REAL :: y41d
8032   REAL :: y2
8033   REAL :: abs32
8034   REAL :: y95
8035   REAL :: max45
8036   REAL :: abs69
8037   REAL :: abs102
8038   REAL :: y86d
8039   REAL :: abs92d
8040   REAL :: y1
8041   REAL :: abs31
8042   REAL :: y94
8043   REAL :: max44
8044   REAL :: abs68
8045   REAL :: abs101
8046   REAL :: min42d
8047   REAL :: y1d
8048   REAL :: y94d
8049
8050
8051
8052
8053
8054 ! set order for the advection schemes
8055 !  write(6,*) ' in pd advection routine '
8056 ! Empty arrays just in case:
8057   IF (config_flags%polar) THEN
8058     fqx(:, :, :) = 0.
8059     fqy(:, :, :) = 0.
8060     fqz(:, :, :) = 0.
8061     fqxl(:, :, :) = 0.
8062     fqyl(:, :, :) = 0.
8063     fqzl(:, :, :) = 0.
8064   END IF
8065   IF (kte .GT. kde - 1) THEN
8066     ktf = kde - 1
8067   ELSE
8068     ktf = kte
8069   END IF
8070   horz_order = config_flags%h_sca_adv_order
8071   vert_order = config_flags%v_sca_adv_order
8072 !  determine boundary mods for flux operators
8073 !  We degrade the flux operators from 3rd/4th order
8074 !   to second order one gridpoint in from the boundaries for
8075 !   all boundary conditions except periodic and symmetry - these
8076 !   conditions have boundary zone data fill for correct application
8077 !   of the higher order flux stencils
8078   degrade_xs = .true.
8079   degrade_xe = .true.
8080   degrade_ys = .true.
8081   degrade_ye = .true.
8082 !  begin with horizontal flux divergence
8083 !  here is the choice of flux operators
8084   IF (horz_order .EQ. 6) THEN
8085     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
8086 &        its .GT. ids + 3) degrade_xs = .false.
8087     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
8088 &        ite .LT. ide - 4) degrade_xe = .false.
8089     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
8090 &        jts .GT. jds + 3) degrade_ys = .false.
8091     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
8092 &        jte .LT. jde - 4) degrade_ye = .false.
8093     IF (kte .GT. kde - 1) THEN
8094       ktf = kde - 1
8095     ELSE
8096       ktf = kte
8097     END IF
8098     i_start = its - 1
8099     IF (ite .GT. ide - 1) THEN
8100       min1 = ide - 1
8101     ELSE
8102       min1 = ite
8103     END IF
8104     i_end = min1 + 1
8105     j_start = jts - 1
8106     IF (jte .GT. jde - 1) THEN
8107       min2 = jde - 1
8108     ELSE
8109       min2 = jte
8110     END IF
8111     j_end = min2 + 1
8112     j_start_f = j_start
8113     j_end_f = j_end + 1
8114 !--  modify loop bounds if open or specified
8115 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
8116 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
8117     IF (degrade_xs) THEN
8118       IF (its - 1 .LT. ids) THEN
8119         i_start = ids
8120       ELSE
8121         i_start = its - 1
8122       END IF
8123     END IF
8124     IF (degrade_xe) THEN
8125       IF (ite + 1 .GT. ide - 1) THEN
8126         i_end = ide - 1
8127       ELSE
8128         i_end = ite + 1
8129       END IF
8130     END IF
8131     IF (degrade_ys) THEN
8132       IF (jts - 1 .LT. jds + 1) THEN
8133         j_start = jds + 1
8134       ELSE
8135         j_start = jts - 1
8136       END IF
8137       j_start_f = jds + 3
8138     END IF
8139     IF (degrade_ye) THEN
8140       IF (jte + 1 .GT. jde - 2) THEN
8141         j_end = jde - 2
8142       ELSE
8143         j_end = jte + 1
8144       END IF
8145       j_end_f = jde - 3
8146       fqyld = 0.0
8147       fqyd = 0.0
8148     ELSE
8149       fqyld = 0.0
8150       fqyd = 0.0
8151     END IF
8152 !  compute fluxes, 6th order
8153 j_loop_y_flux_6:DO j=j_start,j_end+1
8154       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
8155 ! use full stencil
8156         DO k=kts,ktf
8157           DO i=i_start,i_end
8158 ! ADT eqn 48 d/dy
8159             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
8160             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
8161             mu = 0.5*(mut(i, j)+mut(i, j-1))
8162             veld = rvd(i, k, j)
8163             vel = rv(i, k, j)
8164             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
8165             cr = vel*dt/dy/mu
8166             IF (cr .GE. 0.) THEN
8167               abs1d = crd
8168               abs1 = cr
8169             ELSE
8170               abs1d = -crd
8171               abs1 = -cr
8172             END IF
8173             y1d = crd + abs1d
8174             y1 = cr + abs1
8175             IF (1.0 .GT. y1) THEN
8176               min3d = y1d
8177               min3 = y1
8178             ELSE
8179               min3 = 1.0
8180               min3d = 0.0
8181             END IF
8182             IF (cr .GE. 0.) THEN
8183               abs52d = crd
8184               abs52 = cr
8185             ELSE
8186               abs52d = -crd
8187               abs52 = -cr
8188             END IF
8189             y52d = crd - abs52d
8190             y52 = cr - abs52
8191             IF (-1.0 .LT. y52) THEN
8192               max2d = y52d
8193               max2 = y52
8194             ELSE
8195               max2 = -1.0
8196               max2d = 0.0
8197             END IF
8198             fqyld(i, k, j) = dy*(mud*(0.5*min3*field_old(i, k, j-1)+0.5*&
8199 &              max2*field_old(i, k, j))+mu*(0.5*(min3d*field_old(i, k, j-&
8200 &              1)+min3*field_oldd(i, k, j-1))+0.5*(max2d*field_old(i, k, &
8201 &              j)+max2*field_oldd(i, k, j))))/dt
8202             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min3*field_old(i, k, j-1)+&
8203 &              0.5*max2*field_old(i, k, j))
8204             fqyd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i, k, j-&
8205 &              1))-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(&
8206 &              field(i, k, j+2)+field(i, k, j-3))) + vel*(37.*(fieldd(i, &
8207 &              k, j)+fieldd(i, k, j-1))/60.-2.*(fieldd(i, k, j+1)+fieldd(&
8208 &              i, k, j-2))/15.+(fieldd(i, k, j+2)+fieldd(i, k, j-3))/60.)
8209             fqy(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k, j-1)&
8210 &              )-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(field&
8211 &              (i, k, j+2)+field(i, k, j-3)))
8212             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
8213             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
8214           END DO
8215         END DO
8216       ELSE IF (j .EQ. jds + 1) THEN
8217 ! 2nd order flux next to south boundary
8218         DO k=kts,ktf
8219           DO i=i_start,i_end
8220 ! ADT eqn 48 d/dy
8221             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
8222             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
8223             mu = 0.5*(mut(i, j)+mut(i, j-1))
8224             veld = rvd(i, k, j)
8225             vel = rv(i, k, j)
8226             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
8227             cr = vel*dt/dy/mu
8228             IF (cr .GE. 0.) THEN
8229               abs2d = crd
8230               abs2 = cr
8231             ELSE
8232               abs2d = -crd
8233               abs2 = -cr
8234             END IF
8235             y2d = crd + abs2d
8236             y2 = cr + abs2
8237             IF (1.0 .GT. y2) THEN
8238               min4d = y2d
8239               min4 = y2
8240             ELSE
8241               min4 = 1.0
8242               min4d = 0.0
8243             END IF
8244             IF (cr .GE. 0.) THEN
8245               abs53d = crd
8246               abs53 = cr
8247             ELSE
8248               abs53d = -crd
8249               abs53 = -cr
8250             END IF
8251             y53d = crd - abs53d
8252             y53 = cr - abs53
8253             IF (-1.0 .LT. y53) THEN
8254               max3d = y53d
8255               max3 = y53
8256             ELSE
8257               max3 = -1.0
8258               max3d = 0.0
8259             END IF
8260             fqyld(i, k, j) = dy*(mud*(0.5*min4*field_old(i, k, j-1)+0.5*&
8261 &              max3*field_old(i, k, j))+mu*(0.5*(min4d*field_old(i, k, j-&
8262 &              1)+min4*field_oldd(i, k, j-1))+0.5*(max3d*field_old(i, k, &
8263 &              j)+max3*field_oldd(i, k, j))))/dt
8264             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min4*field_old(i, k, j-1)+&
8265 &              0.5*max3*field_old(i, k, j))
8266             fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
8267 &              , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
8268             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
8269 &              -1))
8270             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
8271             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
8272           END DO
8273         END DO
8274       ELSE IF (j .EQ. jds + 2) THEN
8275 ! third of 4th order flux 2 in from south boundary
8276         DO k=kts,ktf
8277           DO i=i_start,i_end
8278 ! ADT eqn 48 d/dy
8279             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
8280             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
8281             mu = 0.5*(mut(i, j)+mut(i, j-1))
8282             veld = rvd(i, k, j)
8283             vel = rv(i, k, j)
8284             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
8285             cr = vel*dt/dy/mu
8286             IF (cr .GE. 0.) THEN
8287               abs3d = crd
8288               abs3 = cr
8289             ELSE
8290               abs3d = -crd
8291               abs3 = -cr
8292             END IF
8293             y3d = crd + abs3d
8294             y3 = cr + abs3
8295             IF (1.0 .GT. y3) THEN
8296               min5d = y3d
8297               min5 = y3
8298             ELSE
8299               min5 = 1.0
8300               min5d = 0.0
8301             END IF
8302             IF (cr .GE. 0.) THEN
8303               abs54d = crd
8304               abs54 = cr
8305             ELSE
8306               abs54d = -crd
8307               abs54 = -cr
8308             END IF
8309             y54d = crd - abs54d
8310             y54 = cr - abs54
8311             IF (-1.0 .LT. y54) THEN
8312               max4d = y54d
8313               max4 = y54
8314             ELSE
8315               max4 = -1.0
8316               max4d = 0.0
8317             END IF
8318             fqyld(i, k, j) = dy*(mud*(0.5*min5*field_old(i, k, j-1)+0.5*&
8319 &              max4*field_old(i, k, j))+mu*(0.5*(min5d*field_old(i, k, j-&
8320 &              1)+min5*field_oldd(i, k, j-1))+0.5*(max4d*field_old(i, k, &
8321 &              j)+max4*field_oldd(i, k, j))))/dt
8322             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min5*field_old(i, k, j-1)+&
8323 &              0.5*max4*field_old(i, k, j))
8324             fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
8325 &              ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))) + vel*(7.*(&
8326 &              fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+&
8327 &              fieldd(i, k, j-2))/12.)
8328             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
8329 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2)))
8330             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
8331             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
8332           END DO
8333         END DO
8334       ELSE IF (j .EQ. jde - 1) THEN
8335 ! 2nd order flux next to north boundary
8336         DO k=kts,ktf
8337           DO i=i_start,i_end
8338 ! ADT eqn 48 d/dy
8339             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
8340             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
8341             mu = 0.5*(mut(i, j)+mut(i, j-1))
8342             veld = rvd(i, k, j)
8343             vel = rv(i, k, j)
8344             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
8345             cr = vel*dt/dy/mu
8346             IF (cr .GE. 0.) THEN
8347               abs4d = crd
8348               abs4 = cr
8349             ELSE
8350               abs4d = -crd
8351               abs4 = -cr
8352             END IF
8353             y4d = crd + abs4d
8354             y4 = cr + abs4
8355             IF (1.0 .GT. y4) THEN
8356               min6d = y4d
8357               min6 = y4
8358             ELSE
8359               min6 = 1.0
8360               min6d = 0.0
8361             END IF
8362             IF (cr .GE. 0.) THEN
8363               abs55d = crd
8364               abs55 = cr
8365             ELSE
8366               abs55d = -crd
8367               abs55 = -cr
8368             END IF
8369             y55d = crd - abs55d
8370             y55 = cr - abs55
8371             IF (-1.0 .LT. y55) THEN
8372               max5d = y55d
8373               max5 = y55
8374             ELSE
8375               max5 = -1.0
8376               max5d = 0.0
8377             END IF
8378             fqyld(i, k, j) = dy*(mud*(0.5*min6*field_old(i, k, j-1)+0.5*&
8379 &              max5*field_old(i, k, j))+mu*(0.5*(min6d*field_old(i, k, j-&
8380 &              1)+min6*field_oldd(i, k, j-1))+0.5*(max5d*field_old(i, k, &
8381 &              j)+max5*field_oldd(i, k, j))))/dt
8382             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min6*field_old(i, k, j-1)+&
8383 &              0.5*max5*field_old(i, k, j))
8384             fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
8385 &              , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
8386             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
8387 &              -1))
8388             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
8389             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
8390           END DO
8391         END DO
8392       ELSE IF (j .EQ. jde - 2) THEN
8393 ! 3rd or 4th order flux 2 in from north boundary
8394         DO k=kts,ktf
8395           DO i=i_start,i_end
8396 ! ADT eqn 48 d/dy
8397             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
8398             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
8399             mu = 0.5*(mut(i, j)+mut(i, j-1))
8400             veld = rvd(i, k, j)
8401             vel = rv(i, k, j)
8402             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
8403             cr = vel*dt/dy/mu
8404             IF (cr .GE. 0.) THEN
8405               abs5d = crd
8406               abs5 = cr
8407             ELSE
8408               abs5d = -crd
8409               abs5 = -cr
8410             END IF
8411             y5d = crd + abs5d
8412             y5 = cr + abs5
8413             IF (1.0 .GT. y5) THEN
8414               min7d = y5d
8415               min7 = y5
8416             ELSE
8417               min7 = 1.0
8418               min7d = 0.0
8419             END IF
8420             IF (cr .GE. 0.) THEN
8421               abs56d = crd
8422               abs56 = cr
8423             ELSE
8424               abs56d = -crd
8425               abs56 = -cr
8426             END IF
8427             y56d = crd - abs56d
8428             y56 = cr - abs56
8429             IF (-1.0 .LT. y56) THEN
8430               max6d = y56d
8431               max6 = y56
8432             ELSE
8433               max6 = -1.0
8434               max6d = 0.0
8435             END IF
8436             fqyld(i, k, j) = dy*(mud*(0.5*min7*field_old(i, k, j-1)+0.5*&
8437 &              max6*field_old(i, k, j))+mu*(0.5*(min7d*field_old(i, k, j-&
8438 &              1)+min7*field_oldd(i, k, j-1))+0.5*(max6d*field_old(i, k, &
8439 &              j)+max6*field_oldd(i, k, j))))/dt
8440             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min7*field_old(i, k, j-1)+&
8441 &              0.5*max6*field_old(i, k, j))
8442             fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
8443 &              ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))) + vel*(7.*(&
8444 &              fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+&
8445 &              fieldd(i, k, j-2))/12.)
8446             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
8447 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2)))
8448             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
8449             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
8450           END DO
8451         END DO
8452       END IF
8453     END DO j_loop_y_flux_6
8454 !  next, x flux
8455 !--  these bounds are for periodic and sym conditions
8456     i_start = its - 1
8457     IF (ite .GT. ide - 1) THEN
8458       min8 = ide - 1
8459     ELSE
8460       min8 = ite
8461     END IF
8462     i_end = min8 + 1
8463     i_start_f = i_start
8464     i_end_f = i_end + 1
8465     j_start = jts - 1
8466     IF (jte .GT. jde - 1) THEN
8467       min9 = jde - 1
8468     ELSE
8469       min9 = jte
8470     END IF
8471     j_end = min9 + 1
8472 !--  modify loop bounds for open and specified b.c
8473 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
8474 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
8475     IF (degrade_ys) THEN
8476       IF (jts - 1 .LT. jds) THEN
8477         j_start = jds
8478       ELSE
8479         j_start = jts - 1
8480       END IF
8481     END IF
8482     IF (degrade_ye) THEN
8483       IF (jte + 1 .GT. jde - 1) THEN
8484         j_end = jde - 1
8485       ELSE
8486         j_end = jte + 1
8487       END IF
8488     END IF
8489     IF (degrade_xs) THEN
8490       IF (ids + 1 .LT. its - 1) THEN
8491         i_start = its - 1
8492       ELSE
8493         i_start = ids + 1
8494       END IF
8495       i_start_f = ids + 3
8496     END IF
8497     IF (degrade_xe) THEN
8498       IF (ide - 2 .GT. ite + 1) THEN
8499         i_end = ite + 1
8500       ELSE
8501         i_end = ide - 2
8502       END IF
8503       i_end_f = ide - 3
8504       fqxld = 0.0
8505       fqxd = 0.0
8506     ELSE
8507       fqxld = 0.0
8508       fqxd = 0.0
8509     END IF
8510 !  compute fluxes
8511     DO j=j_start,j_end
8512 !  5th order flux
8513       DO k=kts,ktf
8514         DO i=i_start_f,i_end_f
8515 ! ADT eqn 48 d/dx
8516           dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
8517           mud = 0.5*(mutd(i, j)+mutd(i-1, j))
8518           mu = 0.5*(mut(i, j)+mut(i-1, j))
8519           veld = rud(i, k, j)
8520           vel = ru(i, k, j)
8521           crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
8522           cr = vel*dt/dx/mu
8523           IF (cr .GE. 0.) THEN
8524             abs6d = crd
8525             abs6 = cr
8526           ELSE
8527             abs6d = -crd
8528             abs6 = -cr
8529           END IF
8530           y6d = crd + abs6d
8531           y6 = cr + abs6
8532           IF (1.0 .GT. y6) THEN
8533             min10d = y6d
8534             min10 = y6
8535           ELSE
8536             min10 = 1.0
8537             min10d = 0.0
8538           END IF
8539           IF (cr .GE. 0.) THEN
8540             abs57d = crd
8541             abs57 = cr
8542           ELSE
8543             abs57d = -crd
8544             abs57 = -cr
8545           END IF
8546           y57d = crd - abs57d
8547           y57 = cr - abs57
8548           IF (-1.0 .LT. y57) THEN
8549             max7d = y57d
8550             max7 = y57
8551           ELSE
8552             max7 = -1.0
8553             max7d = 0.0
8554           END IF
8555           fqxld(i, k, j) = dx*(mud*(0.5*min10*field_old(i-1, k, j)+0.5*&
8556 &            max7*field_old(i, k, j))+mu*(0.5*(min10d*field_old(i-1, k, j&
8557 &            )+min10*field_oldd(i-1, k, j))+0.5*(max7d*field_old(i, k, j)&
8558 &            +max7*field_oldd(i, k, j))))/dt
8559           fqxl(i, k, j) = mu*(dx/dt)*(0.5*min10*field_old(i-1, k, j)+0.5&
8560 &            *max7*field_old(i, k, j))
8561           fqxd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i-1, k, j)&
8562 &            )-2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i&
8563 &            +2, k, j)+field(i-3, k, j))) + vel*(37.*(fieldd(i, k, j)+&
8564 &            fieldd(i-1, k, j))/60.-2.*(fieldd(i+1, k, j)+fieldd(i-2, k, &
8565 &            j))/15.+(fieldd(i+2, k, j)+fieldd(i-3, k, j))/60.)
8566           fqx(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i-1, k, j))-&
8567 &            2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i+2&
8568 &            , k, j)+field(i-3, k, j)))
8569           fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
8570           fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
8571         END DO
8572       END DO
8573 !  lower order fluxes close to boundaries (if not periodic or symmetric)
8574       IF (degrade_xs) THEN
8575         DO i=i_start,i_start_f-1
8576           IF (i .EQ. ids + 1) THEN
8577 ! second order
8578             DO k=kts,ktf
8579 ! ADT eqn 48 d/dx
8580               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
8581               mud = 0.5*(mutd(i, j)+mutd(i-1, j))
8582               mu = 0.5*(mut(i, j)+mut(i-1, j))
8583               veld = (rud(i, k, j)*mu-ru(i, k, j)*mud)/mu**2
8584               vel = ru(i, k, j)/mu
8585               crd = dt*veld/dx
8586               cr = vel*dt/dx
8587               IF (cr .GE. 0.) THEN
8588                 abs7d = crd
8589                 abs7 = cr
8590               ELSE
8591                 abs7d = -crd
8592                 abs7 = -cr
8593               END IF
8594               y7d = crd + abs7d
8595               y7 = cr + abs7
8596               IF (1.0 .GT. y7) THEN
8597                 min11d = y7d
8598                 min11 = y7
8599               ELSE
8600                 min11 = 1.0
8601                 min11d = 0.0
8602               END IF
8603               IF (cr .GE. 0.) THEN
8604                 abs58d = crd
8605                 abs58 = cr
8606               ELSE
8607                 abs58d = -crd
8608                 abs58 = -cr
8609               END IF
8610               y58d = crd - abs58d
8611               y58 = cr - abs58
8612               IF (-1.0 .LT. y58) THEN
8613                 max8d = y58d
8614                 max8 = y58
8615               ELSE
8616                 max8 = -1.0
8617                 max8d = 0.0
8618               END IF
8619               fqxld(i, k, j) = dx*(mud*(0.5*min11*field_old(i-1, k, j)+&
8620 &                0.5*max8*field_old(i, k, j))+mu*(0.5*(min11d*field_old(i&
8621 &                -1, k, j)+min11*field_oldd(i-1, k, j))+0.5*(max8d*&
8622 &                field_old(i, k, j)+max8*field_oldd(i, k, j))))/dt
8623               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min11*field_old(i-1, k, j)&
8624 &                +0.5*max8*field_old(i, k, j))
8625               fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-&
8626 &                1, k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)&
8627 &                ))
8628               fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
8629 &                k, j))
8630               fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
8631               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
8632             END DO
8633           END IF
8634           IF (i .EQ. ids + 2) THEN
8635 ! fourth order
8636             DO k=kts,ktf
8637 ! ADT eqn 48 d/dx
8638               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
8639               mud = 0.5*(mutd(i, j)+mutd(i-1, j))
8640               mu = 0.5*(mut(i, j)+mut(i-1, j))
8641               veld = rud(i, k, j)
8642               vel = ru(i, k, j)
8643               crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
8644               cr = vel*dt/dx/mu
8645               IF (cr .GE. 0.) THEN
8646                 abs8d = crd
8647                 abs8 = cr
8648               ELSE
8649                 abs8d = -crd
8650                 abs8 = -cr
8651               END IF
8652               y8d = crd + abs8d
8653               y8 = cr + abs8
8654               IF (1.0 .GT. y8) THEN
8655                 min12d = y8d
8656                 min12 = y8
8657               ELSE
8658                 min12 = 1.0
8659                 min12d = 0.0
8660               END IF
8661               IF (cr .GE. 0.) THEN
8662                 abs59d = crd
8663                 abs59 = cr
8664               ELSE
8665                 abs59d = -crd
8666                 abs59 = -cr
8667               END IF
8668               y59d = crd - abs59d
8669               y59 = cr - abs59
8670               IF (-1.0 .LT. y59) THEN
8671                 max9d = y59d
8672                 max9 = y59
8673               ELSE
8674                 max9 = -1.0
8675                 max9d = 0.0
8676               END IF
8677               fqxld(i, k, j) = dx*(mud*(0.5*min12*field_old(i-1, k, j)+&
8678 &                0.5*max9*field_old(i, k, j))+mu*(0.5*(min12d*field_old(i&
8679 &                -1, k, j)+min12*field_oldd(i-1, k, j))+0.5*(max9d*&
8680 &                field_old(i, k, j)+max9*field_oldd(i, k, j))))/dt
8681               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min12*field_old(i-1, k, j)&
8682 &                +0.5*max9*field_old(i, k, j))
8683               fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k&
8684 &                , j))-1./12.*(field(i+1, k, j)+field(i-2, k, j))) + vel*&
8685 &                (7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1&
8686 &                , k, j)+fieldd(i-2, k, j))/12.)
8687               fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
8688 &                ))-1./12.*(field(i+1, k, j)+field(i-2, k, j)))
8689               fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
8690               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
8691             END DO
8692           END IF
8693         END DO
8694       END IF
8695       IF (degrade_xe) THEN
8696         DO i=i_end_f+1,i_end+1
8697           IF (i .EQ. ide - 1) THEN
8698 ! second order flux next to the boundary
8699             DO k=kts,ktf
8700 ! ADT eqn 48 d/dx
8701               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
8702               mud = 0.5*(mutd(i, j)+mutd(i-1, j))
8703               mu = 0.5*(mut(i, j)+mut(i-1, j))
8704               veld = rud(i, k, j)
8705               vel = ru(i, k, j)
8706               crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
8707               cr = vel*dt/dx/mu
8708               IF (cr .GE. 0.) THEN
8709                 abs9d = crd
8710                 abs9 = cr
8711               ELSE
8712                 abs9d = -crd
8713                 abs9 = -cr
8714               END IF
8715               y9d = crd + abs9d
8716               y9 = cr + abs9
8717               IF (1.0 .GT. y9) THEN
8718                 min13d = y9d
8719                 min13 = y9
8720               ELSE
8721                 min13 = 1.0
8722                 min13d = 0.0
8723               END IF
8724               IF (cr .GE. 0.) THEN
8725                 abs60d = crd
8726                 abs60 = cr
8727               ELSE
8728                 abs60d = -crd
8729                 abs60 = -cr
8730               END IF
8731               y60d = crd - abs60d
8732               y60 = cr - abs60
8733               IF (-1.0 .LT. y60) THEN
8734                 max10d = y60d
8735                 max10 = y60
8736               ELSE
8737                 max10 = -1.0
8738                 max10d = 0.0
8739               END IF
8740               fqxld(i, k, j) = dx*(mud*(0.5*min13*field_old(i-1, k, j)+&
8741 &                0.5*max10*field_old(i, k, j))+mu*(0.5*(min13d*field_old(&
8742 &                i-1, k, j)+min13*field_oldd(i-1, k, j))+0.5*(max10d*&
8743 &                field_old(i, k, j)+max10*field_oldd(i, k, j))))/dt
8744               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min13*field_old(i-1, k, j)&
8745 &                +0.5*max10*field_old(i, k, j))
8746               fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-&
8747 &                1, k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)&
8748 &                ))
8749               fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
8750 &                k, j))
8751               fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
8752               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
8753             END DO
8754           END IF
8755           IF (i .EQ. ide - 2) THEN
8756 ! fourth order flux one in from the boundary
8757             DO k=kts,ktf
8758 ! ADT eqn 48 d/dx
8759               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
8760               mud = 0.5*(mutd(i, j)+mutd(i-1, j))
8761               mu = 0.5*(mut(i, j)+mut(i-1, j))
8762               veld = rud(i, k, j)
8763               vel = ru(i, k, j)
8764               crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
8765               cr = vel*dt/dx/mu
8766               IF (cr .GE. 0.) THEN
8767                 abs10d = crd
8768                 abs10 = cr
8769               ELSE
8770                 abs10d = -crd
8771                 abs10 = -cr
8772               END IF
8773               y10d = crd + abs10d
8774               y10 = cr + abs10
8775               IF (1.0 .GT. y10) THEN
8776                 min14d = y10d
8777                 min14 = y10
8778               ELSE
8779                 min14 = 1.0
8780                 min14d = 0.0
8781               END IF
8782               IF (cr .GE. 0.) THEN
8783                 abs61d = crd
8784                 abs61 = cr
8785               ELSE
8786                 abs61d = -crd
8787                 abs61 = -cr
8788               END IF
8789               y61d = crd - abs61d
8790               y61 = cr - abs61
8791               IF (-1.0 .LT. y61) THEN
8792                 max11d = y61d
8793                 max11 = y61
8794               ELSE
8795                 max11 = -1.0
8796                 max11d = 0.0
8797               END IF
8798               fqxld(i, k, j) = dx*(mud*(0.5*min14*field_old(i-1, k, j)+&
8799 &                0.5*max11*field_old(i, k, j))+mu*(0.5*(min14d*field_old(&
8800 &                i-1, k, j)+min14*field_oldd(i-1, k, j))+0.5*(max11d*&
8801 &                field_old(i, k, j)+max11*field_oldd(i, k, j))))/dt
8802               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min14*field_old(i-1, k, j)&
8803 &                +0.5*max11*field_old(i, k, j))
8804               fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k&
8805 &                , j))-1./12.*(field(i+1, k, j)+field(i-2, k, j))) + vel*&
8806 &                (7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1&
8807 &                , k, j)+fieldd(i-2, k, j))/12.)
8808               fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
8809 &                ))-1./12.*(field(i+1, k, j)+field(i-2, k, j)))
8810               fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
8811               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
8812             END DO
8813           END IF
8814         END DO
8815       END IF
8816     END DO
8817   ELSE IF (horz_order .EQ. 5) THEN
8818 ! enddo for outer J loop
8819 !--- end of 6th order horizontal flux calculation
8820     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
8821 &        its .GT. ids + 3) degrade_xs = .false.
8822     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
8823 &        ite .LT. ide - 4) degrade_xe = .false.
8824     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
8825 &        jts .GT. jds + 3) degrade_ys = .false.
8826     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
8827 &        jte .LT. jde - 4) degrade_ye = .false.
8828     IF (kte .GT. kde - 1) THEN
8829       ktf = kde - 1
8830     ELSE
8831       ktf = kte
8832     END IF
8833     i_start = its - 1
8834     IF (ite .GT. ide - 1) THEN
8835       min15 = ide - 1
8836     ELSE
8837       min15 = ite
8838     END IF
8839     i_end = min15 + 1
8840     j_start = jts - 1
8841     IF (jte .GT. jde - 1) THEN
8842       min16 = jde - 1
8843     ELSE
8844       min16 = jte
8845     END IF
8846     j_end = min16 + 1
8847     j_start_f = j_start
8848     j_end_f = j_end + 1
8849 !--  modify loop bounds if open or specified
8850 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
8851 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
8852     IF (degrade_xs) THEN
8853       IF (its - 1 .LT. ids) THEN
8854         i_start = ids
8855       ELSE
8856         i_start = its - 1
8857       END IF
8858     END IF
8859     IF (degrade_xe) THEN
8860       IF (ite + 1 .GT. ide - 1) THEN
8861         i_end = ide - 1
8862       ELSE
8863         i_end = ite + 1
8864       END IF
8865     END IF
8866     IF (degrade_ys) THEN
8867       IF (jts - 1 .LT. jds + 1) THEN
8868         j_start = jds + 1
8869       ELSE
8870         j_start = jts - 1
8871       END IF
8872       j_start_f = jds + 3
8873     END IF
8874     IF (degrade_ye) THEN
8875       IF (jte + 1 .GT. jde - 2) THEN
8876         j_end = jde - 2
8877       ELSE
8878         j_end = jte + 1
8879       END IF
8880       j_end_f = jde - 3
8881       fqyld = 0.0
8882       fqyd = 0.0
8883     ELSE
8884       fqyld = 0.0
8885       fqyd = 0.0
8886     END IF
8887 !  compute fluxes, 5th order
8888 j_loop_y_flux_5:DO j=j_start,j_end+1
8889       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
8890 ! use full stencil
8891         DO k=kts,ktf
8892           DO i=i_start,i_end
8893 ! ADT eqn 48 d/dy
8894             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
8895             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
8896             mu = 0.5*(mut(i, j)+mut(i, j-1))
8897             veld = rvd(i, k, j)
8898             vel = rv(i, k, j)
8899             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
8900             cr = vel*dt/dy/mu
8901             IF (cr .GE. 0.) THEN
8902               abs11d = crd
8903               abs11 = cr
8904             ELSE
8905               abs11d = -crd
8906               abs11 = -cr
8907             END IF
8908             y11d = crd + abs11d
8909             y11 = cr + abs11
8910             IF (1.0 .GT. y11) THEN
8911               min17d = y11d
8912               min17 = y11
8913             ELSE
8914               min17 = 1.0
8915               min17d = 0.0
8916             END IF
8917             IF (cr .GE. 0.) THEN
8918               abs62d = crd
8919               abs62 = cr
8920             ELSE
8921               abs62d = -crd
8922               abs62 = -cr
8923             END IF
8924             y62d = crd - abs62d
8925             y62 = cr - abs62
8926             IF (-1.0 .LT. y62) THEN
8927               max12d = y62d
8928               max12 = y62
8929             ELSE
8930               max12 = -1.0
8931               max12d = 0.0
8932             END IF
8933             fqyld(i, k, j) = dy*(mud*(0.5*min17*field_old(i, k, j-1)+0.5&
8934 &              *max12*field_old(i, k, j))+mu*(0.5*(min17d*field_old(i, k&
8935 &              , j-1)+min17*field_oldd(i, k, j-1))+0.5*(max12d*field_old(&
8936 &              i, k, j)+max12*field_oldd(i, k, j))))/dt
8937             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min17*field_old(i, k, j-1)+&
8938 &              0.5*max12*field_old(i, k, j))
8939             fqyd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i, k, j-&
8940 &              1))-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(&
8941 &              field(i, k, j+2)+field(i, k, j-3))-SIGN(1, time_step)*SIGN&
8942 &              (1., vel)*(1./60.)*(field(i, k, j+2)-field(i, k, j-3)-5.*(&
8943 &              field(i, k, j+1)-field(i, k, j-2))+10.*(field(i, k, j)-&
8944 &              field(i, k, j-1)))) + vel*(37.*(fieldd(i, k, j)+fieldd(i, &
8945 &              k, j-1))/60.-2.*(fieldd(i, k, j+1)+fieldd(i, k, j-2))/15.+&
8946 &              (fieldd(i, k, j+2)+fieldd(i, k, j-3))/60.-SIGN(1, &
8947 &              time_step)*SIGN(1., vel)*(fieldd(i, k, j+2)-fieldd(i, k, j&
8948 &              -3)-5.*(fieldd(i, k, j+1)-fieldd(i, k, j-2))+10.*(fieldd(i&
8949 &              , k, j)-fieldd(i, k, j-1)))/60.)
8950             fqy(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k, j-1)&
8951 &              )-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(field&
8952 &              (i, k, j+2)+field(i, k, j-3))-SIGN(1, time_step)*SIGN(1., &
8953 &              vel)*(1./60.)*(field(i, k, j+2)-field(i, k, j-3)-5.*(field&
8954 &              (i, k, j+1)-field(i, k, j-2))+10.*(field(i, k, j)-field(i&
8955 &              , k, j-1))))
8956             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
8957             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
8958           END DO
8959         END DO
8960       ELSE IF (j .EQ. jds + 1) THEN
8961 ! 2nd order flux next to south boundary
8962         DO k=kts,ktf
8963           DO i=i_start,i_end
8964 ! ADT eqn 48 d/dy
8965             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
8966             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
8967             mu = 0.5*(mut(i, j)+mut(i, j-1))
8968             veld = rvd(i, k, j)
8969             vel = rv(i, k, j)
8970             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
8971             cr = vel*dt/dy/mu
8972             IF (cr .GE. 0.) THEN
8973               abs12d = crd
8974               abs12 = cr
8975             ELSE
8976               abs12d = -crd
8977               abs12 = -cr
8978             END IF
8979             y12d = crd + abs12d
8980             y12 = cr + abs12
8981             IF (1.0 .GT. y12) THEN
8982               min18d = y12d
8983               min18 = y12
8984             ELSE
8985               min18 = 1.0
8986               min18d = 0.0
8987             END IF
8988             IF (cr .GE. 0.) THEN
8989               abs63d = crd
8990               abs63 = cr
8991             ELSE
8992               abs63d = -crd
8993               abs63 = -cr
8994             END IF
8995             y63d = crd - abs63d
8996             y63 = cr - abs63
8997             IF (-1.0 .LT. y63) THEN
8998               max13d = y63d
8999               max13 = y63
9000             ELSE
9001               max13 = -1.0
9002               max13d = 0.0
9003             END IF
9004             fqyld(i, k, j) = dy*(mud*(0.5*min18*field_old(i, k, j-1)+0.5&
9005 &              *max13*field_old(i, k, j))+mu*(0.5*(min18d*field_old(i, k&
9006 &              , j-1)+min18*field_oldd(i, k, j-1))+0.5*(max13d*field_old(&
9007 &              i, k, j)+max13*field_oldd(i, k, j))))/dt
9008             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min18*field_old(i, k, j-1)+&
9009 &              0.5*max13*field_old(i, k, j))
9010             fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
9011 &              , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
9012             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
9013 &              -1))
9014             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
9015             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
9016           END DO
9017         END DO
9018       ELSE IF (j .EQ. jds + 2) THEN
9019 ! third of 4th order flux 2 in from south boundary
9020         DO k=kts,ktf
9021           DO i=i_start,i_end
9022 ! ADT eqn 48 d/dy
9023             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
9024             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
9025             mu = 0.5*(mut(i, j)+mut(i, j-1))
9026             veld = rvd(i, k, j)
9027             vel = rv(i, k, j)
9028             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
9029             cr = vel*dt/dy/mu
9030             IF (cr .GE. 0.) THEN
9031               abs13d = crd
9032               abs13 = cr
9033             ELSE
9034               abs13d = -crd
9035               abs13 = -cr
9036             END IF
9037             y13d = crd + abs13d
9038             y13 = cr + abs13
9039             IF (1.0 .GT. y13) THEN
9040               min19d = y13d
9041               min19 = y13
9042             ELSE
9043               min19 = 1.0
9044               min19d = 0.0
9045             END IF
9046             IF (cr .GE. 0.) THEN
9047               abs64d = crd
9048               abs64 = cr
9049             ELSE
9050               abs64d = -crd
9051               abs64 = -cr
9052             END IF
9053             y64d = crd - abs64d
9054             y64 = cr - abs64
9055             IF (-1.0 .LT. y64) THEN
9056               max14d = y64d
9057               max14 = y64
9058             ELSE
9059               max14 = -1.0
9060               max14d = 0.0
9061             END IF
9062             fqyld(i, k, j) = dy*(mud*(0.5*min19*field_old(i, k, j-1)+0.5&
9063 &              *max14*field_old(i, k, j))+mu*(0.5*(min19d*field_old(i, k&
9064 &              , j-1)+min19*field_oldd(i, k, j-1))+0.5*(max14d*field_old(&
9065 &              i, k, j)+max14*field_oldd(i, k, j))))/dt
9066             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min19*field_old(i, k, j-1)+&
9067 &              0.5*max14*field_old(i, k, j))
9068             fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
9069 &              ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
9070 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
9071 &              i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) + vel*(&
9072 &              7.*(fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j&
9073 &              +1)+fieldd(i, k, j-2))/12.+SIGN(1, time_step)*SIGN(1., vel&
9074 &              )*(fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)&
9075 &              -fieldd(i, k, j-1)))/12.)
9076             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
9077 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
9078 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
9079 &              i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1))))
9080             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
9081             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
9082           END DO
9083         END DO
9084       ELSE IF (j .EQ. jde - 1) THEN
9085 ! 2nd order flux next to north boundary
9086         DO k=kts,ktf
9087           DO i=i_start,i_end
9088 ! ADT eqn 48 d/dy
9089             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
9090             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
9091             mu = 0.5*(mut(i, j)+mut(i, j-1))
9092             veld = rvd(i, k, j)
9093             vel = rv(i, k, j)
9094             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
9095             cr = vel*dt/dy/mu
9096             IF (cr .GE. 0.) THEN
9097               abs14d = crd
9098               abs14 = cr
9099             ELSE
9100               abs14d = -crd
9101               abs14 = -cr
9102             END IF
9103             y14d = crd + abs14d
9104             y14 = cr + abs14
9105             IF (1.0 .GT. y14) THEN
9106               min20d = y14d
9107               min20 = y14
9108             ELSE
9109               min20 = 1.0
9110               min20d = 0.0
9111             END IF
9112             IF (cr .GE. 0.) THEN
9113               abs65d = crd
9114               abs65 = cr
9115             ELSE
9116               abs65d = -crd
9117               abs65 = -cr
9118             END IF
9119             y65d = crd - abs65d
9120             y65 = cr - abs65
9121             IF (-1.0 .LT. y65) THEN
9122               max15d = y65d
9123               max15 = y65
9124             ELSE
9125               max15 = -1.0
9126               max15d = 0.0
9127             END IF
9128             fqyld(i, k, j) = dy*(mud*(0.5*min20*field_old(i, k, j-1)+0.5&
9129 &              *max15*field_old(i, k, j))+mu*(0.5*(min20d*field_old(i, k&
9130 &              , j-1)+min20*field_oldd(i, k, j-1))+0.5*(max15d*field_old(&
9131 &              i, k, j)+max15*field_oldd(i, k, j))))/dt
9132             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min20*field_old(i, k, j-1)+&
9133 &              0.5*max15*field_old(i, k, j))
9134             fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
9135 &              , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
9136             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
9137 &              -1))
9138             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
9139             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
9140           END DO
9141         END DO
9142       ELSE IF (j .EQ. jde - 2) THEN
9143 ! 3rd or 4th order flux 2 in from north boundary
9144         DO k=kts,ktf
9145           DO i=i_start,i_end
9146 ! ADT eqn 48 d/dy
9147             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
9148             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
9149             mu = 0.5*(mut(i, j)+mut(i, j-1))
9150             veld = rvd(i, k, j)
9151             vel = rv(i, k, j)
9152             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
9153             cr = vel*dt/dy/mu
9154             IF (cr .GE. 0.) THEN
9155               abs15d = crd
9156               abs15 = cr
9157             ELSE
9158               abs15d = -crd
9159               abs15 = -cr
9160             END IF
9161             y15d = crd + abs15d
9162             y15 = cr + abs15
9163             IF (1.0 .GT. y15) THEN
9164               min21d = y15d
9165               min21 = y15
9166             ELSE
9167               min21 = 1.0
9168               min21d = 0.0
9169             END IF
9170             IF (cr .GE. 0.) THEN
9171               abs66d = crd
9172               abs66 = cr
9173             ELSE
9174               abs66d = -crd
9175               abs66 = -cr
9176             END IF
9177             y66d = crd - abs66d
9178             y66 = cr - abs66
9179             IF (-1.0 .LT. y66) THEN
9180               max16d = y66d
9181               max16 = y66
9182             ELSE
9183               max16 = -1.0
9184               max16d = 0.0
9185             END IF
9186             fqyld(i, k, j) = dy*(mud*(0.5*min21*field_old(i, k, j-1)+0.5&
9187 &              *max16*field_old(i, k, j))+mu*(0.5*(min21d*field_old(i, k&
9188 &              , j-1)+min21*field_oldd(i, k, j-1))+0.5*(max16d*field_old(&
9189 &              i, k, j)+max16*field_oldd(i, k, j))))/dt
9190             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min21*field_old(i, k, j-1)+&
9191 &              0.5*max16*field_old(i, k, j))
9192             fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
9193 &              ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
9194 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
9195 &              i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) + vel*(&
9196 &              7.*(fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j&
9197 &              +1)+fieldd(i, k, j-2))/12.+SIGN(1, time_step)*SIGN(1., vel&
9198 &              )*(fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)&
9199 &              -fieldd(i, k, j-1)))/12.)
9200             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
9201 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
9202 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
9203 &              i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1))))
9204             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
9205             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
9206           END DO
9207         END DO
9208       END IF
9209     END DO j_loop_y_flux_5
9210 !  next, x flux
9211 !--  these bounds are for periodic and sym conditions
9212     i_start = its - 1
9213     IF (ite .GT. ide - 1) THEN
9214       min22 = ide - 1
9215     ELSE
9216       min22 = ite
9217     END IF
9218     i_end = min22 + 1
9219     i_start_f = i_start
9220     i_end_f = i_end + 1
9221     j_start = jts - 1
9222     IF (jte .GT. jde - 1) THEN
9223       min23 = jde - 1
9224     ELSE
9225       min23 = jte
9226     END IF
9227     j_end = min23 + 1
9228 !--  modify loop bounds for open and specified b.c
9229 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
9230 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
9231     IF (degrade_ys) THEN
9232       IF (jts - 1 .LT. jds) THEN
9233         j_start = jds
9234       ELSE
9235         j_start = jts - 1
9236       END IF
9237     END IF
9238     IF (degrade_ye) THEN
9239       IF (jte + 1 .GT. jde - 1) THEN
9240         j_end = jde - 1
9241       ELSE
9242         j_end = jte + 1
9243       END IF
9244     END IF
9245     IF (degrade_xs) THEN
9246       IF (ids + 1 .LT. its - 1) THEN
9247         i_start = its - 1
9248       ELSE
9249         i_start = ids + 1
9250       END IF
9251       i_start_f = ids + 3
9252     END IF
9253     IF (degrade_xe) THEN
9254       IF (ide - 2 .GT. ite + 1) THEN
9255         i_end = ite + 1
9256       ELSE
9257         i_end = ide - 2
9258       END IF
9259       i_end_f = ide - 3
9260       fqxld = 0.0
9261       fqxd = 0.0
9262     ELSE
9263       fqxld = 0.0
9264       fqxd = 0.0
9265     END IF
9266 !  compute fluxes
9267     DO j=j_start,j_end
9268 !  5th order flux
9269       DO k=kts,ktf
9270         DO i=i_start_f,i_end_f
9271 ! ADT eqn 48 d/dx
9272           dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
9273           mud = 0.5*(mutd(i, j)+mutd(i-1, j))
9274           mu = 0.5*(mut(i, j)+mut(i-1, j))
9275           veld = rud(i, k, j)
9276           vel = ru(i, k, j)
9277           crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
9278           cr = vel*dt/dx/mu
9279           IF (cr .GE. 0.) THEN
9280             abs16d = crd
9281             abs16 = cr
9282           ELSE
9283             abs16d = -crd
9284             abs16 = -cr
9285           END IF
9286           y16d = crd + abs16d
9287           y16 = cr + abs16
9288           IF (1.0 .GT. y16) THEN
9289             min24d = y16d
9290             min24 = y16
9291           ELSE
9292             min24 = 1.0
9293             min24d = 0.0
9294           END IF
9295           IF (cr .GE. 0.) THEN
9296             abs67d = crd
9297             abs67 = cr
9298           ELSE
9299             abs67d = -crd
9300             abs67 = -cr
9301           END IF
9302           y67d = crd - abs67d
9303           y67 = cr - abs67
9304           IF (-1.0 .LT. y67) THEN
9305             max17d = y67d
9306             max17 = y67
9307           ELSE
9308             max17 = -1.0
9309             max17d = 0.0
9310           END IF
9311           fqxld(i, k, j) = dx*(mud*(0.5*min24*field_old(i-1, k, j)+0.5*&
9312 &            max17*field_old(i, k, j))+mu*(0.5*(min24d*field_old(i-1, k, &
9313 &            j)+min24*field_oldd(i-1, k, j))+0.5*(max17d*field_old(i, k, &
9314 &            j)+max17*field_oldd(i, k, j))))/dt
9315           fqxl(i, k, j) = mu*(dx/dt)*(0.5*min24*field_old(i-1, k, j)+0.5&
9316 &            *max17*field_old(i, k, j))
9317           fqxd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i-1, k, j)&
9318 &            )-2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i&
9319 &            +2, k, j)+field(i-3, k, j))-SIGN(1, time_step)*SIGN(1., vel)&
9320 &            *(1./60.)*(field(i+2, k, j)-field(i-3, k, j)-5.*(field(i+1, &
9321 &            k, j)-field(i-2, k, j))+10.*(field(i, k, j)-field(i-1, k, j)&
9322 &            ))) + vel*(37.*(fieldd(i, k, j)+fieldd(i-1, k, j))/60.-2.*(&
9323 &            fieldd(i+1, k, j)+fieldd(i-2, k, j))/15.+(fieldd(i+2, k, j)+&
9324 &            fieldd(i-3, k, j))/60.-SIGN(1, time_step)*SIGN(1., vel)*(&
9325 &            fieldd(i+2, k, j)-fieldd(i-3, k, j)-5.*(fieldd(i+1, k, j)-&
9326 &            fieldd(i-2, k, j))+10.*(fieldd(i, k, j)-fieldd(i-1, k, j)))/&
9327 &            60.)
9328           fqx(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i-1, k, j))-&
9329 &            2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i+2&
9330 &            , k, j)+field(i-3, k, j))-SIGN(1, time_step)*SIGN(1., vel)*(&
9331 &            1./60.)*(field(i+2, k, j)-field(i-3, k, j)-5.*(field(i+1, k&
9332 &            , j)-field(i-2, k, j))+10.*(field(i, k, j)-field(i-1, k, j))&
9333 &            ))
9334           fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
9335           fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
9336         END DO
9337       END DO
9338 !  lower order fluxes close to boundaries (if not periodic or symmetric)
9339       IF (degrade_xs) THEN
9340         DO i=i_start,i_start_f-1
9341           IF (i .EQ. ids + 1) THEN
9342 ! second order
9343             DO k=kts,ktf
9344 ! ADT eqn 48 d/dx
9345               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
9346               mud = 0.5*(mutd(i, j)+mutd(i-1, j))
9347               mu = 0.5*(mut(i, j)+mut(i-1, j))
9348               veld = (rud(i, k, j)*mu-ru(i, k, j)*mud)/mu**2
9349               vel = ru(i, k, j)/mu
9350               crd = dt*veld/dx
9351               cr = vel*dt/dx
9352               IF (cr .GE. 0.) THEN
9353                 abs17d = crd
9354                 abs17 = cr
9355               ELSE
9356                 abs17d = -crd
9357                 abs17 = -cr
9358               END IF
9359               y17d = crd + abs17d
9360               y17 = cr + abs17
9361               IF (1.0 .GT. y17) THEN
9362                 min25d = y17d
9363                 min25 = y17
9364               ELSE
9365                 min25 = 1.0
9366                 min25d = 0.0
9367               END IF
9368               IF (cr .GE. 0.) THEN
9369                 abs68d = crd
9370                 abs68 = cr
9371               ELSE
9372                 abs68d = -crd
9373                 abs68 = -cr
9374               END IF
9375               y68d = crd - abs68d
9376               y68 = cr - abs68
9377               IF (-1.0 .LT. y68) THEN
9378                 max18d = y68d
9379                 max18 = y68
9380               ELSE
9381                 max18 = -1.0
9382                 max18d = 0.0
9383               END IF
9384               fqxld(i, k, j) = dx*(mud*(0.5*min25*field_old(i-1, k, j)+&
9385 &                0.5*max18*field_old(i, k, j))+mu*(0.5*(min25d*field_old(&
9386 &                i-1, k, j)+min25*field_oldd(i-1, k, j))+0.5*(max18d*&
9387 &                field_old(i, k, j)+max18*field_oldd(i, k, j))))/dt
9388               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min25*field_old(i-1, k, j)&
9389 &                +0.5*max18*field_old(i, k, j))
9390               fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-&
9391 &                1, k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)&
9392 &                ))
9393               fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
9394 &                k, j))
9395               fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
9396               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
9397             END DO
9398           END IF
9399           IF (i .EQ. ids + 2) THEN
9400 ! third order
9401             DO k=kts,ktf
9402 ! ADT eqn 48 d/dx
9403               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
9404               mud = 0.5*(mutd(i, j)+mutd(i-1, j))
9405               mu = 0.5*(mut(i, j)+mut(i-1, j))
9406               veld = rud(i, k, j)
9407               vel = ru(i, k, j)
9408               crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
9409               cr = vel*dt/dx/mu
9410               IF (cr .GE. 0.) THEN
9411                 abs18d = crd
9412                 abs18 = cr
9413               ELSE
9414                 abs18d = -crd
9415                 abs18 = -cr
9416               END IF
9417               y18d = crd + abs18d
9418               y18 = cr + abs18
9419               IF (1.0 .GT. y18) THEN
9420                 min26d = y18d
9421                 min26 = y18
9422               ELSE
9423                 min26 = 1.0
9424                 min26d = 0.0
9425               END IF
9426               IF (cr .GE. 0.) THEN
9427                 abs69d = crd
9428                 abs69 = cr
9429               ELSE
9430                 abs69d = -crd
9431                 abs69 = -cr
9432               END IF
9433               y69d = crd - abs69d
9434               y69 = cr - abs69
9435               IF (-1.0 .LT. y69) THEN
9436                 max19d = y69d
9437                 max19 = y69
9438               ELSE
9439                 max19 = -1.0
9440                 max19d = 0.0
9441               END IF
9442               fqxld(i, k, j) = dx*(mud*(0.5*min26*field_old(i-1, k, j)+&
9443 &                0.5*max19*field_old(i, k, j))+mu*(0.5*(min26d*field_old(&
9444 &                i-1, k, j)+min26*field_oldd(i-1, k, j))+0.5*(max19d*&
9445 &                field_old(i, k, j)+max19*field_oldd(i, k, j))))/dt
9446               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min26*field_old(i-1, k, j)&
9447 &                +0.5*max19*field_old(i, k, j))
9448               fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k&
9449 &                , j))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1&
9450 &                , time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-&
9451 &                field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) &
9452 &                + vel*(7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(&
9453 &                fieldd(i+1, k, j)+fieldd(i-2, k, j))/12.+SIGN(1, &
9454 &                time_step)*SIGN(1., vel)*(fieldd(i+1, k, j)-fieldd(i-2, &
9455 &                k, j)-3.*(fieldd(i, k, j)-fieldd(i-1, k, j)))/12.)
9456               fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
9457 &                ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
9458 &                time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-&
9459 &                field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
9460               fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
9461               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
9462             END DO
9463           END IF
9464         END DO
9465       END IF
9466       IF (degrade_xe) THEN
9467         DO i=i_end_f+1,i_end+1
9468           IF (i .EQ. ide - 1) THEN
9469 ! second order flux next to the boundary
9470             DO k=kts,ktf
9471 ! ADT eqn 48 d/dx
9472               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
9473               mud = 0.5*(mutd(i, j)+mutd(i-1, j))
9474               mu = 0.5*(mut(i, j)+mut(i-1, j))
9475               veld = rud(i, k, j)
9476               vel = ru(i, k, j)
9477               crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
9478               cr = vel*dt/dx/mu
9479               IF (cr .GE. 0.) THEN
9480                 abs19d = crd
9481                 abs19 = cr
9482               ELSE
9483                 abs19d = -crd
9484                 abs19 = -cr
9485               END IF
9486               y19d = crd + abs19d
9487               y19 = cr + abs19
9488               IF (1.0 .GT. y19) THEN
9489                 min27d = y19d
9490                 min27 = y19
9491               ELSE
9492                 min27 = 1.0
9493                 min27d = 0.0
9494               END IF
9495               IF (cr .GE. 0.) THEN
9496                 abs70d = crd
9497                 abs70 = cr
9498               ELSE
9499                 abs70d = -crd
9500                 abs70 = -cr
9501               END IF
9502               y70d = crd - abs70d
9503               y70 = cr - abs70
9504               IF (-1.0 .LT. y70) THEN
9505                 max20d = y70d
9506                 max20 = y70
9507               ELSE
9508                 max20 = -1.0
9509                 max20d = 0.0
9510               END IF
9511               fqxld(i, k, j) = dx*(mud*(0.5*min27*field_old(i-1, k, j)+&
9512 &                0.5*max20*field_old(i, k, j))+mu*(0.5*(min27d*field_old(&
9513 &                i-1, k, j)+min27*field_oldd(i-1, k, j))+0.5*(max20d*&
9514 &                field_old(i, k, j)+max20*field_oldd(i, k, j))))/dt
9515               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min27*field_old(i-1, k, j)&
9516 &                +0.5*max20*field_old(i, k, j))
9517               fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-&
9518 &                1, k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)&
9519 &                ))
9520               fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
9521 &                k, j))
9522               fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
9523               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
9524             END DO
9525           END IF
9526           IF (i .EQ. ide - 2) THEN
9527 ! third order flux one in from the boundary
9528             DO k=kts,ktf
9529 ! ADT eqn 48 d/dx
9530               dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
9531               mud = 0.5*(mutd(i, j)+mutd(i-1, j))
9532               mu = 0.5*(mut(i, j)+mut(i-1, j))
9533               veld = rud(i, k, j)
9534               vel = ru(i, k, j)
9535               crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
9536               cr = vel*dt/dx/mu
9537               IF (cr .GE. 0.) THEN
9538                 abs20d = crd
9539                 abs20 = cr
9540               ELSE
9541                 abs20d = -crd
9542                 abs20 = -cr
9543               END IF
9544               y20d = crd + abs20d
9545               y20 = cr + abs20
9546               IF (1.0 .GT. y20) THEN
9547                 min28d = y20d
9548                 min28 = y20
9549               ELSE
9550                 min28 = 1.0
9551                 min28d = 0.0
9552               END IF
9553               IF (cr .GE. 0.) THEN
9554                 abs71d = crd
9555                 abs71 = cr
9556               ELSE
9557                 abs71d = -crd
9558                 abs71 = -cr
9559               END IF
9560               y71d = crd - abs71d
9561               y71 = cr - abs71
9562               IF (-1.0 .LT. y71) THEN
9563                 max21d = y71d
9564                 max21 = y71
9565               ELSE
9566                 max21 = -1.0
9567                 max21d = 0.0
9568               END IF
9569               fqxld(i, k, j) = dx*(mud*(0.5*min28*field_old(i-1, k, j)+&
9570 &                0.5*max21*field_old(i, k, j))+mu*(0.5*(min28d*field_old(&
9571 &                i-1, k, j)+min28*field_oldd(i-1, k, j))+0.5*(max21d*&
9572 &                field_old(i, k, j)+max21*field_oldd(i, k, j))))/dt
9573               fqxl(i, k, j) = mu*(dx/dt)*(0.5*min28*field_old(i-1, k, j)&
9574 &                +0.5*max21*field_old(i, k, j))
9575               fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k&
9576 &                , j))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1&
9577 &                , time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-&
9578 &                field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) &
9579 &                + vel*(7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(&
9580 &                fieldd(i+1, k, j)+fieldd(i-2, k, j))/12.+SIGN(1, &
9581 &                time_step)*SIGN(1., vel)*(fieldd(i+1, k, j)-fieldd(i-2, &
9582 &                k, j)-3.*(fieldd(i, k, j)-fieldd(i-1, k, j)))/12.)
9583               fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
9584 &                ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
9585 &                time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-&
9586 &                field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
9587               fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
9588               fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
9589             END DO
9590           END IF
9591         END DO
9592       END IF
9593     END DO
9594   ELSE IF (horz_order .EQ. 4) THEN
9595 ! enddo for outer J loop
9596 !--- end of 5th order horizontal flux calculation
9597     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
9598 &        its .GT. ids + 1) degrade_xs = .false.
9599     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
9600 &        ite .LT. ide - 2) degrade_xe = .false.
9601     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
9602 &        jts .GT. jds + 1) degrade_ys = .false.
9603     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
9604 &        jte .LT. jde - 2) degrade_ye = .false.
9605     IF (kte .GT. kde - 1) THEN
9606       ktf = kde - 1
9607     ELSE
9608       ktf = kte
9609     END IF
9610     i_start = its - 1
9611     IF (ite .GT. ide - 1) THEN
9612       min29 = ide - 1
9613     ELSE
9614       min29 = ite
9615     END IF
9616     i_end = min29 + 1
9617     j_start = jts - 1
9618     IF (jte .GT. jde - 1) THEN
9619       min30 = jde - 1
9620     ELSE
9621       min30 = jte
9622     END IF
9623     j_end = min30 + 1
9624     j_start_f = j_start
9625     j_end_f = j_end + 1
9626 !--  modify loop bounds if open or specified
9627     IF (degrade_xs) i_start = its
9628     IF (degrade_xe) THEN
9629       IF (ite .GT. ide - 1) THEN
9630         i_end = ide - 1
9631       ELSE
9632         i_end = ite
9633       END IF
9634     END IF
9635     IF (degrade_ys) THEN
9636       IF (jts .LT. jds + 1) THEN
9637         j_start = jds + 1
9638       ELSE
9639         j_start = jts
9640       END IF
9641       j_start_f = jds + 2
9642     END IF
9643     IF (degrade_ye) THEN
9644       IF (jte .GT. jde - 2) THEN
9645         j_end = jde - 2
9646       ELSE
9647         j_end = jte
9648       END IF
9649       j_end_f = jde - 2
9650       fqyld = 0.0
9651       fqyd = 0.0
9652     ELSE
9653       fqyld = 0.0
9654       fqyd = 0.0
9655     END IF
9656 !  compute fluxes, 4th order
9657 j_loop_y_flux_4:DO j=j_start,j_end+1
9658       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
9659 ! use full stencil
9660         DO k=kts,ktf
9661           DO i=i_start,i_end
9662 ! ADT eqn 48 d/dy
9663             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
9664             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
9665             mu = 0.5*(mut(i, j)+mut(i, j-1))
9666             veld = rvd(i, k, j)
9667             vel = rv(i, k, j)
9668             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
9669             cr = vel*dt/dy/mu
9670             IF (cr .GE. 0.) THEN
9671               abs21d = crd
9672               abs21 = cr
9673             ELSE
9674               abs21d = -crd
9675               abs21 = -cr
9676             END IF
9677             y21d = crd + abs21d
9678             y21 = cr + abs21
9679             IF (1.0 .GT. y21) THEN
9680               min31d = y21d
9681               min31 = y21
9682             ELSE
9683               min31 = 1.0
9684               min31d = 0.0
9685             END IF
9686             IF (cr .GE. 0.) THEN
9687               abs72d = crd
9688               abs72 = cr
9689             ELSE
9690               abs72d = -crd
9691               abs72 = -cr
9692             END IF
9693             y72d = crd - abs72d
9694             y72 = cr - abs72
9695             IF (-1.0 .LT. y72) THEN
9696               max22d = y72d
9697               max22 = y72
9698             ELSE
9699               max22 = -1.0
9700               max22d = 0.0
9701             END IF
9702             fqyld(i, k, j) = dy*(mud*(0.5*min31*field_old(i, k, j-1)+0.5&
9703 &              *max22*field_old(i, k, j))+mu*(0.5*(min31d*field_old(i, k&
9704 &              , j-1)+min31*field_oldd(i, k, j-1))+0.5*(max22d*field_old(&
9705 &              i, k, j)+max22*field_oldd(i, k, j))))/dt
9706             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min31*field_old(i, k, j-1)+&
9707 &              0.5*max22*field_old(i, k, j))
9708             fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
9709 &              ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))) + vel*(7.*(&
9710 &              fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+&
9711 &              fieldd(i, k, j-2))/12.)
9712             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
9713 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2)))
9714             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
9715             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
9716           END DO
9717         END DO
9718       ELSE IF (j .EQ. jds + 1) THEN
9719 ! 2nd order flux next to south boundary
9720         DO k=kts,ktf
9721           DO i=i_start,i_end
9722 ! ADT eqn 48 d/dy
9723             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
9724             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
9725             mu = 0.5*(mut(i, j)+mut(i, j-1))
9726             veld = rvd(i, k, j)
9727             vel = rv(i, k, j)
9728             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
9729             cr = vel*dt/dy/mu
9730             IF (cr .GE. 0.) THEN
9731               abs22d = crd
9732               abs22 = cr
9733             ELSE
9734               abs22d = -crd
9735               abs22 = -cr
9736             END IF
9737             y22d = crd + abs22d
9738             y22 = cr + abs22
9739             IF (1.0 .GT. y22) THEN
9740               min32d = y22d
9741               min32 = y22
9742             ELSE
9743               min32 = 1.0
9744               min32d = 0.0
9745             END IF
9746             IF (cr .GE. 0.) THEN
9747               abs73d = crd
9748               abs73 = cr
9749             ELSE
9750               abs73d = -crd
9751               abs73 = -cr
9752             END IF
9753             y73d = crd - abs73d
9754             y73 = cr - abs73
9755             IF (-1.0 .LT. y73) THEN
9756               max23d = y73d
9757               max23 = y73
9758             ELSE
9759               max23 = -1.0
9760               max23d = 0.0
9761             END IF
9762             fqyld(i, k, j) = dy*(mud*(0.5*min32*field_old(i, k, j-1)+0.5&
9763 &              *max23*field_old(i, k, j))+mu*(0.5*(min32d*field_old(i, k&
9764 &              , j-1)+min32*field_oldd(i, k, j-1))+0.5*(max23d*field_old(&
9765 &              i, k, j)+max23*field_oldd(i, k, j))))/dt
9766             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min32*field_old(i, k, j-1)+&
9767 &              0.5*max23*field_old(i, k, j))
9768             fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
9769 &              , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
9770             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
9771 &              -1))
9772             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
9773             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
9774           END DO
9775         END DO
9776       ELSE IF (j .EQ. jde - 1) THEN
9777 ! 2nd order flux next to north boundary
9778         DO k=kts,ktf
9779           DO i=i_start,i_end
9780 ! ADT eqn 48 d/dy
9781             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
9782             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
9783             mu = 0.5*(mut(i, j)+mut(i, j-1))
9784             veld = rvd(i, k, j)
9785             vel = rv(i, k, j)
9786             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
9787             cr = vel*dt/dy/mu
9788             IF (cr .GE. 0.) THEN
9789               abs23d = crd
9790               abs23 = cr
9791             ELSE
9792               abs23d = -crd
9793               abs23 = -cr
9794             END IF
9795             y23d = crd + abs23d
9796             y23 = cr + abs23
9797             IF (1.0 .GT. y23) THEN
9798               min33d = y23d
9799               min33 = y23
9800             ELSE
9801               min33 = 1.0
9802               min33d = 0.0
9803             END IF
9804             IF (cr .GE. 0.) THEN
9805               abs74d = crd
9806               abs74 = cr
9807             ELSE
9808               abs74d = -crd
9809               abs74 = -cr
9810             END IF
9811             y74d = crd - abs74d
9812             y74 = cr - abs74
9813             IF (-1.0 .LT. y74) THEN
9814               max24d = y74d
9815               max24 = y74
9816             ELSE
9817               max24 = -1.0
9818               max24d = 0.0
9819             END IF
9820             fqyld(i, k, j) = dy*(mud*(0.5*min33*field_old(i, k, j-1)+0.5&
9821 &              *max24*field_old(i, k, j))+mu*(0.5*(min33d*field_old(i, k&
9822 &              , j-1)+min33*field_oldd(i, k, j-1))+0.5*(max24d*field_old(&
9823 &              i, k, j)+max24*field_oldd(i, k, j))))/dt
9824             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min33*field_old(i, k, j-1)+&
9825 &              0.5*max24*field_old(i, k, j))
9826             fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
9827 &              , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
9828             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
9829 &              -1))
9830             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
9831             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
9832           END DO
9833         END DO
9834       END IF
9835     END DO j_loop_y_flux_4
9836 !  next, x flux
9837 !--  these bounds are for periodic and sym conditions
9838     i_start = its - 1
9839     IF (ite .GT. ide - 1) THEN
9840       min34 = ide - 1
9841     ELSE
9842       min34 = ite
9843     END IF
9844     i_end = min34 + 1
9845     i_start_f = i_start
9846     i_end_f = i_end + 1
9847     j_start = jts - 1
9848     IF (jte .GT. jde - 1) THEN
9849       min35 = jde - 1
9850     ELSE
9851       min35 = jte
9852     END IF
9853     j_end = min35 + 1
9854 !--  modify loop bounds for open and specified b.c
9855     IF (degrade_ys) j_start = jts
9856     IF (degrade_ye) THEN
9857       IF (jte .GT. jde - 1) THEN
9858         j_end = jde - 1
9859       ELSE
9860         j_end = jte
9861       END IF
9862     END IF
9863     IF (degrade_xs) THEN
9864       IF (ids + 1 .LT. its) THEN
9865         i_start = its
9866       ELSE
9867         i_start = ids + 1
9868       END IF
9869       i_start_f = i_start + 1
9870     END IF
9871     IF (degrade_xe) THEN
9872       IF (ide - 2 .GT. ite) THEN
9873         i_end = ite
9874       ELSE
9875         i_end = ide - 2
9876       END IF
9877       i_end_f = ide - 2
9878       fqxld = 0.0
9879       fqxd = 0.0
9880     ELSE
9881       fqxld = 0.0
9882       fqxd = 0.0
9883     END IF
9884 !  compute fluxes
9885     DO j=j_start,j_end
9886 !  4th order flux
9887       DO k=kts,ktf
9888         DO i=i_start_f,i_end_f
9889 ! ADT eqn 48 d/dx
9890           dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
9891           mud = 0.5*(mutd(i, j)+mutd(i-1, j))
9892           mu = 0.5*(mut(i, j)+mut(i-1, j))
9893           veld = rud(i, k, j)
9894           vel = ru(i, k, j)
9895           crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
9896           cr = vel*dt/dx/mu
9897           IF (cr .GE. 0.) THEN
9898             abs24d = crd
9899             abs24 = cr
9900           ELSE
9901             abs24d = -crd
9902             abs24 = -cr
9903           END IF
9904           y24d = crd + abs24d
9905           y24 = cr + abs24
9906           IF (1.0 .GT. y24) THEN
9907             min36d = y24d
9908             min36 = y24
9909           ELSE
9910             min36 = 1.0
9911             min36d = 0.0
9912           END IF
9913           IF (cr .GE. 0.) THEN
9914             abs75d = crd
9915             abs75 = cr
9916           ELSE
9917             abs75d = -crd
9918             abs75 = -cr
9919           END IF
9920           y75d = crd - abs75d
9921           y75 = cr - abs75
9922           IF (-1.0 .LT. y75) THEN
9923             max25d = y75d
9924             max25 = y75
9925           ELSE
9926             max25 = -1.0
9927             max25d = 0.0
9928           END IF
9929           fqxld(i, k, j) = dx*(mud*(0.5*min36*field_old(i-1, k, j)+0.5*&
9930 &            max25*field_old(i, k, j))+mu*(0.5*(min36d*field_old(i-1, k, &
9931 &            j)+min36*field_oldd(i-1, k, j))+0.5*(max25d*field_old(i, k, &
9932 &            j)+max25*field_oldd(i, k, j))))/dt
9933           fqxl(i, k, j) = mu*(dx/dt)*(0.5*min36*field_old(i-1, k, j)+0.5&
9934 &            *max25*field_old(i, k, j))
9935           fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j))&
9936 &            -1./12.*(field(i+1, k, j)+field(i-2, k, j))) + vel*(7.*(&
9937 &            fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k, j)+&
9938 &            fieldd(i-2, k, j))/12.)
9939           fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-&
9940 &            1./12.*(field(i+1, k, j)+field(i-2, k, j)))
9941           fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
9942           fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
9943         END DO
9944       END DO
9945 !  lower order fluxes close to boundaries (if not periodic or symmetric)
9946       IF (degrade_xs) THEN
9947         IF (i_start .EQ. ids + 1) THEN
9948 ! second order flux next to the boundary
9949           i = ids + 1
9950           DO k=kts,ktf
9951 ! ADT eqn 48 d/dx
9952             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
9953             mud = 0.5*(mutd(i, j)+mutd(i-1, j))
9954             mu = 0.5*(mut(i, j)+mut(i-1, j))
9955             veld = (rud(i, k, j)*mu-ru(i, k, j)*mud)/mu**2
9956             vel = ru(i, k, j)/mu
9957             crd = dt*veld/dx
9958             cr = vel*dt/dx
9959             IF (cr .GE. 0.) THEN
9960               abs25d = crd
9961               abs25 = cr
9962             ELSE
9963               abs25d = -crd
9964               abs25 = -cr
9965             END IF
9966             y25d = crd + abs25d
9967             y25 = cr + abs25
9968             IF (1.0 .GT. y25) THEN
9969               min37d = y25d
9970               min37 = y25
9971             ELSE
9972               min37 = 1.0
9973               min37d = 0.0
9974             END IF
9975             IF (cr .GE. 0.) THEN
9976               abs76d = crd
9977               abs76 = cr
9978             ELSE
9979               abs76d = -crd
9980               abs76 = -cr
9981             END IF
9982             y76d = crd - abs76d
9983             y76 = cr - abs76
9984             IF (-1.0 .LT. y76) THEN
9985               max26d = y76d
9986               max26 = y76
9987             ELSE
9988               max26 = -1.0
9989               max26d = 0.0
9990             END IF
9991             fqxld(i, k, j) = dx*(mud*(0.5*min37*field_old(i-1, k, j)+0.5&
9992 &              *max26*field_old(i, k, j))+mu*(0.5*(min37d*field_old(i-1, &
9993 &              k, j)+min37*field_oldd(i-1, k, j))+0.5*(max26d*field_old(i&
9994 &              , k, j)+max26*field_oldd(i, k, j))))/dt
9995             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min37*field_old(i-1, k, j)+&
9996 &              0.5*max26*field_old(i, k, j))
9997             fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
9998 &              , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
9999             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
10000 &              , j))
10001             fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
10002             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
10003           END DO
10004         END IF
10005       END IF
10006       IF (degrade_xe) THEN
10007         IF (i_end .EQ. ide - 2) THEN
10008 ! second order flux next to the boundary
10009           i = ide - 1
10010           DO k=kts,ktf
10011 ! ADT eqn 48 d/dx
10012             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
10013             mud = 0.5*(mutd(i, j)+mutd(i-1, j))
10014             mu = 0.5*(mut(i, j)+mut(i-1, j))
10015             veld = rud(i, k, j)
10016             vel = ru(i, k, j)
10017             crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
10018             cr = vel*dt/dx/mu
10019             IF (cr .GE. 0.) THEN
10020               abs26d = crd
10021               abs26 = cr
10022             ELSE
10023               abs26d = -crd
10024               abs26 = -cr
10025             END IF
10026             y26d = crd + abs26d
10027             y26 = cr + abs26
10028             IF (1.0 .GT. y26) THEN
10029               min38d = y26d
10030               min38 = y26
10031             ELSE
10032               min38 = 1.0
10033               min38d = 0.0
10034             END IF
10035             IF (cr .GE. 0.) THEN
10036               abs77d = crd
10037               abs77 = cr
10038             ELSE
10039               abs77d = -crd
10040               abs77 = -cr
10041             END IF
10042             y77d = crd - abs77d
10043             y77 = cr - abs77
10044             IF (-1.0 .LT. y77) THEN
10045               max27d = y77d
10046               max27 = y77
10047             ELSE
10048               max27 = -1.0
10049               max27d = 0.0
10050             END IF
10051             fqxld(i, k, j) = dx*(mud*(0.5*min38*field_old(i-1, k, j)+0.5&
10052 &              *max27*field_old(i, k, j))+mu*(0.5*(min38d*field_old(i-1, &
10053 &              k, j)+min38*field_oldd(i-1, k, j))+0.5*(max27d*field_old(i&
10054 &              , k, j)+max27*field_oldd(i, k, j))))/dt
10055             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min38*field_old(i-1, k, j)+&
10056 &              0.5*max27*field_old(i, k, j))
10057             fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
10058 &              , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
10059             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
10060 &              , j))
10061             fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
10062             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
10063           END DO
10064         END IF
10065       END IF
10066     END DO
10067   ELSE IF (horz_order .EQ. 3) THEN
10068 ! enddo for outer J loop
10069 !--- end of 4th order horizontal flux calculation
10070     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
10071 &        its .GT. ids + 2) degrade_xs = .false.
10072     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
10073 &        ite .LT. ide - 1) degrade_xe = .false.
10074     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
10075 &        jts .GT. jds + 2) degrade_ys = .false.
10076     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
10077 &        jte .LT. jde - 1) degrade_ye = .false.
10078     IF (kte .GT. kde - 1) THEN
10079       ktf = kde - 1
10080     ELSE
10081       ktf = kte
10082     END IF
10083     i_start = its - 1
10084     IF (ite .GT. ide - 1) THEN
10085       min39 = ide - 1
10086     ELSE
10087       min39 = ite
10088     END IF
10089     i_end = min39 + 1
10090     j_start = jts - 1
10091     IF (jte .GT. jde - 1) THEN
10092       min40 = jde - 1
10093     ELSE
10094       min40 = jte
10095     END IF
10096     j_end = min40 + 1
10097     j_start_f = j_start
10098     j_end_f = j_end + 1
10099 !--  modify loop bounds if open or specified
10100     IF (degrade_xs) i_start = its
10101     IF (degrade_xe) THEN
10102       IF (ite .GT. ide - 1) THEN
10103         i_end = ide - 1
10104       ELSE
10105         i_end = ite
10106       END IF
10107     END IF
10108     IF (degrade_ys) THEN
10109       IF (jts .LT. jds + 1) THEN
10110         j_start = jds + 1
10111       ELSE
10112         j_start = jts
10113       END IF
10114       j_start_f = jds + 2
10115     END IF
10116     IF (degrade_ye) THEN
10117       IF (jte .GT. jde - 2) THEN
10118         j_end = jde - 2
10119       ELSE
10120         j_end = jte
10121       END IF
10122       j_end_f = jde - 2
10123       fqyld = 0.0
10124       fqyd = 0.0
10125     ELSE
10126       fqyld = 0.0
10127       fqyd = 0.0
10128     END IF
10129 !  compute fluxes, 3rd order
10130 j_loop_y_flux_3:DO j=j_start,j_end+1
10131       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
10132 ! use full stencil
10133         DO k=kts,ktf
10134           DO i=i_start,i_end
10135 ! ADT eqn 48 d/dy
10136             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
10137             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
10138             mu = 0.5*(mut(i, j)+mut(i, j-1))
10139             veld = rvd(i, k, j)
10140             vel = rv(i, k, j)
10141             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
10142             cr = vel*dt/dy/mu
10143             IF (cr .GE. 0.) THEN
10144               abs27d = crd
10145               abs27 = cr
10146             ELSE
10147               abs27d = -crd
10148               abs27 = -cr
10149             END IF
10150             y27d = crd + abs27d
10151             y27 = cr + abs27
10152             IF (1.0 .GT. y27) THEN
10153               min41d = y27d
10154               min41 = y27
10155             ELSE
10156               min41 = 1.0
10157               min41d = 0.0
10158             END IF
10159             IF (cr .GE. 0.) THEN
10160               abs78d = crd
10161               abs78 = cr
10162             ELSE
10163               abs78d = -crd
10164               abs78 = -cr
10165             END IF
10166             y78d = crd - abs78d
10167             y78 = cr - abs78
10168             IF (-1.0 .LT. y78) THEN
10169               max28d = y78d
10170               max28 = y78
10171             ELSE
10172               max28 = -1.0
10173               max28d = 0.0
10174             END IF
10175             fqyld(i, k, j) = dy*(mud*(0.5*min41*field_old(i, k, j-1)+0.5&
10176 &              *max28*field_old(i, k, j))+mu*(0.5*(min41d*field_old(i, k&
10177 &              , j-1)+min41*field_oldd(i, k, j-1))+0.5*(max28d*field_old(&
10178 &              i, k, j)+max28*field_oldd(i, k, j))))/dt
10179             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min41*field_old(i, k, j-1)+&
10180 &              0.5*max28*field_old(i, k, j))
10181             fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
10182 &              ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
10183 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
10184 &              i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) + vel*(&
10185 &              7.*(fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j&
10186 &              +1)+fieldd(i, k, j-2))/12.+SIGN(1, time_step)*SIGN(1., vel&
10187 &              )*(fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)&
10188 &              -fieldd(i, k, j-1)))/12.)
10189             fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
10190 &              -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
10191 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
10192 &              i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1))))
10193             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
10194             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
10195           END DO
10196         END DO
10197       ELSE IF (j .EQ. jds + 1) THEN
10198 ! 2nd order flux next to south boundary
10199         DO k=kts,ktf
10200           DO i=i_start,i_end
10201 ! ADT eqn 48 d/dy
10202             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
10203             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
10204             mu = 0.5*(mut(i, j)+mut(i, j-1))
10205             veld = rvd(i, k, j)
10206             vel = rv(i, k, j)
10207             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
10208             cr = vel*dt/dy/mu
10209             IF (cr .GE. 0.) THEN
10210               abs28d = crd
10211               abs28 = cr
10212             ELSE
10213               abs28d = -crd
10214               abs28 = -cr
10215             END IF
10216             y28d = crd + abs28d
10217             y28 = cr + abs28
10218             IF (1.0 .GT. y28) THEN
10219               min42d = y28d
10220               min42 = y28
10221             ELSE
10222               min42 = 1.0
10223               min42d = 0.0
10224             END IF
10225             IF (cr .GE. 0.) THEN
10226               abs79d = crd
10227               abs79 = cr
10228             ELSE
10229               abs79d = -crd
10230               abs79 = -cr
10231             END IF
10232             y79d = crd - abs79d
10233             y79 = cr - abs79
10234             IF (-1.0 .LT. y79) THEN
10235               max29d = y79d
10236               max29 = y79
10237             ELSE
10238               max29 = -1.0
10239               max29d = 0.0
10240             END IF
10241             fqyld(i, k, j) = dy*(mud*(0.5*min42*field_old(i, k, j-1)+0.5&
10242 &              *max29*field_old(i, k, j))+mu*(0.5*(min42d*field_old(i, k&
10243 &              , j-1)+min42*field_oldd(i, k, j-1))+0.5*(max29d*field_old(&
10244 &              i, k, j)+max29*field_oldd(i, k, j))))/dt
10245             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min42*field_old(i, k, j-1)+&
10246 &              0.5*max29*field_old(i, k, j))
10247             fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
10248 &              , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
10249             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
10250 &              -1))
10251             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
10252             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
10253           END DO
10254         END DO
10255       ELSE IF (j .EQ. jde - 1) THEN
10256 ! 2nd order flux next to north boundary
10257         DO k=kts,ktf
10258           DO i=i_start,i_end
10259 ! ADT eqn 48 d/dy
10260             dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
10261             mud = 0.5*(mutd(i, j)+mutd(i, j-1))
10262             mu = 0.5*(mut(i, j)+mut(i, j-1))
10263             veld = rvd(i, k, j)
10264             vel = rv(i, k, j)
10265             crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
10266             cr = vel*dt/dy/mu
10267             IF (cr .GE. 0.) THEN
10268               abs29d = crd
10269               abs29 = cr
10270             ELSE
10271               abs29d = -crd
10272               abs29 = -cr
10273             END IF
10274             y29d = crd + abs29d
10275             y29 = cr + abs29
10276             IF (1.0 .GT. y29) THEN
10277               min43d = y29d
10278               min43 = y29
10279             ELSE
10280               min43 = 1.0
10281               min43d = 0.0
10282             END IF
10283             IF (cr .GE. 0.) THEN
10284               abs80d = crd
10285               abs80 = cr
10286             ELSE
10287               abs80d = -crd
10288               abs80 = -cr
10289             END IF
10290             y80d = crd - abs80d
10291             y80 = cr - abs80
10292             IF (-1.0 .LT. y80) THEN
10293               max30d = y80d
10294               max30 = y80
10295             ELSE
10296               max30 = -1.0
10297               max30d = 0.0
10298             END IF
10299             fqyld(i, k, j) = dy*(mud*(0.5*min43*field_old(i, k, j-1)+0.5&
10300 &              *max30*field_old(i, k, j))+mu*(0.5*(min43d*field_old(i, k&
10301 &              , j-1)+min43*field_oldd(i, k, j-1))+0.5*(max30d*field_old(&
10302 &              i, k, j)+max30*field_oldd(i, k, j))))/dt
10303             fqyl(i, k, j) = mu*(dy/dt)*(0.5*min43*field_old(i, k, j-1)+&
10304 &              0.5*max30*field_old(i, k, j))
10305             fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
10306 &              , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
10307             fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
10308 &              -1))
10309             fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
10310             fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
10311           END DO
10312         END DO
10313       END IF
10314     END DO j_loop_y_flux_3
10315 !  next, x flux
10316 !--  these bounds are for periodic and sym conditions
10317     i_start = its - 1
10318     IF (ite .GT. ide - 1) THEN
10319       min44 = ide - 1
10320     ELSE
10321       min44 = ite
10322     END IF
10323     i_end = min44 + 1
10324     i_start_f = i_start
10325     i_end_f = i_end + 1
10326     j_start = jts - 1
10327     IF (jte .GT. jde - 1) THEN
10328       min45 = jde - 1
10329     ELSE
10330       min45 = jte
10331     END IF
10332     j_end = min45 + 1
10333 !--  modify loop bounds for open and specified b.c
10334     IF (degrade_ys) j_start = jts
10335     IF (degrade_ye) THEN
10336       IF (jte .GT. jde - 1) THEN
10337         j_end = jde - 1
10338       ELSE
10339         j_end = jte
10340       END IF
10341     END IF
10342     IF (degrade_xs) THEN
10343       IF (ids + 1 .LT. its) THEN
10344         i_start = its
10345       ELSE
10346         i_start = ids + 1
10347       END IF
10348       i_start_f = i_start + 1
10349     END IF
10350     IF (degrade_xe) THEN
10351       IF (ide - 2 .GT. ite) THEN
10352         i_end = ite
10353       ELSE
10354         i_end = ide - 2
10355       END IF
10356       i_end_f = ide - 2
10357       fqxld = 0.0
10358       fqxd = 0.0
10359     ELSE
10360       fqxld = 0.0
10361       fqxd = 0.0
10362     END IF
10363 !  compute fluxes
10364     DO j=j_start,j_end
10365 !  4th order flux
10366       DO k=kts,ktf
10367         DO i=i_start_f,i_end_f
10368 ! ADT eqn 48 d/dx
10369           dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
10370           mud = 0.5*(mutd(i, j)+mutd(i-1, j))
10371           mu = 0.5*(mut(i, j)+mut(i-1, j))
10372           veld = rud(i, k, j)
10373           vel = ru(i, k, j)
10374           crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
10375           cr = vel*dt/dx/mu
10376           IF (cr .GE. 0.) THEN
10377             abs30d = crd
10378             abs30 = cr
10379           ELSE
10380             abs30d = -crd
10381             abs30 = -cr
10382           END IF
10383           y30d = crd + abs30d
10384           y30 = cr + abs30
10385           IF (1.0 .GT. y30) THEN
10386             min46d = y30d
10387             min46 = y30
10388           ELSE
10389             min46 = 1.0
10390             min46d = 0.0
10391           END IF
10392           IF (cr .GE. 0.) THEN
10393             abs81d = crd
10394             abs81 = cr
10395           ELSE
10396             abs81d = -crd
10397             abs81 = -cr
10398           END IF
10399           y81d = crd - abs81d
10400           y81 = cr - abs81
10401           IF (-1.0 .LT. y81) THEN
10402             max31d = y81d
10403             max31 = y81
10404           ELSE
10405             max31 = -1.0
10406             max31d = 0.0
10407           END IF
10408           fqxld(i, k, j) = dx*(mud*(0.5*min46*field_old(i-1, k, j)+0.5*&
10409 &            max31*field_old(i, k, j))+mu*(0.5*(min46d*field_old(i-1, k, &
10410 &            j)+min46*field_oldd(i-1, k, j))+0.5*(max31d*field_old(i, k, &
10411 &            j)+max31*field_oldd(i, k, j))))/dt
10412           fqxl(i, k, j) = mu*(dx/dt)*(0.5*min46*field_old(i-1, k, j)+0.5&
10413 &            *max31*field_old(i, k, j))
10414           fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j))&
10415 &            -1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
10416 &            time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(i-&
10417 &            2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) + vel*(7.*(&
10418 &            fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k, j)+&
10419 &            fieldd(i-2, k, j))/12.+SIGN(1, time_step)*SIGN(1., vel)*(&
10420 &            fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i, k, j)-&
10421 &            fieldd(i-1, k, j)))/12.)
10422           fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-&
10423 &            1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, time_step&
10424 &            )*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-&
10425 &            3.*(field(i, k, j)-field(i-1, k, j))))
10426           fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
10427           fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
10428         END DO
10429       END DO
10430 !  lower order fluxes close to boundaries (if not periodic or symmetric)
10431       IF (degrade_xs) THEN
10432         IF (i_start .EQ. ids + 1) THEN
10433 ! second order flux next to the boundary
10434           i = ids + 1
10435           DO k=kts,ktf
10436 ! ADT eqn 48 d/dx
10437             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
10438             mud = 0.5*(mutd(i, j)+mutd(i-1, j))
10439             mu = 0.5*(mut(i, j)+mut(i-1, j))
10440             veld = (rud(i, k, j)*mu-ru(i, k, j)*mud)/mu**2
10441             vel = ru(i, k, j)/mu
10442             crd = dt*veld/dx
10443             cr = vel*dt/dx
10444             IF (cr .GE. 0.) THEN
10445               abs31d = crd
10446               abs31 = cr
10447             ELSE
10448               abs31d = -crd
10449               abs31 = -cr
10450             END IF
10451             y31d = crd + abs31d
10452             y31 = cr + abs31
10453             IF (1.0 .GT. y31) THEN
10454               min47d = y31d
10455               min47 = y31
10456             ELSE
10457               min47 = 1.0
10458               min47d = 0.0
10459             END IF
10460             IF (cr .GE. 0.) THEN
10461               abs82d = crd
10462               abs82 = cr
10463             ELSE
10464               abs82d = -crd
10465               abs82 = -cr
10466             END IF
10467             y82d = crd - abs82d
10468             y82 = cr - abs82
10469             IF (-1.0 .LT. y82) THEN
10470               max32d = y82d
10471               max32 = y82
10472             ELSE
10473               max32 = -1.0
10474               max32d = 0.0
10475             END IF
10476             fqxld(i, k, j) = dx*(mud*(0.5*min47*field_old(i-1, k, j)+0.5&
10477 &              *max32*field_old(i, k, j))+mu*(0.5*(min47d*field_old(i-1, &
10478 &              k, j)+min47*field_oldd(i-1, k, j))+0.5*(max32d*field_old(i&
10479 &              , k, j)+max32*field_oldd(i, k, j))))/dt
10480             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min47*field_old(i-1, k, j)+&
10481 &              0.5*max32*field_old(i, k, j))
10482             fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
10483 &              , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
10484             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
10485 &              , j))
10486             fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
10487             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
10488           END DO
10489         END IF
10490       END IF
10491       IF (degrade_xe) THEN
10492         IF (i_end .EQ. ide - 2) THEN
10493 ! second order flux next to the boundary
10494           i = ide - 1
10495           DO k=kts,ktf
10496 ! ADT eqn 48 d/dx
10497             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
10498             mud = 0.5*(mutd(i, j)+mutd(i-1, j))
10499             mu = 0.5*(mut(i, j)+mut(i-1, j))
10500             veld = rud(i, k, j)
10501             vel = ru(i, k, j)
10502             crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
10503             cr = vel*dt/dx/mu
10504             IF (cr .GE. 0.) THEN
10505               abs32d = crd
10506               abs32 = cr
10507             ELSE
10508               abs32d = -crd
10509               abs32 = -cr
10510             END IF
10511             y32d = crd + abs32d
10512             y32 = cr + abs32
10513             IF (1.0 .GT. y32) THEN
10514               min48d = y32d
10515               min48 = y32
10516             ELSE
10517               min48 = 1.0
10518               min48d = 0.0
10519             END IF
10520             IF (cr .GE. 0.) THEN
10521               abs83d = crd
10522               abs83 = cr
10523             ELSE
10524               abs83d = -crd
10525               abs83 = -cr
10526             END IF
10527             y83d = crd - abs83d
10528             y83 = cr - abs83
10529             IF (-1.0 .LT. y83) THEN
10530               max33d = y83d
10531               max33 = y83
10532             ELSE
10533               max33 = -1.0
10534               max33d = 0.0
10535             END IF
10536             fqxld(i, k, j) = dx*(mud*(0.5*min48*field_old(i-1, k, j)+0.5&
10537 &              *max33*field_old(i, k, j))+mu*(0.5*(min48d*field_old(i-1, &
10538 &              k, j)+min48*field_oldd(i-1, k, j))+0.5*(max33d*field_old(i&
10539 &              , k, j)+max33*field_oldd(i, k, j))))/dt
10540             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min48*field_old(i-1, k, j)+&
10541 &              0.5*max33*field_old(i, k, j))
10542             fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
10543 &              , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
10544             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
10545 &              , j))
10546             fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
10547             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
10548           END DO
10549         END IF
10550       END IF
10551     END DO
10552   ELSE IF (horz_order .EQ. 2) THEN
10553 ! enddo for outer J loop
10554 !--- end of 3rd order horizontal flux calculation
10555     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
10556 &        its .GT. ids + 1) degrade_xs = .false.
10557     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
10558 &        ite .LT. ide - 2) degrade_xe = .false.
10559     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
10560 &        jts .GT. jds + 1) degrade_ys = .false.
10561     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
10562 &        jte .LT. jde - 2) degrade_ye = .false.
10563     IF (kte .GT. kde - 1) THEN
10564       ktf = kde - 1
10565     ELSE
10566       ktf = kte
10567     END IF
10568     i_start = its - 1
10569     IF (ite .GT. ide - 1) THEN
10570       min49 = ide - 1
10571     ELSE
10572       min49 = ite
10573     END IF
10574     i_end = min49 + 1
10575     j_start = jts - 1
10576     IF (jte .GT. jde - 1) THEN
10577       min50 = jde - 1
10578     ELSE
10579       min50 = jte
10580     END IF
10581     j_end = min50 + 1
10582 !--  modify loop bounds if open or specified
10583     IF (degrade_xs) i_start = its
10584     IF (degrade_xe) THEN
10585       IF (ite .GT. ide - 1) THEN
10586         i_end = ide - 1
10587       ELSE
10588         i_end = ite
10589       END IF
10590     END IF
10591     IF (degrade_ys) THEN
10592       IF (jts .LT. jds + 1) THEN
10593         j_start = jds + 1
10594       ELSE
10595         j_start = jts
10596       END IF
10597     END IF
10598     IF (degrade_ye) THEN
10599       IF (jte .GT. jde - 2) THEN
10600         j_end = jde - 2
10601       ELSE
10602         j_end = jte
10603       END IF
10604       fqyld = 0.0
10605       fqyd = 0.0
10606     ELSE
10607       fqyld = 0.0
10608       fqyd = 0.0
10609     END IF
10610 !  compute fluxes, 2nd order, y flux
10611     DO j=j_start,j_end+1
10612       DO k=kts,ktf
10613         DO i=i_start,i_end
10614 ! ADT eqn 48 d/dy
10615           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
10616           mud = 0.5*(mutd(i, j)+mutd(i, j-1))
10617           mu = 0.5*(mut(i, j)+mut(i, j-1))
10618           veld = rvd(i, k, j)
10619           vel = rv(i, k, j)
10620           crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
10621           cr = vel*dt/dy/mu
10622           IF (cr .GE. 0.) THEN
10623             abs33d = crd
10624             abs33 = cr
10625           ELSE
10626             abs33d = -crd
10627             abs33 = -cr
10628           END IF
10629           y33d = crd + abs33d
10630           y33 = cr + abs33
10631           IF (1.0 .GT. y33) THEN
10632             min51d = y33d
10633             min51 = y33
10634           ELSE
10635             min51 = 1.0
10636             min51d = 0.0
10637           END IF
10638           IF (cr .GE. 0.) THEN
10639             abs84d = crd
10640             abs84 = cr
10641           ELSE
10642             abs84d = -crd
10643             abs84 = -cr
10644           END IF
10645           y84d = crd - abs84d
10646           y84 = cr - abs84
10647           IF (-1.0 .LT. y84) THEN
10648             max34d = y84d
10649             max34 = y84
10650           ELSE
10651             max34 = -1.0
10652             max34d = 0.0
10653           END IF
10654           fqyld(i, k, j) = dy*(mud*(0.5*min51*field_old(i, k, j-1)+0.5*&
10655 &            max34*field_old(i, k, j))+mu*(0.5*(min51d*field_old(i, k, j-&
10656 &            1)+min51*field_oldd(i, k, j-1))+0.5*(max34d*field_old(i, k, &
10657 &            j)+max34*field_oldd(i, k, j))))/dt
10658           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min51*field_old(i, k, j-1)+0.5&
10659 &            *max34*field_old(i, k, j))
10660           fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k, &
10661 &            j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
10662           fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1&
10663 &            ))
10664           fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
10665           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
10666         END DO
10667       END DO
10668     END DO
10669     fqxld = 0.0
10670     fqxd = 0.0
10671 !  next, x flux
10672     DO j=j_start,j_end
10673       DO k=kts,ktf
10674         DO i=i_start,i_end+1
10675 ! ADT eqn 48 d/dx
10676           dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
10677           mud = 0.5*(mutd(i, j)+mutd(i-1, j))
10678           mu = 0.5*(mut(i, j)+mut(i-1, j))
10679           veld = rud(i, k, j)
10680           vel = ru(i, k, j)
10681           crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
10682           cr = vel*dt/dx/mu
10683           IF (cr .GE. 0.) THEN
10684             abs34d = crd
10685             abs34 = cr
10686           ELSE
10687             abs34d = -crd
10688             abs34 = -cr
10689           END IF
10690           y34d = crd + abs34d
10691           y34 = cr + abs34
10692           IF (1.0 .GT. y34) THEN
10693             min52d = y34d
10694             min52 = y34
10695           ELSE
10696             min52 = 1.0
10697             min52d = 0.0
10698           END IF
10699           IF (cr .GE. 0.) THEN
10700             abs85d = crd
10701             abs85 = cr
10702           ELSE
10703             abs85d = -crd
10704             abs85 = -cr
10705           END IF
10706           y85d = crd - abs85d
10707           y85 = cr - abs85
10708           IF (-1.0 .LT. y85) THEN
10709             max35d = y85d
10710             max35 = y85
10711           ELSE
10712             max35 = -1.0
10713             max35d = 0.0
10714           END IF
10715           fqxld(i, k, j) = dx*(mud*(0.5*min52*field_old(i-1, k, j)+0.5*&
10716 &            max35*field_old(i, k, j))+mu*(0.5*(min52d*field_old(i-1, k, &
10717 &            j)+min52*field_oldd(i-1, k, j))+0.5*(max35d*field_old(i, k, &
10718 &            j)+max35*field_oldd(i, k, j))))/dt
10719           fqxl(i, k, j) = mu*(dx/dt)*(0.5*min52*field_old(i-1, k, j)+0.5&
10720 &            *max35*field_old(i, k, j))
10721           fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, k&
10722 &            , j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
10723           fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, j&
10724 &            ))
10725           fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
10726           fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
10727         END DO
10728       END DO
10729     END DO
10730   ELSE
10731 !--- end of 2nd order horizontal flux calculation
10732     WRITE(wrf_err_message, *) &
10733 &    'module_advect: advect_scalar_pd, h_order not known ', horz_order
10734     CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
10735     fqxld = 0.0
10736     fqyld = 0.0
10737     fqxd = 0.0
10738     fqyd = 0.0
10739   END IF
10740 !  pick up the rest of the horizontal radiation boundary conditions.
10741 !  (these are the computations that don't require 'cb'.
10742 !  first, set to index ranges
10743   i_start = its
10744   IF (ite .GT. ide - 1) THEN
10745     i_end = ide - 1
10746   ELSE
10747     i_end = ite
10748   END IF
10749   j_start = jts
10750   IF (jte .GT. jde - 1) THEN
10751     j_end = jde - 1
10752   ELSE
10753     j_end = jte
10754   END IF
10755 !  compute x (u) conditions for v, w, or scalar
10756   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
10757     DO j=j_start,j_end
10758       DO k=kts,ktf
10759         IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
10760           ub = 0.
10761           ubd = 0.0
10762         ELSE
10763           ubd = 0.5*(rud(its, k, j)+rud(its+1, k, j))
10764           ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
10765         END IF
10766         tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(&
10767 &          field_old(its+1, k, j)-field_old(its, k, j))+ub*(field_oldd(&
10768 &          its+1, k, j)-field_oldd(its, k, j))+fieldd(its, k, j)*(ru(its+&
10769 &          1, k, j)-ru(its, k, j))+field(its, k, j)*(rud(its+1, k, j)-rud&
10770 &          (its, k, j)))
10771         tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(field_old(&
10772 &          its+1, k, j)-field_old(its, k, j))+field(its, k, j)*(ru(its+1&
10773 &          , k, j)-ru(its, k, j)))
10774       END DO
10775     END DO
10776   END IF
10777   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
10778     DO j=j_start,j_end
10779       DO k=kts,ktf
10780         IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
10781           ub = 0.
10782           ubd = 0.0
10783         ELSE
10784           ubd = 0.5*(rud(ite-1, k, j)+rud(ite, k, j))
10785           ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
10786         END IF
10787         tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
10788 &          field_old(i_end, k, j)-field_old(i_end-1, k, j))+ub*(&
10789 &          field_oldd(i_end, k, j)-field_oldd(i_end-1, k, j))+fieldd(&
10790 &          i_end, k, j)*(ru(ite, k, j)-ru(ite-1, k, j))+field(i_end, k, j&
10791 &          )*(rud(ite, k, j)-rud(ite-1, k, j)))
10792         tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(&
10793 &          field_old(i_end, k, j)-field_old(i_end-1, k, j))+field(i_end, &
10794 &          k, j)*(ru(ite, k, j)-ru(ite-1, k, j)))
10795       END DO
10796     END DO
10797   END IF
10798   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
10799     DO i=i_start,i_end
10800       DO k=kts,ktf
10801         IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
10802           vb = 0.
10803           vbd = 0.0
10804         ELSE
10805           vbd = 0.5*(rvd(i, k, jts)+rvd(i, k, jts+1))
10806           vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
10807         END IF
10808         tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
10809 &          field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
10810 &          , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*(rv(i, k&
10811 &          , jts+1)-rv(i, k, jts))+field(i, k, jts)*(rvd(i, k, jts+1)-rvd&
10812 &          (i, k, jts)))
10813         tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
10814 &          , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*(rv(i, k, &
10815 &          jts+1)-rv(i, k, jts)))
10816       END DO
10817     END DO
10818   END IF
10819   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
10820     DO i=i_start,i_end
10821       DO k=kts,ktf
10822         IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
10823           vb = 0.
10824           vbd = 0.0
10825         ELSE
10826           vbd = 0.5*(rvd(i, k, jte-1)+rvd(i, k, jte))
10827           vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
10828         END IF
10829         tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
10830 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
10831 &          field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))+fieldd(i, k&
10832 &          , j_end)*(rv(i, k, jte)-rv(i, k, jte-1))+field(i, k, j_end)*(&
10833 &          rvd(i, k, jte)-rvd(i, k, jte-1)))
10834         tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
10835 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
10836 &          j_end)*(rv(i, k, jte)-rv(i, k, jte-1)))
10837       END DO
10838     END DO
10839   END IF
10840   IF (config_flags%polar .AND. jts .EQ. jds) THEN
10841 ! Assuming rv(i,k,jds) = 0.
10842     DO i=i_start,i_end
10843       DO k=kts,ktf
10844         IF (0.5*rv(i, k, jts+1) .GT. 0.) THEN
10845           vb = 0.
10846           vbd = 0.0
10847         ELSE
10848           vbd = 0.5*rvd(i, k, jts+1)
10849           vb = 0.5*rv(i, k, jts+1)
10850         END IF
10851         tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
10852 &          field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
10853 &          , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*rv(i, k, &
10854 &          jts+1)+field(i, k, jts)*rvd(i, k, jts+1))
10855         tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
10856 &          , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*rv(i, k, &
10857 &          jts+1))
10858       END DO
10859     END DO
10860   END IF
10861   IF (config_flags%polar .AND. jte .EQ. jde) THEN
10862 ! Assuming rv(i,k,jde) = 0.
10863     DO i=i_start,i_end
10864       DO k=kts,ktf
10865         IF (0.5*rv(i, k, jte-1) .LT. 0.) THEN
10866           vb = 0.
10867           vbd = 0.0
10868         ELSE
10869           vbd = 0.5*rvd(i, k, jte-1)
10870           vb = 0.5*rv(i, k, jte-1)
10871         END IF
10872         tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
10873 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
10874 &          field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))-fieldd(i, k&
10875 &          , j_end)*rv(i, k, jte-1)-field(i, k, j_end)*rvd(i, k, jte-1))
10876         tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
10877 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
10878 &          j_end)*(-rv(i, k, jte-1)))
10879       END DO
10880     END DO
10881   END IF
10882 !-------------------- vertical advection
10883 !-- loop bounds for periodic or sym conditions
10884   i_start = its - 1
10885   IF (ite .GT. ide - 1) THEN
10886     min53 = ide - 1
10887   ELSE
10888     min53 = ite
10889   END IF
10890   i_end = min53 + 1
10891   j_start = jts - 1
10892   IF (jte .GT. jde - 1) THEN
10893     min54 = jde - 1
10894   ELSE
10895     min54 = jte
10896   END IF
10897   j_end = min54 + 1
10898 !-- loop bounds for open or specified conditions
10899   IF (degrade_xs) THEN
10900     IF (its - 1 .LT. ids) THEN
10901       i_start = ids
10902     ELSE
10903       i_start = its - 1
10904     END IF
10905   END IF
10906   IF (degrade_xe) THEN
10907     IF (ite + 1 .GT. ide - 1) THEN
10908       i_end = ide - 1
10909     ELSE
10910       i_end = ite + 1
10911     END IF
10912   END IF
10913   IF (degrade_ys) THEN
10914     IF (jts - 1 .LT. jds) THEN
10915       j_start = jds
10916     ELSE
10917       j_start = jts - 1
10918     END IF
10919   END IF
10920   IF (degrade_ye) THEN
10921     IF (jte + 1 .GT. jde - 1) THEN
10922       j_end = jde - 1
10923     ELSE
10924       j_end = jte + 1
10925     END IF
10926   END IF
10927   IF (vert_order .EQ. 6) THEN
10928     fqzd = 0.0
10929     fqzld = 0.0
10930     DO j=j_start,j_end
10931       DO i=i_start,i_end
10932         fqzd(i, 1, j) = 0.0
10933         fqz(i, 1, j) = 0.
10934         fqzld(i, 1, j) = 0.0
10935         fqzl(i, 1, j) = 0.
10936         fqzd(i, kde, j) = 0.0
10937         fqz(i, kde, j) = 0.
10938         fqzld(i, kde, j) = 0.0
10939         fqzl(i, kde, j) = 0.
10940       END DO
10941       DO k=kts+3,ktf-2
10942         DO i=i_start,i_end
10943           dz = 2./(rdzw(k)+rdzw(k-1))
10944           mud = 0.5*2*mutd(i, j)
10945           mu = 0.5*(mut(i, j)+mut(i, j))
10946           veld = romd(i, k, j)
10947           vel = rom(i, k, j)
10948           crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
10949           cr = vel*dt/dz/mu
10950           IF (cr .GE. 0.) THEN
10951             abs35d = crd
10952             abs35 = cr
10953           ELSE
10954             abs35d = -crd
10955             abs35 = -cr
10956           END IF
10957           y35d = crd + abs35d
10958           y35 = cr + abs35
10959           IF (1.0 .GT. y35) THEN
10960             min55d = y35d
10961             min55 = y35
10962           ELSE
10963             min55 = 1.0
10964             min55d = 0.0
10965           END IF
10966           IF (cr .GE. 0.) THEN
10967             abs86d = crd
10968             abs86 = cr
10969           ELSE
10970             abs86d = -crd
10971             abs86 = -cr
10972           END IF
10973           y86d = crd - abs86d
10974           y86 = cr - abs86
10975           IF (-1.0 .LT. y86) THEN
10976             max36d = y86d
10977             max36 = y86
10978           ELSE
10979             max36 = -1.0
10980             max36d = 0.0
10981           END IF
10982           fqzld(i, k, j) = dz*(mud*(0.5*min55*field_old(i, k-1, j)+0.5*&
10983 &            max36*field_old(i, k, j))+mu*(0.5*(min55d*field_old(i, k-1, &
10984 &            j)+min55*field_oldd(i, k-1, j))+0.5*(max36d*field_old(i, k, &
10985 &            j)+max36*field_oldd(i, k, j))))/dt
10986           fqzl(i, k, j) = mu*(dz/dt)*(0.5*min55*field_old(i, k-1, j)+0.5&
10987 &            *max36*field_old(i, k, j))
10988           fqzd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i, k-1, j)&
10989 &            )-2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i&
10990 &            , k+2, j)+field(i, k-3, j))) + vel*(37.*(fieldd(i, k, j)+&
10991 &            fieldd(i, k-1, j))/60.-2.*(fieldd(i, k+1, j)+fieldd(i, k-2, &
10992 &            j))/15.+(fieldd(i, k+2, j)+fieldd(i, k-3, j))/60.)
10993           fqz(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k-1, j))-&
10994 &            2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i, &
10995 &            k+2, j)+field(i, k-3, j)))
10996           fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
10997           fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
10998         END DO
10999       END DO
11000       DO i=i_start,i_end
11001         k = kts + 1
11002         dz = 2./(rdzw(k)+rdzw(k-1))
11003         mud = 0.5*2*mutd(i, j)
11004         mu = 0.5*(mut(i, j)+mut(i, j))
11005         veld = romd(i, k, j)
11006         vel = rom(i, k, j)
11007         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11008         cr = vel*dt/dz/mu
11009         IF (cr .GE. 0.) THEN
11010           abs36d = crd
11011           abs36 = cr
11012         ELSE
11013           abs36d = -crd
11014           abs36 = -cr
11015         END IF
11016         y36d = crd + abs36d
11017         y36 = cr + abs36
11018         IF (1.0 .GT. y36) THEN
11019           min56d = y36d
11020           min56 = y36
11021         ELSE
11022           min56 = 1.0
11023           min56d = 0.0
11024         END IF
11025         IF (cr .GE. 0.) THEN
11026           abs87d = crd
11027           abs87 = cr
11028         ELSE
11029           abs87d = -crd
11030           abs87 = -cr
11031         END IF
11032         y87d = crd - abs87d
11033         y87 = cr - abs87
11034         IF (-1.0 .LT. y87) THEN
11035           max37d = y87d
11036           max37 = y87
11037         ELSE
11038           max37 = -1.0
11039           max37d = 0.0
11040         END IF
11041         fqzld(i, k, j) = dz*(mud*(0.5*min56*field_old(i, k-1, j)+0.5*&
11042 &          max37*field_old(i, k, j))+mu*(0.5*(min56d*field_old(i, k-1, j)&
11043 &          +min56*field_oldd(i, k-1, j))+0.5*(max37d*field_old(i, k, j)+&
11044 &          max37*field_oldd(i, k, j))))/dt
11045         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min56*field_old(i, k-1, j)+0.5*&
11046 &          max37*field_old(i, k, j))
11047         fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
11048 &          field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
11049 &          )*fieldd(i, k-1, j))
11050         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
11051 &          i, k-1, j))
11052         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11053         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11054         k = kts + 2
11055         dz = 2./(rdzw(k)+rdzw(k-1))
11056         mud = 0.5*2*mutd(i, j)
11057         mu = 0.5*(mut(i, j)+mut(i, j))
11058         veld = romd(i, k, j)
11059         vel = rom(i, k, j)
11060         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11061         cr = vel*dt/dz/mu
11062         IF (cr .GE. 0.) THEN
11063           abs37d = crd
11064           abs37 = cr
11065         ELSE
11066           abs37d = -crd
11067           abs37 = -cr
11068         END IF
11069         y37d = crd + abs37d
11070         y37 = cr + abs37
11071         IF (1.0 .GT. y37) THEN
11072           min57d = y37d
11073           min57 = y37
11074         ELSE
11075           min57 = 1.0
11076           min57d = 0.0
11077         END IF
11078         IF (cr .GE. 0.) THEN
11079           abs88d = crd
11080           abs88 = cr
11081         ELSE
11082           abs88d = -crd
11083           abs88 = -cr
11084         END IF
11085         y88d = crd - abs88d
11086         y88 = cr - abs88
11087         IF (-1.0 .LT. y88) THEN
11088           max38d = y88d
11089           max38 = y88
11090         ELSE
11091           max38 = -1.0
11092           max38d = 0.0
11093         END IF
11094         fqzld(i, k, j) = dz*(mud*(0.5*min57*field_old(i, k-1, j)+0.5*&
11095 &          max38*field_old(i, k, j))+mu*(0.5*(min57d*field_old(i, k-1, j)&
11096 &          +min57*field_oldd(i, k-1, j))+0.5*(max38d*field_old(i, k, j)+&
11097 &          max38*field_oldd(i, k, j))))/dt
11098         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min57*field_old(i, k-1, j)+0.5*&
11099 &          max38*field_old(i, k, j))
11100         fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
11101 &          1./12.*(field(i, k+1, j)+field(i, k-2, j))) + vel*(7.*(fieldd(&
11102 &          i, k, j)+fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k&
11103 &          -2, j))/12.)
11104         fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
11105 &          12.*(field(i, k+1, j)+field(i, k-2, j)))
11106         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11107         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11108         k = ktf - 1
11109         dz = 2./(rdzw(k)+rdzw(k-1))
11110         mud = 0.5*2*mutd(i, j)
11111         mu = 0.5*(mut(i, j)+mut(i, j))
11112         veld = romd(i, k, j)
11113         vel = rom(i, k, j)
11114         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11115         cr = vel*dt/dz/mu
11116         IF (cr .GE. 0.) THEN
11117           abs38d = crd
11118           abs38 = cr
11119         ELSE
11120           abs38d = -crd
11121           abs38 = -cr
11122         END IF
11123         y38d = crd + abs38d
11124         y38 = cr + abs38
11125         IF (1.0 .GT. y38) THEN
11126           min58d = y38d
11127           min58 = y38
11128         ELSE
11129           min58 = 1.0
11130           min58d = 0.0
11131         END IF
11132         IF (cr .GE. 0.) THEN
11133           abs89d = crd
11134           abs89 = cr
11135         ELSE
11136           abs89d = -crd
11137           abs89 = -cr
11138         END IF
11139         y89d = crd - abs89d
11140         y89 = cr - abs89
11141         IF (-1.0 .LT. y89) THEN
11142           max39d = y89d
11143           max39 = y89
11144         ELSE
11145           max39 = -1.0
11146           max39d = 0.0
11147         END IF
11148         fqzld(i, k, j) = dz*(mud*(0.5*min58*field_old(i, k-1, j)+0.5*&
11149 &          max39*field_old(i, k, j))+mu*(0.5*(min58d*field_old(i, k-1, j)&
11150 &          +min58*field_oldd(i, k-1, j))+0.5*(max39d*field_old(i, k, j)+&
11151 &          max39*field_oldd(i, k, j))))/dt
11152         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min58*field_old(i, k-1, j)+0.5*&
11153 &          max39*field_old(i, k, j))
11154         fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
11155 &          1./12.*(field(i, k+1, j)+field(i, k-2, j))) + vel*(7.*(fieldd(&
11156 &          i, k, j)+fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k&
11157 &          -2, j))/12.)
11158         fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
11159 &          12.*(field(i, k+1, j)+field(i, k-2, j)))
11160         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11161         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11162         k = ktf
11163         dz = 2./(rdzw(k)+rdzw(k-1))
11164         mud = 0.5*2*mutd(i, j)
11165         mu = 0.5*(mut(i, j)+mut(i, j))
11166         veld = romd(i, k, j)
11167         vel = rom(i, k, j)
11168         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11169         cr = vel*dt/dz/mu
11170         IF (cr .GE. 0.) THEN
11171           abs39d = crd
11172           abs39 = cr
11173         ELSE
11174           abs39d = -crd
11175           abs39 = -cr
11176         END IF
11177         y39d = crd + abs39d
11178         y39 = cr + abs39
11179         IF (1.0 .GT. y39) THEN
11180           min59d = y39d
11181           min59 = y39
11182         ELSE
11183           min59 = 1.0
11184           min59d = 0.0
11185         END IF
11186         IF (cr .GE. 0.) THEN
11187           abs90d = crd
11188           abs90 = cr
11189         ELSE
11190           abs90d = -crd
11191           abs90 = -cr
11192         END IF
11193         y90d = crd - abs90d
11194         y90 = cr - abs90
11195         IF (-1.0 .LT. y90) THEN
11196           max40d = y90d
11197           max40 = y90
11198         ELSE
11199           max40 = -1.0
11200           max40d = 0.0
11201         END IF
11202         fqzld(i, k, j) = dz*(mud*(0.5*min59*field_old(i, k-1, j)+0.5*&
11203 &          max40*field_old(i, k, j))+mu*(0.5*(min59d*field_old(i, k-1, j)&
11204 &          +min59*field_oldd(i, k-1, j))+0.5*(max40d*field_old(i, k, j)+&
11205 &          max40*field_oldd(i, k, j))))/dt
11206         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min59*field_old(i, k-1, j)+0.5*&
11207 &          max40*field_old(i, k, j))
11208         fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
11209 &          field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
11210 &          )*fieldd(i, k-1, j))
11211         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
11212 &          i, k-1, j))
11213         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11214         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11215       END DO
11216     END DO
11217   ELSE IF (vert_order .EQ. 5) THEN
11218     fqzd = 0.0
11219     fqzld = 0.0
11220     DO j=j_start,j_end
11221       DO i=i_start,i_end
11222         fqzd(i, 1, j) = 0.0
11223         fqz(i, 1, j) = 0.
11224         fqzld(i, 1, j) = 0.0
11225         fqzl(i, 1, j) = 0.
11226         fqzd(i, kde, j) = 0.0
11227         fqz(i, kde, j) = 0.
11228         fqzld(i, kde, j) = 0.0
11229         fqzl(i, kde, j) = 0.
11230       END DO
11231       DO k=kts+3,ktf-2
11232         DO i=i_start,i_end
11233           dz = 2./(rdzw(k)+rdzw(k-1))
11234           mud = 0.5*2*mutd(i, j)
11235           mu = 0.5*(mut(i, j)+mut(i, j))
11236           veld = romd(i, k, j)
11237           vel = rom(i, k, j)
11238           crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11239           cr = vel*dt/dz/mu
11240           IF (cr .GE. 0.) THEN
11241             abs40d = crd
11242             abs40 = cr
11243           ELSE
11244             abs40d = -crd
11245             abs40 = -cr
11246           END IF
11247           y40d = crd + abs40d
11248           y40 = cr + abs40
11249           IF (1.0 .GT. y40) THEN
11250             min60d = y40d
11251             min60 = y40
11252           ELSE
11253             min60 = 1.0
11254             min60d = 0.0
11255           END IF
11256           IF (cr .GE. 0.) THEN
11257             abs91d = crd
11258             abs91 = cr
11259           ELSE
11260             abs91d = -crd
11261             abs91 = -cr
11262           END IF
11263           y91d = crd - abs91d
11264           y91 = cr - abs91
11265           IF (-1.0 .LT. y91) THEN
11266             max41d = y91d
11267             max41 = y91
11268           ELSE
11269             max41 = -1.0
11270             max41d = 0.0
11271           END IF
11272           fqzld(i, k, j) = dz*(mud*(0.5*min60*field_old(i, k-1, j)+0.5*&
11273 &            max41*field_old(i, k, j))+mu*(0.5*(min60d*field_old(i, k-1, &
11274 &            j)+min60*field_oldd(i, k-1, j))+0.5*(max41d*field_old(i, k, &
11275 &            j)+max41*field_oldd(i, k, j))))/dt
11276           fqzl(i, k, j) = mu*(dz/dt)*(0.5*min60*field_old(i, k-1, j)+0.5&
11277 &            *max41*field_old(i, k, j))
11278           fqzd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i, k-1, j)&
11279 &            )-2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i&
11280 &            , k+2, j)+field(i, k-3, j))-SIGN(1, time_step)*SIGN(1., -vel&
11281 &            )*(1./60.)*(field(i, k+2, j)-field(i, k-3, j)-5.*(field(i, k&
11282 &            +1, j)-field(i, k-2, j))+10.*(field(i, k, j)-field(i, k-1, j&
11283 &            )))) + vel*(37.*(fieldd(i, k, j)+fieldd(i, k-1, j))/60.-2.*(&
11284 &            fieldd(i, k+1, j)+fieldd(i, k-2, j))/15.+(fieldd(i, k+2, j)+&
11285 &            fieldd(i, k-3, j))/60.-SIGN(1, time_step)*SIGN(1., -vel)*(&
11286 &            fieldd(i, k+2, j)-fieldd(i, k-3, j)-5.*(fieldd(i, k+1, j)-&
11287 &            fieldd(i, k-2, j))+10.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/&
11288 &            60.)
11289           fqz(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k-1, j))-&
11290 &            2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i, &
11291 &            k+2, j)+field(i, k-3, j))-SIGN(1, time_step)*SIGN(1., -vel)*&
11292 &            (1./60.)*(field(i, k+2, j)-field(i, k-3, j)-5.*(field(i, k+1&
11293 &            , j)-field(i, k-2, j))+10.*(field(i, k, j)-field(i, k-1, j))&
11294 &            ))
11295           fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11296           fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11297         END DO
11298       END DO
11299       DO i=i_start,i_end
11300         k = kts + 1
11301         dz = 2./(rdzw(k)+rdzw(k-1))
11302         mud = 0.5*2*mutd(i, j)
11303         mu = 0.5*(mut(i, j)+mut(i, j))
11304         veld = romd(i, k, j)
11305         vel = rom(i, k, j)
11306         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11307         cr = vel*dt/dz/mu
11308         IF (cr .GE. 0.) THEN
11309           abs41d = crd
11310           abs41 = cr
11311         ELSE
11312           abs41d = -crd
11313           abs41 = -cr
11314         END IF
11315         y41d = crd + abs41d
11316         y41 = cr + abs41
11317         IF (1.0 .GT. y41) THEN
11318           min61d = y41d
11319           min61 = y41
11320         ELSE
11321           min61 = 1.0
11322           min61d = 0.0
11323         END IF
11324         IF (cr .GE. 0.) THEN
11325           abs92d = crd
11326           abs92 = cr
11327         ELSE
11328           abs92d = -crd
11329           abs92 = -cr
11330         END IF
11331         y92d = crd - abs92d
11332         y92 = cr - abs92
11333         IF (-1.0 .LT. y92) THEN
11334           max42d = y92d
11335           max42 = y92
11336         ELSE
11337           max42 = -1.0
11338           max42d = 0.0
11339         END IF
11340         fqzld(i, k, j) = dz*(mud*(0.5*min61*field_old(i, k-1, j)+0.5*&
11341 &          max42*field_old(i, k, j))+mu*(0.5*(min61d*field_old(i, k-1, j)&
11342 &          +min61*field_oldd(i, k-1, j))+0.5*(max42d*field_old(i, k, j)+&
11343 &          max42*field_oldd(i, k, j))))/dt
11344         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min61*field_old(i, k-1, j)+0.5*&
11345 &          max42*field_old(i, k, j))
11346         fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
11347 &          field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
11348 &          )*fieldd(i, k-1, j))
11349         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
11350 &          i, k-1, j))
11351         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11352         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11353         k = kts + 2
11354         dz = 2./(rdzw(k)+rdzw(k-1))
11355         mud = 0.5*2*mutd(i, j)
11356         mu = 0.5*(mut(i, j)+mut(i, j))
11357         veld = romd(i, k, j)
11358         vel = rom(i, k, j)
11359         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11360         cr = vel*dt/dz/mu
11361         IF (cr .GE. 0.) THEN
11362           abs42d = crd
11363           abs42 = cr
11364         ELSE
11365           abs42d = -crd
11366           abs42 = -cr
11367         END IF
11368         y42d = crd + abs42d
11369         y42 = cr + abs42
11370         IF (1.0 .GT. y42) THEN
11371           min62d = y42d
11372           min62 = y42
11373         ELSE
11374           min62 = 1.0
11375           min62d = 0.0
11376         END IF
11377         IF (cr .GE. 0.) THEN
11378           abs93d = crd
11379           abs93 = cr
11380         ELSE
11381           abs93d = -crd
11382           abs93 = -cr
11383         END IF
11384         y93d = crd - abs93d
11385         y93 = cr - abs93
11386         IF (-1.0 .LT. y93) THEN
11387           max43d = y93d
11388           max43 = y93
11389         ELSE
11390           max43 = -1.0
11391           max43d = 0.0
11392         END IF
11393         fqzld(i, k, j) = dz*(mud*(0.5*min62*field_old(i, k-1, j)+0.5*&
11394 &          max43*field_old(i, k, j))+mu*(0.5*(min62d*field_old(i, k-1, j)&
11395 &          +min62*field_oldd(i, k-1, j))+0.5*(max43d*field_old(i, k, j)+&
11396 &          max43*field_oldd(i, k, j))))/dt
11397         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min62*field_old(i, k-1, j)+0.5*&
11398 &          max43*field_old(i, k, j))
11399         fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
11400 &          1./12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*&
11401 &          SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*&
11402 &          (field(i, k, j)-field(i, k-1, j)))) + vel*(7.*(fieldd(i, k, j)&
11403 &          +fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k-2, j))/&
11404 &          12.+SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-&
11405 &          fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.)
11406         fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
11407 &          12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*&
11408 &          SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*&
11409 &          (field(i, k, j)-field(i, k-1, j))))
11410         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11411         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11412         k = ktf - 1
11413         dz = 2./(rdzw(k)+rdzw(k-1))
11414         mud = 0.5*2*mutd(i, j)
11415         mu = 0.5*(mut(i, j)+mut(i, j))
11416         veld = romd(i, k, j)
11417         vel = rom(i, k, j)
11418         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11419         cr = vel*dt/dz/mu
11420         IF (cr .GE. 0.) THEN
11421           abs43d = crd
11422           abs43 = cr
11423         ELSE
11424           abs43d = -crd
11425           abs43 = -cr
11426         END IF
11427         y43d = crd + abs43d
11428         y43 = cr + abs43
11429         IF (1.0 .GT. y43) THEN
11430           min63d = y43d
11431           min63 = y43
11432         ELSE
11433           min63 = 1.0
11434           min63d = 0.0
11435         END IF
11436         IF (cr .GE. 0.) THEN
11437           abs94d = crd
11438           abs94 = cr
11439         ELSE
11440           abs94d = -crd
11441           abs94 = -cr
11442         END IF
11443         y94d = crd - abs94d
11444         y94 = cr - abs94
11445         IF (-1.0 .LT. y94) THEN
11446           max44d = y94d
11447           max44 = y94
11448         ELSE
11449           max44 = -1.0
11450           max44d = 0.0
11451         END IF
11452         fqzld(i, k, j) = dz*(mud*(0.5*min63*field_old(i, k-1, j)+0.5*&
11453 &          max44*field_old(i, k, j))+mu*(0.5*(min63d*field_old(i, k-1, j)&
11454 &          +min63*field_oldd(i, k-1, j))+0.5*(max44d*field_old(i, k, j)+&
11455 &          max44*field_oldd(i, k, j))))/dt
11456         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min63*field_old(i, k-1, j)+0.5*&
11457 &          max44*field_old(i, k, j))
11458         fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
11459 &          1./12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*&
11460 &          SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*&
11461 &          (field(i, k, j)-field(i, k-1, j)))) + vel*(7.*(fieldd(i, k, j)&
11462 &          +fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k-2, j))/&
11463 &          12.+SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-&
11464 &          fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.)
11465         fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
11466 &          12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*&
11467 &          SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*&
11468 &          (field(i, k, j)-field(i, k-1, j))))
11469         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11470         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11471         k = ktf
11472         dz = 2./(rdzw(k)+rdzw(k-1))
11473         mud = 0.5*2*mutd(i, j)
11474         mu = 0.5*(mut(i, j)+mut(i, j))
11475         veld = romd(i, k, j)
11476         vel = rom(i, k, j)
11477         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11478         cr = vel*dt/dz/mu
11479         IF (cr .GE. 0.) THEN
11480           abs44d = crd
11481           abs44 = cr
11482         ELSE
11483           abs44d = -crd
11484           abs44 = -cr
11485         END IF
11486         y44d = crd + abs44d
11487         y44 = cr + abs44
11488         IF (1.0 .GT. y44) THEN
11489           min64d = y44d
11490           min64 = y44
11491         ELSE
11492           min64 = 1.0
11493           min64d = 0.0
11494         END IF
11495         IF (cr .GE. 0.) THEN
11496           abs95d = crd
11497           abs95 = cr
11498         ELSE
11499           abs95d = -crd
11500           abs95 = -cr
11501         END IF
11502         y95d = crd - abs95d
11503         y95 = cr - abs95
11504         IF (-1.0 .LT. y95) THEN
11505           max45d = y95d
11506           max45 = y95
11507         ELSE
11508           max45 = -1.0
11509           max45d = 0.0
11510         END IF
11511         fqzld(i, k, j) = dz*(mud*(0.5*min64*field_old(i, k-1, j)+0.5*&
11512 &          max45*field_old(i, k, j))+mu*(0.5*(min64d*field_old(i, k-1, j)&
11513 &          +min64*field_oldd(i, k-1, j))+0.5*(max45d*field_old(i, k, j)+&
11514 &          max45*field_oldd(i, k, j))))/dt
11515         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min64*field_old(i, k-1, j)+0.5*&
11516 &          max45*field_old(i, k, j))
11517         fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
11518 &          field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
11519 &          )*fieldd(i, k-1, j))
11520         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
11521 &          i, k-1, j))
11522         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11523         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11524       END DO
11525     END DO
11526   ELSE IF (vert_order .EQ. 4) THEN
11527     fqzd = 0.0
11528     fqzld = 0.0
11529     DO j=j_start,j_end
11530       DO i=i_start,i_end
11531         fqzd(i, 1, j) = 0.0
11532         fqz(i, 1, j) = 0.
11533         fqzld(i, 1, j) = 0.0
11534         fqzl(i, 1, j) = 0.
11535         fqzd(i, kde, j) = 0.0
11536         fqz(i, kde, j) = 0.
11537         fqzld(i, kde, j) = 0.0
11538         fqzl(i, kde, j) = 0.
11539       END DO
11540       DO k=kts+2,ktf-1
11541         DO i=i_start,i_end
11542           dz = 2./(rdzw(k)+rdzw(k-1))
11543           mud = 0.5*2*mutd(i, j)
11544           mu = 0.5*(mut(i, j)+mut(i, j))
11545           veld = romd(i, k, j)
11546           vel = rom(i, k, j)
11547           crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11548           cr = vel*dt/dz/mu
11549           IF (cr .GE. 0.) THEN
11550             abs45d = crd
11551             abs45 = cr
11552           ELSE
11553             abs45d = -crd
11554             abs45 = -cr
11555           END IF
11556           y45d = crd + abs45d
11557           y45 = cr + abs45
11558           IF (1.0 .GT. y45) THEN
11559             min65d = y45d
11560             min65 = y45
11561           ELSE
11562             min65 = 1.0
11563             min65d = 0.0
11564           END IF
11565           IF (cr .GE. 0.) THEN
11566             abs96d = crd
11567             abs96 = cr
11568           ELSE
11569             abs96d = -crd
11570             abs96 = -cr
11571           END IF
11572           y96d = crd - abs96d
11573           y96 = cr - abs96
11574           IF (-1.0 .LT. y96) THEN
11575             max46d = y96d
11576             max46 = y96
11577           ELSE
11578             max46 = -1.0
11579             max46d = 0.0
11580           END IF
11581           fqzld(i, k, j) = dz*(mud*(0.5*min65*field_old(i, k-1, j)+0.5*&
11582 &            max46*field_old(i, k, j))+mu*(0.5*(min65d*field_old(i, k-1, &
11583 &            j)+min65*field_oldd(i, k-1, j))+0.5*(max46d*field_old(i, k, &
11584 &            j)+max46*field_oldd(i, k, j))))/dt
11585           fqzl(i, k, j) = mu*(dz/dt)*(0.5*min65*field_old(i, k-1, j)+0.5&
11586 &            *max46*field_old(i, k, j))
11587           fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))&
11588 &            -1./12.*(field(i, k+1, j)+field(i, k-2, j))) + vel*(7.*(&
11589 &            fieldd(i, k, j)+fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+&
11590 &            fieldd(i, k-2, j))/12.)
11591           fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
11592 &            1./12.*(field(i, k+1, j)+field(i, k-2, j)))
11593           fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11594           fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11595         END DO
11596       END DO
11597       DO i=i_start,i_end
11598         k = kts + 1
11599         dz = 2./(rdzw(k)+rdzw(k-1))
11600         mud = 0.5*2*mutd(i, j)
11601         mu = 0.5*(mut(i, j)+mut(i, j))
11602         veld = romd(i, k, j)
11603         vel = rom(i, k, j)
11604         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11605         cr = vel*dt/dz/mu
11606         IF (cr .GE. 0.) THEN
11607           abs46d = crd
11608           abs46 = cr
11609         ELSE
11610           abs46d = -crd
11611           abs46 = -cr
11612         END IF
11613         y46d = crd + abs46d
11614         y46 = cr + abs46
11615         IF (1.0 .GT. y46) THEN
11616           min66d = y46d
11617           min66 = y46
11618         ELSE
11619           min66 = 1.0
11620           min66d = 0.0
11621         END IF
11622         IF (cr .GE. 0.) THEN
11623           abs97d = crd
11624           abs97 = cr
11625         ELSE
11626           abs97d = -crd
11627           abs97 = -cr
11628         END IF
11629         y97d = crd - abs97d
11630         y97 = cr - abs97
11631         IF (-1.0 .LT. y97) THEN
11632           max47d = y97d
11633           max47 = y97
11634         ELSE
11635           max47 = -1.0
11636           max47d = 0.0
11637         END IF
11638         fqzld(i, k, j) = dz*(mud*(0.5*min66*field_old(i, k-1, j)+0.5*&
11639 &          max47*field_old(i, k, j))+mu*(0.5*(min66d*field_old(i, k-1, j)&
11640 &          +min66*field_oldd(i, k-1, j))+0.5*(max47d*field_old(i, k, j)+&
11641 &          max47*field_oldd(i, k, j))))/dt
11642         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min66*field_old(i, k-1, j)+0.5*&
11643 &          max47*field_old(i, k, j))
11644         fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
11645 &          field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
11646 &          )*fieldd(i, k-1, j))
11647         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
11648 &          i, k-1, j))
11649         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11650         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11651         k = ktf
11652         dz = 2./(rdzw(k)+rdzw(k-1))
11653         mud = 0.5*2*mutd(i, j)
11654         mu = 0.5*(mut(i, j)+mut(i, j))
11655         veld = romd(i, k, j)
11656         vel = rom(i, k, j)
11657         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11658         cr = vel*dt/dz/mu
11659         IF (cr .GE. 0.) THEN
11660           abs47d = crd
11661           abs47 = cr
11662         ELSE
11663           abs47d = -crd
11664           abs47 = -cr
11665         END IF
11666         y47d = crd + abs47d
11667         y47 = cr + abs47
11668         IF (1.0 .GT. y47) THEN
11669           min67d = y47d
11670           min67 = y47
11671         ELSE
11672           min67 = 1.0
11673           min67d = 0.0
11674         END IF
11675         IF (cr .GE. 0.) THEN
11676           abs98d = crd
11677           abs98 = cr
11678         ELSE
11679           abs98d = -crd
11680           abs98 = -cr
11681         END IF
11682         y98d = crd - abs98d
11683         y98 = cr - abs98
11684         IF (-1.0 .LT. y98) THEN
11685           max48d = y98d
11686           max48 = y98
11687         ELSE
11688           max48 = -1.0
11689           max48d = 0.0
11690         END IF
11691         fqzld(i, k, j) = dz*(mud*(0.5*min67*field_old(i, k-1, j)+0.5*&
11692 &          max48*field_old(i, k, j))+mu*(0.5*(min67d*field_old(i, k-1, j)&
11693 &          +min67*field_oldd(i, k-1, j))+0.5*(max48d*field_old(i, k, j)+&
11694 &          max48*field_oldd(i, k, j))))/dt
11695         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min67*field_old(i, k-1, j)+0.5*&
11696 &          max48*field_old(i, k, j))
11697         fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
11698 &          field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
11699 &          )*fieldd(i, k-1, j))
11700         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
11701 &          i, k-1, j))
11702         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11703         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11704       END DO
11705     END DO
11706   ELSE IF (vert_order .EQ. 3) THEN
11707     fqzd = 0.0
11708     fqzld = 0.0
11709     DO j=j_start,j_end
11710       DO i=i_start,i_end
11711         fqzd(i, 1, j) = 0.0
11712         fqz(i, 1, j) = 0.
11713         fqzld(i, 1, j) = 0.0
11714         fqzl(i, 1, j) = 0.
11715         fqzd(i, kde, j) = 0.0
11716         fqz(i, kde, j) = 0.
11717         fqzld(i, kde, j) = 0.0
11718         fqzl(i, kde, j) = 0.
11719       END DO
11720       DO k=kts+2,ktf-1
11721         DO i=i_start,i_end
11722           dz = 2./(rdzw(k)+rdzw(k-1))
11723           mud = 0.5*2*mutd(i, j)
11724           mu = 0.5*(mut(i, j)+mut(i, j))
11725           veld = romd(i, k, j)
11726           vel = rom(i, k, j)
11727           crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11728           cr = vel*dt/dz/mu
11729           IF (cr .GE. 0.) THEN
11730             abs48d = crd
11731             abs48 = cr
11732           ELSE
11733             abs48d = -crd
11734             abs48 = -cr
11735           END IF
11736           y48d = crd + abs48d
11737           y48 = cr + abs48
11738           IF (1.0 .GT. y48) THEN
11739             min68d = y48d
11740             min68 = y48
11741           ELSE
11742             min68 = 1.0
11743             min68d = 0.0
11744           END IF
11745           IF (cr .GE. 0.) THEN
11746             abs99d = crd
11747             abs99 = cr
11748           ELSE
11749             abs99d = -crd
11750             abs99 = -cr
11751           END IF
11752           y99d = crd - abs99d
11753           y99 = cr - abs99
11754           IF (-1.0 .LT. y99) THEN
11755             max49d = y99d
11756             max49 = y99
11757           ELSE
11758             max49 = -1.0
11759             max49d = 0.0
11760           END IF
11761           fqzld(i, k, j) = dz*(mud*(0.5*min68*field_old(i, k-1, j)+0.5*&
11762 &            max49*field_old(i, k, j))+mu*(0.5*(min68d*field_old(i, k-1, &
11763 &            j)+min68*field_oldd(i, k-1, j))+0.5*(max49d*field_old(i, k, &
11764 &            j)+max49*field_oldd(i, k, j))))/dt
11765           fqzl(i, k, j) = mu*(dz/dt)*(0.5*min68*field_old(i, k-1, j)+0.5&
11766 &            *max49*field_old(i, k, j))
11767           fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))&
11768 &            -1./12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, &
11769 &            time_step)*SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i&
11770 &            , k-2, j)-3.*(field(i, k, j)-field(i, k-1, j)))) + vel*(7.*(&
11771 &            fieldd(i, k, j)+fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+&
11772 &            fieldd(i, k-2, j))/12.+SIGN(1, time_step)*SIGN(1., -vel)*(&
11773 &            fieldd(i, k+1, j)-fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-&
11774 &            fieldd(i, k-1, j)))/12.)
11775           fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
11776 &            1./12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step&
11777 &            )*SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)&
11778 &            -3.*(field(i, k, j)-field(i, k-1, j))))
11779           fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11780           fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11781         END DO
11782       END DO
11783       DO i=i_start,i_end
11784         k = kts + 1
11785         dz = 2./(rdzw(k)+rdzw(k-1))
11786         mud = 0.5*2*mutd(i, j)
11787         mu = 0.5*(mut(i, j)+mut(i, j))
11788         veld = romd(i, k, j)
11789         vel = rom(i, k, j)
11790         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11791         cr = vel*dt/dz/mu
11792         IF (cr .GE. 0.) THEN
11793           abs49d = crd
11794           abs49 = cr
11795         ELSE
11796           abs49d = -crd
11797           abs49 = -cr
11798         END IF
11799         y49d = crd + abs49d
11800         y49 = cr + abs49
11801         IF (1.0 .GT. y49) THEN
11802           min69d = y49d
11803           min69 = y49
11804         ELSE
11805           min69 = 1.0
11806           min69d = 0.0
11807         END IF
11808         IF (cr .GE. 0.) THEN
11809           abs100d = crd
11810           abs100 = cr
11811         ELSE
11812           abs100d = -crd
11813           abs100 = -cr
11814         END IF
11815         y100d = crd - abs100d
11816         y100 = cr - abs100
11817         IF (-1.0 .LT. y100) THEN
11818           max50d = y100d
11819           max50 = y100
11820         ELSE
11821           max50 = -1.0
11822           max50d = 0.0
11823         END IF
11824         fqzld(i, k, j) = dz*(mud*(0.5*min69*field_old(i, k-1, j)+0.5*&
11825 &          max50*field_old(i, k, j))+mu*(0.5*(min69d*field_old(i, k-1, j)&
11826 &          +min69*field_oldd(i, k-1, j))+0.5*(max50d*field_old(i, k, j)+&
11827 &          max50*field_oldd(i, k, j))))/dt
11828         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min69*field_old(i, k-1, j)+0.5*&
11829 &          max50*field_old(i, k, j))
11830         fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
11831 &          field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
11832 &          )*fieldd(i, k-1, j))
11833         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
11834 &          i, k-1, j))
11835         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11836         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11837         k = ktf
11838         dz = 2./(rdzw(k)+rdzw(k-1))
11839         mud = 0.5*2*mutd(i, j)
11840         mu = 0.5*(mut(i, j)+mut(i, j))
11841         veld = romd(i, k, j)
11842         vel = rom(i, k, j)
11843         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11844         cr = vel*dt/dz/mu
11845         IF (cr .GE. 0.) THEN
11846           abs50d = crd
11847           abs50 = cr
11848         ELSE
11849           abs50d = -crd
11850           abs50 = -cr
11851         END IF
11852         y50d = crd + abs50d
11853         y50 = cr + abs50
11854         IF (1.0 .GT. y50) THEN
11855           min70d = y50d
11856           min70 = y50
11857         ELSE
11858           min70 = 1.0
11859           min70d = 0.0
11860         END IF
11861         IF (cr .GE. 0.) THEN
11862           abs101d = crd
11863           abs101 = cr
11864         ELSE
11865           abs101d = -crd
11866           abs101 = -cr
11867         END IF
11868         y101d = crd - abs101d
11869         y101 = cr - abs101
11870         IF (-1.0 .LT. y101) THEN
11871           max51d = y101d
11872           max51 = y101
11873         ELSE
11874           max51 = -1.0
11875           max51d = 0.0
11876         END IF
11877         fqzld(i, k, j) = dz*(mud*(0.5*min70*field_old(i, k-1, j)+0.5*&
11878 &          max51*field_old(i, k, j))+mu*(0.5*(min70d*field_old(i, k-1, j)&
11879 &          +min70*field_oldd(i, k-1, j))+0.5*(max51d*field_old(i, k, j)+&
11880 &          max51*field_oldd(i, k, j))))/dt
11881         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min70*field_old(i, k-1, j)+0.5*&
11882 &          max51*field_old(i, k, j))
11883         fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
11884 &          field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
11885 &          )*fieldd(i, k-1, j))
11886         fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
11887 &          i, k-1, j))
11888         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11889         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11890       END DO
11891     END DO
11892   ELSE IF (vert_order .EQ. 2) THEN
11893     fqzd = 0.0
11894     fqzld = 0.0
11895     DO j=j_start,j_end
11896       DO i=i_start,i_end
11897         fqzd(i, 1, j) = 0.0
11898         fqz(i, 1, j) = 0.
11899         fqzld(i, 1, j) = 0.0
11900         fqzl(i, 1, j) = 0.
11901         fqzd(i, kde, j) = 0.0
11902         fqz(i, kde, j) = 0.
11903         fqzld(i, kde, j) = 0.0
11904         fqzl(i, kde, j) = 0.
11905       END DO
11906       DO k=kts+1,ktf
11907         DO i=i_start,i_end
11908           dz = 2./(rdzw(k)+rdzw(k-1))
11909           mud = 0.5*2*mutd(i, j)
11910           mu = 0.5*(mut(i, j)+mut(i, j))
11911           veld = romd(i, k, j)
11912           vel = rom(i, k, j)
11913           crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
11914           cr = vel*dt/dz/mu
11915           IF (cr .GE. 0.) THEN
11916             abs51d = crd
11917             abs51 = cr
11918           ELSE
11919             abs51d = -crd
11920             abs51 = -cr
11921           END IF
11922           y51d = crd + abs51d
11923           y51 = cr + abs51
11924           IF (1.0 .GT. y51) THEN
11925             min71d = y51d
11926             min71 = y51
11927           ELSE
11928             min71 = 1.0
11929             min71d = 0.0
11930           END IF
11931           IF (cr .GE. 0.) THEN
11932             abs102d = crd
11933             abs102 = cr
11934           ELSE
11935             abs102d = -crd
11936             abs102 = -cr
11937           END IF
11938           y102d = crd - abs102d
11939           y102 = cr - abs102
11940           IF (-1.0 .LT. y102) THEN
11941             max52d = y102d
11942             max52 = y102
11943           ELSE
11944             max52 = -1.0
11945             max52d = 0.0
11946           END IF
11947           fqzld(i, k, j) = dz*(mud*(0.5*min71*field_old(i, k-1, j)+0.5*&
11948 &            max52*field_old(i, k, j))+mu*(0.5*(min71d*field_old(i, k-1, &
11949 &            j)+min71*field_oldd(i, k-1, j))+0.5*(max52d*field_old(i, k, &
11950 &            j)+max52*field_oldd(i, k, j))))/dt
11951           fqzl(i, k, j) = mu*(dz/dt)*(0.5*min71*field_old(i, k-1, j)+0.5&
11952 &            *max52*field_old(i, k, j))
11953           fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
11954 &            field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp&
11955 &            (k)*fieldd(i, k-1, j))
11956           fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
11957 &            field(i, k-1, j))
11958           fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
11959           fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
11960         END DO
11961       END DO
11962     END DO
11963   ELSE
11964     WRITE(wrf_err_message, *) ' advect_scalar_pd, v_order not known ', &
11965 &    vert_order
11966     CALL WRF_ERROR_FATAL(wrf_err_message)
11967     fqzd = 0.0
11968     fqzld = 0.0
11969   END IF
11970   IF (pd_limit) THEN
11971 ! positive definite filter
11972     i_start = its - 1
11973     IF (ite .GT. ide - 1) THEN
11974       min72 = ide - 1
11975     ELSE
11976       min72 = ite
11977     END IF
11978     i_end = min72 + 1
11979     j_start = jts - 1
11980     IF (jte .GT. jde - 1) THEN
11981       min73 = jde - 1
11982     ELSE
11983       min73 = jte
11984     END IF
11985     j_end = min73 + 1
11986 !-- loop bounds for open or specified conditions
11987     IF (degrade_xs) THEN
11988       IF (its - 1 .LT. ids) THEN
11989         i_start = ids
11990       ELSE
11991         i_start = its - 1
11992       END IF
11993     END IF
11994     IF (degrade_xe) THEN
11995       IF (ite + 1 .GT. ide - 1) THEN
11996         i_end = ide - 1
11997       ELSE
11998         i_end = ite + 1
11999       END IF
12000     END IF
12001     IF (degrade_ys) THEN
12002       IF (jts - 1 .LT. jds) THEN
12003         j_start = jds
12004       ELSE
12005         j_start = jts - 1
12006       END IF
12007     END IF
12008     IF (degrade_ye) THEN
12009       IF (jte + 1 .GT. jde - 1) THEN
12010         j_end = jde - 1
12011       ELSE
12012         j_end = jte + 1
12013       END IF
12014     END IF
12015     IF (config_flags%specified .OR. config_flags%nested) THEN
12016       IF (degrade_xs) THEN
12017         IF (its - 1 .LT. ids + 1) THEN
12018           i_start = ids + 1
12019         ELSE
12020           i_start = its - 1
12021         END IF
12022       END IF
12023       IF (degrade_xe) THEN
12024         IF (ite + 1 .GT. ide - 2) THEN
12025           i_end = ide - 2
12026         ELSE
12027           i_end = ite + 1
12028         END IF
12029       END IF
12030       IF (degrade_ys) THEN
12031         IF (jts - 1 .LT. jds + 1) THEN
12032           j_start = jds + 1
12033         ELSE
12034           j_start = jts - 1
12035         END IF
12036       END IF
12037       IF (degrade_ye) THEN
12038         IF (jte + 1 .GT. jde - 2) THEN
12039           j_end = jde - 2
12040         ELSE
12041           j_end = jte + 1
12042         END IF
12043       END IF
12044     END IF
12045     IF (config_flags%open_xs) THEN
12046       IF (degrade_xs) THEN
12047         IF (its - 1 .LT. ids + 1) THEN
12048           i_start = ids + 1
12049         ELSE
12050           i_start = its - 1
12051         END IF
12052       END IF
12053     END IF
12054     IF (config_flags%open_xe) THEN
12055       IF (degrade_xe) THEN
12056         IF (ite + 1 .GT. ide - 2) THEN
12057           i_end = ide - 2
12058         ELSE
12059           i_end = ite + 1
12060         END IF
12061       END IF
12062     END IF
12063     IF (config_flags%open_ys) THEN
12064       IF (degrade_ys) THEN
12065         IF (jts - 1 .LT. jds + 1) THEN
12066           j_start = jds + 1
12067         ELSE
12068           j_start = jts - 1
12069         END IF
12070       END IF
12071     END IF
12072     IF (config_flags%open_ye) THEN
12073       IF (degrade_ye) THEN
12074         IF (jte + 1 .GT. jde - 2) THEN
12075           j_end = jde - 2
12076         ELSE
12077           j_end = jte + 1
12078         END IF
12079         ph_lowd = 0.0
12080       ELSE
12081         ph_lowd = 0.0
12082       END IF
12083     ELSE
12084       ph_lowd = 0.0
12085     END IF
12086 ! ADT note:
12087 ! We don't want to change j_start and j_end
12088 ! for polar BC's since we want to calculate
12089 ! fluxes for directions other than y at the
12090 ! edge
12091 !-- here is the limiter...
12092     DO j=j_start,j_end
12093       DO k=kts,ktf
12094 #ifdef XEON_SIMD
12095 !DIR$ simd
12096 #else
12097 !DIR$ vector always
12098 #endif
12099         DO i=i_start,i_end
12100           ph_lowd(i,k,j) = mu_oldd(i, j)*field_old(i, k, j) + (mub(i, j)+mu_old&
12101 &            (i, j))*field_oldd(i, k, j) - dt*(msftx(i, j)*msfty(i, j)*(&
12102 &            rdx*(fqxld(i+1, k, j)-fqxld(i, k, j))+rdy*(fqyld(i, k, j+1)-&
12103 &            fqyld(i, k, j)))+msfty(i, j)*rdzw(k)*(fqzld(i, k+1, j)-fqzld&
12104 &            (i, k, j)))
12105           ph_low(i,k,j) = (mub(i, j)+mu_old(i, j))*field_old(i, k, j) - dt*(&
12106 &            msftx(i, j)*msfty(i, j)*(rdx*(fqxl(i+1, k, j)-fqxl(i, k, j))&
12107 &            +rdy*(fqyl(i, k, j+1)-fqyl(i, k, j)))+msfty(i, j)*rdzw(k)*(&
12108 &            fqzl(i, k+1, j)-fqzl(i, k, j)))
12109         ENDDO
12110       ENDDO
12111     ENDDO
12112     flux_outd = 0.0
12113     DO j=j_start,j_end
12114       DO k=kts,ktf
12115 !DIR$ vector always
12116         DO i=i_start,i_end
12117           IF (0. .LT. fqx(i+1, k, j)) THEN
12118             max1d = fqxd(i+1, k, j)
12119             max1 = fqx(i+1, k, j)
12120           ELSE
12121             max1 = 0.
12122             max1d = 0.0
12123           END IF
12124           IF (0. .GT. fqx(i, k, j)) THEN
12125             min74d = fqxd(i, k, j)
12126             min74 = fqx(i, k, j)
12127           ELSE
12128             min74 = 0.
12129             min74d = 0.0
12130           END IF
12131           IF (0. .LT. fqy(i, k, j+1)) THEN
12132             max53d = fqyd(i, k, j+1)
12133             max53 = fqy(i, k, j+1)
12134           ELSE
12135             max53 = 0.
12136             max53d = 0.0
12137           END IF
12138           IF (0. .GT. fqy(i, k, j)) THEN
12139             min75d = fqyd(i, k, j)
12140             min75 = fqy(i, k, j)
12141           ELSE
12142             min75 = 0.
12143             min75d = 0.0
12144           END IF
12145           IF (0. .GT. fqz(i, k+1, j)) THEN
12146             min76d = fqzd(i, k+1, j)
12147             min76 = fqz(i, k+1, j)
12148           ELSE
12149             min76 = 0.
12150             min76d = 0.0
12151           END IF
12152           IF (0. .LT. fqz(i, k, j)) THEN
12153             max54d = fqzd(i, k, j)
12154             max54 = fqz(i, k, j)
12155           ELSE
12156             max54 = 0.
12157             max54d = 0.0
12158           END IF
12159           flux_outd(i,k,j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1d-min74d)+&
12160 &            rdy*(max53d-min75d))+msfty(i, j)*rdzw(k)*(min76d-max54d))
12161           flux_out(i,k,j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1-min74)+rdy*(&
12162 &            max53-min75))+msfty(i, j)*rdzw(k)*(min76-max54))
12163         ENDDO
12164       ENDDO
12165     ENDDO
12166     DO j=j_start,j_end
12167       DO k=kts,ktf
12168 !DIR$ vector always
12169         DO i=i_start,i_end
12170           IF (flux_out(i,k,j) .GT. ph_low(i,k,j)) THEN
12171             y16d = (ph_lowd(i,k,j)*(flux_out(i,k,j)+eps)-ph_low(i,k,j)*flux_outd(i,k,j))/(&
12172 &                flux_out(i,k,j)+eps)**2
12173             y16 = ph_low(i,k,j)/(flux_out(i,k,j)+eps)
12174             IF (0. .LT. y16) THEN
12175               scaled = y16d
12176               scale = y16
12177             ELSE
12178               scale = 0.
12179               scaled = 0.0
12180             END IF
12181             IF (fqx(i+1, k, j) .GT. 0.) THEN
12182               fqxd(i+1, k, j) = scaled*fqx(i+1, k, j) + scale*fqxd(i+1, &
12183 &                k, j)
12184               fqx(i+1, k, j) = scale*fqx(i+1, k, j)
12185             END IF
12186             IF (fqx(i, k, j) .LT. 0.) THEN
12187               fqxd(i, k, j) = scaled*fqx(i, k, j) + scale*fqxd(i, k, j)
12188               fqx(i, k, j) = scale*fqx(i, k, j)
12189             END IF
12190             IF (fqy(i, k, j+1) .GT. 0.) THEN
12191               fqyd(i, k, j+1) = scaled*fqy(i, k, j+1) + scale*fqyd(i, k&
12192 &                , j+1)
12193               fqy(i, k, j+1) = scale*fqy(i, k, j+1)
12194             END IF
12195             IF (fqy(i, k, j) .LT. 0.) THEN
12196               fqyd(i, k, j) = scaled*fqy(i, k, j) + scale*fqyd(i, k, j)
12197               fqy(i, k, j) = scale*fqy(i, k, j)
12198             END IF
12199 !  note: z flux is opposite sign in mass coordinate because
12200 !  vertical coordinate decreases with increasing k
12201             IF (fqz(i, k+1, j) .LT. 0.) THEN
12202               fqzd(i, k+1, j) = scaled*fqz(i, k+1, j) + scale*fqzd(i, k+&
12203 &                1, j)
12204               fqz(i, k+1, j) = scale*fqz(i, k+1, j)
12205             END IF
12206             IF (fqz(i, k, j) .GT. 0.) THEN
12207               fqzd(i, k, j) = scaled*fqz(i, k, j) + scale*fqzd(i, k, j)
12208               fqz(i, k, j) = scale*fqz(i, k, j)
12209             END IF
12210           END IF
12211         END DO
12212       END DO
12213     END DO
12214   END IF
12215 ! add in the pd-limited flux divergence
12216   i_start = its
12217   IF (ite .GT. ide - 1) THEN
12218     i_end = ide - 1
12219   ELSE
12220     i_end = ite
12221   END IF
12222   j_start = jts
12223   IF (jte .GT. jde - 1) THEN
12224     j_end = jde - 1
12225   ELSE
12226     j_end = jte
12227   END IF
12228   DO j=j_start,j_end
12229     DO k=kts,ktf
12230       DO i=i_start,i_end
12231         tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(fqzd(i, k+1, &
12232 &          j)-fqzd(i, k, j)+fqzld(i, k+1, j)-fqzld(i, k, j))
12233         tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(fqz(i, k+1, j)-&
12234 &          fqz(i, k, j)+fqzl(i, k+1, j)-fqzl(i, k, j))
12235       END DO
12236     END DO
12237   END DO
12238   IF (tenddec) THEN
12239     DO j=j_start,j_end
12240       DO k=kts,ktf
12241         DO i=i_start,i_end
12242           z_tendencyd(i, k, j) = -(rdzw(k)*(fqzd(i, k+1, j)-fqzd(i, k, j&
12243 &            )+fqzld(i, k+1, j)-fqzld(i, k, j)))
12244           z_tendency(i, k, j) = 0. - rdzw(k)*(fqz(i, k+1, j)-fqz(i, k, j&
12245 &            )+fqzl(i, k+1, j)-fqzl(i, k, j))
12246         END DO
12247       END DO
12248     END DO
12249   END IF
12250 ! x flux divergence
12251 !
12252   IF (degrade_xs) THEN
12253     IF (its .LT. ids + 1) THEN
12254       i_start = ids + 1
12255     ELSE
12256       i_start = its
12257     END IF
12258   END IF
12259   IF (degrade_xe) THEN
12260     IF (ite .GT. ide - 2) THEN
12261       i_end = ide - 2
12262     ELSE
12263       i_end = ite
12264     END IF
12265   END IF
12266   DO j=j_start,j_end
12267     DO k=kts,ktf
12268       DO i=i_start,i_end
12269 ! Un-"canceled" map scale factor, ADT Eq. 48
12270         tendencyd(i, k, j) = tendencyd(i, k, j) - msftx(i, j)*rdx*(fqxd(&
12271 &          i+1, k, j)-fqxd(i, k, j)+fqxld(i+1, k, j)-fqxld(i, k, j))
12272         tendency(i, k, j) = tendency(i, k, j) - msftx(i, j)*(rdx*(fqx(i+&
12273 &          1, k, j)-fqx(i, k, j)+fqxl(i+1, k, j)-fqxl(i, k, j)))
12274       END DO
12275     END DO
12276   END DO
12277   IF (tenddec) THEN
12278     DO j=j_start,j_end
12279       DO k=kts,ktf
12280         DO i=i_start,i_end
12281           h_tendencyd(i, k, j) = -(msftx(i, j)*rdx*(fqxd(i+1, k, j)-fqxd&
12282 &            (i, k, j)+fqxld(i+1, k, j)-fqxld(i, k, j)))
12283           h_tendency(i, k, j) = 0. - msftx(i, j)*(rdx*(fqx(i+1, k, j)-&
12284 &            fqx(i, k, j)+fqxl(i+1, k, j)-fqxl(i, k, j)))
12285         END DO
12286       END DO
12287     END DO
12288   END IF
12289 ! y flux divergence
12290 !
12291   i_start = its
12292   IF (ite .GT. ide - 1) THEN
12293     i_end = ide - 1
12294   ELSE
12295     i_end = ite
12296   END IF
12297   IF (degrade_ys) THEN
12298     IF (jts .LT. jds + 1) THEN
12299       j_start = jds + 1
12300     ELSE
12301       j_start = jts
12302     END IF
12303   END IF
12304   IF (degrade_ye) THEN
12305     IF (jte .GT. jde - 2) THEN
12306       j_end = jde - 2
12307     ELSE
12308       j_end = jte
12309     END IF
12310   END IF
12311   DO j=j_start,j_end
12312     DO k=kts,ktf
12313       DO i=i_start,i_end
12314 ! Un-"canceled" map scale factor, ADT Eq. 48
12315 ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
12316         tendencyd(i, k, j) = tendencyd(i, k, j) - msftx(i, j)*rdy*(fqyd(&
12317 &          i, k, j+1)-fqyd(i, k, j)+fqyld(i, k, j+1)-fqyld(i, k, j))
12318         tendency(i, k, j) = tendency(i, k, j) - msftx(i, j)*(rdy*(fqy(i&
12319 &          , k, j+1)-fqy(i, k, j)+fqyl(i, k, j+1)-fqyl(i, k, j)))
12320       END DO
12321     END DO
12322   END DO
12323   IF (tenddec) THEN
12324     DO j=j_start,j_end
12325       DO k=kts,ktf
12326         DO i=i_start,i_end
12327           h_tendencyd(i, k, j) = h_tendencyd(i, k, j) - msftx(i, j)*rdy*&
12328 &            (fqyd(i, k, j+1)-fqyd(i, k, j)+fqyld(i, k, j+1)-fqyld(i, k, &
12329 &            j))
12330           h_tendency(i, k, j) = h_tendency(i, k, j) - msftx(i, j)*(rdy*(&
12331 &            fqy(i, k, j+1)-fqy(i, k, j)+fqyl(i, k, j+1)-fqyl(i, k, j)))
12332         END DO
12333       END DO
12334     END DO
12335   END IF
12336 END SUBROUTINE G_ADVECT_SCALAR_PD
12337
12338 !        Generated by TAPENADE     (INRIA, Tropics team)
12339 !  Tapenade 3.6 (r4165) - 21 sep 2011 20:54
12340 !
12341 !  Differentiation of advect_scalar_wenopd in forward (tangent) mode:
12342 !   variations   of useful results: tendency
12343 !   with respect to varying inputs: rom field tendency ru rv mu_old
12344 !                field_old mut
12345 !   RW status of diff variables: rom:in field:in tendency:in-out
12346 !                ru:in rv:in mu_old:in field_old:in mut:in
12347 SUBROUTINE G_ADVECT_SCALAR_WENOPD(field, fieldd, field_old, field_oldd, &
12348 &  tendency, tendencyd, ru, rud, rv, rvd, rom, romd, mut, mutd, mub, &
12349 &  mu_old, mu_oldd, time_step, config_flags, msfux, msfuy, msfvx, msfvy, &
12350 &  msftx, msfty, fzm, fzp, rdx, rdy, rdzw, dt, ids, ide, jds, jde, kds, &
12351 &  kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
12352   IMPLICIT NONE
12353 ! Input data
12354   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
12355   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
12356 &  jme, kms, kme, its, ite, jts, jte, kts, kte
12357   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
12358 &  field_old, ru, rv, rom
12359   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: fieldd, &
12360 &  field_oldd, rud, rvd, romd
12361   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut, mub, mu_old
12362   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd, mu_oldd
12363   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
12364   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
12365   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
12366 &  msfvy, msftx, msfty
12367   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
12368   REAL, INTENT(IN) :: rdx, rdy, dt
12369   INTEGER, INTENT(IN) :: time_step
12370 ! Local data
12371   INTEGER :: i, j, k, itf, jtf, ktf
12372   INTEGER :: i_start, i_end, j_start, j_end
12373   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
12374   INTEGER :: jmin, jmax, jp, jm, imin, imax
12375   REAL :: mrdx, mrdy, ub, vb, uw, vw, mu
12376   REAL :: ubd, vbd, mud
12377 !  storage for high and low order fluxes
12378   REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqx, fqy&
12379 &  , fqz
12380   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxd, fqyd, fqzd
12381   REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqxl, &
12382 &  fqyl, fqzl
12383   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxld, fqyld, &
12384 &  fqzld
12385   INTEGER :: horz_order, vert_order
12386   LOGICAL :: degrade_xs, degrade_ys
12387   LOGICAL :: degrade_xe, degrade_ye
12388   INTEGER :: jp1, jp0, jtmp
12389   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_out, ph_low
12390   REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_outd, ph_lowd
12391   REAL :: scale
12392   REAL :: scaled
12393   REAL, PARAMETER :: eps=1.e-20
12394   REAL :: dir, vv
12395   REAL :: ue, vs, vn, wb, wt
12396   REAL, PARAMETER :: f30=7./12., f31=1./12.
12397   REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
12398   REAL :: qim2, qim1, qi, qip1, qip2
12399   REAL :: qim2d, qim1d, qid, qip1d, qip2d
12400   DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
12401 &  sumwk
12402   DOUBLE PRECISION :: beta0d, beta1d, beta2d, f0d, f1d, f2d, wi0d, wi1d&
12403 &  , wi2d, sumwkd
12404   DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
12405 &    3.d0/10.d0, eps1=1.0d-28
12406   INTEGER, PARAMETER :: pw=2
12407 ! definition of flux operators, 3rd, 4th, 5th or 6th order
12408   REAL :: flux3, flux4, flux5, flux6, flux_upwind
12409   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
12410   REAL :: veld, crd
12411 !      flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
12412 !                                    +0.5*(1.-sign(1.,cr))*q_i
12413 !      flux_upwind(q_im1, q_i, cr ) = 0.
12414   REAL :: dx, dy, dz
12415   LOGICAL, PARAMETER :: pd_limit=.true.
12416   DOUBLE PRECISION :: pwx1
12417   DOUBLE PRECISION :: pwx1d
12418   DOUBLE PRECISION :: pwr1
12419   DOUBLE PRECISION :: pwr1d
12420   REAL :: abs18d
12421   REAL :: abs26d
12422   REAL :: min5d
12423   REAL :: max10d
12424   REAL :: y28d
12425   REAL :: y4d
12426   INTEGER :: min9
12427   REAL :: abs29d
12428   INTEGER :: min8
12429   REAL :: max13d
12430   REAL :: min7
12431   REAL :: abs1d
12432   REAL :: y29
12433   REAL :: min6
12434   REAL :: y10d
12435   REAL :: y28
12436   REAL :: min5
12437   REAL :: y27
12438   REAL :: min4
12439   REAL :: max2d
12440   REAL :: y7d
12441   REAL :: min11d
12442   REAL :: y26
12443   REAL :: min3
12444   REAL :: y25
12445   INTEGER :: min2
12446   REAL :: y24
12447   INTEGER :: min1
12448   REAL :: max16d
12449   REAL :: y23
12450   REAL :: abs4d
12451   REAL :: abs11d
12452   REAL :: y22
12453   REAL :: y13d
12454   REAL :: y21
12455   REAL :: y21d
12456   REAL :: y20
12457   REAL :: max5d
12458   REAL :: min14d
12459   REAL :: abs29
12460   INTRINSIC MAX
12461   REAL :: abs28
12462   REAL :: abs27
12463   REAL :: abs7d
12464   REAL :: abs14d
12465   REAL :: abs26
12466   REAL :: y16d
12467   REAL :: abs22d
12468   INTRINSIC SIGN
12469   REAL :: abs25
12470   REAL :: y24d
12471   REAL :: abs24
12472   REAL :: max8d
12473   REAL :: min17d
12474   REAL :: abs23
12475   REAL :: min25d
12476   INTRINSIC ABS
12477   REAL :: abs22
12478   REAL :: abs21
12479   REAL :: abs20
12480   REAL :: abs17d
12481   REAL :: y19d
12482   REAL :: abs25d
12483   REAL :: min4d
12484   REAL :: y27d
12485   REAL :: y3d
12486   REAL :: abs28d
12487   REAL :: min7d
12488   REAL :: max12d
12489   REAL :: min26
12490   REAL :: abs0d
12491   REAL :: y19
12492   REAL :: min25
12493   REAL :: y18
12494   REAL :: min24
12495   REAL :: y17
12496   INTEGER :: min23
12497   REAL :: y6d
12498   REAL :: min10d
12499   REAL :: max1d
12500   REAL :: y16
12501   INTEGER :: min22
12502   REAL :: y15
12503   REAL :: min21
12504   REAL :: y14
12505   REAL :: min20
12506   REAL :: max15d
12507   REAL :: y13
12508   REAL :: abs3d
12509   REAL :: abs10d
12510   REAL :: y12
12511   REAL :: y12d
12512   REAL :: y11
12513   REAL :: y20d
12514   REAL :: y10
12515   REAL :: max4d
12516   REAL :: y9d
12517   REAL :: min13d
12518   REAL :: min21d
12519   REAL :: abs19
12520   REAL :: abs18
12521   REAL :: max18d
12522   REAL :: abs17
12523   REAL :: abs6d
12524   REAL :: abs13d
12525   REAL :: abs16
12526   REAL :: abs21d
12527   REAL :: y15d
12528   REAL :: abs15
12529   REAL :: y23d
12530   REAL :: abs14
12531   REAL :: max7d
12532   REAL :: abs13
12533   REAL :: min24d
12534   REAL :: abs12
12535   REAL :: abs11
12536   REAL :: abs10
12537   REAL :: abs16d
12538   REAL :: abs9d
12539   REAL :: y18d
12540   REAL :: abs24d
12541   REAL :: min3d
12542   REAL :: y26d
12543   REAL :: min19d
12544   REAL :: y2d
12545   REAL :: min19
12546   REAL :: abs19d
12547   REAL :: min18
12548   REAL :: abs27d
12549   REAL :: min17
12550   REAL :: min6d
12551   REAL :: max11d
12552   REAL :: y29d
12553   INTEGER :: min16
12554   REAL :: abs9
12555   INTEGER :: min15
12556   REAL :: abs8
12557   REAL :: min14
12558   REAL :: abs7
12559   REAL :: min13
12560   REAL :: abs6
12561   REAL :: y5d
12562   REAL :: min12
12563   REAL :: abs5
12564   REAL :: min11
12565   REAL :: abs4
12566   REAL :: min10
12567   REAL :: abs3
12568   REAL :: max14d
12569   REAL :: abs2
12570   REAL :: abs2d
12571   REAL :: abs1
12572   REAL :: y11d
12573   REAL :: abs0
12574   REAL :: max3d
12575   REAL :: y8d
12576   REAL :: min12d
12577   REAL :: min20d
12578   INTRINSIC MIN
12579   REAL :: max17d
12580   REAL :: max9
12581   REAL :: abs5d
12582   REAL :: abs12d
12583   REAL :: max8
12584   REAL :: abs20d
12585   REAL :: y14d
12586   REAL :: max7
12587   REAL :: max18
12588   REAL :: y22d
12589   REAL :: y30
12590   REAL :: max6
12591   REAL :: max17
12592   REAL :: max6d
12593   REAL :: y30d
12594   REAL :: max5
12595   REAL :: max16
12596   REAL :: y9
12597   REAL :: max4
12598   REAL :: max15
12599   REAL :: y8
12600   REAL :: max3
12601   REAL :: max14
12602   REAL :: y7
12603   REAL :: max2
12604   REAL :: max13
12605   REAL :: abs15d
12606   REAL :: abs8d
12607   REAL :: y6
12608   REAL :: max1
12609   REAL :: max12
12610   REAL :: y17d
12611   REAL :: abs23d
12612   REAL :: y5
12613   REAL :: max11
12614   REAL :: y25d
12615   REAL :: y4
12616   REAL :: max10
12617   REAL :: max9d
12618   REAL :: min18d
12619   REAL :: y3
12620   REAL :: min26d
12621   REAL :: y2
12622   REAL :: y1
12623   REAL :: y1d
12624
12625
12626
12627
12628
12629 ! set order for the advection schemes
12630 !  write(6,*) ' in pd advection routine '
12631 ! Empty arrays just in case:
12632   IF (config_flags%polar) THEN
12633     fqx(:, :, :) = 0.
12634     fqy(:, :, :) = 0.
12635     fqz(:, :, :) = 0.
12636     fqxl(:, :, :) = 0.
12637     fqyl(:, :, :) = 0.
12638     fqzl(:, :, :) = 0.
12639   END IF
12640   IF (kte .GT. kde - 1) THEN
12641     ktf = kde - 1
12642   ELSE
12643     ktf = kte
12644   END IF
12645   horz_order = config_flags%h_sca_adv_order
12646   vert_order = config_flags%v_sca_adv_order
12647 !  determine boundary mods for flux operators
12648 !  We degrade the flux operators from 3rd/4th order
12649 !   to second order one gridpoint in from the boundaries for
12650 !   all boundary conditions except periodic and symmetry - these
12651 !   conditions have boundary zone data fill for correct application
12652 !   of the higher order flux stencils
12653   degrade_xs = .true.
12654   degrade_xe = .true.
12655   degrade_ys = .true.
12656   degrade_ye = .true.
12657 !  begin with horizontal flux divergence
12658 !  here is the choice of flux operators
12659 !  horizontal_order_test : IF( horz_order == 6 ) THEN
12660 !    ELSE IF( horz_order == 5 ) THEN
12661   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
12662 &      .GT. ids + 3) degrade_xs = .false.
12663   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
12664 &      .LT. ide - 4) degrade_xe = .false.
12665   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
12666 &      .GT. jds + 3) degrade_ys = .false.
12667   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
12668 &      .LT. jde - 4) degrade_ye = .false.
12669   IF (kte .GT. kde - 1) THEN
12670     ktf = kde - 1
12671   ELSE
12672     ktf = kte
12673   END IF
12674   i_start = its - 1
12675   IF (ite .GT. ide - 1) THEN
12676     min1 = ide - 1
12677   ELSE
12678     min1 = ite
12679   END IF
12680   i_end = min1 + 1
12681   j_start = jts - 1
12682   IF (jte .GT. jde - 1) THEN
12683     min2 = jde - 1
12684   ELSE
12685     min2 = jte
12686   END IF
12687   j_end = min2 + 1
12688   j_start_f = j_start
12689   j_end_f = j_end + 1
12690 !--  modify loop bounds if open or specified
12691 !      IF(degrade_xs) i_start = MAX(its-1,ids-1)
12692 !      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
12693   IF (degrade_xs) THEN
12694     IF (its - 1 .LT. ids) THEN
12695       i_start = ids
12696     ELSE
12697       i_start = its - 1
12698     END IF
12699   END IF
12700   IF (degrade_xe) THEN
12701     IF (ite + 1 .GT. ide - 1) THEN
12702       i_end = ide - 1
12703     ELSE
12704       i_end = ite + 1
12705     END IF
12706   END IF
12707   IF (degrade_ys) THEN
12708     IF (jts - 1 .LT. jds + 1) THEN
12709       j_start = jds + 1
12710     ELSE
12711       j_start = jts - 1
12712     END IF
12713     j_start_f = jds + 3
12714   END IF
12715   IF (degrade_ye) THEN
12716     IF (jte + 1 .GT. jde - 2) THEN
12717       j_end = jde - 2
12718     ELSE
12719       j_end = jte + 1
12720     END IF
12721     j_end_f = jde - 3
12722     fqyld = 0.0
12723     fqyd = 0.0
12724   ELSE
12725     fqyld = 0.0
12726     fqyd = 0.0
12727   END IF
12728 !  compute fluxes, 5th order
12729 j_loop_y_flux_5:DO j=j_start,j_end+1
12730     IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
12731 ! use full stencil
12732       DO k=kts,ktf
12733         DO i=i_start,i_end
12734 ! ADT eqn 48 d/dy
12735           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
12736           mud = 0.5*(mutd(i, j)+mutd(i, j-1))
12737           mu = 0.5*(mut(i, j)+mut(i, j-1))
12738           veld = rvd(i, k, j)
12739           vel = rv(i, k, j)
12740           crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
12741           cr = vel*dt/dy/mu
12742           IF (cr .GE. 0.) THEN
12743             abs0d = crd
12744             abs0 = cr
12745           ELSE
12746             abs0d = -crd
12747             abs0 = -cr
12748           END IF
12749           y1d = crd + abs0d
12750           y1 = cr + abs0
12751           IF (1.0 .GT. y1) THEN
12752             min3d = y1d
12753             min3 = y1
12754           ELSE
12755             min3 = 1.0
12756             min3d = 0.0
12757           END IF
12758           IF (cr .GE. 0.) THEN
12759             abs15d = crd
12760             abs15 = cr
12761           ELSE
12762             abs15d = -crd
12763             abs15 = -cr
12764           END IF
12765           y16d = crd - abs15d
12766           y16 = cr - abs15
12767           IF (-1.0 .LT. y16) THEN
12768             max2d = y16d
12769             max2 = y16
12770           ELSE
12771             max2 = -1.0
12772             max2d = 0.0
12773           END IF
12774           fqyld(i, k, j) = dy*(mud*(0.5*min3*field_old(i, k, j-1)+0.5*&
12775 &            max2*field_old(i, k, j))+mu*(0.5*(min3d*field_old(i, k, j-1)&
12776 &            +min3*field_oldd(i, k, j-1))+0.5*(max2d*field_old(i, k, j)+&
12777 &            max2*field_oldd(i, k, j))))/dt
12778           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min3*field_old(i, k, j-1)+0.5*&
12779 &            max2*field_old(i, k, j))
12780           IF (vel*sign(1,time_step) .GE. 0.0) THEN
12781             qip2d = fieldd(i, k, j+1)
12782             qip2 = field(i, k, j+1)
12783             qip1d = fieldd(i, k, j)
12784             qip1 = field(i, k, j)
12785             qid = fieldd(i, k, j-1)
12786             qi = field(i, k, j-1)
12787             qim1d = fieldd(i, k, j-2)
12788             qim1 = field(i, k, j-2)
12789             qim2d = fieldd(i, k, j-3)
12790             qim2 = field(i, k, j-3)
12791           ELSE
12792             qip2d = fieldd(i, k, j-2)
12793             qip2 = field(i, k, j-2)
12794             qip1d = fieldd(i, k, j-1)
12795             qip1 = field(i, k, j-1)
12796             qid = fieldd(i, k, j)
12797             qi = field(i, k, j)
12798             qim1d = fieldd(i, k, j+1)
12799             qim1 = field(i, k, j+1)
12800             qim2d = fieldd(i, k, j+2)
12801             qim2 = field(i, k, j+2)
12802           END IF
12803           f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
12804           f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
12805           f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
12806           f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
12807           f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
12808           f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
12809           beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*&
12810 &            (qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
12811           beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
12812 &            qi)**2
12813           beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*&
12814 &            (qim1-qip1)*(qim1d-qip1d)/4.
12815           beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
12816           beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*&
12817 &            (qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
12818           beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
12819 &            qi)**2
12820           pwx1d = beta0d
12821           pwx1 = eps1 + beta0
12822           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
12823 &          THEN
12824             pwr1d = pw*pwx1**(pw-1)*pwx1d
12825           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
12826             pwr1d = pwx1d
12827           ELSE
12828             pwr1d = 0.0
12829           END IF
12830           pwr1 = pwx1**pw
12831           wi0d = -(gi0*pwr1d/pwr1**2)
12832           wi0 = gi0/pwr1
12833           pwx1d = beta1d
12834           pwx1 = eps1 + beta1
12835           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
12836 &          THEN
12837             pwr1d = pw*pwx1**(pw-1)*pwx1d
12838           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
12839             pwr1d = pwx1d
12840           ELSE
12841             pwr1d = 0.0
12842           END IF
12843           pwr1 = pwx1**pw
12844           wi1d = -(gi1*pwr1d/pwr1**2)
12845           wi1 = gi1/pwr1
12846           pwx1d = beta2d
12847           pwx1 = eps1 + beta2
12848           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
12849 &          THEN
12850             pwr1d = pw*pwx1**(pw-1)*pwx1d
12851           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
12852             pwr1d = pwx1d
12853           ELSE
12854             pwr1d = 0.0
12855           END IF
12856           pwr1 = pwx1**pw
12857           wi2d = -(gi2*pwr1d/pwr1**2)
12858           wi2 = gi2/pwr1
12859           sumwkd = wi0d + wi1d + wi2d
12860           sumwk = wi0 + wi1 + wi2
12861           fqyd(i, k, j) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0&
12862 &            *f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1&
12863 &            *f1+wi2*f2)*sumwkd)/sumwk**2
12864           fqy(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
12865 !          fqy( i, k, j  ) = vel*flux5(                                  &
12866 !                  field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
12867 !                  field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
12868           fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
12869           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
12870         END DO
12871       END DO
12872     ELSE IF (j .EQ. jds + 1) THEN
12873 ! 2nd order flux next to south boundary
12874       DO k=kts,ktf
12875         DO i=i_start,i_end
12876 ! ADT eqn 48 d/dy
12877           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
12878           mud = 0.5*(mutd(i, j)+mutd(i, j-1))
12879           mu = 0.5*(mut(i, j)+mut(i, j-1))
12880           veld = rvd(i, k, j)
12881           vel = rv(i, k, j)
12882           crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
12883           cr = vel*dt/dy/mu
12884           IF (cr .GE. 0.) THEN
12885             abs1d = crd
12886             abs1 = cr
12887           ELSE
12888             abs1d = -crd
12889             abs1 = -cr
12890           END IF
12891           y2d = crd + abs1d
12892           y2 = cr + abs1
12893           IF (1.0 .GT. y2) THEN
12894             min4d = y2d
12895             min4 = y2
12896           ELSE
12897             min4 = 1.0
12898             min4d = 0.0
12899           END IF
12900           IF (cr .GE. 0.) THEN
12901             abs16d = crd
12902             abs16 = cr
12903           ELSE
12904             abs16d = -crd
12905             abs16 = -cr
12906           END IF
12907           y17d = crd - abs16d
12908           y17 = cr - abs16
12909           IF (-1.0 .LT. y17) THEN
12910             max3d = y17d
12911             max3 = y17
12912           ELSE
12913             max3 = -1.0
12914             max3d = 0.0
12915           END IF
12916           fqyld(i, k, j) = dy*(mud*(0.5*min4*field_old(i, k, j-1)+0.5*&
12917 &            max3*field_old(i, k, j))+mu*(0.5*(min4d*field_old(i, k, j-1)&
12918 &            +min4*field_oldd(i, k, j-1))+0.5*(max3d*field_old(i, k, j)+&
12919 &            max3*field_oldd(i, k, j))))/dt
12920           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min4*field_old(i, k, j-1)+0.5*&
12921 &            max3*field_old(i, k, j))
12922           fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k, &
12923 &            j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
12924           fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1&
12925 &            ))
12926           fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
12927           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
12928         END DO
12929       END DO
12930     ELSE IF (j .EQ. jds + 2) THEN
12931 ! third of 4th order flux 2 in from south boundary
12932       DO k=kts,ktf
12933         DO i=i_start,i_end
12934 ! ADT eqn 48 d/dy
12935           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
12936           mud = 0.5*(mutd(i, j)+mutd(i, j-1))
12937           mu = 0.5*(mut(i, j)+mut(i, j-1))
12938           veld = rvd(i, k, j)
12939           vel = rv(i, k, j)
12940           crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
12941           cr = vel*dt/dy/mu
12942           IF (cr .GE. 0.) THEN
12943             abs2d = crd
12944             abs2 = cr
12945           ELSE
12946             abs2d = -crd
12947             abs2 = -cr
12948           END IF
12949           y3d = crd + abs2d
12950           y3 = cr + abs2
12951           IF (1.0 .GT. y3) THEN
12952             min5d = y3d
12953             min5 = y3
12954           ELSE
12955             min5 = 1.0
12956             min5d = 0.0
12957           END IF
12958           IF (cr .GE. 0.) THEN
12959             abs17d = crd
12960             abs17 = cr
12961           ELSE
12962             abs17d = -crd
12963             abs17 = -cr
12964           END IF
12965           y18d = crd - abs17d
12966           y18 = cr - abs17
12967           IF (-1.0 .LT. y18) THEN
12968             max4d = y18d
12969             max4 = y18
12970           ELSE
12971             max4 = -1.0
12972             max4d = 0.0
12973           END IF
12974           fqyld(i, k, j) = dy*(mud*(0.5*min5*field_old(i, k, j-1)+0.5*&
12975 &            max4*field_old(i, k, j))+mu*(0.5*(min5d*field_old(i, k, j-1)&
12976 &            +min5*field_oldd(i, k, j-1))+0.5*(max4d*field_old(i, k, j)+&
12977 &            max4*field_oldd(i, k, j))))/dt
12978           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min5*field_old(i, k, j-1)+0.5*&
12979 &            max4*field_old(i, k, j))
12980           fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1))&
12981 &            -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
12982 &            time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i&
12983 &            , k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) + vel*(7.*(&
12984 &            fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+&
12985 &            fieldd(i, k, j-2))/12.+SIGN(1, time_step)*SIGN(1., vel)*(&
12986 &            fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)-&
12987 &            fieldd(i, k, j-1)))/12.)
12988           fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))-&
12989 &            1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, time_step&
12990 &            )*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-&
12991 &            3.*(field(i, k, j)-field(i, k, j-1))))
12992           fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
12993           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
12994         END DO
12995       END DO
12996     ELSE IF (j .EQ. jde - 1) THEN
12997 ! 2nd order flux next to north boundary
12998       DO k=kts,ktf
12999         DO i=i_start,i_end
13000 ! ADT eqn 48 d/dy
13001           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
13002           mud = 0.5*(mutd(i, j)+mutd(i, j-1))
13003           mu = 0.5*(mut(i, j)+mut(i, j-1))
13004           veld = rvd(i, k, j)
13005           vel = rv(i, k, j)
13006           crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
13007           cr = vel*dt/dy/mu
13008           IF (cr .GE. 0.) THEN
13009             abs3d = crd
13010             abs3 = cr
13011           ELSE
13012             abs3d = -crd
13013             abs3 = -cr
13014           END IF
13015           y4d = crd + abs3d
13016           y4 = cr + abs3
13017           IF (1.0 .GT. y4) THEN
13018             min6d = y4d
13019             min6 = y4
13020           ELSE
13021             min6 = 1.0
13022             min6d = 0.0
13023           END IF
13024           IF (cr .GE. 0.) THEN
13025             abs18d = crd
13026             abs18 = cr
13027           ELSE
13028             abs18d = -crd
13029             abs18 = -cr
13030           END IF
13031           y19d = crd - abs18d
13032           y19 = cr - abs18
13033           IF (-1.0 .LT. y19) THEN
13034             max5d = y19d
13035             max5 = y19
13036           ELSE
13037             max5 = -1.0
13038             max5d = 0.0
13039           END IF
13040           fqyld(i, k, j) = dy*(mud*(0.5*min6*field_old(i, k, j-1)+0.5*&
13041 &            max5*field_old(i, k, j))+mu*(0.5*(min6d*field_old(i, k, j-1)&
13042 &            +min6*field_oldd(i, k, j-1))+0.5*(max5d*field_old(i, k, j)+&
13043 &            max5*field_oldd(i, k, j))))/dt
13044           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min6*field_old(i, k, j-1)+0.5*&
13045 &            max5*field_old(i, k, j))
13046           fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k, &
13047 &            j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
13048           fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1&
13049 &            ))
13050           fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
13051           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
13052         END DO
13053       END DO
13054     ELSE IF (j .EQ. jde - 2) THEN
13055 ! 3rd or 4th order flux 2 in from north boundary
13056       DO k=kts,ktf
13057         DO i=i_start,i_end
13058 ! ADT eqn 48 d/dy
13059           dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
13060           mud = 0.5*(mutd(i, j)+mutd(i, j-1))
13061           mu = 0.5*(mut(i, j)+mut(i, j-1))
13062           veld = rvd(i, k, j)
13063           vel = rv(i, k, j)
13064           crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
13065           cr = vel*dt/dy/mu
13066           IF (cr .GE. 0.) THEN
13067             abs4d = crd
13068             abs4 = cr
13069           ELSE
13070             abs4d = -crd
13071             abs4 = -cr
13072           END IF
13073           y5d = crd + abs4d
13074           y5 = cr + abs4
13075           IF (1.0 .GT. y5) THEN
13076             min7d = y5d
13077             min7 = y5
13078           ELSE
13079             min7 = 1.0
13080             min7d = 0.0
13081           END IF
13082           IF (cr .GE. 0.) THEN
13083             abs19d = crd
13084             abs19 = cr
13085           ELSE
13086             abs19d = -crd
13087             abs19 = -cr
13088           END IF
13089           y20d = crd - abs19d
13090           y20 = cr - abs19
13091           IF (-1.0 .LT. y20) THEN
13092             max6d = y20d
13093             max6 = y20
13094           ELSE
13095             max6 = -1.0
13096             max6d = 0.0
13097           END IF
13098           fqyld(i, k, j) = dy*(mud*(0.5*min7*field_old(i, k, j-1)+0.5*&
13099 &            max6*field_old(i, k, j))+mu*(0.5*(min7d*field_old(i, k, j-1)&
13100 &            +min7*field_oldd(i, k, j-1))+0.5*(max6d*field_old(i, k, j)+&
13101 &            max6*field_oldd(i, k, j))))/dt
13102           fqyl(i, k, j) = mu*(dy/dt)*(0.5*min7*field_old(i, k, j-1)+0.5*&
13103 &            max6*field_old(i, k, j))
13104           fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1))&
13105 &            -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
13106 &            time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i&
13107 &            , k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) + vel*(7.*(&
13108 &            fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+&
13109 &            fieldd(i, k, j-2))/12.+SIGN(1, time_step)*SIGN(1., vel)*(&
13110 &            fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)-&
13111 &            fieldd(i, k, j-1)))/12.)
13112           fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))-&
13113 &            1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, time_step&
13114 &            )*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-&
13115 &            3.*(field(i, k, j)-field(i, k, j-1))))
13116           fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
13117           fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
13118         END DO
13119       END DO
13120     END IF
13121   END DO j_loop_y_flux_5
13122 !  next, x flux
13123 !--  these bounds are for periodic and sym conditions
13124   i_start = its - 1
13125   IF (ite .GT. ide - 1) THEN
13126     min8 = ide - 1
13127   ELSE
13128     min8 = ite
13129   END IF
13130   i_end = min8 + 1
13131   i_start_f = i_start
13132   i_end_f = i_end + 1
13133   j_start = jts - 1
13134   IF (jte .GT. jde - 1) THEN
13135     min9 = jde - 1
13136   ELSE
13137     min9 = jte
13138   END IF
13139   j_end = min9 + 1
13140 !--  modify loop bounds for open and specified b.c
13141 !      IF(degrade_ys) j_start = MAX(jts-1,jds+1)
13142 !      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
13143   IF (degrade_ys) THEN
13144     IF (jts - 1 .LT. jds) THEN
13145       j_start = jds
13146     ELSE
13147       j_start = jts - 1
13148     END IF
13149   END IF
13150   IF (degrade_ye) THEN
13151     IF (jte + 1 .GT. jde - 1) THEN
13152       j_end = jde - 1
13153     ELSE
13154       j_end = jte + 1
13155     END IF
13156   END IF
13157   IF (degrade_xs) THEN
13158     IF (ids + 1 .LT. its - 1) THEN
13159       i_start = its - 1
13160     ELSE
13161       i_start = ids + 1
13162     END IF
13163     i_start_f = ids + 3
13164   END IF
13165   IF (degrade_xe) THEN
13166     IF (ide - 2 .GT. ite + 1) THEN
13167       i_end = ite + 1
13168     ELSE
13169       i_end = ide - 2
13170     END IF
13171     i_end_f = ide - 3
13172     fqxld = 0.0
13173     fqxd = 0.0
13174   ELSE
13175     fqxld = 0.0
13176     fqxd = 0.0
13177   END IF
13178 !  compute fluxes
13179   DO j=j_start,j_end
13180 !  5th order flux
13181     DO k=kts,ktf
13182       DO i=i_start_f,i_end_f
13183 ! ADT eqn 48 d/dx
13184         dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
13185         mud = 0.5*(mutd(i, j)+mutd(i-1, j))
13186         mu = 0.5*(mut(i, j)+mut(i-1, j))
13187         veld = rud(i, k, j)
13188         vel = ru(i, k, j)
13189         crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
13190         cr = vel*dt/dx/mu
13191         IF (cr .GE. 0.) THEN
13192           abs5d = crd
13193           abs5 = cr
13194         ELSE
13195           abs5d = -crd
13196           abs5 = -cr
13197         END IF
13198         y6d = crd + abs5d
13199         y6 = cr + abs5
13200         IF (1.0 .GT. y6) THEN
13201           min10d = y6d
13202           min10 = y6
13203         ELSE
13204           min10 = 1.0
13205           min10d = 0.0
13206         END IF
13207         IF (cr .GE. 0.) THEN
13208           abs20d = crd
13209           abs20 = cr
13210         ELSE
13211           abs20d = -crd
13212           abs20 = -cr
13213         END IF
13214         y21d = crd - abs20d
13215         y21 = cr - abs20
13216         IF (-1.0 .LT. y21) THEN
13217           max7d = y21d
13218           max7 = y21
13219         ELSE
13220           max7 = -1.0
13221           max7d = 0.0
13222         END IF
13223         fqxld(i, k, j) = dx*(mud*(0.5*min10*field_old(i-1, k, j)+0.5*&
13224 &          max7*field_old(i, k, j))+mu*(0.5*(min10d*field_old(i-1, k, j)+&
13225 &          min10*field_oldd(i-1, k, j))+0.5*(max7d*field_old(i, k, j)+&
13226 &          max7*field_oldd(i, k, j))))/dt
13227         fqxl(i, k, j) = mu*(dx/dt)*(0.5*min10*field_old(i-1, k, j)+0.5*&
13228 &          max7*field_old(i, k, j))
13229         IF (vel*sign(1,time_step) .GE. 0.0) THEN
13230           qip2d = fieldd(i+1, k, j)
13231           qip2 = field(i+1, k, j)
13232           qip1d = fieldd(i, k, j)
13233           qip1 = field(i, k, j)
13234           qid = fieldd(i-1, k, j)
13235           qi = field(i-1, k, j)
13236           qim1d = fieldd(i-2, k, j)
13237           qim1 = field(i-2, k, j)
13238           qim2d = fieldd(i-3, k, j)
13239           qim2 = field(i-3, k, j)
13240         ELSE
13241           qip2d = fieldd(i-2, k, j)
13242           qip2 = field(i-2, k, j)
13243           qip1d = fieldd(i-1, k, j)
13244           qip1 = field(i-1, k, j)
13245           qid = fieldd(i, k, j)
13246           qi = field(i, k, j)
13247           qim1d = fieldd(i+1, k, j)
13248           qim1 = field(i+1, k, j)
13249           qim2d = fieldd(i+2, k, j)
13250           qim2 = field(i+2, k, j)
13251         END IF
13252         f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
13253         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
13254         f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
13255         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
13256         f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
13257         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
13258         beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
13259 &          qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
13260         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
13261 &          )**2
13262         beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
13263 &          qim1-qip1)*(qim1d-qip1d)/4.
13264         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
13265         beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
13266 &          qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
13267         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
13268 &          )**2
13269         pwx1d = beta0d
13270         pwx1 = eps1 + beta0
13271         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
13272 &        THEN
13273           pwr1d = pw*pwx1**(pw-1)*pwx1d
13274         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
13275           pwr1d = pwx1d
13276         ELSE
13277           pwr1d = 0.0
13278         END IF
13279         pwr1 = pwx1**pw
13280         wi0d = -(gi0*pwr1d/pwr1**2)
13281         wi0 = gi0/pwr1
13282         pwx1d = beta1d
13283         pwx1 = eps1 + beta1
13284         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
13285 &        THEN
13286           pwr1d = pw*pwx1**(pw-1)*pwx1d
13287         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
13288           pwr1d = pwx1d
13289         ELSE
13290           pwr1d = 0.0
13291         END IF
13292         pwr1 = pwx1**pw
13293         wi1d = -(gi1*pwr1d/pwr1**2)
13294         wi1 = gi1/pwr1
13295         pwx1d = beta2d
13296         pwx1 = eps1 + beta2
13297         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
13298 &        THEN
13299           pwr1d = pw*pwx1**(pw-1)*pwx1d
13300         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
13301           pwr1d = pwx1d
13302         ELSE
13303           pwr1d = 0.0
13304         END IF
13305         pwr1 = pwx1**pw
13306         wi2d = -(gi2*pwr1d/pwr1**2)
13307         wi2 = gi2/pwr1
13308         sumwkd = wi0d + wi1d + wi2d
13309         sumwk = wi0 + wi1 + wi2
13310         fqxd(i, k, j) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
13311 &          f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
13312 &          +wi2*f2)*sumwkd)/sumwk**2
13313         fqx(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
13314 !          fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
13315 !                                         field(i-1,k,j), field(i  ,k,j),  &
13316 !                                         field(i+1,k,j), field(i+2,k,j),  &
13317 !                                         vel                             )
13318         fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
13319         fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
13320       END DO
13321     END DO
13322 !  lower order fluxes close to boundaries (if not periodic or symmetric)
13323     IF (degrade_xs) THEN
13324       DO i=i_start,i_start_f-1
13325         IF (i .EQ. ids + 1) THEN
13326 ! second order
13327           DO k=kts,ktf
13328 ! ADT eqn 48 d/dx
13329             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
13330             mud = 0.5*(mutd(i, j)+mutd(i-1, j))
13331             mu = 0.5*(mut(i, j)+mut(i-1, j))
13332             veld = (rud(i, k, j)*mu-ru(i, k, j)*mud)/mu**2
13333             vel = ru(i, k, j)/mu
13334             crd = dt*veld/dx
13335             cr = vel*dt/dx
13336             IF (cr .GE. 0.) THEN
13337               abs6d = crd
13338               abs6 = cr
13339             ELSE
13340               abs6d = -crd
13341               abs6 = -cr
13342             END IF
13343             y7d = crd + abs6d
13344             y7 = cr + abs6
13345             IF (1.0 .GT. y7) THEN
13346               min11d = y7d
13347               min11 = y7
13348             ELSE
13349               min11 = 1.0
13350               min11d = 0.0
13351             END IF
13352             IF (cr .GE. 0.) THEN
13353               abs21d = crd
13354               abs21 = cr
13355             ELSE
13356               abs21d = -crd
13357               abs21 = -cr
13358             END IF
13359             y22d = crd - abs21d
13360             y22 = cr - abs21
13361             IF (-1.0 .LT. y22) THEN
13362               max8d = y22d
13363               max8 = y22
13364             ELSE
13365               max8 = -1.0
13366               max8d = 0.0
13367             END IF
13368             fqxld(i, k, j) = dx*(mud*(0.5*min11*field_old(i-1, k, j)+0.5&
13369 &              *max8*field_old(i, k, j))+mu*(0.5*(min11d*field_old(i-1, k&
13370 &              , j)+min11*field_oldd(i-1, k, j))+0.5*(max8d*field_old(i, &
13371 &              k, j)+max8*field_oldd(i, k, j))))/dt
13372             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min11*field_old(i-1, k, j)+&
13373 &              0.5*max8*field_old(i, k, j))
13374             fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
13375 &              , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
13376             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
13377 &              , j))
13378             fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
13379             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
13380           END DO
13381         END IF
13382         IF (i .EQ. ids + 2) THEN
13383 ! third order
13384           DO k=kts,ktf
13385 ! ADT eqn 48 d/dx
13386             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
13387             mud = 0.5*(mutd(i, j)+mutd(i-1, j))
13388             mu = 0.5*(mut(i, j)+mut(i-1, j))
13389             veld = rud(i, k, j)
13390             vel = ru(i, k, j)
13391             crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
13392             cr = vel*dt/dx/mu
13393             IF (cr .GE. 0.) THEN
13394               abs7d = crd
13395               abs7 = cr
13396             ELSE
13397               abs7d = -crd
13398               abs7 = -cr
13399             END IF
13400             y8d = crd + abs7d
13401             y8 = cr + abs7
13402             IF (1.0 .GT. y8) THEN
13403               min12d = y8d
13404               min12 = y8
13405             ELSE
13406               min12 = 1.0
13407               min12d = 0.0
13408             END IF
13409             IF (cr .GE. 0.) THEN
13410               abs22d = crd
13411               abs22 = cr
13412             ELSE
13413               abs22d = -crd
13414               abs22 = -cr
13415             END IF
13416             y23d = crd - abs22d
13417             y23 = cr - abs22
13418             IF (-1.0 .LT. y23) THEN
13419               max9d = y23d
13420               max9 = y23
13421             ELSE
13422               max9 = -1.0
13423               max9d = 0.0
13424             END IF
13425             fqxld(i, k, j) = dx*(mud*(0.5*min12*field_old(i-1, k, j)+0.5&
13426 &              *max9*field_old(i, k, j))+mu*(0.5*(min12d*field_old(i-1, k&
13427 &              , j)+min12*field_oldd(i-1, k, j))+0.5*(max9d*field_old(i, &
13428 &              k, j)+max9*field_oldd(i, k, j))))/dt
13429             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min12*field_old(i-1, k, j)+&
13430 &              0.5*max9*field_old(i, k, j))
13431             fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j&
13432 &              ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
13433 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(&
13434 &              i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) + vel*(&
13435 &              7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k&
13436 &              , j)+fieldd(i-2, k, j))/12.+SIGN(1, time_step)*SIGN(1., &
13437 &              vel)*(fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i, k&
13438 &              , j)-fieldd(i-1, k, j)))/12.)
13439             fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))&
13440 &              -1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
13441 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(&
13442 &              i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
13443             fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
13444             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
13445           END DO
13446         END IF
13447       END DO
13448     END IF
13449     IF (degrade_xe) THEN
13450       DO i=i_end_f+1,i_end+1
13451         IF (i .EQ. ide - 1) THEN
13452 ! second order flux next to the boundary
13453           DO k=kts,ktf
13454 ! ADT eqn 48 d/dx
13455             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
13456             mud = 0.5*(mutd(i, j)+mutd(i-1, j))
13457             mu = 0.5*(mut(i, j)+mut(i-1, j))
13458             veld = rud(i, k, j)
13459             vel = ru(i, k, j)
13460             crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
13461             cr = vel*dt/dx/mu
13462             IF (cr .GE. 0.) THEN
13463               abs8d = crd
13464               abs8 = cr
13465             ELSE
13466               abs8d = -crd
13467               abs8 = -cr
13468             END IF
13469             y9d = crd + abs8d
13470             y9 = cr + abs8
13471             IF (1.0 .GT. y9) THEN
13472               min13d = y9d
13473               min13 = y9
13474             ELSE
13475               min13 = 1.0
13476               min13d = 0.0
13477             END IF
13478             IF (cr .GE. 0.) THEN
13479               abs23d = crd
13480               abs23 = cr
13481             ELSE
13482               abs23d = -crd
13483               abs23 = -cr
13484             END IF
13485             y24d = crd - abs23d
13486             y24 = cr - abs23
13487             IF (-1.0 .LT. y24) THEN
13488               max10d = y24d
13489               max10 = y24
13490             ELSE
13491               max10 = -1.0
13492               max10d = 0.0
13493             END IF
13494             fqxld(i, k, j) = dx*(mud*(0.5*min13*field_old(i-1, k, j)+0.5&
13495 &              *max10*field_old(i, k, j))+mu*(0.5*(min13d*field_old(i-1, &
13496 &              k, j)+min13*field_oldd(i-1, k, j))+0.5*(max10d*field_old(i&
13497 &              , k, j)+max10*field_oldd(i, k, j))))/dt
13498             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min13*field_old(i-1, k, j)+&
13499 &              0.5*max10*field_old(i, k, j))
13500             fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
13501 &              , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
13502             fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
13503 &              , j))
13504             fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
13505             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
13506           END DO
13507         END IF
13508         IF (i .EQ. ide - 2) THEN
13509 ! third order flux one in from the boundary
13510           DO k=kts,ktf
13511 ! ADT eqn 48 d/dx
13512             dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
13513             mud = 0.5*(mutd(i, j)+mutd(i-1, j))
13514             mu = 0.5*(mut(i, j)+mut(i-1, j))
13515             veld = rud(i, k, j)
13516             vel = ru(i, k, j)
13517             crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
13518             cr = vel*dt/dx/mu
13519             IF (cr .GE. 0.) THEN
13520               abs9d = crd
13521               abs9 = cr
13522             ELSE
13523               abs9d = -crd
13524               abs9 = -cr
13525             END IF
13526             y10d = crd + abs9d
13527             y10 = cr + abs9
13528             IF (1.0 .GT. y10) THEN
13529               min14d = y10d
13530               min14 = y10
13531             ELSE
13532               min14 = 1.0
13533               min14d = 0.0
13534             END IF
13535             IF (cr .GE. 0.) THEN
13536               abs24d = crd
13537               abs24 = cr
13538             ELSE
13539               abs24d = -crd
13540               abs24 = -cr
13541             END IF
13542             y25d = crd - abs24d
13543             y25 = cr - abs24
13544             IF (-1.0 .LT. y25) THEN
13545               max11d = y25d
13546               max11 = y25
13547             ELSE
13548               max11 = -1.0
13549               max11d = 0.0
13550             END IF
13551             fqxld(i, k, j) = dx*(mud*(0.5*min14*field_old(i-1, k, j)+0.5&
13552 &              *max11*field_old(i, k, j))+mu*(0.5*(min14d*field_old(i-1, &
13553 &              k, j)+min14*field_oldd(i-1, k, j))+0.5*(max11d*field_old(i&
13554 &              , k, j)+max11*field_oldd(i, k, j))))/dt
13555             fqxl(i, k, j) = mu*(dx/dt)*(0.5*min14*field_old(i-1, k, j)+&
13556 &              0.5*max11*field_old(i, k, j))
13557             fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j&
13558 &              ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
13559 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(&
13560 &              i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) + vel*(&
13561 &              7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k&
13562 &              , j)+fieldd(i-2, k, j))/12.+SIGN(1, time_step)*SIGN(1., &
13563 &              vel)*(fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i, k&
13564 &              , j)-fieldd(i-1, k, j)))/12.)
13565             fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))&
13566 &              -1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
13567 &              time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(&
13568 &              i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
13569             fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
13570             fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
13571           END DO
13572         END IF
13573       END DO
13574     END IF
13575   END DO
13576 ! enddo for outer J loop
13577 !--- end of 5th order horizontal flux calculation
13578 !   ELSE
13579 !      WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order
13580 !      CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
13581 !   ENDIF horizontal_order_test
13582 !  pick up the rest of the horizontal radiation boundary conditions.
13583 !  (these are the computations that don't require 'cb'.
13584 !  first, set to index ranges
13585   i_start = its
13586   IF (ite .GT. ide - 1) THEN
13587     i_end = ide - 1
13588   ELSE
13589     i_end = ite
13590   END IF
13591   j_start = jts
13592   IF (jte .GT. jde - 1) THEN
13593     j_end = jde - 1
13594   ELSE
13595     j_end = jte
13596   END IF
13597 !  compute x (u) conditions for v, w, or scalar
13598   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
13599     DO j=j_start,j_end
13600       DO k=kts,ktf
13601         IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
13602           ub = 0.
13603           ubd = 0.0
13604         ELSE
13605           ubd = 0.5*(rud(its, k, j)+rud(its+1, k, j))
13606           ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
13607         END IF
13608         tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(&
13609 &          field_old(its+1, k, j)-field_old(its, k, j))+ub*(field_oldd(&
13610 &          its+1, k, j)-field_oldd(its, k, j))+fieldd(its, k, j)*(ru(its+&
13611 &          1, k, j)-ru(its, k, j))+field(its, k, j)*(rud(its+1, k, j)-rud&
13612 &          (its, k, j)))
13613         tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(field_old(&
13614 &          its+1, k, j)-field_old(its, k, j))+field(its, k, j)*(ru(its+1&
13615 &          , k, j)-ru(its, k, j)))
13616       END DO
13617     END DO
13618   END IF
13619   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
13620     DO j=j_start,j_end
13621       DO k=kts,ktf
13622         IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
13623           ub = 0.
13624           ubd = 0.0
13625         ELSE
13626           ubd = 0.5*(rud(ite-1, k, j)+rud(ite, k, j))
13627           ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
13628         END IF
13629         tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
13630 &          field_old(i_end, k, j)-field_old(i_end-1, k, j))+ub*(&
13631 &          field_oldd(i_end, k, j)-field_oldd(i_end-1, k, j))+fieldd(&
13632 &          i_end, k, j)*(ru(ite, k, j)-ru(ite-1, k, j))+field(i_end, k, j&
13633 &          )*(rud(ite, k, j)-rud(ite-1, k, j)))
13634         tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(&
13635 &          field_old(i_end, k, j)-field_old(i_end-1, k, j))+field(i_end, &
13636 &          k, j)*(ru(ite, k, j)-ru(ite-1, k, j)))
13637       END DO
13638     END DO
13639   END IF
13640   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
13641     DO i=i_start,i_end
13642       DO k=kts,ktf
13643         IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
13644           vb = 0.
13645           vbd = 0.0
13646         ELSE
13647           vbd = 0.5*(rvd(i, k, jts)+rvd(i, k, jts+1))
13648           vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
13649         END IF
13650         tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
13651 &          field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
13652 &          , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*(rv(i, k&
13653 &          , jts+1)-rv(i, k, jts))+field(i, k, jts)*(rvd(i, k, jts+1)-rvd&
13654 &          (i, k, jts)))
13655         tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
13656 &          , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*(rv(i, k, &
13657 &          jts+1)-rv(i, k, jts)))
13658       END DO
13659     END DO
13660   END IF
13661   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
13662     DO i=i_start,i_end
13663       DO k=kts,ktf
13664         IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
13665           vb = 0.
13666           vbd = 0.0
13667         ELSE
13668           vbd = 0.5*(rvd(i, k, jte-1)+rvd(i, k, jte))
13669           vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
13670         END IF
13671         tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
13672 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
13673 &          field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))+fieldd(i, k&
13674 &          , j_end)*(rv(i, k, jte)-rv(i, k, jte-1))+field(i, k, j_end)*(&
13675 &          rvd(i, k, jte)-rvd(i, k, jte-1)))
13676         tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
13677 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
13678 &          j_end)*(rv(i, k, jte)-rv(i, k, jte-1)))
13679       END DO
13680     END DO
13681   END IF
13682   IF (config_flags%polar .AND. jts .EQ. jds) THEN
13683 ! Assuming rv(i,k,jds) = 0.
13684     DO i=i_start,i_end
13685       DO k=kts,ktf
13686         IF (0.5*rv(i, k, jts+1) .GT. 0.) THEN
13687           vb = 0.
13688           vbd = 0.0
13689         ELSE
13690           vbd = 0.5*rvd(i, k, jts+1)
13691           vb = 0.5*rv(i, k, jts+1)
13692         END IF
13693         tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
13694 &          field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
13695 &          , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*rv(i, k, &
13696 &          jts+1)+field(i, k, jts)*rvd(i, k, jts+1))
13697         tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
13698 &          , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*rv(i, k, &
13699 &          jts+1))
13700       END DO
13701     END DO
13702   END IF
13703   IF (config_flags%polar .AND. jte .EQ. jde) THEN
13704 ! Assuming rv(i,k,jde) = 0.
13705     DO i=i_start,i_end
13706       DO k=kts,ktf
13707         IF (0.5*rv(i, k, jte-1) .LT. 0.) THEN
13708           vb = 0.
13709           vbd = 0.0
13710         ELSE
13711           vbd = 0.5*rvd(i, k, jte-1)
13712           vb = 0.5*rv(i, k, jte-1)
13713         END IF
13714         tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
13715 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
13716 &          field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))-fieldd(i, k&
13717 &          , j_end)*rv(i, k, jte-1)-field(i, k, j_end)*rvd(i, k, jte-1))
13718         tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
13719 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
13720 &          j_end)*(-rv(i, k, jte-1)))
13721       END DO
13722     END DO
13723   END IF
13724 !-------------------- vertical advection
13725 !-- loop bounds for periodic or sym conditions
13726   i_start = its - 1
13727   IF (ite .GT. ide - 1) THEN
13728     min15 = ide - 1
13729   ELSE
13730     min15 = ite
13731   END IF
13732   i_end = min15 + 1
13733   j_start = jts - 1
13734   IF (jte .GT. jde - 1) THEN
13735     min16 = jde - 1
13736   ELSE
13737     min16 = jte
13738   END IF
13739   j_end = min16 + 1
13740 !-- loop bounds for open or specified conditions
13741   IF (degrade_xs) THEN
13742     IF (its - 1 .LT. ids) THEN
13743       i_start = ids
13744     ELSE
13745       i_start = its - 1
13746     END IF
13747   END IF
13748   IF (degrade_xe) THEN
13749     IF (ite + 1 .GT. ide - 1) THEN
13750       i_end = ide - 1
13751     ELSE
13752       i_end = ite + 1
13753     END IF
13754   END IF
13755   IF (degrade_ys) THEN
13756     IF (jts - 1 .LT. jds) THEN
13757       j_start = jds
13758     ELSE
13759       j_start = jts - 1
13760     END IF
13761   END IF
13762   IF (degrade_ye) THEN
13763     IF (jte + 1 .GT. jde - 1) THEN
13764       j_end = jde - 1
13765     ELSE
13766       j_end = jte + 1
13767     END IF
13768     fqzd = 0.0
13769     fqzld = 0.0
13770   ELSE
13771     fqzd = 0.0
13772     fqzld = 0.0
13773   END IF
13774 !    vert_order_test : IF (vert_order == 6) THEN
13775 !    ELSE IF (vert_order == 5) THEN
13776   DO j=j_start,j_end
13777     DO i=i_start,i_end
13778       fqzd(i, 1, j) = 0.0
13779       fqz(i, 1, j) = 0.
13780       fqzld(i, 1, j) = 0.0
13781       fqzl(i, 1, j) = 0.
13782       fqzd(i, kde, j) = 0.0
13783       fqz(i, kde, j) = 0.
13784       fqzld(i, kde, j) = 0.0
13785       fqzl(i, kde, j) = 0.
13786     END DO
13787     DO k=kts+3,ktf-2
13788       DO i=i_start,i_end
13789         dz = 2./(rdzw(k)+rdzw(k-1))
13790         mud = 0.5*2*mutd(i, j)
13791         mu = 0.5*(mut(i, j)+mut(i, j))
13792         veld = romd(i, k, j)
13793         vel = rom(i, k, j)
13794         crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
13795         cr = vel*dt/dz/mu
13796         IF (cr .GE. 0.) THEN
13797           abs10d = crd
13798           abs10 = cr
13799         ELSE
13800           abs10d = -crd
13801           abs10 = -cr
13802         END IF
13803         y11d = crd + abs10d
13804         y11 = cr + abs10
13805         IF (1.0 .GT. y11) THEN
13806           min17d = y11d
13807           min17 = y11
13808         ELSE
13809           min17 = 1.0
13810           min17d = 0.0
13811         END IF
13812         IF (cr .GE. 0.) THEN
13813           abs25d = crd
13814           abs25 = cr
13815         ELSE
13816           abs25d = -crd
13817           abs25 = -cr
13818         END IF
13819         y26d = crd - abs25d
13820         y26 = cr - abs25
13821         IF (-1.0 .LT. y26) THEN
13822           max12d = y26d
13823           max12 = y26
13824         ELSE
13825           max12 = -1.0
13826           max12d = 0.0
13827         END IF
13828         fqzld(i, k, j) = dz*(mud*(0.5*min17*field_old(i, k-1, j)+0.5*&
13829 &          max12*field_old(i, k, j))+mu*(0.5*(min17d*field_old(i, k-1, j)&
13830 &          +min17*field_oldd(i, k-1, j))+0.5*(max12d*field_old(i, k, j)+&
13831 &          max12*field_oldd(i, k, j))))/dt
13832         fqzl(i, k, j) = mu*(dz/dt)*(0.5*min17*field_old(i, k-1, j)+0.5*&
13833 &          max12*field_old(i, k, j))
13834         IF (-vel*sign(1,time_step) .GE. 0.0) THEN
13835           qip2d = fieldd(i, k+1, j)
13836           qip2 = field(i, k+1, j)
13837           qip1d = fieldd(i, k, j)
13838           qip1 = field(i, k, j)
13839           qid = fieldd(i, k-1, j)
13840           qi = field(i, k-1, j)
13841           qim1d = fieldd(i, k-2, j)
13842           qim1 = field(i, k-2, j)
13843           qim2d = fieldd(i, k-3, j)
13844           qim2 = field(i, k-3, j)
13845         ELSE
13846           qip2d = fieldd(i, k-2, j)
13847           qip2 = field(i, k-2, j)
13848           qip1d = fieldd(i, k-1, j)
13849           qip1 = field(i, k-1, j)
13850           qid = fieldd(i, k, j)
13851           qi = field(i, k, j)
13852           qim1d = fieldd(i, k+1, j)
13853           qim1 = field(i, k+1, j)
13854           qim2d = fieldd(i, k+2, j)
13855           qim2 = field(i, k+2, j)
13856         END IF
13857         f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
13858         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
13859         f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
13860         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
13861         f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
13862         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
13863         beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
13864 &          qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
13865         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
13866 &          )**2
13867         beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
13868 &          qim1-qip1)*(qim1d-qip1d)/4.
13869         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
13870         beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
13871 &          qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
13872         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
13873 &          )**2
13874         pwx1d = beta0d
13875         pwx1 = eps1 + beta0
13876         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
13877 &        THEN
13878           pwr1d = pw*pwx1**(pw-1)*pwx1d
13879         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
13880           pwr1d = pwx1d
13881         ELSE
13882           pwr1d = 0.0
13883         END IF
13884         pwr1 = pwx1**pw
13885         wi0d = -(gi0*pwr1d/pwr1**2)
13886         wi0 = gi0/pwr1
13887         pwx1d = beta1d
13888         pwx1 = eps1 + beta1
13889         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
13890 &        THEN
13891           pwr1d = pw*pwx1**(pw-1)*pwx1d
13892         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
13893           pwr1d = pwx1d
13894         ELSE
13895           pwr1d = 0.0
13896         END IF
13897         pwr1 = pwx1**pw
13898         wi1d = -(gi1*pwr1d/pwr1**2)
13899         wi1 = gi1/pwr1
13900         pwx1d = beta2d
13901         pwx1 = eps1 + beta2
13902         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
13903 &        THEN
13904           pwr1d = pw*pwx1**(pw-1)*pwx1d
13905         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
13906           pwr1d = pwx1d
13907         ELSE
13908           pwr1d = 0.0
13909         END IF
13910         pwr1 = pwx1**pw
13911         wi2d = -(gi2*pwr1d/pwr1**2)
13912         wi2 = gi2/pwr1
13913         sumwkd = wi0d + wi1d + wi2d
13914         sumwk = wi0 + wi1 + wi2
13915         fqzd(i, k, j) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
13916 &          f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
13917 &          +wi2*f2)*sumwkd)/sumwk**2
13918         fqz(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
13919 !           fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),      &
13920 !                                   field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
13921         fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
13922         fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
13923       END DO
13924     END DO
13925     DO i=i_start,i_end
13926       k = kts + 1
13927       dz = 2./(rdzw(k)+rdzw(k-1))
13928       mud = 0.5*2*mutd(i, j)
13929       mu = 0.5*(mut(i, j)+mut(i, j))
13930       veld = romd(i, k, j)
13931       vel = rom(i, k, j)
13932       crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
13933       cr = vel*dt/dz/mu
13934       IF (cr .GE. 0.) THEN
13935         abs11d = crd
13936         abs11 = cr
13937       ELSE
13938         abs11d = -crd
13939         abs11 = -cr
13940       END IF
13941       y12d = crd + abs11d
13942       y12 = cr + abs11
13943       IF (1.0 .GT. y12) THEN
13944         min18d = y12d
13945         min18 = y12
13946       ELSE
13947         min18 = 1.0
13948         min18d = 0.0
13949       END IF
13950       IF (cr .GE. 0.) THEN
13951         abs26d = crd
13952         abs26 = cr
13953       ELSE
13954         abs26d = -crd
13955         abs26 = -cr
13956       END IF
13957       y27d = crd - abs26d
13958       y27 = cr - abs26
13959       IF (-1.0 .LT. y27) THEN
13960         max13d = y27d
13961         max13 = y27
13962       ELSE
13963         max13 = -1.0
13964         max13d = 0.0
13965       END IF
13966       fqzld(i, k, j) = dz*(mud*(0.5*min18*field_old(i, k-1, j)+0.5*max13&
13967 &        *field_old(i, k, j))+mu*(0.5*(min18d*field_old(i, k-1, j)+min18*&
13968 &        field_oldd(i, k-1, j))+0.5*(max13d*field_old(i, k, j)+max13*&
13969 &        field_oldd(i, k, j))))/dt
13970       fqzl(i, k, j) = mu*(dz/dt)*(0.5*min18*field_old(i, k-1, j)+0.5*&
13971 &        max13*field_old(i, k, j))
13972       fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
13973 &        i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*fieldd&
13974 &        (i, k-1, j))
13975       fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
13976 &        , k-1, j))
13977       fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
13978       fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
13979       k = kts + 2
13980       dz = 2./(rdzw(k)+rdzw(k-1))
13981       mud = 0.5*2*mutd(i, j)
13982       mu = 0.5*(mut(i, j)+mut(i, j))
13983       veld = romd(i, k, j)
13984       vel = rom(i, k, j)
13985       crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
13986       cr = vel*dt/dz/mu
13987       IF (cr .GE. 0.) THEN
13988         abs12d = crd
13989         abs12 = cr
13990       ELSE
13991         abs12d = -crd
13992         abs12 = -cr
13993       END IF
13994       y13d = crd + abs12d
13995       y13 = cr + abs12
13996       IF (1.0 .GT. y13) THEN
13997         min19d = y13d
13998         min19 = y13
13999       ELSE
14000         min19 = 1.0
14001         min19d = 0.0
14002       END IF
14003       IF (cr .GE. 0.) THEN
14004         abs27d = crd
14005         abs27 = cr
14006       ELSE
14007         abs27d = -crd
14008         abs27 = -cr
14009       END IF
14010       y28d = crd - abs27d
14011       y28 = cr - abs27
14012       IF (-1.0 .LT. y28) THEN
14013         max14d = y28d
14014         max14 = y28
14015       ELSE
14016         max14 = -1.0
14017         max14d = 0.0
14018       END IF
14019       fqzld(i, k, j) = dz*(mud*(0.5*min19*field_old(i, k-1, j)+0.5*max14&
14020 &        *field_old(i, k, j))+mu*(0.5*(min19d*field_old(i, k-1, j)+min19*&
14021 &        field_oldd(i, k-1, j))+0.5*(max14d*field_old(i, k, j)+max14*&
14022 &        field_oldd(i, k, j))))/dt
14023       fqzl(i, k, j) = mu*(dz/dt)*(0.5*min19*field_old(i, k-1, j)+0.5*&
14024 &        max14*field_old(i, k, j))
14025       fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
14026 &        12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(&
14027 &        1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
14028 &        i, k, j)-field(i, k-1, j)))) + vel*(7.*(fieldd(i, k, j)+fieldd(i&
14029 &        , k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k-2, j))/12.+SIGN(1&
14030 &        , time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-fieldd(i, k-2, j)&
14031 &        -3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.)
14032       fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
14033 &        12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(&
14034 &        1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
14035 &        i, k, j)-field(i, k-1, j))))
14036       fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
14037       fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
14038       k = ktf - 1
14039       dz = 2./(rdzw(k)+rdzw(k-1))
14040       mud = 0.5*2*mutd(i, j)
14041       mu = 0.5*(mut(i, j)+mut(i, j))
14042       veld = romd(i, k, j)
14043       vel = rom(i, k, j)
14044       crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
14045       cr = vel*dt/dz/mu
14046       IF (cr .GE. 0.) THEN
14047         abs13d = crd
14048         abs13 = cr
14049       ELSE
14050         abs13d = -crd
14051         abs13 = -cr
14052       END IF
14053       y14d = crd + abs13d
14054       y14 = cr + abs13
14055       IF (1.0 .GT. y14) THEN
14056         min20d = y14d
14057         min20 = y14
14058       ELSE
14059         min20 = 1.0
14060         min20d = 0.0
14061       END IF
14062       IF (cr .GE. 0.) THEN
14063         abs28d = crd
14064         abs28 = cr
14065       ELSE
14066         abs28d = -crd
14067         abs28 = -cr
14068       END IF
14069       y29d = crd - abs28d
14070       y29 = cr - abs28
14071       IF (-1.0 .LT. y29) THEN
14072         max15d = y29d
14073         max15 = y29
14074       ELSE
14075         max15 = -1.0
14076         max15d = 0.0
14077       END IF
14078       fqzld(i, k, j) = dz*(mud*(0.5*min20*field_old(i, k-1, j)+0.5*max15&
14079 &        *field_old(i, k, j))+mu*(0.5*(min20d*field_old(i, k-1, j)+min20*&
14080 &        field_oldd(i, k-1, j))+0.5*(max15d*field_old(i, k, j)+max15*&
14081 &        field_oldd(i, k, j))))/dt
14082       fqzl(i, k, j) = mu*(dz/dt)*(0.5*min20*field_old(i, k-1, j)+0.5*&
14083 &        max15*field_old(i, k, j))
14084       fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
14085 &        12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(&
14086 &        1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
14087 &        i, k, j)-field(i, k-1, j)))) + vel*(7.*(fieldd(i, k, j)+fieldd(i&
14088 &        , k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k-2, j))/12.+SIGN(1&
14089 &        , time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-fieldd(i, k-2, j)&
14090 &        -3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.)
14091       fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
14092 &        12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(&
14093 &        1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
14094 &        i, k, j)-field(i, k-1, j))))
14095       fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
14096       fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
14097       k = ktf
14098       dz = 2./(rdzw(k)+rdzw(k-1))
14099       mud = 0.5*2*mutd(i, j)
14100       mu = 0.5*(mut(i, j)+mut(i, j))
14101       veld = romd(i, k, j)
14102       vel = rom(i, k, j)
14103       crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
14104       cr = vel*dt/dz/mu
14105       IF (cr .GE. 0.) THEN
14106         abs14d = crd
14107         abs14 = cr
14108       ELSE
14109         abs14d = -crd
14110         abs14 = -cr
14111       END IF
14112       y15d = crd + abs14d
14113       y15 = cr + abs14
14114       IF (1.0 .GT. y15) THEN
14115         min21d = y15d
14116         min21 = y15
14117       ELSE
14118         min21 = 1.0
14119         min21d = 0.0
14120       END IF
14121       IF (cr .GE. 0.) THEN
14122         abs29d = crd
14123         abs29 = cr
14124       ELSE
14125         abs29d = -crd
14126         abs29 = -cr
14127       END IF
14128       y30d = crd - abs29d
14129       y30 = cr - abs29
14130       IF (-1.0 .LT. y30) THEN
14131         max16d = y30d
14132         max16 = y30
14133       ELSE
14134         max16 = -1.0
14135         max16d = 0.0
14136       END IF
14137       fqzld(i, k, j) = dz*(mud*(0.5*min21*field_old(i, k-1, j)+0.5*max16&
14138 &        *field_old(i, k, j))+mu*(0.5*(min21d*field_old(i, k-1, j)+min21*&
14139 &        field_oldd(i, k-1, j))+0.5*(max16d*field_old(i, k, j)+max16*&
14140 &        field_oldd(i, k, j))))/dt
14141       fqzl(i, k, j) = mu*(dz/dt)*(0.5*min21*field_old(i, k-1, j)+0.5*&
14142 &        max16*field_old(i, k, j))
14143       fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
14144 &        i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*fieldd&
14145 &        (i, k-1, j))
14146       fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
14147 &        , k-1, j))
14148       fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
14149       fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
14150     END DO
14151   END DO
14152 !   ELSE
14153 !      WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order
14154 !      CALL wrf_error_fatal ( wrf_err_message )
14155 !   ENDIF vert_order_test
14156   IF (pd_limit) THEN
14157 ! positive definite filter
14158     i_start = its - 1
14159     IF (ite .GT. ide - 1) THEN
14160       min22 = ide - 1
14161     ELSE
14162       min22 = ite
14163     END IF
14164     i_end = min22 + 1
14165     j_start = jts - 1
14166     IF (jte .GT. jde - 1) THEN
14167       min23 = jde - 1
14168     ELSE
14169       min23 = jte
14170     END IF
14171     j_end = min23 + 1
14172 !-- loop bounds for open or specified conditions
14173     IF (degrade_xs) THEN
14174       IF (its - 1 .LT. ids) THEN
14175         i_start = ids
14176       ELSE
14177         i_start = its - 1
14178       END IF
14179     END IF
14180     IF (degrade_xe) THEN
14181       IF (ite + 1 .GT. ide - 1) THEN
14182         i_end = ide - 1
14183       ELSE
14184         i_end = ite + 1
14185       END IF
14186     END IF
14187     IF (degrade_ys) THEN
14188       IF (jts - 1 .LT. jds) THEN
14189         j_start = jds
14190       ELSE
14191         j_start = jts - 1
14192       END IF
14193     END IF
14194     IF (degrade_ye) THEN
14195       IF (jte + 1 .GT. jde - 1) THEN
14196         j_end = jde - 1
14197       ELSE
14198         j_end = jte + 1
14199       END IF
14200     END IF
14201     IF (config_flags%specified .OR. config_flags%nested) THEN
14202       IF (degrade_xs) THEN
14203         IF (its - 1 .LT. ids + 1) THEN
14204           i_start = ids + 1
14205         ELSE
14206           i_start = its - 1
14207         END IF
14208       END IF
14209       IF (degrade_xe) THEN
14210         IF (ite + 1 .GT. ide - 2) THEN
14211           i_end = ide - 2
14212         ELSE
14213           i_end = ite + 1
14214         END IF
14215       END IF
14216       IF (degrade_ys) THEN
14217         IF (jts - 1 .LT. jds + 1) THEN
14218           j_start = jds + 1
14219         ELSE
14220           j_start = jts - 1
14221         END IF
14222       END IF
14223       IF (degrade_ye) THEN
14224         IF (jte + 1 .GT. jde - 2) THEN
14225           j_end = jde - 2
14226         ELSE
14227           j_end = jte + 1
14228         END IF
14229       END IF
14230     END IF
14231     IF (config_flags%open_xs) THEN
14232       IF (degrade_xs) THEN
14233         IF (its - 1 .LT. ids + 1) THEN
14234           i_start = ids + 1
14235         ELSE
14236           i_start = its - 1
14237         END IF
14238       END IF
14239     END IF
14240     IF (config_flags%open_xe) THEN
14241       IF (degrade_xe) THEN
14242         IF (ite + 1 .GT. ide - 2) THEN
14243           i_end = ide - 2
14244         ELSE
14245           i_end = ite + 1
14246         END IF
14247       END IF
14248     END IF
14249     IF (config_flags%open_ys) THEN
14250       IF (degrade_ys) THEN
14251         IF (jts - 1 .LT. jds + 1) THEN
14252           j_start = jds + 1
14253         ELSE
14254           j_start = jts - 1
14255         END IF
14256       END IF
14257     END IF
14258     IF (config_flags%open_ye) THEN
14259       IF (degrade_ye) THEN
14260         IF (jte + 1 .GT. jde - 2) THEN
14261           j_end = jde - 2
14262         ELSE
14263           j_end = jte + 1
14264         END IF
14265         ph_lowd = 0.0
14266       ELSE
14267         ph_lowd = 0.0
14268       END IF
14269     ELSE
14270       ph_lowd = 0.0
14271     END IF
14272 ! ADT note:
14273 ! We don't want to change j_start and j_end
14274 ! for polar BC's since we want to calculate
14275 ! fluxes for directions other than y at the
14276 ! edge
14277 !-- here is the limiter...
14278     DO j=j_start,j_end
14279       DO k=kts,ktf
14280         DO i=i_start,i_end
14281           ph_lowd(i,k,j) = mu_oldd(i, j)*field_old(i, k, j) + (mub(i, j)+mu_old&
14282 &            (i, j))*field_oldd(i, k, j) - dt*(msftx(i, j)*msfty(i, j)*(&
14283 &            rdx*(fqxld(i+1, k, j)-fqxld(i, k, j))+rdy*(fqyld(i, k, j+1)-&
14284 &            fqyld(i, k, j)))+msfty(i, j)*rdzw(k)*(fqzld(i, k+1, j)-fqzld&
14285 &            (i, k, j)))
14286           ph_low(i,k,j) = (mub(i, j)+mu_old(i, j))*field_old(i, k, j) - dt*(&
14287 &            msftx(i, j)*msfty(i, j)*(rdx*(fqxl(i+1, k, j)-fqxl(i, k, j))&
14288 &            +rdy*(fqyl(i, k, j+1)-fqyl(i, k, j)))+msfty(i, j)*rdzw(k)*(&
14289 &            fqzl(i, k+1, j)-fqzl(i, k, j)))
14290         ENDDO
14291       ENDDO
14292     ENDDO
14293     flux_outd = 0.0
14294     DO j=j_start,j_end
14295       DO k=kts,ktf
14296 !DIR$ vector always
14297         DO i=i_start,i_end
14298           IF (0. .LT. fqx(i+1, k, j)) THEN
14299             max1d = fqxd(i+1, k, j)
14300             max1 = fqx(i+1, k, j)
14301           ELSE
14302             max1 = 0.
14303             max1d = 0.0
14304           END IF
14305           IF (0. .GT. fqx(i, k, j)) THEN
14306             min24d = fqxd(i, k, j)
14307             min24 = fqx(i, k, j)
14308           ELSE
14309             min24 = 0.
14310             min24d = 0.0
14311           END IF
14312           IF (0. .LT. fqy(i, k, j+1)) THEN
14313             max17d = fqyd(i, k, j+1)
14314             max17 = fqy(i, k, j+1)
14315           ELSE
14316             max17 = 0.
14317             max17d = 0.0
14318           END IF
14319           IF (0. .GT. fqy(i, k, j)) THEN
14320             min25d = fqyd(i, k, j)
14321             min25 = fqy(i, k, j)
14322           ELSE
14323             min25 = 0.
14324             min25d = 0.0
14325           END IF
14326           IF (0. .GT. fqz(i, k+1, j)) THEN
14327             min26d = fqzd(i, k+1, j)
14328             min26 = fqz(i, k+1, j)
14329           ELSE
14330             min26 = 0.
14331             min26d = 0.0
14332           END IF
14333           IF (0. .LT. fqz(i, k, j)) THEN
14334             max18d = fqzd(i, k, j)
14335             max18 = fqz(i, k, j)
14336           ELSE
14337             max18 = 0.
14338             max18d = 0.0
14339           END IF
14340           flux_outd(i,k,j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1d-min24d)+&
14341 &            rdy*(max17d-min25d))+msfty(i, j)*rdzw(k)*(min26d-max18d))
14342           flux_out(i,k,j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1-min24)+rdy*(&
14343 &            max17-min25))+msfty(i, j)*rdzw(k)*(min26-max18))
14344         ENDDO
14345       ENDDO
14346     ENDDO
14347     DO j=j_start,j_end
14348       DO k=kts,ktf
14349         DO i=i_start,i_end
14350           IF (flux_out(i,k,j) .GT. ph_low(i,k,j)) THEN
14351             IF (0. .LT. ph_low(i,k,j)/(flux_out(i,k,j)+eps)) THEN
14352               scaled = (ph_lowd(i,k,j)*(flux_out(i,k,j)+eps)-ph_low(i,k,j)*flux_outd(i,k,j))/(&
14353 &                flux_out(i,k,j)+eps)**2
14354               scale = ph_low(i,k,j)/(flux_out(i,k,j)+eps)
14355             ELSE
14356               scale = 0.
14357               scaled = 0.0
14358             END IF
14359             IF (fqx(i+1, k, j) .GT. 0.) THEN
14360               fqxd(i+1, k, j) = scaled*fqx(i+1, k, j) + scale*fqxd(i+1, &
14361 &                k, j)
14362               fqx(i+1, k, j) = scale*fqx(i+1, k, j)
14363             END IF
14364             IF (fqx(i, k, j) .LT. 0.) THEN
14365               fqxd(i, k, j) = scaled*fqx(i, k, j) + scale*fqxd(i, k, j)
14366               fqx(i, k, j) = scale*fqx(i, k, j)
14367             END IF
14368             IF (fqy(i, k, j+1) .GT. 0.) THEN
14369               fqyd(i, k, j+1) = scaled*fqy(i, k, j+1) + scale*fqyd(i, k&
14370 &                , j+1)
14371               fqy(i, k, j+1) = scale*fqy(i, k, j+1)
14372             END IF
14373             IF (fqy(i, k, j) .LT. 0.) THEN
14374               fqyd(i, k, j) = scaled*fqy(i, k, j) + scale*fqyd(i, k, j)
14375               fqy(i, k, j) = scale*fqy(i, k, j)
14376             END IF
14377 !  note: z flux is opposite sign in mass coordinate because
14378 !  vertical coordinate decreases with increasing k
14379             IF (fqz(i, k+1, j) .LT. 0.) THEN
14380               fqzd(i, k+1, j) = scaled*fqz(i, k+1, j) + scale*fqzd(i, k+&
14381 &                1, j)
14382               fqz(i, k+1, j) = scale*fqz(i, k+1, j)
14383             END IF
14384             IF (fqz(i, k, j) .GT. 0.) THEN
14385               fqzd(i, k, j) = scaled*fqz(i, k, j) + scale*fqzd(i, k, j)
14386               fqz(i, k, j) = scale*fqz(i, k, j)
14387             END IF
14388           END IF
14389         END DO
14390       END DO
14391     END DO
14392   END IF
14393 ! add in the pd-limited flux divergence
14394   i_start = its
14395   IF (ite .GT. ide - 1) THEN
14396     i_end = ide - 1
14397   ELSE
14398     i_end = ite
14399   END IF
14400   j_start = jts
14401   IF (jte .GT. jde - 1) THEN
14402     j_end = jde - 1
14403   ELSE
14404     j_end = jte
14405   END IF
14406   DO j=j_start,j_end
14407     DO k=kts,ktf
14408       DO i=i_start,i_end
14409         tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(fqzd(i, k+1, &
14410 &          j)-fqzd(i, k, j)+fqzld(i, k+1, j)-fqzld(i, k, j))
14411         tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(fqz(i, k+1, j)-&
14412 &          fqz(i, k, j)+fqzl(i, k+1, j)-fqzl(i, k, j))
14413       END DO
14414     END DO
14415   END DO
14416 ! x flux divergence
14417 !
14418   IF (degrade_xs) THEN
14419     IF (its .LT. ids + 1) THEN
14420       i_start = ids + 1
14421     ELSE
14422       i_start = its
14423     END IF
14424   END IF
14425   IF (degrade_xe) THEN
14426     IF (ite .GT. ide - 2) THEN
14427       i_end = ide - 2
14428     ELSE
14429       i_end = ite
14430     END IF
14431   END IF
14432   DO j=j_start,j_end
14433     DO k=kts,ktf
14434       DO i=i_start,i_end
14435 ! Un-"canceled" map scale factor, ADT Eq. 48
14436         tendencyd(i, k, j) = tendencyd(i, k, j) - msftx(i, j)*rdx*(fqxd(&
14437 &          i+1, k, j)-fqxd(i, k, j)+fqxld(i+1, k, j)-fqxld(i, k, j))
14438         tendency(i, k, j) = tendency(i, k, j) - msftx(i, j)*(rdx*(fqx(i+&
14439 &          1, k, j)-fqx(i, k, j)+fqxl(i+1, k, j)-fqxl(i, k, j)))
14440       END DO
14441     END DO
14442   END DO
14443 ! y flux divergence
14444 !
14445   i_start = its
14446   IF (ite .GT. ide - 1) THEN
14447     i_end = ide - 1
14448   ELSE
14449     i_end = ite
14450   END IF
14451   IF (degrade_ys) THEN
14452     IF (jts .LT. jds + 1) THEN
14453       j_start = jds + 1
14454     ELSE
14455       j_start = jts
14456     END IF
14457   END IF
14458   IF (degrade_ye) THEN
14459     IF (jte .GT. jde - 2) THEN
14460       j_end = jde - 2
14461     ELSE
14462       j_end = jte
14463     END IF
14464   END IF
14465   DO j=j_start,j_end
14466     DO k=kts,ktf
14467       DO i=i_start,i_end
14468 ! Un-"canceled" map scale factor, ADT Eq. 48
14469 ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
14470         tendencyd(i, k, j) = tendencyd(i, k, j) - msftx(i, j)*rdy*(fqyd(&
14471 &          i, k, j+1)-fqyd(i, k, j)+fqyld(i, k, j+1)-fqyld(i, k, j))
14472         tendency(i, k, j) = tendency(i, k, j) - msftx(i, j)*(rdy*(fqy(i&
14473 &          , k, j+1)-fqy(i, k, j)+fqyl(i, k, j+1)-fqyl(i, k, j)))
14474       END DO
14475     END DO
14476   END DO
14477 END SUBROUTINE G_ADVECT_SCALAR_WENOPD
14478
14479  SUBROUTINE g_advect_scalar_mono(field,g_field,field_old,g_field_old, &
14480  tendency,g_tendency,h_tendency,g_h_tendency,z_tendency,g_z_tendency,ru,g_ru,rv,g_rv,rom,g_rom,mut,g_mut,mub,mu_old, &
14481  g_mu_old,config_flags,tenddec,msfux,msfuy,msfvx,msfvy,msftx,msfty,fzm,fzp,rdx,rdy,rdzw,dt, &
14482  ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
14483
14484  IMPLICIT NONE
14485
14486  REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
14487  g_Tmpv5,Tmpv6,g_Tmpv6,Tmpv7,g_Tmpv7,Tmpv8,g_Tmpv8
14488
14489  REAL g_FuncVal1,FuncVal1
14490  TYPE(grid_config_rec_type) :: config_flags
14491  LOGICAL :: tenddec
14492  INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
14493  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field,field_old,g_field_old, &
14494  ru,g_ru,rv,g_rv,rom,g_rom
14495  REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut,mub,mu_old,g_mu_old
14496  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
14497  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: h_tendency, z_tendency
14498  REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: g_h_tendency, g_z_tendency
14499  REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty
14500  REAL,DIMENSION(kms:kme) :: fzm,fzp,rdzw
14501  REAL :: rdx,rdy,dt
14502
14503  INTEGER :: i,j,k,itf,jtf,ktf
14504  INTEGER :: i_start,i_end,j_start,j_end
14505  INTEGER :: i_start_f,i_end_f,j_start_f,j_end_f
14506  INTEGER :: jmin,jmax,jp,jm,imin,imax
14507  REAL :: mrdx,g_mrdx,mrdy,g_mrdy,ub,g_ub,vb,g_vb,uw,g_uw,vw,g_vw,mu,g_mu
14508  REAL,DIMENSION(its:ite,kts:kte) :: vflux,g_vflux
14509  REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: fqx,g_fqx,fqy,g_fqy,fqz,g_fqz
14510  REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: fqxl,g_fqxl,fqyl,g_fqyl, &
14511  fqzl,g_fqzl
14512  REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: qmin,g_qmin,qmax,g_qmax
14513  REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: scale_in,g_scale_in,scale_out, &
14514  g_scale_out
14515  REAL :: ph_upwind,g_ph_upwind
14516  INTEGER :: horz_order,vert_order
14517  LOGICAL :: degrade_xs,degrade_ys
14518  LOGICAL :: degrade_xe,degrade_ye
14519  INTEGER :: jp1,jp0,jtmp
14520  REAL :: flux_out,g_flux_out,ph_low,g_ph_low,flux_in,g_flux_in,ph_hi, &
14521  g_ph_hi,scale,g_scale
14522  REAL,PARAMETER :: eps =1.e-20
14523  REAL :: flux3,g_flux3,flux4,g_flux4,flux5,g_flux5,flux6,g_flux6, &
14524  flux_upwind,g_flux_upwind
14525  REAL :: q_im3,g_q_im3,q_im2,g_q_im2,q_im1,g_q_im1,q_i,g_q_i,q_ip1, &
14526  g_q_ip1,q_ip2,g_q_ip2,ua,g_ua,vel,g_vel,cr,g_cr
14527
14528 ! Revised by Ning Pan, 2010-07-25
14529 ! g_flux4(g_q_im2, q_im2,g_q_im1, q_im1,g_q_i, q_i,g_q_ip1, q_ip1, &
14530 ! g_ua, ua) =(7./12.)*(g_q_i +g_q_im1) -(1./12.)*(g_q_ip1 +g_q_im2)
14531  g_flux4(q_im2, g_q_im2,q_im1, g_q_im1,q_i, g_q_i,q_ip1, g_q_ip1, &
14532  ua, g_ua) =(7./12.)*(g_q_i +g_q_im1) -(1./12.)*(g_q_ip1 +g_q_im2)
14533  flux4(q_im2,q_im1,q_i,q_ip1,ua) =(7./12.)*(q_i +q_im1) -(1./12.)*(q_ip1 +q_im2)
14534
14535 ! Revised by Ning Pan, 2010-07-25
14536 ! g_flux3(g_q_im2, q_im2,g_q_im1, q_im1,g_q_i, q_i,g_q_ip1, q_ip1, &
14537 ! g_ua, ua) =g_flux4(q_im2,g_q_im2,q_im1,g_q_im1,q_i,g_q_i,q_ip1, &
14538  g_flux3(q_im2, g_q_im2,q_im1, g_q_im1,q_i, g_q_i,q_ip1, g_q_ip1, &
14539  ua, g_ua) =g_flux4(q_im2,g_q_im2,q_im1,g_q_im1,q_i,g_q_i,q_ip1, &
14540  g_q_ip1,ua,g_ua) +sign(1., ua) *(1./12.)*((g_q_ip1 -g_q_im2) &
14541  -3.*(g_q_i -g_q_im1))
14542  flux3(q_im2,q_im1,q_i,q_ip1,ua) =flux4(q_im2,q_im1,q_i,q_ip1,ua) +sign(1., ua) &
14543  *(1./12.)*((q_ip1 -q_im2) -3.*(q_i -q_im1))
14544
14545 ! Revised by Ning Pan, 2010-07-25
14546 ! g_flux6(g_q_im3, q_im3,g_q_im2, q_im2,g_q_im1, q_im1,g_q_i, q_i, &
14547 ! g_q_ip1, q_ip1,g_q_ip2, q_ip2,g_ua, ua) =(37./60.)*(g_q_i +g_q_im1) &
14548  g_flux6(q_im3, g_q_im3,q_im2, g_q_im2,q_im1, g_q_im1,q_i, g_q_i, &
14549  q_ip1, g_q_ip1,q_ip2, g_q_ip2,ua, g_ua) =(37./60.)*(g_q_i +g_q_im1) &
14550  -(2./15.)*(g_q_ip1 +g_q_im2) +(1./60.)*(g_q_ip2 +g_q_im3)
14551  flux6(q_im3,q_im2,q_im1,q_i,q_ip1,q_ip2,ua) =(37./60.)*(q_i +q_im1) -(2./15.) &
14552 *(q_ip1 +q_im2) +(1./60.)*(q_ip2 +q_im3)
14553
14554 ! Revised by Ning Pan, 2010-07-25
14555 ! g_flux5(g_q_im3, q_im3,g_q_im2, q_im2,g_q_im1, q_im1,g_q_i, q_i, &
14556 ! g_q_ip1, q_ip1,g_q_ip2, q_ip2,g_ua, ua) =g_flux6(q_im3,g_q_im3,q_im2, &
14557  g_flux5(q_im3, g_q_im3,q_im2, g_q_im2,q_im1, g_q_im1,q_i, g_q_i, &
14558  q_ip1, g_q_ip1,q_ip2, g_q_ip2,ua, g_ua) =g_flux6(q_im3,g_q_im3,q_im2, &
14559  g_q_im2,q_im1,g_q_im1,q_i,g_q_i,q_ip1,g_q_ip1,q_ip2,g_q_ip2,ua, &
14560  g_ua) -sign(1., ua) *(1./60.)*((g_q_ip2 -g_q_im3) -5.*(g_q_ip1 - &
14561  g_q_im2) +10.*(g_q_i -g_q_im1))
14562  flux5(q_im3,q_im2,q_im1,q_i,q_ip1,q_ip2,ua) =flux6(q_im3,q_im2,q_im1,q_i,q_ip1,q_ip2, &
14563  ua) -sign(1., ua) *(1./60.)*((q_ip2 -q_im3) -5.*(q_ip1 -q_im2) +10.*(q_i -q_im1))
14564
14565 ! Revised by Ning Pan, 2010-07-25
14566 ! g_flux_upwind(g_q_im1, q_im1,g_q_i, q_i,g_cr, cr) =0.5 *(1.+sign(1., cr)) &
14567  g_flux_upwind(q_im1, g_q_im1,q_i, g_q_i,cr, g_cr) =0.5 *(1.+sign(1., cr)) &
14568 *g_q_im1 +0.5 *(1.-sign(1., cr))*g_q_i
14569  flux_upwind(q_im1,q_i,cr) =0.5 *(1.+sign(1., cr))*q_im1 +0.5 *(1.-sign(1., cr))*q_i
14570
14571  LOGICAL,PARAMETER :: mono_limit =.true.
14572
14573  ktf =min(kte,kde-1)
14574
14575  horz_order =config_flags%h_sca_adv_order
14576
14577  vert_order =config_flags%v_sca_adv_order
14578
14579 ! Added by Ning Pan, 2010-07-27
14580  degrade_xs =.true.
14581  degrade_xe =.true.
14582  degrade_ys =.true.
14583  degrade_ye =.true.
14584  IF( config_flags%periodic_x   .or.   &
14585        config_flags%symmetric_xs .or.   &
14586        (its > ids+3)                ) degrade_xs =.false.
14587  IF( config_flags%periodic_x   .or.   &
14588        config_flags%symmetric_xe .or.   &
14589        (ite < ide-4)                ) degrade_xe =.false.
14590  IF( config_flags%periodic_y   .or.   &
14591        config_flags%symmetric_ys .or.   &
14592        (jts > jds+3)                ) degrade_ys =.false.
14593  IF( config_flags%periodic_y   .or.   &
14594        config_flags%symmetric_ye .or.   &
14595        (jte < jde-4)                ) degrade_ye =.false.
14596
14597  DO j =jts-2,jte+2
14598  DO k =kts,kte
14599  DO i =its-2,ite+2
14600
14601  g_qmin(i,k,j) =g_field_old(i,k,j)
14602  qmin(i,k,j) =field_old(i,k,j)
14603
14604  g_qmax(i,k,j) =g_field_old(i,k,j)
14605  qmax(i,k,j) =field_old(i,k,j)
14606
14607  g_scale_in(i,k,j) =0.0
14608  scale_in(i,k,j) =1.
14609
14610  g_scale_out(i,k,j) =0.0
14611  scale_out(i,k,j) =1.
14612
14613  g_fqx(i,k,j) =0.0
14614  fqx(i,k,j) =0.
14615
14616  g_fqy(i,k,j) =0.0
14617  fqy(i,k,j) =0.
14618
14619  g_fqz(i,k,j) =0.0
14620  fqz(i,k,j) =0.
14621
14622  g_fqxl(i,k,j) =0.0
14623  fqxl(i,k,j) =0.
14624
14625  g_fqyl(i,k,j) =0.0
14626  fqyl(i,k,j) =0.
14627
14628  g_fqzl(i,k,j) =0.0
14629  fqzl(i,k,j) =0.
14630
14631  ENDDO
14632  ENDDO
14633  ENDDO
14634
14635  IF( horz_order == 5 ) THEN
14636
14637 ! degrade_xs =.true.
14638
14639 ! degrade_xe =.true.
14640
14641 ! degrade_ys =.true.
14642
14643 ! degrade_ye =.true.
14644
14645 ! IF( config_flags%periodic_x   .or.   &
14646 !       config_flags%symmetric_xs .or.   &
14647 !       (its > ids+3)                ) degrade_xs =.false.
14648
14649 ! IF( config_flags%periodic_x   .or.   &
14650 !       config_flags%symmetric_xe .or.   &
14651 !       (ite < ide-4)                ) degrade_xe =.false.
14652
14653 ! IF( config_flags%periodic_y   .or.   &
14654 !       config_flags%symmetric_ys .or.   &
14655 !       (jts > jds+3)                ) degrade_ys =.false.
14656
14657 ! IF( config_flags%periodic_y   .or.   &
14658 !       config_flags%symmetric_ye .or.   &
14659 !       (jte < jde-4)                ) degrade_ye =.false.
14660
14661  ktf =min(kte,kde-1)
14662
14663  i_start =its-1
14664
14665  i_end =min(ite,ide-1) +1
14666
14667  j_start =jts-1
14668
14669  j_end =min(jte,jde-1) +1
14670
14671  j_start_f =j_start
14672
14673  j_end_f =j_end+1
14674
14675  IF(degrade_xs) i_start =max(its-1,ids)
14676
14677  IF(degrade_xe) i_end =min(ite+1,ide-1)
14678
14679  IF(degrade_ys) THEN
14680
14681  j_start =max(jts-1,jds+1)
14682
14683  j_start_f =jds+3
14684  ENDIF
14685
14686  IF(degrade_ye) THEN
14687
14688  j_end =min(jte+1,jde-2)
14689
14690  j_end_f =jde-3
14691  ENDIF
14692
14693  DO j =j_start,j_end+1
14694
14695  IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
14696
14697  DO k =kts,ktf
14698  DO i =i_start,i_end
14699
14700  g_vel =g_rv(i,k,j)
14701  vel =rv(i,k,j)
14702
14703  g_cr =g_vel
14704  cr =vel
14705
14706  g_FuncVal1=g_flux_upwind(field_old(i,k,j-1),g_field_old(i,k,j-1) &
14707 ,field_old(i,k,j),g_field_old(i,k,j),vel,g_vel)
14708  FuncVal1 =flux_upwind(field_old(i,k,j-1),field_old(i,k,j),vel)
14709
14710  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
14711  Tmpv1 =vel*FuncVal1
14712
14713  g_fqyl(i,k,j) =g_Tmpv1
14714  fqyl(i,k,j) =Tmpv1
14715
14716  g_FuncVal1=g_flux5(field(i,k,j-3),g_field(i,k,j-3),field(i,k,j-2) &
14717 ,g_field(i,k,j-2),field(i,k,j-1),g_field(i,k,j-1),field(i,k,j),g_field(i,k, &
14718  j),field(i,k,j+1),g_field(i,k,j+1),field(i,k,j+2),g_field(i,k,j+2),vel,g_vel)
14719  FuncVal1 =flux5(field(i,k,j-3),field(i,k,j-2),field(i,k,j-1),field(i,k,j) &
14720 ,field(i,k,j+1),field(i,k,j+2),vel)
14721
14722  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
14723  Tmpv1 =vel*FuncVal1
14724
14725  g_fqy(i,k,j) =g_Tmpv1
14726  fqy(i,k,j) =Tmpv1
14727
14728  g_fqy(i,k,j) =g_fqy(i,k,j) -g_fqyl(i,k,j)
14729  fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
14730
14731  IF(cr.gt. 0) THEN
14732
14733  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k,j-1) +(g_qmax(i,k,j) &
14734  -g_field_old(i,k,j-1))*sign(1.0, qmax(i,k,j) -(field_old(i,k,j-1))))*0.5
14735  qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k,j-1))
14736
14737  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k,j-1) -(g_qmin(i,k,j) &
14738  -g_field_old(i,k,j-1))*sign(1.0, qmin(i,k,j) -(field_old(i,k,j-1))))*0.5
14739  qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k,j-1))
14740
14741  else
14742
14743  g_qmax(i,k,j-1) =(g_qmax(i,k,j-1) +g_field_old(i,k,j) +(g_qmax(i,k,j-1) &
14744  -g_field_old(i,k,j))*sign(1.0, qmax(i,k,j-1) -(field_old(i,k,j))))*0.5
14745  qmax(i,k,j-1) =max(qmax(i,k,j-1),field_old(i,k,j))
14746
14747  g_qmin(i,k,j-1) =(g_qmin(i,k,j-1) +g_field_old(i,k,j) -(g_qmin(i,k,j-1) &
14748  -g_field_old(i,k,j))*sign(1.0, qmin(i,k,j-1) -(field_old(i,k,j))))*0.5
14749  qmin(i,k,j-1) =min(qmin(i,k,j-1),field_old(i,k,j))
14750
14751  end IF
14752  ENDDO
14753  ENDDO
14754
14755  ELSE IF( j == jds+1 ) THEN
14756
14757  DO k =kts,ktf
14758  DO i =i_start,i_end
14759
14760  g_vel =g_rv(i,k,j)
14761  vel =rv(i,k,j)
14762
14763  g_cr =g_vel
14764  cr =vel
14765
14766  g_FuncVal1=g_flux_upwind(field_old(i,k,j-1),g_field_old(i,k,j-1) &
14767 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
14768  FuncVal1 =flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
14769
14770  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
14771  Tmpv1 =vel*FuncVal1
14772
14773  g_fqyl(i,k,j) =g_Tmpv1
14774  fqyl(i,k,j) =Tmpv1
14775
14776  g_Tmpv1 =0.5*rv(i,k,j)*(g_field(i,k,j) +g_field(i,k,j-1)) +0.5*g_rv(i,k, &
14777  j)*(field(i,k,j) +field(i,k,j-1))
14778  Tmpv1 =0.5*rv(i,k,j)*(field(i,k,j) +field(i,k,j-1))
14779
14780  g_fqy(i,k,j) =g_Tmpv1
14781  fqy(i,k,j) =Tmpv1
14782
14783  g_fqy(i,k,j) =g_fqy(i,k,j) -g_fqyl(i,k,j)
14784  fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
14785
14786  IF(cr.gt. 0) THEN
14787
14788  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k,j-1) +(g_qmax(i,k,j) &
14789  -g_field_old(i,k,j-1))*sign(1.0, qmax(i,k,j) -(field_old(i,k,j-1))))*0.5
14790  qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k,j-1))
14791
14792  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k,j-1) -(g_qmin(i,k,j) &
14793  -g_field_old(i,k,j-1))*sign(1.0, qmin(i,k,j) -(field_old(i,k,j-1))))*0.5
14794  qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k,j-1))
14795
14796  else
14797
14798  g_qmax(i,k,j-1) =(g_qmax(i,k,j-1) +g_field_old(i,k,j) +(g_qmax(i,k,j-1) &
14799  -g_field_old(i,k,j))*sign(1.0, qmax(i,k,j-1) -(field_old(i,k,j))))*0.5
14800  qmax(i,k,j-1) =max(qmax(i,k,j-1),field_old(i,k,j))
14801
14802  g_qmin(i,k,j-1) =(g_qmin(i,k,j-1) +g_field_old(i,k,j) -(g_qmin(i,k,j-1) &
14803  -g_field_old(i,k,j))*sign(1.0, qmin(i,k,j-1) -(field_old(i,k,j))))*0.5
14804  qmin(i,k,j-1) =min(qmin(i,k,j-1),field_old(i,k,j))
14805
14806  end IF
14807  ENDDO
14808  ENDDO
14809
14810  ELSE IF( j == jds+2 ) THEN
14811
14812  DO k =kts,ktf
14813  DO i =i_start,i_end
14814
14815  g_vel =g_rv(i,k,j)
14816  vel =rv(i,k,j)
14817
14818  g_cr =g_vel
14819  cr =vel
14820
14821  g_FuncVal1=g_flux_upwind(field_old(i,k,j-1),g_field_old(i,k,j-1) &
14822 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
14823  FuncVal1 =flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
14824
14825  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
14826  Tmpv1 =vel*FuncVal1
14827
14828  g_fqyl(i,k,j) =g_Tmpv1
14829  fqyl(i,k,j) =Tmpv1
14830
14831  g_FuncVal1=g_flux3(field(i,k,j-2),g_field(i,k,j-2),field(i,k,j-1) &
14832 ,g_field(i,k,j-1),field(i,k,j),g_field(i,k,j),field(i,k,j+1),g_field(i,k,j+ &
14833  1),vel,g_vel)
14834  FuncVal1 =flux3(field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel)
14835
14836  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
14837  Tmpv1 =vel*FuncVal1
14838
14839  g_fqy(i,k,j) =g_Tmpv1
14840  fqy(i,k,j) =Tmpv1
14841
14842  g_fqy(i,k,j) =g_fqy(i,k,j) -g_fqyl(i,k,j)
14843  fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
14844
14845  IF(cr.gt. 0) THEN
14846
14847  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k,j-1) +(g_qmax(i,k,j) &
14848  -g_field_old(i,k,j-1))*sign(1.0, qmax(i,k,j) -(field_old(i,k,j-1))))*0.5
14849  qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k,j-1))
14850
14851  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k,j-1) -(g_qmin(i,k,j) &
14852  -g_field_old(i,k,j-1))*sign(1.0, qmin(i,k,j) -(field_old(i,k,j-1))))*0.5
14853  qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k,j-1))
14854
14855  else
14856
14857  g_qmax(i,k,j-1) =(g_qmax(i,k,j-1) +g_field_old(i,k,j) +(g_qmax(i,k,j-1) &
14858  -g_field_old(i,k,j))*sign(1.0, qmax(i,k,j-1) -(field_old(i,k,j))))*0.5
14859  qmax(i,k,j-1) =max(qmax(i,k,j-1),field_old(i,k,j))
14860
14861  g_qmin(i,k,j-1) =(g_qmin(i,k,j-1) +g_field_old(i,k,j) -(g_qmin(i,k,j-1) &
14862  -g_field_old(i,k,j))*sign(1.0, qmin(i,k,j-1) -(field_old(i,k,j))))*0.5
14863  qmin(i,k,j-1) =min(qmin(i,k,j-1),field_old(i,k,j))
14864
14865  end IF
14866  ENDDO
14867  ENDDO
14868
14869  ELSE IF( j == jde-1 ) THEN
14870
14871  DO k =kts,ktf
14872  DO i =i_start,i_end
14873
14874  g_vel =g_rv(i,k,j)
14875  vel =rv(i,k,j)
14876
14877  g_cr =g_vel
14878  cr =vel
14879
14880  g_FuncVal1=g_flux_upwind(field_old(i,k,j-1),g_field_old(i,k,j-1) &
14881 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
14882  FuncVal1 =flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
14883
14884  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
14885  Tmpv1 =vel*FuncVal1
14886
14887  g_fqyl(i,k,j) =g_Tmpv1
14888  fqyl(i,k,j) =Tmpv1
14889
14890  g_Tmpv1 =0.5*rv(i,k,j)*(g_field(i,k,j) +g_field(i,k,j-1)) +0.5*g_rv(i,k, &
14891  j)*(field(i,k,j) +field(i,k,j-1))
14892  Tmpv1 =0.5*rv(i,k,j)*(field(i,k,j) +field(i,k,j-1))
14893
14894  g_fqy(i,k,j) =g_Tmpv1
14895  fqy(i,k,j) =Tmpv1
14896
14897  g_fqy(i,k,j) =g_fqy(i,k,j) -g_fqyl(i,k,j)
14898  fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
14899
14900  IF(cr.gt. 0) THEN
14901
14902  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k,j-1) +(g_qmax(i,k,j) &
14903  -g_field_old(i,k,j-1))*sign(1.0, qmax(i,k,j) -(field_old(i,k,j-1))))*0.5
14904  qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k,j-1))
14905
14906  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k,j-1) -(g_qmin(i,k,j) &
14907  -g_field_old(i,k,j-1))*sign(1.0, qmin(i,k,j) -(field_old(i,k,j-1))))*0.5
14908  qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k,j-1))
14909
14910  else
14911
14912  g_qmax(i,k,j-1) =(g_qmax(i,k,j-1) +g_field_old(i,k,j) +(g_qmax(i,k,j-1) &
14913  -g_field_old(i,k,j))*sign(1.0, qmax(i,k,j-1) -(field_old(i,k,j))))*0.5
14914  qmax(i,k,j-1) =max(qmax(i,k,j-1),field_old(i,k,j))
14915
14916  g_qmin(i,k,j-1) =(g_qmin(i,k,j-1) +g_field_old(i,k,j) -(g_qmin(i,k,j-1) &
14917  -g_field_old(i,k,j))*sign(1.0, qmin(i,k,j-1) -(field_old(i,k,j))))*0.5
14918  qmin(i,k,j-1) =min(qmin(i,k,j-1),field_old(i,k,j))
14919
14920  end IF
14921  ENDDO
14922  ENDDO
14923
14924  ELSE IF( j == jde-2 ) THEN
14925
14926  DO k =kts,ktf
14927  DO i =i_start,i_end
14928
14929  g_vel =g_rv(i,k,j)
14930  vel =rv(i,k,j)
14931
14932  g_cr =g_vel
14933  cr =vel
14934
14935  g_FuncVal1=g_flux_upwind(field_old(i,k,j-1),g_field_old(i,k,j-1) &
14936 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
14937  FuncVal1 =flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
14938
14939  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
14940  Tmpv1 =vel*FuncVal1
14941
14942  g_fqyl(i,k,j) =g_Tmpv1
14943  fqyl(i,k,j) =Tmpv1
14944
14945  g_FuncVal1=g_flux3(field(i,k,j-2),g_field(i,k,j-2),field(i,k,j-1) &
14946 ,g_field(i,k,j-1),field(i,k,j),g_field(i,k,j),field(i,k,j+1),g_field(i,k,j+ &
14947  1),vel,g_vel)
14948  FuncVal1 =flux3(field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel)
14949
14950  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
14951  Tmpv1 =vel*FuncVal1
14952
14953  g_fqy(i,k,j) =g_Tmpv1
14954  fqy(i,k,j) =Tmpv1
14955
14956  g_fqy(i,k,j) =g_fqy(i,k,j) -g_fqyl(i,k,j)
14957  fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
14958
14959  IF(cr.gt. 0) THEN
14960
14961  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k,j-1) +(g_qmax(i,k,j) &
14962  -g_field_old(i,k,j-1))*sign(1.0, qmax(i,k,j) -(field_old(i,k,j-1))))*0.5
14963  qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k,j-1))
14964
14965  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k,j-1) -(g_qmin(i,k,j) &
14966  -g_field_old(i,k,j-1))*sign(1.0, qmin(i,k,j) -(field_old(i,k,j-1))))*0.5
14967  qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k,j-1))
14968
14969  else
14970
14971  g_qmax(i,k,j-1) =(g_qmax(i,k,j-1) +g_field_old(i,k,j) +(g_qmax(i,k,j-1) &
14972  -g_field_old(i,k,j))*sign(1.0, qmax(i,k,j-1) -(field_old(i,k,j))))*0.5
14973  qmax(i,k,j-1) =max(qmax(i,k,j-1),field_old(i,k,j))
14974
14975  g_qmin(i,k,j-1) =(g_qmin(i,k,j-1) +g_field_old(i,k,j) -(g_qmin(i,k,j-1) &
14976  -g_field_old(i,k,j))*sign(1.0, qmin(i,k,j-1) -(field_old(i,k,j))))*0.5
14977  qmin(i,k,j-1) =min(qmin(i,k,j-1),field_old(i,k,j))
14978
14979  end IF
14980  ENDDO
14981  ENDDO
14982  ENDIF
14983  ENDDO
14984
14985  i_start =its-1
14986
14987  i_end =min(ite,ide-1) +1
14988
14989  i_start_f =i_start
14990
14991  i_end_f =i_end+1
14992
14993  j_start =jts-1
14994
14995  j_end =min(jte,jde-1) +1
14996
14997  IF(degrade_ys) j_start =max(jts-1,jds)
14998
14999  IF(degrade_ye) j_end =min(jte+1,jde-1)
15000
15001  IF(degrade_xs) THEN
15002
15003  i_start =max(ids+1,its-1)
15004
15005  i_start_f =ids+3
15006  ENDIF
15007
15008  IF(degrade_xe) THEN
15009
15010  i_end =min(ide-2,ite+1)
15011
15012  i_end_f =ide-3
15013  ENDIF
15014
15015  DO j =j_start,j_end
15016  DO k =kts,ktf
15017  DO i =i_start_f,i_end_f
15018
15019  g_vel =g_ru(i,k,j)
15020  vel =ru(i,k,j)
15021
15022  g_cr =g_vel
15023  cr =vel
15024
15025  g_FuncVal1=g_flux_upwind(field_old(i-1,k,j),g_field_old(i-1,k,j) &
15026 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
15027  FuncVal1 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
15028
15029  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15030  Tmpv1 =vel*FuncVal1
15031
15032  g_fqxl(i,k,j) =g_Tmpv1
15033  fqxl(i,k,j) =Tmpv1
15034
15035  g_FuncVal1=g_flux5(field(i-3,k,j),g_field(i-3,k,j),field(i-2,k,j) &
15036 ,g_field(i-2,k,j),field(i-1,k,j),g_field(i-1,k,j),field(i,k,j),g_field(i,k, &
15037  j),field(i+1,k,j),g_field(i+1,k,j),field(i+2,k,j),g_field(i+2,k,j),vel,g_vel)
15038  FuncVal1 =flux5(field(i-3,k,j),field(i-2,k,j),field(i-1,k,j),field(i,k,j) &
15039 ,field(i+1,k,j),field(i+2,k,j),vel)
15040
15041  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15042  Tmpv1 =vel*FuncVal1
15043
15044  g_fqx(i,k,j) =g_Tmpv1
15045  fqx(i,k,j) =Tmpv1
15046
15047  g_fqx(i,k,j) =g_fqx(i,k,j) -g_fqxl(i,k,j)
15048  fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
15049
15050  IF(cr.gt. 0) THEN
15051
15052  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i-1,k,j) +(g_qmax(i,k,j) &
15053  -g_field_old(i-1,k,j))*sign(1.0, qmax(i,k,j) -(field_old(i-1,k,j))))*0.5
15054  qmax(i,k,j) =max(qmax(i,k,j),field_old(i-1,k,j))
15055
15056  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i-1,k,j) -(g_qmin(i,k,j) &
15057  -g_field_old(i-1,k,j))*sign(1.0, qmin(i,k,j) -(field_old(i-1,k,j))))*0.5
15058  qmin(i,k,j) =min(qmin(i,k,j),field_old(i-1,k,j))
15059
15060  else
15061
15062  g_qmax(i-1,k,j) =(g_qmax(i-1,k,j) +g_field_old(i,k,j) +(g_qmax(i-1,k,j) &
15063  -g_field_old(i,k,j))*sign(1.0, qmax(i-1,k,j) -(field_old(i,k,j))))*0.5
15064  qmax(i-1,k,j) =max(qmax(i-1,k,j),field_old(i,k,j))
15065
15066  g_qmin(i-1,k,j) =(g_qmin(i-1,k,j) +g_field_old(i,k,j) -(g_qmin(i-1,k,j) &
15067  -g_field_old(i,k,j))*sign(1.0, qmin(i-1,k,j) -(field_old(i,k,j))))*0.5
15068  qmin(i-1,k,j) =min(qmin(i-1,k,j),field_old(i,k,j))
15069
15070  end IF
15071  ENDDO
15072  ENDDO
15073
15074  IF( degrade_xs ) THEN
15075
15076  DO i =i_start,i_start_f-1
15077
15078  IF(i == ids+1) THEN
15079
15080  DO k =kts,ktf
15081
15082  g_vel =g_ru(i,k,j)
15083  vel =ru(i,k,j)
15084
15085  g_cr =g_vel
15086  cr =vel
15087
15088  g_FuncVal1=g_flux_upwind(field_old(i-1,k,j),g_field_old(i-1,k,j) &
15089 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
15090  FuncVal1 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
15091
15092  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15093  Tmpv1 =vel*FuncVal1
15094
15095  g_fqxl(i,k,j) =g_Tmpv1
15096  fqxl(i,k,j) =Tmpv1
15097
15098  g_Tmpv1 =0.5*(ru(i,k,j))*(g_field(i,k,j) +g_field(i-1,k,j)) +0.5*(g_ru( &
15099  i,k,j))*(field(i,k,j) +field(i-1,k,j))
15100  Tmpv1 =0.5*(ru(i,k,j))*(field(i,k,j) +field(i-1,k,j))
15101
15102  g_fqx(i,k,j) =g_Tmpv1
15103  fqx(i,k,j) =Tmpv1
15104
15105  g_fqx(i,k,j) =g_fqx(i,k,j) -g_fqxl(i,k,j)
15106  fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
15107
15108  IF(cr.gt. 0) THEN
15109
15110  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i-1,k,j) +(g_qmax(i,k,j) &
15111  -g_field_old(i-1,k,j))*sign(1.0, qmax(i,k,j) -(field_old(i-1,k,j))))*0.5
15112  qmax(i,k,j) =max(qmax(i,k,j),field_old(i-1,k,j))
15113
15114  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i-1,k,j) -(g_qmin(i,k,j) &
15115  -g_field_old(i-1,k,j))*sign(1.0, qmin(i,k,j) -(field_old(i-1,k,j))))*0.5
15116  qmin(i,k,j) =min(qmin(i,k,j),field_old(i-1,k,j))
15117
15118  else
15119
15120  g_qmax(i-1,k,j) =(g_qmax(i-1,k,j) +g_field_old(i,k,j) +(g_qmax(i-1,k,j) &
15121  -g_field_old(i,k,j))*sign(1.0, qmax(i-1,k,j) -(field_old(i,k,j))))*0.5
15122  qmax(i-1,k,j) =max(qmax(i-1,k,j),field_old(i,k,j))
15123
15124  g_qmin(i-1,k,j) =(g_qmin(i-1,k,j) +g_field_old(i,k,j) -(g_qmin(i-1,k,j) &
15125  -g_field_old(i,k,j))*sign(1.0, qmin(i-1,k,j) -(field_old(i,k,j))))*0.5
15126  qmin(i-1,k,j) =min(qmin(i-1,k,j),field_old(i,k,j))
15127
15128  end IF
15129  ENDDO
15130  ENDIF
15131
15132  IF(i == ids+2) THEN
15133
15134  DO k =kts,ktf
15135
15136  g_vel =g_ru(i,k,j)
15137  vel =ru(i,k,j)
15138
15139  g_cr =g_vel
15140  cr =vel
15141
15142  g_FuncVal1=g_flux_upwind(field_old(i-1,k,j),g_field_old(i-1,k,j) &
15143 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
15144  FuncVal1 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
15145
15146  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15147  Tmpv1 =vel*FuncVal1
15148
15149  g_fqxl(i,k,j) =g_Tmpv1
15150  fqxl(i,k,j) =Tmpv1
15151
15152  g_FuncVal1=g_flux3(field(i-2,k,j),g_field(i-2,k,j),field(i-1,k,j) &
15153 ,g_field(i-1,k,j),field(i,k,j),g_field(i,k,j),field(i+1,k,j),g_field(i+1,k, &
15154  j),vel,g_vel)
15155  FuncVal1 =flux3(field(i-2,k,j),field(i-1,k,j),field(i,k,j),field(i+1,k,j),vel)
15156
15157  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15158  Tmpv1 =vel*FuncVal1
15159
15160  g_fqx(i,k,j) =g_Tmpv1
15161  fqx(i,k,j) =Tmpv1
15162
15163  g_fqx(i,k,j) =g_fqx(i,k,j) -g_fqxl(i,k,j)
15164  fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
15165
15166  IF(cr.gt. 0) THEN
15167
15168  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i-1,k,j) +(g_qmax(i,k,j) &
15169  -g_field_old(i-1,k,j))*sign(1.0, qmax(i,k,j) -(field_old(i-1,k,j))))*0.5
15170  qmax(i,k,j) =max(qmax(i,k,j),field_old(i-1,k,j))
15171
15172  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i-1,k,j) -(g_qmin(i,k,j) &
15173  -g_field_old(i-1,k,j))*sign(1.0, qmin(i,k,j) -(field_old(i-1,k,j))))*0.5
15174  qmin(i,k,j) =min(qmin(i,k,j),field_old(i-1,k,j))
15175
15176  else
15177
15178  g_qmax(i-1,k,j) =(g_qmax(i-1,k,j) +g_field_old(i,k,j) +(g_qmax(i-1,k,j) &
15179  -g_field_old(i,k,j))*sign(1.0, qmax(i-1,k,j) -(field_old(i,k,j))))*0.5
15180  qmax(i-1,k,j) =max(qmax(i-1,k,j),field_old(i,k,j))
15181
15182  g_qmin(i-1,k,j) =(g_qmin(i-1,k,j) +g_field_old(i,k,j) -(g_qmin(i-1,k,j) &
15183  -g_field_old(i,k,j))*sign(1.0, qmin(i-1,k,j) -(field_old(i,k,j))))*0.5
15184  qmin(i-1,k,j) =min(qmin(i-1,k,j),field_old(i,k,j))
15185
15186  end IF
15187  ENDDO
15188  ENDIF
15189  ENDDO
15190  ENDIF
15191
15192  IF( degrade_xe ) THEN
15193
15194  DO i =i_end_f+1,i_end+1
15195
15196  IF( i == ide-1 ) THEN
15197
15198  DO k =kts,ktf
15199
15200  g_vel =g_ru(i,k,j)
15201  vel =ru(i,k,j)
15202
15203  g_cr =g_vel
15204  cr =vel
15205
15206  g_FuncVal1=g_flux_upwind(field_old(i-1,k,j),g_field_old(i-1,k,j) &
15207 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
15208  FuncVal1 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
15209
15210  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15211  Tmpv1 =vel*FuncVal1
15212
15213  g_fqxl(i,k,j) =g_Tmpv1
15214  fqxl(i,k,j) =Tmpv1
15215
15216  g_Tmpv1 =0.5*(ru(i,k,j))*(g_field(i,k,j) +g_field(i-1,k,j)) +0.5*(g_ru( &
15217  i,k,j))*(field(i,k,j) +field(i-1,k,j))
15218  Tmpv1 =0.5*(ru(i,k,j))*(field(i,k,j) +field(i-1,k,j))
15219
15220  g_fqx(i,k,j) =g_Tmpv1
15221  fqx(i,k,j) =Tmpv1
15222
15223  g_fqx(i,k,j) =g_fqx(i,k,j) -g_fqxl(i,k,j)
15224  fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
15225
15226  IF(cr.gt. 0) THEN
15227
15228  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i-1,k,j) +(g_qmax(i,k,j) &
15229  -g_field_old(i-1,k,j))*sign(1.0, qmax(i,k,j) -(field_old(i-1,k,j))))*0.5
15230  qmax(i,k,j) =max(qmax(i,k,j),field_old(i-1,k,j))
15231
15232  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i-1,k,j) -(g_qmin(i,k,j) &
15233  -g_field_old(i-1,k,j))*sign(1.0, qmin(i,k,j) -(field_old(i-1,k,j))))*0.5
15234  qmin(i,k,j) =min(qmin(i,k,j),field_old(i-1,k,j))
15235
15236  else
15237
15238  g_qmax(i-1,k,j) =(g_qmax(i-1,k,j) +g_field_old(i,k,j) +(g_qmax(i-1,k,j) &
15239  -g_field_old(i,k,j))*sign(1.0, qmax(i-1,k,j) -(field_old(i,k,j))))*0.5
15240  qmax(i-1,k,j) =max(qmax(i-1,k,j),field_old(i,k,j))
15241
15242  g_qmin(i-1,k,j) =(g_qmin(i-1,k,j) +g_field_old(i,k,j) -(g_qmin(i-1,k,j) &
15243  -g_field_old(i,k,j))*sign(1.0, qmin(i-1,k,j) -(field_old(i,k,j))))*0.5
15244  qmin(i-1,k,j) =min(qmin(i-1,k,j),field_old(i,k,j))
15245
15246  end IF
15247  ENDDO
15248  ENDIF
15249
15250  IF( i == ide-2 ) THEN
15251
15252  DO k =kts,ktf
15253
15254  g_vel =g_ru(i,k,j)
15255  vel =ru(i,k,j)
15256
15257  g_cr =g_vel
15258  cr =vel
15259
15260  g_FuncVal1=g_flux_upwind(field_old(i-1,k,j),g_field_old(i-1,k,j) &
15261 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
15262  FuncVal1 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
15263
15264  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15265  Tmpv1 =vel*FuncVal1
15266
15267  g_fqxl(i,k,j) =g_Tmpv1
15268  fqxl(i,k,j) =Tmpv1
15269
15270  g_FuncVal1=g_flux3(field(i-2,k,j),g_field(i-2,k,j),field(i-1,k,j) &
15271 ,g_field(i-1,k,j),field(i,k,j),g_field(i,k,j),field(i+1,k,j),g_field(i+1,k, &
15272  j),vel,g_vel)
15273  FuncVal1 =flux3(field(i-2,k,j),field(i-1,k,j),field(i,k,j),field(i+1,k,j),vel)
15274
15275  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15276  Tmpv1 =vel*FuncVal1
15277
15278  g_fqx(i,k,j) =g_Tmpv1
15279  fqx(i,k,j) =Tmpv1
15280
15281  g_fqx(i,k,j) =g_fqx(i,k,j) -g_fqxl(i,k,j)
15282  fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
15283
15284  IF(cr.gt. 0) THEN
15285
15286  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i-1,k,j) +(g_qmax(i,k,j) &
15287  -g_field_old(i-1,k,j))*sign(1.0, qmax(i,k,j) -(field_old(i-1,k,j))))*0.5
15288  qmax(i,k,j) =max(qmax(i,k,j),field_old(i-1,k,j))
15289
15290  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i-1,k,j) -(g_qmin(i,k,j) &
15291  -g_field_old(i-1,k,j))*sign(1.0, qmin(i,k,j) -(field_old(i-1,k,j))))*0.5
15292  qmin(i,k,j) =min(qmin(i,k,j),field_old(i-1,k,j))
15293
15294  else
15295
15296  g_qmax(i-1,k,j) =(g_qmax(i-1,k,j) +g_field_old(i,k,j) +(g_qmax(i-1,k,j) &
15297  -g_field_old(i,k,j))*sign(1.0, qmax(i-1,k,j) -(field_old(i,k,j))))*0.5
15298  qmax(i-1,k,j) =max(qmax(i-1,k,j),field_old(i,k,j))
15299
15300  g_qmin(i-1,k,j) =(g_qmin(i-1,k,j) +g_field_old(i,k,j) -(g_qmin(i-1,k,j) &
15301  -g_field_old(i,k,j))*sign(1.0, qmin(i-1,k,j) -(field_old(i,k,j))))*0.5
15302  qmin(i-1,k,j) =min(qmin(i-1,k,j),field_old(i,k,j))
15303
15304  end IF
15305  ENDDO
15306  ENDIF
15307  ENDDO
15308  ENDIF
15309
15310  ENDDO
15311  ELSE
15312
15313 ! Revised by Ning Pan, 2010-07-25
15314 ! WRITE (wrf_err_message,*) 'module_advect: advect_scalar_mono, h_order not known ',horz_order
15315  WRITE (wrf_err_message,*) 'g_module_advect: g_advect_scalar_mono, h_order not known ',horz_order
15316
15317 !DELETED BY WALLS
15318 !CALL g_wrf_error_fatal(Trim(wrf_err_message))
15319 CALL wrf_error_fatal(Trim(wrf_err_message))  ! Added by Ning Pan, 2010-07-25
15320  ENDIF
15321
15322  i_start =its
15323
15324  i_end =min(ite,ide-1)
15325
15326  j_start =jts
15327
15328  j_end =min(jte,jde-1)
15329
15330  IF( (config_flags%open_xs) .and. (its == ids) ) THEN
15331
15332  DO j =j_start,j_end
15333  DO k =kts,ktf
15334
15335  g_ub =(0.5*(g_ru(its,k,j) +g_ru(its+1,k,j)) +0.0 -(0.5*(g_ru(its,k,j) &
15336  +g_ru(its+1,k,j)) -0.0)*sign(1.0, 0.5*(ru(its,k,j) +ru(its+1,k,j)) -(0.)))*0.5
15337  ub =min(0.5*(ru(its,k,j) +ru(its+1,k,j)),0.)
15338
15339  g_Tmpv1 =ub*(g_field_old(its+1,k,j) -g_field_old(its,k,j)) +g_ub*( &
15340  field_old(its+1,k,j) -field_old(its,k,j))
15341  Tmpv1 =ub*(field_old(its+1,k,j) -field_old(its,k,j))
15342
15343  g_Tmpv2 =field(its,k,j)*(g_ru(its+1,k,j) -g_ru(its,k,j)) +g_field(its,k, &
15344  j)*(ru(its+1,k,j) -ru(its,k,j))
15345  Tmpv2 =field(its,k,j)*(ru(its+1,k,j) -ru(its,k,j))
15346
15347  g_tendency(its,k,j) =g_tendency(its,k,j) -rdx*(g_Tmpv1 +g_Tmpv2)
15348  tendency(its,k,j) =tendency(its,k,j) -rdx*(Tmpv1 +Tmpv2)
15349
15350  ENDDO
15351  ENDDO
15352  ENDIF
15353
15354  IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
15355
15356  DO j =j_start,j_end
15357  DO k =kts,ktf
15358
15359  g_ub =(0.5*(g_ru(ite-1,k,j) +g_ru(ite,k,j)) +0.0 +(0.5*(g_ru(ite-1,k,j) &
15360  +g_ru(ite,k,j)) -0.0)*sign(1.0, 0.5*(ru(ite-1,k,j) +ru(ite,k,j)) -(0.)))*0.5
15361  ub =max(0.5*(ru(ite-1,k,j) +ru(ite,k,j)),0.)
15362
15363  g_Tmpv1 =ub*(g_field_old(i_end,k,j) -g_field_old(i_end-1,k,j)) &
15364  +g_ub*(field_old(i_end,k,j) -field_old(i_end-1,k,j))
15365  Tmpv1 =ub*(field_old(i_end,k,j) -field_old(i_end-1,k,j))
15366
15367  g_Tmpv2 =field(i_end,k,j)*(g_ru(ite,k,j) -g_ru(ite-1,k,j)) +g_field( &
15368  i_end,k,j)*(ru(ite,k,j) -ru(ite-1,k,j))
15369  Tmpv2 =field(i_end,k,j)*(ru(ite,k,j) -ru(ite-1,k,j))
15370
15371  g_tendency(i_end,k,j) =g_tendency(i_end,k,j) -rdx*(g_Tmpv1 +g_Tmpv2)
15372  tendency(i_end,k,j) =tendency(i_end,k,j) -rdx*(Tmpv1 +Tmpv2)
15373
15374  ENDDO
15375  ENDDO
15376  ENDIF
15377
15378  IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
15379
15380  DO i =i_start,i_end
15381  DO k =kts,ktf
15382
15383  g_vb =(0.5*(g_rv(i,k,jts) +g_rv(i,k,jts+1)) +0.0 -(0.5*(g_rv(i,k,jts) &
15384  +g_rv(i,k,jts+1)) -0.0)*sign(1.0, 0.5*(rv(i,k,jts) +rv(i,k,jts+1)) -(0.)))*0.5
15385  vb =min(0.5*(rv(i,k,jts) +rv(i,k,jts+1)),0.)
15386
15387  g_Tmpv1 =vb*(g_field_old(i,k,jts+1) -g_field_old(i,k,jts)) +g_vb*( &
15388  field_old(i,k,jts+1) -field_old(i,k,jts))
15389  Tmpv1 =vb*(field_old(i,k,jts+1) -field_old(i,k,jts))
15390
15391  g_Tmpv2 =field(i,k,jts)*(g_rv(i,k,jts+1) -g_rv(i,k,jts)) +g_field(i,k, &
15392  jts)*(rv(i,k,jts+1) -rv(i,k,jts))
15393  Tmpv2 =field(i,k,jts)*(rv(i,k,jts+1) -rv(i,k,jts))
15394
15395  g_tendency(i,k,jts) =g_tendency(i,k,jts) -rdy*(g_Tmpv1 +g_Tmpv2)
15396  tendency(i,k,jts) =tendency(i,k,jts) -rdy*(Tmpv1 +Tmpv2)
15397
15398  ENDDO
15399  ENDDO
15400  ENDIF
15401
15402  IF( (config_flags%open_ye) .and. (jte == jde)) THEN
15403
15404  DO i =i_start,i_end
15405  DO k =kts,ktf
15406
15407  g_vb =(0.5*(g_rv(i,k,jte-1) +g_rv(i,k,jte)) +0.0 +(0.5*(g_rv(i,k,jte-1) &
15408  +g_rv(i,k,jte)) -0.0)*sign(1.0, 0.5*(rv(i,k,jte-1) +rv(i,k,jte)) -(0.)))*0.5
15409  vb =max(0.5*(rv(i,k,jte-1) +rv(i,k,jte)),0.)
15410
15411  g_Tmpv1 =vb*(g_field_old(i,k,j_end) -g_field_old(i,k,j_end-1)) &
15412  +g_vb*(field_old(i,k,j_end) -field_old(i,k,j_end-1))
15413  Tmpv1 =vb*(field_old(i,k,j_end) -field_old(i,k,j_end-1))
15414
15415  g_Tmpv2 =field(i,k,j_end)*(g_rv(i,k,jte) -g_rv(i,k,jte-1)) +g_field(i,k, &
15416  j_end)*(rv(i,k,jte) -rv(i,k,jte-1))
15417  Tmpv2 =field(i,k,j_end)*(rv(i,k,jte) -rv(i,k,jte-1))
15418
15419  g_tendency(i,k,j_end) =g_tendency(i,k,j_end) -rdy*(g_Tmpv1 +g_Tmpv2)
15420  tendency(i,k,j_end) =tendency(i,k,j_end) -rdy*(Tmpv1 +Tmpv2)
15421
15422  ENDDO
15423  ENDDO
15424  ENDIF
15425
15426  i_start =its-1
15427
15428  i_end =min(ite,ide-1) +1
15429
15430  j_start =jts-1
15431
15432  j_end =min(jte,jde-1) +1
15433
15434  IF(degrade_xs) i_start =max(its-1,ids)
15435
15436  IF(degrade_xe) i_end =min(ite+1,ide-1)
15437
15438  IF(degrade_ys) j_start =max(jts-1,jds)
15439
15440  IF(degrade_ye) j_end =min(jte+1,jde-1)
15441
15442  IF(vert_order == 3) THEN
15443
15444  DO j =j_start,j_end
15445  DO i =i_start,i_end
15446
15447  g_fqz(i,1,j) =0.0
15448  fqz(i,1,j) =0.
15449
15450  g_fqzl(i,1,j) =0.0
15451  fqzl(i,1,j) =0.
15452
15453  g_fqz(i,kde,j) =0.0
15454  fqz(i,kde,j) =0.
15455
15456  g_fqzl(i,kde,j) =0.0
15457  fqzl(i,kde,j) =0.
15458
15459  ENDDO
15460
15461  DO k =kts+2,ktf-1
15462  DO i =i_start,i_end
15463
15464  g_vel =g_rom(i,k,j)
15465  vel =rom(i,k,j)
15466
15467  g_cr =-g_vel
15468  cr =-vel
15469
15470  g_FuncVal1=g_flux_upwind(field_old(i,k-1,j),g_field_old(i,k-1,j) &
15471 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
15472  FuncVal1 =flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)
15473
15474  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15475  Tmpv1 =vel*FuncVal1
15476
15477  g_fqzl(i,k,j) =g_Tmpv1
15478  fqzl(i,k,j) =Tmpv1
15479
15480  g_FuncVal1=g_flux3(field(i,k-2,j),g_field(i,k-2,j),field(i,k-1,j) &
15481 ,g_field(i,k-1,j),field(i,k,j),g_field(i,k,j),field(i,k+1,j),g_field(i,k+1, &
15482  j),-vel,-g_vel)
15483  FuncVal1 =flux3(field(i,k-2,j),field(i,k-1,j),field(i,k,j),field(i,k+1,j),-vel)
15484
15485  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15486  Tmpv1 =vel*FuncVal1
15487
15488  g_fqz(i,k,j) =g_Tmpv1
15489  fqz(i,k,j) =Tmpv1
15490
15491  g_fqz(i,k,j) =g_fqz(i,k,j) -g_fqzl(i,k,j)
15492  fqz(i,k,j) =fqz(i,k,j) -fqzl(i,k,j)
15493
15494  IF(cr.gt. 0) THEN
15495
15496  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k-1,j) +(g_qmax(i,k,j) &
15497  -g_field_old(i,k-1,j))*sign(1.0, qmax(i,k,j) -(field_old(i,k-1,j))))*0.5
15498  qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k-1,j))
15499
15500  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k-1,j) -(g_qmin(i,k,j) &
15501  -g_field_old(i,k-1,j))*sign(1.0, qmin(i,k,j) -(field_old(i,k-1,j))))*0.5
15502  qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k-1,j))
15503
15504  else
15505
15506  g_qmax(i,k-1,j) =(g_qmax(i,k-1,j) +g_field_old(i,k,j) +(g_qmax(i,k-1,j) &
15507  -g_field_old(i,k,j))*sign(1.0, qmax(i,k-1,j) -(field_old(i,k,j))))*0.5
15508  qmax(i,k-1,j) =max(qmax(i,k-1,j),field_old(i,k,j))
15509
15510  g_qmin(i,k-1,j) =(g_qmin(i,k-1,j) +g_field_old(i,k,j) -(g_qmin(i,k-1,j) &
15511  -g_field_old(i,k,j))*sign(1.0, qmin(i,k-1,j) -(field_old(i,k,j))))*0.5
15512  qmin(i,k-1,j) =min(qmin(i,k-1,j),field_old(i,k,j))
15513
15514  end IF
15515  ENDDO
15516  ENDDO
15517
15518  DO i =i_start,i_end
15519
15520  k =kts+1
15521
15522  g_vel =g_rom(i,k,j)
15523  vel =rom(i,k,j)
15524
15525  g_cr =-g_vel
15526  cr =-vel
15527
15528  g_FuncVal1=g_flux_upwind(field_old(i,k-1,j),g_field_old(i,k-1,j) &
15529 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
15530  FuncVal1 =flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)
15531
15532  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15533  Tmpv1 =vel*FuncVal1
15534
15535  g_fqzl(i,k,j) =g_Tmpv1
15536  fqzl(i,k,j) =Tmpv1
15537
15538  g_Tmpv1 =rom(i,k,j)*(fzm(k)*g_field(i,k,j) +fzp(k)*g_field(i,k-1,j)) &
15539  +g_rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j))
15540  Tmpv1 =rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j))
15541
15542  g_fqz(i,k,j) =g_Tmpv1
15543  fqz(i,k,j) =Tmpv1
15544
15545  g_fqz(i,k,j) =g_fqz(i,k,j) -g_fqzl(i,k,j)
15546  fqz(i,k,j) =fqz(i,k,j) -fqzl(i,k,j)
15547
15548  IF(cr.gt. 0) THEN
15549
15550  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k-1,j) +(g_qmax(i,k,j) &
15551  -g_field_old(i,k-1,j))*sign(1.0, qmax(i,k,j) -(field_old(i,k-1,j))))*0.5
15552  qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k-1,j))
15553
15554  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k-1,j) -(g_qmin(i,k,j) &
15555  -g_field_old(i,k-1,j))*sign(1.0, qmin(i,k,j) -(field_old(i,k-1,j))))*0.5
15556  qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k-1,j))
15557
15558  else
15559
15560  g_qmax(i,k-1,j) =(g_qmax(i,k-1,j) +g_field_old(i,k,j) +(g_qmax(i,k-1,j) &
15561  -g_field_old(i,k,j))*sign(1.0, qmax(i,k-1,j) -(field_old(i,k,j))))*0.5
15562  qmax(i,k-1,j) =max(qmax(i,k-1,j),field_old(i,k,j))
15563
15564  g_qmin(i,k-1,j) =(g_qmin(i,k-1,j) +g_field_old(i,k,j) -(g_qmin(i,k-1,j) &
15565  -g_field_old(i,k,j))*sign(1.0, qmin(i,k-1,j) -(field_old(i,k,j))))*0.5
15566  qmin(i,k-1,j) =min(qmin(i,k-1,j),field_old(i,k,j))
15567
15568  end IF
15569
15570  k =ktf
15571
15572  g_vel =g_rom(i,k,j)
15573  vel =rom(i,k,j)
15574
15575  g_cr =-g_vel
15576  cr =-vel
15577
15578  g_FuncVal1=g_flux_upwind(field_old(i,k-1,j),g_field_old(i,k-1,j) &
15579 ,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
15580  FuncVal1 =flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)
15581
15582  g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
15583  Tmpv1 =vel*FuncVal1
15584
15585  g_fqzl(i,k,j) =g_Tmpv1
15586  fqzl(i,k,j) =Tmpv1
15587
15588  g_Tmpv1 =rom(i,k,j)*(fzm(k)*g_field(i,k,j) +fzp(k)*g_field(i,k-1,j)) &
15589  +g_rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j))
15590  Tmpv1 =rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j))
15591
15592  g_fqz(i,k,j) =g_Tmpv1
15593  fqz(i,k,j) =Tmpv1
15594
15595  g_fqz(i,k,j) =g_fqz(i,k,j) -g_fqzl(i,k,j)
15596  fqz(i,k,j) =fqz(i,k,j) -fqzl(i,k,j)
15597
15598  IF(cr.gt. 0) THEN
15599
15600  g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k-1,j) +(g_qmax(i,k,j) &
15601  -g_field_old(i,k-1,j))*sign(1.0, qmax(i,k,j) -(field_old(i,k-1,j))))*0.5
15602  qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k-1,j))
15603
15604  g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k-1,j) -(g_qmin(i,k,j) &
15605  -g_field_old(i,k-1,j))*sign(1.0, qmin(i,k,j) -(field_old(i,k-1,j))))*0.5
15606  qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k-1,j))
15607
15608  else
15609
15610  g_qmax(i,k-1,j) =(g_qmax(i,k-1,j) +g_field_old(i,k,j) +(g_qmax(i,k-1,j) &
15611  -g_field_old(i,k,j))*sign(1.0, qmax(i,k-1,j) -(field_old(i,k,j))))*0.5
15612  qmax(i,k-1,j) =max(qmax(i,k-1,j),field_old(i,k,j))
15613
15614  g_qmin(i,k-1,j) =(g_qmin(i,k-1,j) +g_field_old(i,k,j) -(g_qmin(i,k-1,j) &
15615  -g_field_old(i,k,j))*sign(1.0, qmin(i,k-1,j) -(field_old(i,k,j))))*0.5
15616  qmin(i,k-1,j) =min(qmin(i,k-1,j),field_old(i,k,j))
15617
15618  end IF
15619  ENDDO
15620  ENDDO
15621  ELSE
15622
15623 ! Revised by Ning Pan, 2010-07-25
15624 ! WRITE (wrf_err_message,*) ' advect_scalar_mono, v_order not known ',vert_order
15625  WRITE (wrf_err_message,*) ' g_advect_scalar_mono, v_order not known ',vert_order
15626
15627 !DELETED BY WALLS
15628 !CALL g_wrf_error_fatal(wrf_err_message)
15629 CALL wrf_error_fatal(wrf_err_message)  ! Added by Ning Pan, 2010-07-25
15630  ENDIF
15631
15632  IF(mono_limit) THEN
15633
15634  i_start =its-1
15635
15636  i_end =min(ite,ide-1) +1
15637
15638  j_start =jts-1
15639
15640  j_end =min(jte,jde-1) +1
15641
15642  IF(degrade_xs) i_start =max(its-1,ids)
15643
15644  IF(degrade_xe) i_end =min(ite+1,ide-1)
15645
15646  IF(degrade_ys) j_start =max(jts-1,jds)
15647
15648  IF(degrade_ye) j_end =min(jte+1,jde-1)
15649
15650  IF(config_flags%specified .or. config_flags%nested) THEN
15651
15652  IF(degrade_xs) i_start =max(its-1,ids+1)
15653
15654  IF(degrade_xe) i_end =min(ite+1,ide-2)
15655
15656  IF(degrade_ys) j_start =max(jts-1,jds+1)
15657
15658  IF(degrade_ye) j_end =min(jte+1,jde-2)
15659   END IF
15660
15661  IF(config_flags%open_xs) THEN
15662
15663  IF(degrade_xs) i_start =max(its-1,ids+1)
15664   END IF
15665
15666  IF(config_flags%open_xe) THEN
15667
15668  IF(degrade_xe) i_end =min(ite+1,ide-2)
15669   END IF
15670
15671  IF(config_flags%open_ys) THEN
15672
15673  IF(degrade_ys) j_start =max(jts-1,jds+1)
15674   END IF
15675
15676  IF(config_flags%open_ye) THEN
15677
15678  IF(degrade_ye) j_end =min(jte+1,jde-2)
15679   END IF
15680
15681  DO j =j_start,j_end
15682  DO k =kts,ktf
15683  DO i =i_start,i_end
15684
15685  g_Tmpv1 =(mub(i,j) +mu_old(i,j))*g_field_old(i,k,j) +(g_mu_old(i,j)) &
15686 *field_old(i,k,j)
15687  Tmpv1 =(mub(i,j) +mu_old(i,j))*field_old(i,k,j)
15688
15689  g_ph_upwind =g_Tmpv1 -dt*(msftx(i,j) *msfty(i,j)*(rdx*(g_fqxl(i+1,k,j) &
15690  -g_fqxl(i,k,j)) +rdy*(g_fqyl(i,k,j+1) -g_fqyl(i,k,j))) +msfty(i,j) *rdzw(k) &
15691 *(g_fqzl(i,k+1,j) -g_fqzl(i,k,j)))
15692  ph_upwind =Tmpv1 -dt*(msftx(i,j) *msfty(i,j)*(rdx*(fqxl(i+1,k,j) -fqxl(i,k,j)) &
15693  +rdy*(fqyl(i,k,j+1) -fqyl(i,k,j))) +msfty(i,j) *rdzw(k)*(fqzl(i,k+1,j) -fqzl(i,k,j)))
15694
15695  g_flux_in =-dt*((msftx(i,j) *msfty(i,j))*(rdx*((0.0 +g_fqx(i+1,k,j) &
15696  -(0.0 -g_fqx(i+1,k,j))*sign(1.0, 0. -(fqx(i+1,k,j))))*0.5 -(0.0 +g_fqx(i,k,j) &
15697  +(0.0 -g_fqx(i,k,j))*sign(1.0, 0. -(fqx(i,k,j))))*0.5) +rdy*((0.0 +g_fqy(i,k, &
15698  j+1) -(0.0 -g_fqy(i,k,j+1))*sign(1.0, 0. -(fqy(i,k,j+1))))*0.5 -(0.0 +g_fqy(i, &
15699  k,j) +(0.0 -g_fqy(i,k,j))*sign(1.0, 0. -(fqy(i,k,j))))*0.5)) +msfty(i,j) *rdzw(k) &
15700 *((0.0 +g_fqz(i,k+1,j) +(0.0 -g_fqz(i,k+1,j))*sign(1.0, 0. -(fqz(i,k+1,j)))) &
15701 *0.5 -(0.0 +g_fqz(i,k,j) -(0.0 -g_fqz(i,k,j))*sign(1.0, 0. -(fqz(i,k,j))))*0.5))
15702  flux_in =-dt*((msftx(i,j) *msfty(i,j))*(rdx*(min(0.,fqx(i+1,k,j)) -max(0.,fqx(i,k, &
15703  j))) +rdy*(min(0.,fqy(i,k,j+1)) -max(0.,fqy(i,k,j)))) +msfty(i,j) *rdzw(k) &
15704 *(max(0.,fqz(i,k+1,j)) -min(0.,fqz(i,k,j))))
15705
15706  g_Tmpv1 =mut(i,j)*g_qmax(i,k,j) +g_mut(i,j)*qmax(i,k,j)
15707  Tmpv1 =mut(i,j)*qmax(i,k,j)
15708
15709  g_ph_hi =g_Tmpv1 -g_ph_upwind
15710  ph_hi =Tmpv1 -ph_upwind
15711
15712  g_Tmpv1 =(g_ph_hi*(flux_in +eps) -(g_flux_in)*ph_hi)/((flux_in +eps)*(flux_in +eps))
15713  Tmpv1 =ph_hi/(flux_in +eps)
15714
15715  IF( flux_in .gt. ph_hi ) g_scale_in(i,k,j) =(0.0 +g_Tmpv1 +(0.0 -g_Tmpv1) &
15716 *sign(1.0, 0. -(Tmpv1)))*0.5
15717  IF( flux_in .gt. ph_hi ) scale_in(i,k,j) =max(0.,Tmpv1)
15718
15719  g_flux_out =dt*((msftx(i,j) *msfty(i,j))*(rdx*((0.0 +g_fqx(i+1,k,j) &
15720  +(0.0 -g_fqx(i+1,k,j))*sign(1.0, 0. -(fqx(i+1,k,j))))*0.5 -(0.0 +g_fqx(i,k,j) &
15721  -(0.0 -g_fqx(i,k,j))*sign(1.0, 0. -(fqx(i,k,j))))*0.5) +rdy*((0.0 +g_fqy(i,k, &
15722  j+1) +(0.0 -g_fqy(i,k,j+1))*sign(1.0, 0. -(fqy(i,k,j+1))))*0.5 -(0.0 +g_fqy(i, &
15723  k,j) -(0.0 -g_fqy(i,k,j))*sign(1.0, 0. -(fqy(i,k,j))))*0.5)) +msfty(i,j) *rdzw(k) &
15724 *((0.0 +g_fqz(i,k+1,j) -(0.0 -g_fqz(i,k+1,j))*sign(1.0, 0. -(fqz(i,k+1,j)))) &
15725 *0.5 -(0.0 +g_fqz(i,k,j) +(0.0 -g_fqz(i,k,j))*sign(1.0, 0. -(fqz(i,k,j))))*0.5))
15726  flux_out =dt*((msftx(i,j) *msfty(i,j))*(rdx*(max(0.,fqx(i+1,k,j)) -min(0.,fqx(i,k, &
15727  j))) +rdy*(max(0.,fqy(i,k,j+1)) -min(0.,fqy(i,k,j)))) +msfty(i,j) *rdzw(k) &
15728 *(min(0.,fqz(i,k+1,j)) -max(0.,fqz(i,k,j))))
15729
15730  g_Tmpv1 =mut(i,j)*g_qmin(i,k,j) +g_mut(i,j)*qmin(i,k,j)
15731  Tmpv1 =mut(i,j)*qmin(i,k,j)
15732
15733  g_ph_low =g_ph_upwind -g_Tmpv1
15734  ph_low =ph_upwind -Tmpv1
15735
15736  g_Tmpv1 =(g_ph_low*(flux_out +eps) -(g_flux_out)*ph_low)/((flux_out +eps) &
15737 *(flux_out +eps))
15738  Tmpv1 =ph_low/(flux_out +eps)
15739
15740  IF( flux_out .gt. ph_low ) g_scale_out(i,k,j) =(0.0 +g_Tmpv1 +(0.0 -g_Tmpv1) &
15741 *sign(1.0, 0. -(Tmpv1)))*0.5
15742  IF( flux_out .gt. ph_low ) scale_out(i,k,j) =max(0.,Tmpv1)
15743  ENDDO
15744  ENDDO
15745  ENDDO
15746
15747  DO j =j_start,j_end
15748  DO k =kts,ktf
15749  DO i =i_start,i_end+1
15750
15751  IF( fqx (i,k,j) .gt. 0.) THEN
15752
15753  g_Tmpv1 =min(scale_in(i,k,j),scale_out(i-1,k,j))*g_fqx(i,k,j) +(g_scale_in( &
15754  i,k,j) +g_scale_out(i-1,k,j) -(g_scale_in(i,k,j) -g_scale_out(i-1,k,j)) &
15755 *sign(1.0, scale_in(i,k,j) -(scale_out(i-1,k,j))))*0.5*fqx(i,k,j)
15756  Tmpv1 =min(scale_in(i,k,j),scale_out(i-1,k,j))*fqx(i,k,j)
15757
15758  g_fqx(i,k,j) =g_Tmpv1
15759  fqx(i,k,j) =Tmpv1
15760
15761  ELSE
15762
15763  g_Tmpv1 =min(scale_out(i,k,j),scale_in(i-1,k,j))*g_fqx(i,k,j) +( &
15764  g_scale_out(i,k,j) +g_scale_in(i-1,k,j) -(g_scale_out(i,k,j) -g_scale_in( &
15765  i-1,k,j))*sign(1.0, scale_out(i,k,j) -(scale_in(i-1,k,j))))*0.5*fqx(i,k,j)
15766  Tmpv1 =min(scale_out(i,k,j),scale_in(i-1,k,j))*fqx(i,k,j)
15767
15768  g_fqx(i,k,j) =g_Tmpv1
15769  fqx(i,k,j) =Tmpv1
15770
15771  ENDIF
15772  ENDDO
15773  ENDDO
15774  ENDDO
15775
15776  DO j =j_start,j_end+1
15777  DO k =kts,ktf
15778  DO i =i_start,i_end
15779
15780  IF( fqy (i,k,j) .gt. 0.) THEN
15781
15782  g_Tmpv1 =min(scale_in(i,k,j),scale_out(i,k,j-1))*g_fqy(i,k,j) +(g_scale_in( &
15783  i,k,j) +g_scale_out(i,k,j-1) -(g_scale_in(i,k,j) -g_scale_out(i,k,j-1)) &
15784 *sign(1.0, scale_in(i,k,j) -(scale_out(i,k,j-1))))*0.5*fqy(i,k,j)
15785  Tmpv1 =min(scale_in(i,k,j),scale_out(i,k,j-1))*fqy(i,k,j)
15786
15787  g_fqy(i,k,j) =g_Tmpv1
15788  fqy(i,k,j) =Tmpv1
15789
15790  ELSE
15791
15792  g_Tmpv1 =min(scale_out(i,k,j),scale_in(i,k,j-1))*g_fqy(i,k,j) +( &
15793  g_scale_out(i,k,j) +g_scale_in(i,k,j-1) -(g_scale_out(i,k,j) -g_scale_in( &
15794  i,k,j-1))*sign(1.0, scale_out(i,k,j) -(scale_in(i,k,j-1))))*0.5*fqy(i,k,j)
15795  Tmpv1 =min(scale_out(i,k,j),scale_in(i,k,j-1))*fqy(i,k,j)
15796
15797  g_fqy(i,k,j) =g_Tmpv1
15798  fqy(i,k,j) =Tmpv1
15799
15800  ENDIF
15801  ENDDO
15802  ENDDO
15803  ENDDO
15804
15805  DO j =j_start,j_end
15806  DO k =kts+1,ktf
15807  DO i =i_start,i_end
15808
15809  IF( fqz (i,k,j) .lt. 0.) THEN
15810
15811  g_Tmpv1 =min(scale_in(i,k,j),scale_out(i,k-1,j))*g_fqz(i,k,j) +(g_scale_in( &
15812  i,k,j) +g_scale_out(i,k-1,j) -(g_scale_in(i,k,j) -g_scale_out(i,k-1,j)) &
15813 *sign(1.0, scale_in(i,k,j) -(scale_out(i,k-1,j))))*0.5*fqz(i,k,j)
15814  Tmpv1 =min(scale_in(i,k,j),scale_out(i,k-1,j))*fqz(i,k,j)
15815
15816  g_fqz(i,k,j) =g_Tmpv1
15817  fqz(i,k,j) =Tmpv1
15818
15819  ELSE
15820
15821  g_Tmpv1 =min(scale_out(i,k,j),scale_in(i,k-1,j))*g_fqz(i,k,j) +( &
15822  g_scale_out(i,k,j) +g_scale_in(i,k-1,j) -(g_scale_out(i,k,j) -g_scale_in( &
15823  i,k-1,j))*sign(1.0, scale_out(i,k,j) -(scale_in(i,k-1,j))))*0.5*fqz(i,k,j)
15824  Tmpv1 =min(scale_out(i,k,j),scale_in(i,k-1,j))*fqz(i,k,j)
15825
15826  g_fqz(i,k,j) =g_Tmpv1
15827  fqz(i,k,j) =Tmpv1
15828
15829  ENDIF
15830  ENDDO
15831  ENDDO
15832  ENDDO
15833  END IF
15834
15835  i_start =its
15836
15837  i_end =min(ite,ide-1)
15838
15839  j_start =jts
15840
15841  j_end =min(jte,jde-1)
15842
15843  DO j =j_start,j_end
15844  DO k =kts,ktf
15845  DO i =i_start,i_end
15846
15847  g_tendency(i,k,j) =g_tendency(i,k,j) -rdzw(k)*(g_fqz(i,k+1,j) -g_fqz(i,k, &
15848  j) +g_fqzl(i,k+1,j) -g_fqzl(i,k,j))
15849  tendency(i,k,j) =tendency(i,k,j) -rdzw(k)*(fqz(i,k+1,j) -fqz(i,k,j) +fqzl(i,k+1,j) &
15850  -fqzl(i,k,j))
15851
15852  ENDDO
15853  ENDDO
15854  ENDDO
15855
15856  IF(tenddec) THEN
15857  DO j = j_start, j_end
15858  DO k = kts, ktf
15859  DO i = i_start, i_end
15860
15861     g_z_tendency (i,k,j) = -rdzw(k)*( g_fqz (i,k+1,j)-g_fqz (i,k,j)  &
15862                                      +g_fqzl(i,k+1,j)-g_fqzl(i,k,j))
15863
15864     z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
15865                                      +fqzl(i,k+1,j)-fqzl(i,k,j))
15866
15867  ENDDO
15868  ENDDO
15869  ENDDO
15870  END IF
15871
15872  IF(degrade_xs) i_start =max(its,ids+1)
15873
15874  IF(degrade_xe) i_end =min(ite,ide-2)
15875
15876  DO j =j_start,j_end
15877  DO k =kts,ktf
15878  DO i =i_start,i_end
15879
15880  g_tendency(i,k,j) =g_tendency(i,k,j) -msftx(i,j)*(rdx*(g_fqx(i+1,k,j) &
15881  -g_fqx(i,k,j) +g_fqxl(i+1,k,j) -g_fqxl(i,k,j)))
15882  tendency(i,k,j) =tendency(i,k,j) -msftx(i,j)*(rdx*(fqx(i+1,k,j) -fqx(i,k,j) &
15883  +fqxl(i+1,k,j) -fqxl(i,k,j)))
15884
15885  ENDDO
15886  ENDDO
15887  ENDDO
15888
15889  IF(tenddec) THEN
15890  DO j = j_start, j_end
15891  DO k = kts, ktf
15892  DO i = i_start, i_end
15893
15894     g_h_tendency (i,k,j) =                                       &
15895               - msftx(i,j)*( rdx*( g_fqx (i+1,k,j)-g_fqx (i,k,j)     &
15896                                   +g_fqxl(i+1,k,j)-g_fqxl(i,k,j))   )
15897     h_tendency (i,k,j) = 0.                                      &
15898               - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
15899                                   +fqxl(i+1,k,j)-fqxl(i,k,j))   )
15900
15901  ENDDO
15902  ENDDO
15903  ENDDO
15904  END IF
15905
15906  i_start =its
15907
15908  i_end =min(ite,ide-1)
15909
15910  IF(degrade_ys) j_start =max(jts,jds+1)
15911
15912  IF(degrade_ye) j_end =min(jte,jde-2)
15913
15914  DO j =j_start,j_end
15915  DO k =kts,ktf
15916  DO i =i_start,i_end
15917
15918  g_tendency(i,k,j) =g_tendency(i,k,j) -msftx(i,j)*(rdy*(g_fqy(i,k,j+1) &
15919  -g_fqy(i,k,j) +g_fqyl(i,k,j+1) -g_fqyl(i,k,j)))
15920  tendency(i,k,j) =tendency(i,k,j) -msftx(i,j)*(rdy*(fqy(i,k,j+1) -fqy(i,k,j) &
15921  +fqyl(i,k,j+1) -fqyl(i,k,j)))
15922
15923  ENDDO
15924  ENDDO
15925  ENDDO
15926
15927  IF(tenddec) THEN
15928  DO j = j_start, j_end
15929  DO k = kts, ktf
15930  DO i = i_start, i_end
15931
15932     g_h_tendency (i,k,j) = g_h_tendency (i,k,j)                      &
15933               - msftx(i,j)*( rdy*( g_fqy (i,k,j+1)-g_fqy (i,k,j)     &
15934                                   +g_fqyl(i,k,j+1)-g_fqyl(i,k,j))   )
15935     h_tendency (i,k,j) = h_tendency (i,k,j)                      &
15936               - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
15937                                   +fqyl(i,k,j+1)-fqyl(i,k,j))   )
15938
15939  ENDDO
15940  ENDDO
15941  ENDDO
15942  END IF
15943
15944  END SUBROUTINE g_advect_scalar_mono
15945
15946
15947 !        Generated by TAPENADE     (INRIA, Tropics team)
15948 !  Tapenade 3.6 (r4165) - 21 sep 2011 20:54
15949 !
15950 !  Differentiation of advect_scalar_weno in forward (tangent) mode:
15951 !   variations   of useful results: tendency
15952 !   with respect to varying inputs: rom field tendency ru rv field_old
15953 !   RW status of diff variables: rom:in field:in tendency:in-out
15954 !                ru:in rv:in field_old:in
15955 SUBROUTINE G_ADVECT_SCALAR_WENO(field, fieldd, field_old, field_oldd, &
15956 &  tendency, tendencyd, ru, rud, rv, rvd, rom, romd, mut, time_step, &
15957 &  config_flags, msfux, msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx&
15958 &  , rdy, rdzw, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, &
15959 &  kme, its, ite, jts, jte, kts, kte)
15960   IMPLICIT NONE
15961 ! Input data
15962   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
15963   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
15964 &  jme, kms, kme, its, ite, jts, jte, kts, kte
15965   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
15966 &  field_old, ru, rv, rom
15967   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: fieldd, &
15968 &  field_oldd, rud, rvd, romd
15969   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
15970   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
15971   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
15972   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
15973 &  msfvy, msftx, msfty
15974   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
15975   REAL, INTENT(IN) :: rdx, rdy
15976   INTEGER, INTENT(IN) :: time_step
15977 ! Local data
15978   INTEGER :: i, j, k, itf, jtf, ktf
15979   INTEGER :: i_start, i_end, j_start, j_end
15980   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
15981   INTEGER :: jmin, jmax, jp, jm, imin, imax
15982   INTEGER, PARAMETER :: is=0, js=0, ks=0
15983   REAL :: mrdx, mrdy, ub, vb, vw
15984   REAL :: ubd, vbd
15985   REAL, DIMENSION(its:ite, kts:kte) :: vflux
15986   REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
15987   REAL, DIMENSION(its - is:ite + 1, kts:kte) :: fqx
15988   REAL, DIMENSION(its-is:ite+1, kts:kte) :: fqxd
15989 !   REAL,  DIMENSION( its:ite+1, kts:kte  ) :: fqx
15990   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
15991   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
15992   INTEGER :: horz_order, vert_order
15993   LOGICAL :: degrade_xs, degrade_ys
15994   LOGICAL :: degrade_xe, degrade_ye
15995   INTEGER :: jp1, jp0, jtmp
15996   REAL :: dir, vv
15997   REAL :: ue, uw, vs, vn, wb, wt
15998   REAL, PARAMETER :: f30=7./12., f31=1./12.
15999   REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
16000   INTEGER :: kt, kb
16001   REAL :: qim2, qim1, qi, qip1, qip2
16002   REAL :: qim2d, qim1d, qid, qip1d, qip2d
16003   DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
16004 &  sumwk
16005   DOUBLE PRECISION :: beta0d, beta1d, beta2d, f0d, f1d, f2d, wi0d, wi1d&
16006 &  , wi2d, sumwkd
16007   DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
16008 &    3.d0/10.d0, eps=1.0d-28
16009   INTEGER, PARAMETER :: pw=2
16010 ! definition of flux operators, 3rd, 4th, 5th or 6th order
16011   REAL :: flux3, flux4, flux5, flux6
16012   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
16013   REAL :: veld
16014   LOGICAL :: specified
16015   DOUBLE PRECISION :: pwx1
16016   DOUBLE PRECISION :: pwx1d
16017   DOUBLE PRECISION :: pwr1
16018   DOUBLE PRECISION :: pwr1d
16019   INTRINSIC MAX
16020   INTRINSIC SIGN
16021   INTRINSIC MIN
16022
16023
16024
16025
16026   specified = .false.
16027   IF (config_flags%specified .OR. config_flags%nested) specified = &
16028 &      .true.
16029   IF (kte .GT. kde - 1) THEN
16030     ktf = kde - 1
16031   ELSE
16032     ktf = kte
16033   END IF
16034 ! config_flags%h_sca_adv_order
16035   horz_order = 5
16036 ! config_flags%v_sca_adv_order
16037   vert_order = 5
16038 !  begin with horizontal flux divergence
16039 !  here is the choice of flux operators
16040   IF (horz_order .EQ. 5) THEN
16041 !  determine boundary mods for flux operators
16042 !  We degrade the flux operators from 3rd/4th order
16043 !   to second order one gridpoint in from the boundaries for
16044 !   all boundary conditions except periodic and symmetry - these
16045 !   conditions have boundary zone data fill for correct application
16046 !   of the higher order flux stencils
16047     degrade_xs = .true.
16048     degrade_xe = .true.
16049     degrade_ys = .true.
16050     degrade_ye = .true.
16051     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
16052 &        its .GT. ids + 3) degrade_xs = .false.
16053     IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
16054 &        ite .LT. ide - 3) degrade_xe = .false.
16055     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
16056 &        jts .GT. jds + 3) degrade_ys = .false.
16057     IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
16058 &        jte .LT. jde - 4) degrade_ye = .false.
16059     IF (kte .GT. kde - 1) THEN
16060       ktf = kde - 1
16061     ELSE
16062       ktf = kte
16063     END IF
16064     i_start = its
16065     IF (ite .GT. ide - 1) THEN
16066       i_end = ide - 1
16067     ELSE
16068       i_end = ite
16069     END IF
16070 ! check for U
16071     IF (is .EQ. 1) THEN
16072       i_start = its
16073       i_end = ite
16074       IF (config_flags%open_xs .OR. specified) THEN
16075         IF (ids + 1 .LT. its) THEN
16076           i_start = its
16077         ELSE
16078           i_start = ids + 1
16079         END IF
16080       END IF
16081       IF (config_flags%open_xe .OR. specified) THEN
16082         IF (ide - 1 .GT. ite) THEN
16083           i_end = ite
16084         ELSE
16085           i_end = ide - 1
16086         END IF
16087       END IF
16088       IF (config_flags%periodic_x) i_start = its
16089       IF (config_flags%periodic_x) i_end = ite
16090     END IF
16091     j_start = jts
16092     IF (jte .GT. jde - 1) THEN
16093       j_end = jde - 1
16094     ELSE
16095       j_end = jte
16096     END IF
16097 !  higher order flux has a 5 or 7 point stencil, so compute
16098 !  bounds so we can switch to second order flux close to the boundary
16099     j_start_f = j_start
16100     j_end_f = j_end + 1
16101     IF (degrade_ys) THEN
16102       IF (jts .LT. jds + 1) THEN
16103         j_start = jds + 1
16104       ELSE
16105         j_start = jts
16106       END IF
16107       j_start_f = jds + 3
16108     END IF
16109     IF (degrade_ye) THEN
16110       IF (jte .GT. jde - 2) THEN
16111         j_end = jde - 2
16112       ELSE
16113         j_end = jte
16114       END IF
16115       j_end_f = jde - 3
16116     END IF
16117     IF (config_flags%polar) THEN
16118       IF (jte .GT. jde - 1) THEN
16119         j_end = jde - 1
16120       ELSE
16121         j_end = jte
16122       END IF
16123     END IF
16124 !  compute fluxes, 5th or 6th order
16125     jp1 = 2
16126     jp0 = 1
16127     fqyd = 0.0
16128 j_loop_y_flux_5:DO j=j_start,j_end+1
16129       IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
16130 ! use full stencil
16131         DO k=kts,ktf
16132           DO i=i_start,i_end
16133 !          vel = rv(i,k,j)
16134             veld = 0.5*(rvd(i, k, j)+rvd(i-is, k-ks, j-js))
16135             vel = 0.5*(rv(i, k, j)+rv(i-is, k-ks, j-js))
16136             IF (vel*sign(1,time_step) .GE. 0.0) THEN
16137               qip2d = fieldd(i, k, j+1)
16138               qip2 = field(i, k, j+1)
16139               qip1d = fieldd(i, k, j)
16140               qip1 = field(i, k, j)
16141               qid = fieldd(i, k, j-1)
16142               qi = field(i, k, j-1)
16143               qim1d = fieldd(i, k, j-2)
16144               qim1 = field(i, k, j-2)
16145               qim2d = fieldd(i, k, j-3)
16146               qim2 = field(i, k, j-3)
16147             ELSE
16148               qip2d = fieldd(i, k, j-2)
16149               qip2 = field(i, k, j-2)
16150               qip1d = fieldd(i, k, j-1)
16151               qip1 = field(i, k, j-1)
16152               qid = fieldd(i, k, j)
16153               qi = field(i, k, j)
16154               qim1d = fieldd(i, k, j+1)
16155               qim1 = field(i, k, j+1)
16156               qim2d = fieldd(i, k, j+2)
16157               qim2 = field(i, k, j+2)
16158             END IF
16159             f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
16160             f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
16161             f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
16162             f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
16163             f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
16164             f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
16165             beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + &
16166 &              2*(qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
16167             beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+&
16168 &              3.*qi)**2
16169             beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + &
16170 &              2*(qim1-qip1)*(qim1d-qip1d)/4.
16171             beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
16172             beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + &
16173 &              2*(qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
16174             beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+&
16175 &              3.*qi)**2
16176             pwx1d = beta0d
16177             pwx1 = eps + beta0
16178             IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))&
16179 &            ) THEN
16180               pwr1d = pw*pwx1**(pw-1)*pwx1d
16181             ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
16182               pwr1d = pwx1d
16183             ELSE
16184               pwr1d = 0.0
16185             END IF
16186             pwr1 = pwx1**pw
16187             wi0d = -(gi0*pwr1d/pwr1**2)
16188             wi0 = gi0/pwr1
16189             pwx1d = beta1d
16190             pwx1 = eps + beta1
16191             IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))&
16192 &            ) THEN
16193               pwr1d = pw*pwx1**(pw-1)*pwx1d
16194             ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
16195               pwr1d = pwx1d
16196             ELSE
16197               pwr1d = 0.0
16198             END IF
16199             pwr1 = pwx1**pw
16200             wi1d = -(gi1*pwr1d/pwr1**2)
16201             wi1 = gi1/pwr1
16202             pwx1d = beta2d
16203             pwx1 = eps + beta2
16204             IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))&
16205 &            ) THEN
16206               pwr1d = pw*pwx1**(pw-1)*pwx1d
16207             ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
16208               pwr1d = pwx1d
16209             ELSE
16210               pwr1d = 0.0
16211             END IF
16212             pwr1 = pwx1**pw
16213             wi2d = -(gi2*pwr1d/pwr1**2)
16214             wi2 = gi2/pwr1
16215             sumwkd = wi0d + wi1d + wi2d
16216             sumwk = wi0 + wi1 + wi2
16217             fqyd(i, k, jp1) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0&
16218 &              +wi0*f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*&
16219 &              f0+wi1*f1+wi2*f2)*sumwkd)/sumwk**2
16220             fqy(i, k, jp1) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
16221           END DO
16222         END DO
16223       ELSE IF (j .EQ. jds + 1) THEN
16224 !          fqy( i, k, jp1 ) = vel*flux5(                                &
16225 !                  field(i,k,j-3), field(i,k,j-2), field(i,k,j-1),       &
16226 !                  field(i,k,j  ), field(i,k,j+1), field(i,k,j+2),  vel )
16227 ! 2nd order flux next to south boundary
16228         DO k=kts,ktf
16229           DO i=i_start,i_end
16230 !              fqy(i,k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )*          &
16231             fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
16232 &              , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
16233 &              )
16234             fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
16235 &              , j-1))
16236           END DO
16237         END DO
16238       ELSE IF (j .EQ. jds + 2) THEN
16239 ! third of 4th order flux 2 in from south boundary
16240         DO k=kts,ktf
16241           DO i=i_start,i_end
16242 !              vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
16243             veld = rvd(i, k, j)
16244             vel = rv(i, k, j)
16245             fqyd(i, k, jp1) = veld*(7./12.*(field(i, k, j)+field(i, k, j&
16246 &              -1))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1., &
16247 &              vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-3.*(field&
16248 &              (i, k, j)-field(i, k, j-1)))) + vel*(7.*(fieldd(i, k, j)+&
16249 &              fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+fieldd(i, k, j-2&
16250 &              ))/12.+SIGN(1., vel)*(fieldd(i, k, j+1)-fieldd(i, k, j-2)-&
16251 &              3.*(fieldd(i, k, j)-fieldd(i, k, j-1)))/12.)
16252             fqy(i, k, jp1) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1&
16253 &              ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1., vel&
16254 &              )*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-3.*(field(i&
16255 &              , k, j)-field(i, k, j-1))))
16256           END DO
16257         END DO
16258       ELSE IF (j .EQ. jde - 1) THEN
16259 ! 2nd order flux next to north boundary
16260         DO k=kts,ktf
16261           DO i=i_start,i_end
16262 !              fqy(i, k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )*      &
16263             fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
16264 &              , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
16265 &              )
16266             fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
16267 &              , j-1))
16268           END DO
16269         END DO
16270       ELSE IF (j .EQ. jde - 2) THEN
16271 ! 3rd or 4th order flux 2 in from north boundary
16272         DO k=kts,ktf
16273           DO i=i_start,i_end
16274             veld = rvd(i, k, j)
16275             vel = rv(i, k, j)
16276 !              vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
16277             fqyd(i, k, jp1) = veld*(7./12.*(field(i, k, j)+field(i, k, j&
16278 &              -1))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1., &
16279 &              vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-3.*(field&
16280 &              (i, k, j)-field(i, k, j-1)))) + vel*(7.*(fieldd(i, k, j)+&
16281 &              fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+fieldd(i, k, j-2&
16282 &              ))/12.+SIGN(1., vel)*(fieldd(i, k, j+1)-fieldd(i, k, j-2)-&
16283 &              3.*(fieldd(i, k, j)-fieldd(i, k, j-1)))/12.)
16284             fqy(i, k, jp1) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1&
16285 &              ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1., vel&
16286 &              )*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-3.*(field(i&
16287 &              , k, j)-field(i, k, j-1))))
16288           END DO
16289         END DO
16290       END IF
16291 !  y flux-divergence into tendency
16292       IF (is .EQ. 0) THEN
16293 ! Comments on polar boundary conditions
16294 ! Same process as for advect_u - tendencies run from jds to jde-1
16295 ! (latitudes are as for u grid, longitudes are displaced)
16296 ! Therefore: flow is only from one side for points next to poles
16297         IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
16298           DO k=kts,ktf
16299             DO i=i_start,i_end
16300 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
16301               mrdy = msftx(i, j-1)*rdy
16302               tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i&
16303 &                , k, jp1)
16304               tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k&
16305 &                , jp1)
16306             END DO
16307           END DO
16308         ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
16309           DO k=kts,ktf
16310             DO i=i_start,i_end
16311 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
16312               mrdy = msftx(i, j-1)*rdy
16313               tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i&
16314 &                , k, jp0)
16315               tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k&
16316 &                , jp0)
16317             END DO
16318           END DO
16319         ELSE IF (j .GT. j_start) THEN
16320 ! normal code
16321           DO k=kts,ktf
16322             DO i=i_start,i_end
16323 ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
16324               mrdy = msftx(i, j-1)*rdy
16325               tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i&
16326 &                , k, jp1)-fqyd(i, k, jp0))
16327               tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k&
16328 &                , jp1)-fqy(i, k, jp0))
16329             END DO
16330           END DO
16331         END IF
16332       ELSE IF (is .EQ. 1) THEN
16333 ! (j > j_start) will miss the u(,,jds) tendency
16334         IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
16335           DO k=kts,ktf
16336             DO i=i_start,i_end
16337 ! ADT eqn 44, 2nd term on RHS
16338               mrdy = msfux(i, j-1)*rdy
16339               tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i&
16340 &                , k, jp1)
16341               tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k&
16342 &                , jp1)
16343             END DO
16344           END DO
16345         ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
16346 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
16347           DO k=kts,ktf
16348             DO i=i_start,i_end
16349 ! ADT eqn 44, 2nd term on RHS
16350               mrdy = msfux(i, j-1)*rdy
16351               tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i&
16352 &                , k, jp0)
16353               tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k&
16354 &                , jp0)
16355             END DO
16356           END DO
16357         ELSE IF (j .GT. j_start) THEN
16358 ! normal code
16359           DO k=kts,ktf
16360             DO i=i_start,i_end
16361 ! ADT eqn 44, 2nd term on RHS
16362               mrdy = msfux(i, j-1)*rdy
16363               tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i&
16364 &                , k, jp1)-fqyd(i, k, jp0))
16365               tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k&
16366 &                , jp1)-fqy(i, k, jp0))
16367             END DO
16368           END DO
16369         END IF
16370       END IF
16371       jtmp = jp1
16372       jp1 = jp0
16373       jp0 = jtmp
16374     END DO j_loop_y_flux_5
16375 !  next, x - flux divergence
16376     i_start = its
16377     IF (ite .GT. ide - 1) THEN
16378       i_end = ide - 1
16379     ELSE
16380       i_end = ite
16381     END IF
16382     j_start = jts
16383     IF (jte .GT. jde - 1) THEN
16384       j_end = jde - 1
16385     ELSE
16386       j_end = jte
16387     END IF
16388 !  higher order flux has a 5 or 7 point stencil, so compute
16389 !  bounds so we can switch to second order flux close to the boundary
16390     i_start_f = i_start
16391     i_end_f = i_end + 1
16392     IF (degrade_xs) THEN
16393       IF (ids + 1 .LT. its) THEN
16394         i_start = its
16395       ELSE
16396         i_start = ids + 1
16397       END IF
16398       IF (i_start + 2 .GT. ids + 3) THEN
16399         i_start_f = ids + 3
16400       ELSE
16401         i_start_f = i_start + 2
16402       END IF
16403     END IF
16404     IF (degrade_xe) THEN
16405       IF (ide - 2 .GT. ite) THEN
16406         i_end = ite
16407       ELSE
16408         i_end = ide - 2
16409       END IF
16410       i_end_f = ide - 3
16411       fqxd = 0.0
16412     ELSE
16413       fqxd = 0.0
16414     END IF
16415 !  compute fluxes
16416     DO j=j_start,j_end
16417 !  5th or 6th order flux
16418       DO k=kts,ktf
16419         DO i=i_start_f,i_end_f
16420 !          vel = ru(i,k,j)
16421           veld = 0.5*(rud(i, k, j)+rud(i-is, k-ks, j-js))
16422           vel = 0.5*(ru(i, k, j)+ru(i-is, k-ks, j-js))
16423           IF (vel*sign(1,time_step) .GE. 0.0) THEN
16424             qip2d = fieldd(i+1, k, j)
16425             qip2 = field(i+1, k, j)
16426             qip1d = fieldd(i, k, j)
16427             qip1 = field(i, k, j)
16428             qid = fieldd(i-1, k, j)
16429             qi = field(i-1, k, j)
16430             qim1d = fieldd(i-2, k, j)
16431             qim1 = field(i-2, k, j)
16432             qim2d = fieldd(i-3, k, j)
16433             qim2 = field(i-3, k, j)
16434           ELSE
16435             qip2d = fieldd(i-2, k, j)
16436             qip2 = field(i-2, k, j)
16437             qip1d = fieldd(i-1, k, j)
16438             qip1 = field(i-1, k, j)
16439             qid = fieldd(i, k, j)
16440             qi = field(i, k, j)
16441             qim1d = fieldd(i+1, k, j)
16442             qim1 = field(i+1, k, j)
16443             qim2d = fieldd(i+2, k, j)
16444             qim2 = field(i+2, k, j)
16445           END IF
16446           f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
16447           f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
16448           f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
16449           f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
16450           f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
16451           f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
16452           beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*&
16453 &            (qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
16454           beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
16455 &            qi)**2
16456           beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*&
16457 &            (qim1-qip1)*(qim1d-qip1d)/4.
16458           beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
16459           beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*&
16460 &            (qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
16461           beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
16462 &            qi)**2
16463           pwx1d = beta0d
16464           pwx1 = eps + beta0
16465           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
16466 &          THEN
16467             pwr1d = pw*pwx1**(pw-1)*pwx1d
16468           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
16469             pwr1d = pwx1d
16470           ELSE
16471             pwr1d = 0.0
16472           END IF
16473           pwr1 = pwx1**pw
16474           wi0d = -(gi0*pwr1d/pwr1**2)
16475           wi0 = gi0/pwr1
16476           pwx1d = beta1d
16477           pwx1 = eps + beta1
16478           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
16479 &          THEN
16480             pwr1d = pw*pwx1**(pw-1)*pwx1d
16481           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
16482             pwr1d = pwx1d
16483           ELSE
16484             pwr1d = 0.0
16485           END IF
16486           pwr1 = pwx1**pw
16487           wi1d = -(gi1*pwr1d/pwr1**2)
16488           wi1 = gi1/pwr1
16489           pwx1d = beta2d
16490           pwx1 = eps + beta2
16491           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
16492 &          THEN
16493             pwr1d = pw*pwx1**(pw-1)*pwx1d
16494           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
16495             pwr1d = pwx1d
16496           ELSE
16497             pwr1d = 0.0
16498           END IF
16499           pwr1 = pwx1**pw
16500           wi2d = -(gi2*pwr1d/pwr1**2)
16501           wi2 = gi2/pwr1
16502           sumwkd = wi0d + wi1d + wi2d
16503           sumwk = wi0 + wi1 + wi2
16504           fqxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
16505 &            f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*&
16506 &            f1+wi2*f2)*sumwkd)/sumwk**2
16507           fqx(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
16508         END DO
16509       END DO
16510 !          fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j),  &
16511 !                                         field(i-1,k,j), field(i  ,k,j),  &
16512 !                                         field(i+1,k,j), field(i+2,k,j),  &
16513 !                                         vel                             )
16514 !  lower order fluxes close to boundaries (if not periodic or symmetric)
16515       IF (degrade_xs) THEN
16516         DO i=i_start,i_start_f-1
16517           IF (i .EQ. ids + 1) THEN
16518 ! second order
16519             DO k=kts,ktf
16520               fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
16521 &                k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
16522               fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
16523 &                j))
16524             END DO
16525           END IF
16526           IF (i .EQ. ids + 2) THEN
16527 ! third order
16528             DO k=kts,ktf
16529               veld = rud(i, k, j)
16530               vel = ru(i, k, j)
16531               fqxd(i, k) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j)&
16532 &                )-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1., &
16533 &                vel)*(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-3.*(&
16534 &                field(i, k, j)-field(i-1, k, j)))) + vel*(7.*(fieldd(i, &
16535 &                k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k, j)+fieldd(i&
16536 &                -2, k, j))/12.+SIGN(1., vel)*(fieldd(i+1, k, j)-fieldd(i&
16537 &                -2, k, j)-3.*(fieldd(i, k, j)-fieldd(i-1, k, j)))/12.)
16538               fqx(i, k) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-&
16539 &                1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1., vel)&
16540 &                *(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-3.*(field(i&
16541 &                , k, j)-field(i-1, k, j))))
16542             END DO
16543           END IF
16544         END DO
16545       END IF
16546       IF (degrade_xe) THEN
16547         DO i=i_end_f+1,i_end+1
16548           IF (i .EQ. ide - 1) THEN
16549 ! second order flux next to the boundary
16550             DO k=kts,ktf
16551               fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
16552 &                k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
16553               fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
16554 &                j))
16555             END DO
16556           END IF
16557           IF (i .EQ. ide - 2) THEN
16558 ! third order flux one in from the boundary
16559             DO k=kts,ktf
16560               veld = rud(i, k, j)
16561               vel = ru(i, k, j)
16562               fqxd(i, k) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j)&
16563 &                )-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1., &
16564 &                vel)*(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-3.*(&
16565 &                field(i, k, j)-field(i-1, k, j)))) + vel*(7.*(fieldd(i, &
16566 &                k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k, j)+fieldd(i&
16567 &                -2, k, j))/12.+SIGN(1., vel)*(fieldd(i+1, k, j)-fieldd(i&
16568 &                -2, k, j)-3.*(fieldd(i, k, j)-fieldd(i-1, k, j)))/12.)
16569               fqx(i, k) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-&
16570 &                1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1., vel)&
16571 &                *(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-3.*(field(i&
16572 &                , k, j)-field(i-1, k, j))))
16573             END DO
16574           END IF
16575         END DO
16576       END IF
16577 !  x flux-divergence into tendency
16578       IF (is .EQ. 0) THEN
16579         DO k=kts,ktf
16580           DO i=i_start,i_end
16581 ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
16582             mrdx = msftx(i, j)*rdx
16583             tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)&
16584 &              -fqxd(i, k))
16585             tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-&
16586 &              fqx(i, k))
16587           END DO
16588         END DO
16589       ELSE IF (is .EQ. 1) THEN
16590         DO k=kts,ktf
16591           DO i=i_start,i_end
16592 ! ADT eqn 44, 1st term on RHS
16593             mrdx = msfux(i, j)*rdx
16594             tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)&
16595 &              -fqxd(i, k))
16596             tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-&
16597 &              fqx(i, k))
16598           END DO
16599         END DO
16600       END IF
16601     END DO
16602   END IF
16603 !  pick up the rest of the horizontal radiation boundary conditions.
16604 !  (these are the computations that don't require 'cb'.
16605 !  first, set to index ranges
16606   i_start = its
16607   IF (ite .GT. ide - 1) THEN
16608     i_end = ide - 1
16609   ELSE
16610     i_end = ite
16611   END IF
16612   j_start = jts
16613   IF (jte .GT. jde - 1) THEN
16614     j_end = jde - 1
16615   ELSE
16616     j_end = jte
16617   END IF
16618 !  compute x (u) conditions for v, w, or scalar
16619   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
16620     DO j=j_start,j_end
16621       DO k=kts,ktf
16622         IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
16623           ub = 0.
16624           ubd = 0.0
16625         ELSE
16626           ubd = 0.5*(rud(its, k, j)+rud(its+1, k, j))
16627           ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
16628         END IF
16629         tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(&
16630 &          field_old(its+1, k, j)-field_old(its, k, j))+ub*(field_oldd(&
16631 &          its+1, k, j)-field_oldd(its, k, j))+fieldd(its, k, j)*(ru(its+&
16632 &          1, k, j)-ru(its, k, j))+field(its, k, j)*(rud(its+1, k, j)-rud&
16633 &          (its, k, j)))
16634         tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(field_old(&
16635 &          its+1, k, j)-field_old(its, k, j))+field(its, k, j)*(ru(its+1&
16636 &          , k, j)-ru(its, k, j)))
16637       END DO
16638     END DO
16639   END IF
16640   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
16641     DO j=j_start,j_end
16642       DO k=kts,ktf
16643         IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
16644           ub = 0.
16645           ubd = 0.0
16646         ELSE
16647           ubd = 0.5*(rud(ite-1, k, j)+rud(ite, k, j))
16648           ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
16649         END IF
16650         tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
16651 &          field_old(i_end, k, j)-field_old(i_end-1, k, j))+ub*(&
16652 &          field_oldd(i_end, k, j)-field_oldd(i_end-1, k, j))+fieldd(&
16653 &          i_end, k, j)*(ru(ite, k, j)-ru(ite-1, k, j))+field(i_end, k, j&
16654 &          )*(rud(ite, k, j)-rud(ite-1, k, j)))
16655         tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(&
16656 &          field_old(i_end, k, j)-field_old(i_end-1, k, j))+field(i_end, &
16657 &          k, j)*(ru(ite, k, j)-ru(ite-1, k, j)))
16658       END DO
16659     END DO
16660   END IF
16661   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
16662     DO i=i_start,i_end
16663       DO k=kts,ktf
16664         IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
16665           vb = 0.
16666           vbd = 0.0
16667         ELSE
16668           vbd = 0.5*(rvd(i, k, jts)+rvd(i, k, jts+1))
16669           vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
16670         END IF
16671         tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
16672 &          field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
16673 &          , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*(rv(i, k&
16674 &          , jts+1)-rv(i, k, jts))+field(i, k, jts)*(rvd(i, k, jts+1)-rvd&
16675 &          (i, k, jts)))
16676         tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
16677 &          , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*(rv(i, k, &
16678 &          jts+1)-rv(i, k, jts)))
16679       END DO
16680     END DO
16681   END IF
16682   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
16683     DO i=i_start,i_end
16684       DO k=kts,ktf
16685         IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
16686           vb = 0.
16687           vbd = 0.0
16688         ELSE
16689           vbd = 0.5*(rvd(i, k, jte-1)+rvd(i, k, jte))
16690           vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
16691         END IF
16692         tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
16693 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
16694 &          field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))+fieldd(i, k&
16695 &          , j_end)*(rv(i, k, jte)-rv(i, k, jte-1))+field(i, k, j_end)*(&
16696 &          rvd(i, k, jte)-rvd(i, k, jte-1)))
16697         tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
16698 &          field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
16699 &          j_end)*(rv(i, k, jte)-rv(i, k, jte-1)))
16700       END DO
16701     END DO
16702   END IF
16703 !-------------------- vertical advection
16704 !     Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
16705 !     Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
16706 !     So we don't need to make a correction for advect_scalar
16707   i_start = its
16708   IF (ite .GT. ide - 1) THEN
16709     i_end = ide - 1
16710   ELSE
16711     i_end = ite
16712   END IF
16713   j_start = jts
16714   IF (jte .GT. jde - 1) THEN
16715     j_end = jde - 1
16716   ELSE
16717     j_end = jte
16718   END IF
16719   DO i=i_start,i_end
16720     vfluxd(i, kts) = 0.0
16721     vflux(i, kts) = 0.
16722     vfluxd(i, kte) = 0.0
16723     vflux(i, kte) = 0.
16724   END DO
16725   vfluxd = 0.0
16726   DO j=j_start,j_end
16727     DO k=kts+3,ktf-2
16728       DO i=i_start,i_end
16729 !           vel = rom(i,k,j)
16730         veld = 0.5*(romd(i, k, j)+romd(i-is, k-ks, j-js))
16731         vel = 0.5*(rom(i, k, j)+rom(i-is, k-ks, j-js))
16732         IF (-vel*sign(1,time_step) .GE. 0.0) THEN
16733           qip2d = fieldd(i, k+1, j)
16734           qip2 = field(i, k+1, j)
16735           qip1d = fieldd(i, k, j)
16736           qip1 = field(i, k, j)
16737           qid = fieldd(i, k-1, j)
16738           qi = field(i, k-1, j)
16739           qim1d = fieldd(i, k-2, j)
16740           qim1 = field(i, k-2, j)
16741           qim2d = fieldd(i, k-3, j)
16742           qim2 = field(i, k-3, j)
16743         ELSE
16744           qip2d = fieldd(i, k-2, j)
16745           qip2 = field(i, k-2, j)
16746           qip1d = fieldd(i, k-1, j)
16747           qip1 = field(i, k-1, j)
16748           qid = fieldd(i, k, j)
16749           qi = field(i, k, j)
16750           qim1d = fieldd(i, k+1, j)
16751           qim1 = field(i, k+1, j)
16752           qim2d = fieldd(i, k+2, j)
16753           qim2 = field(i, k+2, j)
16754         END IF
16755         f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
16756         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
16757         f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
16758         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
16759         f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
16760         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
16761         beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
16762 &          qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
16763         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
16764 &          )**2
16765         beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
16766 &          qim1-qip1)*(qim1d-qip1d)/4.
16767         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
16768         beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
16769 &          qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
16770         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
16771 &          )**2
16772         pwx1d = beta0d
16773         pwx1 = eps + beta0
16774         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
16775 &        THEN
16776           pwr1d = pw*pwx1**(pw-1)*pwx1d
16777         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
16778           pwr1d = pwx1d
16779         ELSE
16780           pwr1d = 0.0
16781         END IF
16782         pwr1 = pwx1**pw
16783         wi0d = -(gi0*pwr1d/pwr1**2)
16784         wi0 = gi0/pwr1
16785         pwx1d = beta1d
16786         pwx1 = eps + beta1
16787         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
16788 &        THEN
16789           pwr1d = pw*pwx1**(pw-1)*pwx1d
16790         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
16791           pwr1d = pwx1d
16792         ELSE
16793           pwr1d = 0.0
16794         END IF
16795         pwr1 = pwx1**pw
16796         wi1d = -(gi1*pwr1d/pwr1**2)
16797         wi1 = gi1/pwr1
16798         pwx1d = beta2d
16799         pwx1 = eps + beta2
16800         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
16801 &        THEN
16802           pwr1d = pw*pwx1**(pw-1)*pwx1d
16803         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
16804           pwr1d = pwx1d
16805         ELSE
16806           pwr1d = 0.0
16807         END IF
16808         pwr1 = pwx1**pw
16809         wi2d = -(gi2*pwr1d/pwr1**2)
16810         wi2 = gi2/pwr1
16811         sumwkd = wi0d + wi1d + wi2d
16812         sumwk = wi0 + wi1 + wi2
16813         vfluxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
16814 &          f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
16815 &          +wi2*f2)*sumwkd)/sumwk**2
16816         vflux(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
16817       END DO
16818     END DO
16819 !           vflux(i,k) = vel*flux5(                                 &
16820 !                   field(i,k-3,j), field(i,k-2,j), field(i,k-1,j),       &
16821 !                   field(i,k  ,j), field(i,k+1,j), field(i,k+2,j),  -vel )
16822     DO i=i_start,i_end
16823       k = kts + 1
16824       vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
16825 &        , k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*fieldd(&
16826 &        i, k-1, j))
16827       vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i, &
16828 &        k-1, j))
16829       k = kts + 2
16830       veld = romd(i, k, j)
16831       vel = rom(i, k, j)
16832       vfluxd(i, k) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
16833 &        12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1., -vel)*(1./12.)*&
16834 &        (field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-field(i, k&
16835 &        -1, j)))) + vel*(7.*(fieldd(i, k, j)+fieldd(i, k-1, j))/12.-(&
16836 &        fieldd(i, k+1, j)+fieldd(i, k-2, j))/12.+SIGN(1., -vel)*(fieldd(&
16837 &        i, k+1, j)-fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, &
16838 &        j)))/12.)
16839       vflux(i, k) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./12.&
16840 &        *(field(i, k+1, j)+field(i, k-2, j))+SIGN(1., -vel)*(1./12.)*(&
16841 &        field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-field(i, k-&
16842 &        1, j))))
16843       k = ktf - 1
16844       veld = romd(i, k, j)
16845       vel = rom(i, k, j)
16846       vfluxd(i, k) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
16847 &        12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1., -vel)*(1./12.)*&
16848 &        (field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-field(i, k&
16849 &        -1, j)))) + vel*(7.*(fieldd(i, k, j)+fieldd(i, k-1, j))/12.-(&
16850 &        fieldd(i, k+1, j)+fieldd(i, k-2, j))/12.+SIGN(1., -vel)*(fieldd(&
16851 &        i, k+1, j)-fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, &
16852 &        j)))/12.)
16853       vflux(i, k) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./12.&
16854 &        *(field(i, k+1, j)+field(i, k-2, j))+SIGN(1., -vel)*(1./12.)*(&
16855 &        field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-field(i, k-&
16856 &        1, j))))
16857       k = ktf
16858       vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
16859 &        , k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*fieldd(&
16860 &        i, k-1, j))
16861       vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i, &
16862 &        k-1, j))
16863     END DO
16864     DO k=kts,ktf
16865       DO i=i_start,i_end
16866         tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k+1&
16867 &          )-vfluxd(i, k))
16868         tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)-&
16869 &          vflux(i, k))
16870       END DO
16871     END DO
16872   END DO
16873 END SUBROUTINE G_ADVECT_SCALAR_WENO
16874
16875 !        Generated by TAPENADE     (INRIA, Tropics team)
16876 !  Tapenade 3.6 (r4165) - 21 sep 2011 20:54
16877 !
16878 !  Differentiation of advect_weno_u in forward (tangent) mode:
16879 !   variations   of useful results: tendency
16880 !   with respect to varying inputs: rom u tendency u_old ru rv
16881 !                mut
16882 !   RW status of diff variables: rom:in u:in tendency:in-out u_old:in
16883 !                ru:in rv:in mut:in
16884 SUBROUTINE G_ADVECT_WENO_U(u, ud, u_old, u_oldd, tendency, tendencyd, ru&
16885 &  , rud, rv, rvd, rom, romd, mut, mutd, time_step, config_flags, msfux, &
16886 &  msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide&
16887 &  , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte&
16888 &  , kts, kte)
16889   IMPLICIT NONE
16890 ! Input data
16891   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
16892   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
16893 &  jme, kms, kme, its, ite, jts, jte, kts, kte
16894   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u, u_old, ru&
16895 &  , rv, rom
16896   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ud, u_oldd, &
16897 &  rud, rvd, romd
16898   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
16899   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd
16900   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
16901   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
16902   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
16903 &  msfvy, msftx, msfty
16904   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
16905   REAL, INTENT(IN) :: rdx, rdy
16906   INTEGER, INTENT(IN) :: time_step
16907 ! Local data
16908   INTEGER :: i, j, k, itf, jtf, ktf
16909   INTEGER :: i_start, i_end, j_start, j_end
16910   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
16911   INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
16912   INTEGER :: jp1, jp0, jtmp
16913   REAL :: dir, vv
16914   REAL :: ue, vs, vn, wb, wt
16915   REAL, PARAMETER :: f30=7./12., f31=1./12.
16916   REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
16917   INTEGER :: kt, kb
16918   REAL :: qim2, qim1, qi, qip1, qip2
16919   REAL :: qim2d, qim1d, qid, qip1d, qip2d
16920   DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
16921 &  sumwk
16922   DOUBLE PRECISION :: beta0d, beta1d, beta2d, f0d, f1d, f2d, wi0d, wi1d&
16923 &  , wi2d, sumwkd
16924   DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
16925 &    3.d0/10.d0, eps=1.0d-18
16926   INTEGER, PARAMETER :: pw=2
16927   INTEGER :: horz_order, vert_order
16928   REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
16929   REAL :: ubd, vbd, vwd, dvmd, dvpd
16930   REAL, DIMENSION(its:ite, kts:kte) :: vflux
16931   REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
16932   REAL, DIMENSION(its - 1:ite + 1, kts:kte) :: fqx
16933   REAL, DIMENSION(its-1:ite+1, kts:kte) :: fqxd
16934   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
16935   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
16936   LOGICAL :: degrade_xs, degrade_ys
16937   LOGICAL :: degrade_xe, degrade_ye
16938 ! definition of flux operators, 3rd, 4th, 5th or 6th order
16939   REAL :: flux3, flux4, flux5, flux6
16940   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
16941   REAL :: veld
16942   LOGICAL :: specified
16943   DOUBLE PRECISION :: pwx1
16944   DOUBLE PRECISION :: pwx1d
16945   DOUBLE PRECISION :: pwr1
16946   DOUBLE PRECISION :: pwr1d
16947   INTRINSIC MAX
16948   INTRINSIC SIGN
16949   INTRINSIC MIN
16950
16951
16952
16953
16954   specified = .false.
16955   IF (config_flags%specified .OR. config_flags%nested) specified = &
16956 &      .true.
16957 !  set order for vertical and horzontal flux operators
16958   horz_order = config_flags%h_mom_adv_order
16959   vert_order = config_flags%v_mom_adv_order
16960   IF (kte .GT. kde - 1) THEN
16961     ktf = kde - 1
16962   ELSE
16963     ktf = kte
16964   END IF
16965 !  begin with horizontal flux divergence
16966 !   horizontal_order_test : IF( horz_order == 6 ) THEN
16967 !   ELSE IF( horz_order == 5 ) THEN
16968 !  5th order horizontal flux calculation
16969 !  This code is EXACTLY the same as the 6th order code
16970 !  EXCEPT the 5th order and 3rd operators are used in
16971 !  place of the 6th and 4th order operators
16972 !  determine boundary mods for flux operators
16973 !  We degrade the flux operators from 3rd/4th order
16974 !   to second order one gridpoint in from the boundaries for
16975 !   all boundary conditions except periodic and symmetry - these
16976 !   conditions have boundary zone data fill for correct application
16977 !   of the higher order flux stencils
16978   degrade_xs = .true.
16979   degrade_xe = .true.
16980   degrade_ys = .true.
16981   degrade_ye = .true.
16982   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
16983 &      .GT. ids + 3) degrade_xs = .false.
16984   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
16985 &      .LT. ide - 2) degrade_xe = .false.
16986   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
16987 &      .GT. jds + 3) degrade_ys = .false.
16988   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
16989 &      .LT. jde - 4) degrade_ye = .false.
16990 !--------------- y - advection first
16991   i_start = its
16992   i_end = ite
16993   IF (config_flags%open_xs .OR. specified) THEN
16994     IF (ids + 1 .LT. its) THEN
16995       i_start = its
16996     ELSE
16997       i_start = ids + 1
16998     END IF
16999   END IF
17000   IF (config_flags%open_xe .OR. specified) THEN
17001     IF (ide - 1 .GT. ite) THEN
17002       i_end = ite
17003     ELSE
17004       i_end = ide - 1
17005     END IF
17006   END IF
17007   IF (config_flags%periodic_x) i_start = its
17008   IF (config_flags%periodic_x) i_end = ite
17009   j_start = jts
17010   IF (jte .GT. jde - 1) THEN
17011     j_end = jde - 1
17012   ELSE
17013     j_end = jte
17014   END IF
17015 !  higher order flux has a 5 or 7 point stencil, so compute
17016 !  bounds so we can switch to second order flux close to the boundary
17017   j_start_f = j_start
17018   j_end_f = j_end + 1
17019   IF (degrade_ys) THEN
17020     IF (jts .LT. jds + 1) THEN
17021       j_start = jds + 1
17022     ELSE
17023       j_start = jts
17024     END IF
17025     j_start_f = jds + 3
17026   END IF
17027   IF (degrade_ye) THEN
17028     IF (jte .GT. jde - 2) THEN
17029       j_end = jde - 2
17030     ELSE
17031       j_end = jte
17032     END IF
17033     j_end_f = jde - 3
17034   END IF
17035   IF (config_flags%polar) THEN
17036     IF (jte .GT. jde - 1) THEN
17037       j_end = jde - 1
17038     ELSE
17039       j_end = jte
17040     END IF
17041   END IF
17042 !  compute fluxes, 5th or 6th order
17043   jp1 = 2
17044   jp0 = 1
17045   fqyd = 0.0
17046 j_loop_y_flux_5:DO j=j_start,j_end+1
17047     IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
17048 ! use full stencil
17049       DO k=kts,ktf
17050         DO i=i_start,i_end
17051           veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
17052           vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
17053           IF (vel*sign(1,time_step) .GE. 0.0) THEN
17054             qip2d = ud(i, k, j+1)
17055             qip2 = u(i, k, j+1)
17056             qip1d = ud(i, k, j)
17057             qip1 = u(i, k, j)
17058             qid = ud(i, k, j-1)
17059             qi = u(i, k, j-1)
17060             qim1d = ud(i, k, j-2)
17061             qim1 = u(i, k, j-2)
17062             qim2d = ud(i, k, j-3)
17063             qim2 = u(i, k, j-3)
17064           ELSE
17065             qip2d = ud(i, k, j-2)
17066             qip2 = u(i, k, j-2)
17067             qip1d = ud(i, k, j-1)
17068             qip1 = u(i, k, j-1)
17069             qid = ud(i, k, j)
17070             qi = u(i, k, j)
17071             qim1d = ud(i, k, j+1)
17072             qim1 = u(i, k, j+1)
17073             qim2d = ud(i, k, j+2)
17074             qim2 = u(i, k, j+2)
17075           END IF
17076           f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
17077           f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
17078           f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
17079           f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
17080           f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
17081           f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
17082           beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*&
17083 &            (qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
17084           beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
17085 &            qi)**2
17086           beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*&
17087 &            (qim1-qip1)*(qim1d-qip1d)/4.
17088           beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
17089           beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*&
17090 &            (qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
17091           beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
17092 &            qi)**2
17093           pwx1d = beta0d
17094           pwx1 = eps + beta0
17095           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
17096 &          THEN
17097             pwr1d = pw*pwx1**(pw-1)*pwx1d
17098           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
17099             pwr1d = pwx1d
17100           ELSE
17101             pwr1d = 0.0
17102           END IF
17103           pwr1 = pwx1**pw
17104           wi0d = -(gi0*pwr1d/pwr1**2)
17105           wi0 = gi0/pwr1
17106           pwx1d = beta1d
17107           pwx1 = eps + beta1
17108           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
17109 &          THEN
17110             pwr1d = pw*pwx1**(pw-1)*pwx1d
17111           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
17112             pwr1d = pwx1d
17113           ELSE
17114             pwr1d = 0.0
17115           END IF
17116           pwr1 = pwx1**pw
17117           wi1d = -(gi1*pwr1d/pwr1**2)
17118           wi1 = gi1/pwr1
17119           pwx1d = beta2d
17120           pwx1 = eps + beta2
17121           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
17122 &          THEN
17123             pwr1d = pw*pwx1**(pw-1)*pwx1d
17124           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
17125             pwr1d = pwx1d
17126           ELSE
17127             pwr1d = 0.0
17128           END IF
17129           pwr1 = pwx1**pw
17130           wi2d = -(gi2*pwr1d/pwr1**2)
17131           wi2 = gi2/pwr1
17132           sumwkd = wi0d + wi1d + wi2d
17133           sumwk = wi0 + wi1 + wi2
17134           fqyd(i, k, jp1) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+&
17135 &            wi0*f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+&
17136 &            wi1*f1+wi2*f2)*sumwkd)/sumwk**2
17137           fqy(i, k, jp1) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
17138         END DO
17139       END DO
17140     ELSE IF (j .EQ. jds + 1) THEN
17141 !          fqy( i, k, jp1 ) = vel*flux5(               &
17142 !                  u(i,k,j-3), u(i,k,j-2), u(i,k,j-1),       &
17143 !                  u(i,k,j  ), u(i,k,j+1), u(i,k,j+2),  vel )
17144 !  we must be close to some boundary where we need to reduce the order of the stencil
17145 ! 2nd order flux next to south boundary
17146       DO k=kts,ktf
17147         DO i=i_start,i_end
17148           fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, k&
17149 &            , j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, j)+&
17150 &            ud(i, k, j-1)))
17151           fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j)+&
17152 &            u(i, k, j-1))
17153         END DO
17154       END DO
17155     ELSE IF (j .EQ. jds + 2) THEN
17156 ! third of 4th order flux 2 in from south boundary
17157       DO k=kts,ktf
17158         DO i=i_start,i_end
17159           veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
17160           vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
17161           fqyd(i, k, jp1) = veld*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
17162 &            , j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
17163 &            (u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))/&
17164 &            12.0) + vel*((7.*(ud(i, k, j)+ud(i, k, j-1))-ud(i, k, j+1)-&
17165 &            ud(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i, &
17166 &            k, j+1)-ud(i, k, j-2)-3.*(ud(i, k, j)-ud(i, k, j-1)))/12.0)
17167           fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k, j&
17168 &            +1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(&
17169 &            i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))/12.0)
17170         END DO
17171       END DO
17172     ELSE IF (j .EQ. jde - 1) THEN
17173 ! 2nd order flux next to north boundary
17174       DO k=kts,ktf
17175         DO i=i_start,i_end
17176           fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, k&
17177 &            , j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, j)+&
17178 &            ud(i, k, j-1)))
17179           fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j)+&
17180 &            u(i, k, j-1))
17181         END DO
17182       END DO
17183     ELSE IF (j .EQ. jde - 2) THEN
17184 ! 3rd order flux 2 in from north boundary
17185       DO k=kts,ktf
17186         DO i=i_start,i_end
17187           veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
17188           vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
17189           fqyd(i, k, jp1) = veld*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
17190 &            , j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
17191 &            (u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))/&
17192 &            12.0) + vel*((7.*(ud(i, k, j)+ud(i, k, j-1))-ud(i, k, j+1)-&
17193 &            ud(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i, &
17194 &            k, j+1)-ud(i, k, j-2)-3.*(ud(i, k, j)-ud(i, k, j-1)))/12.0)
17195           fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k, j&
17196 &            +1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(&
17197 &            i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))/12.0)
17198         END DO
17199       END DO
17200     END IF
17201 !  y flux-divergence into tendency
17202 ! (j > j_start) will miss the u(,,jds) tendency
17203     IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
17204       DO k=kts,ktf
17205         DO i=i_start,i_end
17206 ! ADT eqn 44, 2nd term on RHS
17207           mrdy = msfux(i, j-1)*rdy
17208           tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k, &
17209 &            jp1)
17210           tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, jp1&
17211 &            )
17212         END DO
17213       END DO
17214     ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
17215 ! This would be seen by (j > j_start) but we need to zero out the NP tendency
17216       DO k=kts,ktf
17217         DO i=i_start,i_end
17218 ! ADT eqn 44, 2nd term on RHS
17219           mrdy = msfux(i, j-1)*rdy
17220           tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k, &
17221 &            jp0)
17222           tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, jp0&
17223 &            )
17224         END DO
17225       END DO
17226     ELSE IF (j .GT. j_start) THEN
17227 ! normal code
17228       DO k=kts,ktf
17229         DO i=i_start,i_end
17230 ! ADT eqn 44, 2nd term on RHS
17231           mrdy = msfux(i, j-1)*rdy
17232           tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, k&
17233 &            , jp1)-fqyd(i, k, jp0))
17234           tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
17235 &            jp1)-fqy(i, k, jp0))
17236         END DO
17237       END DO
17238     END IF
17239     jtmp = jp1
17240     jp1 = jp0
17241     jp0 = jtmp
17242   END DO j_loop_y_flux_5
17243 !  next, x - flux divergence
17244   i_start = its
17245   i_end = ite
17246   j_start = jts
17247   IF (jte .GT. jde - 1) THEN
17248     j_end = jde - 1
17249   ELSE
17250     j_end = jte
17251   END IF
17252 !  higher order flux has a 5 or 7 point stencil, so compute
17253 !  bounds so we can switch to second order flux close to the boundary
17254   i_start_f = i_start
17255   i_end_f = i_end + 1
17256   IF (degrade_xs) THEN
17257     IF (ids + 1 .LT. its) THEN
17258       i_start = its
17259     ELSE
17260       i_start = ids + 1
17261     END IF
17262     i_start_f = ids + 3
17263   END IF
17264   IF (degrade_xe) THEN
17265     IF (ide - 1 .GT. ite) THEN
17266       i_end = ite
17267     ELSE
17268       i_end = ide - 1
17269     END IF
17270     i_end_f = ide - 2
17271     fqxd = 0.0
17272   ELSE
17273     fqxd = 0.0
17274   END IF
17275 !  compute fluxes
17276   DO j=j_start,j_end
17277 !  5th or 6th order flux
17278     DO k=kts,ktf
17279       DO i=i_start_f,i_end_f
17280         veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
17281         vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
17282         IF (vel*sign(1,time_step) .GE. 0.0) THEN
17283           qip2d = ud(i+1, k, j)
17284           qip2 = u(i+1, k, j)
17285           qip1d = ud(i, k, j)
17286           qip1 = u(i, k, j)
17287           qid = ud(i-1, k, j)
17288           qi = u(i-1, k, j)
17289           qim1d = ud(i-2, k, j)
17290           qim1 = u(i-2, k, j)
17291           qim2d = ud(i-3, k, j)
17292           qim2 = u(i-3, k, j)
17293         ELSE
17294           qip2d = ud(i-2, k, j)
17295           qip2 = u(i-2, k, j)
17296           qip1d = ud(i-1, k, j)
17297           qip1 = u(i-1, k, j)
17298           qid = ud(i, k, j)
17299           qi = u(i, k, j)
17300           qim1d = ud(i+1, k, j)
17301           qim1 = u(i+1, k, j)
17302           qim2d = ud(i+2, k, j)
17303           qim2 = u(i+2, k, j)
17304         END IF
17305         f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
17306         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
17307         f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
17308         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
17309         f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
17310         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
17311         beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
17312 &          qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
17313         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
17314 &          )**2
17315         beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
17316 &          qim1-qip1)*(qim1d-qip1d)/4.
17317         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
17318         beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
17319 &          qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
17320         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
17321 &          )**2
17322         pwx1d = beta0d
17323         pwx1 = eps + beta0
17324         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
17325 &        THEN
17326           pwr1d = pw*pwx1**(pw-1)*pwx1d
17327         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
17328           pwr1d = pwx1d
17329         ELSE
17330           pwr1d = 0.0
17331         END IF
17332         pwr1 = pwx1**pw
17333         wi0d = -(gi0*pwr1d/pwr1**2)
17334         wi0 = gi0/pwr1
17335         pwx1d = beta1d
17336         pwx1 = eps + beta1
17337         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
17338 &        THEN
17339           pwr1d = pw*pwx1**(pw-1)*pwx1d
17340         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
17341           pwr1d = pwx1d
17342         ELSE
17343           pwr1d = 0.0
17344         END IF
17345         pwr1 = pwx1**pw
17346         wi1d = -(gi1*pwr1d/pwr1**2)
17347         wi1 = gi1/pwr1
17348         pwx1d = beta2d
17349         pwx1 = eps + beta2
17350         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
17351 &        THEN
17352           pwr1d = pw*pwx1**(pw-1)*pwx1d
17353         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
17354           pwr1d = pwx1d
17355         ELSE
17356           pwr1d = 0.0
17357         END IF
17358         pwr1 = pwx1**pw
17359         wi2d = -(gi2*pwr1d/pwr1**2)
17360         wi2 = gi2/pwr1
17361         sumwkd = wi0d + wi1d + wi2d
17362         sumwk = wi0 + wi1 + wi2
17363         fqxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*f0d+&
17364 &          wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1+wi2&
17365 &          *f2)*sumwkd)/sumwk**2
17366         fqx(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
17367       END DO
17368     END DO
17369 !          fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j),  &
17370 !                                         u(i-1,k,j), u(i  ,k,j),  &
17371 !                                         u(i+1,k,j), u(i+2,k,j),  &
17372 !                                         vel                     )
17373 !  lower order fluxes close to boundaries (if not periodic or symmetric)
17374 !  specified uses upstream normal wind at boundaries
17375     IF (degrade_xs) THEN
17376       IF (i_start .EQ. ids + 1) THEN
17377 ! second order flux next to the boundary
17378         i = ids + 1
17379         DO k=kts,ktf
17380           ubd = ud(i-1, k, j)
17381           ub = u(i-1, k, j)
17382           IF (specified .AND. u(i, k, j) .LT. 0.) THEN
17383             ubd = ud(i, k, j)
17384             ub = u(i, k, j)
17385           END IF
17386           fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i, k, j)+&
17387 &            ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)+ubd))
17388           fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i, k, j)+ub)
17389         END DO
17390       END IF
17391       i = ids + 2
17392       DO k=kts,ktf
17393         veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
17394         vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
17395         fqxd(i, k) = veld*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
17396 &          (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, k&
17397 &          , j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0) + vel*((&
17398 &          7.*(ud(i, k, j)+ud(i-1, k, j))-ud(i+1, k, j)-ud(i-2, k, j))/&
17399 &          12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i+1, k, j)-ud(i-2, k&
17400 &          , j)-3.*(ud(i, k, j)-ud(i-1, k, j)))/12.0)
17401         fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u(i&
17402 &          -2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, k, j&
17403 &          )-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0)
17404       END DO
17405     END IF
17406     IF (degrade_xe) THEN
17407       IF (i_end .EQ. ide - 1) THEN
17408 ! second order flux next to the boundary
17409         i = ide
17410         DO k=kts,ktf
17411           ubd = ud(i, k, j)
17412           ub = u(i, k, j)
17413           IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
17414             ubd = ud(i-1, k, j)
17415             ub = u(i-1, k, j)
17416           END IF
17417           fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i-1, k, j)&
17418 &            +ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i-1, k, j)+ubd))
17419           fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i-1, k, j)+ub)
17420         END DO
17421       END IF
17422       DO k=kts,ktf
17423         i = ide - 1
17424         veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
17425         vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
17426         fqxd(i, k) = veld*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
17427 &          (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, k&
17428 &          , j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0) + vel*((&
17429 &          7.*(ud(i, k, j)+ud(i-1, k, j))-ud(i+1, k, j)-ud(i-2, k, j))/&
17430 &          12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i+1, k, j)-ud(i-2, k&
17431 &          , j)-3.*(ud(i, k, j)-ud(i-1, k, j)))/12.0)
17432         fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u(i&
17433 &          -2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, k, j&
17434 &          )-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0)
17435       END DO
17436     END IF
17437 !  x flux-divergence into tendency
17438     DO k=kts,ktf
17439       DO i=i_start,i_end
17440 ! ADT eqn 44, 1st term on RHS
17441         mrdx = msfux(i, j)*rdx
17442         tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
17443 &          fqxd(i, k))
17444         tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(i&
17445 &          , k))
17446       END DO
17447     END DO
17448   END DO
17449 !  radiative lateral boundary condition in x for normal velocity (u)
17450   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
17451     j_start = jts
17452     IF (jte .GT. jde - 1) THEN
17453       j_end = jde - 1
17454     ELSE
17455       j_end = jte
17456     END IF
17457     DO j=j_start,j_end
17458       DO k=kts,ktf
17459         IF (ru(its, k, j) - cb*mut(its, j) .GT. 0.) THEN
17460           ub = 0.
17461           ubd = 0.0
17462         ELSE
17463           ubd = rud(its, k, j) - cb*mutd(its, j)
17464           ub = ru(its, k, j) - cb*mut(its, j)
17465         END IF
17466         tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(u_old(&
17467 &          its+1, k, j)-u_old(its, k, j))+ub*(u_oldd(its+1, k, j)-u_oldd(&
17468 &          its, k, j)))
17469         tendency(its, k, j) = tendency(its, k, j) - rdx*ub*(u_old(its+1&
17470 &          , k, j)-u_old(its, k, j))
17471       END DO
17472     END DO
17473   END IF
17474   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
17475     j_start = jts
17476     IF (jte .GT. jde - 1) THEN
17477       j_end = jde - 1
17478     ELSE
17479       j_end = jte
17480     END IF
17481     DO j=j_start,j_end
17482       DO k=kts,ktf
17483         IF (ru(ite, k, j) + cb*mut(ite-1, j) .LT. 0.) THEN
17484           ub = 0.
17485           ubd = 0.0
17486         ELSE
17487           ubd = rud(ite, k, j) + cb*mutd(ite-1, j)
17488           ub = ru(ite, k, j) + cb*mut(ite-1, j)
17489         END IF
17490         tendencyd(ite, k, j) = tendencyd(ite, k, j) - rdx*(ubd*(u_old(&
17491 &          ite, k, j)-u_old(ite-1, k, j))+ub*(u_oldd(ite, k, j)-u_oldd(&
17492 &          ite-1, k, j)))
17493         tendency(ite, k, j) = tendency(ite, k, j) - rdx*ub*(u_old(ite, k&
17494 &          , j)-u_old(ite-1, k, j))
17495       END DO
17496     END DO
17497   END IF
17498 !  pick up the rest of the horizontal radiation boundary conditions.
17499 !  (these are the computations that don't require 'cb')
17500 !  first, set to index ranges
17501   i_start = its
17502   IF (ite .GT. ide) THEN
17503     i_end = ide
17504   ELSE
17505     i_end = ite
17506   END IF
17507   imin = ids
17508   imax = ide - 1
17509   IF (config_flags%open_xs) THEN
17510     IF (ids + 1 .LT. its) THEN
17511       i_start = its
17512     ELSE
17513       i_start = ids + 1
17514     END IF
17515     imin = ids
17516   END IF
17517   IF (config_flags%open_xe) THEN
17518     IF (ite .GT. ide - 1) THEN
17519       i_end = ide - 1
17520     ELSE
17521       i_end = ite
17522     END IF
17523     imax = ide - 1
17524   END IF
17525   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
17526     DO i=i_start,i_end
17527 ! ADT eqn 44, 2nd term on RHS
17528       mrdy = msfux(i, jts)*rdy
17529       IF (imax .GT. i) THEN
17530         ip = i
17531       ELSE
17532         ip = imax
17533       END IF
17534       IF (imin .LT. i - 1) THEN
17535         im = i - 1
17536       ELSE
17537         im = imin
17538       END IF
17539       DO k=kts,ktf
17540         vwd = 0.5*(rvd(ip, k, jts)+rvd(im, k, jts))
17541         vw = 0.5*(rv(ip, k, jts)+rv(im, k, jts))
17542         IF (vw .GT. 0.) THEN
17543           vb = 0.
17544           vbd = 0.0
17545         ELSE
17546           vbd = vwd
17547           vb = vw
17548         END IF
17549         dvmd = rvd(ip, k, jts+1) - rvd(ip, k, jts)
17550         dvm = rv(ip, k, jts+1) - rv(ip, k, jts)
17551         dvpd = rvd(im, k, jts+1) - rvd(im, k, jts)
17552         dvp = rv(im, k, jts+1) - rv(im, k, jts)
17553         tendencyd(i, k, jts) = tendencyd(i, k, jts) - mrdy*(vbd*(u_old(i&
17554 &          , k, jts+1)-u_old(i, k, jts))+vb*(u_oldd(i, k, jts+1)-u_oldd(i&
17555 &          , k, jts))+0.5*(ud(i, k, jts)*(dvm+dvp)+u(i, k, jts)*(dvmd+&
17556 &          dvpd)))
17557         tendency(i, k, jts) = tendency(i, k, jts) - mrdy*(vb*(u_old(i, k&
17558 &          , jts+1)-u_old(i, k, jts))+0.5*u(i, k, jts)*(dvm+dvp))
17559       END DO
17560     END DO
17561   END IF
17562   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
17563     DO i=i_start,i_end
17564 ! ADT eqn 44, 2nd term on RHS
17565       mrdy = msfux(i, jte-1)*rdy
17566       IF (imax .GT. i) THEN
17567         ip = i
17568       ELSE
17569         ip = imax
17570       END IF
17571       IF (imin .LT. i - 1) THEN
17572         im = i - 1
17573       ELSE
17574         im = imin
17575       END IF
17576       DO k=kts,ktf
17577         vwd = 0.5*(rvd(ip, k, jte)+rvd(im, k, jte))
17578         vw = 0.5*(rv(ip, k, jte)+rv(im, k, jte))
17579         IF (vw .LT. 0.) THEN
17580           vb = 0.
17581           vbd = 0.0
17582         ELSE
17583           vbd = vwd
17584           vb = vw
17585         END IF
17586         dvmd = rvd(ip, k, jte) - rvd(ip, k, jte-1)
17587         dvm = rv(ip, k, jte) - rv(ip, k, jte-1)
17588         dvpd = rvd(im, k, jte) - rvd(im, k, jte-1)
17589         dvp = rv(im, k, jte) - rv(im, k, jte-1)
17590         tendencyd(i, k, jte-1) = tendencyd(i, k, jte-1) - mrdy*(vbd*(&
17591 &          u_old(i, k, jte-1)-u_old(i, k, jte-2))+vb*(u_oldd(i, k, jte-1)&
17592 &          -u_oldd(i, k, jte-2))+0.5*(ud(i, k, jte-1)*(dvm+dvp)+u(i, k, &
17593 &          jte-1)*(dvmd+dvpd)))
17594         tendency(i, k, jte-1) = tendency(i, k, jte-1) - mrdy*(vb*(u_old(&
17595 &          i, k, jte-1)-u_old(i, k, jte-2))+0.5*u(i, k, jte-1)*(dvm+dvp))
17596       END DO
17597     END DO
17598   END IF
17599 !-------------------- vertical advection
17600 !  ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
17601 !  Here we have:  - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
17602 !  Since 'my' (map scale factor in y-direction) isn't a function of z,
17603 !  this is what we need, so leave unchanged in advect_u
17604   i_start = its
17605   i_end = ite
17606   j_start = jts
17607   IF (jte .GT. jde - 1) THEN
17608     j_end = jde - 1
17609   ELSE
17610     j_end = jte
17611   END IF
17612 !   IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
17613 !   IF ( config_flags%open_xe ) i_end   = MIN(ide-1,ite)
17614   IF (config_flags%open_ys .OR. specified) THEN
17615     IF (ids + 1 .LT. its) THEN
17616       i_start = its
17617     ELSE
17618       i_start = ids + 1
17619     END IF
17620   END IF
17621   IF (config_flags%open_ye .OR. specified) THEN
17622     IF (ide - 1 .GT. ite) THEN
17623       i_end = ite
17624     ELSE
17625       i_end = ide - 1
17626     END IF
17627   END IF
17628   IF (config_flags%periodic_x) i_start = its
17629   IF (config_flags%periodic_x) i_end = ite
17630   DO i=i_start,i_end
17631     vfluxd(i, kts) = 0.0
17632     vflux(i, kts) = 0.
17633     vfluxd(i, kte) = 0.0
17634     vflux(i, kte) = 0.
17635   END DO
17636   vfluxd = 0.0
17637 !   vert_order_test : IF (vert_order == 6) THEN
17638 !    ELSE IF (vert_order == 5) THEN
17639   DO j=j_start,j_end
17640     DO k=kts+3,ktf-2
17641       DO i=i_start,i_end
17642         veld = 0.5*(romd(i-1, k, j)+romd(i, k, j))
17643         vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
17644         IF (-vel*sign(1,time_step) .GE. 0.0) THEN
17645           qip2d = ud(i, k+1, j)
17646           qip2 = u(i, k+1, j)
17647           qip1d = ud(i, k, j)
17648           qip1 = u(i, k, j)
17649           qid = ud(i, k-1, j)
17650           qi = u(i, k-1, j)
17651           qim1d = ud(i, k-2, j)
17652           qim1 = u(i, k-2, j)
17653           qim2d = ud(i, k-3, j)
17654           qim2 = u(i, k-3, j)
17655         ELSE
17656           qip2d = ud(i, k-2, j)
17657           qip2 = u(i, k-2, j)
17658           qip1d = ud(i, k-1, j)
17659           qip1 = u(i, k-1, j)
17660           qid = ud(i, k, j)
17661           qi = u(i, k, j)
17662           qim1d = ud(i, k+1, j)
17663           qim1 = u(i, k+1, j)
17664           qim2d = ud(i, k+2, j)
17665           qim2 = u(i, k+2, j)
17666         END IF
17667         f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
17668         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
17669         f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
17670         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
17671         f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
17672         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
17673         beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
17674 &          qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
17675         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
17676 &          )**2
17677         beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
17678 &          qim1-qip1)*(qim1d-qip1d)/4.
17679         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
17680         beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
17681 &          qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
17682         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
17683 &          )**2
17684         pwx1d = beta0d
17685         pwx1 = eps + beta0
17686         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
17687 &        THEN
17688           pwr1d = pw*pwx1**(pw-1)*pwx1d
17689         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
17690           pwr1d = pwx1d
17691         ELSE
17692           pwr1d = 0.0
17693         END IF
17694         pwr1 = pwx1**pw
17695         wi0d = -(gi0*pwr1d/pwr1**2)
17696         wi0 = gi0/pwr1
17697         pwx1d = beta1d
17698         pwx1 = eps + beta1
17699         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
17700 &        THEN
17701           pwr1d = pw*pwx1**(pw-1)*pwx1d
17702         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
17703           pwr1d = pwx1d
17704         ELSE
17705           pwr1d = 0.0
17706         END IF
17707         pwr1 = pwx1**pw
17708         wi1d = -(gi1*pwr1d/pwr1**2)
17709         wi1 = gi1/pwr1
17710         pwx1d = beta2d
17711         pwx1 = eps + beta2
17712         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
17713 &        THEN
17714           pwr1d = pw*pwx1**(pw-1)*pwx1d
17715         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
17716           pwr1d = pwx1d
17717         ELSE
17718           pwr1d = 0.0
17719         END IF
17720         pwr1 = pwx1**pw
17721         wi2d = -(gi2*pwr1d/pwr1**2)
17722         wi2 = gi2/pwr1
17723         sumwkd = wi0d + wi1d + wi2d
17724         sumwk = wi0 + wi1 + wi2
17725         vfluxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
17726 &          f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
17727 &          +wi2*f2)*sumwkd)/sumwk**2
17728         vflux(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
17729       END DO
17730     END DO
17731 !           vflux(i,k) = vel*flux5(                     &
17732 !                   u(i,k-3,j), u(i,k-2,j), u(i,k-1,j),       &
17733 !                   u(i,k  ,j), u(i,k+1,j), u(i,k+2,j),  -vel )
17734     DO i=i_start,i_end
17735       k = kts + 1
17736       vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i, k&
17737 &        , j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*&
17738 &        ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
17739       vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, j)&
17740 &        +fzp(k)*u(i, k-1, j))
17741       k = kts + 2
17742       veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
17743       vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
17744       vfluxd(i, k) = veld*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
17745 &        (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1, &
17746 &        j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0) + vel*((7.*(&
17747 &        ud(i, k, j)+ud(i, k-1, j))-ud(i, k+1, j)-ud(i, k-2, j))/12.0+&
17748 &        SIGN(1, time_step)*SIGN(1., -vel)*(ud(i, k+1, j)-ud(i, k-2, j)-&
17749 &        3.*(ud(i, k, j)-ud(i, k-1, j)))/12.0)
17750       vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u(i&
17751 &        , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1, j)&
17752 &        -u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0)
17753       k = ktf - 1
17754       veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
17755       vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
17756       vfluxd(i, k) = veld*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
17757 &        (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1, &
17758 &        j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0) + vel*((7.*(&
17759 &        ud(i, k, j)+ud(i, k-1, j))-ud(i, k+1, j)-ud(i, k-2, j))/12.0+&
17760 &        SIGN(1, time_step)*SIGN(1., -vel)*(ud(i, k+1, j)-ud(i, k-2, j)-&
17761 &        3.*(ud(i, k, j)-ud(i, k-1, j)))/12.0)
17762       vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u(i&
17763 &        , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1, j)&
17764 &        -u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0)
17765       k = ktf
17766       vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i, k&
17767 &        , j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*&
17768 &        ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
17769       vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, j)&
17770 &        +fzp(k)*u(i, k-1, j))
17771     END DO
17772     DO k=kts,ktf
17773       DO i=i_start,i_end
17774         tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k+1&
17775 &          )-vfluxd(i, k))
17776         tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)-&
17777 &          vflux(i, k))
17778       END DO
17779     END DO
17780   END DO
17781 END SUBROUTINE G_ADVECT_WENO_U
17782
17783 !        Generated by TAPENADE     (INRIA, Tropics team)
17784 !  Tapenade 3.6 (r4165) - 21 sep 2011 20:54
17785 !
17786 !  Differentiation of advect_weno_v in forward (tangent) mode:
17787 !   variations   of useful results: tendency
17788 !   with respect to varying inputs: rom tendency v v_old ru rv
17789 !                mut
17790 !   RW status of diff variables: rom:in tendency:in-out v:in v_old:in
17791 !                ru:in rv:in mut:in
17792 SUBROUTINE G_ADVECT_WENO_V(v, vd, v_old, v_oldd, tendency, tendencyd, ru&
17793 &  , rud, rv, rvd, rom, romd, mut, mutd, time_step, config_flags, msfux, &
17794 &  msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide&
17795 &  , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte&
17796 &  , kts, kte)
17797   IMPLICIT NONE
17798 ! Input data
17799   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
17800   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
17801 &  jme, kms, kme, its, ite, jts, jte, kts, kte
17802   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: v, v_old, ru&
17803 &  , rv, rom
17804   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: vd, v_oldd, &
17805 &  rud, rvd, romd
17806   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
17807   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd
17808   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
17809   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
17810   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
17811 &  msfvy, msftx, msfty
17812   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
17813   REAL, INTENT(IN) :: rdx, rdy
17814   INTEGER, INTENT(IN) :: time_step
17815 ! Local data
17816   INTEGER :: i, j, k, itf, jtf, ktf
17817   INTEGER :: i_start, i_end, j_start, j_end
17818   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
17819   INTEGER :: jmin, jmax, jp, jm, imin, imax
17820   REAL :: dir, vv
17821   REAL :: ue, vs, vn, wb, wt
17822   REAL, PARAMETER :: f30=7./12., f31=1./12.
17823   REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
17824   INTEGER :: kt, kb
17825   REAL :: qim2, qim1, qi, qip1, qip2
17826   REAL :: qim2d, qim1d, qid, qip1d, qip2d
17827   DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
17828 &  sumwk
17829   DOUBLE PRECISION :: beta0d, beta1d, beta2d, f0d, f1d, f2d, wi0d, wi1d&
17830 &  , wi2d, sumwkd
17831   DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
17832 &    3.d0/10.d0, eps=1.0d-18
17833   INTEGER, PARAMETER :: pw=2
17834   REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
17835   REAL :: ubd, vbd, uwd, dupd, dumd
17836   REAL, DIMENSION(its:ite, kts:kte) :: vflux
17837   REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
17838   REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
17839   REAL, DIMENSION(its:ite+1, kts:kte) :: fqxd
17840   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
17841   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
17842   INTEGER :: horz_order
17843   INTEGER :: vert_order
17844   LOGICAL :: degrade_xs, degrade_ys
17845   LOGICAL :: degrade_xe, degrade_ye
17846   INTEGER :: jp1, jp0, jtmp
17847 ! definition of flux operators, 3rd, 4th, 5th or 6th order
17848   REAL :: flux3, flux4, flux5, flux6
17849   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
17850   REAL :: veld
17851   LOGICAL :: specified
17852   DOUBLE PRECISION :: pwx1
17853   DOUBLE PRECISION :: pwx1d
17854   DOUBLE PRECISION :: pwr1
17855   DOUBLE PRECISION :: pwr1d
17856   INTRINSIC MAX
17857   INTRINSIC SIGN
17858   INTRINSIC MIN
17859
17860
17861
17862
17863   specified = .false.
17864   IF (config_flags%specified .OR. config_flags%nested) specified = &
17865 &      .true.
17866   IF (kte .GT. kde - 1) THEN
17867     ktf = kde - 1
17868   ELSE
17869     ktf = kte
17870   END IF
17871   horz_order = config_flags%h_mom_adv_order
17872   vert_order = config_flags%v_mom_adv_order
17873 !  here is the choice of flux operators
17874 !   horizontal_order_test : IF( horz_order == 6 ) THEN
17875 !   ELSE IF( horz_order == 5 ) THEN
17876 !  5th order horizontal flux calculation
17877 !  This code is EXACTLY the same as the 6th order code
17878 !  EXCEPT the 5th order and 3rd operators are used in
17879 !  place of the 6th and 4th order operators
17880 !  determine boundary mods for flux operators
17881 !  We degrade the flux operators from 3rd/4th order
17882 !   to second order one gridpoint in from the boundaries for
17883 !   all boundary conditions except periodic and symmetry - these
17884 !   conditions have boundary zone data fill for correct application
17885 !   of the higher order flux stencils
17886   degrade_xs = .true.
17887   degrade_xe = .true.
17888   degrade_ys = .true.
17889   degrade_ye = .true.
17890   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
17891 &      .GT. ids + 3) degrade_xs = .false.
17892   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
17893 &      .LT. ide - 3) degrade_xe = .false.
17894   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
17895 &      .GT. jds + 3) degrade_ys = .false.
17896   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
17897 &      .LT. jde - 3) degrade_ye = .false.
17898 !--------------- y - advection first
17899   i_start = its
17900   IF (ite .GT. ide - 1) THEN
17901     i_end = ide - 1
17902   ELSE
17903     i_end = ite
17904   END IF
17905   j_start = jts
17906   j_end = jte
17907 !  higher order flux has a 5 or 7 point stencil, so compute
17908 !  bounds so we can switch to second order flux close to the boundary
17909   j_start_f = j_start
17910   j_end_f = j_end + 1
17911   IF (degrade_ys) THEN
17912     IF (jts .LT. jds + 1) THEN
17913       j_start = jds + 1
17914     ELSE
17915       j_start = jts
17916     END IF
17917     j_start_f = jds + 3
17918   END IF
17919   IF (degrade_ye) THEN
17920     IF (jte .GT. jde - 1) THEN
17921       j_end = jde - 1
17922     ELSE
17923       j_end = jte
17924     END IF
17925     j_end_f = jde - 2
17926   END IF
17927 !  compute fluxes, 5th or 6th order
17928   jp1 = 2
17929   jp0 = 1
17930   fqyd = 0.0
17931 j_loop_y_flux_5:DO j=j_start,j_end+1
17932     IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
17933       DO k=kts,ktf
17934         DO i=i_start,i_end
17935           veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
17936           vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
17937           IF (vel*sign(1,time_step) .GE. 0.0) THEN
17938             qip2d = vd(i, k, j+1)
17939             qip2 = v(i, k, j+1)
17940             qip1d = vd(i, k, j)
17941             qip1 = v(i, k, j)
17942             qid = vd(i, k, j-1)
17943             qi = v(i, k, j-1)
17944             qim1d = vd(i, k, j-2)
17945             qim1 = v(i, k, j-2)
17946             qim2d = vd(i, k, j-3)
17947             qim2 = v(i, k, j-3)
17948           ELSE
17949             qip2d = vd(i, k, j-2)
17950             qip2 = v(i, k, j-2)
17951             qip1d = vd(i, k, j-1)
17952             qip1 = v(i, k, j-1)
17953             qid = vd(i, k, j)
17954             qi = v(i, k, j)
17955             qim1d = vd(i, k, j+1)
17956             qim1 = v(i, k, j+1)
17957             qim2d = vd(i, k, j+2)
17958             qim2 = v(i, k, j+2)
17959           END IF
17960           f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
17961           f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
17962           f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
17963           f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
17964           f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
17965           f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
17966           beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*&
17967 &            (qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
17968           beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
17969 &            qi)**2
17970           beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*&
17971 &            (qim1-qip1)*(qim1d-qip1d)/4.
17972           beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
17973           beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*&
17974 &            (qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
17975           beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
17976 &            qi)**2
17977           pwx1d = beta0d
17978           pwx1 = eps + beta0
17979           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
17980 &          THEN
17981             pwr1d = pw*pwx1**(pw-1)*pwx1d
17982           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
17983             pwr1d = pwx1d
17984           ELSE
17985             pwr1d = 0.0
17986           END IF
17987           pwr1 = pwx1**pw
17988           wi0d = -(gi0*pwr1d/pwr1**2)
17989           wi0 = gi0/pwr1
17990           pwx1d = beta1d
17991           pwx1 = eps + beta1
17992           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
17993 &          THEN
17994             pwr1d = pw*pwx1**(pw-1)*pwx1d
17995           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
17996             pwr1d = pwx1d
17997           ELSE
17998             pwr1d = 0.0
17999           END IF
18000           pwr1 = pwx1**pw
18001           wi1d = -(gi1*pwr1d/pwr1**2)
18002           wi1 = gi1/pwr1
18003           pwx1d = beta2d
18004           pwx1 = eps + beta2
18005           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
18006 &          THEN
18007             pwr1d = pw*pwx1**(pw-1)*pwx1d
18008           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
18009             pwr1d = pwx1d
18010           ELSE
18011             pwr1d = 0.0
18012           END IF
18013           pwr1 = pwx1**pw
18014           wi2d = -(gi2*pwr1d/pwr1**2)
18015           wi2 = gi2/pwr1
18016           sumwkd = wi0d + wi1d + wi2d
18017           sumwk = wi0 + wi1 + wi2
18018           fqyd(i, k, jp1) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+&
18019 &            wi0*f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+&
18020 &            wi1*f1+wi2*f2)*sumwkd)/sumwk**2
18021           fqy(i, k, jp1) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
18022         END DO
18023       END DO
18024     ELSE IF (j .EQ. jds + 1) THEN
18025 !          fqy( i, k, jp1 ) = vel*flux5(               &
18026 !                  v(i,k,j-3), v(i,k,j-2), v(i,k,j-1),       &
18027 !                  v(i,k,j  ), v(i,k,j+1), v(i,k,j+2),  vel )
18028 !  we must be close to some boundary where we need to reduce the order of the stencil
18029 !  specified uses upstream normal wind at boundaries
18030 ! 2nd order flux next to south boundary
18031       DO k=kts,ktf
18032         DO i=i_start,i_end
18033           vbd = vd(i, k, j-1)
18034           vb = v(i, k, j-1)
18035           IF (specified .AND. v(i, k, j) .LT. 0.) THEN
18036             vbd = vd(i, k, j)
18037             vb = v(i, k, j)
18038           END IF
18039           fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(v(i, k&
18040 &            , j)+vb)+(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)+vbd))
18041           fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(v(i, k, j)+&
18042 &            vb)
18043         END DO
18044       END DO
18045     ELSE IF (j .EQ. jds + 2) THEN
18046 ! third of 4th order flux 2 in from south boundary
18047       DO k=kts,ktf
18048         DO i=i_start,i_end
18049           veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
18050           vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
18051           fqyd(i, k, jp1) = veld*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
18052 &            , j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
18053 &            (v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))/&
18054 &            12.0) + vel*((7.*(vd(i, k, j)+vd(i, k, j-1))-vd(i, k, j+1)-&
18055 &            vd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(vd(i, &
18056 &            k, j+1)-vd(i, k, j-2)-3.*(vd(i, k, j)-vd(i, k, j-1)))/12.0)
18057           fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k, j&
18058 &            +1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(&
18059 &            i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))/12.0)
18060         END DO
18061       END DO
18062     ELSE IF (j .EQ. jde) THEN
18063 ! 2nd order flux next to north boundary
18064       DO k=kts,ktf
18065         DO i=i_start,i_end
18066           vbd = vd(i, k, j)
18067           vb = v(i, k, j)
18068           IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
18069             vbd = vd(i, k, j-1)
18070             vb = v(i, k, j-1)
18071           END IF
18072           fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(vb+v(i&
18073 &            , k, j-1))+(rv(i, k, j)+rv(i, k, j-1))*(vbd+vd(i, k, j-1)))
18074           fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(vb+v(i, k, &
18075 &            j-1))
18076         END DO
18077       END DO
18078     ELSE IF (j .EQ. jde - 1) THEN
18079 ! 3rd or 4th order flux 2 in from north boundary
18080       DO k=kts,ktf
18081         DO i=i_start,i_end
18082           veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
18083           vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
18084           fqyd(i, k, jp1) = veld*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
18085 &            , j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
18086 &            (v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))/&
18087 &            12.0) + vel*((7.*(vd(i, k, j)+vd(i, k, j-1))-vd(i, k, j+1)-&
18088 &            vd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(vd(i, &
18089 &            k, j+1)-vd(i, k, j-2)-3.*(vd(i, k, j)-vd(i, k, j-1)))/12.0)
18090           fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k, j&
18091 &            +1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(&
18092 &            i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))/12.0)
18093         END DO
18094       END DO
18095     END IF
18096 !  y flux-divergence into tendency
18097 ! Comments on polar boundary conditions
18098 ! No advection over the poles means tendencies (held from jds [S. pole]
18099 ! to jde [N pole], i.e., on v grid) must be zero at poles
18100 ! [tendency(jds) and tendency(jde)=0]
18101     IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
18102       DO k=kts,ktf
18103         DO i=i_start,i_end
18104           tendencyd(i, k, j-1) = 0.0
18105           tendency(i, k, j-1) = 0.
18106         END DO
18107       END DO
18108     ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
18109 ! If j_end were set to jde in a special if statement apart from
18110 ! degrade_ye, then we would hit the next conditional.  But since
18111 ! we want the tendency to be zero anyway, not looping to jde+1
18112 ! will produce the same effect.
18113       DO k=kts,ktf
18114         DO i=i_start,i_end
18115           tendencyd(i, k, j-1) = 0.0
18116           tendency(i, k, j-1) = 0.
18117         END DO
18118       END DO
18119     ELSE IF (j .GT. j_start) THEN
18120 ! Normal code
18121       DO k=kts,ktf
18122         DO i=i_start,i_end
18123 ! ADT eqn 45, 2nd term on RHS
18124           mrdy = msfvy(i, j-1)*rdy
18125           tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, k&
18126 &            , jp1)-fqyd(i, k, jp0))
18127           tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
18128 &            jp1)-fqy(i, k, jp0))
18129         END DO
18130       END DO
18131     END IF
18132     jtmp = jp1
18133     jp1 = jp0
18134     jp0 = jtmp
18135   END DO j_loop_y_flux_5
18136 !  next, x - flux divergence
18137   i_start = its
18138   IF (ite .GT. ide - 1) THEN
18139     i_end = ide - 1
18140   ELSE
18141     i_end = ite
18142   END IF
18143   j_start = jts
18144   j_end = jte
18145 ! Polar boundary conditions are like open or specified
18146   IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
18147 &  THEN
18148     IF (jds + 1 .LT. jts) THEN
18149       j_start = jts
18150     ELSE
18151       j_start = jds + 1
18152     END IF
18153   END IF
18154   IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
18155 &  THEN
18156     IF (jde - 1 .GT. jte) THEN
18157       j_end = jte
18158     ELSE
18159       j_end = jde - 1
18160     END IF
18161   END IF
18162 !  higher order flux has a 5 or 7 point stencil, so compute
18163 !  bounds so we can switch to second order flux close to the boundary
18164   i_start_f = i_start
18165   i_end_f = i_end + 1
18166   IF (degrade_xs) THEN
18167     IF (ids + 1 .LT. its) THEN
18168       i_start = its
18169     ELSE
18170       i_start = ids + 1
18171     END IF
18172     IF (i_start + 2 .GT. ids + 3) THEN
18173       i_start_f = ids + 3
18174     ELSE
18175       i_start_f = i_start + 2
18176     END IF
18177   END IF
18178   IF (degrade_xe) THEN
18179     IF (ide - 2 .GT. ite) THEN
18180       i_end = ite
18181     ELSE
18182       i_end = ide - 2
18183     END IF
18184     i_end_f = ide - 3
18185     fqxd = 0.0
18186   ELSE
18187     fqxd = 0.0
18188   END IF
18189 !  compute fluxes
18190   DO j=j_start,j_end
18191 !  5th or 6th order flux
18192     DO k=kts,ktf
18193       DO i=i_start_f,i_end_f
18194         veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
18195         vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
18196         IF (vel*sign(1,time_step) .GE. 0.0) THEN
18197           qip2d = vd(i+1, k, j)
18198           qip2 = v(i+1, k, j)
18199           qip1d = vd(i, k, j)
18200           qip1 = v(i, k, j)
18201           qid = vd(i-1, k, j)
18202           qi = v(i-1, k, j)
18203           qim1d = vd(i-2, k, j)
18204           qim1 = v(i-2, k, j)
18205           qim2d = vd(i-3, k, j)
18206           qim2 = v(i-3, k, j)
18207         ELSE
18208           qip2d = vd(i-2, k, j)
18209           qip2 = v(i-2, k, j)
18210           qip1d = vd(i-1, k, j)
18211           qip1 = v(i-1, k, j)
18212           qid = vd(i, k, j)
18213           qi = v(i, k, j)
18214           qim1d = vd(i+1, k, j)
18215           qim1 = v(i+1, k, j)
18216           qim2d = vd(i+2, k, j)
18217           qim2 = v(i+2, k, j)
18218         END IF
18219         f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
18220         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
18221         f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
18222         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
18223         f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
18224         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
18225         beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
18226 &          qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
18227         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
18228 &          )**2
18229         beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
18230 &          qim1-qip1)*(qim1d-qip1d)/4.
18231         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
18232         beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
18233 &          qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
18234         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
18235 &          )**2
18236         pwx1d = beta0d
18237         pwx1 = eps + beta0
18238         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
18239 &        THEN
18240           pwr1d = pw*pwx1**(pw-1)*pwx1d
18241         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
18242           pwr1d = pwx1d
18243         ELSE
18244           pwr1d = 0.0
18245         END IF
18246         pwr1 = pwx1**pw
18247         wi0d = -(gi0*pwr1d/pwr1**2)
18248         wi0 = gi0/pwr1
18249         pwx1d = beta1d
18250         pwx1 = eps + beta1
18251         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
18252 &        THEN
18253           pwr1d = pw*pwx1**(pw-1)*pwx1d
18254         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
18255           pwr1d = pwx1d
18256         ELSE
18257           pwr1d = 0.0
18258         END IF
18259         pwr1 = pwx1**pw
18260         wi1d = -(gi1*pwr1d/pwr1**2)
18261         wi1 = gi1/pwr1
18262         pwx1d = beta2d
18263         pwx1 = eps + beta2
18264         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
18265 &        THEN
18266           pwr1d = pw*pwx1**(pw-1)*pwx1d
18267         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
18268           pwr1d = pwx1d
18269         ELSE
18270           pwr1d = 0.0
18271         END IF
18272         pwr1 = pwx1**pw
18273         wi2d = -(gi2*pwr1d/pwr1**2)
18274         wi2 = gi2/pwr1
18275         sumwkd = wi0d + wi1d + wi2d
18276         sumwk = wi0 + wi1 + wi2
18277         fqxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*f0d+&
18278 &          wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1+wi2&
18279 &          *f2)*sumwkd)/sumwk**2
18280         fqx(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
18281       END DO
18282     END DO
18283 !          fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j),  &
18284 !                                         v(i-1,k,j), v(i  ,k,j),  &
18285 !                                         v(i+1,k,j), v(i+2,k,j),  &
18286 !                                         vel                     )
18287 !  lower order fluxes close to boundaries (if not periodic or symmetric)
18288     IF (degrade_xs) THEN
18289       DO i=i_start,i_start_f-1
18290         IF (i .EQ. ids + 1) THEN
18291 ! second order
18292           DO k=kts,ktf
18293             fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i, k, j-1))*(v(i, k, j)&
18294 &              +v(i-1, k, j))+(ru(i, k, j)+ru(i, k, j-1))*(vd(i, k, j)+vd&
18295 &              (i-1, k, j)))
18296             fqx(i, k) = 0.25*(ru(i, k, j)+ru(i, k, j-1))*(v(i, k, j)+v(i&
18297 &              -1, k, j))
18298           END DO
18299         END IF
18300         IF (i .EQ. ids + 2) THEN
18301 ! third order
18302           DO k=kts,ktf
18303             veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
18304             vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
18305             fqxd(i, k) = veld*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
18306 &              j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v&
18307 &              (i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/&
18308 &              12.0) + vel*((7.*(vd(i, k, j)+vd(i-1, k, j))-vd(i+1, k, j)&
18309 &              -vd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(vd(&
18310 &              i+1, k, j)-vd(i-2, k, j)-3.*(vd(i, k, j)-vd(i-1, k, j)))/&
18311 &              12.0)
18312             fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)&
18313 &              +v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(i&
18314 &              +1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/12.0)
18315           END DO
18316         END IF
18317       END DO
18318     END IF
18319     IF (degrade_xe) THEN
18320       DO i=i_end_f+1,i_end+1
18321         IF (i .EQ. ide - 1) THEN
18322 ! second order flux next to the boundary
18323           DO k=kts,ktf
18324             fqxd(i, k) = 0.25*((rud(i_end+1, k, j)+rud(i_end+1, k, j-1))&
18325 &              *(v(i_end+1, k, j)+v(i_end, k, j))+(ru(i_end+1, k, j)+ru(&
18326 &              i_end+1, k, j-1))*(vd(i_end+1, k, j)+vd(i_end, k, j)))
18327             fqx(i, k) = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*(v(&
18328 &              i_end+1, k, j)+v(i_end, k, j))
18329           END DO
18330         END IF
18331         IF (i .EQ. ide - 2) THEN
18332 ! third order flux one in from the boundary
18333           DO k=kts,ktf
18334             veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
18335             vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
18336             fqxd(i, k) = veld*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
18337 &              j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v&
18338 &              (i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/&
18339 &              12.0) + vel*((7.*(vd(i, k, j)+vd(i-1, k, j))-vd(i+1, k, j)&
18340 &              -vd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(vd(&
18341 &              i+1, k, j)-vd(i-2, k, j)-3.*(vd(i, k, j)-vd(i-1, k, j)))/&
18342 &              12.0)
18343             fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)&
18344 &              +v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(i&
18345 &              +1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/12.0)
18346           END DO
18347         END IF
18348       END DO
18349     END IF
18350 !  x flux-divergence into tendency
18351     DO k=kts,ktf
18352       DO i=i_start,i_end
18353 ! ADT eqn 45, 1st term on RHS
18354         mrdx = msfvy(i, j)*rdx
18355         tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
18356 &          fqxd(i, k))
18357         tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(i&
18358 &          , k))
18359       END DO
18360     END DO
18361   END DO
18362 !  Comments on polar boundary condition
18363 !  Force tendency=0 at NP and SP
18364 !  We keep setting this everywhere, but it can't hurt...
18365   IF (config_flags%polar .AND. jts .EQ. jds) THEN
18366     DO i=its,ite
18367       DO k=kts,ktf
18368         tendencyd(i, k, jts) = 0.0
18369         tendency(i, k, jts) = 0.
18370       END DO
18371     END DO
18372   END IF
18373   IF (config_flags%polar .AND. jte .EQ. jde) THEN
18374     DO i=its,ite
18375       DO k=kts,ktf
18376         tendencyd(i, k, jte) = 0.0
18377         tendency(i, k, jte) = 0.
18378       END DO
18379     END DO
18380   END IF
18381 !  radiative lateral boundary condition in y for normal velocity (v)
18382   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
18383     i_start = its
18384     IF (ite .GT. ide - 1) THEN
18385       i_end = ide - 1
18386     ELSE
18387       i_end = ite
18388     END IF
18389     DO i=i_start,i_end
18390       DO k=kts,ktf
18391         IF (rv(i, k, jts) - cb*mut(i, jts) .GT. 0.) THEN
18392           vb = 0.
18393           vbd = 0.0
18394         ELSE
18395           vbd = rvd(i, k, jts) - cb*mutd(i, jts)
18396           vb = rv(i, k, jts) - cb*mut(i, jts)
18397         END IF
18398         tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(v_old(i&
18399 &          , k, jts+1)-v_old(i, k, jts))+vb*(v_oldd(i, k, jts+1)-v_oldd(i&
18400 &          , k, jts)))
18401         tendency(i, k, jts) = tendency(i, k, jts) - rdy*vb*(v_old(i, k, &
18402 &          jts+1)-v_old(i, k, jts))
18403       END DO
18404     END DO
18405   END IF
18406   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
18407     i_start = its
18408     IF (ite .GT. ide - 1) THEN
18409       i_end = ide - 1
18410     ELSE
18411       i_end = ite
18412     END IF
18413     DO i=i_start,i_end
18414       DO k=kts,ktf
18415         IF (rv(i, k, jte) + cb*mut(i, jte-1) .LT. 0.) THEN
18416           vb = 0.
18417           vbd = 0.0
18418         ELSE
18419           vbd = rvd(i, k, jte) + cb*mutd(i, jte-1)
18420           vb = rv(i, k, jte) + cb*mut(i, jte-1)
18421         END IF
18422         tendencyd(i, k, jte) = tendencyd(i, k, jte) - rdy*(vbd*(v_old(i&
18423 &          , k, jte)-v_old(i, k, jte-1))+vb*(v_oldd(i, k, jte)-v_oldd(i, &
18424 &          k, jte-1)))
18425         tendency(i, k, jte) = tendency(i, k, jte) - rdy*vb*(v_old(i, k, &
18426 &          jte)-v_old(i, k, jte-1))
18427       END DO
18428     END DO
18429   END IF
18430 !  pick up the rest of the horizontal radiation boundary conditions.
18431 !  (these are the computations that don't require 'cb'.
18432 !  first, set to index ranges
18433   j_start = jts
18434   IF (jte .GT. jde) THEN
18435     j_end = jde
18436   ELSE
18437     j_end = jte
18438   END IF
18439   jmin = jds
18440   jmax = jde - 1
18441   IF (config_flags%open_ys) THEN
18442     IF (jds + 1 .LT. jts) THEN
18443       j_start = jts
18444     ELSE
18445       j_start = jds + 1
18446     END IF
18447     jmin = jds
18448   END IF
18449   IF (config_flags%open_ye) THEN
18450     IF (jte .GT. jde - 1) THEN
18451       j_end = jde - 1
18452     ELSE
18453       j_end = jte
18454     END IF
18455     jmax = jde - 1
18456   END IF
18457 !  compute x (u) conditions for v, w, or scalar
18458   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
18459     DO j=j_start,j_end
18460 ! ADT eqn 45, 1st term on RHS
18461       mrdx = msfvy(its, j)*rdx
18462       IF (jmax .GT. j) THEN
18463         jp = j
18464       ELSE
18465         jp = jmax
18466       END IF
18467       IF (jmin .LT. j - 1) THEN
18468         jm = j - 1
18469       ELSE
18470         jm = jmin
18471       END IF
18472       DO k=kts,ktf
18473         uwd = 0.5*(rud(its, k, jp)+rud(its, k, jm))
18474         uw = 0.5*(ru(its, k, jp)+ru(its, k, jm))
18475         IF (uw .GT. 0.) THEN
18476           ub = 0.
18477           ubd = 0.0
18478         ELSE
18479           ubd = uwd
18480           ub = uw
18481         END IF
18482         dupd = rud(its+1, k, jp) - rud(its, k, jp)
18483         dup = ru(its+1, k, jp) - ru(its, k, jp)
18484         dumd = rud(its+1, k, jm) - rud(its, k, jm)
18485         dum = ru(its+1, k, jm) - ru(its, k, jm)
18486         tendencyd(its, k, j) = tendencyd(its, k, j) - mrdx*(ubd*(v_old(&
18487 &          its+1, k, j)-v_old(its, k, j))+ub*(v_oldd(its+1, k, j)-v_oldd(&
18488 &          its, k, j))+0.5*(vd(its, k, j)*(dup+dum)+v(its, k, j)*(dupd+&
18489 &          dumd)))
18490         tendency(its, k, j) = tendency(its, k, j) - mrdx*(ub*(v_old(its+&
18491 &          1, k, j)-v_old(its, k, j))+0.5*v(its, k, j)*(dup+dum))
18492       END DO
18493     END DO
18494   END IF
18495   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
18496     DO j=j_start,j_end
18497 ! ADT eqn 45, 1st term on RHS
18498       mrdx = msfvy(ite-1, j)*rdx
18499       IF (jmax .GT. j) THEN
18500         jp = j
18501       ELSE
18502         jp = jmax
18503       END IF
18504       IF (jmin .LT. j - 1) THEN
18505         jm = j - 1
18506       ELSE
18507         jm = jmin
18508       END IF
18509       DO k=kts,ktf
18510         uwd = 0.5*(rud(ite, k, jp)+rud(ite, k, jm))
18511         uw = 0.5*(ru(ite, k, jp)+ru(ite, k, jm))
18512         IF (uw .LT. 0.) THEN
18513           ub = 0.
18514           ubd = 0.0
18515         ELSE
18516           ubd = uwd
18517           ub = uw
18518         END IF
18519         dupd = rud(ite, k, jp) - rud(ite-1, k, jp)
18520         dup = ru(ite, k, jp) - ru(ite-1, k, jp)
18521         dumd = rud(ite, k, jm) - rud(ite-1, k, jm)
18522         dum = ru(ite, k, jm) - ru(ite-1, k, jm)
18523 !          tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*(              &
18524 !                            ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j))    &
18525 !                           +0.5*v(ite-1,k,j)*                         &
18526 !                                  ( ru(ite,k,jp)-ru(ite-1,k,jp)       &
18527 !                                   +ru(ite,k,jm)-ru(ite-1,k,jm))     )
18528         tendencyd(ite-1, k, j) = tendencyd(ite-1, k, j) - mrdx*(ubd*(&
18529 &          v_old(ite-1, k, j)-v_old(ite-2, k, j))+ub*(v_oldd(ite-1, k, j)&
18530 &          -v_oldd(ite-2, k, j))+0.5*(vd(ite-1, k, j)*(dup+dum)+v(ite-1, &
18531 &          k, j)*(dupd+dumd)))
18532         tendency(ite-1, k, j) = tendency(ite-1, k, j) - mrdx*(ub*(v_old(&
18533 &          ite-1, k, j)-v_old(ite-2, k, j))+0.5*v(ite-1, k, j)*(dup+dum))
18534       END DO
18535     END DO
18536   END IF
18537 !-------------------- vertical advection
18538 !     ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
18539 !     Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
18540 !     We therefore need to make a correction for advect_v
18541 !     since 'my' (map scale factor in y direction) isn't a function of z,
18542 !     we can do this using *(my/mx) (see eqn. 45 for example)
18543   i_start = its
18544   IF (ite .GT. ide - 1) THEN
18545     i_end = ide - 1
18546   ELSE
18547     i_end = ite
18548   END IF
18549   j_start = jts
18550   j_end = jte
18551   DO i=i_start,i_end
18552     vfluxd(i, kts) = 0.0
18553     vflux(i, kts) = 0.
18554     vfluxd(i, kte) = 0.0
18555     vflux(i, kte) = 0.
18556   END DO
18557 ! Polar boundary conditions are like open or specified
18558 ! We don't want to calculate vertical v tendencies at the N or S pole
18559   IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
18560 &  THEN
18561     IF (jds + 1 .LT. jts) THEN
18562       j_start = jts
18563     ELSE
18564       j_start = jds + 1
18565     END IF
18566   END IF
18567   IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
18568 &  THEN
18569     IF (jde - 1 .GT. jte) THEN
18570       j_end = jte
18571     ELSE
18572       j_end = jde - 1
18573     END IF
18574     vfluxd = 0.0
18575   ELSE
18576     vfluxd = 0.0
18577   END IF
18578 !    vert_order_test : IF (vert_order == 6) THEN
18579 !   ELSE IF (vert_order == 5) THEN
18580   DO j=j_start,j_end
18581     DO k=kts+3,ktf-2
18582       DO i=i_start,i_end
18583         veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
18584         vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
18585         IF (-vel*sign(1,time_step) .GE. 0.0) THEN
18586           qip2d = vd(i, k+1, j)
18587           qip2 = v(i, k+1, j)
18588           qip1d = vd(i, k, j)
18589           qip1 = v(i, k, j)
18590           qid = vd(i, k-1, j)
18591           qi = v(i, k-1, j)
18592           qim1d = vd(i, k-2, j)
18593           qim1 = v(i, k-2, j)
18594           qim2d = vd(i, k-3, j)
18595           qim2 = v(i, k-3, j)
18596         ELSE
18597           qip2d = vd(i, k-2, j)
18598           qip2 = v(i, k-2, j)
18599           qip1d = vd(i, k-1, j)
18600           qip1 = v(i, k-1, j)
18601           qid = vd(i, k, j)
18602           qi = v(i, k, j)
18603           qim1d = vd(i, k+1, j)
18604           qim1 = v(i, k+1, j)
18605           qim2d = vd(i, k+2, j)
18606           qim2 = v(i, k+2, j)
18607         END IF
18608         f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
18609         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
18610         f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
18611         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
18612         f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
18613         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
18614         beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
18615 &          qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
18616         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
18617 &          )**2
18618         beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
18619 &          qim1-qip1)*(qim1d-qip1d)/4.
18620         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
18621         beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
18622 &          qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
18623         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
18624 &          )**2
18625         pwx1d = beta0d
18626         pwx1 = eps + beta0
18627         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
18628 &        THEN
18629           pwr1d = pw*pwx1**(pw-1)*pwx1d
18630         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
18631           pwr1d = pwx1d
18632         ELSE
18633           pwr1d = 0.0
18634         END IF
18635         pwr1 = pwx1**pw
18636         wi0d = -(gi0*pwr1d/pwr1**2)
18637         wi0 = gi0/pwr1
18638         pwx1d = beta1d
18639         pwx1 = eps + beta1
18640         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
18641 &        THEN
18642           pwr1d = pw*pwx1**(pw-1)*pwx1d
18643         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
18644           pwr1d = pwx1d
18645         ELSE
18646           pwr1d = 0.0
18647         END IF
18648         pwr1 = pwx1**pw
18649         wi1d = -(gi1*pwr1d/pwr1**2)
18650         wi1 = gi1/pwr1
18651         pwx1d = beta2d
18652         pwx1 = eps + beta2
18653         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
18654 &        THEN
18655           pwr1d = pw*pwx1**(pw-1)*pwx1d
18656         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
18657           pwr1d = pwx1d
18658         ELSE
18659           pwr1d = 0.0
18660         END IF
18661         pwr1 = pwx1**pw
18662         wi2d = -(gi2*pwr1d/pwr1**2)
18663         wi2 = gi2/pwr1
18664         sumwkd = wi0d + wi1d + wi2d
18665         sumwk = wi0 + wi1 + wi2
18666         vfluxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
18667 &          f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
18668 &          +wi2*f2)*sumwkd)/sumwk**2
18669         vflux(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
18670       END DO
18671     END DO
18672 !           vflux(i,k) = vel*flux5(                       &
18673 !                   v(i,k-3,j), v(i,k-2,j), v(i,k-1,j),       &
18674 !                   v(i,k  ,j), v(i,k+1,j), v(i,k+2,j),  -vel )
18675     DO i=i_start,i_end
18676       k = kts + 1
18677       vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i, k&
18678 &        , j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*&
18679 &        vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
18680       vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, j)&
18681 &        +fzp(k)*v(i, k-1, j))
18682       k = kts + 2
18683       veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
18684       vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
18685       vfluxd(i, k) = veld*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
18686 &        (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1, &
18687 &        j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0) + vel*((7.*(&
18688 &        vd(i, k, j)+vd(i, k-1, j))-vd(i, k+1, j)-vd(i, k-2, j))/12.0+&
18689 &        SIGN(1, time_step)*SIGN(1., -vel)*(vd(i, k+1, j)-vd(i, k-2, j)-&
18690 &        3.*(vd(i, k, j)-vd(i, k-1, j)))/12.0)
18691       vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v(i&
18692 &        , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1, j)&
18693 &        -v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0)
18694       k = ktf - 1
18695       veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
18696       vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
18697       vfluxd(i, k) = veld*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
18698 &        (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1, &
18699 &        j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0) + vel*((7.*(&
18700 &        vd(i, k, j)+vd(i, k-1, j))-vd(i, k+1, j)-vd(i, k-2, j))/12.0+&
18701 &        SIGN(1, time_step)*SIGN(1., -vel)*(vd(i, k+1, j)-vd(i, k-2, j)-&
18702 &        3.*(vd(i, k, j)-vd(i, k-1, j)))/12.0)
18703       vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v(i&
18704 &        , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1, j)&
18705 &        -v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0)
18706       k = ktf
18707       vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i, k&
18708 &        , j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*&
18709 &        vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
18710       vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, j)&
18711 &        +fzp(k)*v(i, k-1, j))
18712     END DO
18713     DO k=kts,ktf
18714       DO i=i_start,i_end
18715 ! We are calculating vertical fluxes on v points,
18716 ! so we must mean msf_v_x/y variables
18717 ! ADT eqn 45, 3rd term on RHS
18718         tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*(&
18719 &          vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
18720         tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j)*&
18721 &          rdzw(k)*(vflux(i, k+1)-vflux(i, k))
18722       END DO
18723     END DO
18724   END DO
18725 END SUBROUTINE G_ADVECT_WENO_V
18726
18727 !        Generated by TAPENADE     (INRIA, Tropics team)
18728 !  Tapenade 3.6 (r4165) - 21 sep 2011 20:54
18729 !
18730 !  Differentiation of advect_weno_w in forward (tangent) mode:
18731 !   variations   of useful results: tendency
18732 !   with respect to varying inputs: rom tendency w ru rv w_old
18733 !   RW status of diff variables: rom:in tendency:in-out w:in ru:in
18734 !                rv:in w_old:in
18735 SUBROUTINE G_ADVECT_WENO_W(w, wd, w_old, w_oldd, tendency, tendencyd, ru&
18736 &  , rud, rv, rvd, rom, romd, mut, time_step, config_flags, msfux, msfuy&
18737 &  , msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzu, ids, ide, jds&
18738 &  , jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts&
18739 &  , kte)
18740   IMPLICIT NONE
18741 ! Input data
18742   TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
18743   INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
18744 &  jme, kms, kme, its, ite, jts, jte, kts, kte
18745   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: w, w_old, ru&
18746 &  , rv, rom
18747   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: wd, w_oldd, &
18748 &  rud, rvd, romd
18749   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
18750   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
18751   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
18752   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
18753 &  msfvy, msftx, msfty
18754   REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzu
18755   REAL, INTENT(IN) :: rdx, rdy
18756   INTEGER, INTENT(IN) :: time_step
18757 ! Local data
18758   INTEGER :: i, j, k, itf, jtf, ktf
18759   INTEGER :: i_start, i_end, j_start, j_end
18760   INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
18761   INTEGER :: jmin, jmax, jp, jm, imin, imax
18762   REAL :: mrdx, mrdy, ub, vb, uw, vw
18763   REAL :: ubd, vbd, uwd, vwd
18764   REAL, DIMENSION(its:ite, kts:kte) :: vflux
18765   REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
18766   REAL :: dir, vv
18767   REAL :: ue, vs, vn, wb, wt
18768   REAL, PARAMETER :: f30=7./12., f31=1./12.
18769   REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
18770   INTEGER :: kt, kb
18771   REAL :: qim2, qim1, qi, qip1, qip2
18772   REAL :: qim2d, qim1d, qid, qip1d, qip2d
18773   DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
18774 &  sumwk
18775   DOUBLE PRECISION :: beta0d, beta1d, beta2d, f0d, f1d, f2d, wi0d, wi1d&
18776 &  , wi2d, sumwkd
18777   DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
18778 &    3.d0/10.d0, eps=1.0d-18
18779   INTEGER, PARAMETER :: pw=2
18780   INTEGER :: horz_order, vert_order
18781   REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
18782   REAL, DIMENSION(its:ite+1, kts:kte) :: fqxd
18783   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
18784   REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
18785   LOGICAL :: degrade_xs, degrade_ys
18786   LOGICAL :: degrade_xe, degrade_ye
18787   INTEGER :: jp1, jp0, jtmp
18788 ! definition of flux operators, 3rd, 4th, 5th or 6th order
18789   REAL :: flux3, flux4, flux5, flux6
18790   REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
18791   REAL :: veld
18792   LOGICAL :: specified
18793   DOUBLE PRECISION :: pwx1
18794   DOUBLE PRECISION :: pwx1d
18795   DOUBLE PRECISION :: pwr1
18796   DOUBLE PRECISION :: pwr1d
18797   INTRINSIC MAX
18798   INTRINSIC SIGN
18799   INTRINSIC MIN
18800
18801
18802
18803
18804   specified = .false.
18805   IF (config_flags%specified .OR. config_flags%nested) specified = &
18806 &      .true.
18807   IF (kte .GT. kde - 1) THEN
18808     ktf = kde - 1
18809   ELSE
18810     ktf = kte
18811   END IF
18812   horz_order = config_flags%h_sca_adv_order
18813   vert_order = config_flags%v_sca_adv_order
18814 !  here is the choice of flux operators
18815 !  begin with horizontal flux divergence
18816 !  horizontal_order_test : IF( horz_order == 6 ) THEN
18817 ! ELSE IF (horz_order == 5 ) THEN
18818 !  determine boundary mods for flux operators
18819 !  We degrade the flux operators from 3rd/4th order
18820 !   to second order one gridpoint in from the boundaries for
18821 !   all boundary conditions except periodic and symmetry - these
18822 !   conditions have boundary zone data fill for correct application
18823 !   of the higher order flux stencils
18824   degrade_xs = .true.
18825   degrade_xe = .true.
18826   degrade_ys = .true.
18827   degrade_ye = .true.
18828   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
18829 &      .GT. ids + 3) degrade_xs = .false.
18830   IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
18831 &      .LT. ide - 3) degrade_xe = .false.
18832   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
18833 &      .GT. jds + 3) degrade_ys = .false.
18834   IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
18835 &      .LT. jde - 4) degrade_ye = .false.
18836 !--------------- y - advection first
18837   i_start = its
18838   IF (ite .GT. ide - 1) THEN
18839     i_end = ide - 1
18840   ELSE
18841     i_end = ite
18842   END IF
18843   j_start = jts
18844   IF (jte .GT. jde - 1) THEN
18845     j_end = jde - 1
18846   ELSE
18847     j_end = jte
18848   END IF
18849 !  higher order flux has a 5 or 7 point stencil, so compute
18850 !  bounds so we can switch to second order flux close to the boundary
18851   j_start_f = j_start
18852   j_end_f = j_end + 1
18853   IF (degrade_ys) THEN
18854     IF (jts .LT. jds + 1) THEN
18855       j_start = jds + 1
18856     ELSE
18857       j_start = jts
18858     END IF
18859     j_start_f = jds + 3
18860   END IF
18861   IF (degrade_ye) THEN
18862     IF (jte .GT. jde - 2) THEN
18863       j_end = jde - 2
18864     ELSE
18865       j_end = jte
18866     END IF
18867     j_end_f = jde - 3
18868   END IF
18869   IF (config_flags%polar) THEN
18870     IF (jte .GT. jde - 1) THEN
18871       j_end = jde - 1
18872     ELSE
18873       j_end = jte
18874     END IF
18875   END IF
18876 !  compute fluxes, 5th or 6th order
18877   jp1 = 2
18878   jp0 = 1
18879   fqyd = 0.0
18880 j_loop_y_flux_5:DO j=j_start,j_end+1
18881     IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
18882       DO k=kts+1,ktf
18883         DO i=i_start,i_end
18884           veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
18885           vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
18886           IF (vel*sign(1,time_step) .GE. 0.0) THEN
18887             qip2d = wd(i, k, j+1)
18888             qip2 = w(i, k, j+1)
18889             qip1d = wd(i, k, j)
18890             qip1 = w(i, k, j)
18891             qid = wd(i, k, j-1)
18892             qi = w(i, k, j-1)
18893             qim1d = wd(i, k, j-2)
18894             qim1 = w(i, k, j-2)
18895             qim2d = wd(i, k, j-3)
18896             qim2 = w(i, k, j-3)
18897           ELSE
18898             qip2d = wd(i, k, j-2)
18899             qip2 = w(i, k, j-2)
18900             qip1d = wd(i, k, j-1)
18901             qip1 = w(i, k, j-1)
18902             qid = wd(i, k, j)
18903             qi = w(i, k, j)
18904             qim1d = wd(i, k, j+1)
18905             qim1 = w(i, k, j+1)
18906             qim2d = wd(i, k, j+2)
18907             qim2 = w(i, k, j+2)
18908           END IF
18909           f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
18910           f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
18911           f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
18912           f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
18913           f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
18914           f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
18915           beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*&
18916 &            (qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
18917           beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
18918 &            qi)**2
18919           beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*&
18920 &            (qim1-qip1)*(qim1d-qip1d)/4.
18921           beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
18922           beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*&
18923 &            (qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
18924           beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
18925 &            qi)**2
18926           pwx1d = beta0d
18927           pwx1 = eps + beta0
18928           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
18929 &          THEN
18930             pwr1d = pw*pwx1**(pw-1)*pwx1d
18931           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
18932             pwr1d = pwx1d
18933           ELSE
18934             pwr1d = 0.0
18935           END IF
18936           pwr1 = pwx1**pw
18937           wi0d = -(gi0*pwr1d/pwr1**2)
18938           wi0 = gi0/pwr1
18939           pwx1d = beta1d
18940           pwx1 = eps + beta1
18941           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
18942 &          THEN
18943             pwr1d = pw*pwx1**(pw-1)*pwx1d
18944           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
18945             pwr1d = pwx1d
18946           ELSE
18947             pwr1d = 0.0
18948           END IF
18949           pwr1 = pwx1**pw
18950           wi1d = -(gi1*pwr1d/pwr1**2)
18951           wi1 = gi1/pwr1
18952           pwx1d = beta2d
18953           pwx1 = eps + beta2
18954           IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
18955 &          THEN
18956             pwr1d = pw*pwx1**(pw-1)*pwx1d
18957           ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
18958             pwr1d = pwx1d
18959           ELSE
18960             pwr1d = 0.0
18961           END IF
18962           pwr1 = pwx1**pw
18963           wi2d = -(gi2*pwr1d/pwr1**2)
18964           wi2 = gi2/pwr1
18965           sumwkd = wi0d + wi1d + wi2d
18966           sumwk = wi0 + wi1 + wi2
18967           fqyd(i, k, jp1) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+&
18968 &            wi0*f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+&
18969 &            wi1*f1+wi2*f2)*sumwkd)/sumwk**2
18970           fqy(i, k, jp1) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
18971         END DO
18972       END DO
18973 !          fqy( i, k, jp1 ) = vel*flux5(                     &
18974 !                  w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
18975 !                  w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
18976       k = ktf + 1
18977       DO i=i_start,i_end
18978         veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
18979         vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
18980         IF (vel*sign(1,time_step) .GE. 0.0) THEN
18981           qip2d = wd(i, k, j+1)
18982           qip2 = w(i, k, j+1)
18983           qip1d = wd(i, k, j)
18984           qip1 = w(i, k, j)
18985           qid = wd(i, k, j-1)
18986           qi = w(i, k, j-1)
18987           qim1d = wd(i, k, j-2)
18988           qim1 = w(i, k, j-2)
18989           qim2d = wd(i, k, j-3)
18990           qim2 = w(i, k, j-3)
18991         ELSE
18992           qip2d = wd(i, k, j-2)
18993           qip2 = w(i, k, j-2)
18994           qip1d = wd(i, k, j-1)
18995           qip1 = w(i, k, j-1)
18996           qid = wd(i, k, j)
18997           qi = w(i, k, j)
18998           qim1d = wd(i, k, j+1)
18999           qim1 = w(i, k, j+1)
19000           qim2d = wd(i, k, j+2)
19001           qim2 = w(i, k, j+2)
19002         END IF
19003         f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
19004         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
19005         f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
19006         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
19007         f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
19008         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
19009         beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
19010 &          qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
19011         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
19012 &          )**2
19013         beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
19014 &          qim1-qip1)*(qim1d-qip1d)/4.
19015         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
19016         beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
19017 &          qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
19018         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
19019 &          )**2
19020         pwx1d = beta0d
19021         pwx1 = eps + beta0
19022         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
19023 &        THEN
19024           pwr1d = pw*pwx1**(pw-1)*pwx1d
19025         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19026           pwr1d = pwx1d
19027         ELSE
19028           pwr1d = 0.0
19029         END IF
19030         pwr1 = pwx1**pw
19031         wi0d = -(gi0*pwr1d/pwr1**2)
19032         wi0 = gi0/pwr1
19033         pwx1d = beta1d
19034         pwx1 = eps + beta1
19035         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
19036 &        THEN
19037           pwr1d = pw*pwx1**(pw-1)*pwx1d
19038         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19039           pwr1d = pwx1d
19040         ELSE
19041           pwr1d = 0.0
19042         END IF
19043         pwr1 = pwx1**pw
19044         wi1d = -(gi1*pwr1d/pwr1**2)
19045         wi1 = gi1/pwr1
19046         pwx1d = beta2d
19047         pwx1 = eps + beta2
19048         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
19049 &        THEN
19050           pwr1d = pw*pwx1**(pw-1)*pwx1d
19051         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19052           pwr1d = pwx1d
19053         ELSE
19054           pwr1d = 0.0
19055         END IF
19056         pwr1 = pwx1**pw
19057         wi2d = -(gi2*pwr1d/pwr1**2)
19058         wi2 = gi2/pwr1
19059         sumwkd = wi0d + wi1d + wi2d
19060         sumwk = wi0 + wi1 + wi2
19061         fqyd(i, k, jp1) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0&
19062 &          *f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*&
19063 &          f1+wi2*f2)*sumwkd)/sumwk**2
19064         fqy(i, k, jp1) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
19065       END DO
19066     ELSE IF (j .EQ. jds + 1) THEN
19067 !          fqy( i, k, jp1 ) = vel*flux5(                     &
19068 !                  w(i,k,j-3), w(i,k,j-2), w(i,k,j-1),       &
19069 !                  w(i,k,j  ), w(i,k,j+1), w(i,k,j+2),  vel )
19070 ! 2nd order flux next to south boundary
19071       DO k=kts+1,ktf
19072         DO i=i_start,i_end
19073           fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-1&
19074 &            , j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k)*&
19075 &            rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
19076           fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))&
19077 &            *(w(i, k, j)+w(i, k, j-1))
19078         END DO
19079       END DO
19080       k = ktf + 1
19081       DO i=i_start,i_end
19082         fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
19083 &          rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(i&
19084 &          , k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1)))
19085         fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i&
19086 &          , k-2, j))*(w(i, k, j)+w(i, k, j-1))
19087       END DO
19088     ELSE IF (j .EQ. jds + 2) THEN
19089 ! third of 4th order flux 2 in from south boundary
19090       DO k=kts+1,ktf
19091         DO i=i_start,i_end
19092           veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
19093           vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
19094           fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
19095 &            , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
19096 &            (w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/&
19097 &            12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-&
19098 &            wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, &
19099 &            k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
19100           fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
19101 &            +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(&
19102 &            i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
19103         END DO
19104       END DO
19105       k = ktf + 1
19106       DO i=i_start,i_end
19107         veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
19108         vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
19109         fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
19110 &          +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
19111 &          , k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0) + &
19112 &          vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-wd(i, k, j-&
19113 &          2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, k, j+1)-wd(i&
19114 &          , k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
19115         fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j+1&
19116 &          )+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i, k&
19117 &          , j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
19118       END DO
19119     ELSE IF (j .EQ. jde - 1) THEN
19120 ! 2nd order flux next to north boundary
19121       DO k=kts+1,ktf
19122         DO i=i_start,i_end
19123           fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-1&
19124 &            , j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k)*&
19125 &            rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
19126           fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))&
19127 &            *(w(i, k, j)+w(i, k, j-1))
19128         END DO
19129       END DO
19130       k = ktf + 1
19131       DO i=i_start,i_end
19132         fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
19133 &          rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(i&
19134 &          , k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1)))
19135         fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i&
19136 &          , k-2, j))*(w(i, k, j)+w(i, k, j-1))
19137       END DO
19138     ELSE IF (j .EQ. jde - 2) THEN
19139 ! 3rd or 4th order flux 2 in from north boundary
19140       DO k=kts+1,ktf
19141         DO i=i_start,i_end
19142           veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
19143           vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
19144           fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
19145 &            , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
19146 &            (w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/&
19147 &            12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-&
19148 &            wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, &
19149 &            k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
19150           fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
19151 &            +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(&
19152 &            i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
19153         END DO
19154       END DO
19155       k = ktf + 1
19156       DO i=i_start,i_end
19157         veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
19158         vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
19159         fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
19160 &          +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
19161 &          , k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0) + &
19162 &          vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-wd(i, k, j-&
19163 &          2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, k, j+1)-wd(i&
19164 &          , k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
19165         fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j+1&
19166 &          )+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i, k&
19167 &          , j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
19168       END DO
19169     END IF
19170 !  y flux-divergence into tendency
19171 ! Comments for polar boundary conditions
19172 ! Same process as for advect_u - tendencies run from jds to jde-1
19173 ! (latitudes are as for u grid, longitudes are displaced)
19174 ! Therefore: flow is only from one side for points next to poles
19175     IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
19176       DO k=kts,ktf
19177         DO i=i_start,i_end
19178 ! see ADT eqn 46 dividing by my, 2nd term RHS
19179           mrdy = msftx(i, j-1)*rdy
19180           tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k, &
19181 &            jp1)
19182           tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, jp1&
19183 &            )
19184         END DO
19185       END DO
19186     ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
19187       DO k=kts,ktf
19188         DO i=i_start,i_end
19189 ! see ADT eqn 46 dividing by my, 2nd term RHS
19190           mrdy = msftx(i, j-1)*rdy
19191           tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k, &
19192 &            jp0)
19193           tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, jp0&
19194 &            )
19195         END DO
19196       END DO
19197     ELSE IF (j .GT. j_start) THEN
19198 ! normal code
19199       DO k=kts+1,ktf+1
19200         DO i=i_start,i_end
19201 ! see ADT eqn 46 dividing by my, 2nd term RHS
19202           mrdy = msftx(i, j-1)*rdy
19203           tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, k&
19204 &            , jp1)-fqyd(i, k, jp0))
19205           tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
19206 &            jp1)-fqy(i, k, jp0))
19207         END DO
19208       END DO
19209     END IF
19210     jtmp = jp1
19211     jp1 = jp0
19212     jp0 = jtmp
19213   END DO j_loop_y_flux_5
19214 !  next, x - flux divergence
19215   i_start = its
19216   IF (ite .GT. ide - 1) THEN
19217     i_end = ide - 1
19218   ELSE
19219     i_end = ite
19220   END IF
19221   j_start = jts
19222   IF (jte .GT. jde - 1) THEN
19223     j_end = jde - 1
19224   ELSE
19225     j_end = jte
19226   END IF
19227 !  higher order flux has a 5 or 7 point stencil, so compute
19228 !  bounds so we can switch to second order flux close to the boundary
19229   i_start_f = i_start
19230   i_end_f = i_end + 1
19231   IF (degrade_xs) THEN
19232     IF (ids + 1 .LT. its) THEN
19233       i_start = its
19234     ELSE
19235       i_start = ids + 1
19236     END IF
19237     IF (i_start + 2 .GT. ids + 3) THEN
19238       i_start_f = ids + 3
19239     ELSE
19240       i_start_f = i_start + 2
19241     END IF
19242   END IF
19243   IF (degrade_xe) THEN
19244     IF (ide - 2 .GT. ite) THEN
19245       i_end = ite
19246     ELSE
19247       i_end = ide - 2
19248     END IF
19249     i_end_f = ide - 3
19250     fqxd = 0.0
19251   ELSE
19252     fqxd = 0.0
19253   END IF
19254 !  compute fluxes
19255   DO j=j_start,j_end
19256 !  5th or 6th order flux
19257     DO k=kts+1,ktf
19258       DO i=i_start_f,i_end_f
19259         veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
19260         vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
19261         IF (vel*sign(1,time_step) .GE. 0.0) THEN
19262           qip2d = wd(i+1, k, j)
19263           qip2 = w(i+1, k, j)
19264           qip1d = wd(i, k, j)
19265           qip1 = w(i, k, j)
19266           qid = wd(i-1, k, j)
19267           qi = w(i-1, k, j)
19268           qim1d = wd(i-2, k, j)
19269           qim1 = w(i-2, k, j)
19270           qim2d = wd(i-3, k, j)
19271           qim2 = w(i-3, k, j)
19272         ELSE
19273           qip2d = wd(i-2, k, j)
19274           qip2 = w(i-2, k, j)
19275           qip1d = wd(i-1, k, j)
19276           qip1 = w(i-1, k, j)
19277           qid = wd(i, k, j)
19278           qi = w(i, k, j)
19279           qim1d = wd(i+1, k, j)
19280           qim1 = w(i+1, k, j)
19281           qim2d = wd(i+2, k, j)
19282           qim2 = w(i+2, k, j)
19283         END IF
19284         f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
19285         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
19286         f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
19287         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
19288         f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
19289         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
19290         beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
19291 &          qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
19292         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
19293 &          )**2
19294         beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
19295 &          qim1-qip1)*(qim1d-qip1d)/4.
19296         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
19297         beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
19298 &          qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
19299         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
19300 &          )**2
19301         pwx1d = beta0d
19302         pwx1 = eps + beta0
19303         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
19304 &        THEN
19305           pwr1d = pw*pwx1**(pw-1)*pwx1d
19306         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19307           pwr1d = pwx1d
19308         ELSE
19309           pwr1d = 0.0
19310         END IF
19311         pwr1 = pwx1**pw
19312         wi0d = -(gi0*pwr1d/pwr1**2)
19313         wi0 = gi0/pwr1
19314         pwx1d = beta1d
19315         pwx1 = eps + beta1
19316         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
19317 &        THEN
19318           pwr1d = pw*pwx1**(pw-1)*pwx1d
19319         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19320           pwr1d = pwx1d
19321         ELSE
19322           pwr1d = 0.0
19323         END IF
19324         pwr1 = pwx1**pw
19325         wi1d = -(gi1*pwr1d/pwr1**2)
19326         wi1 = gi1/pwr1
19327         pwx1d = beta2d
19328         pwx1 = eps + beta2
19329         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
19330 &        THEN
19331           pwr1d = pw*pwx1**(pw-1)*pwx1d
19332         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19333           pwr1d = pwx1d
19334         ELSE
19335           pwr1d = 0.0
19336         END IF
19337         pwr1 = pwx1**pw
19338         wi2d = -(gi2*pwr1d/pwr1**2)
19339         wi2 = gi2/pwr1
19340         sumwkd = wi0d + wi1d + wi2d
19341         sumwk = wi0 + wi1 + wi2
19342         fqxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*f0d+&
19343 &          wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1+wi2&
19344 &          *f2)*sumwkd)/sumwk**2
19345         fqx(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
19346       END DO
19347     END DO
19348 !          fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
19349 !                                  w(i-1,k,j), w(i  ,k,j),  &
19350 !                                  w(i+1,k,j), w(i+2,k,j),  &
19351 !                                  vel                     )
19352     k = ktf + 1
19353     DO i=i_start_f,i_end_f
19354       veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
19355       vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
19356       IF (vel*sign(1,time_step) .GE. 0.0) THEN
19357         qip2d = wd(i+1, k, j)
19358         qip2 = w(i+1, k, j)
19359         qip1d = wd(i, k, j)
19360         qip1 = w(i, k, j)
19361         qid = wd(i-1, k, j)
19362         qi = w(i-1, k, j)
19363         qim1d = wd(i-2, k, j)
19364         qim1 = w(i-2, k, j)
19365         qim2d = wd(i-3, k, j)
19366         qim2 = w(i-3, k, j)
19367       ELSE
19368         qip2d = wd(i-2, k, j)
19369         qip2 = w(i-2, k, j)
19370         qip1d = wd(i-1, k, j)
19371         qip1 = w(i-1, k, j)
19372         qid = wd(i, k, j)
19373         qi = w(i, k, j)
19374         qim1d = wd(i+1, k, j)
19375         qim1 = w(i+1, k, j)
19376         qim2d = wd(i+2, k, j)
19377         qim2 = w(i+2, k, j)
19378       END IF
19379       f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
19380       f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
19381       f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
19382       f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
19383       f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
19384       f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
19385       beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
19386 &        qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
19387       beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi)&
19388 &        **2
19389       beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
19390 &        qim1-qip1)*(qim1d-qip1d)/4.
19391       beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
19392       beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
19393 &        qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
19394       beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi)&
19395 &        **2
19396       pwx1d = beta0d
19397       pwx1 = eps + beta0
19398       IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) THEN
19399         pwr1d = pw*pwx1**(pw-1)*pwx1d
19400       ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19401         pwr1d = pwx1d
19402       ELSE
19403         pwr1d = 0.0
19404       END IF
19405       pwr1 = pwx1**pw
19406       wi0d = -(gi0*pwr1d/pwr1**2)
19407       wi0 = gi0/pwr1
19408       pwx1d = beta1d
19409       pwx1 = eps + beta1
19410       IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) THEN
19411         pwr1d = pw*pwx1**(pw-1)*pwx1d
19412       ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19413         pwr1d = pwx1d
19414       ELSE
19415         pwr1d = 0.0
19416       END IF
19417       pwr1 = pwx1**pw
19418       wi1d = -(gi1*pwr1d/pwr1**2)
19419       wi1 = gi1/pwr1
19420       pwx1d = beta2d
19421       pwx1 = eps + beta2
19422       IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) THEN
19423         pwr1d = pw*pwx1**(pw-1)*pwx1d
19424       ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19425         pwr1d = pwx1d
19426       ELSE
19427         pwr1d = 0.0
19428       END IF
19429       pwr1 = pwx1**pw
19430       wi2d = -(gi2*pwr1d/pwr1**2)
19431       wi2 = gi2/pwr1
19432       sumwkd = wi0d + wi1d + wi2d
19433       sumwk = wi0 + wi1 + wi2
19434       fqxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*f0d+&
19435 &        wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1+wi2*&
19436 &        f2)*sumwkd)/sumwk**2
19437       fqx(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
19438     END DO
19439 !          fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j),  &
19440 !                                  w(i-1,k,j), w(i  ,k,j),  &
19441 !                                  w(i+1,k,j), w(i+2,k,j),  &
19442 !                                  vel                     )
19443 !  lower order fluxes close to boundaries (if not periodic or symmetric)
19444     IF (degrade_xs) THEN
19445       DO i=i_start,i_start_f-1
19446         IF (i .EQ. ids + 1) THEN
19447 ! second order
19448           DO k=kts+1,ktf
19449             fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, j)&
19450 &              )*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)*ru(&
19451 &              i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
19452             fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*(w&
19453 &              (i, k, j)+w(i-1, k, j))
19454           END DO
19455           k = ktf + 1
19456           fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud(i&
19457 &            , k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i, k-&
19458 &            1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, j)))
19459           fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-&
19460 &            2, j))*(w(i, k, j)+w(i-1, k, j))
19461         END IF
19462         IF (i .EQ. ids + 2) THEN
19463 ! third order
19464           DO k=kts+1,ktf
19465             veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
19466             vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
19467             fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
19468 &              j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w&
19469 &              (i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/&
19470 &              12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)&
19471 &              -wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(&
19472 &              i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/&
19473 &              12.0)
19474             fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
19475 &              +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
19476 &              +1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
19477           END DO
19478           k = ktf + 1
19479           veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
19480           vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
19481           fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
19482 &            +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1&
19483 &            , k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0) + &
19484 &            vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)-wd(i-2, k&
19485 &            , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i+1, k, j)-&
19486 &            wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/12.0)
19487           fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w&
19488 &            (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1, &
19489 &            k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
19490         END IF
19491       END DO
19492     END IF
19493     IF (degrade_xe) THEN
19494       DO i=i_end_f+1,i_end+1
19495         IF (i .EQ. ide - 1) THEN
19496 ! second order flux next to the boundary
19497           DO k=kts+1,ktf
19498             fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, j)&
19499 &              )*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)*ru(&
19500 &              i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
19501             fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*(w&
19502 &              (i, k, j)+w(i-1, k, j))
19503           END DO
19504           k = ktf + 1
19505           fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud(i&
19506 &            , k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i, k-&
19507 &            1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, j)))
19508           fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-&
19509 &            2, j))*(w(i, k, j)+w(i-1, k, j))
19510         END IF
19511         IF (i .EQ. ide - 2) THEN
19512 ! third order flux one in from the boundary
19513           DO k=kts+1,ktf
19514             veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
19515             vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
19516             fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
19517 &              j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w&
19518 &              (i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/&
19519 &              12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)&
19520 &              -wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(&
19521 &              i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/&
19522 &              12.0)
19523             fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
19524 &              +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
19525 &              +1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
19526           END DO
19527           k = ktf + 1
19528           veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
19529           vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
19530           fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
19531 &            +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1&
19532 &            , k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0) + &
19533 &            vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)-wd(i-2, k&
19534 &            , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i+1, k, j)-&
19535 &            wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/12.0)
19536           fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w&
19537 &            (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1, &
19538 &            k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
19539         END IF
19540       END DO
19541     END IF
19542 !  x flux-divergence into tendency
19543     DO k=kts+1,ktf+1
19544       DO i=i_start,i_end
19545 ! see ADT eqn 46 dividing by my, 1st term RHS
19546         mrdx = msftx(i, j)*rdx
19547         tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
19548 &          fqxd(i, k))
19549         tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(i&
19550 &          , k))
19551       END DO
19552     END DO
19553   END DO
19554 !  pick up the the horizontal radiation boundary conditions.
19555 !  (these are the computations that don't require 'cb'.
19556 !  first, set to index ranges
19557   i_start = its
19558   IF (ite .GT. ide - 1) THEN
19559     i_end = ide - 1
19560   ELSE
19561     i_end = ite
19562   END IF
19563   j_start = jts
19564   IF (jte .GT. jde - 1) THEN
19565     j_end = jde - 1
19566   ELSE
19567     j_end = jte
19568   END IF
19569   IF (config_flags%open_xs .AND. its .EQ. ids) THEN
19570     DO j=j_start,j_end
19571       DO k=kts+1,ktf
19572         uwd = 0.5*(fzm(k)*(rud(its, k, j)+rud(its+1, k, j))+fzp(k)*(rud(&
19573 &          its, k-1, j)+rud(its+1, k-1, j)))
19574         uw = 0.5*(fzm(k)*(ru(its, k, j)+ru(its+1, k, j))+fzp(k)*(ru(its&
19575 &          , k-1, j)+ru(its+1, k-1, j)))
19576         IF (uw .GT. 0.) THEN
19577           ub = 0.
19578           ubd = 0.0
19579         ELSE
19580           ubd = uwd
19581           ub = uw
19582         END IF
19583         tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(w_old(&
19584 &          its+1, k, j)-w_old(its, k, j))+ub*(w_oldd(its+1, k, j)-w_oldd(&
19585 &          its, k, j))+wd(its, k, j)*(fzm(k)*(ru(its+1, k, j)-ru(its, k, &
19586 &          j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j)))+w(its, k, j)*(&
19587 &          fzm(k)*(rud(its+1, k, j)-rud(its, k, j))+fzp(k)*(rud(its+1, k-&
19588 &          1, j)-rud(its, k-1, j))))
19589         tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(w_old(its+1&
19590 &          , k, j)-w_old(its, k, j))+w(its, k, j)*(fzm(k)*(ru(its+1, k, j&
19591 &          )-ru(its, k, j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j))))
19592       END DO
19593     END DO
19594     k = ktf + 1
19595     DO j=j_start,j_end
19596       uwd = 0.5*((2.-fzm(k-1))*(rud(its, k-1, j)+rud(its+1, k-1, j))-fzp&
19597 &        (k-1)*(rud(its, k-2, j)+rud(its+1, k-2, j)))
19598       uw = 0.5*((2.-fzm(k-1))*(ru(its, k-1, j)+ru(its+1, k-1, j))-fzp(k-&
19599 &        1)*(ru(its, k-2, j)+ru(its+1, k-2, j)))
19600       IF (uw .GT. 0.) THEN
19601         ub = 0.
19602         ubd = 0.0
19603       ELSE
19604         ubd = uwd
19605         ub = uw
19606       END IF
19607       tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(w_old(its+&
19608 &        1, k, j)-w_old(its, k, j))+ub*(w_oldd(its+1, k, j)-w_oldd(its, k&
19609 &        , j))+wd(its, k, j)*((2.-fzm(k-1))*(ru(its+1, k-1, j)-ru(its, k-&
19610 &        1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2, j)))+w(its, k, j&
19611 &        )*((2.-fzm(k-1))*(rud(its+1, k-1, j)-rud(its, k-1, j))-fzp(k-1)*&
19612 &        (rud(its+1, k-2, j)-rud(its, k-2, j))))
19613       tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(w_old(its+1, &
19614 &        k, j)-w_old(its, k, j))+w(its, k, j)*((2.-fzm(k-1))*(ru(its+1, k&
19615 &        -1, j)-ru(its, k-1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2&
19616 &        , j))))
19617     END DO
19618   END IF
19619   IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
19620     DO j=j_start,j_end
19621       DO k=kts+1,ktf
19622         uwd = 0.5*(fzm(k)*(rud(ite-1, k, j)+rud(ite, k, j))+fzp(k)*(rud(&
19623 &          ite-1, k-1, j)+rud(ite, k-1, j)))
19624         uw = 0.5*(fzm(k)*(ru(ite-1, k, j)+ru(ite, k, j))+fzp(k)*(ru(ite-&
19625 &          1, k-1, j)+ru(ite, k-1, j)))
19626         IF (uw .LT. 0.) THEN
19627           ub = 0.
19628           ubd = 0.0
19629         ELSE
19630           ubd = uwd
19631           ub = uw
19632         END IF
19633         tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
19634 &          w_old(i_end, k, j)-w_old(i_end-1, k, j))+ub*(w_oldd(i_end, k, &
19635 &          j)-w_oldd(i_end-1, k, j))+wd(i_end, k, j)*(fzm(k)*(ru(ite, k, &
19636 &          j)-ru(ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, k-1, j))&
19637 &          )+w(i_end, k, j)*(fzm(k)*(rud(ite, k, j)-rud(ite-1, k, j))+fzp&
19638 &          (k)*(rud(ite, k-1, j)-rud(ite-1, k-1, j))))
19639         tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(w_old(&
19640 &          i_end, k, j)-w_old(i_end-1, k, j))+w(i_end, k, j)*(fzm(k)*(ru(&
19641 &          ite, k, j)-ru(ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, &
19642 &          k-1, j))))
19643       END DO
19644     END DO
19645     k = ktf + 1
19646     DO j=j_start,j_end
19647       uwd = 0.5*((2.-fzm(k-1))*(rud(ite-1, k-1, j)+rud(ite, k-1, j))-fzp&
19648 &        (k-1)*(rud(ite-1, k-2, j)+rud(ite, k-2, j)))
19649       uw = 0.5*((2.-fzm(k-1))*(ru(ite-1, k-1, j)+ru(ite, k-1, j))-fzp(k-&
19650 &        1)*(ru(ite-1, k-2, j)+ru(ite, k-2, j)))
19651       IF (uw .LT. 0.) THEN
19652         ub = 0.
19653         ubd = 0.0
19654       ELSE
19655         ubd = uwd
19656         ub = uw
19657       END IF
19658       tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(w_old(&
19659 &        i_end, k, j)-w_old(i_end-1, k, j))+ub*(w_oldd(i_end, k, j)-&
19660 &        w_oldd(i_end-1, k, j))+wd(i_end, k, j)*((2.-fzm(k-1))*(ru(ite, k&
19661 &        -1, j)-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-ru(ite-1, k-&
19662 &        2, j)))+w(i_end, k, j)*((2.-fzm(k-1))*(rud(ite, k-1, j)-rud(ite-&
19663 &        1, k-1, j))-fzp(k-1)*(rud(ite, k-2, j)-rud(ite-1, k-2, j))))
19664       tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(w_old(&
19665 &        i_end, k, j)-w_old(i_end-1, k, j))+w(i_end, k, j)*((2.-fzm(k-1))&
19666 &        *(ru(ite, k-1, j)-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-&
19667 &        ru(ite-1, k-2, j))))
19668     END DO
19669   END IF
19670   IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
19671     DO i=i_start,i_end
19672       DO k=kts+1,ktf
19673         vwd = 0.5*(fzm(k)*(rvd(i, k, jts)+rvd(i, k, jts+1))+fzp(k)*(rvd(&
19674 &          i, k-1, jts)+rvd(i, k-1, jts+1)))
19675         vw = 0.5*(fzm(k)*(rv(i, k, jts)+rv(i, k, jts+1))+fzp(k)*(rv(i, k&
19676 &          -1, jts)+rv(i, k-1, jts+1)))
19677         IF (vw .GT. 0.) THEN
19678           vb = 0.
19679           vbd = 0.0
19680         ELSE
19681           vbd = vwd
19682           vb = vw
19683         END IF
19684         tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(w_old(i&
19685 &          , k, jts+1)-w_old(i, k, jts))+vb*(w_oldd(i, k, jts+1)-w_oldd(i&
19686 &          , k, jts))+wd(i, k, jts)*(fzm(k)*(rv(i, k, jts+1)-rv(i, k, jts&
19687 &          ))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts)))+w(i, k, jts)*(&
19688 &          fzm(k)*(rvd(i, k, jts+1)-rvd(i, k, jts))+fzp(k)*(rvd(i, k-1, &
19689 &          jts+1)-rvd(i, k-1, jts))))
19690         tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(w_old(i, k&
19691 &          , jts+1)-w_old(i, k, jts))+w(i, k, jts)*(fzm(k)*(rv(i, k, jts+&
19692 &          1)-rv(i, k, jts))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts))))
19693       END DO
19694     END DO
19695     k = ktf + 1
19696     DO i=i_start,i_end
19697       vwd = 0.5*((2.-fzm(k-1))*(rvd(i, k-1, jts)+rvd(i, k-1, jts+1))-fzp&
19698 &        (k-1)*(rvd(i, k-2, jts)+rvd(i, k-2, jts+1)))
19699       vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jts)+rv(i, k-1, jts+1))-fzp(k-&
19700 &        1)*(rv(i, k-2, jts)+rv(i, k-2, jts+1)))
19701       IF (vw .GT. 0.) THEN
19702         vb = 0.
19703         vbd = 0.0
19704       ELSE
19705         vbd = vwd
19706         vb = vw
19707       END IF
19708       tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(w_old(i, k&
19709 &        , jts+1)-w_old(i, k, jts))+vb*(w_oldd(i, k, jts+1)-w_oldd(i, k, &
19710 &        jts))+wd(i, k, jts)*((2.-fzm(k-1))*(rv(i, k-1, jts+1)-rv(i, k-1&
19711 &        , jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2, jts)))+w(i, k, &
19712 &        jts)*((2.-fzm(k-1))*(rvd(i, k-1, jts+1)-rvd(i, k-1, jts))-fzp(k-&
19713 &        1)*(rvd(i, k-2, jts+1)-rvd(i, k-2, jts))))
19714       tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(w_old(i, k, &
19715 &        jts+1)-w_old(i, k, jts))+w(i, k, jts)*((2.-fzm(k-1))*(rv(i, k-1&
19716 &        , jts+1)-rv(i, k-1, jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2&
19717 &        , jts))))
19718     END DO
19719   END IF
19720   IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
19721     DO i=i_start,i_end
19722       DO k=kts+1,ktf
19723         vwd = 0.5*(fzm(k)*(rvd(i, k, jte-1)+rvd(i, k, jte))+fzp(k)*(rvd(&
19724 &          i, k-1, jte-1)+rvd(i, k-1, jte)))
19725         vw = 0.5*(fzm(k)*(rv(i, k, jte-1)+rv(i, k, jte))+fzp(k)*(rv(i, k&
19726 &          -1, jte-1)+rv(i, k-1, jte)))
19727         IF (vw .LT. 0.) THEN
19728           vb = 0.
19729           vbd = 0.0
19730         ELSE
19731           vbd = vwd
19732           vb = vw
19733         END IF
19734         tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
19735 &          w_old(i, k, j_end)-w_old(i, k, j_end-1))+vb*(w_oldd(i, k, &
19736 &          j_end)-w_oldd(i, k, j_end-1))+wd(i, k, j_end)*(fzm(k)*(rv(i, k&
19737 &          , jte)-rv(i, k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, jte&
19738 &          -1)))+w(i, k, j_end)*(fzm(k)*(rvd(i, k, jte)-rvd(i, k, jte-1))&
19739 &          +fzp(k)*(rvd(i, k-1, jte)-rvd(i, k-1, jte-1))))
19740         tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(w_old(i&
19741 &          , k, j_end)-w_old(i, k, j_end-1))+w(i, k, j_end)*(fzm(k)*(rv(i&
19742 &          , k, jte)-rv(i, k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, &
19743 &          jte-1))))
19744       END DO
19745     END DO
19746     k = ktf + 1
19747     DO i=i_start,i_end
19748       vwd = 0.5*((2.-fzm(k-1))*(rvd(i, k-1, jte-1)+rvd(i, k-1, jte))-fzp&
19749 &        (k-1)*(rvd(i, k-2, jte-1)+rvd(i, k-2, jte)))
19750       vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jte-1)+rv(i, k-1, jte))-fzp(k-&
19751 &        1)*(rv(i, k-2, jte-1)+rv(i, k-2, jte)))
19752       IF (vw .LT. 0.) THEN
19753         vb = 0.
19754         vbd = 0.0
19755       ELSE
19756         vbd = vwd
19757         vb = vw
19758       END IF
19759       tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(w_old(&
19760 &        i, k, j_end)-w_old(i, k, j_end-1))+vb*(w_oldd(i, k, j_end)-&
19761 &        w_oldd(i, k, j_end-1))+wd(i, k, j_end)*((2.-fzm(k-1))*(rv(i, k-1&
19762 &        , jte)-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(i, k-2, &
19763 &        jte-1)))+w(i, k, j_end)*((2.-fzm(k-1))*(rvd(i, k-1, jte)-rvd(i, &
19764 &        k-1, jte-1))-fzp(k-1)*(rvd(i, k-2, jte)-rvd(i, k-2, jte-1))))
19765       tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(w_old(i, &
19766 &        k, j_end)-w_old(i, k, j_end-1))+w(i, k, j_end)*((2.-fzm(k-1))*(&
19767 &        rv(i, k-1, jte)-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(&
19768 &        i, k-2, jte-1))))
19769     END DO
19770   END IF
19771 !-------------------- vertical advection
19772 !     ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
19773 !     Here we have:  - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
19774 !     Therefore we don't need to make a correction for advect_w
19775   i_start = its
19776   IF (ite .GT. ide - 1) THEN
19777     i_end = ide - 1
19778   ELSE
19779     i_end = ite
19780   END IF
19781   j_start = jts
19782   IF (jte .GT. jde - 1) THEN
19783     j_end = jde - 1
19784   ELSE
19785     j_end = jte
19786   END IF
19787   DO i=i_start,i_end
19788     vfluxd(i, kts) = 0.0
19789     vflux(i, kts) = 0.
19790     vfluxd(i, kte) = 0.0
19791     vflux(i, kte) = 0.
19792   END DO
19793   vfluxd = 0.0
19794 !    vert_order_test : IF (vert_order == 6) THEN
19795 ! ELSE IF (vert_order == 5) THEN
19796   DO j=j_start,j_end
19797     DO k=kts+3,ktf-1
19798       DO i=i_start,i_end
19799         veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
19800         vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
19801         IF (-vel*sign(1,time_step) .GE. 0.0) THEN
19802           qip2d = wd(i, k+1, j)
19803           qip2 = w(i, k+1, j)
19804           qip1d = wd(i, k, j)
19805           qip1 = w(i, k, j)
19806           qid = wd(i, k-1, j)
19807           qi = w(i, k-1, j)
19808           qim1d = wd(i, k-2, j)
19809           qim1 = w(i, k-2, j)
19810           qim2d = wd(i, k-3, j)
19811           qim2 = w(i, k-3, j)
19812         ELSE
19813           qip2d = wd(i, k-2, j)
19814           qip2 = w(i, k-2, j)
19815           qip1d = wd(i, k-1, j)
19816           qip1 = w(i, k-1, j)
19817           qid = wd(i, k, j)
19818           qi = w(i, k, j)
19819           qim1d = wd(i, k+1, j)
19820           qim1 = w(i, k+1, j)
19821           qim2d = wd(i, k+2, j)
19822           qim2 = w(i, k+2, j)
19823         END IF
19824         f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
19825         f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
19826         f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
19827         f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
19828         f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
19829         f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
19830         beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
19831 &          qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
19832         beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
19833 &          )**2
19834         beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
19835 &          qim1-qip1)*(qim1d-qip1d)/4.
19836         beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
19837         beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
19838 &          qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
19839         beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
19840 &          )**2
19841         pwx1d = beta0d
19842         pwx1 = eps + beta0
19843         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
19844 &        THEN
19845           pwr1d = pw*pwx1**(pw-1)*pwx1d
19846         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19847           pwr1d = pwx1d
19848         ELSE
19849           pwr1d = 0.0
19850         END IF
19851         pwr1 = pwx1**pw
19852         wi0d = -(gi0*pwr1d/pwr1**2)
19853         wi0 = gi0/pwr1
19854         pwx1d = beta1d
19855         pwx1 = eps + beta1
19856         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
19857 &        THEN
19858           pwr1d = pw*pwx1**(pw-1)*pwx1d
19859         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19860           pwr1d = pwx1d
19861         ELSE
19862           pwr1d = 0.0
19863         END IF
19864         pwr1 = pwx1**pw
19865         wi1d = -(gi1*pwr1d/pwr1**2)
19866         wi1 = gi1/pwr1
19867         pwx1d = beta2d
19868         pwx1 = eps + beta2
19869         IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
19870 &        THEN
19871           pwr1d = pw*pwx1**(pw-1)*pwx1d
19872         ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
19873           pwr1d = pwx1d
19874         ELSE
19875           pwr1d = 0.0
19876         END IF
19877         pwr1 = pwx1**pw
19878         wi2d = -(gi2*pwr1d/pwr1**2)
19879         wi2 = gi2/pwr1
19880         sumwkd = wi0d + wi1d + wi2d
19881         sumwk = wi0 + wi1 + wi2
19882         vfluxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
19883 &          f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
19884 &          +wi2*f2)*sumwkd)/sumwk**2
19885         vflux(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
19886       END DO
19887     END DO
19888 !           vflux(i,k) = vel*flux5(                                   &
19889 !                   w(i,k-3,j), w(i,k-2,j), w(i,k-1,j),       &
19890 !                   w(i,k  ,j), w(i,k+1,j), w(i,k+2,j),  -vel )
19891     DO i=i_start,i_end
19892       k = kts + 1
19893       vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)+w&
19894 &        (i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i, k-&
19895 &        1, j)))
19896       vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i, &
19897 &        k-1, j))
19898       k = kts + 2
19899       veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
19900       vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
19901       vfluxd(i, k) = veld*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
19902 &        (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1, &
19903 &        j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0) + vel*((7.*(&
19904 &        wd(i, k, j)+wd(i, k-1, j))-wd(i, k+1, j)-wd(i, k-2, j))/12.0+&
19905 &        SIGN(1, time_step)*SIGN(1., -vel)*(wd(i, k+1, j)-wd(i, k-2, j)-&
19906 &        3.*(wd(i, k, j)-wd(i, k-1, j)))/12.0)
19907       vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w(i&
19908 &        , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1, j)&
19909 &        -w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0)
19910       k = ktf
19911       veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
19912       vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
19913       vfluxd(i, k) = veld*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
19914 &        (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1, &
19915 &        j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0) + vel*((7.*(&
19916 &        wd(i, k, j)+wd(i, k-1, j))-wd(i, k+1, j)-wd(i, k-2, j))/12.0+&
19917 &        SIGN(1, time_step)*SIGN(1., -vel)*(wd(i, k+1, j)-wd(i, k-2, j)-&
19918 &        3.*(wd(i, k, j)-wd(i, k-1, j)))/12.0)
19919       vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w(i&
19920 &        , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1, j)&
19921 &        -w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0)
19922       k = ktf + 1
19923       vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)+w&
19924 &        (i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i, k-&
19925 &        1, j)))
19926       vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i, &
19927 &        k-1, j))
19928     END DO
19929     DO k=kts+1,ktf
19930       DO i=i_start,i_end
19931         tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k+1&
19932 &          )-vfluxd(i, k))
19933         tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)-&
19934 &          vflux(i, k))
19935       END DO
19936     END DO
19937 ! pick up flux contribution for w at the lid, wcs. 13 march 2004
19938     k = ktf + 1
19939     DO i=i_start,i_end
19940       tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i, k&
19941 &        )
19942       tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
19943     END DO
19944   END DO
19945 END SUBROUTINE G_ADVECT_WENO_W
19946
19947  END MODULE g_module_advect_em
19948