/*
** (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 ** MKSCAFLUX **
c ** Create the time-centered edge states for scalars
c ***************************************************************

      subroutine FORT_MKSCAFLUX(s,sedgex,sedgey,sedgez,slopex,slopey,slopez,
     $                          uadv,vadv,wadv,utrans,vtrans,wtrans,u,diff,force,
     $                          s_l,s_r,s_b,s_t,s_d,s_u,DIMS,
     $                          dx,dt,bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi,numqty)

      implicit none

      integer DIMS
      integer numqty

      REAL_T       s(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numqty)
      REAL_T  sedgex(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numqty)
      REAL_T  sedgey(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numqty)
      REAL_T  sedgez(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numqty)
      REAL_T  slopex(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numqty)
      REAL_T  slopey(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numqty)
      REAL_T  slopez(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numqty)
      REAL_T    uadv(lo_1:hi_1+1,lo_2:hi_2  ,lo_3:hi_3  )
      REAL_T    vadv(lo_1:hi_1  ,lo_2:hi_2+1,lo_3:hi_3  )
      REAL_T    wadv(lo_1:hi_1  ,lo_2:hi_2  ,lo_3:hi_3+1)
      REAL_T  utrans(lo_1:hi_1+1,lo_2:hi_2  ,lo_3:hi_3  )
      REAL_T  vtrans(lo_1:hi_1  ,lo_2:hi_2+1,lo_3:hi_3  )
      REAL_T  wtrans(lo_1:hi_1  ,lo_2:hi_2  ,lo_3:hi_3+1)
      REAL_T       u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,3)
      REAL_T    diff(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numqty)
      REAL_T   force(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numqty)
      REAL_T     s_l(lo_1:hi_1+1)
      REAL_T     s_r(lo_1:hi_1+1)
      REAL_T     s_b(lo_2:hi_2+1)
      REAL_T     s_t(lo_2:hi_2+1)
      REAL_T     s_d(lo_3:hi_3+1)
      REAL_T     s_u(lo_3:hi_3+1)
      REAL_T dx(3)
      REAL_T dt
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer bcz_lo,bcz_hi

c     Local variables
      REAL_T savg
      REAL_T sUpx1,sUpx2
      REAL_T sUpy1,sUpy2
      REAL_T sUpz1,sUpz2
      REAL_T hx
      REAL_T hy
      REAL_T hz
      integer i,j,k,n,is,ie,js,je,ks,ke

      REAL_T eps
      eps = 1.0e-8

      hx = dx(1)
      hy = dx(2)
      hz = dx(3)
      is = lo_1
      ie = hi_1
      js = lo_2
      je = hi_2
      ks = lo_3
      ke = hi_3

c ::: First do s^(n+1/2) on the (i+1/2) boundaries.

      do n = 1, numqty
      do k = ks,ke 
      do j = js,je 
        do i = is,ie 

          sUpy1 = cvmgp(  s(i,j,k,n) , s(i,j+1,k,n), vtrans(i,j+1,k))
          savg = half * (s(i,j,k,n) + s(i,j+1,k,n))
          sUpy1 = cvmgt(sUpy1, savg, abs(vtrans(i,j+1,k)) .gt. eps)

          sUpy2 = cvmgp(  s(i,j-1,k,n) , s(i,j,k,n), vtrans(i,j  ,k))
          savg = half * (s(i,j-1,k,n) + s(i,j,k,n))
          sUpy2 = cvmgt(sUpy2, savg, abs(vtrans(i,j  ,k)) .gt. eps)

          sUpz1 = cvmgp(  s(i,j,k,n) , s(i,j,k+1,n), wtrans(i,j,k+1))
          savg = half * (s(i,j,k,n) + s(i,j,k+1,n))
          sUpz1 = cvmgt(sUpz1, savg, abs(wtrans(i,j,k+1)) .gt. eps)

          sUpz2 = cvmgp(  s(i,j,k-1,n) , s(i,j,k,n), wtrans(i,j,k  ))
          savg = half * (s(i,j,k-1,n) + s(i,j,k,n))
          sUpz2 = cvmgt(sUpz2, savg, abs(wtrans(i,j,k  )) .gt. eps)

          s_l(i+1) = s(i,j,k,n) + 
     $      half*(one - u(i,j,k,1)*dt/hx)*slopex(i,j,k,n) - 
     $      half*dt*u(i,j,k,2)*(sUpy1 - sUpy2)/hy -
     $      half*dt*u(i,j,k,3)*(sUpz1 - sUpz2)/hz +
     $      half*dt*(diff(i,j,k,n) + force(i,j,k,n))

          s_r(i  ) = s(i,j,k,n) - 
     $      half*(one + u(i,j,k,1)*dt/hx)*slopex(i,j,k,n) -
     $      half*dt*u(i,j,k,2)*(sUpy1 - sUpy2)/hy -
     $      half*dt*u(i,j,k,3)*(sUpz1 - sUpz2)/hz +
     $      half*dt*(diff(i,j,k,n) + force(i,j,k,n))

        enddo

        if (bcx_lo .eq. PERIODIC) then
          s_l(is  ) = s_l(ie+1)
        elseif (bcx_lo .eq. WALL) then
          s_l(is  ) = s_r(is  )
        elseif (bcx_lo .eq. INLET ) then
          s_l(is  ) = s(is-1,j,k,n)
        elseif (bcx_lo .eq. OUTLET ) then
          s_l(is  ) = s_r(is  )
        endif

        if (bcx_hi .eq. PERIODIC) then
          s_r(ie+1) = s_r(is  )
        elseif (bcx_hi .eq. WALL) then
          s_r(ie+1) = s_l(ie+1)
        elseif (bcx_hi .eq. INLET ) then
          s_r(ie+1) = s(ie+1,j,k,n)
        elseif (bcx_hi .eq. OUTLET ) then
          s_r(ie+1) = s_l(ie+1)
        endif

        do i = is,ie+1 

          sedgex(i,j,k,n)= cvmgp(s_l(i),s_r(i),uadv(i,j,k))
          savg = half*(s_l(i) + s_r(i))
          sedgex(i,j,k,n) = cvmgp(savg,sedgex(i,j,k,n),eps-abs(uadv(i,j,k)))

        enddo
      enddo
      enddo

c ::: Now do s^(n+1/2) on the (j+1/2) boundaries.

      do k = ks,ke 
      do i = is,ie 
        do j = js,je 

          sUpx1 = cvmgp(  s(i,j,k,n) , s(i+1,j,k,n),utrans(i+1,j,k))
          savg = half * (s(i,j,k,n) + s(i+1,j,k,n))
          sUpx1 = cvmgt(sUpx1, savg, abs(utrans(i+1,j,k)) .gt. eps)

          sUpx2 = cvmgp(  s(i-1,j,k,n) , s(i,j,k,n),utrans(i  ,j,k))
          savg = half * (s(i-1,j,k,n) + s(i,j,k,n))
          sUpx2 = cvmgt(sUpx2, savg, abs(utrans(i,j,k)) .gt. eps)

          sUpz1 = cvmgp(  s(i,j,k,n) , s(i,j,k+1,n),wtrans(i,j,k+1))
          savg = half * (s(i,j,k,n) + s(i,j,k+1,n))
          sUpz1 = cvmgt(sUpz1, savg, abs(wtrans(i,j,k+1)) .gt. eps)

          sUpz2 = cvmgp(  s(i,j,k-1,n) , s(i,j,k,n),wtrans(i,j,k  ))
          savg = half * (s(i,j,k-1,n) + s(i,j,k,n))
          sUpz2 = cvmgt(sUpz2, savg, abs(wtrans(i,j,k)) .gt. eps)

          s_b(j+1) = s(i,j,k,n) + 
     $       half*(one - u(i,j,k,2)*dt/hy)*slopey(i,j,k,n) - 
     $       half*dt*u(i,j,k,1)*(sUpx1 - sUpx2)/hx -
     $       half*dt*u(i,j,k,3)*(sUpz1 - sUpz2)/hz +
     $       half*dt*(diff(i,j,k,n) + force(i,j,k,n))

          s_t(j  ) = s(i,j,k,n) - 
     $       half*(one + u(i,j,k,2)*dt/hy)*slopey(i,j,k,n) -
     $       half*dt*u(i,j,k,1)*(sUpx1 - sUpx2)/hx -
     $       half*dt*u(i,j,k,3)*(sUpz1 - sUpz2)/hz +
     $       half*dt*(diff(i,j,k,n) + force(i,j,k,n))

        enddo

        if (bcy_lo .eq. PERIODIC) then
          s_b(js  ) = s_b(je+1)
        elseif (bcy_lo .eq. WALL ) then
          s_b(js  ) = s_t(js  )
        elseif (bcy_lo .eq. INLET ) then
          s_b(js  ) = s(i,js-1,k,n)
        elseif (bcy_lo .eq. OUTLET ) then
          s_b(js  ) = s_t(js  )
        endif

        if (bcy_hi .eq. PERIODIC) then
          s_t(je+1) = s_t(js  )
        elseif (bcy_hi .eq. WALL ) then
          s_t(je+1) = s_b(je+1)
        elseif (bcy_hi .eq. INLET ) then
          s_t(je+1) = s(i,je+1,k,n)
        elseif (bcy_hi .eq. OUTLET ) then
          s_t(je+1) = s_b(je+1)
        endif


        do j = js, je+1 

          sedgey(i,j,k,n) = cvmgp(s_b(j),s_t(j),vadv(i,j,k))
          savg = half*(s_b(j) + s_t(j))
          sedgey(i,j,k,n) = cvmgp(savg,sedgey(i,j,k,n),eps-abs(vadv(i,j,k)))

        enddo
      enddo
      enddo

c ::: Now do s^(n+1/2) on the (k+1/2) boundaries.

      do j = js,je 
      do i = is,ie 
        do k = ks,ke 

          sUpx1 = cvmgp(  s(i,j,k,n) , s(i+1,j,k,n),utrans(i+1,j,k))
          savg = half * (s(i,j,k,n) + s(i+1,j,k,n))
          sUpx1 = cvmgt(sUpx1, savg, abs(utrans(i+1,j,k)) .gt. eps)

          sUpx2 = cvmgp(  s(i-1,j,k,n) , s(i,j,k,n),utrans(i  ,j,k))
          savg = half * (s(i-1,j,k,n) + s(i,j,k,n))
          sUpx2 = cvmgt(sUpx2, savg, abs(utrans(i,j,k)) .gt. eps)

          sUpy1 = cvmgp(  s(i,j,k,n) , s(i,j+1,k,n), vtrans(i,j+1,k))
          savg = half * (s(i,j,k,n) + s(i,j+1,k,n))
          sUpy1 = cvmgt(sUpy1, savg, abs(vtrans(i,j+1,k)) .gt. eps)

          sUpy2 = cvmgp(  s(i,j-1,k,n) , s(i,j,k,n), vtrans(i,j  ,k))
          savg = half * (s(i,j-1,k,n) + s(i,j,k,n))
          sUpy2 = cvmgt(sUpy2, savg, abs(vtrans(i,j  ,k)) .gt. eps)

          s_d(k+1) = s(i,j,k,n) + 
     $       half*(one - u(i,j,k,3)*dt/hz)*slopez(i,j,k,n) - 
     $       half*dt*u(i,j,k,1)*(sUpx1 - sUpx2)/hx -
     $       half*dt*u(i,j,k,2)*(sUpy1 - sUpy2)/hy +
     $       half*dt*(diff(i,j,k,n) + force(i,j,k,n))

          s_u(k  ) = s(i,j,k,n) - 
     $       half*(one + u(i,j,k,3)*dt/hz)*slopez(i,j,k,n) -
     $       half*dt*u(i,j,k,1)*(sUpx1 - sUpx2)/hx -
     $       half*dt*u(i,j,k,2)*(sUpy1 - sUpy2)/hy +
     $       half*dt*(diff(i,j,k,n) + force(i,j,k,n))

        enddo

        if (bcz_lo .eq. PERIODIC) then
          s_d(ks  ) = s_d(ke+1)
        elseif (bcz_lo .eq. WALL ) then
          s_d(ks  ) = s_u(ks  )
        elseif (bcz_lo .eq. INLET ) then
          s_d(ks  ) = s(i,j,ks-1,n)
        elseif (bcz_lo .eq. OUTLET ) then
          s_d(ks  ) = s_u(ks  )
        endif

        if (bcz_hi .eq. PERIODIC) then
          s_u(ke+1) = s_u(ks  )
        elseif (bcz_hi .eq. WALL ) then
          s_u(ke+1) = s_d(ke+1)
        elseif (bcz_hi .eq. INLET ) then
          s_u(ke+1) = s(i,j,ke+1,n)
        elseif (bcz_hi .eq. OUTLET ) then
          s_u(ke+1) = s_d(ke+1)
        endif

        do k = ks, ke+1 

          sedgez(i,j,k,n) = cvmgp(s_d(k),s_u(k),wadv(i,j,k))
          savg = half*(s_d(k) + s_u(k))
          sedgez(i,j,k,n) = cvmgp(savg,sedgez(i,j,k,n),eps-abs(wadv(i,j,k)))

        enddo
      enddo
      enddo

      enddo

      return
      end
