/*
** (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 "VISC_F.H"
#include "BCTypes.H"

#define DIMS lo_1,lo_2,lo_3,hi_1,hi_2,hi_3
#define CDIMS loc_1,loc_2,loc_3,hic_1,hic_2,hic_3

#if BL_USE_FLOAT
#define twentyfive 25.e0
#define fifth 0.2
#else
#define twentyfive 25.d0
#define fifth 0.2d0
#endif

c *************************************************************************
c ** INITSIG **
c ** Define the 1/rho coefficients at the top level of the multigrid
c *************************************************************************

      subroutine FORT_INITSIGV(sigma,rho,rmu,DIMS)

      implicit none

      integer DIMS
      REAL_T sigma(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T   rho(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T rmu

c     Local variables
      integer i,j,k

      do k = lo_3-1,hi_3+1 
       do j = lo_2-1,hi_2+1 
        do i = lo_1-1,hi_1+1 
          sigma(i,j,k) = rmu/rho(i,j,k)
        enddo
       enddo
      enddo

      return
      end

c *************************************************************************
c ** RHSNORM **
c ** Take the norm of the right-hand-side and fill the inflow registers
c *************************************************************************

      subroutine FORT_RHSNORM(rhs,source,DIMS,rnorm,
     $                        uinx_lo,uinx_hi,uiny_lo,uiny_hi,uinz_lo,uinz_hi)

      implicit none
      integer DIMS
      REAL_T     rhs(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T  source(lo_1  :hi_1  ,lo_2  :hi_2  ,lo_3  :hi_3  )
      REAL_T    uinx_lo(lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T    uinx_hi(lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T    uiny_lo(lo_1-1:hi_1+1,lo_3-1:hi_3+1)
      REAL_T    uiny_hi(lo_1-1:hi_1+1,lo_3-1:hi_3+1)
      REAL_T    uinz_lo(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T    uinz_hi(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T rnorm

c     Local variables
      integer i,j,k

      rnorm = zero

      do k = lo_3,hi_3 
       do j = lo_2,hi_2 
        do i = lo_1,hi_1 
          rnorm = max(rnorm,abs(rhs(i,j,k)))
          source(i,j,k) = rhs(i,j,k)
        enddo
       enddo
      enddo

      do k = lo_3-1,hi_3+1
      do j = lo_2-1,hi_2+1
        uinx_lo(j,k) = rhs(lo_1-1,j,k)
        uinx_hi(j,k) = rhs(hi_1+1,j,k)
      enddo
      enddo

      do k = lo_3-1,hi_3+1
      do i = lo_1-1,hi_1+1 
        uiny_lo(i,k) = rhs(i,lo_2-1,k)
        uiny_hi(i,k) = rhs(i,hi_2+1,k)
      enddo
      enddo

      do j = lo_2-1,hi_2+1 
      do i = lo_1-1,hi_1+1 
        uinz_lo(i,j) = rhs(i,j,lo_3-1)
        uinz_hi(i,j) = rhs(i,j,hi_3+1)
      enddo
      enddo

      return
      end

c *************************************************************************
c ** RESID **
c ** Compute the residual
c *************************************************************************

      subroutine FORT_RESID(res,u,f,sigma,
     $                      uinx_lo,uinx_hi,uiny_lo,uiny_hi,uinz_lo,uinz_hi,
     $                      DIMS,hx,hy,hz,resnorm,
     $                      bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi,level)

      implicit none

      integer DIMS
      REAL_T    res(lo_1  :hi_1  ,lo_2  :hi_2  ,lo_3  :hi_3  )
      REAL_T      u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T      f(lo_1  :hi_1  ,lo_2  :hi_2  ,lo_3  :hi_3  )
      REAL_T  sigma(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T    uinx_lo(lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T    uinx_hi(lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T    uiny_lo(lo_1-1:hi_1+1,lo_3-1:hi_3+1)
      REAL_T    uiny_hi(lo_1-1:hi_1+1,lo_3-1:hi_3+1)
      REAL_T    uinz_lo(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T    uinz_hi(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T hx
      REAL_T hy
      REAL_T hz
      REAL_T resnorm
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer bcz_lo,bcz_hi
      integer level

c     Local variables
      REAL_T rlu
      REAL_T dgu
      REAL_T hxsqinv
      REAL_T hysqinv
      REAL_T hzsqinv
      REAL_T uxx, uxx_lo, uxx_hi
      REAL_T uyy, uyy_lo, uyy_hi
      REAL_T uzz, uzz_lo, uzz_hi
      integer is,ie,js,je,ks,ke
      integer i,j,k

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

      hxsqinv = one/(hx*hx)
      hysqinv = one/(hy*hy)
      hzsqinv = one/(hz*hz)

      if (level .eq. 0) then
        call gsrbvbc(u,uinx_lo,uinx_hi,uiny_lo,uiny_hi,uinz_lo,uinz_hi,
     $               DIMS,bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)
      endif

      do k = lo_3,hi_3 
       do j = lo_2,hi_2 
        do i = lo_1,hi_1 

            uxx = ( u(i+1,j,k) - two * u(i,j,k) + u(i-1,j,k) )
            uxx_hi = (sixteen * u(ie+1,j,k) - twentyfive * u(ie,j,k) +
     $                ten * u(ie-1,j,k) - u(ie-2,j,k) ) * fifth
            uxx_lo = (sixteen * u(is-1,j,k) - twentyfive * u(is,j,k) +
     $                ten * u(is+1,j,k) - u(is+2,j,k) ) * fifth
            uxx = cvmgt(uxx_hi, uxx, i .eq. ie .and. 
     $                  (bcx_hi .eq. WALL .or. bcx_hi .eq. INLET) )
            uxx = cvmgt(uxx_lo, uxx, i .eq. is .and. 
     $                  (bcx_lo .eq. WALL .or. bcx_lo .eq. INLET) )

            uyy = ( u(i,j+1,k) - two * u(i,j,k) + u(i,j-1,k) )
            uyy_hi = (sixteen * u(i,je+1,k) - twentyfive * u(i,je,k) +
     $                ten * u(i,je-1,k) - u(i,je-2,k) ) * fifth
            uyy_lo = (sixteen * u(i,js-1,k) - twentyfive * u(i,js,k) +
     $                ten * u(i,js+1,k) - u(i,js+2,k) ) * fifth
            uyy = cvmgt(uyy_hi, uyy, j .eq. je .and.
     $                  (bcy_hi .eq. WALL .or. bcy_hi .eq. INLET) )
            uyy = cvmgt(uyy_lo, uyy, j .eq. js .and.
     $                  (bcy_lo .eq. WALL .or. bcy_lo .eq. INLET) )

            uzz = ( u(i,j,k+1) - two * u(i,j,k) + u(i,j,k-1) )
            uzz_hi = (sixteen * u(i,j,ke+1) - twentyfive * u(i,j,ke) +
     $                ten * u(i,j,ke-1) - u(i,j,ke-2) ) * fifth
            uzz_lo = (sixteen * u(i,j,ks-1) - twentyfive * u(i,j,ks) +
     $                ten * u(i,j,ks+1) - u(i,j,ks+2) ) * fifth
            uzz = cvmgt(uzz_hi, uzz, k .eq. ke .and.
     $                  (bcz_hi .eq. WALL .or. bcz_hi .eq. INLET) )
            uzz = cvmgt(uzz_lo, uzz, k .eq. ks .and.
     $                  (bcz_lo .eq. WALL .or. bcz_lo .eq. INLET) )

            dgu = uxx*hxsqinv + uyy*hysqinv + uzz*hzsqinv 
            rlu = u(i,j,k) - dgu*sigma(i,j,k)
            res(i,j,k) = f(i,j,k) - rlu

        enddo
       enddo
      enddo

      resnorm = zero

      do k = lo_3,hi_3 
      do j = lo_2,hi_2 
      do i = lo_1,hi_1 
          resnorm = max(resnorm,abs(res(i,j,k)))
      enddo
      enddo
      enddo

      return
      end

c *************************************************************************
c ** GSRBV **
c ** Gauss-Seidel red-black relaxation 
c *************************************************************************

      subroutine FORT_GSRBV(u,f,sigma,
     $                      uinx_lo,uinx_hi,uiny_lo,uiny_hi,uinz_lo,uinz_hi,
     $                      DIMS,hx,hy,hz,
     $                      bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi,
     $                      level,nngsrb)

      implicit none

      integer DIMS
      REAL_T      u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T      f(lo_1  :hi_1  ,lo_2  :hi_2  ,lo_3  :hi_3  )
      REAL_T  sigma(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T    uinx_lo(lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T    uinx_hi(lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T    uiny_lo(lo_1-1:hi_1+1,lo_3-1:hi_3+1)
      REAL_T    uiny_hi(lo_1-1:hi_1+1,lo_3-1:hi_3+1)
      REAL_T    uinz_lo(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T    uinz_hi(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T hx
      REAL_T hy
      REAL_T hz
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer bcz_lo,bcz_hi
      integer level
      integer nngsrb

c     Local variables
      REAL_T rlam,rlu
      REAL_T hxsqinv, hysqinv, hzsqinv
      REAL_T facx, facy, facz
      REAL_T uxx, uxx_lo, uxx_hi
      REAL_T uyy, uyy_lo, uyy_hi
      REAL_T uzz, uzz_lo, uzz_hi
      integer i,j,k,iter,ioff,iinc
      integer is,ie,js,je,ks,ke
      logical ltestx,ltesty,ltestz

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

      hxsqinv = one / (hx*hx)
      hysqinv = one / (hy*hy)
      hzsqinv = one / (hz*hz)

      do iter = 1, nngsrb 

        do ioff = 0,1 

         if (level .eq. 0) then
          call gsrbvbc(u,uinx_lo,uinx_hi,uiny_lo,uiny_hi,uinz_lo,uinz_hi,
     $                 DIMS,bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)
         else
          if (bcx_lo .eq. PERIODIC) then
            do k = ks,ke
            do j = js,je
              u(is-1,j,k) = u(ie,j,k)
            enddo
            enddo
          elseif (bcx_lo .eq. OUTLET) then
            do k = ks,ke
            do j = js,je
              u(is-1,j,k) = u(is,j,k)
            enddo
            enddo
          endif

          if (bcx_hi .eq. PERIODIC) then
            do k = ks,ke
            do j = js,je
              u(ie+1,j,k) = u(is,j,k)
            enddo
            enddo
          elseif (bcx_hi .eq. OUTLET) then
            do k = ks,ke
            do j = js,je
              u(ie+1,j,k) = u(ie,j,k)
            enddo
            enddo
          endif

          if (bcy_lo .eq. PERIODIC) then
            do k = ks,ke
            do i = is,ie 
              u(i,js-1,k) = u(i,je,k)
            enddo
            enddo
          elseif (bcy_lo .eq. OUTLET) then
            do k = ks,ke
            do i = is,ie
              u(i,js-1,k) = u(i,js,k)
            enddo
            enddo
          endif

          if (bcy_hi .eq. PERIODIC) then
            do k = ks,ke
            do i = is,ie 
              u(i,je+1,k) = u(i,js,k)
            enddo
            enddo
          elseif (bcy_hi .eq. OUTLET) then
            do k = ks,ke
            do i = is,ie
              u(i,je+1,k) = u(i,je,k)
            enddo
            enddo
          endif

          if (bcz_lo .eq. PERIODIC) then
            do j = js,je
            do i = is,ie 
              u(i,j,ks-1) = u(i,j,ke)
            enddo
            enddo
          elseif (bcz_lo .eq. OUTLET) then
            do j = js,je
            do i = is,ie
              u(i,j,ks-1) = u(i,j,ks)
            enddo
            enddo
          endif

          if (bcz_hi .eq. PERIODIC) then
            do j = js,je
            do i = is,ie 
              u(i,j,ke+1) = u(i,j,ks)
            enddo
            enddo
          elseif (bcz_hi .eq. OUTLET) then
            do j = js,je
            do i = is,ie
              u(i,j,ke+1) = u(i,j,ke)
            enddo
            enddo
          endif

         endif

          do k = ks,ke 

           ltestz = ( (k .eq. ks .and. (bcz_lo .eq. WALL .or. bcz_lo .eq. INLET) ) .or.
     $                (k .eq. ke .and. (bcz_hi .eq. WALL .or. bcz_hi .eq. INLET) ) )
           ltestz = (ltestz .and. level .eq. 0)
           facz = cvmgt(five,two,ltestz)

           do j = js,je 

            ltesty = ( (j .eq. js .and. (bcy_lo .eq. WALL .or. bcy_lo .eq. INLET) ) .or.
     $                 (j .eq. je .and. (bcy_hi .eq. WALL .or. bcy_hi .eq. INLET) ) )
            ltesty = (ltesty .and. level .eq. 0)
            facy = cvmgt(five,two,ltesty)

            iinc = mod(j+k+ioff,2)
            do i = is+iinc,ie,2 

              ltestx = ( (i .eq. is .and. (bcx_lo .eq. WALL .or. bcx_lo .eq. INLET) ) .or.
     $                   (i .eq. ie .and. (bcx_hi .eq. WALL .or. bcx_hi .eq. INLET) ) )
              ltestx = (ltestx .and. level .eq. 0)
              facx = cvmgt(five,two,ltestx)

              rlam = one + sigma(i,j,k)*(facx * hxsqinv +
     $                                   facy * hysqinv +
     $                                   facz * hzsqinv )
              rlam = one/rlam

              uxx = (u(i+1,j,k) - two*u(i,j,k) + u(i-1,j,k))
              uxx_lo = (sixteen*u(is-1,j,k) - twentyfive*u(is,j,k) + 
     $                  ten*u(is+1,j,k) - u(is+2,j,k)) * fifth
              uxx_hi = (sixteen*u(ie+1,j,k) - twentyfive*u(ie,j,k) + 
     $                  ten*u(ie-1,j,k) - u(ie-2,j,k)) * fifth
              uxx = cvmgt(uxx_lo,uxx,i .eq. is .and. ltestx)
              uxx = cvmgt(uxx_hi,uxx,i .eq. ie .and. ltestx)

              uyy = (u(i,j+1,k) - two*u(i,j,k) + u(i,j-1,k))
              uyy_lo = (sixteen*u(i,js-1,k) - twentyfive*u(i,js,k) + 
     $                  ten*u(i,js+1,k) - u(i,js+2,k)) * fifth
              uyy_hi = (sixteen*u(i,je+1,k) - twentyfive*u(i,je,k) + 
     $                  ten*u(i,je-1,k) - u(i,je-2,k)) * fifth
              uyy = cvmgt(uyy_lo,uyy,j .eq. js .and. ltesty)
              uyy = cvmgt(uyy_hi,uyy,j .eq. je .and. ltesty)

              uzz = (u(i,j,k+1) - two*u(i,j,k) + u(i,j,k-1))
              uzz_lo = (sixteen*u(i,j,ks-1) - twentyfive*u(i,j,ks) + 
     $                  ten*u(i,j,ks+1) - u(i,j,ks+2)) * fifth
              uzz_hi = (sixteen*u(i,j,ke+1) - twentyfive*u(i,j,ke) + 
     $                  ten*u(i,j,ke-1) - u(i,j,ke-2)) * fifth
              uzz = cvmgt(uzz_lo,uzz,k .eq. ks .and. ltestz)
              uzz = cvmgt(uzz_hi,uzz,k .eq. ke .and. ltestz)

              rlu = u(i,j,k) - sigma(i,j,k)*(uxx * hxsqinv + 
     $                                       uyy * hysqinv + 
     $                                       uzz * hzsqinv )
              u(i,j,k) = u(i,j,k) - rlam*(rlu - f(i,j,k))

            enddo
           enddo
          enddo
        enddo

        if (level .eq. 0) then
          call gsrbvbc(u,uinx_lo,uinx_hi,uiny_lo,uiny_hi,uinz_lo,uinz_hi,
     $                 DIMS,bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)
        else

          if (bcx_lo .eq. PERIODIC) then
            do k = ks,ke
            do j = js,je
              u(is-1,j,k) = u(ie,j,k)
            enddo
            enddo
          elseif (bcx_lo .eq. OUTLET) then
            do k = ks,ke
            do j = js,je
              u(is-1,j,k) = u(is,j,k)
            enddo
            enddo
          endif

          if (bcx_hi .eq. PERIODIC) then
            do k = ks,ke
            do j = js,je
              u(ie+1,j,k) = u(is,j,k)
            enddo
            enddo
          elseif (bcx_hi .eq. OUTLET) then
            do k = ks,ke
            do j = js,je
              u(ie+1,j,k) = u(ie,j,k)
            enddo
            enddo
          endif

          if (bcy_lo .eq. PERIODIC) then
            do k = ks,ke
            do i = is,ie 
              u(i,js-1,k) = u(i,je,k)
            enddo
            enddo
          elseif (bcy_lo .eq. OUTLET) then
            do k = ks,ke
            do i = is,ie
              u(i,js-1,k) = u(i,js,k)
            enddo
            enddo
          endif

          if (bcy_hi .eq. PERIODIC) then
            do k = ks,ke
            do i = is,ie 
              u(i,je+1,k) = u(i,js,k)
            enddo
            enddo
          elseif (bcy_hi .eq. OUTLET) then
            do k = ks,ke
            do i = is,ie
              u(i,je+1,k) = u(i,je,k)
            enddo
            enddo
          endif

          if (bcz_lo .eq. PERIODIC) then
            do j = js,je
            do i = is,ie 
              u(i,j,ks-1) = u(i,j,ke)
            enddo
            enddo
          elseif (bcz_lo .eq. OUTLET) then
            do j = js,je
            do i = is,ie
              u(i,j,ks-1) = u(i,j,ks)
            enddo
            enddo
          endif

          if (bcz_hi .eq. PERIODIC) then
            do j = js,je
            do i = is,ie 
              u(i,j,ke+1) = u(i,j,ks)
            enddo
            enddo
          elseif (bcz_hi .eq. OUTLET) then
            do j = js,je
            do i = is,ie
              u(i,j,ke+1) = u(i,j,ke)
            enddo
            enddo
          endif

        endif
      enddo

      return
      end

c *************************************************************************
c ** GSRBVBC **
c ** Impose phyical boundary conditions
c *************************************************************************

      subroutine gsrbvbc(u,uinx_lo,uinx_hi,uiny_lo,uiny_hi,uinz_lo,uinz_hi,
     $                   DIMS,bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

      implicit none

      integer DIMS
      REAL_T     u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T    uinx_lo(lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T    uinx_hi(lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T    uiny_lo(lo_1-1:hi_1+1,lo_3-1:hi_3+1)
      REAL_T    uiny_hi(lo_1-1:hi_1+1,lo_3-1:hi_3+1)
      REAL_T    uinz_lo(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T    uinz_hi(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer bcz_lo,bcz_hi

c     Local variables
      integer i,j,k,is,ie,js,je,ks,ke

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

c     NOTE: WHEN BC = 2 or 3, THE STENCILS ASSUME THE GHOST CELL VALUES
c           APPLY AT THE EDGE, NOT AT THE CELL OUTSIDE!!!

      if (bcz_lo .eq. OUTLET) then
        do j = js,je 
        do i = is,ie
          u(i,j,ks-1) = u(i,j,ks)
        enddo
        enddo
      elseif (bcz_lo .eq. INLET) then
        do j = js,je 
        do i = is,ie
          u(i,j,ks-1) = uinz_lo(i,j)
        enddo
        enddo
      elseif (bcz_lo .eq. WALL) then
        do j = js,je 
        do i = is,ie 
          u(i,j,ks-1) = zero
        enddo
        enddo
      elseif (bcz_lo .eq. PERIODIC) then
        do j = js,je 
        do i = is,ie 
          u(i,j,ks-1) = u(i,j,ke)
        enddo
        enddo
      else
        print *,'bogus bcz_lo in gsrbvbc ',bcz_lo
        stop
      endif

      if (bcz_hi .eq. OUTLET) then
        do j = js,je 
        do i = is,ie
          u(i,j,ke+1) = u(i,j,ke)
        enddo
        enddo
      elseif (bcz_hi .eq. INLET) then
        do j = js,je 
        do i = is,ie
          u(i,j,ke+1) = uinz_hi(i,j)
        enddo
        enddo
      elseif (bcz_hi .eq. WALL) then
        do j = js,je 
        do i = is,ie 
          u(i,j,ke+1) = zero
        enddo
        enddo
      elseif (bcz_hi .eq. PERIODIC) then
        do j = js,je 
        do i = is,ie 
          u(i,j,ke+1) = u(i,j,ks)
        enddo
        enddo
      else
        print *,'bogus bcz_hi in gsrbvbc ',bcz_hi
        stop
      endif

      if (bcy_lo .eq. OUTLET) then
        do k = ks,ke 
        do i = is,ie
          u(i,js-1,k) = u(i,js,k)
        enddo
        enddo
      elseif (bcy_lo .eq. INLET) then
        do k = ks,ke 
        do i = is,ie
          u(i,js-1,k) = uiny_lo(i,k)
        enddo
        enddo
      elseif (bcy_lo .eq. WALL) then
        do k = ks,ke 
        do i = is,ie
            u(i,js-1,k) = zero
        enddo
        enddo
      elseif (bcy_lo .eq. PERIODIC) then
        do k = ks,ke 
        do i = is,ie 
          u(i,js-1,k) = u(i,je,k)
        enddo
        enddo
      else
        print *,'bogus bcy_lo in gsrbvbc ',bcy_lo
        stop
      endif

      if (bcy_hi .eq. OUTLET) then
        do k = ks,ke 
        do i = is,ie
          u(i,je+1,k) = u(i,je,k)
        enddo
        enddo
      elseif (bcy_hi .eq. INLET) then
        do k = ks,ke 
        do i = is,ie
          u(i,je+1,k) = uiny_hi(i,k)
        enddo
        enddo
      elseif (bcy_hi .eq. WALL) then
        do k = ks,ke 
        do i = is,ie
            u(i,je+1,k) = zero
        enddo
        enddo
      elseif (bcy_hi .eq. PERIODIC) then
        do k = ks,ke 
        do i = is,ie 
          u(i,je+1,k) = u(i,js,k)
        enddo
        enddo
      else
        print *,'bogus bcy_hi in gsrbvbc ',bcy_hi
        stop
      endif


      if (bcx_lo .eq. OUTLET) then
        do k = ks,ke 
        do j = js,je 
          u(is-1,j,k) = u(is,j,k)
        enddo
        enddo
      elseif (bcx_lo .eq. INLET) then
        do k = ks,ke 
        do j = js,je 
          u(is-1,j,k) = uinx_lo(j,k)
        enddo
        enddo
      elseif (bcx_lo .eq. WALL) then
        do k = ks,ke 
        do j = js,je 
            u(is-1,j,k) = zero
        enddo
        enddo
      elseif (bcx_lo .eq. PERIODIC) then
        do k = ks,ke 
        do j = js,je 
          u(is-1,j,k) = u(ie,j,k)
        enddo
        enddo
      else
        print *,'bogus bcx_lo in gsrbvbc ',bcx_lo
        stop
      endif

      if (bcx_hi .eq. OUTLET) then
        do k = ks,ke 
        do j = js,je 
          u(ie+1,j,k) = u(ie,j,k)
        enddo
        enddo
      elseif (bcx_hi .eq. INLET) then
        do k = ks,ke 
        do j = js,je 
          u(ie+1,j,k) = uinx_hi(j,k)
        enddo
        enddo
      elseif (bcx_hi .eq. WALL) then
        do k = ks,ke 
        do j = js,je 
            u(ie+1,j,k) = zero
        enddo
        enddo
      elseif (bcx_hi .eq. PERIODIC) then
        do k = ks,ke 
        do j = js,je 
          u(ie+1,j,k) = u(is,j,k)
        enddo
        enddo
      else
        print *,'bogus bcx_hi in gsrbvbc ',bcx_hi
        stop
      endif


      return
      end

c *************************************************************************
c ** RESTRICT **
c ** Conservative restriction of the residual
c *************************************************************************

      subroutine FORT_RESTRICT(res,resc,DIMS,CDIMS)

      implicit none

      integer DIMS
      integer CDIMS
      REAL_T   res(lo_1 :hi_1 ,lo_2 :hi_2 ,lo_3 :hi_3 )
      REAL_T  resc(loc_1:hic_1,loc_2:hic_2,loc_3:hic_3)

c     Local variables
      integer i,j,k
      integer twoi,twoj,twok

      do k = loc_3,hic_3 
        twok = 2*(k-loc_3)+ lo_3

        do j = loc_2,hic_2 
          twoj = 2*(j-loc_2)+ lo_2

          do i = loc_1,hic_1 
            twoi = 2*(i-loc_1)+ lo_1
            resc(i,j,k) = (res(twoi  ,twoj  ,twok  ) +
     $                     res(twoi+1,twoj  ,twok  ) +
     $                     res(twoi  ,twoj+1,twok  ) +
     $                     res(twoi+1,twoj+1,twok  ) +
     $                     res(twoi  ,twoj  ,twok+1) +
     $                     res(twoi+1,twoj  ,twok+1) +
     $                     res(twoi  ,twoj+1,twok+1) +
     $                     res(twoi+1,twoj+1,twok+1) ) * eighth
          enddo
        enddo
      enddo

      return
      end

c *************************************************************************
c ** COARSIGV **
c ** Coarsending of the coefficients
c *************************************************************************

      subroutine FORT_COARSIGV(sigma,sigmac,DIMS,CDIMS)

      implicit none
      integer DIMS
      integer CDIMS
      REAL_T   sigma(lo_1 -1:hi_1 +1,lo_2 -1:hi_2+1 ,lo_3 -1:hi_3 +1)
      REAL_T  sigmac(loc_1-1:hic_1+1,loc_2-1:hic_2+1,loc_3-1:hic_3+1)

c     Local variables
      integer i,j,k
      integer twoi,twoj,twok

      do k = loc_3,hic_3 
        twok = 2*(k-loc_3)+ lo_3

        do j = loc_2,hic_2 
          twoj = 2*(j-loc_2)+ lo_2

          do i = loc_1,hic_1 
            twoi = 2*(i-loc_1)+ lo_1
            sigmac(i,j,k) = (sigma(twoi  ,twoj  ,twok  ) +
     $                       sigma(twoi+1,twoj  ,twok  ) +
     $                       sigma(twoi  ,twoj+1,twok  ) +
     $                       sigma(twoi+1,twoj+1,twok  ) +
     $                       sigma(twoi  ,twoj  ,twok+1) +
     $                       sigma(twoi+1,twoj  ,twok+1) +
     $                       sigma(twoi  ,twoj+1,twok+1) +
     $                       sigma(twoi+1,twoj+1,twok+1) ) * eighth

          enddo
        enddo
      enddo

      return
      end

c *************************************************************************
c ** INTERPOLATE **
c ** Piecewise-constant interpolation 
c *************************************************************************

      subroutine FORT_INTERPOLATE(u,deltac,DIMS,CDIMS)

      implicit none

      integer DIMS
      integer CDIMS
      REAL_T       u(lo_1 -1:hi_1 +1,lo_2 -1:hi_2 +1,lo_3 -1:hi_3 +1)
      REAL_T  deltac(loc_1-1:hic_1+1,loc_2-1:hic_2+1,loc_3-1:hic_3+1)

c     Local variables
      integer i,j,k
      integer twoi,twoj,twok

      do k = loc_3,hic_3 
        twok = 2*(k-loc_3)+ lo_3

        do j = loc_2,hic_2 
          twoj = 2*(j-loc_2)+ lo_2

          do i = loc_1,hic_1 
            twoi = 2*(i-loc_1)+ lo_1

            u(twoi  ,twoj  ,twok  ) = u(twoi  ,twoj  ,twok  ) + deltac(i,j,k)
            u(twoi+1,twoj  ,twok  ) = u(twoi+1,twoj  ,twok  ) + deltac(i,j,k)
            u(twoi  ,twoj+1,twok  ) = u(twoi  ,twoj+1,twok  ) + deltac(i,j,k)
            u(twoi+1,twoj+1,twok  ) = u(twoi+1,twoj+1,twok  ) + deltac(i,j,k)
            u(twoi  ,twoj  ,twok+1) = u(twoi  ,twoj  ,twok+1) + deltac(i,j,k)
            u(twoi+1,twoj  ,twok+1) = u(twoi+1,twoj  ,twok+1) + deltac(i,j,k)
            u(twoi  ,twoj+1,twok+1) = u(twoi  ,twoj+1,twok+1) + deltac(i,j,k)
            u(twoi+1,twoj+1,twok+1) = u(twoi+1,twoj+1,twok+1) + deltac(i,j,k)

          enddo
        enddo
      enddo


      return
      end
