! ======================================================================================
! This file was generated by the version 5.3.5 of DFT on 07/13/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
! ======================================================================================
#ifndef DOUBLE_PRECISION
#   define VPOWX vspowx
#   define VPOW  vspow
#else
#   define VPOWX vpowx
#   define VPOW  vpow
#endif

 MODULE g_module_big_step_utilities_em

 USE module_model_constants
 USE module_state_description, only: p_qg, p_qs, p_qi, gdscheme, tiedtkescheme, ntiedtkescheme, &
 kfetascheme, mskfscheme, g3scheme, p_qv, param_first_scalar, p_qr, p_qc, DFI_FWD
 USE module_configure, ONLY : grid_config_rec_type
 USE module_wrf_error

 CONTAINS

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
!  Differentiation of calc_mu_uv in forward (tangent) mode:
!   variations   of useful results: muu muv
!   with respect to varying inputs: muu muv mu
!   RW status of diff variables: muu:in-out muv:in-out mu:in
SUBROUTINE G_CALC_MU_UV(config_flags, mu, mud, mub, muu, muud, muv, muvd&
&  , 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, jms:jme), INTENT(OUT) :: muu, muv
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: muud, muvd
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, mub
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mud
!  local stuff
  INTEGER :: i, j, itf, jtf, im, jm
  INTRINSIC MIN
!<DESCRIPTION>
!
!  calc_mu_uv calculates the full column dry-air mass at the staggered
!  horizontal velocity points (u,v) and places the results in muu and muv.
!  This routine uses the reference state (mub) and perturbation state (mu)
!
!</DESCRIPTION>
  itf = ite
  IF (jte .GT. jde - 1) THEN
    jtf = jde - 1
  ELSE
    jtf = jte
  END IF
  IF (its .NE. ids .AND. ite .NE. ide) THEN
    DO j=jts,jtf
      DO i=its,itf
        muud(i, j) = 0.5*(mud(i, j)+mud(i-1, j))
        muu(i, j) = 0.5*(mu(i, j)+mu(i-1, j)+mub(i, j)+mub(i-1, j))
      END DO
    END DO
  ELSE IF (its .EQ. ids .AND. ite .NE. ide) THEN
    DO j=jts,jtf
      DO i=its+1,itf
        muud(i, j) = 0.5*(mud(i, j)+mud(i-1, j))
        muu(i, j) = 0.5*(mu(i, j)+mu(i-1, j)+mub(i, j)+mub(i-1, j))
      END DO
    END DO
    i = its
    im = its
    IF (config_flags%periodic_x) im = its - 1
    DO j=jts,jtf
!            muu(i,j) =      mu(i,j)          +mub(i,j)
!  fix for periodic b.c., 13 march 2004, wcs
      muud(i, j) = 0.5*(mud(i, j)+mud(im, j))
      muu(i, j) = 0.5*(mu(i, j)+mu(im, j)+mub(i, j)+mub(im, j))
    END DO
  ELSE IF (its .NE. ids .AND. ite .EQ. ide) THEN
    DO j=jts,jtf
      DO i=its,itf-1
        muud(i, j) = 0.5*(mud(i, j)+mud(i-1, j))
        muu(i, j) = 0.5*(mu(i, j)+mu(i-1, j)+mub(i, j)+mub(i-1, j))
      END DO
    END DO
    i = ite
    im = ite - 1
    IF (config_flags%periodic_x) im = ite
    DO j=jts,jtf
!            muu(i,j) =      mu(i-1,j)        +mub(i-1,j)
!  fix for periodic b.c., 13 march 2004, wcs
      muud(i, j) = 0.5*(mud(i-1, j)+mud(im, j))
      muu(i, j) = 0.5*(mu(i-1, j)+mu(im, j)+mub(i-1, j)+mub(im, j))
    END DO
  ELSE IF (its .EQ. ids .AND. ite .EQ. ide) THEN
    DO j=jts,jtf
      DO i=its+1,itf-1
        muud(i, j) = 0.5*(mud(i, j)+mud(i-1, j))
        muu(i, j) = 0.5*(mu(i, j)+mu(i-1, j)+mub(i, j)+mub(i-1, j))
      END DO
    END DO
    i = its
    im = its
    IF (config_flags%periodic_x) im = its - 1
    DO j=jts,jtf
!            muu(i,j) =      mu(i,j)          +mub(i,j)
!  fix for periodic b.c., 13 march 2004, wcs
      muud(i, j) = 0.5*(mud(i, j)+mud(im, j))
      muu(i, j) = 0.5*(mu(i, j)+mu(im, j)+mub(i, j)+mub(im, j))
    END DO
    i = ite
    im = ite - 1
    IF (config_flags%periodic_x) im = ite
    DO j=jts,jtf
!            muu(i,j) =      mu(i-1,j)        +mub(i-1,j)
!  fix for periodic b.c., 13 march 2004, wcs
      muud(i, j) = 0.5*(mud(i-1, j)+mud(im, j))
      muu(i, j) = 0.5*(mu(i-1, j)+mu(im, j)+mub(i-1, j)+mub(im, j))
    END DO
  END IF
  IF (ite .GT. ide - 1) THEN
    itf = ide - 1
  ELSE
    itf = ite
  END IF
  jtf = jte
  IF (jts .NE. jds .AND. jte .NE. jde) THEN
    DO j=jts,jtf
      DO i=its,itf
        muvd(i, j) = 0.5*(mud(i, j)+mud(i, j-1))
        muv(i, j) = 0.5*(mu(i, j)+mu(i, j-1)+mub(i, j)+mub(i, j-1))
      END DO
    END DO
  ELSE IF (jts .EQ. jds .AND. jte .NE. jde) THEN
    DO j=jts+1,jtf
      DO i=its,itf
        muvd(i, j) = 0.5*(mud(i, j)+mud(i, j-1))
        muv(i, j) = 0.5*(mu(i, j)+mu(i, j-1)+mub(i, j)+mub(i, j-1))
      END DO
    END DO
    j = jts
    jm = jts
    IF (config_flags%periodic_y) jm = jts - 1
    DO i=its,itf
!             muv(i,j) =      mu(i,j)          +mub(i,j)
!  fix for periodic b.c., 13 march 2004, wcs
      muvd(i, j) = 0.5*(mud(i, j)+mud(i, jm))
      muv(i, j) = 0.5*(mu(i, j)+mu(i, jm)+mub(i, j)+mub(i, jm))
    END DO
  ELSE IF (jts .NE. jds .AND. jte .EQ. jde) THEN
    DO j=jts,jtf-1
      DO i=its,itf
        muvd(i, j) = 0.5*(mud(i, j)+mud(i, j-1))
        muv(i, j) = 0.5*(mu(i, j)+mu(i, j-1)+mub(i, j)+mub(i, j-1))
      END DO
    END DO
    j = jte
    jm = jte - 1
    IF (config_flags%periodic_y) jm = jte
    DO i=its,itf
! comment out the following statement. NPan 05/26/10 
!             muv(i,j) =      mu(i,j-1)        +mub(i,j-1)
!  fix for periodic b.c., 13 march 2004, wcs
      muvd(i, j) = 0.5*(mud(i, j-1)+mud(i, jm))
      muv(i, j) = 0.5*(mu(i, j-1)+mu(i, jm)+mub(i, j-1)+mub(i, jm))
    END DO
  ELSE IF (jts .EQ. jds .AND. jte .EQ. jde) THEN
    DO j=jts+1,jtf-1
      DO i=its,itf
        muvd(i, j) = 0.5*(mud(i, j)+mud(i, j-1))
        muv(i, j) = 0.5*(mu(i, j)+mu(i, j-1)+mub(i, j)+mub(i, j-1))
      END DO
    END DO
    j = jts
    jm = jts
    IF (config_flags%periodic_y) jm = jts - 1
    DO i=its,itf
!             muv(i,j) =      mu(i,j)          +mub(i,j)
!  fix for periodic b.c., 13 march 2004, wcs
      muvd(i, j) = 0.5*(mud(i, j)+mud(i, jm))
      muv(i, j) = 0.5*(mu(i, j)+mu(i, jm)+mub(i, j)+mub(i, jm))
    END DO
    j = jte
    jm = jte - 1
    IF (config_flags%periodic_y) jm = jte
    DO i=its,itf
!             muv(i,j) =      mu(i,j-1)        +mub(i,j-1)
!  fix for periodic b.c., 13 march 2004, wcs
      muvd(i, j) = 0.5*(mud(i, j-1)+mud(i, jm))
      muv(i, j) = 0.5*(mu(i, j-1)+mu(i, jm)+mub(i, j-1)+mub(i, jm))
    END DO
  END IF
END SUBROUTINE G_CALC_MU_UV

 SUBROUTINE g_calc_mu_uv_1(config_flags,mu,g_mu,muu,g_muu,muv,g_muv,ids, &
 ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)

 IMPLICIT NONE

 REAL :: Tmpv1,g_Tmpv1
 TYPE(grid_config_rec_type) :: config_flags
 INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
 REAL,DIMENSION(ims:ime,jms:jme) :: muu,g_muu,muv,g_muv
 REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu

 INTEGER :: i,j,itf,jtf,im,jm

 itf =ite

 jtf =min(jte,jde-1)

 IF( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN

 DO j =jts,jtf
 DO i =its,itf

 g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(i-1,j))
 muu(i,j) =0.5*(mu(i,j) +mu(i-1,j))

 ENDDO
 ENDDO
 ELSE IF( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN

 DO j =jts,jtf
 DO i =its+1,itf

 g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(i-1,j))
 muu(i,j) =0.5*(mu(i,j) +mu(i-1,j))

 ENDDO
 ENDDO

 i =its

 im =its

 if(config_flags%periodic_x) im =its-1

 DO j =jts,jtf

 g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(im,j))
 muu(i,j) =0.5*(mu(i,j) +mu(im,j))

 ENDDO
 ELSE IF( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN

 DO j =jts,jtf
 DO i =its,itf-1

 g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(i-1,j))
 muu(i,j) =0.5*(mu(i,j) +mu(i-1,j))

 ENDDO
 ENDDO

 i =ite

 im =ite-1

 if(config_flags%periodic_x) im =ite

 DO j =jts,jtf

 g_muu(i,j) =0.5*(g_mu(i-1,j) +g_mu(im,j))
 muu(i,j) =0.5*(mu(i-1,j) +mu(im,j))

 ENDDO
 ELSE IF( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN

 DO j =jts,jtf
 DO i =its+1,itf-1

 g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(i-1,j))
 muu(i,j) =0.5*(mu(i,j) +mu(i-1,j))

 ENDDO
 ENDDO

 i =its

 im =its

 if(config_flags%periodic_x) im =its-1

 DO j =jts,jtf

 g_muu(i,j) =0.5*(g_mu(i,j) +g_mu(im,j))
 muu(i,j) =0.5*(mu(i,j) +mu(im,j))

 ENDDO

 i =ite

 im =ite-1

 if(config_flags%periodic_x) im =ite

 DO j =jts,jtf

 g_muu(i,j) =0.5*(g_mu(i-1,j) +g_mu(im,j))
 muu(i,j) =0.5*(mu(i-1,j) +mu(im,j))

 ENDDO
 END IF

 itf =min(ite,ide-1)

 jtf =jte

 IF( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN

 DO j =jts,jtf
 DO i =its,itf

 g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,j-1))
 muv(i,j) =0.5*(mu(i,j) +mu(i,j-1))

 ENDDO
 ENDDO
 ELSE IF( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN

 DO j =jts+1,jtf
 DO i =its,itf

 g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,j-1))
 muv(i,j) =0.5*(mu(i,j) +mu(i,j-1))

 ENDDO
 ENDDO

 j =jts

 jm =jts

 if(config_flags%periodic_y) jm =jts-1

 DO i =its,itf

 g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,jm))
 muv(i,j) =0.5*(mu(i,j) +mu(i,jm))

 ENDDO
 ELSE IF( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN

 DO j =jts,jtf-1
 DO i =its,itf

 g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,j-1))
 muv(i,j) =0.5*(mu(i,j) +mu(i,j-1))

 ENDDO
 ENDDO

 j =jte

 jm =jte-1

 if(config_flags%periodic_y) jm =jte

 DO i =its,itf

 g_muv(i,j) =0.5*(g_mu(i,j-1) +g_mu(i,jm))
 muv(i,j) =0.5*(mu(i,j-1) +mu(i,jm))

 ENDDO
 ELSE IF( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN

 DO j =jts+1,jtf-1
 DO i =its,itf

 g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,j-1))
 muv(i,j) =0.5*(mu(i,j) +mu(i,j-1))

 ENDDO
 ENDDO

 j =jts

 jm =jts

 if(config_flags%periodic_y) jm =jts-1

 DO i =its,itf

 g_muv(i,j) =0.5*(g_mu(i,j) +g_mu(i,jm))
 muv(i,j) =0.5*(mu(i,j) +mu(i,jm))

 ENDDO

 j =jte

 jm =jte-1

 if(config_flags%periodic_y) jm =jte

 DO i =its,itf

 g_muv(i,j) =0.5*(g_mu(i,j-1) +g_mu(i,jm))
 muv(i,j) =0.5*(mu(i,j-1) +mu(i,jm))

 ENDDO
 END IF

 END SUBROUTINE g_calc_mu_uv_1

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
!  Differentiation of couple_momentum in forward (tangent) mode:
!   variations   of useful results: ru rv rw
!   with respect to varying inputs: u v w ru rv rw mut muu muv
!   RW status of diff variables: u:in v:in w:in ru:in-out rv:in-out
!                rw:in-out mut:in muu:in muv:in
! Map scale factor comments for this routine:
! Locally not changed, but sent the correct map scale factors
! from module_em (msfuy, msfvx, msfty)
SUBROUTINE G_COUPLE_MOMENTUM(muu, muud, ru, rud, u, ud, msfu, muv, muvd&
&  , rv, rvd, v, vd, msfv, msfv_inv, mut, mutd, rw, rwd, w, wd, msft, ids&
&  , ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts&
&  , jte, kts, kte)
  IMPLICIT NONE
! Input data
  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(OUT) :: ru, rv, rw
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rud, rvd, &
&  rwd
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: muu, muv, mut
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: muud, muvd, mutd
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfu, msfv, msft, &
&  msfv_inv
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u, v, w
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ud, vd, wd
! Local data
  INTEGER :: i, j, k, itf, jtf, ktf
  IF (kte .GT. kde - 1) THEN
    ktf = kde - 1
  ELSE
    ktf = kte
  END IF
  itf = ite
  IF (jte .GT. jde - 1) THEN
    jtf = jde - 1
  ELSE
    jtf = jte
  END IF
  DO j=jts,jtf
    DO k=kts,ktf
      DO i=its,itf
        rud(i, k, j) = (ud(i, k, j)*muu(i, j)+u(i, k, j)*muud(i, j))/&
&          msfu(i, j)
        ru(i, k, j) = u(i, k, j)*muu(i, j)/msfu(i, j)
      END DO
    END DO
  END DO
  IF (ite .GT. ide - 1) THEN
    itf = ide - 1
  ELSE
    itf = ite
  END IF
  jtf = jte
  DO j=jts,jtf
    DO k=kts,ktf
      DO i=its,itf
        rvd(i, k, j) = msfv_inv(i, j)*(vd(i, k, j)*muv(i, j)+v(i, k, j)*&
&          muvd(i, j))
        rv(i, k, j) = v(i, k, j)*muv(i, j)*msfv_inv(i, j)
      END DO
    END DO
  END DO
  IF (ite .GT. ide - 1) THEN
    itf = ide - 1
  ELSE
    itf = ite
  END IF
  IF (jte .GT. jde - 1) THEN
    jtf = jde - 1
  ELSE
    jtf = jte
  END IF
  DO j=jts,jtf
    DO k=kts,kte
      DO i=its,itf
        rwd(i, k, j) = (wd(i, k, j)*mut(i, j)+w(i, k, j)*mutd(i, j))/&
&          msft(i, j)
        rw(i, k, j) = w(i, k, j)*mut(i, j)/msft(i, j)
      END DO
    END DO
  END DO
END SUBROUTINE G_COUPLE_MOMENTUM

 SUBROUTINE g_calc_ww_cp(u,g_u,v,g_v,mup,g_mup,mub,ww,g_ww,rdx,rdy, &
 msftx,msfty,msfux,msfuy,msfvx,msfvx_inv,msfvy,dnw,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
 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) :: u,g_u,v,g_v
 REAL,DIMENSION(ims:ime,jms:jme) :: mup,g_mup,mub,msftx,msfty,msfux,msfuy,msfvx, &
 msfvy,msfvx_inv
 REAL,DIMENSION(kms:kme) :: dnw
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ww,g_ww
 REAL :: rdx,rdy

 INTEGER :: i,j,k,itf,jtf,ktf
 REAL,DIMENSION(its:ite) :: dmdt,g_dmdt
 REAL,DIMENSION(its:ite,kts:kte) :: divv,g_divv
 REAL,DIMENSION(its:ite+1,jts:jte+1) :: muu,g_muu,muv,g_muv

 jtf =min(jte,jde-1)

 ktf =min(kte,kde-1)

 itf =min(ite,ide-1)

 DO j =jts,jtf
 DO i =its,min(ite+1,ide)

 g_muu(i,j) =0.5*(g_mup(i,j) +g_mup(i-1,j))/msfuy(i,j)
 muu(i,j) =0.5*(mup(i,j) +mub(i,j) +mup(i-1,j) +mub(i-1,j))/msfuy(i,j)

 ENDDO
 ENDDO

 DO j =jts,min(jte+1,jde)
 DO i =its,itf

 g_muv(i,j) =0.5*(g_mup(i,j) +g_mup(i,j-1))*msfvx_inv(i,j)
 muv(i,j) =0.5*(mup(i,j) +mub(i,j) +mup(i,j-1) +mub(i,j-1))*msfvx_inv(i,j)

 ENDDO
 ENDDO

 DO j =jts,jtf
 DO i =its,ite

 g_dmdt(i) =0.0
 dmdt(i) =0.

 g_ww(i,1,j) =0.0
 ww(i,1,j) =0.

 g_ww(i,kte,j) =0.0
 ww(i,kte,j) =0.

 ENDDO

 DO k =kts,ktf
 DO i =its,itf

 g_Tmpv1 =muu(i+1,j)*g_u(i+1,k,j) +g_muu(i+1,j)*u(i+1,k,j) 
 Tmpv1 =muu(i+1,j)*u(i+1,k,j)

 g_Tmpv2 =muu(i,j)*g_u(i,k,j) +g_muu(i,j)*u(i,k,j) 
 Tmpv2 =muu(i,j)*u(i,k,j)

 g_Tmpv3 =muv(i,j+1)*g_v(i,k,j+1) +g_muv(i,j+1)*v(i,k,j+1) 
 Tmpv3 =muv(i,j+1)*v(i,k,j+1)

 g_Tmpv4 =muv(i,j)*g_v(i,k,j) +g_muv(i,j)*v(i,k,j) 
 Tmpv4 =muv(i,j)*v(i,k,j)

 g_divv(i,k) =msftx(i,j) *dnw(k)*(rdx*(g_Tmpv1 -g_Tmpv2) +rdy*(g_Tmpv3 - &
 g_Tmpv4))
 divv(i,k) =msftx(i,j) *dnw(k)*(rdx*(Tmpv1 -Tmpv2) +rdy*(Tmpv3 -Tmpv4))

 g_dmdt(i) =g_dmdt(i) +g_divv(i,k)
 dmdt(i) =dmdt(i) +divv(i,k)

 ENDDO
 ENDDO

 DO k =2,ktf
 DO i =its,itf

 g_ww(i,k,j) =g_ww(i,k-1,j) -dnw(k-1)*g_dmdt(i) -g_divv(i,k-1)
 ww(i,k,j) =ww(i,k-1,j) -dnw(k-1)*dmdt(i) -divv(i,k-1)

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_calc_ww_cp

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
!  Differentiation of calc_cq in forward (tangent) mode:
!   variations   of useful results: cqu cqv cqw
!   with respect to varying inputs: cqu cqv cqw moist
!   RW status of diff variables: cqu:in-out cqv:in-out cqw:in-out
!                moist:in
SUBROUTINE G_CALC_CQ(moist, moistd, cqu, cqud, cqv, cqvd, cqw, cqwd, &
&  n_moist, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, &
&  its, ite, jts, jte, kts, kte)
  IMPLICIT NONE
! Input data
  INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
&  jme, kms, kme, its, ite, jts, jte, kts, kte
  INTEGER, INTENT(IN) :: n_moist
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
&  moist
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
&  moistd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: cqu, cqv, &
&  cqw
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: cqud, cqvd&
&  , cqwd
! Local stuff
! Changes from Larry Meadows, Intel Corp.  Improve vectorization of this routine
  REAL :: qtot(its:ite)
  REAL :: qtotd(its:ite)
  INTEGER :: i, j, k, itf, jtf, ktf, ispe
  IF (kte .GT. kde - 1) THEN
    ktf = kde - 1
  ELSE
    ktf = kte
  END IF
  IF (n_moist .GE. param_first_scalar) THEN
    itf = ite
    IF (jte .GT. jde - 1) THEN
      jtf = jde - 1
    ELSE
      jtf = jte
    END IF
    DO j=jts,jtf
      DO k=kts,ktf
        qtot = 0.
        qtotd = 0.0
        DO ispe=param_first_scalar,n_moist
          DO i=its,itf
            qtotd(i) = qtotd(i) + moistd(i, k, j, ispe) + moistd(i-1, k&
&              , j, ispe)
            qtot(i) = qtot(i) + moist(i, k, j, ispe) + moist(i-1, k, j, &
&              ispe)
          END DO
        END DO
        DO i=its,itf
          cqud(i, k, j) = -(0.5*qtotd(i)/(1.+0.5*qtot(i))**2)
          cqu(i, k, j) = 1./(1.+0.5*qtot(i))
        END DO
      END DO
    END DO
    IF (ite .GT. ide - 1) THEN
      itf = ide - 1
    ELSE
      itf = ite
    END IF
    jtf = jte
    DO j=jts,jtf
      DO k=kts,ktf
        qtot = 0.
        qtotd = 0.0
        DO ispe=param_first_scalar,n_moist
          DO i=its,itf
            qtotd(i) = qtotd(i) + moistd(i, k, j, ispe) + moistd(i, k, j&
&              -1, ispe)
            qtot(i) = qtot(i) + moist(i, k, j, ispe) + moist(i, k, j-1, &
&              ispe)
          END DO
        END DO
        DO i=its,itf
          cqvd(i, k, j) = -(0.5*qtotd(i)/(1.+0.5*qtot(i))**2)
          cqv(i, k, j) = 1./(1.+0.5*qtot(i))
        END DO
      END DO
    END DO
    IF (ite .GT. ide - 1) THEN
      itf = ide - 1
    ELSE
      itf = ite
    END IF
    IF (jte .GT. jde - 1) THEN
      jtf = jde - 1
    ELSE
      jtf = jte
    END IF
    DO j=jts,jtf
      DO k=kts+1,ktf
        qtot = 0.
        qtotd = 0.0
        DO ispe=param_first_scalar,n_moist
          DO i=its,itf
            qtotd(i) = qtotd(i) + moistd(i, k, j, ispe) + moistd(i, k-1&
&              , j, ispe)
            qtot(i) = qtot(i) + moist(i, k, j, ispe) + moist(i, k-1, j, &
&              ispe)
          END DO
        END DO
        DO i=its,itf
          cqwd(i, k, j) = 0.5*qtotd(i)
          cqw(i, k, j) = 0.5*qtot(i)
        END DO
      END DO
    END DO
  ELSE
    itf = ite
    IF (jte .GT. jde - 1) THEN
      jtf = jde - 1
    ELSE
      jtf = jte
    END IF
    DO j=jts,jtf
      DO k=kts,ktf
        DO i=its,itf
          cqud(i, k, j) = 0.0
          cqu(i, k, j) = 1.
        END DO
      END DO
    END DO
    IF (ite .GT. ide - 1) THEN
      itf = ide - 1
    ELSE
      itf = ite
    END IF
    jtf = jte
    DO j=jts,jtf
      DO k=kts,ktf
        DO i=its,itf
          cqvd(i, k, j) = 0.0
          cqv(i, k, j) = 1.
        END DO
      END DO
    END DO
    IF (ite .GT. ide - 1) THEN
      itf = ide - 1
    ELSE
      itf = ite
    END IF
    IF (jte .GT. jde - 1) THEN
      jtf = jde - 1
    ELSE
      jtf = jte
    END IF
    DO j=jts,jtf
      DO k=kts+1,ktf
        DO i=its,itf
          cqwd(i, k, j) = 0.0
          cqw(i, k, j) = 0.
        END DO
      END DO
    END DO
  END IF
END SUBROUTINE G_CALC_CQ

 SUBROUTINE g_calc_alt(alt,g_alt,al,g_al,alb,ids,ide,jds,jde,kds,kde,ims,ime, &
 jms,jme,kms,kme,its,ite,jts,jte,kts,kte)

 IMPLICIT NONE

 REAL :: Tmpv1,g_Tmpv1
 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) :: alb,al,g_al
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: alt,g_alt

 INTEGER :: i,j,k,itf,jtf,ktf

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 ktf =min(kte,kde-1)

 DO j =jts,jtf
 DO k =kts,ktf
 DO i =its,itf

 g_alt(i,k,j) =g_al(i,k,j)
 alt(i,k,j) =al(i,k,j) +alb(i,k,j)

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_calc_alt

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
!  Differentiation of calc_p_rho_phi in forward (tangent) mode:
!   variations   of useful results: p al ph
!   with respect to varying inputs: p al t muts ph moist mu
!   RW status of diff variables: p:in-out al:in-out t:in muts:in
!                ph:in-out moist:in mu:in
SUBROUTINE G_CALC_P_RHO_PHI(moist, moistd, n_moist, hypsometric_opt, al&
&  , ald, alb, mu, mud, muts, mutsd, ph, phd, phb, p, pd, pb, t, td, p0, &
&  t0, ptop, znu, znw, dnw, rdnw, rdn, non_hydrostatic, ids, ide, jds, &
&  jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, &
&  kte)
  IMPLICIT NONE
! Input data
  LOGICAL, INTENT(IN) :: non_hydrostatic
  INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, ims, ime, jms, &
&  jme, kms, kme, its, ite, jts, jte, kts, kte
  INTEGER, INTENT(IN) :: n_moist
  INTEGER, INTENT(IN) :: hypsometric_opt
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: alb, pb, t
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: td
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
&  moist
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
&  moistd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: al, p
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: ald, pd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ph, phb
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: phd
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, muts
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mud, mutsd
  REAL, DIMENSION(kms:kme), INTENT(IN) :: znu, znw, dnw, rdnw, rdn
  REAL, INTENT(IN) :: t0, p0, ptop
! Local stuff
  INTEGER :: i, j, k, itf, jtf, ktf, ispe
  REAL :: qvf, qtot, qf1, qf2
  REAL :: qvfd, qtotd, qf1d
  REAL, DIMENSION(its:ite) :: temp, cpovcv_v
  REAL, DIMENSION(its:ite) :: tempd
  REAL :: pfu, phm, pfd
  REAL :: pfud, phmd, pfdd
  REAL :: pwx1
  REAL :: pwx1d
  REAL :: pwr1
  REAL :: pwr1d
  IF (ite .GT. ide - 1) THEN
    itf = ide - 1
  ELSE
    itf = ite
  END IF
  IF (jte .GT. jde - 1) THEN
    jtf = jde - 1
  ELSE
    jtf = jte
  END IF
  IF (kte .GT. kde - 1) THEN
    ktf = kde - 1
  ELSE
    ktf = kte
  END IF
!#ifndef INTELMKL
  cpovcv_v = cpovcv
!#endif
  IF (non_hydrostatic) THEN
    IF (hypsometric_opt .EQ. 1) THEN
      DO j=jts,jtf
        DO k=kts,ktf
          DO i=its,itf
            ald(i, k, j) = -((alb(i, k, j)*mud(i, j)+rdnw(k)*(phd(i, k+1&
&              , j)-phd(i, k, j)))/muts(i, j)-mutsd(i, j)*(alb(i, k, j)*&
&              mu(i, j)+rdnw(k)*(ph(i, k+1, j)-ph(i, k, j)))/muts(i, j)**&
&              2)
            al(i, k, j) = -(1./muts(i, j)*(alb(i, k, j)*mu(i, j)+rdnw(k)&
&              *(ph(i, k+1, j)-ph(i, k, j))))
          END DO
        END DO
      END DO
    ELSE IF (hypsometric_opt .EQ. 2) THEN
! The relation used to get specific volume, al, is: al = -dZ/dp,
! where dp = mut * d(eta). The pressure depth, dp, is replaced with
! p*(dp/p) ~ p*LOG((p+0.5dp)/(p-0.5dp)). Difference between dp and p*dLOG(p)
! is as follows: p*dLOG(p) - dp = 1/12*(dp/p)**3 + 1/90*(dp/p)**5 + ...
! Therefore, p*dLOG(p) is always larger than dp and the difference is
! in proportion to dp/p. TKW, 02/16/2010
      DO j=jts,jtf
        DO k=kts,ktf
          DO i=its,itf
            pfud = znw(k+1)*mutsd(i, j)
            pfu = muts(i, j)*znw(k+1) + ptop
            pfdd = znw(k)*mutsd(i, j)
            pfd = muts(i, j)*znw(k) + ptop
            phmd = znu(k)*mutsd(i, j)
            phm = muts(i, j)*znu(k) + ptop
            ald(i, k, j) = (((phd(i, k+1, j)-phd(i, k, j))*phm-(ph(i, k+&
&              1, j)-ph(i, k, j)+phb(i, k+1, j)-phb(i, k, j))*phmd)*LOG(&
&              pfd/pfu)/phm**2-(ph(i, k+1, j)-ph(i, k, j)+phb(i, k+1, j)-&
&              phb(i, k, j))*(pfdd*pfu-pfd*pfud)/(phm*pfu*pfd))/LOG(pfd/&
&              pfu)**2
            al(i, k, j) = (ph(i, k+1, j)-ph(i, k, j)+phb(i, k+1, j)-phb(&
&              i, k, j))/phm/LOG(pfd/pfu) - alb(i, k, j)
          END DO
        END DO
      END DO
    ELSE
      CALL WRF_ERROR_FATAL(&
&                     'calc_p_rho_phi: hypsometric_opt should be 1 or 2')
    END IF
    IF (n_moist .GE. param_first_scalar) THEN
      tempd = 0.0
      DO j=jts,jtf
        DO k=kts,ktf
          DO i=its,itf
            qvfd = rvovrd*moistd(i, k, j, p_qv)
            qvf = 1. + rvovrd*moist(i, k, j, p_qv)
            tempd(i) = (r_d*(td(i, k, j)*qvf+(t0+t(i, k, j))*qvfd)*p0*(&
&              al(i, k, j)+alb(i, k, j))-r_d*(t0+t(i, k, j))*qvf*p0*ald(i&
&              , k, j))/(p0*(al(i, k, j)+alb(i, k, j)))**2
            temp(i) = r_d*(t0+t(i, k, j))*qvf/(p0*(al(i, k, j)+alb(i, k&
&              , j)))
          END DO
!#ifdef INTELMKL
!       CALL VPOWX ( itf-its+1, temp(its), cpovcv, p(its,k,j) )
!#else
! use vector version from libmassv or from compat lib in frame/libmassv.F
          CALL G_VPOW(p(its, k, j), pd(its, k, j), temp(its), tempd(its)&
&                , cpovcv_v(its), itf - its + 1)
!#endif
          DO i=its,itf
            pd(i, k, j) = p0*pd(i, k, j)
            p(i, k, j) = p(i, k, j)*p0 - pb(i, k, j)
          END DO
        END DO
      END DO
    ELSE
      DO j=jts,jtf
        DO k=kts,ktf
          DO i=its,itf
            pwx1d = (r_d*td(i, k, j)*p0*(al(i, k, j)+alb(i, k, j))-r_d*(&
&              t0+t(i, k, j))*p0*ald(i, k, j))/(p0*(al(i, k, j)+alb(i, k&
&              , j)))**2
            pwx1 = r_d*(t0+t(i, k, j))/(p0*(al(i, k, j)+alb(i, k, j)))
            IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. cpovcv .EQ. INT(&
&                cpovcv))) THEN
              pwr1d = cpovcv*pwx1**(cpovcv-1)*pwx1d
            ELSE IF (pwx1 .EQ. 0.0 .AND. cpovcv .EQ. 1.0) THEN
              pwr1d = pwx1d
            ELSE
              pwr1d = 0.0
            END IF
            pwr1 = pwx1**cpovcv
            pd(i, k, j) = p0*pwr1d
            p(i, k, j) = p0*pwr1 - pb(i, k, j)
          END DO
        END DO
      END DO
    END IF
  ELSE
!  hydrostatic pressure, al, and ph1 calc; WCS, 5 sept 2001
    IF (n_moist .GE. param_first_scalar) THEN
      DO j=jts,jtf
! top layer
        k = ktf
        DO i=its,itf
          qtot = 0.
          qtotd = 0.0
          DO ispe=param_first_scalar,n_moist
            qtotd = qtotd + moistd(i, k, j, ispe)
            qtot = qtot + moist(i, k, j, ispe)
          END DO
          qf2 = 1.
          qf1d = qf2*qtotd
          qf1 = qtot*qf2
          pd(i, k, j) = -(0.5*(mud(i, j)+qf1d*muts(i, j)+qf1*mutsd(i, j)&
&            )/rdnw(k)/qf2)
          p(i, k, j) = -(0.5*(mu(i, j)+qf1*muts(i, j))/rdnw(k)/qf2)
          qvfd = rvovrd*moistd(i, k, j, p_qv)
          qvf = 1. + rvovrd*moist(i, k, j, p_qv)
          pwx1d = pd(i, k, j)/p1000mb
          pwx1 = (p(i, k, j)+pb(i, k, j))/p1000mb
          IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. cvpm .EQ. INT(cvpm&
&              ))) THEN
            pwr1d = cvpm*pwx1**(cvpm-1)*pwx1d
          ELSE IF (pwx1 .EQ. 0.0 .AND. cvpm .EQ. 1.0) THEN
            pwr1d = pwx1d
          ELSE
            pwr1d = 0.0
          END IF
          pwr1 = pwx1**cvpm
          ald(i, k, j) = r_d*(td(i, k, j)*qvf*pwr1+(t(i, k, j)+t0)*(qvfd&
&            *pwr1+qvf*pwr1d))/p1000mb
          al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*pwr1 - alb(i, k&
&            , j)
        END DO
! remaining layers, integrate down
        DO k=ktf-1,kts,-1
          DO i=its,itf
            qtot = 0.
            qtotd = 0.0
            DO ispe=param_first_scalar,n_moist
              qtotd = qtotd + 0.5*(moistd(i, k, j, ispe)+moistd(i, k+1, &
&                j, ispe))
              qtot = qtot + 0.5*(moist(i, k, j, ispe)+moist(i, k+1, j, &
&                ispe))
            END DO
            qf2 = 1.
            qf1d = qf2*qtotd
            qf1 = qtot*qf2
            pd(i, k, j) = pd(i, k+1, j) - (mud(i, j)+qf1d*muts(i, j)+qf1&
&              *mutsd(i, j))/qf2/rdn(k+1)
            p(i, k, j) = p(i, k+1, j) - (mu(i, j)+qf1*muts(i, j))/qf2/&
&              rdn(k+1)
            qvfd = rvovrd*moistd(i, k, j, p_qv)
            qvf = 1. + rvovrd*moist(i, k, j, p_qv)
            pwx1d = pd(i, k, j)/p1000mb
            pwx1 = (p(i, k, j)+pb(i, k, j))/p1000mb
            IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. cvpm .EQ. INT(&
&                cvpm))) THEN
              pwr1d = cvpm*pwx1**(cvpm-1)*pwx1d
            ELSE IF (pwx1 .EQ. 0.0 .AND. cvpm .EQ. 1.0) THEN
              pwr1d = pwx1d
            ELSE
              pwr1d = 0.0
            END IF
            pwr1 = pwx1**cvpm
            ald(i, k, j) = r_d*(td(i, k, j)*qvf*pwr1+(t(i, k, j)+t0)*(&
&              qvfd*pwr1+qvf*pwr1d))/p1000mb
            al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*pwr1 - alb(i, &
&              k, j)
          END DO
        END DO
      END DO
    ELSE
      DO j=jts,jtf
! top layer
        k = ktf
        DO i=its,itf
          qtot = 0.
          qf2 = 1.
          qf1 = qtot*qf2
          pd(i, k, j) = -(0.5*(mud(i, j)+qf1*mutsd(i, j))/rdnw(k)/qf2)
          p(i, k, j) = -(0.5*(mu(i, j)+qf1*muts(i, j))/rdnw(k)/qf2)
          qvf = 1.
          pwx1d = pd(i, k, j)/p1000mb
          pwx1 = (p(i, k, j)+pb(i, k, j))/p1000mb
          IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. cvpm .EQ. INT(cvpm&
&              ))) THEN
            pwr1d = cvpm*pwx1**(cvpm-1)*pwx1d
          ELSE IF (pwx1 .EQ. 0.0 .AND. cvpm .EQ. 1.0) THEN
            pwr1d = pwx1d
          ELSE
            pwr1d = 0.0
          END IF
          pwr1 = pwx1**cvpm
          ald(i, k, j) = r_d*qvf*(td(i, k, j)*pwr1+(t(i, k, j)+t0)*pwr1d&
&            )/p1000mb
          al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*pwr1 - alb(i, k&
&            , j)
        END DO
! remaining layers, integrate down
        DO k=ktf-1,kts,-1
          DO i=its,itf
            qtot = 0.
            qf2 = 1.
            qf1 = qtot*qf2
            pd(i, k, j) = pd(i, k+1, j) - (mud(i, j)+qf1*mutsd(i, j))/&
&              qf2/rdn(k+1)
            p(i, k, j) = p(i, k+1, j) - (mu(i, j)+qf1*muts(i, j))/qf2/&
&              rdn(k+1)
            qvf = 1.
            pwx1d = pd(i, k, j)/p1000mb
            pwx1 = (p(i, k, j)+pb(i, k, j))/p1000mb
            IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. cvpm .EQ. INT(&
&                cvpm))) THEN
              pwr1d = cvpm*pwx1**(cvpm-1)*pwx1d
            ELSE IF (pwx1 .EQ. 0.0 .AND. cvpm .EQ. 1.0) THEN
              pwr1d = pwx1d
            ELSE
              pwr1d = 0.0
            END IF
            pwr1 = pwx1**cvpm
            ald(i, k, j) = r_d*qvf*(td(i, k, j)*pwr1+(t(i, k, j)+t0)*&
&              pwr1d)/p1000mb
            al(i, k, j) = r_d/p1000mb*(t(i, k, j)+t0)*qvf*pwr1 - alb(i, &
&              k, j)
          END DO
        END DO
      END DO
    END IF
    IF (hypsometric_opt .EQ. 1) THEN
      DO j=jts,jtf
! integrate hydrostatic equation for geopotential
        DO k=2,ktf+1
          DO i=its,itf
            phd(i, k, j) = phd(i, k-1, j) - dnw(k-1)*(mutsd(i, j)*al(i, &
&              k-1, j)+muts(i, j)*ald(i, k-1, j)+alb(i, k-1, j)*mud(i, j)&
&              )
            ph(i, k, j) = ph(i, k-1, j) - dnw(k-1)*(muts(i, j)*al(i, k-1&
&              , j)+mu(i, j)*alb(i, k-1, j))
          END DO
        END DO
      END DO
    ELSE
! Revised hypsometric eq.: dZ=-al*p*dLOG(p), where p is dry pressure
      DO j=jts,jtf
        DO i=its,itf
          phd(i, kts, j) = 0.0
          ph(i, kts, j) = phb(i, kts, j)
        END DO
        DO k=kts+1,ktf+1
          DO i=its,itf
            pfud = znw(k)*mutsd(i, j)
            pfu = muts(i, j)*znw(k) + ptop
            pfdd = znw(k-1)*mutsd(i, j)
            pfd = muts(i, j)*znw(k-1) + ptop
            phmd = znu(k-1)*mutsd(i, j)
            phm = muts(i, j)*znu(k-1) + ptop
            phd(i, k, j) = phd(i, k-1, j) + (ald(i, k-1, j)*phm+(al(i, k&
&              -1, j)+alb(i, k-1, j))*phmd)*LOG(pfd/pfu) + (al(i, k-1, j)&
&              +alb(i, k-1, j))*phm*(pfdd*pfu-pfd*pfud)/(pfu*pfd)
            ph(i, k, j) = ph(i, k-1, j) + (al(i, k-1, j)+alb(i, k-1, j))&
&              *phm*LOG(pfd/pfu)
          END DO
        END DO
        DO k=kts,ktf+1
          DO i=its,itf
            ph(i, k, j) = ph(i, k, j) - phb(i, k, j)
          END DO
        END DO
      END DO
    END IF
  END IF
END SUBROUTINE G_CALC_P_RHO_PHI

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
!  Differentiation of vpow in forward (tangent) mode:
!   variations   of useful results: z
!   with respect to varying inputs: y z
SUBROUTINE G_VPOW(z, zd, y, yd, x, n)
  IMPLICIT NONE
  REAL :: x(*), y(*), z(*)
  REAL :: yd(*), zd(*)
  INTEGER :: j
  INTEGER :: n
  DO j=1,n
    IF (y(j) .GT. 0.0 .OR. (y(j) .LT. 0.0 .AND. x(j) .EQ. INT(x(j)))) &
&    THEN
      zd(j) = x(j)*y(j)**(x(j)-1)*yd(j)
    ELSE IF (y(j) .EQ. 0.0 .AND. x(j) .EQ. 1.0) THEN
      zd(j) = yd(j)
    ELSE
      zd(j) = 0.0
    END IF
    z(j) = y(j)**x(j)
  END DO
  RETURN
END SUBROUTINE G_VPOW

 SUBROUTINE g_calc_php(php,g_php,ph,g_ph,phb,ids,ide,jds,jde,kds,kde,ims,ime, &
 jms,jme,kms,kme,its,ite,jts,jte,kts,kte)

 IMPLICIT NONE

 REAL :: Tmpv1,g_Tmpv1
 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) :: phb,ph,g_ph
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: php,g_php

 INTEGER :: i,j,k,itf,jtf,ktf

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 ktf =min(kte,kde-1)

 DO j =jts,jtf
 DO k =kts,ktf
 DO i =its,itf

 g_php(i,k,j) =0.5*(g_ph(i,k,j) +g_ph(i,k+1,j))
 php(i,k,j) =0.5*(phb(i,k,j)+phb(i,k+1,j) +ph(i,k,j) +ph(i,k+1,j))

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_calc_php

 SUBROUTINE g_diagnose_w(ph_tend,g_ph_tend,ph_new,g_ph_new,ph_old, &
 g_ph_old,w,g_w,mu,g_mu,dt,u,g_u,v,g_v,ht,cf1,cf2,cf3,rdx,rdy,msftx, &
 msfty,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,Tmpv9,g_Tmpv9, &
 Tmpv10,g_Tmpv10,Tmpv11,g_Tmpv11,Tmpv12,g_Tmpv12,Tmpv13,g_Tmpv13,Tmpv14, &
 g_Tmpv14,Tmpv15,g_Tmpv15,Tmpv16,g_Tmpv16,Tmpv17,g_Tmpv17,Tmpv18, &
 g_Tmpv18,Tmpv19,g_Tmpv19,Tmpv20,g_Tmpv20
 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) :: ph_tend,g_ph_tend,ph_new,g_ph_new, &
 ph_old,g_ph_old,u,g_u,v,g_v
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: w,g_w
 REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu,ht,msftx,msfty
 REAL :: dt,cf1,cf2,cf3,rdx,rdy
 INTEGER :: i,j,k,itf,jtf

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 DO j =jts,jtf
 DO i =its,itf

 g_w(i,1,j) =msfty(i,j) *.5 *rdy*((ht(i,j+1)-ht(i,j))*(cf1*g_v(i,1,j+1) &
 +cf2*g_v(i,2,j+1) +cf3*g_v(i,3,j+1)) +(ht(i,j)-ht(i,j-1))*(cf1*g_v(i,1,j) &
 +cf2*g_v(i,2,j) +cf3*g_v(i,3,j))) +msftx(i,j) *.5 *rdx*((ht(i+1,j)-ht(i,j)) &
*(cf1*g_u(i+1,1,j) +cf2*g_u(i+1,2,j) +cf3*g_u(i+1,3,j)) +(ht(i,j)-ht(i-1,j)) &
*(cf1*g_u(i,1,j) +cf2*g_u(i,2,j) +cf3*g_u(i,3,j)))
 w(i,1,j) =msfty(i,j) *.5 *rdy*((ht(i,j+1)-ht(i,j))*(cf1*v(i,1,j+1) +cf2*v(i,2,j+1) &
 +cf3*v(i,3,j+1)) +(ht(i,j)-ht(i,j-1))*(cf1*v(i,1,j) +cf2*v(i,2,j) +cf3*v(i,3,j))) &
 +msftx(i,j) *.5 *rdx*((ht(i+1,j)-ht(i,j))*(cf1*u(i+1,1,j) +cf2*u(i+1,2,j) &
 +cf3*u(i+1,3,j)) +(ht(i,j)-ht(i-1,j))*(cf1*u(i,1,j) +cf2*u(i,2,j) +cf3*u(i,3,j)))

 ENDDO

 DO k =2,kte
 DO i =its,itf

 g_Tmpv1 =(g_ph_tend(i,k,j)*mu(i,j) -g_mu(i,j)*ph_tend(i,k,j))/(mu(i,j)*mu(i,j)) 
 Tmpv1 =ph_tend(i,k,j)/mu(i,j)

 g_w(i,k,j) =msfty(i,j)*((g_ph_new(i,k,j) -g_ph_old(i,k,j))/dt -g_Tmpv1)/g
 w(i,k,j) =msfty(i,j)*((ph_new(i,k,j) -ph_old(i,k,j))/dt -Tmpv1)/g

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_diagnose_w

 SUBROUTINE g_rhs_ph(ph_tend,g_ph_tend,u,g_u,v,g_v,ww,g_ww,ph,g_ph, &
 ph_old,g_ph_old,phb,w,g_w,mut,g_mut,muu,g_muu,muv,g_muv,fnm,fnp,rdnw, &
 cfn,cfn1,rdx,rdy,msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty,non_hydrostatic, &
 config_flags,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,Tmpv9,g_Tmpv9, &
 Tmpv10,g_Tmpv10,Tmpv11,g_Tmpv11,Tmpv12,g_Tmpv12
 TYPE(grid_config_rec_type) :: config_flags
 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) :: u,g_u,v,g_v,ww,g_ww,ph,g_ph, &
 ph_old,g_ph_old,phb,w,g_w
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ph_tend,g_ph_tend
 REAL,DIMENSION(ims:ime,jms:jme) :: muu,g_muu,muv,g_muv,mut,g_mut,msfux, &
 msfuy,msfvx,msfvy,msftx,msfty,msfvx_inv
 REAL,DIMENSION(kms:kme) :: rdnw,fnm,fnp
 REAL :: cfn,cfn1,rdx,rdy
 LOGICAL :: non_hydrostatic

 INTEGER :: i,j,k,itf,jtf,ktf,kz,i_start,j_start
 REAL :: ur,g_ur,ul,g_ul,ub,g_ub,vr,g_vr,vl,g_vl,vb,g_vb
 REAL,DIMENSION(its:ite,kts:kte) :: wdwn,g_wdwn
 INTEGER :: advective_order
 LOGICAL :: specified

 specified =.false.

 if(config_flags%specified .or. config_flags%nested) specified =.true.

 advective_order =config_flags%h_sca_adv_order

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 ktf =min(kte,kde-1)

 DO j =jts,jtf
 DO k =2,kte
 DO i =its,itf

 g_Tmpv1 =.5*(ww(i,k,j) +ww(i,k-1,j))*rdnw(k-1)*(g_ph(i,k,j) -g_ph(i,k-1,j)) &
 +.5*(g_ww(i,k,j) +g_ww(i,k-1,j))*rdnw(k-1)*(ph(i,k,j) -ph(i,k-1,j) +phb(i,k,j) &
 -phb(i,k-1,j)) 
 Tmpv1 =.5*(ww(i,k,j) +ww(i,k-1,j))*rdnw(k-1)*(ph(i,k,j) -ph(i,k-1,j) +phb(i,k,j) &
 -phb(i,k-1,j))

 g_wdwn(i,k) =g_Tmpv1
 wdwn(i,k) =Tmpv1

 ENDDO
 ENDDO

 DO k =2,kte-1
 DO i =its,itf

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(fnm(k)*g_wdwn(i,k+1) +fnp(k)*g_wdwn(i,k))
 ph_tend(i,k,j) =ph_tend(i,k,j) -(fnm(k)*wdwn(i,k+1) +fnp(k)*wdwn(i,k))

 ENDDO
 ENDDO
 ENDDO

 IF(non_hydrostatic) THEN

 DO j =jts,jtf

 DO i =its,itf

 g_ph_tend(i,kde,j) =0.0
 ph_tend(i,kde,j) =0.

 ENDDO

 DO k =2,kte
 DO i =its,itf

 g_Tmpv1 =mut(i,j)*g*g_w(i,k,j) +g_mut(i,j)*g*w(i,k,j) 
 Tmpv1 =mut(i,j)*g*w(i,k,j)

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) +(g_Tmpv1/msfty(i,j))
 ph_tend(i,k,j) =ph_tend(i,k,j) +Tmpv1/msfty(i,j)

 ENDDO
 ENDDO
 ENDDO
 END IF

 IF(advective_order <= 2) THEN

 i_start =its

 j_start =jts

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 IF( (config_flags%open_ys .or. specified) .and. jts == jds ) j_start =jts+1

 IF( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf =jtf-2

 DO j =j_start,jtf
 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
*(v(i,k,j+1) +v(i,k-1,j+1)) 
 Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))

 g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
 i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))

 g_Tmpv3 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j)) 
 Tmpv3 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))

 g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
 j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)) 
 Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
 +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)) 
 Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))

 g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
 i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))

 g_Tmpv3 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)) 
 Tmpv3 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))

 g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
 j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)) 
 Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO

 i_start =its

 j_start =jts

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 IF( (config_flags%open_xs .or. specified) .and. its == ids ) i_start =its+1

 IF( (config_flags%open_xe .or. specified) .and. ite == ide ) itf =itf-2

 DO j =j_start,jtf
 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
*(u(i+1,k,j) +u(i+1,k-1,j)) 
 Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))

 g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
 i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))

 g_Tmpv3 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j)) 
 Tmpv3 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))

 g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
 j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)) 
 Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
 +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)) 
 Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))

 g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
 i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))

 g_Tmpv3 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)) 
 Tmpv3 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))

 g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
 j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)) 
 Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO
 ELSE IF(advective_order <= 4) THEN

 i_start =its

 j_start =jts

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 IF( (config_flags%open_ys .or. specified) .and. jts == jds ) j_start =jts+2

 IF( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf =jtf-3

 DO j =j_start,jtf
 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
*(v(i,k,j+1) +v(i,k-1,j+1)) 
 Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))

 g_Tmpv2 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j)) 
 Tmpv2 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))

 g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
 -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
 +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
 -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2))) 
 Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
 -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
 -(phb(i,k,j+2)-phb(i,k,j-2)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv3)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
 +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)) 
 Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))

 g_Tmpv2 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)) 
 Tmpv2 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))

 g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
 -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
 +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
 -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2))) 
 Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
 -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
 -(phb(i,k,j+2)-phb(i,k,j-2)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv3)

 ENDDO
 ENDDO

 IF( (config_flags%open_ys .or. specified) .and. jts <= jds+1 ) THEN

 j =jds+1

 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
*(v(i,k,j+1) +v(i,k-1,j+1)) 
 Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))

 g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
 i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))

 g_Tmpv3 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j)) 
 Tmpv3 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))

 g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
 j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)) 
 Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
 +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)) 
 Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))

 g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
 i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))

 g_Tmpv3 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)) 
 Tmpv3 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))

 g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
 j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)) 
 Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 END IF

 IF( (config_flags%open_ye .or. specified) .and. jte >= jde-2 ) THEN

 j =jde-2

 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
*(v(i,k,j+1) +v(i,k-1,j+1)) 
 Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))

 g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
 i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))

 g_Tmpv3 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j)) 
 Tmpv3 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))

 g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
 j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)) 
 Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
 +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)) 
 Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))

 g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
 i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))

 g_Tmpv3 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)) 
 Tmpv3 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))

 g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
 j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)) 
 Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 END IF

 i_start =its

 j_start =jts

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 IF( (config_flags%open_xs) .and. its == ids ) i_start =its+2

 IF( (config_flags%open_xe) .and. ite == ide ) itf =itf-3

 DO j =j_start,jtf
 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
*(u(i+1,k,j) +u(i+1,k-1,j)) 
 Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))

 g_Tmpv2 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j)) 
 Tmpv2 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))

 g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
 -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
 +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
 -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j))) 
 Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
 -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
 -(phb(i+2,k,j)-phb(i-2,k,j)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv3)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
 +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)) 
 Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))

 g_Tmpv2 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)) 
 Tmpv2 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))

 g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
 -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
 +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
 -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j))) 
 Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
 -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
 -(phb(i+2,k,j)-phb(i-2,k,j)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv3)

 ENDDO
 ENDDO

 IF( (config_flags%open_xs .or. specified) .and. its <= ids+1 ) THEN

 i =ids+1

 DO j =j_start,jtf
 DO k =2,kte-1

 g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
*(u(i+1,k,j) +u(i+1,k-1,j)) 
 Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))

 g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
 i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))

 g_Tmpv3 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j)) 
 Tmpv3 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))

 g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
 j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)) 
 Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO

 k =kte

 DO j =j_start,jtf

 g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
 +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)) 
 Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))

 g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
 i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))

 g_Tmpv3 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)) 
 Tmpv3 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))

 g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
 j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)) 
 Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 END IF

 IF( (config_flags%open_xe .or. specified) .and. ite >= ide-2 ) THEN

 i =ide-2

 DO j =j_start,jtf
 DO k =2,kte-1

 g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
*(u(i+1,k,j) +u(i+1,k-1,j)) 
 Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))

 g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
 i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))

 g_Tmpv3 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j)) 
 Tmpv3 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))

 g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
 j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)) 
 Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO

 k =kte

 DO j =j_start,jtf

 g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
 +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)) 
 Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))

 g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
 i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))

 g_Tmpv3 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)) 
 Tmpv3 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))

 g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
 j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)) 
 Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 END IF
 ELSE IF(advective_order <= 6) THEN

 i_start =its

 j_start =jts

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 IF(config_flags%open_ys .or. specified ) j_start =max(jts,jds+3)

 IF(config_flags%open_ye .or. specified ) jtf =min(jtf,jde-4)

 DO j =j_start,jtf
 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
*(v(i,k,j+1) +v(i,k-1,j+1)) 
 Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))

 g_Tmpv2 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j)) 
 Tmpv2 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))

 g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./60.)*(45.*(g_ph(i,k,j+1) &
 -g_ph(i,k,j-1)) -9.*(g_ph(i,k,j+2) -g_ph(i,k,j-2)) +(g_ph(i,k,j+3) &
 -g_ph(i,k,j-3))) +(g_Tmpv1*msfvy(i,j+1) +g_Tmpv2*msfvy(i,j))*(1./60.) &
*(45.*(ph(i,k,j+1) -ph(i,k,j-1)) -9.*(ph(i,k,j+2) -ph(i,k,j-2)) +(ph(i,k,j+3) &
 -ph(i,k,j-3)) +45. *(phb(i,k,j+1)-phb(i,k,j-1)) -9. *(phb(i,k,j+2)-phb(i,k,j-2)) &
 +(phb(i,k,j+3)-phb(i,k,j-3))) 
 Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./60.)*(45.*(ph(i,k,j+1) &
 -ph(i,k,j-1)) -9.*(ph(i,k,j+2) -ph(i,k,j-2)) +(ph(i,k,j+3) -ph(i,k,j-3)) &
 +45. *(phb(i,k,j+1)-phb(i,k,j-1)) -9. *(phb(i,k,j+2)-phb(i,k,j-2)) +(phb(i,k,j+3) &
-phb(i,k,j-3)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv3)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
 +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)) 
 Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))

 g_Tmpv2 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)) 
 Tmpv2 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))

 g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./60.)*(45.*(g_ph(i,k,j+1) &
 -g_ph(i,k,j-1)) -9.*(g_ph(i,k,j+2) -g_ph(i,k,j-2)) +(g_ph(i,k,j+3) &
 -g_ph(i,k,j-3))) +(g_Tmpv1*msfvy(i,j+1) +g_Tmpv2*msfvy(i,j))*(1./60.) &
*(45.*(ph(i,k,j+1) -ph(i,k,j-1)) -9.*(ph(i,k,j+2) -ph(i,k,j-2)) +(ph(i,k,j+3) &
 -ph(i,k,j-3)) +45. *(phb(i,k,j+1)-phb(i,k,j-1)) -9. *(phb(i,k,j+2)-phb(i,k,j-2)) &
 +(phb(i,k,j+3)-phb(i,k,j-3))) 
 Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./60.)*(45.*(ph(i,k,j+1) &
 -ph(i,k,j-1)) -9.*(ph(i,k,j+2) -ph(i,k,j-2)) +(ph(i,k,j+3) -ph(i,k,j-3)) &
 +45. *(phb(i,k,j+1)-phb(i,k,j-1)) -9. *(phb(i,k,j+2)-phb(i,k,j-2)) +(phb(i,k,j+3) &
-phb(i,k,j-3)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv3)

 ENDDO
 ENDDO

 IF( (config_flags%open_ys .or. specified) .and. jts <= jds+2 .and. jds+2 <= jte ) THEN

 j =jds+2

 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
*(v(i,k,j+1) +v(i,k-1,j+1)) 
 Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))

 g_Tmpv2 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j)) 
 Tmpv2 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))

 g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
 -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
 +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
 -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2))) 
 Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
 -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
 -(phb(i,k,j+2)-phb(i,k,j-2)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv3)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
 +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)) 
 Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))

 g_Tmpv2 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)) 
 Tmpv2 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))

 g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
 -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
 +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
 -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2))) 
 Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
 -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
 -(phb(i,k,j+2)-phb(i,k,j-2)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv3)

 ENDDO
 END IF

 IF( (config_flags%open_ye .or. specified) .and. jts <= jde-3 .and. jde-3 <= jte ) THEN

 j =jde-3

 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
*(v(i,k,j+1) +v(i,k-1,j+1)) 
 Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))

 g_Tmpv2 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j)) 
 Tmpv2 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))

 g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
 -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
 +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
 -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2))) 
 Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
 -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
 -(phb(i,k,j+2)-phb(i,k,j-2)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv3)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
 +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)) 
 Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))

 g_Tmpv2 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)) 
 Tmpv2 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))

 g_Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(g_ph(i,k,j+1) &
 -g_ph(i,k,j-1)) -(g_ph(i,k,j+2) -g_ph(i,k,j-2))) +(g_Tmpv1*msfvy(i,j+1) &
 +g_Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) -ph(i,k,j-1)) -(ph(i,k,j+2) &
 -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) -(phb(i,k,j+2)-phb(i,k,j-2))) 
 Tmpv3 =(Tmpv1*msfvy(i,j+1) +Tmpv2*msfvy(i,j))*(1./12.)*(8.*(ph(i,k,j+1) &
 -ph(i,k,j-1)) -(ph(i,k,j+2) -ph(i,k,j-2)) +8. *(phb(i,k,j+1)-phb(i,k,j-1)) &
 -(phb(i,k,j+2)-phb(i,k,j-2)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv3)

 ENDDO
 END IF

 IF( (config_flags%open_ys .or. specified) .and. jts <= jds+1 .and. jds+1 <= jte ) THEN

 j =jds+1

 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
*(v(i,k,j+1) +v(i,k-1,j+1)) 
 Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))

 g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
 i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))

 g_Tmpv3 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j)) 
 Tmpv3 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))

 g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
 j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)) 
 Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
 +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)) 
 Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))

 g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
 i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))

 g_Tmpv3 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)) 
 Tmpv3 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))

 g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
 j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)) 
 Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 END IF

 IF( (config_flags%open_ye .or. specified) .and. jts <= jde-2 .and. jde-2 <= jte ) THEN

 j =jde-2

 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(g_v(i,k,j+1) +g_v(i,k-1,j+1)) +g_muv(i,j+1) &
*(v(i,k,j+1) +v(i,k-1,j+1)) 
 Tmpv1 =muv(i,j+1)*(v(i,k,j+1) +v(i,k-1,j+1))

 g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
 i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))

 g_Tmpv3 =muv(i,j)*(g_v(i,k,j) +g_v(i,k-1,j)) +g_muv(i,j)*(v(i,k,j) +v(i,k-1,j)) 
 Tmpv3 =muv(i,j)*(v(i,k,j) +v(i,k-1,j))

 g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
 j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)) 
 Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muv(i,j+1)*(cfn*g_v(i,k-1,j+1) +cfn1*g_v(i,k-2,j+1)) &
 +g_muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1)) 
 Tmpv1 =muv(i,j+1)*(cfn*v(i,k-1,j+1) +cfn1*v(i,k-2,j+1))

 g_Tmpv2 =Tmpv1*msfvy(i,j+1)*(g_ph(i,k,j+1) -g_ph(i,k,j)) +g_Tmpv1*msfvy( &
 i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfvy(i,j+1)*(phb(i,k,j+1)-phb(i,k,j) +ph(i,k,j+1) -ph(i,k,j))

 g_Tmpv3 =muv(i,j)*(cfn*g_v(i,k-1,j) +cfn1*g_v(i,k-2,j)) +g_muv(i,j) &
*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j)) 
 Tmpv3 =muv(i,j)*(cfn*v(i,k-1,j) +cfn1*v(i,k-2,j))

 g_Tmpv4 =Tmpv3*msfvy(i,j)*(g_ph(i,k,j) -g_ph(i,k,j-1)) +g_Tmpv3*msfvy(i, &
 j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1)) 
 Tmpv4 =Tmpv3*msfvy(i,j)*(phb(i,k,j)-phb(i,k,j-1) +ph(i,k,j) -ph(i,k,j-1))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdy/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 END IF

 i_start =its

 j_start =jts

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 IF(config_flags%open_xs .or. specified ) i_start =max(its,ids+3)

 IF(config_flags%open_xe .or. specified ) itf =min(itf,ide-4)

 DO j =j_start,jtf
 DO k =2,kte-1
 DO i =i_start,itf

 g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
*(u(i+1,k,j) +u(i+1,k-1,j)) 
 Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))

 g_Tmpv2 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j)) 
 Tmpv2 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))

 g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./60.)*(45.*(g_ph(i+1,k,j) &
 -g_ph(i-1,k,j)) -9.*(g_ph(i+2,k,j) -g_ph(i-2,k,j)) +(g_ph(i+3,k,j) &
 -g_ph(i-3,k,j))) +(g_Tmpv1*msfux(i+1,j) +g_Tmpv2*msfux(i,j))*(1./60.) &
*(45.*(ph(i+1,k,j) -ph(i-1,k,j)) -9.*(ph(i+2,k,j) -ph(i-2,k,j)) +(ph(i+3,k,j) &
 -ph(i-3,k,j)) +45. *(phb(i+1,k,j)-phb(i-1,k,j)) -9. *(phb(i+2,k,j)-phb(i-2,k,j)) &
 +(phb(i+3,k,j)-phb(i-3,k,j))) 
 Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./60.)*(45.*(ph(i+1,k,j) &
 -ph(i-1,k,j)) -9.*(ph(i+2,k,j) -ph(i-2,k,j)) +(ph(i+3,k,j) -ph(i-3,k,j)) &
 +45. *(phb(i+1,k,j)-phb(i-1,k,j)) -9. *(phb(i+2,k,j)-phb(i-2,k,j)) +(phb(i+3,k,j) &
-phb(i-3,k,j)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv3)

 ENDDO
 ENDDO

 k =kte

 DO i =i_start,itf

 g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
 +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)) 
 Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))

 g_Tmpv2 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)) 
 Tmpv2 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))

 g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./60.)*(45.*(g_ph(i+1,k,j) &
 -g_ph(i-1,k,j)) -9.*(g_ph(i+2,k,j) -g_ph(i-2,k,j)) +(g_ph(i+3,k,j) &
 -g_ph(i-3,k,j))) +(g_Tmpv1*msfux(i+1,j) +g_Tmpv2*msfux(i,j))*(1./60.) &
*(45.*(ph(i+1,k,j) -ph(i-1,k,j)) -9.*(ph(i+2,k,j) -ph(i-2,k,j)) +(ph(i+3,k,j) &
 -ph(i-3,k,j)) +45. *(phb(i+1,k,j)-phb(i-1,k,j)) -9. *(phb(i+2,k,j)-phb(i-2,k,j)) &
 +(phb(i+3,k,j)-phb(i-3,k,j))) 
 Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./60.)*(45.*(ph(i+1,k,j) &
 -ph(i-1,k,j)) -9.*(ph(i+2,k,j) -ph(i-2,k,j)) +(ph(i+3,k,j) -ph(i-3,k,j)) &
 +45. *(phb(i+1,k,j)-phb(i-1,k,j)) -9. *(phb(i+2,k,j)-phb(i-2,k,j)) +(phb(i+3,k,j) &
-phb(i-3,k,j)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv3)

 ENDDO
 ENDDO

 IF( (config_flags%open_xs) .and. its <= ids+2 .and. ids+2 <= ite ) THEN

 i =ids+2

 DO j =j_start,jtf
 DO k =2,kte-1

 g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
*(u(i+1,k,j) +u(i+1,k-1,j)) 
 Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))

 g_Tmpv2 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j)) 
 Tmpv2 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))

 g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
 -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
 +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
 -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j))) 
 Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
 -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
 -(phb(i+2,k,j)-phb(i-2,k,j)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv3)

 ENDDO

 k =kte

 g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
 +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)) 
 Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))

 g_Tmpv2 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)) 
 Tmpv2 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))

 g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
 -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
 +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
 -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j))) 
 Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
 -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
 -(phb(i+2,k,j)-phb(i-2,k,j)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv3)

 ENDDO
 END IF

 IF( (config_flags%open_xe) .and. its <= ide-3 .and. ide-3 <= ite ) THEN

 i =ide-3

 DO j =j_start,jtf
 DO k =2,kte-1

 g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
*(u(i+1,k,j) +u(i+1,k-1,j)) 
 Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))

 g_Tmpv2 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j)) 
 Tmpv2 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))

 g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
 -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
 +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
 -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j))) 
 Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
 -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
 -(phb(i+2,k,j)-phb(i-2,k,j)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv3)

 ENDDO

 k =kte

 g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
 +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)) 
 Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))

 g_Tmpv2 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)) 
 Tmpv2 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))

 g_Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(g_ph(i+1,k,j) &
 -g_ph(i-1,k,j)) -(g_ph(i+2,k,j) -g_ph(i-2,k,j))) +(g_Tmpv1*msfux(i+1,j) &
 +g_Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) -ph(i-1,k,j)) -(ph(i+2,k,j) &
 -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) -(phb(i+2,k,j)-phb(i-2,k,j))) 
 Tmpv3 =(Tmpv1*msfux(i+1,j) +Tmpv2*msfux(i,j))*(1./12.)*(8.*(ph(i+1,k,j) &
 -ph(i-1,k,j)) -(ph(i+2,k,j) -ph(i-2,k,j)) +8. *(phb(i+1,k,j)-phb(i-1,k,j)) &
 -(phb(i+2,k,j)-phb(i-2,k,j)))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv3)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv3)

 ENDDO
 END IF

 IF( (config_flags%open_xs .or. specified) .and. its <= ids+1 .and. ids+1 <= ite ) THEN

 i =ids+1

 DO j =j_start,jtf
 DO k =2,kte-1

 g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
*(u(i+1,k,j) +u(i+1,k-1,j)) 
 Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))

 g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
 i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))

 g_Tmpv3 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j)) 
 Tmpv3 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))

 g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
 j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)) 
 Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO

 k =kte

 DO j =j_start,jtf

 g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
 +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)) 
 Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))

 g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
 i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))

 g_Tmpv3 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)) 
 Tmpv3 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))

 g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
 j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)) 
 Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 END IF

 IF( (config_flags%open_xe .or. specified) .and. its <= ide-2 .and. ide-2 <= ite ) THEN

 i =ide-2

 DO j =j_start,jtf
 DO k =2,kte-1

 g_Tmpv1 =muu(i+1,j)*(g_u(i+1,k,j) +g_u(i+1,k-1,j)) +g_muu(i+1,j) &
*(u(i+1,k,j) +u(i+1,k-1,j)) 
 Tmpv1 =muu(i+1,j)*(u(i+1,k,j) +u(i+1,k-1,j))

 g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
 i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))

 g_Tmpv3 =muu(i,j)*(g_u(i,k,j) +g_u(i,k-1,j)) +g_muu(i,j)*(u(i,k,j) +u(i,k-1,j)) 
 Tmpv3 =muu(i,j)*(u(i,k,j) +u(i,k-1,j))

 g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
 j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)) 
 Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.25 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 ENDDO

 k =kte

 DO j =j_start,jtf

 g_Tmpv1 =muu(i+1,j)*(cfn*g_u(i+1,k-1,j) +cfn1*g_u(i+1,k-2,j)) &
 +g_muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j)) 
 Tmpv1 =muu(i+1,j)*(cfn*u(i+1,k-1,j) +cfn1*u(i+1,k-2,j))

 g_Tmpv2 =Tmpv1*msfux(i+1,j)*(g_ph(i+1,k,j) -g_ph(i,k,j)) +g_Tmpv1*msfux( &
 i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j)) 
 Tmpv2 =Tmpv1*msfux(i+1,j)*(phb(i+1,k,j)-phb(i,k,j) +ph(i+1,k,j) -ph(i,k,j))

 g_Tmpv3 =muu(i,j)*(cfn*g_u(i,k-1,j) +cfn1*g_u(i,k-2,j)) +g_muu(i,j) &
*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j)) 
 Tmpv3 =muu(i,j)*(cfn*u(i,k-1,j) +cfn1*u(i,k-2,j))

 g_Tmpv4 =Tmpv3*msfux(i,j)*(g_ph(i,k,j) -g_ph(i-1,k,j)) +g_Tmpv3*msfux(i, &
 j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j)) 
 Tmpv4 =Tmpv3*msfux(i,j)*(phb(i,k,j)-phb(i-1,k,j) +ph(i,k,j) -ph(i-1,k,j))

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(g_Tmpv2 +g_Tmpv4)
 ph_tend(i,k,j) =ph_tend(i,k,j) -(0.5 *rdx/msfty(i,j))*(Tmpv2 +Tmpv4)

 ENDDO
 END IF

 END IF

 i_start =its

 itf =min(ite,ide-1)

 IF( (config_flags%open_ys) .and. jts == jds ) THEN

 j =jts

 DO k =2,kde

 kz =min(k,kde-1)

 DO i =its,itf

 g_vb =.5*(fnm(kz)*(g_v(i,kz,j+1) +g_v(i,kz,j)) +fnp(kz)*(g_v(i,kz-1,j+1) &
 +g_v(i,kz-1,j)))
 vb =.5*(fnm(kz)*(v(i,kz,j+1) +v(i,kz,j)) +fnp(kz)*(v(i,kz-1,j+1) +v(i,kz-1,j)))

 g_vl =(g_vb +0.0 -(g_vb -0.0)*sign(1.0, vb -(0.)))*0.5
! Revised by Ning Pan, 2010-07-21
! vl =min(vb,0.)
 vl =amin1(vb,0.)

 g_Tmpv1 =vl*(g_ph_old(i,k,j+1) -g_ph_old(i,k,j)) +g_vl*(ph_old(i,k,j+1) &
 -ph_old(i,k,j)) 
 Tmpv1 =vl*(ph_old(i,k,j+1) -ph_old(i,k,j))

 g_Tmpv2 =rdy*mut(i,j)*(g_Tmpv1) +rdy*g_mut(i,j)*(Tmpv1) 
 Tmpv2 =rdy*mut(i,j)*(Tmpv1)

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
 ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2

 ENDDO
 ENDDO
 END IF

 IF( (config_flags%open_ye) .and. jte == jde ) THEN

 j =jte-1

 DO k =2,kde

 kz =min(k,kde-1)

 DO i =its,itf

 g_vb =.5*(fnm(kz)*(g_v(i,kz,j+1) +g_v(i,kz,j)) +fnp(kz)*(g_v(i,kz-1,j+1) &
 +g_v(i,kz-1,j)))
 vb =.5*(fnm(kz)*(v(i,kz,j+1) +v(i,kz,j)) +fnp(kz)*(v(i,kz-1,j+1) +v(i,kz-1,j)))

 g_vr =(g_vb +0.0 +(g_vb -0.0)*sign(1.0, vb -(0.)))*0.5
! Revised by Ning Pan, 2010-07-21
! vr =max(vb,0.)
 vr =amax1(vb,0.)

 g_Tmpv1 =vr*(g_ph_old(i,k,j) -g_ph_old(i,k,j-1)) +g_vr*(ph_old(i,k,j) &
 -ph_old(i,k,j-1)) 
 Tmpv1 =vr*(ph_old(i,k,j) -ph_old(i,k,j-1))

 g_Tmpv2 =rdy*mut(i,j)*(g_Tmpv1) +rdy*g_mut(i,j)*(Tmpv1) 
 Tmpv2 =rdy*mut(i,j)*(Tmpv1)

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
 ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2

 ENDDO
 ENDDO
 END IF

 j_start =its

 jtf =min(jte,jde-1)

 IF( (config_flags%open_xs) .and. its == ids ) THEN

 i =its

 DO j =jts,jtf
 DO k =2,kde-1

 kz =k

 g_ub =.5*(fnm(kz)*(g_u(i+1,kz,j) +g_u(i,kz,j)) +fnp(kz)*(g_u(i+1,kz-1,j) &
 +g_u(i,kz-1,j)))
 ub =.5*(fnm(kz)*(u(i+1,kz,j) +u(i,kz,j)) +fnp(kz)*(u(i+1,kz-1,j) +u(i,kz-1,j)))

 g_ul =(g_ub +0.0 -(g_ub -0.0)*sign(1.0, ub -(0.)))*0.5
! Revised by Ning Pan, 2010-07-20
! ul =min(ub,0.)
 ul =amin1(ub,0.)

 g_Tmpv1 =ul*(g_ph_old(i+1,k,j) -g_ph_old(i,k,j)) +g_ul*(ph_old(i+1,k,j) &
 -ph_old(i,k,j)) 
 Tmpv1 =ul*(ph_old(i+1,k,j) -ph_old(i,k,j))

 g_Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(g_Tmpv1) +(msftx(i,j) &
/msfty(i,j)) *rdx*g_mut(i,j)*(Tmpv1) 
 Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(Tmpv1)

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
 ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2

 ENDDO

 k =kde

 kz =k

 g_ub =.5*(fnm(kz)*(g_u(i+1,kz,j) +g_u(i,kz,j)) +fnp(kz)*(g_u(i+1,kz-1,j) &
 +g_u(i,kz-1,j)))
 ub =.5*(fnm(kz)*(u(i+1,kz,j) +u(i,kz,j)) +fnp(kz)*(u(i+1,kz-1,j) +u(i,kz-1,j)))

 g_ul =(g_ub +0.0 -(g_ub -0.0)*sign(1.0, ub -(0.)))*0.5
! Revised by Ning Pan, 2010-07-20
! ul =min(ub,0.)
 ul =amin1(ub,0.)

 g_Tmpv1 =ul*(g_ph_old(i+1,k,j) -g_ph_old(i,k,j)) +g_ul*(ph_old(i+1,k,j) &
 -ph_old(i,k,j)) 
 Tmpv1 =ul*(ph_old(i+1,k,j) -ph_old(i,k,j))

 g_Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(g_Tmpv1) +(msftx(i,j) &
/msfty(i,j)) *rdx*g_mut(i,j)*(Tmpv1) 
 Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(Tmpv1)

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
 ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2

 ENDDO
 END IF

 IF( (config_flags%open_xe) .and. ite == ide ) THEN

 i =ite-1

 DO j =jts,jtf
 DO k =2,kde-1

 kz =k

 g_ub =.5*(fnm(kz)*(g_u(i+1,kz,j) +g_u(i,kz,j)) +fnp(kz)*(g_u(i+1,kz-1,j) &
 +g_u(i,kz-1,j)))
 ub =.5*(fnm(kz)*(u(i+1,kz,j) +u(i,kz,j)) +fnp(kz)*(u(i+1,kz-1,j) +u(i,kz-1,j)))

 g_ur =(g_ub +0.0 +(g_ub -0.0)*sign(1.0, ub -(0.)))*0.5
! Revised by Ning Pan, 2010-07-20
! ur =max(ub,0.)
 ur =amax1(ub,0.)

 g_Tmpv1 =ur*(g_ph_old(i,k,j) -g_ph_old(i-1,k,j)) +g_ur*(ph_old(i,k,j) &
 -ph_old(i-1,k,j)) 
 Tmpv1 =ur*(ph_old(i,k,j) -ph_old(i-1,k,j))

 g_Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(g_Tmpv1) +(msftx(i,j) &
/msfty(i,j)) *rdx*g_mut(i,j)*(Tmpv1) 
 Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(Tmpv1)

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
 ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2

 ENDDO

 k =kde

 kz =k-1

 g_ub =.5*(fnm(kz)*(g_u(i+1,kz,j) +g_u(i,kz,j)) +fnp(kz)*(g_u(i+1,kz-1,j) &
 +g_u(i,kz-1,j)))
 ub =.5*(fnm(kz)*(u(i+1,kz,j) +u(i,kz,j)) +fnp(kz)*(u(i+1,kz-1,j) +u(i,kz-1,j)))

 g_ur =(g_ub +0.0 +(g_ub -0.0)*sign(1.0, ub -(0.)))*0.5
! Revised by Ning Pan, 2010-07-20
! ur =max(ub,0.)
 ur =amax1(ub,0.)

 g_Tmpv1 =ur*(g_ph_old(i,k,j) -g_ph_old(i-1,k,j)) +g_ur*(ph_old(i,k,j) &
 -ph_old(i-1,k,j)) 
 Tmpv1 =ur*(ph_old(i,k,j) -ph_old(i-1,k,j))

 g_Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(g_Tmpv1) +(msftx(i,j) &
/msfty(i,j)) *rdx*g_mut(i,j)*(Tmpv1) 
 Tmpv2 =(msftx(i,j)/msfty(i,j)) *rdx*mut(i,j)*(Tmpv1)

 g_ph_tend(i,k,j) =g_ph_tend(i,k,j) -g_Tmpv2
 ph_tend(i,k,j) =ph_tend(i,k,j) -Tmpv2

 ENDDO
 END IF

 END SUBROUTINE g_rhs_ph

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
!  Differentiation of horizontal_pressure_gradient in forward (tangent) mode:
!   variations   of useful results: ru_tend rv_tend
!   with respect to varying inputs: p al ru_tend cqu cqv php rv_tend
!                ph alt muu muv mu
!   RW status of diff variables: p:in al:in ru_tend:in-out cqu:in
!                cqv:in php:in rv_tend:in-out ph:in alt:in muu:in
!                muv:in mu:in
SUBROUTINE G_HORIZONTAL_PRESSURE_GRADIENT(ru_tend, ru_tendd, rv_tend, &
&  rv_tendd, ph, phd, alt, altd, p, pd, pb, al, ald, php, phpd, cqu, cqud&
&  , cqv, cqvd, muu, muud, muv, muvd, mu, mud, fnm, fnp, rdnw, cf1, cf2, &
&  cf3, cfn, cfn1,rdx, rdy, msfux, msfuy, msfvx, msfvy, msftx, msfty, config_flags&
&  , non_hydrostatic, top_lid, 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
  LOGICAL, INTENT(IN) :: non_hydrostatic, top_lid
  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) :: ph, alt, al&
&  , p, pb, php, cqu, cqv
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: phd, altd, &
&  ald, pd, phpd, cqud, cqvd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tend, &
&  rv_tend
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tendd&
&  , rv_tendd
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: muu, muv, mu, msfux, &
&  msfuy, msfvx, msfvy, msftx, msfty
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: muud, muvd, mud
  REAL, DIMENSION(kms:kme), INTENT(IN) :: rdnw, fnm, fnp
  REAL, INTENT(IN) :: rdx, rdy, cf1, cf2, cf3, cfn, cfn1
  INTEGER :: i, j, k, itf, jtf, ktf, i_start, j_start
  REAL, DIMENSION(ims:ime, kms:kme) :: dpn
  REAL, DIMENSION(ims:ime, kms:kme) :: dpnd
  REAL :: dpx, dpy
  REAL :: dpxd, dpyd
  LOGICAL :: specified
  INTRINSIC MIN
!<DESCRIPTION>
!
!  horizontal_pressure_gradient calculates the 
!  horizontal pressure gradient terms for the large-timestep tendency 
!  in the horizontal momentum equations (u,v).
!
!</DESCRIPTION>
  specified = .false.
  IF (config_flags%specified .OR. config_flags%nested) specified = &
&      .true.
  IF (ite .GT. ide - 1) THEN
    itf = ide - 1
  ELSE
    itf = ite
  END IF
  jtf = jte
  IF (kte .GT. kde - 1) THEN
    ktf = kde - 1
  ELSE
    ktf = kte
  END IF
  i_start = its
  j_start = jts
  IF ((((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
&      .OR. config_flags%polar) .AND. jts .EQ. jds) j_start = jts + 1
  IF ((((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
&      .OR. config_flags%polar) .AND. jte .EQ. jde) THEN
    jtf = jtf - 1
    dpnd = 0.0
  ELSE
    dpnd = 0.0
  END IF
  DO j=j_start,jtf
    IF (non_hydrostatic) THEN
      k = 1
      DO i=i_start,itf
        dpnd(i, k) = .5*(cf1*(pd(i, k, j-1)+pd(i, k, j))+cf2*(pd(i, k+1&
&          , j-1)+pd(i, k+1, j))+cf3*(pd(i, k+2, j-1)+pd(i, k+2, j)))
        dpn(i, k) = .5*(cf1*(p(i, k, j-1)+p(i, k, j))+cf2*(p(i, k+1, j-1&
&          )+p(i, k+1, j))+cf3*(p(i, k+2, j-1)+p(i, k+2, j)))
        dpnd(i, kde) = 0.0
        dpn(i, kde) = 0.
      END DO
      IF (top_lid) THEN
        DO i=i_start,itf
!commented out for bug fix, Jan 2016
!          dpnd(i, kde) = .5*(cf1*(pd(i, kde-1, j-1)+pd(i, kde-1, j))+cf2&
!&            *(pd(i, kde-2, j-1)+pd(i, kde-2, j))+cf3*(pd(i, kde-3, j-1)+&
!&            pd(i, kde-3, j)))
!          dpn(i, kde) = .5*(cf1*(p(i, kde-1, j-1)+p(i, kde-1, j))+cf2*(p&
!&            (i, kde-2, j-1)+p(i, kde-2, j))+cf3*(p(i, kde-3, j-1)+p(i, &
!&            kde-3, j)))
            dpnd(i,kde) = .5*( cfn *(pd(i,kde-1,j-1)+pd(i,kde-1,j))   &
                              +cfn1*(pd(i,kde-2,j-1)+pd(i,kde-2,j)) )

            dpn(i,kde) = .5*( cfn *(p(i,kde-1,j-1)+p(i,kde-1,j))   &
                             +cfn1*(p(i,kde-2,j-1)+p(i,kde-2,j)) )
        END DO
      END IF
      DO k=2,ktf
        DO i=i_start,itf
          dpnd(i, k) = .5*(fnm(k)*(pd(i, k, j-1)+pd(i, k, j))+fnp(k)*(pd&
&            (i, k-1, j-1)+pd(i, k-1, j)))
          dpn(i, k) = .5*(fnm(k)*(p(i, k, j-1)+p(i, k, j))+fnp(k)*(p(i, &
&            k-1, j-1)+p(i, k-1, j)))
        END DO
      END DO
!       ADT eqn 45: -mu*(my/mx)*(1/rho)*partial dp/dy
!       [alt, al are 1/rho terms; muv, mu are NOT coupled]
      DO k=1,ktf
        DO i=i_start,itf
! Here are mu dp/dy terms 1-3 
          dpyd = msfvy(i, j)*.5*rdy*(muvd(i, j)*(ph(i, k+1, j)-ph(i, k+1&
&            , j-1)+ph(i, k, j)-ph(i, k, j-1)+(alt(i, k, j)+alt(i, k, j-1&
&            ))*(p(i, k, j)-p(i, k, j-1))+(al(i, k, j)+al(i, k, j-1))*(pb&
&            (i, k, j)-pb(i, k, j-1)))+muv(i, j)*(phd(i, k+1, j)-phd(i, k&
&            +1, j-1)+phd(i, k, j)-phd(i, k, j-1)+(altd(i, k, j)+altd(i, &
&            k, j-1))*(p(i, k, j)-p(i, k, j-1))+(alt(i, k, j)+alt(i, k, j&
&            -1))*(pd(i, k, j)-pd(i, k, j-1))+(pb(i, k, j)-pb(i, k, j-1))&
&            *(ald(i, k, j)+ald(i, k, j-1))))/msfvx(i, j)
          dpy = msfvy(i, j)/msfvx(i, j)*.5*rdy*muv(i, j)*(ph(i, k+1, j)-&
&            ph(i, k+1, j-1)+ph(i, k, j)-ph(i, k, j-1)+(alt(i, k, j)+alt(&
&            i, k, j-1))*(p(i, k, j)-p(i, k, j-1))+(al(i, k, j)+al(i, k, &
&            j-1))*(pb(i, k, j)-pb(i, k, j-1)))
! Here is mu dp/dy term 4 
          dpyd = dpyd + msfvy(i, j)*rdy*((phpd(i, k, j)-phpd(i, k, j-1))&
&            *(rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i, j-1)+mu(i, j)))+&
&            (php(i, k, j)-php(i, k, j-1))*(rdnw(k)*(dpnd(i, k+1)-dpnd(i&
&            , k))-.5*(mud(i, j-1)+mud(i, j))))/msfvx(i, j)
          dpy = dpy + msfvy(i, j)/msfvx(i, j)*rdy*(php(i, k, j)-php(i, k&
&            , j-1))*(rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i, j-1)+mu(i&
&            , j)))
          rv_tendd(i, k, j) = rv_tendd(i, k, j) - cqvd(i, k, j)*dpy - &
&            cqv(i, k, j)*dpyd
          rv_tend(i, k, j) = rv_tend(i, k, j) - cqv(i, k, j)*dpy
        END DO
      END DO
    ELSE
!       ADT eqn 45: -mu*(my/mx)*(1/rho)*partial dp/dy
!       [alt, al are 1/rho terms; muv, mu are NOT coupled]
      DO k=1,ktf
        DO i=i_start,itf
! Here are mu dp/dy terms 1-3; term 4 not needed if hydrostatic
          dpyd = msfvy(i, j)*.5*rdy*(muvd(i, j)*(ph(i, k+1, j)-ph(i, k+1&
&            , j-1)+ph(i, k, j)-ph(i, k, j-1)+(alt(i, k, j)+alt(i, k, j-1&
&            ))*(p(i, k, j)-p(i, k, j-1))+(al(i, k, j)+al(i, k, j-1))*(pb&
&            (i, k, j)-pb(i, k, j-1)))+muv(i, j)*(phd(i, k+1, j)-phd(i, k&
&            +1, j-1)+phd(i, k, j)-phd(i, k, j-1)+(altd(i, k, j)+altd(i, &
&            k, j-1))*(p(i, k, j)-p(i, k, j-1))+(alt(i, k, j)+alt(i, k, j&
&            -1))*(pd(i, k, j)-pd(i, k, j-1))+(pb(i, k, j)-pb(i, k, j-1))&
&            *(ald(i, k, j)+ald(i, k, j-1))))/msfvx(i, j)
          dpy = msfvy(i, j)/msfvx(i, j)*.5*rdy*muv(i, j)*(ph(i, k+1, j)-&
&            ph(i, k+1, j-1)+ph(i, k, j)-ph(i, k, j-1)+(alt(i, k, j)+alt(&
&            i, k, j-1))*(p(i, k, j)-p(i, k, j-1))+(al(i, k, j)+al(i, k, &
&            j-1))*(pb(i, k, j)-pb(i, k, j-1)))
          rv_tendd(i, k, j) = rv_tendd(i, k, j) - dpyd
          rv_tend(i, k, j) = rv_tend(i, k, j) - dpy
        END DO
      END DO
    END IF
  END DO
!  now the east-west (x) pressure gradient
  itf = ite
  IF (jte .GT. jde - 1) THEN
    jtf = jde - 1
  ELSE
    jtf = jte
  END IF
  IF (kte .GT. kde - 1) THEN
    ktf = kde - 1
  ELSE
    ktf = kte
  END IF
  i_start = its
  j_start = jts
  IF (((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
&      .AND. its .EQ. ids) i_start = its + 1
  IF (((config_flags%open_xe .OR. specified) .OR. config_flags%nested) &
&      .AND. ite .EQ. ide) itf = itf - 1
  IF (config_flags%periodic_x) i_start = its
  IF (config_flags%periodic_x) itf = ite
  DO j=j_start,jtf
    IF (non_hydrostatic) THEN
      k = 1
      DO i=i_start,itf
        dpnd(i, k) = .5*(cf1*(pd(i-1, k, j)+pd(i, k, j))+cf2*(pd(i-1, k+&
&          1, j)+pd(i, k+1, j))+cf3*(pd(i-1, k+2, j)+pd(i, k+2, j)))
        dpn(i, k) = .5*(cf1*(p(i-1, k, j)+p(i, k, j))+cf2*(p(i-1, k+1, j&
&          )+p(i, k+1, j))+cf3*(p(i-1, k+2, j)+p(i, k+2, j)))
        dpnd(i, kde) = 0.0
        dpn(i, kde) = 0.
      END DO
      IF (top_lid) THEN
        DO i=i_start,itf
!commented out for bug fix, Jan 2016
!          dpnd(i, kde) = .5*(cf1*(pd(i-1, kde-1, j)+pd(i, kde-1, j))+cf2&
!&            *(pd(i-1, kde-2, j)+pd(i, kde-2, j))+cf3*(pd(i-1, kde-3, j)+&
!&            pd(i, kde-3, j)))
!          dpn(i, kde) = .5*(cf1*(p(i-1, kde-1, j)+p(i, kde-1, j))+cf2*(p&
!&            (i-1, kde-2, j)+p(i, kde-2, j))+cf3*(p(i-1, kde-3, j)+p(i, &
!&            kde-3, j)))
           dpnd(i,kde) = .5*( cfn *(pd(i-1,kde-1,j)+pd(i,kde-1,j))   &
                             +cfn1*(pd(i-1,kde-2,j)+pd(i,kde-2,j)) )

           dpn(i,kde) = .5*( cfn *(p(i-1,kde-1,j)+p(i,kde-1,j))   &
                            +cfn1*(p(i-1,kde-2,j)+p(i,kde-2,j)) )
        END DO
      END IF
      DO k=2,ktf
        DO i=i_start,itf
          dpnd(i, k) = .5*(fnm(k)*(pd(i-1, k, j)+pd(i, k, j))+fnp(k)*(pd&
&            (i-1, k-1, j)+pd(i, k-1, j)))
          dpn(i, k) = .5*(fnm(k)*(p(i-1, k, j)+p(i, k, j))+fnp(k)*(p(i-1&
&            , k-1, j)+p(i, k-1, j)))
        END DO
      END DO
! ADT eqn 44: -mu*(mx/my)*(1/rho)*partial dp/dx
! [alt, al are 1/rho terms; muu, mu are NOT coupled]
      DO k=1,ktf
        DO i=i_start,itf
! Here are mu dp/dy terms 1-3
          dpxd = msfux(i, j)*.5*rdx*(muud(i, j)*(ph(i, k+1, j)-ph(i-1, k&
&            +1, j)+ph(i, k, j)-ph(i-1, k, j)+(alt(i, k, j)+alt(i-1, k, j&
&            ))*(p(i, k, j)-p(i-1, k, j))+(al(i, k, j)+al(i-1, k, j))*(pb&
&            (i, k, j)-pb(i-1, k, j)))+muu(i, j)*(phd(i, k+1, j)-phd(i-1&
&            , k+1, j)+phd(i, k, j)-phd(i-1, k, j)+(altd(i, k, j)+altd(i-&
&            1, k, j))*(p(i, k, j)-p(i-1, k, j))+(alt(i, k, j)+alt(i-1, k&
&            , j))*(pd(i, k, j)-pd(i-1, k, j))+(pb(i, k, j)-pb(i-1, k, j)&
&            )*(ald(i, k, j)+ald(i-1, k, j))))/msfuy(i, j)
          dpx = msfux(i, j)/msfuy(i, j)*.5*rdx*muu(i, j)*(ph(i, k+1, j)-&
&            ph(i-1, k+1, j)+ph(i, k, j)-ph(i-1, k, j)+(alt(i, k, j)+alt(&
&            i-1, k, j))*(p(i, k, j)-p(i-1, k, j))+(al(i, k, j)+al(i-1, k&
&            , j))*(pb(i, k, j)-pb(i-1, k, j)))
! Here is mu dp/dy term 4
          dpxd = dpxd + msfux(i, j)*rdx*((phpd(i, k, j)-phpd(i-1, k, j))&
&            *(rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i-1, j)+mu(i, j)))+&
&            (php(i, k, j)-php(i-1, k, j))*(rdnw(k)*(dpnd(i, k+1)-dpnd(i&
&            , k))-.5*(mud(i-1, j)+mud(i, j))))/msfuy(i, j)
          dpx = dpx + msfux(i, j)/msfuy(i, j)*rdx*(php(i, k, j)-php(i-1&
&            , k, j))*(rdnw(k)*(dpn(i, k+1)-dpn(i, k))-.5*(mu(i-1, j)+mu(&
&            i, j)))
          ru_tendd(i, k, j) = ru_tendd(i, k, j) - cqud(i, k, j)*dpx - &
&            cqu(i, k, j)*dpxd
          ru_tend(i, k, j) = ru_tend(i, k, j) - cqu(i, k, j)*dpx
        END DO
      END DO
    ELSE
!       ADT eqn 44: -mu*(mx/my)*(1/rho)*partial dp/dx
!       [alt, al are 1/rho terms; muu, mu are NOT coupled]
      DO k=1,ktf
        DO i=i_start,itf
! Here are mu dp/dy terms 1-3; term 4 not needed if hydrostatic
          dpxd = msfux(i, j)*.5*rdx*(muud(i, j)*(ph(i, k+1, j)-ph(i-1, k&
&            +1, j)+ph(i, k, j)-ph(i-1, k, j)+(alt(i, k, j)+alt(i-1, k, j&
&            ))*(p(i, k, j)-p(i-1, k, j))+(al(i, k, j)+al(i-1, k, j))*(pb&
&            (i, k, j)-pb(i-1, k, j)))+muu(i, j)*(phd(i, k+1, j)-phd(i-1&
&            , k+1, j)+phd(i, k, j)-phd(i-1, k, j)+(altd(i, k, j)+altd(i-&
&            1, k, j))*(p(i, k, j)-p(i-1, k, j))+(alt(i, k, j)+alt(i-1, k&
&            , j))*(pd(i, k, j)-pd(i-1, k, j))+(pb(i, k, j)-pb(i-1, k, j)&
&            )*(ald(i, k, j)+ald(i-1, k, j))))/msfuy(i, j)
          dpx = msfux(i, j)/msfuy(i, j)*.5*rdx*muu(i, j)*(ph(i, k+1, j)-&
&            ph(i-1, k+1, j)+ph(i, k, j)-ph(i-1, k, j)+(alt(i, k, j)+alt(&
&            i-1, k, j))*(p(i, k, j)-p(i-1, k, j))+(al(i, k, j)+al(i-1, k&
&            , j))*(pb(i, k, j)-pb(i-1, k, j)))
          ru_tendd(i, k, j) = ru_tendd(i, k, j) - dpxd
          ru_tend(i, k, j) = ru_tend(i, k, j) - dpx
        END DO
      END DO
    END IF
  END DO
END SUBROUTINE G_HORIZONTAL_PRESSURE_GRADIENT

 SUBROUTINE g_pg_buoy_w(rw_tend,g_rw_tend,p,g_p,cqw,g_cqw,mu,g_mu,mub, &
 rdnw,rdn,g,msftx,msfty,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
 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) :: p,g_p
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: cqw,g_cqw
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rw_tend,g_rw_tend
 REAL,DIMENSION(ims:ime,jms:jme) :: mub,mu,g_mu,msftx,msfty
 REAL,DIMENSION(kms:kme) :: rdnw,rdn
 REAL :: g
 INTEGER :: itf,jtf,i,j,k
 REAL :: cq1,g_cq1,cq2,g_cq2

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 DO j =jts,jtf

 k =kde

 DO i =its,itf

 g_cq1 =-1.*(g_cqw(i,k-1,j))/((1. +cqw(i,k-1,j))*(1. +cqw(i,k-1,j)))
 cq1 =1./(1. +cqw(i,k-1,j))

 g_Tmpv1 =cqw(i,k-1,j)*g_cq1 +g_cqw(i,k-1,j)*cq1 
 Tmpv1 =cqw(i,k-1,j)*cq1

 g_cq2 =g_Tmpv1
 cq2 =Tmpv1

 g_Tmpv1 =cq1*2.*rdnw(k-1)*(-g_p(i,k-1,j)) +g_cq1*2.*rdnw(k-1)*(-p(i,k-1,j)) 
 Tmpv1 =cq1*2.*rdnw(k-1)*(-p(i,k-1,j))

 g_rw_tend(i,k,j) =g_rw_tend(i,k,j) +(1./msfty(i,j)) *g*(g_Tmpv1 -g_mu(i, &
 j) -g_cq2*mub(i,j))
 rw_tend(i,k,j) =rw_tend(i,k,j) +(1./msfty(i,j)) *g*(Tmpv1 -mu(i,j) -cq2*mub(i,j))

 ENDDO

 DO k =2,kde-1
 DO i =its,itf

 g_cq1 =-1.*(g_cqw(i,k,j))/((1. +cqw(i,k,j))*(1. +cqw(i,k,j)))
 cq1 =1./(1. +cqw(i,k,j))

 g_Tmpv1 =cqw(i,k,j)*g_cq1 +g_cqw(i,k,j)*cq1 
 Tmpv1 =cqw(i,k,j)*cq1

 g_cq2 =g_Tmpv1
 cq2 =Tmpv1

 g_cqw(i,k,j) =g_cq1
 cqw(i,k,j) =cq1

 g_Tmpv1 =cq1*rdn(k)*(g_p(i,k,j) -g_p(i,k-1,j)) +g_cq1*rdn(k)*(p(i,k,j) &
 -p(i,k-1,j)) 
 Tmpv1 =cq1*rdn(k)*(p(i,k,j) -p(i,k-1,j))

 g_rw_tend(i,k,j) =g_rw_tend(i,k,j) +(1./msfty(i,j)) *g*(g_Tmpv1 -g_mu(i, &
 j) -g_cq2*mub(i,j))
 rw_tend(i,k,j) =rw_tend(i,k,j) +(1./msfty(i,j)) *g*(Tmpv1 -mu(i,j) -cq2*mub(i,j))

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_pg_buoy_w

! Revised by Ning Pan, 2010-07-21
! SUBROUTINE g_w_damp(rw_tend,g_rw_tend,max_vert_cfl,g_max_vert_cfl, &
! max_horiz_cfl,g_max_horiz_cfl,u,g_u,v,g_v,ww,g_ww,w,g_w,mut,g_mut, &
 SUBROUTINE g_w_damp(rw_tend,g_rw_tend,max_vert_cfl, &
 max_horiz_cfl,u,g_u,v,g_v,ww,g_ww,w,g_w,mut,g_mut, &
 rdnw,rdx,rdy,msfux,msfuy,msfvx,msfvy,dt,config_flags,ids,ide,jds,jde,kds,kde,ims,ime, &
 jms,jme,kms,kme,its,ite,jts,jte,kts,kte)

 USE module_llxy
 IMPLICIT NONE

 REAL :: Tmpv1,g_Tmpv1,Tmpv2,g_Tmpv2,Tmpv3,g_Tmpv3,Tmpv4,g_Tmpv4,Tmpv5, &
 g_Tmpv5,Tmpv6,g_Tmpv6
 TYPE(grid_config_rec_type) :: config_flags
 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) :: u,g_u,v,g_v,ww,g_ww,w,g_w
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: rw_tend,g_rw_tend
! Revised by Ning Pan, 2010-07-21
! REAL :: max_vert_cfl,g_max_vert_cfl
! REAL :: max_horiz_cfl,g_max_horiz_cfl
 REAL :: max_vert_cfl
 REAL :: max_horiz_cfl
 REAL :: horiz_cfl,g_horiz_cfl
 REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut
 REAL,DIMENSION(kms:kme) :: rdnw
 REAL :: dt
 REAL :: rdx,rdy
 REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy
 REAL,DIMENSION(ims:ime,jms:jme) :: msfvx,msfvy
! Revised by Ning Pan, 2010-07-21
! REAL :: vert_cfl,g_vert_cfl,cf_n,g_cf_n,cf_d,g_cf_d,maxdub,g_maxdub, &
! maxdeta,g_maxdeta
 REAL :: vert_cfl,g_vert_cfl,cf_n,g_cf_n,cf_d,g_cf_d,maxdub, &
 maxdeta
 INTEGER :: itf,jtf,i,j,k,maxi,maxj,maxk
 INTEGER :: some
 CHARACTER*512 :: temp
 CHARACTER (LEN=256) :: time_str
 CHARACTER (LEN=256) :: grid_str
 integer :: total
! Revised by Ning Pan, 2010-07-21
! REAL :: msfuxt,g_msfuxt,msfxffl,g_msfxffl
 REAL :: msfuxt,g_msfuxt,msfxffl,g_msfxffl

 itf =min(ite,ide-1)

 jtf =min(jte,jde-1)

 some =0

! g_max_vert_cfl =0.0  ! Remarked by Ning Pan, 2010-07-21
 max_vert_cfl =0.

! g_max_horiz_cfl =0.0  ! Remarked by Ning Pan, 2010-07-21
 max_horiz_cfl =0.

 total =0

 IF(config_flags%polar) THEN

!PRINT*, 'DELETED FOR COMPILING BY WALLS' ! Remarked by Ning Pan, 2010-07-21
!STOP  ! Remarked by Ning Pan, 2010-07-21
!g_msfxffl =-1.0*(-g_config_flags%fft_filter_lat*degrad*sin(config_flags%fft_fil &
!ter_lat*degrad))/(cos(config_flags%fft_filter_lat*degrad)*cos(config_flags%fft_filter &
!_lat*degrad))
 msfxffl =1.0/cos(config_flags%fft_filter_lat*degrad)

 END IF

 IF( config_flags%w_damping == 1 ) THEN

 DO j =jts,jtf
 DO k =2,kde-1
 DO i =its,itf
#if 1

 IF(config_flags%polar) THEN

! g_msfuxt =(0.0 +g_msfxffl -(0.0 -g_msfxffl)*sign(1.0, msfux(i,j) -(msfxffl)))*0.5  ! Remarked by Ning Pan, 2010-07-21
 msfuxt =min(msfux(i,j),msfxffl)

 ELSE

! g_msfuxt =0.0  ! Remarked by Ning Pan, 2010-07-21
 msfuxt =msfux(i,j)

 END IF

 g_Tmpv1 =(g_ww(i,k,j)*mut(i,j) -g_mut(i,j)*ww(i,k,j))/(mut(i,j)*mut(i,j)) 
 Tmpv1 =ww(i,k,j)/mut(i,j)

 g_vert_cfl =sign(1.0, Tmpv1*rdnw(k)*dt)*g_Tmpv1*rdnw(k)*dt
 vert_cfl =abs(Tmpv1*rdnw(k)*dt)

 IF( vert_cfl > max_vert_cfl ) THEN

! g_max_vert_cfl =g_vert_cfl  ! Remarked by Ning Pan, 2010-07-21
 max_vert_cfl =vert_cfl

 maxi =i

 maxj =j

 maxk =k

! g_maxdub =g_w(i,k,j)  ! Remarked by Ning Pan, 2010-07-21
 maxdub =w(i,k,j)

! g_maxdeta =0.0  ! Remarked by Ning Pan, 2010-07-21
 maxdeta =-1./rdnw(k)

 ENDIF

! Revised by Ning Pan, 2010-07-21
! g_Tmpv1 =u(i,k,j)*rdx*g_msfuxt +g_u(i,k,j)*rdx*msfuxt 
 g_Tmpv1 =g_u(i,k,j)*rdx*msfuxt 
 Tmpv1 =u(i,k,j)*rdx*msfuxt

 g_horiz_cfl =(sign(1.0, Tmpv1*dt)*g_Tmpv1*dt +sign(1.0, v(i,k,j)*rdy*msfvy(i,j) &
*dt)*g_v(i,k,j)*rdy*msfvy(i,j)*dt +(sign(1.0, Tmpv1*dt)*g_Tmpv1*dt -sign(1.0, &
 v(i,k,j)*rdy*msfvy(i,j)*dt)*g_v(i,k,j)*rdy*msfvy(i,j)*dt)*sign(1.0, abs(Tmpv1*dt) &
 -(abs(v(i,k,j)*rdy*msfvy(i,j)*dt))))*0.5
 horiz_cfl =max(abs(Tmpv1*dt),abs(v(i,k,j)*rdy*msfvy(i,j)*dt))

 IF(horiz_cfl > max_horiz_cfl) THEN

! g_max_horiz_cfl =g_horiz_cfl  ! Remarked by Ning Pan, 2010-07-21
 max_horiz_cfl =horiz_cfl

 endif

 IF(vert_cfl .gt. w_beta) THEN
#else

 g_cf_n =sign(1.0, ww(i,k,j)*rdnw(k)*dt)*g_ww(i,k,j)*rdnw(k)*dt
 cf_n =abs(ww(i,k,j)*rdnw(k)*dt)

 g_cf_d =sign(1.0, mut(i,j))*g_mut(i,j)
 cf_d =abs(mut(i,j))

 IF(cf_n .gt. cf_d*w_beta ) THEN
#endif

 WRITE (temp,*) i,j,k,' vert_cfl,w,d(eta)=',vert_cfl,w(i,k,j),-1./rdnw(k)
!This line is fail to be recognized
            CALL wrf_debug ( 100 , TRIM(temp) )

 if( vert_cfl > 2. ) some =some+1

 g_Tmpv1 =sign(1., w(i,k,j)) *w_alpha*(vert_cfl -w_beta)*g_mut(i,j) &
 +sign(1., w(i,k,j)) *w_alpha*(g_vert_cfl)*mut(i,j) 
 Tmpv1 =sign(1., w(i,k,j)) *w_alpha*(vert_cfl -w_beta)*mut(i,j)

 g_rw_tend(i,k,j) =g_rw_tend(i,k,j) -g_Tmpv1
 rw_tend(i,k,j) =rw_tend(i,k,j) -Tmpv1

 endif
 ENDDO
 ENDDO
 ENDDO
 ELSE
! Remark all the computation of perturbation because this part (w_damping=0) 
!   is just for print (w_damping=0). Ning Pan, 2010-07-21 
 DO j =jts,jtf
 DO k =2,kde-1
 DO i =its,itf
#if 1

 IF(config_flags%polar) THEN

! g_msfuxt =(0.0 +g_msfxffl -(0.0 -g_msfxffl)*sign(1.0, msfux(i,j) -(msfxffl)))*0.5 
 msfuxt =min(msfux(i,j),msfxffl)

 ELSE

! g_msfuxt =0.0
 msfuxt =msfux(i,j)

 END IF

! g_Tmpv1 =(g_ww(i,k,j)*mut(i,j) -g_mut(i,j)*ww(i,k,j))/(mut(i,j)*mut(i,j)) 
 Tmpv1 =ww(i,k,j)/mut(i,j)

! g_vert_cfl =sign(1.0, Tmpv1*rdnw(k)*dt)*g_Tmpv1*rdnw(k)*dt
 vert_cfl =abs(Tmpv1*rdnw(k)*dt)

 IF( vert_cfl > max_vert_cfl ) THEN

! g_max_vert_cfl =g_vert_cfl  ! Remarked by Ning Pan, 2010-07-21
 max_vert_cfl =vert_cfl

 maxi =i

 maxj =j

 maxk =k

! g_maxdub =g_w(i,k,j)
 maxdub =w(i,k,j)

! g_maxdeta =0.0
 maxdeta =-1./rdnw(k)

 ENDIF

! g_Tmpv1 =u(i,k,j)*rdx*g_msfuxt +g_u(i,k,j)*rdx*msfuxt 
 Tmpv1 =u(i,k,j)*rdx*msfuxt

! g_horiz_cfl =(sign(1.0, Tmpv1*dt)*g_Tmpv1*dt +sign(1.0, v(i,k,j)*rdy*msfvy(i,j) &
!*dt)*g_v(i,k,j)*rdy*msfvy(i,j)*dt +(sign(1.0, Tmpv1*dt)*g_Tmpv1*dt -sign(1.0, &
! v(i,k,j)*rdy*msfvy(i,j)*dt)*g_v(i,k,j)*rdy*msfvy(i,j)*dt)*sign(1.0, abs(Tmpv1*dt) &
! -(abs(v(i,k,j)*rdy*msfvy(i,j)*dt))))*0.5
 horiz_cfl =max(abs(Tmpv1*dt),abs(v(i,k,j)*rdy*msfvy(i,j)*dt))

 IF(horiz_cfl > max_horiz_cfl) THEN

! g_max_horiz_cfl =g_horiz_cfl
 max_horiz_cfl =horiz_cfl

 endif

 IF(vert_cfl .gt. w_beta) THEN
#else

! g_cf_n =sign(1.0, ww(i,k,j)*rdnw(k)*dt)*g_ww(i,k,j)*rdnw(k)*dt
 cf_n =abs(ww(i,k,j)*rdnw(k)*dt)

! g_cf_d =sign(1.0, mut(i,j))*g_mut(i,j)
 cf_d =abs(mut(i,j))

 IF(cf_n .gt. cf_d*w_beta ) THEN
#endif

 WRITE (temp,*) i,j,k,' vert_cfl,w,d(eta)=',vert_cfl,w(i,k,j),-1./rdnw(k)
!This line is fail to be recognized
            CALL wrf_debug ( 100 , TRIM(temp) )

 if( vert_cfl > 2. ) some =some+1
  endif
 ENDDO
 ENDDO
 ENDDO
 ENDIF

 IF( some .GT. 0 ) THEN
!This line is fail to be recognized
      CALL get_current_time_string( time_str )
!This line is fail to be recognized
      CALL get_current_grid_name( grid_str )

 WRITE (temp,*) some,' points exceeded cfl=2 in domain '//Trim(grid_str) &
//' at time '//Trim(time_str)//' hours'
!This line is fail to be recognized
      CALL wrf_debug ( 0 , TRIM(temp) )

!REVISED BY WALLS
! WRITE (temp,*) 'MAX AT i,j,k: ',maxi,maxj,maxk,' vert_cfl,w,d(eta) &
!=',max_vert_cfl,maxdub,maxdeta
!This line is fail to be recognized
      CALL wrf_debug ( 0 , TRIM(temp) )
 ENDIF

 END SUBROUTINE g_w_damp

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
!  Differentiation of horizontal_diffusion in forward (tangent) mode:
!   variations   of useful results: tendency
!   with respect to varying inputs: field tendency xkmhd mu
!   RW status of diff variables: field:in tendency:in-out xkmhd:in
!                mu:in
SUBROUTINE G_HORIZONTAL_DIFFUSION(name, field, fieldd, tendency, &
&  tendencyd, mu, mud, config_flags, msfux, msfuy, msfvx, msfvx_inv, &
&  msfvy, msftx, msfty, khdif, xkmhd, xkmhdd, rdx, rdy, 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
  CHARACTER(len=1), INTENT(IN) :: name
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field, xkmhd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: fieldd, &
&  xkmhdd
  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) :: mu
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mud
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
&  msfvx_inv, msfvy, msftx, msfty
  REAL, INTENT(IN) :: rdx, rdy, khdif
! Local data
  INTEGER :: i, j, k, itf, jtf, ktf
  INTEGER :: i_start, i_end, j_start, j_end
  REAL :: mrdx, mkrdxm, mkrdxp, mrdy, mkrdym, mkrdyp
  REAL :: mkrdxmd, mkrdxpd, mkrdymd, mkrdypd
  LOGICAL :: specified
!<DESCRIPTION>
!
!  horizontal_diffusion computes the horizontal diffusion tendency
!  on model horizontal coordinate surfaces.
!
!</DESCRIPTION>
  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
  IF (name .EQ. 'u') 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 .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%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
    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
! The interior is grad: (m_x*d/dx), the exterior is div: (m_x*m_y*d/dx(/m_y))
! setting up different averagings of m^2 partial d/dX and m^2 partial d/dY
          mkrdxmd = msftx(i-1, j)*rdx*(mud(i-1, j)*xkmhd(i-1, k, j)+mu(i&
&            -1, j)*xkmhdd(i-1, k, j))/msfty(i-1, j)
          mkrdxm = msftx(i-1, j)/msfty(i-1, j)*mu(i-1, j)*xkmhd(i-1, k, &
&            j)*rdx
          mkrdxpd = msftx(i, j)*rdx*(mud(i, j)*xkmhd(i, k, j)+mu(i, j)*&
&            xkmhdd(i, k, j))/msfty(i, j)
          mkrdxp = msftx(i, j)/msfty(i, j)*mu(i, j)*xkmhd(i, k, j)*rdx
          mrdx = msfux(i, j)*msfuy(i, j)*rdx
          mkrdymd = (msfuy(i, j)+msfuy(i, j-1))*0.25**2*rdy*((mud(i, j)+&
&            mud(i, j-1)+mud(i-1, j-1)+mud(i-1, j))*(xkmhd(i, k, j)+xkmhd&
&            (i, k, j-1)+xkmhd(i-1, k, j-1)+xkmhd(i-1, k, j))+(mu(i, j)+&
&            mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*(xkmhdd(i, k, j)+xkmhdd(&
&            i, k, j-1)+xkmhdd(i-1, k, j-1)+xkmhdd(i-1, k, j)))/(msfux(i&
&            , j)+msfux(i, j-1))
          mkrdym = (msfuy(i, j)+msfuy(i, j-1))/(msfux(i, j)+msfux(i, j-1&
&            ))*0.25*(mu(i, j)+mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*0.25*(&
&            xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i-1, k, j-1)+xkmhd(i-1&
&            , k, j))*rdy
          mkrdypd = (msfuy(i, j)+msfuy(i, j+1))*0.25**2*rdy*((mud(i, j)+&
&            mud(i, j+1)+mud(i-1, j+1)+mud(i-1, j))*(xkmhd(i, k, j)+xkmhd&
&            (i, k, j+1)+xkmhd(i-1, k, j+1)+xkmhd(i-1, k, j))+(mu(i, j)+&
&            mu(i, j+1)+mu(i-1, j+1)+mu(i-1, j))*(xkmhdd(i, k, j)+xkmhdd(&
&            i, k, j+1)+xkmhdd(i-1, k, j+1)+xkmhdd(i-1, k, j)))/(msfux(i&
&            , j)+msfux(i, j+1))
          mkrdyp = (msfuy(i, j)+msfuy(i, j+1))/(msfux(i, j)+msfux(i, j+1&
&            ))*0.25*(mu(i, j)+mu(i, j+1)+mu(i-1, j+1)+mu(i-1, j))*0.25*(&
&            xkmhd(i, k, j)+xkmhd(i, k, j+1)+xkmhd(i-1, k, j+1)+xkmhd(i-1&
&            , k, j))*rdy
! need to do four-corners (t) for diffusion coefficient as there are
! no values at u,v points
! msfuy - has to be y as part of d/dY
!         has to be u as we're at a u point
          mrdy = msfux(i, j)*msfuy(i, j)*rdy
! correctly averaged version of rho~ * m^2 * 
!    [partial d/dX(partial du^/dX) + partial d/dY(partial du^/dY)]
          tendencyd(i, k, j) = tendencyd(i, k, j) + mrdx*(mkrdxpd*(field&
&            (i+1, k, j)-field(i, k, j))+mkrdxp*(fieldd(i+1, k, j)-fieldd&
&            (i, k, j))-mkrdxmd*(field(i, k, j)-field(i-1, k, j))-mkrdxm*&
&            (fieldd(i, k, j)-fieldd(i-1, k, j))) + mrdy*(mkrdypd*(field(&
&            i, k, j+1)-field(i, k, j))+mkrdyp*(fieldd(i, k, j+1)-fieldd(&
&            i, k, j))-mkrdymd*(field(i, k, j)-field(i, k, j-1))-mkrdym*(&
&            fieldd(i, k, j)-fieldd(i, k, j-1)))
          tendency(i, k, j) = tendency(i, k, j) + (mrdx*(mkrdxp*(field(i&
&            +1, k, j)-field(i, k, j))-mkrdxm*(field(i, k, j)-field(i-1, &
&            k, j)))+mrdy*(mkrdyp*(field(i, k, j+1)-field(i, k, j))-&
&            mkrdym*(field(i, k, j)-field(i, k, j-1))))
        END DO
      END DO
    END DO
  ELSE IF (name .EQ. 'v') 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_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
    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 - 1 .GT. jte) THEN
        j_end = jte
      ELSE
        j_end = jde - 1
      END IF
    END IF
    IF (config_flags%periodic_x) i_start = its
    IF (config_flags%periodic_x) THEN
      IF (ite .GT. ide - 1) THEN
        i_end = ide - 1
      ELSE
        i_end = ite
      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
          mkrdxmd = (msfvx(i, j)+msfvx(i-1, j))*0.25**2*rdx*((mud(i, j)+&
&            mud(i, j-1)+mud(i-1, j-1)+mud(i-1, j))*(xkmhd(i, k, j)+xkmhd&
&            (i, k, j-1)+xkmhd(i-1, k, j-1)+xkmhd(i-1, k, j))+(mu(i, j)+&
&            mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*(xkmhdd(i, k, j)+xkmhdd(&
&            i, k, j-1)+xkmhdd(i-1, k, j-1)+xkmhdd(i-1, k, j)))/(msfvy(i&
&            , j)+msfvy(i-1, j))
          mkrdxm = (msfvx(i, j)+msfvx(i-1, j))/(msfvy(i, j)+msfvy(i-1, j&
&            ))*0.25*(mu(i, j)+mu(i, j-1)+mu(i-1, j-1)+mu(i-1, j))*0.25*(&
&            xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i-1, k, j-1)+xkmhd(i-1&
&            , k, j))*rdx
          mkrdxpd = (msfvx(i, j)+msfvx(i+1, j))*0.25**2*rdx*((mud(i, j)+&
&            mud(i, j-1)+mud(i+1, j-1)+mud(i+1, j))*(xkmhd(i, k, j)+xkmhd&
&            (i, k, j-1)+xkmhd(i+1, k, j-1)+xkmhd(i+1, k, j))+(mu(i, j)+&
&            mu(i, j-1)+mu(i+1, j-1)+mu(i+1, j))*(xkmhdd(i, k, j)+xkmhdd(&
&            i, k, j-1)+xkmhdd(i+1, k, j-1)+xkmhdd(i+1, k, j)))/(msfvy(i&
&            , j)+msfvy(i+1, j))
          mkrdxp = (msfvx(i, j)+msfvx(i+1, j))/(msfvy(i, j)+msfvy(i+1, j&
&            ))*0.25*(mu(i, j)+mu(i, j-1)+mu(i+1, j-1)+mu(i+1, j))*0.25*(&
&            xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i+1, k, j-1)+xkmhd(i+1&
&            , k, j))*rdx
          mrdx = msfvx(i, j)*msfvy(i, j)*rdx
          mkrdymd = msfty(i, j-1)*rdy*xkmhdd(i, k, j-1)/msftx(i, j-1)
          mkrdym = msfty(i, j-1)/msftx(i, j-1)*xkmhd(i, k, j-1)*rdy
          mkrdypd = msfty(i, j)*rdy*xkmhdd(i, k, j)/msftx(i, j)
          mkrdyp = msfty(i, j)/msftx(i, j)*xkmhd(i, k, j)*rdy
          mrdy = msfvx(i, j)*msfvy(i, j)*rdy
          tendencyd(i, k, j) = tendencyd(i, k, j) + mrdx*(mkrdxpd*(field&
&            (i+1, k, j)-field(i, k, j))+mkrdxp*(fieldd(i+1, k, j)-fieldd&
&            (i, k, j))-mkrdxmd*(field(i, k, j)-field(i-1, k, j))-mkrdxm*&
&            (fieldd(i, k, j)-fieldd(i-1, k, j))) + mrdy*(mkrdypd*(field(&
&            i, k, j+1)-field(i, k, j))+mkrdyp*(fieldd(i, k, j+1)-fieldd(&
&            i, k, j))-mkrdymd*(field(i, k, j)-field(i, k, j-1))-mkrdym*(&
&            fieldd(i, k, j)-fieldd(i, k, j-1)))
          tendency(i, k, j) = tendency(i, k, j) + (mrdx*(mkrdxp*(field(i&
&            +1, k, j)-field(i, k, j))-mkrdxm*(field(i, k, j)-field(i-1, &
&            k, j)))+mrdy*(mkrdyp*(field(i, k, j+1)-field(i, k, j))-&
&            mkrdym*(field(i, k, j)-field(i, k, j-1))))
        END DO
      END DO
    END DO
  ELSE IF (name .EQ. 'w') 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 (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
    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
    IF (config_flags%periodic_x) i_start = its
    IF (config_flags%periodic_x) THEN
      IF (ite .GT. ide - 1) THEN
        i_end = ide - 1
      ELSE
        i_end = ite
      END IF
    END IF
    DO j=j_start,j_end
      DO k=kts+1,ktf
        DO i=i_start,i_end
          mkrdxmd = msfux(i, j)*0.25**2*rdx*((2*mud(i, j)+2*mud(i-1, j))&
&            *(xkmhd(i, k, j)+xkmhd(i-1, k, j)+xkmhd(i, k-1, j)+xkmhd(i-1&
&            , k-1, j))+(mu(i, j)+mu(i-1, j)+mu(i, j)+mu(i-1, j))*(xkmhdd&
&            (i, k, j)+xkmhdd(i-1, k, j)+xkmhdd(i, k-1, j)+xkmhdd(i-1, k-&
&            1, j)))/msfuy(i, j)
          mkrdxm = msfux(i, j)/msfuy(i, j)*0.25*(mu(i, j)+mu(i-1, j)+mu(&
&            i, j)+mu(i-1, j))*0.25*(xkmhd(i, k, j)+xkmhd(i-1, k, j)+&
&            xkmhd(i, k-1, j)+xkmhd(i-1, k-1, j))*rdx
          mkrdxpd = msfux(i+1, j)*0.25**2*rdx*((2*mud(i+1, j)+2*mud(i, j&
&            ))*(xkmhd(i+1, k, j)+xkmhd(i, k, j)+xkmhd(i+1, k-1, j)+xkmhd&
&            (i, k-1, j))+(mu(i+1, j)+mu(i, j)+mu(i+1, j)+mu(i, j))*(&
&            xkmhdd(i+1, k, j)+xkmhdd(i, k, j)+xkmhdd(i+1, k-1, j)+xkmhdd&
&            (i, k-1, j)))/msfuy(i+1, j)
          mkrdxp = msfux(i+1, j)/msfuy(i+1, j)*0.25*(mu(i+1, j)+mu(i, j)&
&            +mu(i+1, j)+mu(i, j))*0.25*(xkmhd(i+1, k, j)+xkmhd(i, k, j)+&
&            xkmhd(i+1, k-1, j)+xkmhd(i, k-1, j))*rdx
          mrdx = msftx(i, j)*msfty(i, j)*rdx
!         mkrdym=(msfvy(i,j)/msfvx(i,j))*   &
          mkrdymd = msfvy(i, j)*msfvx_inv(i, j)*0.25**2*rdy*((2*mud(i, j&
&            )+2*mud(i, j-1))*(xkmhd(i, k, j)+xkmhd(i, k, j-1)+xkmhd(i, k&
&            -1, j)+xkmhd(i, k-1, j-1))+(mu(i, j)+mu(i, j-1)+mu(i, j)+mu(&
&            i, j-1))*(xkmhdd(i, k, j)+xkmhdd(i, k, j-1)+xkmhdd(i, k-1, j&
&            )+xkmhdd(i, k-1, j-1)))
          mkrdym = msfvy(i, j)*msfvx_inv(i, j)*0.25*(mu(i, j)+mu(i, j-1)&
&            +mu(i, j)+mu(i, j-1))*0.25*(xkmhd(i, k, j)+xkmhd(i, k, j-1)+&
&            xkmhd(i, k-1, j)+xkmhd(i, k-1, j-1))*rdy
!         mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*   &
          mkrdypd = msfvy(i, j+1)*msfvx_inv(i, j+1)*0.25**2*rdy*((2*mud(&
&            i, j+1)+2*mud(i, j))*(xkmhd(i, k, j+1)+xkmhd(i, k, j)+xkmhd(&
&            i, k-1, j+1)+xkmhd(i, k-1, j))+(mu(i, j+1)+mu(i, j)+mu(i, j+&
&            1)+mu(i, j))*(xkmhdd(i, k, j+1)+xkmhdd(i, k, j)+xkmhdd(i, k-&
&            1, j+1)+xkmhdd(i, k-1, j)))
          mkrdyp = msfvy(i, j+1)*msfvx_inv(i, j+1)*0.25*(mu(i, j+1)+mu(i&
&            , j)+mu(i, j+1)+mu(i, j))*0.25*(xkmhd(i, k, j+1)+xkmhd(i, k&
&            , j)+xkmhd(i, k-1, j+1)+xkmhd(i, k-1, j))*rdy
          mrdy = msftx(i, j)*msfty(i, j)*rdy
          tendencyd(i, k, j) = tendencyd(i, k, j) + mrdx*(mkrdxpd*(field&
&            (i+1, k, j)-field(i, k, j))+mkrdxp*(fieldd(i+1, k, j)-fieldd&
&            (i, k, j))-mkrdxmd*(field(i, k, j)-field(i-1, k, j))-mkrdxm*&
&            (fieldd(i, k, j)-fieldd(i-1, k, j))) + mrdy*(mkrdypd*(field(&
&            i, k, j+1)-field(i, k, j))+mkrdyp*(fieldd(i, k, j+1)-fieldd(&
&            i, k, j))-mkrdymd*(field(i, k, j)-field(i, k, j-1))-mkrdym*(&
&            fieldd(i, k, j)-fieldd(i, k, j-1)))
          tendency(i, k, j) = tendency(i, k, j) + (mrdx*(mkrdxp*(field(i&
&            +1, k, j)-field(i, k, j))-mkrdxm*(field(i, k, j)-field(i-1, &
&            k, j)))+mrdy*(mkrdyp*(field(i, k, j+1)-field(i, k, j))-&
&            mkrdym*(field(i, k, j)-field(i, k, j-1))))
        END DO
      END DO
    END DO
  ELSE
    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 .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
    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
    IF (config_flags%periodic_x) i_start = its
    IF (config_flags%periodic_x) THEN
      IF (ite .GT. ide - 1) THEN
        i_end = ide - 1
      ELSE
        i_end = ite
      END IF
    END IF
    DO j=j_start,j_end
      DO k=kts,ktf
        DO i=i_start,i_end
          mkrdxmd = msfux(i, j)*0.5**2*rdx*((xkmhdd(i, k, j)+xkmhdd(i-1&
&            , k, j))*(mu(i, j)+mu(i-1, j))+(xkmhd(i, k, j)+xkmhd(i-1, k&
&            , j))*(mud(i, j)+mud(i-1, j)))/msfuy(i, j)
          mkrdxm = msfux(i, j)/msfuy(i, j)*0.5*(xkmhd(i, k, j)+xkmhd(i-1&
&            , k, j))*0.5*(mu(i, j)+mu(i-1, j))*rdx
          mkrdxpd = msfux(i+1, j)*0.5**2*rdx*((xkmhdd(i+1, k, j)+xkmhdd(&
&            i, k, j))*(mu(i+1, j)+mu(i, j))+(xkmhd(i+1, k, j)+xkmhd(i, k&
&            , j))*(mud(i+1, j)+mud(i, j)))/msfuy(i+1, j)
          mkrdxp = msfux(i+1, j)/msfuy(i+1, j)*0.5*(xkmhd(i+1, k, j)+&
&            xkmhd(i, k, j))*0.5*(mu(i+1, j)+mu(i, j))*rdx
          mrdx = msftx(i, j)*msfty(i, j)*rdx
!         mkrdym=(msfvy(i,j)/msfvx(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy
          mkrdymd = msfvy(i, j)*msfvx_inv(i, j)*0.5**2*rdy*((xkmhdd(i, k&
&            , j)+xkmhdd(i, k, j-1))*(mu(i, j)+mu(i, j-1))+(xkmhd(i, k, j&
&            )+xkmhd(i, k, j-1))*(mud(i, j)+mud(i, j-1)))
          mkrdym = msfvy(i, j)*msfvx_inv(i, j)*0.5*(xkmhd(i, k, j)+xkmhd&
&            (i, k, j-1))*0.5*(mu(i, j)+mu(i, j-1))*rdy
!         mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy
          mkrdypd = msfvy(i, j+1)*msfvx_inv(i, j+1)*0.5**2*rdy*((xkmhdd(&
&            i, k, j+1)+xkmhdd(i, k, j))*(mu(i, j+1)+mu(i, j))+(xkmhd(i, &
&            k, j+1)+xkmhd(i, k, j))*(mud(i, j+1)+mud(i, j)))
          mkrdyp = msfvy(i, j+1)*msfvx_inv(i, j+1)*0.5*(xkmhd(i, k, j+1)&
&            +xkmhd(i, k, j))*0.5*(mu(i, j+1)+mu(i, j))*rdy
          mrdy = msftx(i, j)*msfty(i, j)*rdy
          tendencyd(i, k, j) = tendencyd(i, k, j) + mrdx*(mkrdxpd*(field&
&            (i+1, k, j)-field(i, k, j))+mkrdxp*(fieldd(i+1, k, j)-fieldd&
&            (i, k, j))-mkrdxmd*(field(i, k, j)-field(i-1, k, j))-mkrdxm*&
&            (fieldd(i, k, j)-fieldd(i-1, k, j))) + mrdy*(mkrdypd*(field(&
&            i, k, j+1)-field(i, k, j))+mkrdyp*(fieldd(i, k, j+1)-fieldd(&
&            i, k, j))-mkrdymd*(field(i, k, j)-field(i, k, j-1))-mkrdym*(&
&            fieldd(i, k, j)-fieldd(i, k, j-1)))
          tendency(i, k, j) = tendency(i, k, j) + (mrdx*(mkrdxp*(field(i&
&            +1, k, j)-field(i, k, j))-mkrdxm*(field(i, k, j)-field(i-1, &
&            k, j)))+mrdy*(mkrdyp*(field(i, k, j+1)-field(i, k, j))-&
&            mkrdym*(field(i, k, j)-field(i, k, j-1))))
        END DO
      END DO
    END DO
  END IF
END SUBROUTINE G_HORIZONTAL_DIFFUSION

 SUBROUTINE g_horizontal_diffusion_3dmp(name,field,g_field,tendency, &
 g_tendency,mu,g_mu,config_flags,base_3d,msfux,msfuy,msfvx,msfvx_inv,msfvy, &
 msftx,msfty,khdif,xkmhd,g_xkmhd,rdx,rdy,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
 TYPE(grid_config_rec_type) :: config_flags
 INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
 CHARACTER (LEN=1) :: name
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field,xkmhd,g_xkmhd,base_3d
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
 REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
 REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvx_inv,msfvy,msftx,msfty
 REAL :: rdx,rdy,khdif

 INTEGER :: i,j,k,itf,jtf,ktf
 INTEGER :: i_start,i_end,j_start,j_end
! Revised by Ning Pan, 2010-07-23 
! REAL :: mrdx,g_mrdx,mkrdxm,g_mkrdxm,mkrdxp,g_mkrdxp,mrdy,g_mrdy,mkrdym, &
 REAL :: mrdx,mkrdxm,g_mkrdxm,mkrdxp,g_mkrdxp,mrdy,mkrdym, &
 g_mkrdym,mkrdyp,g_mkrdyp
 LOGICAL :: specified

 specified =.false.

 if(config_flags%specified .or. config_flags%nested) specified =.true.

 ktf =min(kte,kde-1)

 i_start =its

 i_end =min(ite,ide-1)

 j_start =jts

 j_end =min(jte,jde-1)

 IF( config_flags%open_xs .or. specified ) i_start =max(ids+1,its)

 IF( config_flags%open_xe .or. specified ) i_end =min(ide-2,ite)

 IF( config_flags%open_ys .or. specified ) j_start =max(jds+1,jts)

 IF( config_flags%open_ye .or. specified ) j_end =min(jde-2,jte)

 IF( config_flags%periodic_x ) i_start =its

 IF( config_flags%periodic_x ) i_end =min(ite,ide-1)

 DO j =j_start,j_end
 DO k =kts,ktf
 DO i =i_start,i_end

 g_Tmpv1 =(msfux(i,j)/msfuy(i,j)) *0.5*(xkmhd(i,k,j) +xkmhd(i-1,k,j)) &
*0.5*(g_mu(i,j) +g_mu(i-1,j)) +(msfux(i,j)/msfuy(i,j)) *0.5*(g_xkmhd(i,k,j) &
 +g_xkmhd(i-1,k,j))*0.5*(mu(i,j) +mu(i-1,j)) 
 Tmpv1 =(msfux(i,j)/msfuy(i,j)) *0.5*(xkmhd(i,k,j) +xkmhd(i-1,k,j))*0.5*(mu(i,j) +mu(i-1,j))

 g_mkrdxm =g_Tmpv1*rdx
 mkrdxm =Tmpv1*rdx

 g_Tmpv1 =(msfux(i+1,j)/msfuy(i+1,j)) *0.5*(xkmhd(i+1,k,j) +xkmhd(i,k,j)) &
*0.5*(g_mu(i+1,j) +g_mu(i,j)) +(msfux(i+1,j)/msfuy(i+1,j)) *0.5*(g_xkmhd(i+ &
 1,k,j) +g_xkmhd(i,k,j))*0.5*(mu(i+1,j) +mu(i,j)) 
 Tmpv1 =(msfux(i+1,j)/msfuy(i+1,j)) *0.5*(xkmhd(i+1,k,j) +xkmhd(i,k,j)) &
*0.5*(mu(i+1,j) +mu(i,j))

 g_mkrdxp =g_Tmpv1*rdx
 mkrdxp =Tmpv1*rdx

! g_mrdx =0.0  ! Remarked by Ning Pan, 2010-07-23
 mrdx =msftx(i,j) *msfty(i,j) *rdx

 g_Tmpv1 =(msfvy(i,j) *msfvx_inv(i,j)) *0.5*(xkmhd(i,k,j) +xkmhd(i,k,j-1)) &
*0.5*(g_mu(i,j) +g_mu(i,j-1)) +(msfvy(i,j) *msfvx_inv(i,j)) *0.5*(g_xkmhd(i, &
 k,j) +g_xkmhd(i,k,j-1))*0.5*(mu(i,j) +mu(i,j-1)) 
 Tmpv1 =(msfvy(i,j) *msfvx_inv(i,j)) *0.5*(xkmhd(i,k,j) +xkmhd(i,k,j-1))*0.5*(mu(i,j) &
 +mu(i,j-1))

 g_mkrdym =g_Tmpv1*rdy
 mkrdym =Tmpv1*rdy

 g_Tmpv1 =(msfvy(i,j+1) *msfvx_inv(i,j+1)) *0.5*(xkmhd(i,k,j+1) +xkmhd(i,k,j)) &
*0.5*(g_mu(i,j+1) +g_mu(i,j)) +(msfvy(i,j+1) *msfvx_inv(i,j+1)) *0.5*( &
 g_xkmhd(i,k,j+1) +g_xkmhd(i,k,j))*0.5*(mu(i,j+1) +mu(i,j)) 
 Tmpv1 =(msfvy(i,j+1) *msfvx_inv(i,j+1)) *0.5*(xkmhd(i,k,j+1) +xkmhd(i,k,j)) &
*0.5*(mu(i,j+1) +mu(i,j))

 g_mkrdyp =g_Tmpv1*rdy
 mkrdyp =Tmpv1*rdy

! g_mrdy =0.0  ! Remarked by Ning Pan, 2010-07-23
 mrdy =msftx(i,j) *msfty(i,j) *rdy

 g_Tmpv1 =mkrdxp*(g_field(i+1,k,j) -g_field(i,k,j)) +g_mkrdxp*(field(i+1, &
 k,j) -field(i,k,j) -base_3d(i+1,k,j) +base_3d(i,k,j)) 
 Tmpv1 =mkrdxp*(field(i+1,k,j) -field(i,k,j) -base_3d(i+1,k,j) +base_3d(i,k,j))

 g_Tmpv2 =mkrdxm*(g_field(i,k,j) -g_field(i-1,k,j)) +g_mkrdxm*(field(i,k, &
 j) -field(i-1,k,j) -base_3d(i,k,j) +base_3d(i-1,k,j)) 
 Tmpv2 =mkrdxm*(field(i,k,j) -field(i-1,k,j) -base_3d(i,k,j) +base_3d(i-1,k,j))

! Revised by Ning Pan, 2010-07-23
! g_Tmpv3 =mrdx*(g_Tmpv1 -g_Tmpv2) +g_mrdx*(Tmpv1 -Tmpv2) 
 g_Tmpv3 =mrdx*(g_Tmpv1 -g_Tmpv2)
 Tmpv3 =mrdx*(Tmpv1 -Tmpv2)

 g_Tmpv4 =mkrdyp*(g_field(i,k,j+1) -g_field(i,k,j)) +g_mkrdyp*(field(i,k, &
 j+1) -field(i,k,j) -base_3d(i,k,j+1) +base_3d(i,k,j)) 
 Tmpv4 =mkrdyp*(field(i,k,j+1) -field(i,k,j) -base_3d(i,k,j+1) +base_3d(i,k,j))

 g_Tmpv5 =mkrdym*(g_field(i,k,j) -g_field(i,k,j-1)) +g_mkrdym*(field(i,k, &
 j) -field(i,k,j-1) -base_3d(i,k,j) +base_3d(i,k,j-1)) 
 Tmpv5 =mkrdym*(field(i,k,j) -field(i,k,j-1) -base_3d(i,k,j) +base_3d(i,k,j-1))

! Revised by Ning Pan, 2010-07-23
! g_Tmpv6 =mrdy*(g_Tmpv4 -g_Tmpv5) +g_mrdy*(Tmpv4 -Tmpv5) 
 g_Tmpv6 =mrdy*(g_Tmpv4 -g_Tmpv5)
 Tmpv6 =mrdy*(Tmpv4 -Tmpv5)

 g_tendency(i,k,j) =g_tendency(i,k,j) +(g_Tmpv3 +g_Tmpv6)
 tendency(i,k,j) =tendency(i,k,j) +(Tmpv3 +Tmpv6)

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_horizontal_diffusion_3dmp

 SUBROUTINE g_vertical_diffusion(name,field,g_field,tendency,g_tendency, &
 config_flags,alt,g_alt,mut,g_mut,rdn,rdnw,kvdif,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
 TYPE(grid_config_rec_type) :: config_flags
 INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
 CHARACTER (LEN=1) :: name
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field,alt,g_alt
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
 REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut
 REAL,DIMENSION(kms:kme) :: rdn,rdnw
 REAL :: kvdif

 INTEGER :: i,j,k,itf,jtf,ktf
 INTEGER :: i_start,i_end,j_start,j_end
! REAL,DIMENSION(its:ite,jts:jte) :: vfluxm,g_vfluxm,vfluxp,g_vfluxp,zz,g_zz  ! Remarked by Ning Pan, 2010-07-23
 REAL,DIMENSION(its:ite,0:kte+1) :: vflux,g_vflux
! REAL :: rdz,g_rdz  ! Remarked by Ning Pan, 2010-07-23
 LOGICAL :: specified

 specified =.false.

 if(config_flags%specified .or. config_flags%nested) specified =.true.

 ktf =min(kte,kde-1)

 IF(name .EQ. 'w') THEN

 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-1
 DO i =i_start,i_end

 g_Tmpv1 =(kvdif/alt(i,k,j))*rdnw(k)*(g_field(i,k+1,j) -g_field(i,k,j)) &
 +(-kvdif*g_alt(i,k,j)/(alt(i,k,j)*alt(i,k,j)))*rdnw(k)*(field(i,k+1,j) -field(i,k,j)) 
 Tmpv1 =(kvdif/alt(i,k,j))*rdnw(k)*(field(i,k+1,j) -field(i,k,j))

 g_vflux(i,k) =g_Tmpv1
 vflux(i,k) =Tmpv1

 ENDDO
 ENDDO

 DO i =i_start,i_end

 g_vflux(i,ktf) =0.0
 vflux(i,ktf) =0.

 ENDDO

 DO k =kts+1,ktf
 DO i =i_start,i_end

 g_Tmpv1 =((-rdn(k) *g *g*g_mut(i,j)/(mut(i,j)*mut(i,j)))*(0.5*(alt(i,k,j) &
 +alt(i,k-1,j))) -(0.5*(g_alt(i,k,j) +g_alt(i,k-1,j)))*rdn(k) *g *g/mut(i,j)) &
/((0.5*(alt(i,k,j) +alt(i,k-1,j)))*(0.5*(alt(i,k,j) +alt(i,k-1,j)))) 
 Tmpv1 =rdn(k) *g *g/mut(i,j)/(0.5*(alt(i,k,j) +alt(i,k-1,j)))

 g_Tmpv2 =Tmpv1*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*(vflux(i,k) -vflux(i,k-1)) 
 Tmpv2 =Tmpv1*(vflux(i,k) -vflux(i,k-1))

 g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
 tendency(i,k,j) =tendency(i,k,j) +Tmpv2

 ENDDO
 ENDDO
 ENDDO
 ELSE IF(name .EQ. 'm') THEN

 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-1
 DO i =i_start,i_end

 g_Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(g_field(i,k+1,j) &
 -g_field(i,k,j)) +(-kvdif *rdn(k+1)*(0.5*(g_alt(i,k,j) +g_alt(i,k+1,j))) &
/((0.5*(alt(i,k,j) +alt(i,k+1,j)))*(0.5*(alt(i,k,j) +alt(i,k+1,j)))))*(field(i,k+1,j) &
 -field(i,k,j)) 
 Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(field(i,k+1,j) -field(i,k,j))

 g_vflux(i,k) =g_Tmpv1
 vflux(i,k) =Tmpv1

 ENDDO
 ENDDO

 DO i =i_start,i_end

 g_vflux(i,0) =g_vflux(i,1)
 vflux(i,0) =vflux(i,1)

 ENDDO

 DO i =i_start,i_end

 g_vflux(i,ktf) =0.0
 vflux(i,ktf) =0.

 ENDDO

 DO k =kts,ktf
 DO i =i_start,i_end

 g_Tmpv1 =((-g *g*g_mut(i,j)/(mut(i,j)*mut(i,j)))*alt(i,k,j) -g_alt(i,k,j) &
*g *g/mut(i,j))/(alt(i,k,j)*alt(i,k,j)) 
 Tmpv1 =g *g/mut(i,j)/alt(i,k,j)

 g_Tmpv2 =Tmpv1*rdnw(k)*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*rdnw(k) &
*(vflux(i,k) -vflux(i,k-1)) 
 Tmpv2 =Tmpv1*rdnw(k)*(vflux(i,k) -vflux(i,k-1))

 g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
 tendency(i,k,j) =tendency(i,k,j) +Tmpv2

 ENDDO
 ENDDO
 ENDDO
 ENDIF

 END SUBROUTINE g_vertical_diffusion

 SUBROUTINE g_vertical_diffusion_mp(field,g_field,tendency,g_tendency, &
 config_flags,base,alt,g_alt,mut,g_mut,rdn,rdnw,kvdif,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
 TYPE(grid_config_rec_type) :: config_flags
 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,alt,g_alt
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
 REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut
 REAL,DIMENSION(kms:kme) :: rdn,rdnw,base
 REAL :: kvdif

 INTEGER :: i,j,k,itf,jtf,ktf
 INTEGER :: i_start,i_end,j_start,j_end
 REAL,DIMENSION(its:ite,0:kte+1) :: vflux,g_vflux
 REAL :: rdz,g_rdz
 LOGICAL :: specified

 specified =.false.

 if(config_flags%specified .or. config_flags%nested) specified =.true.

 ktf =min(kte,kde-1)

 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-1
 DO i =i_start,i_end

 g_Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(g_field(i,k+1,j) &
 -g_field(i,k,j)) +(-kvdif *rdn(k+1)*(0.5*(g_alt(i,k,j) +g_alt(i,k+1,j))) &
/((0.5*(alt(i,k,j) +alt(i,k+1,j)))*(0.5*(alt(i,k,j) +alt(i,k+1,j)))))*(field(i,k+1,j) &
 -field(i,k,j) -base(k+1) +base(k)) 
 Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(field(i,k+1,j) &
 -field(i,k,j) -base(k+1) +base(k))

 g_vflux(i,k) =g_Tmpv1
 vflux(i,k) =Tmpv1

 ENDDO
 ENDDO

 DO i =i_start,i_end

 g_vflux(i,0) =g_vflux(i,1)
 vflux(i,0) =vflux(i,1)

 ENDDO

 DO i =i_start,i_end

 g_vflux(i,ktf) =0.0
 vflux(i,ktf) =0.

 ENDDO

 DO k =kts,ktf
 DO i =i_start,i_end

 g_Tmpv1 =((-g *g*g_mut(i,j)/(mut(i,j)*mut(i,j)))*alt(i,k,j) -g_alt(i,k,j) &
*g *g/mut(i,j))/(alt(i,k,j)*alt(i,k,j)) 
 Tmpv1 =g *g/mut(i,j)/alt(i,k,j)

 g_Tmpv2 =Tmpv1*rdnw(k)*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*rdnw(k) &
*(vflux(i,k) -vflux(i,k-1)) 
 Tmpv2 =Tmpv1*rdnw(k)*(vflux(i,k) -vflux(i,k-1))

 g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
 tendency(i,k,j) =tendency(i,k,j) +Tmpv2

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_vertical_diffusion_mp

 SUBROUTINE g_vertical_diffusion_3dmp(field,g_field,tendency,g_tendency, &
 config_flags,base_3d,alt,g_alt,mut,g_mut,rdn,rdnw,kvdif,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
 TYPE(grid_config_rec_type) :: config_flags
 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,alt,g_alt,base_3d
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
 REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut
 REAL,DIMENSION(kms:kme) :: rdn,rdnw
 REAL :: kvdif

 INTEGER :: i,j,k,itf,jtf,ktf
 INTEGER :: i_start,i_end,j_start,j_end
 REAL,DIMENSION(its:ite,0:kte+1) :: vflux,g_vflux
! REAL :: rdz,g_rdz  ! Remarked by Ning Pan, 2010-07-23
 LOGICAL :: specified

 specified =.false.

 if(config_flags%specified .or. config_flags%nested) specified =.true.

 ktf =min(kte,kde-1)

 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-1
 DO i =i_start,i_end

 g_Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(g_field(i,k+1,j) &
 -g_field(i,k,j)) +(-kvdif *rdn(k+1)*(0.5*(g_alt(i,k,j) +g_alt(i,k+1,j))) &
/((0.5*(alt(i,k,j) +alt(i,k+1,j)))*(0.5*(alt(i,k,j) +alt(i,k+1,j)))))*(field(i,k+1,j) &
 -field(i,k,j) -base_3d(i,k+1,j) +base_3d(i,k,j)) 
 Tmpv1 =kvdif *rdn(k+1)/(0.5*(alt(i,k,j) +alt(i,k+1,j)))*(field(i,k+1,j) &
 -field(i,k,j) -base_3d(i,k+1,j) +base_3d(i,k,j))

 g_vflux(i,k) =g_Tmpv1
 vflux(i,k) =Tmpv1

 ENDDO
 ENDDO

 DO i =i_start,i_end

 g_vflux(i,0) =g_vflux(i,1)
 vflux(i,0) =vflux(i,1)

 ENDDO

 DO i =i_start,i_end

 g_vflux(i,ktf) =0.0
 vflux(i,ktf) =0.

 ENDDO

 DO k =kts,ktf
 DO i =i_start,i_end

 g_Tmpv1 =((-g *g*g_mut(i,j)/(mut(i,j)*mut(i,j)))*alt(i,k,j) -g_alt(i,k,j) &
*g *g/mut(i,j))/(alt(i,k,j)*alt(i,k,j)) 
 Tmpv1 =g *g/mut(i,j)/alt(i,k,j)

 g_Tmpv2 =Tmpv1*rdnw(k)*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*rdnw(k) &
*(vflux(i,k) -vflux(i,k-1)) 
 Tmpv2 =Tmpv1*rdnw(k)*(vflux(i,k) -vflux(i,k-1))

 g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
 tendency(i,k,j) =tendency(i,k,j) +Tmpv2

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_vertical_diffusion_3dmp

 SUBROUTINE g_vertical_diffusion_u(field,g_field,tendency,g_tendency, &
 config_flags,u_base,alt,g_alt,muu,g_muu,rdn,rdnw,kvdif,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
 TYPE(grid_config_rec_type) :: config_flags
 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,alt,g_alt
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
 REAL,DIMENSION(ims:ime,jms:jme) :: muu,g_muu
 REAL,DIMENSION(kms:kme) :: rdn,rdnw,u_base
 REAL :: kvdif

 INTEGER :: i,j,k,itf,jtf,ktf
 INTEGER :: i_start,i_end,j_start,j_end
 REAL,DIMENSION(its:ite,0:kte+1) :: vflux,g_vflux
 REAL :: rdz,g_rdz,zz,g_zz
 LOGICAL :: specified

 specified =.false.

 if(config_flags%specified .or. config_flags%nested) specified =.true.

 ktf =min(kte,kde-1)

 i_start =its

 i_end =ite

 j_start =jts

 j_end =min(jte,jde-1)

 IF( config_flags%open_xs .or. specified ) i_start =max(ids+1,its)

 IF( config_flags%open_xe .or. specified ) i_end =min(ide-1,ite)

 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-1
 DO i =i_start,i_end

 g_Tmpv1 =kvdif *rdn(k+1)/(0.25*(alt(i,k,j) +alt(i-1,k,j) +alt(i,k+1,j) &
 +alt(i-1,k+1,j)))*(g_field(i,k+1,j) -g_field(i,k,j)) +(-kvdif *rdn(k+1) &
*(0.25*(g_alt(i,k,j) +g_alt(i-1,k,j) +g_alt(i,k+1,j) +g_alt(i-1,k+1,j))) &
/((0.25*(alt(i,k,j) +alt(i-1,k,j) +alt(i,k+1,j) +alt(i-1,k+1,j)))*(0.25*(alt(i,k,j) &
 +alt(i-1,k,j) +alt(i,k+1,j) +alt(i-1,k+1,j)))))*(field(i,k+1,j) -field(i,k,j) &
 -u_base(k+1) +u_base(k)) 
 Tmpv1 =kvdif *rdn(k+1)/(0.25*(alt(i,k,j) +alt(i-1,k,j) +alt(i,k+1,j) +alt(i-1,k+1, &
 j)))*(field(i,k+1,j) -field(i,k,j) -u_base(k+1) +u_base(k))

 g_vflux(i,k) =g_Tmpv1
 vflux(i,k) =Tmpv1

 ENDDO
 ENDDO

 DO i =i_start,i_end

 g_vflux(i,0) =g_vflux(i,1)
 vflux(i,0) =vflux(i,1)

 ENDDO

 DO i =i_start,i_end

 g_vflux(i,ktf) =0.0
 vflux(i,ktf) =0.

 ENDDO

 DO k =kts,ktf-1
 DO i =i_start,i_end

 g_Tmpv1 =((-g *g *rdnw(k)*g_muu(i,j)/(muu(i,j)*muu(i,j)))*(0.5*(alt(i-1,k,j) &
 +alt(i,k,j))) -(0.5*(g_alt(i-1,k,j) +g_alt(i,k,j)))*g *g *rdnw(k)/muu(i,j)) &
/((0.5*(alt(i-1,k,j) +alt(i,k,j)))*(0.5*(alt(i-1,k,j) +alt(i,k,j)))) 
 Tmpv1 =g *g *rdnw(k)/muu(i,j)/(0.5*(alt(i-1,k,j) +alt(i,k,j)))

 g_Tmpv2 =Tmpv1*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*(vflux(i,k) -vflux(i,k-1)) 
 Tmpv2 =Tmpv1*(vflux(i,k) -vflux(i,k-1))

 g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
 tendency(i,k,j) =tendency(i,k,j) +Tmpv2

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_vertical_diffusion_u

 SUBROUTINE g_vertical_diffusion_v(field,g_field,tendency,g_tendency, &
 config_flags,v_base,alt,g_alt,muv,g_muv,rdn,rdnw,kvdif,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
 TYPE(grid_config_rec_type) :: config_flags
 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,alt,g_alt
 REAL,DIMENSION(kms:kme) :: rdn,rdnw,v_base
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
 REAL,DIMENSION(ims:ime,jms:jme) :: muv,g_muv
 REAL :: kvdif

 INTEGER :: i,j,k,itf,jtf,ktf,jm1
 INTEGER :: i_start,i_end,j_start,j_end
 REAL,DIMENSION(its:ite,0:kte+1) :: vflux,g_vflux
! REAL :: rdz,g_rdz,zz,g_zz  ! Remarked by Ning Pan, 2010-07-23
 LOGICAL :: specified

 specified =.false.

 if(config_flags%specified .or. config_flags%nested) specified =.true.

 ktf =min(kte,kde-1)

 i_start =its

 i_end =min(ite,ide-1)

 j_start =jts

 j_end =min(jte,jde-1)

 IF( config_flags%open_ys .or. specified ) j_start =max(jds+1,jts)

 IF( config_flags%open_ye .or. specified ) j_end =min(jde-1,jte)

 DO j =j_start,j_end

 jm1 =j-1

 DO k =kts,ktf-1
 DO i =i_start,i_end

 g_Tmpv1 =kvdif *rdn(k+1)/(0.25*(alt(i,k,j) +alt(i,k,jm1) +alt(i,k+1,j) &
 +alt(i,k+1,jm1)))*(g_field(i,k+1,j) -g_field(i,k,j)) +(-kvdif *rdn(k+1) &
*(0.25*(g_alt(i,k,j) +g_alt(i,k,jm1) +g_alt(i,k+1,j) +g_alt(i,k+1,jm1))) &
/((0.25*(alt(i,k,j) +alt(i,k,jm1) +alt(i,k+1,j) +alt(i,k+1,jm1)))*(0.25*(alt(i,k,j) &
 +alt(i,k,jm1) +alt(i,k+1,j) +alt(i,k+1,jm1)))))*(field(i,k+1,j) -field(i,k,j) &
 -v_base(k+1) +v_base(k)) 
 Tmpv1 =kvdif *rdn(k+1)/(0.25*(alt(i,k,j) +alt(i,k,jm1) +alt(i,k+1,j) +alt(i,k+1, &
 jm1)))*(field(i,k+1,j) -field(i,k,j) -v_base(k+1) +v_base(k))

 g_vflux(i,k) =g_Tmpv1
 vflux(i,k) =Tmpv1

 ENDDO
 ENDDO

 DO i =i_start,i_end

 g_vflux(i,0) =g_vflux(i,1)
 vflux(i,0) =vflux(i,1)

 ENDDO

 DO i =i_start,i_end

 g_vflux(i,ktf) =0.0
 vflux(i,ktf) =0.

 ENDDO

 DO k =kts,ktf-1
 DO i =i_start,i_end

 g_Tmpv1 =((-g *g *rdnw(k)*g_muv(i,j)/(muv(i,j)*muv(i,j)))*(0.5*(alt(i,k,jm1) &
 +alt(i,k,j))) -(0.5*(g_alt(i,k,jm1) +g_alt(i,k,j)))*g *g *rdnw(k)/muv(i,j)) &
/((0.5*(alt(i,k,jm1) +alt(i,k,j)))*(0.5*(alt(i,k,jm1) +alt(i,k,j)))) 
 Tmpv1 =g *g *rdnw(k)/muv(i,j)/(0.5*(alt(i,k,jm1) +alt(i,k,j)))

 g_Tmpv2 =Tmpv1*(g_vflux(i,k) -g_vflux(i,k-1)) +g_Tmpv1*(vflux(i,k) -vflux(i,k-1)) 
 Tmpv2 =Tmpv1*(vflux(i,k) -vflux(i,k-1))

 g_tendency(i,k,j) =g_tendency(i,k,j) +g_Tmpv2
 tendency(i,k,j) =tendency(i,k,j) +Tmpv2

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_vertical_diffusion_v

SUBROUTINE g_calculate_full ( rfield, g_rfield, rfieldb, rfieldp, g_rfieldp, &
                              ids, ide, jds, jde, kds, kde, &
                              ims, ime, jms, jme, kms, kme, &
                              its, ite, jts, jte, kts, kte )

   IMPLICIT NONE
   
   ! Input data
   
   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   ) :: g_rfieldp
   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: rfieldb, &
                                                                      rfieldp

   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT  ) :: g_rfield
   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT  ) :: rfield
   
   ! Local indices.
   
   INTEGER :: i, j, k, itf, jtf, ktf
   
!<DESCRIPTION>
!
!  calculate_full
!  calculates full 3D field from pertubation and base field.
!
!</DESCRIPTION>

   itf=MIN(ite,ide-1)
   jtf=MIN(jte,jde-1)
   ktf=MIN(kte,kde-1)

   DO j=jts,jtf
   DO k=kts,ktf
   DO i=its,itf
      g_rfield(i,k,j)=g_rfieldp(i,k,j)
      rfield(i,k,j)=rfieldb(i,k,j)+rfieldp(i,k,j)
   ENDDO
   ENDDO
   ENDDO

END SUBROUTINE g_calculate_full

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
!  Differentiation of coriolis in forward (tangent) mode:
!   variations   of useful results: ru_tend rw_tend rv_tend
!   with respect to varying inputs: ru_tend rw_tend ru rv rw rv_tend
!   RW status of diff variables: ru_tend:in-out rw_tend:in-out
!                ru:in rv:in rw:in rv_tend:in-out
SUBROUTINE G_CORIOLIS(ru, rud, rv, rvd, rw, rwd, ru_tend, ru_tendd, &
&  rv_tend, rv_tendd, rw_tend, rw_tendd, config_flags, msftx, msfty, &
&  msfux, msfuy, msfvx, msfvy, f, e, sina, cosa, fzm, fzp, 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(INOUT) :: ru_tend, &
&  rv_tend, rw_tend
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tendd&
&  , rv_tendd, rw_tendd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ru, rv, rw
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rud, rvd, &
&  rwd
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
&  msfvy, msftx, msfty
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: f, e, sina, cosa
  REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
! Local indices.
  INTEGER :: i, j, k, ktf
  INTEGER :: i_start, i_end, j_start, j_end
  LOGICAL :: specified
  INTEGER :: min4
  INTEGER :: min3
  INTEGER :: min2
  INTEGER :: min1
!<DESCRIPTION>
!
!  coriolis calculates the large timestep tendency terms in the 
!  u, v, and w momentum equations arise from the coriolis force.
!
!</DESCRIPTION>
  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
! coriolis for u-momentum equation
!  Notes on map scale factor
!  cosa, sina are related to rotating the coordinate frame if desired
!  generally sina=0, cosa=1
!  ADT eqn 44, RHS terms 6 and 7: -2 mu w omega cos(lat)/my
!                                + 2 mu v omega sin(lat)/my
!  Define f=2 omega sin(lat), e=2 omega cos(lat)
!   => terms are: -e mu w / my + f mu v / my
!  rv = mu v / mx ; rw = mu w / my
!   => terms are: -e rw + f rv *mx / my
  i_start = its
  i_end = ite
  IF ((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
&  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) .OR. config_flags%nested) &
&  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
  IF (jte .GT. jde - 1) THEN
    min1 = jde - 1
  ELSE
    min1 = jte
  END IF
  DO j=jts,min1
    DO k=kts,ktf
      DO i=i_start,i_end
        ru_tendd(i, k, j) = ru_tendd(i, k, j) + msfux(i, j)*0.5*(f(i, j)&
&          +f(i-1, j))*0.25*(rvd(i-1, k, j+1)+rvd(i, k, j+1)+rvd(i-1, k, &
&          j)+rvd(i, k, j))/msfuy(i, j) - 0.5**2*(e(i, j)+e(i-1, j))*(&
&          cosa(i, j)+cosa(i-1, j))*0.25*(rwd(i-1, k+1, j)+rwd(i-1, k, j)&
&          +rwd(i, k+1, j)+rwd(i, k, j))
        ru_tend(i, k, j) = ru_tend(i, k, j) + msfux(i, j)/msfuy(i, j)*&
&          0.5*(f(i, j)+f(i-1, j))*0.25*(rv(i-1, k, j+1)+rv(i, k, j+1)+rv&
&          (i-1, k, j)+rv(i, k, j)) - 0.5*(e(i, j)+e(i-1, j))*0.5*(cosa(i&
&          , j)+cosa(i-1, j))*0.25*(rw(i-1, k+1, j)+rw(i-1, k, j)+rw(i, k&
&          +1, j)+rw(i, k, j))
      END DO
    END DO
  END DO
! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
!  IF ( (config_flags%open_xs) .and. (its == ids) ) THEN
!    DO k=kts,ktf
!  
!      ru_tend(its,k,j)=ru_tend(its,k,j) + (msfux(its,j)/msfuy(its,j))*0.5*(f(its,j)+f(its,j))   &
!        *0.25*(rv(its,k,j+1)+rv(its,k,j+1)+rv(its,k,j)+rv(its,k,j)) &
!            - 0.5*(e(its,j)+e(its,j))*0.5*(cosa(its,j)+cosa(its,j)) &
!        *0.25*(rw(its,k+1,j)+rw(its,k,j)+rw(its,k+1,j)+rw(its,k,j))
!    ENDDO
!  ENDIF
!  IF ( (config_flags%open_xe) .and. (ite == ide) ) THEN
!    DO k=kts,ktf
!  
!      ru_tend(ite,k,j)=ru_tend(ite,k,j) + (msfux(ite,j)/msfuy(ite,j))*0.5*(f(ite-1,j)+f(ite-1,j)) &
!        *0.25*(rv(ite-1,k,j+1)+rv(ite-1,k,j+1)+rv(ite-1,k,j)+rv(ite-1,k,j)) &
!            - 0.5*(e(ite-1,j)+e(ite-1,j))*0.5*(cosa(ite-1,j)+cosa(ite-1,j)) &
!        *0.25*(rw(ite-1,k+1,j)+rw(ite-1,k,j)+rw(ite-1,k+1,j)+rw(ite-1,k,j))
!    ENDDO
!  ENDIF
!  coriolis term for v-momentum equation
!  Notes on map scale factors
!  ADT eqn 45, RHS terms 6 and 6b [0 for sina=0]: -2 mu u omega sin(lat)/mx + ?
!  Define f=2 omega sin(lat), e=2 omega cos(lat)
!   => terms are: -f mu u / mx
!  ru = mu u / my ; rw = mu w / my
!   => terms are: -f ru *my / mx + ?
  j_start = jts
  j_end = jte
  IF (((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
&      .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%nested) &
&      .OR. config_flags%polar) THEN
    IF (jde - 1 .GT. jte) THEN
      j_end = jte
    ELSE
      j_end = jde - 1
    END IF
  END IF
! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
!  IF ( (config_flags%open_ys) .and. (jts == jds) ) THEN
!    DO k=kts,ktf
!    DO i=its,MIN(ide-1,ite)
!  
!       rv_tend(i,k,jts)=rv_tend(i,k,jts) - (msfvy(i,jts)/msfvx(i,jts))*0.5*(f(i,jts)+f(i,jts))    &
!        *0.25*(ru(i,k,jts)+ru(i+1,k,jts)+ru(i,k,jts)+ru(i+1,k,jts))   &
!            + (msfvy(i,jts)/msfvx(i,jts))*0.5*(e(i,jts)+e(i,jts))*0.5*(sina(i,jts)+sina(i,jts))   &
!            *0.25*(rw(i,k+1,jts)+rw(i,k,jts)+rw(i,k+1,jts)+rw(i,k,jts)) 
!    ENDDO
!    ENDDO
!  ENDIF
  DO j=j_start,j_end
    DO k=kts,ktf
      IF (ide - 1 .GT. ite) THEN
        min2 = ite
      ELSE
        min2 = ide - 1
      END IF
      DO i=its,min2
        rv_tendd(i, k, j) = rv_tendd(i, k, j) - msfvy(i, j)*0.5*(f(i, j)&
&          +f(i, j-1))*0.25*(rud(i, k, j)+rud(i+1, k, j)+rud(i, k, j-1)+&
&          rud(i+1, k, j-1))/msfvx(i, j) + msfvy(i, j)*0.5**2*(e(i, j)+e(&
&          i, j-1))*(sina(i, j)+sina(i, j-1))*0.25*(rwd(i, k+1, j-1)+rwd(&
&          i, k, j-1)+rwd(i, k+1, j)+rwd(i, k, j))/msfvx(i, j)
        rv_tend(i, k, j) = rv_tend(i, k, j) - msfvy(i, j)/msfvx(i, j)*&
&          0.5*(f(i, j)+f(i, j-1))*0.25*(ru(i, k, j)+ru(i+1, k, j)+ru(i, &
&          k, j-1)+ru(i+1, k, j-1)) + msfvy(i, j)/msfvx(i, j)*0.5*(e(i, j&
&          )+e(i, j-1))*0.5*(sina(i, j)+sina(i, j-1))*0.25*(rw(i, k+1, j-&
&          1)+rw(i, k, j-1)+rw(i, k+1, j)+rw(i, k, j))
      END DO
    END DO
  END DO
  IF (jte .GT. jde - 1) THEN
    min3 = jde - 1
  ELSE
    min3 = jte
  END IF
! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
!  IF ( (config_flags%open_ye) .and. (jte == jde) ) THEN
!    DO k=kts,ktf
!    DO i=its,MIN(ide-1,ite)
!  
!       rv_tend(i,k,jte)=rv_tend(i,k,jte) - (msfvy(i,jte)/msfvx(i,jte))*0.5*(f(i,jte-1)+f(i,jte-1))        &
!        *0.25*(ru(i,k,jte-1)+ru(i+1,k,jte-1)+ru(i,k,jte-1)+ru(i+1,k,jte-1))   &
!            + (msfvy(i,jte)/msfvx(i,jte))*0.5*(e(i,jte-1)+e(i,jte-1))*0.5*(sina(i,jte-1)+sina(i,jte-1))   &
!            *0.25*(rw(i,k+1,jte-1)+rw(i,k,jte-1)+rw(i,k+1,jte-1)+rw(i,k,jte-1)) 
!    ENDDO
!    ENDDO
!  ENDIF
! coriolis term for w-mometum 
! Notes on map scale factors
! ADT eqn 46/my, RHS terms 5 and 5b [0 for sina=0]: 2 mu u omega cos(lat)/my +?
! Define e=2 omega cos(lat)
!  => terms are: e mu u / my + ???
! ru = mu u / my ; ru = mu v / mx
!  => terms are: e ru + ???
  DO j=jts,min3
    DO k=kts+1,ktf
      IF (ite .GT. ide - 1) THEN
        min4 = ide - 1
      ELSE
        min4 = ite
      END IF
      DO i=its,min4
        rw_tendd(i, k, j) = rw_tendd(i, k, j) + e(i, j)*(cosa(i, j)*0.5*&
&          (fzm(k)*(rud(i, k, j)+rud(i+1, k, j))+fzp(k)*(rud(i, k-1, j)+&
&          rud(i+1, k-1, j)))-msftx(i, j)*sina(i, j)*0.5*(fzm(k)*(rvd(i, &
&          k, j)+rvd(i, k, j+1))+fzp(k)*(rvd(i, k-1, j)+rvd(i, k-1, j+1))&
&          )/msfty(i, j))
        rw_tend(i, k, j) = rw_tend(i, k, j) + e(i, j)*(cosa(i, j)*0.5*(&
&          fzm(k)*(ru(i, k, j)+ru(i+1, k, j))+fzp(k)*(ru(i, k-1, j)+ru(i+&
&          1, k-1, j)))-msftx(i, j)/msfty(i, j)*sina(i, j)*0.5*(fzm(k)*(&
&          rv(i, k, j)+rv(i, k, j+1))+fzp(k)*(rv(i, k-1, j)+rv(i, k-1, j+&
&          1))))
      END DO
    END DO
  END DO
END SUBROUTINE G_CORIOLIS

 SUBROUTINE g_perturbation_coriolis(ru_in,g_ru_in,rv_in,g_rv_in,rw,g_rw, &
 ru_tend,g_ru_tend,rv_tend,g_rv_tend,rw_tend,g_rw_tend,config_flags,u_base, &
 v_base,z_base,muu,g_muu,muv,g_muv,phb,ph,g_ph,msftx,msfty,msfux,msfuy,msfvx, &
 msfvy,f,e,sina,cosa,fzm,fzp,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,Tmpv9,g_Tmpv9
 TYPE(grid_config_rec_type) :: config_flags
 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) :: ru_tend,g_ru_tend,rv_tend,g_rv_tend, &
 rw_tend,g_rw_tend
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru_in,g_ru_in,rv_in,g_rv_in,rw, &
 g_rw,ph,g_ph,phb
 REAL,DIMENSION(ims:ime,jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty
 REAL,DIMENSION(ims:ime,jms:jme) :: f,e,sina,cosa
 REAL,DIMENSION(ims:ime,jms:jme) :: muu,g_muu,muv,g_muv
 REAL,DIMENSION(kms:kme) :: fzm,fzp
 REAL,DIMENSION(kms:kme) :: u_base,v_base,z_base

 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: ru,g_ru,rv,g_rv
 REAL :: z_at_u,g_z_at_u,z_at_v,g_z_at_v,wkp1,g_wkp1,wk,g_wk,wkm1,g_wkm1

 INTEGER :: i,j,k,ktf
 INTEGER :: i_start,i_end,j_start,j_end
 LOGICAL :: specified

 specified =.false.

 if(config_flags%specified .or. config_flags%nested) specified =.true.

 ktf =min(kte,kde-1)

 i_start =its

 i_end =ite

 IF( config_flags%open_xs .or. specified .or.   &
        config_flags%nested) i_start =max(ids+1,its)

 IF( config_flags%open_xe .or. specified .or.   &
        config_flags%nested) i_end =min(ide-1,ite)

 IF( config_flags%periodic_x ) i_start =its

 IF( config_flags%periodic_x ) i_end =ite

 DO j =jts,min(jte,jde-1) +1
 DO k =kts+1,ktf-1
 DO i =i_start-1,i_end

 g_z_at_v =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i,k,j-1) +g_ph(i,k+1,j-1))/g
 z_at_v =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i,k,j-1)+phb(i,k+1,j-1) +ph(i,k,j) &
 +ph(i,k+1,j) +ph(i,k,j-1) +ph(i,k+1,j-1))/g

 g_wkp1 =(0.0 +((0.0 +g_z_at_v +(0.0 -g_z_at_v)*sign(1.0, 0. -(z_at_v - &
 z_base(k))))*0.5/(z_base(k+1)-z_base(k))) -(0.0 -((0.0 +g_z_at_v +(0.0 - &
 g_z_at_v)*sign(1.0, 0. -(z_at_v -z_base(k))))*0.5/(z_base(k+1)-z_base(k)))) &
*sign(1.0, 1. -(max(0.,z_at_v -z_base(k))/(z_base(k+1)-z_base(k)))))*0.5
 wkp1 =min(1.,max(0.,z_at_v -z_base(k))/(z_base(k+1)-z_base(k)))

!REVISED BY WALLS
!g_wkm1 =(0.0 +((0.0 +g_z_at_v +(0.0 +g_z_at_v)*sign(1.0, 0. -(z_base(k) &
! Revised by Ning Pan, 2010-07-24
! g_wkm1 =(0.0 +((0.0 +g_z_at_v +(0.0 +g_z_at_v)*sign(1.0, 0. -(z_base(k) &
! -z_at_v)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 +g_z_at_v +(0.0 + &
! g_z_at_v)*sign(1.0, 0. -(z_base(k) -z_at_v)))*0.5/(z_base(k)-z_base(k-1)))) &
!*sign(1.0,! 1. -(max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))))*0.5
 g_wkm1 =(0.0 +((0.0 -g_z_at_v +(0.0 +g_z_at_v)*sign(1.0, 0. -(z_base(k) &
 -z_at_v)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 -g_z_at_v +(0.0 + &
 g_z_at_v)*sign(1.0, 0. -(z_base(k) -z_at_v)))*0.5/(z_base(k)-z_base(k-1)))) &
*sign(1.0, 1. -(max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))))*0.5
 wkm1 =min(1.,max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))

 g_wk =-g_wkp1 -g_wkm1
 wk =1. -wkp1 -wkm1

 g_Tmpv1 =muv(i,j)*(g_wkm1*v_base(k-1) +g_wk*v_base(k) +g_wkp1*v_base(k+ &
 1)) +g_muv(i,j)*(wkm1*v_base(k-1) +wk*v_base(k) +wkp1*v_base(k+1)) 
 Tmpv1 =muv(i,j)*(wkm1*v_base(k-1) +wk*v_base(k) +wkp1*v_base(k+1))

 g_rv(i,k,j) =g_rv_in(i,k,j) -g_Tmpv1
 rv(i,k,j) =rv_in(i,k,j) -Tmpv1

 ENDDO
 ENDDO
 ENDDO

 DO j =jts,min(jte,jde-1) +1
 DO i =i_start-1,i_end

 k =kts

 g_z_at_v =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i,k,j-1) +g_ph(i,k+1,j-1))/g
 z_at_v =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i,k,j-1)+phb(i,k+1,j-1) +ph(i,k,j) &
 +ph(i,k+1,j) +ph(i,k,j-1) +ph(i,k+1,j-1))/g

 g_wkp1 =(0.0 +((0.0 +g_z_at_v +(0.0 -g_z_at_v)*sign(1.0, 0. -(z_at_v - &
 z_base(k))))*0.5/(z_base(k+1)-z_base(k))) -(0.0 -((0.0 +g_z_at_v +(0.0 - &
 g_z_at_v)*sign(1.0, 0. -(z_at_v -z_base(k))))*0.5/(z_base(k+1)-z_base(k)))) &
*sign(1.0, 1. -(max(0.,z_at_v -z_base(k))/(z_base(k+1)-z_base(k)))))*0.5
 wkp1 =min(1.,max(0.,z_at_v -z_base(k))/(z_base(k+1)-z_base(k)))

 g_wk =-g_wkp1
 wk =1. -wkp1

 g_Tmpv1 =muv(i,j)*(g_wk*v_base(k) +g_wkp1*v_base(k+1)) +g_muv(i,j) &
*(wk*v_base(k) +wkp1*v_base(k+1)) 
 Tmpv1 =muv(i,j)*(wk*v_base(k) +wkp1*v_base(k+1))

 g_rv(i,k,j) =g_rv_in(i,k,j) -g_Tmpv1
 rv(i,k,j) =rv_in(i,k,j) -Tmpv1

 k =ktf

 g_z_at_v =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i,k,j-1) +g_ph(i,k+1,j-1))/g
 z_at_v =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i,k,j-1)+phb(i,k+1,j-1) +ph(i,k,j) &
 +ph(i,k+1,j) +ph(i,k,j-1) +ph(i,k+1,j-1))/g

! Revised by Ning Pan, 2010-07-24
! g_wkm1 =(0.0 +((0.0 +g_z_at_v +(0.0 +g_z_at_v)*sign(1.0, 0. -(z_base(k) &
! -z_at_v)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 +g_z_at_v +(0.0 + &
! g_z_at_v)*sign(1.0, 0. -(z_base(k) -z_at_v)))*0.5/(z_base(k)-z_base(k-1)))) &
!*sign(1.0,! 1. -(max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))))*0.5
 g_wkm1 =(0.0 +((0.0 -g_z_at_v +(0.0 +g_z_at_v)*sign(1.0, 0. -(z_base(k) &
 -z_at_v)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 -g_z_at_v +(0.0 + &
 g_z_at_v)*sign(1.0, 0. -(z_base(k) -z_at_v)))*0.5/(z_base(k)-z_base(k-1)))) &
*sign(1.0, 1. -(max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))))*0.5
 wkm1 =min(1.,max(0.,z_base(k) -z_at_v)/(z_base(k)-z_base(k-1)))

 g_wk =-g_wkm1
 wk =1. -wkm1

 g_Tmpv1 =muv(i,j)*(g_wkm1*v_base(k-1) +g_wk*v_base(k)) +g_muv(i,j) &
*(wkm1*v_base(k-1) +wk*v_base(k)) 
 Tmpv1 =muv(i,j)*(wkm1*v_base(k-1) +wk*v_base(k))

 g_rv(i,k,j) =g_rv_in(i,k,j) -g_Tmpv1
 rv(i,k,j) =rv_in(i,k,j) -Tmpv1

 ENDDO
 ENDDO

 DO j =jts,min(jte,jde-1)
 DO k =kts,ktf
 DO i =i_start,i_end

 g_ru_tend(i,k,j) =g_ru_tend(i,k,j) +(msfux(i,j)/msfuy(i,j)) *0.5 *(f(i,j) &
+f(i-1,j)) *0.25*(g_rv(i-1,k,j+1) +g_rv(i,k,j+1) +g_rv(i-1,k,j) &
 +g_rv(i,k,j)) -0.5 *(e(i,j)+e(i-1,j)) *0.5 *(cosa(i,j)+cosa(i-1,j)) &
 *0.25*(g_rw(i-1,k+1,j) +g_rw(i-1,k,j) +g_rw(i,k+1,j) +g_rw(i,k,j))
 ru_tend(i,k,j) =ru_tend(i,k,j) +(msfux(i,j)/msfuy(i,j)) *0.5 *(f(i,j)+f(i-1,j)) &
 *0.25*(rv(i-1,k,j+1) +rv(i,k,j+1) +rv(i-1,k,j) +rv(i,k,j)) -0.5 *(e(i,j)+e(i-1,j)) &
 *0.5 *(cosa(i,j)+cosa(i-1,j)) *0.25*(rw(i-1,k+1,j) +rw(i-1,k,j) +rw(i,k+1,j) +rw(i,k,j))

 ENDDO
 ENDDO

! boundary loops for perturbation coriolis is needed for open bdy  (20110307 XZ)
 IF( (config_flags%open_xs) .and. (its == ids) ) THEN

 DO k =kts,ktf

 g_ru_tend(its,k,j) =g_ru_tend(its,k,j) +(msfux(its,j)/msfuy(its,j)) &
 *0.5 *(f(its,j)+f(its,j)) *0.25*(g_rv(its,k,j+1) +g_rv(its,k,j+1) &
 +g_rv(its,k,j) +g_rv(its,k,j)) -0.5 *(e(its,j)+e(its,j)) *0.5 *(cosa(its,j) &
+cosa(its,j)) *0.25*(g_rw(its,k+1,j) +g_rw(its,k,j) +g_rw(its,k+1,j) &
 +g_rw(its,k,j))
 ru_tend(its,k,j) =ru_tend(its,k,j) +(msfux(its,j)/msfuy(its,j)) *0.5 *(f(its,j) &
+f(its,j)) *0.25*(rv(its,k,j+1) +rv(its,k,j+1) +rv(its,k,j) +rv(its,k,j)) &
 -0.5 *(e(its,j)+e(its,j)) *0.5 *(cosa(its,j)+cosa(its,j)) *0.25*(rw(its,k+1,j) &
 +rw(its,k,j) +rw(its,k+1,j) +rw(its,k,j))

 ENDDO
 ENDIF

 IF( (config_flags%open_xe) .and. (ite == ide) ) THEN

 DO k =kts,ktf

 g_ru_tend(ite,k,j) =g_ru_tend(ite,k,j) +(msfux(ite,j)/msfuy(ite,j)) &
 *0.5 *(f(ite-1,j)+f(ite-1,j)) *0.25*(g_rv(ite-1,k,j+1) +g_rv(ite-1,k,j+1) &
 +g_rv(ite-1,k,j) +g_rv(ite-1,k,j)) -0.5 *(e(ite-1,j)+e(ite-1,j)) &
 *0.5 *(cosa(ite-1,j)+cosa(ite-1,j)) *0.25*(g_rw(ite-1,k+1,j) +g_rw(ite-1,k,j) &
 +g_rw(ite-1,k+1,j) +g_rw(ite-1,k,j))
 ru_tend(ite,k,j) =ru_tend(ite,k,j) +(msfux(ite,j)/msfuy(ite,j)) *0.5 *(f(ite-1,j) &
+f(ite-1,j)) *0.25*(rv(ite-1,k,j+1) +rv(ite-1,k,j+1) +rv(ite-1,k,j) +rv(ite-1,k,j)) &
 -0.5 *(e(ite-1,j)+e(ite-1,j)) *0.5 *(cosa(ite-1,j)+cosa(ite-1,j)) *0.25*(rw(ite-1,k+ &
 1,j) +rw(ite-1,k,j) +rw(ite-1,k+1,j) +rw(ite-1,k,j))

 ENDDO
 ENDIF

 ENDDO

 j_start =jts

 j_end =jte

 IF( config_flags%open_ys .or. specified .or.   &
        config_flags%nested .or. config_flags%polar) j_start =max(jds+1,jts)

 IF( config_flags%open_ye .or. specified .or.   &
        config_flags%nested .or. config_flags%polar) j_end =min(jde-1,jte)

 DO j =j_start-1,j_end
 DO k =kts+1,ktf-1
 DO i =its,min(ite,ide-1) +1

 g_z_at_u =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i-1,k,j) +g_ph(i-1,k+1,j))/g
 z_at_u =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i-1,k,j)+phb(i-1,k+1,j) +ph(i,k,j) &
 +ph(i,k+1,j) +ph(i-1,k,j) +ph(i-1,k+1,j))/g

 g_wkp1 =(0.0 +((0.0 +g_z_at_u +(0.0 -g_z_at_u)*sign(1.0, 0. -(z_at_u - &
 z_base(k))))*0.5/(z_base(k+1)-z_base(k))) -(0.0 -((0.0 +g_z_at_u +(0.0 - &
 g_z_at_u)*sign(1.0, 0. -(z_at_u -z_base(k))))*0.5/(z_base(k+1)-z_base(k)))) &
*sign(1.0, 1. -(max(0.,z_at_u -z_base(k))/(z_base(k+1)-z_base(k)))))*0.5
 wkp1 =min(1.,max(0.,z_at_u -z_base(k))/(z_base(k+1)-z_base(k)))

! Revised by Ning Pan, 2010-07-24
! g_wkm1 =(0.0 +((0.0 +g_z_at_u +(0.0 +g_z_at_u)*sign(1.0, 0. -(z_base(k) &
! -z_at_u)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 +g_z_at_u +(0.0 + &
! g_z_at_u)*sign(1.0, 0. -(z_base(k) -z_at_u)))*0.5/(z_base(k)-z_base(k-1)))) &
!*sign(1.0,! 1. -(max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))))*0.5
 g_wkm1 =(0.0 +((0.0 -g_z_at_u +(0.0 +g_z_at_u)*sign(1.0, 0. -(z_base(k) &
 -z_at_u)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 -g_z_at_u +(0.0 + &
 g_z_at_u)*sign(1.0, 0. -(z_base(k) -z_at_u)))*0.5/(z_base(k)-z_base(k-1)))) &
*sign(1.0, 1. -(max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))))*0.5
 wkm1 =min(1.,max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))

 g_wk =-g_wkp1 -g_wkm1
 wk =1. -wkp1 -wkm1

 g_Tmpv1 =muu(i,j)*(g_wkm1*u_base(k-1) +g_wk*u_base(k) +g_wkp1*u_base(k+ &
 1)) +g_muu(i,j)*(wkm1*u_base(k-1) +wk*u_base(k) +wkp1*u_base(k+1)) 
 Tmpv1 =muu(i,j)*(wkm1*u_base(k-1) +wk*u_base(k) +wkp1*u_base(k+1))

 g_ru(i,k,j) =g_ru_in(i,k,j) -g_Tmpv1
 ru(i,k,j) =ru_in(i,k,j) -Tmpv1

 ENDDO
 ENDDO
 ENDDO

 DO j =j_start-1,j_end
 DO i =its,min(ite,ide-1) +1

 k =kts

 g_z_at_u =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i-1,k,j) +g_ph(i-1,k+1,j))/g
 z_at_u =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i-1,k,j)+phb(i-1,k+1,j) +ph(i,k,j) &
 +ph(i,k+1,j) +ph(i-1,k,j) +ph(i-1,k+1,j))/g

 g_wkp1 =(0.0 +((0.0 +g_z_at_u +(0.0 -g_z_at_u)*sign(1.0, 0. -(z_at_u - &
 z_base(k))))*0.5/(z_base(k+1)-z_base(k))) -(0.0 -((0.0 +g_z_at_u +(0.0 - &
 g_z_at_u)*sign(1.0, 0. -(z_at_u -z_base(k))))*0.5/(z_base(k+1)-z_base(k)))) &
*sign(1.0, 1. -(max(0.,z_at_u -z_base(k))/(z_base(k+1)-z_base(k)))))*0.5
 wkp1 =min(1.,max(0.,z_at_u -z_base(k))/(z_base(k+1)-z_base(k)))

 g_wk =-g_wkp1
 wk =1. -wkp1

 g_Tmpv1 =muu(i,j)*(g_wk*u_base(k) +g_wkp1*u_base(k+1)) +g_muu(i,j) &
*(wk*u_base(k) +wkp1*u_base(k+1)) 
 Tmpv1 =muu(i,j)*(wk*u_base(k) +wkp1*u_base(k+1))

 g_ru(i,k,j) =g_ru_in(i,k,j) -g_Tmpv1
 ru(i,k,j) =ru_in(i,k,j) -Tmpv1

 k =ktf

 g_z_at_u =0.25*(g_ph(i,k,j) +g_ph(i,k+1,j) +g_ph(i-1,k,j) +g_ph(i-1,k+1,j))/g
 z_at_u =0.25*(phb(i,k,j)+phb(i,k+1,j)+phb(i-1,k,j)+phb(i-1,k+1,j) +ph(i,k,j) &
 +ph(i,k+1,j) +ph(i-1,k,j) +ph(i-1,k+1,j))/g

! Revised by Ning Pan, 2010-07-24
! g_wkm1 =(0.0 +((0.0 +g_z_at_u +(0.0 +g_z_at_u)*sign(1.0, 0. -(z_base(k) &
! -z_at_u)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 +g_z_at_u +(0.0 + &
! g_z_at_u)*sign(1.0, 0. -(z_base(k) -z_at_u)))*0.5/(z_base(k)-z_base(k-1)))) &
!*sign(1.0,! 1. -(max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))))*0.5
 g_wkm1 =(0.0 +((0.0 -g_z_at_u +(0.0 +g_z_at_u)*sign(1.0, 0. -(z_base(k) &
 -z_at_u)))*0.5/(z_base(k)-z_base(k-1))) -(0.0 -((0.0 -g_z_at_u +(0.0 + &
 g_z_at_u)*sign(1.0, 0. -(z_base(k) -z_at_u)))*0.5/(z_base(k)-z_base(k-1)))) &
*sign(1.0, 1. -(max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))))*0.5
 wkm1 =min(1.,max(0.,z_base(k) -z_at_u)/(z_base(k)-z_base(k-1)))

 g_wk =-g_wkm1
 wk =1. -wkm1

 g_Tmpv1 =muu(i,j)*(g_wkm1*u_base(k-1) +g_wk*u_base(k)) +g_muu(i,j) &
*(wkm1*u_base(k-1) +wk*u_base(k)) 
 Tmpv1 =muu(i,j)*(wkm1*u_base(k-1) +wk*u_base(k))

 g_ru(i,k,j) =g_ru_in(i,k,j) -g_Tmpv1
 ru(i,k,j) =ru_in(i,k,j) -Tmpv1

 ENDDO
 ENDDO

! boundary loops for perturbation coriolis is needed for open bdy  (20110301 XZ)
 IF( (config_flags%open_ys) .and. (jts == jds) ) THEN

 DO k =kts,ktf
 DO i =its,min(ide-1,ite)

 g_rv_tend(i,k,jts) =g_rv_tend(i,k,jts) -(msfvy(i,jts)/msfvx(i,jts)) &
 *0.5 *(f(i,jts)+f(i,jts)) *0.25*(g_ru(i,k,jts) +g_ru(i+1,k,jts) +g_ru(i,k, &
 jts) +g_ru(i+1,k,jts)) +(msfvy(i,jts)/msfvx(i,jts)) *0.5 *(e(i,jts)+e(i,jts)) &
 *0.5 *(sina(i,jts)+sina(i,jts)) *0.25*(g_rw(i,k+1,jts) +g_rw(i,k,jts) &
 +g_rw(i,k+1,jts) +g_rw(i,k,jts))
 rv_tend(i,k,jts) =rv_tend(i,k,jts) -(msfvy(i,jts)/msfvx(i,jts)) *0.5 *(f(i,jts) &
+f(i,jts)) *0.25*(ru(i,k,jts) +ru(i+1,k,jts) +ru(i,k,jts) +ru(i+1,k,jts)) &
 +(msfvy(i,jts)/msfvx(i,jts)) *0.5 *(e(i,jts)+e(i,jts)) *0.5 *(sina(i,jts) &
+sina(i,jts)) *0.25*(rw(i,k+1,jts) +rw(i,k,jts) +rw(i,k+1,jts) +rw(i,k,jts))

 ENDDO
 ENDDO
 ENDIF

 DO j =j_start,j_end
 DO k =kts,ktf
 DO i =its,min(ide-1,ite)

 g_rv_tend(i,k,j) =g_rv_tend(i,k,j) -(msfvy(i,j)/msfvx(i,j)) *0.5 *(f(i,j) &
+f(i,j-1)) *0.25*(g_ru(i,k,j) +g_ru(i+1,k,j) +g_ru(i,k,j-1) +g_ru(i+1,k, &
 j-1)) +(msfvy(i,j)/msfvx(i,j)) *0.5 *(e(i,j)+e(i,j-1)) *0.5 *(sina(i,j)+sina(i,j-1)) &
 *0.25*(g_rw(i,k+1,j-1) +g_rw(i,k,j-1) +g_rw(i,k+1,j) +g_rw(i,k,j))
 rv_tend(i,k,j) =rv_tend(i,k,j) -(msfvy(i,j)/msfvx(i,j)) *0.5 *(f(i,j)+f(i,j-1)) &
 *0.25*(ru(i,k,j) +ru(i+1,k,j) +ru(i,k,j-1) +ru(i+1,k,j-1)) +(msfvy(i,j)/msfvx(i,j)) &
 *0.5 *(e(i,j)+e(i,j-1)) *0.5 *(sina(i,j)+sina(i,j-1)) *0.25*(rw(i,k+1,j-1) &
 +rw(i,k,j-1) +rw(i,k+1,j) +rw(i,k,j))

 ENDDO
 ENDDO
 ENDDO

! boundary loops for perturbation coriolis is needed for open bdy  (20110307 XZ)
 IF( (config_flags%open_ye) .and. (jte == jde) ) THEN

 DO k =kts,ktf
 DO i =its,min(ide-1,ite)

 g_rv_tend(i,k,jte) =g_rv_tend(i,k,jte) -(msfvy(i,jte)/msfvx(i,jte)) &
 *0.5 *(f(i,jte-1)+f(i,jte-1)) *0.25*(g_ru(i,k,jte-1) +g_ru(i+1,k,jte-1) &
 +g_ru(i,k,jte-1) +g_ru(i+1,k,jte-1)) +(msfvy(i,jte)/msfvx(i,jte)) &
 *0.5 *(e(i,jte-1)+e(i,jte-1)) *0.5 *(sina(i,jte-1)+sina(i,jte-1)) *0.25*(g_rw(i, &
 k+1,jte-1) +g_rw(i,k,jte-1) +g_rw(i,k+1,jte-1) +g_rw(i,k,jte-1))
 rv_tend(i,k,jte) =rv_tend(i,k,jte) -(msfvy(i,jte)/msfvx(i,jte)) *0.5 *(f(i,jte-1) &
+f(i,jte-1)) *0.25*(ru(i,k,jte-1) +ru(i+1,k,jte-1) +ru(i,k,jte-1) +ru(i+1,k,jte-1)) &
 +(msfvy(i,jte)/msfvx(i,jte)) *0.5 *(e(i,jte-1)+e(i,jte-1)) *0.5 *(sina(i,jte-1) &
+sina(i,jte-1)) *0.25*(rw(i,k+1,jte-1) +rw(i,k,jte-1) +rw(i,k+1,jte-1) +rw(i,k,jte-1))

 ENDDO
 ENDDO
 ENDIF

 DO j =jts,min(jte,jde-1)
 DO k =kts+1,ktf
 DO i =its,min(ite,ide-1)

 g_rw_tend(i,k,j) =g_rw_tend(i,k,j) +e(i,j)*(cosa(i,j) *0.5*(fzm(k) &
*(g_ru(i,k,j) +g_ru(i+1,k,j)) +fzp(k)*(g_ru(i,k-1,j) +g_ru(i+1,k-1,j))) &
 -(msftx(i,j)/msfty(i,j)) *sina(i,j) *0.5*(fzm(k)*(g_rv(i,k,j) +g_rv(i,k,j+1)) &
 +fzp(k)*(g_rv(i,k-1,j) +g_rv(i,k-1,j+1))))
 rw_tend(i,k,j) =rw_tend(i,k,j) +e(i,j)*(cosa(i,j) *0.5*(fzm(k)*(ru(i,k,j) &
 +ru(i+1,k,j)) +fzp(k)*(ru(i,k-1,j) +ru(i+1,k-1,j))) -(msftx(i,j)/msfty(i,j)) &
 *sina(i,j) *0.5*(fzm(k)*(rv(i,k,j) +rv(i,k,j+1)) +fzp(k)*(rv(i,k-1,j) +rv(i,k-1,j+1))))

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_perturbation_coriolis

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
!  Differentiation of curvature in forward (tangent) mode:
!   variations   of useful results: ru_tend rw_tend rv_tend
!   with respect to varying inputs: u v ru_tend rw_tend ru rv rw
!                rv_tend
!   RW status of diff variables: u:in v:in ru_tend:in-out rw_tend:in-out
!                ru:in rv:in rw:in rv_tend:in-out
SUBROUTINE G_CURVATURE(ru, rud, rv, rvd, rw, rwd, u, ud, v, vd, w, &
&  ru_tend, ru_tendd, rv_tend, rv_tendd, rw_tend, rw_tendd, config_flags&
&  , msfux, msfuy, msfvx, msfvy, msftx, msfty, xlat, fzm, fzp, rdx, rdy, &
&  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(INOUT) :: ru_tend, &
&  rv_tend, rw_tend
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: ru_tendd&
&  , rv_tendd, rw_tendd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ru, rv, rw, &
&  u, v, w
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: rud, rvd, &
&  rwd, ud, vd
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: msfux, msfuy, msfvx, &
&  msfvy, msftx, msfty, xlat
  REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
  REAL, INTENT(IN) :: rdx, rdy
! Local data
!   INTEGER :: i, j, k, itf, jtf, ktf, kp1, im, ip, jm, jp
  INTEGER :: i, j, k, itf, jtf, ktf
  INTEGER :: i_start, i_end, j_start, j_end
!   INTEGER :: irmin, irmax, jrmin, jrmax
  REAL, DIMENSION(its - 1:ite, kts:kte, jts - 1:jte) :: vxgm
  REAL, DIMENSION(its-1:ite, kts:kte, jts-1:jte) :: vxgmd
  LOGICAL :: specified
  REAL :: arg1
  INTEGER :: min6
  INTEGER :: min5
  INTEGER :: min4
  INTEGER :: min3
  INTEGER :: min2
  INTEGER :: min1
  INTEGER :: max1
!<DESCRIPTION>
!
!  curvature calculates the large timestep tendency terms in the 
!  u, v, and w momentum equations arise from the curvature terms.  
!
!</DESCRIPTION>
  specified = .false.
  IF (config_flags%specified .OR. config_flags%nested) specified = &
&      .true.
  IF (ite .GT. ide - 1) THEN
    itf = ide - 1
  ELSE
    itf = ite
  END IF
  IF (jte .GT. jde - 1) THEN
    jtf = jde - 1
  ELSE
    jtf = jte
  END IF
  IF (kte .GT. kde - 1) THEN
    ktf = kde - 1
  ELSE
    ktf = kte
  END IF
!   irmin = ims
!   irmax = ime
!   jrmin = jms
!   jrmax = jme
!   IF ( config_flags%open_xs ) irmin = ids
!   IF ( config_flags%open_xe ) irmax = ide-1
!   IF ( config_flags%open_ys ) jrmin = jds
!   IF ( config_flags%open_ye ) jrmax = jde-1
! Define v cross grad m at scalar points - vxgm(i,j)
  i_start = its - 1
  i_end = ite
  j_start = jts - 1
  j_end = jte
  IF (((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
&      .AND. its .EQ. ids) i_start = its
  IF (((config_flags%open_xe .OR. specified) .OR. config_flags%nested) &
&      .AND. ite .EQ. ide) i_end = ite - 1
  IF ((((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
&      .OR. config_flags%polar) .AND. jts .EQ. jds) j_start = jts
  IF ((((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
&      .OR. config_flags%polar) .AND. jte .EQ. jde) j_end = jte - 1
  IF (config_flags%periodic_x) i_start = its - 1
  IF (config_flags%periodic_x) THEN
    i_end = ite
    vxgmd = 0.0
  ELSE
    vxgmd = 0.0
  END IF
  DO j=j_start,j_end
    DO k=kts,ktf
      DO i=i_start,i_end
!     Map scale factor notes:
!     msf...y is constant everywhere for cylindrical map projection
!     msf...x varies with y only
!     But we know that this is not = 0 for cylindrical,
!     therefore use msfvX in 1st line
!     which => by symmetry use msfuY in 2nd line - ???  
        vxgmd(i, k, j) = 0.5*(msfvx(i, j+1)-msfvx(i, j))*rdy*(ud(i, k, j&
&          )+ud(i+1, k, j)) - 0.5*(msfuy(i+1, j)-msfuy(i, j))*rdx*(vd(i, &
&          k, j)+vd(i, k, j+1))
        vxgm(i, k, j) = 0.5*(u(i, k, j)+u(i+1, k, j))*(msfvx(i, j+1)-&
&          msfvx(i, j))*rdy - 0.5*(v(i, k, j)+v(i, k, j+1))*(msfuy(i+1, j&
&          )-msfuy(i, j))*rdx
      END DO
    END DO
  END DO
!  Pick up the boundary rows for open (radiation) lateral b.c.
!  Rather crude at present, we are assuming there is no
!    variation in this term at the boundary.
  IF (((config_flags%open_xs .OR. (specified .AND. (.NOT.config_flags%&
&      periodic_x))) .OR. config_flags%nested) .AND. its .EQ. ids) THEN
    DO j=jts,jte-1
      DO k=kts,ktf
        vxgmd(its-1, k, j) = vxgmd(its, k, j)
        vxgm(its-1, k, j) = vxgm(its, k, j)
      END DO
    END DO
  END IF
  IF (((config_flags%open_xe .OR. (specified .AND. (.NOT.config_flags%&
&      periodic_x))) .OR. config_flags%nested) .AND. ite .EQ. ide) THEN
    DO j=jts,jte-1
      DO k=kts,ktf
        vxgmd(ite, k, j) = vxgmd(ite-1, k, j)
        vxgm(ite, k, j) = vxgm(ite-1, k, j)
      END DO
    END DO
  END IF
!  Polar boundary condition:
!  The following change is needed in case one tries using the vxgm route with
!  polar B.C.'s in the future, but not needed if 'tan' used
  IF ((((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
&      .OR. config_flags%polar) .AND. jts .EQ. jds) THEN
    DO k=kts,ktf
      DO i=its-1,ite
        vxgmd(i, k, jts-1) = vxgmd(i, k, jts)
        vxgm(i, k, jts-1) = vxgm(i, k, jts)
      END DO
    END DO
  END IF
!  Polar boundary condition:
!  The following change is needed in case one tries using the vxgm route with
!  polar B.C.'s in the future, but not needed if 'tan' used
  IF ((((config_flags%open_ye .OR. specified) .OR. config_flags%nested) &
&      .OR. config_flags%polar) .AND. jte .EQ. jde) THEN
    DO k=kts,ktf
      DO i=its-1,ite
        vxgmd(i, k, jte) = vxgmd(i, k, jte-1)
        vxgm(i, k, jte) = vxgm(i, k, jte-1)
      END DO
    END DO
  END IF
!  curvature term for u momentum eqn.
!  Map scale factor notes:
!  ADT eqn 44, RHS terms 4 and 5, in cylindrical: mu u v tan(lat)/(a my)
!                                               - mu u w /(a my)
!  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
!   => terms are:
!  (mx/my)*u rv tan(lat) / a - u rw / a = (u/a)*[(mx/my) rv tan(lat) - rw]
!  ru v tan(lat) / a - u rw / a
!  xlat defined with end points half grid space from pole,
!  hence are on u latitude points
  i_start = its
  IF ((config_flags%open_xs .OR. specified) .OR. config_flags%nested) &
&  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) .OR. config_flags%nested) &
&  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
!  Polar boundary condition
  IF (config_flags%map_proj .EQ. 6 .OR. config_flags%polar) THEN
    IF (jde - 1 .GT. jte) THEN
      min1 = jte
    ELSE
      min1 = jde - 1
    END IF
    DO j=jts,min1
      DO k=kts,ktf
        DO i=i_start,i_end
          ru_tendd(i, k, j) = ru_tendd(i, k, j) + reradius*(ud(i, k, j)*&
&            (msfux(i, j)/msfuy(i, j)*0.25*(rv(i-1, k, j+1)+rv(i, k, j+1)&
&            +rv(i-1, k, j)+rv(i, k, j))*TAN(xlat(i, j)*degrad)-0.25*(rw(&
&            i-1, k+1, j)+rw(i-1, k, j)+rw(i, k+1, j)+rw(i, k, j)))+u(i, &
&            k, j)*(msfux(i, j)*0.25*TAN(xlat(i, j)*degrad)*(rvd(i-1, k, &
&            j+1)+rvd(i, k, j+1)+rvd(i-1, k, j)+rvd(i, k, j))/msfuy(i, j)&
&            -0.25*(rwd(i-1, k+1, j)+rwd(i-1, k, j)+rwd(i, k+1, j)+rwd(i&
&            , k, j))))
          ru_tend(i, k, j) = ru_tend(i, k, j) + u(i, k, j)*reradius*(&
&            msfux(i, j)/msfuy(i, j)*0.25*(rv(i-1, k, j+1)+rv(i, k, j+1)+&
&            rv(i-1, k, j)+rv(i, k, j))*TAN(xlat(i, j)*degrad)-0.25*(rw(i&
&            -1, k+1, j)+rw(i-1, k, j)+rw(i, k+1, j)+rw(i, k, j)))
        END DO
      END DO
    END DO
  ELSE
    IF (jde - 1 .GT. jte) THEN
      min2 = jte
    ELSE
      min2 = jde - 1
    END IF
! normal code
    DO j=jts,min2
      DO k=kts,ktf
        DO i=i_start,i_end
          ru_tendd(i, k, j) = ru_tendd(i, k, j) + 0.5*0.25*((vxgmd(i, k&
&            , j)+vxgmd(i-1, k, j))*(rv(i-1, k, j+1)+rv(i, k, j+1)+rv(i-1&
&            , k, j)+rv(i, k, j))+(vxgm(i, k, j)+vxgm(i-1, k, j))*(rvd(i-&
&            1, k, j+1)+rvd(i, k, j+1)+rvd(i-1, k, j)+rvd(i, k, j))) - &
&            reradius*0.25*(ud(i, k, j)*(rw(i-1, k+1, j)+rw(i-1, k, j)+rw&
&            (i, k+1, j)+rw(i, k, j))+u(i, k, j)*(rwd(i-1, k+1, j)+rwd(i-&
&            1, k, j)+rwd(i, k+1, j)+rwd(i, k, j)))
          ru_tend(i, k, j) = ru_tend(i, k, j) + 0.5*(vxgm(i, k, j)+vxgm(&
&            i-1, k, j))*0.25*(rv(i-1, k, j+1)+rv(i, k, j+1)+rv(i-1, k, j&
&            )+rv(i, k, j)) - u(i, k, j)*reradius*0.25*(rw(i-1, k+1, j)+&
&            rw(i-1, k, j)+rw(i, k+1, j)+rw(i, k, j))
        END DO
      END DO
    END DO
  END IF
!  curvature term for v momentum eqn.
!  Map scale factor notes
!  ADT eqn 45, RHS terms 4 and 5, in cylindrical:  - mu u*u tan(lat)/(a mx)
!                                               - mu v w /(a mx)
!  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
!  terms are:
!  - (my/mx)*u ru tan(lat) / a - (my/mx)*v rw / a 
!  = - [my/(mx*a)]*[u ru tan(lat) + v rw]
!  - (1/a)*[(my/mx)*u ru tan(lat) + w rv]
!  xlat defined with end points half grid space from pole, hence are on
!  u latitude points => av here
!
!  in original wrf, there was a sign error for the rw contribution
  j_start = jts
  IF (((config_flags%open_ys .OR. specified) .OR. config_flags%nested) &
&      .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%nested) &
&      .OR. config_flags%polar) THEN
    IF (jde - 1 .GT. jte) THEN
      j_end = jte
    ELSE
      j_end = jde - 1
    END IF
  END IF
  IF (config_flags%map_proj .EQ. 6 .OR. config_flags%polar) THEN
    DO j=j_start,j_end
      DO k=kts,ktf
        IF (ite .GT. ide - 1) THEN
          min3 = ide - 1
        ELSE
          min3 = ite
        END IF
        DO i=its,min3
          arg1 = (xlat(i, j)+xlat(i, j-1))*0.5*degrad
          rv_tendd(i, k, j) = rv_tendd(i, k, j) - msfvy(i, j)*reradius*(&
&            0.25**2*TAN(arg1)*((ud(i, k, j)+ud(i+1, k, j)+ud(i, k, j-1)+&
&            ud(i+1, k, j-1))*(ru(i, k, j)+ru(i+1, k, j)+ru(i, k, j-1)+ru&
&            (i+1, k, j-1))+(u(i, k, j)+u(i+1, k, j)+u(i, k, j-1)+u(i+1, &
&            k, j-1))*(rud(i, k, j)+rud(i+1, k, j)+rud(i, k, j-1)+rud(i+1&
&            , k, j-1)))+0.25*(vd(i, k, j)*(rw(i, k+1, j-1)+rw(i, k, j-1)&
&            +rw(i, k+1, j)+rw(i, k, j))+v(i, k, j)*(rwd(i, k+1, j-1)+rwd&
&            (i, k, j-1)+rwd(i, k+1, j)+rwd(i, k, j))))/msfvx(i, j)
          rv_tend(i, k, j) = rv_tend(i, k, j) - msfvy(i, j)/msfvx(i, j)*&
&            reradius*(0.25*(u(i, k, j)+u(i+1, k, j)+u(i, k, j-1)+u(i+1, &
&            k, j-1))*TAN(arg1)*0.25*(ru(i, k, j)+ru(i+1, k, j)+ru(i, k, &
&            j-1)+ru(i+1, k, j-1))+v(i, k, j)*0.25*(rw(i, k+1, j-1)+rw(i&
&            , k, j-1)+rw(i, k+1, j)+rw(i, k, j)))
        END DO
      END DO
    END DO
  ELSE
! normal code
    DO j=j_start,j_end
      DO k=kts,ktf
        IF (ite .GT. ide - 1) THEN
          min4 = ide - 1
        ELSE
          min4 = ite
        END IF
        DO i=its,min4
          rv_tendd(i, k, j) = rv_tendd(i, k, j) - 0.5*0.25*((vxgmd(i, k&
&            , j)+vxgmd(i, k, j-1))*(ru(i, k, j)+ru(i+1, k, j)+ru(i, k, j&
&            -1)+ru(i+1, k, j-1))+(vxgm(i, k, j)+vxgm(i, k, j-1))*(rud(i&
&            , k, j)+rud(i+1, k, j)+rud(i, k, j-1)+rud(i+1, k, j-1))) - &
&            msfvy(i, j)*reradius*0.25*(vd(i, k, j)*(rw(i, k+1, j-1)+rw(i&
&            , k, j-1)+rw(i, k+1, j)+rw(i, k, j))+v(i, k, j)*(rwd(i, k+1&
&            , j-1)+rwd(i, k, j-1)+rwd(i, k+1, j)+rwd(i, k, j)))/msfvx(i&
&            , j)
          rv_tend(i, k, j) = rv_tend(i, k, j) - 0.5*(vxgm(i, k, j)+vxgm(&
&            i, k, j-1))*0.25*(ru(i, k, j)+ru(i+1, k, j)+ru(i, k, j-1)+ru&
&            (i+1, k, j-1)) - msfvy(i, j)/msfvx(i, j)*v(i, k, j)*reradius&
&            *0.25*(rw(i, k+1, j-1)+rw(i, k, j-1)+rw(i, k+1, j)+rw(i, k, &
&            j))
        END DO
      END DO
    END DO
  END IF
  IF (jte .GT. jde - 1) THEN
    min5 = jde - 1
  ELSE
    min5 = jte
  END IF
!  curvature term for vertical momentum eqn.
!  Notes on map scale factors:
!  ADT eqn 46, RHS term 4: [mu/(a my)]*[u*u + v*v]
!  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
!  terms are: u ru / a + (mx/my)v rv / a
  DO j=jts,min5
    IF (2 .LT. kts) THEN
      max1 = kts
    ELSE
      max1 = 2
    END IF
    DO k=max1,ktf
      IF (ite .GT. ide - 1) THEN
        min6 = ide - 1
      ELSE
        min6 = ite
      END IF
      DO i=its,min6
        rw_tendd(i, k, j) = rw_tendd(i, k, j) + reradius*(0.5**2*((fzm(k&
&          )*(rud(i, k, j)+rud(i+1, k, j))+fzp(k)*(rud(i, k-1, j)+rud(i+1&
&          , k-1, j)))*(fzm(k)*(u(i, k, j)+u(i+1, k, j))+fzp(k)*(u(i, k-1&
&          , j)+u(i+1, k-1, j)))+(fzm(k)*(ru(i, k, j)+ru(i+1, k, j))+fzp(&
&          k)*(ru(i, k-1, j)+ru(i+1, k-1, j)))*(fzm(k)*(ud(i, k, j)+ud(i+&
&          1, k, j))+fzp(k)*(ud(i, k-1, j)+ud(i+1, k-1, j))))+msftx(i, j)&
&          *0.5**2*((fzm(k)*(rvd(i, k, j)+rvd(i, k, j+1))+fzp(k)*(rvd(i, &
&          k-1, j)+rvd(i, k-1, j+1)))*(fzm(k)*(v(i, k, j)+v(i, k, j+1))+&
&          fzp(k)*(v(i, k-1, j)+v(i, k-1, j+1)))+(fzm(k)*(rv(i, k, j)+rv(&
&          i, k, j+1))+fzp(k)*(rv(i, k-1, j)+rv(i, k-1, j+1)))*(fzm(k)*(&
&          vd(i, k, j)+vd(i, k, j+1))+fzp(k)*(vd(i, k-1, j)+vd(i, k-1, j+&
&          1))))/msfty(i, j))
        rw_tend(i, k, j) = rw_tend(i, k, j) + reradius*(0.5*(fzm(k)*(ru(&
&          i, k, j)+ru(i+1, k, j))+fzp(k)*(ru(i, k-1, j)+ru(i+1, k-1, j))&
&          )*0.5*(fzm(k)*(u(i, k, j)+u(i+1, k, j))+fzp(k)*(u(i, k-1, j)+u&
&          (i+1, k-1, j)))+msftx(i, j)/msfty(i, j)*0.5*(fzm(k)*(rv(i, k, &
&          j)+rv(i, k, j+1))+fzp(k)*(rv(i, k-1, j)+rv(i, k-1, j+1)))*0.5*&
&          (fzm(k)*(v(i, k, j)+v(i, k, j+1))+fzp(k)*(v(i, k-1, j)+v(i, k-&
&          1, j+1))))
      END DO
    END DO
  END DO
END SUBROUTINE G_CURVATURE

 SUBROUTINE g_zero_tend(tendency,g_tendency,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
 jme,kms,kme,its,ite,jts,jte,kts,kte)

 IMPLICIT NONE

 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) :: tendency,g_tendency

 INTEGER :: i,j,k,itf,jtf,ktf

 DO j =jts,jte
 DO k =kts,kte
 DO i =its,ite

 g_tendency(i,k,j) =0.0
 tendency(i,k,j) =0.

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_zero_tend

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.6 (r4343) - 10 Feb 2012 10:52
!
!  Differentiation of zero_tend2d in forward (tangent) mode:
!   variations   of useful results: tendency
!   with respect to varying inputs: tendency
!   RW status of diff variables: tendency:in-out
SUBROUTINE G_ZERO_TEND2D(tendency, tendencyd, ids, ide, jds, jde, kds, &
&  kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
  IMPLICIT NONE
! Input data
  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, jms:jme), INTENT(INOUT) :: tendency
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: tendencyd
! Local data
  INTEGER :: i, j, k, itf, jtf, ktf
!<DESCRIPTION>
!
!  zero_tend sets the input tendency array to zero.
!
!</DESCRIPTION>
  DO j=jts,jte
    DO i=its,ite
      tendencyd(i, j) = 0.0
      tendency(i, j) = 0.
    END DO
  END DO
END SUBROUTINE G_ZERO_TEND2D

 SUBROUTINE g_zero_pole(field,g_field,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
 kms,kme,its,ite,jts,jte,kts,kte)

 IMPLICIT NONE

 REAL :: Tmpv1,g_Tmpv1
 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

 INTEGER :: i,k

 IF(jts == jds) THEN

 DO k =kts,kte
 DO i =its-1,ite+1

 g_field(i,k,jts) =0.0
 field(i,k,jts) =0.

 ENDDO
 ENDDO
 END IF

 IF(jte == jde) THEN

 DO k =kts,kte
 DO i =its-1,ite+1

 g_field(i,k,jte) =0.0
 field(i,k,jte) =0.

 ENDDO
 ENDDO
 END IF

 END SUBROUTINE g_zero_pole

 SUBROUTINE g_pole_point_bc(field,g_field,ids,ide,jds,jde,kds,kde,ims,ime,jms, &
 jme,kms,kme,its,ite,jts,jte,kts,kte)

 IMPLICIT NONE

 REAL :: Tmpv1,g_Tmpv1
 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

 INTEGER :: i,k

 IF(jts == jds) THEN

 DO k =kts,kte
 DO i =its,ite

 g_field(i,k,jts) =g_field(i,k,jts+1)
 field(i,k,jts) =field(i,k,jts+1)

 ENDDO
 ENDDO
 END IF

 IF(jte == jde) THEN

 DO k =kts,kte
 DO i =its,ite

 g_field(i,k,jte) =g_field(i,k,jte-1)
 field(i,k,jte) =field(i,k,jte-1)

 ENDDO
 ENDDO
 END IF

 END SUBROUTINE g_pole_point_bc

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
!  Differentiation of phy_prep in forward (tangent) mode:
!   variations   of useful results: rthndgdten rublten v_phy rqvndgdten
!                rthraten rqccuten rthcuten rqicuten z th_phy rthften
!                rvndgdten rqscuten t8w rqrshten rqvshten rucuten
!                pi_phy rvshten rqvblten rvblten rphndgdten t_phy
!                rqcshten rqvften rthshten rqgshten p_hyd_w rqishten
!                p_phy rqcblten rthblten u_phy rqrcuten rqiblten
!                rqsshten rqvcuten p8w z_at_w rho rvcuten p_hyd
!                rushten rundgdten dz8w
!   with respect to varying inputs: rthndgdten rublten v_phy rqvndgdten
!                rthraten p rqccuten t rthcuten u v rqicuten z
!                th_phy rthften rvndgdten rqscuten t8w rqrshten
!                rqvshten rucuten pi_phy rvshten rqvblten rvblten
!                rphndgdten t_phy rqcshten rqvften rthshten rqgshten
!                p_hyd_w rqishten p_phy rqcblten moist ph rthblten
!                u_phy rqrcuten rqiblten alt rqsshten rqvcuten
!                p8w z_at_w rho rvcuten p_hyd rushten muu muv rundgdten
!                mu dz8w
!   RW status of diff variables: rthndgdten:in-out rublten:in-out
!                v_phy:in-out rqvndgdten:in-out rthraten:in-out
!                p:in rqccuten:in-out t:in rthcuten:in-out u:in
!                v:in rqicuten:in-out z:in-out th_phy:in-out rthften:in-out
!                rvndgdten:in-out rqscuten:in-out t8w:in-out rqrshten:in-out
!                rqvshten:in-out rucuten:in-out pi_phy:in-out rvshten:in-out
!                rqvblten:in-out rvblten:in-out rphndgdten:in-out
!                t_phy:in-out rqcshten:in-out rqvften:in-out rthshten:in-out
!                rqgshten:in-out p_hyd_w:in-out rqishten:in-out
!                p_phy:in-out rqcblten:in-out moist:in ph:in rthblten:in-out
!                u_phy:in-out rqrcuten:in-out rqiblten:in-out alt:in
!                rqsshten:in-out rqvcuten:in-out p8w:in-out z_at_w:in-out
!                rho:in-out rvcuten:in-out p_hyd:in-out rushten:in-out
!                muu:in muv:in rundgdten:in-out mu:in dz8w:in-out
! input
! input
! input
! output
! output
! output
! output
! params
!01/2017 decoupling mu in G_PHY_PREP is moved to G_PHY_PREP_part2
SUBROUTINE G_PHY_PREP(config_flags, mu, mud, muu, muud, muv, muvd, u, ud&
&  , v, vd, p, pd, pb, alt, altd, ph, phd, phb, t, td, moist, moistd&
&  , n_moist, rho, rhod, th_phy, th_phyd, p_phy, p_phyd, pi_phy, pi_phyd&
&  , u_phy, u_phyd, v_phy, v_phyd, p8w, p8wd, t_phy, t_phyd, t8w, t8wd, z&
&  , zd, z_at_w, z_at_wd, dz8w, dz8wd, p_hyd, p_hydd, p_hyd_w, p_hyd_wd, &
&  dnw, fzm, fzp, znw, p_top, &
&  ids, ide, jds, jde, kds, kde, ims, ime, jms, &
&  jme, kms, kme, its, ite, jts, jte, kts, kte)
  IMPLICIT NONE
!----------------------------------------------------------------------
  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
  INTEGER, INTENT(IN) :: n_moist
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
&  moist
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme, n_moist), INTENT(IN) :: &
&  moistd
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, muu, muv
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mud, muud, muvd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: u_phy, &
&  v_phy, pi_phy, p_phy, p8w, t_phy, th_phy, t8w, rho, z, dz8w, z_at_w
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: u_phyd, &
&  v_phyd, pi_phyd, p_phyd, p8wd, t_phyd, th_phyd, t8wd, rhod, zd, dz8wd&
&  , z_at_wd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: p_hyd, &
&  p_hyd_w
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: p_hydd, &
&  p_hyd_wd
  REAL, INTENT(IN) :: p_top
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: pb, p, u, v&
&  , alt, ph, phb, t
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: pd, ud, vd, &
&  altd, phd, td
  REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
  REAL, DIMENSION(kms:kme), INTENT(IN) :: znw, dnw
  INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, &
&  j_startv
  INTEGER :: i, j, k
  REAL :: w1, w2, z0, z1, z2
  REAL :: w1d, w2d, z0d, z1d, z2d
  REAL :: qtot
  REAL :: qtotd
  INTEGER :: n
  REAL :: pwx1
  REAL :: pwx1d
  REAL :: arg1
  REAL :: arg1d
!-----------------------------------------------------------------------
!<DESCRIPTION>
!
!  phys_prep calculates a number of diagnostic quantities needed by
!  the physics routines.
!
!</DESCRIPTION>
!  set up loop bounds for this grid's boundary conditions
  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
  k_start = kts
  IF (kte .GT. kde - 1) THEN
    k_end = kde - 1
  ELSE
    k_end = kte
  END IF

!  compute thermodynamics and velocities at pressure points (or half levels)
  DO j=j_start,j_end
    DO k=k_start,k_end
      DO i=i_start,i_end
        th_phyd(i, k, j) = td(i, k, j)
        th_phy(i, k, j) = t(i, k, j) + t0
        p_phyd(i, k, j) = pd(i, k, j)
        p_phy(i, k, j) = p(i, k, j) + pb(i, k, j)
        pwx1d = p_phyd(i, k, j)/p1000mb
        pwx1 = p_phy(i, k, j)/p1000mb
        IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. rcp .EQ. INT(rcp))) &
&        THEN
          pi_phyd(i, k, j) = rcp*pwx1**(rcp-1)*pwx1d
        ELSE IF (pwx1 .EQ. 0.0 .AND. rcp .EQ. 1.0) THEN
          pi_phyd(i, k, j) = pwx1d
        ELSE
          pi_phyd(i, k, j) = 0.0
        END IF
        pi_phy(i, k, j) = pwx1**rcp
        t_phyd(i, k, j) = th_phyd(i, k, j)*pi_phy(i, k, j) + th_phy(i, k&
&          , j)*pi_phyd(i, k, j)
        t_phy(i, k, j) = th_phy(i, k, j)*pi_phy(i, k, j)
        rhod(i, k, j) = moistd(i, k, j, p_qv)/alt(i, k, j) - altd(i, k, &
&          j)*(1.+moist(i, k, j, p_qv))/alt(i, k, j)**2
        rho(i, k, j) = 1./alt(i, k, j)*(1.+moist(i, k, j, p_qv))
        u_phyd(i, k, j) = 0.5*(ud(i, k, j)+ud(i+1, k, j))
        u_phy(i, k, j) = 0.5*(u(i, k, j)+u(i+1, k, j))
        v_phyd(i, k, j) = 0.5*(vd(i, k, j)+vd(i, k, j+1))
        v_phy(i, k, j) = 0.5*(v(i, k, j)+v(i, k, j+1))
      END DO
    END DO
  END DO
!  compute z at w points
  DO j=j_start,j_end
    DO k=k_start,kte
      DO i=i_start,i_end
        z_at_wd(i, k, j) = phd(i, k, j)/g
        z_at_w(i, k, j) = (phb(i, k, j)+ph(i, k, j))/g
      END DO
    END DO
  END DO
  DO j=j_start,j_end
    DO k=k_start,kte-1
      DO i=i_start,i_end
        dz8wd(i, k, j) = z_at_wd(i, k+1, j) - z_at_wd(i, k, j)
        dz8w(i, k, j) = z_at_w(i, k+1, j) - z_at_w(i, k, j)
      END DO
    END DO
  END DO
  DO j=j_start,j_end
    DO i=i_start,i_end
      dz8wd(i, kte, j) = 0.0
      dz8w(i, kte, j) = 0.
    END DO
  END DO
!  compute z at p points or half levels (average of z at full levels)
  DO j=j_start,j_end
    DO k=k_start,k_end
      DO i=i_start,i_end
        zd(i, k, j) = 0.5*(z_at_wd(i, k, j)+z_at_wd(i, k+1, j))
        z(i, k, j) = 0.5*(z_at_w(i, k, j)+z_at_w(i, k+1, j))
      END DO
    END DO
  END DO
!  interp t and p to full levels
  DO j=j_start,j_end
    DO k=2,k_end
      DO i=i_start,i_end
        p8wd(i, k, j) = fzm(k)*p_phyd(i, k, j) + fzp(k)*p_phyd(i, k-1, j&
&          )
        p8w(i, k, j) = fzm(k)*p_phy(i, k, j) + fzp(k)*p_phy(i, k-1, j)
        t8wd(i, k, j) = fzm(k)*t_phyd(i, k, j) + fzp(k)*t_phyd(i, k-1, j&
&          )
        t8w(i, k, j) = fzm(k)*t_phy(i, k, j) + fzp(k)*t_phy(i, k-1, j)
      END DO
    END DO
  END DO
!  extrapolate p and t to surface and top.
!  we'll use an extrapolation in z for now
  DO j=j_start,j_end
    DO i=i_start,i_end
! bottom
      z0d = z_at_wd(i, 1, j)
      z0 = z_at_w(i, 1, j)
      z1d = zd(i, 1, j)
      z1 = z(i, 1, j)
      z2d = zd(i, 2, j)
      z2 = z(i, 2, j)
      w1d = ((z0d-z2d)*(z1-z2)-(z0-z2)*(z1d-z2d))/(z1-z2)**2
      w1 = (z0-z2)/(z1-z2)
      w2d = -w1d
      w2 = 1. - w1
      p8wd(i, 1, j) = w1d*p_phy(i, 1, j) + w1*p_phyd(i, 1, j) + w2d*&
&        p_phy(i, 2, j) + w2*p_phyd(i, 2, j)
      p8w(i, 1, j) = w1*p_phy(i, 1, j) + w2*p_phy(i, 2, j)
      t8wd(i, 1, j) = w1d*t_phy(i, 1, j) + w1*t_phyd(i, 1, j) + w2d*&
&        t_phy(i, 2, j) + w2*t_phyd(i, 2, j)
      t8w(i, 1, j) = w1*t_phy(i, 1, j) + w2*t_phy(i, 2, j)
! top
      z0d = z_at_wd(i, kte, j)
      z0 = z_at_w(i, kte, j)
      z1d = zd(i, k_end, j)
      z1 = z(i, k_end, j)
      z2d = zd(i, k_end-1, j)
      z2 = z(i, k_end-1, j)
      w1d = ((z0d-z2d)*(z1-z2)-(z0-z2)*(z1d-z2d))/(z1-z2)**2
      w1 = (z0-z2)/(z1-z2)
      w2d = -w1d
      w2 = 1. - w1
!      p8w(i,kde,j) = w1*p_phy(i,kde-1,j)+w2*p_phy(i,kde-2,j)
!!!  bug fix      extrapolate ln(p) so p is positive definite
      arg1d = w1d*LOG(p_phy(i, kde-1, j)) + w1*p_phyd(i, kde-1, j)/p_phy&
&        (i, kde-1, j) + w2d*LOG(p_phy(i, kde-2, j)) + w2*p_phyd(i, kde-2&
&        , j)/p_phy(i, kde-2, j)
      arg1 = w1*LOG(p_phy(i, kde-1, j)) + w2*LOG(p_phy(i, kde-2, j))
      p8wd(i, kde, j) = arg1d*EXP(arg1)
      p8w(i, kde, j) = EXP(arg1)
      t8wd(i, kde, j) = w1d*t_phy(i, kde-1, j) + w1*t_phyd(i, kde-1, j) &
&        + w2d*t_phy(i, kde-2, j) + w2*t_phyd(i, kde-2, j)
      t8w(i, kde, j) = w1*t_phy(i, kde-1, j) + w2*t_phy(i, kde-2, j)
    END DO
  END DO
! calculate hydrostatic pressure at both full and half levels
! first, full level p: assuming dry over model top
  DO j=j_start,j_end
    DO i=i_start,i_end
      p_hyd_wd(i, kte, j) = 0.0
      p_hyd_w(i, kte, j) = p_top
    END DO
  END DO
  DO j=j_start,j_end
    DO k=kte-1,k_start,-1
      DO i=i_start,i_end
        qtot = 0.
        qtotd = 0.0
        DO n=param_first_scalar,n_moist
          qtotd = qtotd + moistd(i, k, j, n)
          qtot = qtot + moist(i, k, j, n)
        END DO
        p_hyd_wd(i, k, j) = p_hyd_wd(i, k+1, j) - dnw(k)*(qtotd*mu(i, j)&
&          +(1.+qtot)*mud(i, j))
        p_hyd_w(i, k, j) = p_hyd_w(i, k+1, j) - (1.+qtot)*mu(i, j)*dnw(k&
&          )
      END DO
    END DO
  END DO
!      p_hyd_w(i,k,j) = p_hyd_w(i,k+1,j)+1./alt(i,k,j)*(1.+moist(i,k,j,P_QV))*g*dz8w(i,k,j)
! now calculate hydrostatic pressure at half levels
  DO j=j_start,j_end
    DO k=k_start,k_end
      DO i=i_start,i_end
        p_hydd(i, k, j) = 0.5*(p_hyd_wd(i, k, j)+p_hyd_wd(i, k+1, j))
        p_hyd(i, k, j) = 0.5*(p_hyd_w(i, k, j)+p_hyd_w(i, k+1, j))
      END DO
    END DO
  END DO
END SUBROUTINE G_PHY_PREP

SUBROUTINE G_PHY_PREP_part2(config_flags, mu, mud, muu, muud, muv, muvd, &
&  rthraten, rthratend, rthblten, rthbltend, &
&  rublten, rubltend, rvblten, rvbltend, rqvblten, rqvbltend, rqcblten, &
&  rqcbltend, rqiblten, rqibltend, rucuten, rucutend, rvcuten, rvcutend, &
&  rthcuten, rthcutend, rqvcuten, rqvcutend, rqccuten, rqccutend, &
&  rqrcuten, rqrcutend, rqicuten, rqicutend, rqscuten, rqscutend, rushten&
&  , rushtend, rvshten, rvshtend, rthshten, rthshtend, rqvshten, &
&  rqvshtend, rqcshten, rqcshtend, rqrshten, rqrshtend, rqishten, &
&  rqishtend, rqsshten, rqsshtend, rqgshten, rqgshtend, rthften, rthftend&
&  , rqvften, rqvftend, rundgdten, rundgdtend, rvndgdten, rvndgdtend, &
&  rthndgdten, rthndgdtend, rphndgdten, rphndgdtend, rqvndgdten, &
&  rqvndgdtend, rmundgdten, ids, ide, jds, jde, kds, kde, ims, ime, jms, &
&  jme, kms, kme, its, ite, jts, jte, kts, kte)
  IMPLICIT NONE
!----------------------------------------------------------------------
  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, jms:jme), INTENT(IN) :: mu, muu, muv
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mud, muud, muvd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthraten
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthratend
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rucuten, &
&  rvcuten, rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, &
&  rushten, rvshten, rthshten, rqvshten, rqcshten, rqrshten, rqishten, &
&  rqsshten, rqgshten
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rucutend&
&  , rvcutend, rthcutend, rqvcutend, rqccutend, rqrcutend, rqicutend, &
&  rqscutend, rushtend, rvshtend, rthshtend, rqvshtend, rqcshtend, &
&  rqrshtend, rqishtend, rqsshtend, rqgshtend
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rublten, &
&  rvblten, rthblten, rqvblten, rqcblten, rqiblten
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rubltend&
&  , rvbltend, rthbltend, rqvbltend, rqcbltend, rqibltend
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthften, &
&  rqvften
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rthftend&
&  , rqvftend
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: rundgdten&
&  , rvndgdten, rthndgdten, rphndgdten, rqvndgdten
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
&  rundgdtend, rvndgdtend, rthndgdtend, rphndgdtend, rqvndgdtend
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: rmundgdten
  INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, &
&  j_startv
  INTEGER :: i, j, k
!-----------------------------------------------------------------------
!<DESCRIPTION>
!
!  phys_prep_part2 decouples the physics tendencies from
!  the column dry-air mass (the physics routines expect to see/update the
!  uncoupled tendencies).
!
!</DESCRIPTION>
!  set up loop bounds for this grid's boundary conditions
  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
  k_start = kts
  IF (kte .GT. kde - 1) THEN
    k_end = kde - 1
  ELSE
    k_end = kte
  END IF

! decouple all physics tendencies
  IF (config_flags%ra_lw_physics .GT. 0 .OR. config_flags%ra_sw_physics &
&      .GT. 0) THEN
    DO j=j_start,j_end
      DO k=k_start,k_end
        DO i=i_start,i_end
          rthratend(i, k, j) = (rthratend(i, k, j)*mu(i, j)-rthraten(i, &
&            k, j)*mud(i, j))/mu(i, j)**2
          rthraten(i, k, j) = rthraten(i, k, j)/mu(i, j)
        END DO
      END DO
    END DO
  END IF
  IF (config_flags%cu_physics .GT. 0) THEN
    DO j=j_start,j_end
      DO i=i_start,i_end
        DO k=k_start,k_end
          rucutend(i, k, j) = (rucutend(i, k, j)*mu(i, j)-rucuten(i, k, &
&            j)*mud(i, j))/mu(i, j)**2
          rucuten(i, k, j) = rucuten(i, k, j)/mu(i, j)
          rvcutend(i, k, j) = (rvcutend(i, k, j)*mu(i, j)-rvcuten(i, k, &
&            j)*mud(i, j))/mu(i, j)**2
          rvcuten(i, k, j) = rvcuten(i, k, j)/mu(i, j)
          rthcutend(i, k, j) = (rthcutend(i, k, j)*mu(i, j)-rthcuten(i, &
&            k, j)*mud(i, j))/mu(i, j)**2
          rthcuten(i, k, j) = rthcuten(i, k, j)/mu(i, j)
        END DO
      END DO
    END DO
    IF (p_qv .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqvcutend(i, k, j) = (rqvcutend(i, k, j)*mu(i, j)-rqvcuten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqvcuten(i, k, j) = rqvcuten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
    IF (p_qc .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqccutend(i, k, j) = (rqccutend(i, k, j)*mu(i, j)-rqccuten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqccuten(i, k, j) = rqccuten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
    IF (p_qr .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqrcutend(i, k, j) = (rqrcutend(i, k, j)*mu(i, j)-rqrcuten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqrcuten(i, k, j) = rqrcuten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
    IF (p_qi .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqicutend(i, k, j) = (rqicutend(i, k, j)*mu(i, j)-rqicuten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqicuten(i, k, j) = rqicuten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
    IF (p_qs .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqscutend(i, k, j) = (rqscutend(i, k, j)*mu(i, j)-rqscuten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqscuten(i, k, j) = rqscuten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
  END IF
  IF (config_flags%shcu_physics .GT. 0) THEN
    DO j=j_start,j_end
      DO i=i_start,i_end
        DO k=k_start,k_end
          rushtend(i, k, j) = (rushtend(i, k, j)*mu(i, j)-rushten(i, k, &
&            j)*mud(i, j))/mu(i, j)**2
          rushten(i, k, j) = rushten(i, k, j)/mu(i, j)
          rvshtend(i, k, j) = (rvshtend(i, k, j)*mu(i, j)-rvshten(i, k, &
&            j)*mud(i, j))/mu(i, j)**2
          rvshten(i, k, j) = rvshten(i, k, j)/mu(i, j)
          rthshtend(i, k, j) = (rthshtend(i, k, j)*mu(i, j)-rthshten(i, &
&            k, j)*mud(i, j))/mu(i, j)**2
          rthshten(i, k, j) = rthshten(i, k, j)/mu(i, j)
        END DO
      END DO
    END DO
    IF (p_qv .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqvshtend(i, k, j) = (rqvshtend(i, k, j)*mu(i, j)-rqvshten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqvshten(i, k, j) = rqvshten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
    IF (p_qc .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqcshtend(i, k, j) = (rqcshtend(i, k, j)*mu(i, j)-rqcshten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqcshten(i, k, j) = rqcshten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
    IF (p_qr .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqrshtend(i, k, j) = (rqrshtend(i, k, j)*mu(i, j)-rqrshten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqrshten(i, k, j) = rqrshten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
    IF (p_qi .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqishtend(i, k, j) = (rqishtend(i, k, j)*mu(i, j)-rqishten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqishten(i, k, j) = rqishten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
    IF (p_qs .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqsshtend(i, k, j) = (rqsshtend(i, k, j)*mu(i, j)-rqsshten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqsshten(i, k, j) = rqsshten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
    IF (p_qg .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqgshtend(i, k, j) = (rqgshtend(i, k, j)*mu(i, j)-rqgshten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqgshten(i, k, j) = rqgshten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
  END IF
  IF (config_flags%bl_pbl_physics .GT. 0) THEN
    DO j=j_start,j_end
      DO k=k_start,k_end
        DO i=i_start,i_end
          rubltend(i, k, j) = (rubltend(i, k, j)*mu(i, j)-rublten(i, k, &
&            j)*mud(i, j))/mu(i, j)**2
          rublten(i, k, j) = rublten(i, k, j)/mu(i, j)
          rvbltend(i, k, j) = (rvbltend(i, k, j)*mu(i, j)-rvblten(i, k, &
&            j)*mud(i, j))/mu(i, j)**2
          rvblten(i, k, j) = rvblten(i, k, j)/mu(i, j)
          rthbltend(i, k, j) = (rthbltend(i, k, j)*mu(i, j)-rthblten(i, &
&            k, j)*mud(i, j))/mu(i, j)**2
          rthblten(i, k, j) = rthblten(i, k, j)/mu(i, j)
        END DO
      END DO
    END DO
    IF (p_qv .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO k=k_start,k_end
          DO i=i_start,i_end
            rqvbltend(i, k, j) = (rqvbltend(i, k, j)*mu(i, j)-rqvblten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqvblten(i, k, j) = rqvblten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
    IF (p_qc .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO k=k_start,k_end
          DO i=i_start,i_end
            rqcbltend(i, k, j) = (rqcbltend(i, k, j)*mu(i, j)-rqcblten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqcblten(i, k, j) = rqcblten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
    IF (p_qi .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO k=k_start,k_end
          DO i=i_start,i_end
            rqibltend(i, k, j) = (rqibltend(i, k, j)*mu(i, j)-rqiblten(i&
&              , k, j)*mud(i, j))/mu(i, j)**2
            rqiblten(i, k, j) = rqiblten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
  END IF
!  decouple advective forcing required by Grell-Devenyi scheme
  IF (((config_flags%cu_physics .EQ. gdscheme .OR. config_flags%&
&      cu_physics .EQ. g3scheme) .OR. config_flags%cu_physics .EQ. &
&      kfetascheme) .OR. config_flags%cu_physics .EQ. tiedtkescheme .OR. &
&      (config_flags%cu_physics == NTIEDTKESCHEME) .OR. &
&      (config_flags%cu_physics == MSKFSCHEME) ) THEN
    DO j=j_start,j_end
      DO i=i_start,i_end
        DO k=k_start,k_end
          rthftend(i, k, j) = (rthftend(i, k, j)*mu(i, j)-rthften(i, k, &
&            j)*mud(i, j))/mu(i, j)**2
          rthften(i, k, j) = rthften(i, k, j)/mu(i, j)
        END DO
      END DO
    END DO
    IF (p_qv .GE. param_first_scalar) THEN
      DO j=j_start,j_end
        DO i=i_start,i_end
          DO k=k_start,k_end
            rqvftend(i, k, j) = (rqvftend(i, k, j)*mu(i, j)-rqvften(i, k&
&              , j)*mud(i, j))/mu(i, j)**2
            rqvften(i, k, j) = rqvften(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    END IF
  END IF
! fdda
! note fdda u and v tendencies are staggered, also only interior points have muu/muv,
!   so only decouple those
  IF (config_flags%grid_fdda .GT. 0) THEN
    IF (its .LT. ids + 1) THEN
      i_startu = ids + 1
    ELSE
      i_startu = its
    END IF
    IF (jts .LT. jds + 1) THEN
      j_startv = jds + 1
    ELSE
      j_startv = jts
    END IF
    DO j=j_start,j_end
      DO k=k_start,k_end
        DO i=i_startu,i_end
          rundgdtend(i, k, j) = (rundgdtend(i, k, j)*muu(i, j)-rundgdten&
&            (i, k, j)*muud(i, j))/muu(i, j)**2
          rundgdten(i, k, j) = rundgdten(i, k, j)/muu(i, j)
        END DO
      END DO
    END DO
    DO j=j_startv,j_end
      DO k=k_start,k_end
        DO i=i_start,i_end
          rvndgdtend(i, k, j) = (rvndgdtend(i, k, j)*muv(i, j)-rvndgdten&
&            (i, k, j)*muvd(i, j))/muv(i, j)**2
          rvndgdten(i, k, j) = rvndgdten(i, k, j)/muv(i, j)
        END DO
      END DO
    END DO
    DO j=j_start,j_end
      DO k=k_start,k_end
        DO i=i_start,i_end
          rthndgdtend(i, k, j) = (rthndgdtend(i, k, j)*mu(i, j)-&
&            rthndgdten(i, k, j)*mud(i, j))/mu(i, j)**2
          rthndgdten(i, k, j) = rthndgdten(i, k, j)/mu(i, j)
        END DO
      END DO
    END DO
!        RMUNDGDTEN(I,J) - no coupling
    IF (config_flags%grid_fdda .EQ. 2) THEN
      DO j=j_start,j_end
        DO k=k_start,kte
          DO i=i_start,i_end
            rphndgdtend(i, k, j) = (rphndgdtend(i, k, j)*mu(i, j)-&
&              rphndgdten(i, k, j)*mud(i, j))/mu(i, j)**2
            rphndgdten(i, k, j) = rphndgdten(i, k, j)/mu(i, j)
          END DO
        END DO
      END DO
    ELSE IF (config_flags%grid_fdda .EQ. 1) THEN
      IF (p_qv .GE. param_first_scalar) THEN
        DO j=j_start,j_end
          DO k=k_start,k_end
            DO i=i_start,i_end
              rqvndgdtend(i, k, j) = (rqvndgdtend(i, k, j)*mu(i, j)-&
&                rqvndgdten(i, k, j)*mud(i, j))/mu(i, j)**2
              rqvndgdten(i, k, j) = rqvndgdten(i, k, j)/mu(i, j)
            END DO
          END DO
        END DO
      END IF
    END IF
  END IF
END SUBROUTINE G_PHY_PREP_part2

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
!  Differentiation of moist_physics_prep_em in forward (tangent) mode:
!   variations   of useful results: z th_phy h_diabatic pf p8w
!                z_at_w rho pii dz8w
!   with respect to varying inputs: p al t_new ph
!   RW status of diff variables: p:in al:in z:out th_phy:out h_diabatic:out
!                t_new:in pf:out ph:in p8w:out z_at_w:out rho:out
!                pii:out dz8w:out
SUBROUTINE G_MOIST_PHYSICS_PREP_EM(t_new, t_newd, t_old, t0, rho, rhod, &
&  al, ald, alb, p, pd, p8w, p8wd, p0, pb, ph, phd, phb, th_phy, th_phyd&
&  , pii, piid, pf, pfd, z, zd, z_at_w, z_at_wd, dz8w, dz8wd, dt, &
&  h_diabatic, h_diabaticd, &
&  qv, qvd, qv_diabatic, qv_diabaticd, &
&  qc, qcd, qc_diabatic, qc_diabaticd, &
&  config_flags, fzm, fzp, ids, ide, jds, jde, &
&  kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
  IMPLICIT NONE
! Here we construct full fields
! needed by the microphysics
  TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
  INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
  INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
  INTEGER, INTENT(IN) :: its, ite, jts, jte, kts, kte
  REAL, INTENT(IN) :: dt
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: al, alb, p, &
&  pb, ph, phb, qv, qc
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: ald, pd, phd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: qvd, qcd
  REAL, DIMENSION(kms:kme), INTENT(IN) :: fzm, fzp
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rho, th_phy&
&  , pii, pf, z, z_at_w, dz8w, p8w
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: rhod, &
&  th_phyd, piid, pfd, zd, z_at_wd, dz8wd, p8wd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
&  h_diabatic, qv_diabatic, qc_diabatic
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
&  h_diabaticd, qv_diabaticd, qc_diabaticd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_new, &
&  t_old
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_newd
  REAL, INTENT(IN) :: t0, p0
  REAL :: z0, z1, z2, w1, w2
  REAL :: z0d, z1d, z2d, w1d, w2d
  INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end
  INTEGER :: i, j, k
  REAL :: pwx1
  REAL :: pwx1d
  REAL :: arg1
  REAL :: arg1d
!--------------------------------------------------------------------
!<DESCRIPTION>
!
!  moist_phys_prep_em calculates a number of diagnostic quantities needed by
!  the microphysics routines.
!
!</DESCRIPTION>
!  set up loop bounds for this grid's boundary conditions
  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
  k_start = kts
  IF (kte .GT. kde - 1) THEN
    k_end = kde - 1
  ELSE
    k_end = kte
  END IF
  z_at_wd = 0.0
  DO j=j_start,j_end
    DO k=k_start,kte
      DO i=i_start,i_end
        z_at_wd(i, k, j) = phd(i, k, j)/g
        z_at_w(i, k, j) = (ph(i, k, j)+phb(i, k, j))/g
      END DO
    END DO
  END DO
  dz8wd = 0.0
  DO j=j_start,j_end
    DO k=k_start,kte-1
      DO i=i_start,i_end
        dz8wd(i, k, j) = z_at_wd(i, k+1, j) - z_at_wd(i, k, j)
        dz8w(i, k, j) = z_at_w(i, k+1, j) - z_at_w(i, k, j)
      END DO
    END DO
  END DO
  DO j=j_start,j_end
    DO i=i_start,i_end
      dz8wd(i, kte, j) = 0.0
      dz8w(i, kte, j) = 0.
    END DO
  END DO
  zd = 0.0
  th_phyd = 0.0
  h_diabaticd = 0.0
  pfd = 0.0
  rhod = 0.0
  piid = 0.0
!  compute full pii, rho, and z at the new time-level
!  (needed for physics).
!  convert perturbation theta to full theta (th_phy)
!  use h_diabatic to temporarily save pre-microphysics full theta
  DO j=j_start,j_end
    DO k=k_start,k_end
      DO i=i_start,i_end
        th_phyd(i, k, j) = t_newd(i, k, j)
        th_phy(i, k, j) = t_new(i, k, j) + t0
        h_diabaticd(i, k, j) = th_phyd(i, k, j)
        h_diabatic(i, k, j) = th_phy(i, k, j)
        if ( P_QV >= PARAM_FIRST_SCALAR ) then
           qv_diabaticd(i, k, j) = qvd(i, k, j)
           qv_diabatic(i, k, j)  = qv(i, k, j)
        else
           qv_diabaticd(i, k, j) = 0.0
           qv_diabatic(i, k, j)  = 0.0
        end if
        if ( P_QC >= PARAM_FIRST_SCALAR ) then
           qc_diabaticd(i, k, j) = qcd(i, k, j)
           qc_diabatic(i, k, j)  = qc(i, k, j)
        else
           qc_diabaticd(i, k, j) = 0.0
           qc_diabatic(i, k, j)  = 0.0
        end if
        rhod(i, k, j) = -(ald(i, k, j)/(al(i, k, j)+alb(i, k, j))**2)
        rho(i, k, j) = 1./(al(i, k, j)+alb(i, k, j))
        pwx1d = pd(i, k, j)/p0
        pwx1 = (p(i, k, j)+pb(i, k, j))/p0
        IF (pwx1 .GT. 0.0 .OR. (pwx1 .LT. 0.0 .AND. rcp .EQ. INT(rcp))) &
&        THEN
          piid(i, k, j) = rcp*pwx1**(rcp-1)*pwx1d
        ELSE IF (pwx1 .EQ. 0.0 .AND. rcp .EQ. 1.0) THEN
          piid(i, k, j) = pwx1d
        ELSE
          piid(i, k, j) = 0.0
        END IF
        pii(i, k, j) = pwx1**rcp
        zd(i, k, j) = 0.5*(z_at_wd(i, k, j)+z_at_wd(i, k+1, j))
        z(i, k, j) = 0.5*(z_at_w(i, k, j)+z_at_w(i, k+1, j))
        pfd(i, k, j) = pd(i, k, j)
        pf(i, k, j) = p(i, k, j) + pb(i, k, j)
      END DO
    END DO
  END DO
  p8wd = 0.0
!  interp t and p at w points
  DO j=j_start,j_end
    DO k=2,k_end
      DO i=i_start,i_end
        p8wd(i, k, j) = fzm(k)*pfd(i, k, j) + fzp(k)*pfd(i, k-1, j)
        p8w(i, k, j) = fzm(k)*pf(i, k, j) + fzp(k)*pf(i, k-1, j)
      END DO
    END DO
  END DO
!  extrapolate p and t to surface and top.
!  we'll use an extrapolation in z for now
  DO j=j_start,j_end
    DO i=i_start,i_end
! bottom
      z0d = z_at_wd(i, 1, j)
      z0 = z_at_w(i, 1, j)
      z1d = zd(i, 1, j)
      z1 = z(i, 1, j)
      z2d = zd(i, 2, j)
      z2 = z(i, 2, j)
      w1d = ((z0d-z2d)*(z1-z2)-(z0-z2)*(z1d-z2d))/(z1-z2)**2
      w1 = (z0-z2)/(z1-z2)
      w2d = -w1d
      w2 = 1. - w1
      p8wd(i, 1, j) = w1d*pf(i, 1, j) + w1*pfd(i, 1, j) + w2d*pf(i, 2, j&
&        ) + w2*pfd(i, 2, j)
      p8w(i, 1, j) = w1*pf(i, 1, j) + w2*pf(i, 2, j)
! top
      z0d = z_at_wd(i, kte, j)
      z0 = z_at_w(i, kte, j)
      z1d = zd(i, k_end, j)
      z1 = z(i, k_end, j)
      z2d = zd(i, k_end-1, j)
      z2 = z(i, k_end-1, j)
      w1d = ((z0d-z2d)*(z1-z2)-(z0-z2)*(z1d-z2d))/(z1-z2)**2
      w1 = (z0-z2)/(z1-z2)
      w2d = -w1d
      w2 = 1. - w1
!      p8w(i,kde,j) = w1*pf(i,kde-1,j)+w2*pf(i,kde-2,j)
      arg1d = w1d*LOG(pf(i, kde-1, j)) + w1*pfd(i, kde-1, j)/pf(i, kde-1&
&        , j) + w2d*LOG(pf(i, kde-2, j)) + w2*pfd(i, kde-2, j)/pf(i, kde-&
&        2, j)
      arg1 = w1*LOG(pf(i, kde-1, j)) + w2*LOG(pf(i, kde-2, j))
      p8wd(i, kde, j) = arg1d*EXP(arg1)
      p8w(i, kde, j) = EXP(arg1)
    END DO
  END DO
END SUBROUTINE G_MOIST_PHYSICS_PREP_EM

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.7 (r4786) - 21 Feb 2013 15:53
!
!  Differentiation of moist_physics_finish_em in forward (tangent) mode (with options i4 r8):
!   variations   of useful results: h_diabatic t_new
!   with respect to varying inputs: th_phy h_diabatic t_new
!   RW status of diff variables: th_phy:in h_diabatic:in-out t_new:in-out
SUBROUTINE G_MOIST_PHYSICS_FINISH_EM(t_new, t_newd, t_old, t0, mut, &
&  th_phy, th_phyd, h_diabatic, h_diabaticd, &
&  qv, qvd, qv_diabatic, qv_diabaticd, qc, qcd, qc_diabatic, qc_diabaticd, &
&  dt, config_flags, ids, ide, &
&  jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, &
&  kts, kte)
  IMPLICIT NONE
! Here we construct full fields
! needed by the microphysics
  TYPE(GRID_CONFIG_REC_TYPE), INTENT(IN) :: config_flags
  INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
  INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
  INTEGER, INTENT(IN) :: its, ite, jts, jte, kts, kte
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_new, &
&  t_old, th_phy, h_diabatic, qv_diabatic, qc_diabatic
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_newd, &
&  th_phyd, h_diabaticd, qv_diabaticd, qc_diabaticd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: qv, qc
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: qvd, qcd
  REAL :: mpten, qvten, qcten
  REAL :: mptend, qvtend, qctend
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: mut
  REAL, INTENT(IN) :: t0, dt
  INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end
  INTEGER :: i, j, k, imax, jmax, imin, jmin
!--------------------------------------------------------------------
!<DESCRIPTION>
!
!  moist_phys_finish_em resets theta to its perturbation value and
!  computes and stores the microphysics diabatic heating term.
!
!</DESCRIPTION>
!  set up loop bounds for this grid's boundary conditions
  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
  k_start = kts
  IF (kte .GT. kde - 1) THEN
    k_end = kde - 1
  ELSE
    k_end = kte
  END IF
!  add microphysics theta diff to perturbation theta, set h_diabatic
  IF (config_flags%no_mp_heating .EQ. 0) THEN
    qvtend = 0.0
    qctend = 0.0
    DO j=j_start,j_end
      DO k=k_start,k_end
        DO i=i_start,i_end
          mptend = th_phyd(i, k, j) - h_diabaticd(i, k, j)
          mpten = th_phy(i, k, j) - h_diabatic(i, k, j)
          if ( P_QV >= PARAM_FIRST_SCALAR ) then
             qvtend = qvd(i, k, j) - qv_diabaticd(i, k, j)
             qvten  = qv(i, k, j)  - qv_diabatic(i, k, j)
          end if
          if ( P_QC >= PARAM_FIRST_SCALAR ) then
             qctend = qcd(i, k, j) - qc_diabaticd(i, k, j)
             qcten  = qc(i, k, j)  - qc_diabatic(i, k, j)
          end if
          IF (config_flags%mp_tend_lim*dt .GT. mpten) THEN
            mpten = mpten
          ELSE
            mpten = config_flags%mp_tend_lim*dt
            mptend = 0.0_8
          END IF
          IF (-(config_flags%mp_tend_lim*dt) .LT. mpten) THEN
            mpten = mpten
          ELSE
            mpten = -(config_flags%mp_tend_lim*dt)
            mptend = 0.0_8
          END IF
          t_newd(i, k, j) = t_newd(i, k, j) + mptend
          t_new(i, k, j) = t_new(i, k, j) + mpten
          h_diabaticd(i, k, j) = mptend/dt
          h_diabatic(i, k, j) = mpten/dt
          if ( P_QV >= PARAM_FIRST_SCALAR ) then
             qv_diabaticd(i, k, j) = qvtend/dt
             qv_diabatic(i, k, j)  = qvten/dt
          else
             qv_diabaticd(i, k, j) = 0.0
             qv_diabatic(i, k, j)  = 0.0
          end if
          if ( P_QC >= PARAM_FIRST_SCALAR ) then
             qc_diabaticd(i, k, j) = qctend/dt
             qc_diabatic(i, k, j)  = qcten/dt
          else
             qc_diabaticd(i, k, j) = 0.0
             qc_diabatic(i, k, j)  = 0.0
          end if
        END DO
      END DO
    END DO
  ELSE
    DO j=j_start,j_end
      DO k=k_start,k_end
        DO i=i_start,i_end
          h_diabaticd(i, k, j) = 0.0_8
          h_diabatic(i, k, j) = 0.
          qv_diabaticd(i, k, j) = 0.0
          qv_diabatic(i, k, j)  = 0.0
          qc_diabaticd(i, k, j) = 0.0
          qc_diabatic(i, k, j)  = 0.0
        END DO
      END DO
    END DO
  END IF
END SUBROUTINE G_MOIST_PHYSICS_FINISH_EM

SUBROUTINE g_init_module_big_step

 END SUBROUTINE g_init_module_big_step

 SUBROUTINE g_set_tend(field,g_field,field_adv_tend,g_field_adv_tend,msf, &
! Revised by Ning Pan, 2010-07-19
! g_msf,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
 ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)

 IMPLICIT NONE

 REAL :: Tmpv1,g_Tmpv1
 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
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field_adv_tend,g_field_adv_tend
! Revised by Ning Pan, 2010-07-19
! REAL,DIMENSION(ims:ime,jms:jme) :: msf,g_msf
 REAL,DIMENSION(ims:ime,jms:jme) :: msf,g_msf

 INTEGER :: i,j,k,itf,jtf,ktf

 jtf =min(jte,jde-1)

 ktf =min(kte,kde-1)

 itf =min(ite,ide-1)

 DO j =jts,jtf
 DO k =kts,ktf
 DO i =its,itf

! Revised by Ning Pan, 2010-07-19
! g_Tmpv1 =field_adv_tend(i,k,j)*g_msf(i,j) +g_field_adv_tend(i,k,j)*msf(i,j) 
 g_Tmpv1 =g_field_adv_tend(i,k,j)*msf(i,j) 
 Tmpv1 =field_adv_tend(i,k,j)*msf(i,j)

 g_field(i,k,j) =g_Tmpv1
 field(i,k,j) =Tmpv1

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_set_tend

 SUBROUTINE g_rk_rayleigh_damp(ru_tendf,g_ru_tendf,rv_tendf,g_rv_tendf, &
 rw_tendf,g_rw_tendf,t_tendf,g_t_tendf,u,g_u,v,g_v,w,g_w,t,g_t, &
! Revised by Ning Pan, 2010-07-23
! t_init,g_t_init,mut,g_mut,muu,g_muu,muv,g_muv,ph,g_ph,phb,g_phb, &
! u_base,g_u_base,v_base,g_v_base,t_base,g_t_base,z_base,g_z_base,dampcoef, &
! g_dampcoef,zdamp,g_zdamp,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its, &
 t_init,mut,g_mut,muu,g_muu,muv,g_muv,ph,g_ph,phb, &
 u_base,v_base,t_base,z_base,dampcoef, &
 zdamp,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
 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) :: ru_tendf,g_ru_tendf,rv_tendf, &
 g_rv_tendf,rw_tendf,g_rw_tendf,t_tendf,g_t_tendf
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: u,g_u,v,g_v,w,g_w,t,g_t, &
! Revised by Ning Pan, 2010-07-23
! t_init,g_t_init,ph,g_ph,phb,g_phb
 t_init,ph,g_ph,phb
 REAL,DIMENSION(ims:ime,jms:jme) :: mut,g_mut,muu,g_muu,muv,g_muv
! Revised by Ning Pan, 2010-07-23
! REAL,DIMENSION(kms:kme) :: u_base,g_u_base,v_base,g_v_base,t_base,g_t_base, &
! z_base,g_z_base
 REAL,DIMENSION(kms:kme) :: u_base,v_base,t_base,z_base
! REAL :: dampcoef,g_dampcoef,zdamp,g_zdamp
 REAL :: dampcoef,zdamp
 INTEGER :: i_start,i_end,j_start,j_end,k_start,k_end,i,j,k,ktf,k1,k2
! Revised by Ning Pan, 2010-07-23
! REAL :: pii,g_pii,dcoef,g_dcoef,z,g_z,ztop,g_ztop
 REAL :: pii,dcoef,g_dcoef,z,g_z,ztop,g_ztop
! REAL :: wkp1,g_wkp1,wk,g_wk,wkm1,g_wkm1  ! Remarked by Ning Pan, 2010-07-23
 REAL,DIMENSION(kms:kme) :: z00,g_z00,u00,g_u00,v00,g_v00,t00,g_t00

! g_pii =0.0  ! Remarked by Ning Pan, 2010-07-23
 pii =2.0 *Asin(1.0)

 ktf =min(kte,kde-1)

 DO j =jts,min(jte,jde-1)
 DO i =its,min(ite,ide)

! Revised by Ning Pan, 2010-07-23
! g_ztop =0.5*(g_phb(i,kde,j) +g_phb(i-1,kde,j) +g_ph(i,kde,j) &
! +g_ph(i-1,kde,j))/g
 g_ztop =0.5*(g_ph(i,kde,j) +g_ph(i-1,kde,j))/g
 ztop =0.5*(phb(i,kde,j) +phb(i-1,kde,j) +ph(i,kde,j) +ph(i-1,kde,j))/g

 k1 =ktf

 g_z =g_ztop
 z =ztop

!This line is fail to be recognized
       DO WHILE( z >= (ztop-zdamp) )

! Revised by Ning Pan, 2010-07-23
! g_z =0.25*(g_phb(i,k1,j) +g_phb(i,k1+1,j) +g_phb(i-1,k1,j) +g_phb(i-1, &
! k1+1,j) +g_ph(i,k1,j) +g_ph(i,k1+1,j) +g_ph(i-1,k1,j) +g_ph(i-1,k1+1,j))/g
 g_z =0.25*(g_ph(i,k1,j) +g_ph(i,k1+1,j) +g_ph(i-1,k1,j) +g_ph(i-1,k1+1,j))/g
 z =0.25*(phb(i,k1,j) +phb(i,k1+1,j) +phb(i-1,k1,j) +phb(i-1,k1+1,j) +ph(i,k1,j) &
 +ph(i,k1+1,j) +ph(i-1,k1,j) +ph(i-1,k1+1,j))/g

 g_z00(k1) =g_z
 z00(k1) =z

 k1 =k1-1
 ENDDO

 k1 =k1+2

 DO k =k1,ktf

 k2 =ktf

 DO WHILE(z_base(k2) .gt. z00(k))

 k2 =k2-1
 ENDDO

 IF(k2+1.gt.ktf) THEN

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =(u_base(k2) -u_base(k2-1))*(g_z00(k) -g_z_base(k2)) +(g_u_base( &
! k2) -g_u_base(k2-1))*(z00(k) -z_base(k2)) 
 g_Tmpv1 =(u_base(k2) -u_base(k2-1))*g_z00(k)
 Tmpv1 =(u_base(k2) -u_base(k2-1))*(z00(k) -z_base(k2))

! Revised by Ning Pan, 2010-07-23
! g_Tmpv2 =(g_Tmpv1*(z_base(k2) -z_base(k2-1)) -(g_z_base(k2) -g_z_base( &
! k2-1))*Tmpv1)/((z_base(k2) -z_base(k2-1))*(z_base(k2) -z_base(k2-1))) 
 g_Tmpv2 =g_Tmpv1/(z_base(k2) -z_base(k2-1))
 Tmpv2 =Tmpv1/(z_base(k2) -z_base(k2-1))

! Revised by Ning Pan, 2010-07-23
! g_u00(k) =g_u_base(k2) +g_Tmpv2
 g_u00(k) =g_Tmpv2
 u00(k) =u_base(k2) +Tmpv2

 else

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =(u_base(k2+1) -u_base(k2))*(g_z00(k) -g_z_base(k2)) +(g_u_base( &
! k2+1) -g_u_base(k2))*(z00(k) -z_base(k2)) 
 g_Tmpv1 =(u_base(k2+1) -u_base(k2))*g_z00(k)
 Tmpv1 =(u_base(k2+1) -u_base(k2))*(z00(k) -z_base(k2))

! Revised by Ning Pan, 2010-07-23
! g_Tmpv2 =(g_Tmpv1*(z_base(k2+1) -z_base(k2)) -(g_z_base(k2+1) &
! -g_z_base(k2))*Tmpv1)/((z_base(k2+1) -z_base(k2))*(z_base(k2+1) -z_base(k2))) 
 g_Tmpv2 =g_Tmpv1/(z_base(k2+1) -z_base(k2))
 Tmpv2 =Tmpv1/(z_base(k2+1) -z_base(k2))

! Revised by Ning Pan, 2010-07-23
! g_u00(k) =g_u_base(k2) +g_Tmpv2
 g_u00(k) =g_Tmpv2
 u00(k) =u_base(k2) +Tmpv2

 endif
 ENDDO

 DO k =k1,ktf

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =((g_ztop -g_z00(k))*zdamp -g_zdamp*(ztop -z00(k)))/(zdamp*zdamp) 
 g_Tmpv1 =(g_ztop -g_z00(k))/zdamp
 Tmpv1 =(ztop -z00(k))/zdamp

 g_dcoef =-(0.0 +g_Tmpv1 -(0.0 -g_Tmpv1)*sign(1.0, 1.0 -(Tmpv1)))*0.5
 dcoef =1.0 -min(1.0,Tmpv1)

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =0.5*pii*g_dcoef +0.5*g_pii*dcoef 
 g_Tmpv1 =0.5*pii*g_dcoef
 Tmpv1 =0.5*pii*dcoef

 g_dcoef =2.0*(g_Tmpv1*cos(Tmpv1))*(sin(Tmpv1))
 dcoef =(sin(Tmpv1))**2

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =dcoef*g_dampcoef +g_dcoef*dampcoef 
 g_Tmpv1 =g_dcoef*dampcoef 
 Tmpv1 =dcoef*dampcoef

 g_Tmpv2 =muu(i,j)*(g_Tmpv1) +g_muu(i,j)*(Tmpv1) 
 Tmpv2 =muu(i,j)*(Tmpv1)

 g_Tmpv3 =Tmpv2*(g_u(i,k,j) -g_u00(k)) +g_Tmpv2*(u(i,k,j) -u00(k)) 
 Tmpv3 =Tmpv2*(u(i,k,j) -u00(k))

 g_ru_tendf(i,k,j) =g_ru_tendf(i,k,j) -g_Tmpv3
 ru_tendf(i,k,j) =ru_tendf(i,k,j) -Tmpv3

 ENDDO
 ENDDO
 ENDDO

 DO j =jts,min(jte,jde)
 DO i =its,min(ite,ide-1)

! Revised by Ning Pan, 2010-07-23
! g_ztop =0.5*(g_phb(i,kde,j) +g_phb(i,kde,j-1) +g_ph(i,kde,j) &
! +g_ph(i,kde,j-1))/g
 g_ztop =0.5*(g_ph(i,kde,j) +g_ph(i,kde,j-1))/g
 ztop =0.5*(phb(i,kde,j) +phb(i,kde,j-1) +ph(i,kde,j) +ph(i,kde,j-1))/g

 k1 =ktf

 g_z =g_ztop
 z =ztop

!This line is fail to be recognized
       DO WHILE( z >= (ztop-zdamp) )

! Revised by Ning Pan, 2010-07-23
! g_z =0.25*(g_phb(i,k1,j) +g_phb(i,k1+1,j) +g_phb(i,k1,j-1) +g_phb(i, &
! k1+1,j-1) +g_ph(i,k1,j) +g_ph(i,k1+1,j) +g_ph(i,k1,j-1) +g_ph(i,k1+1,j-1))/g
 g_z =0.25*(g_ph(i,k1,j) +g_ph(i,k1+1,j) +g_ph(i,k1,j-1) +g_ph(i,k1+1,j-1))/g
 z =0.25*(phb(i,k1,j) +phb(i,k1+1,j) +phb(i,k1,j-1) +phb(i,k1+1,j-1) +ph(i,k1,j) &
 +ph(i,k1+1,j) +ph(i,k1,j-1) +ph(i,k1+1,j-1))/g

 g_z00(k1) =g_z
 z00(k1) =z

 k1 =k1-1
 ENDDO

 k1 =k1+2

 DO k =k1,ktf

 k2 =ktf

 DO WHILE(z_base(k2) .gt. z00(k))

 k2 =k2-1
 ENDDO

 IF(k2+1.gt.ktf) THEN

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =(v_base(k2) -v_base(k2-1))*(g_z00(k) -g_z_base(k2)) +(g_v_base( &
! k2) -g_v_base(k2-1))*(z00(k) -z_base(k2)) 
 g_Tmpv1 =(v_base(k2) -v_base(k2-1))*g_z00(k)
 Tmpv1 =(v_base(k2) -v_base(k2-1))*(z00(k) -z_base(k2))

! Revised by Ning Pan, 2010-07-23
! g_Tmpv2 =(g_Tmpv1*(z_base(k2) -z_base(k2-1)) -(g_z_base(k2) -g_z_base( &
! k2-1))*Tmpv1)/((z_base(k2) -z_base(k2-1))*(z_base(k2) -z_base(k2-1))) 
 g_Tmpv2 =g_Tmpv1/(z_base(k2) -z_base(k2-1))
 Tmpv2 =Tmpv1/(z_base(k2) -z_base(k2-1))

! Revised by Ning Pan, 2010-07-23
! g_v00(k) =g_v_base(k2) +g_Tmpv2
 g_v00(k) =g_Tmpv2
 v00(k) =v_base(k2) +Tmpv2

 else

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =(v_base(k2+1) -v_base(k2))*(g_z00(k) -g_z_base(k2)) +(g_v_base( &
! k2+1) -g_v_base(k2))*(z00(k) -z_base(k2)) 
 g_Tmpv1 =(v_base(k2+1) -v_base(k2))*g_z00(k)
 Tmpv1 =(v_base(k2+1) -v_base(k2))*(z00(k) -z_base(k2))

! Revised by Ning Pan, 2010-07-23
! g_Tmpv2 =(g_Tmpv1*(z_base(k2+1) -z_base(k2)) -(g_z_base(k2+1) &
! -g_z_base(k2))*Tmpv1)/((z_base(k2+1) -z_base(k2))*(z_base(k2+1) -z_base(k2))) 
 g_Tmpv2 =g_Tmpv1/(z_base(k2+1) -z_base(k2))
 Tmpv2 =Tmpv1/(z_base(k2+1) -z_base(k2))

! Revised by Ning Pan, 2010-07-23
! g_v00(k) =g_v_base(k2) +g_Tmpv2
 g_v00(k) =g_Tmpv2
 v00(k) =v_base(k2) +Tmpv2

 endif
 ENDDO

 DO k =k1,ktf

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =((g_ztop -g_z00(k))*zdamp -g_zdamp*(ztop -z00(k)))/(zdamp*zdamp) 
 g_Tmpv1 =(g_ztop -g_z00(k))/zdamp
 Tmpv1 =(ztop -z00(k))/zdamp

 g_dcoef =-(0.0 +g_Tmpv1 -(0.0 -g_Tmpv1)*sign(1.0, 1.0 -(Tmpv1)))*0.5
 dcoef =1.0 -min(1.0,Tmpv1)

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =0.5*pii*g_dcoef +0.5*g_pii*dcoef 
 g_Tmpv1 =0.5*pii*g_dcoef
 Tmpv1 =0.5*pii*dcoef

 g_dcoef =2.0*(g_Tmpv1*cos(Tmpv1))*(sin(Tmpv1))
 dcoef =(sin(Tmpv1))**2

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =dcoef*g_dampcoef +g_dcoef*dampcoef 
 g_Tmpv1 =g_dcoef*dampcoef 
 Tmpv1 =dcoef*dampcoef

 g_Tmpv2 =muv(i,j)*(g_Tmpv1) +g_muv(i,j)*(Tmpv1) 
 Tmpv2 =muv(i,j)*(Tmpv1)

 g_Tmpv3 =Tmpv2*(g_v(i,k,j) -g_v00(k)) +g_Tmpv2*(v(i,k,j) -v00(k)) 
 Tmpv3 =Tmpv2*(v(i,k,j) -v00(k))

 g_rv_tendf(i,k,j) =g_rv_tendf(i,k,j) -g_Tmpv3
 rv_tendf(i,k,j) =rv_tendf(i,k,j) -Tmpv3

 ENDDO
 ENDDO
 ENDDO

 DO j =jts,min(jte,jde-1)
 DO i =its,min(ite,ide-1)

! Revised by Ning Pan, 2010-07-23
! g_ztop =(g_phb(i,kde,j) +g_ph(i,kde,j))/g
 g_ztop =g_ph(i,kde,j)/g
 ztop =(phb(i,kde,j) +ph(i,kde,j))/g

 DO k =kts,min(kte,kde)

! Revised by Ning Pan, 2010-07-23
! g_z =(g_phb(i,k,j) +g_ph(i,k,j))/g
 g_z =g_ph(i,k,j)/g
 z =(phb(i,k,j) +ph(i,k,j))/g

 IF( z >= (ztop-zdamp) ) THEN

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =((g_ztop -g_z)*zdamp -g_zdamp*(ztop -z))/(zdamp*zdamp) 
 g_Tmpv1 =(g_ztop -g_z)/zdamp
 Tmpv1 =(ztop -z)/zdamp

 g_dcoef =-(0.0 +g_Tmpv1 -(0.0 -g_Tmpv1)*sign(1.0, 1.0 -(Tmpv1)))*0.5
 dcoef =1.0 -min(1.0,Tmpv1)

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =0.5*pii*g_dcoef +0.5*g_pii*dcoef 
 g_Tmpv1 =0.5*pii*g_dcoef
 Tmpv1 =0.5*pii*dcoef

 g_dcoef =2.0*(g_Tmpv1*cos(Tmpv1))*(sin(Tmpv1))
 dcoef =(sin(Tmpv1))**2

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =dcoef*g_dampcoef +g_dcoef*dampcoef 
 g_Tmpv1 =g_dcoef*dampcoef 
 Tmpv1 =dcoef*dampcoef

 g_Tmpv2 =mut(i,j)*(g_Tmpv1) +g_mut(i,j)*(Tmpv1) 
 Tmpv2 =mut(i,j)*(Tmpv1)

 g_Tmpv3 =Tmpv2*g_w(i,k,j) +g_Tmpv2*w(i,k,j) 
 Tmpv3 =Tmpv2*w(i,k,j)

 g_rw_tendf(i,k,j) =g_rw_tendf(i,k,j) -g_Tmpv3
 rw_tendf(i,k,j) =rw_tendf(i,k,j) -Tmpv3

 END IF
 ENDDO
 ENDDO
 ENDDO

 DO j =jts,min(jte,jde-1)
 DO i =its,min(ite,ide-1)

! Revised by Ning Pan, 2010-07-23
! g_ztop =(g_phb(i,kde,j) +g_ph(i,kde,j))/g
 g_ztop =g_ph(i,kde,j)/g
 ztop =(phb(i,kde,j) +ph(i,kde,j))/g

 k1 =ktf

 g_z =g_ztop
 z =ztop

!This line is fail to be recognized
       DO WHILE( z >= (ztop-zdamp) )

! Revised by Ning Pan, 2010-07-23
! g_z =0.5*(g_phb(i,k1,j) +g_phb(i,k1+1,j) +g_ph(i,k1,j) +g_ph(i,k1+1,j))/g
 g_z =0.5*(g_ph(i,k1,j) +g_ph(i,k1+1,j))/g
 z =0.5*(phb(i,k1,j) +phb(i,k1+1,j) +ph(i,k1,j) +ph(i,k1+1,j))/g

 g_z00(k1) =g_z
 z00(k1) =z

 k1 =k1-1
 ENDDO

 k1 =k1+2

 DO k =k1,ktf

 k2 =ktf

 DO WHILE(z_base(k2) .gt. z00(k))

 k2 =k2-1
 ENDDO

 IF(k2+1.gt.ktf) THEN

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =(t_base(k2) -t_base(k2-1))*(g_z00(k) -g_z_base(k2)) +(g_t_base( &
! k2) -g_t_base(k2-1))*(z00(k) -z_base(k2)) 
 g_Tmpv1 =(t_base(k2) -t_base(k2-1))*g_z00(k)
 Tmpv1 =(t_base(k2) -t_base(k2-1))*(z00(k) -z_base(k2))

! Revised by Ning Pan, 2010-07-23
! g_Tmpv2 =(g_Tmpv1*(z_base(k2) -z_base(k2-1)) -(g_z_base(k2) -g_z_base( &
! k2-1))*Tmpv1)/((z_base(k2) -z_base(k2-1))*(z_base(k2) -z_base(k2-1))) 
 g_Tmpv2 =g_Tmpv1/(z_base(k2) -z_base(k2-1))
 Tmpv2 =Tmpv1/(z_base(k2) -z_base(k2-1))

! Revised by Ning Pan, 2010-07-23
! g_t00(k) =g_t_base(k2) +g_Tmpv2
 g_t00(k) =g_Tmpv2
 t00(k) =t_base(k2) +Tmpv2

 else

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =(t_base(k2+1) -t_base(k2))*(g_z00(k) -g_z_base(k2)) +(g_t_base( &
! k2+1) -g_t_base(k2))*(z00(k) -z_base(k2)) 
 g_Tmpv1 =(t_base(k2+1) -t_base(k2))*g_z00(k)
 Tmpv1 =(t_base(k2+1) -t_base(k2))*(z00(k) -z_base(k2))

! Revised by Ning Pan, 2010-07-23
! g_Tmpv2 =(g_Tmpv1*(z_base(k2+1) -z_base(k2)) -(g_z_base(k2+1) &
! -g_z_base(k2))*Tmpv1)/((z_base(k2+1) -z_base(k2))*(z_base(k2+1) -z_base(k2))) 
 g_Tmpv2 =g_Tmpv1/(z_base(k2+1) -z_base(k2))
 Tmpv2 =Tmpv1/(z_base(k2+1) -z_base(k2))

! Revised by Ning Pan, 2010-07-23
! g_t00(k) =g_t_base(k2) +g_Tmpv2
 g_t00(k) =g_Tmpv2
 t00(k) =t_base(k2) +Tmpv2

 endif
 ENDDO

 DO k =k1,ktf

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =((g_ztop -g_z00(k))*zdamp -g_zdamp*(ztop -z00(k)))/(zdamp*zdamp) 
 g_Tmpv1 =(g_ztop -g_z00(k))/zdamp
 Tmpv1 =(ztop -z00(k))/zdamp

 g_dcoef =-(0.0 +g_Tmpv1 -(0.0 -g_Tmpv1)*sign(1.0, 1.0 -(Tmpv1)))*0.5
 dcoef =1.0 -min(1.0,Tmpv1)

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =0.5*pii*g_dcoef +0.5*g_pii*dcoef 
 g_Tmpv1 =0.5*pii*g_dcoef
 Tmpv1 =0.5*pii*dcoef

 g_dcoef =2.0*(g_Tmpv1*cos(Tmpv1))*(sin(Tmpv1))
 dcoef =(sin(Tmpv1))**2

! Revised by Ning Pan, 2010-07-23
! g_Tmpv1 =dcoef*g_dampcoef +g_dcoef*dampcoef 
 g_Tmpv1 =g_dcoef*dampcoef 
 Tmpv1 =dcoef*dampcoef

 g_Tmpv2 =mut(i,j)*(g_Tmpv1) +g_mut(i,j)*(Tmpv1) 
 Tmpv2 =mut(i,j)*(Tmpv1)

 g_Tmpv3 =Tmpv2*(g_t(i,k,j) -g_t00(k)) +g_Tmpv2*(t(i,k,j) -t00(k)) 
 Tmpv3 =Tmpv2*(t(i,k,j) -t00(k))

 g_t_tendf(i,k,j) =g_t_tendf(i,k,j) -g_Tmpv3
 t_tendf(i,k,j) =t_tendf(i,k,j) -Tmpv3

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_rk_rayleigh_damp

!        Generated by TAPENADE     (INRIA, Tropics team)
!  Tapenade 3.5 (r3805) - 29 Mar 2011 12:57
!
!  Differentiation of theta_relaxation in forward (tangent) mode:
!   variations   of useful results: t_tendf
!   with respect to varying inputs: t ph t_tendf mut
!   RW status of diff variables: t:in ph:in t_tendf:in-out mut:in
SUBROUTINE G_THETA_RELAXATION(t_tendf, t_tendfd, t, td, t_init, mut, &
&  mutd, ph, phd, phb, t_base, z_base, ids, ide, jds, jde, kds, kde, ims&
&  , ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
  IMPLICIT NONE
  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(INOUT) :: t_tendf
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: t_tendfd
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: t, t_init, &
&  ph, phb
  REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: td, phd
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mut
  REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mutd
  REAL, DIMENSION(kms:kme), INTENT(IN) :: t_base, z_base
! Local variables.
  INTEGER :: i, j, k, ktf, k2
  REAL :: tau_r, rmax, rmin, inv_tau_r, inv_g, rterm
  REAL :: rtermd
  REAL, DIMENSION(kms:kme) :: z00, t00
  REAL, DIMENSION(kms:kme) :: z00d, t00d
  INTEGER :: min2
  INTEGER :: min1
! End declarations.
!-----------------------------------------------------------------------
! set tau_r to 12 h, following RE87
  tau_r = 12.0*3600.0
! limit rterm to +/- 2 K/day
  rmax = 2.0/86400.0
  rmin = -rmax
  IF (kte .GT. kde - 1) THEN
    ktf = kde - 1
  ELSE
    ktf = kte
  END IF
  inv_tau_r = 1.0/tau_r
  inv_g = 1.0/g
  IF (jte .GT. jde - 1) THEN
    min1 = jde - 1
    t00d = 0.0
    z00d = 0.0
  ELSE
    min1 = jte
    t00d = 0.0
    z00d = 0.0
  END IF
!-----------------------------------------------------------------------
! Adjust potential temperature to base state.
  DO j=jts,min1
    IF (ite .GT. ide - 1) THEN
      min2 = ide - 1
    ELSE
      min2 = ite
    END IF
    DO i=its,min2
! Get height of model levels:
      DO k=kts,ktf
        z00d(k) = 0.5*inv_g*(phd(i, k, j)+phd(i, k+1, j))
        z00(k) = 0.5*(phb(i, k, j)+phb(i, k+1, j)+ph(i, k, j)+ph(i, k+1&
&          , j))*inv_g
      END DO
! Get reference state:
      DO k=kts,ktf
        k2 = ktf
        DO WHILE (z_base(k2) .GT. z00(k) .AND. k2 .GT. 1)
          k2 = k2 - 1
        END DO
        IF (k2 + 1 .GT. ktf) THEN
          t00d(k) = (t_base(k2)-t_base(k2-1))*z00d(k)/(z_base(k2)-z_base&
&            (k2-1))
          t00(k) = t_base(k2) + (t_base(k2)-t_base(k2-1))*(z00(k)-z_base&
&            (k2))/(z_base(k2)-z_base(k2-1))
        ELSE
          t00d(k) = (t_base(k2+1)-t_base(k2))*z00d(k)/(z_base(k2+1)-&
&            z_base(k2))
          t00(k) = t_base(k2) + (t_base(k2+1)-t_base(k2))*(z00(k)-z_base&
&            (k2))/(z_base(k2+1)-z_base(k2))
        END IF
      END DO
! Apply the RE87 R term:
      DO k=kts,ktf
        rtermd = -(inv_tau_r*(td(i, k, j)-t00d(k)))
        rterm = -((t(i, k, j)-t00(k))*inv_tau_r)
        IF (rterm .GT. rmax) THEN
          rterm = rmax
          rtermd = 0.0
        ELSE
          rterm = rterm
        END IF
        IF (rterm .LT. rmin) THEN
          rterm = rmin
          rtermd = 0.0
        ELSE
          rterm = rterm
        END IF
        t_tendfd(i, k, j) = t_tendfd(i, k, j) + mutd(i, j)*rterm + mut(i&
&          , j)*rtermd
        t_tendf(i, k, j) = t_tendf(i, k, j) + mut(i, j)*rterm
      END DO
    END DO
  END DO
END SUBROUTINE G_THETA_RELAXATION

 SUBROUTINE g_sixth_order_diffusion(name,field,g_field,tendency,g_tendency, &
! Revised by Ning Pan, 2010-07-23
! mu,g_mu,dt,g_dt,config_flags,diff_6th_opt,diff_6th_factor,g_diff_6th_factor, &
 mu,g_mu,dt,config_flags,diff_6th_opt,diff_6th_factor, &
 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
 INTEGER :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte
 TYPE(grid_config_rec_type) :: config_flags
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: tendency,g_tendency
 REAL,DIMENSION(ims:ime,kms:kme,jms:jme) :: field,g_field
 REAL,DIMENSION(ims:ime,jms:jme) :: mu,g_mu
! Revised by Ning Pan, 2010-07-23
! REAL :: dt,g_dt
! REAL :: diff_6th_factor,g_diff_6th_factor
 REAL :: dt
 REAL :: diff_6th_factor
 INTEGER :: diff_6th_opt
 CHARACTER (LEN=1) :: name
 INTEGER :: i,j,k,i_start,i_end,j_start,j_end,k_start,k_end,ktf
 REAL :: dflux_x_p0,g_dflux_x_p0,dflux_y_p0,g_dflux_y_p0,dflux_x_p1, &
 g_dflux_x_p1,dflux_y_p1,g_dflux_y_p1,tendency_x,g_tendency_x,tendency_y, &
! Revised by Ning Pan, 2010-07-23
! g_tendency_y,mu_avg_p0,g_mu_avg_p0,mu_avg_p1,g_mu_avg_p1,diff_6th_coef, &
! g_diff_6th_coef
 g_tendency_y,mu_avg_p0,g_mu_avg_p0,mu_avg_p1,g_mu_avg_p1,diff_6th_coef
 LOGICAL :: specified

! Remarked by Ning Pan, 2010-07-23
! g_Tmpv1 =(g_diff_6th_factor*0.015625*(2.0*dt) -(2.0*g_dt)*diff_6th_factor* &
! 0.015625)/((2.0*dt)*(2.0*dt)) 
 Tmpv1 =diff_6th_factor*0.015625/(2.0*dt)

! Remarked by Ning Pan, 2010-07-23
! g_diff_6th_coef =g_Tmpv1
 diff_6th_coef =Tmpv1

 ktf =min(kte,kde-1)

 IF( name .EQ. 'u' ) THEN

 i_start =its

 i_end =ite

 j_start =jts

 j_end =min(jde-1,jte)

 k_start =kts

 k_end =ktf
 ELSE IF( name .EQ. 'v' ) THEN

 i_start =its

 i_end =min(ide-1,ite)

 j_start =jts

 j_end =jte

 k_start =kts

 k_end =ktf
 ELSE IF( name .EQ. 'w' ) THEN

 i_start =its

 i_end =min(ide-1,ite)

 j_start =jts

 j_end =min(jde-1,jte)

 k_start =kts+1

 k_end =ktf
 ELSE

 i_start =its

 i_end =min(ide-1,ite)

 j_start =jts

 j_end =min(jde-1,jte)

 k_start =kts

 k_end =ktf
 ENDIF

 DO j =j_start,j_end
 DO k =k_start,k_end
 DO i =i_start,i_end

 g_dflux_x_p0 =(10.0*(g_field(i,k,j) -g_field(i-1,k,j)) -5.0*(g_field(i+1, &
 k,j) -g_field(i-2,k,j)) +(g_field(i+2,k,j) -g_field(i-3,k,j)))
 dflux_x_p0 =(10.0*(field(i,k,j) -field(i-1,k,j)) -5.0*(field(i+1,k,j) -field(i-2,k, &
 j)) +(field(i+2,k,j) -field(i-3,k,j)))

 g_dflux_x_p1 =(10.0*(g_field(i+1,k,j) -g_field(i,k,j)) -5.0*(g_field(i+2, &
 k,j) -g_field(i-1,k,j)) +(g_field(i+3,k,j) -g_field(i-2,k,j)))
 dflux_x_p1 =(10.0*(field(i+1,k,j) -field(i,k,j)) -5.0*(field(i+2,k,j) -field(i-1,k, &
 j)) +(field(i+3,k,j) -field(i-2,k,j)))

 IF( diff_6th_opt .EQ. 2 ) THEN

 IF( dflux_x_p0 * ( field(i  ,k,j)-field(i-1,k,j) ) .LE. 0.0 ) THEN

 g_dflux_x_p0 =0.0
 dflux_x_p0 =0.0

 END IF

 IF( dflux_x_p1 * ( field(i+1,k,j)-field(i  ,k,j) ) .LE. 0.0 ) THEN

 g_dflux_x_p1 =0.0
 dflux_x_p1 =0.0

 END IF
 END IF

 IF( name .EQ. 'u' ) THEN

 g_mu_avg_p0 =g_mu(i-1,j)
 mu_avg_p0 =mu(i-1,j)

 g_mu_avg_p1 =g_mu(i,j)
 mu_avg_p1 =mu(i,j)

 ELSE IF( name .EQ. 'v' ) THEN

 g_mu_avg_p0 =0.25*(g_mu(i-1,j-1) +g_mu(i,j-1) +g_mu(i-1,j) +g_mu(i,j))
 mu_avg_p0 =0.25*(mu(i-1,j-1) +mu(i,j-1) +mu(i-1,j) +mu(i,j))

 g_mu_avg_p1 =0.25*(g_mu(i,j-1) +g_mu(i+1,j-1) +g_mu(i,j) +g_mu(i+1,j))
 mu_avg_p1 =0.25*(mu(i,j-1) +mu(i+1,j-1) +mu(i,j) +mu(i+1,j))

 ELSE

 g_mu_avg_p0 =0.5*(g_mu(i-1,j) +g_mu(i,j))
 mu_avg_p0 =0.5*(mu(i-1,j) +mu(i,j))

 g_mu_avg_p1 =0.5*(g_mu(i,j) +g_mu(i+1,j))
 mu_avg_p1 =0.5*(mu(i,j) +mu(i+1,j))

 END IF

 g_Tmpv1 =mu_avg_p1*g_dflux_x_p1 +g_mu_avg_p1*dflux_x_p1 
 Tmpv1 =mu_avg_p1*dflux_x_p1

 g_Tmpv2 =mu_avg_p0*g_dflux_x_p0 +g_mu_avg_p0*dflux_x_p0 
 Tmpv2 =mu_avg_p0*dflux_x_p0

! Revised by Ning Pan, 2010-07-23
! g_Tmpv3 =diff_6th_coef*((g_Tmpv1) -(g_Tmpv2)) +g_diff_6th_coef*((Tmpv1) -(Tmpv2)) 
 g_Tmpv3 =diff_6th_coef*((g_Tmpv1) -(g_Tmpv2))
 Tmpv3 =diff_6th_coef*((Tmpv1) -(Tmpv2))

 g_tendency_x =g_Tmpv3
 tendency_x =Tmpv3

 g_dflux_y_p0 =(10.0*(g_field(i,k,j) -g_field(i,k,j-1)) -5.0*(g_field(i,k, &
 j+1) -g_field(i,k,j-2)) +(g_field(i,k,j+2) -g_field(i,k,j-3)))
 dflux_y_p0 =(10.0*(field(i,k,j) -field(i,k,j-1)) -5.0*(field(i,k,j+1) -field(i,k,j- &
 2)) +(field(i,k,j+2) -field(i,k,j-3)))

 g_dflux_y_p1 =(10.0*(g_field(i,k,j+1) -g_field(i,k,j)) -5.0*(g_field(i,k, &
 j+2) -g_field(i,k,j-1)) +(g_field(i,k,j+3) -g_field(i,k,j-2)))
 dflux_y_p1 =(10.0*(field(i,k,j+1) -field(i,k,j)) -5.0*(field(i,k,j+2) -field(i,k,j- &
 1)) +(field(i,k,j+3) -field(i,k,j-2)))

 IF( diff_6th_opt .EQ. 2 ) THEN

 IF( dflux_y_p0 * ( field(i,k,j  )-field(i,k,j-1) ) .LE. 0.0 ) THEN

 g_dflux_y_p0 =0.0
 dflux_y_p0 =0.0

 END IF

 IF( dflux_y_p1 * ( field(i,k,j+1)-field(i,k,j  ) ) .LE. 0.0 ) THEN

 g_dflux_y_p1 =0.0
 dflux_y_p1 =0.0

 END IF
 END IF

 IF( name .EQ. 'u' ) THEN

 g_mu_avg_p0 =0.25*(g_mu(i-1,j-1) +g_mu(i,j-1) +g_mu(i-1,j) +g_mu(i,j))
 mu_avg_p0 =0.25*(mu(i-1,j-1) +mu(i,j-1) +mu(i-1,j) +mu(i,j))

 g_mu_avg_p1 =0.25*(g_mu(i-1,j) +g_mu(i,j) +g_mu(i-1,j+1) +g_mu(i,j+1))
 mu_avg_p1 =0.25*(mu(i-1,j) +mu(i,j) +mu(i-1,j+1) +mu(i,j+1))

 ELSE IF( name .EQ. 'v' ) THEN

 g_mu_avg_p0 =g_mu(i,j-1)
 mu_avg_p0 =mu(i,j-1)

 g_mu_avg_p1 =g_mu(i,j)
 mu_avg_p1 =mu(i,j)

 ELSE

 g_mu_avg_p0 =0.5*(g_mu(i,j-1) +g_mu(i,j))
 mu_avg_p0 =0.5*(mu(i,j-1) +mu(i,j))

 g_mu_avg_p1 =0.5*(g_mu(i,j) +g_mu(i,j+1))
 mu_avg_p1 =0.5*(mu(i,j) +mu(i,j+1))

 END IF

 g_Tmpv1 =mu_avg_p1*g_dflux_y_p1 +g_mu_avg_p1*dflux_y_p1 
 Tmpv1 =mu_avg_p1*dflux_y_p1

 g_Tmpv2 =mu_avg_p0*g_dflux_y_p0 +g_mu_avg_p0*dflux_y_p0 
 Tmpv2 =mu_avg_p0*dflux_y_p0

! Revised by Ning Pan, 2010-07-23
! g_Tmpv3 =diff_6th_coef*((g_Tmpv1) -(g_Tmpv2)) +g_diff_6th_coef*((Tmpv1) -(Tmpv2)) 
 g_Tmpv3 =diff_6th_coef*((g_Tmpv1) -(g_Tmpv2))
 Tmpv3 =diff_6th_coef*((Tmpv1) -(Tmpv2))

 g_tendency_y =g_Tmpv3
 tendency_y =Tmpv3

 g_tendency(i,k,j) =g_tendency(i,k,j) +g_tendency_x +g_tendency_y
 tendency(i,k,j) =tendency(i,k,j) +tendency_x +tendency_y

 ENDDO
 ENDDO
 ENDDO

 END SUBROUTINE g_sixth_order_diffusion

 END MODULE g_module_big_step_utilities_em