/*
** (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 ** RESID **
c ** Compute the residual
c *************************************************************************

      subroutine FORT_RESID(res,u,f,areax,areay,areaz,alpha,
     $                      DIMS,dx,resnorm,bc,level,idir,mu,ng)

      implicit none

      integer DIMS
      integer ng
      REAL_T    res(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng-1,lo_3-ng+1:hi_3+ng-1)
      REAL_T      u(lo_1-ng  :hi_1+ng  ,lo_2-ng  :hi_2+ng  ,lo_3-ng  :hi_3+ng  )
      REAL_T      f(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng-1,lo_3-ng+1:hi_3+ng-1)
      REAL_T  areax(lo_1-ng+1:hi_1+ng  ,lo_2-ng+1:hi_2+ng-1,lo_3-ng+1:hi_3+ng-1)
      REAL_T  areay(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng  ,lo_3-ng+1:hi_3+ng-1)
      REAL_T  areaz(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng-1,lo_3-ng+1:hi_3+ng  )
      REAL_T  alpha(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng-1,lo_3-ng+1:hi_3+ng  )

      REAL_T dx(3)
      REAL_T mu
      REAL_T resnorm
      integer bc(2,3)
      integer level
      integer idir

c     Local variables
      REAL_T rlu
      REAL_T ux_left,ux_left_wall
      REAL_T ux_rght,ux_rght_wall
      REAL_T uy_bot,uy_bot_wall
      REAL_T uy_top,uy_top_wall
      REAL_T uz_dwn,uz_dwn_wall
      REAL_T uz_up ,uz_up_wall
      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

      call gsrbvbc(u,DIMS,bc,ng)

      resnorm = zero

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

            ux_left = (u(i,j,k) - u(i-1,j,k)) 
            ux_left_wall = (-sixteen * u(is-1,j,k) + twenty * u(is,j,k)
     $                         -five * u(is+1,j,k) + u(is+2,j,k) ) * fifth
            ux_left = cvmgt(ux_left_wall, ux_left, i .eq. is .and.
     $                      (BCX_LO .eq. WALL .or. BCX_LO .eq. INLET) )
            ux_left = areax(i,j,k) * ux_left / dx(1)

            ux_rght = (u(i+1,j,k) - u(i,j,k)) 
            ux_rght_wall = -(-sixteen * u(ie+1,j,k) + twenty * u(ie,j,k)
     $                          -five * u(ie-1,j,k) + u(ie-2,j,k) ) * fifth
            ux_rght = cvmgt(ux_rght_wall, ux_rght, i .eq. ie .and.
     $                      (BCX_HI .eq. WALL .or. BCX_HI .eq. INLET) )
            ux_rght = areax(i+1,j,k) * ux_rght / dx(1)

            uy_bot = (u(i,j,k) - u(i,j-1,k)) 
            uy_bot_wall = (-sixteen * u(i,js-1,k) + twenty * u(i,js,k)
     $                         -five * u(i,js+1,k) + u(i,js+2,k) ) * fifth
            uy_bot = cvmgt(uy_bot_wall, uy_bot, j .eq. js .and.
     $                      (BCY_LO .eq. WALL .or. BCY_LO .eq. INLET) )
            uy_bot = areay(i,j,k) * uy_bot / dx(2)

            uy_top = (u(i,j+1,k) - u(i,j,k)) 
            uy_top_wall = -(-sixteen * u(i,je+1,k) + twenty * u(i,je,k)
     $                         -five * u(i,je-1,k) + u(i,je-2,k) ) * fifth
            uy_top = cvmgt(uy_top_wall, uy_top, j .eq. je .and.
     $                      (BCY_HI .eq. WALL .or. BCY_HI .eq. INLET) )
            uy_top = areay(i,j+1,k) * uy_top / dx(2)

            uz_dwn = (u(i,j,k) - u(i,j,k-1)) 
            uz_dwn_wall = (-sixteen * u(i,j,ks-1) + twenty * u(i,j,ks)
     $                        -five * u(i,j,ks+1) + u(i,j,ks+2) ) * fifth
            uz_dwn = cvmgt(uz_dwn_wall, uz_dwn, k .eq. ks .and.
     $                      (BCZ_LO .eq. WALL .or. BCZ_LO .eq. INLET) )
            uz_dwn = areaz(i,j,k) * uz_dwn / dx(3)

            uz_up = (u(i,j,k+1) - u(i,j,k)) 
            uz_up_wall = -(-sixteen * u(i,j,ke+1) + twenty * u(i,j,ke)
     $                        -five * u(i,j,ke-1) + u(i,j,ke-2) ) * fifth
            uz_up = cvmgt(uz_up_wall, uz_up, k .eq. ke .and.
     $                      (BCZ_HI .eq. WALL .or. BCZ_HI .eq. INLET) )
            uz_up = areaz(i,j,k+1) * uz_up / dx(3)

            rlu = alpha(i,j,k)*u(i,j,k) - mu*((ux_rght - ux_left)+
     $                                        (uy_top  - uy_bot )+
     $                                        (uz_up   - uz_dwn ) )

            res(i,j,k) = f(i,j,k) - rlu

            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,areax,areay,areaz,alpha,
     $                      DIMS,dx,bc,level,idir,nngsrb,mu,ng)

      implicit none

      integer DIMS
      integer ng
      REAL_T      u(lo_1-ng  :hi_1+ng  ,lo_2-ng  :hi_2+ng  ,lo_3-ng  :hi_3+ng  )
      REAL_T      f(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng-1,lo_3-ng+1:hi_3+ng-1)
      REAL_T  areax(lo_1-ng+1:hi_1+ng  ,lo_2-ng+1:hi_2+ng-1,lo_3-ng+1:hi_3+ng-1)
      REAL_T  areay(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng  ,lo_3-ng+1:hi_3+ng-1)
      REAL_T  areaz(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng-1,lo_3-ng+1:hi_3+ng  )
      REAL_T  alpha(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng-1,lo_3-ng+1:hi_3+ng  )
      REAL_T dx(3)
      REAL_T mu
      integer bc(2,3)
      integer level,idir
      integer nngsrb

c     Local variables
      REAL_T rlam,rlu
      REAL_T facx,facy,facz
      REAL_T hxsqinv, hysqinv, hzsqinv
      REAL_T ux_left,ux_left_wall
      REAL_T ux_rght,ux_rght_wall
      REAL_T uy_bot,uy_bot_wall
      REAL_T uy_top,uy_top_wall
      REAL_T uz_dwn,uz_dwn_wall
      REAL_T uz_up,uz_up_wall
      REAL_T facx_left, facx_rght
      REAL_T facy_bot, facy_top
      REAL_T facz_dwn, facz_up
      integer i,j,k,iter
      integer is,ie,js,je,ks,ke
      integer extra_xlo,extra_xhi
      integer extra_ylo,extra_yhi
      integer extra_zlo,extra_zhi
      integer iinc
      logical ltest

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

      call gsrbvbc(u,DIMS,bc,ng)

      do iter = 1, 2*nngsrb
 
         extra_xlo = cvmgt(ng-iter,0,BCX_LO .eq. INTERIOR .or. BCX_LO .eq. PERIODIC)
         extra_xhi = cvmgt(ng-iter,0,BCX_HI .eq. INTERIOR .or. BCX_HI .eq. PERIODIC)
         extra_ylo = cvmgt(ng-iter,0,BCY_LO .eq. INTERIOR .or. BCY_LO .eq. PERIODIC)
         extra_yhi = cvmgt(ng-iter,0,BCY_HI .eq. INTERIOR .or. BCY_HI .eq. PERIODIC)
         extra_zlo = cvmgt(ng-iter,0,BCZ_LO .eq. INTERIOR .or. BCZ_LO .eq. PERIODIC)
         extra_zhi = cvmgt(ng-iter,0,BCZ_HI .eq. INTERIOR .or. BCZ_HI .eq. PERIODIC)
 
         do k = lo_3-extra_zlo,hi_3+extra_zhi
         do j = lo_2-extra_ylo,hi_2+extra_yhi
            iinc = mod(j+k+iter+1+extra_xlo+2*ng,2)
            do i = lo_1-extra_xlo+iinc,hi_1+extra_xhi,2

              ux_left = (u(i,j,k) - u(i-1,j,k)) 
              ux_left_wall = (-sixteen * u(is-1,j,k) + twenty * u(is,j,k)
     $                           -five * u(is+1,j,k) + u(is+2,j,k) ) * fifth
              ltest = (i .eq. is .and. level .eq. 0 .and. 
     $                 (BCX_LO .eq. WALL .or. BCX_LO .eq. INLET) )
              ux_left   = cvmgt(ux_left_wall,ux_left,ltest)
              facx_left = cvmgt(four        ,one    ,ltest)
              ux_left   = areax(i,j,k) *   ux_left / dx(1)
              facx_left = areax(i,j,k) * facx_left / dx(1)

              ux_rght = (u(i+1,j,k) - u(i,j,k)) 
              ux_rght_wall = -(-sixteen * u(ie+1,j,k) + twenty * u(ie,j,k)
     $                            -five * u(ie-1,j,k) + u(ie-2,j,k) ) * fifth
              ltest = (i .eq. ie .and. level .eq. 0 .and. 
     $                 (BCX_HI .eq. WALL .or. BCX_HI .eq. INLET) )
              ux_rght   = cvmgt(ux_rght_wall,ux_rght,ltest)
              facx_rght = cvmgt(four        ,one    ,ltest)
              ux_rght   = areax(i+1,j,k) *   ux_rght / dx(1)
              facx_rght = areax(i+1,j,k) * facx_rght / dx(1)

              uy_bot = (u(i,j,k) - u(i,j-1,k)) 
              uy_bot_wall = (-sixteen * u(i,js-1,k) + twenty * u(i,js,k)
     $                          -five * u(i,js+1,k) + u(i,js+2,k) ) * fifth
              ltest = (j .eq. js .and. level .eq. 0 .and. 
     $                 (BCY_LO .eq. WALL .or. BCY_LO .eq. INLET) )
              uy_bot   = cvmgt(uy_bot_wall,uy_bot,ltest)
              facy_bot = cvmgt(four       ,one   ,ltest)
              uy_bot   = areay(i,j,k) *   uy_bot / dx(2)
              facy_bot = areay(i,j,k) * facy_bot / dx(2)

              uy_top = (u(i,j+1,k) - u(i,j,k)) 
              uy_top_wall = -(-sixteen * u(i,je+1,k) + twenty * u(i,je,k)
     $                           -five * u(i,je-1,k) + u(i,je-2,k) ) * fifth
              ltest = (j .eq. je .and. level .eq. 0 .and. 
     $                 (BCY_HI .eq. WALL .or. BCY_HI .eq. INLET) )
              uy_top   = cvmgt(uy_top_wall,uy_top,ltest)
              facy_top = cvmgt(four       ,one   ,ltest)
              uy_top   = areay(i,j+1,k) *   uy_top  / dx(2)
              facy_top = areay(i,j+1,k) * facy_top / dx(2)

              uz_dwn = (u(i,j,k) - u(i,j,k-1)) 
              uz_dwn_wall = (-sixteen * u(i,j,ks-1) + twenty * u(i,j,ks)
     $                          -five * u(i,j,ks+1) + u(i,j,ks+2) ) * fifth
              ltest = (k .eq. ks .and. level .eq. 0 .and. 
     $                 (BCZ_LO .eq. WALL .or. BCZ_LO .eq. INLET) )
              uz_dwn   = cvmgt(uz_dwn_wall,uz_dwn,ltest)
              facz_dwn = cvmgt(four       ,one   ,ltest)
              uz_dwn   = areaz(i,j,k) *   uz_dwn / dx(3)
              facz_dwn = areaz(i,j,k) * facz_dwn / dx(3)

              uz_up  = (u(i,j,k+1) - u(i,j,k)) 
              uz_up _wall = -(-sixteen * u(i,j,ke+1) + twenty * u(i,j,ke)
     $                           -five * u(i,j,ke-1) + u(i,j,ke-2) ) * fifth
              ltest = (k .eq. ke .and. level .eq. 0 .and. 
     $                 (BCZ_HI .eq. WALL .or. BCZ_HI .eq. INLET) )
              uz_up    = cvmgt(uz_up_wall ,uz_up ,ltest)
              facz_up  = cvmgt(four       ,one   ,ltest)
              uz_up    = areaz(i,j,k+1) *   uz_up  / dx(3)
              facz_up  = areaz(i,j,k+1) * facz_up  / dx(3)

              rlu = alpha(i,j,k)*u(i,j,k) - mu*((ux_rght - ux_left)+
     $                                          (uy_top  - uy_bot )+
     $                                          (uz_up   - uz_dwn ))

              rlam = alpha(i,j,k) + mu*(facx_left+facx_rght+facy_bot+facy_top+
     $                                  facz_dwn+facz_up)
              rlam = one/rlam
              u(i,j,k) = u(i,j,k) - rlam*(rlu - f(i,j,k))

            enddo
         enddo
         enddo

         call gsrbvbc(u,DIMS,bc,ng)

      enddo

      return
      end

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

      subroutine gsrbvbc(u,DIMS,bc,ng)

      implicit none

      integer DIMS
      integer ng
      REAL_T  u(lo_1-ng:hi_1+ng,lo_2-ng:hi_2+ng,lo_3-ng:hi_3+ng)
      integer bc(2,3)

c     Local variables
      integer i,j,k,is,ie,js,je,ks,ke
      integer ilo,ihi,jlo,jhi,klo,khi

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

      ilo = cvmgt(lo_1-ng,lo_1,BCX_LO .eq. INTERIOR .or. BCX_LO .eq. PERIODIC)
      ihi = cvmgt(hi_1+ng,hi_1,BCX_HI .eq. INTERIOR .or. BCX_HI .eq. PERIODIC)
      jlo = cvmgt(lo_2-ng,lo_2,BCY_LO .eq. INTERIOR .or. BCY_LO .eq. PERIODIC)
      jhi = cvmgt(hi_2+ng,hi_2,BCY_HI .eq. INTERIOR .or. BCY_HI .eq. PERIODIC)
      klo = cvmgt(lo_3-ng,lo_3,BCZ_LO .eq. INTERIOR .or. BCZ_LO .eq. PERIODIC)
      khi = cvmgt(hi_3+ng,hi_3,BCZ_HI .eq. INTERIOR .or. BCZ_HI .eq. PERIODIC)

c
c     The only boundary conditions we need to enforce are OUTLET,
c      since all the others are zero (now that we've put the equations
c      into residual-correction form). 
c

      if (BCZ_LO .eq. OUTLET) then
        do j = jlo,jhi
        do i = ilo,ihi
          u(i,j,ks-1) = u(i,j,ks)
        enddo
        enddo
      endif

      if (BCZ_HI .eq. OUTLET) then
        do j = jlo,jhi
        do i = ilo,ihi
          u(i,j,ke+1) = u(i,j,ke)
        enddo
        enddo
      endif

      if (BCY_LO .eq. OUTLET) then
        do k = klo,khi
        do i = ilo,ihi
          u(i,js-1,k) = u(i,js,k)
        enddo
        enddo
      endif

      if (BCY_HI .eq. OUTLET) then
        do k = klo,khi
        do i = ilo,ihi
          u(i,je+1,k) = u(i,je,k)
        enddo
        enddo
      endif


      if (BCX_LO .eq. OUTLET) then
        do k = klo,khi
        do j = jlo,jhi
          u(is-1,j,k) = u(is,j,k)
        enddo
        enddo
      endif

      if (BCX_HI .eq. OUTLET) then
        do k = klo,khi
        do j = jlo,jhi
          u(ie+1,j,k) = u(ie,j,k)
        enddo
        enddo
      endif

      return
      end
