/*
** (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,hi_1,hi_2

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

      subroutine FORT_SLOPEX(s,slx,dxscr,DIMS,first_comp,nvar,
     $                       bcx_lo,bcx_hi,irz,slope_order)
 
      implicit none

      integer DIMS
      integer nvar
      REAL_T      s(lo_1-1:hi_1+1,lo_2-1:hi_2+1,nvar)
      REAL_T    slx(lo_1-1:hi_1+1,lo_2-1:hi_2+1,nvar)
      REAL_T  dxscr(lo_1-1:hi_1+1,4)
      integer bcx_lo,bcx_hi
      integer irz
      integer first_comp
      integer slope_order

c     Local variables
      integer is,js,ie,je
      integer i,j,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
      ie = hi_1
      je = hi_2

      if (irz .eq. 1 .and. lo_1 .ne. 0) then
         print *,'NEED LO(1) = 0 WHEN IRZ = 1'
         stop
      endif

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

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

        do iv=1,nvar 
          do j = js-1,je+1 
            do 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))
            enddo

            if (bcx_lo .eq. PERIODIC) then

              slx(is-1,j,iv) = slx(ie,j,iv)

            elseif (bcx_lo .eq. WALL  .or.  bcx_lo .eq. INLET) then

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

            elseif (bcx_lo .eq. OUTLET) then

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

            endif

            if (bcx_hi .eq. PERIODIC) then

              slx(ie+1,j,iv) = slx(is,j,iv)

            elseif (bcx_hi .eq. WALL  .or.  bcx_hi .eq. INLET) then

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

            elseif (bcx_hi .eq. OUTLET) then

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

            endif
          enddo
          enddo

      else 

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

          if (irz .eq. 1 .and.  
     $        first_comp .eq. 0 .and. iv .eq. 1) then
            s(-1,j,1) = -s(0,j,1)
          endif

          do i = is,ie 
            dxscr(i,cen) = half*(s(i+1,j,iv)-s(i-1,j,iv))
            dmin = two*(s(i  ,j,iv)-s(i-1,j,iv))
            dpls = two*(s(i+1,j,iv)-s(i  ,j,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

          if (bcx_lo .eq. PERIODIC) then
            dxscr(is-1,fromm) = dxscr(ie,fromm)
          else
            dxscr(is-1,fromm) = dxscr(is,fromm)
          endif

          if (bcx_hi .eq. PERIODIC) then
            dxscr(ie+1,fromm) = dxscr(is,fromm)
          else
            dxscr(ie+1,fromm) = dxscr(ie,fromm)
          endif

          do i = is,ie 

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

          enddo

          if (irz .eq. 1 .and.
     $        first_comp .eq. 0 .and. iv .eq. 1) then
            s(-1,j,1) = zero
          endif

          if (bcx_lo .eq. PERIODIC) then

            slx(is-1,j,iv)=slx(ie,j,iv)

          elseif (bcx_lo .eq. WALL  .or.  bcx_lo .eq. INLET) then

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

            if (irz .eq. 0  .or.  .not. 
     $          (first_comp .eq. 0 .and. iv .eq. 1) ) then
              del = -sixteen/fifteen*s(is-1,j,iv) + half*s(is,j,iv) + 
     $                        two3rd*s(is+1,j,iv) - tenth*s(is+2,j,iv)
              dmin = two*(s(is  ,j,iv)-s(is-1,j,iv))
              dpls = two*(s(is+1,j,iv)-s(is  ,j,iv))
              slim = min(abs(dpls), abs(dmin))
              slim = cvmgp(slim, zero, dpls*dmin)
              sflag = sign(one,del)
              slx(is,j,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,iv)
              ds = two * two3rd * dxscr(is+1,cen) -
     $             sixth * (dxscr(is+2,fromm) + dxscr(is,fromm))
              slx(is+1,j,iv) = dxscr(is+1,flag)*min(abs(ds),dxscr(is+1,lim))
            endif

          elseif (bcx_lo .eq. OUTLET) then

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

          endif

          if (bcx_hi .eq. PERIODIC) then

            slx(ie+1,j,iv)=slx(is,j,iv)

          elseif (bcx_hi .eq. WALL  .or.  bcx_hi .eq. INLET) then

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

            del = -( -sixteen/fifteen*s(ie+1,j,iv) + half*s(ie,j,iv) + 
     $                         two3rd*s(ie-1,j,iv) - tenth*s(ie-2,j,iv) )
            dmin = two*(s(ie  ,j,iv)-s(ie-1,j,iv))
            dpls = two*(s(ie+1,j,iv)-s(ie  ,j,iv))
            slim = min(abs(dpls), abs(dmin))
            slim = cvmgp(slim, zero, dpls*dmin)
            sflag = sign(one,del)
            slx(ie,j,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,iv)
            ds = two * two3rd * dxscr(ie-1,cen) -
     $           sixth * (dxscr(ie-2,fromm) + dxscr(ie,fromm))
            slx(ie-1,j,iv) = dxscr(ie-1,flag)*min(abs(ds),dxscr(ie-1,lim))

          elseif (bcx_hi .eq. OUTLET) then

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

          endif
        enddo
      enddo

        if (irz .eq. 1 .and.
     $     first_comp .eq. 0 .and. nvar .ge. 2) then

           do iv = 2,nvar
           do j = js,je 
             slx(is-1,j,iv)=-slx(is,j,iv)
           enddo
           enddo

        endif

      endif

      return
      end
