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

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

#define DIMS lo_1,lo_2,hi_1,hi_2
#define CDIMS loc_1,loc_2,hic_1,hic_2
#define GDIMS g_lo_1,g_lo_2,g_hi_1,g_hi_2
#define PDIMS p_lo_1,p_lo_2,p_hi_1,p_hi_2

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

      subroutine FORT_INITSIG(sigma,rho,r,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     r(lo_1-1:hi_1+1)
      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) = r(i) / rho(i,j)
        enddo
      enddo

      if (bcx_lo .eq. PERIODIC) then

        do j = lo_2-1,hi_2+1 
          sigma(lo_1-1,j) = sigma(hi_1,j)
          sigma(hi_1+1,j) = sigma(lo_1,j)
        enddo

      endif

      if (bcy_lo .eq. PERIODIC) then

        do i = lo_1-1,hi_1+1 
          sigma(i,lo_2-1) = sigma(i,hi_2)
          sigma(i,hi_2+1) = sigma(i,lo_2)
        enddo

      endif

      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,
     &                       bcx_lo, bcx_hi, bcy_lo, bcy_hi)

      implicit none

      integer DIMS
      integer p_lo_1, p_lo_2
      integer p_hi_1, p_hi_2
      integer g_lo_1, g_lo_2
      integer g_hi_1, g_hi_2
      REAL_T  gphi(g_lo_1:g_hi_1,g_lo_2:g_hi_2,2)
      REAL_T   phi(p_lo_1:p_hi_1,p_lo_2:p_hi_2  )
      REAL_T  hx
      REAL_T  hy
      integer bcx_lo, bcx_hi, bcy_lo, bcy_hi

c     Local variables
      integer i, j

      do j = lo_2,hi_2
        do i = lo_1,hi_1
          gphi(i,j,1) = half*(phi(i+1,j) + phi(i+1,j+1) - 
     $                        phi(i  ,j) - phi(i  ,j+1) ) /hx
          gphi(i,j,2) = half*(phi(i,j+1) + phi(i+1,j+1) - 
     $                        phi(i,j  ) - phi(i+1,j  ) ) /hy
        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 j = lo_2,hi_2
               gphi(lo_1-1,j,1) = gphi(hi_1,j,1)
               gphi(lo_1-1,j,2) = gphi(hi_1,j,2)
            enddo
         endif
         if (bcx_hi .eq. PERIODIC) then
            do j = lo_2,hi_2
               gphi(hi_1+1,j,1) = gphi(lo_1,j,1)
               gphi(hi_1+1,j,2) = gphi(lo_1,j,2)
            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 i = lo_1,hi_1
                gphi(i,lo_2-1,1) = gphi(i,hi_2,1)
                gphi(i,lo_2-1,2) = gphi(i,hi_2,2)
             enddo
          endif
          if (bcy_hi .eq. PERIODIC) then
             do i = lo_1,hi_1
                gphi(i,hi_2+1,1) = gphi(i,lo_2,1)
                gphi(i,hi_2+1,2) = gphi(i,lo_2,2)
             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.
     $   (bcx_lo .eq. PERIODIC .and. bcy_lo .eq. PERIODIC) ) then
          gphi(lo_1-1,lo_2-1,1) = gphi(hi_1,hi_2,1)
          gphi(lo_1-1,lo_2-1,2) = gphi(hi_1,hi_2,2)

          gphi(hi_1+1,lo_2-1,1) = gphi(lo_1,hi_2,1)
          gphi(hi_1+1,lo_2-1,2) = gphi(lo_1,hi_2,2)

          gphi(lo_1-1,hi_2+1,1) = gphi(hi_1,lo_2,1)
          gphi(lo_1-1,hi_2+1,2) = gphi(hi_1,lo_2,2)

          gphi(hi_1+1,hi_2+1,1) = gphi(lo_1,lo_2,1)
          gphi(hi_1+1,hi_2+1,2) = gphi(lo_1,lo_2,2)
      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,r,DIMS,hx,hy,
     $                      bcx_lo,bcx_hi,bcy_lo,bcy_hi,norm,time,dt)

      implicit none

      integer lo_1, lo_2
      integer hi_1, hi_2
      REAL_T        du(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T  divu_src(lo_1  :hi_1+1,lo_2  :hi_2+1)
      REAL_T         r(lo_1-1:hi_1+1)
      REAL_T         u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,2)
      REAL_T  hx
      REAL_T  hy
      REAL_T  time
      REAL_T  dt
      integer bcx_lo, bcx_hi
      integer bcy_lo, bcy_hi

c     Local variables
      REAL_T  fac,norm
      REAL_T  rnode
      REAL_T  factor
      REAL_T  sum_src, sum_fac
      integer i, j, n
      integer is,ie,js,je
      integer istart,iend
      integer jstart,jend
      logical is_singular

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

      norm = zero

      istart = cvmgt(lo_1+1,lo_1  ,bcx_lo .eq. OUTLET)
      iend   = cvmgt(hi_1  ,hi_1+1,bcx_hi .eq. OUTLET)
      jstart = cvmgt(lo_2+1,lo_2  ,bcy_lo .eq. OUTLET)
      jend   = cvmgt(hi_2  ,hi_2+1,bcy_hi .eq. OUTLET)

      if (bcx_lo .eq. PERIODIC) then
        do n = 1,2
        do j = js-1,je+1
          u(is-1,j,n) = u(ie,j,n)
          u(ie+1,j,n) = u(is,j,n)
        enddo
        enddo
      endif

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

      is_singular = .true.
      if (bcx_lo .eq. OUTLET .or. bcy_lo .eq. OUTLET .or.
     $    bcx_hi .eq. OUTLET .or. bcy_hi .eq. OUTLET) is_singular = .false.

      fac = one/twelve*(one/(hx*hx) + one/(hy*hy))

      do j = jstart,jend 
        do i = istart,iend 
            du(i,j) = (r(i  )*(u(i  ,j-1,1) +      u(i  ,j,1)) - 
     $                 r(i-1)*(u(i-1,j-1,1) +      u(i-1,j,1))) / (two*hx) + 
     $               ((r(i-1)* u(i-1,j  ,2) + r(i)*u(i,j  ,2)) -
     $                (r(i-1)* u(i-1,j-1,2) + r(i)*u(i,j-1,2))) / (two*hy)
        enddo
      enddo

      if (bcx_lo .eq. WALL) then
          i = is
          do j = jstart,jend 
            du(i,j) = r(i)*( (u(i,j-1,1) + u(i,j  ,1))/ (two*hx)
     $                      +(u(i,j  ,2) - u(i,j-1,2))/ (two*hy) )
          enddo
      endif

      if (bcx_hi .eq. WALL) then
          i = ie+1
          do j = jstart,jend 
            du(i,j) = r(i-1)*(-(u(i-1,j-1,1) + u(i-1,j,1))/ (two*hx)
     $                        +(u(i-1,j,2) - u(i-1,j-1,2))/ (two*hy) )
          enddo
      endif

      if (bcy_lo .eq. WALL) then
          j = js
          do i = is,iend 
            du(i,j) = ( (r(i  )*u(i  ,j,1) - r(i-1)*u(i-1,j,1))/ (two*hx) 
     $                 +(r(i-1)*u(i-1,j,2) + r(i  )*u(i  ,j,2))/ (two*hy) )
          enddo
      endif

      if (bcy_hi .eq. WALL) then
          j = je+1
          do i = is,iend 
            du(i,j) = ( (r(i  )*u(i  ,j-1,1) - r(i-1)*u(i-1,j-1,1))/ (two*hx)
     $                 -(r(i-1)*u(i-1,j-1,2) + r(i  )*u(i  ,j-1,2))/ (two*hy) )
          enddo
      endif

      if (bcx_lo .eq. WALL  .and.  bcy_lo .eq. WALL) then
          i = is
          j = js
          du(i,j) = r(i)*(u(i,j,1)/(two*hx) + u(i,j,2)/(two*hy))
      endif

      if (bcx_hi .eq. WALL  .and.  bcy_lo .eq. WALL) then
          i = ie+1
          j = js
          du(i,j) = r(i-1)*(-u(i-1,j,1)/(two*hx) + u(i-1,j,2)/(two*hy))
      endif

      if (bcx_lo .eq. WALL  .and.  bcy_hi .eq. WALL) then
          i = is
          j = je+1
          du(i,j) = r(i)*(u(i,j-1,1)/(two*hx) - u(i,j-1,2)/(two*hy))
      endif

      if (bcx_hi .eq. WALL  .and.  bcy_hi .eq. WALL) then
          i = ie+1
          j = je+1
          du(i,j) = -r(i-1)*(u(i-1,j-1,1)/(two*hx) + u(i-1,j-1,2)/(two*hy))
      endif

      if (bcx_lo .eq. WALL .or. bcx_lo .eq. INLET) then
          do j = jstart,jend 
            du(is,j) = two*du(is,j)
          enddo
      endif

      if (bcx_hi .eq. WALL .or. bcx_hi .eq. INLET) then
          do j = jstart,jend 
            du(ie+1,j) = two*du(ie+1,j)
          enddo
      endif

      if (bcy_lo .eq. WALL .or. bcy_lo .eq. INLET) then
          do i = istart,iend 
            du(i,js) = two*du(i,js)
          enddo
      endif

      if (bcy_hi .eq. WALL .or. bcy_hi .eq. INLET) then
          do i = istart,iend 
            du(i,je+1) = two*du(i,je+1)
          enddo
      endif

      do j = jstart,jend 
         do i = istart,iend 
           rnode = half * (r(i) + r(i-1))
           du(i,j) = du(i,j) - rnode * divu_src(i,j)
         enddo
      enddo

      if (is_singular) then
         sum_src  = zero
         sum_fac  = zero
         do j = jstart, jend
         do i = istart, 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)
           sum_src = sum_src + factor * du(i,j)
           sum_fac = sum_fac + factor
         enddo
         enddo

         sum_src = sum_src / sum_fac
 
c        write(6,999) sum_src
 
         do j = jstart, jend
         do i = istart, iend
           du(i,j) = du(i,j) - sum_src
         enddo
         enddo
      endif

      do j = jstart,jend 
        do i = istart,iend 
          norm = max(norm, abs(du(i,j)))
        enddo
      enddo
 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 lo_1, lo_2
      integer hi_1, hi_2
      REAL_T         u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,2)
      REAL_T  pressure(lo_1  :hi_1+1,lo_2  :hi_2+1)
      REAL_T       phi(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T   gradphi(lo_1-1:hi_1+1,lo_2-1:hi_2+1,2)
      REAL_T    rhonph(lo_1-1:hi_1+1,lo_2-1:hi_2+1)

c     Local variables
      integer i, j

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


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

      return
      end

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

      subroutine FORT_RESIDUAL(residual,phi,source,sigma,dgphi,
     $                         DIMS,hx,hy,resnorm,bcx_lo,bcx_hi,bcy_lo,bcy_hi)

      implicit none

      integer lo_1, lo_2
      integer hi_1, hi_2
      REAL_T  residual(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T       phi(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T    source(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T       sigma(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T     dgphi(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T  hx
      REAL_T  hy
      REAL_T  resnorm
      integer bcx_lo, bcx_hi
      integer bcy_lo, bcy_hi

c     Local variables
      integer i,j
      integer istart,iend
      integer jstart,jend

      resnorm = zero

      istart = cvmgt(lo_1+1,lo_1  ,bcx_lo .eq. OUTLET)
      iend   = cvmgt(hi_1  ,hi_1+1,bcx_hi .eq. OUTLET)
      jstart = cvmgt(lo_2+1,lo_2  ,bcy_lo .eq. OUTLET)
      jend   = cvmgt(hi_2  ,hi_2+1,bcy_hi .eq. OUTLET)
       
      call makedgphi(phi,dgphi,sigma,DIMS,hx,hy,bcx_lo,bcx_hi,bcy_lo,bcy_hi)

      do j = jstart,jend
        do i = istart,iend
          residual(i,j) = source(i,j) - dgphi(i,j)
        enddo
      enddo

      do j = jstart,jend 
        do i = istart,iend 
          resnorm = max(resnorm,abs(residual(i,j)))
        enddo
      enddo

      return
      end

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

      subroutine FORT_RELAX(phi,source,sigma,dgphi,DIMS,hx,hy,
     $                      bcx_lo,bcx_hi,bcy_lo,bcy_hi,nnrelax)

      implicit none

      integer lo_1, lo_2
      integer hi_1, hi_2
      REAL_T     phi(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T  source(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T   sigma(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T   dgphi(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T hx
      REAL_T hy
      integer bcx_lo, bcx_hi
      integer bcy_lo, bcy_hi
      integer nnrelax

c     Local variables
      REAL_T  hxsqinv,hysqinv
      REAL_T  rfac
      integer i,j
      integer iter
      integer is,ie,js,je
      integer istart,iend
      integer jstart,jend

c     Additional temporaries for the line solve
      REAL_T a_ls(0:4096)
      REAL_T b_ls(0:4096)
      REAL_T c_ls(0:4096)
      REAL_T r_ls(0:4096)
      REAL_T u_ls(0:4096)

      integer do_line
      integer ilen,jlen

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

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

      istart = cvmgt(lo_1+1,lo_1  ,bcx_lo .eq. OUTLET)
      iend   = cvmgt(hi_1  ,hi_1+1,bcx_hi .eq. OUTLET)
      jstart = cvmgt(lo_2+1,lo_2  ,bcy_lo .eq. OUTLET)
      jend   = cvmgt(hi_2  ,hi_2+1,bcy_hi .eq. OUTLET)

      if (hy. gt. 1.5*hx) then
         do_line = 1
         ilen = iend - istart + 1
         if (ilen .gt. 4096) then
           print *,'TOO BIG FOR LINE SOLVE IN GSRB: ilen = ',ilen
           stop
         endif
       elseif (hx .gt. 1.5*hy) then
         do_line = 2
         jlen = jend - jstart + 1
         if (jlen .gt. 4096) then
           print *,'TOO BIG FOR LINE SOLVE IN GSRB: jlen = ',jlen
           stop
         endif
       else
         do_line = 0
       endif

      do iter = 1, nnrelax 

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

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

          call makedgphi(phi,dgphi,sigma,DIMS,hx,hy,bcx_lo,bcx_hi,bcy_lo,bcy_hi)

          if (do_line .eq. 0) then
            do j = jstart,jend
            do i = istart,iend
#if 0
              dgphi(i,j) = sixth * (
     $         hxsqinv * 
     $          (sigma(i-1,j-1) * (phi(i-1,j-1) - phi(i,j-1) + 
     $                       two * phi(i-1,j)) + 
     $           sigma(i-1,j  ) * (phi(i-1,j+1) - phi(i,j+1) + 
     $                       two * phi(i-1,j)) + 
     $           sigma(i  ,j-1) * (phi(i+1,j-1) - phi(i,j-1) + 
     $                       two * phi(i+1,j)) + 
     $           sigma(i  ,j  ) * (phi(i+1,j+1) - phi(i,j+1) + 
     $                       two * phi(i+1,j)) - 
     $           two*(sigma(i-1,j-1) + sigma(i-1,j) + 
     $                sigma(i  ,j-1) + sigma(i  ,j)) * phi(i,j)) + 
     $         hysqinv * 
     $          (sigma(i-1,j-1) * (phi(i-1,j-1) - phi(i-1,j) +   
     $                       two * phi(i  ,j-1)) + 
     $           sigma(i-1,j  ) * (phi(i-1,j+1) - phi(i-1,j) + 
     $                       two * phi(i  ,j+1)) + 
     $           sigma(i  ,j-1) * (phi(i+1,j-1) - phi(i+1,j) + 
     $                       two * phi(i  ,j-1)) + 
     $           sigma(i  ,j  ) * (phi(i+1,j+1) - phi(i+1,j) +
     $                       two * phi(i,j+1)) - 
     $           two*(sigma(i-1,j-1) + sigma(i-1,j) +
     $                sigma(i  ,j-1) + sigma(i  ,j)) * phi(i,j)) )
#endif


              rfac = (hxsqinv + hysqinv) * 
     $               (sigma(i-1,j-1) + sigma(i-1,j) + 
     $                sigma(i  ,j-1) + sigma(i  ,j))

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

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

              rfac = three/rfac

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

            enddo
            enddo

          else if (do_line .eq. 1) then

            do j = jstart,jend

            do i = istart,iend
              a_ls(i-istart) = third * hxsqinv * 
     $                      (sigma(i-1,j-1) + sigma(i-1,j)) 
     $                     - sixth * hysqinv * 
     $                      (sigma(i-1,j-1) + sigma(i-1,j)) 

              c_ls(i-istart) = third * hxsqinv * 
     $                      (sigma(i,j-1) + sigma(i,j)) 
     $                     - sixth * hysqinv * 
     $                      (sigma(i,j-1) + sigma(i,j)) 

              b_ls(i-istart) = -third * (hxsqinv + hysqinv) * 
     $                       (sigma(i-1,j-1) + sigma(i-1,j) + 
     $                        sigma(i  ,j-1) + sigma(i  ,j))

              dgphi(i,j) = sixth * (
     $         hxsqinv * 
     $          (sigma(i-1,j-1) * (phi(i-1,j-1) - phi(i,j-1) ) + 
     $           sigma(i-1,j  ) * (phi(i-1,j+1) - phi(i,j+1) ) + 
     $           sigma(i  ,j-1) * (phi(i+1,j-1) - phi(i,j-1) ) + 
     $           sigma(i  ,j  ) * (phi(i+1,j+1) - phi(i,j+1) ) ) + 
     $         hysqinv * 
     $          (sigma(i-1,j-1) * (phi(i-1,j-1)              +   
     $                       two * phi(i  ,j-1)) + 
     $           sigma(i-1,j  ) * (phi(i-1,j+1)              + 
     $                       two * phi(i  ,j+1)) + 
     $           sigma(i  ,j-1) * (phi(i+1,j-1)              + 
     $                       two * phi(i  ,j-1)) + 
     $           sigma(i  ,j  ) * (phi(i+1,j+1)              +
     $                       two * phi(i,j+1)) ) )

              if ( (i .eq. is   .and. (bcx_lo .eq. WALL .or. bcx_lo .eq. INLET)) .or. 
     $             (i .eq. ie+1 .and. (bcx_hi .eq. WALL .or. bcx_hi .eq. INLET)) ) then
                dgphi(i,j) = two*dgphi(i,j)
                a_ls(i-istart) = two*a_ls(i-istart)
                b_ls(i-istart) = two*b_ls(i-istart)
                c_ls(i-istart) = two*c_ls(i-istart)
              endif

              if ( (j .eq. js   .and. (bcy_lo .eq. WALL .or. bcy_lo .eq. INLET)) .or. 
     $             (j .eq. je+1 .and. (bcy_hi .eq. WALL .or. bcy_hi .eq. INLET)) ) then
                dgphi(i,j) = two*dgphi(i,j)
                a_ls(i-istart) = two*a_ls(i-istart)
                b_ls(i-istart) = two*b_ls(i-istart)
                c_ls(i-istart) = two*c_ls(i-istart)
              endif

              r_ls(i-istart) = source(i,j) - dgphi(i,j)

            enddo

            call tridiag(a_ls,b_ls,c_ls,r_ls,u_ls,ilen)

            do i = istart,iend
              phi(i,j) = u_ls(i-istart)
            enddo

            enddo
          else if (do_line .eq. 2) then

            do i = istart,iend

            do j = jstart,jend
              a_ls(j-jstart) = sixth * hxsqinv * (
     $                       -sigma(i-1,j-1) - sigma(i,j-1) )
     $                     + third * hysqinv * (
     $                        sigma(i-1,j-1) + sigma(i,j-1) )

              c_ls(j-jstart) = sixth * hxsqinv * (
     $                       -sigma(i-1,j) - sigma(i,j) )
     $                     + third * hysqinv * (
     $                        sigma(i-1,j) + sigma(i,j) )

              b_ls(j-jstart) = -third * (hxsqinv + hysqinv) * 
     $                       (sigma(i-1,j-1) + sigma(i-1,j) + 
     $                        sigma(i  ,j-1) + sigma(i  ,j))

              dgphi(i,j) = sixth * (
     $         hxsqinv * 
     $          (sigma(i-1,j-1) * (phi(i-1,j-1)              + 
     $                       two * phi(i-1,j)) +
     $           sigma(i-1,j  ) * (phi(i-1,j+1)              + 
     $                       two * phi(i-1,j)) + 
     $           sigma(i  ,j-1) * (phi(i+1,j-1)              + 
     $                       two * phi(i+1,j)) + 
     $           sigma(i  ,j  ) * (phi(i+1,j+1)              + 
     $                       two * phi(i+1,j)) ) + 
     $         hysqinv * 
     $          (sigma(i-1,j-1) * (phi(i-1,j-1) - phi(i-1,j) ) +   
     $           sigma(i-1,j  ) * (phi(i-1,j+1) - phi(i-1,j) ) + 
     $           sigma(i  ,j-1) * (phi(i+1,j-1) - phi(i+1,j) ) + 
     $           sigma(i  ,j  ) * (phi(i+1,j+1) - phi(i+1,j) ) ) )

              if ( (i .eq. is   .and. (bcx_lo .eq. WALL .or. bcx_lo .eq. INLET)) .or. 
     $             (i .eq. ie+1 .and. (bcx_hi .eq. WALL .or. bcx_hi .eq. INLET)) ) then
                dgphi(i,j) = two*dgphi(i,j)
                a_ls(j-jstart) = two*a_ls(j-jstart)
                b_ls(j-jstart) = two*b_ls(j-jstart)
                c_ls(j-jstart) = two*c_ls(j-jstart)
              endif

              if ( (j .eq. js   .and. (bcy_lo .eq. WALL .or. bcy_lo .eq. INLET)) .or. 
     $             (j .eq. je+1 .and. (bcy_hi .eq. WALL .or. bcy_hi .eq. INLET)) ) then
                dgphi(i,j) = two*dgphi(i,j)
                a_ls(j-jstart) = two*a_ls(j-jstart)
                b_ls(j-jstart) = two*b_ls(j-jstart)
                c_ls(j-jstart) = two*c_ls(j-jstart)
              endif

              r_ls(j-jstart) = source(i,j) - dgphi(i,j)

            enddo

            call tridiag(a_ls,b_ls,c_ls,r_ls,u_ls,jlen)

            do j = js,jend
              phi(i,j) = u_ls(j-jstart)
            enddo

            enddo

          endif

      enddo

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

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

      return
      end

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

      subroutine FORT_COARSIG(sigma,sigmac,DIMS,CDIMS,
     $                        bcx_lo,bcx_hi,bcy_lo,bcy_hi)

      implicit none

      integer lo_1, lo_2
      integer hi_1, hi_2
      integer loc_1, loc_2
      integer hic_1, hic_2
      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)
      integer bcx_lo, bcx_hi
      integer bcy_lo, bcy_hi

c     Local variables
      integer i ,j
      integer i2,j2

      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
          sigmac(i,j) = (sigma(i2  ,j2) + sigma(i2  ,j2+1)+ 
     $                   sigma(i2+1,j2) + sigma(i2+1,j2+1))*fourth
        enddo
      enddo

      if (bcx_lo .eq. PERIODIC) then

        do j = loc_2-1,hic_2+1 
          sigmac(loc_1-1,j) = sigmac(hic_1,j)
          sigmac(hic_1+1,j) = sigmac(loc_1,j)
        enddo

      endif

      if (bcy_lo .eq. PERIODIC) then

        do i = loc_1-1,hic_1+1 
          sigmac(i,loc_2-1) = sigmac(i,hic_2)
          sigmac(i,hic_2+1) = sigmac(i,loc_2)
        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)

      implicit none

      integer lo_1, lo_2
      integer hi_1, hi_2
      integer loc_1, loc_2
      integer hic_1, hic_2
      REAL_T   res(lo_1 -1:hi_1 +2,lo_2 -1:hi_2 +2)
      REAL_T  resc(loc_1-1:hic_1+2,loc_2-1:hic_2+2)
      integer bcx_lo, bcx_hi
      integer bcy_lo, bcy_hi

c     Local variables
      integer i,j,ii,jj
      integer istart,iend
      integer jstart,jend

      istart = cvmgt(loc_1+1,loc_1  ,bcx_lo .eq. OUTLET)
      iend   = cvmgt(hic_1  ,hic_1+1,bcx_hi .eq. OUTLET)
      jstart = cvmgt(loc_2+1,loc_2  ,bcy_lo .eq. OUTLET)
      jend   = cvmgt(hic_2  ,hic_2+1,bcy_hi .eq. OUTLET)

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

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

      do j = jstart,jend
        do i = istart,iend

          ii = 2*(i-loc_1)+lo_1
          jj = 2*(j-loc_2)+lo_2

          resc(i,j) = fourth*res(ii  ,jj) + 
     $               eighth*(res(ii+1,jj  ) + res(ii-1,jj  ) + 
     $                       res(ii  ,jj+1) + res(ii  ,jj-1) ) +
     $            sixteenth*(res(ii+1,jj+1) + res(ii+1,jj-1) + 
     $                       res(ii-1,jj+1) + res(ii-1,jj-1) )
        enddo
      enddo

      if (bcx_lo .eq. WALL .or. bcx_lo .eq. INLET) then
        i = loc_1
        ii = 2*(i-loc_1)+lo_1

        do j = jstart,jend
          jj = 2*(j-loc_2)+lo_2
          resc(i,j) = fourth*(res(ii,jj  ) + res(ii+1,jj  )) + 
     $                eighth*(res(ii,jj-1) + res(ii+1,jj-1)+
     $                        res(ii,jj+1) + res(ii+1,jj+1) )
        enddo
      endif

      if (bcy_lo .eq. WALL .or. bcy_lo .eq. INLET) then
        j = loc_2
        jj = 2*(j-loc_2)+lo_2

        do i = istart,iend
          ii = 2*(i-loc_1)+lo_1
          resc(i,j) = fourth*(res(ii  ,jj) + res(ii  ,jj+1)) + 
     $                eighth*(res(ii+1,jj) + res(ii+1,jj+1)+
     $                        res(ii-1,jj) + res(ii-1,jj+1) )
        enddo
      endif

      if (bcx_hi .eq. WALL .or. bcx_hi .eq. INLET) then
        i = hic_1+1
        ii = 2*(i-loc_1)+lo_1

        do j = jstart,jend
          jj = 2*(j-loc_2)+lo_2
          resc(i,j) = fourth*(res(ii,jj  ) + res(ii-1,jj  )) + 
     $                eighth*(res(ii,jj-1) + res(ii-1,jj-1)+
     $                        res(ii,jj+1) + res(ii-1,jj+1) )
        enddo
      endif

      if (bcy_hi .eq. WALL .or. bcy_hi .eq. INLET) then
        j = hic_2+1
        jj = 2*(j-loc_2)+lo_2

        do i = istart,iend
          ii = 2*(i-loc_1)+lo_1
          resc(i,j) = fourth*(res(ii  ,jj) + res(ii  ,jj-1)) + 
     $                eighth*(res(ii+1,jj) + res(ii+1,jj-1)+
     $                        res(ii-1,jj) + res(ii-1,jj-1) )
        enddo
      endif

      if ( (bcx_lo .eq. WALL .or. bcx_lo .eq. INLET) .and.
     $     (bcy_lo .eq. WALL .or. bcy_lo .eq. INLET) ) then
        i = loc_1
        j = loc_2
        ii = 2*(i-loc_1)+lo_1
        jj = 2*(j-loc_2)+lo_2
        resc(i,j) = fourth*(res(ii,jj  ) + res(ii+1,jj  ) +
     $                      res(ii,jj+1) + res(ii+1,jj+1) )
      endif
 
      if ( (bcx_hi .eq. WALL .or. bcx_hi .eq. INLET) .and.
     $     (bcy_hi .eq. WALL .or. bcy_hi .eq. INLET) ) then
        i = hic_1+1
        j = hic_2+1
        ii = 2*(i-loc_1)+lo_1
        jj = 2*(j-loc_2)+lo_2
        resc(i,j) = fourth*(res(ii,jj  ) + res(ii-1,jj  ) +
     $                      res(ii,jj-1) + res(ii-1,jj-1) )
      endif

      if ( (bcx_lo .eq. WALL .or. bcx_lo .eq. INLET) .and.
     $     (bcy_hi .eq. WALL .or. bcy_hi .eq. INLET) ) then
        i = loc_1
        j = hic_2+1
        ii = 2*(i-loc_1)+lo_1
        jj = 2*(j-loc_2)+lo_2
        resc(i,j) = fourth*(res(ii,jj  ) + res(ii+1,jj  ) +
     $                      res(ii,jj-1) + res(ii+1,jj-1) )
      endif

      if ( (bcx_hi .eq. WALL .or. bcx_hi .eq. INLET) .and.
     $     (bcy_lo .eq. WALL .or. bcy_lo .eq. INLET) ) then
        i = hic_1+1
        j = loc_2
        ii = 2*(i-loc_1)+lo_1
        jj = 2*(j-loc_2)+lo_2
        resc(i,j) = fourth*(res(ii,jj  ) + res(ii-1,jj  ) +
     $                      res(ii,jj+1) + res(ii-1,jj+1) )
      endif

      return
      end

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

      subroutine FORT_INTERP(phi,deltac,DIMS,CDIMS)

      implicit none

      integer lo_1, lo_2
      integer hi_1, hi_2
      integer loc_1, loc_2
      integer hic_1, hic_2
      REAL_T     phi(lo_1 -1:hi_1 +2,lo_2 -1:hi_2 +2)
      REAL_T  deltac(loc_1-1:hic_1+2,loc_2-1:hic_2+2)

c     Local variables
      integer i,j,ii,jj
      integer is,ie,js,je,isc,iec,jsc,jec

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

      isc = loc_1
      jsc = loc_2
      iec = hic_1
      jec = hic_2

      do j = jsc, jec+1 
        do i = isc, iec+1

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js

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

        enddo
      enddo

      do j = jsc, jec
        do i = isc, iec+1

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js

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

        enddo
      enddo

      do j = jsc, jec+1 
        do i = isc, iec

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js

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

        enddo
      enddo

      do j = jsc, jec 
        do i = isc, iec 

          ii = 2*(i-isc)+is
          jj = 2*(j-jsc)+js

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

      return
      end

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

      subroutine makedgphi(phi,dgphi,sigma,DIMS,hx,hy,
     $                     bcx_lo,bcx_hi,bcy_lo,bcy_hi)

      implicit none

      integer lo_1, lo_2
      integer hi_1, hi_2
      REAL_T    phi(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T  dgphi(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T  sigma(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T  hx
      REAL_T  hy
      integer bcx_lo, bcx_hi
      integer bcy_lo, bcy_hi

c     Local variables
      REAL_T hxsqinv
      REAL_T hysqinv
      integer is,ie,js,je
      integer i,j

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

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

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

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

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

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

            dgphi(i,j) = sixth * (hxsqinv * 
     $       (sigma(i-1,j-1) * (phi(i-1,j-1) - phi(i,j-1) + two * phi(i-1,j)) +
     $        sigma(i-1,j  ) * (phi(i-1,j+1) - phi(i,j+1) + two * phi(i-1,j)) +
     $        sigma(i  ,j-1) * (phi(i+1,j-1) - phi(i,j-1) + two * phi(i+1,j)) +
     $        sigma(i  ,j  ) * (phi(i+1,j+1) - phi(i,j+1) + two * phi(i+1,j)) -
     $           two*(sigma(i-1,j-1) + sigma(i-1,j) + 
     $                sigma(i  ,j-1) + sigma(i  ,j)) * phi(i,j)) +
     $                          hysqinv * 
     $       (sigma(i-1,j-1) * (phi(i-1,j-1) - phi(i-1,j) + two * phi(i,j-1)) +
     $        sigma(i-1,j  ) * (phi(i-1,j+1) - phi(i-1,j) + two * phi(i,j+1)) +
     $        sigma(i  ,j-1) * (phi(i+1,j-1) - phi(i+1,j) + two * phi(i,j-1)) +
     $        sigma(i  ,j  ) * (phi(i+1,j+1) - phi(i+1,j) + two * phi(i,j+1)) -
     $           two*(sigma(i-1,j-1) + sigma(i-1,j) + 
     $                sigma(i  ,j-1) + sigma(i  ,j)) *  phi(i,j)))
        enddo
      enddo

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

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

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

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

      return
      end

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

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

      implicit none

      integer lo_1, lo_2
      integer hi_1, hi_2
      REAL_T   dest(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T  dest0(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T source(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T  sigma(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T    sum(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T      r(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T      w(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T      z(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T   work(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T hx
      REAL_T hy
      integer bcx_lo, bcx_hi
      integer bcy_lo, bcy_hi
      integer maxiter
      REAL_T norm
      REAL_T prob_norm

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
      logical testx
      logical testy
      integer i,j,iter
      integer istart,iend
      integer jstart,jend

      tolfac = 1.0d-3

      istart = cvmgt(lo_1+1,lo_1  ,bcx_lo .eq. OUTLET)
      iend   = cvmgt(hi_1  ,hi_1+1,bcx_hi .eq. OUTLET)
      jstart = cvmgt(lo_2+1,lo_2  ,bcy_lo .eq. OUTLET)
      jend   = cvmgt(hi_2  ,hi_2+1,bcy_hi .eq. OUTLET)

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

  10  call makedgphi(dest0,w,sigma,DIMS,hx,hy,bcx_lo,bcx_hi,bcy_lo,bcy_hi)

      rho = zero
      norm = zero

      do j = jstart, jend 
        do i = istart, iend 
          r(i,j) = source(i,j) - w(i,j)
        enddo
      enddo

      local_norm = zero
      do j = jstart, jend 
        do i = istart, iend 
          factor = one
          testx  = (i .eq. lo_1 .or. i .eq. hi_1+1)
          testy  = (j .eq. lo_2 .or. j .eq. hi_2+1)
          factor = cvmgt(factor*half,factor,testx)
          factor = cvmgt(factor*half,factor,testy)
          local_norm  = max(local_norm, abs(r(i,j)))
          z(i,j) = r(i,j) 
          rho    = rho + z(i,j) * r(i,j) * factor
          norm   = max(norm,abs(r(i,j)))
        enddo
      enddo

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

      do j = jstart, jend 
        do i = istart, iend 
          work(i,j) = zero
          dest(i,j) = z(i,j)
        enddo
      enddo

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

100   continue  

      call makedgphi(dest,w,sigma,DIMS,hx,hy,bcx_lo,bcx_hi,bcy_lo,bcy_hi)

      alpha = zero
      do j = jstart, jend 
        do i = istart, iend 
          factor = one
          testx  = (i .eq. lo_1 .or. i .eq. hi_1+1)
          testy  = (j .eq. lo_2 .or. j .eq. hi_2+1)
          factor = cvmgt(factor*half,factor,testx)
          factor = cvmgt(factor*half,factor,testy)
          alpha  = alpha + dest(i,j)*w(i,j) * factor
        enddo
      enddo

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

      do j = jstart, jend 
        do i = istart, iend 
          factor = one
          testx  = (i .eq. lo_1 .or. i .eq. hi_1+1)
          testy  = (j .eq. lo_2 .or. j .eq. hi_2+1)
          factor = cvmgt(factor*half,factor,testx)
          factor = cvmgt(factor*half,factor,testy)
          work(i,j) = work(i,j) + alpha * dest(i,j)
          r(i,j) = r(i,j) - alpha * w(i,j)
          z(i,j) = r(i,j) 
          rho    = rho + z(i,j) * r(i,j) * factor
          norm   = max(norm,abs(r(i,j)))
        enddo
      enddo

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

      if (norm .le. tol) then
         
         do j = jstart, jend 
            do i = istart, iend 
               dest(i,j) = work(i,j) + dest0(i,j)
            enddo
         enddo
         
      else if (iter .ge. maxiter  .or.  norm .ge. 100.d0*local_norm) then

         tolfac = 10.d0 * tolfac
         iter = 1
         do j = jstart, jend 
            do i = istart, iend 
               dest(i,j) = zero
            enddo
         enddo
         goto 10

      else

        beta = rho / rhol
        do j = jstart, jend 
          do i = istart, iend 
            dest(i,j) = z(i,j) + beta * dest(i,j)
          enddo
        enddo
        goto 100

      endif

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

      return
      end

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

      subroutine FORT_MAKESUM(sigma,sum,DIMS,hx,hy,
     $                        bcx_lo,bcx_hi,bcy_lo,bcy_hi)

      implicit none

      integer lo_1, lo_2
      integer hi_1, hi_2
      REAL_T  sigma(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T    sum(lo_1-1:hi_1+2,lo_2-1:hi_2+2)
      REAL_T  hx
      REAL_T  hy
      integer bcx_lo, bcx_hi
      integer bcy_lo, bcy_hi

c     Local variables
      integer i, j
      integer is, ie, js, je
      integer istart,iend
      integer jstart,jend
      REAL_T  hxsqinv, hysqinv

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

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

      if (bcx_lo .eq. OUTLET) then
        istart = lo_1+1
      else
        istart = lo_1
      endif
      if (bcx_hi .eq. OUTLET) then
        iend = hi_1
      else
        iend = hi_1+1
      endif

      if (bcy_lo .eq. OUTLET) then
        jstart = lo_2+1
      else
        jstart = lo_2
      endif
      if (bcy_hi .eq. OUTLET) then
        jend = hi_2
      else
        jend = hi_2+1
      endif

      do j = jstart, jend 
        do i = istart, iend 

          sum(i,j) = third * (hxsqinv * 
     $      (sigma(i-1,j-1) + sigma(i-1,j) + sigma(i,j-1) + sigma(i,j)) + 
     $                        hysqinv * 
     $      (sigma(i-1,j-1) + sigma(i-1,j) + sigma(i ,j-1) + sigma(i,j)))
          sum(i,j) = -fourth*sum(i,j)

        enddo
      enddo

      if (bcx_lo .eq. WALL) then
        do j = jstart, jend
          sum(is  ,j) = two * sum(is  ,j)
        enddo
      endif

      if (bcx_hi .eq. WALL) then
        do j = jstart, jend
          sum(ie+1,j) = two * sum(ie+1,j)
        enddo
      endif

      if (bcy_lo .eq. WALL) then
        do i = istart, iend 
          sum(i,js  ) = two * sum(i,js  )
        enddo
      endif

      if (bcy_hi .eq. WALL) then
        do i = istart, iend 
          sum(i,je+1) = two * sum(i,je+1)
        enddo
      endif

      return
      end
