! ======================================================================================
! This file was generated by the version 5.3.6 of DFT on 07/15/2010. The differentiation
! transforming system(DFT) was jointly developed and sponsored by LASG of IAP(1998-2010)
! and LSEC of ICMSEC, AMSS(2001-2003)
! The copyright of the DFT system was declared by Walls at LASG, 1998-2010
! ======================================================================================
MODULE g_module_advect_em
USE module_bc !REVISED BY WALLS
USE module_model_constants
USE module_wrf_error
CONTAINS
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
! Differentiation of advect_u in forward (tangent) mode:
! variations of useful results: tendency
! with respect to varying inputs: rom u tendency u_old ru rv
! mut
! RW status of diff variables: rom:in u:in tendency:in-out u_old:in
! ru:in rv:in mut:in
SUBROUTINE G_ADVECT_U(u, ud, u_old, u_oldd, tendency, tendencyd, ru, rud&
& , rv, rvd, rom, romd, mut, mutd, time_step, config_flags, msfux, msfuy&
& , msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide, jds&
& , jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts&
& , kte)
IMPLICIT NONE
! Input data
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u, u_old, ru&
& , rv, rom
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ud, u_oldd, &
& rud, rvd, romd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
& msfvy, msftx, msfty
REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
REAL, INTENT(IN) :: rdx, rdy
INTEGER, INTENT(IN) :: time_step
! Local data
INTEGER :: i, j, k, itf, jtf, ktf
INTEGER :: i_start, i_end, j_start, j_end
INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
INTEGER :: jp1, jp0, jtmp
INTEGER :: horz_order, vert_order
REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
REAL :: ubd, vbd, vwd, dvmd, dvpd
REAL, DIMENSION(its:ite, kts:kte) :: vflux
REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
REAL, DIMENSION(its - 1:ite + 1, kts:kte) :: fqx
REAL, DIMENSION(its-1:ite+1, kts:kte) :: fqxd
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
LOGICAL :: degrade_xs, degrade_ys
LOGICAL :: degrade_xe, degrade_ye
! definition of flux operators, 3rd, 4th, 5th or 6th order
REAL :: flux3, flux4, flux5, flux6
REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
REAL :: veld
LOGICAL :: specified
specified = .false.
IF (config_flags%specified .OR. config_flags%nested) specified = &
& .true.
! set order for vertical and horzontal flux operators
horz_order = config_flags%h_mom_adv_order
vert_order = config_flags%v_mom_adv_order
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
! begin with horizontal flux divergence
IF (horz_order .EQ. 6) THEN
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 2) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 4) degrade_ye = .false.
!--------------- y - advection first
i_start = its
i_end = ite
IF (config_flags%open_xs .OR. specified) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_xe .OR. specified) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
j_end_f = jde - 3
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_6:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
! use full stencil
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
fqyd(i, k, jp1) = veld*(37.*(u(i, k, j)+u(i, k, j-1))-8.*(u(&
& i, k, j+1)+u(i, k, j-2))+(u(i, k, j+2)+u(i, k, j-3)))/60.0&
& + vel*(37.*(ud(i, k, j)+ud(i, k, j-1))-8.*(ud(i, k, j+1)+&
& ud(i, k, j-2))+ud(i, k, j+2)+ud(i, k, j-3))/60.0
fqy(i, k, jp1) = vel*((37.*(u(i, k, j)+u(i, k, j-1))-8.*(u(i&
& , k, j+1)+u(i, k, j-2))+(u(i, k, j+2)+u(i, k, j-3)))/60.0)
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! we must be close to some boundary where we need to reduce the order of the stencil
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
& k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
& j)+ud(i, k, j-1)))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
& )+u(i, k, j-1))
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
fqyd(i, k, jp1) = veld*(7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
& , j+1)+u(i, k, j-2)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k&
& , j-1))-ud(i, k, j+1)-ud(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
& , j+1)+u(i, k, j-2)))/12.0)
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
& k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
& j)+ud(i, k, j-1)))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
& )+u(i, k, j-1))
END DO
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
fqyd(i, k, jp1) = veld*(7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
& , j+1)+u(i, k, j-2)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k&
& , j-1))-ud(i, k, j+1)-ud(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
& , j+1)+u(i, k, j-2)))/12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! (j > j_start) will miss the u(,,jds) tendency
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
! This would be seen by (j > j_start) but we need to zero out the NP tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_6
! next, x - flux divergence
i_start = its
i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
i_start_f = ids + 3
END IF
IF (degrade_xe) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
i_end_f = ide - 2
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
fqxd(i, k) = veld*(37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k&
& , j)+u(i-2, k, j))+(u(i+2, k, j)+u(i-3, k, j)))/60.0 + vel*(&
& 37.*(ud(i, k, j)+ud(i-1, k, j))-8.*(ud(i+1, k, j)+ud(i-2, k&
& , j))+ud(i+2, k, j)+ud(i-3, k, j))/60.0
fqx(i, k) = vel*((37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k, &
& j)+u(i-2, k, j))+(u(i+2, k, j)+u(i-3, k, j)))/60.0)
END DO
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
! specified uses upstream normal wind at boundaries
IF (degrade_xs) THEN
IF (i_start .EQ. ids + 1) THEN
! second order flux next to the boundary
i = ids + 1
DO k=kts,ktf
ubd = ud(i-1, k, j)
ub = u(i-1, k, j)
IF (specified .AND. u(i, k, j) .LT. 0.) THEN
ubd = ud(i, k, j)
ub = u(i, k, j)
END IF
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i, k, j)&
& +ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)+ubd))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i, k, j)+ub)
END DO
END IF
i = ids + 2
DO k=kts,ktf
veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
fqxd(i, k) = veld*(7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+&
& u(i-2, k, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i-1, k, j))-ud&
& (i+1, k, j)-ud(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
& (i-2, k, j)))/12.0)
END DO
END IF
IF (degrade_xe) THEN
IF (i_end .EQ. ide - 1) THEN
! second order flux next to the boundary
i = ide
DO k=kts,ktf
ubd = ud(i, k, j)
ub = u(i, k, j)
IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
ubd = ud(i-1, k, j)
ub = u(i-1, k, j)
END IF
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i-1, k, &
& j)+ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i-1, k, j)+ubd))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i-1, k, j)+&
& ub)
END DO
END IF
DO k=kts,ktf
i = ide - 1
veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
fqxd(i, k) = veld*(7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+&
& u(i-2, k, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i-1, k, j))-ud&
& (i+1, k, j)-ud(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
& (i-2, k, j)))/12.0)
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 1st term on RHS
mrdx = msfux(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
ELSE IF (horz_order .EQ. 5) THEN
! 5th order horizontal flux calculation
! This code is EXACTLY the same as the 6th order code
! EXCEPT the 5th order and 3rd operators are used in
! place of the 6th and 4th order operators
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 2) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 4) degrade_ye = .false.
!--------------- y - advection first
i_start = its
i_end = ite
IF (config_flags%open_xs .OR. specified) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_xe .OR. specified) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
j_end_f = jde - 3
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_5:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
! use full stencil
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
fqyd(i, k, jp1) = veld*((37.*(u(i, k, j)+u(i, k, j-1))-8.*(u&
& (i, k, j+1)+u(i, k, j-2))+(u(i, k, j+2)+u(i, k, j-3)))/&
& 60.0-SIGN(1, time_step)*SIGN(1., vel)*(u(i, k, j+2)-u(i, k&
& , j-3)-5.*(u(i, k, j+1)-u(i, k, j-2))+10.*(u(i, k, j)-u(i&
& , k, j-1)))/60.0) + vel*((37.*(ud(i, k, j)+ud(i, k, j-1))-&
& 8.*(ud(i, k, j+1)+ud(i, k, j-2))+ud(i, k, j+2)+ud(i, k, j-&
& 3))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(ud(i, k, j+2)-&
& ud(i, k, j-3)-5.*(ud(i, k, j+1)-ud(i, k, j-2))+10.*(ud(i, &
& k, j)-ud(i, k, j-1)))/60.0)
fqy(i, k, jp1) = vel*((37.*(u(i, k, j)+u(i, k, j-1))-8.*(u(i&
& , k, j+1)+u(i, k, j-2))+(u(i, k, j+2)+u(i, k, j-3)))/60.0-&
& SIGN(1, time_step)*SIGN(1., vel)*(u(i, k, j+2)-u(i, k, j-3&
& )-5.*(u(i, k, j+1)-u(i, k, j-2))+10.*(u(i, k, j)-u(i, k, j&
& -1)))/60.0)
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! we must be close to some boundary where we need to reduce the order of the stencil
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
& k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
& j)+ud(i, k, j-1)))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
& )+u(i, k, j-1))
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
fqyd(i, k, jp1) = veld*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, &
& k, j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1&
& )))/12.0) + vel*((7.*(ud(i, k, j)+ud(i, k, j-1))-ud(i, k, &
& j+1)-ud(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (ud(i, k, j+1)-ud(i, k, j-2)-3.*(ud(i, k, j)-ud(i, k, j-1)&
& ))/12.0)
fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
& , j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))&
& /12.0)
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
& k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
& j)+ud(i, k, j-1)))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
& )+u(i, k, j-1))
END DO
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
fqyd(i, k, jp1) = veld*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, &
& k, j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1&
& )))/12.0) + vel*((7.*(ud(i, k, j)+ud(i, k, j-1))-ud(i, k, &
& j+1)-ud(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (ud(i, k, j+1)-ud(i, k, j-2)-3.*(ud(i, k, j)-ud(i, k, j-1)&
& ))/12.0)
fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
& , j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))&
& /12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! (j > j_start) will miss the u(,,jds) tendency
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
! This would be seen by (j > j_start) but we need to zero out the NP tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_5
! next, x - flux divergence
i_start = its
i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
i_start_f = ids + 3
END IF
IF (degrade_xe) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
i_end_f = ide - 2
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
fqxd(i, k) = veld*((37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k&
& , j)+u(i-2, k, j))+(u(i+2, k, j)+u(i-3, k, j)))/60.0-SIGN(1&
& , time_step)*SIGN(1., vel)*(u(i+2, k, j)-u(i-3, k, j)-5.*(u(&
& i+1, k, j)-u(i-2, k, j))+10.*(u(i, k, j)-u(i-1, k, j)))/60.0&
& ) + vel*((37.*(ud(i, k, j)+ud(i-1, k, j))-8.*(ud(i+1, k, j)+&
& ud(i-2, k, j))+ud(i+2, k, j)+ud(i-3, k, j))/60.0-SIGN(1, &
& time_step)*SIGN(1., vel)*(ud(i+2, k, j)-ud(i-3, k, j)-5.*(ud&
& (i+1, k, j)-ud(i-2, k, j))+10.*(ud(i, k, j)-ud(i-1, k, j)))/&
& 60.0)
fqx(i, k) = vel*((37.*(u(i, k, j)+u(i-1, k, j))-8.*(u(i+1, k, &
& j)+u(i-2, k, j))+(u(i+2, k, j)+u(i-3, k, j)))/60.0-SIGN(1, &
& time_step)*SIGN(1., vel)*(u(i+2, k, j)-u(i-3, k, j)-5.*(u(i+&
& 1, k, j)-u(i-2, k, j))+10.*(u(i, k, j)-u(i-1, k, j)))/60.0)
END DO
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
! specified uses upstream normal wind at boundaries
IF (degrade_xs) THEN
IF (i_start .EQ. ids + 1) THEN
! second order flux next to the boundary
i = ids + 1
DO k=kts,ktf
ubd = ud(i-1, k, j)
ub = u(i-1, k, j)
IF (specified .AND. u(i, k, j) .LT. 0.) THEN
ubd = ud(i, k, j)
ub = u(i, k, j)
END IF
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i, k, j)&
& +ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)+ubd))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i, k, j)+ub)
END DO
END IF
i = ids + 2
DO k=kts,ktf
veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
fqxd(i, k) = veld*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)&
& +u(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1&
& , k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0) + &
& vel*((7.*(ud(i, k, j)+ud(i-1, k, j))-ud(i+1, k, j)-ud(i-2, k&
& , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i+1, k, j)-&
& ud(i-2, k, j)-3.*(ud(i, k, j)-ud(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
& (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, &
& k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0)
END DO
END IF
IF (degrade_xe) THEN
IF (i_end .EQ. ide - 1) THEN
! second order flux next to the boundary
i = ide
DO k=kts,ktf
ubd = ud(i, k, j)
ub = u(i, k, j)
IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
ubd = ud(i-1, k, j)
ub = u(i-1, k, j)
END IF
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i-1, k, &
& j)+ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i-1, k, j)+ubd))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i-1, k, j)+&
& ub)
END DO
END IF
DO k=kts,ktf
i = ide - 1
veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
fqxd(i, k) = veld*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)&
& +u(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1&
& , k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0) + &
& vel*((7.*(ud(i, k, j)+ud(i-1, k, j))-ud(i+1, k, j)-ud(i-2, k&
& , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i+1, k, j)-&
& ud(i-2, k, j)-3.*(ud(i, k, j)-ud(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
& (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, &
& k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0)
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 1st term on RHS
mrdx = msfux(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
ELSE IF (horz_order .EQ. 4) THEN
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 2) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 1) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 2) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 3) degrade_ye = .false.
!--------------- x - advection first
i_start = its
i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
i_start = ids + 1
i_start_f = i_start + 1
END IF
IF (degrade_xe) THEN
i_end = ide - 1
i_end_f = ide - 1
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
fqxd(i, k) = veld*(7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+&
& u(i-2, k, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i-1, k, j))-ud&
& (i+1, k, j)-ud(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
& (i-2, k, j)))/12.0)
END DO
END DO
! second order flux close to boundaries (if not periodic or symmetric)
! specified uses upstream normal wind at boundaries
IF (degrade_xs) THEN
i = i_start
DO k=kts,ktf
ubd = ud(i-1, k, j)
ub = u(i-1, k, j)
IF (specified .AND. u(i, k, j) .LT. 0.) THEN
ubd = ud(i, k, j)
ub = u(i, k, j)
END IF
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i, k, j)+&
& ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)+ubd))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i, k, j)+ub)
END DO
END IF
IF (degrade_xe) THEN
i = i_end + 1
DO k=kts,ktf
ubd = ud(i, k, j)
ub = u(i, k, j)
IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
ubd = ud(i-1, k, j)
ub = u(i-1, k, j)
END IF
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i-1, k, j)&
& +ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i-1, k, j)+ubd))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i-1, k, j)+ub)
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 1st term on RHS
mrdx = msfux(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
! y flux divergence
i_start = its
i_end = ite
IF (config_flags%open_xs .OR. specified) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_xe .OR. specified) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
!CJM these may not work with tiling because they define j_start and end in terms of domain dim
IF (degrade_ys) THEN
j_start = jds + 1
j_start_f = j_start + 1
END IF
IF (degrade_ye) THEN
j_end = jde - 2
j_end_f = jde - 2
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
! j flux loop for v flux of u momentum
jp1 = 2
jp0 = 1
fqyd = 0.0
DO j=j_start,j_end+1
IF (j .LT. j_start_f .AND. degrade_ys) THEN
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j_start)+rvd(i-1, k, &
& j_start))*(u(i, k, j_start)+u(i, k, j_start-1))+(rv(i, k, &
& j_start)+rv(i-1, k, j_start))*(ud(i, k, j_start)+ud(i, k, &
& j_start-1)))
fqy(i, k, jp1) = 0.25*(rv(i, k, j_start)+rv(i-1, k, j_start)&
& )*(u(i, k, j_start)+u(i, k, j_start-1))
END DO
END DO
ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
DO k=kts,ktf
DO i=i_start,i_end
! Assumes j>j_end_f is ONLY j_end+1 ...
! fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1)) &
! *(u(i,k,j_end+1)+u(i,k,j_end))
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
& k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
& j)+ud(i, k, j-1)))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
& )+u(i, k, j-1))
END DO
END DO
ELSE
! 3rd or 4th order flux
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
fqyd(i, k, jp1) = veld*(7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
& , j+1)+u(i, k, j-2)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k&
& , j-1))-ud(i, k, j+1)-ud(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
& , j+1)+u(i, k, j-2)))/12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! (j > j_start) will miss the u(,,jds) tendency
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
! This would be seen by (j > j_start) but we need to zero out the NP tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO
ELSE IF (horz_order .EQ. 3) THEN
! As with the 5th and 6th order flux chioces, the 3rd and 4th order
! code is EXACTLY the same EXCEPT for the flux operator.
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 2) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 1) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 2) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 3) degrade_ye = .false.
!--------------- x - advection first
i_start = its
i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
i_start = ids + 1
i_start_f = i_start + 1
END IF
IF (degrade_xe) THEN
i_end = ide - 1
i_end_f = ide - 1
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
fqxd(i, k) = veld*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)&
& +u(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1&
& , k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0) + &
& vel*((7.*(ud(i, k, j)+ud(i-1, k, j))-ud(i+1, k, j)-ud(i-2, k&
& , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i+1, k, j)-&
& ud(i-2, k, j)-3.*(ud(i, k, j)-ud(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
& (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, &
& k, j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0)
END DO
END DO
! second order flux close to boundaries (if not periodic or symmetric)
! specified uses upstream normal wind at boundaries
IF (degrade_xs) THEN
i = i_start
DO k=kts,ktf
ubd = ud(i-1, k, j)
ub = u(i-1, k, j)
IF (specified .AND. u(i, k, j) .LT. 0.) THEN
ubd = ud(i, k, j)
ub = u(i, k, j)
END IF
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i, k, j)+&
& ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)+ubd))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i, k, j)+ub)
END DO
END IF
IF (degrade_xe) THEN
i = i_end + 1
DO k=kts,ktf
ubd = ud(i, k, j)
ub = u(i, k, j)
IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
ubd = ud(i-1, k, j)
ub = u(i-1, k, j)
END IF
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i-1, k, j)&
& +ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i-1, k, j)+ubd))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i-1, k, j)+ub)
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 1st term on RHS
mrdx = msfux(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
! y flux divergence
i_start = its
i_end = ite
IF (config_flags%open_xs .OR. specified) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_xe .OR. specified) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
!CJM these may not work with tiling because they define j_start and end in terms of domain dim
IF (degrade_ys) THEN
j_start = jds + 1
j_start_f = j_start + 1
END IF
IF (degrade_ye) THEN
j_end = jde - 2
j_end_f = jde - 2
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
! j flux loop for v flux of u momentum
jp1 = 2
jp0 = 1
fqyd = 0.0
DO j=j_start,j_end+1
IF (j .LT. j_start_f .AND. degrade_ys) THEN
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j_start)+rvd(i-1, k, &
& j_start))*(u(i, k, j_start)+u(i, k, j_start-1))+(rv(i, k, &
& j_start)+rv(i-1, k, j_start))*(ud(i, k, j_start)+ud(i, k, &
& j_start-1)))
fqy(i, k, jp1) = 0.25*(rv(i, k, j_start)+rv(i-1, k, j_start)&
& )*(u(i, k, j_start)+u(i, k, j_start-1))
END DO
END DO
ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
DO k=kts,ktf
DO i=i_start,i_end
! Assumes j>j_end_f is ONLY j_end+1 ...
! fqy(i, k, jp1) = 0.25*(rv(i,k,j_end+1)+rv(i-1,k,j_end+1)) &
! *(u(i,k,j_end+1)+u(i,k,j_end))
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, &
& k, j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, &
& j)+ud(i, k, j-1)))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j&
& )+u(i, k, j-1))
END DO
END DO
ELSE
! 3rd or 4th order flux
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
fqyd(i, k, jp1) = veld*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, &
& k, j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1&
& )))/12.0) + vel*((7.*(ud(i, k, j)+ud(i, k, j-1))-ud(i, k, &
& j+1)-ud(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (ud(i, k, j+1)-ud(i, k, j-2)-3.*(ud(i, k, j)-ud(i, k, j-1)&
& ))/12.0)
fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
& , j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))&
& /12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! (j > j_start) will miss the u(,,jds) tendency
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
! This would be seen by (j > j_start) but we need to zero out the NP tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO
ELSE IF (horz_order .EQ. 2) THEN
i_start = its
i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
IF (config_flags%open_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_xe) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
END IF
IF (specified) THEN
IF (ids + 2 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 2
END IF
END IF
IF (specified) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) i_end = ite
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 1st term on RHS
mrdx = msfux(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.25*((rud(i+1&
& , k, j)+rud(i, k, j))*(u(i+1, k, j)+u(i, k, j))+(ru(i+1, k, &
& j)+ru(i, k, j))*(ud(i+1, k, j)+ud(i, k, j))-(rud(i, k, j)+&
& rud(i-1, k, j))*(u(i, k, j)+u(i-1, k, j))-(ru(i, k, j)+ru(i-&
& 1, k, j))*(ud(i, k, j)+ud(i-1, k, j)))
tendency(i, k, j) = tendency(i, k, j) - mrdx*0.25*((ru(i+1, k&
& , j)+ru(i, k, j))*(u(i+1, k, j)+u(i, k, j))-(ru(i, k, j)+ru(&
& i-1, k, j))*(u(i, k, j)+u(i-1, k, j)))
END DO
END DO
END DO
IF (specified .AND. its .LE. ids + 1 .AND. (.NOT.config_flags%&
& periodic_x)) THEN
DO j=j_start,j_end
DO k=kts,ktf
i = ids + 1
! ADT eqn 44, 1st term on RHS
mrdx = msfux(i, j)*rdx
ubd = ud(i-1, k, j)
ub = u(i-1, k, j)
IF (u(i, k, j) .LT. 0.) THEN
ubd = ud(i, k, j)
ub = u(i, k, j)
END IF
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.25*((rud(i+1&
& , k, j)+rud(i, k, j))*(u(i+1, k, j)+u(i, k, j))+(ru(i+1, k, &
& j)+ru(i, k, j))*(ud(i+1, k, j)+ud(i, k, j))-(rud(i, k, j)+&
& rud(i-1, k, j))*(u(i, k, j)+ub)-(ru(i, k, j)+ru(i-1, k, j))*&
& (ud(i, k, j)+ubd))
tendency(i, k, j) = tendency(i, k, j) - mrdx*0.25*((ru(i+1, k&
& , j)+ru(i, k, j))*(u(i+1, k, j)+u(i, k, j))-(ru(i, k, j)+ru(&
& i-1, k, j))*(u(i, k, j)+ub))
END DO
END DO
END IF
IF (specified .AND. ite .GE. ide - 1 .AND. (.NOT.config_flags%&
& periodic_x)) THEN
DO j=j_start,j_end
DO k=kts,ktf
i = ide - 1
! ADT eqn 44, 1st term on RHS
mrdx = msfux(i, j)*rdx
ubd = ud(i+1, k, j)
ub = u(i+1, k, j)
IF (u(i, k, j) .GT. 0.) THEN
ubd = ud(i, k, j)
ub = u(i, k, j)
END IF
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.25*((rud(i+1&
& , k, j)+rud(i, k, j))*(ub+u(i, k, j))+(ru(i+1, k, j)+ru(i, k&
& , j))*(ubd+ud(i, k, j))-(rud(i, k, j)+rud(i-1, k, j))*(u(i, &
& k, j)+u(i-1, k, j))-(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)&
& +ud(i-1, k, j)))
tendency(i, k, j) = tendency(i, k, j) - mrdx*0.25*((ru(i+1, k&
& , j)+ru(i, k, j))*(ub+u(i, k, j))-(ru(i, k, j)+ru(i-1, k, j)&
& )*(u(i, k, j)+u(i-1, k, j)))
END DO
END DO
END IF
IF (config_flags%open_ys .OR. specified) THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF (config_flags%open_ye .OR. specified) THEN
IF (jde - 2 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 2
END IF
END IF
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 1st term on RHS
mrdy = msfux(i, j)*rdy
! Comments for polar boundary condition
! Flow is only from one side for points next to poles
IF (config_flags%polar .AND. j .EQ. jds) THEN
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.25*((rvd(i&
& , k, j+1)+rvd(i-1, k, j+1))*(u(i, k, j+1)+u(i, k, j))+(rv(&
& i, k, j+1)+rv(i-1, k, j+1))*(ud(i, k, j+1)+ud(i, k, j)))
tendency(i, k, j) = tendency(i, k, j) - mrdy*0.25*(rv(i, k, &
& j+1)+rv(i-1, k, j+1))*(u(i, k, j+1)+u(i, k, j))
ELSE IF (config_flags%polar .AND. j .EQ. jde - 1) THEN
tendencyd(i, k, j) = tendencyd(i, k, j) + mrdy*0.25*((rvd(i&
& , k, j)+rvd(i-1, k, j))*(u(i, k, j)+u(i, k, j-1))+(rv(i, k&
& , j)+rv(i-1, k, j))*(ud(i, k, j)+ud(i, k, j-1)))
tendency(i, k, j) = tendency(i, k, j) + mrdy*0.25*(rv(i, k, &
& j)+rv(i-1, k, j))*(u(i, k, j)+u(i, k, j-1))
ELSE
! Normal code
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.25*((rvd(i&
& , k, j+1)+rvd(i-1, k, j+1))*(u(i, k, j+1)+u(i, k, j))+(rv(&
& i, k, j+1)+rv(i-1, k, j+1))*(ud(i, k, j+1)+ud(i, k, j))-(&
& rvd(i, k, j)+rvd(i-1, k, j))*(u(i, k, j)+u(i, k, j-1))-(rv&
& (i, k, j)+rv(i-1, k, j))*(ud(i, k, j)+ud(i, k, j-1)))
tendency(i, k, j) = tendency(i, k, j) - mrdy*0.25*((rv(i, k&
& , j+1)+rv(i-1, k, j+1))*(u(i, k, j+1)+u(i, k, j))-(rv(i, k&
& , j)+rv(i-1, k, j))*(u(i, k, j)+u(i, k, j-1)))
END IF
END DO
END DO
END DO
ELSE IF (horz_order .NE. 0) THEN
! Just in case we want to turn horizontal advection off, we can do it
WRITE(wrf_err_message, *) &
& 'module_advect: advect_u_6a: h_order not known ', horz_order
CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
END IF
! radiative lateral boundary condition in x for normal velocity (u)
IF (config_flags%open_xs .AND. its .EQ. ids) THEN
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
DO j=j_start,j_end
DO k=kts,ktf
IF (ru(its, k, j) - cb*mut(its, j) .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = rud(its, k, j) - cb*mutd(its, j)
ub = ru(its, k, j) - cb*mut(its, j)
END IF
tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(u_old(&
& its+1, k, j)-u_old(its, k, j))+ub*(u_oldd(its+1, k, j)-u_oldd(&
& its, k, j)))
tendency(its, k, j) = tendency(its, k, j) - rdx*ub*(u_old(its+1&
& , k, j)-u_old(its, k, j))
END DO
END DO
END IF
IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
DO j=j_start,j_end
DO k=kts,ktf
IF (ru(ite, k, j) + cb*mut(ite-1, j) .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = rud(ite, k, j) + cb*mutd(ite-1, j)
ub = ru(ite, k, j) + cb*mut(ite-1, j)
END IF
tendencyd(ite, k, j) = tendencyd(ite, k, j) - rdx*(ubd*(u_old(&
& ite, k, j)-u_old(ite-1, k, j))+ub*(u_oldd(ite, k, j)-u_oldd(&
& ite-1, k, j)))
tendency(ite, k, j) = tendency(ite, k, j) - rdx*ub*(u_old(ite, k&
& , j)-u_old(ite-1, k, j))
END DO
END DO
END IF
! pick up the rest of the horizontal radiation boundary conditions.
! (these are the computations that don't require 'cb')
! first, set to index ranges
i_start = its
IF (ite .GT. ide) THEN
i_end = ide
ELSE
i_end = ite
END IF
imin = ids
imax = ide - 1
IF (config_flags%open_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
imin = ids
END IF
IF (config_flags%open_xe) THEN
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
imax = ide - 1
END IF
IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, jts)*rdy
IF (imax .GT. i) THEN
ip = i
ELSE
ip = imax
END IF
IF (imin .LT. i - 1) THEN
im = i - 1
ELSE
im = imin
END IF
DO k=kts,ktf
vwd = 0.5*(rvd(ip, k, jts)+rvd(im, k, jts))
vw = 0.5*(rv(ip, k, jts)+rv(im, k, jts))
IF (vw .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
dvmd = rvd(ip, k, jts+1) - rvd(ip, k, jts)
dvm = rv(ip, k, jts+1) - rv(ip, k, jts)
dvpd = rvd(im, k, jts+1) - rvd(im, k, jts)
dvp = rv(im, k, jts+1) - rv(im, k, jts)
tendencyd(i, k, jts) = tendencyd(i, k, jts) - mrdy*(vbd*(u_old(i&
& , k, jts+1)-u_old(i, k, jts))+vb*(u_oldd(i, k, jts+1)-u_oldd(i&
& , k, jts))+0.5*(ud(i, k, jts)*(dvm+dvp)+u(i, k, jts)*(dvmd+&
& dvpd)))
tendency(i, k, jts) = tendency(i, k, jts) - mrdy*(vb*(u_old(i, k&
& , jts+1)-u_old(i, k, jts))+0.5*u(i, k, jts)*(dvm+dvp))
END DO
END DO
END IF
IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, jte-1)*rdy
IF (imax .GT. i) THEN
ip = i
ELSE
ip = imax
END IF
IF (imin .LT. i - 1) THEN
im = i - 1
ELSE
im = imin
END IF
DO k=kts,ktf
vwd = 0.5*(rvd(ip, k, jte)+rvd(im, k, jte))
vw = 0.5*(rv(ip, k, jte)+rv(im, k, jte))
IF (vw .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
dvmd = rvd(ip, k, jte) - rvd(ip, k, jte-1)
dvm = rv(ip, k, jte) - rv(ip, k, jte-1)
dvpd = rvd(im, k, jte) - rvd(im, k, jte-1)
dvp = rv(im, k, jte) - rv(im, k, jte-1)
tendencyd(i, k, jte-1) = tendencyd(i, k, jte-1) - mrdy*(vbd*(&
& u_old(i, k, jte-1)-u_old(i, k, jte-2))+vb*(u_oldd(i, k, jte-1)&
& -u_oldd(i, k, jte-2))+0.5*(ud(i, k, jte-1)*(dvm+dvp)+u(i, k, &
& jte-1)*(dvmd+dvpd)))
tendency(i, k, jte-1) = tendency(i, k, jte-1) - mrdy*(vb*(u_old(&
& i, k, jte-1)-u_old(i, k, jte-2))+0.5*u(i, k, jte-1)*(dvm+dvp))
END DO
END DO
END IF
!-------------------- vertical advection
! ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
! Here we have: - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
! Since 'my' (map scale factor in y-direction) isn't a function of z,
! this is what we need, so leave unchanged in advect_u
i_start = its
i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
! IF ( config_flags%open_xe ) i_end = MIN(ide-1,ite)
IF (config_flags%open_ys .OR. specified) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_ye .OR. specified) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) i_end = ite
DO i=i_start,i_end
vfluxd(i, kts) = 0.0
vflux(i, kts) = 0.
vfluxd(i, kte) = 0.0
vflux(i, kte) = 0.
END DO
IF (vert_order .EQ. 6) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+3,ktf-2
DO i=i_start,i_end
veld = 0.5*(romd(i-1, k, j)+romd(i, k, j))
vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
vfluxd(i, k) = veld*(37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k+&
& 1, j)+u(i, k-2, j))+(u(i, k+2, j)+u(i, k-3, j)))/60.0 + vel*&
& (37.*(ud(i, k, j)+ud(i, k-1, j))-8.*(ud(i, k+1, j)+ud(i, k-2&
& , j))+ud(i, k+2, j)+ud(i, k-3, j))/60.0
vflux(i, k) = vel*((37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k+1&
& , j)+u(i, k-2, j))+(u(i, k+2, j)+u(i, k-3, j)))/60.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
& , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
& fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
& j)+fzp(k)*u(i, k-1, j))
k = kts + 2
veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
vfluxd(i, k) = veld*(7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+&
& u(i, k-2, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k-1, j))-ud(i&
& , k+1, j)-ud(i, k-2, j))/12.0
vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
& (i, k-2, j)))/12.0)
k = ktf - 1
veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
vfluxd(i, k) = veld*(7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+&
& u(i, k-2, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k-1, j))-ud(i&
& , k+1, j)-ud(i, k-2, j))/12.0
vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
& (i, k-2, j)))/12.0)
k = ktf
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
& , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
& fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
& j)+fzp(k)*u(i, k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 5) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+3,ktf-2
DO i=i_start,i_end
veld = 0.5*(romd(i-1, k, j)+romd(i, k, j))
vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
vfluxd(i, k) = veld*((37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k&
& +1, j)+u(i, k-2, j))+(u(i, k+2, j)+u(i, k-3, j)))/60.0-SIGN(&
& 1, time_step)*SIGN(1., -vel)*(u(i, k+2, j)-u(i, k-3, j)-5.*(&
& u(i, k+1, j)-u(i, k-2, j))+10.*(u(i, k, j)-u(i, k-1, j)))/&
& 60.0) + vel*((37.*(ud(i, k, j)+ud(i, k-1, j))-8.*(ud(i, k+1&
& , j)+ud(i, k-2, j))+ud(i, k+2, j)+ud(i, k-3, j))/60.0-SIGN(1&
& , time_step)*SIGN(1., -vel)*(ud(i, k+2, j)-ud(i, k-3, j)-5.*&
& (ud(i, k+1, j)-ud(i, k-2, j))+10.*(ud(i, k, j)-ud(i, k-1, j)&
& ))/60.0)
vflux(i, k) = vel*((37.*(u(i, k, j)+u(i, k-1, j))-8.*(u(i, k+1&
& , j)+u(i, k-2, j))+(u(i, k+2, j)+u(i, k-3, j)))/60.0-SIGN(1&
& , time_step)*SIGN(1., -vel)*(u(i, k+2, j)-u(i, k-3, j)-5.*(u&
& (i, k+1, j)-u(i, k-2, j))+10.*(u(i, k, j)-u(i, k-1, j)))/&
& 60.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
& , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
& fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
& j)+fzp(k)*u(i, k-1, j))
k = kts + 2
veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
vfluxd(i, k) = veld*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)&
& +u(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k&
& +1, j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0) + vel*&
& ((7.*(ud(i, k, j)+ud(i, k-1, j))-ud(i, k+1, j)-ud(i, k-2, j))/&
& 12.0+SIGN(1, time_step)*SIGN(1., -vel)*(ud(i, k+1, j)-ud(i, k-&
& 2, j)-3.*(ud(i, k, j)-ud(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1&
& , j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0)
k = ktf - 1
veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
vfluxd(i, k) = veld*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)&
& +u(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k&
& +1, j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0) + vel*&
& ((7.*(ud(i, k, j)+ud(i, k-1, j))-ud(i, k+1, j)-ud(i, k-2, j))/&
& 12.0+SIGN(1, time_step)*SIGN(1., -vel)*(ud(i, k+1, j)-ud(i, k-&
& 2, j)-3.*(ud(i, k, j)-ud(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1&
& , j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0)
k = ktf
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
& , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
& fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
& j)+fzp(k)*u(i, k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 4) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+2,ktf-1
DO i=i_start,i_end
veld = 0.5*(romd(i-1, k, j)+romd(i, k, j))
vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
vfluxd(i, k) = veld*(7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j&
& )+u(i, k-2, j)))/12.0 + vel*(7.*(ud(i, k, j)+ud(i, k-1, j))-&
& ud(i, k+1, j)-ud(i, k-2, j))/12.0
vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)&
& +u(i, k-2, j)))/12.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
& , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
& fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
& j)+fzp(k)*u(i, k-1, j))
k = ktf
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
& , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
& fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
& j)+fzp(k)*u(i, k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 3) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+2,ktf-1
DO i=i_start,i_end
veld = 0.5*(romd(i-1, k, j)+romd(i, k, j))
vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
vfluxd(i, k) = veld*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, &
& j)+u(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(&
& i, k+1, j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0) &
& + vel*((7.*(ud(i, k, j)+ud(i, k-1, j))-ud(i, k+1, j)-ud(i, k&
& -2, j))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(ud(i, k+1, j&
& )-ud(i, k-2, j)-3.*(ud(i, k, j)-ud(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)&
& +u(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i&
& , k+1, j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
& , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
& fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
& j)+fzp(k)*u(i, k-1, j))
k = ktf
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i&
& , k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(&
& fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, &
& j)+fzp(k)*u(i, k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 2) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+1,ktf
DO i=i_start,i_end
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(&
& i, k, j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*&
& (fzm(k)*ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k&
& , j)+fzp(k)*u(i, k-1, j))
END DO
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
END DO
ELSE
WRITE(wrf_err_message, *) &
& 'module_advect: advect_u_6a: v_order not known ', vert_order
CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
END IF
END SUBROUTINE G_ADVECT_U
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
! Differentiation of advect_v in forward (tangent) mode:
! variations of useful results: tendency
! with respect to varying inputs: rom tendency v v_old ru rv
! mut
! RW status of diff variables: rom:in tendency:in-out v:in v_old:in
! ru:in rv:in mut:in
SUBROUTINE G_ADVECT_V(v, vd, v_old, v_oldd, tendency, tendencyd, ru, rud&
& , rv, rvd, rom, romd, mut, mutd, time_step, config_flags, msfux, msfuy&
& , msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide, jds&
& , jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts&
& , kte)
IMPLICIT NONE
! Input data
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: v, v_old, ru&
& , rv, rom
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: vd, v_oldd, &
& rud, rvd, romd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
& msfvy, msftx, msfty
REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
REAL, INTENT(IN) :: rdx, rdy
INTEGER, INTENT(IN) :: time_step
! Local data
INTEGER :: i, j, k, itf, jtf, ktf
INTEGER :: i_start, i_end, j_start, j_end
INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
INTEGER :: jmin, jmax, jp, jm, imin, imax
REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
REAL :: ubd, vbd, uwd, dupd, dumd
REAL, DIMENSION(its:ite, kts:kte) :: vflux
REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
REAL, DIMENSION(its:ite+1, kts:kte) :: fqxd
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
INTEGER :: horz_order
INTEGER :: vert_order
LOGICAL :: degrade_xs, degrade_ys
LOGICAL :: degrade_xe, degrade_ye
INTEGER :: jp1, jp0, jtmp
! definition of flux operators, 3rd, 4th, 5th or 6th order
REAL :: flux3, flux4, flux5, flux6
REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
REAL :: veld
LOGICAL :: specified
REAL :: cb
specified = .false.
IF (config_flags%specified .OR. config_flags%nested) specified = &
& .true.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
horz_order = config_flags%h_mom_adv_order
vert_order = config_flags%v_mom_adv_order
! here is the choice of flux operators
IF (horz_order .EQ. 6) THEN
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 3) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 3) degrade_ye = .false.
!--------------- y - advection first
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
j_end_f = jde - 2
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_6:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
fqyd(i, k, jp1) = veld*(37.*(v(i, k, j)+v(i, k, j-1))-8.*(v(&
& i, k, j+1)+v(i, k, j-2))+(v(i, k, j+2)+v(i, k, j-3)))/60.0&
& + vel*(37.*(vd(i, k, j)+vd(i, k, j-1))-8.*(vd(i, k, j+1)+&
& vd(i, k, j-2))+vd(i, k, j+2)+vd(i, k, j-3))/60.0
fqy(i, k, jp1) = vel*((37.*(v(i, k, j)+v(i, k, j-1))-8.*(v(i&
& , k, j+1)+v(i, k, j-2))+(v(i, k, j+2)+v(i, k, j-3)))/60.0)
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! we must be close to some boundary where we need to reduce the order of the stencil
! specified uses upstream normal wind at boundaries
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
vbd = vd(i, k, j-1)
vb = v(i, k, j-1)
IF (specified .AND. v(i, k, j) .LT. 0.) THEN
vbd = vd(i, k, j)
vb = v(i, k, j)
END IF
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(v(i, &
& k, j)+vb)+(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)+vbd))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(v(i, k, j&
& )+vb)
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
fqyd(i, k, jp1) = veld*(7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
& , j+1)+v(i, k, j-2)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k&
& , j-1))-vd(i, k, j+1)-vd(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
& , j+1)+v(i, k, j-2)))/12.0)
END DO
END DO
ELSE IF (j .EQ. jde) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
vbd = vd(i, k, j)
vb = v(i, k, j)
IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
vbd = vd(i, k, j-1)
vb = v(i, k, j-1)
END IF
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(vb+v(&
& i, k, j-1))+(rv(i, k, j)+rv(i, k, j-1))*(vbd+vd(i, k, j-1)&
& ))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(vb+v(i, k&
& , j-1))
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
fqyd(i, k, jp1) = veld*(7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
& , j+1)+v(i, k, j-2)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k&
& , j-1))-vd(i, k, j+1)-vd(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
& , j+1)+v(i, k, j-2)))/12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! Comments on polar boundary conditions
! No advection over the poles means tendencies (held from jds [S. pole]
! to jde [N pole], i.e., on v grid) must be zero at poles
! [tendency(jds) and tendency(jde)=0]
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j-1) = 0.0
tendency(i, k, j-1) = 0.
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
! If j_end were set to jde in a special if statement apart from
! degrade_ye, then we would hit the next conditional. But since
! we want the tendency to be zero anyway, not looping to jde+1
! will produce the same effect.
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j-1) = 0.0
tendency(i, k, j-1) = 0.
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! Normal code
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 2nd term on RHS
mrdy = msfvy(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_6
! next, x - flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
! Polar boundary conditions are like open or specified
IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jde - 1 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 1
END IF
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
IF (i_start + 2 .GT. ids + 3) THEN
i_start_f = ids + 3
ELSE
i_start_f = i_start + 2
END IF
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
fqxd(i, k) = veld*(37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k&
& , j)+v(i-2, k, j))+(v(i+2, k, j)+v(i-3, k, j)))/60.0 + vel*(&
& 37.*(vd(i, k, j)+vd(i-1, k, j))-8.*(vd(i+1, k, j)+vd(i-2, k&
& , j))+vd(i+2, k, j)+vd(i-3, k, j))/60.0
fqx(i, k) = vel*((37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k, &
& j)+v(i-2, k, j))+(v(i+2, k, j)+v(i-3, k, j)))/60.0)
END DO
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts,ktf
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i, k, j-1))*(v(i, k, &
& j)+v(i-1, k, j))+(ru(i, k, j)+ru(i, k, j-1))*(vd(i, k, j&
& )+vd(i-1, k, j)))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i, k, j-1))*(v(i, k, j)+v&
& (i-1, k, j))
END DO
END IF
IF (i .EQ. ids + 2) THEN
! third order
DO k=kts,ktf
veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
fqxd(i, k) = veld*(7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k&
& , j)+v(i-2, k, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i-1, &
& k, j))-vd(i+1, k, j)-vd(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
& j)+v(i-2, k, j)))/12.0)
END DO
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts,ktf
fqxd(i, k) = 0.25*((rud(i_end+1, k, j)+rud(i_end+1, k, j-1&
& ))*(v(i_end+1, k, j)+v(i_end, k, j))+(ru(i_end+1, k, j)+&
& ru(i_end+1, k, j-1))*(vd(i_end+1, k, j)+vd(i_end, k, j))&
& )
fqx(i, k) = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*(&
& v(i_end+1, k, j)+v(i_end, k, j))
END DO
END IF
IF (i .EQ. ide - 2) THEN
! third order flux one in from the boundary
DO k=kts,ktf
veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
fqxd(i, k) = veld*(7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k&
& , j)+v(i-2, k, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i-1, &
& k, j))-vd(i+1, k, j)-vd(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
& j)+v(i-2, k, j)))/12.0)
END DO
END IF
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 1st term on RHS
mrdx = msfvy(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
ELSE IF (horz_order .EQ. 5) THEN
! 5th order horizontal flux calculation
! This code is EXACTLY the same as the 6th order code
! EXCEPT the 5th order and 3rd operators are used in
! place of the 6th and 4th order operators
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 3) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 3) degrade_ye = .false.
!--------------- y - advection first
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
j_end_f = jde - 2
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_5:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
fqyd(i, k, jp1) = veld*((37.*(v(i, k, j)+v(i, k, j-1))-8.*(v&
& (i, k, j+1)+v(i, k, j-2))+(v(i, k, j+2)+v(i, k, j-3)))/&
& 60.0-SIGN(1, time_step)*SIGN(1., vel)*(v(i, k, j+2)-v(i, k&
& , j-3)-5.*(v(i, k, j+1)-v(i, k, j-2))+10.*(v(i, k, j)-v(i&
& , k, j-1)))/60.0) + vel*((37.*(vd(i, k, j)+vd(i, k, j-1))-&
& 8.*(vd(i, k, j+1)+vd(i, k, j-2))+vd(i, k, j+2)+vd(i, k, j-&
& 3))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(vd(i, k, j+2)-&
& vd(i, k, j-3)-5.*(vd(i, k, j+1)-vd(i, k, j-2))+10.*(vd(i, &
& k, j)-vd(i, k, j-1)))/60.0)
fqy(i, k, jp1) = vel*((37.*(v(i, k, j)+v(i, k, j-1))-8.*(v(i&
& , k, j+1)+v(i, k, j-2))+(v(i, k, j+2)+v(i, k, j-3)))/60.0-&
& SIGN(1, time_step)*SIGN(1., vel)*(v(i, k, j+2)-v(i, k, j-3&
& )-5.*(v(i, k, j+1)-v(i, k, j-2))+10.*(v(i, k, j)-v(i, k, j&
& -1)))/60.0)
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! we must be close to some boundary where we need to reduce the order of the stencil
! specified uses upstream normal wind at boundaries
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
vbd = vd(i, k, j-1)
vb = v(i, k, j-1)
IF (specified .AND. v(i, k, j) .LT. 0.) THEN
vbd = vd(i, k, j)
vb = v(i, k, j)
END IF
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(v(i, &
& k, j)+vb)+(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)+vbd))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(v(i, k, j&
& )+vb)
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
fqyd(i, k, jp1) = veld*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, &
& k, j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1&
& )))/12.0) + vel*((7.*(vd(i, k, j)+vd(i, k, j-1))-vd(i, k, &
& j+1)-vd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (vd(i, k, j+1)-vd(i, k, j-2)-3.*(vd(i, k, j)-vd(i, k, j-1)&
& ))/12.0)
fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
& , j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))&
& /12.0)
END DO
END DO
ELSE IF (j .EQ. jde) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
vbd = vd(i, k, j)
vb = v(i, k, j)
IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
vbd = vd(i, k, j-1)
vb = v(i, k, j-1)
END IF
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(vb+v(&
& i, k, j-1))+(rv(i, k, j)+rv(i, k, j-1))*(vbd+vd(i, k, j-1)&
& ))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(vb+v(i, k&
& , j-1))
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
fqyd(i, k, jp1) = veld*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, &
& k, j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1&
& )))/12.0) + vel*((7.*(vd(i, k, j)+vd(i, k, j-1))-vd(i, k, &
& j+1)-vd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (vd(i, k, j+1)-vd(i, k, j-2)-3.*(vd(i, k, j)-vd(i, k, j-1)&
& ))/12.0)
fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
& , j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))&
& /12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! Comments on polar boundary conditions
! No advection over the poles means tendencies (held from jds [S. pole]
! to jde [N pole], i.e., on v grid) must be zero at poles
! [tendency(jds) and tendency(jde)=0]
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j-1) = 0.0
tendency(i, k, j-1) = 0.
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
! If j_end were set to jde in a special if statement apart from
! degrade_ye, then we would hit the next conditional. But since
! we want the tendency to be zero anyway, not looping to jde+1
! will produce the same effect.
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j-1) = 0.0
tendency(i, k, j-1) = 0.
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! Normal code
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 2nd term on RHS
mrdy = msfvy(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_5
! next, x - flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
! Polar boundary conditions are like open or specified
IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jde - 1 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 1
END IF
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
IF (i_start + 2 .GT. ids + 3) THEN
i_start_f = ids + 3
ELSE
i_start_f = i_start + 2
END IF
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
fqxd(i, k) = veld*((37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k&
& , j)+v(i-2, k, j))+(v(i+2, k, j)+v(i-3, k, j)))/60.0-SIGN(1&
& , time_step)*SIGN(1., vel)*(v(i+2, k, j)-v(i-3, k, j)-5.*(v(&
& i+1, k, j)-v(i-2, k, j))+10.*(v(i, k, j)-v(i-1, k, j)))/60.0&
& ) + vel*((37.*(vd(i, k, j)+vd(i-1, k, j))-8.*(vd(i+1, k, j)+&
& vd(i-2, k, j))+vd(i+2, k, j)+vd(i-3, k, j))/60.0-SIGN(1, &
& time_step)*SIGN(1., vel)*(vd(i+2, k, j)-vd(i-3, k, j)-5.*(vd&
& (i+1, k, j)-vd(i-2, k, j))+10.*(vd(i, k, j)-vd(i-1, k, j)))/&
& 60.0)
fqx(i, k) = vel*((37.*(v(i, k, j)+v(i-1, k, j))-8.*(v(i+1, k, &
& j)+v(i-2, k, j))+(v(i+2, k, j)+v(i-3, k, j)))/60.0-SIGN(1, &
& time_step)*SIGN(1., vel)*(v(i+2, k, j)-v(i-3, k, j)-5.*(v(i+&
& 1, k, j)-v(i-2, k, j))+10.*(v(i, k, j)-v(i-1, k, j)))/60.0)
END DO
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts,ktf
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i, k, j-1))*(v(i, k, &
& j)+v(i-1, k, j))+(ru(i, k, j)+ru(i, k, j-1))*(vd(i, k, j&
& )+vd(i-1, k, j)))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i, k, j-1))*(v(i, k, j)+v&
& (i-1, k, j))
END DO
END IF
IF (i .EQ. ids + 2) THEN
! third order
DO k=kts,ktf
veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
fqxd(i, k) = veld*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k&
& , j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(v(i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)&
& ))/12.0) + vel*((7.*(vd(i, k, j)+vd(i-1, k, j))-vd(i+1, &
& k, j)-vd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(vd(i+1, k, j)-vd(i-2, k, j)-3.*(vd(i, k, j)-vd(i-1&
& , k, j)))/12.0)
fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
& j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (v(i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))&
& /12.0)
END DO
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts,ktf
fqxd(i, k) = 0.25*((rud(i_end+1, k, j)+rud(i_end+1, k, j-1&
& ))*(v(i_end+1, k, j)+v(i_end, k, j))+(ru(i_end+1, k, j)+&
& ru(i_end+1, k, j-1))*(vd(i_end+1, k, j)+vd(i_end, k, j))&
& )
fqx(i, k) = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*(&
& v(i_end+1, k, j)+v(i_end, k, j))
END DO
END IF
IF (i .EQ. ide - 2) THEN
! third order flux one in from the boundary
DO k=kts,ktf
veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
fqxd(i, k) = veld*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k&
& , j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(v(i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)&
& ))/12.0) + vel*((7.*(vd(i, k, j)+vd(i-1, k, j))-vd(i+1, &
& k, j)-vd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(vd(i+1, k, j)-vd(i-2, k, j)-3.*(vd(i, k, j)-vd(i-1&
& , k, j)))/12.0)
fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
& j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (v(i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))&
& /12.0)
END DO
END IF
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 1st term on RHS
mrdx = msfvy(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
ELSE IF (horz_order .EQ. 4) THEN
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 2) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 2) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 2) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 2) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
!CJM May not work with tiling because defined in terms of domain dims
IF (degrade_ys) THEN
j_start = jds + 1
j_start_f = j_start + 1
END IF
IF (degrade_ye) THEN
j_end = jde - 1
j_end_f = jde - 1
END IF
! compute fluxes
! specified uses upstream normal wind at boundaries
jp0 = 1
jp1 = 2
fqyd = 0.0
DO j=j_start,j_end+1
IF (j .EQ. j_start .AND. degrade_ys) THEN
DO k=kts,ktf
DO i=i_start,i_end
vbd = vd(i, k, j-1)
vb = v(i, k, j-1)
IF (specified .AND. v(i, k, j) .LT. 0.) THEN
vbd = vd(i, k, j)
vb = v(i, k, j)
END IF
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(v(i, &
& k, j)+vb)+(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)+vbd))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(v(i, k, j&
& )+vb)
END DO
END DO
ELSE IF (j .EQ. j_end + 1 .AND. degrade_ye) THEN
DO k=kts,ktf
DO i=i_start,i_end
vbd = vd(i, k, j)
vb = v(i, k, j)
IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
vbd = vd(i, k, j-1)
vb = v(i, k, j-1)
END IF
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(vb+v(&
& i, k, j-1))+(rv(i, k, j)+rv(i, k, j-1))*(vbd+vd(i, k, j-1)&
& ))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(vb+v(i, k&
& , j-1))
END DO
END DO
ELSE
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
fqyd(i, k, jp1) = veld*(7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
& , j+1)+v(i, k, j-2)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k&
& , j-1))-vd(i, k, j+1)-vd(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
& , j+1)+v(i, k, j-2)))/12.0)
END DO
END DO
END IF
! Comments on polar boundary conditions
! No advection over the poles means tendencies (held from jds [S. pole]
! to jde [N pole], i.e., on v grid) must be zero at poles
! [tendency(jds) and tendency(jde)=0]
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j-1) = 0.0
tendency(i, k, j-1) = 0.
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
! If j_end were set to jde in a special if statement apart from
! degrade_ye, then we would hit the next conditional. But since
! we want the tendency to be zero anyway, not looping to jde+1
! will produce the same effect.
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j-1) = 0.0
tendency(i, k, j-1) = 0.
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! Normal code
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 2nd term on RHS
mrdy = msfvy(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO
! next, x - flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
! Polar boundary conditions are like open or specified
IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jde - 1 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 1
END IF
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
i_start = ids + 1
i_start_f = i_start + 1
END IF
IF (degrade_xe) THEN
i_end = ide - 2
i_end_f = ide - 2
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 3rd or 4th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
fqxd(i, k) = veld*(7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)+&
& v(i-2, k, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i-1, k, j))-vd&
& (i+1, k, j)-vd(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)+v&
& (i-2, k, j)))/12.0)
END DO
END DO
! second order flux close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO k=kts,ktf
fqxd(i_start, k) = 0.25*((rud(i_start, k, j)+rud(i_start, k, j&
& -1))*(v(i_start, k, j)+v(i_start-1, k, j))+(ru(i_start, k, j&
& )+ru(i_start, k, j-1))*(vd(i_start, k, j)+vd(i_start-1, k, j&
& )))
fqx(i_start, k) = 0.25*(ru(i_start, k, j)+ru(i_start, k, j-1))&
& *(v(i_start, k, j)+v(i_start-1, k, j))
END DO
END IF
IF (degrade_xe) THEN
DO k=kts,ktf
fqxd(i_end+1, k) = 0.25*((rud(i_end+1, k, j)+rud(i_end+1, k, j&
& -1))*(v(i_end+1, k, j)+v(i_end, k, j))+(ru(i_end+1, k, j)+ru&
& (i_end+1, k, j-1))*(vd(i_end+1, k, j)+vd(i_end, k, j)))
fqx(i_end+1, k) = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))&
& *(v(i_end+1, k, j)+v(i_end, k, j))
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 1st term on RHS
mrdx = msfvy(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
ELSE IF (horz_order .EQ. 3) THEN
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 2) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 2) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 2) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 2) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
!CJM May not work with tiling because defined in terms of domain dims
IF (degrade_ys) THEN
j_start = jds + 1
j_start_f = j_start + 1
END IF
IF (degrade_ye) THEN
j_end = jde - 1
j_end_f = jde - 1
END IF
! compute fluxes
! specified uses upstream normal wind at boundaries
jp0 = 1
jp1 = 2
fqyd = 0.0
DO j=j_start,j_end+1
IF (j .EQ. j_start .AND. degrade_ys) THEN
DO k=kts,ktf
DO i=i_start,i_end
vbd = vd(i, k, j-1)
vb = v(i, k, j-1)
IF (specified .AND. v(i, k, j) .LT. 0.) THEN
vbd = vd(i, k, j)
vb = v(i, k, j)
END IF
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(v(i, &
& k, j)+vb)+(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)+vbd))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(v(i, k, j&
& )+vb)
END DO
END DO
ELSE IF (j .EQ. j_end + 1 .AND. degrade_ye) THEN
DO k=kts,ktf
DO i=i_start,i_end
vbd = vd(i, k, j)
vb = v(i, k, j)
IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
vbd = vd(i, k, j-1)
vb = v(i, k, j-1)
END IF
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(vb+v(&
& i, k, j-1))+(rv(i, k, j)+rv(i, k, j-1))*(vbd+vd(i, k, j-1)&
& ))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(vb+v(i, k&
& , j-1))
END DO
END DO
ELSE
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
fqyd(i, k, jp1) = veld*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, &
& k, j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1&
& )))/12.0) + vel*((7.*(vd(i, k, j)+vd(i, k, j-1))-vd(i, k, &
& j+1)-vd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (vd(i, k, j+1)-vd(i, k, j-2)-3.*(vd(i, k, j)-vd(i, k, j-1)&
& ))/12.0)
fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
& , j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))&
& /12.0)
END DO
END DO
END IF
! Comments on polar boundary conditions
! No advection over the poles means tendencies (held from jds [S. pole]
! to jde [N pole], i.e., on v grid) must be zero at poles
! [tendency(jds) and tendency(jde)=0]
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j-1) = 0.0
tendency(i, k, j-1) = 0.
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
! If j_end were set to jde in a special if statement apart from
! degrade_ye, then we would hit the next conditional. But since
! we want the tendency to be zero anyway, not looping to jde+1
! will produce the same effect.
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j-1) = 0.0
tendency(i, k, j-1) = 0.
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! Normal code
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 2nd term on RHS
mrdy = msfvy(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO
! next, x - flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
! Polar boundary conditions are like open or specified
IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jde - 1 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 1
END IF
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
i_start = ids + 1
i_start_f = i_start + 1
END IF
IF (degrade_xe) THEN
i_end = ide - 2
i_end_f = ide - 2
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 3rd or 4th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
fqxd(i, k) = veld*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)&
& +v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(i+1&
& , k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/12.0) + &
& vel*((7.*(vd(i, k, j)+vd(i-1, k, j))-vd(i+1, k, j)-vd(i-2, k&
& , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(vd(i+1, k, j)-&
& vd(i-2, k, j)-3.*(vd(i, k, j)-vd(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)+v&
& (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(i+1, &
& k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/12.0)
END DO
END DO
! second order flux close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO k=kts,ktf
fqxd(i_start, k) = 0.25*((rud(i_start, k, j)+rud(i_start, k, j&
& -1))*(v(i_start, k, j)+v(i_start-1, k, j))+(ru(i_start, k, j&
& )+ru(i_start, k, j-1))*(vd(i_start, k, j)+vd(i_start-1, k, j&
& )))
fqx(i_start, k) = 0.25*(ru(i_start, k, j)+ru(i_start, k, j-1))&
& *(v(i_start, k, j)+v(i_start-1, k, j))
END DO
END IF
IF (degrade_xe) THEN
DO k=kts,ktf
fqxd(i_end+1, k) = 0.25*((rud(i_end+1, k, j)+rud(i_end+1, k, j&
& -1))*(v(i_end+1, k, j)+v(i_end, k, j))+(ru(i_end+1, k, j)+ru&
& (i_end+1, k, j-1))*(vd(i_end+1, k, j)+vd(i_end, k, j)))
fqx(i_end+1, k) = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))&
& *(v(i_end+1, k, j)+v(i_end, k, j))
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 1st term on RHS
mrdx = msfvy(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
ELSE IF (horz_order .EQ. 2) THEN
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
IF (config_flags%open_ys) THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF (config_flags%open_ye) THEN
IF (jde - 1 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 1
END IF
END IF
IF (specified) THEN
IF (jds + 2 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 2
END IF
END IF
IF (specified) THEN
IF (jde - 2 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 2
END IF
END IF
IF (config_flags%polar) THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF (config_flags%polar) THEN
IF (jde - 1 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 1
END IF
END IF
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 2nd term on RHS
mrdy = msfvy(i, j)*rdy
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.25*((rvd(i, k&
& , j+1)+rvd(i, k, j))*(v(i, k, j+1)+v(i, k, j))+(rv(i, k, j+1&
& )+rv(i, k, j))*(vd(i, k, j+1)+vd(i, k, j))-(rvd(i, k, j)+rvd&
& (i, k, j-1))*(v(i, k, j)+v(i, k, j-1))-(rv(i, k, j)+rv(i, k&
& , j-1))*(vd(i, k, j)+vd(i, k, j-1)))
tendency(i, k, j) = tendency(i, k, j) - mrdy*0.25*((rv(i, k, j&
& +1)+rv(i, k, j))*(v(i, k, j+1)+v(i, k, j))-(rv(i, k, j)+rv(i&
& , k, j-1))*(v(i, k, j)+v(i, k, j-1)))
END DO
END DO
END DO
! Comments on polar boundary conditions
! tendencies = 0 at poles, and polar points do not contribute at points
! next to poles
IF (config_flags%polar) THEN
IF (jts .EQ. jds) THEN
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, jds) = 0.0
tendency(i, k, jds) = 0.
END DO
END DO
END IF
IF (jte .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, jde) = 0.0
tendency(i, k, jde) = 0.
END DO
END DO
END IF
END IF
! specified uses upstream normal wind at boundaries
IF (specified .AND. jts .LE. jds + 1) THEN
j = jds + 1
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 2nd term on RHS
mrdy = msfvy(i, j)*rdy
vbd = vd(i, k, j-1)
vb = v(i, k, j-1)
IF (v(i, k, j) .LT. 0.) THEN
vbd = vd(i, k, j)
vb = v(i, k, j)
END IF
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.25*((rvd(i, k&
& , j+1)+rvd(i, k, j))*(v(i, k, j+1)+v(i, k, j))+(rv(i, k, j+1&
& )+rv(i, k, j))*(vd(i, k, j+1)+vd(i, k, j))-(rvd(i, k, j)+rvd&
& (i, k, j-1))*(v(i, k, j)+vb)-(rv(i, k, j)+rv(i, k, j-1))*(vd&
& (i, k, j)+vbd))
tendency(i, k, j) = tendency(i, k, j) - mrdy*0.25*((rv(i, k, j&
& +1)+rv(i, k, j))*(v(i, k, j+1)+v(i, k, j))-(rv(i, k, j)+rv(i&
& , k, j-1))*(v(i, k, j)+vb))
END DO
END DO
END IF
IF (specified .AND. jte .GE. jde - 1) THEN
j = jde - 1
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 2nd term on RHS
mrdy = msfvy(i, j)*rdy
vbd = vd(i, k, j+1)
vb = v(i, k, j+1)
IF (v(i, k, j) .GT. 0.) THEN
vbd = vd(i, k, j)
vb = v(i, k, j)
END IF
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.25*((rvd(i, k&
& , j+1)+rvd(i, k, j))*(vb+v(i, k, j))+(rv(i, k, j+1)+rv(i, k&
& , j))*(vbd+vd(i, k, j))-(rvd(i, k, j)+rvd(i, k, j-1))*(v(i, &
& k, j)+v(i, k, j-1))-(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)&
& +vd(i, k, j-1)))
tendency(i, k, j) = tendency(i, k, j) - mrdy*0.25*((rv(i, k, j&
& +1)+rv(i, k, j))*(vb+v(i, k, j))-(rv(i, k, j)+rv(i, k, j-1))&
& *(v(i, k, j)+v(i, k, j-1)))
END DO
END DO
END IF
IF (.NOT.config_flags%periodic_x) THEN
IF (config_flags%open_xs .OR. specified) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_xe .OR. specified) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
END IF
END IF
IF (config_flags%polar) THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF (config_flags%polar) THEN
IF (jde - 1 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 1
END IF
END IF
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 1st term on RHS
mrdx = msfvy(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.25*((rud(i+1&
& , k, j)+rud(i+1, k, j-1))*(v(i+1, k, j)+v(i, k, j))+(ru(i+1&
& , k, j)+ru(i+1, k, j-1))*(vd(i+1, k, j)+vd(i, k, j))-(rud(i&
& , k, j)+rud(i, k, j-1))*(v(i, k, j)+v(i-1, k, j))-(ru(i, k, &
& j)+ru(i, k, j-1))*(vd(i, k, j)+vd(i-1, k, j)))
tendency(i, k, j) = tendency(i, k, j) - mrdx*0.25*((ru(i+1, k&
& , j)+ru(i+1, k, j-1))*(v(i+1, k, j)+v(i, k, j))-(ru(i, k, j)&
& +ru(i, k, j-1))*(v(i, k, j)+v(i-1, k, j)))
END DO
END DO
END DO
ELSE IF (horz_order .NE. 0) THEN
! Just in case we want to turn horizontal advection off, we can do it
WRITE(wrf_err_message, *) &
& 'module_advect: advect_v_6a: h_order not known ', horz_order
CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
END IF
! Comments on polar boundary condition
! Force tendency=0 at NP and SP
! We keep setting this everywhere, but it can't hurt...
IF (config_flags%polar .AND. jts .EQ. jds) THEN
DO i=its,ite
DO k=kts,ktf
tendencyd(i, k, jts) = 0.0
tendency(i, k, jts) = 0.
END DO
END DO
END IF
IF (config_flags%polar .AND. jte .EQ. jde) THEN
DO i=its,ite
DO k=kts,ktf
tendencyd(i, k, jte) = 0.0
tendency(i, k, jte) = 0.
END DO
END DO
END IF
! radiative lateral boundary condition in y for normal velocity (v)
IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
DO i=i_start,i_end
DO k=kts,ktf
IF (rv(i, k, jts) - cb*mut(i, jts) .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = rvd(i, k, jts) - cb*mutd(i, jts)
vb = rv(i, k, jts) - cb*mut(i, jts)
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(v_old(i&
& , k, jts+1)-v_old(i, k, jts))+vb*(v_oldd(i, k, jts+1)-v_oldd(i&
& , k, jts)))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*vb*(v_old(i, k, &
& jts+1)-v_old(i, k, jts))
END DO
END DO
END IF
IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
DO i=i_start,i_end
DO k=kts,ktf
IF (rv(i, k, jte) + cb*mut(i, jte-1) .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = rvd(i, k, jte) + cb*mutd(i, jte-1)
vb = rv(i, k, jte) + cb*mut(i, jte-1)
END IF
tendencyd(i, k, jte) = tendencyd(i, k, jte) - rdy*(vbd*(v_old(i&
& , k, jte)-v_old(i, k, jte-1))+vb*(v_oldd(i, k, jte)-v_oldd(i, &
& k, jte-1)))
tendency(i, k, jte) = tendency(i, k, jte) - rdy*vb*(v_old(i, k, &
& jte)-v_old(i, k, jte-1))
END DO
END DO
END IF
! pick up the rest of the horizontal radiation boundary conditions.
! (these are the computations that don't require 'cb'.
! first, set to index ranges
j_start = jts
IF (jte .GT. jde) THEN
j_end = jde
ELSE
j_end = jte
END IF
jmin = jds
jmax = jde - 1
IF (config_flags%open_ys) THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
jmin = jds
END IF
IF (config_flags%open_ye) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
jmax = jde - 1
END IF
! compute x (u) conditions for v, w, or scalar
IF (config_flags%open_xs .AND. its .EQ. ids) THEN
DO j=j_start,j_end
! ADT eqn 45, 1st term on RHS
mrdx = msfvy(its, j)*rdx
IF (jmax .GT. j) THEN
jp = j
ELSE
jp = jmax
END IF
IF (jmin .LT. j - 1) THEN
jm = j - 1
ELSE
jm = jmin
END IF
DO k=kts,ktf
uwd = 0.5*(rud(its, k, jp)+rud(its, k, jm))
uw = 0.5*(ru(its, k, jp)+ru(its, k, jm))
IF (uw .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
dupd = rud(its+1, k, jp) - rud(its, k, jp)
dup = ru(its+1, k, jp) - ru(its, k, jp)
dumd = rud(its+1, k, jm) - rud(its, k, jm)
dum = ru(its+1, k, jm) - ru(its, k, jm)
tendencyd(its, k, j) = tendencyd(its, k, j) - mrdx*(ubd*(v_old(&
& its+1, k, j)-v_old(its, k, j))+ub*(v_oldd(its+1, k, j)-v_oldd(&
& its, k, j))+0.5*(vd(its, k, j)*(dup+dum)+v(its, k, j)*(dupd+&
& dumd)))
tendency(its, k, j) = tendency(its, k, j) - mrdx*(ub*(v_old(its+&
& 1, k, j)-v_old(its, k, j))+0.5*v(its, k, j)*(dup+dum))
END DO
END DO
END IF
IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
DO j=j_start,j_end
! ADT eqn 45, 1st term on RHS
mrdx = msfvy(ite-1, j)*rdx
IF (jmax .GT. j) THEN
jp = j
ELSE
jp = jmax
END IF
IF (jmin .LT. j - 1) THEN
jm = j - 1
ELSE
jm = jmin
END IF
DO k=kts,ktf
uwd = 0.5*(rud(ite, k, jp)+rud(ite, k, jm))
uw = 0.5*(ru(ite, k, jp)+ru(ite, k, jm))
IF (uw .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
dupd = rud(ite, k, jp) - rud(ite-1, k, jp)
dup = ru(ite, k, jp) - ru(ite-1, k, jp)
dumd = rud(ite, k, jm) - rud(ite-1, k, jm)
dum = ru(ite, k, jm) - ru(ite-1, k, jm)
! tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*( &
! ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j)) &
! +0.5*v(ite-1,k,j)* &
! ( ru(ite,k,jp)-ru(ite-1,k,jp) &
! +ru(ite,k,jm)-ru(ite-1,k,jm)) )
tendencyd(ite-1, k, j) = tendencyd(ite-1, k, j) - mrdx*(ubd*(&
& v_old(ite-1, k, j)-v_old(ite-2, k, j))+ub*(v_oldd(ite-1, k, j)&
& -v_oldd(ite-2, k, j))+0.5*(vd(ite-1, k, j)*(dup+dum)+v(ite-1, &
& k, j)*(dupd+dumd)))
tendency(ite-1, k, j) = tendency(ite-1, k, j) - mrdx*(ub*(v_old(&
& ite-1, k, j)-v_old(ite-2, k, j))+0.5*v(ite-1, k, j)*(dup+dum))
END DO
END DO
END IF
!-------------------- vertical advection
! ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
! Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
! We therefore need to make a correction for advect_v
! since 'my' (map scale factor in y direction) isn't a function of z,
! we can do this using *(my/mx) (see eqn. 45 for example)
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
DO i=i_start,i_end
vfluxd(i, kts) = 0.0
vflux(i, kts) = 0.
vfluxd(i, kte) = 0.0
vflux(i, kte) = 0.
END DO
! Polar boundary conditions are like open or specified
! We don't want to calculate vertical v tendencies at the N or S pole
IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jde - 1 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 1
END IF
END IF
IF (vert_order .EQ. 6) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+3,ktf-2
DO i=i_start,i_end
veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
vfluxd(i, k) = veld*(37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k+&
& 1, j)+v(i, k-2, j))+(v(i, k+2, j)+v(i, k-3, j)))/60.0 + vel*&
& (37.*(vd(i, k, j)+vd(i, k-1, j))-8.*(vd(i, k+1, j)+vd(i, k-2&
& , j))+vd(i, k+2, j)+vd(i, k-3, j))/60.0
vflux(i, k) = vel*((37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k+1&
& , j)+v(i, k-2, j))+(v(i, k+2, j)+v(i, k-3, j)))/60.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
& , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
& fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
& j)+fzp(k)*v(i, k-1, j))
k = kts + 2
veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
vfluxd(i, k) = veld*(7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+&
& v(i, k-2, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k-1, j))-vd(i&
& , k+1, j)-vd(i, k-2, j))/12.0
vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
& (i, k-2, j)))/12.0)
k = ktf - 1
veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
vfluxd(i, k) = veld*(7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+&
& v(i, k-2, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k-1, j))-vd(i&
& , k+1, j)-vd(i, k-2, j))/12.0
vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
& (i, k-2, j)))/12.0)
k = ktf
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
& , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
& fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
& j)+fzp(k)*v(i, k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
! We are calculating vertical fluxes on v points,
! so we must mean msf_v_x/y variables
! ADT eqn 45, 3rd term on RHS
tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*&
& (vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j&
& )*rdzw(k)*(vflux(i, k+1)-vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 5) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+3,ktf-2
DO i=i_start,i_end
veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
vfluxd(i, k) = veld*((37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k&
& +1, j)+v(i, k-2, j))+(v(i, k+2, j)+v(i, k-3, j)))/60.0-SIGN(&
& 1, time_step)*SIGN(1., -vel)*(v(i, k+2, j)-v(i, k-3, j)-5.*(&
& v(i, k+1, j)-v(i, k-2, j))+10.*(v(i, k, j)-v(i, k-1, j)))/&
& 60.0) + vel*((37.*(vd(i, k, j)+vd(i, k-1, j))-8.*(vd(i, k+1&
& , j)+vd(i, k-2, j))+vd(i, k+2, j)+vd(i, k-3, j))/60.0-SIGN(1&
& , time_step)*SIGN(1., -vel)*(vd(i, k+2, j)-vd(i, k-3, j)-5.*&
& (vd(i, k+1, j)-vd(i, k-2, j))+10.*(vd(i, k, j)-vd(i, k-1, j)&
& ))/60.0)
vflux(i, k) = vel*((37.*(v(i, k, j)+v(i, k-1, j))-8.*(v(i, k+1&
& , j)+v(i, k-2, j))+(v(i, k+2, j)+v(i, k-3, j)))/60.0-SIGN(1&
& , time_step)*SIGN(1., -vel)*(v(i, k+2, j)-v(i, k-3, j)-5.*(v&
& (i, k+1, j)-v(i, k-2, j))+10.*(v(i, k, j)-v(i, k-1, j)))/&
& 60.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
& , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
& fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
& j)+fzp(k)*v(i, k-1, j))
k = kts + 2
veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
vfluxd(i, k) = veld*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)&
& +v(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k&
& +1, j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0) + vel*&
& ((7.*(vd(i, k, j)+vd(i, k-1, j))-vd(i, k+1, j)-vd(i, k-2, j))/&
& 12.0+SIGN(1, time_step)*SIGN(1., -vel)*(vd(i, k+1, j)-vd(i, k-&
& 2, j)-3.*(vd(i, k, j)-vd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1&
& , j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0)
k = ktf - 1
veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
vfluxd(i, k) = veld*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)&
& +v(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k&
& +1, j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0) + vel*&
& ((7.*(vd(i, k, j)+vd(i, k-1, j))-vd(i, k+1, j)-vd(i, k-2, j))/&
& 12.0+SIGN(1, time_step)*SIGN(1., -vel)*(vd(i, k+1, j)-vd(i, k-&
& 2, j)-3.*(vd(i, k, j)-vd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1&
& , j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0)
k = ktf
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
& , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
& fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
& j)+fzp(k)*v(i, k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
! We are calculating vertical fluxes on v points,
! so we must mean msf_v_x/y variables
! ADT eqn 45, 3rd term on RHS
tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*&
& (vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j&
& )*rdzw(k)*(vflux(i, k+1)-vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 4) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+2,ktf-1
DO i=i_start,i_end
veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
vfluxd(i, k) = veld*(7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j&
& )+v(i, k-2, j)))/12.0 + vel*(7.*(vd(i, k, j)+vd(i, k-1, j))-&
& vd(i, k+1, j)-vd(i, k-2, j))/12.0
vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)&
& +v(i, k-2, j)))/12.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
& , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
& fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
& j)+fzp(k)*v(i, k-1, j))
k = ktf
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
& , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
& fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
& j)+fzp(k)*v(i, k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
! We are calculating vertical fluxes on v points,
! so we must mean msf_v_x/y variables
! ADT eqn 45, 3rd term on RHS
tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*&
& (vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j&
& )*rdzw(k)*(vflux(i, k+1)-vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 3) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+2,ktf-1
DO i=i_start,i_end
veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
vfluxd(i, k) = veld*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, &
& j)+v(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(&
& i, k+1, j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0) &
& + vel*((7.*(vd(i, k, j)+vd(i, k-1, j))-vd(i, k+1, j)-vd(i, k&
& -2, j))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(vd(i, k+1, j&
& )-vd(i, k-2, j)-3.*(vd(i, k, j)-vd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)&
& +v(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i&
& , k+1, j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
& , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
& fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
& j)+fzp(k)*v(i, k-1, j))
k = ktf
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i&
& , k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(&
& fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, &
& j)+fzp(k)*v(i, k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
! We are calculating vertical fluxes on v points,
! so we must mean msf_v_x/y variables
! ADT eqn 45, 3rd term on RHS
tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*&
& (vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j&
& )*rdzw(k)*(vflux(i, k+1)-vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 2) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+1,ktf
DO i=i_start,i_end
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(&
& i, k, j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*&
& (fzm(k)*vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k&
& , j)+fzp(k)*v(i, k-1, j))
END DO
END DO
DO k=kts,ktf
DO i=i_start,i_end
! We are calculating vertical fluxes on v points,
! so we must mean msf_v_x/y variables
! ADT eqn 45, 3rd term on RHS
tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*&
& (vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j&
& )*rdzw(k)*(vflux(i, k+1)-vflux(i, k))
END DO
END DO
END DO
ELSE
WRITE(wrf_err_message, *) &
& 'module_advect: advect_v_6a: v_order not known ', vert_order
CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
END IF
END SUBROUTINE G_ADVECT_V
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
! Differentiation of advect_scalar in forward (tangent) mode:
! variations of useful results: tendency
! with respect to varying inputs: rom field tendency ru rv field_old
! RW status of diff variables: rom:in field:in tendency:in-out
! ru:in rv:in field_old:in
SUBROUTINE G_ADVECT_SCALAR(field, fieldd, field_old, field_oldd, &
& tendency, tendencyd, ru, rud, rv, rvd, rom, romd, mut, time_step, &
& config_flags, msfux, msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx&
& , rdy, rdzw, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, &
& kme, its, ite, jts, jte, kts, kte)
IMPLICIT NONE
! Input data
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
& field_old, ru, rv, rom
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: fieldd, &
& field_oldd, rud, rvd, romd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
& msfvy, msftx, msfty
REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
REAL, INTENT(IN) :: rdx, rdy
INTEGER, INTENT(IN) :: time_step
! Local data
INTEGER :: i, j, k, itf, jtf, ktf
INTEGER :: i_start, i_end, j_start, j_end
INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
INTEGER :: jmin, jmax, jp, jm, imin, imax
REAL :: mrdx, mrdy, ub, vb, uw, vw
REAL :: ubd, vbd
REAL, DIMENSION(its:ite, kts:kte) :: vflux
REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
REAL, DIMENSION(its:ite+1, kts:kte) :: fqxd
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
INTEGER :: horz_order, vert_order
LOGICAL :: degrade_xs, degrade_ys
LOGICAL :: degrade_xe, degrade_ye
INTEGER :: jp1, jp0, jtmp
! definition of flux operators, 3rd, 4th, 5th or 6th order
REAL :: flux3, flux4, flux5, flux6
REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
REAL :: veld
LOGICAL :: specified
specified = .false.
IF (config_flags%specified .OR. config_flags%nested) specified = &
& .true.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
horz_order = config_flags%h_sca_adv_order
vert_order = config_flags%v_sca_adv_order
! begin with horizontal flux divergence
! here is the choice of flux operators
IF (horz_order .EQ. 6) THEN
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 3) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 4) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
j_end_f = jde - 3
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_6:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
! use full stencil
DO k=kts,ktf
DO i=i_start,i_end
veld = rvd(i, k, j)
vel = rv(i, k, j)
fqyd(i, k, jp1) = veld*(37.*(field(i, k, j)+field(i, k, j-1)&
& )-8.*(field(i, k, j+1)+field(i, k, j-2))+(field(i, k, j+2)&
& +field(i, k, j-3)))/60.0 + vel*(37.*(fieldd(i, k, j)+&
& fieldd(i, k, j-1))-8.*(fieldd(i, k, j+1)+fieldd(i, k, j-2)&
& )+fieldd(i, k, j+2)+fieldd(i, k, j-3))/60.0
fqy(i, k, jp1) = vel*((37.*(field(i, k, j)+field(i, k, j-1))&
& -8.*(field(i, k, j+1)+field(i, k, j-2))+(field(i, k, j+2)+&
& field(i, k, j-3)))/60.0)
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
& , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
& )
fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = rvd(i, k, j)
vel = rv(i, k, j)
fqyd(i, k, jp1) = veld*(7.*(field(i, k, j)+field(i, k, j-1))&
& -(field(i, k, j+1)+field(i, k, j-2)))/12.0 + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i, k, j-1))-fieldd(i, k, j+1)-&
& fieldd(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(field(i, k, j)+field(i, k, j-1))-&
& (field(i, k, j+1)+field(i, k, j-2)))/12.0)
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
& , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
& )
fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))
END DO
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = rvd(i, k, j)
vel = rv(i, k, j)
fqyd(i, k, jp1) = veld*(7.*(field(i, k, j)+field(i, k, j-1))&
& -(field(i, k, j+1)+field(i, k, j-2)))/12.0 + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i, k, j-1))-fieldd(i, k, j+1)-&
& fieldd(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(field(i, k, j)+field(i, k, j-1))-&
& (field(i, k, j+1)+field(i, k, j-2)))/12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! Comments on polar boundary conditions
! Same process as for advect_u - tendencies run from jds to jde-1
! (latitudes are as for u grid, longitudes are displaced)
! Therefore: flow is only from one side for points next to poles
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_6
! next, x - flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
IF (i_start + 2 .GT. ids + 3) THEN
i_start_f = ids + 3
ELSE
i_start_f = i_start + 2
END IF
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = rud(i, k, j)
vel = ru(i, k, j)
fqxd(i, k) = veld*(37.*(field(i, k, j)+field(i-1, k, j))-8.*(&
& field(i+1, k, j)+field(i-2, k, j))+(field(i+2, k, j)+field(i&
& -3, k, j)))/60.0 + vel*(37.*(fieldd(i, k, j)+fieldd(i-1, k, &
& j))-8.*(fieldd(i+1, k, j)+fieldd(i-2, k, j))+fieldd(i+2, k, &
& j)+fieldd(i-3, k, j))/60.0
fqx(i, k) = vel*((37.*(field(i, k, j)+field(i-1, k, j))-8.*(&
& field(i+1, k, j)+field(i-2, k, j))+(field(i+2, k, j)+field(i&
& -3, k, j)))/60.0)
END DO
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts,ktf
fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
& k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
& j))
END DO
END IF
IF (i .EQ. ids + 2) THEN
! third order
DO k=kts,ktf
veld = rud(i, k, j)
vel = ru(i, k, j)
fqxd(i, k) = veld*(7.*(field(i, k, j)+field(i-1, k, j))-(&
& field(i+1, k, j)+field(i-2, k, j)))/12.0 + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k, j)-&
& fieldd(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(field(i, k, j)+field(i-1, k, j))-(&
& field(i+1, k, j)+field(i-2, k, j)))/12.0)
END DO
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts,ktf
fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
& k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
& j))
END DO
END IF
IF (i .EQ. ide - 2) THEN
! third order flux one in from the boundary
DO k=kts,ktf
veld = rud(i, k, j)
vel = ru(i, k, j)
fqxd(i, k) = veld*(7.*(field(i, k, j)+field(i-1, k, j))-(&
& field(i+1, k, j)+field(i-2, k, j)))/12.0 + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k, j)-&
& fieldd(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(field(i, k, j)+field(i-1, k, j))-(&
& field(i+1, k, j)+field(i-2, k, j)))/12.0)
END DO
END IF
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
ELSE IF (horz_order .EQ. 5) THEN
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 3) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 4) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
j_end_f = jde - 3
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_5:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
! use full stencil
DO k=kts,ktf
DO i=i_start,i_end
veld = rvd(i, k, j)
vel = rv(i, k, j)
fqyd(i, k, jp1) = veld*((37.*(field(i, k, j)+field(i, k, j-1&
& ))-8.*(field(i, k, j+1)+field(i, k, j-2))+(field(i, k, j+2&
& )+field(i, k, j-3)))/60.0-SIGN(1, time_step)*SIGN(1., vel)&
& *(field(i, k, j+2)-field(i, k, j-3)-5.*(field(i, k, j+1)-&
& field(i, k, j-2))+10.*(field(i, k, j)-field(i, k, j-1)))/&
& 60.0) + vel*((37.*(fieldd(i, k, j)+fieldd(i, k, j-1))-8.*(&
& fieldd(i, k, j+1)+fieldd(i, k, j-2))+fieldd(i, k, j+2)+&
& fieldd(i, k, j-3))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(&
& fieldd(i, k, j+2)-fieldd(i, k, j-3)-5.*(fieldd(i, k, j+1)-&
& fieldd(i, k, j-2))+10.*(fieldd(i, k, j)-fieldd(i, k, j-1))&
& )/60.0)
fqy(i, k, jp1) = vel*((37.*(field(i, k, j)+field(i, k, j-1))&
& -8.*(field(i, k, j+1)+field(i, k, j-2))+(field(i, k, j+2)+&
& field(i, k, j-3)))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(&
& field(i, k, j+2)-field(i, k, j-3)-5.*(field(i, k, j+1)-&
& field(i, k, j-2))+10.*(field(i, k, j)-field(i, k, j-1)))/&
& 60.0)
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
& , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
& )
fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = rvd(i, k, j)
vel = rv(i, k, j)
fqyd(i, k, jp1) = veld*((7.*(field(i, k, j)+field(i, k, j-1)&
& )-(field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(1, &
& time_step)*SIGN(1., vel)*(field(i, k, j+1)-field(i, k, j-2&
& )-3.*(field(i, k, j)-field(i, k, j-1)))/12.0) + vel*((7.*(&
& fieldd(i, k, j)+fieldd(i, k, j-1))-fieldd(i, k, j+1)-&
& fieldd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(&
& fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)-&
& fieldd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(field(i, k, j)+field(i, k, j-1))-&
& (field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(1, &
& time_step)*SIGN(1., vel)*(field(i, k, j+1)-field(i, k, j-2&
& )-3.*(field(i, k, j)-field(i, k, j-1)))/12.0)
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
& , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
& )
fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))
END DO
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = rvd(i, k, j)
vel = rv(i, k, j)
fqyd(i, k, jp1) = veld*((7.*(field(i, k, j)+field(i, k, j-1)&
& )-(field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(1, &
& time_step)*SIGN(1., vel)*(field(i, k, j+1)-field(i, k, j-2&
& )-3.*(field(i, k, j)-field(i, k, j-1)))/12.0) + vel*((7.*(&
& fieldd(i, k, j)+fieldd(i, k, j-1))-fieldd(i, k, j+1)-&
& fieldd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(&
& fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)-&
& fieldd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(field(i, k, j)+field(i, k, j-1))-&
& (field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(1, &
& time_step)*SIGN(1., vel)*(field(i, k, j+1)-field(i, k, j-2&
& )-3.*(field(i, k, j)-field(i, k, j-1)))/12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! Comments on polar boundary conditions
! Same process as for advect_u - tendencies run from jds to jde-1
! (latitudes are as for u grid, longitudes are displaced)
! Therefore: flow is only from one side for points next to poles
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_5
! next, x - flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
IF (i_start + 2 .GT. ids + 3) THEN
i_start_f = ids + 3
ELSE
i_start_f = i_start + 2
END IF
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = rud(i, k, j)
vel = ru(i, k, j)
fqxd(i, k) = veld*((37.*(field(i, k, j)+field(i-1, k, j))-8.*(&
& field(i+1, k, j)+field(i-2, k, j))+(field(i+2, k, j)+field(i&
& -3, k, j)))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(field(i+2&
& , k, j)-field(i-3, k, j)-5.*(field(i+1, k, j)-field(i-2, k, &
& j))+10.*(field(i, k, j)-field(i-1, k, j)))/60.0) + vel*((37.&
& *(fieldd(i, k, j)+fieldd(i-1, k, j))-8.*(fieldd(i+1, k, j)+&
& fieldd(i-2, k, j))+fieldd(i+2, k, j)+fieldd(i-3, k, j))/60.0&
& -SIGN(1, time_step)*SIGN(1., vel)*(fieldd(i+2, k, j)-fieldd(&
& i-3, k, j)-5.*(fieldd(i+1, k, j)-fieldd(i-2, k, j))+10.*(&
& fieldd(i, k, j)-fieldd(i-1, k, j)))/60.0)
fqx(i, k) = vel*((37.*(field(i, k, j)+field(i-1, k, j))-8.*(&
& field(i+1, k, j)+field(i-2, k, j))+(field(i+2, k, j)+field(i&
& -3, k, j)))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(field(i+2&
& , k, j)-field(i-3, k, j)-5.*(field(i+1, k, j)-field(i-2, k, &
& j))+10.*(field(i, k, j)-field(i-1, k, j)))/60.0)
END DO
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts,ktf
fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
& k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
& j))
END DO
END IF
IF (i .EQ. ids + 2) THEN
! third order
DO k=kts,ktf
veld = rud(i, k, j)
vel = ru(i, k, j)
fqxd(i, k) = veld*((7.*(field(i, k, j)+field(i-1, k, j))-(&
& field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, &
& time_step)*SIGN(1., vel)*(field(i+1, k, j)-field(i-2, k&
& , j)-3.*(field(i, k, j)-field(i-1, k, j)))/12.0) + vel*(&
& (7.*(fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k, j&
& )-fieldd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i, &
& k, j)-fieldd(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(field(i, k, j)+field(i-1, k, j))-(&
& field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, &
& time_step)*SIGN(1., vel)*(field(i+1, k, j)-field(i-2, k&
& , j)-3.*(field(i, k, j)-field(i-1, k, j)))/12.0)
END DO
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts,ktf
fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
& k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
& j))
END DO
END IF
IF (i .EQ. ide - 2) THEN
! third order flux one in from the boundary
DO k=kts,ktf
veld = rud(i, k, j)
vel = ru(i, k, j)
fqxd(i, k) = veld*((7.*(field(i, k, j)+field(i-1, k, j))-(&
& field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, &
& time_step)*SIGN(1., vel)*(field(i+1, k, j)-field(i-2, k&
& , j)-3.*(field(i, k, j)-field(i-1, k, j)))/12.0) + vel*(&
& (7.*(fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k, j&
& )-fieldd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i, &
& k, j)-fieldd(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(field(i, k, j)+field(i-1, k, j))-(&
& field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, &
& time_step)*SIGN(1., vel)*(field(i+1, k, j)-field(i-2, k&
& , j)-3.*(field(i, k, j)-field(i-1, k, j)))/12.0)
END DO
END IF
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
ELSE IF (horz_order .EQ. 4) THEN
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 2) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 2) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 2) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 3) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
i_start = ids + 1
i_start_f = i_start + 1
END IF
IF (degrade_xe) THEN
i_end = ide - 2
i_end_f = ide - 2
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 3rd or 4th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
fqxd(i, k) = rud(i, k, j)*(7.*(field(i, k, j)+field(i-1, k, j)&
& )-(field(i+1, k, j)+field(i-2, k, j)))/12.0 + ru(i, k, j)*(&
& 7.*(fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k, j)-&
& fieldd(i-2, k, j))/12.0
fqx(i, k) = ru(i, k, j)*((7.*(field(i, k, j)+field(i-1, k, j))&
& -(field(i+1, k, j)+field(i-2, k, j)))/12.0)
END DO
END DO
! second order flux close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO k=kts,ktf
fqxd(i_start, k) = 0.5*(rud(i_start, k, j)*(field(i_start, k, &
& j)+field(i_start-1, k, j))+ru(i_start, k, j)*(fieldd(i_start&
& , k, j)+fieldd(i_start-1, k, j)))
fqx(i_start, k) = 0.5*ru(i_start, k, j)*(field(i_start, k, j)+&
& field(i_start-1, k, j))
END DO
END IF
IF (degrade_xe) THEN
DO k=kts,ktf
fqxd(i_end+1, k) = 0.5*(rud(i_end+1, k, j)*(field(i_end+1, k, &
& j)+field(i_end, k, j))+ru(i_end+1, k, j)*(fieldd(i_end+1, k&
& , j)+fieldd(i_end, k, j)))
fqx(i_end+1, k) = 0.5*ru(i_end+1, k, j)*(field(i_end+1, k, j)+&
& field(i_end, k, j))
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
! next -> y flux divergence calculation
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
j_start = jds + 1
j_start_f = j_start + 1
END IF
IF (degrade_ye) THEN
j_end = jde - 2
j_end_f = jde - 2
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
jp1 = 2
jp0 = 1
fqyd = 0.0
DO j=j_start,j_end+1
IF (j .LT. j_start_f .AND. degrade_ys) THEN
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(rvd(i, k, j_start)*(field(i, k, &
& j_start)+field(i, k, j_start-1))+rv(i, k, j_start)*(fieldd&
& (i, k, j_start)+fieldd(i, k, j_start-1)))
fqy(i, k, jp1) = 0.5*rv(i, k, j_start)*(field(i, k, j_start)&
& +field(i, k, j_start-1))
END DO
END DO
ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
DO k=kts,ktf
DO i=i_start,i_end
! Assumes j>j_end_f is ONLY j_end+1 ...
! fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1) &
! *(field(i,k,j_end+1)+field(i,k,j_end))
fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
& , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
& )
fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))
END DO
END DO
ELSE
! 3rd or 4th order flux
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = rvd(i, k, j)*(7.*(field(i, k, j)+field(i, &
& k, j-1))-(field(i, k, j+1)+field(i, k, j-2)))/12.0 + rv(i&
& , k, j)*(7.*(fieldd(i, k, j)+fieldd(i, k, j-1))-fieldd(i, &
& k, j+1)-fieldd(i, k, j-2))/12.0
fqy(i, k, jp1) = rv(i, k, j)*((7.*(field(i, k, j)+field(i, k&
& , j-1))-(field(i, k, j+1)+field(i, k, j-2)))/12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! Comments on polar boundary conditions
! Same process as for advect_u - tendencies run from jds to jde-1
! (latitudes are as for u grid, longitudes are displaced)
! Therefore: flow is only from one side for points next to poles
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO
ELSE IF (horz_order .EQ. 3) THEN
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 2) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 2) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 2) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 3) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
i_start = ids + 1
i_start_f = i_start + 1
END IF
IF (degrade_xe) THEN
i_end = ide - 2
i_end_f = ide - 2
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 3rd or 4th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
fqxd(i, k) = rud(i, k, j)*((7.*(field(i, k, j)+field(i-1, k, j&
& ))-(field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, &
& time_step)*SIGN(1., ru(i, k, j))*(field(i+1, k, j)-field(i-2&
& , k, j)-3.*(field(i, k, j)-field(i-1, k, j)))/12.0) + ru(i, &
& k, j)*((7.*(fieldd(i, k, j)+fieldd(i-1, k, j))-fieldd(i+1, k&
& , j)-fieldd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., ru(&
& i, k, j))*(fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i&
& , k, j)-fieldd(i-1, k, j)))/12.0)
fqx(i, k) = ru(i, k, j)*((7.*(field(i, k, j)+field(i-1, k, j))&
& -(field(i+1, k, j)+field(i-2, k, j)))/12.0+SIGN(1, time_step&
& )*SIGN(1., ru(i, k, j))*(field(i+1, k, j)-field(i-2, k, j)-&
& 3.*(field(i, k, j)-field(i-1, k, j)))/12.0)
END DO
END DO
! second order flux close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO k=kts,ktf
fqxd(i_start, k) = 0.5*(rud(i_start, k, j)*(field(i_start, k, &
& j)+field(i_start-1, k, j))+ru(i_start, k, j)*(fieldd(i_start&
& , k, j)+fieldd(i_start-1, k, j)))
fqx(i_start, k) = 0.5*ru(i_start, k, j)*(field(i_start, k, j)+&
& field(i_start-1, k, j))
END DO
END IF
IF (degrade_xe) THEN
DO k=kts,ktf
fqxd(i_end+1, k) = 0.5*(rud(i_end+1, k, j)*(field(i_end+1, k, &
& j)+field(i_end, k, j))+ru(i_end+1, k, j)*(fieldd(i_end+1, k&
& , j)+fieldd(i_end, k, j)))
fqx(i_end+1, k) = 0.5*ru(i_end+1, k, j)*(field(i_end+1, k, j)+&
& field(i_end, k, j))
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
! next -> y flux divergence calculation
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
j_start = jds + 1
j_start_f = j_start + 1
END IF
IF (degrade_ye) THEN
j_end = jde - 2
j_end_f = jde - 2
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
jp1 = 2
jp0 = 1
fqyd = 0.0
DO j=j_start,j_end+1
IF (j .LT. j_start_f .AND. degrade_ys) THEN
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(rvd(i, k, j_start)*(field(i, k, &
& j_start)+field(i, k, j_start-1))+rv(i, k, j_start)*(fieldd&
& (i, k, j_start)+fieldd(i, k, j_start-1)))
fqy(i, k, jp1) = 0.5*rv(i, k, j_start)*(field(i, k, j_start)&
& +field(i, k, j_start-1))
END DO
END DO
ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
DO k=kts,ktf
DO i=i_start,i_end
! Assumes j>j_end_f is ONLY j_end+1 ...
! fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1) &
! *(field(i,k,j_end+1)+field(i,k,j_end))
fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
& , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
& )
fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))
END DO
END DO
ELSE
! 3rd or 4th order flux
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = rvd(i, k, j)*((7.*(field(i, k, j)+field(i&
& , k, j-1))-(field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(&
& 1, time_step)*SIGN(1., rv(i, k, j))*(field(i, k, j+1)-&
& field(i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))/&
& 12.0) + rv(i, k, j)*((7.*(fieldd(i, k, j)+fieldd(i, k, j-1&
& ))-fieldd(i, k, j+1)-fieldd(i, k, j-2))/12.0+SIGN(1, &
& time_step)*SIGN(1., rv(i, k, j))*(fieldd(i, k, j+1)-fieldd&
& (i, k, j-2)-3.*(fieldd(i, k, j)-fieldd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = rv(i, k, j)*((7.*(field(i, k, j)+field(i, k&
& , j-1))-(field(i, k, j+1)+field(i, k, j-2)))/12.0+SIGN(1, &
& time_step)*SIGN(1., rv(i, k, j))*(field(i, k, j+1)-field(i&
& , k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))/12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! Comments on polar boundary conditions
! Same process as for advect_u - tendencies run from jds to jde-1
! (latitudes are as for u grid, longitudes are displaced)
! Therefore: flow is only from one side for points next to poles
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO
ELSE IF (horz_order .EQ. 2) THEN
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
IF (.NOT.config_flags%periodic_x) THEN
IF (config_flags%open_xs .OR. specified) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_xe .OR. specified) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
END IF
END IF
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.5*(rud(i+1, k&
& , j)*(field(i+1, k, j)+field(i, k, j))+ru(i+1, k, j)*(fieldd&
& (i+1, k, j)+fieldd(i, k, j))-rud(i, k, j)*(field(i, k, j)+&
& field(i-1, k, j))-ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k&
& , j)))
tendency(i, k, j) = tendency(i, k, j) - mrdx*0.5*(ru(i+1, k, j&
& )*(field(i+1, k, j)+field(i, k, j))-ru(i, k, j)*(field(i, k&
& , j)+field(i-1, k, j)))
END DO
END DO
END DO
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
! Polar boundary conditions are like open or specified
IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jde - 2 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 2
END IF
END IF
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j)*rdy
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.5*(rvd(i, k, &
& j+1)*(field(i, k, j+1)+field(i, k, j))+rv(i, k, j+1)*(fieldd&
& (i, k, j+1)+fieldd(i, k, j))-rvd(i, k, j)*(field(i, k, j)+&
& field(i, k, j-1))-rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, &
& j-1)))
tendency(i, k, j) = tendency(i, k, j) - mrdy*0.5*(rv(i, k, j+1&
& )*(field(i, k, j+1)+field(i, k, j))-rv(i, k, j)*(field(i, k&
& , j)+field(i, k, j-1)))
END DO
END DO
END DO
! Polar boundary condtions
! These won't be covered in the loop above...
IF (config_flags%polar) THEN
IF (jts .EQ. jds) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, jds)*rdy
tendencyd(i, k, jds) = tendencyd(i, k, jds) - mrdy*0.5*(rvd(&
& i, k, jds+1)*(field(i, k, jds+1)+field(i, k, jds))+rv(i, k&
& , jds+1)*(fieldd(i, k, jds+1)+fieldd(i, k, jds)))
tendency(i, k, jds) = tendency(i, k, jds) - mrdy*0.5*rv(i, k&
& , jds+1)*(field(i, k, jds+1)+field(i, k, jds))
END DO
END DO
END IF
IF (jte .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, jde-1)*rdy
tendencyd(i, k, jde-1) = tendencyd(i, k, jde-1) + mrdy*0.5*(&
& rvd(i, k, jde-1)*(field(i, k, jde-1)+field(i, k, jde-2))+&
& rv(i, k, jde-1)*(fieldd(i, k, jde-1)+fieldd(i, k, jde-2)))
tendency(i, k, jde-1) = tendency(i, k, jde-1) + mrdy*0.5*rv(&
& i, k, jde-1)*(field(i, k, jde-1)+field(i, k, jde-2))
END DO
END DO
END IF
END IF
ELSE IF (horz_order .NE. 0) THEN
! Just in case we want to turn horizontal advection off, we can do it
WRITE(wrf_err_message, *) &
& 'module_advect: advect_scalar_6a, h_order not known ', horz_order
CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
END IF
! pick up the rest of the horizontal radiation boundary conditions.
! (these are the computations that don't require 'cb'.
! first, set to index ranges
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! compute x (u) conditions for v, w, or scalar
IF (config_flags%open_xs .AND. its .EQ. ids) THEN
DO j=j_start,j_end
DO k=kts,ktf
IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = 0.5*(rud(its, k, j)+rud(its+1, k, j))
ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
END IF
tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(&
& field_old(its+1, k, j)-field_old(its, k, j))+ub*(field_oldd(&
& its+1, k, j)-field_oldd(its, k, j))+fieldd(its, k, j)*(ru(its+&
& 1, k, j)-ru(its, k, j))+field(its, k, j)*(rud(its+1, k, j)-rud&
& (its, k, j)))
tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(field_old(&
& its+1, k, j)-field_old(its, k, j))+field(its, k, j)*(ru(its+1&
& , k, j)-ru(its, k, j)))
END DO
END DO
END IF
IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
DO j=j_start,j_end
DO k=kts,ktf
IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = 0.5*(rud(ite-1, k, j)+rud(ite, k, j))
ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
END IF
tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
& field_old(i_end, k, j)-field_old(i_end-1, k, j))+ub*(&
& field_oldd(i_end, k, j)-field_oldd(i_end-1, k, j))+fieldd(&
& i_end, k, j)*(ru(ite, k, j)-ru(ite-1, k, j))+field(i_end, k, j&
& )*(rud(ite, k, j)-rud(ite-1, k, j)))
tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(&
& field_old(i_end, k, j)-field_old(i_end-1, k, j))+field(i_end, &
& k, j)*(ru(ite, k, j)-ru(ite-1, k, j)))
END DO
END DO
END IF
IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*(rvd(i, k, jts)+rvd(i, k, jts+1))
vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
& field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
& , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*(rv(i, k&
& , jts+1)-rv(i, k, jts))+field(i, k, jts)*(rvd(i, k, jts+1)-rvd&
& (i, k, jts)))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
& , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*(rv(i, k, &
& jts+1)-rv(i, k, jts)))
END DO
END DO
END IF
IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*(rvd(i, k, jte-1)+rvd(i, k, jte))
vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
END IF
tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
& field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))+fieldd(i, k&
& , j_end)*(rv(i, k, jte)-rv(i, k, jte-1))+field(i, k, j_end)*(&
& rvd(i, k, jte)-rvd(i, k, jte-1)))
tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
& j_end)*(rv(i, k, jte)-rv(i, k, jte-1)))
END DO
END DO
END IF
!-------------------- vertical advection
! Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
! Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
! So we don't need to make a correction for advect_scalar
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
DO i=i_start,i_end
vfluxd(i, kts) = 0.0
vflux(i, kts) = 0.
vfluxd(i, kte) = 0.0
vflux(i, kte) = 0.
END DO
IF (vert_order .EQ. 6) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+3,ktf-2
DO i=i_start,i_end
veld = romd(i, k, j)
vel = rom(i, k, j)
vfluxd(i, k) = veld*(37.*(field(i, k, j)+field(i, k-1, j))-8.*&
& (field(i, k+1, j)+field(i, k-2, j))+(field(i, k+2, j)+field(&
& i, k-3, j)))/60.0 + vel*(37.*(fieldd(i, k, j)+fieldd(i, k-1&
& , j))-8.*(fieldd(i, k+1, j)+fieldd(i, k-2, j))+fieldd(i, k+2&
& , j)+fieldd(i, k-3, j))/60.0
vflux(i, k) = vel*((37.*(field(i, k, j)+field(i, k-1, j))-8.*(&
& field(i, k+1, j)+field(i, k-2, j))+(field(i, k+2, j)+field(i&
& , k-3, j)))/60.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
& (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
& fieldd(i, k-1, j))
vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j))
k = kts + 2
veld = romd(i, k, j)
vel = rom(i, k, j)
vfluxd(i, k) = veld*(7.*(field(i, k, j)+field(i, k-1, j))-(field&
& (i, k+1, j)+field(i, k-2, j)))/12.0 + vel*(7.*(fieldd(i, k, j)&
& +fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, j))/12.0
vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(field(&
& i, k+1, j)+field(i, k-2, j)))/12.0)
k = ktf - 1
veld = romd(i, k, j)
vel = rom(i, k, j)
vfluxd(i, k) = veld*(7.*(field(i, k, j)+field(i, k-1, j))-(field&
& (i, k+1, j)+field(i, k-2, j)))/12.0 + vel*(7.*(fieldd(i, k, j)&
& +fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, j))/12.0
vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(field(&
& i, k+1, j)+field(i, k-2, j)))/12.0)
k = ktf
vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
& (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
& fieldd(i, k-1, j))
vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 5) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+3,ktf-2
DO i=i_start,i_end
veld = romd(i, k, j)
vel = rom(i, k, j)
vfluxd(i, k) = veld*((37.*(field(i, k, j)+field(i, k-1, j))-8.&
& *(field(i, k+1, j)+field(i, k-2, j))+(field(i, k+2, j)+field&
& (i, k-3, j)))/60.0-SIGN(1, time_step)*SIGN(1., -vel)*(field(&
& i, k+2, j)-field(i, k-3, j)-5.*(field(i, k+1, j)-field(i, k-&
& 2, j))+10.*(field(i, k, j)-field(i, k-1, j)))/60.0) + vel*((&
& 37.*(fieldd(i, k, j)+fieldd(i, k-1, j))-8.*(fieldd(i, k+1, j&
& )+fieldd(i, k-2, j))+fieldd(i, k+2, j)+fieldd(i, k-3, j))/&
& 60.0-SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+2, j)-&
& fieldd(i, k-3, j)-5.*(fieldd(i, k+1, j)-fieldd(i, k-2, j))+&
& 10.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/60.0)
vflux(i, k) = vel*((37.*(field(i, k, j)+field(i, k-1, j))-8.*(&
& field(i, k+1, j)+field(i, k-2, j))+(field(i, k+2, j)+field(i&
& , k-3, j)))/60.0-SIGN(1, time_step)*SIGN(1., -vel)*(field(i&
& , k+2, j)-field(i, k-3, j)-5.*(field(i, k+1, j)-field(i, k-2&
& , j))+10.*(field(i, k, j)-field(i, k-1, j)))/60.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
& (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
& fieldd(i, k-1, j))
vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j))
k = kts + 2
veld = romd(i, k, j)
vel = rom(i, k, j)
vfluxd(i, k) = veld*((7.*(field(i, k, j)+field(i, k-1, j))-(&
& field(i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*&
& SIGN(1., -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(i&
& , k, j)-field(i, k-1, j)))/12.0) + vel*((7.*(fieldd(i, k, j)+&
& fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, j))/12.0+&
& SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-fieldd(i&
& , k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(field(&
& i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1.&
& , -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-&
& field(i, k-1, j)))/12.0)
k = ktf - 1
veld = romd(i, k, j)
vel = rom(i, k, j)
vfluxd(i, k) = veld*((7.*(field(i, k, j)+field(i, k-1, j))-(&
& field(i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*&
& SIGN(1., -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(i&
& , k, j)-field(i, k-1, j)))/12.0) + vel*((7.*(fieldd(i, k, j)+&
& fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, j))/12.0+&
& SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-fieldd(i&
& , k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(field(&
& i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1.&
& , -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-&
& field(i, k-1, j)))/12.0)
k = ktf
vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
& (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
& fieldd(i, k-1, j))
vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 4) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+2,ktf-1
DO i=i_start,i_end
veld = romd(i, k, j)
vel = rom(i, k, j)
vfluxd(i, k) = veld*(7.*(field(i, k, j)+field(i, k-1, j))-(&
& field(i, k+1, j)+field(i, k-2, j)))/12.0 + vel*(7.*(fieldd(i&
& , k, j)+fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, &
& j))/12.0
vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(&
& field(i, k+1, j)+field(i, k-2, j)))/12.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
& (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
& fieldd(i, k-1, j))
vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j))
k = ktf
vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
& (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
& fieldd(i, k-1, j))
vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 3) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+2,ktf-1
DO i=i_start,i_end
veld = romd(i, k, j)
vel = rom(i, k, j)
vfluxd(i, k) = veld*((7.*(field(i, k, j)+field(i, k-1, j))-(&
& field(i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*&
& SIGN(1., -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
& i, k, j)-field(i, k-1, j)))/12.0) + vel*((7.*(fieldd(i, k, j&
& )+fieldd(i, k-1, j))-fieldd(i, k+1, j)-fieldd(i, k-2, j))/&
& 12.0+SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-&
& fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/&
& 12.0)
vflux(i, k) = vel*((7.*(field(i, k, j)+field(i, k-1, j))-(&
& field(i, k+1, j)+field(i, k-2, j)))/12.0+SIGN(1, time_step)*&
& SIGN(1., -vel)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
& i, k, j)-field(i, k-1, j)))/12.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
& (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
& fieldd(i, k-1, j))
vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j))
k = ktf
vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
& (i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*&
& fieldd(i, k-1, j))
vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
END DO
ELSE IF (vert_order .EQ. 2) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+1,ktf
DO i=i_start,i_end
vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
& field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp&
& (k)*fieldd(i, k-1, j))
vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field&
& (i, k-1, j))
END DO
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
END DO
ELSE
WRITE(wrf_err_message, *) ' advect_scalar_6a, v_order not known ', &
& vert_order
CALL WRF_ERROR_FATAL(wrf_err_message)
END IF
END SUBROUTINE G_ADVECT_SCALAR
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
! Differentiation of advect_w in forward (tangent) mode:
! variations of useful results: tendency
! with respect to varying inputs: rom tendency w ru rv w_old
! RW status of diff variables: rom:in tendency:in-out w:in ru:in
! rv:in w_old:in
SUBROUTINE G_ADVECT_W(w, wd, w_old, w_oldd, tendency, tendencyd, ru, rud&
& , rv, rvd, rom, romd, mut, time_step, config_flags, msfux, msfuy, &
& msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzu, ids, ide, jds, &
& jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, &
& kte)
IMPLICIT NONE
! Input data
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: w, w_old, ru&
& , rv, rom
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: wd, w_oldd, &
& rud, rvd, romd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
& msfvy, msftx, msfty
REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzu
REAL, INTENT(IN) :: rdx, rdy
INTEGER, INTENT(IN) :: time_step
! Local data
INTEGER :: i, j, k, itf, jtf, ktf
INTEGER :: i_start, i_end, j_start, j_end
INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
INTEGER :: jmin, jmax, jp, jm, imin, imax
REAL :: mrdx, mrdy, ub, vb, uw, vw
REAL :: ubd, vbd, uwd, vwd
REAL, DIMENSION(its:ite, kts:kte) :: vflux
REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
INTEGER :: horz_order, vert_order
REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
REAL, DIMENSION(its:ite+1, kts:kte) :: fqxd
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
LOGICAL :: degrade_xs, degrade_ys
LOGICAL :: degrade_xe, degrade_ye
INTEGER :: jp1, jp0, jtmp
! definition of flux operators, 3rd, 4th, 5th or 6th order
REAL :: flux3, flux4, flux5, flux6
REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
REAL :: veld
LOGICAL :: specified
specified = .false.
IF (config_flags%specified .OR. config_flags%nested) specified = &
& .true.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
horz_order = config_flags%h_sca_adv_order
vert_order = config_flags%v_sca_adv_order
! here is the choice of flux operators
! begin with horizontal flux divergence
IF (horz_order .EQ. 6) THEN
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 3) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 4) degrade_ye = .false.
!--------------- y - advection first
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
j_end_f = jde - 3
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_6:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
DO k=kts+1,ktf
DO i=i_start,i_end
veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
fqyd(i, k, jp1) = veld*(37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(&
& i, k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0&
& + vel*(37.*(wd(i, k, j)+wd(i, k, j-1))-8.*(wd(i, k, j+1)+&
& wd(i, k, j-2))+wd(i, k, j+2)+wd(i, k, j-3))/60.0
fqy(i, k, jp1) = vel*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i&
& , k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0)
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
fqyd(i, k, jp1) = veld*(37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i&
& , k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0 + &
& vel*(37.*(wd(i, k, j)+wd(i, k, j-1))-8.*(wd(i, k, j+1)+wd(i&
& , k, j-2))+wd(i, k, j+2)+wd(i, k, j-3))/60.0
fqy(i, k, jp1) = vel*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, &
& k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0)
END DO
ELSE IF (j .EQ. jds + 1) THEN
! 2nd order flux next to south boundary
DO k=kts+1,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
& 1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
& )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
& ))*(w(i, k, j)+w(i, k, j-1))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
& rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
& i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
& )))
fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
& i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts+1,ktf
DO i=i_start,i_end
veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k&
& , j-1))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0)
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, &
& j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k, j-1&
& ))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
& +1)+w(i, k, j-2)))/12.0)
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts+1,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
& 1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
& )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
& ))*(w(i, k, j)+w(i, k, j-1))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
& rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
& i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
& )))
fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
& i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts+1,ktf
DO i=i_start,i_end
veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k&
& , j-1))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0)
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, &
& j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k, j-1&
& ))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
& +1)+w(i, k, j-2)))/12.0)
END DO
END IF
! y flux-divergence into tendency
! Comments for polar boundary conditions
! Same process as for advect_u - tendencies run from jds to jde-1
! (latitudes are as for u grid, longitudes are displaced)
! Therefore: flow is only from one side for points next to poles
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts+1,ktf+1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_6
! next, x - flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
IF (i_start + 2 .GT. ids + 3) THEN
i_start_f = ids + 3
ELSE
i_start_f = i_start + 2
END IF
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts+1,ktf
DO i=i_start_f,i_end_f
veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
fqxd(i, k) = veld*(37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k&
& , j)+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0 + vel*(&
& 37.*(wd(i, k, j)+wd(i-1, k, j))-8.*(wd(i+1, k, j)+wd(i-2, k&
& , j))+wd(i+2, k, j)+wd(i-3, k, j))/60.0
fqx(i, k) = vel*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, &
& j)+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0)
END DO
END DO
k = ktf + 1
DO i=i_start_f,i_end_f
veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
fqxd(i, k) = veld*(37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j&
& )+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0 + vel*(37.*(&
& wd(i, k, j)+wd(i-1, k, j))-8.*(wd(i+1, k, j)+wd(i-2, k, j))+wd&
& (i+2, k, j)+wd(i-3, k, j))/60.0
fqx(i, k) = vel*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)&
& +w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0)
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts+1,ktf
fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, &
& j))*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)&
& *ru(i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
& (w(i, k, j)+w(i-1, k, j))
END DO
k = ktf + 1
fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud&
& (i, k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i&
& , k-1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, &
& j)))
fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, &
& k-2, j))*(w(i, k, j)+w(i-1, k, j))
END IF
IF (i .EQ. ids + 2) THEN
! third order
DO k=kts+1,ktf
veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k&
& , j)+w(i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, &
& k, j))-wd(i+1, k, j)-wd(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
& j)+w(i-2, k, j)))/12.0)
END DO
k = ktf + 1
veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j&
& )
vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j&
& )+w(i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, k, j)&
& )-wd(i+1, k, j)-wd(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
& +w(i-2, k, j)))/12.0)
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts+1,ktf
fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, &
& j))*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)&
& *ru(i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
& (w(i, k, j)+w(i-1, k, j))
END DO
k = ktf + 1
fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud&
& (i, k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i&
& , k-1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, &
& j)))
fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, &
& k-2, j))*(w(i, k, j)+w(i-1, k, j))
END IF
IF (i .EQ. ide - 2) THEN
! third order flux one in from the boundary
DO k=kts+1,ktf
veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k&
& , j)+w(i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, &
& k, j))-wd(i+1, k, j)-wd(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
& j)+w(i-2, k, j)))/12.0)
END DO
k = ktf + 1
veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j&
& )
vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j&
& )+w(i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, k, j)&
& )-wd(i+1, k, j)-wd(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
& +w(i-2, k, j)))/12.0)
END IF
END DO
END IF
! x flux-divergence into tendency
DO k=kts+1,ktf+1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
ELSE IF (horz_order .EQ. 5) THEN
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 3) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 4) degrade_ye = .false.
!--------------- y - advection first
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
j_end_f = jde - 3
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_5:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
DO k=kts+1,ktf
DO i=i_start,i_end
veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
fqyd(i, k, jp1) = veld*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w&
& (i, k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/&
& 60.0-SIGN(1, time_step)*SIGN(1., vel)*(w(i, k, j+2)-w(i, k&
& , j-3)-5.*(w(i, k, j+1)-w(i, k, j-2))+10.*(w(i, k, j)-w(i&
& , k, j-1)))/60.0) + vel*((37.*(wd(i, k, j)+wd(i, k, j-1))-&
& 8.*(wd(i, k, j+1)+wd(i, k, j-2))+wd(i, k, j+2)+wd(i, k, j-&
& 3))/60.0-SIGN(1, time_step)*SIGN(1., vel)*(wd(i, k, j+2)-&
& wd(i, k, j-3)-5.*(wd(i, k, j+1)-wd(i, k, j-2))+10.*(wd(i, &
& k, j)-wd(i, k, j-1)))/60.0)
fqy(i, k, jp1) = vel*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i&
& , k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0-&
& SIGN(1, time_step)*SIGN(1., vel)*(w(i, k, j+2)-w(i, k, j-3&
& )-5.*(w(i, k, j+1)-w(i, k, j-2))+10.*(w(i, k, j)-w(i, k, j&
& -1)))/60.0)
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
fqyd(i, k, jp1) = veld*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i&
& , k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0-&
& SIGN(1, time_step)*SIGN(1., vel)*(w(i, k, j+2)-w(i, k, j-3)-&
& 5.*(w(i, k, j+1)-w(i, k, j-2))+10.*(w(i, k, j)-w(i, k, j-1))&
& )/60.0) + vel*((37.*(wd(i, k, j)+wd(i, k, j-1))-8.*(wd(i, k&
& , j+1)+wd(i, k, j-2))+wd(i, k, j+2)+wd(i, k, j-3))/60.0-SIGN&
& (1, time_step)*SIGN(1., vel)*(wd(i, k, j+2)-wd(i, k, j-3)-5.&
& *(wd(i, k, j+1)-wd(i, k, j-2))+10.*(wd(i, k, j)-wd(i, k, j-1&
& )))/60.0)
fqy(i, k, jp1) = vel*((37.*(w(i, k, j)+w(i, k, j-1))-8.*(w(i, &
& k, j+1)+w(i, k, j-2))+(w(i, k, j+2)+w(i, k, j-3)))/60.0-SIGN&
& (1, time_step)*SIGN(1., vel)*(w(i, k, j+2)-w(i, k, j-3)-5.*(&
& w(i, k, j+1)-w(i, k, j-2))+10.*(w(i, k, j)-w(i, k, j-1)))/&
& 60.0)
END DO
ELSE IF (j .EQ. jds + 1) THEN
! 2nd order flux next to south boundary
DO k=kts+1,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
& 1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
& )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
& ))*(w(i, k, j)+w(i, k, j-1))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
& rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
& i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
& )))
fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
& i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts+1,ktf
DO i=i_start,i_end
veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, &
& k, j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1&
& )))/12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, &
& j+1)-wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (wd(i, k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)&
& ))/12.0)
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))&
& /12.0)
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/&
& 12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-&
& wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, &
& k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
& +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(&
& i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts+1,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
& 1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
& )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
& ))*(w(i, k, j)+w(i, k, j-1))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
& rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
& i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
& )))
fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
& i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts+1,ktf
DO i=i_start,i_end
veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, &
& k, j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1&
& )))/12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, &
& j+1)-wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (wd(i, k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)&
& ))/12.0)
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))&
& /12.0)
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/&
& 12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-&
& wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, &
& k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
& +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(&
& i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
END DO
END IF
! y flux-divergence into tendency
! Comments for polar boundary conditions
! Same process as for advect_u - tendencies run from jds to jde-1
! (latitudes are as for u grid, longitudes are displaced)
! Therefore: flow is only from one side for points next to poles
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts+1,ktf+1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_5
! next, x - flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
IF (i_start + 2 .GT. ids + 3) THEN
i_start_f = ids + 3
ELSE
i_start_f = i_start + 2
END IF
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts+1,ktf
DO i=i_start_f,i_end_f
veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
fqxd(i, k) = veld*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k&
& , j)+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0-SIGN(1&
& , time_step)*SIGN(1., vel)*(w(i+2, k, j)-w(i-3, k, j)-5.*(w(&
& i+1, k, j)-w(i-2, k, j))+10.*(w(i, k, j)-w(i-1, k, j)))/60.0&
& ) + vel*((37.*(wd(i, k, j)+wd(i-1, k, j))-8.*(wd(i+1, k, j)+&
& wd(i-2, k, j))+wd(i+2, k, j)+wd(i-3, k, j))/60.0-SIGN(1, &
& time_step)*SIGN(1., vel)*(wd(i+2, k, j)-wd(i-3, k, j)-5.*(wd&
& (i+1, k, j)-wd(i-2, k, j))+10.*(wd(i, k, j)-wd(i-1, k, j)))/&
& 60.0)
fqx(i, k) = vel*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, &
& j)+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0-SIGN(1, &
& time_step)*SIGN(1., vel)*(w(i+2, k, j)-w(i-3, k, j)-5.*(w(i+&
& 1, k, j)-w(i-2, k, j))+10.*(w(i, k, j)-w(i-1, k, j)))/60.0)
END DO
END DO
k = ktf + 1
DO i=i_start_f,i_end_f
veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
fqxd(i, k) = veld*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, &
& j)+w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0-SIGN(1, &
& time_step)*SIGN(1., vel)*(w(i+2, k, j)-w(i-3, k, j)-5.*(w(i+1&
& , k, j)-w(i-2, k, j))+10.*(w(i, k, j)-w(i-1, k, j)))/60.0) + &
& vel*((37.*(wd(i, k, j)+wd(i-1, k, j))-8.*(wd(i+1, k, j)+wd(i-2&
& , k, j))+wd(i+2, k, j)+wd(i-3, k, j))/60.0-SIGN(1, time_step)*&
& SIGN(1., vel)*(wd(i+2, k, j)-wd(i-3, k, j)-5.*(wd(i+1, k, j)-&
& wd(i-2, k, j))+10.*(wd(i, k, j)-wd(i-1, k, j)))/60.0)
fqx(i, k) = vel*((37.*(w(i, k, j)+w(i-1, k, j))-8.*(w(i+1, k, j)&
& +w(i-2, k, j))+(w(i+2, k, j)+w(i-3, k, j)))/60.0-SIGN(1, &
& time_step)*SIGN(1., vel)*(w(i+2, k, j)-w(i-3, k, j)-5.*(w(i+1&
& , k, j)-w(i-2, k, j))+10.*(w(i, k, j)-w(i-1, k, j)))/60.0)
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts+1,ktf
fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, &
& j))*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)&
& *ru(i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
& (w(i, k, j)+w(i-1, k, j))
END DO
k = ktf + 1
fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud&
& (i, k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i&
& , k-1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, &
& j)))
fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, &
& k-2, j))*(w(i, k, j)+w(i-1, k, j))
END IF
IF (i .EQ. ids + 2) THEN
! third order
DO k=kts+1,ktf
veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k&
& , j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(w(i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)&
& ))/12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, &
& k, j)-wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(wd(i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1&
& , k, j)))/12.0)
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
& j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (w(i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))&
& /12.0)
END DO
k = ktf + 1
veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j&
& )
vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
& j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w&
& (i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/&
& 12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)&
& -wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(&
& i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/&
& 12.0)
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
& +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
& +1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts+1,ktf
fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, &
& j))*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)&
& *ru(i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*&
& (w(i, k, j)+w(i-1, k, j))
END DO
k = ktf + 1
fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud&
& (i, k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i&
& , k-1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, &
& j)))
fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, &
& k-2, j))*(w(i, k, j)+w(i-1, k, j))
END IF
IF (i .EQ. ide - 2) THEN
! third order flux one in from the boundary
DO k=kts+1,ktf
veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k&
& , j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(w(i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)&
& ))/12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, &
& k, j)-wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(wd(i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1&
& , k, j)))/12.0)
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
& j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (w(i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))&
& /12.0)
END DO
k = ktf + 1
veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j&
& )
vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
& j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w&
& (i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/&
& 12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)&
& -wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(&
& i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/&
& 12.0)
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
& +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
& +1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
END IF
END DO
END IF
! x flux-divergence into tendency
DO k=kts+1,ktf+1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
ELSE IF (horz_order .EQ. 4) THEN
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 2) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 2) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 2) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 3) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
i_start = ids + 1
i_start_f = i_start + 1
END IF
IF (degrade_xe) THEN
i_end = ide - 2
i_end_f = ide - 2
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
DO k=kts+1,ktf
DO i=i_start_f,i_end_f
veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+&
& w(i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, k, j))-wd&
& (i+1, k, j)-wd(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w&
& (i-2, k, j)))/12.0)
END DO
END DO
k = ktf + 1
DO i=i_start_f,i_end_f
veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
fqxd(i, k) = veld*(7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w(&
& i-2, k, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1&
& , k, j)-wd(i-2, k, j))/12.0
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w(i&
& -2, k, j)))/12.0)
END DO
! second order flux close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO k=kts+1,ktf
fqxd(i_start, k) = 0.5*((fzm(k)*rud(i_start, k, j)+fzp(k)*rud(&
& i_start, k-1, j))*(w(i_start, k, j)+w(i_start-1, k, j))+(fzm&
& (k)*ru(i_start, k, j)+fzp(k)*ru(i_start, k-1, j))*(wd(&
& i_start, k, j)+wd(i_start-1, k, j)))
fqx(i_start, k) = 0.5*(fzm(k)*ru(i_start, k, j)+fzp(k)*ru(&
& i_start, k-1, j))*(w(i_start, k, j)+w(i_start-1, k, j))
END DO
k = ktf + 1
fqxd(i_start, k) = 0.5*(((2.-fzm(k-1))*rud(i_start, k-1, j)-fzp(&
& k-1)*rud(i_start, k-2, j))*(w(i_start, k, j)+w(i_start-1, k, j&
& ))+((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1)*ru(i_start, k-2&
& , j))*(wd(i_start, k, j)+wd(i_start-1, k, j)))
fqx(i_start, k) = 0.5*((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1&
& )*ru(i_start, k-2, j))*(w(i_start, k, j)+w(i_start-1, k, j))
END IF
IF (degrade_xe) THEN
DO k=kts+1,ktf
fqxd(i_end+1, k) = 0.5*((fzm(k)*rud(i_end+1, k, j)+fzp(k)*rud(&
& i_end+1, k-1, j))*(w(i_end+1, k, j)+w(i_end, k, j))+(fzm(k)*&
& ru(i_end+1, k, j)+fzp(k)*ru(i_end+1, k-1, j))*(wd(i_end+1, k&
& , j)+wd(i_end, k, j)))
fqx(i_end+1, k) = 0.5*(fzm(k)*ru(i_end+1, k, j)+fzp(k)*ru(&
& i_end+1, k-1, j))*(w(i_end+1, k, j)+w(i_end, k, j))
END DO
k = ktf + 1
fqxd(i_end+1, k) = 0.5*(((2.-fzm(k-1))*rud(i_end+1, k-1, j)-fzp(&
& k-1)*rud(i_end+1, k-2, j))*(w(i_end+1, k, j)+w(i_end, k, j))+(&
& (2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1)*ru(i_end+1, k-2, j)&
& )*(wd(i_end+1, k, j)+wd(i_end, k, j)))
fqx(i_end+1, k) = 0.5*((2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1&
& )*ru(i_end+1, k-2, j))*(w(i_end+1, k, j)+w(i_end, k, j))
END IF
! x flux-divergence into tendency
DO k=kts+1,ktf+1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
! next -> y flux divergence calculation
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
j_start = jds + 1
j_start_f = j_start + 1
END IF
IF (degrade_ye) THEN
j_end = jde - 2
j_end_f = jde - 2
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
jp1 = 2
jp0 = 1
fqyd = 0.0
DO j=j_start,j_end+1
IF (j .LT. j_start_f .AND. degrade_ys) THEN
DO k=kts+1,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j_start)+fzp(k)*rvd&
& (i, k-1, j_start))*(w(i, k, j_start)+w(i, k, j_start-1))+(&
& fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, k-1, j_start))*(wd(i&
& , k, j_start)+wd(i, k, j_start-1)))
fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, &
& k-1, j_start))*(w(i, k, j_start)+w(i, k, j_start-1))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j_start)-fzp&
& (k-1)*rvd(i, k-2, j_start))*(w(i, k, j_start)+w(i, k, &
& j_start-1))+((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-1)*rv(i&
& , k-2, j_start))*(wd(i, k, j_start)+wd(i, k, j_start-1)))
fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-&
& 1)*rv(i, k-2, j_start))*(w(i, k, j_start)+w(i, k, j_start-1)&
& )
END DO
ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
DO k=kts+1,ktf
DO i=i_start,i_end
! Assumes j>j_end_f is ONLY j_end+1 ...
! fqy(i, k, jp1) = &
! 0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1)) &
! *(w(i,k,j_end+1)+w(i,k,j_end))
fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
& 1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
& )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
& ))*(w(i, k, j)+w(i, k, j-1))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
! Assumes j>j_end_f is ONLY j_end+1 ...
! fqy(i, k, jp1) = &
! 0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1)) &
! *(w(i,k,j_end+1)+w(i,k,j_end))
fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
& rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
& i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
& )))
fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
& i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
END DO
ELSE
! 3rd or 4th order flux
DO k=kts+1,ktf
DO i=i_start,i_end
veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k&
& , j-1))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0)
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
fqyd(i, k, jp1) = veld*(7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, &
& j+1)+w(i, k, j-2)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k, j-1&
& ))-wd(i, k, j+1)-wd(i, k, j-2))/12.0
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
& +1)+w(i, k, j-2)))/12.0)
END DO
END IF
! y flux-divergence into tendency
! Comments for polar boundary conditions
! Same process as for advect_u - tendencies run from jds to jde-1
! (latitudes are as for u grid, longitudes are displaced)
! Therefore: flow is only from one side for points next to poles
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts+1,ktf+1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO
ELSE IF (horz_order .EQ. 3) THEN
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 2) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 2) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 2) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 3) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
i_start = ids + 1
i_start_f = i_start + 1
END IF
IF (degrade_xe) THEN
i_end = ide - 2
i_end_f = ide - 2
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
DO k=kts+1,ktf
DO i=i_start_f,i_end_f
veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
& +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1&
& , k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0) + &
& vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)-wd(i-2, k&
& , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i+1, k, j)-&
& wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w&
& (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1, &
& k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
END DO
END DO
k = ktf + 1
DO i=i_start_f,i_end_f
veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w&
& (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1, k&
& , j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0) + vel*((&
& 7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)-wd(i-2, k, j))/&
& 12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i+1, k, j)-wd(i-2, k&
& , j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w(i&
& -2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1, k, j&
& )-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
END DO
! second order flux close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO k=kts+1,ktf
fqxd(i_start, k) = 0.5*((fzm(k)*rud(i_start, k, j)+fzp(k)*rud(&
& i_start, k-1, j))*(w(i_start, k, j)+w(i_start-1, k, j))+(fzm&
& (k)*ru(i_start, k, j)+fzp(k)*ru(i_start, k-1, j))*(wd(&
& i_start, k, j)+wd(i_start-1, k, j)))
fqx(i_start, k) = 0.5*(fzm(k)*ru(i_start, k, j)+fzp(k)*ru(&
& i_start, k-1, j))*(w(i_start, k, j)+w(i_start-1, k, j))
END DO
k = ktf + 1
fqxd(i_start, k) = 0.5*(((2.-fzm(k-1))*rud(i_start, k-1, j)-fzp(&
& k-1)*rud(i_start, k-2, j))*(w(i_start, k, j)+w(i_start-1, k, j&
& ))+((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1)*ru(i_start, k-2&
& , j))*(wd(i_start, k, j)+wd(i_start-1, k, j)))
fqx(i_start, k) = 0.5*((2.-fzm(k-1))*ru(i_start, k-1, j)-fzp(k-1&
& )*ru(i_start, k-2, j))*(w(i_start, k, j)+w(i_start-1, k, j))
END IF
IF (degrade_xe) THEN
DO k=kts+1,ktf
fqxd(i_end+1, k) = 0.5*((fzm(k)*rud(i_end+1, k, j)+fzp(k)*rud(&
& i_end+1, k-1, j))*(w(i_end+1, k, j)+w(i_end, k, j))+(fzm(k)*&
& ru(i_end+1, k, j)+fzp(k)*ru(i_end+1, k-1, j))*(wd(i_end+1, k&
& , j)+wd(i_end, k, j)))
fqx(i_end+1, k) = 0.5*(fzm(k)*ru(i_end+1, k, j)+fzp(k)*ru(&
& i_end+1, k-1, j))*(w(i_end+1, k, j)+w(i_end, k, j))
END DO
k = ktf + 1
fqxd(i_end+1, k) = 0.5*(((2.-fzm(k-1))*rud(i_end+1, k-1, j)-fzp(&
& k-1)*rud(i_end+1, k-2, j))*(w(i_end+1, k, j)+w(i_end, k, j))+(&
& (2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1)*ru(i_end+1, k-2, j)&
& )*(wd(i_end+1, k, j)+wd(i_end, k, j)))
fqx(i_end+1, k) = 0.5*((2.-fzm(k-1))*ru(i_end+1, k-1, j)-fzp(k-1&
& )*ru(i_end+1, k-2, j))*(w(i_end+1, k, j)+w(i_end, k, j))
END IF
! x flux-divergence into tendency
DO k=kts+1,ktf+1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(&
& i, k))
END DO
END DO
END DO
! next -> y flux divergence calculation
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! 3rd or 4th order flux has a 5 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
j_start = jds + 1
j_start_f = j_start + 1
END IF
IF (degrade_ye) THEN
j_end = jde - 2
j_end_f = jde - 2
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
jp1 = 2
jp0 = 1
fqyd = 0.0
DO j=j_start,j_end+1
IF (j .LT. j_start_f .AND. degrade_ys) THEN
DO k=kts+1,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j_start)+fzp(k)*rvd&
& (i, k-1, j_start))*(w(i, k, j_start)+w(i, k, j_start-1))+(&
& fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, k-1, j_start))*(wd(i&
& , k, j_start)+wd(i, k, j_start-1)))
fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j_start)+fzp(k)*rv(i, &
& k-1, j_start))*(w(i, k, j_start)+w(i, k, j_start-1))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j_start)-fzp&
& (k-1)*rvd(i, k-2, j_start))*(w(i, k, j_start)+w(i, k, &
& j_start-1))+((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-1)*rv(i&
& , k-2, j_start))*(wd(i, k, j_start)+wd(i, k, j_start-1)))
fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j_start)-fzp(k-&
& 1)*rv(i, k-2, j_start))*(w(i, k, j_start)+w(i, k, j_start-1)&
& )
END DO
ELSE IF (j .GT. j_end_f .AND. degrade_ye) THEN
DO k=kts+1,ktf
DO i=i_start,i_end
! Assumes j>j_end_f is ONLY j_end+1 ...
! fqy(i, k, jp1) = &
! 0.5*(fzm(k)*rv(i,k,j_end+1)+fzp(k)*rv(i,k-1,j_end+1)) &
! *(w(i,k,j_end+1)+w(i,k,j_end))
fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-&
& 1, j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k&
& )*rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j&
& ))*(w(i, k, j)+w(i, k, j-1))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
! Assumes j>j_end_f is ONLY j_end+1 ...
! fqy(i, k, jp1) = &
! 0.5*((2.-fzm(k-1))*rv(i,k-1,j_end+1)-fzp(k-1)*rv(i,k-2,j_end+1)) &
! *(w(i,k,j_end+1)+w(i,k,j_end))
fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
& rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(&
& i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1&
& )))
fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(&
& i, k-2, j))*(w(i, k, j)+w(i, k, j-1))
END DO
ELSE
! 3rd or 4th order flux
DO k=kts+1,ktf
DO i=i_start,i_end
veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, &
& k, j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., &
& vel)*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1&
& )))/12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, &
& j+1)-wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (wd(i, k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)&
& ))/12.0)
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel&
& )*(w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))&
& /12.0)
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/&
& 12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-&
& wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, &
& k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
& +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(&
& i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
END DO
END IF
! y flux-divergence into tendency
! Comments for polar boundary conditions
! Same process as for advect_u - tendencies run from jds to jde-1
! (latitudes are as for u grid, longitudes are displaced)
! Therefore: flow is only from one side for points next to poles
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k&
& , jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, &
& jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k&
& , jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, &
& jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts+1,ktf+1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, &
& k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO
ELSE IF (horz_order .EQ. 2) THEN
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
IF (.NOT.config_flags%periodic_x) THEN
IF (config_flags%open_xs .OR. specified) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_xe .OR. specified) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
END IF
END IF
DO j=j_start,j_end
DO k=kts+1,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.5*((fzm(k)*&
& rud(i+1, k, j)+fzp(k)*rud(i+1, k-1, j))*(w(i+1, k, j)+w(i, k&
& , j))+(fzm(k)*ru(i+1, k, j)+fzp(k)*ru(i+1, k-1, j))*(wd(i+1&
& , k, j)+wd(i, k, j))-(fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1&
& , j))*(w(i, k, j)+w(i-1, k, j))-(fzm(k)*ru(i, k, j)+fzp(k)*&
& ru(i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
tendency(i, k, j) = tendency(i, k, j) - mrdx*0.5*((fzm(k)*ru(i&
& +1, k, j)+fzp(k)*ru(i+1, k-1, j))*(w(i+1, k, j)+w(i, k, j))-&
& (fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*(w(i, k, j)+w(i-1&
& , k, j)))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*0.5*(((2.-fzm(k-1&
& ))*rud(i+1, k-1, j)-fzp(k-1)*rud(i+1, k-2, j))*(w(i+1, k, j)+w&
& (i, k, j))+((2.-fzm(k-1))*ru(i+1, k-1, j)-fzp(k-1)*ru(i+1, k-2&
& , j))*(wd(i+1, k, j)+wd(i, k, j))-((2.-fzm(k-1))*rud(i, k-1, j&
& )-fzp(k-1)*rud(i, k-2, j))*(w(i, k, j)+w(i-1, k, j))-((2.-fzm(&
& k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-&
& 1, k, j)))
tendency(i, k, j) = tendency(i, k, j) - mrdx*0.5*(((2.-fzm(k-1))&
& *ru(i+1, k-1, j)-fzp(k-1)*ru(i+1, k-2, j))*(w(i+1, k, j)+w(i, &
& k, j))-((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-2, j))*(w&
& (i, k, j)+w(i-1, k, j)))
END DO
END DO
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
! Polar boundary conditions are like open or specified
IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jde - 2 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 2
END IF
END IF
DO j=j_start,j_end
DO k=kts+1,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j)*rdy
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.5*((fzm(k)*&
& rvd(i, k, j+1)+fzp(k)*rvd(i, k-1, j+1))*(w(i, k, j+1)+w(i, k&
& , j))+(fzm(k)*rv(i, k, j+1)+fzp(k)*rv(i, k-1, j+1))*(wd(i, k&
& , j+1)+wd(i, k, j))-(fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-1, &
& j))*(w(i, k, j)+w(i, k, j-1))-(fzm(k)*rv(i, k, j)+fzp(k)*rv(&
& i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
tendency(i, k, j) = tendency(i, k, j) - mrdy*0.5*((fzm(k)*rv(i&
& , k, j+1)+fzp(k)*rv(i, k-1, j+1))*(w(i, k, j+1)+w(i, k, j))-&
& (fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))*(w(i, k, j)+w(i, k&
& , j-1)))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j)*rdy
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdy*0.5*(((2.-fzm(k-1&
& ))*rvd(i, k-1, j+1)-fzp(k-1)*rvd(i, k-2, j+1))*(w(i, k, j+1)+w&
& (i, k, j))+((2.-fzm(k-1))*rv(i, k-1, j+1)-fzp(k-1)*rv(i, k-2, &
& j+1))*(wd(i, k, j+1)+wd(i, k, j))-((2.-fzm(k-1))*rvd(i, k-1, j&
& )-fzp(k-1)*rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))-((2.-fzm(&
& k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i&
& , k, j-1)))
tendency(i, k, j) = tendency(i, k, j) - mrdy*0.5*(((2.-fzm(k-1))&
& *rv(i, k-1, j+1)-fzp(k-1)*rv(i, k-2, j+1))*(w(i, k, j+1)+w(i, &
& k, j))-((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i, k-2, j))*(w&
& (i, k, j)+w(i, k, j-1)))
END DO
END DO
! Polar boundary condition ... not covered in above j-loop
IF (config_flags%polar) THEN
IF (jts .EQ. jds) THEN
DO k=kts+1,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, jds)*rdy
tendencyd(i, k, jds) = tendencyd(i, k, jds) - mrdy*0.5*((fzm&
& (k)*rvd(i, k, jds+1)+fzp(k)*rvd(i, k-1, jds+1))*(w(i, k, &
& jds+1)+w(i, k, jds))+(fzm(k)*rv(i, k, jds+1)+fzp(k)*rv(i, &
& k-1, jds+1))*(wd(i, k, jds+1)+wd(i, k, jds)))
tendency(i, k, jds) = tendency(i, k, jds) - mrdy*0.5*((fzm(k&
& )*rv(i, k, jds+1)+fzp(k)*rv(i, k-1, jds+1))*(w(i, k, jds+1&
& )+w(i, k, jds)))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, jds)*rdy
tendencyd(i, k, jds) = tendencyd(i, k, jds) - mrdy*0.5*(((2.-&
& fzm(k-1))*rvd(i, k-1, jds+1)-fzp(k-1)*rvd(i, k-2, jds+1))*(w&
& (i, k, jds+1)+w(i, k, jds))+((2.-fzm(k-1))*rv(i, k-1, jds+1)&
& -fzp(k-1)*rv(i, k-2, jds+1))*(wd(i, k, jds+1)+wd(i, k, jds))&
& )
tendency(i, k, jds) = tendency(i, k, jds) - mrdy*0.5*((2.-fzm(&
& k-1))*rv(i, k-1, jds+1)-fzp(k-1)*rv(i, k-2, jds+1))*(w(i, k&
& , jds+1)+w(i, k, jds))
END DO
END IF
IF (jte .EQ. jde) THEN
DO k=kts+1,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, jde-1)*rdy
tendencyd(i, k, jde-1) = tendencyd(i, k, jde-1) + mrdy*0.5*(&
& (fzm(k)*rvd(i, k, jde-1)+fzp(k)*rvd(i, k-1, jde-1))*(w(i, &
& k, jde-1)+w(i, k, jde-2))+(fzm(k)*rv(i, k, jde-1)+fzp(k)*&
& rv(i, k-1, jde-1))*(wd(i, k, jde-1)+wd(i, k, jde-2)))
tendency(i, k, jde-1) = tendency(i, k, jde-1) + mrdy*0.5*((&
& fzm(k)*rv(i, k, jde-1)+fzp(k)*rv(i, k-1, jde-1))*(w(i, k, &
& jde-1)+w(i, k, jde-2)))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, jde-1)*rdy
tendencyd(i, k, jde-1) = tendencyd(i, k, jde-1) + mrdy*0.5*(((&
& 2.-fzm(k-1))*rvd(i, k-1, jde-1)-fzp(k-1)*rvd(i, k-2, jde-1))&
& *(w(i, k, jde-1)+w(i, k, jde-2))+((2.-fzm(k-1))*rv(i, k-1, &
& jde-1)-fzp(k-1)*rv(i, k-2, jde-1))*(wd(i, k, jde-1)+wd(i, k&
& , jde-2)))
tendency(i, k, jde-1) = tendency(i, k, jde-1) + mrdy*0.5*((2.-&
& fzm(k-1))*rv(i, k-1, jde-1)-fzp(k-1)*rv(i, k-2, jde-1))*(w(i&
& , k, jde-1)+w(i, k, jde-2))
END DO
END IF
END IF
ELSE IF (horz_order .NE. 0) THEN
! Just in case we want to turn horizontal advection off, we can do it
WRITE(wrf_err_message, *) ' advect_w_6a, h_order not known ', &
& horz_order
CALL WRF_ERROR_FATAL(wrf_err_message)
END IF
! pick up the the horizontal radiation boundary conditions.
! (these are the computations that don't require 'cb'.
! first, set to index ranges
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
IF (config_flags%open_xs .AND. its .EQ. ids) THEN
DO j=j_start,j_end
DO k=kts+1,ktf
uwd = 0.5*(fzm(k)*(rud(its, k, j)+rud(its+1, k, j))+fzp(k)*(rud(&
& its, k-1, j)+rud(its+1, k-1, j)))
uw = 0.5*(fzm(k)*(ru(its, k, j)+ru(its+1, k, j))+fzp(k)*(ru(its&
& , k-1, j)+ru(its+1, k-1, j)))
IF (uw .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(w_old(&
& its+1, k, j)-w_old(its, k, j))+ub*(w_oldd(its+1, k, j)-w_oldd(&
& its, k, j))+wd(its, k, j)*(fzm(k)*(ru(its+1, k, j)-ru(its, k, &
& j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j)))+w(its, k, j)*(&
& fzm(k)*(rud(its+1, k, j)-rud(its, k, j))+fzp(k)*(rud(its+1, k-&
& 1, j)-rud(its, k-1, j))))
tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(w_old(its+1&
& , k, j)-w_old(its, k, j))+w(its, k, j)*(fzm(k)*(ru(its+1, k, j&
& )-ru(its, k, j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j))))
END DO
END DO
k = ktf + 1
DO j=j_start,j_end
uwd = 0.5*((2.-fzm(k-1))*(rud(its, k-1, j)+rud(its+1, k-1, j))-fzp&
& (k-1)*(rud(its, k-2, j)+rud(its+1, k-2, j)))
uw = 0.5*((2.-fzm(k-1))*(ru(its, k-1, j)+ru(its+1, k-1, j))-fzp(k-&
& 1)*(ru(its, k-2, j)+ru(its+1, k-2, j)))
IF (uw .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(w_old(its+&
& 1, k, j)-w_old(its, k, j))+ub*(w_oldd(its+1, k, j)-w_oldd(its, k&
& , j))+wd(its, k, j)*((2.-fzm(k-1))*(ru(its+1, k-1, j)-ru(its, k-&
& 1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2, j)))+w(its, k, j&
& )*((2.-fzm(k-1))*(rud(its+1, k-1, j)-rud(its, k-1, j))-fzp(k-1)*&
& (rud(its+1, k-2, j)-rud(its, k-2, j))))
tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(w_old(its+1, &
& k, j)-w_old(its, k, j))+w(its, k, j)*((2.-fzm(k-1))*(ru(its+1, k&
& -1, j)-ru(its, k-1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2&
& , j))))
END DO
END IF
IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
DO j=j_start,j_end
DO k=kts+1,ktf
uwd = 0.5*(fzm(k)*(rud(ite-1, k, j)+rud(ite, k, j))+fzp(k)*(rud(&
& ite-1, k-1, j)+rud(ite, k-1, j)))
uw = 0.5*(fzm(k)*(ru(ite-1, k, j)+ru(ite, k, j))+fzp(k)*(ru(ite-&
& 1, k-1, j)+ru(ite, k-1, j)))
IF (uw .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
& w_old(i_end, k, j)-w_old(i_end-1, k, j))+ub*(w_oldd(i_end, k, &
& j)-w_oldd(i_end-1, k, j))+wd(i_end, k, j)*(fzm(k)*(ru(ite, k, &
& j)-ru(ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, k-1, j))&
& )+w(i_end, k, j)*(fzm(k)*(rud(ite, k, j)-rud(ite-1, k, j))+fzp&
& (k)*(rud(ite, k-1, j)-rud(ite-1, k-1, j))))
tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(w_old(&
& i_end, k, j)-w_old(i_end-1, k, j))+w(i_end, k, j)*(fzm(k)*(ru(&
& ite, k, j)-ru(ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, &
& k-1, j))))
END DO
END DO
k = ktf + 1
DO j=j_start,j_end
uwd = 0.5*((2.-fzm(k-1))*(rud(ite-1, k-1, j)+rud(ite, k-1, j))-fzp&
& (k-1)*(rud(ite-1, k-2, j)+rud(ite, k-2, j)))
uw = 0.5*((2.-fzm(k-1))*(ru(ite-1, k-1, j)+ru(ite, k-1, j))-fzp(k-&
& 1)*(ru(ite-1, k-2, j)+ru(ite, k-2, j)))
IF (uw .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(w_old(&
& i_end, k, j)-w_old(i_end-1, k, j))+ub*(w_oldd(i_end, k, j)-&
& w_oldd(i_end-1, k, j))+wd(i_end, k, j)*((2.-fzm(k-1))*(ru(ite, k&
& -1, j)-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-ru(ite-1, k-&
& 2, j)))+w(i_end, k, j)*((2.-fzm(k-1))*(rud(ite, k-1, j)-rud(ite-&
& 1, k-1, j))-fzp(k-1)*(rud(ite, k-2, j)-rud(ite-1, k-2, j))))
tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(w_old(&
& i_end, k, j)-w_old(i_end-1, k, j))+w(i_end, k, j)*((2.-fzm(k-1))&
& *(ru(ite, k-1, j)-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-&
& ru(ite-1, k-2, j))))
END DO
END IF
IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
DO i=i_start,i_end
DO k=kts+1,ktf
vwd = 0.5*(fzm(k)*(rvd(i, k, jts)+rvd(i, k, jts+1))+fzp(k)*(rvd(&
& i, k-1, jts)+rvd(i, k-1, jts+1)))
vw = 0.5*(fzm(k)*(rv(i, k, jts)+rv(i, k, jts+1))+fzp(k)*(rv(i, k&
& -1, jts)+rv(i, k-1, jts+1)))
IF (vw .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(w_old(i&
& , k, jts+1)-w_old(i, k, jts))+vb*(w_oldd(i, k, jts+1)-w_oldd(i&
& , k, jts))+wd(i, k, jts)*(fzm(k)*(rv(i, k, jts+1)-rv(i, k, jts&
& ))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts)))+w(i, k, jts)*(&
& fzm(k)*(rvd(i, k, jts+1)-rvd(i, k, jts))+fzp(k)*(rvd(i, k-1, &
& jts+1)-rvd(i, k-1, jts))))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(w_old(i, k&
& , jts+1)-w_old(i, k, jts))+w(i, k, jts)*(fzm(k)*(rv(i, k, jts+&
& 1)-rv(i, k, jts))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts))))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
vwd = 0.5*((2.-fzm(k-1))*(rvd(i, k-1, jts)+rvd(i, k-1, jts+1))-fzp&
& (k-1)*(rvd(i, k-2, jts)+rvd(i, k-2, jts+1)))
vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jts)+rv(i, k-1, jts+1))-fzp(k-&
& 1)*(rv(i, k-2, jts)+rv(i, k-2, jts+1)))
IF (vw .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(w_old(i, k&
& , jts+1)-w_old(i, k, jts))+vb*(w_oldd(i, k, jts+1)-w_oldd(i, k, &
& jts))+wd(i, k, jts)*((2.-fzm(k-1))*(rv(i, k-1, jts+1)-rv(i, k-1&
& , jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2, jts)))+w(i, k, &
& jts)*((2.-fzm(k-1))*(rvd(i, k-1, jts+1)-rvd(i, k-1, jts))-fzp(k-&
& 1)*(rvd(i, k-2, jts+1)-rvd(i, k-2, jts))))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(w_old(i, k, &
& jts+1)-w_old(i, k, jts))+w(i, k, jts)*((2.-fzm(k-1))*(rv(i, k-1&
& , jts+1)-rv(i, k-1, jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2&
& , jts))))
END DO
END IF
IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
DO i=i_start,i_end
DO k=kts+1,ktf
vwd = 0.5*(fzm(k)*(rvd(i, k, jte-1)+rvd(i, k, jte))+fzp(k)*(rvd(&
& i, k-1, jte-1)+rvd(i, k-1, jte)))
vw = 0.5*(fzm(k)*(rv(i, k, jte-1)+rv(i, k, jte))+fzp(k)*(rv(i, k&
& -1, jte-1)+rv(i, k-1, jte)))
IF (vw .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
& w_old(i, k, j_end)-w_old(i, k, j_end-1))+vb*(w_oldd(i, k, &
& j_end)-w_oldd(i, k, j_end-1))+wd(i, k, j_end)*(fzm(k)*(rv(i, k&
& , jte)-rv(i, k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, jte&
& -1)))+w(i, k, j_end)*(fzm(k)*(rvd(i, k, jte)-rvd(i, k, jte-1))&
& +fzp(k)*(rvd(i, k-1, jte)-rvd(i, k-1, jte-1))))
tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(w_old(i&
& , k, j_end)-w_old(i, k, j_end-1))+w(i, k, j_end)*(fzm(k)*(rv(i&
& , k, jte)-rv(i, k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, &
& jte-1))))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
vwd = 0.5*((2.-fzm(k-1))*(rvd(i, k-1, jte-1)+rvd(i, k-1, jte))-fzp&
& (k-1)*(rvd(i, k-2, jte-1)+rvd(i, k-2, jte)))
vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jte-1)+rv(i, k-1, jte))-fzp(k-&
& 1)*(rv(i, k-2, jte-1)+rv(i, k-2, jte)))
IF (vw .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(w_old(&
& i, k, j_end)-w_old(i, k, j_end-1))+vb*(w_oldd(i, k, j_end)-&
& w_oldd(i, k, j_end-1))+wd(i, k, j_end)*((2.-fzm(k-1))*(rv(i, k-1&
& , jte)-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(i, k-2, &
& jte-1)))+w(i, k, j_end)*((2.-fzm(k-1))*(rvd(i, k-1, jte)-rvd(i, &
& k-1, jte-1))-fzp(k-1)*(rvd(i, k-2, jte)-rvd(i, k-2, jte-1))))
tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(w_old(i, &
& k, j_end)-w_old(i, k, j_end-1))+w(i, k, j_end)*((2.-fzm(k-1))*(&
& rv(i, k-1, jte)-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(&
& i, k-2, jte-1))))
END DO
END IF
!-------------------- vertical advection
! ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
! Here we have: - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
! Therefore we don't need to make a correction for advect_w
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
DO i=i_start,i_end
vfluxd(i, kts) = 0.0
vflux(i, kts) = 0.
vfluxd(i, kte) = 0.0
vflux(i, kte) = 0.
END DO
IF (vert_order .EQ. 6) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+3,ktf-1
DO i=i_start,i_end
veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
vfluxd(i, k) = veld*(37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k+&
& 1, j)+w(i, k-2, j))+(w(i, k+2, j)+w(i, k-3, j)))/60.0 + vel*&
& (37.*(wd(i, k, j)+wd(i, k-1, j))-8.*(wd(i, k+1, j)+wd(i, k-2&
& , j))+wd(i, k+2, j)+wd(i, k-3, j))/60.0
vflux(i, k) = vel*((37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k+1&
& , j)+w(i, k-2, j))+(w(i, k+2, j)+w(i, k-3, j)))/60.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
& +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
& , k-1, j)))
vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
& , k-1, j))
k = kts + 2
veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
vfluxd(i, k) = veld*(7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+&
& w(i, k-2, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k-1, j))-wd(i&
& , k+1, j)-wd(i, k-2, j))/12.0
vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
& (i, k-2, j)))/12.0)
k = ktf
veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
vfluxd(i, k) = veld*(7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+&
& w(i, k-2, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k-1, j))-wd(i&
& , k+1, j)-wd(i, k-2, j))/12.0
vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
& (i, k-2, j)))/12.0)
k = ktf + 1
vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
& +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
& , k-1, j)))
vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
& , k-1, j))
END DO
DO k=kts+1,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
! pick up flux contribution for w at the lid. wcs, 13 march 2004
k = ktf + 1
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i&
& , k)
tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
END DO
END DO
ELSE IF (vert_order .EQ. 5) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+3,ktf-1
DO i=i_start,i_end
veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
vfluxd(i, k) = veld*((37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k&
& +1, j)+w(i, k-2, j))+(w(i, k+2, j)+w(i, k-3, j)))/60.0-SIGN(&
& 1, time_step)*SIGN(1., -vel)*(w(i, k+2, j)-w(i, k-3, j)-5.*(&
& w(i, k+1, j)-w(i, k-2, j))+10.*(w(i, k, j)-w(i, k-1, j)))/&
& 60.0) + vel*((37.*(wd(i, k, j)+wd(i, k-1, j))-8.*(wd(i, k+1&
& , j)+wd(i, k-2, j))+wd(i, k+2, j)+wd(i, k-3, j))/60.0-SIGN(1&
& , time_step)*SIGN(1., -vel)*(wd(i, k+2, j)-wd(i, k-3, j)-5.*&
& (wd(i, k+1, j)-wd(i, k-2, j))+10.*(wd(i, k, j)-wd(i, k-1, j)&
& ))/60.0)
vflux(i, k) = vel*((37.*(w(i, k, j)+w(i, k-1, j))-8.*(w(i, k+1&
& , j)+w(i, k-2, j))+(w(i, k+2, j)+w(i, k-3, j)))/60.0-SIGN(1&
& , time_step)*SIGN(1., -vel)*(w(i, k+2, j)-w(i, k-3, j)-5.*(w&
& (i, k+1, j)-w(i, k-2, j))+10.*(w(i, k, j)-w(i, k-1, j)))/&
& 60.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
& +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
& , k-1, j)))
vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
& , k-1, j))
k = kts + 2
veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
vfluxd(i, k) = veld*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)&
& +w(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k&
& +1, j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0) + vel*&
& ((7.*(wd(i, k, j)+wd(i, k-1, j))-wd(i, k+1, j)-wd(i, k-2, j))/&
& 12.0+SIGN(1, time_step)*SIGN(1., -vel)*(wd(i, k+1, j)-wd(i, k-&
& 2, j)-3.*(wd(i, k, j)-wd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1&
& , j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0)
k = ktf
veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
vfluxd(i, k) = veld*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)&
& +w(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k&
& +1, j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0) + vel*&
& ((7.*(wd(i, k, j)+wd(i, k-1, j))-wd(i, k+1, j)-wd(i, k-2, j))/&
& 12.0+SIGN(1, time_step)*SIGN(1., -vel)*(wd(i, k+1, j)-wd(i, k-&
& 2, j)-3.*(wd(i, k, j)-wd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1&
& , j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0)
k = ktf + 1
vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
& +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
& , k-1, j)))
vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
& , k-1, j))
END DO
DO k=kts+1,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
! pick up flux contribution for w at the lid, wcs. 13 march 2004
k = ktf + 1
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i&
& , k)
tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
END DO
END DO
ELSE IF (vert_order .EQ. 4) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+2,ktf
DO i=i_start,i_end
veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
vfluxd(i, k) = veld*(7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j&
& )+w(i, k-2, j)))/12.0 + vel*(7.*(wd(i, k, j)+wd(i, k-1, j))-&
& wd(i, k+1, j)-wd(i, k-2, j))/12.0
vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)&
& +w(i, k-2, j)))/12.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
& +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
& , k-1, j)))
vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
& , k-1, j))
k = ktf + 1
vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
& +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
& , k-1, j)))
vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
& , k-1, j))
END DO
DO k=kts+1,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
! pick up flux contribution for w at the lid, wcs. 13 march 2004
k = ktf + 1
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i&
& , k)
tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
END DO
END DO
ELSE IF (vert_order .EQ. 3) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+2,ktf
DO i=i_start,i_end
veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
vfluxd(i, k) = veld*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, &
& j)+w(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(&
& i, k+1, j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0) &
& + vel*((7.*(wd(i, k, j)+wd(i, k-1, j))-wd(i, k+1, j)-wd(i, k&
& -2, j))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(wd(i, k+1, j&
& )-wd(i, k-2, j)-3.*(wd(i, k, j)-wd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)&
& +w(i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i&
& , k+1, j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
& +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
& , k-1, j)))
vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
& , k-1, j))
k = ktf + 1
vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)&
& +w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i&
& , k-1, j)))
vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i&
& , k-1, j))
END DO
DO k=kts+1,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
! pick up flux contribution for w at the lid, wcs. 13 march 2004
k = ktf + 1
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i&
& , k)
tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
END DO
END DO
ELSE IF (vert_order .EQ. 2) THEN
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+1,ktf+1
DO i=i_start,i_end
vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, &
& j)+w(i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+&
& wd(i, k-1, j)))
vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w&
& (i, k-1, j))
END DO
END DO
DO k=kts+1,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k&
& +1)-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)&
& -vflux(i, k))
END DO
END DO
! pick up flux contribution for w at the lid, wcs. 13 march 2004
k = ktf + 1
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i&
& , k)
tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
END DO
END DO
ELSE
WRITE(wrf_err_message, *) ' advect_w, v_order not known ', &
& vert_order
CALL WRF_ERROR_FATAL(wrf_err_message)
END IF
END SUBROUTINE G_ADVECT_W
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
! Differentiation of advect_scalar_pd in forward (tangent) mode:
! variations of useful results: tendency h_tendency z_tendency
! with respect to varying inputs: rom field tendency h_tendency
! z_tendency ru rv mu_old field_old mut
! RW status of diff variables: rom:in field:in tendency:in-out
! h_tendency:in-out z_tendency:in-out ru:in rv:in
! mu_old:in field_old:in mut:in
SUBROUTINE G_ADVECT_SCALAR_PD(field, fieldd, field_old, field_oldd, &
& tendency, tendencyd, h_tendency, h_tendencyd, z_tendency, z_tendencyd&
& , ru, rud, rv, rvd, rom, romd, mut, mutd, mub, mu_old, mu_oldd, &
& time_step, config_flags, tenddec, msfux, msfuy, msfvx, msfvy, msftx, &
& msfty, fzm, fzp, rdx, rdy, rdzw, dt, ids, ide, jds, jde, kds, kde, ims&
& , ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
IMPLICIT NONE
! Input data
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
! tendency flag
LOGICAL, INTENT(IN) :: tenddec
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
& field_old, ru, rv, rom
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: fieldd, &
& field_oldd, rud, rvd, romd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut, mub, mu_old
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd, mu_oldd
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: h_tendency&
& , z_tendency
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: h_tendencyd&
& , z_tendencyd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
& msfvy, msftx, msfty
REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
REAL, INTENT(IN) :: rdx, rdy, dt
INTEGER, INTENT(IN) :: time_step
! Local data
INTEGER :: i, j, k, itf, jtf, ktf
INTEGER :: i_start, i_end, j_start, j_end
INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
INTEGER :: jmin, jmax, jp, jm, imin, imax
REAL :: mrdx, mrdy, ub, vb, uw, vw, mu
REAL :: ubd, vbd, mud
! storage for high and low order fluxes
REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqx, fqy&
& , fqz
REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxd, fqyd, fqzd
REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqxl, &
& fqyl, fqzl
REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxld, fqyld, &
& fqzld
INTEGER :: horz_order, vert_order
LOGICAL :: degrade_xs, degrade_ys
LOGICAL :: degrade_xe, degrade_ye
INTEGER :: jp1, jp0, jtmp
REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_out, ph_low
REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_outd, ph_lowd
REAL :: scale
REAL :: scaled
REAL, PARAMETER :: eps=1.e-20
! definition of flux operators, 3rd, 4th, 5th or 6th order
REAL :: flux3, flux4, flux5, flux6, flux_upwind
REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
REAL :: veld, crd
! flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
! +0.5*(1.-sign(1.,cr))*q_i
! flux_upwind(q_im1, q_i, cr ) = 0.
REAL :: dx, dy, dz
LOGICAL, PARAMETER :: pd_limit=.true.
REAL :: abs30
REAL :: y93
REAL :: max43
REAL :: abs67
REAL :: abs100
REAL :: abs18d
REAL :: y92
REAL :: max42
REAL :: abs66
REAL :: abs26d
REAL :: max39d
REAL :: y91
REAL :: max41
REAL :: abs65
REAL :: y28d
REAL :: abs34d
REAL :: min5d
REAL :: max10d
REAL :: max47d
REAL :: y90
REAL :: max40
REAL :: abs64
REAL :: abs79d
REAL :: y36d
REAL :: abs42d
REAL :: abs63
REAL :: abs87d
REAL :: y44d
REAL :: abs50d
REAL :: abs62
REAL :: abs99
REAL :: min37d
REAL :: y52d
REAL :: y89d
REAL :: abs95d
REAL :: abs61
REAL :: abs98
REAL :: y4d
REAL :: y60d
REAL :: y97d
INTEGER :: min39
REAL :: abs60
REAL :: abs97
INTEGER :: min9
REAL :: min38
REAL :: abs96
REAL :: abs29d
REAL :: min61d
REAL :: abs102d
INTEGER :: min8
REAL :: min37
REAL :: abs95
REAL :: max13d
REAL :: abs37d
REAL :: min7
REAL :: min36
REAL :: abs94
REAL :: max21d
REAL :: abs1d
REAL :: y39d
REAL :: abs45d
REAL :: min6
INTEGER :: min35
REAL :: y29
REAL :: abs93
REAL :: abs53d
REAL :: y10d
REAL :: y47d
REAL :: min5
INTEGER :: min34
REAL :: y28
REAL :: abs92
REAL :: y55d
REAL :: abs61d
REAL :: abs98d
REAL :: min4
REAL :: min33
REAL :: y27
REAL :: abs91
REAL :: y63d
REAL :: min48d
REAL :: max2d
REAL :: y7d
REAL :: min11d
REAL :: min3
REAL :: min32
REAL :: y26
REAL :: min69
REAL :: abs90
REAL :: y71d
REAL :: min56d
INTEGER :: min2
REAL :: min31
REAL :: y25
REAL :: min68
REAL :: min64d
INTEGER :: min1
INTEGER :: min30
REAL :: y24
REAL :: min67
REAL :: max16d
REAL :: y23
REAL :: min66
REAL :: abs11d
REAL :: max24d
REAL :: abs4d
REAL :: abs48d
REAL :: y22
REAL :: min65
REAL :: y59
REAL :: y13d
REAL :: max32d
REAL :: abs56d
REAL :: y21
REAL :: min64
REAL :: y58
REAL :: abs64d
REAL :: y21d
REAL :: y58d
REAL :: max40d
REAL :: y20
REAL :: min63
REAL :: y57
REAL :: y66d
REAL :: abs72d
REAL :: max5d
REAL :: min14d
REAL :: min62
REAL :: y56
REAL :: y74d
REAL :: abs80d
REAL :: min59d
REAL :: y102d
REAL :: min61
REAL :: y55
REAL :: abs29
REAL :: y82d
REAL :: min67d
REAL :: min60
REAL :: y54
REAL :: abs28
REAL :: max19d
REAL :: y90d
REAL :: min75d
REAL :: y53
REAL :: abs27
REAL :: abs14d
REAL :: max27d
REAL :: abs7d
REAL :: y52
REAL :: abs26
REAL :: y89
REAL :: max39
REAL :: y16d
REAL :: abs22d
REAL :: max35d
REAL :: abs59d
REAL :: y51
REAL :: abs25
REAL :: y88
REAL :: max38
REAL :: abs67d
REAL :: y24d
REAL :: abs30d
REAL :: max43d
REAL :: y50
REAL :: abs24
REAL :: y87
REAL :: max37
REAL :: min17d
REAL :: y69d
REAL :: abs75d
REAL :: y32d
REAL :: max8d
REAL :: max51d
REAL :: abs23
REAL :: y86
REAL :: max36
REAL :: min25d
REAL :: y77d
REAL :: abs83d
REAL :: y40d
REAL :: abs22
REAL :: y85
REAL :: max35
REAL :: abs59
REAL :: min33d
REAL :: y85d
REAL :: abs91d
REAL :: abs21
REAL :: y84
REAL :: max34
REAL :: abs58
REAL :: min41d
REAL :: y93d
REAL :: abs20
REAL :: y83
REAL :: max33
REAL :: abs57
REAL :: abs17d
REAL :: y82
REAL :: max32
REAL :: abs56
REAL :: y19d
REAL :: abs25d
REAL :: max38d
REAL :: y81
REAL :: max31
REAL :: abs55
REAL :: y27d
REAL :: abs33d
REAL :: min4d
REAL :: max46d
REAL :: y80
REAL :: max30
REAL :: abs54
REAL :: abs78d
REAL :: y35d
REAL :: abs41d
REAL :: max54d
REAL :: abs53
REAL :: min28d
REAL :: abs86d
REAL :: y43d
REAL :: abs52
REAL :: abs89
REAL :: min36d
REAL :: y88d
REAL :: abs94d
REAL :: y51d
REAL :: abs51
REAL :: abs88
REAL :: y3d
REAL :: y96d
INTEGER :: min29
REAL :: abs50
REAL :: abs87
REAL :: min52d
REAL :: min28
REAL :: abs86
REAL :: abs28d
REAL :: min60d
REAL :: abs101d
REAL :: min27
REAL :: abs85
REAL :: max12d
REAL :: min7d
REAL :: abs36d
REAL :: max49d
REAL :: min26
REAL :: abs84
REAL :: max20d
REAL :: y38d
REAL :: abs44d
REAL :: min25
REAL :: y19
REAL :: abs83
REAL :: abs52d
REAL :: abs89d
REAL :: y46d
REAL :: min24
REAL :: y18
REAL :: abs82
REAL :: y54d
REAL :: abs60d
REAL :: abs97d
INTEGER :: min23
REAL :: y17
REAL :: abs81
REAL :: y62d
REAL :: min47d
REAL :: y6d
REAL :: min10d
REAL :: y99d
REAL :: max1d
INTEGER :: min22
REAL :: y16
REAL :: min59
REAL :: abs80
REAL :: y70d
REAL :: min55d
REAL :: y15
REAL :: min21
REAL :: min58
REAL :: min63d
REAL :: y14
REAL :: min20
REAL :: min57
REAL :: max15d
REAL :: abs39d
REAL :: min71d
REAL :: y13
REAL :: min56
REAL :: max23d
REAL :: abs3d
REAL :: abs10d
REAL :: abs47d
REAL :: y12
REAL :: min55
REAL :: y49
REAL :: y12d
REAL :: max31d
REAL :: abs55d
REAL :: y49d
REAL :: y11
INTEGER :: min54
REAL :: y48
REAL :: abs63d
REAL :: y20d
REAL :: y57d
REAL :: y10
INTEGER :: min53
REAL :: y47
REAL :: y65d
REAL :: abs71d
REAL :: max4d
REAL :: y9d
REAL :: min13d
REAL :: min52
REAL :: y46
REAL :: min21d
REAL :: y73d
REAL :: min58d
REAL :: y101d
REAL :: min51
REAL :: y45
REAL :: abs19
REAL :: y81d
REAL :: min66d
INTEGER :: min50
REAL :: y44
REAL :: abs18
REAL :: max18d
REAL :: min74d
REAL :: y43
REAL :: abs17
REAL :: abs13d
REAL :: max26d
REAL :: abs6d
REAL :: y42
REAL :: abs16
REAL :: y79
REAL :: max29
REAL :: y15d
REAL :: abs21d
REAL :: max34d
REAL :: abs58d
REAL :: y41
REAL :: abs15
REAL :: y78
REAL :: max28
REAL :: abs66d
REAL :: y23d
REAL :: max42d
REAL :: y40
REAL :: abs14
REAL :: y77
REAL :: max27
REAL :: y68d
REAL :: abs74d
REAL :: y31d
REAL :: max7d
REAL :: max50d
REAL :: abs13
REAL :: y76
REAL :: max26
REAL :: min24d
REAL :: y76d
REAL :: abs82d
REAL :: abs12
REAL :: y75
REAL :: max25
REAL :: abs49
REAL :: min32d
REAL :: y84d
REAL :: abs90d
REAL :: min69d
REAL :: abs11
REAL :: y74
REAL :: max24
REAL :: abs48
REAL :: y102
REAL :: y92d
REAL :: abs10
REAL :: y73
REAL :: max23
REAL :: abs47
REAL :: y101
REAL :: abs16d
REAL :: max29d
REAL :: abs9d
REAL :: y72
REAL :: max22
REAL :: abs46
REAL :: y100
REAL :: y18d
REAL :: abs24d
REAL :: max37d
REAL :: y71
REAL :: max21
REAL :: abs45
REAL :: abs69d
REAL :: y26d
REAL :: abs32d
REAL :: min3d
REAL :: max45d
REAL :: y70
REAL :: max20
REAL :: abs44
REAL :: min19d
REAL :: abs77d
REAL :: y34d
REAL :: abs40d
REAL :: max53d
REAL :: abs43
REAL :: min27d
REAL :: y79d
REAL :: abs85d
REAL :: y42d
REAL :: abs42
REAL :: abs79
REAL :: y87d
REAL :: abs93d
REAL :: y50d
REAL :: abs41
REAL :: abs78
REAL :: max54
REAL :: min43d
REAL :: y2d
REAL :: y95d
REAL :: min19
REAL :: abs40
REAL :: abs77
REAL :: max53
REAL :: abs19d
REAL :: min51d
REAL :: min18
REAL :: max52
REAL :: abs76
REAL :: abs27d
REAL :: abs100d
REAL :: min17
REAL :: max51
REAL :: abs75
REAL :: y29d
REAL :: min6d
REAL :: max11d
REAL :: abs35d
REAL :: max48d
INTEGER :: min16
REAL :: abs9
REAL :: max50
REAL :: abs74
REAL :: y37d
REAL :: abs43d
INTEGER :: min15
REAL :: abs8
REAL :: abs73
REAL :: abs88d
REAL :: y45d
REAL :: abs51d
REAL :: min14
REAL :: abs7
REAL :: abs72
REAL :: min38d
REAL :: y53d
REAL :: abs96d
REAL :: min13
REAL :: abs6
REAL :: abs71
REAL :: min46d
REAL :: y5d
REAL :: y61d
REAL :: y98d
REAL :: min12
INTEGER :: min49
REAL :: abs5
REAL :: abs70
REAL :: min11
REAL :: min48
REAL :: abs4
REAL :: min62d
REAL :: min10
REAL :: min47
REAL :: abs3
REAL :: max14d
REAL :: abs38d
REAL :: min70d
REAL :: min46
REAL :: abs2
REAL :: max22d
REAL :: abs2d
REAL :: abs46d
INTEGER :: min45
REAL :: y39
REAL :: abs1
REAL :: y11d
REAL :: max30d
REAL :: abs54d
REAL :: y48d
INTEGER :: min44
REAL :: y38
REAL :: abs62d
REAL :: y56d
REAL :: abs99d
REAL :: min43
REAL :: y37
REAL :: y64d
REAL :: abs70d
REAL :: max3d
REAL :: y8d
REAL :: min12d
REAL :: min42
REAL :: y36
REAL :: min20d
REAL :: y72d
REAL :: min57d
REAL :: y100d
REAL :: min41
REAL :: y35
REAL :: y80d
REAL :: min65d
INTEGER :: min40
REAL :: y34
REAL :: max17d
REAL :: y33
REAL :: max9
REAL :: min76
REAL :: abs12d
REAL :: max25d
REAL :: abs5d
REAL :: abs49d
REAL :: y32
REAL :: max8
REAL :: y69
REAL :: max19
REAL :: min75
REAL :: y14d
REAL :: abs20d
REAL :: max33d
REAL :: abs57d
REAL :: y31
REAL :: max7
REAL :: y68
REAL :: max18
REAL :: min74
REAL :: abs65d
REAL :: y22d
REAL :: y59d
REAL :: max41d
REAL :: y30
INTEGER :: min73
REAL :: max6
REAL :: y67
REAL :: max17
REAL :: y67d
REAL :: abs73d
REAL :: y30d
REAL :: max6d
INTEGER :: min72
REAL :: max5
REAL :: y66
REAL :: max16
REAL :: y75d
REAL :: abs81d
REAL :: y9
REAL :: min71
REAL :: max4
REAL :: y65
REAL :: max15
REAL :: abs39
REAL :: min31d
REAL :: y83d
REAL :: min68d
REAL :: y8
REAL :: min70
REAL :: max3
REAL :: y64
REAL :: max14
REAL :: abs38
REAL :: y91d
REAL :: min76d
REAL :: y7
REAL :: max2
REAL :: y63
REAL :: max13
REAL :: abs37
REAL :: abs15d
REAL :: max28d
REAL :: abs8d
REAL :: y6
REAL :: max1
REAL :: y62
REAL :: max12
REAL :: abs36
REAL :: y99
REAL :: max49
REAL :: y17d
REAL :: abs23d
REAL :: max36d
REAL :: y5
REAL :: y61
REAL :: max11
REAL :: abs35
REAL :: y98
REAL :: max48
REAL :: abs68d
REAL :: y25d
REAL :: abs31d
REAL :: max44d
REAL :: y4
REAL :: y60
REAL :: max10
REAL :: abs34
REAL :: y97
REAL :: max47
REAL :: min18d
REAL :: abs76d
REAL :: y33d
REAL :: max9d
REAL :: max52d
REAL :: y3
REAL :: abs33
REAL :: y96
REAL :: max46
REAL :: min26d
REAL :: y78d
REAL :: abs84d
REAL :: y41d
REAL :: y2
REAL :: abs32
REAL :: y95
REAL :: max45
REAL :: abs69
REAL :: abs102
REAL :: y86d
REAL :: abs92d
REAL :: y1
REAL :: abs31
REAL :: y94
REAL :: max44
REAL :: abs68
REAL :: abs101
REAL :: min42d
REAL :: y1d
REAL :: y94d
! set order for the advection schemes
! write(6,*) ' in pd advection routine '
! Empty arrays just in case:
IF (config_flags%polar) THEN
fqx(:, :, :) = 0.
fqy(:, :, :) = 0.
fqz(:, :, :) = 0.
fqxl(:, :, :) = 0.
fqyl(:, :, :) = 0.
fqzl(:, :, :) = 0.
END IF
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
horz_order = config_flags%h_sca_adv_order
vert_order = config_flags%v_sca_adv_order
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
! begin with horizontal flux divergence
! here is the choice of flux operators
IF (horz_order .EQ. 6) THEN
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 4) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 4) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min1 = ide - 1
ELSE
min1 = ite
END IF
i_end = min1 + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min2 = jde - 1
ELSE
min2 = jte
END IF
j_end = min2 + 1
j_start_f = j_start
j_end_f = j_end + 1
!-- modify loop bounds if open or specified
! IF(degrade_xs) i_start = MAX(its-1,ids-1)
! IF(degrade_xe) i_end = MIN(ite+1,ide-2)
IF (degrade_xs) THEN
IF (its - 1 .LT. ids) THEN
i_start = ids
ELSE
i_start = its - 1
END IF
END IF
IF (degrade_xe) THEN
IF (ite + 1 .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite + 1
END IF
END IF
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts - 1
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte + 1
END IF
j_end_f = jde - 3
fqyld = 0.0
fqyd = 0.0
ELSE
fqyld = 0.0
fqyd = 0.0
END IF
! compute fluxes, 6th order
j_loop_y_flux_6:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
! use full stencil
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs1d = crd
abs1 = cr
ELSE
abs1d = -crd
abs1 = -cr
END IF
y1d = crd + abs1d
y1 = cr + abs1
IF (1.0 .GT. y1) THEN
min3d = y1d
min3 = y1
ELSE
min3 = 1.0
min3d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs52d = crd
abs52 = cr
ELSE
abs52d = -crd
abs52 = -cr
END IF
y52d = crd - abs52d
y52 = cr - abs52
IF (-1.0 .LT. y52) THEN
max2d = y52d
max2 = y52
ELSE
max2 = -1.0
max2d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min3*field_old(i, k, j-1)+0.5*&
& max2*field_old(i, k, j))+mu*(0.5*(min3d*field_old(i, k, j-&
& 1)+min3*field_oldd(i, k, j-1))+0.5*(max2d*field_old(i, k, &
& j)+max2*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min3*field_old(i, k, j-1)+&
& 0.5*max2*field_old(i, k, j))
fqyd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i, k, j-&
& 1))-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(&
& field(i, k, j+2)+field(i, k, j-3))) + vel*(37.*(fieldd(i, &
& k, j)+fieldd(i, k, j-1))/60.-2.*(fieldd(i, k, j+1)+fieldd(&
& i, k, j-2))/15.+(fieldd(i, k, j+2)+fieldd(i, k, j-3))/60.)
fqy(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k, j-1)&
& )-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(field&
& (i, k, j+2)+field(i, k, j-3)))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs2d = crd
abs2 = cr
ELSE
abs2d = -crd
abs2 = -cr
END IF
y2d = crd + abs2d
y2 = cr + abs2
IF (1.0 .GT. y2) THEN
min4d = y2d
min4 = y2
ELSE
min4 = 1.0
min4d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs53d = crd
abs53 = cr
ELSE
abs53d = -crd
abs53 = -cr
END IF
y53d = crd - abs53d
y53 = cr - abs53
IF (-1.0 .LT. y53) THEN
max3d = y53d
max3 = y53
ELSE
max3 = -1.0
max3d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min4*field_old(i, k, j-1)+0.5*&
& max3*field_old(i, k, j))+mu*(0.5*(min4d*field_old(i, k, j-&
& 1)+min4*field_oldd(i, k, j-1))+0.5*(max3d*field_old(i, k, &
& j)+max3*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min4*field_old(i, k, j-1)+&
& 0.5*max3*field_old(i, k, j))
fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
& -1))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs3d = crd
abs3 = cr
ELSE
abs3d = -crd
abs3 = -cr
END IF
y3d = crd + abs3d
y3 = cr + abs3
IF (1.0 .GT. y3) THEN
min5d = y3d
min5 = y3
ELSE
min5 = 1.0
min5d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs54d = crd
abs54 = cr
ELSE
abs54d = -crd
abs54 = -cr
END IF
y54d = crd - abs54d
y54 = cr - abs54
IF (-1.0 .LT. y54) THEN
max4d = y54d
max4 = y54
ELSE
max4 = -1.0
max4d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min5*field_old(i, k, j-1)+0.5*&
& max4*field_old(i, k, j))+mu*(0.5*(min5d*field_old(i, k, j-&
& 1)+min5*field_oldd(i, k, j-1))+0.5*(max4d*field_old(i, k, &
& j)+max4*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min5*field_old(i, k, j-1)+&
& 0.5*max4*field_old(i, k, j))
fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
& ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))) + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+&
& fieldd(i, k, j-2))/12.)
fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
& -1./12.*(field(i, k, j+1)+field(i, k, j-2)))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs4d = crd
abs4 = cr
ELSE
abs4d = -crd
abs4 = -cr
END IF
y4d = crd + abs4d
y4 = cr + abs4
IF (1.0 .GT. y4) THEN
min6d = y4d
min6 = y4
ELSE
min6 = 1.0
min6d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs55d = crd
abs55 = cr
ELSE
abs55d = -crd
abs55 = -cr
END IF
y55d = crd - abs55d
y55 = cr - abs55
IF (-1.0 .LT. y55) THEN
max5d = y55d
max5 = y55
ELSE
max5 = -1.0
max5d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min6*field_old(i, k, j-1)+0.5*&
& max5*field_old(i, k, j))+mu*(0.5*(min6d*field_old(i, k, j-&
& 1)+min6*field_oldd(i, k, j-1))+0.5*(max5d*field_old(i, k, &
& j)+max5*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min6*field_old(i, k, j-1)+&
& 0.5*max5*field_old(i, k, j))
fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
& -1))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs5d = crd
abs5 = cr
ELSE
abs5d = -crd
abs5 = -cr
END IF
y5d = crd + abs5d
y5 = cr + abs5
IF (1.0 .GT. y5) THEN
min7d = y5d
min7 = y5
ELSE
min7 = 1.0
min7d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs56d = crd
abs56 = cr
ELSE
abs56d = -crd
abs56 = -cr
END IF
y56d = crd - abs56d
y56 = cr - abs56
IF (-1.0 .LT. y56) THEN
max6d = y56d
max6 = y56
ELSE
max6 = -1.0
max6d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min7*field_old(i, k, j-1)+0.5*&
& max6*field_old(i, k, j))+mu*(0.5*(min7d*field_old(i, k, j-&
& 1)+min7*field_oldd(i, k, j-1))+0.5*(max6d*field_old(i, k, &
& j)+max6*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min7*field_old(i, k, j-1)+&
& 0.5*max6*field_old(i, k, j))
fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
& ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))) + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+&
& fieldd(i, k, j-2))/12.)
fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
& -1./12.*(field(i, k, j+1)+field(i, k, j-2)))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
END IF
END DO j_loop_y_flux_6
! next, x flux
!-- these bounds are for periodic and sym conditions
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min8 = ide - 1
ELSE
min8 = ite
END IF
i_end = min8 + 1
i_start_f = i_start
i_end_f = i_end + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min9 = jde - 1
ELSE
min9 = jte
END IF
j_end = min9 + 1
!-- modify loop bounds for open and specified b.c
! IF(degrade_ys) j_start = MAX(jts-1,jds+1)
! IF(degrade_ye) j_end = MIN(jte+1,jde-2)
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds) THEN
j_start = jds
ELSE
j_start = jts - 1
END IF
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte + 1
END IF
END IF
IF (degrade_xs) THEN
IF (ids + 1 .LT. its - 1) THEN
i_start = its - 1
ELSE
i_start = ids + 1
END IF
i_start_f = ids + 3
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite + 1) THEN
i_end = ite + 1
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxld = 0.0
fqxd = 0.0
ELSE
fqxld = 0.0
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs6d = crd
abs6 = cr
ELSE
abs6d = -crd
abs6 = -cr
END IF
y6d = crd + abs6d
y6 = cr + abs6
IF (1.0 .GT. y6) THEN
min10d = y6d
min10 = y6
ELSE
min10 = 1.0
min10d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs57d = crd
abs57 = cr
ELSE
abs57d = -crd
abs57 = -cr
END IF
y57d = crd - abs57d
y57 = cr - abs57
IF (-1.0 .LT. y57) THEN
max7d = y57d
max7 = y57
ELSE
max7 = -1.0
max7d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min10*field_old(i-1, k, j)+0.5*&
& max7*field_old(i, k, j))+mu*(0.5*(min10d*field_old(i-1, k, j&
& )+min10*field_oldd(i-1, k, j))+0.5*(max7d*field_old(i, k, j)&
& +max7*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min10*field_old(i-1, k, j)+0.5&
& *max7*field_old(i, k, j))
fqxd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i-1, k, j)&
& )-2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i&
& +2, k, j)+field(i-3, k, j))) + vel*(37.*(fieldd(i, k, j)+&
& fieldd(i-1, k, j))/60.-2.*(fieldd(i+1, k, j)+fieldd(i-2, k, &
& j))/15.+(fieldd(i+2, k, j)+fieldd(i-3, k, j))/60.)
fqx(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i-1, k, j))-&
& 2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i+2&
& , k, j)+field(i-3, k, j)))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = (rud(i, k, j)*mu-ru(i, k, j)*mud)/mu**2
vel = ru(i, k, j)/mu
crd = dt*veld/dx
cr = vel*dt/dx
IF (cr .GE. 0.) THEN
abs7d = crd
abs7 = cr
ELSE
abs7d = -crd
abs7 = -cr
END IF
y7d = crd + abs7d
y7 = cr + abs7
IF (1.0 .GT. y7) THEN
min11d = y7d
min11 = y7
ELSE
min11 = 1.0
min11d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs58d = crd
abs58 = cr
ELSE
abs58d = -crd
abs58 = -cr
END IF
y58d = crd - abs58d
y58 = cr - abs58
IF (-1.0 .LT. y58) THEN
max8d = y58d
max8 = y58
ELSE
max8 = -1.0
max8d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min11*field_old(i-1, k, j)+&
& 0.5*max8*field_old(i, k, j))+mu*(0.5*(min11d*field_old(i&
& -1, k, j)+min11*field_oldd(i-1, k, j))+0.5*(max8d*&
& field_old(i, k, j)+max8*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min11*field_old(i-1, k, j)&
& +0.5*max8*field_old(i, k, j))
fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-&
& 1, k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)&
& ))
fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
& k, j))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
IF (i .EQ. ids + 2) THEN
! fourth order
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs8d = crd
abs8 = cr
ELSE
abs8d = -crd
abs8 = -cr
END IF
y8d = crd + abs8d
y8 = cr + abs8
IF (1.0 .GT. y8) THEN
min12d = y8d
min12 = y8
ELSE
min12 = 1.0
min12d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs59d = crd
abs59 = cr
ELSE
abs59d = -crd
abs59 = -cr
END IF
y59d = crd - abs59d
y59 = cr - abs59
IF (-1.0 .LT. y59) THEN
max9d = y59d
max9 = y59
ELSE
max9 = -1.0
max9d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min12*field_old(i-1, k, j)+&
& 0.5*max9*field_old(i, k, j))+mu*(0.5*(min12d*field_old(i&
& -1, k, j)+min12*field_oldd(i-1, k, j))+0.5*(max9d*&
& field_old(i, k, j)+max9*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min12*field_old(i-1, k, j)&
& +0.5*max9*field_old(i, k, j))
fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k&
& , j))-1./12.*(field(i+1, k, j)+field(i-2, k, j))) + vel*&
& (7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1&
& , k, j)+fieldd(i-2, k, j))/12.)
fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
& ))-1./12.*(field(i+1, k, j)+field(i-2, k, j)))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs9d = crd
abs9 = cr
ELSE
abs9d = -crd
abs9 = -cr
END IF
y9d = crd + abs9d
y9 = cr + abs9
IF (1.0 .GT. y9) THEN
min13d = y9d
min13 = y9
ELSE
min13 = 1.0
min13d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs60d = crd
abs60 = cr
ELSE
abs60d = -crd
abs60 = -cr
END IF
y60d = crd - abs60d
y60 = cr - abs60
IF (-1.0 .LT. y60) THEN
max10d = y60d
max10 = y60
ELSE
max10 = -1.0
max10d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min13*field_old(i-1, k, j)+&
& 0.5*max10*field_old(i, k, j))+mu*(0.5*(min13d*field_old(&
& i-1, k, j)+min13*field_oldd(i-1, k, j))+0.5*(max10d*&
& field_old(i, k, j)+max10*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min13*field_old(i-1, k, j)&
& +0.5*max10*field_old(i, k, j))
fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-&
& 1, k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)&
& ))
fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
& k, j))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
IF (i .EQ. ide - 2) THEN
! fourth order flux one in from the boundary
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs10d = crd
abs10 = cr
ELSE
abs10d = -crd
abs10 = -cr
END IF
y10d = crd + abs10d
y10 = cr + abs10
IF (1.0 .GT. y10) THEN
min14d = y10d
min14 = y10
ELSE
min14 = 1.0
min14d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs61d = crd
abs61 = cr
ELSE
abs61d = -crd
abs61 = -cr
END IF
y61d = crd - abs61d
y61 = cr - abs61
IF (-1.0 .LT. y61) THEN
max11d = y61d
max11 = y61
ELSE
max11 = -1.0
max11d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min14*field_old(i-1, k, j)+&
& 0.5*max11*field_old(i, k, j))+mu*(0.5*(min14d*field_old(&
& i-1, k, j)+min14*field_oldd(i-1, k, j))+0.5*(max11d*&
& field_old(i, k, j)+max11*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min14*field_old(i-1, k, j)&
& +0.5*max11*field_old(i, k, j))
fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k&
& , j))-1./12.*(field(i+1, k, j)+field(i-2, k, j))) + vel*&
& (7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1&
& , k, j)+fieldd(i-2, k, j))/12.)
fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
& ))-1./12.*(field(i+1, k, j)+field(i-2, k, j)))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
END DO
END IF
END DO
ELSE IF (horz_order .EQ. 5) THEN
! enddo for outer J loop
!--- end of 6th order horizontal flux calculation
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 4) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 4) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min15 = ide - 1
ELSE
min15 = ite
END IF
i_end = min15 + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min16 = jde - 1
ELSE
min16 = jte
END IF
j_end = min16 + 1
j_start_f = j_start
j_end_f = j_end + 1
!-- modify loop bounds if open or specified
! IF(degrade_xs) i_start = MAX(its-1,ids-1)
! IF(degrade_xe) i_end = MIN(ite+1,ide-2)
IF (degrade_xs) THEN
IF (its - 1 .LT. ids) THEN
i_start = ids
ELSE
i_start = its - 1
END IF
END IF
IF (degrade_xe) THEN
IF (ite + 1 .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite + 1
END IF
END IF
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts - 1
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte + 1
END IF
j_end_f = jde - 3
fqyld = 0.0
fqyd = 0.0
ELSE
fqyld = 0.0
fqyd = 0.0
END IF
! compute fluxes, 5th order
j_loop_y_flux_5:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
! use full stencil
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs11d = crd
abs11 = cr
ELSE
abs11d = -crd
abs11 = -cr
END IF
y11d = crd + abs11d
y11 = cr + abs11
IF (1.0 .GT. y11) THEN
min17d = y11d
min17 = y11
ELSE
min17 = 1.0
min17d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs62d = crd
abs62 = cr
ELSE
abs62d = -crd
abs62 = -cr
END IF
y62d = crd - abs62d
y62 = cr - abs62
IF (-1.0 .LT. y62) THEN
max12d = y62d
max12 = y62
ELSE
max12 = -1.0
max12d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min17*field_old(i, k, j-1)+0.5&
& *max12*field_old(i, k, j))+mu*(0.5*(min17d*field_old(i, k&
& , j-1)+min17*field_oldd(i, k, j-1))+0.5*(max12d*field_old(&
& i, k, j)+max12*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min17*field_old(i, k, j-1)+&
& 0.5*max12*field_old(i, k, j))
fqyd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i, k, j-&
& 1))-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(&
& field(i, k, j+2)+field(i, k, j-3))-SIGN(1, time_step)*SIGN&
& (1., vel)*(1./60.)*(field(i, k, j+2)-field(i, k, j-3)-5.*(&
& field(i, k, j+1)-field(i, k, j-2))+10.*(field(i, k, j)-&
& field(i, k, j-1)))) + vel*(37.*(fieldd(i, k, j)+fieldd(i, &
& k, j-1))/60.-2.*(fieldd(i, k, j+1)+fieldd(i, k, j-2))/15.+&
& (fieldd(i, k, j+2)+fieldd(i, k, j-3))/60.-SIGN(1, &
& time_step)*SIGN(1., vel)*(fieldd(i, k, j+2)-fieldd(i, k, j&
& -3)-5.*(fieldd(i, k, j+1)-fieldd(i, k, j-2))+10.*(fieldd(i&
& , k, j)-fieldd(i, k, j-1)))/60.)
fqy(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k, j-1)&
& )-2./15.*(field(i, k, j+1)+field(i, k, j-2))+1./60.*(field&
& (i, k, j+2)+field(i, k, j-3))-SIGN(1, time_step)*SIGN(1., &
& vel)*(1./60.)*(field(i, k, j+2)-field(i, k, j-3)-5.*(field&
& (i, k, j+1)-field(i, k, j-2))+10.*(field(i, k, j)-field(i&
& , k, j-1))))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs12d = crd
abs12 = cr
ELSE
abs12d = -crd
abs12 = -cr
END IF
y12d = crd + abs12d
y12 = cr + abs12
IF (1.0 .GT. y12) THEN
min18d = y12d
min18 = y12
ELSE
min18 = 1.0
min18d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs63d = crd
abs63 = cr
ELSE
abs63d = -crd
abs63 = -cr
END IF
y63d = crd - abs63d
y63 = cr - abs63
IF (-1.0 .LT. y63) THEN
max13d = y63d
max13 = y63
ELSE
max13 = -1.0
max13d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min18*field_old(i, k, j-1)+0.5&
& *max13*field_old(i, k, j))+mu*(0.5*(min18d*field_old(i, k&
& , j-1)+min18*field_oldd(i, k, j-1))+0.5*(max13d*field_old(&
& i, k, j)+max13*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min18*field_old(i, k, j-1)+&
& 0.5*max13*field_old(i, k, j))
fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
& -1))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs13d = crd
abs13 = cr
ELSE
abs13d = -crd
abs13 = -cr
END IF
y13d = crd + abs13d
y13 = cr + abs13
IF (1.0 .GT. y13) THEN
min19d = y13d
min19 = y13
ELSE
min19 = 1.0
min19d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs64d = crd
abs64 = cr
ELSE
abs64d = -crd
abs64 = -cr
END IF
y64d = crd - abs64d
y64 = cr - abs64
IF (-1.0 .LT. y64) THEN
max14d = y64d
max14 = y64
ELSE
max14 = -1.0
max14d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min19*field_old(i, k, j-1)+0.5&
& *max14*field_old(i, k, j))+mu*(0.5*(min19d*field_old(i, k&
& , j-1)+min19*field_oldd(i, k, j-1))+0.5*(max14d*field_old(&
& i, k, j)+max14*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min19*field_old(i, k, j-1)+&
& 0.5*max14*field_old(i, k, j))
fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
& ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
& i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) + vel*(&
& 7.*(fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j&
& +1)+fieldd(i, k, j-2))/12.+SIGN(1, time_step)*SIGN(1., vel&
& )*(fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)&
& -fieldd(i, k, j-1)))/12.)
fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
& -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
& i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1))))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs14d = crd
abs14 = cr
ELSE
abs14d = -crd
abs14 = -cr
END IF
y14d = crd + abs14d
y14 = cr + abs14
IF (1.0 .GT. y14) THEN
min20d = y14d
min20 = y14
ELSE
min20 = 1.0
min20d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs65d = crd
abs65 = cr
ELSE
abs65d = -crd
abs65 = -cr
END IF
y65d = crd - abs65d
y65 = cr - abs65
IF (-1.0 .LT. y65) THEN
max15d = y65d
max15 = y65
ELSE
max15 = -1.0
max15d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min20*field_old(i, k, j-1)+0.5&
& *max15*field_old(i, k, j))+mu*(0.5*(min20d*field_old(i, k&
& , j-1)+min20*field_oldd(i, k, j-1))+0.5*(max15d*field_old(&
& i, k, j)+max15*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min20*field_old(i, k, j-1)+&
& 0.5*max15*field_old(i, k, j))
fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
& -1))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs15d = crd
abs15 = cr
ELSE
abs15d = -crd
abs15 = -cr
END IF
y15d = crd + abs15d
y15 = cr + abs15
IF (1.0 .GT. y15) THEN
min21d = y15d
min21 = y15
ELSE
min21 = 1.0
min21d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs66d = crd
abs66 = cr
ELSE
abs66d = -crd
abs66 = -cr
END IF
y66d = crd - abs66d
y66 = cr - abs66
IF (-1.0 .LT. y66) THEN
max16d = y66d
max16 = y66
ELSE
max16 = -1.0
max16d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min21*field_old(i, k, j-1)+0.5&
& *max16*field_old(i, k, j))+mu*(0.5*(min21d*field_old(i, k&
& , j-1)+min21*field_oldd(i, k, j-1))+0.5*(max16d*field_old(&
& i, k, j)+max16*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min21*field_old(i, k, j-1)+&
& 0.5*max16*field_old(i, k, j))
fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
& ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
& i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) + vel*(&
& 7.*(fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j&
& +1)+fieldd(i, k, j-2))/12.+SIGN(1, time_step)*SIGN(1., vel&
& )*(fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)&
& -fieldd(i, k, j-1)))/12.)
fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
& -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
& i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1))))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
END IF
END DO j_loop_y_flux_5
! next, x flux
!-- these bounds are for periodic and sym conditions
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min22 = ide - 1
ELSE
min22 = ite
END IF
i_end = min22 + 1
i_start_f = i_start
i_end_f = i_end + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min23 = jde - 1
ELSE
min23 = jte
END IF
j_end = min23 + 1
!-- modify loop bounds for open and specified b.c
! IF(degrade_ys) j_start = MAX(jts-1,jds+1)
! IF(degrade_ye) j_end = MIN(jte+1,jde-2)
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds) THEN
j_start = jds
ELSE
j_start = jts - 1
END IF
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte + 1
END IF
END IF
IF (degrade_xs) THEN
IF (ids + 1 .LT. its - 1) THEN
i_start = its - 1
ELSE
i_start = ids + 1
END IF
i_start_f = ids + 3
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite + 1) THEN
i_end = ite + 1
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxld = 0.0
fqxd = 0.0
ELSE
fqxld = 0.0
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs16d = crd
abs16 = cr
ELSE
abs16d = -crd
abs16 = -cr
END IF
y16d = crd + abs16d
y16 = cr + abs16
IF (1.0 .GT. y16) THEN
min24d = y16d
min24 = y16
ELSE
min24 = 1.0
min24d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs67d = crd
abs67 = cr
ELSE
abs67d = -crd
abs67 = -cr
END IF
y67d = crd - abs67d
y67 = cr - abs67
IF (-1.0 .LT. y67) THEN
max17d = y67d
max17 = y67
ELSE
max17 = -1.0
max17d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min24*field_old(i-1, k, j)+0.5*&
& max17*field_old(i, k, j))+mu*(0.5*(min24d*field_old(i-1, k, &
& j)+min24*field_oldd(i-1, k, j))+0.5*(max17d*field_old(i, k, &
& j)+max17*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min24*field_old(i-1, k, j)+0.5&
& *max17*field_old(i, k, j))
fqxd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i-1, k, j)&
& )-2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i&
& +2, k, j)+field(i-3, k, j))-SIGN(1, time_step)*SIGN(1., vel)&
& *(1./60.)*(field(i+2, k, j)-field(i-3, k, j)-5.*(field(i+1, &
& k, j)-field(i-2, k, j))+10.*(field(i, k, j)-field(i-1, k, j)&
& ))) + vel*(37.*(fieldd(i, k, j)+fieldd(i-1, k, j))/60.-2.*(&
& fieldd(i+1, k, j)+fieldd(i-2, k, j))/15.+(fieldd(i+2, k, j)+&
& fieldd(i-3, k, j))/60.-SIGN(1, time_step)*SIGN(1., vel)*(&
& fieldd(i+2, k, j)-fieldd(i-3, k, j)-5.*(fieldd(i+1, k, j)-&
& fieldd(i-2, k, j))+10.*(fieldd(i, k, j)-fieldd(i-1, k, j)))/&
& 60.)
fqx(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i-1, k, j))-&
& 2./15.*(field(i+1, k, j)+field(i-2, k, j))+1./60.*(field(i+2&
& , k, j)+field(i-3, k, j))-SIGN(1, time_step)*SIGN(1., vel)*(&
& 1./60.)*(field(i+2, k, j)-field(i-3, k, j)-5.*(field(i+1, k&
& , j)-field(i-2, k, j))+10.*(field(i, k, j)-field(i-1, k, j))&
& ))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = (rud(i, k, j)*mu-ru(i, k, j)*mud)/mu**2
vel = ru(i, k, j)/mu
crd = dt*veld/dx
cr = vel*dt/dx
IF (cr .GE. 0.) THEN
abs17d = crd
abs17 = cr
ELSE
abs17d = -crd
abs17 = -cr
END IF
y17d = crd + abs17d
y17 = cr + abs17
IF (1.0 .GT. y17) THEN
min25d = y17d
min25 = y17
ELSE
min25 = 1.0
min25d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs68d = crd
abs68 = cr
ELSE
abs68d = -crd
abs68 = -cr
END IF
y68d = crd - abs68d
y68 = cr - abs68
IF (-1.0 .LT. y68) THEN
max18d = y68d
max18 = y68
ELSE
max18 = -1.0
max18d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min25*field_old(i-1, k, j)+&
& 0.5*max18*field_old(i, k, j))+mu*(0.5*(min25d*field_old(&
& i-1, k, j)+min25*field_oldd(i-1, k, j))+0.5*(max18d*&
& field_old(i, k, j)+max18*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min25*field_old(i-1, k, j)&
& +0.5*max18*field_old(i, k, j))
fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-&
& 1, k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)&
& ))
fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
& k, j))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
IF (i .EQ. ids + 2) THEN
! third order
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs18d = crd
abs18 = cr
ELSE
abs18d = -crd
abs18 = -cr
END IF
y18d = crd + abs18d
y18 = cr + abs18
IF (1.0 .GT. y18) THEN
min26d = y18d
min26 = y18
ELSE
min26 = 1.0
min26d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs69d = crd
abs69 = cr
ELSE
abs69d = -crd
abs69 = -cr
END IF
y69d = crd - abs69d
y69 = cr - abs69
IF (-1.0 .LT. y69) THEN
max19d = y69d
max19 = y69
ELSE
max19 = -1.0
max19d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min26*field_old(i-1, k, j)+&
& 0.5*max19*field_old(i, k, j))+mu*(0.5*(min26d*field_old(&
& i-1, k, j)+min26*field_oldd(i-1, k, j))+0.5*(max19d*&
& field_old(i, k, j)+max19*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min26*field_old(i-1, k, j)&
& +0.5*max19*field_old(i, k, j))
fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k&
& , j))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1&
& , time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-&
& field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) &
& + vel*(7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(&
& fieldd(i+1, k, j)+fieldd(i-2, k, j))/12.+SIGN(1, &
& time_step)*SIGN(1., vel)*(fieldd(i+1, k, j)-fieldd(i-2, &
& k, j)-3.*(fieldd(i, k, j)-fieldd(i-1, k, j)))/12.)
fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
& ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-&
& field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs19d = crd
abs19 = cr
ELSE
abs19d = -crd
abs19 = -cr
END IF
y19d = crd + abs19d
y19 = cr + abs19
IF (1.0 .GT. y19) THEN
min27d = y19d
min27 = y19
ELSE
min27 = 1.0
min27d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs70d = crd
abs70 = cr
ELSE
abs70d = -crd
abs70 = -cr
END IF
y70d = crd - abs70d
y70 = cr - abs70
IF (-1.0 .LT. y70) THEN
max20d = y70d
max20 = y70
ELSE
max20 = -1.0
max20d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min27*field_old(i-1, k, j)+&
& 0.5*max20*field_old(i, k, j))+mu*(0.5*(min27d*field_old(&
& i-1, k, j)+min27*field_oldd(i-1, k, j))+0.5*(max20d*&
& field_old(i, k, j)+max20*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min27*field_old(i-1, k, j)&
& +0.5*max20*field_old(i, k, j))
fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-&
& 1, k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)&
& ))
fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, &
& k, j))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
IF (i .EQ. ide - 2) THEN
! third order flux one in from the boundary
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs20d = crd
abs20 = cr
ELSE
abs20d = -crd
abs20 = -cr
END IF
y20d = crd + abs20d
y20 = cr + abs20
IF (1.0 .GT. y20) THEN
min28d = y20d
min28 = y20
ELSE
min28 = 1.0
min28d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs71d = crd
abs71 = cr
ELSE
abs71d = -crd
abs71 = -cr
END IF
y71d = crd - abs71d
y71 = cr - abs71
IF (-1.0 .LT. y71) THEN
max21d = y71d
max21 = y71
ELSE
max21 = -1.0
max21d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min28*field_old(i-1, k, j)+&
& 0.5*max21*field_old(i, k, j))+mu*(0.5*(min28d*field_old(&
& i-1, k, j)+min28*field_oldd(i-1, k, j))+0.5*(max21d*&
& field_old(i, k, j)+max21*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min28*field_old(i-1, k, j)&
& +0.5*max21*field_old(i, k, j))
fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k&
& , j))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1&
& , time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-&
& field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) &
& + vel*(7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(&
& fieldd(i+1, k, j)+fieldd(i-2, k, j))/12.+SIGN(1, &
& time_step)*SIGN(1., vel)*(fieldd(i+1, k, j)-fieldd(i-2, &
& k, j)-3.*(fieldd(i, k, j)-fieldd(i-1, k, j)))/12.)
fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j&
& ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-&
& field(i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
END DO
END IF
END DO
ELSE IF (horz_order .EQ. 4) THEN
! enddo for outer J loop
!--- end of 5th order horizontal flux calculation
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 1) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 2) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 1) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 2) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min29 = ide - 1
ELSE
min29 = ite
END IF
i_end = min29 + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min30 = jde - 1
ELSE
min30 = jte
END IF
j_end = min30 + 1
j_start_f = j_start
j_end_f = j_end + 1
!-- modify loop bounds if open or specified
IF (degrade_xs) i_start = its
IF (degrade_xe) THEN
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
END IF
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 2
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
j_end_f = jde - 2
fqyld = 0.0
fqyd = 0.0
ELSE
fqyld = 0.0
fqyd = 0.0
END IF
! compute fluxes, 4th order
j_loop_y_flux_4:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
! use full stencil
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs21d = crd
abs21 = cr
ELSE
abs21d = -crd
abs21 = -cr
END IF
y21d = crd + abs21d
y21 = cr + abs21
IF (1.0 .GT. y21) THEN
min31d = y21d
min31 = y21
ELSE
min31 = 1.0
min31d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs72d = crd
abs72 = cr
ELSE
abs72d = -crd
abs72 = -cr
END IF
y72d = crd - abs72d
y72 = cr - abs72
IF (-1.0 .LT. y72) THEN
max22d = y72d
max22 = y72
ELSE
max22 = -1.0
max22d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min31*field_old(i, k, j-1)+0.5&
& *max22*field_old(i, k, j))+mu*(0.5*(min31d*field_old(i, k&
& , j-1)+min31*field_oldd(i, k, j-1))+0.5*(max22d*field_old(&
& i, k, j)+max22*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min31*field_old(i, k, j-1)+&
& 0.5*max22*field_old(i, k, j))
fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
& ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))) + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+&
& fieldd(i, k, j-2))/12.)
fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
& -1./12.*(field(i, k, j+1)+field(i, k, j-2)))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs22d = crd
abs22 = cr
ELSE
abs22d = -crd
abs22 = -cr
END IF
y22d = crd + abs22d
y22 = cr + abs22
IF (1.0 .GT. y22) THEN
min32d = y22d
min32 = y22
ELSE
min32 = 1.0
min32d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs73d = crd
abs73 = cr
ELSE
abs73d = -crd
abs73 = -cr
END IF
y73d = crd - abs73d
y73 = cr - abs73
IF (-1.0 .LT. y73) THEN
max23d = y73d
max23 = y73
ELSE
max23 = -1.0
max23d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min32*field_old(i, k, j-1)+0.5&
& *max23*field_old(i, k, j))+mu*(0.5*(min32d*field_old(i, k&
& , j-1)+min32*field_oldd(i, k, j-1))+0.5*(max23d*field_old(&
& i, k, j)+max23*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min32*field_old(i, k, j-1)+&
& 0.5*max23*field_old(i, k, j))
fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
& -1))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs23d = crd
abs23 = cr
ELSE
abs23d = -crd
abs23 = -cr
END IF
y23d = crd + abs23d
y23 = cr + abs23
IF (1.0 .GT. y23) THEN
min33d = y23d
min33 = y23
ELSE
min33 = 1.0
min33d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs74d = crd
abs74 = cr
ELSE
abs74d = -crd
abs74 = -cr
END IF
y74d = crd - abs74d
y74 = cr - abs74
IF (-1.0 .LT. y74) THEN
max24d = y74d
max24 = y74
ELSE
max24 = -1.0
max24d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min33*field_old(i, k, j-1)+0.5&
& *max24*field_old(i, k, j))+mu*(0.5*(min33d*field_old(i, k&
& , j-1)+min33*field_oldd(i, k, j-1))+0.5*(max24d*field_old(&
& i, k, j)+max24*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min33*field_old(i, k, j-1)+&
& 0.5*max24*field_old(i, k, j))
fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
& -1))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
END IF
END DO j_loop_y_flux_4
! next, x flux
!-- these bounds are for periodic and sym conditions
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min34 = ide - 1
ELSE
min34 = ite
END IF
i_end = min34 + 1
i_start_f = i_start
i_end_f = i_end + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min35 = jde - 1
ELSE
min35 = jte
END IF
j_end = min35 + 1
!-- modify loop bounds for open and specified b.c
IF (degrade_ys) j_start = jts
IF (degrade_ye) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
i_start_f = i_start + 1
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 2
fqxld = 0.0
fqxd = 0.0
ELSE
fqxld = 0.0
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 4th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs24d = crd
abs24 = cr
ELSE
abs24d = -crd
abs24 = -cr
END IF
y24d = crd + abs24d
y24 = cr + abs24
IF (1.0 .GT. y24) THEN
min36d = y24d
min36 = y24
ELSE
min36 = 1.0
min36d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs75d = crd
abs75 = cr
ELSE
abs75d = -crd
abs75 = -cr
END IF
y75d = crd - abs75d
y75 = cr - abs75
IF (-1.0 .LT. y75) THEN
max25d = y75d
max25 = y75
ELSE
max25 = -1.0
max25d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min36*field_old(i-1, k, j)+0.5*&
& max25*field_old(i, k, j))+mu*(0.5*(min36d*field_old(i-1, k, &
& j)+min36*field_oldd(i-1, k, j))+0.5*(max25d*field_old(i, k, &
& j)+max25*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min36*field_old(i-1, k, j)+0.5&
& *max25*field_old(i, k, j))
fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j))&
& -1./12.*(field(i+1, k, j)+field(i-2, k, j))) + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k, j)+&
& fieldd(i-2, k, j))/12.)
fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-&
& 1./12.*(field(i+1, k, j)+field(i-2, k, j)))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
IF (i_start .EQ. ids + 1) THEN
! second order flux next to the boundary
i = ids + 1
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = (rud(i, k, j)*mu-ru(i, k, j)*mud)/mu**2
vel = ru(i, k, j)/mu
crd = dt*veld/dx
cr = vel*dt/dx
IF (cr .GE. 0.) THEN
abs25d = crd
abs25 = cr
ELSE
abs25d = -crd
abs25 = -cr
END IF
y25d = crd + abs25d
y25 = cr + abs25
IF (1.0 .GT. y25) THEN
min37d = y25d
min37 = y25
ELSE
min37 = 1.0
min37d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs76d = crd
abs76 = cr
ELSE
abs76d = -crd
abs76 = -cr
END IF
y76d = crd - abs76d
y76 = cr - abs76
IF (-1.0 .LT. y76) THEN
max26d = y76d
max26 = y76
ELSE
max26 = -1.0
max26d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min37*field_old(i-1, k, j)+0.5&
& *max26*field_old(i, k, j))+mu*(0.5*(min37d*field_old(i-1, &
& k, j)+min37*field_oldd(i-1, k, j))+0.5*(max26d*field_old(i&
& , k, j)+max26*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min37*field_old(i-1, k, j)+&
& 0.5*max26*field_old(i, k, j))
fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
& , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
& , j))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
END IF
IF (degrade_xe) THEN
IF (i_end .EQ. ide - 2) THEN
! second order flux next to the boundary
i = ide - 1
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs26d = crd
abs26 = cr
ELSE
abs26d = -crd
abs26 = -cr
END IF
y26d = crd + abs26d
y26 = cr + abs26
IF (1.0 .GT. y26) THEN
min38d = y26d
min38 = y26
ELSE
min38 = 1.0
min38d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs77d = crd
abs77 = cr
ELSE
abs77d = -crd
abs77 = -cr
END IF
y77d = crd - abs77d
y77 = cr - abs77
IF (-1.0 .LT. y77) THEN
max27d = y77d
max27 = y77
ELSE
max27 = -1.0
max27d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min38*field_old(i-1, k, j)+0.5&
& *max27*field_old(i, k, j))+mu*(0.5*(min38d*field_old(i-1, &
& k, j)+min38*field_oldd(i-1, k, j))+0.5*(max27d*field_old(i&
& , k, j)+max27*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min38*field_old(i-1, k, j)+&
& 0.5*max27*field_old(i, k, j))
fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
& , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
& , j))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
END IF
END DO
ELSE IF (horz_order .EQ. 3) THEN
! enddo for outer J loop
!--- end of 4th order horizontal flux calculation
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 2) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 1) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 2) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 1) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min39 = ide - 1
ELSE
min39 = ite
END IF
i_end = min39 + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min40 = jde - 1
ELSE
min40 = jte
END IF
j_end = min40 + 1
j_start_f = j_start
j_end_f = j_end + 1
!-- modify loop bounds if open or specified
IF (degrade_xs) i_start = its
IF (degrade_xe) THEN
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
END IF
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 2
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
j_end_f = jde - 2
fqyld = 0.0
fqyd = 0.0
ELSE
fqyld = 0.0
fqyd = 0.0
END IF
! compute fluxes, 3rd order
j_loop_y_flux_3:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
! use full stencil
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs27d = crd
abs27 = cr
ELSE
abs27d = -crd
abs27 = -cr
END IF
y27d = crd + abs27d
y27 = cr + abs27
IF (1.0 .GT. y27) THEN
min41d = y27d
min41 = y27
ELSE
min41 = 1.0
min41d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs78d = crd
abs78 = cr
ELSE
abs78d = -crd
abs78 = -cr
END IF
y78d = crd - abs78d
y78 = cr - abs78
IF (-1.0 .LT. y78) THEN
max28d = y78d
max28 = y78
ELSE
max28 = -1.0
max28d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min41*field_old(i, k, j-1)+0.5&
& *max28*field_old(i, k, j))+mu*(0.5*(min41d*field_old(i, k&
& , j-1)+min41*field_oldd(i, k, j-1))+0.5*(max28d*field_old(&
& i, k, j)+max28*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min41*field_old(i, k, j-1)+&
& 0.5*max28*field_old(i, k, j))
fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1&
& ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
& i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) + vel*(&
& 7.*(fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j&
& +1)+fieldd(i, k, j-2))/12.+SIGN(1, time_step)*SIGN(1., vel&
& )*(fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)&
& -fieldd(i, k, j-1)))/12.)
fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))&
& -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(&
& i, k, j-2)-3.*(field(i, k, j)-field(i, k, j-1))))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs28d = crd
abs28 = cr
ELSE
abs28d = -crd
abs28 = -cr
END IF
y28d = crd + abs28d
y28 = cr + abs28
IF (1.0 .GT. y28) THEN
min42d = y28d
min42 = y28
ELSE
min42 = 1.0
min42d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs79d = crd
abs79 = cr
ELSE
abs79d = -crd
abs79 = -cr
END IF
y79d = crd - abs79d
y79 = cr - abs79
IF (-1.0 .LT. y79) THEN
max29d = y79d
max29 = y79
ELSE
max29 = -1.0
max29d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min42*field_old(i, k, j-1)+0.5&
& *max29*field_old(i, k, j))+mu*(0.5*(min42d*field_old(i, k&
& , j-1)+min42*field_oldd(i, k, j-1))+0.5*(max29d*field_old(&
& i, k, j)+max29*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min42*field_old(i, k, j-1)+&
& 0.5*max29*field_old(i, k, j))
fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
& -1))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs29d = crd
abs29 = cr
ELSE
abs29d = -crd
abs29 = -cr
END IF
y29d = crd + abs29d
y29 = cr + abs29
IF (1.0 .GT. y29) THEN
min43d = y29d
min43 = y29
ELSE
min43 = 1.0
min43d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs80d = crd
abs80 = cr
ELSE
abs80d = -crd
abs80 = -cr
END IF
y80d = crd - abs80d
y80 = cr - abs80
IF (-1.0 .LT. y80) THEN
max30d = y80d
max30 = y80
ELSE
max30 = -1.0
max30d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min43*field_old(i, k, j-1)+0.5&
& *max30*field_old(i, k, j))+mu*(0.5*(min43d*field_old(i, k&
& , j-1)+min43*field_oldd(i, k, j-1))+0.5*(max30d*field_old(&
& i, k, j)+max30*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min43*field_old(i, k, j-1)+&
& 0.5*max30*field_old(i, k, j))
fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j&
& -1))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
END IF
END DO j_loop_y_flux_3
! next, x flux
!-- these bounds are for periodic and sym conditions
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min44 = ide - 1
ELSE
min44 = ite
END IF
i_end = min44 + 1
i_start_f = i_start
i_end_f = i_end + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min45 = jde - 1
ELSE
min45 = jte
END IF
j_end = min45 + 1
!-- modify loop bounds for open and specified b.c
IF (degrade_ys) j_start = jts
IF (degrade_ye) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
i_start_f = i_start + 1
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 2
fqxld = 0.0
fqxd = 0.0
ELSE
fqxld = 0.0
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 4th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs30d = crd
abs30 = cr
ELSE
abs30d = -crd
abs30 = -cr
END IF
y30d = crd + abs30d
y30 = cr + abs30
IF (1.0 .GT. y30) THEN
min46d = y30d
min46 = y30
ELSE
min46 = 1.0
min46d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs81d = crd
abs81 = cr
ELSE
abs81d = -crd
abs81 = -cr
END IF
y81d = crd - abs81d
y81 = cr - abs81
IF (-1.0 .LT. y81) THEN
max31d = y81d
max31 = y81
ELSE
max31 = -1.0
max31d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min46*field_old(i-1, k, j)+0.5*&
& max31*field_old(i, k, j))+mu*(0.5*(min46d*field_old(i-1, k, &
& j)+min46*field_oldd(i-1, k, j))+0.5*(max31d*field_old(i, k, &
& j)+max31*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min46*field_old(i-1, k, j)+0.5&
& *max31*field_old(i, k, j))
fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j))&
& -1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(i-&
& 2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k, j)+&
& fieldd(i-2, k, j))/12.+SIGN(1, time_step)*SIGN(1., vel)*(&
& fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i, k, j)-&
& fieldd(i-1, k, j)))/12.)
fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-&
& 1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, time_step&
& )*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-&
& 3.*(field(i, k, j)-field(i-1, k, j))))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
IF (i_start .EQ. ids + 1) THEN
! second order flux next to the boundary
i = ids + 1
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = (rud(i, k, j)*mu-ru(i, k, j)*mud)/mu**2
vel = ru(i, k, j)/mu
crd = dt*veld/dx
cr = vel*dt/dx
IF (cr .GE. 0.) THEN
abs31d = crd
abs31 = cr
ELSE
abs31d = -crd
abs31 = -cr
END IF
y31d = crd + abs31d
y31 = cr + abs31
IF (1.0 .GT. y31) THEN
min47d = y31d
min47 = y31
ELSE
min47 = 1.0
min47d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs82d = crd
abs82 = cr
ELSE
abs82d = -crd
abs82 = -cr
END IF
y82d = crd - abs82d
y82 = cr - abs82
IF (-1.0 .LT. y82) THEN
max32d = y82d
max32 = y82
ELSE
max32 = -1.0
max32d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min47*field_old(i-1, k, j)+0.5&
& *max32*field_old(i, k, j))+mu*(0.5*(min47d*field_old(i-1, &
& k, j)+min47*field_oldd(i-1, k, j))+0.5*(max32d*field_old(i&
& , k, j)+max32*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min47*field_old(i-1, k, j)+&
& 0.5*max32*field_old(i, k, j))
fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
& , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
& , j))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
END IF
IF (degrade_xe) THEN
IF (i_end .EQ. ide - 2) THEN
! second order flux next to the boundary
i = ide - 1
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs32d = crd
abs32 = cr
ELSE
abs32d = -crd
abs32 = -cr
END IF
y32d = crd + abs32d
y32 = cr + abs32
IF (1.0 .GT. y32) THEN
min48d = y32d
min48 = y32
ELSE
min48 = 1.0
min48d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs83d = crd
abs83 = cr
ELSE
abs83d = -crd
abs83 = -cr
END IF
y83d = crd - abs83d
y83 = cr - abs83
IF (-1.0 .LT. y83) THEN
max33d = y83d
max33 = y83
ELSE
max33 = -1.0
max33d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min48*field_old(i-1, k, j)+0.5&
& *max33*field_old(i, k, j))+mu*(0.5*(min48d*field_old(i-1, &
& k, j)+min48*field_oldd(i-1, k, j))+0.5*(max33d*field_old(i&
& , k, j)+max33*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min48*field_old(i-1, k, j)+&
& 0.5*max33*field_old(i, k, j))
fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
& , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
& , j))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
END IF
END DO
ELSE IF (horz_order .EQ. 2) THEN
! enddo for outer J loop
!--- end of 3rd order horizontal flux calculation
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 1) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 2) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 1) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 2) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min49 = ide - 1
ELSE
min49 = ite
END IF
i_end = min49 + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min50 = jde - 1
ELSE
min50 = jte
END IF
j_end = min50 + 1
!-- modify loop bounds if open or specified
IF (degrade_xs) i_start = its
IF (degrade_xe) THEN
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
END IF
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
fqyld = 0.0
fqyd = 0.0
ELSE
fqyld = 0.0
fqyd = 0.0
END IF
! compute fluxes, 2nd order, y flux
DO j=j_start,j_end+1
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs33d = crd
abs33 = cr
ELSE
abs33d = -crd
abs33 = -cr
END IF
y33d = crd + abs33d
y33 = cr + abs33
IF (1.0 .GT. y33) THEN
min51d = y33d
min51 = y33
ELSE
min51 = 1.0
min51d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs84d = crd
abs84 = cr
ELSE
abs84d = -crd
abs84 = -cr
END IF
y84d = crd - abs84d
y84 = cr - abs84
IF (-1.0 .LT. y84) THEN
max34d = y84d
max34 = y84
ELSE
max34 = -1.0
max34d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min51*field_old(i, k, j-1)+0.5*&
& max34*field_old(i, k, j))+mu*(0.5*(min51d*field_old(i, k, j-&
& 1)+min51*field_oldd(i, k, j-1))+0.5*(max34d*field_old(i, k, &
& j)+max34*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min51*field_old(i, k, j-1)+0.5&
& *max34*field_old(i, k, j))
fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k, &
& j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1&
& ))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
END DO
fqxld = 0.0
fqxd = 0.0
! next, x flux
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end+1
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs34d = crd
abs34 = cr
ELSE
abs34d = -crd
abs34 = -cr
END IF
y34d = crd + abs34d
y34 = cr + abs34
IF (1.0 .GT. y34) THEN
min52d = y34d
min52 = y34
ELSE
min52 = 1.0
min52d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs85d = crd
abs85 = cr
ELSE
abs85d = -crd
abs85 = -cr
END IF
y85d = crd - abs85d
y85 = cr - abs85
IF (-1.0 .LT. y85) THEN
max35d = y85d
max35 = y85
ELSE
max35 = -1.0
max35d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min52*field_old(i-1, k, j)+0.5*&
& max35*field_old(i, k, j))+mu*(0.5*(min52d*field_old(i-1, k, &
& j)+min52*field_oldd(i-1, k, j))+0.5*(max35d*field_old(i, k, &
& j)+max35*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min52*field_old(i-1, k, j)+0.5&
& *max35*field_old(i, k, j))
fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, k&
& , j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, j&
& ))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END DO
END DO
ELSE
!--- end of 2nd order horizontal flux calculation
WRITE(wrf_err_message, *) &
& 'module_advect: advect_scalar_pd, h_order not known ', horz_order
CALL WRF_ERROR_FATAL(TRIM(wrf_err_message))
fqxld = 0.0
fqyld = 0.0
fqxd = 0.0
fqyd = 0.0
END IF
! pick up the rest of the horizontal radiation boundary conditions.
! (these are the computations that don't require 'cb'.
! first, set to index ranges
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! compute x (u) conditions for v, w, or scalar
IF (config_flags%open_xs .AND. its .EQ. ids) THEN
DO j=j_start,j_end
DO k=kts,ktf
IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = 0.5*(rud(its, k, j)+rud(its+1, k, j))
ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
END IF
tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(&
& field_old(its+1, k, j)-field_old(its, k, j))+ub*(field_oldd(&
& its+1, k, j)-field_oldd(its, k, j))+fieldd(its, k, j)*(ru(its+&
& 1, k, j)-ru(its, k, j))+field(its, k, j)*(rud(its+1, k, j)-rud&
& (its, k, j)))
tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(field_old(&
& its+1, k, j)-field_old(its, k, j))+field(its, k, j)*(ru(its+1&
& , k, j)-ru(its, k, j)))
END DO
END DO
END IF
IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
DO j=j_start,j_end
DO k=kts,ktf
IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = 0.5*(rud(ite-1, k, j)+rud(ite, k, j))
ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
END IF
tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
& field_old(i_end, k, j)-field_old(i_end-1, k, j))+ub*(&
& field_oldd(i_end, k, j)-field_oldd(i_end-1, k, j))+fieldd(&
& i_end, k, j)*(ru(ite, k, j)-ru(ite-1, k, j))+field(i_end, k, j&
& )*(rud(ite, k, j)-rud(ite-1, k, j)))
tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(&
& field_old(i_end, k, j)-field_old(i_end-1, k, j))+field(i_end, &
& k, j)*(ru(ite, k, j)-ru(ite-1, k, j)))
END DO
END DO
END IF
IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*(rvd(i, k, jts)+rvd(i, k, jts+1))
vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
& field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
& , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*(rv(i, k&
& , jts+1)-rv(i, k, jts))+field(i, k, jts)*(rvd(i, k, jts+1)-rvd&
& (i, k, jts)))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
& , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*(rv(i, k, &
& jts+1)-rv(i, k, jts)))
END DO
END DO
END IF
IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*(rvd(i, k, jte-1)+rvd(i, k, jte))
vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
END IF
tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
& field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))+fieldd(i, k&
& , j_end)*(rv(i, k, jte)-rv(i, k, jte-1))+field(i, k, j_end)*(&
& rvd(i, k, jte)-rvd(i, k, jte-1)))
tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
& j_end)*(rv(i, k, jte)-rv(i, k, jte-1)))
END DO
END DO
END IF
IF (config_flags%polar .AND. jts .EQ. jds) THEN
! Assuming rv(i,k,jds) = 0.
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*rv(i, k, jts+1) .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*rvd(i, k, jts+1)
vb = 0.5*rv(i, k, jts+1)
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
& field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
& , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*rv(i, k, &
& jts+1)+field(i, k, jts)*rvd(i, k, jts+1))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
& , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*rv(i, k, &
& jts+1))
END DO
END DO
END IF
IF (config_flags%polar .AND. jte .EQ. jde) THEN
! Assuming rv(i,k,jde) = 0.
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*rv(i, k, jte-1) .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*rvd(i, k, jte-1)
vb = 0.5*rv(i, k, jte-1)
END IF
tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
& field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))-fieldd(i, k&
& , j_end)*rv(i, k, jte-1)-field(i, k, j_end)*rvd(i, k, jte-1))
tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
& j_end)*(-rv(i, k, jte-1)))
END DO
END DO
END IF
!-------------------- vertical advection
!-- loop bounds for periodic or sym conditions
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min53 = ide - 1
ELSE
min53 = ite
END IF
i_end = min53 + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min54 = jde - 1
ELSE
min54 = jte
END IF
j_end = min54 + 1
!-- loop bounds for open or specified conditions
IF (degrade_xs) THEN
IF (its - 1 .LT. ids) THEN
i_start = ids
ELSE
i_start = its - 1
END IF
END IF
IF (degrade_xe) THEN
IF (ite + 1 .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite + 1
END IF
END IF
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds) THEN
j_start = jds
ELSE
j_start = jts - 1
END IF
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte + 1
END IF
END IF
IF (vert_order .EQ. 6) THEN
fqzd = 0.0
fqzld = 0.0
DO j=j_start,j_end
DO i=i_start,i_end
fqzd(i, 1, j) = 0.0
fqz(i, 1, j) = 0.
fqzld(i, 1, j) = 0.0
fqzl(i, 1, j) = 0.
fqzd(i, kde, j) = 0.0
fqz(i, kde, j) = 0.
fqzld(i, kde, j) = 0.0
fqzl(i, kde, j) = 0.
END DO
DO k=kts+3,ktf-2
DO i=i_start,i_end
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs35d = crd
abs35 = cr
ELSE
abs35d = -crd
abs35 = -cr
END IF
y35d = crd + abs35d
y35 = cr + abs35
IF (1.0 .GT. y35) THEN
min55d = y35d
min55 = y35
ELSE
min55 = 1.0
min55d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs86d = crd
abs86 = cr
ELSE
abs86d = -crd
abs86 = -cr
END IF
y86d = crd - abs86d
y86 = cr - abs86
IF (-1.0 .LT. y86) THEN
max36d = y86d
max36 = y86
ELSE
max36 = -1.0
max36d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min55*field_old(i, k-1, j)+0.5*&
& max36*field_old(i, k, j))+mu*(0.5*(min55d*field_old(i, k-1, &
& j)+min55*field_oldd(i, k-1, j))+0.5*(max36d*field_old(i, k, &
& j)+max36*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min55*field_old(i, k-1, j)+0.5&
& *max36*field_old(i, k, j))
fqzd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i, k-1, j)&
& )-2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i&
& , k+2, j)+field(i, k-3, j))) + vel*(37.*(fieldd(i, k, j)+&
& fieldd(i, k-1, j))/60.-2.*(fieldd(i, k+1, j)+fieldd(i, k-2, &
& j))/15.+(fieldd(i, k+2, j)+fieldd(i, k-3, j))/60.)
fqz(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k-1, j))-&
& 2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i, &
& k+2, j)+field(i, k-3, j)))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs36d = crd
abs36 = cr
ELSE
abs36d = -crd
abs36 = -cr
END IF
y36d = crd + abs36d
y36 = cr + abs36
IF (1.0 .GT. y36) THEN
min56d = y36d
min56 = y36
ELSE
min56 = 1.0
min56d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs87d = crd
abs87 = cr
ELSE
abs87d = -crd
abs87 = -cr
END IF
y87d = crd - abs87d
y87 = cr - abs87
IF (-1.0 .LT. y87) THEN
max37d = y87d
max37 = y87
ELSE
max37 = -1.0
max37d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min56*field_old(i, k-1, j)+0.5*&
& max37*field_old(i, k, j))+mu*(0.5*(min56d*field_old(i, k-1, j)&
& +min56*field_oldd(i, k-1, j))+0.5*(max37d*field_old(i, k, j)+&
& max37*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min56*field_old(i, k-1, j)+0.5*&
& max37*field_old(i, k, j))
fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
& field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
& )*fieldd(i, k-1, j))
fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
& i, k-1, j))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
k = kts + 2
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs37d = crd
abs37 = cr
ELSE
abs37d = -crd
abs37 = -cr
END IF
y37d = crd + abs37d
y37 = cr + abs37
IF (1.0 .GT. y37) THEN
min57d = y37d
min57 = y37
ELSE
min57 = 1.0
min57d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs88d = crd
abs88 = cr
ELSE
abs88d = -crd
abs88 = -cr
END IF
y88d = crd - abs88d
y88 = cr - abs88
IF (-1.0 .LT. y88) THEN
max38d = y88d
max38 = y88
ELSE
max38 = -1.0
max38d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min57*field_old(i, k-1, j)+0.5*&
& max38*field_old(i, k, j))+mu*(0.5*(min57d*field_old(i, k-1, j)&
& +min57*field_oldd(i, k-1, j))+0.5*(max38d*field_old(i, k, j)+&
& max38*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min57*field_old(i, k-1, j)+0.5*&
& max38*field_old(i, k, j))
fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
& 1./12.*(field(i, k+1, j)+field(i, k-2, j))) + vel*(7.*(fieldd(&
& i, k, j)+fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k&
& -2, j))/12.)
fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
& 12.*(field(i, k+1, j)+field(i, k-2, j)))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
k = ktf - 1
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs38d = crd
abs38 = cr
ELSE
abs38d = -crd
abs38 = -cr
END IF
y38d = crd + abs38d
y38 = cr + abs38
IF (1.0 .GT. y38) THEN
min58d = y38d
min58 = y38
ELSE
min58 = 1.0
min58d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs89d = crd
abs89 = cr
ELSE
abs89d = -crd
abs89 = -cr
END IF
y89d = crd - abs89d
y89 = cr - abs89
IF (-1.0 .LT. y89) THEN
max39d = y89d
max39 = y89
ELSE
max39 = -1.0
max39d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min58*field_old(i, k-1, j)+0.5*&
& max39*field_old(i, k, j))+mu*(0.5*(min58d*field_old(i, k-1, j)&
& +min58*field_oldd(i, k-1, j))+0.5*(max39d*field_old(i, k, j)+&
& max39*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min58*field_old(i, k-1, j)+0.5*&
& max39*field_old(i, k, j))
fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
& 1./12.*(field(i, k+1, j)+field(i, k-2, j))) + vel*(7.*(fieldd(&
& i, k, j)+fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k&
& -2, j))/12.)
fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
& 12.*(field(i, k+1, j)+field(i, k-2, j)))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
k = ktf
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs39d = crd
abs39 = cr
ELSE
abs39d = -crd
abs39 = -cr
END IF
y39d = crd + abs39d
y39 = cr + abs39
IF (1.0 .GT. y39) THEN
min59d = y39d
min59 = y39
ELSE
min59 = 1.0
min59d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs90d = crd
abs90 = cr
ELSE
abs90d = -crd
abs90 = -cr
END IF
y90d = crd - abs90d
y90 = cr - abs90
IF (-1.0 .LT. y90) THEN
max40d = y90d
max40 = y90
ELSE
max40 = -1.0
max40d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min59*field_old(i, k-1, j)+0.5*&
& max40*field_old(i, k, j))+mu*(0.5*(min59d*field_old(i, k-1, j)&
& +min59*field_oldd(i, k-1, j))+0.5*(max40d*field_old(i, k, j)+&
& max40*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min59*field_old(i, k-1, j)+0.5*&
& max40*field_old(i, k, j))
fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
& field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
& )*fieldd(i, k-1, j))
fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
& i, k-1, j))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
END DO
END DO
ELSE IF (vert_order .EQ. 5) THEN
fqzd = 0.0
fqzld = 0.0
DO j=j_start,j_end
DO i=i_start,i_end
fqzd(i, 1, j) = 0.0
fqz(i, 1, j) = 0.
fqzld(i, 1, j) = 0.0
fqzl(i, 1, j) = 0.
fqzd(i, kde, j) = 0.0
fqz(i, kde, j) = 0.
fqzld(i, kde, j) = 0.0
fqzl(i, kde, j) = 0.
END DO
DO k=kts+3,ktf-2
DO i=i_start,i_end
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs40d = crd
abs40 = cr
ELSE
abs40d = -crd
abs40 = -cr
END IF
y40d = crd + abs40d
y40 = cr + abs40
IF (1.0 .GT. y40) THEN
min60d = y40d
min60 = y40
ELSE
min60 = 1.0
min60d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs91d = crd
abs91 = cr
ELSE
abs91d = -crd
abs91 = -cr
END IF
y91d = crd - abs91d
y91 = cr - abs91
IF (-1.0 .LT. y91) THEN
max41d = y91d
max41 = y91
ELSE
max41 = -1.0
max41d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min60*field_old(i, k-1, j)+0.5*&
& max41*field_old(i, k, j))+mu*(0.5*(min60d*field_old(i, k-1, &
& j)+min60*field_oldd(i, k-1, j))+0.5*(max41d*field_old(i, k, &
& j)+max41*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min60*field_old(i, k-1, j)+0.5&
& *max41*field_old(i, k, j))
fqzd(i, k, j) = veld*(37./60.*(field(i, k, j)+field(i, k-1, j)&
& )-2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i&
& , k+2, j)+field(i, k-3, j))-SIGN(1, time_step)*SIGN(1., -vel&
& )*(1./60.)*(field(i, k+2, j)-field(i, k-3, j)-5.*(field(i, k&
& +1, j)-field(i, k-2, j))+10.*(field(i, k, j)-field(i, k-1, j&
& )))) + vel*(37.*(fieldd(i, k, j)+fieldd(i, k-1, j))/60.-2.*(&
& fieldd(i, k+1, j)+fieldd(i, k-2, j))/15.+(fieldd(i, k+2, j)+&
& fieldd(i, k-3, j))/60.-SIGN(1, time_step)*SIGN(1., -vel)*(&
& fieldd(i, k+2, j)-fieldd(i, k-3, j)-5.*(fieldd(i, k+1, j)-&
& fieldd(i, k-2, j))+10.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/&
& 60.)
fqz(i, k, j) = vel*(37./60.*(field(i, k, j)+field(i, k-1, j))-&
& 2./15.*(field(i, k+1, j)+field(i, k-2, j))+1./60.*(field(i, &
& k+2, j)+field(i, k-3, j))-SIGN(1, time_step)*SIGN(1., -vel)*&
& (1./60.)*(field(i, k+2, j)-field(i, k-3, j)-5.*(field(i, k+1&
& , j)-field(i, k-2, j))+10.*(field(i, k, j)-field(i, k-1, j))&
& ))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs41d = crd
abs41 = cr
ELSE
abs41d = -crd
abs41 = -cr
END IF
y41d = crd + abs41d
y41 = cr + abs41
IF (1.0 .GT. y41) THEN
min61d = y41d
min61 = y41
ELSE
min61 = 1.0
min61d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs92d = crd
abs92 = cr
ELSE
abs92d = -crd
abs92 = -cr
END IF
y92d = crd - abs92d
y92 = cr - abs92
IF (-1.0 .LT. y92) THEN
max42d = y92d
max42 = y92
ELSE
max42 = -1.0
max42d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min61*field_old(i, k-1, j)+0.5*&
& max42*field_old(i, k, j))+mu*(0.5*(min61d*field_old(i, k-1, j)&
& +min61*field_oldd(i, k-1, j))+0.5*(max42d*field_old(i, k, j)+&
& max42*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min61*field_old(i, k-1, j)+0.5*&
& max42*field_old(i, k, j))
fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
& field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
& )*fieldd(i, k-1, j))
fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
& i, k-1, j))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
k = kts + 2
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs42d = crd
abs42 = cr
ELSE
abs42d = -crd
abs42 = -cr
END IF
y42d = crd + abs42d
y42 = cr + abs42
IF (1.0 .GT. y42) THEN
min62d = y42d
min62 = y42
ELSE
min62 = 1.0
min62d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs93d = crd
abs93 = cr
ELSE
abs93d = -crd
abs93 = -cr
END IF
y93d = crd - abs93d
y93 = cr - abs93
IF (-1.0 .LT. y93) THEN
max43d = y93d
max43 = y93
ELSE
max43 = -1.0
max43d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min62*field_old(i, k-1, j)+0.5*&
& max43*field_old(i, k, j))+mu*(0.5*(min62d*field_old(i, k-1, j)&
& +min62*field_oldd(i, k-1, j))+0.5*(max43d*field_old(i, k, j)+&
& max43*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min62*field_old(i, k-1, j)+0.5*&
& max43*field_old(i, k, j))
fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
& 1./12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*&
& SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*&
& (field(i, k, j)-field(i, k-1, j)))) + vel*(7.*(fieldd(i, k, j)&
& +fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k-2, j))/&
& 12.+SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-&
& fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.)
fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
& 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*&
& SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*&
& (field(i, k, j)-field(i, k-1, j))))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
k = ktf - 1
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs43d = crd
abs43 = cr
ELSE
abs43d = -crd
abs43 = -cr
END IF
y43d = crd + abs43d
y43 = cr + abs43
IF (1.0 .GT. y43) THEN
min63d = y43d
min63 = y43
ELSE
min63 = 1.0
min63d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs94d = crd
abs94 = cr
ELSE
abs94d = -crd
abs94 = -cr
END IF
y94d = crd - abs94d
y94 = cr - abs94
IF (-1.0 .LT. y94) THEN
max44d = y94d
max44 = y94
ELSE
max44 = -1.0
max44d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min63*field_old(i, k-1, j)+0.5*&
& max44*field_old(i, k, j))+mu*(0.5*(min63d*field_old(i, k-1, j)&
& +min63*field_oldd(i, k-1, j))+0.5*(max44d*field_old(i, k, j)+&
& max44*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min63*field_old(i, k-1, j)+0.5*&
& max44*field_old(i, k, j))
fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
& 1./12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*&
& SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*&
& (field(i, k, j)-field(i, k-1, j)))) + vel*(7.*(fieldd(i, k, j)&
& +fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k-2, j))/&
& 12.+SIGN(1, time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-&
& fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.)
fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
& 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*&
& SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*&
& (field(i, k, j)-field(i, k-1, j))))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
k = ktf
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs44d = crd
abs44 = cr
ELSE
abs44d = -crd
abs44 = -cr
END IF
y44d = crd + abs44d
y44 = cr + abs44
IF (1.0 .GT. y44) THEN
min64d = y44d
min64 = y44
ELSE
min64 = 1.0
min64d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs95d = crd
abs95 = cr
ELSE
abs95d = -crd
abs95 = -cr
END IF
y95d = crd - abs95d
y95 = cr - abs95
IF (-1.0 .LT. y95) THEN
max45d = y95d
max45 = y95
ELSE
max45 = -1.0
max45d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min64*field_old(i, k-1, j)+0.5*&
& max45*field_old(i, k, j))+mu*(0.5*(min64d*field_old(i, k-1, j)&
& +min64*field_oldd(i, k-1, j))+0.5*(max45d*field_old(i, k, j)+&
& max45*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min64*field_old(i, k-1, j)+0.5*&
& max45*field_old(i, k, j))
fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
& field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
& )*fieldd(i, k-1, j))
fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
& i, k-1, j))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
END DO
END DO
ELSE IF (vert_order .EQ. 4) THEN
fqzd = 0.0
fqzld = 0.0
DO j=j_start,j_end
DO i=i_start,i_end
fqzd(i, 1, j) = 0.0
fqz(i, 1, j) = 0.
fqzld(i, 1, j) = 0.0
fqzl(i, 1, j) = 0.
fqzd(i, kde, j) = 0.0
fqz(i, kde, j) = 0.
fqzld(i, kde, j) = 0.0
fqzl(i, kde, j) = 0.
END DO
DO k=kts+2,ktf-1
DO i=i_start,i_end
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs45d = crd
abs45 = cr
ELSE
abs45d = -crd
abs45 = -cr
END IF
y45d = crd + abs45d
y45 = cr + abs45
IF (1.0 .GT. y45) THEN
min65d = y45d
min65 = y45
ELSE
min65 = 1.0
min65d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs96d = crd
abs96 = cr
ELSE
abs96d = -crd
abs96 = -cr
END IF
y96d = crd - abs96d
y96 = cr - abs96
IF (-1.0 .LT. y96) THEN
max46d = y96d
max46 = y96
ELSE
max46 = -1.0
max46d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min65*field_old(i, k-1, j)+0.5*&
& max46*field_old(i, k, j))+mu*(0.5*(min65d*field_old(i, k-1, &
& j)+min65*field_oldd(i, k-1, j))+0.5*(max46d*field_old(i, k, &
& j)+max46*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min65*field_old(i, k-1, j)+0.5&
& *max46*field_old(i, k, j))
fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))&
& -1./12.*(field(i, k+1, j)+field(i, k-2, j))) + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+&
& fieldd(i, k-2, j))/12.)
fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
& 1./12.*(field(i, k+1, j)+field(i, k-2, j)))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs46d = crd
abs46 = cr
ELSE
abs46d = -crd
abs46 = -cr
END IF
y46d = crd + abs46d
y46 = cr + abs46
IF (1.0 .GT. y46) THEN
min66d = y46d
min66 = y46
ELSE
min66 = 1.0
min66d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs97d = crd
abs97 = cr
ELSE
abs97d = -crd
abs97 = -cr
END IF
y97d = crd - abs97d
y97 = cr - abs97
IF (-1.0 .LT. y97) THEN
max47d = y97d
max47 = y97
ELSE
max47 = -1.0
max47d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min66*field_old(i, k-1, j)+0.5*&
& max47*field_old(i, k, j))+mu*(0.5*(min66d*field_old(i, k-1, j)&
& +min66*field_oldd(i, k-1, j))+0.5*(max47d*field_old(i, k, j)+&
& max47*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min66*field_old(i, k-1, j)+0.5*&
& max47*field_old(i, k, j))
fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
& field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
& )*fieldd(i, k-1, j))
fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
& i, k-1, j))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
k = ktf
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs47d = crd
abs47 = cr
ELSE
abs47d = -crd
abs47 = -cr
END IF
y47d = crd + abs47d
y47 = cr + abs47
IF (1.0 .GT. y47) THEN
min67d = y47d
min67 = y47
ELSE
min67 = 1.0
min67d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs98d = crd
abs98 = cr
ELSE
abs98d = -crd
abs98 = -cr
END IF
y98d = crd - abs98d
y98 = cr - abs98
IF (-1.0 .LT. y98) THEN
max48d = y98d
max48 = y98
ELSE
max48 = -1.0
max48d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min67*field_old(i, k-1, j)+0.5*&
& max48*field_old(i, k, j))+mu*(0.5*(min67d*field_old(i, k-1, j)&
& +min67*field_oldd(i, k-1, j))+0.5*(max48d*field_old(i, k, j)+&
& max48*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min67*field_old(i, k-1, j)+0.5*&
& max48*field_old(i, k, j))
fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
& field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
& )*fieldd(i, k-1, j))
fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
& i, k-1, j))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
END DO
END DO
ELSE IF (vert_order .EQ. 3) THEN
fqzd = 0.0
fqzld = 0.0
DO j=j_start,j_end
DO i=i_start,i_end
fqzd(i, 1, j) = 0.0
fqz(i, 1, j) = 0.
fqzld(i, 1, j) = 0.0
fqzl(i, 1, j) = 0.
fqzd(i, kde, j) = 0.0
fqz(i, kde, j) = 0.
fqzld(i, kde, j) = 0.0
fqzl(i, kde, j) = 0.
END DO
DO k=kts+2,ktf-1
DO i=i_start,i_end
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs48d = crd
abs48 = cr
ELSE
abs48d = -crd
abs48 = -cr
END IF
y48d = crd + abs48d
y48 = cr + abs48
IF (1.0 .GT. y48) THEN
min68d = y48d
min68 = y48
ELSE
min68 = 1.0
min68d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs99d = crd
abs99 = cr
ELSE
abs99d = -crd
abs99 = -cr
END IF
y99d = crd - abs99d
y99 = cr - abs99
IF (-1.0 .LT. y99) THEN
max49d = y99d
max49 = y99
ELSE
max49 = -1.0
max49d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min68*field_old(i, k-1, j)+0.5*&
& max49*field_old(i, k, j))+mu*(0.5*(min68d*field_old(i, k-1, &
& j)+min68*field_oldd(i, k-1, j))+0.5*(max49d*field_old(i, k, &
& j)+max49*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min68*field_old(i, k-1, j)+0.5&
& *max49*field_old(i, k, j))
fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))&
& -1./12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, &
& time_step)*SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i&
& , k-2, j)-3.*(field(i, k, j)-field(i, k-1, j)))) + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i, k-1, j))/12.-(fieldd(i, k+1, j)+&
& fieldd(i, k-2, j))/12.+SIGN(1, time_step)*SIGN(1., -vel)*(&
& fieldd(i, k+1, j)-fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-&
& fieldd(i, k-1, j)))/12.)
fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-&
& 1./12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step&
& )*SIGN(1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)&
& -3.*(field(i, k, j)-field(i, k-1, j))))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs49d = crd
abs49 = cr
ELSE
abs49d = -crd
abs49 = -cr
END IF
y49d = crd + abs49d
y49 = cr + abs49
IF (1.0 .GT. y49) THEN
min69d = y49d
min69 = y49
ELSE
min69 = 1.0
min69d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs100d = crd
abs100 = cr
ELSE
abs100d = -crd
abs100 = -cr
END IF
y100d = crd - abs100d
y100 = cr - abs100
IF (-1.0 .LT. y100) THEN
max50d = y100d
max50 = y100
ELSE
max50 = -1.0
max50d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min69*field_old(i, k-1, j)+0.5*&
& max50*field_old(i, k, j))+mu*(0.5*(min69d*field_old(i, k-1, j)&
& +min69*field_oldd(i, k-1, j))+0.5*(max50d*field_old(i, k, j)+&
& max50*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min69*field_old(i, k-1, j)+0.5*&
& max50*field_old(i, k, j))
fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
& field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
& )*fieldd(i, k-1, j))
fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
& i, k-1, j))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
k = ktf
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs50d = crd
abs50 = cr
ELSE
abs50d = -crd
abs50 = -cr
END IF
y50d = crd + abs50d
y50 = cr + abs50
IF (1.0 .GT. y50) THEN
min70d = y50d
min70 = y50
ELSE
min70 = 1.0
min70d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs101d = crd
abs101 = cr
ELSE
abs101d = -crd
abs101 = -cr
END IF
y101d = crd - abs101d
y101 = cr - abs101
IF (-1.0 .LT. y101) THEN
max51d = y101d
max51 = y101
ELSE
max51 = -1.0
max51d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min70*field_old(i, k-1, j)+0.5*&
& max51*field_old(i, k, j))+mu*(0.5*(min70d*field_old(i, k-1, j)&
& +min70*field_oldd(i, k-1, j))+0.5*(max51d*field_old(i, k, j)+&
& max51*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min70*field_old(i, k-1, j)+0.5*&
& max51*field_old(i, k, j))
fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
& field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k&
& )*fieldd(i, k-1, j))
fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
& i, k-1, j))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
END DO
END DO
ELSE IF (vert_order .EQ. 2) THEN
fqzd = 0.0
fqzld = 0.0
DO j=j_start,j_end
DO i=i_start,i_end
fqzd(i, 1, j) = 0.0
fqz(i, 1, j) = 0.
fqzld(i, 1, j) = 0.0
fqzl(i, 1, j) = 0.
fqzd(i, kde, j) = 0.0
fqz(i, kde, j) = 0.
fqzld(i, kde, j) = 0.0
fqzl(i, kde, j) = 0.
END DO
DO k=kts+1,ktf
DO i=i_start,i_end
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs51d = crd
abs51 = cr
ELSE
abs51d = -crd
abs51 = -cr
END IF
y51d = crd + abs51d
y51 = cr + abs51
IF (1.0 .GT. y51) THEN
min71d = y51d
min71 = y51
ELSE
min71 = 1.0
min71d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs102d = crd
abs102 = cr
ELSE
abs102d = -crd
abs102 = -cr
END IF
y102d = crd - abs102d
y102 = cr - abs102
IF (-1.0 .LT. y102) THEN
max52d = y102d
max52 = y102
ELSE
max52 = -1.0
max52d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min71*field_old(i, k-1, j)+0.5*&
& max52*field_old(i, k, j))+mu*(0.5*(min71d*field_old(i, k-1, &
& j)+min71*field_oldd(i, k-1, j))+0.5*(max52d*field_old(i, k, &
& j)+max52*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min71*field_old(i, k-1, j)+0.5&
& *max52*field_old(i, k, j))
fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
& field(i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp&
& (k)*fieldd(i, k-1, j))
fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*&
& field(i, k-1, j))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
END DO
END DO
END DO
ELSE
WRITE(wrf_err_message, *) ' advect_scalar_pd, v_order not known ', &
& vert_order
CALL WRF_ERROR_FATAL(wrf_err_message)
fqzd = 0.0
fqzld = 0.0
END IF
IF (pd_limit) THEN
! positive definite filter
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min72 = ide - 1
ELSE
min72 = ite
END IF
i_end = min72 + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min73 = jde - 1
ELSE
min73 = jte
END IF
j_end = min73 + 1
!-- loop bounds for open or specified conditions
IF (degrade_xs) THEN
IF (its - 1 .LT. ids) THEN
i_start = ids
ELSE
i_start = its - 1
END IF
END IF
IF (degrade_xe) THEN
IF (ite + 1 .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite + 1
END IF
END IF
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds) THEN
j_start = jds
ELSE
j_start = jts - 1
END IF
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte + 1
END IF
END IF
IF (config_flags%specified .OR. config_flags%nested) THEN
IF (degrade_xs) THEN
IF (its - 1 .LT. ids + 1) THEN
i_start = ids + 1
ELSE
i_start = its - 1
END IF
END IF
IF (degrade_xe) THEN
IF (ite + 1 .GT. ide - 2) THEN
i_end = ide - 2
ELSE
i_end = ite + 1
END IF
END IF
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts - 1
END IF
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte + 1
END IF
END IF
END IF
IF (config_flags%open_xs) THEN
IF (degrade_xs) THEN
IF (its - 1 .LT. ids + 1) THEN
i_start = ids + 1
ELSE
i_start = its - 1
END IF
END IF
END IF
IF (config_flags%open_xe) THEN
IF (degrade_xe) THEN
IF (ite + 1 .GT. ide - 2) THEN
i_end = ide - 2
ELSE
i_end = ite + 1
END IF
END IF
END IF
IF (config_flags%open_ys) THEN
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts - 1
END IF
END IF
END IF
IF (config_flags%open_ye) THEN
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte + 1
END IF
ph_lowd = 0.0
ELSE
ph_lowd = 0.0
END IF
ELSE
ph_lowd = 0.0
END IF
! ADT note:
! We don't want to change j_start and j_end
! for polar BC's since we want to calculate
! fluxes for directions other than y at the
! edge
!-- here is the limiter...
DO j=j_start,j_end
DO k=kts,ktf
#ifdef XEON_SIMD
!DIR$ simd
#else
!DIR$ vector always
#endif
DO i=i_start,i_end
ph_lowd(i,k,j) = mu_oldd(i, j)*field_old(i, k, j) + (mub(i, j)+mu_old&
& (i, j))*field_oldd(i, k, j) - dt*(msftx(i, j)*msfty(i, j)*(&
& rdx*(fqxld(i+1, k, j)-fqxld(i, k, j))+rdy*(fqyld(i, k, j+1)-&
& fqyld(i, k, j)))+msfty(i, j)*rdzw(k)*(fqzld(i, k+1, j)-fqzld&
& (i, k, j)))
ph_low(i,k,j) = (mub(i, j)+mu_old(i, j))*field_old(i, k, j) - dt*(&
& msftx(i, j)*msfty(i, j)*(rdx*(fqxl(i+1, k, j)-fqxl(i, k, j))&
& +rdy*(fqyl(i, k, j+1)-fqyl(i, k, j)))+msfty(i, j)*rdzw(k)*(&
& fqzl(i, k+1, j)-fqzl(i, k, j)))
ENDDO
ENDDO
ENDDO
flux_outd = 0.0
DO j=j_start,j_end
DO k=kts,ktf
!DIR$ vector always
DO i=i_start,i_end
IF (0. .LT. fqx(i+1, k, j)) THEN
max1d = fqxd(i+1, k, j)
max1 = fqx(i+1, k, j)
ELSE
max1 = 0.
max1d = 0.0
END IF
IF (0. .GT. fqx(i, k, j)) THEN
min74d = fqxd(i, k, j)
min74 = fqx(i, k, j)
ELSE
min74 = 0.
min74d = 0.0
END IF
IF (0. .LT. fqy(i, k, j+1)) THEN
max53d = fqyd(i, k, j+1)
max53 = fqy(i, k, j+1)
ELSE
max53 = 0.
max53d = 0.0
END IF
IF (0. .GT. fqy(i, k, j)) THEN
min75d = fqyd(i, k, j)
min75 = fqy(i, k, j)
ELSE
min75 = 0.
min75d = 0.0
END IF
IF (0. .GT. fqz(i, k+1, j)) THEN
min76d = fqzd(i, k+1, j)
min76 = fqz(i, k+1, j)
ELSE
min76 = 0.
min76d = 0.0
END IF
IF (0. .LT. fqz(i, k, j)) THEN
max54d = fqzd(i, k, j)
max54 = fqz(i, k, j)
ELSE
max54 = 0.
max54d = 0.0
END IF
flux_outd(i,k,j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1d-min74d)+&
& rdy*(max53d-min75d))+msfty(i, j)*rdzw(k)*(min76d-max54d))
flux_out(i,k,j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1-min74)+rdy*(&
& max53-min75))+msfty(i, j)*rdzw(k)*(min76-max54))
ENDDO
ENDDO
ENDDO
DO j=j_start,j_end
DO k=kts,ktf
!DIR$ vector always
DO i=i_start,i_end
IF (flux_out(i,k,j) .GT. ph_low(i,k,j)) THEN
y16d = (ph_lowd(i,k,j)*(flux_out(i,k,j)+eps)-ph_low(i,k,j)*flux_outd(i,k,j))/(&
& flux_out(i,k,j)+eps)**2
y16 = ph_low(i,k,j)/(flux_out(i,k,j)+eps)
IF (0. .LT. y16) THEN
scaled = y16d
scale = y16
ELSE
scale = 0.
scaled = 0.0
END IF
IF (fqx(i+1, k, j) .GT. 0.) THEN
fqxd(i+1, k, j) = scaled*fqx(i+1, k, j) + scale*fqxd(i+1, &
& k, j)
fqx(i+1, k, j) = scale*fqx(i+1, k, j)
END IF
IF (fqx(i, k, j) .LT. 0.) THEN
fqxd(i, k, j) = scaled*fqx(i, k, j) + scale*fqxd(i, k, j)
fqx(i, k, j) = scale*fqx(i, k, j)
END IF
IF (fqy(i, k, j+1) .GT. 0.) THEN
fqyd(i, k, j+1) = scaled*fqy(i, k, j+1) + scale*fqyd(i, k&
& , j+1)
fqy(i, k, j+1) = scale*fqy(i, k, j+1)
END IF
IF (fqy(i, k, j) .LT. 0.) THEN
fqyd(i, k, j) = scaled*fqy(i, k, j) + scale*fqyd(i, k, j)
fqy(i, k, j) = scale*fqy(i, k, j)
END IF
! note: z flux is opposite sign in mass coordinate because
! vertical coordinate decreases with increasing k
IF (fqz(i, k+1, j) .LT. 0.) THEN
fqzd(i, k+1, j) = scaled*fqz(i, k+1, j) + scale*fqzd(i, k+&
& 1, j)
fqz(i, k+1, j) = scale*fqz(i, k+1, j)
END IF
IF (fqz(i, k, j) .GT. 0.) THEN
fqzd(i, k, j) = scaled*fqz(i, k, j) + scale*fqzd(i, k, j)
fqz(i, k, j) = scale*fqz(i, k, j)
END IF
END IF
END DO
END DO
END DO
END IF
! add in the pd-limited flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(fqzd(i, k+1, &
& j)-fqzd(i, k, j)+fqzld(i, k+1, j)-fqzld(i, k, j))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(fqz(i, k+1, j)-&
& fqz(i, k, j)+fqzl(i, k+1, j)-fqzl(i, k, j))
END DO
END DO
END DO
IF (tenddec) THEN
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
z_tendencyd(i, k, j) = -(rdzw(k)*(fqzd(i, k+1, j)-fqzd(i, k, j&
& )+fqzld(i, k+1, j)-fqzld(i, k, j)))
z_tendency(i, k, j) = 0. - rdzw(k)*(fqz(i, k+1, j)-fqz(i, k, j&
& )+fqzl(i, k+1, j)-fqzl(i, k, j))
END DO
END DO
END DO
END IF
! x flux divergence
!
IF (degrade_xs) THEN
IF (its .LT. ids + 1) THEN
i_start = ids + 1
ELSE
i_start = its
END IF
END IF
IF (degrade_xe) THEN
IF (ite .GT. ide - 2) THEN
i_end = ide - 2
ELSE
i_end = ite
END IF
END IF
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
! Un-"canceled" map scale factor, ADT Eq. 48
tendencyd(i, k, j) = tendencyd(i, k, j) - msftx(i, j)*rdx*(fqxd(&
& i+1, k, j)-fqxd(i, k, j)+fqxld(i+1, k, j)-fqxld(i, k, j))
tendency(i, k, j) = tendency(i, k, j) - msftx(i, j)*(rdx*(fqx(i+&
& 1, k, j)-fqx(i, k, j)+fqxl(i+1, k, j)-fqxl(i, k, j)))
END DO
END DO
END DO
IF (tenddec) THEN
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
h_tendencyd(i, k, j) = -(msftx(i, j)*rdx*(fqxd(i+1, k, j)-fqxd&
& (i, k, j)+fqxld(i+1, k, j)-fqxld(i, k, j)))
h_tendency(i, k, j) = 0. - msftx(i, j)*(rdx*(fqx(i+1, k, j)-&
& fqx(i, k, j)+fqxl(i+1, k, j)-fqxl(i, k, j)))
END DO
END DO
END DO
END IF
! y flux divergence
!
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
END IF
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
! Un-"canceled" map scale factor, ADT Eq. 48
! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
tendencyd(i, k, j) = tendencyd(i, k, j) - msftx(i, j)*rdy*(fqyd(&
& i, k, j+1)-fqyd(i, k, j)+fqyld(i, k, j+1)-fqyld(i, k, j))
tendency(i, k, j) = tendency(i, k, j) - msftx(i, j)*(rdy*(fqy(i&
& , k, j+1)-fqy(i, k, j)+fqyl(i, k, j+1)-fqyl(i, k, j)))
END DO
END DO
END DO
IF (tenddec) THEN
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
h_tendencyd(i, k, j) = h_tendencyd(i, k, j) - msftx(i, j)*rdy*&
& (fqyd(i, k, j+1)-fqyd(i, k, j)+fqyld(i, k, j+1)-fqyld(i, k, &
& j))
h_tendency(i, k, j) = h_tendency(i, k, j) - msftx(i, j)*(rdy*(&
& fqy(i, k, j+1)-fqy(i, k, j)+fqyl(i, k, j+1)-fqyl(i, k, j)))
END DO
END DO
END DO
END IF
END SUBROUTINE G_ADVECT_SCALAR_PD
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.6 (r4165) - 21 sep 2011 20:54
!
! Differentiation of advect_scalar_wenopd in forward (tangent) mode:
! variations of useful results: tendency
! with respect to varying inputs: rom field tendency ru rv mu_old
! field_old mut
! RW status of diff variables: rom:in field:in tendency:in-out
! ru:in rv:in mu_old:in field_old:in mut:in
SUBROUTINE G_ADVECT_SCALAR_WENOPD(field, fieldd, field_old, field_oldd, &
& tendency, tendencyd, ru, rud, rv, rvd, rom, romd, mut, mutd, mub, &
& mu_old, mu_oldd, time_step, config_flags, msfux, msfuy, msfvx, msfvy, &
& msftx, msfty, fzm, fzp, rdx, rdy, rdzw, dt, ids, ide, jds, jde, kds, &
& kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
IMPLICIT NONE
! Input data
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
& field_old, ru, rv, rom
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: fieldd, &
& field_oldd, rud, rvd, romd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut, mub, mu_old
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd, mu_oldd
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
& msfvy, msftx, msfty
REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
REAL, INTENT(IN) :: rdx, rdy, dt
INTEGER, INTENT(IN) :: time_step
! Local data
INTEGER :: i, j, k, itf, jtf, ktf
INTEGER :: i_start, i_end, j_start, j_end
INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
INTEGER :: jmin, jmax, jp, jm, imin, imax
REAL :: mrdx, mrdy, ub, vb, uw, vw, mu
REAL :: ubd, vbd, mud
! storage for high and low order fluxes
REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqx, fqy&
& , fqz
REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxd, fqyd, fqzd
REAL, DIMENSION(its - 1:ite + 2, kts:kte, jts - 1:jte + 2) :: fqxl, &
& fqyl, fqzl
REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: fqxld, fqyld, &
& fqzld
INTEGER :: horz_order, vert_order
LOGICAL :: degrade_xs, degrade_ys
LOGICAL :: degrade_xe, degrade_ye
INTEGER :: jp1, jp0, jtmp
REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_out, ph_low
REAL, DIMENSION(its-1:ite+2, kts:kte, jts-1:jte+2) :: flux_outd, ph_lowd
REAL :: scale
REAL :: scaled
REAL, PARAMETER :: eps=1.e-20
REAL :: dir, vv
REAL :: ue, vs, vn, wb, wt
REAL, PARAMETER :: f30=7./12., f31=1./12.
REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
REAL :: qim2, qim1, qi, qip1, qip2
REAL :: qim2d, qim1d, qid, qip1d, qip2d
DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
& sumwk
DOUBLE PRECISION :: beta0d, beta1d, beta2d, f0d, f1d, f2d, wi0d, wi1d&
& , wi2d, sumwkd
DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
& 3.d0/10.d0, eps1=1.0d-28
INTEGER, PARAMETER :: pw=2
! definition of flux operators, 3rd, 4th, 5th or 6th order
REAL :: flux3, flux4, flux5, flux6, flux_upwind
REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr
REAL :: veld, crd
! flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
! +0.5*(1.-sign(1.,cr))*q_i
! flux_upwind(q_im1, q_i, cr ) = 0.
REAL :: dx, dy, dz
LOGICAL, PARAMETER :: pd_limit=.true.
DOUBLE PRECISION :: pwx1
DOUBLE PRECISION :: pwx1d
DOUBLE PRECISION :: pwr1
DOUBLE PRECISION :: pwr1d
REAL :: abs18d
REAL :: abs26d
REAL :: min5d
REAL :: max10d
REAL :: y28d
REAL :: y4d
INTEGER :: min9
REAL :: abs29d
INTEGER :: min8
REAL :: max13d
REAL :: min7
REAL :: abs1d
REAL :: y29
REAL :: min6
REAL :: y10d
REAL :: y28
REAL :: min5
REAL :: y27
REAL :: min4
REAL :: max2d
REAL :: y7d
REAL :: min11d
REAL :: y26
REAL :: min3
REAL :: y25
INTEGER :: min2
REAL :: y24
INTEGER :: min1
REAL :: max16d
REAL :: y23
REAL :: abs4d
REAL :: abs11d
REAL :: y22
REAL :: y13d
REAL :: y21
REAL :: y21d
REAL :: y20
REAL :: max5d
REAL :: min14d
REAL :: abs29
INTRINSIC MAX
REAL :: abs28
REAL :: abs27
REAL :: abs7d
REAL :: abs14d
REAL :: abs26
REAL :: y16d
REAL :: abs22d
INTRINSIC SIGN
REAL :: abs25
REAL :: y24d
REAL :: abs24
REAL :: max8d
REAL :: min17d
REAL :: abs23
REAL :: min25d
INTRINSIC ABS
REAL :: abs22
REAL :: abs21
REAL :: abs20
REAL :: abs17d
REAL :: y19d
REAL :: abs25d
REAL :: min4d
REAL :: y27d
REAL :: y3d
REAL :: abs28d
REAL :: min7d
REAL :: max12d
REAL :: min26
REAL :: abs0d
REAL :: y19
REAL :: min25
REAL :: y18
REAL :: min24
REAL :: y17
INTEGER :: min23
REAL :: y6d
REAL :: min10d
REAL :: max1d
REAL :: y16
INTEGER :: min22
REAL :: y15
REAL :: min21
REAL :: y14
REAL :: min20
REAL :: max15d
REAL :: y13
REAL :: abs3d
REAL :: abs10d
REAL :: y12
REAL :: y12d
REAL :: y11
REAL :: y20d
REAL :: y10
REAL :: max4d
REAL :: y9d
REAL :: min13d
REAL :: min21d
REAL :: abs19
REAL :: abs18
REAL :: max18d
REAL :: abs17
REAL :: abs6d
REAL :: abs13d
REAL :: abs16
REAL :: abs21d
REAL :: y15d
REAL :: abs15
REAL :: y23d
REAL :: abs14
REAL :: max7d
REAL :: abs13
REAL :: min24d
REAL :: abs12
REAL :: abs11
REAL :: abs10
REAL :: abs16d
REAL :: abs9d
REAL :: y18d
REAL :: abs24d
REAL :: min3d
REAL :: y26d
REAL :: min19d
REAL :: y2d
REAL :: min19
REAL :: abs19d
REAL :: min18
REAL :: abs27d
REAL :: min17
REAL :: min6d
REAL :: max11d
REAL :: y29d
INTEGER :: min16
REAL :: abs9
INTEGER :: min15
REAL :: abs8
REAL :: min14
REAL :: abs7
REAL :: min13
REAL :: abs6
REAL :: y5d
REAL :: min12
REAL :: abs5
REAL :: min11
REAL :: abs4
REAL :: min10
REAL :: abs3
REAL :: max14d
REAL :: abs2
REAL :: abs2d
REAL :: abs1
REAL :: y11d
REAL :: abs0
REAL :: max3d
REAL :: y8d
REAL :: min12d
REAL :: min20d
INTRINSIC MIN
REAL :: max17d
REAL :: max9
REAL :: abs5d
REAL :: abs12d
REAL :: max8
REAL :: abs20d
REAL :: y14d
REAL :: max7
REAL :: max18
REAL :: y22d
REAL :: y30
REAL :: max6
REAL :: max17
REAL :: max6d
REAL :: y30d
REAL :: max5
REAL :: max16
REAL :: y9
REAL :: max4
REAL :: max15
REAL :: y8
REAL :: max3
REAL :: max14
REAL :: y7
REAL :: max2
REAL :: max13
REAL :: abs15d
REAL :: abs8d
REAL :: y6
REAL :: max1
REAL :: max12
REAL :: y17d
REAL :: abs23d
REAL :: y5
REAL :: max11
REAL :: y25d
REAL :: y4
REAL :: max10
REAL :: max9d
REAL :: min18d
REAL :: y3
REAL :: min26d
REAL :: y2
REAL :: y1
REAL :: y1d
! set order for the advection schemes
! write(6,*) ' in pd advection routine '
! Empty arrays just in case:
IF (config_flags%polar) THEN
fqx(:, :, :) = 0.
fqy(:, :, :) = 0.
fqz(:, :, :) = 0.
fqxl(:, :, :) = 0.
fqyl(:, :, :) = 0.
fqzl(:, :, :) = 0.
END IF
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
horz_order = config_flags%h_sca_adv_order
vert_order = config_flags%v_sca_adv_order
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
! begin with horizontal flux divergence
! here is the choice of flux operators
! horizontal_order_test : IF( horz_order == 6 ) THEN
! ELSE IF( horz_order == 5 ) THEN
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
& .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
& .LT. ide - 4) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
& .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
& .LT. jde - 4) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min1 = ide - 1
ELSE
min1 = ite
END IF
i_end = min1 + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min2 = jde - 1
ELSE
min2 = jte
END IF
j_end = min2 + 1
j_start_f = j_start
j_end_f = j_end + 1
!-- modify loop bounds if open or specified
! IF(degrade_xs) i_start = MAX(its-1,ids-1)
! IF(degrade_xe) i_end = MIN(ite+1,ide-2)
IF (degrade_xs) THEN
IF (its - 1 .LT. ids) THEN
i_start = ids
ELSE
i_start = its - 1
END IF
END IF
IF (degrade_xe) THEN
IF (ite + 1 .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite + 1
END IF
END IF
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts - 1
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte + 1
END IF
j_end_f = jde - 3
fqyld = 0.0
fqyd = 0.0
ELSE
fqyld = 0.0
fqyd = 0.0
END IF
! compute fluxes, 5th order
j_loop_y_flux_5:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
! use full stencil
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs0d = crd
abs0 = cr
ELSE
abs0d = -crd
abs0 = -cr
END IF
y1d = crd + abs0d
y1 = cr + abs0
IF (1.0 .GT. y1) THEN
min3d = y1d
min3 = y1
ELSE
min3 = 1.0
min3d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs15d = crd
abs15 = cr
ELSE
abs15d = -crd
abs15 = -cr
END IF
y16d = crd - abs15d
y16 = cr - abs15
IF (-1.0 .LT. y16) THEN
max2d = y16d
max2 = y16
ELSE
max2 = -1.0
max2d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min3*field_old(i, k, j-1)+0.5*&
& max2*field_old(i, k, j))+mu*(0.5*(min3d*field_old(i, k, j-1)&
& +min3*field_oldd(i, k, j-1))+0.5*(max2d*field_old(i, k, j)+&
& max2*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min3*field_old(i, k, j-1)+0.5*&
& max2*field_old(i, k, j))
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = fieldd(i, k, j+1)
qip2 = field(i, k, j+1)
qip1d = fieldd(i, k, j)
qip1 = field(i, k, j)
qid = fieldd(i, k, j-1)
qi = field(i, k, j-1)
qim1d = fieldd(i, k, j-2)
qim1 = field(i, k, j-2)
qim2d = fieldd(i, k, j-3)
qim2 = field(i, k, j-3)
ELSE
qip2d = fieldd(i, k, j-2)
qip2 = field(i, k, j-2)
qip1d = fieldd(i, k, j-1)
qip1 = field(i, k, j-1)
qid = fieldd(i, k, j)
qi = field(i, k, j)
qim1d = fieldd(i, k, j+1)
qim1 = field(i, k, j+1)
qim2d = fieldd(i, k, j+2)
qim2 = field(i, k, j+2)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*&
& (qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
& qi)**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*&
& (qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*&
& (qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
& qi)**2
pwx1d = beta0d
pwx1 = eps1 + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps1 + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps1 + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqyd(i, k, j) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0&
& *f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1&
& *f1+wi2*f2)*sumwkd)/sumwk**2
fqy(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
! fqy( i, k, j ) = vel*flux5( &
! field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), &
! field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel )
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs1d = crd
abs1 = cr
ELSE
abs1d = -crd
abs1 = -cr
END IF
y2d = crd + abs1d
y2 = cr + abs1
IF (1.0 .GT. y2) THEN
min4d = y2d
min4 = y2
ELSE
min4 = 1.0
min4d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs16d = crd
abs16 = cr
ELSE
abs16d = -crd
abs16 = -cr
END IF
y17d = crd - abs16d
y17 = cr - abs16
IF (-1.0 .LT. y17) THEN
max3d = y17d
max3 = y17
ELSE
max3 = -1.0
max3d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min4*field_old(i, k, j-1)+0.5*&
& max3*field_old(i, k, j))+mu*(0.5*(min4d*field_old(i, k, j-1)&
& +min4*field_oldd(i, k, j-1))+0.5*(max3d*field_old(i, k, j)+&
& max3*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min4*field_old(i, k, j-1)+0.5*&
& max3*field_old(i, k, j))
fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k, &
& j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1&
& ))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs2d = crd
abs2 = cr
ELSE
abs2d = -crd
abs2 = -cr
END IF
y3d = crd + abs2d
y3 = cr + abs2
IF (1.0 .GT. y3) THEN
min5d = y3d
min5 = y3
ELSE
min5 = 1.0
min5d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs17d = crd
abs17 = cr
ELSE
abs17d = -crd
abs17 = -cr
END IF
y18d = crd - abs17d
y18 = cr - abs17
IF (-1.0 .LT. y18) THEN
max4d = y18d
max4 = y18
ELSE
max4 = -1.0
max4d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min5*field_old(i, k, j-1)+0.5*&
& max4*field_old(i, k, j))+mu*(0.5*(min5d*field_old(i, k, j-1)&
& +min5*field_oldd(i, k, j-1))+0.5*(max4d*field_old(i, k, j)+&
& max4*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min5*field_old(i, k, j-1)+0.5*&
& max4*field_old(i, k, j))
fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1))&
& -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i&
& , k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+&
& fieldd(i, k, j-2))/12.+SIGN(1, time_step)*SIGN(1., vel)*(&
& fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)-&
& fieldd(i, k, j-1)))/12.)
fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))-&
& 1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, time_step&
& )*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-&
& 3.*(field(i, k, j)-field(i, k, j-1))))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs3d = crd
abs3 = cr
ELSE
abs3d = -crd
abs3 = -cr
END IF
y4d = crd + abs3d
y4 = cr + abs3
IF (1.0 .GT. y4) THEN
min6d = y4d
min6 = y4
ELSE
min6 = 1.0
min6d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs18d = crd
abs18 = cr
ELSE
abs18d = -crd
abs18 = -cr
END IF
y19d = crd - abs18d
y19 = cr - abs18
IF (-1.0 .LT. y19) THEN
max5d = y19d
max5 = y19
ELSE
max5 = -1.0
max5d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min6*field_old(i, k, j-1)+0.5*&
& max5*field_old(i, k, j))+mu*(0.5*(min6d*field_old(i, k, j-1)&
& +min6*field_oldd(i, k, j-1))+0.5*(max5d*field_old(i, k, j)+&
& max5*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min6*field_old(i, k, j-1)+0.5*&
& max5*field_old(i, k, j))
fqyd(i, k, j) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i, k, &
& j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1)))
fqy(i, k, j) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k, j-1&
& ))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 48 d/dy
dy = 2./(msftx(i, j)+msftx(i, j-1))/rdy
mud = 0.5*(mutd(i, j)+mutd(i, j-1))
mu = 0.5*(mut(i, j)+mut(i, j-1))
veld = rvd(i, k, j)
vel = rv(i, k, j)
crd = (dt*veld*mu/dy-vel*dt*mud/dy)/mu**2
cr = vel*dt/dy/mu
IF (cr .GE. 0.) THEN
abs4d = crd
abs4 = cr
ELSE
abs4d = -crd
abs4 = -cr
END IF
y5d = crd + abs4d
y5 = cr + abs4
IF (1.0 .GT. y5) THEN
min7d = y5d
min7 = y5
ELSE
min7 = 1.0
min7d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs19d = crd
abs19 = cr
ELSE
abs19d = -crd
abs19 = -cr
END IF
y20d = crd - abs19d
y20 = cr - abs19
IF (-1.0 .LT. y20) THEN
max6d = y20d
max6 = y20
ELSE
max6 = -1.0
max6d = 0.0
END IF
fqyld(i, k, j) = dy*(mud*(0.5*min7*field_old(i, k, j-1)+0.5*&
& max6*field_old(i, k, j))+mu*(0.5*(min7d*field_old(i, k, j-1)&
& +min7*field_oldd(i, k, j-1))+0.5*(max6d*field_old(i, k, j)+&
& max6*field_oldd(i, k, j))))/dt
fqyl(i, k, j) = mu*(dy/dt)*(0.5*min7*field_old(i, k, j-1)+0.5*&
& max6*field_old(i, k, j))
fqyd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k, j-1))&
& -1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i&
& , k, j-2)-3.*(field(i, k, j)-field(i, k, j-1)))) + vel*(7.*(&
& fieldd(i, k, j)+fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+&
& fieldd(i, k, j-2))/12.+SIGN(1, time_step)*SIGN(1., vel)*(&
& fieldd(i, k, j+1)-fieldd(i, k, j-2)-3.*(fieldd(i, k, j)-&
& fieldd(i, k, j-1)))/12.)
fqy(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1))-&
& 1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1, time_step&
& )*SIGN(1., vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-&
& 3.*(field(i, k, j)-field(i, k, j-1))))
fqyd(i, k, j) = fqyd(i, k, j) - fqyld(i, k, j)
fqy(i, k, j) = fqy(i, k, j) - fqyl(i, k, j)
END DO
END DO
END IF
END DO j_loop_y_flux_5
! next, x flux
!-- these bounds are for periodic and sym conditions
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min8 = ide - 1
ELSE
min8 = ite
END IF
i_end = min8 + 1
i_start_f = i_start
i_end_f = i_end + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min9 = jde - 1
ELSE
min9 = jte
END IF
j_end = min9 + 1
!-- modify loop bounds for open and specified b.c
! IF(degrade_ys) j_start = MAX(jts-1,jds+1)
! IF(degrade_ye) j_end = MIN(jte+1,jde-2)
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds) THEN
j_start = jds
ELSE
j_start = jts - 1
END IF
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte + 1
END IF
END IF
IF (degrade_xs) THEN
IF (ids + 1 .LT. its - 1) THEN
i_start = its - 1
ELSE
i_start = ids + 1
END IF
i_start_f = ids + 3
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite + 1) THEN
i_end = ite + 1
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxld = 0.0
fqxd = 0.0
ELSE
fqxld = 0.0
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs5d = crd
abs5 = cr
ELSE
abs5d = -crd
abs5 = -cr
END IF
y6d = crd + abs5d
y6 = cr + abs5
IF (1.0 .GT. y6) THEN
min10d = y6d
min10 = y6
ELSE
min10 = 1.0
min10d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs20d = crd
abs20 = cr
ELSE
abs20d = -crd
abs20 = -cr
END IF
y21d = crd - abs20d
y21 = cr - abs20
IF (-1.0 .LT. y21) THEN
max7d = y21d
max7 = y21
ELSE
max7 = -1.0
max7d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min10*field_old(i-1, k, j)+0.5*&
& max7*field_old(i, k, j))+mu*(0.5*(min10d*field_old(i-1, k, j)+&
& min10*field_oldd(i-1, k, j))+0.5*(max7d*field_old(i, k, j)+&
& max7*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min10*field_old(i-1, k, j)+0.5*&
& max7*field_old(i, k, j))
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = fieldd(i+1, k, j)
qip2 = field(i+1, k, j)
qip1d = fieldd(i, k, j)
qip1 = field(i, k, j)
qid = fieldd(i-1, k, j)
qi = field(i-1, k, j)
qim1d = fieldd(i-2, k, j)
qim1 = field(i-2, k, j)
qim2d = fieldd(i-3, k, j)
qim2 = field(i-3, k, j)
ELSE
qip2d = fieldd(i-2, k, j)
qip2 = field(i-2, k, j)
qip1d = fieldd(i-1, k, j)
qip1 = field(i-1, k, j)
qid = fieldd(i, k, j)
qi = field(i, k, j)
qim1d = fieldd(i+1, k, j)
qim1 = field(i+1, k, j)
qim2d = fieldd(i+2, k, j)
qim2 = field(i+2, k, j)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
& qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
& )**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
& qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
& qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
& )**2
pwx1d = beta0d
pwx1 = eps1 + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps1 + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps1 + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqxd(i, k, j) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
& f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
& +wi2*f2)*sumwkd)/sumwk**2
fqx(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
! fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), &
! field(i-1,k,j), field(i ,k,j), &
! field(i+1,k,j), field(i+2,k,j), &
! vel )
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END DO
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = (rud(i, k, j)*mu-ru(i, k, j)*mud)/mu**2
vel = ru(i, k, j)/mu
crd = dt*veld/dx
cr = vel*dt/dx
IF (cr .GE. 0.) THEN
abs6d = crd
abs6 = cr
ELSE
abs6d = -crd
abs6 = -cr
END IF
y7d = crd + abs6d
y7 = cr + abs6
IF (1.0 .GT. y7) THEN
min11d = y7d
min11 = y7
ELSE
min11 = 1.0
min11d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs21d = crd
abs21 = cr
ELSE
abs21d = -crd
abs21 = -cr
END IF
y22d = crd - abs21d
y22 = cr - abs21
IF (-1.0 .LT. y22) THEN
max8d = y22d
max8 = y22
ELSE
max8 = -1.0
max8d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min11*field_old(i-1, k, j)+0.5&
& *max8*field_old(i, k, j))+mu*(0.5*(min11d*field_old(i-1, k&
& , j)+min11*field_oldd(i-1, k, j))+0.5*(max8d*field_old(i, &
& k, j)+max8*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min11*field_old(i-1, k, j)+&
& 0.5*max8*field_old(i, k, j))
fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
& , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
& , j))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
IF (i .EQ. ids + 2) THEN
! third order
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs7d = crd
abs7 = cr
ELSE
abs7d = -crd
abs7 = -cr
END IF
y8d = crd + abs7d
y8 = cr + abs7
IF (1.0 .GT. y8) THEN
min12d = y8d
min12 = y8
ELSE
min12 = 1.0
min12d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs22d = crd
abs22 = cr
ELSE
abs22d = -crd
abs22 = -cr
END IF
y23d = crd - abs22d
y23 = cr - abs22
IF (-1.0 .LT. y23) THEN
max9d = y23d
max9 = y23
ELSE
max9 = -1.0
max9d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min12*field_old(i-1, k, j)+0.5&
& *max9*field_old(i, k, j))+mu*(0.5*(min12d*field_old(i-1, k&
& , j)+min12*field_oldd(i-1, k, j))+0.5*(max9d*field_old(i, &
& k, j)+max9*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min12*field_old(i-1, k, j)+&
& 0.5*max9*field_old(i, k, j))
fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j&
& ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(&
& i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) + vel*(&
& 7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k&
& , j)+fieldd(i-2, k, j))/12.+SIGN(1, time_step)*SIGN(1., &
& vel)*(fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i, k&
& , j)-fieldd(i-1, k, j)))/12.)
fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))&
& -1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(&
& i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs8d = crd
abs8 = cr
ELSE
abs8d = -crd
abs8 = -cr
END IF
y9d = crd + abs8d
y9 = cr + abs8
IF (1.0 .GT. y9) THEN
min13d = y9d
min13 = y9
ELSE
min13 = 1.0
min13d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs23d = crd
abs23 = cr
ELSE
abs23d = -crd
abs23 = -cr
END IF
y24d = crd - abs23d
y24 = cr - abs23
IF (-1.0 .LT. y24) THEN
max10d = y24d
max10 = y24
ELSE
max10 = -1.0
max10d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min13*field_old(i-1, k, j)+0.5&
& *max10*field_old(i, k, j))+mu*(0.5*(min13d*field_old(i-1, &
& k, j)+min13*field_oldd(i-1, k, j))+0.5*(max10d*field_old(i&
& , k, j)+max10*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min13*field_old(i-1, k, j)+&
& 0.5*max10*field_old(i, k, j))
fqxd(i, k, j) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1&
& , k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k, j) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k&
& , j))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
IF (i .EQ. ide - 2) THEN
! third order flux one in from the boundary
DO k=kts,ktf
! ADT eqn 48 d/dx
dx = 2./(msfty(i, j)+msfty(i-1, j))/rdx
mud = 0.5*(mutd(i, j)+mutd(i-1, j))
mu = 0.5*(mut(i, j)+mut(i-1, j))
veld = rud(i, k, j)
vel = ru(i, k, j)
crd = (dt*veld*mu/dx-vel*dt*mud/dx)/mu**2
cr = vel*dt/dx/mu
IF (cr .GE. 0.) THEN
abs9d = crd
abs9 = cr
ELSE
abs9d = -crd
abs9 = -cr
END IF
y10d = crd + abs9d
y10 = cr + abs9
IF (1.0 .GT. y10) THEN
min14d = y10d
min14 = y10
ELSE
min14 = 1.0
min14d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs24d = crd
abs24 = cr
ELSE
abs24d = -crd
abs24 = -cr
END IF
y25d = crd - abs24d
y25 = cr - abs24
IF (-1.0 .LT. y25) THEN
max11d = y25d
max11 = y25
ELSE
max11 = -1.0
max11d = 0.0
END IF
fqxld(i, k, j) = dx*(mud*(0.5*min14*field_old(i-1, k, j)+0.5&
& *max11*field_old(i, k, j))+mu*(0.5*(min14d*field_old(i-1, &
& k, j)+min14*field_oldd(i-1, k, j))+0.5*(max11d*field_old(i&
& , k, j)+max11*field_oldd(i, k, j))))/dt
fqxl(i, k, j) = mu*(dx/dt)*(0.5*min14*field_old(i-1, k, j)+&
& 0.5*max11*field_old(i, k, j))
fqxd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j&
& ))-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(&
& i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j)))) + vel*(&
& 7.*(fieldd(i, k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k&
& , j)+fieldd(i-2, k, j))/12.+SIGN(1, time_step)*SIGN(1., &
& vel)*(fieldd(i+1, k, j)-fieldd(i-2, k, j)-3.*(fieldd(i, k&
& , j)-fieldd(i-1, k, j)))/12.)
fqx(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))&
& -1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1, &
& time_step)*SIGN(1., vel)*(1./12.)*(field(i+1, k, j)-field(&
& i-2, k, j)-3.*(field(i, k, j)-field(i-1, k, j))))
fqxd(i, k, j) = fqxd(i, k, j) - fqxld(i, k, j)
fqx(i, k, j) = fqx(i, k, j) - fqxl(i, k, j)
END DO
END IF
END DO
END IF
END DO
! enddo for outer J loop
!--- end of 5th order horizontal flux calculation
! ELSE
! WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order
! CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
! ENDIF horizontal_order_test
! pick up the rest of the horizontal radiation boundary conditions.
! (these are the computations that don't require 'cb'.
! first, set to index ranges
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! compute x (u) conditions for v, w, or scalar
IF (config_flags%open_xs .AND. its .EQ. ids) THEN
DO j=j_start,j_end
DO k=kts,ktf
IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = 0.5*(rud(its, k, j)+rud(its+1, k, j))
ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
END IF
tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(&
& field_old(its+1, k, j)-field_old(its, k, j))+ub*(field_oldd(&
& its+1, k, j)-field_oldd(its, k, j))+fieldd(its, k, j)*(ru(its+&
& 1, k, j)-ru(its, k, j))+field(its, k, j)*(rud(its+1, k, j)-rud&
& (its, k, j)))
tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(field_old(&
& its+1, k, j)-field_old(its, k, j))+field(its, k, j)*(ru(its+1&
& , k, j)-ru(its, k, j)))
END DO
END DO
END IF
IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
DO j=j_start,j_end
DO k=kts,ktf
IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = 0.5*(rud(ite-1, k, j)+rud(ite, k, j))
ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
END IF
tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
& field_old(i_end, k, j)-field_old(i_end-1, k, j))+ub*(&
& field_oldd(i_end, k, j)-field_oldd(i_end-1, k, j))+fieldd(&
& i_end, k, j)*(ru(ite, k, j)-ru(ite-1, k, j))+field(i_end, k, j&
& )*(rud(ite, k, j)-rud(ite-1, k, j)))
tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(&
& field_old(i_end, k, j)-field_old(i_end-1, k, j))+field(i_end, &
& k, j)*(ru(ite, k, j)-ru(ite-1, k, j)))
END DO
END DO
END IF
IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*(rvd(i, k, jts)+rvd(i, k, jts+1))
vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
& field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
& , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*(rv(i, k&
& , jts+1)-rv(i, k, jts))+field(i, k, jts)*(rvd(i, k, jts+1)-rvd&
& (i, k, jts)))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
& , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*(rv(i, k, &
& jts+1)-rv(i, k, jts)))
END DO
END DO
END IF
IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*(rvd(i, k, jte-1)+rvd(i, k, jte))
vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
END IF
tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
& field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))+fieldd(i, k&
& , j_end)*(rv(i, k, jte)-rv(i, k, jte-1))+field(i, k, j_end)*(&
& rvd(i, k, jte)-rvd(i, k, jte-1)))
tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
& j_end)*(rv(i, k, jte)-rv(i, k, jte-1)))
END DO
END DO
END IF
IF (config_flags%polar .AND. jts .EQ. jds) THEN
! Assuming rv(i,k,jds) = 0.
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*rv(i, k, jts+1) .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*rvd(i, k, jts+1)
vb = 0.5*rv(i, k, jts+1)
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
& field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
& , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*rv(i, k, &
& jts+1)+field(i, k, jts)*rvd(i, k, jts+1))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
& , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*rv(i, k, &
& jts+1))
END DO
END DO
END IF
IF (config_flags%polar .AND. jte .EQ. jde) THEN
! Assuming rv(i,k,jde) = 0.
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*rv(i, k, jte-1) .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*rvd(i, k, jte-1)
vb = 0.5*rv(i, k, jte-1)
END IF
tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
& field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))-fieldd(i, k&
& , j_end)*rv(i, k, jte-1)-field(i, k, j_end)*rvd(i, k, jte-1))
tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
& j_end)*(-rv(i, k, jte-1)))
END DO
END DO
END IF
!-------------------- vertical advection
!-- loop bounds for periodic or sym conditions
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min15 = ide - 1
ELSE
min15 = ite
END IF
i_end = min15 + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min16 = jde - 1
ELSE
min16 = jte
END IF
j_end = min16 + 1
!-- loop bounds for open or specified conditions
IF (degrade_xs) THEN
IF (its - 1 .LT. ids) THEN
i_start = ids
ELSE
i_start = its - 1
END IF
END IF
IF (degrade_xe) THEN
IF (ite + 1 .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite + 1
END IF
END IF
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds) THEN
j_start = jds
ELSE
j_start = jts - 1
END IF
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte + 1
END IF
fqzd = 0.0
fqzld = 0.0
ELSE
fqzd = 0.0
fqzld = 0.0
END IF
! vert_order_test : IF (vert_order == 6) THEN
! ELSE IF (vert_order == 5) THEN
DO j=j_start,j_end
DO i=i_start,i_end
fqzd(i, 1, j) = 0.0
fqz(i, 1, j) = 0.
fqzld(i, 1, j) = 0.0
fqzl(i, 1, j) = 0.
fqzd(i, kde, j) = 0.0
fqz(i, kde, j) = 0.
fqzld(i, kde, j) = 0.0
fqzl(i, kde, j) = 0.
END DO
DO k=kts+3,ktf-2
DO i=i_start,i_end
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs10d = crd
abs10 = cr
ELSE
abs10d = -crd
abs10 = -cr
END IF
y11d = crd + abs10d
y11 = cr + abs10
IF (1.0 .GT. y11) THEN
min17d = y11d
min17 = y11
ELSE
min17 = 1.0
min17d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs25d = crd
abs25 = cr
ELSE
abs25d = -crd
abs25 = -cr
END IF
y26d = crd - abs25d
y26 = cr - abs25
IF (-1.0 .LT. y26) THEN
max12d = y26d
max12 = y26
ELSE
max12 = -1.0
max12d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min17*field_old(i, k-1, j)+0.5*&
& max12*field_old(i, k, j))+mu*(0.5*(min17d*field_old(i, k-1, j)&
& +min17*field_oldd(i, k-1, j))+0.5*(max12d*field_old(i, k, j)+&
& max12*field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min17*field_old(i, k-1, j)+0.5*&
& max12*field_old(i, k, j))
IF (-vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = fieldd(i, k+1, j)
qip2 = field(i, k+1, j)
qip1d = fieldd(i, k, j)
qip1 = field(i, k, j)
qid = fieldd(i, k-1, j)
qi = field(i, k-1, j)
qim1d = fieldd(i, k-2, j)
qim1 = field(i, k-2, j)
qim2d = fieldd(i, k-3, j)
qim2 = field(i, k-3, j)
ELSE
qip2d = fieldd(i, k-2, j)
qip2 = field(i, k-2, j)
qip1d = fieldd(i, k-1, j)
qip1 = field(i, k-1, j)
qid = fieldd(i, k, j)
qi = field(i, k, j)
qim1d = fieldd(i, k+1, j)
qim1 = field(i, k+1, j)
qim2d = fieldd(i, k+2, j)
qim2 = field(i, k+2, j)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
& qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
& )**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
& qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
& qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
& )**2
pwx1d = beta0d
pwx1 = eps1 + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps1 + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps1 + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqzd(i, k, j) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
& f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
& +wi2*f2)*sumwkd)/sumwk**2
fqz(i, k, j) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
! fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), &
! field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel )
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
END DO
END DO
DO i=i_start,i_end
k = kts + 1
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs11d = crd
abs11 = cr
ELSE
abs11d = -crd
abs11 = -cr
END IF
y12d = crd + abs11d
y12 = cr + abs11
IF (1.0 .GT. y12) THEN
min18d = y12d
min18 = y12
ELSE
min18 = 1.0
min18d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs26d = crd
abs26 = cr
ELSE
abs26d = -crd
abs26 = -cr
END IF
y27d = crd - abs26d
y27 = cr - abs26
IF (-1.0 .LT. y27) THEN
max13d = y27d
max13 = y27
ELSE
max13 = -1.0
max13d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min18*field_old(i, k-1, j)+0.5*max13&
& *field_old(i, k, j))+mu*(0.5*(min18d*field_old(i, k-1, j)+min18*&
& field_oldd(i, k-1, j))+0.5*(max13d*field_old(i, k, j)+max13*&
& field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min18*field_old(i, k-1, j)+0.5*&
& max13*field_old(i, k, j))
fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
& i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*fieldd&
& (i, k-1, j))
fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
k = kts + 2
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs12d = crd
abs12 = cr
ELSE
abs12d = -crd
abs12 = -cr
END IF
y13d = crd + abs12d
y13 = cr + abs12
IF (1.0 .GT. y13) THEN
min19d = y13d
min19 = y13
ELSE
min19 = 1.0
min19d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs27d = crd
abs27 = cr
ELSE
abs27d = -crd
abs27 = -cr
END IF
y28d = crd - abs27d
y28 = cr - abs27
IF (-1.0 .LT. y28) THEN
max14d = y28d
max14 = y28
ELSE
max14 = -1.0
max14d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min19*field_old(i, k-1, j)+0.5*max14&
& *field_old(i, k, j))+mu*(0.5*(min19d*field_old(i, k-1, j)+min19*&
& field_oldd(i, k-1, j))+0.5*(max14d*field_old(i, k, j)+max14*&
& field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min19*field_old(i, k-1, j)+0.5*&
& max14*field_old(i, k, j))
fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
& 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(&
& 1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
& i, k, j)-field(i, k-1, j)))) + vel*(7.*(fieldd(i, k, j)+fieldd(i&
& , k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k-2, j))/12.+SIGN(1&
& , time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-fieldd(i, k-2, j)&
& -3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.)
fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
& 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(&
& 1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
& i, k, j)-field(i, k-1, j))))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
k = ktf - 1
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs13d = crd
abs13 = cr
ELSE
abs13d = -crd
abs13 = -cr
END IF
y14d = crd + abs13d
y14 = cr + abs13
IF (1.0 .GT. y14) THEN
min20d = y14d
min20 = y14
ELSE
min20 = 1.0
min20d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs28d = crd
abs28 = cr
ELSE
abs28d = -crd
abs28 = -cr
END IF
y29d = crd - abs28d
y29 = cr - abs28
IF (-1.0 .LT. y29) THEN
max15d = y29d
max15 = y29
ELSE
max15 = -1.0
max15d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min20*field_old(i, k-1, j)+0.5*max15&
& *field_old(i, k, j))+mu*(0.5*(min20d*field_old(i, k-1, j)+min20*&
& field_oldd(i, k-1, j))+0.5*(max15d*field_old(i, k, j)+max15*&
& field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min20*field_old(i, k-1, j)+0.5*&
& max15*field_old(i, k, j))
fqzd(i, k, j) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
& 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(&
& 1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
& i, k, j)-field(i, k-1, j)))) + vel*(7.*(fieldd(i, k, j)+fieldd(i&
& , k-1, j))/12.-(fieldd(i, k+1, j)+fieldd(i, k-2, j))/12.+SIGN(1&
& , time_step)*SIGN(1., -vel)*(fieldd(i, k+1, j)-fieldd(i, k-2, j)&
& -3.*(fieldd(i, k, j)-fieldd(i, k-1, j)))/12.)
fqz(i, k, j) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
& 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1, time_step)*SIGN(&
& 1., -vel)*(1./12.)*(field(i, k+1, j)-field(i, k-2, j)-3.*(field(&
& i, k, j)-field(i, k-1, j))))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
k = ktf
dz = 2./(rdzw(k)+rdzw(k-1))
mud = 0.5*2*mutd(i, j)
mu = 0.5*(mut(i, j)+mut(i, j))
veld = romd(i, k, j)
vel = rom(i, k, j)
crd = (dt*veld*mu/dz-vel*dt*mud/dz)/mu**2
cr = vel*dt/dz/mu
IF (cr .GE. 0.) THEN
abs14d = crd
abs14 = cr
ELSE
abs14d = -crd
abs14 = -cr
END IF
y15d = crd + abs14d
y15 = cr + abs14
IF (1.0 .GT. y15) THEN
min21d = y15d
min21 = y15
ELSE
min21 = 1.0
min21d = 0.0
END IF
IF (cr .GE. 0.) THEN
abs29d = crd
abs29 = cr
ELSE
abs29d = -crd
abs29 = -cr
END IF
y30d = crd - abs29d
y30 = cr - abs29
IF (-1.0 .LT. y30) THEN
max16d = y30d
max16 = y30
ELSE
max16 = -1.0
max16d = 0.0
END IF
fqzld(i, k, j) = dz*(mud*(0.5*min21*field_old(i, k-1, j)+0.5*max16&
& *field_old(i, k, j))+mu*(0.5*(min21d*field_old(i, k-1, j)+min21*&
& field_oldd(i, k-1, j))+0.5*(max16d*field_old(i, k, j)+max16*&
& field_oldd(i, k, j))))/dt
fqzl(i, k, j) = mu*(dz/dt)*(0.5*min21*field_old(i, k-1, j)+0.5*&
& max16*field_old(i, k, j))
fqzd(i, k, j) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(&
& i, k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*fieldd&
& (i, k-1, j))
fqz(i, k, j) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j))
fqzd(i, k, j) = fqzd(i, k, j) - fqzld(i, k, j)
fqz(i, k, j) = fqz(i, k, j) - fqzl(i, k, j)
END DO
END DO
! ELSE
! WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order
! CALL wrf_error_fatal ( wrf_err_message )
! ENDIF vert_order_test
IF (pd_limit) THEN
! positive definite filter
i_start = its - 1
IF (ite .GT. ide - 1) THEN
min22 = ide - 1
ELSE
min22 = ite
END IF
i_end = min22 + 1
j_start = jts - 1
IF (jte .GT. jde - 1) THEN
min23 = jde - 1
ELSE
min23 = jte
END IF
j_end = min23 + 1
!-- loop bounds for open or specified conditions
IF (degrade_xs) THEN
IF (its - 1 .LT. ids) THEN
i_start = ids
ELSE
i_start = its - 1
END IF
END IF
IF (degrade_xe) THEN
IF (ite + 1 .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite + 1
END IF
END IF
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds) THEN
j_start = jds
ELSE
j_start = jts - 1
END IF
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte + 1
END IF
END IF
IF (config_flags%specified .OR. config_flags%nested) THEN
IF (degrade_xs) THEN
IF (its - 1 .LT. ids + 1) THEN
i_start = ids + 1
ELSE
i_start = its - 1
END IF
END IF
IF (degrade_xe) THEN
IF (ite + 1 .GT. ide - 2) THEN
i_end = ide - 2
ELSE
i_end = ite + 1
END IF
END IF
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts - 1
END IF
END IF
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte + 1
END IF
END IF
END IF
IF (config_flags%open_xs) THEN
IF (degrade_xs) THEN
IF (its - 1 .LT. ids + 1) THEN
i_start = ids + 1
ELSE
i_start = its - 1
END IF
END IF
END IF
IF (config_flags%open_xe) THEN
IF (degrade_xe) THEN
IF (ite + 1 .GT. ide - 2) THEN
i_end = ide - 2
ELSE
i_end = ite + 1
END IF
END IF
END IF
IF (config_flags%open_ys) THEN
IF (degrade_ys) THEN
IF (jts - 1 .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts - 1
END IF
END IF
END IF
IF (config_flags%open_ye) THEN
IF (degrade_ye) THEN
IF (jte + 1 .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte + 1
END IF
ph_lowd = 0.0
ELSE
ph_lowd = 0.0
END IF
ELSE
ph_lowd = 0.0
END IF
! ADT note:
! We don't want to change j_start and j_end
! for polar BC's since we want to calculate
! fluxes for directions other than y at the
! edge
!-- here is the limiter...
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
ph_lowd(i,k,j) = mu_oldd(i, j)*field_old(i, k, j) + (mub(i, j)+mu_old&
& (i, j))*field_oldd(i, k, j) - dt*(msftx(i, j)*msfty(i, j)*(&
& rdx*(fqxld(i+1, k, j)-fqxld(i, k, j))+rdy*(fqyld(i, k, j+1)-&
& fqyld(i, k, j)))+msfty(i, j)*rdzw(k)*(fqzld(i, k+1, j)-fqzld&
& (i, k, j)))
ph_low(i,k,j) = (mub(i, j)+mu_old(i, j))*field_old(i, k, j) - dt*(&
& msftx(i, j)*msfty(i, j)*(rdx*(fqxl(i+1, k, j)-fqxl(i, k, j))&
& +rdy*(fqyl(i, k, j+1)-fqyl(i, k, j)))+msfty(i, j)*rdzw(k)*(&
& fqzl(i, k+1, j)-fqzl(i, k, j)))
ENDDO
ENDDO
ENDDO
flux_outd = 0.0
DO j=j_start,j_end
DO k=kts,ktf
!DIR$ vector always
DO i=i_start,i_end
IF (0. .LT. fqx(i+1, k, j)) THEN
max1d = fqxd(i+1, k, j)
max1 = fqx(i+1, k, j)
ELSE
max1 = 0.
max1d = 0.0
END IF
IF (0. .GT. fqx(i, k, j)) THEN
min24d = fqxd(i, k, j)
min24 = fqx(i, k, j)
ELSE
min24 = 0.
min24d = 0.0
END IF
IF (0. .LT. fqy(i, k, j+1)) THEN
max17d = fqyd(i, k, j+1)
max17 = fqy(i, k, j+1)
ELSE
max17 = 0.
max17d = 0.0
END IF
IF (0. .GT. fqy(i, k, j)) THEN
min25d = fqyd(i, k, j)
min25 = fqy(i, k, j)
ELSE
min25 = 0.
min25d = 0.0
END IF
IF (0. .GT. fqz(i, k+1, j)) THEN
min26d = fqzd(i, k+1, j)
min26 = fqz(i, k+1, j)
ELSE
min26 = 0.
min26d = 0.0
END IF
IF (0. .LT. fqz(i, k, j)) THEN
max18d = fqzd(i, k, j)
max18 = fqz(i, k, j)
ELSE
max18 = 0.
max18d = 0.0
END IF
flux_outd(i,k,j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1d-min24d)+&
& rdy*(max17d-min25d))+msfty(i, j)*rdzw(k)*(min26d-max18d))
flux_out(i,k,j) = dt*(msftx(i, j)*msfty(i, j)*(rdx*(max1-min24)+rdy*(&
& max17-min25))+msfty(i, j)*rdzw(k)*(min26-max18))
ENDDO
ENDDO
ENDDO
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
IF (flux_out(i,k,j) .GT. ph_low(i,k,j)) THEN
IF (0. .LT. ph_low(i,k,j)/(flux_out(i,k,j)+eps)) THEN
scaled = (ph_lowd(i,k,j)*(flux_out(i,k,j)+eps)-ph_low(i,k,j)*flux_outd(i,k,j))/(&
& flux_out(i,k,j)+eps)**2
scale = ph_low(i,k,j)/(flux_out(i,k,j)+eps)
ELSE
scale = 0.
scaled = 0.0
END IF
IF (fqx(i+1, k, j) .GT. 0.) THEN
fqxd(i+1, k, j) = scaled*fqx(i+1, k, j) + scale*fqxd(i+1, &
& k, j)
fqx(i+1, k, j) = scale*fqx(i+1, k, j)
END IF
IF (fqx(i, k, j) .LT. 0.) THEN
fqxd(i, k, j) = scaled*fqx(i, k, j) + scale*fqxd(i, k, j)
fqx(i, k, j) = scale*fqx(i, k, j)
END IF
IF (fqy(i, k, j+1) .GT. 0.) THEN
fqyd(i, k, j+1) = scaled*fqy(i, k, j+1) + scale*fqyd(i, k&
& , j+1)
fqy(i, k, j+1) = scale*fqy(i, k, j+1)
END IF
IF (fqy(i, k, j) .LT. 0.) THEN
fqyd(i, k, j) = scaled*fqy(i, k, j) + scale*fqyd(i, k, j)
fqy(i, k, j) = scale*fqy(i, k, j)
END IF
! note: z flux is opposite sign in mass coordinate because
! vertical coordinate decreases with increasing k
IF (fqz(i, k+1, j) .LT. 0.) THEN
fqzd(i, k+1, j) = scaled*fqz(i, k+1, j) + scale*fqzd(i, k+&
& 1, j)
fqz(i, k+1, j) = scale*fqz(i, k+1, j)
END IF
IF (fqz(i, k, j) .GT. 0.) THEN
fqzd(i, k, j) = scaled*fqz(i, k, j) + scale*fqzd(i, k, j)
fqz(i, k, j) = scale*fqz(i, k, j)
END IF
END IF
END DO
END DO
END DO
END IF
! add in the pd-limited flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(fqzd(i, k+1, &
& j)-fqzd(i, k, j)+fqzld(i, k+1, j)-fqzld(i, k, j))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(fqz(i, k+1, j)-&
& fqz(i, k, j)+fqzl(i, k+1, j)-fqzl(i, k, j))
END DO
END DO
END DO
! x flux divergence
!
IF (degrade_xs) THEN
IF (its .LT. ids + 1) THEN
i_start = ids + 1
ELSE
i_start = its
END IF
END IF
IF (degrade_xe) THEN
IF (ite .GT. ide - 2) THEN
i_end = ide - 2
ELSE
i_end = ite
END IF
END IF
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
! Un-"canceled" map scale factor, ADT Eq. 48
tendencyd(i, k, j) = tendencyd(i, k, j) - msftx(i, j)*rdx*(fqxd(&
& i+1, k, j)-fqxd(i, k, j)+fqxld(i+1, k, j)-fqxld(i, k, j))
tendency(i, k, j) = tendency(i, k, j) - msftx(i, j)*(rdx*(fqx(i+&
& 1, k, j)-fqx(i, k, j)+fqxl(i+1, k, j)-fqxl(i, k, j)))
END DO
END DO
END DO
! y flux divergence
!
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
END IF
DO j=j_start,j_end
DO k=kts,ktf
DO i=i_start,i_end
! Un-"canceled" map scale factor, ADT Eq. 48
! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
tendencyd(i, k, j) = tendencyd(i, k, j) - msftx(i, j)*rdy*(fqyd(&
& i, k, j+1)-fqyd(i, k, j)+fqyld(i, k, j+1)-fqyld(i, k, j))
tendency(i, k, j) = tendency(i, k, j) - msftx(i, j)*(rdy*(fqy(i&
& , k, j+1)-fqy(i, k, j)+fqyl(i, k, j+1)-fqyl(i, k, j)))
END DO
END DO
END DO
END SUBROUTINE G_ADVECT_SCALAR_WENOPD
SUBROUTINE g_advect_scalar_mono(field,g_field,field_old,g_field_old, &
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, &
g_mu_old,config_flags,tenddec,msfux,msfuy,msfvx,msfvy,msftx,msfty,fzm,fzp,rdx,rdy,rdzw,dt, &
ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
IMPLICIT NONE
REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
g_Tmpv5,Tmpv6,g_Tmpv6,Tmpv7,g_Tmpv7,Tmpv8,g_Tmpv8
REAL g_FuncVal1,FuncVal1
TYPE(grid_config_rec_type) :: config_flags
LOGICAL :: tenddec
INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field,field_old,g_field_old, &
ru,g_ru,rv,g_rv,rom,g_rom
REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut,mub,mu_old,g_mu_old
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: h_tendency, z_tendency
REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: g_h_tendency, g_z_tendency
REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty
REAL,DIMENSION(kms:kme) :: fzm,fzp,rdzw
REAL :: rdx,rdy,dt
INTEGER :: i,j,k,itf,jtf,ktf
INTEGER :: i_start,i_end,j_start,j_end
INTEGER :: i_start_f,i_end_f,j_start_f,j_end_f
INTEGER :: jmin,jmax,jp,jm,imin,imax
REAL :: mrdx,g_mrdx,mrdy,g_mrdy,ub,g_ub,vb,g_vb,uw,g_uw,vw,g_vw,mu,g_mu
REAL,DIMENSION(its:ite,kts:kte) :: vflux,g_vflux
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: fqx,g_fqx,fqy,g_fqy,fqz,g_fqz
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: fqxl,g_fqxl,fqyl,g_fqyl, &
fqzl,g_fqzl
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: qmin,g_qmin,qmax,g_qmax
REAL,DIMENSION(its-2:ite+2,kts:kte,jts-2:jte+2) :: scale_in,g_scale_in,scale_out, &
g_scale_out
REAL :: ph_upwind,g_ph_upwind
INTEGER :: horz_order,vert_order
LOGICAL :: degrade_xs,degrade_ys
LOGICAL :: degrade_xe,degrade_ye
INTEGER :: jp1,jp0,jtmp
REAL :: flux_out,g_flux_out,ph_low,g_ph_low,flux_in,g_flux_in,ph_hi, &
g_ph_hi,scale,g_scale
REAL,PARAMETER :: eps =1.e-20
REAL :: flux3,g_flux3,flux4,g_flux4,flux5,g_flux5,flux6,g_flux6, &
flux_upwind,g_flux_upwind
REAL :: q_im3,g_q_im3,q_im2,g_q_im2,q_im1,g_q_im1,q_i,g_q_i,q_ip1, &
g_q_ip1,q_ip2,g_q_ip2,ua,g_ua,vel,g_vel,cr,g_cr
! Revised by Ning Pan, 2010-07-25
! g_flux4(g_q_im2, q_im2,g_q_im1, q_im1,g_q_i, q_i,g_q_ip1, q_ip1, &
! g_ua, ua) =(7./12.)*(g_q_i +g_q_im1) -(1./12.)*(g_q_ip1 +g_q_im2)
g_flux4(q_im2, g_q_im2,q_im1, g_q_im1,q_i, g_q_i,q_ip1, g_q_ip1, &
ua, g_ua) =(7./12.)*(g_q_i +g_q_im1) -(1./12.)*(g_q_ip1 +g_q_im2)
flux4(q_im2,q_im1,q_i,q_ip1,ua) =(7./12.)*(q_i +q_im1) -(1./12.)*(q_ip1 +q_im2)
! Revised by Ning Pan, 2010-07-25
! g_flux3(g_q_im2, q_im2,g_q_im1, q_im1,g_q_i, q_i,g_q_ip1, q_ip1, &
! g_ua, ua) =g_flux4(q_im2,g_q_im2,q_im1,g_q_im1,q_i,g_q_i,q_ip1, &
g_flux3(q_im2, g_q_im2,q_im1, g_q_im1,q_i, g_q_i,q_ip1, g_q_ip1, &
ua, g_ua) =g_flux4(q_im2,g_q_im2,q_im1,g_q_im1,q_i,g_q_i,q_ip1, &
g_q_ip1,ua,g_ua) +sign(1., ua) *(1./12.)*((g_q_ip1 -g_q_im2) &
-3.*(g_q_i -g_q_im1))
flux3(q_im2,q_im1,q_i,q_ip1,ua) =flux4(q_im2,q_im1,q_i,q_ip1,ua) +sign(1., ua) &
*(1./12.)*((q_ip1 -q_im2) -3.*(q_i -q_im1))
! Revised by Ning Pan, 2010-07-25
! g_flux6(g_q_im3, q_im3,g_q_im2, q_im2,g_q_im1, q_im1,g_q_i, q_i, &
! g_q_ip1, q_ip1,g_q_ip2, q_ip2,g_ua, ua) =(37./60.)*(g_q_i +g_q_im1) &
g_flux6(q_im3, g_q_im3,q_im2, g_q_im2,q_im1, g_q_im1,q_i, g_q_i, &
q_ip1, g_q_ip1,q_ip2, g_q_ip2,ua, g_ua) =(37./60.)*(g_q_i +g_q_im1) &
-(2./15.)*(g_q_ip1 +g_q_im2) +(1./60.)*(g_q_ip2 +g_q_im3)
flux6(q_im3,q_im2,q_im1,q_i,q_ip1,q_ip2,ua) =(37./60.)*(q_i +q_im1) -(2./15.) &
*(q_ip1 +q_im2) +(1./60.)*(q_ip2 +q_im3)
! Revised by Ning Pan, 2010-07-25
! g_flux5(g_q_im3, q_im3,g_q_im2, q_im2,g_q_im1, q_im1,g_q_i, q_i, &
! g_q_ip1, q_ip1,g_q_ip2, q_ip2,g_ua, ua) =g_flux6(q_im3,g_q_im3,q_im2, &
g_flux5(q_im3, g_q_im3,q_im2, g_q_im2,q_im1, g_q_im1,q_i, g_q_i, &
q_ip1, g_q_ip1,q_ip2, g_q_ip2,ua, g_ua) =g_flux6(q_im3,g_q_im3,q_im2, &
g_q_im2,q_im1,g_q_im1,q_i,g_q_i,q_ip1,g_q_ip1,q_ip2,g_q_ip2,ua, &
g_ua) -sign(1., ua) *(1./60.)*((g_q_ip2 -g_q_im3) -5.*(g_q_ip1 - &
g_q_im2) +10.*(g_q_i -g_q_im1))
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, &
ua) -sign(1., ua) *(1./60.)*((q_ip2 -q_im3) -5.*(q_ip1 -q_im2) +10.*(q_i -q_im1))
! Revised by Ning Pan, 2010-07-25
! g_flux_upwind(g_q_im1, q_im1,g_q_i, q_i,g_cr, cr) =0.5 *(1.+sign(1., cr)) &
g_flux_upwind(q_im1, g_q_im1,q_i, g_q_i,cr, g_cr) =0.5 *(1.+sign(1., cr)) &
*g_q_im1 +0.5 *(1.-sign(1., cr))*g_q_i
flux_upwind(q_im1,q_i,cr) =0.5 *(1.+sign(1., cr))*q_im1 +0.5 *(1.-sign(1., cr))*q_i
LOGICAL,PARAMETER :: mono_limit =.true.
ktf =min(kte,kde-1)
horz_order =config_flags%h_sca_adv_order
vert_order =config_flags%v_sca_adv_order
! Added by Ning Pan, 2010-07-27
degrade_xs =.true.
degrade_xe =.true.
degrade_ys =.true.
degrade_ye =.true.
IF( config_flags%periodic_x .or. &
config_flags%symmetric_xs .or. &
(its > ids+3) ) degrade_xs =.false.
IF( config_flags%periodic_x .or. &
config_flags%symmetric_xe .or. &
(ite < ide-4) ) degrade_xe =.false.
IF( config_flags%periodic_y .or. &
config_flags%symmetric_ys .or. &
(jts > jds+3) ) degrade_ys =.false.
IF( config_flags%periodic_y .or. &
config_flags%symmetric_ye .or. &
(jte < jde-4) ) degrade_ye =.false.
DO j =jts-2,jte+2
DO k =kts,kte
DO i =its-2,ite+2
g_qmin(i,k,j) =g_field_old(i,k,j)
qmin(i,k,j) =field_old(i,k,j)
g_qmax(i,k,j) =g_field_old(i,k,j)
qmax(i,k,j) =field_old(i,k,j)
g_scale_in(i,k,j) =0.0
scale_in(i,k,j) =1.
g_scale_out(i,k,j) =0.0
scale_out(i,k,j) =1.
g_fqx(i,k,j) =0.0
fqx(i,k,j) =0.
g_fqy(i,k,j) =0.0
fqy(i,k,j) =0.
g_fqz(i,k,j) =0.0
fqz(i,k,j) =0.
g_fqxl(i,k,j) =0.0
fqxl(i,k,j) =0.
g_fqyl(i,k,j) =0.0
fqyl(i,k,j) =0.
g_fqzl(i,k,j) =0.0
fqzl(i,k,j) =0.
ENDDO
ENDDO
ENDDO
IF( horz_order == 5 ) THEN
! degrade_xs =.true.
! degrade_xe =.true.
! degrade_ys =.true.
! degrade_ye =.true.
! IF( config_flags%periodic_x .or. &
! config_flags%symmetric_xs .or. &
! (its > ids+3) ) degrade_xs =.false.
! IF( config_flags%periodic_x .or. &
! config_flags%symmetric_xe .or. &
! (ite < ide-4) ) degrade_xe =.false.
! IF( config_flags%periodic_y .or. &
! config_flags%symmetric_ys .or. &
! (jts > jds+3) ) degrade_ys =.false.
! IF( config_flags%periodic_y .or. &
! config_flags%symmetric_ye .or. &
! (jte < jde-4) ) degrade_ye =.false.
ktf =min(kte,kde-1)
i_start =its-1
i_end =min(ite,ide-1) +1
j_start =jts-1
j_end =min(jte,jde-1) +1
j_start_f =j_start
j_end_f =j_end+1
IF(degrade_xs) i_start =max(its-1,ids)
IF(degrade_xe) i_end =min(ite+1,ide-1)
IF(degrade_ys) THEN
j_start =max(jts-1,jds+1)
j_start_f =jds+3
ENDIF
IF(degrade_ye) THEN
j_end =min(jte+1,jde-2)
j_end_f =jde-3
ENDIF
DO j =j_start,j_end+1
IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN
DO k =kts,ktf
DO i =i_start,i_end
g_vel =g_rv(i,k,j)
vel =rv(i,k,j)
g_cr =g_vel
cr =vel
g_FuncVal1=g_flux_upwind(field_old(i,k,j-1),g_field_old(i,k,j-1) &
,field_old(i,k,j),g_field_old(i,k,j),vel,g_vel)
FuncVal1 =flux_upwind(field_old(i,k,j-1),field_old(i,k,j),vel)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqyl(i,k,j) =g_Tmpv1
fqyl(i,k,j) =Tmpv1
g_FuncVal1=g_flux5(field(i,k,j-3),g_field(i,k,j-3),field(i,k,j-2) &
,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, &
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)
FuncVal1 =flux5(field(i,k,j-3),field(i,k,j-2),field(i,k,j-1),field(i,k,j) &
,field(i,k,j+1),field(i,k,j+2),vel)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqy(i,k,j) =g_Tmpv1
fqy(i,k,j) =Tmpv1
g_fqy(i,k,j) =g_fqy(i,k,j) -g_fqyl(i,k,j)
fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k,j-1) +(g_qmax(i,k,j) &
-g_field_old(i,k,j-1))*sign(1.0, qmax(i,k,j) -(field_old(i,k,j-1))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k,j-1))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k,j-1) -(g_qmin(i,k,j) &
-g_field_old(i,k,j-1))*sign(1.0, qmin(i,k,j) -(field_old(i,k,j-1))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k,j-1))
else
g_qmax(i,k,j-1) =(g_qmax(i,k,j-1) +g_field_old(i,k,j) +(g_qmax(i,k,j-1) &
-g_field_old(i,k,j))*sign(1.0, qmax(i,k,j-1) -(field_old(i,k,j))))*0.5
qmax(i,k,j-1) =max(qmax(i,k,j-1),field_old(i,k,j))
g_qmin(i,k,j-1) =(g_qmin(i,k,j-1) +g_field_old(i,k,j) -(g_qmin(i,k,j-1) &
-g_field_old(i,k,j))*sign(1.0, qmin(i,k,j-1) -(field_old(i,k,j))))*0.5
qmin(i,k,j-1) =min(qmin(i,k,j-1),field_old(i,k,j))
end IF
ENDDO
ENDDO
ELSE IF( j == jds+1 ) THEN
DO k =kts,ktf
DO i =i_start,i_end
g_vel =g_rv(i,k,j)
vel =rv(i,k,j)
g_cr =g_vel
cr =vel
g_FuncVal1=g_flux_upwind(field_old(i,k,j-1),g_field_old(i,k,j-1) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqyl(i,k,j) =g_Tmpv1
fqyl(i,k,j) =Tmpv1
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, &
j)*(field(i,k,j) +field(i,k,j-1))
Tmpv1 =0.5*rv(i,k,j)*(field(i,k,j) +field(i,k,j-1))
g_fqy(i,k,j) =g_Tmpv1
fqy(i,k,j) =Tmpv1
g_fqy(i,k,j) =g_fqy(i,k,j) -g_fqyl(i,k,j)
fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k,j-1) +(g_qmax(i,k,j) &
-g_field_old(i,k,j-1))*sign(1.0, qmax(i,k,j) -(field_old(i,k,j-1))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k,j-1))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k,j-1) -(g_qmin(i,k,j) &
-g_field_old(i,k,j-1))*sign(1.0, qmin(i,k,j) -(field_old(i,k,j-1))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k,j-1))
else
g_qmax(i,k,j-1) =(g_qmax(i,k,j-1) +g_field_old(i,k,j) +(g_qmax(i,k,j-1) &
-g_field_old(i,k,j))*sign(1.0, qmax(i,k,j-1) -(field_old(i,k,j))))*0.5
qmax(i,k,j-1) =max(qmax(i,k,j-1),field_old(i,k,j))
g_qmin(i,k,j-1) =(g_qmin(i,k,j-1) +g_field_old(i,k,j) -(g_qmin(i,k,j-1) &
-g_field_old(i,k,j))*sign(1.0, qmin(i,k,j-1) -(field_old(i,k,j))))*0.5
qmin(i,k,j-1) =min(qmin(i,k,j-1),field_old(i,k,j))
end IF
ENDDO
ENDDO
ELSE IF( j == jds+2 ) THEN
DO k =kts,ktf
DO i =i_start,i_end
g_vel =g_rv(i,k,j)
vel =rv(i,k,j)
g_cr =g_vel
cr =vel
g_FuncVal1=g_flux_upwind(field_old(i,k,j-1),g_field_old(i,k,j-1) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqyl(i,k,j) =g_Tmpv1
fqyl(i,k,j) =Tmpv1
g_FuncVal1=g_flux3(field(i,k,j-2),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,j),field(i,k,j+1),g_field(i,k,j+ &
1),vel,g_vel)
FuncVal1 =flux3(field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqy(i,k,j) =g_Tmpv1
fqy(i,k,j) =Tmpv1
g_fqy(i,k,j) =g_fqy(i,k,j) -g_fqyl(i,k,j)
fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k,j-1) +(g_qmax(i,k,j) &
-g_field_old(i,k,j-1))*sign(1.0, qmax(i,k,j) -(field_old(i,k,j-1))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k,j-1))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k,j-1) -(g_qmin(i,k,j) &
-g_field_old(i,k,j-1))*sign(1.0, qmin(i,k,j) -(field_old(i,k,j-1))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k,j-1))
else
g_qmax(i,k,j-1) =(g_qmax(i,k,j-1) +g_field_old(i,k,j) +(g_qmax(i,k,j-1) &
-g_field_old(i,k,j))*sign(1.0, qmax(i,k,j-1) -(field_old(i,k,j))))*0.5
qmax(i,k,j-1) =max(qmax(i,k,j-1),field_old(i,k,j))
g_qmin(i,k,j-1) =(g_qmin(i,k,j-1) +g_field_old(i,k,j) -(g_qmin(i,k,j-1) &
-g_field_old(i,k,j))*sign(1.0, qmin(i,k,j-1) -(field_old(i,k,j))))*0.5
qmin(i,k,j-1) =min(qmin(i,k,j-1),field_old(i,k,j))
end IF
ENDDO
ENDDO
ELSE IF( j == jde-1 ) THEN
DO k =kts,ktf
DO i =i_start,i_end
g_vel =g_rv(i,k,j)
vel =rv(i,k,j)
g_cr =g_vel
cr =vel
g_FuncVal1=g_flux_upwind(field_old(i,k,j-1),g_field_old(i,k,j-1) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqyl(i,k,j) =g_Tmpv1
fqyl(i,k,j) =Tmpv1
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, &
j)*(field(i,k,j) +field(i,k,j-1))
Tmpv1 =0.5*rv(i,k,j)*(field(i,k,j) +field(i,k,j-1))
g_fqy(i,k,j) =g_Tmpv1
fqy(i,k,j) =Tmpv1
g_fqy(i,k,j) =g_fqy(i,k,j) -g_fqyl(i,k,j)
fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k,j-1) +(g_qmax(i,k,j) &
-g_field_old(i,k,j-1))*sign(1.0, qmax(i,k,j) -(field_old(i,k,j-1))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k,j-1))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k,j-1) -(g_qmin(i,k,j) &
-g_field_old(i,k,j-1))*sign(1.0, qmin(i,k,j) -(field_old(i,k,j-1))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k,j-1))
else
g_qmax(i,k,j-1) =(g_qmax(i,k,j-1) +g_field_old(i,k,j) +(g_qmax(i,k,j-1) &
-g_field_old(i,k,j))*sign(1.0, qmax(i,k,j-1) -(field_old(i,k,j))))*0.5
qmax(i,k,j-1) =max(qmax(i,k,j-1),field_old(i,k,j))
g_qmin(i,k,j-1) =(g_qmin(i,k,j-1) +g_field_old(i,k,j) -(g_qmin(i,k,j-1) &
-g_field_old(i,k,j))*sign(1.0, qmin(i,k,j-1) -(field_old(i,k,j))))*0.5
qmin(i,k,j-1) =min(qmin(i,k,j-1),field_old(i,k,j))
end IF
ENDDO
ENDDO
ELSE IF( j == jde-2 ) THEN
DO k =kts,ktf
DO i =i_start,i_end
g_vel =g_rv(i,k,j)
vel =rv(i,k,j)
g_cr =g_vel
cr =vel
g_FuncVal1=g_flux_upwind(field_old(i,k,j-1),g_field_old(i,k,j-1) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i,k,j-1),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqyl(i,k,j) =g_Tmpv1
fqyl(i,k,j) =Tmpv1
g_FuncVal1=g_flux3(field(i,k,j-2),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,j),field(i,k,j+1),g_field(i,k,j+ &
1),vel,g_vel)
FuncVal1 =flux3(field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqy(i,k,j) =g_Tmpv1
fqy(i,k,j) =Tmpv1
g_fqy(i,k,j) =g_fqy(i,k,j) -g_fqyl(i,k,j)
fqy(i,k,j) =fqy(i,k,j) -fqyl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k,j-1) +(g_qmax(i,k,j) &
-g_field_old(i,k,j-1))*sign(1.0, qmax(i,k,j) -(field_old(i,k,j-1))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k,j-1))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k,j-1) -(g_qmin(i,k,j) &
-g_field_old(i,k,j-1))*sign(1.0, qmin(i,k,j) -(field_old(i,k,j-1))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k,j-1))
else
g_qmax(i,k,j-1) =(g_qmax(i,k,j-1) +g_field_old(i,k,j) +(g_qmax(i,k,j-1) &
-g_field_old(i,k,j))*sign(1.0, qmax(i,k,j-1) -(field_old(i,k,j))))*0.5
qmax(i,k,j-1) =max(qmax(i,k,j-1),field_old(i,k,j))
g_qmin(i,k,j-1) =(g_qmin(i,k,j-1) +g_field_old(i,k,j) -(g_qmin(i,k,j-1) &
-g_field_old(i,k,j))*sign(1.0, qmin(i,k,j-1) -(field_old(i,k,j))))*0.5
qmin(i,k,j-1) =min(qmin(i,k,j-1),field_old(i,k,j))
end IF
ENDDO
ENDDO
ENDIF
ENDDO
i_start =its-1
i_end =min(ite,ide-1) +1
i_start_f =i_start
i_end_f =i_end+1
j_start =jts-1
j_end =min(jte,jde-1) +1
IF(degrade_ys) j_start =max(jts-1,jds)
IF(degrade_ye) j_end =min(jte+1,jde-1)
IF(degrade_xs) THEN
i_start =max(ids+1,its-1)
i_start_f =ids+3
ENDIF
IF(degrade_xe) THEN
i_end =min(ide-2,ite+1)
i_end_f =ide-3
ENDIF
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start_f,i_end_f
g_vel =g_ru(i,k,j)
vel =ru(i,k,j)
g_cr =g_vel
cr =vel
g_FuncVal1=g_flux_upwind(field_old(i-1,k,j),g_field_old(i-1,k,j) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqxl(i,k,j) =g_Tmpv1
fqxl(i,k,j) =Tmpv1
g_FuncVal1=g_flux5(field(i-3,k,j),g_field(i-3,k,j),field(i-2,k,j) &
,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, &
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)
FuncVal1 =flux5(field(i-3,k,j),field(i-2,k,j),field(i-1,k,j),field(i,k,j) &
,field(i+1,k,j),field(i+2,k,j),vel)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqx(i,k,j) =g_Tmpv1
fqx(i,k,j) =Tmpv1
g_fqx(i,k,j) =g_fqx(i,k,j) -g_fqxl(i,k,j)
fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i-1,k,j) +(g_qmax(i,k,j) &
-g_field_old(i-1,k,j))*sign(1.0, qmax(i,k,j) -(field_old(i-1,k,j))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i-1,k,j))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i-1,k,j) -(g_qmin(i,k,j) &
-g_field_old(i-1,k,j))*sign(1.0, qmin(i,k,j) -(field_old(i-1,k,j))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i-1,k,j))
else
g_qmax(i-1,k,j) =(g_qmax(i-1,k,j) +g_field_old(i,k,j) +(g_qmax(i-1,k,j) &
-g_field_old(i,k,j))*sign(1.0, qmax(i-1,k,j) -(field_old(i,k,j))))*0.5
qmax(i-1,k,j) =max(qmax(i-1,k,j),field_old(i,k,j))
g_qmin(i-1,k,j) =(g_qmin(i-1,k,j) +g_field_old(i,k,j) -(g_qmin(i-1,k,j) &
-g_field_old(i,k,j))*sign(1.0, qmin(i-1,k,j) -(field_old(i,k,j))))*0.5
qmin(i-1,k,j) =min(qmin(i-1,k,j),field_old(i,k,j))
end IF
ENDDO
ENDDO
IF( degrade_xs ) THEN
DO i =i_start,i_start_f-1
IF(i == ids+1) THEN
DO k =kts,ktf
g_vel =g_ru(i,k,j)
vel =ru(i,k,j)
g_cr =g_vel
cr =vel
g_FuncVal1=g_flux_upwind(field_old(i-1,k,j),g_field_old(i-1,k,j) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqxl(i,k,j) =g_Tmpv1
fqxl(i,k,j) =Tmpv1
g_Tmpv1 =0.5*(ru(i,k,j))*(g_field(i,k,j) +g_field(i-1,k,j)) +0.5*(g_ru( &
i,k,j))*(field(i,k,j) +field(i-1,k,j))
Tmpv1 =0.5*(ru(i,k,j))*(field(i,k,j) +field(i-1,k,j))
g_fqx(i,k,j) =g_Tmpv1
fqx(i,k,j) =Tmpv1
g_fqx(i,k,j) =g_fqx(i,k,j) -g_fqxl(i,k,j)
fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i-1,k,j) +(g_qmax(i,k,j) &
-g_field_old(i-1,k,j))*sign(1.0, qmax(i,k,j) -(field_old(i-1,k,j))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i-1,k,j))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i-1,k,j) -(g_qmin(i,k,j) &
-g_field_old(i-1,k,j))*sign(1.0, qmin(i,k,j) -(field_old(i-1,k,j))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i-1,k,j))
else
g_qmax(i-1,k,j) =(g_qmax(i-1,k,j) +g_field_old(i,k,j) +(g_qmax(i-1,k,j) &
-g_field_old(i,k,j))*sign(1.0, qmax(i-1,k,j) -(field_old(i,k,j))))*0.5
qmax(i-1,k,j) =max(qmax(i-1,k,j),field_old(i,k,j))
g_qmin(i-1,k,j) =(g_qmin(i-1,k,j) +g_field_old(i,k,j) -(g_qmin(i-1,k,j) &
-g_field_old(i,k,j))*sign(1.0, qmin(i-1,k,j) -(field_old(i,k,j))))*0.5
qmin(i-1,k,j) =min(qmin(i-1,k,j),field_old(i,k,j))
end IF
ENDDO
ENDIF
IF(i == ids+2) THEN
DO k =kts,ktf
g_vel =g_ru(i,k,j)
vel =ru(i,k,j)
g_cr =g_vel
cr =vel
g_FuncVal1=g_flux_upwind(field_old(i-1,k,j),g_field_old(i-1,k,j) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqxl(i,k,j) =g_Tmpv1
fqxl(i,k,j) =Tmpv1
g_FuncVal1=g_flux3(field(i-2,k,j),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,j),field(i+1,k,j),g_field(i+1,k, &
j),vel,g_vel)
FuncVal1 =flux3(field(i-2,k,j),field(i-1,k,j),field(i,k,j),field(i+1,k,j),vel)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqx(i,k,j) =g_Tmpv1
fqx(i,k,j) =Tmpv1
g_fqx(i,k,j) =g_fqx(i,k,j) -g_fqxl(i,k,j)
fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i-1,k,j) +(g_qmax(i,k,j) &
-g_field_old(i-1,k,j))*sign(1.0, qmax(i,k,j) -(field_old(i-1,k,j))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i-1,k,j))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i-1,k,j) -(g_qmin(i,k,j) &
-g_field_old(i-1,k,j))*sign(1.0, qmin(i,k,j) -(field_old(i-1,k,j))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i-1,k,j))
else
g_qmax(i-1,k,j) =(g_qmax(i-1,k,j) +g_field_old(i,k,j) +(g_qmax(i-1,k,j) &
-g_field_old(i,k,j))*sign(1.0, qmax(i-1,k,j) -(field_old(i,k,j))))*0.5
qmax(i-1,k,j) =max(qmax(i-1,k,j),field_old(i,k,j))
g_qmin(i-1,k,j) =(g_qmin(i-1,k,j) +g_field_old(i,k,j) -(g_qmin(i-1,k,j) &
-g_field_old(i,k,j))*sign(1.0, qmin(i-1,k,j) -(field_old(i,k,j))))*0.5
qmin(i-1,k,j) =min(qmin(i-1,k,j),field_old(i,k,j))
end IF
ENDDO
ENDIF
ENDDO
ENDIF
IF( degrade_xe ) THEN
DO i =i_end_f+1,i_end+1
IF( i == ide-1 ) THEN
DO k =kts,ktf
g_vel =g_ru(i,k,j)
vel =ru(i,k,j)
g_cr =g_vel
cr =vel
g_FuncVal1=g_flux_upwind(field_old(i-1,k,j),g_field_old(i-1,k,j) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqxl(i,k,j) =g_Tmpv1
fqxl(i,k,j) =Tmpv1
g_Tmpv1 =0.5*(ru(i,k,j))*(g_field(i,k,j) +g_field(i-1,k,j)) +0.5*(g_ru( &
i,k,j))*(field(i,k,j) +field(i-1,k,j))
Tmpv1 =0.5*(ru(i,k,j))*(field(i,k,j) +field(i-1,k,j))
g_fqx(i,k,j) =g_Tmpv1
fqx(i,k,j) =Tmpv1
g_fqx(i,k,j) =g_fqx(i,k,j) -g_fqxl(i,k,j)
fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i-1,k,j) +(g_qmax(i,k,j) &
-g_field_old(i-1,k,j))*sign(1.0, qmax(i,k,j) -(field_old(i-1,k,j))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i-1,k,j))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i-1,k,j) -(g_qmin(i,k,j) &
-g_field_old(i-1,k,j))*sign(1.0, qmin(i,k,j) -(field_old(i-1,k,j))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i-1,k,j))
else
g_qmax(i-1,k,j) =(g_qmax(i-1,k,j) +g_field_old(i,k,j) +(g_qmax(i-1,k,j) &
-g_field_old(i,k,j))*sign(1.0, qmax(i-1,k,j) -(field_old(i,k,j))))*0.5
qmax(i-1,k,j) =max(qmax(i-1,k,j),field_old(i,k,j))
g_qmin(i-1,k,j) =(g_qmin(i-1,k,j) +g_field_old(i,k,j) -(g_qmin(i-1,k,j) &
-g_field_old(i,k,j))*sign(1.0, qmin(i-1,k,j) -(field_old(i,k,j))))*0.5
qmin(i-1,k,j) =min(qmin(i-1,k,j),field_old(i,k,j))
end IF
ENDDO
ENDIF
IF( i == ide-2 ) THEN
DO k =kts,ktf
g_vel =g_ru(i,k,j)
vel =ru(i,k,j)
g_cr =g_vel
cr =vel
g_FuncVal1=g_flux_upwind(field_old(i-1,k,j),g_field_old(i-1,k,j) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i-1,k,j),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqxl(i,k,j) =g_Tmpv1
fqxl(i,k,j) =Tmpv1
g_FuncVal1=g_flux3(field(i-2,k,j),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,j),field(i+1,k,j),g_field(i+1,k, &
j),vel,g_vel)
FuncVal1 =flux3(field(i-2,k,j),field(i-1,k,j),field(i,k,j),field(i+1,k,j),vel)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqx(i,k,j) =g_Tmpv1
fqx(i,k,j) =Tmpv1
g_fqx(i,k,j) =g_fqx(i,k,j) -g_fqxl(i,k,j)
fqx(i,k,j) =fqx(i,k,j) -fqxl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i-1,k,j) +(g_qmax(i,k,j) &
-g_field_old(i-1,k,j))*sign(1.0, qmax(i,k,j) -(field_old(i-1,k,j))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i-1,k,j))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i-1,k,j) -(g_qmin(i,k,j) &
-g_field_old(i-1,k,j))*sign(1.0, qmin(i,k,j) -(field_old(i-1,k,j))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i-1,k,j))
else
g_qmax(i-1,k,j) =(g_qmax(i-1,k,j) +g_field_old(i,k,j) +(g_qmax(i-1,k,j) &
-g_field_old(i,k,j))*sign(1.0, qmax(i-1,k,j) -(field_old(i,k,j))))*0.5
qmax(i-1,k,j) =max(qmax(i-1,k,j),field_old(i,k,j))
g_qmin(i-1,k,j) =(g_qmin(i-1,k,j) +g_field_old(i,k,j) -(g_qmin(i-1,k,j) &
-g_field_old(i,k,j))*sign(1.0, qmin(i-1,k,j) -(field_old(i,k,j))))*0.5
qmin(i-1,k,j) =min(qmin(i-1,k,j),field_old(i,k,j))
end IF
ENDDO
ENDIF
ENDDO
ENDIF
ENDDO
ELSE
! Revised by Ning Pan, 2010-07-25
! WRITE (wrf_err_message,*) 'module_advect: advect_scalar_mono, h_order not known ',horz_order
WRITE (wrf_err_message,*) 'g_module_advect: g_advect_scalar_mono, h_order not known ',horz_order
!DELETED BY WALLS
!CALL g_wrf_error_fatal(Trim(wrf_err_message))
CALL wrf_error_fatal(Trim(wrf_err_message)) ! Added by Ning Pan, 2010-07-25
ENDIF
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
IF( (config_flags%open_xs) .and. (its == ids) ) THEN
DO j =j_start,j_end
DO k =kts,ktf
g_ub =(0.5*(g_ru(its,k,j) +g_ru(its+1,k,j)) +0.0 -(0.5*(g_ru(its,k,j) &
+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
ub =min(0.5*(ru(its,k,j) +ru(its+1,k,j)),0.)
g_Tmpv1 =ub*(g_field_old(its+1,k,j) -g_field_old(its,k,j)) +g_ub*( &
field_old(its+1,k,j) -field_old(its,k,j))
Tmpv1 =ub*(field_old(its+1,k,j) -field_old(its,k,j))
g_Tmpv2 =field(its,k,j)*(g_ru(its+1,k,j) -g_ru(its,k,j)) +g_field(its,k, &
j)*(ru(its+1,k,j) -ru(its,k,j))
Tmpv2 =field(its,k,j)*(ru(its+1,k,j) -ru(its,k,j))
g_tendency(its,k,j) =g_tendency(its,k,j) -rdx*(g_Tmpv1 +g_Tmpv2)
tendency(its,k,j) =tendency(its,k,j) -rdx*(Tmpv1 +Tmpv2)
ENDDO
ENDDO
ENDIF
IF( (config_flags%open_xe) .and. (ite == ide) ) THEN
DO j =j_start,j_end
DO k =kts,ktf
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) &
+g_ru(ite,k,j)) -0.0)*sign(1.0, 0.5*(ru(ite-1,k,j) +ru(ite,k,j)) -(0.)))*0.5
ub =max(0.5*(ru(ite-1,k,j) +ru(ite,k,j)),0.)
g_Tmpv1 =ub*(g_field_old(i_end,k,j) -g_field_old(i_end-1,k,j)) &
+g_ub*(field_old(i_end,k,j) -field_old(i_end-1,k,j))
Tmpv1 =ub*(field_old(i_end,k,j) -field_old(i_end-1,k,j))
g_Tmpv2 =field(i_end,k,j)*(g_ru(ite,k,j) -g_ru(ite-1,k,j)) +g_field( &
i_end,k,j)*(ru(ite,k,j) -ru(ite-1,k,j))
Tmpv2 =field(i_end,k,j)*(ru(ite,k,j) -ru(ite-1,k,j))
g_tendency(i_end,k,j) =g_tendency(i_end,k,j) -rdx*(g_Tmpv1 +g_Tmpv2)
tendency(i_end,k,j) =tendency(i_end,k,j) -rdx*(Tmpv1 +Tmpv2)
ENDDO
ENDDO
ENDIF
IF( (config_flags%open_ys) .and. (jts == jds) ) THEN
DO i =i_start,i_end
DO k =kts,ktf
g_vb =(0.5*(g_rv(i,k,jts) +g_rv(i,k,jts+1)) +0.0 -(0.5*(g_rv(i,k,jts) &
+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
vb =min(0.5*(rv(i,k,jts) +rv(i,k,jts+1)),0.)
g_Tmpv1 =vb*(g_field_old(i,k,jts+1) -g_field_old(i,k,jts)) +g_vb*( &
field_old(i,k,jts+1) -field_old(i,k,jts))
Tmpv1 =vb*(field_old(i,k,jts+1) -field_old(i,k,jts))
g_Tmpv2 =field(i,k,jts)*(g_rv(i,k,jts+1) -g_rv(i,k,jts)) +g_field(i,k, &
jts)*(rv(i,k,jts+1) -rv(i,k,jts))
Tmpv2 =field(i,k,jts)*(rv(i,k,jts+1) -rv(i,k,jts))
g_tendency(i,k,jts) =g_tendency(i,k,jts) -rdy*(g_Tmpv1 +g_Tmpv2)
tendency(i,k,jts) =tendency(i,k,jts) -rdy*(Tmpv1 +Tmpv2)
ENDDO
ENDDO
ENDIF
IF( (config_flags%open_ye) .and. (jte == jde)) THEN
DO i =i_start,i_end
DO k =kts,ktf
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) &
+g_rv(i,k,jte)) -0.0)*sign(1.0, 0.5*(rv(i,k,jte-1) +rv(i,k,jte)) -(0.)))*0.5
vb =max(0.5*(rv(i,k,jte-1) +rv(i,k,jte)),0.)
g_Tmpv1 =vb*(g_field_old(i,k,j_end) -g_field_old(i,k,j_end-1)) &
+g_vb*(field_old(i,k,j_end) -field_old(i,k,j_end-1))
Tmpv1 =vb*(field_old(i,k,j_end) -field_old(i,k,j_end-1))
g_Tmpv2 =field(i,k,j_end)*(g_rv(i,k,jte) -g_rv(i,k,jte-1)) +g_field(i,k, &
j_end)*(rv(i,k,jte) -rv(i,k,jte-1))
Tmpv2 =field(i,k,j_end)*(rv(i,k,jte) -rv(i,k,jte-1))
g_tendency(i,k,j_end) =g_tendency(i,k,j_end) -rdy*(g_Tmpv1 +g_Tmpv2)
tendency(i,k,j_end) =tendency(i,k,j_end) -rdy*(Tmpv1 +Tmpv2)
ENDDO
ENDDO
ENDIF
i_start =its-1
i_end =min(ite,ide-1) +1
j_start =jts-1
j_end =min(jte,jde-1) +1
IF(degrade_xs) i_start =max(its-1,ids)
IF(degrade_xe) i_end =min(ite+1,ide-1)
IF(degrade_ys) j_start =max(jts-1,jds)
IF(degrade_ye) j_end =min(jte+1,jde-1)
IF(vert_order == 3) THEN
DO j =j_start,j_end
DO i =i_start,i_end
g_fqz(i,1,j) =0.0
fqz(i,1,j) =0.
g_fqzl(i,1,j) =0.0
fqzl(i,1,j) =0.
g_fqz(i,kde,j) =0.0
fqz(i,kde,j) =0.
g_fqzl(i,kde,j) =0.0
fqzl(i,kde,j) =0.
ENDDO
DO k =kts+2,ktf-1
DO i =i_start,i_end
g_vel =g_rom(i,k,j)
vel =rom(i,k,j)
g_cr =-g_vel
cr =-vel
g_FuncVal1=g_flux_upwind(field_old(i,k-1,j),g_field_old(i,k-1,j) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqzl(i,k,j) =g_Tmpv1
fqzl(i,k,j) =Tmpv1
g_FuncVal1=g_flux3(field(i,k-2,j),g_field(i,k-2,j),field(i,k-1,j) &
,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, &
j),-vel,-g_vel)
FuncVal1 =flux3(field(i,k-2,j),field(i,k-1,j),field(i,k,j),field(i,k+1,j),-vel)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqz(i,k,j) =g_Tmpv1
fqz(i,k,j) =Tmpv1
g_fqz(i,k,j) =g_fqz(i,k,j) -g_fqzl(i,k,j)
fqz(i,k,j) =fqz(i,k,j) -fqzl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k-1,j) +(g_qmax(i,k,j) &
-g_field_old(i,k-1,j))*sign(1.0, qmax(i,k,j) -(field_old(i,k-1,j))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k-1,j))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k-1,j) -(g_qmin(i,k,j) &
-g_field_old(i,k-1,j))*sign(1.0, qmin(i,k,j) -(field_old(i,k-1,j))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k-1,j))
else
g_qmax(i,k-1,j) =(g_qmax(i,k-1,j) +g_field_old(i,k,j) +(g_qmax(i,k-1,j) &
-g_field_old(i,k,j))*sign(1.0, qmax(i,k-1,j) -(field_old(i,k,j))))*0.5
qmax(i,k-1,j) =max(qmax(i,k-1,j),field_old(i,k,j))
g_qmin(i,k-1,j) =(g_qmin(i,k-1,j) +g_field_old(i,k,j) -(g_qmin(i,k-1,j) &
-g_field_old(i,k,j))*sign(1.0, qmin(i,k-1,j) -(field_old(i,k,j))))*0.5
qmin(i,k-1,j) =min(qmin(i,k-1,j),field_old(i,k,j))
end IF
ENDDO
ENDDO
DO i =i_start,i_end
k =kts+1
g_vel =g_rom(i,k,j)
vel =rom(i,k,j)
g_cr =-g_vel
cr =-vel
g_FuncVal1=g_flux_upwind(field_old(i,k-1,j),g_field_old(i,k-1,j) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqzl(i,k,j) =g_Tmpv1
fqzl(i,k,j) =Tmpv1
g_Tmpv1 =rom(i,k,j)*(fzm(k)*g_field(i,k,j) +fzp(k)*g_field(i,k-1,j)) &
+g_rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j))
Tmpv1 =rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j))
g_fqz(i,k,j) =g_Tmpv1
fqz(i,k,j) =Tmpv1
g_fqz(i,k,j) =g_fqz(i,k,j) -g_fqzl(i,k,j)
fqz(i,k,j) =fqz(i,k,j) -fqzl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k-1,j) +(g_qmax(i,k,j) &
-g_field_old(i,k-1,j))*sign(1.0, qmax(i,k,j) -(field_old(i,k-1,j))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k-1,j))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k-1,j) -(g_qmin(i,k,j) &
-g_field_old(i,k-1,j))*sign(1.0, qmin(i,k,j) -(field_old(i,k-1,j))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k-1,j))
else
g_qmax(i,k-1,j) =(g_qmax(i,k-1,j) +g_field_old(i,k,j) +(g_qmax(i,k-1,j) &
-g_field_old(i,k,j))*sign(1.0, qmax(i,k-1,j) -(field_old(i,k,j))))*0.5
qmax(i,k-1,j) =max(qmax(i,k-1,j),field_old(i,k,j))
g_qmin(i,k-1,j) =(g_qmin(i,k-1,j) +g_field_old(i,k,j) -(g_qmin(i,k-1,j) &
-g_field_old(i,k,j))*sign(1.0, qmin(i,k-1,j) -(field_old(i,k,j))))*0.5
qmin(i,k-1,j) =min(qmin(i,k-1,j),field_old(i,k,j))
end IF
k =ktf
g_vel =g_rom(i,k,j)
vel =rom(i,k,j)
g_cr =-g_vel
cr =-vel
g_FuncVal1=g_flux_upwind(field_old(i,k-1,j),g_field_old(i,k-1,j) &
,field_old(i,k,j),g_field_old(i,k,j),cr,g_cr)
FuncVal1 =flux_upwind(field_old(i,k-1,j),field_old(i,k,j),cr)
g_Tmpv1 =vel*g_FuncVal1 +g_vel*FuncVal1
Tmpv1 =vel*FuncVal1
g_fqzl(i,k,j) =g_Tmpv1
fqzl(i,k,j) =Tmpv1
g_Tmpv1 =rom(i,k,j)*(fzm(k)*g_field(i,k,j) +fzp(k)*g_field(i,k-1,j)) &
+g_rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j))
Tmpv1 =rom(i,k,j)*(fzm(k)*field(i,k,j) +fzp(k)*field(i,k-1,j))
g_fqz(i,k,j) =g_Tmpv1
fqz(i,k,j) =Tmpv1
g_fqz(i,k,j) =g_fqz(i,k,j) -g_fqzl(i,k,j)
fqz(i,k,j) =fqz(i,k,j) -fqzl(i,k,j)
IF(cr.gt. 0) THEN
g_qmax(i,k,j) =(g_qmax(i,k,j) +g_field_old(i,k-1,j) +(g_qmax(i,k,j) &
-g_field_old(i,k-1,j))*sign(1.0, qmax(i,k,j) -(field_old(i,k-1,j))))*0.5
qmax(i,k,j) =max(qmax(i,k,j),field_old(i,k-1,j))
g_qmin(i,k,j) =(g_qmin(i,k,j) +g_field_old(i,k-1,j) -(g_qmin(i,k,j) &
-g_field_old(i,k-1,j))*sign(1.0, qmin(i,k,j) -(field_old(i,k-1,j))))*0.5
qmin(i,k,j) =min(qmin(i,k,j),field_old(i,k-1,j))
else
g_qmax(i,k-1,j) =(g_qmax(i,k-1,j) +g_field_old(i,k,j) +(g_qmax(i,k-1,j) &
-g_field_old(i,k,j))*sign(1.0, qmax(i,k-1,j) -(field_old(i,k,j))))*0.5
qmax(i,k-1,j) =max(qmax(i,k-1,j),field_old(i,k,j))
g_qmin(i,k-1,j) =(g_qmin(i,k-1,j) +g_field_old(i,k,j) -(g_qmin(i,k-1,j) &
-g_field_old(i,k,j))*sign(1.0, qmin(i,k-1,j) -(field_old(i,k,j))))*0.5
qmin(i,k-1,j) =min(qmin(i,k-1,j),field_old(i,k,j))
end IF
ENDDO
ENDDO
ELSE
! Revised by Ning Pan, 2010-07-25
! WRITE (wrf_err_message,*) ' advect_scalar_mono, v_order not known ',vert_order
WRITE (wrf_err_message,*) ' g_advect_scalar_mono, v_order not known ',vert_order
!DELETED BY WALLS
!CALL g_wrf_error_fatal(wrf_err_message)
CALL wrf_error_fatal(wrf_err_message) ! Added by Ning Pan, 2010-07-25
ENDIF
IF(mono_limit) THEN
i_start =its-1
i_end =min(ite,ide-1) +1
j_start =jts-1
j_end =min(jte,jde-1) +1
IF(degrade_xs) i_start =max(its-1,ids)
IF(degrade_xe) i_end =min(ite+1,ide-1)
IF(degrade_ys) j_start =max(jts-1,jds)
IF(degrade_ye) j_end =min(jte+1,jde-1)
IF(config_flags%specified .or. config_flags%nested) THEN
IF(degrade_xs) i_start =max(its-1,ids+1)
IF(degrade_xe) i_end =min(ite+1,ide-2)
IF(degrade_ys) j_start =max(jts-1,jds+1)
IF(degrade_ye) j_end =min(jte+1,jde-2)
END IF
IF(config_flags%open_xs) THEN
IF(degrade_xs) i_start =max(its-1,ids+1)
END IF
IF(config_flags%open_xe) THEN
IF(degrade_xe) i_end =min(ite+1,ide-2)
END IF
IF(config_flags%open_ys) THEN
IF(degrade_ys) j_start =max(jts-1,jds+1)
END IF
IF(config_flags%open_ye) THEN
IF(degrade_ye) j_end =min(jte+1,jde-2)
END IF
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_Tmpv1 =(mub(i,j) +mu_old(i,j))*g_field_old(i,k,j) +(g_mu_old(i,j)) &
*field_old(i,k,j)
Tmpv1 =(mub(i,j) +mu_old(i,j))*field_old(i,k,j)
g_ph_upwind =g_Tmpv1 -dt*(msftx(i,j) *msfty(i,j)*(rdx*(g_fqxl(i+1,k,j) &
-g_fqxl(i,k,j)) +rdy*(g_fqyl(i,k,j+1) -g_fqyl(i,k,j))) +msfty(i,j) *rdzw(k) &
*(g_fqzl(i,k+1,j) -g_fqzl(i,k,j)))
ph_upwind =Tmpv1 -dt*(msftx(i,j) *msfty(i,j)*(rdx*(fqxl(i+1,k,j) -fqxl(i,k,j)) &
+rdy*(fqyl(i,k,j+1) -fqyl(i,k,j))) +msfty(i,j) *rdzw(k)*(fqzl(i,k+1,j) -fqzl(i,k,j)))
g_flux_in =-dt*((msftx(i,j) *msfty(i,j))*(rdx*((0.0 +g_fqx(i+1,k,j) &
-(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) &
+(0.0 -g_fqx(i,k,j))*sign(1.0, 0. -(fqx(i,k,j))))*0.5) +rdy*((0.0 +g_fqy(i,k, &
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, &
k,j) +(0.0 -g_fqy(i,k,j))*sign(1.0, 0. -(fqy(i,k,j))))*0.5)) +msfty(i,j) *rdzw(k) &
*((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)))) &
*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))
flux_in =-dt*((msftx(i,j) *msfty(i,j))*(rdx*(min(0.,fqx(i+1,k,j)) -max(0.,fqx(i,k, &
j))) +rdy*(min(0.,fqy(i,k,j+1)) -max(0.,fqy(i,k,j)))) +msfty(i,j) *rdzw(k) &
*(max(0.,fqz(i,k+1,j)) -min(0.,fqz(i,k,j))))
g_Tmpv1 =mut(i,j)*g_qmax(i,k,j) +g_mut(i,j)*qmax(i,k,j)
Tmpv1 =mut(i,j)*qmax(i,k,j)
g_ph_hi =g_Tmpv1 -g_ph_upwind
ph_hi =Tmpv1 -ph_upwind
g_Tmpv1 =(g_ph_hi*(flux_in +eps) -(g_flux_in)*ph_hi)/((flux_in +eps)*(flux_in +eps))
Tmpv1 =ph_hi/(flux_in +eps)
IF( flux_in .gt. ph_hi ) g_scale_in(i,k,j) =(0.0 +g_Tmpv1 +(0.0 -g_Tmpv1) &
*sign(1.0, 0. -(Tmpv1)))*0.5
IF( flux_in .gt. ph_hi ) scale_in(i,k,j) =max(0.,Tmpv1)
g_flux_out =dt*((msftx(i,j) *msfty(i,j))*(rdx*((0.0 +g_fqx(i+1,k,j) &
+(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) &
-(0.0 -g_fqx(i,k,j))*sign(1.0, 0. -(fqx(i,k,j))))*0.5) +rdy*((0.0 +g_fqy(i,k, &
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, &
k,j) -(0.0 -g_fqy(i,k,j))*sign(1.0, 0. -(fqy(i,k,j))))*0.5)) +msfty(i,j) *rdzw(k) &
*((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)))) &
*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))
flux_out =dt*((msftx(i,j) *msfty(i,j))*(rdx*(max(0.,fqx(i+1,k,j)) -min(0.,fqx(i,k, &
j))) +rdy*(max(0.,fqy(i,k,j+1)) -min(0.,fqy(i,k,j)))) +msfty(i,j) *rdzw(k) &
*(min(0.,fqz(i,k+1,j)) -max(0.,fqz(i,k,j))))
g_Tmpv1 =mut(i,j)*g_qmin(i,k,j) +g_mut(i,j)*qmin(i,k,j)
Tmpv1 =mut(i,j)*qmin(i,k,j)
g_ph_low =g_ph_upwind -g_Tmpv1
ph_low =ph_upwind -Tmpv1
g_Tmpv1 =(g_ph_low*(flux_out +eps) -(g_flux_out)*ph_low)/((flux_out +eps) &
*(flux_out +eps))
Tmpv1 =ph_low/(flux_out +eps)
IF( flux_out .gt. ph_low ) g_scale_out(i,k,j) =(0.0 +g_Tmpv1 +(0.0 -g_Tmpv1) &
*sign(1.0, 0. -(Tmpv1)))*0.5
IF( flux_out .gt. ph_low ) scale_out(i,k,j) =max(0.,Tmpv1)
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end+1
IF( fqx (i,k,j) .gt. 0.) THEN
g_Tmpv1 =min(scale_in(i,k,j),scale_out(i-1,k,j))*g_fqx(i,k,j) +(g_scale_in( &
i,k,j) +g_scale_out(i-1,k,j) -(g_scale_in(i,k,j) -g_scale_out(i-1,k,j)) &
*sign(1.0, scale_in(i,k,j) -(scale_out(i-1,k,j))))*0.5*fqx(i,k,j)
Tmpv1 =min(scale_in(i,k,j),scale_out(i-1,k,j))*fqx(i,k,j)
g_fqx(i,k,j) =g_Tmpv1
fqx(i,k,j) =Tmpv1
ELSE
g_Tmpv1 =min(scale_out(i,k,j),scale_in(i-1,k,j))*g_fqx(i,k,j) +( &
g_scale_out(i,k,j) +g_scale_in(i-1,k,j) -(g_scale_out(i,k,j) -g_scale_in( &
i-1,k,j))*sign(1.0, scale_out(i,k,j) -(scale_in(i-1,k,j))))*0.5*fqx(i,k,j)
Tmpv1 =min(scale_out(i,k,j),scale_in(i-1,k,j))*fqx(i,k,j)
g_fqx(i,k,j) =g_Tmpv1
fqx(i,k,j) =Tmpv1
ENDIF
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end+1
DO k =kts,ktf
DO i =i_start,i_end
IF( fqy (i,k,j) .gt. 0.) THEN
g_Tmpv1 =min(scale_in(i,k,j),scale_out(i,k,j-1))*g_fqy(i,k,j) +(g_scale_in( &
i,k,j) +g_scale_out(i,k,j-1) -(g_scale_in(i,k,j) -g_scale_out(i,k,j-1)) &
*sign(1.0, scale_in(i,k,j) -(scale_out(i,k,j-1))))*0.5*fqy(i,k,j)
Tmpv1 =min(scale_in(i,k,j),scale_out(i,k,j-1))*fqy(i,k,j)
g_fqy(i,k,j) =g_Tmpv1
fqy(i,k,j) =Tmpv1
ELSE
g_Tmpv1 =min(scale_out(i,k,j),scale_in(i,k,j-1))*g_fqy(i,k,j) +( &
g_scale_out(i,k,j) +g_scale_in(i,k,j-1) -(g_scale_out(i,k,j) -g_scale_in( &
i,k,j-1))*sign(1.0, scale_out(i,k,j) -(scale_in(i,k,j-1))))*0.5*fqy(i,k,j)
Tmpv1 =min(scale_out(i,k,j),scale_in(i,k,j-1))*fqy(i,k,j)
g_fqy(i,k,j) =g_Tmpv1
fqy(i,k,j) =Tmpv1
ENDIF
ENDDO
ENDDO
ENDDO
DO j =j_start,j_end
DO k =kts+1,ktf
DO i =i_start,i_end
IF( fqz (i,k,j) .lt. 0.) THEN
g_Tmpv1 =min(scale_in(i,k,j),scale_out(i,k-1,j))*g_fqz(i,k,j) +(g_scale_in( &
i,k,j) +g_scale_out(i,k-1,j) -(g_scale_in(i,k,j) -g_scale_out(i,k-1,j)) &
*sign(1.0, scale_in(i,k,j) -(scale_out(i,k-1,j))))*0.5*fqz(i,k,j)
Tmpv1 =min(scale_in(i,k,j),scale_out(i,k-1,j))*fqz(i,k,j)
g_fqz(i,k,j) =g_Tmpv1
fqz(i,k,j) =Tmpv1
ELSE
g_Tmpv1 =min(scale_out(i,k,j),scale_in(i,k-1,j))*g_fqz(i,k,j) +( &
g_scale_out(i,k,j) +g_scale_in(i,k-1,j) -(g_scale_out(i,k,j) -g_scale_in( &
i,k-1,j))*sign(1.0, scale_out(i,k,j) -(scale_in(i,k-1,j))))*0.5*fqz(i,k,j)
Tmpv1 =min(scale_out(i,k,j),scale_in(i,k-1,j))*fqz(i,k,j)
g_fqz(i,k,j) =g_Tmpv1
fqz(i,k,j) =Tmpv1
ENDIF
ENDDO
ENDDO
ENDDO
END IF
i_start =its
i_end =min(ite,ide-1)
j_start =jts
j_end =min(jte,jde-1)
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tendency(i,k,j) =g_tendency(i,k,j) -rdzw(k)*(g_fqz(i,k+1,j) -g_fqz(i,k, &
j) +g_fqzl(i,k+1,j) -g_fqzl(i,k,j))
tendency(i,k,j) =tendency(i,k,j) -rdzw(k)*(fqz(i,k+1,j) -fqz(i,k,j) +fqzl(i,k+1,j) &
-fqzl(i,k,j))
ENDDO
ENDDO
ENDDO
IF(tenddec) THEN
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end
g_z_tendency (i,k,j) = -rdzw(k)*( g_fqz (i,k+1,j)-g_fqz (i,k,j) &
+g_fqzl(i,k+1,j)-g_fqzl(i,k,j))
z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) &
+fqzl(i,k+1,j)-fqzl(i,k,j))
ENDDO
ENDDO
ENDDO
END IF
IF(degrade_xs) i_start =max(its,ids+1)
IF(degrade_xe) i_end =min(ite,ide-2)
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tendency(i,k,j) =g_tendency(i,k,j) -msftx(i,j)*(rdx*(g_fqx(i+1,k,j) &
-g_fqx(i,k,j) +g_fqxl(i+1,k,j) -g_fqxl(i,k,j)))
tendency(i,k,j) =tendency(i,k,j) -msftx(i,j)*(rdx*(fqx(i+1,k,j) -fqx(i,k,j) &
+fqxl(i+1,k,j) -fqxl(i,k,j)))
ENDDO
ENDDO
ENDDO
IF(tenddec) THEN
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end
g_h_tendency (i,k,j) = &
- msftx(i,j)*( rdx*( g_fqx (i+1,k,j)-g_fqx (i,k,j) &
+g_fqxl(i+1,k,j)-g_fqxl(i,k,j)) )
h_tendency (i,k,j) = 0. &
- msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) &
+fqxl(i+1,k,j)-fqxl(i,k,j)) )
ENDDO
ENDDO
ENDDO
END IF
i_start =its
i_end =min(ite,ide-1)
IF(degrade_ys) j_start =max(jts,jds+1)
IF(degrade_ye) j_end =min(jte,jde-2)
DO j =j_start,j_end
DO k =kts,ktf
DO i =i_start,i_end
g_tendency(i,k,j) =g_tendency(i,k,j) -msftx(i,j)*(rdy*(g_fqy(i,k,j+1) &
-g_fqy(i,k,j) +g_fqyl(i,k,j+1) -g_fqyl(i,k,j)))
tendency(i,k,j) =tendency(i,k,j) -msftx(i,j)*(rdy*(fqy(i,k,j+1) -fqy(i,k,j) &
+fqyl(i,k,j+1) -fqyl(i,k,j)))
ENDDO
ENDDO
ENDDO
IF(tenddec) THEN
DO j = j_start, j_end
DO k = kts, ktf
DO i = i_start, i_end
g_h_tendency (i,k,j) = g_h_tendency (i,k,j) &
- msftx(i,j)*( rdy*( g_fqy (i,k,j+1)-g_fqy (i,k,j) &
+g_fqyl(i,k,j+1)-g_fqyl(i,k,j)) )
h_tendency (i,k,j) = h_tendency (i,k,j) &
- msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) &
+fqyl(i,k,j+1)-fqyl(i,k,j)) )
ENDDO
ENDDO
ENDDO
END IF
END SUBROUTINE g_advect_scalar_mono
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.6 (r4165) - 21 sep 2011 20:54
!
! Differentiation of advect_scalar_weno in forward (tangent) mode:
! variations of useful results: tendency
! with respect to varying inputs: rom field tendency ru rv field_old
! RW status of diff variables: rom:in field:in tendency:in-out
! ru:in rv:in field_old:in
SUBROUTINE G_ADVECT_SCALAR_WENO(field, fieldd, field_old, field_oldd, &
& tendency, tendencyd, ru, rud, rv, rvd, rom, romd, mut, time_step, &
& config_flags, msfux, msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx&
& , rdy, rdzw, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, &
& kme, its, ite, jts, jte, kts, kte)
IMPLICIT NONE
! Input data
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, &
& field_old, ru, rv, rom
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: fieldd, &
& field_oldd, rud, rvd, romd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
& msfvy, msftx, msfty
REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
REAL, INTENT(IN) :: rdx, rdy
INTEGER, INTENT(IN) :: time_step
! Local data
INTEGER :: i, j, k, itf, jtf, ktf
INTEGER :: i_start, i_end, j_start, j_end
INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
INTEGER :: jmin, jmax, jp, jm, imin, imax
INTEGER, PARAMETER :: is=0, js=0, ks=0
REAL :: mrdx, mrdy, ub, vb, vw
REAL :: ubd, vbd
REAL, DIMENSION(its:ite, kts:kte) :: vflux
REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
REAL, DIMENSION(its - is:ite + 1, kts:kte) :: fqx
REAL, DIMENSION(its-is:ite+1, kts:kte) :: fqxd
! REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
INTEGER :: horz_order, vert_order
LOGICAL :: degrade_xs, degrade_ys
LOGICAL :: degrade_xe, degrade_ye
INTEGER :: jp1, jp0, jtmp
REAL :: dir, vv
REAL :: ue, uw, vs, vn, wb, wt
REAL, PARAMETER :: f30=7./12., f31=1./12.
REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
INTEGER :: kt, kb
REAL :: qim2, qim1, qi, qip1, qip2
REAL :: qim2d, qim1d, qid, qip1d, qip2d
DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
& sumwk
DOUBLE PRECISION :: beta0d, beta1d, beta2d, f0d, f1d, f2d, wi0d, wi1d&
& , wi2d, sumwkd
DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
& 3.d0/10.d0, eps=1.0d-28
INTEGER, PARAMETER :: pw=2
! definition of flux operators, 3rd, 4th, 5th or 6th order
REAL :: flux3, flux4, flux5, flux6
REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
REAL :: veld
LOGICAL :: specified
DOUBLE PRECISION :: pwx1
DOUBLE PRECISION :: pwx1d
DOUBLE PRECISION :: pwr1
DOUBLE PRECISION :: pwr1d
INTRINSIC MAX
INTRINSIC SIGN
INTRINSIC MIN
specified = .false.
IF (config_flags%specified .OR. config_flags%nested) specified = &
& .true.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
! config_flags%h_sca_adv_order
horz_order = 5
! config_flags%v_sca_adv_order
vert_order = 5
! begin with horizontal flux divergence
! here is the choice of flux operators
IF (horz_order .EQ. 5) THEN
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. &
& its .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. &
& ite .LT. ide - 3) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. &
& jts .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. &
& jte .LT. jde - 4) degrade_ye = .false.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
! check for U
IF (is .EQ. 1) THEN
i_start = its
i_end = ite
IF (config_flags%open_xs .OR. specified) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_xe .OR. specified) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
j_end_f = jde - 3
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_5:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
! use full stencil
DO k=kts,ktf
DO i=i_start,i_end
! vel = rv(i,k,j)
veld = 0.5*(rvd(i, k, j)+rvd(i-is, k-ks, j-js))
vel = 0.5*(rv(i, k, j)+rv(i-is, k-ks, j-js))
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = fieldd(i, k, j+1)
qip2 = field(i, k, j+1)
qip1d = fieldd(i, k, j)
qip1 = field(i, k, j)
qid = fieldd(i, k, j-1)
qi = field(i, k, j-1)
qim1d = fieldd(i, k, j-2)
qim1 = field(i, k, j-2)
qim2d = fieldd(i, k, j-3)
qim2 = field(i, k, j-3)
ELSE
qip2d = fieldd(i, k, j-2)
qip2 = field(i, k, j-2)
qip1d = fieldd(i, k, j-1)
qip1 = field(i, k, j-1)
qid = fieldd(i, k, j)
qi = field(i, k, j)
qim1d = fieldd(i, k, j+1)
qim1 = field(i, k, j+1)
qim2d = fieldd(i, k, j+2)
qim2 = field(i, k, j+2)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + &
& 2*(qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+&
& 3.*qi)**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + &
& 2*(qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + &
& 2*(qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+&
& 3.*qi)**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))&
& ) THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))&
& ) THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))&
& ) THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqyd(i, k, jp1) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0&
& +wi0*f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*&
& f0+wi1*f1+wi2*f2)*sumwkd)/sumwk**2
fqy(i, k, jp1) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! fqy( i, k, jp1 ) = vel*flux5( &
! field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), &
! field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel )
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
! fqy(i,k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )* &
fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
& , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
& )
fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
! vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
veld = rvd(i, k, j)
vel = rv(i, k, j)
fqyd(i, k, jp1) = veld*(7./12.*(field(i, k, j)+field(i, k, j&
& -1))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1., &
& vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-3.*(field&
& (i, k, j)-field(i, k, j-1)))) + vel*(7.*(fieldd(i, k, j)+&
& fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+fieldd(i, k, j-2&
& ))/12.+SIGN(1., vel)*(fieldd(i, k, j+1)-fieldd(i, k, j-2)-&
& 3.*(fieldd(i, k, j)-fieldd(i, k, j-1)))/12.)
fqy(i, k, jp1) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1&
& ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1., vel&
& )*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-3.*(field(i&
& , k, j)-field(i, k, j-1))))
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
! fqy(i, k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )* &
fqyd(i, k, jp1) = 0.5*(rvd(i, k, j)*(field(i, k, j)+field(i&
& , k, j-1))+rv(i, k, j)*(fieldd(i, k, j)+fieldd(i, k, j-1))&
& )
fqy(i, k, jp1) = 0.5*rv(i, k, j)*(field(i, k, j)+field(i, k&
& , j-1))
END DO
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = rvd(i, k, j)
vel = rv(i, k, j)
! vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )
fqyd(i, k, jp1) = veld*(7./12.*(field(i, k, j)+field(i, k, j&
& -1))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1., &
& vel)*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-3.*(field&
& (i, k, j)-field(i, k, j-1)))) + vel*(7.*(fieldd(i, k, j)+&
& fieldd(i, k, j-1))/12.-(fieldd(i, k, j+1)+fieldd(i, k, j-2&
& ))/12.+SIGN(1., vel)*(fieldd(i, k, j+1)-fieldd(i, k, j-2)-&
& 3.*(fieldd(i, k, j)-fieldd(i, k, j-1)))/12.)
fqy(i, k, jp1) = vel*(7./12.*(field(i, k, j)+field(i, k, j-1&
& ))-1./12.*(field(i, k, j+1)+field(i, k, j-2))+SIGN(1., vel&
& )*(1./12.)*(field(i, k, j+1)-field(i, k, j-2)-3.*(field(i&
& , k, j)-field(i, k, j-1))))
END DO
END DO
END IF
! y flux-divergence into tendency
IF (is .EQ. 0) THEN
! Comments on polar boundary conditions
! Same process as for advect_u - tendencies run from jds to jde-1
! (latitudes are as for u grid, longitudes are displaced)
! Therefore: flow is only from one side for points next to poles
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i&
& , k, jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k&
& , jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i&
& , k, jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k&
& , jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i&
& , k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k&
& , jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
ELSE IF (is .EQ. 1) THEN
! (j > j_start) will miss the u(,,jds) tendency
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i&
& , k, jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k&
& , jp1)
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
! This would be seen by (j > j_start) but we need to zero out the NP tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i&
& , k, jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k&
& , jp0)
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i&
& , k, jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k&
& , jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_5
! next, x - flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
IF (i_start + 2 .GT. ids + 3) THEN
i_start_f = ids + 3
ELSE
i_start_f = i_start + 2
END IF
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
! vel = ru(i,k,j)
veld = 0.5*(rud(i, k, j)+rud(i-is, k-ks, j-js))
vel = 0.5*(ru(i, k, j)+ru(i-is, k-ks, j-js))
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = fieldd(i+1, k, j)
qip2 = field(i+1, k, j)
qip1d = fieldd(i, k, j)
qip1 = field(i, k, j)
qid = fieldd(i-1, k, j)
qi = field(i-1, k, j)
qim1d = fieldd(i-2, k, j)
qim1 = field(i-2, k, j)
qim2d = fieldd(i-3, k, j)
qim2 = field(i-3, k, j)
ELSE
qip2d = fieldd(i-2, k, j)
qip2 = field(i-2, k, j)
qip1d = fieldd(i-1, k, j)
qip1 = field(i-1, k, j)
qid = fieldd(i, k, j)
qi = field(i, k, j)
qim1d = fieldd(i+1, k, j)
qim1 = field(i+1, k, j)
qim2d = fieldd(i+2, k, j)
qim2 = field(i+2, k, j)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*&
& (qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
& qi)**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*&
& (qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*&
& (qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
& qi)**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
& f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*&
& f1+wi2*f2)*sumwkd)/sumwk**2
fqx(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
! fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), &
! field(i-1,k,j), field(i ,k,j), &
! field(i+1,k,j), field(i+2,k,j), &
! vel )
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts,ktf
fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
& k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
& j))
END DO
END IF
IF (i .EQ. ids + 2) THEN
! third order
DO k=kts,ktf
veld = rud(i, k, j)
vel = ru(i, k, j)
fqxd(i, k) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j)&
& )-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1., &
& vel)*(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-3.*(&
& field(i, k, j)-field(i-1, k, j)))) + vel*(7.*(fieldd(i, &
& k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k, j)+fieldd(i&
& -2, k, j))/12.+SIGN(1., vel)*(fieldd(i+1, k, j)-fieldd(i&
& -2, k, j)-3.*(fieldd(i, k, j)-fieldd(i-1, k, j)))/12.)
fqx(i, k) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-&
& 1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1., vel)&
& *(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-3.*(field(i&
& , k, j)-field(i-1, k, j))))
END DO
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts,ktf
fqxd(i, k) = 0.5*(rud(i, k, j)*(field(i, k, j)+field(i-1, &
& k, j))+ru(i, k, j)*(fieldd(i, k, j)+fieldd(i-1, k, j)))
fqx(i, k) = 0.5*ru(i, k, j)*(field(i, k, j)+field(i-1, k, &
& j))
END DO
END IF
IF (i .EQ. ide - 2) THEN
! third order flux one in from the boundary
DO k=kts,ktf
veld = rud(i, k, j)
vel = ru(i, k, j)
fqxd(i, k) = veld*(7./12.*(field(i, k, j)+field(i-1, k, j)&
& )-1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1., &
& vel)*(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-3.*(&
& field(i, k, j)-field(i-1, k, j)))) + vel*(7.*(fieldd(i, &
& k, j)+fieldd(i-1, k, j))/12.-(fieldd(i+1, k, j)+fieldd(i&
& -2, k, j))/12.+SIGN(1., vel)*(fieldd(i+1, k, j)-fieldd(i&
& -2, k, j)-3.*(fieldd(i, k, j)-fieldd(i-1, k, j)))/12.)
fqx(i, k) = vel*(7./12.*(field(i, k, j)+field(i-1, k, j))-&
& 1./12.*(field(i+1, k, j)+field(i-2, k, j))+SIGN(1., vel)&
& *(1./12.)*(field(i+1, k, j)-field(i-2, k, j)-3.*(field(i&
& , k, j)-field(i-1, k, j))))
END DO
END IF
END DO
END IF
! x flux-divergence into tendency
IF (is .EQ. 0) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)&
& -fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-&
& fqx(i, k))
END DO
END DO
ELSE IF (is .EQ. 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 1st term on RHS
mrdx = msfux(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)&
& -fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-&
& fqx(i, k))
END DO
END DO
END IF
END DO
END IF
! pick up the rest of the horizontal radiation boundary conditions.
! (these are the computations that don't require 'cb'.
! first, set to index ranges
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! compute x (u) conditions for v, w, or scalar
IF (config_flags%open_xs .AND. its .EQ. ids) THEN
DO j=j_start,j_end
DO k=kts,ktf
IF (0.5*(ru(its, k, j)+ru(its+1, k, j)) .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = 0.5*(rud(its, k, j)+rud(its+1, k, j))
ub = 0.5*(ru(its, k, j)+ru(its+1, k, j))
END IF
tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(&
& field_old(its+1, k, j)-field_old(its, k, j))+ub*(field_oldd(&
& its+1, k, j)-field_oldd(its, k, j))+fieldd(its, k, j)*(ru(its+&
& 1, k, j)-ru(its, k, j))+field(its, k, j)*(rud(its+1, k, j)-rud&
& (its, k, j)))
tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(field_old(&
& its+1, k, j)-field_old(its, k, j))+field(its, k, j)*(ru(its+1&
& , k, j)-ru(its, k, j)))
END DO
END DO
END IF
IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
DO j=j_start,j_end
DO k=kts,ktf
IF (0.5*(ru(ite-1, k, j)+ru(ite, k, j)) .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = 0.5*(rud(ite-1, k, j)+rud(ite, k, j))
ub = 0.5*(ru(ite-1, k, j)+ru(ite, k, j))
END IF
tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
& field_old(i_end, k, j)-field_old(i_end-1, k, j))+ub*(&
& field_oldd(i_end, k, j)-field_oldd(i_end-1, k, j))+fieldd(&
& i_end, k, j)*(ru(ite, k, j)-ru(ite-1, k, j))+field(i_end, k, j&
& )*(rud(ite, k, j)-rud(ite-1, k, j)))
tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(&
& field_old(i_end, k, j)-field_old(i_end-1, k, j))+field(i_end, &
& k, j)*(ru(ite, k, j)-ru(ite-1, k, j)))
END DO
END DO
END IF
IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*(rv(i, k, jts)+rv(i, k, jts+1)) .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*(rvd(i, k, jts)+rvd(i, k, jts+1))
vb = 0.5*(rv(i, k, jts)+rv(i, k, jts+1))
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(&
& field_old(i, k, jts+1)-field_old(i, k, jts))+vb*(field_oldd(i&
& , k, jts+1)-field_oldd(i, k, jts))+fieldd(i, k, jts)*(rv(i, k&
& , jts+1)-rv(i, k, jts))+field(i, k, jts)*(rvd(i, k, jts+1)-rvd&
& (i, k, jts)))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(field_old(i&
& , k, jts+1)-field_old(i, k, jts))+field(i, k, jts)*(rv(i, k, &
& jts+1)-rv(i, k, jts)))
END DO
END DO
END IF
IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
DO i=i_start,i_end
DO k=kts,ktf
IF (0.5*(rv(i, k, jte-1)+rv(i, k, jte)) .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = 0.5*(rvd(i, k, jte-1)+rvd(i, k, jte))
vb = 0.5*(rv(i, k, jte-1)+rv(i, k, jte))
END IF
tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+vb*(&
& field_oldd(i, k, j_end)-field_oldd(i, k, j_end-1))+fieldd(i, k&
& , j_end)*(rv(i, k, jte)-rv(i, k, jte-1))+field(i, k, j_end)*(&
& rvd(i, k, jte)-rvd(i, k, jte-1)))
tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(&
& field_old(i, k, j_end)-field_old(i, k, j_end-1))+field(i, k, &
& j_end)*(rv(i, k, jte)-rv(i, k, jte-1)))
END DO
END DO
END IF
!-------------------- vertical advection
! Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
! Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
! So we don't need to make a correction for advect_scalar
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
DO i=i_start,i_end
vfluxd(i, kts) = 0.0
vflux(i, kts) = 0.
vfluxd(i, kte) = 0.0
vflux(i, kte) = 0.
END DO
vfluxd = 0.0
DO j=j_start,j_end
DO k=kts+3,ktf-2
DO i=i_start,i_end
! vel = rom(i,k,j)
veld = 0.5*(romd(i, k, j)+romd(i-is, k-ks, j-js))
vel = 0.5*(rom(i, k, j)+rom(i-is, k-ks, j-js))
IF (-vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = fieldd(i, k+1, j)
qip2 = field(i, k+1, j)
qip1d = fieldd(i, k, j)
qip1 = field(i, k, j)
qid = fieldd(i, k-1, j)
qi = field(i, k-1, j)
qim1d = fieldd(i, k-2, j)
qim1 = field(i, k-2, j)
qim2d = fieldd(i, k-3, j)
qim2 = field(i, k-3, j)
ELSE
qip2d = fieldd(i, k-2, j)
qip2 = field(i, k-2, j)
qip1d = fieldd(i, k-1, j)
qip1 = field(i, k-1, j)
qid = fieldd(i, k, j)
qi = field(i, k, j)
qim1d = fieldd(i, k+1, j)
qim1 = field(i, k+1, j)
qim2d = fieldd(i, k+2, j)
qim2 = field(i, k+2, j)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
& qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
& )**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
& qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
& qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
& )**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
vfluxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
& f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
& +wi2*f2)*sumwkd)/sumwk**2
vflux(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
! vflux(i,k) = vel*flux5( &
! field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), &
! field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel )
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*fieldd(&
& i, k-1, j))
vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i, &
& k-1, j))
k = kts + 2
veld = romd(i, k, j)
vel = rom(i, k, j)
vfluxd(i, k) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
& 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1., -vel)*(1./12.)*&
& (field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-field(i, k&
& -1, j)))) + vel*(7.*(fieldd(i, k, j)+fieldd(i, k-1, j))/12.-(&
& fieldd(i, k+1, j)+fieldd(i, k-2, j))/12.+SIGN(1., -vel)*(fieldd(&
& i, k+1, j)-fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, &
& j)))/12.)
vflux(i, k) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./12.&
& *(field(i, k+1, j)+field(i, k-2, j))+SIGN(1., -vel)*(1./12.)*(&
& field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-field(i, k-&
& 1, j))))
k = ktf - 1
veld = romd(i, k, j)
vel = rom(i, k, j)
vfluxd(i, k) = veld*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./&
& 12.*(field(i, k+1, j)+field(i, k-2, j))+SIGN(1., -vel)*(1./12.)*&
& (field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-field(i, k&
& -1, j)))) + vel*(7.*(fieldd(i, k, j)+fieldd(i, k-1, j))/12.-(&
& fieldd(i, k+1, j)+fieldd(i, k-2, j))/12.+SIGN(1., -vel)*(fieldd(&
& i, k+1, j)-fieldd(i, k-2, j)-3.*(fieldd(i, k, j)-fieldd(i, k-1, &
& j)))/12.)
vflux(i, k) = vel*(7./12.*(field(i, k, j)+field(i, k-1, j))-1./12.&
& *(field(i, k+1, j)+field(i, k-2, j))+SIGN(1., -vel)*(1./12.)*(&
& field(i, k+1, j)-field(i, k-2, j)-3.*(field(i, k, j)-field(i, k-&
& 1, j))))
k = ktf
vfluxd(i, k) = romd(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i&
& , k-1, j)) + rom(i, k, j)*(fzm(k)*fieldd(i, k, j)+fzp(k)*fieldd(&
& i, k-1, j))
vflux(i, k) = rom(i, k, j)*(fzm(k)*field(i, k, j)+fzp(k)*field(i, &
& k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k+1&
& )-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)-&
& vflux(i, k))
END DO
END DO
END DO
END SUBROUTINE G_ADVECT_SCALAR_WENO
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.6 (r4165) - 21 sep 2011 20:54
!
! Differentiation of advect_weno_u in forward (tangent) mode:
! variations of useful results: tendency
! with respect to varying inputs: rom u tendency u_old ru rv
! mut
! RW status of diff variables: rom:in u:in tendency:in-out u_old:in
! ru:in rv:in mut:in
SUBROUTINE G_ADVECT_WENO_U(u, ud, u_old, u_oldd, tendency, tendencyd, ru&
& , rud, rv, rvd, rom, romd, mut, mutd, time_step, config_flags, msfux, &
& msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide&
& , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte&
& , kts, kte)
IMPLICIT NONE
! Input data
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u, u_old, ru&
& , rv, rom
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ud, u_oldd, &
& rud, rvd, romd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
& msfvy, msftx, msfty
REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
REAL, INTENT(IN) :: rdx, rdy
INTEGER, INTENT(IN) :: time_step
! Local data
INTEGER :: i, j, k, itf, jtf, ktf
INTEGER :: i_start, i_end, j_start, j_end
INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
INTEGER :: jmin, jmax, jp, jm, imin, imax, im, ip
INTEGER :: jp1, jp0, jtmp
REAL :: dir, vv
REAL :: ue, vs, vn, wb, wt
REAL, PARAMETER :: f30=7./12., f31=1./12.
REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
INTEGER :: kt, kb
REAL :: qim2, qim1, qi, qip1, qip2
REAL :: qim2d, qim1d, qid, qip1d, qip2d
DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
& sumwk
DOUBLE PRECISION :: beta0d, beta1d, beta2d, f0d, f1d, f2d, wi0d, wi1d&
& , wi2d, sumwkd
DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
& 3.d0/10.d0, eps=1.0d-18
INTEGER, PARAMETER :: pw=2
INTEGER :: horz_order, vert_order
REAL :: mrdx, mrdy, ub, vb, uw, vw, dvm, dvp
REAL :: ubd, vbd, vwd, dvmd, dvpd
REAL, DIMENSION(its:ite, kts:kte) :: vflux
REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
REAL, DIMENSION(its - 1:ite + 1, kts:kte) :: fqx
REAL, DIMENSION(its-1:ite+1, kts:kte) :: fqxd
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
LOGICAL :: degrade_xs, degrade_ys
LOGICAL :: degrade_xe, degrade_ye
! definition of flux operators, 3rd, 4th, 5th or 6th order
REAL :: flux3, flux4, flux5, flux6
REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
REAL :: veld
LOGICAL :: specified
DOUBLE PRECISION :: pwx1
DOUBLE PRECISION :: pwx1d
DOUBLE PRECISION :: pwr1
DOUBLE PRECISION :: pwr1d
INTRINSIC MAX
INTRINSIC SIGN
INTRINSIC MIN
specified = .false.
IF (config_flags%specified .OR. config_flags%nested) specified = &
& .true.
! set order for vertical and horzontal flux operators
horz_order = config_flags%h_mom_adv_order
vert_order = config_flags%v_mom_adv_order
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
! begin with horizontal flux divergence
! horizontal_order_test : IF( horz_order == 6 ) THEN
! ELSE IF( horz_order == 5 ) THEN
! 5th order horizontal flux calculation
! This code is EXACTLY the same as the 6th order code
! EXCEPT the 5th order and 3rd operators are used in
! place of the 6th and 4th order operators
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
& .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
& .LT. ide - 2) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
& .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
& .LT. jde - 4) degrade_ye = .false.
!--------------- y - advection first
i_start = its
i_end = ite
IF (config_flags%open_xs .OR. specified) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_xe .OR. specified) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
j_end_f = jde - 3
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_5:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
! use full stencil
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = ud(i, k, j+1)
qip2 = u(i, k, j+1)
qip1d = ud(i, k, j)
qip1 = u(i, k, j)
qid = ud(i, k, j-1)
qi = u(i, k, j-1)
qim1d = ud(i, k, j-2)
qim1 = u(i, k, j-2)
qim2d = ud(i, k, j-3)
qim2 = u(i, k, j-3)
ELSE
qip2d = ud(i, k, j-2)
qip2 = u(i, k, j-2)
qip1d = ud(i, k, j-1)
qip1 = u(i, k, j-1)
qid = ud(i, k, j)
qi = u(i, k, j)
qim1d = ud(i, k, j+1)
qim1 = u(i, k, j+1)
qim2d = ud(i, k, j+2)
qim2 = u(i, k, j+2)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*&
& (qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
& qi)**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*&
& (qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*&
& (qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
& qi)**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqyd(i, k, jp1) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+&
& wi0*f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+&
& wi1*f1+wi2*f2)*sumwkd)/sumwk**2
fqy(i, k, jp1) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! fqy( i, k, jp1 ) = vel*flux5( &
! u(i,k,j-3), u(i,k,j-2), u(i,k,j-1), &
! u(i,k,j ), u(i,k,j+1), u(i,k,j+2), vel )
! we must be close to some boundary where we need to reduce the order of the stencil
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, k&
& , j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, j)+&
& ud(i, k, j-1)))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j)+&
& u(i, k, j-1))
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
fqyd(i, k, jp1) = veld*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
& , j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))/&
& 12.0) + vel*((7.*(ud(i, k, j)+ud(i, k, j-1))-ud(i, k, j+1)-&
& ud(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i, &
& k, j+1)-ud(i, k, j-2)-3.*(ud(i, k, j)-ud(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k, j&
& +1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(&
& i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))/12.0)
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i-1, k, j))*(u(i, k&
& , j)+u(i, k, j-1))+(rv(i, k, j)+rv(i-1, k, j))*(ud(i, k, j)+&
& ud(i, k, j-1)))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i-1, k, j))*(u(i, k, j)+&
& u(i, k, j-1))
END DO
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i-1, k, j))
vel = 0.5*(rv(i, k, j)+rv(i-1, k, j))
fqyd(i, k, jp1) = veld*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k&
& , j+1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (u(i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))/&
& 12.0) + vel*((7.*(ud(i, k, j)+ud(i, k, j-1))-ud(i, k, j+1)-&
& ud(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i, &
& k, j+1)-ud(i, k, j-2)-3.*(ud(i, k, j)-ud(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(u(i, k, j)+u(i, k, j-1))-(u(i, k, j&
& +1)+u(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(&
& i, k, j+1)-u(i, k, j-2)-3.*(u(i, k, j)-u(i, k, j-1)))/12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! (j > j_start) will miss the u(,,jds) tendency
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k, &
& jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, jp1&
& )
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
! This would be seen by (j > j_start) but we need to zero out the NP tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k, &
& jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, jp0&
& )
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, k&
& , jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_5
! next, x - flux divergence
i_start = its
i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
i_start_f = ids + 3
END IF
IF (degrade_xe) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
i_end_f = ide - 2
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = ud(i+1, k, j)
qip2 = u(i+1, k, j)
qip1d = ud(i, k, j)
qip1 = u(i, k, j)
qid = ud(i-1, k, j)
qi = u(i-1, k, j)
qim1d = ud(i-2, k, j)
qim1 = u(i-2, k, j)
qim2d = ud(i-3, k, j)
qim2 = u(i-3, k, j)
ELSE
qip2d = ud(i-2, k, j)
qip2 = u(i-2, k, j)
qip1d = ud(i-1, k, j)
qip1 = u(i-1, k, j)
qid = ud(i, k, j)
qi = u(i, k, j)
qim1d = ud(i+1, k, j)
qim1 = u(i+1, k, j)
qim2d = ud(i+2, k, j)
qim2 = u(i+2, k, j)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
& qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
& )**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
& qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
& qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
& )**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*f0d+&
& wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1+wi2&
& *f2)*sumwkd)/sumwk**2
fqx(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
! fqx( i,k ) = vel*flux5( u(i-3,k,j), u(i-2,k,j), &
! u(i-1,k,j), u(i ,k,j), &
! u(i+1,k,j), u(i+2,k,j), &
! vel )
! lower order fluxes close to boundaries (if not periodic or symmetric)
! specified uses upstream normal wind at boundaries
IF (degrade_xs) THEN
IF (i_start .EQ. ids + 1) THEN
! second order flux next to the boundary
i = ids + 1
DO k=kts,ktf
ubd = ud(i-1, k, j)
ub = u(i-1, k, j)
IF (specified .AND. u(i, k, j) .LT. 0.) THEN
ubd = ud(i, k, j)
ub = u(i, k, j)
END IF
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i, k, j)+&
& ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i, k, j)+ubd))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i, k, j)+ub)
END DO
END IF
i = ids + 2
DO k=kts,ktf
veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
fqxd(i, k) = veld*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
& (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, k&
& , j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0) + vel*((&
& 7.*(ud(i, k, j)+ud(i-1, k, j))-ud(i+1, k, j)-ud(i-2, k, j))/&
& 12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i+1, k, j)-ud(i-2, k&
& , j)-3.*(ud(i, k, j)-ud(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u(i&
& -2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, k, j&
& )-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0)
END DO
END IF
IF (degrade_xe) THEN
IF (i_end .EQ. ide - 1) THEN
! second order flux next to the boundary
i = ide
DO k=kts,ktf
ubd = ud(i, k, j)
ub = u(i, k, j)
IF (specified .AND. u(i-1, k, j) .GT. 0.) THEN
ubd = ud(i-1, k, j)
ub = u(i-1, k, j)
END IF
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i-1, k, j))*(u(i-1, k, j)&
& +ub)+(ru(i, k, j)+ru(i-1, k, j))*(ud(i-1, k, j)+ubd))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i-1, k, j))*(u(i-1, k, j)+ub)
END DO
END IF
DO k=kts,ktf
i = ide - 1
veld = 0.5*(rud(i, k, j)+rud(i-1, k, j))
vel = 0.5*(ru(i, k, j)+ru(i-1, k, j))
fqxd(i, k) = veld*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u&
& (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, k&
& , j)-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0) + vel*((&
& 7.*(ud(i, k, j)+ud(i-1, k, j))-ud(i+1, k, j)-ud(i-2, k, j))/&
& 12.0+SIGN(1, time_step)*SIGN(1., vel)*(ud(i+1, k, j)-ud(i-2, k&
& , j)-3.*(ud(i, k, j)-ud(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(u(i, k, j)+u(i-1, k, j))-(u(i+1, k, j)+u(i&
& -2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(u(i+1, k, j&
& )-u(i-2, k, j)-3.*(u(i, k, j)-u(i-1, k, j)))/12.0)
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 44, 1st term on RHS
mrdx = msfux(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(i&
& , k))
END DO
END DO
END DO
! radiative lateral boundary condition in x for normal velocity (u)
IF (config_flags%open_xs .AND. its .EQ. ids) THEN
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
DO j=j_start,j_end
DO k=kts,ktf
IF (ru(its, k, j) - cb*mut(its, j) .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = rud(its, k, j) - cb*mutd(its, j)
ub = ru(its, k, j) - cb*mut(its, j)
END IF
tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(u_old(&
& its+1, k, j)-u_old(its, k, j))+ub*(u_oldd(its+1, k, j)-u_oldd(&
& its, k, j)))
tendency(its, k, j) = tendency(its, k, j) - rdx*ub*(u_old(its+1&
& , k, j)-u_old(its, k, j))
END DO
END DO
END IF
IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
DO j=j_start,j_end
DO k=kts,ktf
IF (ru(ite, k, j) + cb*mut(ite-1, j) .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = rud(ite, k, j) + cb*mutd(ite-1, j)
ub = ru(ite, k, j) + cb*mut(ite-1, j)
END IF
tendencyd(ite, k, j) = tendencyd(ite, k, j) - rdx*(ubd*(u_old(&
& ite, k, j)-u_old(ite-1, k, j))+ub*(u_oldd(ite, k, j)-u_oldd(&
& ite-1, k, j)))
tendency(ite, k, j) = tendency(ite, k, j) - rdx*ub*(u_old(ite, k&
& , j)-u_old(ite-1, k, j))
END DO
END DO
END IF
! pick up the rest of the horizontal radiation boundary conditions.
! (these are the computations that don't require 'cb')
! first, set to index ranges
i_start = its
IF (ite .GT. ide) THEN
i_end = ide
ELSE
i_end = ite
END IF
imin = ids
imax = ide - 1
IF (config_flags%open_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
imin = ids
END IF
IF (config_flags%open_xe) THEN
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
imax = ide - 1
END IF
IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, jts)*rdy
IF (imax .GT. i) THEN
ip = i
ELSE
ip = imax
END IF
IF (imin .LT. i - 1) THEN
im = i - 1
ELSE
im = imin
END IF
DO k=kts,ktf
vwd = 0.5*(rvd(ip, k, jts)+rvd(im, k, jts))
vw = 0.5*(rv(ip, k, jts)+rv(im, k, jts))
IF (vw .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
dvmd = rvd(ip, k, jts+1) - rvd(ip, k, jts)
dvm = rv(ip, k, jts+1) - rv(ip, k, jts)
dvpd = rvd(im, k, jts+1) - rvd(im, k, jts)
dvp = rv(im, k, jts+1) - rv(im, k, jts)
tendencyd(i, k, jts) = tendencyd(i, k, jts) - mrdy*(vbd*(u_old(i&
& , k, jts+1)-u_old(i, k, jts))+vb*(u_oldd(i, k, jts+1)-u_oldd(i&
& , k, jts))+0.5*(ud(i, k, jts)*(dvm+dvp)+u(i, k, jts)*(dvmd+&
& dvpd)))
tendency(i, k, jts) = tendency(i, k, jts) - mrdy*(vb*(u_old(i, k&
& , jts+1)-u_old(i, k, jts))+0.5*u(i, k, jts)*(dvm+dvp))
END DO
END DO
END IF
IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
DO i=i_start,i_end
! ADT eqn 44, 2nd term on RHS
mrdy = msfux(i, jte-1)*rdy
IF (imax .GT. i) THEN
ip = i
ELSE
ip = imax
END IF
IF (imin .LT. i - 1) THEN
im = i - 1
ELSE
im = imin
END IF
DO k=kts,ktf
vwd = 0.5*(rvd(ip, k, jte)+rvd(im, k, jte))
vw = 0.5*(rv(ip, k, jte)+rv(im, k, jte))
IF (vw .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
dvmd = rvd(ip, k, jte) - rvd(ip, k, jte-1)
dvm = rv(ip, k, jte) - rv(ip, k, jte-1)
dvpd = rvd(im, k, jte) - rvd(im, k, jte-1)
dvp = rv(im, k, jte) - rv(im, k, jte-1)
tendencyd(i, k, jte-1) = tendencyd(i, k, jte-1) - mrdy*(vbd*(&
& u_old(i, k, jte-1)-u_old(i, k, jte-2))+vb*(u_oldd(i, k, jte-1)&
& -u_oldd(i, k, jte-2))+0.5*(ud(i, k, jte-1)*(dvm+dvp)+u(i, k, &
& jte-1)*(dvmd+dvpd)))
tendency(i, k, jte-1) = tendency(i, k, jte-1) - mrdy*(vb*(u_old(&
& i, k, jte-1)-u_old(i, k, jte-2))+0.5*u(i, k, jte-1)*(dvm+dvp))
END DO
END DO
END IF
!-------------------- vertical advection
! ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
! Here we have: - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
! Since 'my' (map scale factor in y-direction) isn't a function of z,
! this is what we need, so leave unchanged in advect_u
i_start = its
i_end = ite
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! IF ( config_flags%open_xs ) i_start = MAX(ids+1,its)
! IF ( config_flags%open_xe ) i_end = MIN(ide-1,ite)
IF (config_flags%open_ys .OR. specified) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
END IF
IF (config_flags%open_ye .OR. specified) THEN
IF (ide - 1 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 1
END IF
END IF
IF (config_flags%periodic_x) i_start = its
IF (config_flags%periodic_x) i_end = ite
DO i=i_start,i_end
vfluxd(i, kts) = 0.0
vflux(i, kts) = 0.
vfluxd(i, kte) = 0.0
vflux(i, kte) = 0.
END DO
vfluxd = 0.0
! vert_order_test : IF (vert_order == 6) THEN
! ELSE IF (vert_order == 5) THEN
DO j=j_start,j_end
DO k=kts+3,ktf-2
DO i=i_start,i_end
veld = 0.5*(romd(i-1, k, j)+romd(i, k, j))
vel = 0.5*(rom(i-1, k, j)+rom(i, k, j))
IF (-vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = ud(i, k+1, j)
qip2 = u(i, k+1, j)
qip1d = ud(i, k, j)
qip1 = u(i, k, j)
qid = ud(i, k-1, j)
qi = u(i, k-1, j)
qim1d = ud(i, k-2, j)
qim1 = u(i, k-2, j)
qim2d = ud(i, k-3, j)
qim2 = u(i, k-3, j)
ELSE
qip2d = ud(i, k-2, j)
qip2 = u(i, k-2, j)
qip1d = ud(i, k-1, j)
qip1 = u(i, k-1, j)
qid = ud(i, k, j)
qi = u(i, k, j)
qim1d = ud(i, k+1, j)
qim1 = u(i, k+1, j)
qim2d = ud(i, k+2, j)
qim2 = u(i, k+2, j)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
& qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
& )**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
& qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
& qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
& )**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
vfluxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
& f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
& +wi2*f2)*sumwkd)/sumwk**2
vflux(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
! vflux(i,k) = vel*flux5( &
! u(i,k-3,j), u(i,k-2,j), u(i,k-1,j), &
! u(i,k ,j), u(i,k+1,j), u(i,k+2,j), -vel )
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i, k&
& , j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*&
& ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, j)&
& +fzp(k)*u(i, k-1, j))
k = kts + 2
veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
vfluxd(i, k) = veld*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1, &
& j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0) + vel*((7.*(&
& ud(i, k, j)+ud(i, k-1, j))-ud(i, k+1, j)-ud(i, k-2, j))/12.0+&
& SIGN(1, time_step)*SIGN(1., -vel)*(ud(i, k+1, j)-ud(i, k-2, j)-&
& 3.*(ud(i, k, j)-ud(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u(i&
& , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1, j)&
& -u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0)
k = ktf - 1
veld = 0.5*(romd(i, k, j)+romd(i-1, k, j))
vel = 0.5*(rom(i, k, j)+rom(i-1, k, j))
vfluxd(i, k) = veld*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1, &
& j)-u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0) + vel*((7.*(&
& ud(i, k, j)+ud(i, k-1, j))-ud(i, k+1, j)-ud(i, k-2, j))/12.0+&
& SIGN(1, time_step)*SIGN(1., -vel)*(ud(i, k+1, j)-ud(i, k-2, j)-&
& 3.*(ud(i, k, j)-ud(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(u(i, k, j)+u(i, k-1, j))-(u(i, k+1, j)+u(i&
& , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(u(i, k+1, j)&
& -u(i, k-2, j)-3.*(u(i, k, j)-u(i, k-1, j)))/12.0)
k = ktf
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i-1, k, j))*(fzm(k)*u(i, k&
& , j)+fzp(k)*u(i, k-1, j))+(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*&
& ud(i, k, j)+fzp(k)*ud(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i-1, k, j))*(fzm(k)*u(i, k, j)&
& +fzp(k)*u(i, k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzw(k)*(vfluxd(i, k+1&
& )-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzw(k)*(vflux(i, k+1)-&
& vflux(i, k))
END DO
END DO
END DO
END SUBROUTINE G_ADVECT_WENO_U
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.6 (r4165) - 21 sep 2011 20:54
!
! Differentiation of advect_weno_v in forward (tangent) mode:
! variations of useful results: tendency
! with respect to varying inputs: rom tendency v v_old ru rv
! mut
! RW status of diff variables: rom:in tendency:in-out v:in v_old:in
! ru:in rv:in mut:in
SUBROUTINE G_ADVECT_WENO_V(v, vd, v_old, v_oldd, tendency, tendencyd, ru&
& , rud, rv, rvd, rom, romd, mut, mutd, time_step, config_flags, msfux, &
& msfuy, msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzw, ids, ide&
& , jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte&
& , kts, kte)
IMPLICIT NONE
! Input data
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: v, v_old, ru&
& , rv, rom
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: vd, v_oldd, &
& rud, rvd, romd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
& msfvy, msftx, msfty
REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzw
REAL, INTENT(IN) :: rdx, rdy
INTEGER, INTENT(IN) :: time_step
! Local data
INTEGER :: i, j, k, itf, jtf, ktf
INTEGER :: i_start, i_end, j_start, j_end
INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
INTEGER :: jmin, jmax, jp, jm, imin, imax
REAL :: dir, vv
REAL :: ue, vs, vn, wb, wt
REAL, PARAMETER :: f30=7./12., f31=1./12.
REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
INTEGER :: kt, kb
REAL :: qim2, qim1, qi, qip1, qip2
REAL :: qim2d, qim1d, qid, qip1d, qip2d
DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
& sumwk
DOUBLE PRECISION :: beta0d, beta1d, beta2d, f0d, f1d, f2d, wi0d, wi1d&
& , wi2d, sumwkd
DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
& 3.d0/10.d0, eps=1.0d-18
INTEGER, PARAMETER :: pw=2
REAL :: mrdx, mrdy, ub, vb, uw, vw, dup, dum
REAL :: ubd, vbd, uwd, dupd, dumd
REAL, DIMENSION(its:ite, kts:kte) :: vflux
REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
REAL, DIMENSION(its:ite+1, kts:kte) :: fqxd
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
INTEGER :: horz_order
INTEGER :: vert_order
LOGICAL :: degrade_xs, degrade_ys
LOGICAL :: degrade_xe, degrade_ye
INTEGER :: jp1, jp0, jtmp
! definition of flux operators, 3rd, 4th, 5th or 6th order
REAL :: flux3, flux4, flux5, flux6
REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
REAL :: veld
LOGICAL :: specified
DOUBLE PRECISION :: pwx1
DOUBLE PRECISION :: pwx1d
DOUBLE PRECISION :: pwr1
DOUBLE PRECISION :: pwr1d
INTRINSIC MAX
INTRINSIC SIGN
INTRINSIC MIN
specified = .false.
IF (config_flags%specified .OR. config_flags%nested) specified = &
& .true.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
horz_order = config_flags%h_mom_adv_order
vert_order = config_flags%v_mom_adv_order
! here is the choice of flux operators
! horizontal_order_test : IF( horz_order == 6 ) THEN
! ELSE IF( horz_order == 5 ) THEN
! 5th order horizontal flux calculation
! This code is EXACTLY the same as the 6th order code
! EXCEPT the 5th order and 3rd operators are used in
! place of the 6th and 4th order operators
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
& .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
& .LT. ide - 3) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
& .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
& .LT. jde - 3) degrade_ye = .false.
!--------------- y - advection first
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
j_end_f = jde - 2
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_5:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = vd(i, k, j+1)
qip2 = v(i, k, j+1)
qip1d = vd(i, k, j)
qip1 = v(i, k, j)
qid = vd(i, k, j-1)
qi = v(i, k, j-1)
qim1d = vd(i, k, j-2)
qim1 = v(i, k, j-2)
qim2d = vd(i, k, j-3)
qim2 = v(i, k, j-3)
ELSE
qip2d = vd(i, k, j-2)
qip2 = v(i, k, j-2)
qip1d = vd(i, k, j-1)
qip1 = v(i, k, j-1)
qid = vd(i, k, j)
qi = v(i, k, j)
qim1d = vd(i, k, j+1)
qim1 = v(i, k, j+1)
qim2d = vd(i, k, j+2)
qim2 = v(i, k, j+2)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*&
& (qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
& qi)**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*&
& (qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*&
& (qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
& qi)**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqyd(i, k, jp1) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+&
& wi0*f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+&
& wi1*f1+wi2*f2)*sumwkd)/sumwk**2
fqy(i, k, jp1) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
ELSE IF (j .EQ. jds + 1) THEN
! fqy( i, k, jp1 ) = vel*flux5( &
! v(i,k,j-3), v(i,k,j-2), v(i,k,j-1), &
! v(i,k,j ), v(i,k,j+1), v(i,k,j+2), vel )
! we must be close to some boundary where we need to reduce the order of the stencil
! specified uses upstream normal wind at boundaries
! 2nd order flux next to south boundary
DO k=kts,ktf
DO i=i_start,i_end
vbd = vd(i, k, j-1)
vb = v(i, k, j-1)
IF (specified .AND. v(i, k, j) .LT. 0.) THEN
vbd = vd(i, k, j)
vb = v(i, k, j)
END IF
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(v(i, k&
& , j)+vb)+(rv(i, k, j)+rv(i, k, j-1))*(vd(i, k, j)+vbd))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(v(i, k, j)+&
& vb)
END DO
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
fqyd(i, k, jp1) = veld*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
& , j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))/&
& 12.0) + vel*((7.*(vd(i, k, j)+vd(i, k, j-1))-vd(i, k, j+1)-&
& vd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(vd(i, &
& k, j+1)-vd(i, k, j-2)-3.*(vd(i, k, j)-vd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k, j&
& +1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(&
& i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))/12.0)
END DO
END DO
ELSE IF (j .EQ. jde) THEN
! 2nd order flux next to north boundary
DO k=kts,ktf
DO i=i_start,i_end
vbd = vd(i, k, j)
vb = v(i, k, j)
IF (specified .AND. v(i, k, j-1) .GT. 0.) THEN
vbd = vd(i, k, j-1)
vb = v(i, k, j-1)
END IF
fqyd(i, k, jp1) = 0.25*((rvd(i, k, j)+rvd(i, k, j-1))*(vb+v(i&
& , k, j-1))+(rv(i, k, j)+rv(i, k, j-1))*(vbd+vd(i, k, j-1)))
fqy(i, k, jp1) = 0.25*(rv(i, k, j)+rv(i, k, j-1))*(vb+v(i, k, &
& j-1))
END DO
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts,ktf
DO i=i_start,i_end
veld = 0.5*(rvd(i, k, j)+rvd(i, k, j-1))
vel = 0.5*(rv(i, k, j)+rv(i, k, j-1))
fqyd(i, k, jp1) = veld*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k&
& , j+1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (v(i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))/&
& 12.0) + vel*((7.*(vd(i, k, j)+vd(i, k, j-1))-vd(i, k, j+1)-&
& vd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(vd(i, &
& k, j+1)-vd(i, k, j-2)-3.*(vd(i, k, j)-vd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(v(i, k, j)+v(i, k, j-1))-(v(i, k, j&
& +1)+v(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(&
& i, k, j+1)-v(i, k, j-2)-3.*(v(i, k, j)-v(i, k, j-1)))/12.0)
END DO
END DO
END IF
! y flux-divergence into tendency
! Comments on polar boundary conditions
! No advection over the poles means tendencies (held from jds [S. pole]
! to jde [N pole], i.e., on v grid) must be zero at poles
! [tendency(jds) and tendency(jde)=0]
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j-1) = 0.0
tendency(i, k, j-1) = 0.
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde + 1) THEN
! If j_end were set to jde in a special if statement apart from
! degrade_ye, then we would hit the next conditional. But since
! we want the tendency to be zero anyway, not looping to jde+1
! will produce the same effect.
DO k=kts,ktf
DO i=i_start,i_end
tendencyd(i, k, j-1) = 0.0
tendency(i, k, j-1) = 0.
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! Normal code
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 2nd term on RHS
mrdy = msfvy(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, k&
& , jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_5
! next, x - flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
! Polar boundary conditions are like open or specified
IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jde - 1 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 1
END IF
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
IF (i_start + 2 .GT. ids + 3) THEN
i_start_f = ids + 3
ELSE
i_start_f = i_start + 2
END IF
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts,ktf
DO i=i_start_f,i_end_f
veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = vd(i+1, k, j)
qip2 = v(i+1, k, j)
qip1d = vd(i, k, j)
qip1 = v(i, k, j)
qid = vd(i-1, k, j)
qi = v(i-1, k, j)
qim1d = vd(i-2, k, j)
qim1 = v(i-2, k, j)
qim2d = vd(i-3, k, j)
qim2 = v(i-3, k, j)
ELSE
qip2d = vd(i-2, k, j)
qip2 = v(i-2, k, j)
qip1d = vd(i-1, k, j)
qip1 = v(i-1, k, j)
qid = vd(i, k, j)
qi = v(i, k, j)
qim1d = vd(i+1, k, j)
qim1 = v(i+1, k, j)
qim2d = vd(i+2, k, j)
qim2 = v(i+2, k, j)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
& qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
& )**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
& qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
& qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
& )**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*f0d+&
& wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1+wi2&
& *f2)*sumwkd)/sumwk**2
fqx(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
! fqx( i, k ) = vel*flux5( v(i-3,k,j), v(i-2,k,j), &
! v(i-1,k,j), v(i ,k,j), &
! v(i+1,k,j), v(i+2,k,j), &
! vel )
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts,ktf
fqxd(i, k) = 0.25*((rud(i, k, j)+rud(i, k, j-1))*(v(i, k, j)&
& +v(i-1, k, j))+(ru(i, k, j)+ru(i, k, j-1))*(vd(i, k, j)+vd&
& (i-1, k, j)))
fqx(i, k) = 0.25*(ru(i, k, j)+ru(i, k, j-1))*(v(i, k, j)+v(i&
& -1, k, j))
END DO
END IF
IF (i .EQ. ids + 2) THEN
! third order
DO k=kts,ktf
veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
fqxd(i, k) = veld*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
& j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v&
& (i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/&
& 12.0) + vel*((7.*(vd(i, k, j)+vd(i-1, k, j))-vd(i+1, k, j)&
& -vd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(vd(&
& i+1, k, j)-vd(i-2, k, j)-3.*(vd(i, k, j)-vd(i-1, k, j)))/&
& 12.0)
fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)&
& +v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(i&
& +1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/12.0)
END DO
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts,ktf
fqxd(i, k) = 0.25*((rud(i_end+1, k, j)+rud(i_end+1, k, j-1))&
& *(v(i_end+1, k, j)+v(i_end, k, j))+(ru(i_end+1, k, j)+ru(&
& i_end+1, k, j-1))*(vd(i_end+1, k, j)+vd(i_end, k, j)))
fqx(i, k) = 0.25*(ru(i_end+1, k, j)+ru(i_end+1, k, j-1))*(v(&
& i_end+1, k, j)+v(i_end, k, j))
END DO
END IF
IF (i .EQ. ide - 2) THEN
! third order flux one in from the boundary
DO k=kts,ktf
veld = 0.5*(rud(i, k, j)+rud(i, k, j-1))
vel = 0.5*(ru(i, k, j)+ru(i, k, j-1))
fqxd(i, k) = veld*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, &
& j)+v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v&
& (i+1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/&
& 12.0) + vel*((7.*(vd(i, k, j)+vd(i-1, k, j))-vd(i+1, k, j)&
& -vd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(vd(&
& i+1, k, j)-vd(i-2, k, j)-3.*(vd(i, k, j)-vd(i-1, k, j)))/&
& 12.0)
fqx(i, k) = vel*((7.*(v(i, k, j)+v(i-1, k, j))-(v(i+1, k, j)&
& +v(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(v(i&
& +1, k, j)-v(i-2, k, j)-3.*(v(i, k, j)-v(i-1, k, j)))/12.0)
END DO
END IF
END DO
END IF
! x flux-divergence into tendency
DO k=kts,ktf
DO i=i_start,i_end
! ADT eqn 45, 1st term on RHS
mrdx = msfvy(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(i&
& , k))
END DO
END DO
END DO
! Comments on polar boundary condition
! Force tendency=0 at NP and SP
! We keep setting this everywhere, but it can't hurt...
IF (config_flags%polar .AND. jts .EQ. jds) THEN
DO i=its,ite
DO k=kts,ktf
tendencyd(i, k, jts) = 0.0
tendency(i, k, jts) = 0.
END DO
END DO
END IF
IF (config_flags%polar .AND. jte .EQ. jde) THEN
DO i=its,ite
DO k=kts,ktf
tendencyd(i, k, jte) = 0.0
tendency(i, k, jte) = 0.
END DO
END DO
END IF
! radiative lateral boundary condition in y for normal velocity (v)
IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
DO i=i_start,i_end
DO k=kts,ktf
IF (rv(i, k, jts) - cb*mut(i, jts) .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = rvd(i, k, jts) - cb*mutd(i, jts)
vb = rv(i, k, jts) - cb*mut(i, jts)
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(v_old(i&
& , k, jts+1)-v_old(i, k, jts))+vb*(v_oldd(i, k, jts+1)-v_oldd(i&
& , k, jts)))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*vb*(v_old(i, k, &
& jts+1)-v_old(i, k, jts))
END DO
END DO
END IF
IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
DO i=i_start,i_end
DO k=kts,ktf
IF (rv(i, k, jte) + cb*mut(i, jte-1) .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = rvd(i, k, jte) + cb*mutd(i, jte-1)
vb = rv(i, k, jte) + cb*mut(i, jte-1)
END IF
tendencyd(i, k, jte) = tendencyd(i, k, jte) - rdy*(vbd*(v_old(i&
& , k, jte)-v_old(i, k, jte-1))+vb*(v_oldd(i, k, jte)-v_oldd(i, &
& k, jte-1)))
tendency(i, k, jte) = tendency(i, k, jte) - rdy*vb*(v_old(i, k, &
& jte)-v_old(i, k, jte-1))
END DO
END DO
END IF
! pick up the rest of the horizontal radiation boundary conditions.
! (these are the computations that don't require 'cb'.
! first, set to index ranges
j_start = jts
IF (jte .GT. jde) THEN
j_end = jde
ELSE
j_end = jte
END IF
jmin = jds
jmax = jde - 1
IF (config_flags%open_ys) THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
jmin = jds
END IF
IF (config_flags%open_ye) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
jmax = jde - 1
END IF
! compute x (u) conditions for v, w, or scalar
IF (config_flags%open_xs .AND. its .EQ. ids) THEN
DO j=j_start,j_end
! ADT eqn 45, 1st term on RHS
mrdx = msfvy(its, j)*rdx
IF (jmax .GT. j) THEN
jp = j
ELSE
jp = jmax
END IF
IF (jmin .LT. j - 1) THEN
jm = j - 1
ELSE
jm = jmin
END IF
DO k=kts,ktf
uwd = 0.5*(rud(its, k, jp)+rud(its, k, jm))
uw = 0.5*(ru(its, k, jp)+ru(its, k, jm))
IF (uw .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
dupd = rud(its+1, k, jp) - rud(its, k, jp)
dup = ru(its+1, k, jp) - ru(its, k, jp)
dumd = rud(its+1, k, jm) - rud(its, k, jm)
dum = ru(its+1, k, jm) - ru(its, k, jm)
tendencyd(its, k, j) = tendencyd(its, k, j) - mrdx*(ubd*(v_old(&
& its+1, k, j)-v_old(its, k, j))+ub*(v_oldd(its+1, k, j)-v_oldd(&
& its, k, j))+0.5*(vd(its, k, j)*(dup+dum)+v(its, k, j)*(dupd+&
& dumd)))
tendency(its, k, j) = tendency(its, k, j) - mrdx*(ub*(v_old(its+&
& 1, k, j)-v_old(its, k, j))+0.5*v(its, k, j)*(dup+dum))
END DO
END DO
END IF
IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
DO j=j_start,j_end
! ADT eqn 45, 1st term on RHS
mrdx = msfvy(ite-1, j)*rdx
IF (jmax .GT. j) THEN
jp = j
ELSE
jp = jmax
END IF
IF (jmin .LT. j - 1) THEN
jm = j - 1
ELSE
jm = jmin
END IF
DO k=kts,ktf
uwd = 0.5*(rud(ite, k, jp)+rud(ite, k, jm))
uw = 0.5*(ru(ite, k, jp)+ru(ite, k, jm))
IF (uw .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
dupd = rud(ite, k, jp) - rud(ite-1, k, jp)
dup = ru(ite, k, jp) - ru(ite-1, k, jp)
dumd = rud(ite, k, jm) - rud(ite-1, k, jm)
dum = ru(ite, k, jm) - ru(ite-1, k, jm)
! tendency(ite-1,k,j)=tendency(ite-1,k,j)-mrdx*( &
! ub*(v_old(ite-1,k,j)-v_old(ite-2,k,j)) &
! +0.5*v(ite-1,k,j)* &
! ( ru(ite,k,jp)-ru(ite-1,k,jp) &
! +ru(ite,k,jm)-ru(ite-1,k,jm)) )
tendencyd(ite-1, k, j) = tendencyd(ite-1, k, j) - mrdx*(ubd*(&
& v_old(ite-1, k, j)-v_old(ite-2, k, j))+ub*(v_oldd(ite-1, k, j)&
& -v_oldd(ite-2, k, j))+0.5*(vd(ite-1, k, j)*(dup+dum)+v(ite-1, &
& k, j)*(dupd+dumd)))
tendency(ite-1, k, j) = tendency(ite-1, k, j) - mrdx*(ub*(v_old(&
& ite-1, k, j)-v_old(ite-2, k, j))+0.5*v(ite-1, k, j)*(dup+dum))
END DO
END DO
END IF
!-------------------- vertical advection
! ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
! Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
! We therefore need to make a correction for advect_v
! since 'my' (map scale factor in y direction) isn't a function of z,
! we can do this using *(my/mx) (see eqn. 45 for example)
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
j_end = jte
DO i=i_start,i_end
vfluxd(i, kts) = 0.0
vflux(i, kts) = 0.
vfluxd(i, kte) = 0.0
vflux(i, kte) = 0.
END DO
! Polar boundary conditions are like open or specified
! We don't want to calculate vertical v tendencies at the N or S pole
IF ((config_flags%open_ys .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jds + 1 .LT. jts) THEN
j_start = jts
ELSE
j_start = jds + 1
END IF
END IF
IF ((config_flags%open_ye .OR. specified) .OR. config_flags%polar) &
& THEN
IF (jde - 1 .GT. jte) THEN
j_end = jte
ELSE
j_end = jde - 1
END IF
vfluxd = 0.0
ELSE
vfluxd = 0.0
END IF
! vert_order_test : IF (vert_order == 6) THEN
! ELSE IF (vert_order == 5) THEN
DO j=j_start,j_end
DO k=kts+3,ktf-2
DO i=i_start,i_end
veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
IF (-vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = vd(i, k+1, j)
qip2 = v(i, k+1, j)
qip1d = vd(i, k, j)
qip1 = v(i, k, j)
qid = vd(i, k-1, j)
qi = v(i, k-1, j)
qim1d = vd(i, k-2, j)
qim1 = v(i, k-2, j)
qim2d = vd(i, k-3, j)
qim2 = v(i, k-3, j)
ELSE
qip2d = vd(i, k-2, j)
qip2 = v(i, k-2, j)
qip1d = vd(i, k-1, j)
qip1 = v(i, k-1, j)
qid = vd(i, k, j)
qi = v(i, k, j)
qim1d = vd(i, k+1, j)
qim1 = v(i, k+1, j)
qim2d = vd(i, k+2, j)
qim2 = v(i, k+2, j)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
& qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
& )**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
& qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
& qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
& )**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
vfluxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
& f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
& +wi2*f2)*sumwkd)/sumwk**2
vflux(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
! vflux(i,k) = vel*flux5( &
! v(i,k-3,j), v(i,k-2,j), v(i,k-1,j), &
! v(i,k ,j), v(i,k+1,j), v(i,k+2,j), -vel )
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i, k&
& , j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*&
& vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, j)&
& +fzp(k)*v(i, k-1, j))
k = kts + 2
veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
vfluxd(i, k) = veld*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1, &
& j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0) + vel*((7.*(&
& vd(i, k, j)+vd(i, k-1, j))-vd(i, k+1, j)-vd(i, k-2, j))/12.0+&
& SIGN(1, time_step)*SIGN(1., -vel)*(vd(i, k+1, j)-vd(i, k-2, j)-&
& 3.*(vd(i, k, j)-vd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v(i&
& , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1, j)&
& -v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0)
k = ktf - 1
veld = 0.5*(romd(i, k, j)+romd(i, k, j-1))
vel = 0.5*(rom(i, k, j)+rom(i, k, j-1))
vfluxd(i, k) = veld*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1, &
& j)-v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0) + vel*((7.*(&
& vd(i, k, j)+vd(i, k-1, j))-vd(i, k+1, j)-vd(i, k-2, j))/12.0+&
& SIGN(1, time_step)*SIGN(1., -vel)*(vd(i, k+1, j)-vd(i, k-2, j)-&
& 3.*(vd(i, k, j)-vd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(v(i, k, j)+v(i, k-1, j))-(v(i, k+1, j)+v(i&
& , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(v(i, k+1, j)&
& -v(i, k-2, j)-3.*(v(i, k, j)-v(i, k-1, j)))/12.0)
k = ktf
vfluxd(i, k) = 0.5*((romd(i, k, j)+romd(i, k, j-1))*(fzm(k)*v(i, k&
& , j)+fzp(k)*v(i, k-1, j))+(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*&
& vd(i, k, j)+fzp(k)*vd(i, k-1, j)))
vflux(i, k) = 0.5*(rom(i, k, j)+rom(i, k, j-1))*(fzm(k)*v(i, k, j)&
& +fzp(k)*v(i, k-1, j))
END DO
DO k=kts,ktf
DO i=i_start,i_end
! We are calculating vertical fluxes on v points,
! so we must mean msf_v_x/y variables
! ADT eqn 45, 3rd term on RHS
tendencyd(i, k, j) = tendencyd(i, k, j) - msfvy(i, j)*rdzw(k)*(&
& vfluxd(i, k+1)-vfluxd(i, k))/msfvx(i, j)
tendency(i, k, j) = tendency(i, k, j) - msfvy(i, j)/msfvx(i, j)*&
& rdzw(k)*(vflux(i, k+1)-vflux(i, k))
END DO
END DO
END DO
END SUBROUTINE G_ADVECT_WENO_V
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.6 (r4165) - 21 sep 2011 20:54
!
! Differentiation of advect_weno_w in forward (tangent) mode:
! variations of useful results: tendency
! with respect to varying inputs: rom tendency w ru rv w_old
! RW status of diff variables: rom:in tendency:in-out w:in ru:in
! rv:in w_old:in
SUBROUTINE G_ADVECT_WENO_W(w, wd, w_old, w_oldd, tendency, tendencyd, ru&
& , rud, rv, rvd, rom, romd, mut, time_step, config_flags, msfux, msfuy&
& , msfvx, msfvy, msftx, msfty, fzm, fzp, rdx, rdy, rdzu, ids, ide, jds&
& , jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts&
& , kte)
IMPLICIT NONE
! Input data
TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
& jme, kms, kme, its, ite, jts, jte, kts, kte
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: w, w_old, ru&
& , rv, rom
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: wd, w_oldd, &
& rud, rvd, romd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendencyd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
& msfvy, msftx, msfty
REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp, rdzu
REAL, INTENT(IN) :: rdx, rdy
INTEGER, INTENT(IN) :: time_step
! Local data
INTEGER :: i, j, k, itf, jtf, ktf
INTEGER :: i_start, i_end, j_start, j_end
INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f
INTEGER :: jmin, jmax, jp, jm, imin, imax
REAL :: mrdx, mrdy, ub, vb, uw, vw
REAL :: ubd, vbd, uwd, vwd
REAL, DIMENSION(its:ite, kts:kte) :: vflux
REAL, DIMENSION(its:ite, kts:kte) :: vfluxd
REAL :: dir, vv
REAL :: ue, vs, vn, wb, wt
REAL, PARAMETER :: f30=7./12., f31=1./12.
REAL, PARAMETER :: f50=37./60., f51=2./15., f52=1./60.
INTEGER :: kt, kb
REAL :: qim2, qim1, qi, qip1, qip2
REAL :: qim2d, qim1d, qid, qip1d, qip2d
DOUBLE PRECISION :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, &
& sumwk
DOUBLE PRECISION :: beta0d, beta1d, beta2d, f0d, f1d, f2d, wi0d, wi1d&
& , wi2d, sumwkd
DOUBLE PRECISION, PARAMETER :: gi0=1.d0/10.d0, gi1=6.d0/10.d0, gi2=&
& 3.d0/10.d0, eps=1.0d-18
INTEGER, PARAMETER :: pw=2
INTEGER :: horz_order, vert_order
REAL, DIMENSION(its:ite + 1, kts:kte) :: fqx
REAL, DIMENSION(its:ite+1, kts:kte) :: fqxd
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqy
REAL, DIMENSION(its:ite, kts:kte, 2) :: fqyd
LOGICAL :: degrade_xs, degrade_ys
LOGICAL :: degrade_xe, degrade_ye
INTEGER :: jp1, jp0, jtmp
! definition of flux operators, 3rd, 4th, 5th or 6th order
REAL :: flux3, flux4, flux5, flux6
REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel
REAL :: veld
LOGICAL :: specified
DOUBLE PRECISION :: pwx1
DOUBLE PRECISION :: pwx1d
DOUBLE PRECISION :: pwr1
DOUBLE PRECISION :: pwr1d
INTRINSIC MAX
INTRINSIC SIGN
INTRINSIC MIN
specified = .false.
IF (config_flags%specified .OR. config_flags%nested) specified = &
& .true.
IF (kte .GT. kde - 1) THEN
ktf = kde - 1
ELSE
ktf = kte
END IF
horz_order = config_flags%h_sca_adv_order
vert_order = config_flags%v_sca_adv_order
! here is the choice of flux operators
! begin with horizontal flux divergence
! horizontal_order_test : IF( horz_order == 6 ) THEN
! ELSE IF (horz_order == 5 ) THEN
! determine boundary mods for flux operators
! We degrade the flux operators from 3rd/4th order
! to second order one gridpoint in from the boundaries for
! all boundary conditions except periodic and symmetry - these
! conditions have boundary zone data fill for correct application
! of the higher order flux stencils
degrade_xs = .true.
degrade_xe = .true.
degrade_ys = .true.
degrade_ye = .true.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xs) .OR. its &
& .GT. ids + 3) degrade_xs = .false.
IF ((config_flags%periodic_x .OR. config_flags%symmetric_xe) .OR. ite &
& .LT. ide - 3) degrade_xe = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ys) .OR. jts &
& .GT. jds + 3) degrade_ys = .false.
IF ((config_flags%periodic_y .OR. config_flags%symmetric_ye) .OR. jte &
& .LT. jde - 4) degrade_ye = .false.
!--------------- y - advection first
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
j_start_f = j_start
j_end_f = j_end + 1
IF (degrade_ys) THEN
IF (jts .LT. jds + 1) THEN
j_start = jds + 1
ELSE
j_start = jts
END IF
j_start_f = jds + 3
END IF
IF (degrade_ye) THEN
IF (jte .GT. jde - 2) THEN
j_end = jde - 2
ELSE
j_end = jte
END IF
j_end_f = jde - 3
END IF
IF (config_flags%polar) THEN
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
END IF
! compute fluxes, 5th or 6th order
jp1 = 2
jp0 = 1
fqyd = 0.0
j_loop_y_flux_5:DO j=j_start,j_end+1
IF (j .GE. j_start_f .AND. j .LE. j_end_f) THEN
DO k=kts+1,ktf
DO i=i_start,i_end
veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = wd(i, k, j+1)
qip2 = w(i, k, j+1)
qip1d = wd(i, k, j)
qip1 = w(i, k, j)
qid = wd(i, k, j-1)
qi = w(i, k, j-1)
qim1d = wd(i, k, j-2)
qim1 = w(i, k, j-2)
qim2d = wd(i, k, j-3)
qim2 = w(i, k, j-3)
ELSE
qip2d = wd(i, k, j-2)
qip2 = w(i, k, j-2)
qip1d = wd(i, k, j-1)
qip1 = w(i, k, j-1)
qid = wd(i, k, j)
qi = w(i, k, j)
qim1d = wd(i, k, j+1)
qim1 = w(i, k, j+1)
qim2d = wd(i, k, j+2)
qim2 = w(i, k, j+2)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*&
& (qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*&
& qi)**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*&
& (qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*&
& (qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*&
& qi)**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqyd(i, k, jp1) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+&
& wi0*f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+&
& wi1*f1+wi2*f2)*sumwkd)/sumwk**2
fqy(i, k, jp1) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
! fqy( i, k, jp1 ) = vel*flux5( &
! w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), &
! w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel )
k = ktf + 1
DO i=i_start,i_end
veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = wd(i, k, j+1)
qip2 = w(i, k, j+1)
qip1d = wd(i, k, j)
qip1 = w(i, k, j)
qid = wd(i, k, j-1)
qi = w(i, k, j-1)
qim1d = wd(i, k, j-2)
qim1 = w(i, k, j-2)
qim2d = wd(i, k, j-3)
qim2 = w(i, k, j-3)
ELSE
qip2d = wd(i, k, j-2)
qip2 = w(i, k, j-2)
qip1d = wd(i, k, j-1)
qip1 = w(i, k, j-1)
qid = wd(i, k, j)
qi = w(i, k, j)
qim1d = wd(i, k, j+1)
qim1 = w(i, k, j+1)
qim2d = wd(i, k, j+2)
qim2 = w(i, k, j+2)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
& qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
& )**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
& qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
& qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
& )**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqyd(i, k, jp1) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0&
& *f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*&
& f1+wi2*f2)*sumwkd)/sumwk**2
fqy(i, k, jp1) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
ELSE IF (j .EQ. jds + 1) THEN
! fqy( i, k, jp1 ) = vel*flux5( &
! w(i,k,j-3), w(i,k,j-2), w(i,k,j-1), &
! w(i,k,j ), w(i,k,j+1), w(i,k,j+2), vel )
! 2nd order flux next to south boundary
DO k=kts+1,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-1&
& , j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k)*&
& rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))&
& *(w(i, k, j)+w(i, k, j-1))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
& rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(i&
& , k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1)))
fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i&
& , k-2, j))*(w(i, k, j)+w(i, k, j-1))
END DO
ELSE IF (j .EQ. jds + 2) THEN
! third of 4th order flux 2 in from south boundary
DO k=kts+1,ktf
DO i=i_start,i_end
veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/&
& 12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-&
& wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, &
& k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
& +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(&
& i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
& +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
& , k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0) + &
& vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-wd(i, k, j-&
& 2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, k, j+1)-wd(i&
& , k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j+1&
& )+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i, k&
& , j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
END DO
ELSE IF (j .EQ. jde - 1) THEN
! 2nd order flux next to north boundary
DO k=kts+1,ktf
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*((fzm(k)*rvd(i, k, j)+fzp(k)*rvd(i, k-1&
& , j))*(w(i, k, j)+w(i, k, j-1))+(fzm(k)*rv(i, k, j)+fzp(k)*&
& rv(i, k-1, j))*(wd(i, k, j)+wd(i, k, j-1)))
fqy(i, k, jp1) = 0.5*(fzm(k)*rv(i, k, j)+fzp(k)*rv(i, k-1, j))&
& *(w(i, k, j)+w(i, k, j-1))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
fqyd(i, k, jp1) = 0.5*(((2.-fzm(k-1))*rvd(i, k-1, j)-fzp(k-1)*&
& rvd(i, k-2, j))*(w(i, k, j)+w(i, k, j-1))+((2.-fzm(k-1))*rv(i&
& , k-1, j)-fzp(k-1)*rv(i, k-2, j))*(wd(i, k, j)+wd(i, k, j-1)))
fqy(i, k, jp1) = 0.5*((2.-fzm(k-1))*rv(i, k-1, j)-fzp(k-1)*rv(i&
& , k-2, j))*(w(i, k, j)+w(i, k, j-1))
END DO
ELSE IF (j .EQ. jde - 2) THEN
! 3rd or 4th order flux 2 in from north boundary
DO k=kts+1,ktf
DO i=i_start,i_end
veld = fzm(k)*rvd(i, k, j) + fzp(k)*rvd(i, k-1, j)
vel = fzm(k)*rv(i, k, j) + fzp(k)*rv(i, k-1, j)
fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k&
& , j+1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*&
& (w(i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/&
& 12.0) + vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-&
& wd(i, k, j-2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, &
& k, j+1)-wd(i, k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
& +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(&
& i, k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
veld = (2.-fzm(k-1))*rvd(i, k-1, j) - fzp(k-1)*rvd(i, k-2, j)
vel = (2.-fzm(k-1))*rv(i, k-1, j) - fzp(k-1)*rv(i, k-2, j)
fqyd(i, k, jp1) = veld*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j&
& +1)+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
& , k, j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0) + &
& vel*((7.*(wd(i, k, j)+wd(i, k, j-1))-wd(i, k, j+1)-wd(i, k, j-&
& 2))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i, k, j+1)-wd(i&
& , k, j-2)-3.*(wd(i, k, j)-wd(i, k, j-1)))/12.0)
fqy(i, k, jp1) = vel*((7.*(w(i, k, j)+w(i, k, j-1))-(w(i, k, j+1&
& )+w(i, k, j-2)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i, k&
& , j+1)-w(i, k, j-2)-3.*(w(i, k, j)-w(i, k, j-1)))/12.0)
END DO
END IF
! y flux-divergence into tendency
! Comments for polar boundary conditions
! Same process as for advect_u - tendencies run from jds to jde-1
! (latitudes are as for u grid, longitudes are displaced)
! Therefore: flow is only from one side for points next to poles
IF (config_flags%polar .AND. j .EQ. jds + 1) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*fqyd(i, k, &
& jp1)
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*fqy(i, k, jp1&
& )
END DO
END DO
ELSE IF (config_flags%polar .AND. j .EQ. jde) THEN
DO k=kts,ktf
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) + mrdy*fqyd(i, k, &
& jp0)
tendency(i, k, j-1) = tendency(i, k, j-1) + mrdy*fqy(i, k, jp0&
& )
END DO
END DO
ELSE IF (j .GT. j_start) THEN
! normal code
DO k=kts+1,ktf+1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 2nd term RHS
mrdy = msftx(i, j-1)*rdy
tendencyd(i, k, j-1) = tendencyd(i, k, j-1) - mrdy*(fqyd(i, k&
& , jp1)-fqyd(i, k, jp0))
tendency(i, k, j-1) = tendency(i, k, j-1) - mrdy*(fqy(i, k, &
& jp1)-fqy(i, k, jp0))
END DO
END DO
END IF
jtmp = jp1
jp1 = jp0
jp0 = jtmp
END DO j_loop_y_flux_5
! next, x - flux divergence
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
! higher order flux has a 5 or 7 point stencil, so compute
! bounds so we can switch to second order flux close to the boundary
i_start_f = i_start
i_end_f = i_end + 1
IF (degrade_xs) THEN
IF (ids + 1 .LT. its) THEN
i_start = its
ELSE
i_start = ids + 1
END IF
IF (i_start + 2 .GT. ids + 3) THEN
i_start_f = ids + 3
ELSE
i_start_f = i_start + 2
END IF
END IF
IF (degrade_xe) THEN
IF (ide - 2 .GT. ite) THEN
i_end = ite
ELSE
i_end = ide - 2
END IF
i_end_f = ide - 3
fqxd = 0.0
ELSE
fqxd = 0.0
END IF
! compute fluxes
DO j=j_start,j_end
! 5th or 6th order flux
DO k=kts+1,ktf
DO i=i_start_f,i_end_f
veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = wd(i+1, k, j)
qip2 = w(i+1, k, j)
qip1d = wd(i, k, j)
qip1 = w(i, k, j)
qid = wd(i-1, k, j)
qi = w(i-1, k, j)
qim1d = wd(i-2, k, j)
qim1 = w(i-2, k, j)
qim2d = wd(i-3, k, j)
qim2 = w(i-3, k, j)
ELSE
qip2d = wd(i-2, k, j)
qip2 = w(i-2, k, j)
qip1d = wd(i-1, k, j)
qip1 = w(i-1, k, j)
qid = wd(i, k, j)
qi = w(i, k, j)
qim1d = wd(i+1, k, j)
qim1 = w(i+1, k, j)
qim2d = wd(i+2, k, j)
qim2 = w(i+2, k, j)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
& qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
& )**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
& qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
& qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
& )**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*f0d+&
& wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1+wi2&
& *f2)*sumwkd)/sumwk**2
fqx(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
! fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), &
! w(i-1,k,j), w(i ,k,j), &
! w(i+1,k,j), w(i+2,k,j), &
! vel )
k = ktf + 1
DO i=i_start_f,i_end_f
veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
IF (vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = wd(i+1, k, j)
qip2 = w(i+1, k, j)
qip1d = wd(i, k, j)
qip1 = w(i, k, j)
qid = wd(i-1, k, j)
qi = w(i-1, k, j)
qim1d = wd(i-2, k, j)
qim1 = w(i-2, k, j)
qim2d = wd(i-3, k, j)
qim2 = w(i-3, k, j)
ELSE
qip2d = wd(i-2, k, j)
qip2 = w(i-2, k, j)
qip1d = wd(i-1, k, j)
qip1 = w(i-1, k, j)
qid = wd(i, k, j)
qi = w(i, k, j)
qim1d = wd(i+1, k, j)
qim1 = w(i+1, k, j)
qim2d = wd(i+2, k, j)
qim2 = w(i+2, k, j)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
& qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi)&
& **2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
& qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
& qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi)&
& **2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
fqxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*f0d+&
& wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1+wi2*&
& f2)*sumwkd)/sumwk**2
fqx(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
! fqx( i,k ) = vel*flux5( w(i-3,k,j), w(i-2,k,j), &
! w(i-1,k,j), w(i ,k,j), &
! w(i+1,k,j), w(i+2,k,j), &
! vel )
! lower order fluxes close to boundaries (if not periodic or symmetric)
IF (degrade_xs) THEN
DO i=i_start,i_start_f-1
IF (i .EQ. ids + 1) THEN
! second order
DO k=kts+1,ktf
fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, j)&
& )*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)*ru(&
& i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*(w&
& (i, k, j)+w(i-1, k, j))
END DO
k = ktf + 1
fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud(i&
& , k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i, k-&
& 1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, j)))
fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-&
& 2, j))*(w(i, k, j)+w(i-1, k, j))
END IF
IF (i .EQ. ids + 2) THEN
! third order
DO k=kts+1,ktf
veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
& j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w&
& (i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/&
& 12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)&
& -wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(&
& i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/&
& 12.0)
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
& +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
& +1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
END DO
k = ktf + 1
veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
& +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1&
& , k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0) + &
& vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)-wd(i-2, k&
& , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i+1, k, j)-&
& wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w&
& (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1, &
& k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
END IF
END DO
END IF
IF (degrade_xe) THEN
DO i=i_end_f+1,i_end+1
IF (i .EQ. ide - 1) THEN
! second order flux next to the boundary
DO k=kts+1,ktf
fqxd(i, k) = 0.5*((fzm(k)*rud(i, k, j)+fzp(k)*rud(i, k-1, j)&
& )*(w(i, k, j)+w(i-1, k, j))+(fzm(k)*ru(i, k, j)+fzp(k)*ru(&
& i, k-1, j))*(wd(i, k, j)+wd(i-1, k, j)))
fqx(i, k) = 0.5*(fzm(k)*ru(i, k, j)+fzp(k)*ru(i, k-1, j))*(w&
& (i, k, j)+w(i-1, k, j))
END DO
k = ktf + 1
fqxd(i, k) = 0.5*(((2.-fzm(k-1))*rud(i, k-1, j)-fzp(k-1)*rud(i&
& , k-2, j))*(w(i, k, j)+w(i-1, k, j))+((2.-fzm(k-1))*ru(i, k-&
& 1, j)-fzp(k-1)*ru(i, k-2, j))*(wd(i, k, j)+wd(i-1, k, j)))
fqx(i, k) = 0.5*((2.-fzm(k-1))*ru(i, k-1, j)-fzp(k-1)*ru(i, k-&
& 2, j))*(w(i, k, j)+w(i-1, k, j))
END IF
IF (i .EQ. ide - 2) THEN
! third order flux one in from the boundary
DO k=kts+1,ktf
veld = fzm(k)*rud(i, k, j) + fzp(k)*rud(i, k-1, j)
vel = fzm(k)*ru(i, k, j) + fzp(k)*ru(i, k-1, j)
fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, &
& j)+w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w&
& (i+1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/&
& 12.0) + vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)&
& -wd(i-2, k, j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(&
& i+1, k, j)-wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/&
& 12.0)
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
& +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i&
& +1, k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
END DO
k = ktf + 1
veld = (2.-fzm(k-1))*rud(i, k-1, j) - fzp(k-1)*rud(i, k-2, j)
vel = (2.-fzm(k-1))*ru(i, k-1, j) - fzp(k-1)*ru(i, k-2, j)
fqxd(i, k) = veld*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)&
& +w(i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1&
& , k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0) + &
& vel*((7.*(wd(i, k, j)+wd(i-1, k, j))-wd(i+1, k, j)-wd(i-2, k&
& , j))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(wd(i+1, k, j)-&
& wd(i-2, k, j)-3.*(wd(i, k, j)-wd(i-1, k, j)))/12.0)
fqx(i, k) = vel*((7.*(w(i, k, j)+w(i-1, k, j))-(w(i+1, k, j)+w&
& (i-2, k, j)))/12.0+SIGN(1, time_step)*SIGN(1., vel)*(w(i+1, &
& k, j)-w(i-2, k, j)-3.*(w(i, k, j)-w(i-1, k, j)))/12.0)
END IF
END DO
END IF
! x flux-divergence into tendency
DO k=kts+1,ktf+1
DO i=i_start,i_end
! see ADT eqn 46 dividing by my, 1st term RHS
mrdx = msftx(i, j)*rdx
tendencyd(i, k, j) = tendencyd(i, k, j) - mrdx*(fqxd(i+1, k)-&
& fqxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - mrdx*(fqx(i+1, k)-fqx(i&
& , k))
END DO
END DO
END DO
! pick up the the horizontal radiation boundary conditions.
! (these are the computations that don't require 'cb'.
! first, set to index ranges
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
IF (config_flags%open_xs .AND. its .EQ. ids) THEN
DO j=j_start,j_end
DO k=kts+1,ktf
uwd = 0.5*(fzm(k)*(rud(its, k, j)+rud(its+1, k, j))+fzp(k)*(rud(&
& its, k-1, j)+rud(its+1, k-1, j)))
uw = 0.5*(fzm(k)*(ru(its, k, j)+ru(its+1, k, j))+fzp(k)*(ru(its&
& , k-1, j)+ru(its+1, k-1, j)))
IF (uw .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(w_old(&
& its+1, k, j)-w_old(its, k, j))+ub*(w_oldd(its+1, k, j)-w_oldd(&
& its, k, j))+wd(its, k, j)*(fzm(k)*(ru(its+1, k, j)-ru(its, k, &
& j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j)))+w(its, k, j)*(&
& fzm(k)*(rud(its+1, k, j)-rud(its, k, j))+fzp(k)*(rud(its+1, k-&
& 1, j)-rud(its, k-1, j))))
tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(w_old(its+1&
& , k, j)-w_old(its, k, j))+w(its, k, j)*(fzm(k)*(ru(its+1, k, j&
& )-ru(its, k, j))+fzp(k)*(ru(its+1, k-1, j)-ru(its, k-1, j))))
END DO
END DO
k = ktf + 1
DO j=j_start,j_end
uwd = 0.5*((2.-fzm(k-1))*(rud(its, k-1, j)+rud(its+1, k-1, j))-fzp&
& (k-1)*(rud(its, k-2, j)+rud(its+1, k-2, j)))
uw = 0.5*((2.-fzm(k-1))*(ru(its, k-1, j)+ru(its+1, k-1, j))-fzp(k-&
& 1)*(ru(its, k-2, j)+ru(its+1, k-2, j)))
IF (uw .GT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
tendencyd(its, k, j) = tendencyd(its, k, j) - rdx*(ubd*(w_old(its+&
& 1, k, j)-w_old(its, k, j))+ub*(w_oldd(its+1, k, j)-w_oldd(its, k&
& , j))+wd(its, k, j)*((2.-fzm(k-1))*(ru(its+1, k-1, j)-ru(its, k-&
& 1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2, j)))+w(its, k, j&
& )*((2.-fzm(k-1))*(rud(its+1, k-1, j)-rud(its, k-1, j))-fzp(k-1)*&
& (rud(its+1, k-2, j)-rud(its, k-2, j))))
tendency(its, k, j) = tendency(its, k, j) - rdx*(ub*(w_old(its+1, &
& k, j)-w_old(its, k, j))+w(its, k, j)*((2.-fzm(k-1))*(ru(its+1, k&
& -1, j)-ru(its, k-1, j))-fzp(k-1)*(ru(its+1, k-2, j)-ru(its, k-2&
& , j))))
END DO
END IF
IF (config_flags%open_xe .AND. ite .EQ. ide) THEN
DO j=j_start,j_end
DO k=kts+1,ktf
uwd = 0.5*(fzm(k)*(rud(ite-1, k, j)+rud(ite, k, j))+fzp(k)*(rud(&
& ite-1, k-1, j)+rud(ite, k-1, j)))
uw = 0.5*(fzm(k)*(ru(ite-1, k, j)+ru(ite, k, j))+fzp(k)*(ru(ite-&
& 1, k-1, j)+ru(ite, k-1, j)))
IF (uw .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(&
& w_old(i_end, k, j)-w_old(i_end-1, k, j))+ub*(w_oldd(i_end, k, &
& j)-w_oldd(i_end-1, k, j))+wd(i_end, k, j)*(fzm(k)*(ru(ite, k, &
& j)-ru(ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, k-1, j))&
& )+w(i_end, k, j)*(fzm(k)*(rud(ite, k, j)-rud(ite-1, k, j))+fzp&
& (k)*(rud(ite, k-1, j)-rud(ite-1, k-1, j))))
tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(w_old(&
& i_end, k, j)-w_old(i_end-1, k, j))+w(i_end, k, j)*(fzm(k)*(ru(&
& ite, k, j)-ru(ite-1, k, j))+fzp(k)*(ru(ite, k-1, j)-ru(ite-1, &
& k-1, j))))
END DO
END DO
k = ktf + 1
DO j=j_start,j_end
uwd = 0.5*((2.-fzm(k-1))*(rud(ite-1, k-1, j)+rud(ite, k-1, j))-fzp&
& (k-1)*(rud(ite-1, k-2, j)+rud(ite, k-2, j)))
uw = 0.5*((2.-fzm(k-1))*(ru(ite-1, k-1, j)+ru(ite, k-1, j))-fzp(k-&
& 1)*(ru(ite-1, k-2, j)+ru(ite, k-2, j)))
IF (uw .LT. 0.) THEN
ub = 0.
ubd = 0.0
ELSE
ubd = uwd
ub = uw
END IF
tendencyd(i_end, k, j) = tendencyd(i_end, k, j) - rdx*(ubd*(w_old(&
& i_end, k, j)-w_old(i_end-1, k, j))+ub*(w_oldd(i_end, k, j)-&
& w_oldd(i_end-1, k, j))+wd(i_end, k, j)*((2.-fzm(k-1))*(ru(ite, k&
& -1, j)-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-ru(ite-1, k-&
& 2, j)))+w(i_end, k, j)*((2.-fzm(k-1))*(rud(ite, k-1, j)-rud(ite-&
& 1, k-1, j))-fzp(k-1)*(rud(ite, k-2, j)-rud(ite-1, k-2, j))))
tendency(i_end, k, j) = tendency(i_end, k, j) - rdx*(ub*(w_old(&
& i_end, k, j)-w_old(i_end-1, k, j))+w(i_end, k, j)*((2.-fzm(k-1))&
& *(ru(ite, k-1, j)-ru(ite-1, k-1, j))-fzp(k-1)*(ru(ite, k-2, j)-&
& ru(ite-1, k-2, j))))
END DO
END IF
IF (config_flags%open_ys .AND. jts .EQ. jds) THEN
DO i=i_start,i_end
DO k=kts+1,ktf
vwd = 0.5*(fzm(k)*(rvd(i, k, jts)+rvd(i, k, jts+1))+fzp(k)*(rvd(&
& i, k-1, jts)+rvd(i, k-1, jts+1)))
vw = 0.5*(fzm(k)*(rv(i, k, jts)+rv(i, k, jts+1))+fzp(k)*(rv(i, k&
& -1, jts)+rv(i, k-1, jts+1)))
IF (vw .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(w_old(i&
& , k, jts+1)-w_old(i, k, jts))+vb*(w_oldd(i, k, jts+1)-w_oldd(i&
& , k, jts))+wd(i, k, jts)*(fzm(k)*(rv(i, k, jts+1)-rv(i, k, jts&
& ))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts)))+w(i, k, jts)*(&
& fzm(k)*(rvd(i, k, jts+1)-rvd(i, k, jts))+fzp(k)*(rvd(i, k-1, &
& jts+1)-rvd(i, k-1, jts))))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(w_old(i, k&
& , jts+1)-w_old(i, k, jts))+w(i, k, jts)*(fzm(k)*(rv(i, k, jts+&
& 1)-rv(i, k, jts))+fzp(k)*(rv(i, k-1, jts+1)-rv(i, k-1, jts))))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
vwd = 0.5*((2.-fzm(k-1))*(rvd(i, k-1, jts)+rvd(i, k-1, jts+1))-fzp&
& (k-1)*(rvd(i, k-2, jts)+rvd(i, k-2, jts+1)))
vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jts)+rv(i, k-1, jts+1))-fzp(k-&
& 1)*(rv(i, k-2, jts)+rv(i, k-2, jts+1)))
IF (vw .GT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
tendencyd(i, k, jts) = tendencyd(i, k, jts) - rdy*(vbd*(w_old(i, k&
& , jts+1)-w_old(i, k, jts))+vb*(w_oldd(i, k, jts+1)-w_oldd(i, k, &
& jts))+wd(i, k, jts)*((2.-fzm(k-1))*(rv(i, k-1, jts+1)-rv(i, k-1&
& , jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2, jts)))+w(i, k, &
& jts)*((2.-fzm(k-1))*(rvd(i, k-1, jts+1)-rvd(i, k-1, jts))-fzp(k-&
& 1)*(rvd(i, k-2, jts+1)-rvd(i, k-2, jts))))
tendency(i, k, jts) = tendency(i, k, jts) - rdy*(vb*(w_old(i, k, &
& jts+1)-w_old(i, k, jts))+w(i, k, jts)*((2.-fzm(k-1))*(rv(i, k-1&
& , jts+1)-rv(i, k-1, jts))-fzp(k-1)*(rv(i, k-2, jts+1)-rv(i, k-2&
& , jts))))
END DO
END IF
IF (config_flags%open_ye .AND. jte .EQ. jde) THEN
DO i=i_start,i_end
DO k=kts+1,ktf
vwd = 0.5*(fzm(k)*(rvd(i, k, jte-1)+rvd(i, k, jte))+fzp(k)*(rvd(&
& i, k-1, jte-1)+rvd(i, k-1, jte)))
vw = 0.5*(fzm(k)*(rv(i, k, jte-1)+rv(i, k, jte))+fzp(k)*(rv(i, k&
& -1, jte-1)+rv(i, k-1, jte)))
IF (vw .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(&
& w_old(i, k, j_end)-w_old(i, k, j_end-1))+vb*(w_oldd(i, k, &
& j_end)-w_oldd(i, k, j_end-1))+wd(i, k, j_end)*(fzm(k)*(rv(i, k&
& , jte)-rv(i, k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, jte&
& -1)))+w(i, k, j_end)*(fzm(k)*(rvd(i, k, jte)-rvd(i, k, jte-1))&
& +fzp(k)*(rvd(i, k-1, jte)-rvd(i, k-1, jte-1))))
tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(w_old(i&
& , k, j_end)-w_old(i, k, j_end-1))+w(i, k, j_end)*(fzm(k)*(rv(i&
& , k, jte)-rv(i, k, jte-1))+fzp(k)*(rv(i, k-1, jte)-rv(i, k-1, &
& jte-1))))
END DO
END DO
k = ktf + 1
DO i=i_start,i_end
vwd = 0.5*((2.-fzm(k-1))*(rvd(i, k-1, jte-1)+rvd(i, k-1, jte))-fzp&
& (k-1)*(rvd(i, k-2, jte-1)+rvd(i, k-2, jte)))
vw = 0.5*((2.-fzm(k-1))*(rv(i, k-1, jte-1)+rv(i, k-1, jte))-fzp(k-&
& 1)*(rv(i, k-2, jte-1)+rv(i, k-2, jte)))
IF (vw .LT. 0.) THEN
vb = 0.
vbd = 0.0
ELSE
vbd = vwd
vb = vw
END IF
tendencyd(i, k, j_end) = tendencyd(i, k, j_end) - rdy*(vbd*(w_old(&
& i, k, j_end)-w_old(i, k, j_end-1))+vb*(w_oldd(i, k, j_end)-&
& w_oldd(i, k, j_end-1))+wd(i, k, j_end)*((2.-fzm(k-1))*(rv(i, k-1&
& , jte)-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(i, k-2, &
& jte-1)))+w(i, k, j_end)*((2.-fzm(k-1))*(rvd(i, k-1, jte)-rvd(i, &
& k-1, jte-1))-fzp(k-1)*(rvd(i, k-2, jte)-rvd(i, k-2, jte-1))))
tendency(i, k, j_end) = tendency(i, k, j_end) - rdy*(vb*(w_old(i, &
& k, j_end)-w_old(i, k, j_end-1))+w(i, k, j_end)*((2.-fzm(k-1))*(&
& rv(i, k-1, jte)-rv(i, k-1, jte-1))-fzp(k-1)*(rv(i, k-2, jte)-rv(&
& i, k-2, jte-1))))
END DO
END IF
!-------------------- vertical advection
! ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
! Here we have: - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
! Therefore we don't need to make a correction for advect_w
i_start = its
IF (ite .GT. ide - 1) THEN
i_end = ide - 1
ELSE
i_end = ite
END IF
j_start = jts
IF (jte .GT. jde - 1) THEN
j_end = jde - 1
ELSE
j_end = jte
END IF
DO i=i_start,i_end
vfluxd(i, kts) = 0.0
vflux(i, kts) = 0.
vfluxd(i, kte) = 0.0
vflux(i, kte) = 0.
END DO
vfluxd = 0.0
! vert_order_test : IF (vert_order == 6) THEN
! ELSE IF (vert_order == 5) THEN
DO j=j_start,j_end
DO k=kts+3,ktf-1
DO i=i_start,i_end
veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
IF (-vel*sign(1,time_step) .GE. 0.0) THEN
qip2d = wd(i, k+1, j)
qip2 = w(i, k+1, j)
qip1d = wd(i, k, j)
qip1 = w(i, k, j)
qid = wd(i, k-1, j)
qi = w(i, k-1, j)
qim1d = wd(i, k-2, j)
qim1 = w(i, k-2, j)
qim2d = wd(i, k-3, j)
qim2 = w(i, k-3, j)
ELSE
qip2d = wd(i, k-2, j)
qip2 = w(i, k-2, j)
qip1d = wd(i, k-1, j)
qip1 = w(i, k-1, j)
qid = wd(i, k, j)
qi = w(i, k, j)
qim1d = wd(i, k+1, j)
qim1 = w(i, k+1, j)
qim2d = wd(i, k+2, j)
qim2 = w(i, k+2, j)
END IF
f0d = qim2d/3. - 7.*qim1d/6. + 11.*qid/6.
f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi
f1d = 5.*qid/6. - qim1d/6. + qip1d/3.
f1 = -(1./6.*qim1) + 5./6.*qi + 1./3.*qip1
f2d = qid/3. + 5.*qip1d/6. - qip2d/6.
f2 = 1./3.*qi + 5./6.*qip1 - 1./6.*qip2
beta0d = 13.*2*(qim2-2.*qim1+qi)*(qim2d-2.*qim1d+qid)/12. + 2*(&
& qim2-4.*qim1+3.*qi)*(qim2d-4.*qim1d+3.*qid)/4.
beta0 = 13./12.*(qim2-2.*qim1+qi)**2 + 1./4.*(qim2-4.*qim1+3.*qi&
& )**2
beta1d = 13.*2*(qim1-2.*qi+qip1)*(qim1d-2.*qid+qip1d)/12. + 2*(&
& qim1-qip1)*(qim1d-qip1d)/4.
beta1 = 13./12.*(qim1-2.*qi+qip1)**2 + 1./4.*(qim1-qip1)**2
beta2d = 13.*2*(qi-2.*qip1+qip2)*(qid-2.*qip1d+qip2d)/12. + 2*(&
& qip2-4.*qip1+3.*qi)*(qip2d-4.*qip1d+3.*qid)/4.
beta2 = 13./12.*(qi-2.*qip1+qip2)**2 + 1./4.*(qip2-4.*qip1+3.*qi&
& )**2
pwx1d = beta0d
pwx1 = eps + beta0
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi0d = -(gi0*pwr1d/pwr1**2)
wi0 = gi0/pwr1
pwx1d = beta1d
pwx1 = eps + beta1
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi1d = -(gi1*pwr1d/pwr1**2)
wi1 = gi1/pwr1
pwx1d = beta2d
pwx1 = eps + beta2
IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. pw .EQ. INT(pw))) &
& THEN
pwr1d = pw*pwx1**(pw-1)*pwx1d
ELSE IF (pwx1 .EQ. 0.0 .AND. pw .EQ. 1.0) THEN
pwr1d = pwx1d
ELSE
pwr1d = 0.0
END IF
pwr1 = pwx1**pw
wi2d = -(gi2*pwr1d/pwr1**2)
wi2 = gi2/pwr1
sumwkd = wi0d + wi1d + wi2d
sumwk = wi0 + wi1 + wi2
vfluxd(i, k) = ((veld*(wi0*f0+wi1*f1+wi2*f2)+vel*(wi0d*f0+wi0*&
& f0d+wi1d*f1+wi1*f1d+wi2d*f2+wi2*f2d))*sumwk-vel*(wi0*f0+wi1*f1&
& +wi2*f2)*sumwkd)/sumwk**2
vflux(i, k) = vel*(wi0*f0+wi1*f1+wi2*f2)/sumwk
END DO
END DO
! vflux(i,k) = vel*flux5( &
! w(i,k-3,j), w(i,k-2,j), w(i,k-1,j), &
! w(i,k ,j), w(i,k+1,j), w(i,k+2,j), -vel )
DO i=i_start,i_end
k = kts + 1
vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)+w&
& (i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i, k-&
& 1, j)))
vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i, &
& k-1, j))
k = kts + 2
veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
vfluxd(i, k) = veld*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1, &
& j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0) + vel*((7.*(&
& wd(i, k, j)+wd(i, k-1, j))-wd(i, k+1, j)-wd(i, k-2, j))/12.0+&
& SIGN(1, time_step)*SIGN(1., -vel)*(wd(i, k+1, j)-wd(i, k-2, j)-&
& 3.*(wd(i, k, j)-wd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w(i&
& , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1, j)&
& -w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0)
k = ktf
veld = 0.5*(romd(i, k, j)+romd(i, k-1, j))
vel = 0.5*(rom(i, k, j)+rom(i, k-1, j))
vfluxd(i, k) = veld*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w&
& (i, k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1, &
& j)-w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0) + vel*((7.*(&
& wd(i, k, j)+wd(i, k-1, j))-wd(i, k+1, j)-wd(i, k-2, j))/12.0+&
& SIGN(1, time_step)*SIGN(1., -vel)*(wd(i, k+1, j)-wd(i, k-2, j)-&
& 3.*(wd(i, k, j)-wd(i, k-1, j)))/12.0)
vflux(i, k) = vel*((7.*(w(i, k, j)+w(i, k-1, j))-(w(i, k+1, j)+w(i&
& , k-2, j)))/12.0+SIGN(1, time_step)*SIGN(1., -vel)*(w(i, k+1, j)&
& -w(i, k-2, j)-3.*(w(i, k, j)-w(i, k-1, j)))/12.0)
k = ktf + 1
vfluxd(i, k) = 0.25*((romd(i, k, j)+romd(i, k-1, j))*(w(i, k, j)+w&
& (i, k-1, j))+(rom(i, k, j)+rom(i, k-1, j))*(wd(i, k, j)+wd(i, k-&
& 1, j)))
vflux(i, k) = 0.25*(rom(i, k, j)+rom(i, k-1, j))*(w(i, k, j)+w(i, &
& k-1, j))
END DO
DO k=kts+1,ktf
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) - rdzu(k)*(vfluxd(i, k+1&
& )-vfluxd(i, k))
tendency(i, k, j) = tendency(i, k, j) - rdzu(k)*(vflux(i, k+1)-&
& vflux(i, k))
END DO
END DO
! pick up flux contribution for w at the lid, wcs. 13 march 2004
k = ktf + 1
DO i=i_start,i_end
tendencyd(i, k, j) = tendencyd(i, k, j) + 2.*rdzu(k-1)*vfluxd(i, k&
& )
tendency(i, k, j) = tendency(i, k, j) + 2.*rdzu(k-1)*vflux(i, k)
END DO
END DO
END SUBROUTINE G_ADVECT_WENO_W
END MODULE g_module_advect_em