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

      subroutine FORT_SLOPEZ(s,slz,dzscr,DIMS,nvar,bcz_lo,bcz_hi,slope_order)

      implicit none

      integer DIMS
      integer nvar
      integer bcz_lo,bcz_hi
      integer slope_order

      REAL_T      s(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,nvar)
      REAL_T    slz(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,nvar)
      REAL_T  dzscr(lo_3-1:hi_3+1,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,ks,ie,je,ke,i,j,k,iv

      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 
              slz(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,ke 
          do j = js-1,je+1 
          do i = is-1,ie+1 

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

          enddo
          enddo
          enddo

          if (bcz_lo .eq. PERIODIC) then

            do j = js-1,je+1 
            do i = is-1,ie+1 
              slz(i,j,ks-1,iv) = slz(i,j,ke,iv)
            enddo
            enddo

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

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

          elseif (bcz_lo .eq. OUTLET) then

            do j = js-1,je+1 
            do i = is-1, ie+1 
              slz(i,j,ks-1,iv) = zero
            enddo
            enddo

          endif

          if (bcz_hi .eq. PERIODIC) then

            do j = js-1,je+1 
            do i = is-1,ie+1 
              slz(i,j,ke+1,iv) = slz(i,j,ks,iv)
            enddo
            enddo

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

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

          elseif (bcz_hi .eq. OUTLET) then

            do j = js-1,je+1 
            do i = is-1, ie+1 
              slz(i,j,ke+1,iv) = zero
            enddo
            enddo

          endif
        enddo

      else 

c ::: HERE DOING 4TH ORDER

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

          if (bcz_lo .eq. PERIODIC) then
            dzscr(ks-1,fromm) = dzscr(ke,fromm)
          else
            dzscr(ks-1,fromm) = dzscr(ks,fromm)
          endif

          if (bcz_hi .eq. PERIODIC) then
            dzscr(ke+1,fromm) = dzscr(ks,fromm)
          else
            dzscr(ke+1,fromm) = dzscr(ke,fromm)
          endif

          do k = ks,ke 

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

          enddo

          if (bcz_lo .eq. PERIODIC) then

            slz(i,j,ks-1,iv) = slz(i,j,ke,iv)

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

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

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

          elseif (bcz_lo .eq. OUTLET) then

            slz(i,j,ks-1,iv) = zero

          endif

          if (bcz_hi .eq. PERIODIC) then

            slz(i,j,ke+1,iv) = slz(i,j,ks,iv)

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

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

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

          elseif (bcz_hi .eq. OUTLET) then

            slz(i,j,ke+1,iv) = zero

          endif
        enddo
      enddo
      enddo

      endif
      return
      end
