/*
** (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 "HGPROJ_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
#define GDIMS g_lo_1,g_lo_2,g_lo_3,g_hi_1,g_hi_2,g_hi_3
#define PDIMS p_lo_1,p_lo_2,p_lo_3,p_hi_1,p_hi_2,p_hi_3

#if BL_USE_FLOAT
#define sixteenth  .0625e0
#else
#define sixteenth  .0625d0
#endif

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

      subroutine FORT_INITSIG(sig,rho,DIMS,
     $                        bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

      implicit none

      integer DIMS
      REAL_T   sig(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)
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer bcz_lo,bcz_hi

c     Local variables
      integer i,j,k

      do k = lo_3,hi_3 
      do j = lo_2,hi_2 
        do i = lo_1,hi_1 
          sig(i,j,k) = one / rho(i,j,k)
        enddo
      enddo
      enddo

      if (bcx_lo .eq. PERIODIC) then

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

      else 

        do k = lo_3-1,hi_3+1 
        do j = lo_2-1,hi_2+1 
          sig(lo_1-1,j,k) = zero
          sig(hi_1+1,j,k) = zero
        enddo
        enddo

      endif 

      if (bcy_lo .eq. PERIODIC) then

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

      else

        do k = lo_3-1,hi_3+1 
        do i = lo_1-1,hi_1+1 
          sig(i,lo_2-1,k) = zero
          sig(i,hi_2+1,k) = zero
        enddo
        enddo

      endif

      if (bcz_lo .eq. PERIODIC) then

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

      else

        do j = lo_2-1,hi_2+1 
        do i = lo_1-1,hi_1+1 
          sig(i,j,lo_3-1) = zero
          sig(i,j,hi_3+1) = zero
        enddo
        enddo

      endif

      return
      end

c *************************************************************************
c ** MKCOEFF **
c ** Define the coefficients along the axis as averages of sig.
c *************************************************************************

      subroutine FORT_MKCOEFF(coeff,sig,DIMS)

      implicit none

      integer DIMS
      REAL_T   sig(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T coeff(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,3)

c     Local variables
      integer i,j,k

      do k = lo_3  ,hi_3+1
      do j = lo_2  ,hi_2+1
      do i = lo_1-1,hi_1+1 
          coeff(i,j,k,1) = ( sig(i,j,k  ) + sig(i,j-1,k  ) +
     $                       sig(i,j,k-1) + sig(i,j-1,k-1) ) * fourth
      enddo
      enddo
      enddo

      do k = lo_3  ,hi_3+1
      do j = lo_2-1,hi_2+1 
      do i = lo_1  ,hi_1+1
          coeff(i,j,k,2) = ( sig(i,j,k  ) + sig(i-1,j,k  ) +
     $                       sig(i,j,k-1) + sig(i-1,j,k-1) ) * fourth
      enddo
      enddo
      enddo

      do k = lo_3-1,hi_3+1 
      do j = lo_2  ,hi_2+1
      do i = lo_1  ,hi_1+1   
          coeff(i,j,k,3) = ( sig(i  ,j,k) + sig(i  ,j-1,k) +
     $                       sig(i-1,j,k) + sig(i-1,j-1,k) ) * fourth
      enddo
      enddo
      enddo

      return
      end


c *************************************************************************
c ** GRADHG **
c ** Compute the cell-centered gradient of the nodal pressure field
c *************************************************************************

      subroutine FORT_GRADHG(gphi,GDIMS,phi,PDIMS,DIMS,hx,hy,hz,
     &                       bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

      implicit none

      integer DIMS
      integer g_lo_1, g_lo_2, g_lo_3
      integer g_hi_1, g_hi_2, g_hi_3
      integer p_lo_1, p_lo_2, p_lo_3
      integer p_hi_1, p_hi_2, p_hi_3
      REAL_T  gphi(g_lo_1:g_hi_1,g_lo_2:g_hi_2,g_lo_3:g_hi_3,3)
      REAL_T   phi(p_lo_1:p_hi_1,p_lo_2:p_hi_2,p_lo_3:p_hi_3)
      REAL_T  hx
      REAL_T  hy
      REAL_T  hz
      integer bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi
      
c     Local variables
      integer i, j, k,n

      do k = lo_3,hi_3
         do j = lo_2,hi_2
            do i = lo_1,hi_1
               
               gphi(i,j,k,1) = fourth*(phi(i+1,j,k  ) + phi(i+1,j+1,k  ) +
     $              phi(i+1,j,k+1) + phi(i+1,j+1,k+1) -
     $              phi(i  ,j,k  ) - phi(i  ,j+1,k  ) -
     $              phi(i  ,j,k+1) - phi(i  ,j+1,k+1) ) /hx
               
               gphi(i,j,k,2) = fourth*(phi(i,j+1,k  ) + phi(i+1,j+1,k  ) +
     $              phi(i,j+1,k+1) + phi(i+1,j+1,k+1) -
     $              phi(i,j  ,k  ) - phi(i+1,j  ,k  ) -
     $              phi(i,j  ,k+1) - phi(i+1,j  ,k+1) ) /hy
               
               gphi(i,j,k,3) = fourth*(phi(i,j  ,k+1) + phi(i+1,j  ,k+1) + 
     $              phi(i,j+1,k+1) + phi(i+1,j+1,k+1) -
     $              phi(i,j  ,k  ) - phi(i+1,j  ,k  ) -
     $              phi(i,j+1,k  ) - phi(i+1,j+1,k  ) ) /hz
            enddo
         enddo
      enddo

      if (g_lo_1 .le. lo_1-1 .and. g_hi_1 .ge. hi_1+1) then
         if (bcx_lo .eq. PERIODIC) then
            do k = lo_3,hi_3
            do j = lo_2,hi_2
               gphi(lo_1-1,j,k,1) = gphi(hi_1,j,k,1)
               gphi(lo_1-1,j,k,2) = gphi(hi_1,j,k,2)
               gphi(lo_1-1,j,k,3) = gphi(hi_1,j,k,3)
            enddo
            enddo
         endif
         if (bcx_hi .eq. PERIODIC) then
            do k = lo_3,hi_3
            do j = lo_2,hi_2
               gphi(hi_1+1,j,k,1) = gphi(lo_1,j,k,1)
               gphi(hi_1+1,j,k,2) = gphi(lo_1,j,k,2)
               gphi(hi_1+1,j,k,3) = gphi(lo_1,j,k,3)
            enddo
            enddo
         endif
      endif

      if (g_lo_2 .le. lo_2-1 .and. g_hi_2 .ge. hi_2+1) then
          if (bcy_lo .eq. PERIODIC) then
            do k = lo_3,hi_3
            do i = lo_1,hi_1
                gphi(i,lo_2-1,k,1) = gphi(i,hi_2,k,1)
                gphi(i,lo_2-1,k,2) = gphi(i,hi_2,k,2)
                gphi(i,lo_2-1,k,3) = gphi(i,hi_2,k,3)
            enddo
            enddo
          endif
          if (bcy_hi .eq. PERIODIC) then
            do k = lo_3,hi_3
            do i = lo_1,hi_1
                gphi(i,hi_2+1,k,1) = gphi(i,lo_2,k,1)
                gphi(i,hi_2+1,k,2) = gphi(i,lo_2,k,2)
                gphi(i,hi_2+1,k,3) = gphi(i,lo_2,k,3)
            enddo
            enddo
          endif
       endif

      if (g_lo_3 .le. lo_3-1 .and. g_hi_3 .ge. hi_3+1) then
          if (bcz_lo .eq. PERIODIC) then
            do j = lo_2,hi_2
            do i = lo_1,hi_1
                gphi(i,j,lo_3-1,1) = gphi(i,j,hi_3,1)
                gphi(i,j,lo_3-1,2) = gphi(i,j,hi_3,2)
                gphi(i,j,lo_3-1,3) = gphi(i,j,hi_3,3)
            enddo
            enddo
          endif
          if (bcz_hi .eq. PERIODIC) then
            do j = lo_2,hi_2
            do i = lo_1,hi_1
                gphi(i,j,hi_3+1,1) = gphi(i,j,lo_3,1)
                gphi(i,j,hi_3+1,2) = gphi(i,j,lo_3,2)
                gphi(i,j,hi_3+1,3) = gphi(i,j,lo_3,3)
            enddo
            enddo
          endif
       endif

      if (g_lo_1 .le. lo_1-1 .and. g_hi_1 .ge. hi_1+1 .and.
     &    g_lo_2 .le. lo_2-1 .and. g_hi_2 .ge. hi_2+1) then
         if (bcx_lo .eq. PERIODIC .and. bcy_lo .eq. PERIODIC) then
            do n=1,3
               do k = lo_3,hi_3
                  gphi(lo_1-1,lo_2-1,k,n) = gphi(hi_1,hi_2,k,n)
                  gphi(hi_1+1,lo_2-1,k,n) = gphi(lo_1,hi_2,k,n)
                  gphi(lo_1-1,hi_2+1,k,n) = gphi(hi_1,lo_2,k,n)
                  gphi(hi_1+1,hi_2+1,k,n) = gphi(lo_1,lo_2,k,n)
               enddo
            enddo
         endif
      endif
      
      if (g_lo_1 .le. lo_1-1 .and. g_hi_1 .ge. hi_1+1 .and.
     &     g_lo_3 .le. lo_3-1 .and. g_hi_3 .ge. hi_3+1) then
         if (bcx_lo .eq. PERIODIC .and. bcz_lo .eq. PERIODIC) then
            do n= 1,3
               do j = lo_2,hi_2
                  gphi(lo_1-1,j,lo_3-1,n) = gphi(hi_1,j,hi_3,n)
                  gphi(hi_1+1,j,lo_3-1,n) = gphi(lo_1,j,hi_3,n)
                  gphi(lo_1-1,j,hi_3+1,n) = gphi(hi_1,j,lo_3,n)
                  gphi(hi_1+1,j,hi_3+1,n) = gphi(lo_1,j,lo_3,n)
               enddo
            enddo
         endif
      endif
      
      if (g_lo_2 .le. lo_2-1 .and. g_hi_2 .ge. hi_2+1 .and.
     &     g_lo_3 .le. lo_3-1 .and. g_hi_3 .ge. hi_3+1) then
         if (bcy_lo .eq. PERIODIC .and. bcz_lo .eq. PERIODIC) then
            do n= 1,3
               do i = lo_1,hi_1
                  gphi(i,lo_2-1,lo_3-1,n) = gphi(i,hi_2,hi_3,n)
                  gphi(i,hi_2+1,lo_3-1,n) = gphi(i,lo_2,hi_3,n)
                  gphi(i,lo_2-1,hi_3+1,n) = gphi(i,hi_2,lo_3,n)
                  gphi(i,hi_2+1,hi_3+1,n) = gphi(i,lo_2,lo_3,n)
               enddo
            enddo
         endif
      endif
      
      if (g_lo_1 .le. lo_1-1 .and. g_hi_1 .ge. hi_1+1 .and.
     &     g_lo_2 .le. lo_2-1 .and. g_hi_2 .ge. hi_2+1 .and.
     &     g_lo_3 .le. lo_3-1 .and. g_hi_3 .ge. hi_3+1) then
         if (bcx_lo .eq. PERIODIC .and. bcy_lo .eq. PERIODIC 
     &        .and. bcz_lo .eq. PERIODIC) then
            do n=1,3
               gphi(lo_2-1,lo_2-1,lo_3-1,n) = gphi(hi_1,hi_2,hi_3,n)
               gphi(lo_2-1,hi_2+1,lo_3-1,n) = gphi(hi_1,lo_2,hi_3,n)
               gphi(lo_2-1,lo_2-1,hi_3+1,n) = gphi(hi_1,hi_2,lo_3,n)
               gphi(lo_2-1,hi_2+1,hi_3+1,n) = gphi(hi_1,lo_2,lo_3,n)
               gphi(hi_2+1,lo_2-1,lo_3-1,n) = gphi(lo_1,hi_2,hi_3,n)
               gphi(hi_2+1,hi_2+1,lo_3-1,n) = gphi(lo_1,lo_2,hi_3,n)
               gphi(hi_2+1,lo_2-1,hi_3+1,n) = gphi(lo_1,hi_2,lo_3,n)
               gphi(hi_2+1,hi_2+1,hi_3+1,n) = gphi(lo_1,lo_2,lo_3,n)
            enddo
         endif
      endif

      return
      end

c *************************************************************************
c ** RHSHG **
c ** Compute the right-hand-side D(V) for the projection
c *************************************************************************

      subroutine FORT_RHSHG(du,u,divu_src,DIMS,hx,hy,hz,
     $                      bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi,
     $                      norm,time,dt,un,ustar)

      implicit none

      integer DIMS
      REAL_T        du(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T  divu_src(lo_1  :hi_1+1,lo_2  :hi_2+1,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  hx
      REAL_T  hy
      REAL_T  hz
      REAL_T  time
      REAL_T  dt
      REAL_T     un(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T  ustar(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer bcz_lo,bcz_hi

c     Local variables
      REAL_T fac,facx,facy,facz,norm
      REAL_T factor, sum_src, sum_fac
      integer i, j, k, n
      integer is,ie,js,je,ks,ke
      integer istrt,iend
      integer jstrt,jend
      integer kstrt,kend
      logical is_singular

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

      istrt = cvmgt(lo_1+1,lo_1  ,BCX_LO .eq. OUTLET)
      iend  = cvmgt(hi_1  ,hi_1+1,BCX_HI .eq. OUTLET)

      jstrt = cvmgt(lo_2+1,lo_2  ,BCY_LO .eq. OUTLET)
      jend  = cvmgt(hi_2  ,hi_2+1,BCY_HI .eq. OUTLET)

      kstrt = cvmgt(lo_3+1,lo_3  ,BCZ_LO .eq. OUTLET)
      kend  = cvmgt(hi_3  ,hi_3+1,BCZ_HI .eq. OUTLET)

      is_singular = .true.
      if (BCX_LO .eq. OUTLET .or. BCX_HI .eq. OUTLET .or.
     $    BCY_LO .eq. OUTLET .or. BCY_HI .eq. OUTLET .or.
     $    BCZ_LO .eq. OUTLET .or. BCZ_HI .eq. OUTLET) is_singular = .false.


c note: originally, we set inflow bc here, but this was found to be
c  redundant, so it was deleted

      if (bcx_lo .eq. PERIODIC) then
        do n = 1,3
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(is-1,j,k,n) = u(ie,j,k,n)
        enddo
        enddo
        enddo

      else if (bcx_lo .eq. WALL) then

        do n = 1,3
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(is-1,j,k,n) = zero
        enddo
        enddo
        enddo

      endif

      if (bcx_hi .eq. PERIODIC) then
        do n = 1,3
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(ie+1,j,k,n) = u(is,j,k,n)
        enddo
        enddo
        enddo

      else if (bcx_hi .eq. WALL) then

        do n = 1,3
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(ie+1,j,k,n) = zero
        enddo
        enddo
        enddo

      endif

      if (bcy_lo .eq. PERIODIC) then
        do n = 1,3
        do k = ks-1,ke+1
        do i = is-1,ie+1
          u(i,js-1,k,n) = u(i,je,k,n)
        enddo
        enddo
        enddo

      else if (bcy_lo .eq. WALL) then

        do n = 1,3
        do k = ks-1,ke+1
        do i = is-1,ie+1
          u(i,js-1,k,n) = zero
        enddo
        enddo
        enddo

      endif

      if (bcy_hi .eq. PERIODIC) then
        do n = 1,3
        do k = ks-1,ke+1
        do i = is-1,ie+1
          u(i,je+1,k,n) = u(i,js,k,n)
        enddo
        enddo
        enddo

      else if (bcy_hi .eq. WALL) then

        do n = 1,3
        do k = ks-1,ke+1
        do i = is-1,ie+1
          u(i,je+1,k,n) = zero
        enddo
        enddo
        enddo

      endif

      if (bcz_lo .eq. PERIODIC) then

        do n = 1,3
        do j = js-1,je+1
        do i = is-1,ie+1
          u(i,j,ks-1,n) = u(i,j,ke,n)
        enddo
        enddo
        enddo

      else if (bcz_lo .eq. WALL) then

        do n = 1,3
        do j = js-1,je+1
        do i = is-1,ie+1
          u(i,j,ks-1,n) = zero
        enddo
        enddo
        enddo

      endif

      if (bcz_hi .eq. PERIODIC) then

        do n = 1,3
        do j = js-1,je+1
        do i = is-1,ie+1
          u(i,j,ke+1,n) = u(i,j,ks,n)
        enddo
        enddo
        enddo

      else if (bcz_hi .eq. WALL) then

        do n = 1,3
        do j = js-1,je+1
        do i = is-1,ie+1
          u(i,j,ke+1,n) = zero
        enddo
        enddo
        enddo

      endif
 
      facx = fourth / hx
      facy = fourth / hx
      facz = fourth / hx

      do k = kstrt,kend 
      do j = jstrt,jend 
      do i = istrt,iend 
          du(i,j,k) = ((u(i  ,j-1,k  ,1) + u(i  ,j,k  ,1) +
     $                  u(i  ,j-1,k-1,1) + u(i  ,j,k-1,1)) - 
     $                 (u(i-1,j-1,k  ,1) + u(i-1,j,k  ,1)  +
     $                  u(i-1,j-1,k-1,1) + u(i-1,j,k-1,1)) ) * facx
     $              + ((u(i-1,j  ,k  ,2) + u(i,j  ,k  ,2) +
     $                  u(i-1,j  ,k-1,2) + u(i,j  ,k-1,2)) - 
     $                 (u(i-1,j-1,k  ,2) + u(i,j-1,k  ,2) +
     $                  u(i-1,j-1,k-1,2) + u(i,j-1,k-1,2)) ) * facy
     $              + ((u(i-1,j  ,k  ,3) + u(i,j  ,k  ,3) +
     $                  u(i-1,j-1,k  ,3) + u(i,j-1,k  ,3)) - 
     $                 (u(i-1,j  ,k-1,3) + u(i,j  ,k-1,3) +
     $                  u(i-1,j-1,k-1,3) + u(i,j-1,k-1,3)) ) * facz

          du(i,j,k) = du(i,j,k) - divu_src(i,j,k)

      enddo
      enddo
      enddo

      norm = zero

      do k = kstrt,kend 
      do j = jstrt,jend 
      do i = istrt,iend 
        
         fac = one
         fac = cvmgt(two*fac,fac,(i .eq. is  ) .and. bcx_lo .eq. WALL)
         fac = cvmgt(two*fac,fac,(i .eq. ie+1) .and. bcx_hi .eq. WALL)
         fac = cvmgt(two*fac,fac,(j .eq. js  ) .and. bcy_lo .eq. WALL)
         fac = cvmgt(two*fac,fac,(j .eq. je+1) .and. bcy_hi .eq. WALL)
         fac = cvmgt(two*fac,fac,(k .eq. ks  ) .and. bcz_lo .eq. WALL)
         fac = cvmgt(two*fac,fac,(k .eq. ke+1) .and. bcz_hi .eq. WALL)

         du(i,j,k) = du(i,j,k) * fac

      enddo
      enddo
      enddo

      if (is_singular) then
        sum_src  = zero
        sum_fac  = zero
        do k = kstrt, kend 
        do j = jstrt, jend 
        do i = istrt, iend 
          factor = one
          factor = cvmgt(half*factor,factor,i.eq.lo_1 .or. i.eq.hi_1+1)
          factor = cvmgt(half*factor,factor,j.eq.lo_2 .or. j.eq.hi_2+1)
          factor = cvmgt(half*factor,factor,k.eq.lo_3 .or. k.eq.hi_3+1)
          sum_src = sum_src + factor * du(i,j,k)
          sum_fac = sum_fac + factor
        enddo
        enddo
        enddo

        sum_src = sum_src / sum_fac

c       write(6,999) sum_src

        do k = kstrt, kend 
        do j = jstrt, jend 
        do i = istrt, iend 
          du(i,j,k) = du(i,j,k) - sum_src
          norm = max(norm, abs(du(i,j,k)))
        enddo
        enddo
        enddo
      endif

 999  format('Singular adjustment is ',e12.5)

      return
      end

c *************************************************************************
c ** PROJUHG **
c ** Define the updated pressure and vector field
c *************************************************************************

      subroutine FORT_PROJUHG(u,pressure,phi,gradphi,rhonph,DIMS)

      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,3)
      REAL_T  pressure(lo_1  :hi_1+1,lo_2  :hi_2+1,lo_3  :hi_3+1)
      REAL_T       phi(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T   gradphi(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,3)
      REAL_T    rhonph(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)

c     Local variables
      integer i, j, k

      do k = lo_3,hi_3 
      do j = lo_2,hi_2 
        do i = lo_1,hi_1 
          u(i,j,k,1) = u(i,j,k,1) - gradphi(i,j,k,1)/rhonph(i,j,k)
          u(i,j,k,2) = u(i,j,k,2) - gradphi(i,j,k,2)/rhonph(i,j,k)
          u(i,j,k,3) = u(i,j,k,3) - gradphi(i,j,k,3)/rhonph(i,j,k)
        enddo
      enddo
      enddo

      do k = lo_3,hi_3+1
      do j = lo_2,hi_2+1
        do i = lo_1,hi_1+1 
c          pressure(i,j,k) = pressure(i,j,k) + phi(i,j,k)
           pressure(i,j,k) = phi(i,j,k)
        enddo
      enddo
      enddo

      return
      end

c *************************************************************************
c ** RESIDUAL **
c ** Compute the residual R = f - D(sig G(phi))
c *************************************************************************

      subroutine FORT_RESIDUAL(residual,phi,source,coeff,dgphi,
     $                         DIMS,hx,hy,hz,resnorm,
     $                         bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

      implicit none

      integer DIMS
      REAL_T  residual(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T       phi(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T    source(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T     coeff(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     dgphi(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      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

c     Local variables
      integer i,j,k
      integer istrt,jstrt,kstrt
      integer iend,jend,kend

      resnorm = zero

      istrt = cvmgt(lo_1+1,lo_1  ,BCX_LO .eq. OUTLET)
      iend  = cvmgt(hi_1  ,hi_1+1,BCX_HI .eq. OUTLET)

      jstrt = cvmgt(lo_2+1,lo_2  ,BCY_LO .eq. OUTLET)
      jend  = cvmgt(hi_2  ,hi_2+1,BCY_HI .eq. OUTLET)

      kstrt = cvmgt(lo_3+1,lo_3  ,BCZ_LO .eq. OUTLET)
      kend  = cvmgt(hi_3  ,hi_3+1,BCZ_HI .eq. OUTLET)

      call makedgphi(phi,dgphi,coeff,DIMS,hx,hy,hz,
     $               bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

      do k = kstrt,kend
      do j = jstrt,jend
        do i = istrt,iend
          residual(i,j,k) = source(i,j,k) - dgphi(i,j,k)
        enddo
      enddo
      enddo

      do k = kstrt,kend 
      do j = jstrt,jend 
        do i = istrt,iend 
          resnorm = max(resnorm,abs(residual(i,j,k)))
        enddo
      enddo
      enddo

      return
      end

c *************************************************************************
c ** RELAX **
c ** Gauss-Seidel relaxation
c *************************************************************************

      subroutine FORT_RELAX(phi,source,coeff,dgphi,DIMS,hx,hy,hz,
     $                      bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi,nnrelax)

      implicit none

      integer DIMS
      REAL_T     phi(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T  source(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T   coeff(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,3)
      REAL_T   dgphi(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      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 nnrelax

c     Local variables
      REAL_T  facx, facy, facz
      REAL_T  rfac
      integer i,j,k
      integer iter, ioff, iinc
      integer is,ie,js,je,ks,ke
      integer istrt, jstrt, kstrt
      integer iend, jend, kend

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

      facx = one/(hx*hx)
      facy = one/(hy*hy)
      facz = one/(hz*hz)

      istrt = cvmgt(lo_1+1,lo_1  ,BCX_LO .eq. OUTLET)
      iend  = cvmgt(hi_1  ,hi_1+1,BCX_HI .eq. OUTLET)

      jstrt = cvmgt(lo_2+1,lo_2  ,BCY_LO .eq. OUTLET)
      jend  = cvmgt(hi_2  ,hi_2+1,BCY_HI .eq. OUTLET)

      kstrt = cvmgt(lo_3+1,lo_3  ,BCZ_LO .eq. OUTLET)
      kend  = cvmgt(hi_3  ,hi_3+1,BCZ_HI .eq. OUTLET)

      do iter = 1, nnrelax 
c      do ioff = 0,1

          if (bcx_lo .eq. PERIODIC) then
            do k = ks-1,ke+2
            do j = js-1,je+2
              phi(ie+1,j,k) = phi(is  ,j,k)
              phi(ie+2,j,k) = phi(is+1,j,k)
              phi(is-1,j,k) = phi(ie  ,j,k)
            enddo
            enddo
          endif

          if (bcy_lo .eq. PERIODIC) then
            do k = ks-1,ke+2
            do i = is-1,ie+2
              phi(i,je+1,k) = phi(i,js  ,k)
              phi(i,je+2,k) = phi(i,js+1,k)
              phi(i,js-1,k) = phi(i,je  ,k)
            enddo
            enddo
          endif

          if (bcz_lo .eq. PERIODIC) then
            do j = js-1,je+2
            do i = is-1,ie+2
              phi(i,j,ke+1) = phi(i,j,ks  )
              phi(i,j,ke+2) = phi(i,j,ks+1)
              phi(i,j,ks-1) = phi(i,j,ke  )
            enddo
            enddo
          endif

c         call makedgphi(phi,dgphi,coeff,DIMS,hx,hy,hz,
c    $                   bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

          do k = kstrt,kend
           do j = jstrt,jend
c           iinc = mod(j+k+ioff,2)
c           do i = istrt+iinc,iend,2
            do i = istrt,iend

              dgphi(i,j,k) = 
     $         (coeff(i  ,j,k,1) * (phi(i+1,j,k) - phi(i,j,k)) +
     $          coeff(i-1,j,k,1) * (phi(i-1,j,k) - phi(i,j,k)) ) * facx +
     $         (coeff(i,j  ,k,2) * (phi(i,j+1,k) - phi(i,j,k)) +
     $          coeff(i,j-1,k,2) * (phi(i,j-1,k) - phi(i,j,k)) ) * facy +
     $         (coeff(i,j,k  ,3) * (phi(i,j,k+1) - phi(i,j,k)) +
     $          coeff(i,j,k-1,3) * (phi(i,j,k-1) - phi(i,j,k)) ) * facz

              rfac =  (coeff(i,j,k,1) + coeff(i-1,j,k,1)) * facx +
     $                (coeff(i,j,k,2) + coeff(i,j-1,k,2)) * facy +
     $                (coeff(i,j,k,3) + coeff(i,j,k-1,3)) * facz 

              if ( (i .eq. is .or. i .eq. ie+1) .and. bcx_lo .ne. PERIODIC) then 
                 dgphi(i,j,k) = two*dgphi(i,j,k)
                 rfac = two * rfac
              endif

              if ( (j .eq. js .or. j .eq. je+1) .and. bcy_lo .ne. PERIODIC) then
                 dgphi(i,j,k) = two*dgphi(i,j,k)
                 rfac = two * rfac
              endif

              if ( (k .eq. ks .or. k .eq. ke+1) .and. bcz_lo .ne. PERIODIC) then
                 dgphi(i,j,k) = two*dgphi(i,j,k)
                 rfac = two * rfac
              endif

              rfac = one/rfac

              phi(i,j,k) = phi(i,j,k) + rfac*(dgphi(i,j,k) - source(i,j,k))

            enddo
           enddo
           if (k .eq. ks+1 .and. bcz_lo .eq. PERIODIC) then
             do j = js-1,je+2
             do i = is-1,ie+2
               phi(i,j,ke+1) = phi(i,j,ks  )
               phi(i,j,ke+2) = phi(i,j,ks+1)
             enddo
             enddo
           endif
          enddo

c      enddo

       if (bcx_lo .eq. PERIODIC) then
        do k = ks-1,ke+2
        do j = js-1,je+2
          phi(ie+1,j,k) = phi(is  ,j,k)
          phi(ie+2,j,k) = phi(is+1,j,k)
          phi(is-1,j,k) = phi(ie  ,j,k)
        enddo
        enddo
       endif

       if (bcy_lo .eq. PERIODIC) then
        do k = ks-1,ke+2
        do i = is-1,ie+2
          phi(i,je+1,k) = phi(i,js  ,k)
          phi(i,je+2,k) = phi(i,js+1,k)
          phi(i,js-1,k) = phi(i,je  ,k)
        enddo
        enddo
       endif

       if (bcz_lo .eq. PERIODIC) then
        do j = js-1,je+2
        do i = is-1,ie+2
          phi(i,j,ke+1) = phi(i,j,ks  )
          phi(i,j,ke+2) = phi(i,j,ks+1)
          phi(i,j,ks-1) = phi(i,j,ke  )
        enddo
        enddo
       endif

      enddo

      return
      end

c *************************************************************************
c ** COARSIG **
c ** Coarsening of the sig coefficients
c *************************************************************************

      subroutine FORT_COARSIG(sig,sigc,DIMS,CDIMS,
     $                        bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

      implicit none

      integer DIMS
      integer CDIMS
      REAL_T  sig(lo_1 -1:hi_1 +1,lo_2 -1:hi_2 +1,lo_3 -1:hi_3 +1)
      REAL_T sigc(loc_1-1:hic_1+1,loc_2-1:hic_2+1,loc_3-1:hic_3+1)
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer bcz_lo,bcz_hi

c     Local variables
      integer i ,j, k
      integer i2,j2,k2

      do k = loc_3,hic_3 
      do j = loc_2,hic_2 
        do i = loc_1,hic_1 
          i2 = 2*(i-loc_1)+lo_1
          j2 = 2*(j-loc_2)+lo_2
          k2 = 2*(k-loc_3)+lo_3
          sigc(i,j,k) = ( sig(i2  ,j2,k2  ) + sig(i2  ,j2+1,k2  )+ 
     $                    sig(i2+1,j2,k2  ) + sig(i2+1,j2+1,k2  )+
     $                    sig(i2  ,j2,k2+1) + sig(i2  ,j2+1,k2+1)+
     $                    sig(i2+1,j2,k2+1) + sig(i2+1,j2+1,k2+1) ) * eighth

        enddo
      enddo
      enddo

      if (bcx_lo .eq. PERIODIC) then

        do k = loc_3-1,hic_3+1 
        do j = loc_2-1,hic_2+1 
          sigc(loc_1-1,j,k) = sigc(hic_1,j,k)
          sigc(hic_1+1,j,k) = sigc(loc_1,j,k)
        enddo
        enddo

      endif

      if (bcy_lo .eq. PERIODIC) then

        do k = loc_3-1,hic_3+1 
        do i = loc_1-1,hic_1+1 
          sigc(i,loc_2-1,k) = sigc(i,hic_2,k)
          sigc(i,hic_2+1,k) = sigc(i,loc_2,k)
        enddo
        enddo

      endif

      if (bcz_lo .eq. PERIODIC) then

        do j = loc_2-1,hic_2+1 
        do i = loc_1-1,hic_1+1 
          sigc(i,j,loc_3-1) = sigc(i,j,hic_3)
          sigc(i,j,hic_3+1) = sigc(i,j,loc_3)
        enddo
        enddo

      endif

      return
      end

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

      subroutine FORT_RESTRICT(res,resc,DIMS,CDIMS,
     $                         bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

      implicit none

      integer DIMS
      integer CDIMS
      REAL_T   res(lo_1 -1:hi_1 +2,lo_2 -1:hi_2 +2,lo_3 -1:hi_3 +2)
      REAL_T  resc(loc_1-1:hic_1+2,loc_2-1:hic_2+2,loc_3-1:hic_3+2)
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer bcz_lo,bcz_hi

c     Local variables
      integer i,j,k,ii,jj,kk
      integer istrt,jstrt,kstrt
      integer iend,jend,kend
      REAL_T cen, faces, sides, corners

      istrt = cvmgt(loc_1+1,loc_1  ,BCX_LO .eq. OUTLET)
      iend  = cvmgt(hic_1  ,hic_1+1,BCX_HI .eq. OUTLET)

      jstrt = cvmgt(loc_2+1,loc_2  ,BCY_LO .eq. OUTLET)
      jend  = cvmgt(hic_2  ,hic_2+1,BCY_HI .eq. OUTLET)

      kstrt = cvmgt(loc_3+1,loc_3  ,BCZ_LO .eq. OUTLET)
      kend  = cvmgt(hic_3  ,hic_3+1,BCZ_HI .eq. OUTLET)

      if (bcx_lo .eq. PERIODIC) then
        do k = lo_3-1,hi_3+2
        do j = lo_2-1,hi_2+2
          res(hi_1+1,j,k) = res(lo_1  ,j,k)
          res(hi_1+2,j,k) = res(lo_1+1,j,k)
          res(lo_1-1,j,k) = res(hi_1  ,j,k)
        enddo
        enddo
      else 
        do k = lo_3-1,hi_3+2
        do j = lo_2-1,hi_2+2
          res(hi_1+2,j,k) = res(hi_1  ,j,k)
          res(lo_1-1,j,k) = res(lo_1+1,j,k)
        enddo
        enddo
      endif

      if (bcy_lo .eq. PERIODIC) then
        do k = lo_3-1,hi_3+2
        do i = lo_1-1,hi_1+2
          res(i,hi_2+1,k) = res(i,lo_2  ,k)
          res(i,hi_2+2,k) = res(i,lo_2+1,k)
          res(i,lo_2-1,k) = res(i,hi_2  ,k)
        enddo
        enddo
      else
        do k = lo_3-1,hi_3+2
        do i = lo_1-1,hi_1+2
          res(i,hi_2+2,k) = res(i,hi_2  ,k)
          res(i,lo_2-1,k) = res(i,lo_2+1,k)
        enddo
        enddo
      endif

      if (bcz_lo .eq. PERIODIC) then
        do j = lo_2-1,hi_2+2
        do i = lo_1-1,hi_1+2
          res(i,j,hi_3+1) = res(i,j,lo_3  )
          res(i,j,hi_3+2) = res(i,j,lo_3+1)
          res(i,j,lo_3-1) = res(i,j,hi_3  )
        enddo
        enddo
      else
        do j = lo_2-1,hi_2+2
        do i = lo_1-1,hi_1+2
          res(i,j,hi_3+2) = res(i,j,hi_3  )
          res(i,j,lo_3-1) = res(i,j,lo_3+1)
        enddo
        enddo
      endif

      do k = kstrt,kend
      do j = jstrt,jend
      do i = istrt,iend

          ii = 2*(i-loc_1)+lo_1
          jj = 2*(j-loc_2)+lo_2
          kk = 2*(k-loc_3)+lo_3

          cen = res(ii,jj,kk)

          faces = res(ii+1,jj,kk) + res(ii-1,jj,kk) +
     $            res(ii,jj+1,kk) + res(ii,jj-1,kk) +
     $            res(ii,jj,kk+1) + res(ii,jj,kk-1)

          sides = res(ii+1,jj+1,kk) + res(ii-1,jj+1,kk) +
     $            res(ii+1,jj-1,kk) + res(ii-1,jj-1,kk) +
     $            res(ii+1,jj,kk+1) + res(ii-1,jj,kk+1) +
     $            res(ii+1,jj,kk-1) + res(ii-1,jj,kk-1) +
     $            res(ii,jj+1,kk+1) + res(ii,jj-1,kk+1) +
     $            res(ii,jj+1,kk-1) + res(ii,jj-1,kk-1)

          corners = res(ii+1,jj+1,kk+1) + res(ii-1,jj+1,kk+1) +
     $              res(ii+1,jj-1,kk+1) + res(ii-1,jj-1,kk+1) +
     $              res(ii+1,jj+1,kk-1) + res(ii-1,jj+1,kk-1) +
     $              res(ii+1,jj-1,kk-1) + res(ii-1,jj-1,kk-1)

          resc(i,j,k) = eighth * (cen + half   * faces + 
     $                                  fourth * sides + 
     $                                  eighth * corners)

      enddo
      enddo
      enddo

      return
      end

c *************************************************************************
c ** INTERP **
c ** Simple bilinear interpolation
c *************************************************************************

      subroutine FORT_INTERP(phi,deltac,DIMS,CDIMS)

      implicit none

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

c     Local variables
      integer i,j,k,ii,jj,kk
      integer is,ie,js,je,ks,ke,isc,iec,jsc,jec,ksc,kec

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

      isc = loc_1
      jsc = loc_2
      ksc = loc_3
      iec = hic_1
      jec = hic_2
      kec = hic_3

      do k = ksc, kec+1 
      do j = jsc, jec+1 
      do i = isc, iec+1

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js
          kk = 2*(k-ksc)+ks

          phi(ii,jj,kk) = deltac(i,j,k)

      enddo
      enddo
      enddo

      do k = ksc, kec+1
      do j = jsc, jec
      do i = isc, iec+1

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js
          kk = 2*(k-ksc)+ks

          phi(ii,jj+1,kk) = half*(deltac(i,j,k) + deltac(i,j+1,k)) 

      enddo
      enddo
      enddo

      do j = jsc, jec+1 
      do k = ksc, kec+1
      do i = isc, iec

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js
          kk = 2*(k-ksc)+ks

          phi(ii+1,jj,kk) = half*(deltac(i,j,k) + deltac(i+1,j,k))

      enddo
      enddo
      enddo

      do j = jsc, jec+1 
      do i = isc, iec+1
      do k = ksc, kec

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js
          kk = 2*(k-ksc)+ks

          phi(ii,jj,kk+1) = half*(deltac(i,j,k) + deltac(i,j,k+1))

      enddo
      enddo
      enddo

      do k = ksc, kec+1
      do j = jsc, jec 
      do i = isc, iec 

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js
          kk = 2*(k-ksc)+ks

          phi(ii+1,jj+1,kk) = fourth*(deltac(i,j  ,k) + deltac(i+1,j  ,k) + 
     $                                deltac(i,j+1,k) + deltac(i+1,j+1,k) )
      enddo
      enddo
      enddo

      do j = jsc, jec+1 
      do k = ksc, kec
      do i = isc, iec 

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js
          kk = 2*(k-ksc)+ks

          phi(ii+1,jj,kk+1) = fourth*(deltac(i,j,k  ) + deltac(i+1,j,k  ) + 
     $                                deltac(i,j,k+1) + deltac(i+1,j,k+1) )
      enddo
      enddo
      enddo

      do j = jsc, jec 
      do k = ksc, kec
      do i = isc, iec+1 

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js
          kk = 2*(k-ksc)+ks

          phi(ii,jj+1,kk+1) = fourth*(deltac(i,j,k  ) + deltac(i,j+1,k  ) + 
     $                                deltac(i,j,k+1) + deltac(i,j+1,k+1) )
      enddo
      enddo
      enddo


      do j = jsc, jec
      do k = ksc, kec
      do i = isc, iec 

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js
          kk = 2*(k-ksc)+ks

          phi(ii+1,jj+1,kk+1) = eighth*(deltac(i,j  ,k  ) + deltac(i+1,j  ,k  ) + 
     $                                  deltac(i,j  ,k+1) + deltac(i+1,j  ,k+1) +
     $                                  deltac(i,j+1,k  ) + deltac(i+1,j+1,k  ) +
     $                                  deltac(i,j+1,k+1) + deltac(i+1,j+1,k+1) )
      enddo
      enddo
      enddo

      return
      end

c *************************************************************************
c ** MAKEDGPHI **
c ** Compute D(sig G(phi))
c *************************************************************************

      subroutine makedgphi(phi,dgphi,coeff,DIMS,hx,hy,hz,
     $                     bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

      implicit none

      integer DIMS
      REAL_T    phi(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T  dgphi(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T  coeff(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,3)
      REAL_T  hx
      REAL_T  hy
      REAL_T  hz
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer bcz_lo,bcz_hi

c     Local variables
      REAL_T facx, facy, facz
      integer is,ie,js,je,ks,ke
      integer i,j,k

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

      if (bcx_lo .eq. PERIODIC) then
        do k = ks,ke+1 
        do j = js,je+1 
          phi(ie+2,j,k) = phi(is+1,j,k)
          phi(is-1,j,k) = phi(ie  ,j,k)
        enddo
        enddo
      endif

      if (bcy_lo .eq. PERIODIC) then
        do k = ks,ke+1 
        do i = is,ie+1 
          phi(i,je+2,k) = phi(i,js+1,k)
          phi(i,js-1,k) = phi(i,je  ,k)
        enddo
        enddo
      endif

      if (bcz_lo .eq. PERIODIC) then
        do j = js,je+1 
        do i = is,ie+1 
          phi(i,j,ke+2) = phi(i,j,ks+1)
          phi(i,j,ks-1) = phi(i,j,ke  )
        enddo
        enddo
      endif

      if (bcx_lo .eq. PERIODIC .and. bcy_lo .eq. PERIODIC) then
        do k = ks,ke+1
          phi(is-1,js-1,k) = phi(ie,je,k)
          phi(is-1,je+2,k) = phi(ie,js+1,k)
          phi(ie+2,js-1,k) = phi(is+1,je,k)
          phi(ie+2,je+2,k) = phi(is+1,js+1,k)
        enddo
      endif

      if (bcx_lo .eq. PERIODIC .and. bcz_lo .eq. PERIODIC) then
        do j = js,je+1
          phi(is-1,j,ks-1) = phi(ie,j,ke)
          phi(is-1,j,ke+2) = phi(ie,j,ks+1)
          phi(ie+2,j,ks-1) = phi(is+1,j,ke)
          phi(ie+2,j,ke+2) = phi(is+1,j,ks+1)
        enddo
      endif

      if (bcy_lo .eq. PERIODIC .and. bcz_lo .eq. PERIODIC) then
        do i = is,ie+1
          phi(i,js-1,ks-1) = phi(i,je,ke)
          phi(i,js-1,ke+2) = phi(i,je,ks+1)
          phi(i,je+2,ks-1) = phi(i,js+1,ke)
          phi(i,je+2,ke+2) = phi(i,js+1,ks+1)
        enddo
      endif

      if (bcx_lo .eq. PERIODIC .and. bcy_lo .eq. PERIODIC 
     &     .and. bcz_lo .eq. PERIODIC) then
          phi(is-1,js-1,ks-1) = phi(ie  ,je  ,ke)
          phi(ie+2,js-1,ks-1) = phi(is+1,je  ,ke)
          phi(is-1,je+2,ks-1) = phi(ie  ,js+1,ke)
          phi(ie+2,je+2,ks-1) = phi(is+1,js+1,ke)
          phi(is-1,js-1,ke+2) = phi(ie  ,je  ,ks+1)
          phi(ie+2,js-1,ke+2) = phi(is+1,je  ,ks+1)
          phi(is-1,je+2,ke+2) = phi(ie  ,js+1,ks+1)
          phi(ie+2,je+2,ke+2) = phi(is+1,js+1,ks+1)
      endif

      facx = one / (hx*hx)
      facy = one / (hy*hy)
      facz = one / (hz*hz)

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

            dgphi(i,j,k) = 
     $         (coeff(i  ,j,k,1) * (phi(i+1,j,k) - phi(i,j,k)) +
     $          coeff(i-1,j,k,1) * (phi(i-1,j,k) - phi(i,j,k)) ) * facx +
     $         (coeff(i,j  ,k,2) * (phi(i,j+1,k) - phi(i,j,k)) +
     $          coeff(i,j-1,k,2) * (phi(i,j-1,k) - phi(i,j,k)) ) * facy +
     $         (coeff(i,j,k  ,3) * (phi(i,j,k+1) - phi(i,j,k)) +
     $          coeff(i,j,k-1,3) * (phi(i,j,k-1) - phi(i,j,k)) ) * facz
        enddo
      enddo
      enddo

      if (bcx_lo .eq. WALL .or. bcx_lo .eq. INLET) then
         do k = ks,ke+1 
         do j = js,je+1
            dgphi(is  ,j,k) = two * dgphi(is  ,j,k)
         enddo
         enddo
      else if (bcx_lo .eq. OUTLET) then
         do k = ks,ke+1 
         do j = js,je+1
            dgphi(is  ,j,k) = zero
         enddo
         enddo
      endif

      if (bcx_hi .eq. WALL .or. bcx_hi .eq. INLET) then
         do k = ks,ke+1 
         do j = js,je+1
            dgphi(ie+1,j,k) = two * dgphi(ie+1,j,k)
         enddo
         enddo
      else if (bcx_hi .eq. OUTLET) then
         do k = ks,ke+1 
         do j = js,je+1
            dgphi(ie+1,j,k) = zero
         enddo
         enddo
      endif

      if (bcy_lo .eq. WALL .or. bcy_lo .eq. INLET) then
         do k = ks,ke+1 
         do i = is,ie+1
            dgphi(i,js  ,k) = two * dgphi(i,js  ,k) 
         enddo
         enddo
      else if (bcy_lo .eq. OUTLET) then
         do k = ks,ke+1 
         do i = is,ie+1
            dgphi(i,js  ,k) = zero
         enddo
         enddo
      endif

      if (bcy_hi .eq. WALL .or. bcy_hi .eq. INLET) then
         do k = ks,ke+1 
         do i = is,ie+1
            dgphi(i,je+1,k) = two * dgphi(i,je+1,k) 
         enddo
         enddo
      else if (bcy_hi .eq. OUTLET) then
         do k = ks,ke+1 
         do i = is,ie+1
            dgphi(i,je+1,k) = zero
         enddo
         enddo
      endif

      if (bcz_lo .eq. WALL .or. bcz_lo .eq. INLET) then
         do j = js,je+1 
         do i = is,ie+1
            dgphi(i,j,ks  ) = two * dgphi(i,j,ks  ) 
         enddo
         enddo
      else if (bcz_lo .eq. OUTLET) then
         do j = js,je+1 
         do i = is,ie+1
            dgphi(i,j,ks  ) = zero
         enddo
         enddo
      endif

      if (bcz_hi .eq. WALL .or. bcz_hi .eq. INLET) then
         do j = js,je+1 
         do i = is,ie+1
            dgphi(i,j,ke+1) = two * dgphi(i,j,ke+1) 
         enddo
         enddo
      else if (bcz_hi .eq. OUTLET) then
         do j = js,je+1 
         do i = is,ie+1
            dgphi(i,j,ke+1) = zero
         enddo
         enddo
      endif

      return
      end

c *************************************************************************
c ** SOLVEHG **
c *************************************************************************

      subroutine FORT_SOLVEHG(dest,dest0,source,coeff,sum,r,w,z,work,
     $                        DIMS,hx,hy,hz,
     $                        bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi,
     $                        maxiter,norm,prob_norm)

      implicit none

      integer DIMS
      REAL_T   dest(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T  dest0(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T source(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T  coeff(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,3)
      REAL_T    sum(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T      r(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T      w(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T      z(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T   work(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      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 maxiter
      REAL_T norm
      REAL_T prob_norm
      REAL_T sum0

c     Local variables
      REAL_T  factor
      REAL_T  alpha
      REAL_T  beta
      REAL_T  rho
      REAL_T  rhol
      REAL_T  tol, tolfac
      REAL_T local_norm
      integer i,j,k
      integer iter
      integer istrt,iend
      integer jstrt,jend
      integer kstrt,kend

      tolfac = 1.0d-3

      istrt = cvmgt(lo_1+1,lo_1  ,BCX_LO .eq. OUTLET)
      iend  = cvmgt(hi_1  ,hi_1+1,BCX_HI .eq. OUTLET)
      jstrt = cvmgt(lo_2+1,lo_2  ,BCY_LO .eq. OUTLET)
      jend  = cvmgt(hi_2  ,hi_2+1,BCY_HI .eq. OUTLET)
      kstrt = cvmgt(lo_3+1,lo_3  ,BCZ_LO .eq. OUTLET)
      kend  = cvmgt(hi_3  ,hi_3+1,BCZ_HI .eq. OUTLET)

      do k = lo_3-1,hi_3+2
      do j = lo_2-1,hi_2+2
         do i = lo_1-1,hi_1+2
            dest0(i,j,k) = dest(i,j,k)
            dest(i,j,k) = zero
         enddo
      enddo
      enddo

  10  call makedgphi(dest0,w,coeff,DIMS,hx,hy,hz,
     $               bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

      rho = zero
      norm = zero

      do k = kstrt, kend 
      do j = jstrt, jend 
        do i = istrt, iend 
          r(i,j,k) = source(i,j,k) - w(i,j,k)
        enddo
      enddo
      enddo

      local_norm = zero
      do k = kstrt, kend 
      do j = jstrt, jend 
        do i = istrt, iend 
          factor = one
          factor = cvmgt(factor*half,factor,i.eq.lo_1 .or. i.eq.hi_1+1)
          factor = cvmgt(factor*half,factor,j.eq.lo_2 .or. j.eq.hi_2+1)
          factor = cvmgt(factor*half,factor,k.eq.lo_3 .or. k.eq.hi_3+1)
          local_norm  = max(local_norm, abs(r(i,j,k)))
          z(i,j,k) = r(i,j,k) / sum(i,j,k)
          rho    = rho + z(i,j,k) * r(i,j,k) * factor
          norm   = max(norm,abs(r(i,j,k)))
        enddo
      enddo
      enddo

      tol = Max(tolfac*local_norm,1.0d-15*prob_norm)
      if (norm .le. tol) return

      do k = kstrt, kend 
      do j = jstrt, jend 
        do i = istrt, iend 
          work(i,j,k) = zero
          dest(i,j,k) = z(i,j,k)
        enddo
      enddo
      enddo

      iter = 1
c     write(6,1000) iter, norm/prob_norm

100   continue  

      call makedgphi(dest,w,coeff,DIMS,hx,hy,hz,
     $               bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

      alpha = zero
      do k = kstrt, kend 
      do j = jstrt, jend 
        do i = istrt, iend 
          factor = one
          factor = cvmgt(factor*half,factor,i.eq.lo_1 .or. i.eq.hi_1+1)
          factor = cvmgt(factor*half,factor,j.eq.lo_2 .or. j.eq.hi_2+1)
          factor = cvmgt(factor*half,factor,k.eq.lo_3 .or. k.eq.hi_3+1)
          alpha  = alpha + dest(i,j,k)*w(i,j,k) * factor
        enddo
      enddo
      enddo

      alpha = rho / alpha
      rhol  = rho
      rho   = zero
      norm  = zero

      do k = kstrt, kend 
      do j = jstrt, jend 
        do i = istrt, iend 
          factor = one
          factor = cvmgt(factor*half,factor,i.eq.lo_1 .or. i.eq.hi_1+1)
          factor = cvmgt(factor*half,factor,j.eq.lo_2 .or. j.eq.hi_2+1)
          factor = cvmgt(factor*half,factor,k.eq.lo_3 .or. k.eq.hi_3+1)
          work(i,j,k) = work(i,j,k) + alpha * dest(i,j,k)
          r(i,j,k) = r(i,j,k) - alpha * w(i,j,k)
          z(i,j,k) = r(i,j,k) / sum(i,j,k)
          rho    = rho + z(i,j,k) * r(i,j,k) * factor
          norm   = max(norm,abs(r(i,j,k)))
        enddo
      enddo
      enddo

      iter = iter+1
c     write(6,1000) iter, norm/prob_norm

      if (norm .le. tol) then

        do k = kstrt, kend 
        do j = jstrt, jend 
          do i = istrt, iend 
            dest(i,j,k) = work(i,j,k) + dest0(i,j,k)
          enddo
        enddo
        enddo

      else if (iter .ge. maxiter  .or.  norm .ge. 100.d0*local_norm) then

        tolfac = 10.d0 * tolfac
        iter = 1
        do k = kstrt, kend 
        do j = jstrt, jend 
          do i = istrt, iend 
            dest(i,j,k) = zero
          enddo
        enddo
        enddo
        goto 10

      else

        beta = rho / rhol
        do k = kstrt, kend 
        do j = jstrt, jend 
          do i = istrt, iend 
            dest(i,j,k) = z(i,j,k) + beta * dest(i,j,k)
          enddo
        enddo
        enddo
        goto 100

      endif

1000  format('Res/Res0 in solve: ',i4,2x,e12.5)

      return
      end

c *************************************************************************
c ** MAKESUM **
c *************************************************************************

      subroutine FORT_MAKESUM(sum,coeff,DIMS,hx,hy,hz,
     $                        bcx_lo,bcx_hi,bcy_lo,bcy_hi,bcz_lo,bcz_hi)

      implicit none

      integer DIMS
      REAL_T    sum(lo_1-1:hi_1+2,lo_2-1:hi_2+2,lo_3-1:hi_3+2)
      REAL_T  coeff(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,3)
      REAL_T  hx
      REAL_T  hy
      REAL_T  hz
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      integer bcz_lo,bcz_hi

c     Local variables
      integer i, j, k
      integer is, ie, js, je, ks, ke
      integer istrt,iend
      integer jstrt,jend
      integer kstrt,kend
      REAL_T  facx, facy, facz

      facx = one/(hx*hx)
      facy = one/(hy*hy)
      facz = one/(hz*hz)

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

      istrt = cvmgt(lo_1+1,lo_1  ,BCX_LO .eq. OUTLET)
      iend  = cvmgt(hi_1  ,hi_1+1,BCX_HI .eq. OUTLET)

      jstrt = cvmgt(lo_2+1,lo_2  ,BCY_LO .eq. OUTLET)
      jend  = cvmgt(hi_2  ,hi_2+1,BCY_HI .eq. OUTLET)

      kstrt = cvmgt(lo_3+1,lo_3  ,BCZ_LO .eq. OUTLET)
      kend  = cvmgt(hi_3  ,hi_3+1,BCZ_HI .eq. OUTLET)

      do k = kstrt, kend 
      do j = jstrt, jend 
        do i = istrt, iend 
          sum(i,j,k) = - (
     $                (coeff(i,j,k,1) + coeff(i-1,j,k,1)) * facx +
     $                (coeff(i,j,k,2) + coeff(i,j-1,k,2)) * facy +
     $                (coeff(i,j,k,3) + coeff(i,j,k-1,3)) * facz )
        enddo
      enddo
      enddo

      if (bcx_lo .eq. WALL) then
        do k = kstrt, kend
        do j = jstrt, jend
          sum(is  ,j,k) = two * sum(is  ,j,k)
        enddo
        enddo
      endif
      if (bcx_hi .eq. WALL) then
        do k = kstrt, kend
        do j = jstrt, jend
          sum(ie+1,j,k) = two * sum(ie+1,j,k)
        enddo
        enddo
      endif

      if (bcy_lo .eq. WALL) then
        do k = kstrt, kend
        do i = istrt, iend 
          sum(i,js  ,k) = two * sum(i,js  ,k)
        enddo
        enddo
      endif
      if (bcy_hi .eq. WALL) then
        do k = kstrt, kend
        do i = istrt, iend 
          sum(i,je+1,k) = two * sum(i,je+1,k)
        enddo
        enddo
      endif

      if (bcz_lo .eq. WALL) then
        do j = jstrt, jend
        do i = istrt, iend 
          sum(i,j,ks  ) = two * sum(i,j,ks  )
        enddo
        enddo
      endif
      if (bcz_hi .eq. WALL) then
        do j = jstrt, jend
        do i = istrt, iend 
          sum(i,j,ke+1) = two * sum(i,j,ke+1)
        enddo
        enddo
      endif

      return
      end
