/*
** (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"

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

#define DIMS  lo_1,lo_2,hi_1,hi_2
#define CDIMS loc_1,loc_2,hic_1,hic_2

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

      subroutine FORT_RESID(res,u,f,areax,areay,alpha,DIMS, 
     $                      dx,irz,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)
      REAL_T      u(lo_1-ng  :hi_1+ng  ,lo_2-ng  :hi_2+ng  )
      REAL_T      f(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng-1)
      REAL_T  areax(lo_1-ng+1:hi_1+ng  ,lo_2-ng+1:hi_2+ng-1)
      REAL_T  areay(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng  )
      REAL_T  alpha(lo_1-ng+1:hi_1+ng-1,lo_2-ng+1:hi_2+ng-1)
      REAL_T  dx(2)
      REAL_T  resnorm
      integer irz
      integer bc(2,2)
      integer level
      integer idir
      REAL_T  mu

c     Local variables
      REAL_T rlu
      REAL_T r, vol
      integer i,j
      integer is,ie,js,je

      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

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

      call gsrbvbc(u,DIMS,bc,irz,idir,ng)

      resnorm = zero

      do j = js, je
      do i = is, ie

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

          ux_rght = (u(i+1,j) - u(i,j)) 
          ux_rght_wall = -(-sixteen * u(ie+1,j) + twenty * u(ie,j)
     $                        -five * u(ie-1,j) + u(ie-2,j) ) * 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) * ux_rght / dx(1)

          uy_bot = (u(i,j) - u(i,j-1)) 
          uy_bot_wall = (-sixteen * u(i,js-1) + twenty * u(i,js)
     $                       -five * u(i,js+1) + u(i,js+2) ) * 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) * uy_bot / dx(2)

          uy_top = (u(i,j+1) - u(i,j)) 
          uy_top_wall = -(-sixteen * u(i,je+1) + twenty * u(i,je)
     $                       -five * u(i,je-1) + u(i,je-2) ) * 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) * uy_top / dx(2)

          rlu = alpha(i,j)*u(i,j) - mu*((ux_rght - ux_left)+
     $                                  (uy_top  - uy_bot ) )
          res(i,j) = f(i,j) - rlu

      enddo
      enddo

      if (irz .eq. 1 .and. idir .eq. 0) then
          do j = js,je 
            do i = is,ie 
              r = (i+half)*dx(1)
              vol = r * dx(1) * dx(2)
              res(i,j) = res(i,j) - mu*vol*u(i,j)/(r*r)
            enddo
          enddo
      endif

      do j = js,je 
        do i = is,ie 
          resnorm = max(resnorm,abs(res(i,j)))
        enddo
      enddo

      return
      end

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

      subroutine FORT_GSRBV(u,f,areax,areay,alpha,DIMS,dx,bc,level,
     $                      idir,nngsrb,mu,irz,ng)

      implicit none

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

c     Local variables
      REAL_T rlam,rlu
      integer i,j,iter,iinc
      integer is,ie,js,je
      integer extra_xlo,extra_xhi,extra_ylo,extra_yhi

      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 facx_left,facx_rght
      REAL_T facy_bot ,facy_top
      REAL_T r, vol
      logical ltest

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

      call gsrbvbc(u,DIMS,bc,0,idir,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)

 
         do j = lo_2-extra_ylo,hi_2+extra_yhi
            iinc = mod(j+iter+1+extra_xlo,2)
            do i = lo_1-extra_xlo+iinc,hi_1+extra_xhi,2

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

              ux_rght = (u(i+1,j) - u(i,j)) 
              ux_rght_wall = -(-sixteen * u(ie+1,j) + twenty * u(ie,j)
     $                            -five * u(ie-1,j) + u(ie-2,j) ) * 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) *   ux_rght / dx(1)
              facx_rght = areax(i+1,j) * facx_rght / dx(1)

              uy_bot = (u(i,j) - u(i,j-1)) 
              uy_bot_wall = (-sixteen * u(i,js-1) + twenty * u(i,js)
     $                          -five * u(i,js+1) + u(i,js+2) ) * 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) *   uy_bot / dx(2)
              facy_bot = areay(i,j) * facy_bot / dx(2)

              uy_top = (u(i,j+1) - u(i,j)) 
              uy_top_wall = -(-sixteen * u(i,je+1) + twenty * u(i,je)
     $                           -five * u(i,je-1) + u(i,je-2) ) * 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) *   uy_top / dx(2)
              facy_top = areay(i,j+1) * facy_top / dx(2)

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

              if (irz .eq. 1 .and. idir .eq. 0) then
                r = (float(i)+half)*dx(1)
                vol = r * dx(1) * dx(2)
                rlu = rlu + mu * vol * u(i,j) / (r*r)
              endif

              rlam = alpha(i,j) + mu*(facx_left+facx_rght+facy_bot+facy_top)
              rlam = one/rlam

              u(i,j) = u(i,j) - rlam*(rlu - f(i,j))

            enddo
          enddo

          call gsrbvbc(u,DIMS,bc,0,idir,ng)

      enddo

      return
      end

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

      subroutine gsrbvbc(u,DIMS,bc,irz,idir,ng)

      implicit none

      integer DIMS
      integer ng
      REAL_T     u(lo_1-ng:hi_1+ng,lo_2-ng:hi_2+ng)
      integer bc(2,2)
      integer irz
      integer idir

c     Local variables
      integer i,j,is,ie,js,je
      integer ilo,ihi,jlo,jhi

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

      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)

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

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

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

      if ((BCX_LO .eq. OUTLET) .or.
     $    (BCX_LO .eq. WALL .and. idir .ne. 0 .and. irz .eq. 1) ) then
        do j = jlo,jhi
          u(is-1,j) = u(is,j)
        enddo
      endif

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

      return
      end

