/*
** (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 ** SLOPEY **
c ** Compute the slope of nvar components of s in the y-direction
c *************************************************************************

      subroutine FORT_SLOPEY(s,sly,dyscr,DIMS,nvar,bc,slope_order)

      implicit none

      integer DIMS
      integer nvar
      integer bc(2,2)
      integer slope_order

      REAL_T      s(lo_1-3:hi_1+3,lo_2-3:hi_2+3,nvar)
      REAL_T    sly(lo_1-1:hi_1+1,lo_2-1:hi_2+1,nvar)
      REAL_T  dyscr(lo_2-2:hi_2+2,4)

      integer cen,lim,flag,fromm

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

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

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

      is = lo_1
      js = lo_2
      ie = hi_1
      je = hi_2

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 
              sly(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-1,ie+1 

              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))

            enddo
          enddo

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

            do i = is-1,ie+1 
              sly(i,js-1,iv) = zero
              del = (s(i,js+1,iv)+three*s(i,js,iv)-
     $               four*s(i,js-1,iv)) * third
              dpls = two*(s(i,js+1,iv) - s(i,js  ,iv))
              dmin = two*(s(i,js  ,iv) - s(i,js-1,iv))
              slim = min(abs(dpls), abs(dmin))
              slim = cvmgp(slim, zero, dpls*dmin)
              sflag = sign(one,del)
              sly(i,js,iv)= sflag*min(slim,abs(del))
            enddo

          else if (BCY_LO .eq. OUTLET) then

            do i = is-1, ie+1 
              sly(i,js-1,iv) = zero
            enddo

          endif

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

            do i = is-1, ie+1 
              sly(i,je+1,iv) = zero
              del = -(s(i,je-1,iv)+three*s(i,je,iv)-
     $                four*s(i,je+1,iv)) * third
              dpls = two*(s(i,je+1,iv) - s(i,je ,iv))
              dmin = two*(s(i,je  ,iv) - s(i,je-1,iv))
              slim = min(abs(dpls), abs(dmin))
              slim = cvmgp(slim, zero, dpls*dmin)
              sflag = sign(one,del)
              sly(i,je,iv)= sflag*min(slim,abs(del))
            enddo

          else if (BCY_HI .eq. OUTLET) then

            do i = is-1, ie+1 
              sly(i,je+1,iv) = zero
            enddo

          endif
        enddo

      else 

c ::: HERE DOING 4TH ORDER

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

          do j = js-1,je+1 
            ds = two * two3rd * dyscr(j,cen) - 
     $           sixth * (dyscr(j+1,fromm) + dyscr(j-1,fromm))
            sly(i,j,iv) = dyscr(j,flag)*min(abs(ds),dyscr(j,lim))
          enddo


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

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

c           Recalculate the slope at js+1 using the revised dyscr(js,fromm)
            dyscr(js,fromm) = sly(i,js,iv)
            ds = two * two3rd * dyscr(js+1,cen) - 
     $           sixth * (dyscr(js+2,fromm) + dyscr(js,fromm))
            sly(i,js+1,iv) = dyscr(js+1,flag)*min(abs(ds),dyscr(js+1,lim))

          elseif (BCY_LO .eq. OUTLET) then

            sly(i,js-1,iv) = zero

          endif

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

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

c           Recalculate the slope at js+1 using the revised dyscr(js,fromm)
            dyscr(je,fromm) = sly(i,je,iv)
            ds = two * two3rd * dyscr(je-1,cen) - 
     $           sixth * (dyscr(je-2,fromm) + dyscr(je,fromm))
            sly(i,je-1,iv) = dyscr(je-1,flag)*min(abs(ds),dyscr(je-1,lim))

          elseif (BCY_HI .eq. OUTLET) then

            sly(i,je+1,iv) = zero

          endif
        enddo
      enddo

      endif
      return
      end
