/*
** (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) 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_2D.F,v 1.1 2002/04/11 22:36:43 marc 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"
      
#define SDIM 2
#define NGHOST 3
#define LEFT	 0
#define RIGHT	 1
#define BOTTOM	 2
#define TOP 	 3
#define INTERIOR -1
#define ON_PHYS_B 0
#define NQ	 (5+NADV)

#if __STDC__==1
#define BL_ARGL1(u) u##_l1
#define BL_ARGL2(u) u##_l2
#define BL_ARGH1(u) u##_h1
#define BL_ARGH2(u) u##_h2
#define BL_IARG(u) u##_l1, u##_l2, u##_h1, u##_h2
#define BL_UVAR(u,v) REAL_T u(v##_l1:v##_h1, v##_l2:v##_h2)
#else
#define BL_ARGL1(u) u/**/_l1
#define BL_ARGL2(u) u/**/_l2
#define BL_ARGH1(u) u/**/_h1
#define BL_ARGH2(u) u/**/_h2
#define BL_IARG(u) u/**/_l1, u/**/_l2, u/**/_h1, u/**/_h2
#define BL_UVAR(u,v) REAL_T u(v/**/_l1:v/**/_h1, v/**/_l2:v/**/_h2)
#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(2), b##hi(2)
#else
#define BL_BARG(b) b/**/lo, b/**/hi
#define BL_BBOUNDS(b) integer b/**/lo(2), b/**/hi(2)
#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  QPRES   4
#define  QRHOE   5
#if(NADV>0)
#define  QADV    6
#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:SDIM*SDIM-1)
      integer bc(SDIM,2,nvar-1),qbc(SDIM,2,NQ)
      REAL_T  delta(SDIM), dt

      BL_FBOUNDS(q)
      BL_FBOUNDS(qx)
      BL_FBOUNDS(c)
      BL_FBOUNDS(enth)
      BL_FBOUNDS(qbarl)
      BL_FBOUNDS(qbarr)
      BL_FBOUNDS(dloga)
      BL_FBOUNDS(courno)
      BL_BBOUNDS(bx)

      BL_FARRAY(q,nvar)
      BL_FARRAY(qx,nvar)
      BL_FARRAY(qbarl,nvar)
      BL_FARRAY(qbarr,nvar)
      BL_FARRAY1(c)
      BL_FARRAY1(enth)
      BL_FARRAY1(dloga)
      BL_FARRAY1(courno)

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

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

      smallr = 1.0d-6
      dtbydx = dt/dx

#if 0
c ::: convert energy to intensive form for eos call
      do j = js,je
        do i =is,ie
	  RHOE(i,j) = RHOE(i,j)/RHO(i,j)
        end do
      end do

      call eos(RHO(is,js),RHOE(is,js),
     $         gdum,pdum,c,csdum,bxlo,bxhi,0,0,1,0)

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

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

c ::: :::::  Right state of edge at left
          spminus = cvmgp(-one,(U(i,j) - c(i,j))*dtbydx,U(i,j) - c(i,j))
          spplus = cvmgp(-one,(U(i,j) + c(i,j))*dtbydx,U(i,j) + c(i,j))
          spzero = cvmgp(-one, U(i,j) *dtbydx,U(i,j) )
          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
          qbarr(i,j,QRHO) = q(i,j,QRHO) + apright + amright + azrright
          qbarr(i,j,QRHO) = max(smallr, qbarr(i,j,QRHO))
          qbarr(i,j,QVEL1) = q(i,j,QVEL1) +
     $                      (apright - amright)*c(i,j)/RHO(i,j)
          qbarr(i,j,QVEL2) = q(i,j,QVEL2) + azv1rght
          qbarr(i,j,QPRES) = q(i,j,QPRES) +
     $                      (apright + amright)*c(i,j)**2
          qbarr(i,j,QRHOE) = q(i,j,QRHOE) + (apright +
     $                       amright)*enth(i,j)*c(i,j)**2 + azeright
#if(NADV>0)
          qbarr(i,j,QADV) = q(i,j,QADV)+half*(-one-spzero)*DADV(i,j)
#endif

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

          spminus = cvmgp((U(i,j) - c(i,j))*dtbydx,one,U(i,j) - c(i,j))
          spplus = cvmgp((U(i,j) + c(i,j))*dtbydx,one,U(i,j) + c(i,j))
          spzero = cvmgp( U(i,j) *dtbydx,one,U(i,j) )
          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
          qbarl(i+1,j,QRHO) = q(i,j,QRHO) + apleft + amleft + azrleft
          qbarl(i+1,j,QRHO) = max(smallr, qbarl(i+1,j,QRHO))
          qbarl(i+1,j,QVEL1) = q(i,j,QVEL1) +
     $                         (apleft - amleft)*c(i,j)/RHO(i,j)
          qbarl(i+1,j,QVEL2) = q(i,j,QVEL2) + azv1left
          qbarl(i+1,j,QPRES) = q(i,j,QPRES) +
     $                         (apleft + amleft)*c(i,j)**2
          qbarl(i+1,j,QRHOE) = q(i,j,QRHOE) + (apleft + amleft)*
     $                         enth(i,j)*c(i,j)**2 + azeleft
#if(NADV>0)
          qbarl(i+1,j,QADV) = q(i,j,QADV)+half*(one-spzero)*DADV(i,j)
#endif
        end do
      end do
          

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

      dthalf = half*dt
c ::: add geometric source terms to traced states
      do j = jsedg,jeedg
        do i = isedg,ieedg-1
          sourcr = -RHO(i,j)*dloga(i,j)*U(i,j)*dthalf
          sourcp = sourcr*c(i,j)**2
          source = sourcp*enth(i,j)
          qbarl(i+1,j,QRHO) = qbarl(i+1,j,QRHO) + sourcr
          qbarl(i+1,j,QRHO) = max(smallr, qbarl(i+1,j,QRHO))
          qbarl(i+1,j,QPRES) = qbarl(i+1,j,QPRES) + sourcp
          qbarl(i+1,j,QRHOE) = qbarl(i+1,j,QRHOE) + source
          qbarr(i,j ,QRHO) = qbarr(i,j ,QRHO) + sourcr
          qbarr(i,j ,QRHO) = max(smallr, qbarr(i,j,QRHO))
          qbarr(i,j ,QPRES) = qbarr(i,j ,QPRES) + sourcp
          qbarr(i,j ,QRHOE) = qbarr(i,j ,QRHOE) + source
        end do
      end do
#if 0
c ::: convert energy back to intensive form 
c ::: for eos call in RIEMANN
      do j = js,je
        do i =is,ie
	  RHOE(i,j) = RHOE(i,j)/RHO(i,j)
        end do
      end do
#endif
#if 0
c     warning: nqvar = nstatevar+1
      do n = 1, nvar-1
       qbc(1,1,n) = bc(1,1,n)
       qbc(1,2,n) = bc(1,2,n)
       qbc(2,1,n) = bc(2,1,n)
       qbc(2,2,n) = bc(2,2,n)
      end do
       qbc(1,1,nvar) = qbc(1,1,nvar-1)
       qbc(1,2,nvar) = qbc(1,2,nvar-1)
       qbc(2,1,nvar) = qbc(2,1,nvar-1)
       qbc(2,2,nvar) = qbc(2,2,nvar-1)
      
      do n = 1,nvar
        do j = jsedg,jeedg
         reflect = cvmgt(-one,one,qbc(1,1,n).eq.REFLECT_ODD)
           i = isedg
            qbarl(i,j,n) = reflect*qbarr(i,j,n)
         reflect = cvmgt(-one,one,qbc(1,2,n).eq.REFLECT_ODD)
          i = ieedg
           qbarr(i,j,n) = reflect*qbarl(i,j,n)
        end do
      end do

#endif

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

      return
      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  QPRES   4
#define  QRHOE   5
#if(NADV>0)
#define  QADV    6
#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:SDIM*SDIM-1)
      integer bc(SDIM,2,nvar-1),qbc(SDIM,2,NQ)
      REAL_T  delta(SDIM), dt

      BL_FBOUNDS(q)
      BL_FBOUNDS(qy)
      BL_FBOUNDS(qbarl)
      BL_FBOUNDS(qbarr)
      BL_FBOUNDS(c)
      BL_FBOUNDS(enth)
      BL_FBOUNDS(dloga)
      BL_FBOUNDS(courno)
      BL_BBOUNDS(bx)

      BL_FARRAY(q,nvar)
      BL_FARRAY(qy,nvar)
      BL_FARRAY(qbarl,nvar)
      BL_FARRAY(qbarr,nvar)
      BL_FARRAY1(c)
      BL_FARRAY1(enth)
      BL_FARRAY1(dloga)
      BL_FARRAY1(courno)

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

      REAL_T gdum,csdum,pdum

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

      isedg = qbarl_l1
      ieedg = qbarl_h1
      jsedg = qbarl_l2
      jeedg = qbarl_h2


      smallr = 1.0d-6
      dtbydx = dt/dx

c ::: convert energy to intensive form for eos call
#if 0
      do j = js,je
        do i =is,ie
	  RHOE(i,j) = RHOE(i,j)/RHO(i,j)
        end do
      end do

      call eos(RHO(is,js),RHOE(is,js),
     $         gdum,pdum,c,csdum,bxlo,bxhi,0,0,1,0)

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

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

c ::: :::::  Top state of edge at bottom
          spminus = cvmgp(-one,(V(i,j) - c(i,j))*dtbydx,V(i,j) - c(i,j))
          spplus = cvmgp(-one,(V(i,j) + c(i,j))*dtbydx,V(i,j) + c(i,j))
          spzero = cvmgp(-one, V(i,j) *dtbydx,V(i,j) )
          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
          qbarr(i,j,QRHO) = q(i,j,QRHO) + apright + amright + azrright
          qbarr(i,j,QRHO) = max(smallr, qbarr(i,j,QRHO))
          qbarr(i,j,QVEL2) = q(i,j,QVEL2) +
     $                      (apright - amright)*c(i,j)/RHO(i,j)
          qbarr(i,j,QVEL1) = q(i,j,QVEL1) + azv1rght
          qbarr(i,j,QPRES) = q(i,j,QPRES) +
     $                      (apright + amright)*c(i,j)**2
          qbarr(i,j,QRHOE) = q(i,j,QRHOE) + (apright +
     $                       amright)*enth(i,j)*c(i,j)**2 + azeright
#if(NADV>0)
          qbarr(i,j,QADV) = q(i,j,QADV)+half*(-one-spzero)*DADV(i,j)
#endif

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

          spminus = cvmgp((V(i,j) - c(i,j))*dtbydx,one,V(i,j) - c(i,j))
          spplus = cvmgp((V(i,j) + c(i,j))*dtbydx,one,V(i,j) + c(i,j))
          spzero = cvmgp( V(i,j) *dtbydx,one,V(i,j) )
          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
          qbarl(i,j+1,QRHO) = q(i,j,QRHO) + apleft + amleft + azrleft
          qbarl(i,j+1,QRHO) = max(smallr, qbarl(i,j+1,QRHO))
          qbarl(i,j+1,QVEL2) = q(i,j,QVEL2) +
     $                         (apleft - amleft)*c(i,j)/RHO(i,j)
          qbarl(i,j+1,QVEL1) = q(i,j,QVEL1) + azv1left
          qbarl(i,j+1,QPRES) = q(i,j,QPRES) +
     $                         (apleft + amleft)*c(i,j)**2
          qbarl(i,j+1,QRHOE) = q(i,j,QRHOE) + (apleft + amleft)*
     $                         enth(i,j)*c(i,j)**2 + azeleft
#if(NADV>0)
          qbarl(i,j+1,QADV) = q(i,j,QADV)+half*(one-spzero)*DADV(i,j)
#endif
        end do
      end do
          

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

      dthalf = half*dt
c ::: add geometric source terms to traced states
      do j = jsedg,jeedg-1
        do i = isedg,ieedg
          sourcr = -RHO(i,j)*dloga(i,j)*V(i,j)*dthalf
          sourcp = sourcr*c(i,j)**2
          source = sourcp*enth(i,j)
          qbarl(i,j+1,QRHO) = qbarl(i,j+1,QRHO) + sourcr
          qbarl(i,j+1,QRHO) = max(smallr, qbarl(i,j+1,QRHO))
          qbarl(i,j+1,QPRES) = qbarl(i,j+1,QPRES) + sourcp
          qbarl(i,j+1,QRHOE) = qbarl(i,j+1,QRHOE) + source
          qbarr(i,j ,QRHO) = qbarr(i,j ,QRHO) + sourcr
          qbarr(i,j ,QRHO) = max(smallr, qbarr(i,j,QRHO))
          qbarr(i,j ,QPRES) = qbarr(i,j ,QPRES) + sourcp
          qbarr(i,j ,QRHOE) = qbarr(i,j ,QRHOE) + source
        end do
      end do
#if 0
c ::: convert energy back to intensive form 
c ::: for eos call in RIEMANN
      do j = js,je
        do i =is,ie
	  RHOE(i,j) = RHOE(i,j)/RHO(i,j)
        end do
      end do
#endif

#if 0
c     warning: nqvar = nstatevar+1
      do n = 1, nvar-1
       qbc(1,1,n) = bc(1,1,n)
       qbc(1,2,n) = bc(1,2,n)
       qbc(2,1,n) = bc(2,1,n)
       qbc(2,2,n) = bc(2,2,n)
      end do
       qbc(1,1,nvar) = qbc(1,1,nvar-1)
       qbc(1,2,nvar) = qbc(1,2,nvar-1)
       qbc(2,1,nvar) = qbc(2,1,nvar-1)
       qbc(2,2,nvar) = qbc(2,2,nvar-1)
      
      
      do n = 1,nvar
        do i = isedg,ieedg
         j = jsedg
         reflect = cvmgt(-one,one,qbc(2,1,n).eq.REFLECT_ODD)
c        reflect = one
          qbarl(i,j,n) = reflect*qbarr(i,j,n)
         j = jeedg
         reflect = cvmgt(-one,one,qbc(2,2,n).eq.REFLECT_ODD)
c        reflect = one
          qbarr(i,j,n) = reflect*qbarl(i,j,n)
        end do
      end do

#endif

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

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

      subroutine FORT_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_FBOUNDS(qbarp)
      BL_FBOUNDS(c)
      BL_FBOUNDS(rho)
      BL_FBOUNDS(e)
      BL_FBOUNDS(adv)
      BL_FBOUNDS(csml)
      BL_FBOUNDS(gamc)
      BL_FBOUNDS(rgdnv)
      BL_FBOUNDS(ugdnv)
      BL_FBOUNDS(pgdnv)
      BL_FBOUNDS(egdnv)
      BL_FBOUNDS(utgdnv)
#if(NADV>0)
      BL_FBOUNDS(advgdnv)
#endif
      BL_FBOUNDS(ustar)
      BL_FBOUNDS(flux)
      BL_BBOUNDS(bx)

      BL_FARRAY(qbarm,npvar)
      BL_FARRAY(qbarp,npvar)
      BL_FARRAY1(c)
      BL_FARRAY1(rho)
      BL_FARRAY1(e)
      BL_FARRAY1(adv)
      BL_FARRAY1(csml)
      BL_FARRAY1(gamc)
      BL_FARRAY1(rgdnv)
      BL_FARRAY1(ugdnv)
      BL_FARRAY1(pgdnv)
      BL_FARRAY1(egdnv)
      BL_FARRAY1(utgdnv)
#if(NADV>0)
      BL_FARRAY1(advgdnv)
#endif
      BL_FARRAY1(ustar)
      BL_FARRAY(flux,nsvar)

      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,pdum, small

      integer qvnrml, qvtrns
      integer is,ie,js,je, i,j
      integer    lo(2), hi(2)

      
      if(sweep.eq.0)then
c     ::: x-direction
        qvnrml = QVEL1
        qvtrns = QVEL2
      else if(sweep.eq.1)then
c     ::: y-direction
        qvnrml = QVEL2
        qvtrns = QVEL1
      else
        print *,'Abort: Bogus sweep value passed to RIEMANN'
        write(6,*) 'sweep = ', sweep
        stop
      end if

      smallr = 1.0d-6
      small = 1.0d-6

      is = flux_l1
      ie = flux_h1
      js = flux_l2
      je = flux_h2
      
#if 0
      call eos(rho,e,gamc,pdum,c,csml,bxlo,bxhi,1,0,1,1)
#endif

      do j = js,je          
        do i = is,ie          

          if(sweep.eq.0)then
            csmall = max(csml(i-1,j),csml(i,j))
            cav = half*(c(i,j) + c(i-1,j))
            wsmall = smallr*csmall
            wl = max(wsmall,sqrt(abs(gamc(i-1,j)*
     $           qbarm(i,j,QPRES)*qbarm(i,j,QRHO))))
          else
            csmall = max(csml(i,j-1),csml(i,j))
            cav = half*(c(i,j) + c(i,j-1))
            wsmall = smallr*csmall
            wl = max(wsmall,sqrt(abs(gamc(i,j-1)*
     $           qbarm(i,j,QPRES)*qbarm(i,j,QRHO))))
          end if


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

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

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

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

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

          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))
          spout = co - sgnm*uo
          spin = cstar - sgnm*ustar(i,j)
          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) = cvmgp(qbarm(i,j,qvtrns),qbarp(i,j,qvtrns),ustar(i,j))
#if(NADV>0)
          advgdnv(i,j) = cvmgp(qbarm(i,j,QADV),qbarp(i,j,QADV), ustar(i,j))
#endif
          rgdnv(i,j) = frac*rstar + (one - frac)*ro
          ugdnv(i,j) = frac*ustar(i,j) + (one - frac)*uo
          pgdnv(i,j) = frac*pstar + (one - frac)*po
          egdnv(i,j) = frac*estar + (one - frac)*eo

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

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

        end do
      end do

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

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

        end do
      end do

      return
      end



      subroutine FORT_DIVF(
     &          BL_FARG(state),
     &          BL_FARG(div_f),
     &          BL_FARG(xflux),
     &          BL_FARG(yflux),
     &          BL_BARG(bx),
     &          delta, dt, nvar
     &		)

        integer nvar
        REAL_T  delta(SDIM), dt

	BL_FBOUNDS(state)
	BL_FBOUNDS(div_f)
	BL_FBOUNDS(xflux)
	BL_FBOUNDS(yflux)
	BL_BBOUNDS(bx)

	BL_FARRAY(state,nvar)
	BL_FARRAY(div_f,nvar)
	BL_FARRAY(xflux,nvar)
	BL_FARRAY(yflux,nvar)

        integer i, j, n
        integer is, ie, js, je
        REAL_T  hx, hy, vol
        
        hx = delta(1)
        hy = delta(2)
        vol = hx*hy
        is = bxlo(1)
        ie = bxhi(1)
        js = bxlo(2)
        je = bxhi(2)



c	::::: Compute div(u*s). Note the sign.
	do n = 1,nvar
        do i = is, ie
           do j = js, je
              div_f(i,j,n) = 
     &                -    (xflux(i,j,n) - xflux(i+1,j,n)
     &                +     yflux(i,j,n) - yflux(i,j+1,n))/vol
           end do
        end do

        end do
	
      return
      end

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

        integer nvar
        REAL_T  delta(SDIM), dt

	BL_FBOUNDS(state)
	BL_FBOUNDS(xflux)
	BL_FBOUNDS(yflux)
	BL_FBOUNDS(gstate)
	BL_BBOUNDS(bx)

	BL_FARRAY(state,nvar)
	BL_FARRAY(xflux,nvar)
	BL_FARRAY(yflux,nvar)
	BL_FARRAY(gstate,nvar)

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


	do n = 1,nvar
        do i = is, ie
           do j = js, je
              gstate(i,j,n) = state(i,j,n)
           end do
        end do
        end do
	
      return
      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:SDIM*SDIM-1)
        REAL_T delta(SDIM)

        BL_FBOUNDS(state)
        BL_FBOUNDS(div)

        BL_FARRAY(state,nvar)
        BL_FARRAY1(div)

	integer i,j
	REAL_T ux,vy,uij,vij,uimj,vimj,uijm,vijm,uimjm,vimjm


      
      do j = div_l2,div_h2
	 do i = div_l1, div_h1

         uij = state(i,j,2)/state(i,j,1)  
         vij = state(i,j,3)/state(i,j,1)  
         uimj = state(i-1,j,2)/state(i-1,j,1)
         vimj = state(i-1,j,3)/state(i-1,j,1)
         uijm = state(i,j-1,2)/state(i,j-1,1)
         vijm = state(i,j-1,3)/state(i,j-1,1)
         uimjm = state(i-1,j-1,2)/state(i-1,j-1,1)
         vimjm = state(i-1,j-1,3)/state(i-1,j-1,1)

         ux = half* (uij - uimj + uijm - uimjm)/delta(1)
         vy = half* (vij - vijm + vimj - vimjm)/delta(2)

         div(i,j) = ux + vy

         end do
      end do

      return
      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:SDIM*SDIM-1)

      BL_FBOUNDS(s)
      BL_FBOUNDS(slx)

      BL_FARRAY(s,nv)
      BL_FARRAY(slx,nv)

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

      integer is,js,ie,je,i,j,iv

      is = slx_l1
      js = slx_l2
      ie = slx_h1
      je = slx_h2


      do 100 iv = 1,nv

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

100       continue

          return
          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,ie,je, i,j
	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
      data shktst /0.33/
      data zcut1 /0.75/
      data zcut2 /0.85/
#endif
#ifdef  BL_USE_DOUBLE
      data shktst /0.33d0/
      data zcut1 /0.75d0/
      data zcut2 /0.85d0/
#endif

	dzcut = one/(zcut2-zcut1)

c
c  this is a hack.  need to compute the pressure from the state in 
c  a general way.
c

	if(iorder .eq. 3) then
	  return
	else
c
c  could use z or chi limits equivalently
c
        is = dp_l1
        ie = dp_h1
        js = dp_l2
        je = dp_h2
	
	do j = js,je
	  do i = is,ie
	    dp(i,j) =  p(i+1,j)-p(i-1,j)
	    denom = max(smallp,abs(p(i+2,j)-p(i-2,j)))
	    zeta = abs(dp(i,j))/denom
	    z(i,j) = min(one,max(zero, dzcut*(zeta-zcut1)))
	    tst = cvmgp(one,zero,q(i-1,j,QVEL1)-q(i+1,j,QVEL1))
	    tmp = min(q(i+1,j,QRHO)*c(i+1,j)**2,q(i-1,j,QRHO)*c(i-1,j)**2)
	    chi(i,j) = cvmgt(tst,zero,(abs(dp(i,j))/tmp).gt.shktst)
	  end do
	end do

        is = flatn_l1
        ie = flatn_h1
        js = flatn_l2
        je = flatn_h2

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

	end if

	return
	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,ie,je, i,j
	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
      data shktst /0.33/
      data zcut1 /0.75/
      data zcut2 /0.85/
#endif
#ifdef  BL_USE_DOUBLE
      data shktst /0.33d0/
      data zcut1 /0.75d0/
      data zcut2 /0.85d0/
#endif

	dzcut = one/(zcut2-zcut1)

	if(iorder .eq. 3) then
	  return
	else
c
c  could use z or chi limits equivalently
c
        is = dp_l1
        ie = dp_h1
        js = dp_l2
        je = dp_h2
	
	do j = js,je
	  do i = is,ie
	    dp(i,j) = p(i,j+1)-p(i,j-1)
	    denom = max(smallp,abs(p(i,j+2)-p(i,j-2)))
	    zeta = abs(dp(i,j))/denom
	    z(i,j) = min(one,max(zero, dzcut*(zeta-zcut1)))
	    tst = cvmgp(one,zero,q(i,j-1,QVEL2)-q(i,j+1,QVEL2))
	    tmp = min(q(i,j+1,QRHO)*c(i,j+1)**2,q(i,j-1,QRHO)*c(i,j-1)**2)
	    chi(i,j) = cvmgt(tst,zero,(abs(dp(i,j))/tmp).gt.shktst)
	  end do
	end do

        is = flatn_l1
        ie = flatn_h1
        js = flatn_l2
        je = flatn_h2

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

	end if

	return
	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:SDIM*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,ie,je,i,j,iv

#include "xxmeth.fh"


      if(iorder .eq. 1) then
	return
      else

      do 100 iv = 1,nv
 
          is = dsf_l1
          js = dsf_l2
          ie = dsf_h1
          je = dsf_h2

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

	  is = slx_l1
	  ie = slx_h1
	  js = slx_l2
	  je = slx_h2

	  do j = js,je
	    do i = is,ie
	      dq4 = two3rd*(scen(i,j) - forth*(dsf(i+1,j)+dsf(i-1,j))) 
	      slx(i,j,iv) = ssgn(i,j)*flatn(i,j)*min(abs(dq4),slim(i,j))
c	      slx(i,j,iv) = ssgn(i,j)*min(abs(dq4),slim(i,j))
c	slx(i,j,iv) = ssgn(i,j)*min(slim(i,j),half*abs(scen(i,j)))
	    end do
	  end do

100       continue
	end if

          return
	  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,ie,je,i,j,iv

#include "xxmeth.fh"



      if(iorder .eq. 1) then
	 return
      else
      do 100 iv = 1,nv
 
          is = dsf_l1
          js = dsf_l2
          ie = dsf_h1
          je = dsf_h2

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

	  is = sly_l1
	  ie = sly_h1
	  js = sly_l2
	  je = sly_h2

	  do j = js,je
	    do i = is,ie
	      dq4 = two3rd*(scen(i,j) - forth*(dsf(i,j+1)+dsf(i,j-1))) 
	      sly(i,j,iv) = ssgn(i,j)*flatn(i,j)*min(abs(dq4),slim(i,j))
c	      sly(i,j,iv) = ssgn(i,j)*min(abs(dq4),slim(i,j))
c	sly(i,j,iv) = ssgn(i,j)*min(slim(i,j),half*abs(scen(i,j)))
	    end do
	  end do

100   continue
      end if

          return
	  end
c
c ---------------------------------------------------------------
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:SDIM*SDIM-1)

      BL_FBOUNDS(s)                  
      BL_FBOUNDS(sly)

      BL_FARRAY(s,nv)
      BL_FARRAY(sly,nv)

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


      integer is,js,ie,je,i,j,iv

      is = sly_l1
      js = sly_l2
      ie = sly_h1
      je = sly_h2


      do 150 iv = 1,nv
 
          do 180 j = js,je
            do 190 i = is,ie

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

150      continue

      return
      end


c
c ---------------------------------------------------------------
c::  Calculate metric coefficients
c ---------------------------------------------------------------
c
      subroutine FORT_METRICS(BL_FARG(vol),BL_FARG(dloga),BL_FARG(area),
     $                       BL_BARG(bx),delta, coordsys)
      REAL_T  delta(SDIM)

      BL_FBOUNDS(vol)                  
      BL_FBOUNDS(dloga)                  
      BL_FBOUNDS(area)                  
      BL_BBOUNDS(bx)

      BL_FARRAY1(vol)
      BL_FARRAY1(dloga)
      BL_FARRAY(area,SDIM)

      integer i,j,is,ie,js,je,coordsys
      REAL_T dx,dy

      is = bxlo(1)
      ie = bxhi(1)
      js = bxlo(2)
      je = bxhi(2)

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

      if (coordsys.eq.0) then
	do j = js, je
	  do i = is, ie
	    vol(i,j) = dx*dy
	    dloga(i,j) = zero
	    area(i,j,1) = dy
	    area(i,j,2) = dx
          end do
        end do
       else
        print *,'Abort: Not wired for r-z yet.'
        stop
       end if

      return
      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:SDIM*SDIM-1)
      integer bc(SDIM,2,nv)

      BL_FBOUNDS(s)                  
      BL_FBOUNDS(flux)
      BL_FBOUNDS(pgdnv)
      BL_FBOUNDS(div)
      BL_FBOUNDS(area)
      BL_FBOUNDS(vol)
      BL_BBOUNDS(bx)

      BL_FARRAY(s,nv)
      BL_FARRAY(flux,nv)
      BL_FARRAY1(pgdnv)
      BL_FARRAY1(div)
      BL_FARRAY1(area)
      BL_FARRAY1(vol)

      REAL_T dt
      REAL_T delta(SDIM)
      integer sweep, vnrml
      integer is, ie, js, je, i, j, iv, ivbc
      integer isflx, ieflx, jsflx, jeflx
      REAL_T dx, dy,trandiv, divuvs
      REAL_T avgarea
      REAL_T leftbc, rightbc

#include "xxmeth.fh"

      is = bxlo(1)
      ie = bxhi(1)
      js = bxlo(2)
      je = bxhi(2)
      isflx = flux_l1
      ieflx = flux_h1
      jsflx = flux_l2
      jeflx = flux_h2

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

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


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

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

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

          flux(i,j,iv) = flux(i,j,iv)*dt*area(i,j)
        
        end do
      end do
      end do

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


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

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

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

c     if(onBndry .eq. 1) then

#if 0
      do iv = 1,nv
c ::: left face
        ivbc = bc(1,1,iv)
        do j = js, je
          do i = is-2,is-1
          if (ivbc .eq. EXT_DIR) then
            s(i,j,iv) = leftbc 
          else if(ivbc .eq. FOEXTRAP .or. ivbc .eq. HOEXTRAP .or. 
     $         ivbc .eq. REFLECT_EVEN) then
            s(i,j,iv) = s(is,j,iv)
          else if(ivbc .eq. REFLECT_ODD) then
            s(i,j,iv) = -s(is,j,iv)
          end if
         end do
        end do
c ::: right face
        ivbc = bc(1,2,iv)
        do j = js-1, je+1
         do i = ie+1,ie+2
          if (ivbc .eq. EXT_DIR) then
            s(i,j,iv) = rightbc
          else if(ivbc .eq. FOEXTRAP .or. ivbc .eq. HOEXTRAP .or. 
     $         ivbc .eq. REFLECT_EVEN) then
            s(i,j,iv) = s(ie,j,iv)
          else if(ivbc .eq. REFLECT_ODD) then
            s(i,j,iv) = -s(ie,j,iv)
          end if
         end do
        end do

      end do
c     else
c     end if
#endif
      
      return
      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:SDIM*SDIM-1)
      integer bc(SDIM,2,nv)

      BL_FBOUNDS(s)                  
      BL_FBOUNDS(flux)
      BL_FBOUNDS(pgdnv)
      BL_FBOUNDS(div)
      BL_FBOUNDS(area)
      BL_FBOUNDS(vol)
      BL_BBOUNDS(bx)

      BL_FARRAY(s,nv)
      BL_FARRAY(flux,nv)
      BL_FARRAY1(pgdnv)
      BL_FARRAY1(div)
      BL_FARRAY1(area)
      BL_FARRAY1(vol)

      REAL_T dt
      REAL_T delta(SDIM)
      integer vnrml,sweep
      integer  is, ie, js, je, i, j, iv, ivbc
      integer isflx, ieflx, jsflx, jeflx
      REAL_T dx, dy,trandiv, divuvs
      REAL_T avgarea
      REAL_T botbc, topbc

#include "xxmeth.fh"

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

      is = bxlo(1)
      ie = bxhi(1)
      js = bxlo(2)
      je = bxhi(2)
      isflx = flux_l1
      ieflx = flux_h1
      jsflx = flux_l2
      jeflx = flux_h2

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

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

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

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

          flux(i,j,iv) = flux(i,j,iv)*dt*area(i,j)
        
        end do
      end do
      end do

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


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

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

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

c     if(onBndry .eq. 1) then

#if 0
      do iv = 1,nv
c ::: bottom face
        ivbc = bc(2,1,iv)
        do i = is, ie
         do j = js-2,js-1
          if (ivbc .eq. EXT_DIR) then
            s(i,j,iv) = botbc 
          else if(ivbc .eq. FOEXTRAP .or. ivbc .eq. HOEXTRAP .or. 
     $         ivbc .eq. REFLECT_EVEN) then
            s(i,j,iv) = s(i,js,iv)
          else if(ivbc .eq. REFLECT_ODD) then
            s(i,j,iv) = -s(i,js,iv)
          end if
        end do
        end do
c ::: top face
        ivbc = bc(2,2,iv)
        do i = is, ie
         do j = je+1,je+2
          if (ivbc .eq. EXT_DIR) then
            s(i,j,iv) = topbc
          else if(ivbc .eq. FOEXTRAP .or. ivbc .eq. HOEXTRAP .or. 
     $         ivbc .eq. REFLECT_EVEN) then
            s(i,j,iv) = s(i,je,iv)
          else if(ivbc .eq. REFLECT_ODD) then
            s(i,j,iv) = -s(i,je,iv)
          end if
        end do
      end do
      end do

c     else
c     end if

#endif
      return
      end


#if 1
      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,i,j
      REAL_T u,v,w,rho,e
      REAL_T gdum,cdum,csdum, reflect

#include "xxmeth.fh"

       is = bxlo(1)
       js = bxlo(2)
       ie = bxhi(1)
       je = bxhi(2)


       do j = js, je
        do i = is, ie

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


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

        enddo
       enddo

      end
      
#else
      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,i,j
      REAL_T u,v,rho,e
      REAL_T gdum,cdum,csdum, reflect

#include "xxmeth.fh"

       is = bxlo(1)
       js = bxlo(2)
       ie = bxhi(1)
       je = bxhi(2)

      do j = js, je
        do i = is, ie

          rho = max(s(i,j,SRHO),smallr)
          u = s(i,j,SXMOM)/rho
          v = s(i,j,SYMOM)/rho
          e = s(i,j,SRHOE)/rho - half*(u**2 + v**2)
    
          q(i,j,QRHO) = rho
          q(i,j,QVEL1) = u
          q(i,j,QVEL2) = v
          q(i,j,QRHOE) = e
        
        end do
      end do


      call eos(q(is,js,QRHO),q(is,js,QRHOE),
     $         gamc(is,js),q(is,js,QPRES),cdum,csdum,
     $         bxlo,bxhi,1,1,0,0)

      do j = js, je
        do i = is, ie
	  q(i,j,QPRES) = max(smallp,q(i,j,QPRES))
	  p(i,j) = q(i,j,QPRES)
          q(i,j,QRHOE) = q(i,j,QRHOE)*q(i,j,QRHO)
c	  c(i,j) = sqrt(gamc(i,j)*q(i,j,QPRES)/q(i,j,QRHO))
c	  csml(i,j) = max(small,small*c(i,j))
        end do
      end do

      return
      end
#endif
