/*
** (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.
*/

#include "REAL.H"
#include "CONSTANTS.H"
#include "GRID_F.H"
#include "BCTypes.H"

#define DIMS lo_1,lo_2,lo_3,hi_1,hi_2,hi_3

c *************************************************************************
c ** SLOPEX **
c ** Compute the slope of nvar components of s in the x-direction
c *************************************************************************

      subroutine FORT_SLOPEX(s,slx,dxscr,DIMS,nvar,bc,slope_order)
 
      implicit none

      integer DIMS
      integer nvar
      REAL_T      s(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3,nvar)
      REAL_T    slx(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,nvar)
      REAL_T  dxscr(lo_1-2:hi_1+2,4)
      integer bc(2,3)
      integer slope_order

c     Local variables
      integer is,js,ks,ie,je,ke
      integer i,j,k,iv
      integer cen,lim,flag,fromm
      REAL_T del,slim,sflag
      REAL_T dpls,dmin,ds

      parameter( cen = 1 )
      parameter( lim = 2 )
      parameter( flag = 3 )
      parameter( fromm = 4 )

      is = lo_1
      js = lo_2
      ks = lo_3
      ie = hi_1
      je = hi_2
      ke = hi_3

c     HERE DOING 1ST ORDER
      if (slope_order .eq. 0) then
        do iv = 1,nvar 
          do k = ks-1,ke+1 
           do j = js-1,je+1 
            do i = is-1,ie+1 
              slx(i,j,k,iv) = zero
            enddo
           enddo
          enddo
        enddo

c     HERE DOING 2ND ORDER
      else if (slope_order .eq. 2) then

        do iv=1,nvar 
          do k = ks-1,ke+1 
          do j = js-1,je+1 

            do i = is-1,ie+1 
              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))
            enddo

            if (BCX_LO .eq. WALL  .or.  BCX_LO .eq. INLET) then

              slx(is-1,j,k,iv) = zero

              del = (s(is+1,j,k,iv)+three*s(is,j,k,iv)-
     $               four*s(is-1,j,k,iv) ) * third
              dpls = two*(s(is+1,j,k,iv) - s(is  ,j,k,iv))
              dmin = two*(s(is  ,j,k,iv) - s(is-1,j,k,iv))
              slim = min(abs(dpls), abs(dmin))
              slim = cvmgp(slim, zero, dpls*dmin)
              sflag = sign(one,del)
              slx(is,j,k,iv)= sflag*min(slim,abs(del))

            elseif (BCX_LO .eq. OUTLET) then

              slx(is-1,j,k,iv)= zero

            endif

            if (BCX_HI .eq. WALL  .or.  BCX_HI .eq. INLET) then

              slx(ie+1,j,k,iv) = zero

              del = -(s(ie-1,j,k,iv)+three*s(ie,j,k,iv)-
     $                four*s(ie+1,j,k,iv)) * third
              dpls = two*(s(ie+1,j,k,iv) - s(ie  ,j,k,iv))
              dmin = two*(s(ie  ,j,k,iv) - s(ie-1,j,k,iv))
              slim = min(abs(dpls), abs(dmin))
              slim = cvmgp(slim, zero, dpls*dmin)
              sflag = sign(one,del)
              slx(ie,j,k,iv)= sflag*min(slim,abs(del))

            elseif (BCX_HI .eq. OUTLET) then

              slx(ie+1,j,k,iv)= zero

            endif

          enddo
          enddo
        enddo

      else 

c     HERE DOING 4TH ORDER
      do iv=1,nvar 
        do k = ks-1,ke+1 
        do j = js-1,je+1 

          do i = is-2,ie+2 
            dxscr(i,cen) = half*(s(i+1,j,k,iv)-s(i-1,j,k,iv))
            dmin = two*(s(i  ,j,k,iv)-s(i-1,j,k,iv))
            dpls = two*(s(i+1,j,k,iv)-s(i  ,j,k,iv))
            dxscr(i,lim)= min(abs(dmin),abs(dpls))
            dxscr(i,lim) = cvmgp(dxscr(i,lim),zero,dpls*dmin)
            dxscr(i,flag) = sign(one,dxscr(i,cen))
            dxscr(i,fromm)= dxscr(i,flag)*min(dxscr(i,lim),
     $                      abs(dxscr(i,cen)))
          enddo

          do i = is-1,ie+1 
            ds = two * two3rd * dxscr(i,cen) - 
     $           sixth * (dxscr(i+1,fromm) + dxscr(i-1,fromm))
            slx(i,j,k,iv) = dxscr(i,flag)*min(abs(ds),dxscr(i,lim))
          enddo

          if (BCX_LO .eq. WALL  .or.  BCX_LO .eq. INLET) then

            slx(is-1,j,k,iv) = zero

            del = -sixteen/fifteen*s(is-1,j,k,iv) + half*s(is,j,k,iv) + 
     $                      two3rd*s(is+1,j,k,iv) - tenth*s(is+2,j,k,iv)
            dmin = two*(s(is  ,j,k,iv)-s(is-1,j,k,iv))
            dpls = two*(s(is+1,j,k,iv)-s(is  ,j,k,iv))
            slim = min(abs(dpls), abs(dmin))
            slim = cvmgp(slim, zero, dpls*dmin)
            sflag = sign(one,del)
            slx(is,j,k,iv)= sflag*min(slim,abs(del))

c           Recalculate the slope at is+1 using the revised dxscr(is,fromm)
            dxscr(is,fromm) = slx(is,j,k,iv)
            ds = two * two3rd * dxscr(is+1,cen) -
     $           sixth * (dxscr(is+2,fromm) + dxscr(is,fromm))
            slx(is+1,j,k,iv) = dxscr(is+1,flag)*min(abs(ds),dxscr(is+1,lim))

          elseif (BCX_LO .eq. OUTLET) then

            slx(is-1,j,k,iv)= zero

          endif

          if (BCX_HI .eq. WALL  .or.  BCX_HI .eq. INLET) then

            slx(ie+1,j,k,iv) = zero

            del = -( -sixteen/fifteen*s(ie+1,j,k,iv) + half*s(ie,j,k,iv) + 
     $                         two3rd*s(ie-1,j,k,iv) - tenth*s(ie-2,j,k,iv) )
            dmin = two*(s(ie  ,j,k,iv)-s(ie-1,j,k,iv))
            dpls = two*(s(ie+1,j,k,iv)-s(ie  ,j,k,iv))
            slim = min(abs(dpls), abs(dmin))
            slim = cvmgp(slim, zero, dpls*dmin)
            sflag = sign(one,del)
            slx(ie,j,k,iv)= sflag*min(slim,abs(del))

c           Recalculate the slope at ie-1 using the revised dxscr(ie,fromm)
            dxscr(ie,fromm) = slx(ie,j,k,iv)
            ds = two * two3rd * dxscr(ie-1,cen) -
     $           sixth * (dxscr(ie-2,fromm) + dxscr(ie,fromm))
            slx(ie-1,j,k,iv) = dxscr(ie-1,flag)*min(abs(ds),dxscr(ie-1,lim))

          elseif (BCX_HI .eq. OUTLET) then

            slx(ie+1,j,k,iv)= zero

          endif

        enddo
        enddo
      enddo

      endif

      return
      end
