/*
** (c) 1996-2000 The Regents of the University of California (through
** E.O. Lawrence Berkeley National Laboratory), subject to approval by
** the U.S. Department of Energy.  Your use of this software is under
** license -- the license agreement is attached and included in the
** directory as license.txt or you may contact Berkeley Lab's Technology
** Transfer Department at TTD@lbl.gov.  NOTICE OF U.S. GOVERNMENT RIGHTS.
** The Software was developed under funding from the U.S. Government
** which consequently retains certain rights as follows: the
** U.S. Government has been granted for itself and others acting on its
** behalf a paid-up, nonexclusive, irrevocable, worldwide license in the
** Software to reproduce, prepare derivative works, and perform publicly
** and display publicly.  Beginning five (5) years after the date
** permission to assert copyright is obtained from the U.S. Department of
** Energy, and subject to any subsequent five (5) year renewals, the
** U.S. Government is granted for itself and others acting on its behalf
** a paid-up, nonexclusive, irrevocable, worldwide license in the
** Software to reproduce, prepare derivative works, distribute copies to
** the public, perform publicly and display publicly, and to permit
** others to do so.
*/

c
c $Id: GODUNOV_3D.F,v 1.3 2001/02/14 19:05:36 lijewski Exp $
c

#undef  BL_LANG_CC
#ifndef BL_LANG_FORT
#define BL_LANG_FORT
#endif

#include "REAL.H"
#include "CONSTANTS.H"
#include "BC_TYPES.H"
#include "GODUNOV_F.H"
#include "ArrayLim.H"
#include "integrator.fh"
      
#if defined(BL_USE_FLOAT) || defined(BL_T3E)
#define  BL_USE_FLOAT_CONST
#define  onetominussix 1.0e-6
#define  onepointfour  1.4
#endif
#if defined(BL_USE_DOUBLE) && ! defined(BL_T3E)
#define  BL_USE_DOUBLE_CONST
#define  onetominussix 1.0d-6
#define  onepointfour  1.4d+00
#endif

#define SDIM 3
#define NGHOST 3
#define LEFT	 0
#define RIGHT	 1
#define BOTTOM	 2
#define TOP 	 3
#define FRONT	 4
#define BACK 	 5
#define INTERIOR -1
#define ON_PHYS_B 0
#define NTHERM   6
#define NQ	 (6+NADV)

#if __STDC__==1
#define BL_ARGL1(u) u##_l1
#define BL_ARGL2(u) u##_l2
#define BL_ARGL3(u) u##_l3
#define BL_ARGH1(u) u##_h1
#define BL_ARGH2(u) u##_h2
#define BL_ARGH3(u) u##_h3
#define BL_IARG(u) u##_l1, u##_l2, u##_l3, u##_h1, u##_h2, u##_h3
#define BL_UVAR(u,v) REAL_T u(v##_l1:v##_h1, v##_l2:v##_h2, v##_l3:v##_h3)
#else
#define BL_ARGL1(u) u/**/_l1
#define BL_ARGL2(u) u/**/_l2
#define BL_ARGL3(u) u/**/_l3
#define BL_ARGH1(u) u/**/_h1
#define BL_ARGH2(u) u/**/_h2
#define BL_ARGH3(u) u/**/_h3
#define BL_IARG(u) u/**/_l1, u/**/_l2, u/**/_l3, u/**/_h1, u/**/_h2, u/**/_h3
#define BL_UVAR(u,v) REAL_T u(v/**/_l1:v/**/_h1, v/**/_l2:v/**/_h2, v/**/_l3:v/**/_h3)
#endif

c
c From ArrayLim.H ...
c

#define BL_FARG(u) u, DIMS(u)
#define BL_FBOUNDS(u) integer DIMDEC(u)
#define BL_FARRAY(u,n) REAL_T u(DIMV(u), n)
#define BL_FARRAY1(u) REAL_T u(DIMV(u))

#if __STDC__==1
#define BL_BARG(b) b##lo, b##hi
#define BL_BBOUNDS(b) integer b##lo(3), b##hi(3)
#else
#define BL_BARG(b) b/**/lo, b/**/hi
#define BL_BBOUNDS(b) integer b/**/lo(3), b/**/hi(3)
#endif

c 
c ---------------------------------------------------------------
c::  Characteristic tracing for hyperbolic conservation law
c::  Arguments:
c::  q         => field of primitive variables
c::  qx        => x-slopes of primitive variables
c::  c         => sound speed                         
c::  enth     <=  enthalpy
c::  qbarl    <=  left-edge traced state     
c::  qbarr    <=  right-edge traced state   
c::  bxlo,bxhi => index limits of grid interior
c::  bc        => array of bndry condition flags
c::  delta     => cell size
c::  dt        => timestep size
c::  nvar      => number of characteristic variables
c ---------------------------------------------------------------
c ::: these give meaning to the primitive variable components
#define  QRHO    1
#define  QVEL1   2
#define  QVEL2   3
#define  QVEL3   4
#define  QPRES   5
#define  QRHOE   6
#if(NADV>0)
#define  QADV    7
#endif

      subroutine FORT_XTRACE(
     &          BL_FARG(q),
     &          BL_FARG(qx),
     &          BL_FARG(c),
     &          BL_FARG(enth),
     &          BL_FARG(qbarl),
     &          BL_FARG(qbarr),
     &          BL_FARG(dloga),
     &          BL_FARG(courno),
     &          BL_BARG(bx),
     &          delta, dt, bc, gBndry, nvar
     &		)

      integer nvar, gBndry(0:2*SDIM-1)
      integer bc(SDIM,2,nvar-1),qbc(SDIM,2,NQ)
      REAL_T  delta(SDIM), dt
      BL_FBOUNDS(q)
      BL_FARRAY(q,nvar)
      BL_FBOUNDS(qx)
      BL_FARRAY(qx,nvar)
      BL_FBOUNDS(qbarl)
      BL_FARRAY(qbarl,nvar)
      BL_FBOUNDS(qbarr)
      BL_FARRAY(qbarr,nvar)
      BL_FBOUNDS(c)
      BL_FARRAY1(c)
      BL_FBOUNDS(enth)
      BL_FARRAY1(enth)
      BL_FBOUNDS(dloga)
      BL_FARRAY1(dloga)
      BL_FBOUNDS(courno)
      BL_FARRAY1(courno)
      BL_BBOUNDS(bx)

      integer i, j, k, n, nbc
      integer is, ie, js, je, ks, ke, isedg, ieedg,jsedg,jeedg
      integer ksedg, keedg
      REAL_T  dx, dy, dz
      REAL_T spvol, dtbydx, scr, eken, eta, dthalf
      REAL_T sourcp, sourcr, source, avgarea
      REAL_T alpham, alphap, alpha0r, alpha0e
      REAL_T alpha0v1,alpha0v2
      REAL_T spminus, spplus, spzero
      REAL_T apright, amright
      REAL_T apleft, amleft
      REAL_T azrright, azeright, azv1rght,azv2rght
      REAL_T azrleft, azeleft, azv1left,azv2left
      REAL_T smallr
      REAL_T reflect
      
      REAL_T gdum,csdum,pdum
      integer iv

c     ::: some useful macro definitions
#     define U(i,j,k) 		q(i,j,k,QVEL1)
#     define V(i,j,k) 		q(i,j,k,QVEL2)
#     define W(i,j,k) 		q(i,j,k,QVEL3)
#     define P(i,j,k) 		q(i,j,k,QPRES)
#     define RHO(i,j,k) 	q(i,j,k,QRHO)
#     define RHOE(i,j,k) 	q(i,j,k,QRHOE)
#if(NADV>0)
#     define ADV(i,j,k) 	q(i,j,k,QADV)
#endif
#     define DU(i,j,k) 		qx(i,j,k,QVEL1)
#     define DV(i,j,k) 		qx(i,j,k,QVEL2)
#     define DW(i,j,k) 		qx(i,j,k,QVEL3)
#     define DP(i,j,k) 		qx(i,j,k,QPRES)
#     define DRHO(i,j,k) 	qx(i,j,k,QRHO)
#     define DRHOE(i,j,k)	qx(i,j,k,QRHOE)
#if(NADV>0)
#     define DADV(i,j,k)	qx(i,j,k,QADV)
#endif
        
      dx = delta(1)
      dy = delta(2)
      dz = delta(3)
      is = bxlo(1)
      ie = bxhi(1)
      js = bxlo(2)
      je = bxhi(2)
      ks = bxlo(3)
      ke = bxhi(3)
      isedg = qbarl_l1 
      ieedg = qbarl_h1 
      jsedg = qbarl_l2 
      jeedg = qbarl_h2 
      ksedg = qbarl_l3 
      keedg = qbarl_h3

      smallr = onetominussix
      dtbydx = dt/dx

c ::: convert energy to intensive form for eos call
c     do k = ks,ke
c      do j = js,je
c       do i =is,ie
c  RHOE(i,j,k) = RHOE(i,j,k)/RHO(i,j,k)
c       enddo
c      enddo
c     enddo

c     convert energy to extensive form and compute courant number
      do k = ks,ke
       do j = js,je
        do i =is,ie
c  RHOE(i,j,k) = RHOE(i,j,k)*RHO(i,j,k)
          courno(i,j,k) = dtbydx*(c(i,j,k)+abs(U(i,j,k)))       
        enddo
       enddo
      enddo

c     characteristic analysis
      do k = ksedg,keedg
       do j = jsedg,jeedg
        do i = isedg,ieedg-1
          enth(i,j,k) = (RHOE(i,j,k)/RHO(i,j,k) +
     $                 P(i,j,k)/RHO(i,j,k))/c(i,j,k)**2
          alpham = half*(DP(i,j,k)/(RHO(i,j,k)*c(i,j,k)) - DU(i,j,k))*RHO(i,j,k)
     $    /c(i,j,k)
          alphap = half*(DP(i,j,k)/(RHO(i,j,k)*c(i,j,k)) + DU(i,j,k))*RHO(i,j,k)
     $    /c(i,j,k)
          alpha0r = DRHO(i,j,k) - DP(i,j,k)/c(i,j,k)**2
          alpha0e = DRHOE(i,j,k) - DP(i,j,k)*enth(i,j,k)
          alpha0v1 = DV(i,j,k)
          alpha0v2 = DW(i,j,k)

c ::: :::::  Right state of edge at left
          spminus = cvmgp(-one,(U(i,j,k) - c(i,j,k))*dtbydx,U(i,j,k) - c(i,j,k))
          spplus = cvmgp(-one,(U(i,j,k) + c(i,j,k))*dtbydx,U(i,j,k) + c(i,j,k))
          spzero = cvmgp(-one, U(i,j,k) *dtbydx,U(i,j,k) )
          apright = half*(-one - spplus )*alphap
          amright = half*(-one - spminus)*alpham
          azrright= half*(-one - spzero )*alpha0r
          azeright= half*(-one - spzero )*alpha0e
          azv1rght= half*(-one - spzero )*alpha0v1
          azv2rght= half*(-one - spzero )*alpha0v2
          qbarr(i,j,k,QRHO) = q(i,j,k,QRHO) + apright + amright + azrright
          qbarr(i,j,k,QRHO) = max(smallr, qbarr(i,j,k,QRHO))
          qbarr(i,j,k,QVEL1) = q(i,j,k,QVEL1) +
     $                      (apright - amright)*c(i,j,k)/RHO(i,j,k)
          qbarr(i,j,k,QVEL2) = q(i,j,k,QVEL2) + azv1rght
          qbarr(i,j,k,QVEL3) = q(i,j,k,QVEL3) + azv2rght
          qbarr(i,j,k,QPRES) = q(i,j,k,QPRES) +
     $                      (apright + amright)*c(i,j,k)**2
          qbarr(i,j,k,QRHOE) = q(i,j,k,QRHOE) + (apright +
     $                       amright)*enth(i,j,k)*c(i,j,k)**2 + azeright
#if(NADV>0)
          qbarr(i,j,k,QADV) = q(i,j,k,QADV)+half*(-one-spzero)*DADV(i,j,k)
#endif

c ::: :::::  Left state of edge at right

          spminus = cvmgp((U(i,j,k) - c(i,j,k))*dtbydx,one,U(i,j,k) - c(i,j,k))
          spplus = cvmgp((U(i,j,k) + c(i,j,k))*dtbydx,one,U(i,j,k) + c(i,j,k))
          spzero = cvmgp( U(i,j,k) *dtbydx,one,U(i,j,k) )
          apleft = half*(one - spplus )*alphap
          amleft = half*(one - spminus)*alpham
          azrleft= half*(one - spzero )*alpha0r
          azeleft= half*(one - spzero )*alpha0e
          azv1left= half*(one - spzero )*alpha0v1
          azv2left= half*(one - spzero )*alpha0v2
          qbarl(i+1,j,k,QRHO) = q(i,j,k,QRHO) + apleft + amleft + azrleft
          qbarl(i+1,j,k,QRHO) = max(smallr, qbarl(i+1,j,k,QRHO))
          qbarl(i+1,j,k,QVEL1) = q(i,j,k,QVEL1) +
     $                         (apleft - amleft)*c(i,j,k)/RHO(i,j,k)
          qbarl(i+1,j,k,QVEL2) = q(i,j,k,QVEL2) + azv1left
          qbarl(i+1,j,k,QVEL3) = q(i,j,k,QVEL3) + azv2left
          qbarl(i+1,j,k,QPRES) = q(i,j,k,QPRES) +
     $                         (apleft + amleft)*c(i,j,k)**2
          qbarl(i+1,j,k,QRHOE) = q(i,j,k,QRHOE) + (apleft + amleft)*
     $                         enth(i,j,k)*c(i,j,k)**2 + azeleft
#if(NADV>0)
          qbarl(i+1,j,k,QADV) = q(i,j,k,QADV)+half*(one-spzero)*DADV(i,j,k)
#endif
        enddo
       enddo
      enddo
          

c ::: Colella hack near R=0 singularity
      do k = ks,ke
       do j = js,je
        do i = is,ie
          if (dloga(i,j,k) .ne. zero) then
              eta = (one-courno(i,j,k))/(c(i,j,k)*dt*dloga(i,j,k))
              eta = min(one, eta)
              dloga(i,j,k) = dloga(i,j,k) * eta
          endif
        enddo
       enddo
      enddo

      dthalf = half*dt
c ::: add geometric source terms to traced states
      do k = ksedg,keedg
       do j = jsedg,jeedg
        do i = isedg,ieedg-1
          sourcr = -RHO(i,j,k)*dloga(i,j,k)*U(i,j,k)*dthalf
          sourcp = sourcr*c(i,j,k)**2
          source = sourcp*enth(i,j,k)
          qbarl(i+1,j,k,QRHO) = qbarl(i+1,j,k,QRHO) + sourcr
          qbarl(i+1,j,k,QRHO) = max(smallr, qbarl(i+1,j,k,QRHO))
          qbarl(i+1,j,k,QPRES) = qbarl(i+1,j,k,QPRES) + sourcp
          qbarl(i+1,j,k,QRHOE) = qbarl(i+1,j,k,QRHOE) + source
          qbarr(i,j,k,QRHO) = qbarr(i,j,k,QRHO) + sourcr
          qbarr(i,j,k,QRHO) = max(smallr, qbarr(i,j,k,QRHO))
          qbarr(i,j,k,QPRES) = qbarr(i,j,k,QPRES) + sourcp
          qbarr(i,j,k,QRHOE) = qbarr(i,j,k,QRHOE) + source
        enddo
       enddo
      enddo

c ::: convert energy back to intensive form 
c ::: for eos call in RIEMANN
c     do k = ks,ke
c      do j = js,je
c       do i =is,ie
c  RHOE(i,j,k) = RHOE(i,j,k)/RHO(i,j,k)
c       enddo
c     enddo
c     enddo


#undef U
#undef V
#undef W
#undef P
#undef RHO
#undef RHOE
#undef DU
#undef DV
#undef DW
#undef DP
#undef DRHO
#undef DRHOE
#if(NADV>0)
#undef DADV
#endif

      end


c 
c ---------------------------------------------------------------
c::  Y characteristic tracing for hyperbolic conservation law
c::  Arguments:
c::  q         => field of primitive variables
c::  qy        => x-slopes of primitive variables
c::  c         => sound speed                         
c::  enth     <=  enthalpy
c::  qbarl    <=  bottom-edge traced state     
c::  qbarr    <=  top-edge traced state   
c::  bxlo,bxhi => index limits of grid interior
c::  bc        => array of bndry condition flags
c::  delta     => cell size
c::  dt        => timestep size
c::  nvar      => number of characteristic variables
c ---------------------------------------------------------------
c ::: these give meaning to the primitive variable components
#define  QRHO    1
#define  QVEL1   2
#define  QVEL2   3
#define  QVEL3   4
#define  QPRES   5
#define  QRHOE   6
#if(NADV>0)
#define  QADV    7
#endif


      subroutine FORT_YTRACE(
     &          BL_FARG(q),
     &          BL_FARG(qy),
     &          BL_FARG(c),
     &          BL_FARG(enth),
     &          BL_FARG(qbarl),
     &          BL_FARG(qbarr),
     &          BL_FARG(dloga),
     &          BL_FARG(courno),
     &          BL_BARG(bx),
     &          delta, dt, bc, gBndry, nvar
     &		)

      integer nvar, gBndry(0:2*SDIM-1)
      integer bc(SDIM,2,nvar-1),qbc(SDIM,2,NQ)
      REAL_T  delta(SDIM), dt
      BL_FBOUNDS(q)
      BL_FARRAY(q,nvar)
      BL_FBOUNDS(qy)
      BL_FARRAY(qy,nvar)
      BL_FBOUNDS(qbarl)
      BL_FARRAY(qbarl,nvar)
      BL_FBOUNDS(qbarr)
      BL_FARRAY(qbarr,nvar)
      BL_FBOUNDS(c)
      BL_FARRAY1(c)
      BL_FBOUNDS(enth)
      BL_FARRAY1(enth)
      BL_FBOUNDS(dloga)
      BL_FARRAY1(dloga)
      BL_FBOUNDS(courno)
      BL_FARRAY1(courno)
      BL_BBOUNDS(bx)

      integer i, j,k, n, nbc
      integer is,ie,js,je,ks,ke,isedg,ieedg,jsedg,jeedg,ksedg,keedg
      REAL_T  dx, dy,dz
      REAL_T spvol, dtbydx, scr, eken, eta, dthalf
      REAL_T sourcp, sourcr, source, avgarea
      REAL_T alpham, alphap, alpha0r, alpha0e
      REAL_T alpha0v1,alpha0v2
      REAL_T spminus, spplus, spzero
      REAL_T apright, amright
      REAL_T apleft, amleft
      REAL_T azrright, azeright, azv1rght,azv2rght
      REAL_T azrleft, azeleft, azv1left,azv2left
      REAL_T smallr
      REAL_T reflect

      REAL_T gdum,csdum,pdum

c     ::: some useful macro definitions
#     define U(i,j,k) 		q(i,j,k,QVEL1)
#     define V(i,j,k) 		q(i,j,k,QVEL2)
#     define W(i,j,k) 		q(i,j,k,QVEL3)
#     define P(i,j,k) 		q(i,j,k,QPRES)
#     define RHO(i,j,k) 	q(i,j,k,QRHO)
#     define RHOE(i,j,k) 	q(i,j,k,QRHOE)
#if(NADV>0)
#     define ADV(i,j,k) 	q(i,j,k,QADV)
#endif
#     define DU(i,j,k)	 	qy(i,j,k,QVEL1)
#     define DV(i,j,k) 		qy(i,j,k,QVEL2)
#     define DW(i,j,k) 		qy(i,j,k,QVEL3)
#     define DP(i,j,k) 		qy(i,j,k,QPRES)
#     define DRHO(i,j,k) 	qy(i,j,k,QRHO)
#     define DRHOE(i,j,k)	qy(i,j,k,QRHOE)
#if(NADV>0)
#     define DADV(i,j,k)	qy(i,j,k,QADV)
#endif
        
      dx = delta(1)
      dy = delta(2)
      dz = delta(3)
      is = bxlo(1)
      ie = bxhi(1)
      js = bxlo(2)
      je = bxhi(2)
      ks = bxlo(3)
      ke = bxhi(3)

      isedg = qbarl_l1
      ieedg = qbarl_h1
      jsedg = qbarl_l2
      jeedg = qbarl_h2
      ksedg = qbarl_l3
      keedg = qbarl_h3



      smallr = onetominussix
      dtbydx = dt/dx

c ::: convert energy to intensive form for eos call
c     do k = ks,ke
c      do j = js,je
c       do i =is,ie
c  RHOE(i,j,k) = RHOE(i,j,k)/RHO(i,j,k)
c       enddo
c      enddo
c     enddo


c     convert energy back to extensive form and compute courant number
      do k = ks,ke
       do j = js,je
        do i =is,ie
c  RHOE(i,j,k) = RHOE(i,j,k)*RHO(i,j,k)
          courno(i,j,k) = dtbydx*(c(i,j,k)+abs(V(i,j,k)))       
        enddo
      enddo
      enddo

c     characteristic analysis
      do k = ksedg,keedg
       do j = jsedg,jeedg-1
        do i = isedg,ieedg
          enth(i,j,k) = (RHOE(i,j,k)/RHO(i,j,k) +
     $                 P(i,j,k)/RHO(i,j,k))/c(i,j,k)**2
          alpham = half*(DP(i,j,k)/(RHO(i,j,k)*c(i,j,k)) - DV(i,j,k))*RHO(i,j,k)
     $    /c(i,j,k)
          alphap = half*(DP(i,j,k)/(RHO(i,j,k)*c(i,j,k)) + DV(i,j,k))*RHO(i,j,k)
     $    /c(i,j,k)
          alpha0r = DRHO(i,j,k) - DP(i,j,k)/c(i,j,k)**2
          alpha0e = DRHOE(i,j,k) - DP(i,j,k)*enth(i,j,k)
          alpha0v1 = DU(i,j,k)
          alpha0v2 = DW(i,j,k)

c ::: :::::  Top state of edge at bottom
          spminus = cvmgp(-one,(V(i,j,k) - c(i,j,k))*dtbydx,V(i,j,k) - c(i,j,k))
          spplus = cvmgp(-one,(V(i,j,k) + c(i,j,k))*dtbydx,V(i,j,k) + c(i,j,k))
          spzero = cvmgp(-one, V(i,j,k) *dtbydx,V(i,j,k) )
          apright = half*(-one - spplus )*alphap
          amright = half*(-one - spminus)*alpham
          azrright= half*(-one - spzero )*alpha0r
          azeright= half*(-one - spzero )*alpha0e
          azv1rght= half*(-one - spzero )*alpha0v1
          azv2rght= half*(-one - spzero )*alpha0v2
          qbarr(i,j,k,QRHO) = q(i,j,k,QRHO) + apright + amright + azrright
          qbarr(i,j,k,QRHO) = max(smallr, qbarr(i,j,k,QRHO))
          qbarr(i,j,k,QVEL2) = q(i,j,k,QVEL2) +
     $                      (apright - amright)*c(i,j,k)/RHO(i,j,k)
          qbarr(i,j,k,QVEL1) = q(i,j,k,QVEL1) + azv1rght
          qbarr(i,j,k,QVEL3) = q(i,j,k,QVEL3) + azv2rght
          qbarr(i,j,k,QPRES) = q(i,j,k,QPRES) +
     $                      (apright + amright)*c(i,j,k)**2
          qbarr(i,j,k,QRHOE) = q(i,j,k,QRHOE) + (apright +
     $                       amright)*enth(i,j,k)*c(i,j,k)**2 + azeright
#if(NADV>0)
          qbarr(i,j,k,QADV) = q(i,j,k,QADV)+half*(-one-spzero)*DADV(i,j,k)
#endif

c ::: :::::  Bottom state of edge at top

          spminus = cvmgp((V(i,j,k) - c(i,j,k))*dtbydx,one,V(i,j,k) - c(i,j,k))
          spplus = cvmgp((V(i,j,k) + c(i,j,k))*dtbydx,one,V(i,j,k) + c(i,j,k))
          spzero = cvmgp( V(i,j,k) *dtbydx,one,V(i,j,k) )
          apleft = half*(one - spplus )*alphap
          amleft = half*(one - spminus)*alpham
          azrleft= half*(one - spzero )*alpha0r
          azeleft= half*(one - spzero )*alpha0e
          azv1left= half*(one - spzero )*alpha0v1
          azv2left= half*(one - spzero )*alpha0v2
          qbarl(i,j+1,k,QRHO) = q(i,j,k,QRHO) + apleft + amleft + azrleft
          qbarl(i,j+1,k,QRHO) = max(smallr, qbarl(i,j+1,k,QRHO))
          qbarl(i,j+1,k,QVEL2) = q(i,j,k,QVEL2) +
     $                         (apleft - amleft)*c(i,j,k)/RHO(i,j,k)
          qbarl(i,j+1,k,QVEL1) = q(i,j,k,QVEL1) + azv1left
          qbarl(i,j+1,k,QVEL3) = q(i,j,k,QVEL3) + azv2left
          qbarl(i,j+1,k,QPRES) = q(i,j,k,QPRES) +
     $                         (apleft + amleft)*c(i,j,k)**2
          qbarl(i,j+1,k,QRHOE) = q(i,j,k,QRHOE) + (apleft + amleft)*
     $                         enth(i,j,k)*c(i,j,k)**2 + azeleft
#if(NADV>0)
          qbarl(i,j+1,k,QADV) = q(i,j,k,QADV)+half*(one-spzero)*DADV(i,j,k)
#endif
        enddo
       enddo
      enddo
          

c ::: Colella hack near R=0 singularity
      do k = ks,ke
       do j = js,je
        do i = is,ie
          if (dloga(i,j,k) .ne. zero) then
              eta = (one-courno(i,j,k))/(c(i,j,k)*dt*dloga(i,j,k))
              eta = min(one, eta)
              dloga(i,j,k) = dloga(i,j,k) * eta
          endif
        enddo
       enddo
      enddo

      dthalf = half*dt
c ::: add geometric source terms to traced states
      do k = ksedg,keedg
       do j = jsedg,jeedg-1
        do i = isedg,ieedg
          sourcr = -RHO(i,j,k)*dloga(i,j,k)*V(i,j,k)*dthalf
          sourcp = sourcr*c(i,j,k)**2
          source = sourcp*enth(i,j,k)
          qbarl(i,j+1,k,QRHO) = qbarl(i,j+1,k,QRHO) + sourcr
          qbarl(i,j+1,k,QRHO) = max(smallr, qbarl(i,j+1,k,QRHO))
          qbarl(i,j+1,k,QPRES) = qbarl(i,j+1,k,QPRES) + sourcp
          qbarl(i,j+1,k,QRHOE) = qbarl(i,j+1,k,QRHOE) + source
          qbarr(i,j,k ,QRHO) = qbarr(i,j,k ,QRHO) + sourcr
          qbarr(i,j,k ,QRHO) = max(smallr, qbarr(i,j,k,QRHO))
          qbarr(i,j,k ,QPRES) = qbarr(i,j,k ,QPRES) + sourcp
          qbarr(i,j,k ,QRHOE) = qbarr(i,j,k ,QRHOE) + source
        enddo
       enddo
      enddo

c ::: convert energy back to intensive form 
c ::: for eos call in RIEMANN
c     do k = ks,ke
c      do j = js,je
c       do i =is,ie
c  RHOE(i,j,k) = RHOE(i,j,k)/RHO(i,j,k)
c       enddo
c      enddo
c     enddo

#undef U
#undef V
#undef W
#undef P
#undef RHO
#undef RHOE
#undef DU
#undef DV
#undef DW
#undef DP
#undef DRHO
#undef DRHOE
#if(NADV>0)
#undef DADV
#endif

      end

      subroutine FORT_ZTRACE(
     &          BL_FARG(q),
     &          BL_FARG(qz),
     &          BL_FARG(c),
     &          BL_FARG(enth),
     &          BL_FARG(qbarl),
     &          BL_FARG(qbarr),
     &          BL_FARG(dloga),
     &          BL_FARG(courno),
     &          BL_BARG(bx),
     &          delta, dt, bc, gBndry, nvar
     &		)

      integer nvar, gBndry(0:2*SDIM-1)
      integer bc(SDIM,2,nvar-1),qbc(SDIM,2,NQ)
      REAL_T  delta(SDIM), dt
      BL_FBOUNDS(q)
      BL_FARRAY(q,nvar)
      BL_FBOUNDS(qz)
      BL_FARRAY(qz,nvar)
      BL_FBOUNDS(qbarl)
      BL_FARRAY(qbarl,nvar)
      BL_FBOUNDS(qbarr)
      BL_FARRAY(qbarr,nvar)
      BL_FBOUNDS(c)
      BL_FARRAY1(c)
      BL_FBOUNDS(enth)
      BL_FARRAY1(enth)
      BL_FBOUNDS(dloga)
      BL_FARRAY1(dloga)
      BL_FBOUNDS(courno)
      BL_FARRAY1(courno)
      BL_BBOUNDS(bx)

      integer i, j,k, n, nbc
      integer is,ie,js,je,ks,ke,isedg,ieedg,jsedg,jeedg,ksedg,keedg
      REAL_T  dx, dy,dz
      REAL_T spvol, dtbydx, scr, eken, eta, dthalf
      REAL_T sourcp, sourcr, source, avgarea
      REAL_T alpham, alphap, alpha0r, alpha0e
      REAL_T alpha0v1,alpha0v2
      REAL_T spminus, spplus, spzero
      REAL_T apright, amright
      REAL_T apleft, amleft
      REAL_T azrright, azeright, azv1rght,azv2rght
      REAL_T azrleft, azeleft, azv1left,azv2left
      REAL_T smallr
      REAL_T reflect

      REAL_T gdum,csdum,pdum

c     ::: some useful macro definitions
#     define U(i,j,k) 		q(i,j,k,QVEL1)
#     define V(i,j,k) 		q(i,j,k,QVEL2)
#     define W(i,j,k) 		q(i,j,k,QVEL3)
#     define P(i,j,k) 		q(i,j,k,QPRES)
#     define RHO(i,j,k) 	q(i,j,k,QRHO)
#     define RHOE(i,j,k) 	q(i,j,k,QRHOE)
#if(NADV>0)
#     define ADV(i,j,k) 	q(i,j,k,QADV)
#endif
#     define DU(i,j,k)	 	qz(i,j,k,QVEL1)
#     define DV(i,j,k) 		qz(i,j,k,QVEL2)
#     define DW(i,j,k) 		qz(i,j,k,QVEL3)
#     define DP(i,j,k) 		qz(i,j,k,QPRES)
#     define DRHO(i,j,k) 	qz(i,j,k,QRHO)
#     define DRHOE(i,j,k)	qz(i,j,k,QRHOE)
#if(NADV>0)
#     define DADV(i,j,k)	qz(i,j,k,QADV)
#endif
        
      dx = delta(1)
      dy = delta(2)
      dz = delta(3)
      is = bxlo(1)
      ie = bxhi(1)
      js = bxlo(2)
      je = bxhi(2)
      ks = bxlo(3)
      ke = bxhi(3)

      isedg = qbarl_l1
      ieedg = qbarl_h1
      jsedg = qbarl_l2
      jeedg = qbarl_h2
      ksedg = qbarl_l3
      keedg = qbarl_h3

      smallr = onetominussix
      dtbydx = dt/dx

c ::: convert energy to intensive form for eos call
c     do k = ks,ke
c      do j = js,je
c       do i =is,ie
c  RHOE(i,j,k) = RHOE(i,j,k)/RHO(i,j,k)
c       enddo
c      enddo
c     enddo

c     convert energy back to extensive form and compute courant number
      do k = ks,ke
       do j = js,je
        do i =is,ie
c  RHOE(i,j,k) = RHOE(i,j,k)*RHO(i,j,k)
          courno(i,j,k) = dtbydx*(c(i,j,k)+abs(W(i,j,k)))       
        enddo
      enddo
      enddo

c     characteristic analysis
      do k = ksedg,keedg-1
       do j = jsedg,jeedg
        do i = isedg,ieedg
          enth(i,j,k) = (RHOE(i,j,k)/RHO(i,j,k) +
     $                 P(i,j,k)/RHO(i,j,k))/c(i,j,k)**2
          alpham = half*(DP(i,j,k)/(RHO(i,j,k)*c(i,j,k)) - DW(i,j,k))*RHO(i,j,k)
     $    /c(i,j,k)
          alphap = half*(DP(i,j,k)/(RHO(i,j,k)*c(i,j,k)) + DW(i,j,k))*RHO(i,j,k)
     $    /c(i,j,k)
          alpha0r = DRHO(i,j,k) - DP(i,j,k)/c(i,j,k)**2
          alpha0e = DRHOE(i,j,k) - DP(i,j,k)*enth(i,j,k)
          alpha0v1 = DU(i,j,k)
          alpha0v2 = DV(i,j,k)

c ::: :::::  Top state of edge at bottom
          spminus = cvmgp(-one,(W(i,j,k) - c(i,j,k))*dtbydx,W(i,j,k) - c(i,j,k))
          spplus = cvmgp(-one,(W(i,j,k) + c(i,j,k))*dtbydx,W(i,j,k) + c(i,j,k))
          spzero = cvmgp(-one, W(i,j,k) *dtbydx,W(i,j,k) )
          apright = half*(-one - spplus )*alphap
          amright = half*(-one - spminus)*alpham
          azrright= half*(-one - spzero )*alpha0r
          azeright= half*(-one - spzero )*alpha0e
          azv1rght= half*(-one - spzero )*alpha0v1
          azv2rght= half*(-one - spzero )*alpha0v2
          qbarr(i,j,k,QRHO) = q(i,j,k,QRHO) + apright + amright + azrright
          qbarr(i,j,k,QRHO) = max(smallr, qbarr(i,j,k,QRHO))
          qbarr(i,j,k,QVEL3) = q(i,j,k,QVEL3) +
     $                      (apright - amright)*c(i,j,k)/RHO(i,j,k)
          qbarr(i,j,k,QVEL1) = q(i,j,k,QVEL1) + azv1rght
          qbarr(i,j,k,QVEL2) = q(i,j,k,QVEL2) + azv2rght
          qbarr(i,j,k,QPRES) = q(i,j,k,QPRES) +
     $                      (apright + amright)*c(i,j,k)**2
          qbarr(i,j,k,QRHOE) = q(i,j,k,QRHOE) + (apright +
     $                       amright)*enth(i,j,k)*c(i,j,k)**2 + azeright
#if(NADV>0)
          qbarr(i,j,k,QADV) = q(i,j,k,QADV)+half*(-one-spzero)*DADV(i,j,k)
#endif

c ::: :::::  Bottom state of edge at top

          spminus = cvmgp((W(i,j,k) - c(i,j,k))*dtbydx,one,W(i,j,k) - c(i,j,k))
          spplus = cvmgp((W(i,j,k) + c(i,j,k))*dtbydx,one,W(i,j,k) + c(i,j,k))
          spzero = cvmgp( W(i,j,k) *dtbydx,one,W(i,j,k) )
          apleft = half*(one - spplus )*alphap
          amleft = half*(one - spminus)*alpham
          azrleft= half*(one - spzero )*alpha0r
          azeleft= half*(one - spzero )*alpha0e
          azv1left= half*(one - spzero )*alpha0v1
          azv2left= half*(one - spzero )*alpha0v2
          qbarl(i,j,k+1,QRHO) = q(i,j,k,QRHO) + apleft + amleft + azrleft
          qbarl(i,j,k+1,QRHO) = max(smallr, qbarl(i,j,k+1,QRHO))
          qbarl(i,j,k+1,QVEL3) = q(i,j,k,QVEL3) +
     $                         (apleft - amleft)*c(i,j,k)/RHO(i,j,k)
          qbarl(i,j,k+1,QVEL1) = q(i,j,k,QVEL1) + azv1left
          qbarl(i,j,k+1,QVEL2) = q(i,j,k,QVEL2) + azv2left
          qbarl(i,j,k+1,QPRES) = q(i,j,k,QPRES) +
     $                         (apleft + amleft)*c(i,j,k)**2
          qbarl(i,j,k+1,QRHOE) = q(i,j,k,QRHOE) + (apleft + amleft)*
     $                         enth(i,j,k)*c(i,j,k)**2 + azeleft
#if(NADV>0)
          qbarl(i,j,k+1,QADV) = q(i,j,k,QADV)+half*(one-spzero)*DADV(i,j,k)
#endif
        enddo
       enddo
      enddo
          

c ::: Colella hack near R=0 singularity
      do k = ks,ke
       do j = js,je
        do i = is,ie
          if (dloga(i,j,k) .ne. zero) then
              eta = (one-courno(i,j,k))/(c(i,j,k)*dt*dloga(i,j,k))
              eta = min(one, eta)
              dloga(i,j,k) = dloga(i,j,k) * eta
          endif
        enddo
       enddo
      enddo

      dthalf = half*dt
c ::: add geometric source terms to traced states
      do k = ksedg,keedg-1
       do j = jsedg,jeedg
        do i = isedg,ieedg
          sourcr = -RHO(i,j,k)*dloga(i,j,k)*W(i,j,k)*dthalf
          sourcp = sourcr*c(i,j,k)**2
          source = sourcp*enth(i,j,k)
          qbarl(i,j,k+1,QRHO) = qbarl(i,j,k+1,QRHO) + sourcr
          qbarl(i,j,k+1,QRHO) = max(smallr, qbarl(i,j,k+1,QRHO))
          qbarl(i,j,k+1,QPRES) = qbarl(i,j,k+1,QPRES) + sourcp
          qbarl(i,j,k+1,QRHOE) = qbarl(i,j,k+1,QRHOE) + source
          qbarr(i,j,k ,QRHO) = qbarr(i,j,k ,QRHO) + sourcr
          qbarr(i,j,k ,QRHO) = max(smallr, qbarr(i,j,k,QRHO))
          qbarr(i,j,k ,QPRES) = qbarr(i,j,k ,QPRES) + sourcp
          qbarr(i,j,k ,QRHOE) = qbarr(i,j,k ,QRHOE) + source
        enddo
       enddo
      enddo

c ::: convert energy back to intensive form 
c ::: for eos call in RIEMANN
c     do k = ks,ke
c      do j = js,je
c       do i =is,ie
c  RHOE(i,j,k) = RHOE(i,j,k)/RHO(i,j,k)
c       enddo
c      enddo
c     enddo

#undef U
#undef V
#undef W
#undef P
#undef RHO
#undef RHOE
#undef DU
#undef DV
#undef DW
#undef DP
#undef DRHO
#undef DRHOE
#if(NADV>0)
#undef DADV
#endif

      end

#define SRHO 1
#define SXMOM 2
#define SYMOM 3
#define SZMOM 4
#define SRHOE 5
#if(NADV>0)
#define  SADV 6
#endif

      subroutine RIEMANN(
     &		BL_FARG(qbarm),
     &		BL_FARG(qbarp),
     &		BL_FARG(flux),
     &          BL_FARG(rho),
     &          BL_FARG(e),
     &          BL_FARG(adv),
     &		BL_FARG(c),
     &		BL_FARG(csml),
     &		BL_FARG(gamc),
     &		BL_FARG(rgdnv),
     &		BL_FARG(ugdnv),
     &		BL_FARG(pgdnv),
     &		BL_FARG(egdnv),
     &		BL_FARG(utgdnv),
#if(NADV>0)
     &          BL_FARG(advgdnv),
#endif
     &		BL_FARG(ustar),
     &          BL_BARG(bx),
     &		sweep, npvar, nsvar)   

      integer sweep, npvar, nsvar
      BL_FBOUNDS(qbarm)
      BL_FARRAY(qbarm,npvar)
      BL_FBOUNDS(qbarp)
      BL_FARRAY(qbarp,npvar)
      BL_FBOUNDS(c)
      BL_FARRAY1(c)
      BL_FBOUNDS(rho)
      BL_FARRAY1(rho)
      BL_FBOUNDS(e)
      BL_FARRAY1(e)
      BL_FBOUNDS(adv)
      BL_FARRAY1(adv)
      BL_FBOUNDS(csml)
      BL_FARRAY1(csml)
      BL_FBOUNDS(gamc)
      BL_FARRAY1(gamc)
      BL_FBOUNDS(rgdnv)
      BL_FARRAY1(rgdnv)
      BL_FBOUNDS(ugdnv)
      BL_FARRAY1(ugdnv)
      BL_FBOUNDS(pgdnv)
      BL_FARRAY1(pgdnv)
      BL_FBOUNDS(egdnv)
      BL_FARRAY1(egdnv)
      BL_FBOUNDS(utgdnv)
      BL_FARRAY(utgdnv,2)
      BL_FBOUNDS(advgdnv)
      BL_FARRAY1(advgdnv)
      BL_FBOUNDS(ustar)
      BL_FARRAY1(ustar)
      BL_FBOUNDS(flux)
      BL_FARRAY(flux,nsvar)
      BL_BBOUNDS(bx)

      REAL_T wl, wr, cav, pstar
      REAL_T ro, uo, po, eo, gamco, co, entho
      REAL_T rstar, estar, cstar
      REAL_T sgnm, spin, spout, ushock, frac, divuvs
      REAL_T scr

      REAL_T csmall, wsmall, smallr, small
      REAL_T gam_tmp, pdum, c_tmp, csml_tmp

      integer qvnrml, qvtrns1, qvtrns2
      integer is,ie,js,je,ks,ke, i,j,k
      integer    lo(3), hi(3)

      
      if(sweep.eq.0)then
c     ::: x-direction
        qvnrml = QVEL1
        qvtrns1 = QVEL2
        qvtrns2 = QVEL3
      elseif(sweep.eq.1)then
c     ::: y-direction
        qvnrml = QVEL2
        qvtrns1 = QVEL1
        qvtrns2 = QVEL3
      elseif(sweep.eq.2)then
c     ::: z-direction
        qvnrml = QVEL3
        qvtrns1 = QVEL1
        qvtrns2 = QVEL2
      else
        print *,'Abort: Bogus sweep value passed to RIEMANN'
        stop
      endif

      smallr = onetominussix
      small = onetominussix

      is = flux_l1
      ie = flux_h1 
      js = flux_l2  
      je = flux_h2
      ks = flux_l3 
      ke = flux_h3 
      

      do k = ks,ke          
       do j = js,je          
        do i = is,ie          

          if(sweep.eq.0)then
            csmall = max(csml(i-1,j,k),csml(i,j,k))
            cav = half*(c(i,j,k) + c(i-1,j,k))
            wsmall = smallr*csmall
            wl = max(wsmall,sqrt(abs(gamc(i-1,j,k)*
     $           qbarm(i,j,k,QPRES)*qbarm(i,j,k,QRHO))))
          elseif(sweep.eq.1)then
            csmall = max(csml(i,j-1,k),csml(i,j,k))
            cav = half*(c(i,j,k) + c(i,j-1,k))
            wsmall = smallr*csmall
            wl = max(wsmall,sqrt(abs(gamc(i,j-1,k)*
     $           qbarm(i,j,k,QPRES)*qbarm(i,j,k,QRHO))))
          elseif(sweep.eq.2)then
            csmall = max(csml(i,j,k-1),csml(i,j,k))
            cav = half*(c(i,j,k) + c(i,j,k-1))
            wsmall = smallr*csmall
            wl = max(wsmall,sqrt(abs(gamc(i,j,k-1)*
     $           qbarm(i,j,k,QPRES)*qbarm(i,j,k,QRHO))))
          else
            print *,'Abort: Bogus sweep value passed to RIEMANN'
            stop
          endif

          wr = max(wsmall,sqrt(abs(gamc(i,j,k )*qbarp(i,j,k,QPRES)*
     $         qbarp(i,j,k,QRHO))))

          pstar = ((wr*qbarm(i,j,k,QPRES) + wl*qbarp(i,j,k,QPRES)) + wl*wr*
     $    (qbarm(i,j,k,qvnrml) - qbarp(i,j,k,qvnrml)))/(wl + wr)

          ustar(i,j,k) = ((wl*qbarm(i,j,k,qvnrml) + wr*qbarp(i,j,k,qvnrml)) +
     $    (qbarm(i,j,k,QPRES) - qbarp(i,j,k,QPRES)))/(wl + wr)

          ro = cvmgp(qbarm(i,j,k,QRHO),qbarp(i,j,k,QRHO),ustar(i,j,k))
          uo = cvmgp(qbarm(i,j,k,qvnrml),qbarp(i,j,k,qvnrml),ustar(i,j,k))
          po = cvmgp(qbarm(i,j,k,QPRES),qbarp(i,j,k,QPRES),ustar(i,j,k))
          eo = cvmgp(qbarm(i,j,k,QRHOE),qbarp(i,j,k,QRHOE),ustar(i,j,k))

          if(sweep.eq.0)then
            gamco = cvmgp(gamc(i-1,j,k),gamc(i,j,k),ustar(i,j,k))
          elseif(sweep.eq.1)then
            gamco = cvmgp(gamc(i,j-1,k),gamc(i,j,k),ustar(i,j,k))
          else
            gamco = cvmgp(gamc(i,j,k-1),gamc(i,j,k),ustar(i,j,k))
          endif

          co = max(csmall,sqrt(abs(gamco*po/ro)))
          entho = (eo/ro + po/ro)/co**2
          rstar = ro + (pstar - po)/co**2
          rstar = max(rstar,smallr)
          estar = eo + (pstar - po)*entho
          cstar = max(csmall,sqrt(abs(gamco*pstar/rstar)))

          sgnm = sign(one,ustar(i,j,k))
          spout = co - sgnm*uo
          spin = cstar - sgnm*ustar(i,j,k)
          ushock = half*(spin + spout)
          spin = cvmgp(ushock,spin,pstar - po)
          spout = cvmgp(ushock,spout,pstar - po)
          scr = cvmgz(small*cav,spout - spin,spout - spin)
          frac = (one + (spout + spin)/scr)*half
          frac = max(zero,min(one,frac))

          utgdnv(i,j,k,1) = cvmgp(qbarm(i,j,k,qvtrns1),
     &                           qbarp(i,j,k,qvtrns1),ustar(i,j,k))
          utgdnv(i,j,k,2) = cvmgp(qbarm(i,j,k,qvtrns2),
     &                           qbarp(i,j,k,qvtrns2),ustar(i,j,k))
#if(NADV>0)
          advgdnv(i,j,k) = cvmgp(qbarm(i,j,k,QADV),qbarp(i,j,k,QADV),
     &                           ustar(i,j,k))
#endif
          rgdnv(i,j,k) = frac*rstar + (one - frac)*ro
          ugdnv(i,j,k) = frac*ustar(i,j,k) + (one - frac)*uo
          pgdnv(i,j,k) = frac*pstar + (one - frac)*po
          egdnv(i,j,k) = frac*estar + (one - frac)*eo

          rgdnv(i,j,k) = cvmgp(rgdnv(i,j,k),ro,spout)
          ugdnv(i,j,k) = cvmgp(ugdnv(i,j,k),uo,spout)
          pgdnv(i,j,k) = cvmgp(pgdnv(i,j,k),po,spout)
          egdnv(i,j,k) = cvmgp(egdnv(i,j,k),eo,spout)

          rgdnv(i,j,k) = cvmgp(rstar,rgdnv(i,j,k),spin)
          ugdnv(i,j,k) = cvmgp(ustar(i,j,k),ugdnv(i,j,k),spin)
          pgdnv(i,j,k) = cvmgp(pstar,pgdnv(i,j,k),spin)
          egdnv(i,j,k) = cvmgp(estar,egdnv(i,j,k),spin)

        enddo
       enddo
      enddo

c ::: ::::: compute fluxes
      do k = ks,ke
       do j = js,je
        do i = is,ie

          flux(i,j,k,SRHO) = ugdnv(i,j,k)*rgdnv(i,j,k)
          flux(i,j,k,qvnrml) = ugdnv(i,j,k)*flux(i,j,k,SRHO)
          flux(i,j,k,qvtrns1) = utgdnv(i,j,k,1)*flux(i,j,k,SRHO)
          flux(i,j,k,qvtrns2) = utgdnv(i,j,k,2)*flux(i,j,k,SRHO)
          flux(i,j,k,SRHOE) = flux(i,j,k,SRHO)*          
     $     (half*(ugdnv(i,j,k)**2+utgdnv(i,j,k,1)**2+utgdnv(i,j,k,2)**2)
     $    +egdnv(i,j,k)/rgdnv(i,j,k)) + ugdnv(i,j,k)*pgdnv(i,j,k)
#if(NADV>0)
          flux(i,j,k,SADV) = flux(i,j,k,SRHO)*advgdnv(i,j,k)
#endif

        enddo
       enddo
      enddo

      end


      subroutine FORT_COPYSTATE(
     &          BL_FARG(state),
     &          BL_FARG(gstate),
     &          BL_BARG(bx),
     &          nvar)

        integer nvar
	BL_FBOUNDS(state)
	BL_FARRAY(state,nvar)
	BL_FBOUNDS(gstate)
	BL_FARRAY(gstate,nvar)
	BL_BBOUNDS(bx)

        integer i, j, k, n
        integer is, ie, js, je, ks, ke
        
        is = bxlo(1)
        ie = bxhi(1)
        js = bxlo(2)
        je = bxhi(2)
        ks = bxlo(3)
        ke = bxhi(3)

	do n = 1,nvar
           do k = ks, ke
              do j = js, je
                 do i = is, ie
                    gstate(i,j,k,n) = state(i,j,k,n)
                 enddo
              enddo
           enddo
        enddo
	
      end

c 
c ---------------------------------------------------------------
c Node-based divergence for artificial viscosity calculation
c ---------------------------------------------------------------
c       
        subroutine FORT_DIVUNODE (
     &                  BL_FARG(state),
     &                  BL_FARG(div),
     &                  delta, nvar, gbndry)

        integer nvar, gbndry(0:2*SDIM-1)
        REAL_T delta(SDIM)
        BL_FBOUNDS(state)
        BL_FARRAY(state,nvar)
        BL_FBOUNDS(div)
        BL_FARRAY1(div)

	integer i,j,k, is, js, ks, ie, je, ke
        REAL_T ux,vy,wz
        REAL_T uijk,uimjk,uijmk,uimjmk,uijkm,uimjkm,uijmkm,uimjmkm
        REAL_T vijk,vijmk,vimjk,vimjmk,vijkm,vijmkm,vimjkm,vimjmkm
        REAL_T wijk,wijkm,wimjk,wimjkm,wimjmk,wimjmkm,wijmk,wijmkm
        REAL_T quarter

      is = div_l1
      ie = div_h1
      js = div_l2
      je = div_h2
      ks = div_l3
      ke = div_h3

      quarter = 0.25
      
      do k = div_l3, div_h3  
       do j = div_l2, div_h2  
	 do i = div_l1, div_h1  

         uijk = state(i,j,k,2)/state(i,j,k,1)
         uimjk = state(i-1,j,k,2)/state(i-1,j,k,1)
         uijmk = state(i,j-1,k,2)/state(i,j-1,k,1)
         uimjmk = state(i-1,j-1,k,2)/state(i-1,j-1,k,1)
         uijkm = state(i,j,k-1,2)/state(i,j,k-1,1)
         uimjkm = state(i-1,j,k-1,2)/state(i-1,j,k-1,1)
         uijmkm = state(i,j-1,k-1,2)/state(i,j-1,k-1,1)
         uimjmkm = state(i-1,j-1,k-1,2)/state(i-1,j-1,k-1,1)

         vijk = state(i,j,k,3)/state(i,j,k,1)
         vimjk = state(i-1,j,k,3)/state(i-1,j,k,1)
         vijmk = state(i,j-1,k,3)/state(i,j-1,k,1)
         vimjmk = state(i-1,j-1,k,3)/state(i-1,j-1,k,1)
         vijkm = state(i,j,k-1,3)/state(i,j,k-1,1)
         vimjkm = state(i-1,j,k-1,3)/state(i-1,j,k-1,1)
         vijmkm = state(i,j-1,k-1,3)/state(i,j-1,k-1,1)
         vimjmkm = state(i-1,j-1,k-1,3)/state(i-1,j-1,k-1,1)

         wijk = state(i,j,k,4)/state(i,j,k,1)
         wimjk = state(i-1,j,k,4)/state(i-1,j,k,1)
         wijmk = state(i,j-1,k,4)/state(i,j-1,k,1)
         wimjmk = state(i-1,j-1,k,4)/state(i-1,j-1,k,1)
         wijkm = state(i,j,k-1,4)/state(i,j,k-1,1)
         wimjkm = state(i-1,j,k-1,4)/state(i-1,j,k-1,1)
         wijmkm = state(i,j-1,k-1,4)/state(i,j-1,k-1,1)
         wimjmkm = state(i-1,j-1,k-1,4)/state(i-1,j-1,k-1,1)

         ux = quarter*(uijk-uimjk+uijmk-uimjmk+
     &                 uijkm-uimjkm+uijmkm-uimjmkm)/delta(1)

         vy = quarter*(vijk+vimjk-vijmk-vimjmk+
     &                 vijkm+vimjkm-vijmkm-vimjmkm)/delta(2)

         wz = quarter*(wijk+wimjk+wijmk+wimjmk-
     &                 wijkm-wimjkm-wijmkm-wimjmkm)/delta(3)


         div(i,j,k) = ux + vy + wz

         enddo
       enddo
      enddo

      end

c
c--------------------------------------------------------------
c     Conservative update and other final stuff -- x direction
c---------------------------------------------------------------
c


      subroutine FORT_UPDATEX(
     &  		BL_FARG(s),
     &                  BL_FARG(flux),
     &                  BL_FARG(pgdnv),
     &                  BL_FARG(div),
     &                  BL_FARG(area),
     &                  BL_FARG(vol),
     &                  BL_BARG(bx),
     &                  delta, dt, nv, sweep, bc, gBndry)
      integer nv, gBndry(0:2*SDIM-1)
      integer bc(SDIM,2,nv)
      BL_FBOUNDS(s)                  
      BL_FARRAY(s,nv)
      BL_FBOUNDS(flux)
      BL_FARRAY(flux,nv)
      BL_FBOUNDS(pgdnv)
      BL_FARRAY1(pgdnv)
      BL_FBOUNDS(div)
      BL_FARRAY1(div)
      BL_FBOUNDS(area)
      BL_FARRAY1(area)
      BL_FBOUNDS(vol)
      BL_FARRAY1(vol)
      BL_BBOUNDS(bx)
      REAL_T dt
      REAL_T delta(SDIM)
      integer sweep, vnrml
      integer is, ie, js, je,ks,ke, i, j,k, iv, ivbc
      integer isflx, ieflx, jsflx, jeflx, ksflx,keflx
      REAL_T dx, dy,dz,trandiv, divuvs, difmag
      REAL_T avgarea
      REAL_T leftbc, rightbc
      REAL_T trandiv1, trandiv1p, trandivy, trandivz

      data difmag / tenth /

      is = bxlo(1)
      ie = bxhi(1)
      js = bxlo(2)
      je = bxhi(2)
      ks = bxlo(3)
      ke = bxhi(3)
      isflx = flux_l1 
      ieflx = flux_h1 
      jsflx = flux_l2 
      jeflx = flux_h2 
      ksflx = flux_l3 
      keflx = flux_h3 

      dx = delta(1)
      dy = delta(2)
      dz = delta(3)

      if(sweep.eq.0)then
	vnrml = 2
      else
	print *,'Abort: bogus sweep value in UPDATEX'
	stop
      endif


c
c ::: add artifical viscosity and convert to extensive quantities
c

      do iv = 1, nv
      do k = ksflx,keflx
       do j = jsflx,jeflx
        do i = isflx, ieflx

          trandiv = fourth*(div(i,j,k) + div(i,j+1,k)
     &     +div(i,j,k+1) + div(i,j+1,k+1))

          divuvs = difmag*dx*trandiv
          divuvs = min(zero,divuvs)
          flux(i,j,k, iv)= flux(i,j,k, iv) +
     $                  divuvs*(s(i,j,k, iv) - s(i-1,j,k,iv)) 

          flux(i,j,k,iv) = flux(i,j,k,iv)*dt*area(i,j,k)
        
        enddo
       enddo
      enddo
      enddo

c
c ::: conservative update
c
 
      do iv = 1, nv
      do k = ks, ke
       do j = js, je
        do i = is, ie
          s(i,j,k,iv) = s(i,j,k,iv) + 
     $               (flux(i,j,k,iv) - flux(i+1,j,k,iv))/vol(i,j,k)
        enddo
       enddo
      enddo
      enddo


c
c ::: add pressure term to normal momnentum
c

      do k = ks, ke
       do j = js, je
        do i = is, ie
          avgarea = half*(area(i,j,k) + area(i+1,j,k))
          s(i,j,k,vnrml) = s(i,j,k,vnrml) + dt*avgarea*
     $                 (pgdnv(i,j,k) - pgdnv(i+1,j,k))/vol(i,j,k)
        enddo
       enddo
      enddo

c
c ::: add pressure term to normal momnentum flux
c
      do k = ksflx,keflx
       do j = jsflx,jeflx
        do i = isflx,ieflx
          flux(i,j,k,vnrml) = flux(i,j,k,vnrml) + dt*area(i,j,k)*pgdnv(i,j,k)
        enddo
       enddo
      enddo

      end

c
c--------------------------------------------------------------
c     Conservative update and other final stuff -- y direction
c---------------------------------------------------------------
c


      subroutine FORT_UPDATEY(
     &  		BL_FARG(s),
     &                  BL_FARG(flux),
     &                  BL_FARG(pgdnv),
     &                  BL_FARG(div),
     &                  BL_FARG(area),
     &                  BL_FARG(vol),
     &                  BL_BARG(bx),
     &                  delta, dt, nv, sweep, bc, gBndry)
      integer nv, gBndry(0:2*SDIM-1)
      integer bc(SDIM,2,nv)
      BL_FBOUNDS(s)                  
      BL_FARRAY(s,nv)
      BL_FBOUNDS(flux)
      BL_FARRAY(flux,nv)
      BL_FBOUNDS(pgdnv)
      BL_FARRAY1(pgdnv)
      BL_FBOUNDS(div)
      BL_FARRAY1(div)
      BL_FBOUNDS(area)
      BL_FARRAY1(area)
      BL_FBOUNDS(vol)
      BL_FARRAY1(vol)
      BL_BBOUNDS(bx)
      REAL_T dt
      REAL_T delta(SDIM)
      integer vnrml,sweep
      integer  is, ie, js, je,ks,ke, i, j,k, iv, ivbc
      integer isflx, ieflx, jsflx, jeflx, ksflx, keflx
      REAL_T dx, dy,dz,trandiv, divuvs, difmag
      REAL_T avgarea
      REAL_T botbc, topbc
      REAL_T trandiv1, trandiv1p, trandivy, trandivz
      data difmag / tenth /

      if(sweep.eq.1)then
        vnrml = 3
      else
	print *,'Abort: bogus sweep value in UPDATEY'
	stop
      endif

      is = bxlo(1)
      ie = bxhi(1)
      js = bxlo(2)
      je = bxhi(2)
      ks = bxlo(3)
      ke = bxhi(3)
      isflx = flux_l1 
      ieflx = flux_h1 
      jsflx = flux_l2 
      jeflx = flux_h2 
      ksflx = flux_l3 
      keflx = flux_h3 


      dx = delta(1)
      dy = delta(2)
      dz = delta(3)

c
c ::: add artifical viscosity and convert to extensive quantities
c

      do iv = 1, nv
      do k = ksflx,keflx
       do j = jsflx,jeflx
        do i = isflx,ieflx

          trandiv = fourth*(div(i,j,k) + div(i+1,j,k)
     &     +div(i,j,k+1) + div(i+1,j,k+1))

          divuvs = difmag*dy*trandiv
          divuvs = min(zero,divuvs)
          flux(i,j,k, iv)= flux(i,j,k, iv) +
     $                  divuvs*(s(i,j,k, iv) - s(i,j-1,k,iv)) 

          flux(i,j,k,iv) = flux(i,j,k,iv)*dt*area(i,j,k)
        
        enddo
       enddo
      enddo
      enddo

c
c ::: conservsative update
c
 
      do iv = 1, nv
      do k = ks, ke
       do j = js, je
        do i = is, ie
          s(i,j,k,iv) = s(i,j,k,iv) + 
     $               (flux(i,j,k,iv) - flux(i,j+1,k,iv))/vol(i,j,k)
        enddo
       enddo
      enddo
      enddo


c
c ::: add pressure term to normal momnentum
c

      do k = ks, ke
       do j = js, je
        do i = is, ie

          avgarea = half*(area(i,j,k) + area(i,j+1,k))
          s(i,j,k,vnrml) = s(i,j,k,vnrml) + dt*avgarea*
     $                 (pgdnv(i,j,k) - pgdnv(i,j+1,k))/vol(i,j,k)
        enddo
       enddo
      enddo

c
c ::: add pressure term to normal momnentum flux
c
      do k = ksflx, keflx
       do j = jsflx, jeflx
        do i = isflx, ieflx
          flux(i,j,k,vnrml) = flux(i,j,k,vnrml) + dt*area(i,j,k)*pgdnv(i,j,k)
        enddo
       enddo
      enddo

      end


c
c--------------------------------------------------------------
c     Conservative update and other final stuff -- z direction
c---------------------------------------------------------------
c


      subroutine FORT_UPDATEZ(
     &  		BL_FARG(s),
     &                  BL_FARG(flux),
     &                  BL_FARG(pgdnv),
     &                  BL_FARG(div),
     &                  BL_FARG(area),
     &                  BL_FARG(vol),
     &                  BL_BARG(bx),
     &                  delta, dt, nv, sweep, bc, gBndry)
      integer nv, gBndry(0:2*SDIM-1)
      integer bc(SDIM,2,nv)
      BL_FBOUNDS(s)                  
      BL_FARRAY(s,nv)
      BL_FBOUNDS(flux)
      BL_FARRAY(flux,nv)
      BL_FBOUNDS(pgdnv)
      BL_FARRAY1(pgdnv)
      BL_FBOUNDS(div)
      BL_FARRAY1(div)
      BL_FBOUNDS(area)
      BL_FARRAY1(area)
      BL_FBOUNDS(vol)
      BL_FARRAY1(vol)
      BL_BBOUNDS(bx)
      REAL_T dt
      REAL_T delta(SDIM)
      integer vnrml,sweep
      integer  is, ie, js, je, ks,ke,i, j, k,iv, ivbc
      integer isflx, ieflx, jsflx, jeflx,ksflx,keflx
      REAL_T dx, dy,dz,trandiv, divuvs, difmag
      REAL_T avgarea
      REAL_T botbc, topbc
      REAL_T trandiv1, trandiv1p, trandivy, trandivz
      data difmag / tenth /

      if(sweep.eq.2)then
        vnrml = 4
      else
	print *,'Abort: bogus sweep value in UPDATEZ'
	stop
      endif

      is = bxlo(1)
      ie = bxhi(1)
      js = bxlo(2)
      je = bxhi(2)
      ks = bxlo(3)
      ke = bxhi(3)
      isflx = flux_l1 
      ieflx = flux_h1 
      jsflx = flux_l2 
      jeflx = flux_h2 
      ksflx = flux_l3 
      keflx = flux_h3 

      dx = delta(1)
      dy = delta(2)
      dz = delta(3)

c
c ::: add artifical viscosity and convert to extensive quantities
c

      do iv = 1, nv
      do k = ksflx,keflx
       do j = jsflx,jeflx
        do i = isflx,ieflx

          trandiv = fourth*(div(i,j,k) + div(i,j+1,k)
     &     +div(i+1,j,k) + div(i+1,j+1,k))

          divuvs = difmag*dz*trandiv
          divuvs = min(zero,divuvs)
          flux(i,j,k, iv)= flux(i,j,k, iv) +
     $                  divuvs*(s(i,j,k, iv) - s(i,j,k-1,iv)) 

          flux(i,j,k,iv) = flux(i,j,k,iv)*dt*area(i,j,k)
        
        enddo
       enddo
      enddo
      enddo

c
c ::: conservsative update
c
 
      do iv = 1, nv
      do k = ks, ke
       do j = js, je
        do i = is, ie
          s(i,j,k,iv) = s(i,j,k,iv) + 
     $               (flux(i,j,k,iv) - flux(i,j,k+1,iv))/vol(i,j,k)
        enddo
       enddo
      enddo
      enddo


c
c ::: add pressure term to normal momnentum
c

      do k = ks, ke
       do j = js, je
        do i = is, ie
          avgarea = half*(area(i,j,k) + area(i,j,k+1))
          s(i,j,k,vnrml) = s(i,j,k,vnrml) + dt*avgarea*
     $                 (pgdnv(i,j,k) - pgdnv(i,j,k+1))/vol(i,j,k)
        enddo
       enddo
      enddo

c
c ::: add pressure term to normal momnentum flux
c
      do k = ksflx, keflx
       do j = jsflx, jeflx
        do i = isflx, ieflx
          flux(i,j,k,vnrml) = flux(i,j,k,vnrml) + dt*area(i,j,k)*pgdnv(i,j,k)
        enddo
       enddo
      enddo



      end


      subroutine FORT_PRIMITIVES(
     &                  BL_FARG(s),
     &                  BL_FARG(q),
     &                  BL_FARG(p),
     &                  BL_FARG(c),
     &                  BL_FARG(csml),
     &                  BL_FARG(gamc),
     &                  BL_BARG(bx),
     &                  bc, ns, nq, sweep)
      integer ns, nq, sweep
      integer bc(SDIM,2,ns)

      BL_FBOUNDS(s)
      BL_FBOUNDS(q)
      BL_FBOUNDS(p)
      BL_FBOUNDS(c)
      BL_FBOUNDS(csml)
      BL_FBOUNDS(gamc)
      BL_BBOUNDS(bx)

      BL_FARRAY(s,ns)
      BL_FARRAY(q,nq)
        BL_FARRAY1(p)
        BL_FARRAY1(c)
        BL_FARRAY1(csml)
      BL_FARRAY1(gamc)

      integer is,ie,js,je,ks,ke,i,j,k
      REAL_T u,v,w,rho,e
      REAL_T gdum,cdum,csdum, reflect

#include "xxmeth.fh"

       is = bxlo(1)
       js = bxlo(2)
       ks = bxlo(3)
       ie = bxhi(1)
       je = bxhi(2)
       ke = bxhi(3)


      do k = ks, ke
       do j = js, je
        do i = is, ie

          rho = max(s(i,j,k,SRHO),smallr)
          u = s(i,j,k,SXMOM)/s(i,j,k,SRHO)
          v = s(i,j,k,SYMOM)/s(i,j,k,SRHO)
          w = s(i,j,k,SZMOM)/s(i,j,k,SRHO)
          e = s(i,j,k,SRHOE)/rho - half*(u**2 + v**2 + w**2)
    
          q(i,j,k,QRHO) = rho       
          q(i,j,k,QVEL1) = u
          q(i,j,k,QVEL2) = v
          q(i,j,k,QVEL3) = w
          q(i,j,k,QRHOE) = e
#if(NADV>0)
          q(i,j,k,QADV) = S(i,j,k,SADV)/s(i,j,k,SRHO)
#endif
        
        enddo
       enddo
      enddo


      call eos(q(BL_ARGL1(q),BL_ARGL2(q),BL_ARGL3(q),QRHO),
     $         q(BL_ARGL1(q),BL_ARGL2(q),BL_ARGL3(q),QRHOE),
     $         q(BL_ARGL1(q),BL_ARGL2(q),BL_ARGL3(q),QADV),
     $         BL_IARG(q),
     $         gamc(BL_ARGL1(c),BL_ARGL2(c),BL_ARGL3(c)),
     $         q(BL_ARGL1(c),BL_ARGL2(c),BL_ARGL3(c),QPRES),
     $         c(BL_ARGL1(c),BL_ARGL2(c),BL_ARGL3(c)),
     $         csml(BL_ARGL1(c),BL_ARGL2(c),BL_ARGL3(c)),
     $         BL_IARG(c),
     $         bxlo,bxhi,1,1,1,1)
      do k = ks, ke
       do j = js, je
        do i = is, ie
          q(i,j,k,QPRES) = max(smallp,q(i,j,k,QPRES))
          p(i,j,k) = q(i,j,k,QPRES)
          q(i,j,k,QRHOE) = q(i,j,k,QRHOE)*q(i,j,k,QRHO)
c         c(i,j,k) = sqrt(gamc(i,j,k)*q(i,j,k,QPRES)/q(i,j,k,QRHO))
c         csml(i,j,k) = max(small,small*c(i,j,k))

        enddo
       enddo
      enddo

      end
      
        subroutine FORT_FLATENX(BL_FARG(q),BL_FARG(flatn),
     $          BL_FARG(dp), BL_FARG(z), BL_FARG(chi),
     $          BL_FARG(p), BL_FARG(c),nv)
        integer nv
        BL_FBOUNDS(q)
        BL_FBOUNDS(flatn)
        BL_FBOUNDS(dp)
        BL_FBOUNDS(z)
        BL_FBOUNDS(chi)
        BL_FBOUNDS(p)
        BL_FBOUNDS(c)

        BL_FARRAY(q,nv)
        BL_FARRAY1(flatn)
        BL_FARRAY1(dp)
        BL_FARRAY1(z)
        BL_FARRAY1(chi)
        BL_FARRAY1(p)
        BL_FARRAY1(c)

        integer is,js,ks,ie,je,ke, i,j,k
        REAL_T shktst, zcut1, zcut2, dzcut
        REAL_T denom, zeta, tst, tmp

#include "xxmeth.fh"

c ::: ::::: knobs for detection of strong shock
#ifdef  BL_USE_FLOAT_CONST
      data shktst /0.33/
      data zcut1 /0.75/
      data zcut2 /0.85/
#endif
#ifdef  BL_USE_DOUBLE_CONST
      data shktst /0.33d0/
      data zcut1 /0.75d0/
      data zcut2 /0.85d0/
#endif


        dzcut = one/(zcut2-zcut1)

        is = q_l1
        ie = q_h1
        js = q_l2
        je = q_h2
        ks = q_l3
        ke = q_h3

        if(iorder .eq. 3) then
          return
        else
c
c  this is a hack.  need to compute the pressure from the state in
c  a general way.
c
#if 0
        do i = is,ie
          do j = js,je
            do k = ks,ke
              p(i,j,k) = q(i,j,k,QPRES)
              c(i,j,k) = sqrt(onepointfour*p(i,j,k)/q(i,j,k,QRHO))
            enddo
          enddo
        enddo
#endif

c
c  could use z or chi limits equivalently
c
        is = dp_l1
        ie = dp_h1
        js = dp_l2
        je = dp_h2
        ks = dp_l3
        ke = dp_h3

        do k = ks,ke
          do j = js,je
            do i = is,ie
              dp(i,j,k) = p(i+1,j,k)-p(i-1,j,k)
              denom = max(smallp,abs(p(i+2,j,k)-p(i-2,j,k)))
              zeta = abs(dp(i,j,k))/denom
              z(i,j,k) = min(one,max(zero, dzcut*(zeta-zcut1)))
              tst = cvmgp(one,zero,q(i-1,j,k,QVEL1)-q(i+1,j,k,QVEL1))
              tmp = min(q(i+1,j,k,QRHO)*c(i+1,j,k)**2,q(i-1,j,k,QRHO)*c(i-1,j,k)**2)
              chi(i,j,k) = cvmgt(tst,zero,(abs(dp(i,j,k))/tmp).gt.shktst)
            enddo
          enddo
        enddo

        is = flatn_l1
        ie = flatn_h1
        js = flatn_l2
        je = flatn_h2
        ks = flatn_l3
        ke = flatn_h3

        do k = ks,ke
          do j = js,je
            do i = is,ie
              flatn(i,j,k) = one-max(chi(i-1,j,k)*z(i-1,j,k),
     $            chi(i,j,k)*z(i,j,k),
     $            chi(i+1,j,k)*z(i+1,j,k))
            enddo
          enddo
        enddo

        endif

        end

        subroutine FORT_FLATENY(BL_FARG(q),BL_FARG(flatn),
     $          BL_FARG(dp), BL_FARG(z), BL_FARG(chi),
     $          BL_FARG(p), BL_FARG(c),nv)
        integer nv
        BL_FBOUNDS(q)
        BL_FBOUNDS(flatn)
        BL_FBOUNDS(dp)
        BL_FBOUNDS(z)
        BL_FBOUNDS(chi)
        BL_FBOUNDS(p)
        BL_FBOUNDS(c)

        BL_FARRAY(q,nv)
        BL_FARRAY1(flatn)
        BL_FARRAY1(dp)
        BL_FARRAY1(z)
        BL_FARRAY1(chi)
        BL_FARRAY1(p)
        BL_FARRAY1(c)

        integer is,js,ks,ie,je,ke, i,j,k
        REAL_T shktst, zcut1, zcut2, dzcut
        REAL_T denom, zeta, tst, tmp

#include "xxmeth.fh"

c ::: ::::: knobs for detection of strong shock
#ifdef  BL_USE_FLOAT_CONST
      data shktst /0.33/
      data zcut1 /0.75/
      data zcut2 /0.85/
#endif
#ifdef  BL_USE_DOUBLE_CONST
      data shktst /0.33d0/
      data zcut1 /0.75d0/
      data zcut2 /0.85d0/
#endif

        dzcut = one/(zcut2-zcut1)

        is = q_l1
        ie = q_h1
        js = q_l2
        je = q_h2
        ks = q_l3
        ke = q_h3

        if(iorder .eq. 3) then
          return
        else
c
c  this is a hack.  need to compute the pressure from the state in
c  a general way.
c
#if 0
        do i = is,ie
          do j = js,je
            do k = ks,ke
              p(i,j,k) = q(i,j,k,QPRES)
              c(i,j,k) = sqrt(onepointfour*p(i,j,k)/q(i,j,k,QRHO))
            enddo
          enddo
        enddo
#endif

c
c  could use z or chi limits equivalently
c
        is = dp_l1
        ie = dp_h1
        js = dp_l2
        je = dp_h2
        ks = dp_l3
        ke = dp_h3

        do k = ks,ke
          do j = js,je
            do i = is,ie
              dp(i,j,k) = p(i,j+1,k)-p(i,j-1,k)
              denom = max(smallp,abs(p(i,j+2,k)-p(i,j-2,k)))
              zeta = abs(dp(i,j,k))/denom
              z(i,j,k) = min(one,max(zero, dzcut*(zeta-zcut1)))
              tst = cvmgp(one,zero,q(i,j-1,k,QVEL2)-q(i,j+1,k,QVEL2))
              tmp = min(q(i,j+1,k,QRHO)*c(i,j+1,k)**2,q(i,j-1,k,QRHO)*c(i,j-1,k)**2)
              chi(i,j,k) = cvmgt(tst,zero,(abs(dp(i,j,k))/tmp).gt.shktst)
            enddo
          enddo
        enddo

        is = flatn_l1
        ie = flatn_h1
        js = flatn_l2
        je = flatn_h2
        ks = flatn_l3
        ke = flatn_h3

        do k = ks,ke
          do j = js,je
            do i = is,ie
              flatn(i,j,k) = one-max(chi(i,j-1,k)*z(i,j-1,k),chi(i,j,k)*z(i,j,k),
     $            chi(i,j+1,k)*z(i,j+1,k))
            enddo
          enddo
        enddo

        endif

        end

        subroutine FORT_FLATENZ(BL_FARG(q),BL_FARG(flatn),
     $          BL_FARG(dp), BL_FARG(z), BL_FARG(chi),
     $          BL_FARG(p), BL_FARG(c),nv)
        integer nv
        BL_FBOUNDS(q)
        BL_FBOUNDS(flatn)
        BL_FBOUNDS(dp)
        BL_FBOUNDS(z)
        BL_FBOUNDS(chi)
        BL_FBOUNDS(p)
        BL_FBOUNDS(c)

        BL_FARRAY(q,nv)
        BL_FARRAY1(flatn)
        BL_FARRAY1(dp)
        BL_FARRAY1(z)
        BL_FARRAY1(chi)
        BL_FARRAY1(p)
        BL_FARRAY1(c)

        integer is,js,ks,ie,je,ke, i,j,k
        REAL_T shktst, zcut1, zcut2, dzcut
        REAL_T denom, zeta, tst, tmp

#include "xxmeth.fh"

c ::: ::::: knobs for detection of strong shock
#ifdef  BL_USE_FLOAT_CONST
      data shktst /0.33/
      data zcut1 /0.75/
      data zcut2 /0.85/
#endif
#ifdef  BL_USE_DOUBLE_CONST
      data shktst /0.33d0/
      data zcut1 /0.75d0/
      data zcut2 /0.85d0/
#endif

        dzcut = one/(zcut2-zcut1)

        is = q_l1
        ie = q_h1
        js = q_l2
        je = q_h2
        ks = q_l3
        ke = q_h3

        if(iorder .eq. 3) then
          return
        else
c
c  this is a hack.  need to compute the pressure from the state in
c  a general way.
c
#if 0
        do i = is,ie
          do j = js,je
            do k = ks,ke
              p(i,j,k) = q(i,j,k,QPRES)
              c(i,j,k) = sqrt(onepointfour*p(i,j,k)/q(i,j,k,QRHO))
            enddo
          enddo
        enddo
#endif

c
c  could use z or chi limits equivalently
c
        is = dp_l1
        ie = dp_h1
        js = dp_l2
        je = dp_h2
        ks = dp_l3
        ke = dp_h3

        do k = ks,ke
          do j = js,je
            do i = is,ie
              dp(i,j,k) = p(i,j,k+1)-p(i,j,k-1)
              denom = max(smallp,abs(p(i,j,k+2)-p(i,j,k-2)))
              zeta = abs(dp(i,j,k))/denom
              z(i,j,k) = min(one,max(zero, dzcut*(zeta-zcut1)))
              tst = cvmgp(one,zero,q(i,j,k-1,QVEL3)-q(i,j,k+1,QVEL3))
              tmp = min(q(i,j,k+1,QRHO)*c(i,j,k+1)**2,q(i,j,k-1,QRHO)*c(i,j,k-1)**2)
              chi(i,j,k) = cvmgt(tst,zero,(abs(dp(i,j,k))/tmp).gt.shktst)
            enddo
          enddo
        enddo

        is = flatn_l1
        ie = flatn_h1
        js = flatn_l2
        je = flatn_h2
        ks = flatn_l3
        ke = flatn_h3

        do k = ks,ke
          do j = js,je
            do i = is,ie
              flatn(i,j,k) = one-max(chi(i,j,k-1)*z(i,j,k-1),chi(i,j,k)*z(i,j,k),
     $            chi(i,j,k+1)*z(i,j,k+1))
            enddo
          enddo
        enddo

        endif

        end

c
c---------------------------------------------------------------
c::  X-slopes for characteristic tracing
c::  Arguments:
c::  s         => primitive variables
c::  slx      <= slopes
c::  bc        => bndry condition flags
c::  nvar      => number of advected quantities.
c ---------------------------------------------------------------
c
      subroutine FORT_SLOPEX(BL_FARG(s),BL_FARG(slx),BL_FARG(flatn),
     $  BL_FARG(scen),BL_FARG(ssgn),BL_FARG(slim),BL_FARG(dsf),nv,gBndry)
      integer nv,gBndry(0:2*SDIM-1)

      BL_FBOUNDS(s)
      BL_FBOUNDS(slx)
      BL_FBOUNDS(flatn)
      BL_FBOUNDS(scen)
      BL_FBOUNDS(ssgn)
      BL_FBOUNDS(slim)
      BL_FBOUNDS(dsf)

      BL_FARRAY(s,nv)
      BL_FARRAY(slx,nv)
      BL_FARRAY1(flatn)
      BL_FARRAY1(scen)
      BL_FARRAY1(ssgn)
      BL_FARRAY1(slim)
      BL_FARRAY1(dsf)


      REAL_T dpls,dmin,ds
      REAL_T del,sflag, dq4

      integer is,js,ks,ie,je,ke,i,j,k,iv

#include "xxmeth.fh"


      if(iorder .eq. 1) then
        return
      else

      do 100 iv = 1,nv

          is = dsf_l1
          js = dsf_l2
          ks = dsf_l3
          ie = dsf_h1
          je = dsf_h2
          ke = dsf_h3

          do k = ks,ke
            do j = js,je
              do i = is,ie
                scen(i,j,k) = (s(i+1,j,k,iv)-s(i-1,j,k,iv))
                dpls = (s(i+1,j,k,iv) - s(i ,j,k,iv))
                dmin = (s(i ,j,k,iv) - s(i-1,j,k,iv))
                ssgn(i,j,k) = sign(one,scen(i,j,k))
                slim(i,j,k) = two*min(abs(dpls),abs(dmin))
                slim(i,j,k) = cvmgp(slim(i,j,k),zero,dpls*dmin)
                dsf(i,j,k) = ssgn(i,j,k)*min(half*abs(scen(i,j,k)),slim(i,j,k))
              enddo
            enddo
          enddo

          is = slx_l1
          js = slx_l2
          ks = slx_l3
          ie = slx_h1
          je = slx_h2
          ke = slx_h3

          do k = ks,ke
            do j = js,je
              do i = is,ie
                dq4 = two3rd*(scen(i,j,k) - forth*(dsf(i+1,j,k)+dsf(i-1,j,k)))
                slx(i,j,k,iv) = ssgn(i,j,k)*flatn(i,j,k)*min(abs(dq4),slim(i,j,k))
              enddo
            enddo
          enddo

100       continue
        endif

          end

c
c---------------------------------------------------------------
c::  Y-slopes for characteristic tracing
c::  Arguments:
c::  s         => primitive variables
c::  slx      <= slopes
c::  bc        => bndry condition flags
c::  nvar      => number of advected quantities.
c ---------------------------------------------------------------
c
      subroutine FORT_SLOPEY(BL_FARG(s),BL_FARG(sly),BL_FARG(flatn),
     $  BL_FARG(scen),BL_FARG(ssgn),BL_FARG(slim),BL_FARG(dsf),nv,gBndry)
      integer nv,gBndry(0:SDIM*SDIM-1)

      BL_FBOUNDS(s)
      BL_FBOUNDS(sly)
      BL_FBOUNDS(flatn)
      BL_FBOUNDS(scen)
      BL_FBOUNDS(ssgn)
      BL_FBOUNDS(slim)
      BL_FBOUNDS(dsf)

      BL_FARRAY(s,nv)
      BL_FARRAY(sly,nv)
      BL_FARRAY1(flatn)
      BL_FARRAY1(scen)
      BL_FARRAY1(ssgn)
      BL_FARRAY1(slim)
      BL_FARRAY1(dsf)


      REAL_T dpls,dmin,ds
      REAL_T del,sflag, dq4

      integer is,js,ks,ie,je,ke,i,j,k,iv

#include "xxmeth.fh"



      if(iorder .eq. 1) then
         return
      else
      do 100 iv = 1,nv

          is = dsf_l1
          js = dsf_l2
          ks = dsf_l3
          ie = dsf_h1
          je = dsf_h2
          ke = dsf_h3

          do k = ks,ke
            do j = js,je
              do i = is,ie
                scen(i,j,k) = (s(i,j+1,k,iv)-s(i,j-1,k,iv))
                dpls = (s(i,j+1,k,iv) - s(i ,j,k,iv))
                dmin = (s(i ,j,k,iv) - s(i,j-1,k,iv))
                ssgn(i,j,k) = sign(one,scen(i,j,k))
                slim(i,j,k) = two*min(abs(dpls),abs(dmin))
                slim(i,j,k) = cvmgp(slim(i,j,k),zero,dpls*dmin)
                dsf(i,j,k) = ssgn(i,j,k)*min(half*abs(scen(i,j,k)),slim(i,j,k))
              enddo
            enddo
          enddo

          is = sly_l1
          js = sly_l2
          ks = sly_l3
          ie = sly_h1
          je = sly_h2
          ke = sly_h3

          do k = ks,ke
            do j = js,je
              do i = is,ie
                dq4 = two3rd*(scen(i,j,k) - forth*(dsf(i,j+1,k)+dsf(i,j-1,k)))
                sly(i,j,k,iv) = ssgn(i,j,k)*flatn(i,j,k)*min(abs(dq4),slim(i,j,k))
              enddo
            enddo
          enddo

100   continue
      endif

          end

c
c---------------------------------------------------------------
c::  Z-slopes for characteristic tracing
c::  Arguments:
c::  s         => primitive variables
c::  slx      <= slopes
c::  bc        => bndry condition flags
c::  nvar      => number of advected quantities.
c ---------------------------------------------------------------
c
      subroutine FORT_SLOPEZ(BL_FARG(s),BL_FARG(sly),BL_FARG(flatn),
     $  BL_FARG(scen),BL_FARG(ssgn),BL_FARG(slim),BL_FARG(dsf),nv,gBndry)
      integer nv,gBndry(0:SDIM*SDIM-1)

      BL_FBOUNDS(s)
      BL_FBOUNDS(sly)
      BL_FBOUNDS(flatn)
      BL_FBOUNDS(scen)
      BL_FBOUNDS(ssgn)
      BL_FBOUNDS(slim)
      BL_FBOUNDS(dsf)

      BL_FARRAY(s,nv)
      BL_FARRAY(sly,nv)
      BL_FARRAY1(flatn)
      BL_FARRAY1(scen)
      BL_FARRAY1(ssgn)
      BL_FARRAY1(slim)
      BL_FARRAY1(dsf)


      REAL_T dpls,dmin,ds
      REAL_T del,sflag, dq4

      integer is,js,ks,ie,je,ke,i,j,k,iv

#include "xxmeth.fh"



      if(iorder .eq. 1) then
         return
      else
      do 100 iv = 1,nv

          is = dsf_l1
          js = dsf_l2
          ks = dsf_l3
          ie = dsf_h1
          je = dsf_h2
          ke = dsf_h3

          do k = ks,ke
            do j = js,je
              do i = is,ie
                scen(i,j,k) = (s(i,j,k+1,iv)-s(i,j,k-1,iv))
                dpls = (s(i,j,k+1,iv) - s(i ,j,k,iv))
                dmin = (s(i ,j,k,iv) - s(i,j,k-1,iv))
                ssgn(i,j,k) = sign(one,scen(i,j,k))
                slim(i,j,k) = two*min(abs(dpls),abs(dmin))
                slim(i,j,k) = cvmgp(slim(i,j,k),zero,dpls*dmin)
                dsf(i,j,k) = ssgn(i,j,k)*min(half*abs(scen(i,j,k)),slim(i,j,k))
              enddo
            enddo
          enddo

          is = sly_l1
          js = sly_l2
          ks = sly_l3
          ie = sly_h1
          je = sly_h2
          ke = sly_h3

          do k = ks,ke
            do j = js,je
              do i = is,ie
                dq4 = two3rd*(scen(i,j,k) - forth*(dsf(i,j,k+1)+dsf(i,j,k-1)))
                sly(i,j,k,iv) = ssgn(i,j,k)*flatn(i,j,k)*min(abs(dq4),slim(i,j,k))
              enddo
            enddo
          enddo

100   continue
      endif

          end

c
c---------------------------------------------------------------
c::  X-slopes for characteristic tracing
c::  Arguments:
c::  s         => primitive variables
c::  slx      <= slopes                            
c::  bc        => bndry condition flags
c::  nvar      => number of advected quantities.
c ---------------------------------------------------------------
c
      subroutine FORT_SLOPEX2(BL_FARG(s),BL_FARG(slx),nv,gBndry)
      integer nv,gBndry(0:2*SDIM-1)
      BL_FBOUNDS(s)                  
      BL_FARRAY(s,nv)
      BL_FBOUNDS(slx)
      BL_FARRAY(slx,nv)

      REAL_T dpls,dmin,ds
      REAL_T del,slim,sflag


      integer is,js,ks,ie,je,ke,i,j,k,iv

      is = slx_l1
      js = slx_l2 
      ks = slx_l3 
      ie = slx_h1 
      je = slx_h2 
      ke = slx_h3 


      do 100 iv = 1,nv
 
         do 150 k = ks,ke
          do 160 j = js,je
            do 170 i = is,ie
              del = half*(s(i+1,j,k,iv)-s(i-1,j,k,iv))
              dpls = two*(s(i+1,j,k,iv) - s(i ,j,k,iv))
              dmin = two*(s(i ,j,k,iv) - s(i-1,j,k,iv))
              slim = min(abs(dpls), abs(dmin))
              slim = cvmgp(slim, zero, dpls*dmin)
              sflag = sign(one,del)
              slx(i,j,k,iv)= sflag*min(slim,abs(del))
170         continue
160       continue
150       continue
             

100       continue

	  end
c
c ---------------------------------------------------------------
c::  Y-slopes for characteristic tracing
c::  Arguments:
c::  s         => primitive variables
c::  sly      <= slopes                                    
c::  bc        => bndry condition flags
c::  nvar      => number of advected quantities.
c ---------------------------------------------------------------
c
      subroutine FORT_SLOPEY2(BL_FARG(s),BL_FARG(sly),nv,gBndry)
      integer nv,gBndry(0:2*SDIM-1)
      BL_FBOUNDS(s)                  
      BL_FARRAY(s,nv)
      BL_FBOUNDS(sly)
      BL_FARRAY(sly,nv)

      REAL_T dpls,dmin,ds
      REAL_T del,slim,sflag


      integer is,js,ks,ie,je,ke,i,j,k,iv

      is = sly_l1 
      js = sly_l2 
      ks = sly_l3 
      ie = sly_h1 
      je = sly_h2 
      ke = sly_h3 


      do 150 iv = 1,nv
 
        do 170 k = ks,ke
          do 180 j = js,je
            do 190 i = is,ie

              del = half*(s(i,j+1,k,iv)-s(i,j-1,k,iv))
              dpls = two*(s(i,j+1,k,iv) - s(i,j,k,iv ))
              dmin = two*(s(i,j,k,iv ) - s(i,j-1,k,iv))
              slim = min(abs(dpls),abs(dmin))
              slim = cvmgp(slim, zero, dpls*dmin)
              sflag = sign(one,del)
              sly(i,j,k,iv)= sflag*min(slim,abs(del))
190         continue
180       continue
170     continue

150     continue

      end

c
c ---------------------------------------------------------------
c::  z-slopes for characteristic tracing
c::  Arguments:
c::  s         => primitive variables
c::  sly      <= slopes                                    
c::  bc        => bndry condition flags
c::  nvar      => number of advected quantities.
c ---------------------------------------------------------------
c
      subroutine FORT_SLOPEZ2(BL_FARG(s),BL_FARG(slz),nv,gBndry)
      integer nv,gBndry(0:2*SDIM-1)
      BL_FBOUNDS(s)                  
      BL_FARRAY(s,nv)
      BL_FBOUNDS(slz)
      BL_FARRAY(slz,nv)

      REAL_T dpls,dmin,ds
      REAL_T del,slim,sflag


      integer is,js,ks,ie,je,ke,i,j,k,iv

      is = slz_l1 
      js = slz_l2 
      ks = slz_l3 
      ie = slz_h1 
      je = slz_h2 
      ke = slz_h3 


      do 150 iv = 1,nv
 
        do 170 k = ks,ke
          do 180 j = js,je
            do 190 i = is,ie

              del = half*(s(i,j,k+1,iv)-s(i,j,k-1,iv))
              dpls = two*(s(i,j,k+1,iv) - s(i,j,k,iv ))
              dmin = two*(s(i,j,k,iv ) - s(i,j,k-1,iv))
              slim = min(abs(dpls),abs(dmin))
              slim = cvmgp(slim, zero, dpls*dmin)
              sflag = sign(one,del)
              slz(i,j,k,iv)= sflag*min(slim,abs(del))

190         continue
180       continue
170     continue

150     continue

      end

