/*
** (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 ** INITSIG **
c ** Define the 1/rho coefficients at the top level of the multigrid
c *************************************************************************

      subroutine FORT_INITSIGV(sigma,rho,rmu,DIMS,bcx_lo,bcx_hi,bcy_lo,bcy_hi)

      implicit none

      integer DIMS
      REAL_T sigma(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T   rho(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T rmu
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi

c     Local variables
      integer i,j

      do j = lo_2,hi_2
      do i = lo_1,hi_1

        sigma(i,j) = rmu/rho(i,j)

      enddo
      enddo

      if (bcx_lo .eq. PERIODIC) then
        do j = lo_2,hi_2
          sigma(lo_1-1,j) = sigma(hi_1,j)
        enddo
      else if (bcx_lo .eq. WALL) then
        do j = lo_2,hi_2
          sigma(lo_1-1,j) = sigma(lo_1,j)
        enddo
      else if (bcx_lo .eq. INLET) then
        do j = lo_2,hi_2
          sigma(lo_1-1,j) = rmu / rho(lo_1-1,j)
        enddo
      else if (bcx_lo .eq. OUTLET) then
        do j = lo_2,hi_2
          sigma(lo_1-1,j) = sigma(lo_1,j)
        enddo
      endif

      if (bcx_hi .eq. PERIODIC) then
        do j = lo_2,hi_2
          sigma(hi_1+1,j) = sigma(lo_1,j)
        enddo
      else if (bcx_hi .eq. WALL) then
        do j = lo_2,hi_2
          sigma(hi_1+1,j) = sigma(hi_1,j)
        enddo
      else if (bcx_hi .eq. INLET) then
        do j = lo_2,hi_2
          sigma(hi_1+1,j) = rmu / rho(hi_1+1,j)
        enddo
      else if (bcx_hi .eq. OUTLET) then
        do j = lo_2,hi_2
          sigma(hi_1+1,j) = sigma(hi_1,j)
        enddo
      endif

      if (bcy_lo .eq. PERIODIC) then
        do i = lo_1,hi_1
          sigma(i,lo_2-1) = sigma(i,hi_2)
        enddo
      else if (bcy_lo .eq. WALL) then
        do i = lo_1,hi_1
          sigma(i,lo_2-1) = sigma(i,lo_2)
        enddo
      else if (bcy_lo .eq. INLET) then
        do i = lo_1,hi_1
          sigma(i,lo_2-1) = rmu / rho(i,lo_2-1)
        enddo
      else if (bcy_lo .eq. OUTLET) then
        do i = lo_1,hi_1
          sigma(i,lo_2-1) = sigma(i,lo_2)
        enddo
      endif

      if (bcy_hi .eq. PERIODIC) then
        do i = lo_1,hi_1
          sigma(i,hi_2+1) = sigma(i,lo_2)
        enddo
      else if (bcy_hi .eq. WALL) then
        do i = lo_1,hi_1
          sigma(i,hi_2+1) = sigma(i,hi_2)
        enddo
      else if (bcy_hi .eq. INLET) then
        do i = lo_1,hi_1
          sigma(i,hi_2+1) = rmu / rho(i,hi_2+1)
        enddo
      else if (bcy_hi .eq. OUTLET) then
        do i = lo_1,hi_1
          sigma(i,hi_2+1) = sigma(i,hi_2)
        enddo
      endif


      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)

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

c     Local variables
      integer i,j

      rnorm = zero

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

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

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

      return
      end

c *************************************************************************
c ** RESID_XY **
c ** Compute the residual in Cartesian (x-y) geometry
c *************************************************************************

      subroutine FORT_RESID(res,u,f,sigma,
     $                      uinx_lo,uinx_hi,uiny_lo,uiny_hi,r,rhalf,
     $                      DIMS,hx,hy,
     $                      resnorm,bcx_lo,bcx_hi,bcy_lo,bcy_hi,level,irz,idir)

      implicit none

      integer DIMS
      REAL_T    res(lo_1  :hi_1  ,lo_2  :hi_2  )
      REAL_T      u(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T      f(lo_1  :hi_1  ,lo_2  :hi_2  )
      REAL_T  sigma(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T    uinx_lo(lo_2-1:hi_2+1)
      REAL_T    uinx_hi(lo_2-1:hi_2+1)
      REAL_T    uiny_lo(lo_1-1:hi_1+1)
      REAL_T    uiny_hi(lo_1-1:hi_1+1)
      REAL_T          r(lo_1-1:hi_1+1)
      REAL_T      rhalf(lo_1  :hi_1+2)
      REAL_T hx
      REAL_T hy
      REAL_T resnorm
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer level
      integer irz
      integer idir

c     Local variables
      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 hxsqinv, hysqinv
      logical ltest
      integer is,ie,js,je
      integer i,j

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

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

      if (level .eq. 0) then
        call gsrbvbc(u,uinx_lo,uinx_hi,uiny_lo,uiny_hi,
     $               DIMS,bcx_lo,bcx_hi,bcy_lo,bcy_hi,irz,idir)
      endif
      do j = lo_2,hi_2 
        do i = lo_1,hi_1 

            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)
            ux_left   = rhalf(i) *   ux_left * hxsqinv

            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)
            ux_rght   = rhalf(i+1) *   ux_rght * hxsqinv

            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)
            uy_bot   = r(i) *   uy_bot * hysqinv

            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)
            uy_top   = r(i) *   uy_top * hysqinv

            res(i,j) = f(i,j) - (
     $         u(i,j) - sigma(i,j) * (ux_rght-ux_left+uy_top-uy_bot) / r(i) )

        enddo
      enddo

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

      resnorm = zero

      do j = lo_2,hi_2 
        do i = lo_1,hi_1 
          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,sigma,uinx_lo,uinx_hi,uiny_lo,uiny_hi,
     $                      r,rhalf,DIMS,hx,hy,
     $                      bcx_lo,bcx_hi,bcy_lo,bcy_hi,level,irz,idir,nngsrb)

      implicit none

      integer DIMS
      REAL_T      u(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T      f(lo_1  :hi_1  ,lo_2  :hi_2  )
      REAL_T  sigma(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T    uinx_lo(lo_2-1:hi_2+1)
      REAL_T    uinx_hi(lo_2-1:hi_2+1)
      REAL_T    uiny_lo(lo_1-1:hi_1+1)
      REAL_T    uiny_hi(lo_1-1:hi_1+1)
      REAL_T          r(lo_1-1:hi_1+1)
      REAL_T      rhalf(lo_1  :hi_1+2)
      REAL_T hx
      REAL_T hy
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer level
      integer irz
      integer idir
      integer nngsrb

c     Local variables
      REAL_T ux_left,ux_left_wall,facx_left
      REAL_T ux_rght,ux_rght_wall,facx_rght
      REAL_T uy_bot , uy_bot_wall,facy_bot
      REAL_T uy_top , uy_top_wall,facy_top
      REAL_T rlam, rlu
      REAL_T hxsqinv, hysqinv
      integer i,j,iter,ioff,iinc
      integer is,ie,js,je
      logical ltest

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

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

      if (level .eq. 0) then
          call gsrbvbc(u,uinx_lo,uinx_hi,uiny_lo,uiny_hi,
     $                 DIMS,bcx_lo,bcx_hi,bcy_lo,bcy_hi,irz,idir)
      else
          if (bcx_lo .eq. PERIODIC) then
            do j = js-1,je+1 
              u(is-1,j) = u(ie,j)
            enddo
          elseif (bcx_lo .eq. OUTLET) then
            do j = js-1,je+1 
              u(is-1,j) = u(is,j)
            enddo
          endif

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

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

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

      do iter = 1, nngsrb 
       do ioff = 0,1

          do j = js,je 
            iinc = mod(j+ioff,2)
            do i = is+iinc,ie,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   = rhalf(i) *   ux_left * hxsqinv
              facx_left = rhalf(i) * facx_left * hxsqinv

              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   = rhalf(i+1) *   ux_rght * hxsqinv
              facx_rght = rhalf(i+1) * facx_rght * hxsqinv

              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   = r(i) *   uy_bot * hysqinv
              facy_bot = r(i) * facy_bot * hysqinv

              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   = r(i) *   uy_top * hysqinv
              facy_top = r(i) * facy_top * hysqinv

              rlu = u(i,j) - sigma(i,j) * (ux_rght-ux_left+uy_top-uy_bot) / r(i)
              if (irz .eq. 1 .and. idir .eq. 0) 
     $          rlu = rlu + sigma(i,j) * u(i,j) / (r(i)*r(i))

              rlam = one + sigma(i,j)*(facx_left+facx_rght+facy_bot+facy_top)
              rlam = one/rlam
              u(i,j) = u(i,j) - rlam*(rlu - f(i,j))

            enddo
          enddo

          if (level .eq. 0) then
            call gsrbvbc(u,uinx_lo,uinx_hi,uiny_lo,uiny_hi,
     $                   DIMS,bcx_lo,bcx_hi,bcy_lo,bcy_hi,irz,idir)
          else 

            if (bcx_lo .eq. PERIODIC) then
              do j = js-1,je+1 
                u(is-1,j) = u(ie,j)
              enddo
            elseif ( bcx_lo .eq. OUTLET .or.
     $              (bcx_lo .eq. WALL .and. idir .ne. 0 .and. irz .eq. 1) ) then
              do j = lo_2-1,hi_2+1 
                u(is-1,j) = u(is,j)
              enddo
            endif

            if (bcx_hi .eq. PERIODIC) then
              do j = js-1,je+1 
                u(ie+1,j) = u(is,j)
              enddo
            elseif (bcx_hi .eq. OUTLET) then
              do j = lo_2-1,hi_2+1 
                u(ie+1,j) = u(ie,j)
              enddo
            endif

            if (bcy_lo .eq. PERIODIC) then
              do i = is,ie 
                u(i,js-1) = u(i,je)
              enddo
            elseif (bcy_lo .eq. OUTLET) then
              do i = lo_1-1,hi_1+1 
                u(i,js-1) = u(i,js)
              enddo
            endif

            if (bcy_hi .eq. PERIODIC) then
              do i = is,ie 
                u(i,je+1) = u(i,js)
              enddo
            elseif (bcy_hi .eq. OUTLET) then
              do i = lo_1-1,hi_1+1 
                u(i,je+1) = u(i,je)
              enddo
            endif

          endif

       enddo
      enddo

      return
      end

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

      subroutine gsrbvbc(u,uinx_lo,uinx_hi,uiny_lo,uiny_hi,
     $                   DIMS,bcx_lo,bcx_hi,bcy_lo,bcy_hi,irz,idir)

      implicit none

      integer DIMS
      REAL_T     u(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T    uinx_lo(lo_2-1:hi_2+1)
      REAL_T    uinx_hi(lo_2-1:hi_2+1)
      REAL_T    uiny_lo(lo_1-1:hi_1+1)
      REAL_T    uiny_hi(lo_1-1:hi_1+1)
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer irz
      integer idir

c     Local variables
      integer i,j,is,ie,js,je

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

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

      if (bcy_lo .eq. OUTLET) then

        do i = is,ie 
          u(i,js-1) = u(i,js)
        enddo

      elseif (bcy_lo .eq. INLET) then

        do i = is-1,ie+1 
          u(i,js-1) = uiny_lo(i)
        enddo

      elseif (bcy_lo .eq. WALL) then

        do i = is,ie 
          u(i,js-1) = zero
        enddo

      elseif (bcy_lo .eq. PERIODIC) then

        do i = is,ie 
          u(i,js-1) = u(i,je)
        enddo

      endif

      if (bcy_hi .eq. OUTLET) then

        do i = is-1,ie+1 
          u(i,je+1) = u(i,je)
        enddo

      elseif (bcy_hi .eq. INLET) then

        do i = is-1,ie+1 
          u(i,je+1) = uiny_hi(i)
        enddo

      elseif (bcy_hi .eq. WALL) then

        do i = is,ie 
          u(i,je+1) = zero
        enddo

      elseif (bcy_hi .eq. PERIODIC) then

        do i = is,ie 
          u(i,je+1) = u(i,js)
        enddo

      endif

      if (bcx_lo .eq. OUTLET) then

        do j = js-1,je+1 
          u(is-1,j) = u(is,j)
        enddo

      elseif (bcx_lo .eq. INLET) then

        do j = js-1,je+1 
          u(is-1,j) = uinx_lo(j)
        enddo

      elseif (bcx_lo .eq. WALL) then

        if (idir .eq. 0) then
          do j = js-1,je+1 
            u(is-1,j) = zero
          enddo
        else
          do j = js-1,je+1 
            u(is-1,j) = cvmgt(zero,u(is,j),irz .eq. 0)
          enddo
        endif

      elseif (bcx_lo .eq. PERIODIC) then

        do j = js-1,je+1 
          u(is-1,j) = u(ie,j)
        enddo

      endif

      if (bcx_hi .eq. OUTLET) then

        do j = js-1,je+1 
          u(ie+1,j) = u(ie,j)
        enddo

      elseif (bcx_hi .eq. INLET) then

        do j = js-1,je+1 
          u(ie+1,j) = uinx_hi(j)
        enddo

      elseif (bcx_hi .eq. WALL) then

        do j = js-1,je+1 
          u(ie+1,j) = zero
        enddo

      elseif (bcx_hi .eq. PERIODIC) then

        do j = js-1,je+1 
          u(ie+1,j) = u(is,j)
        enddo

      endif

      return
      end

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

      subroutine FORT_RESTRICT(res,resc,DIMS,CDIMS,r)

      implicit none

      integer DIMS
      integer CDIMS
      REAL_T   res(lo_1 :hi_1 ,lo_2 :hi_2 )
      REAL_T  resc(loc_1:hic_1,loc_2:hic_2)
      REAL_T     r(lo_1-1:hi_1+1)

c     Local variables
      REAL_T vtot
      integer i,j
      integer twoi,twoj

      do j = loc_2,hic_2 
        do i = loc_1,hic_1 
          twoi = 2*(i-loc_1)+ lo_1
          twoj = 2*(j-loc_2)+ lo_2
          vtot = (r(twoi) + r(twoi+1))*two
          resc(i,j) = (res(twoi  ,twoj) + res(twoi  ,twoj+1))*r(twoi) + 
     $                (res(twoi+1,twoj) + res(twoi+1,twoj+1))*r(twoi+1)
          resc(i,j) = resc(i,j)/vtot
        enddo
      enddo

      return
      end

c *************************************************************************
c ** COARSIGV **
c ** Coarsening of the coefficients
c *************************************************************************

      subroutine FORT_COARSIGV(sigma,sigmac,DIMS,CDIMS,r)

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

c     Local variables
      REAL_T vtot
      integer i,j,twoi,twoj

      do j = loc_2,hic_2 
        do i = loc_1,hic_1 
          twoi = 2*(i-loc_1)+ lo_1
          twoj = 2*(j-loc_2)+ lo_2
          vtot = (r(twoi) + r(twoi+1))*two
          sigmac(i,j) = (sigma(twoi  ,twoj) + sigma(twoi  ,twoj+1))*r(twoi) 
     $                 +(sigma(twoi+1,twoj) + sigma(twoi+1,twoj+1))*r(twoi+1)
          sigmac(i,j) = sigmac(i,j)/vtot
        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)
      REAL_T  deltac(loc_1-1:hic_1+1,loc_2-1:hic_2+1)

c     Local variables
      integer i,j,twoi,twoj

      do j = loc_2,hic_2 
        do i = loc_1,hic_1 

          twoi = 2*(i-loc_1)+lo_1
          twoj = 2*(j-loc_2)+lo_2

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

        enddo
      enddo


      return
      end
