/*
** (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 "GRID_F.H"
#include "BCTypes.H"

#define DIMS lo_1,lo_2,lo_3,hi_1,hi_2,hi_3
#define SDIMS slo_1,slo_2,slo_3,shi_1,shi_2,shi_3

c *************************************************************************
c ** PROBINIT **
c ** Read in the problem-dependent parameters for the FORTRAN common blocks
c *************************************************************************

      subroutine FORT_PROBINIT (name,namlen)
      integer namlen
      integer name(namlen)
      integer untin, i

#include "probdata.H"

      namelist /fortin/ prob_type, zero_dir,
     $                  in_xvel, in_yvel, in_zvel, in_density, in_tracer,
     $                  xblob, yblob, zblob, radblob, denblob, velfact

c      Build `probin' filename -- the name of file containing fortin namelist.
c
      integer maxlen
      parameter (maxlen=256)

      character probin*(maxlen)

      do i = 1, namlen
         probin(i:i) = char(name(i))
      end do

      untin = 9
      if (namlen .eq. 0) then
         open(untin,file='probin',form='formatted',status='old')
      else
         open(untin,file=probin(1:namlen),form='formatted',status='old')
      end if
  
      read(untin,fortin)
      close(unit=untin)

      end

c *************************************************************************
c ** INITDATA **
c ** Call the appropriate subroutine to initialize the data
c *************************************************************************

      subroutine FORT_INITDATA(state,DIMS,dx,time,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T state(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3,numscal+BL_SPACEDIM)
      REAL_T  dx(3)
      REAL_T  time

      if (prob_type .eq. 1) then

        call initspin(state,dx,DIMS,numscal)

      else if (prob_type .eq. 2) then

        call initbubble(state,dx,DIMS,numscal)

      else if (prob_type .eq. 3) then

        call initshear(state,dx,DIMS,numscal)

      else if (prob_type .eq. 4) then

        call initchannel(state,dx,DIMS,numscal)

      else if (prob_type .eq. 5) then

        call initpoiseuille(state,dx,DIMS,numscal)

      else if (prob_type .eq. 6) then

c       call initfile(state,dx,DIMS,numscal)

        call initplate(state,dx,DIMS,numscal)

      else 

        print *,'DONT KNOW THIS PROBLEM TYPE: ',prob_type
        stop
 
      endif

      return
      end

c *************************************************************************
c ** INITSPIN **
c ** Initialize the constant density flow-in-a-box problem
c *************************************************************************

      subroutine initspin(state,dx,DIMS,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T state(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3,numscal+BL_SPACEDIM)
      REAL_T  dx(3)

c     Local variables
      REAL_T x, y, z 
      REAL_T spx, spy, spz, cpx, cpy, cpz
      integer i, j, k, n

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

        x = dx(1)*(float(i) + half)
        y = dx(2)*(float(j) + half)
        z = dx(3)*(float(k) + half)

        spx = sin(0.5d0*x)
        cpx = cos(0.5d0*x)
        spy = sin(0.5d0*y)
        cpy = cos(0.5d0*y)
        spz = sin(0.5d0*z)
        cpz = cos(0.5d0*z)

        if (zero_dir .eq. 3) then
          state(i,j,k,1) =  velfact*two*spy*cpy*spx**2
          state(i,j,k,2) = -velfact*two*spx*cpx*spy**2
          state(i,j,k,3) =  zero
        else if (zero_dir .eq. 2) then
          state(i,j,k,3) =  velfact*two*spx*cpx*spz**2
          state(i,j,k,1) = -velfact*two*spz*cpz*spx**2
          state(i,j,k,2) =  zero
        else if (zero_dir .eq. 1) then
          state(i,j,k,2) =  velfact*two*spz*cpz*spy**2
          state(i,j,k,3) = -velfact*two*spy*cpy*spz**2
          state(i,j,k,1) =  zero
        endif

        state(i,j,k,4) = one

      enddo
      enddo
      enddo

      do n = 2, numscal
      do k = lo_3,hi_3
      do j = lo_2,hi_2
      do i = lo_1,hi_1
        state(i,j,k,3+n) = zero
      enddo
      enddo
      enddo
      enddo

      return
      end

c *************************************************************************
c ** INITBUBBLE **
c ** Initialize the bubble-drop in a box problem
c *************************************************************************

      subroutine initbubble(state,dx,DIMS,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T state(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3,numscal+BL_SPACEDIM)
      REAL_T  dx(3)

c     Local variables
      REAL_T x, y, z, r
      integer i, j, k, n

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

        state(i,j,k,1) = zero
        state(i,j,k,2) = zero
        state(i,j,k,3) = zero

        x = dx(1)*(float(i) + half)
        y = dx(2)*(float(j) + half)
        z = dx(3)*(float(k) + half)
        r = sqrt((x-xblob)**2 + (y-yblob)**2 + (z-zblob)**2)

        state(i,j,k,4) = one+(denblob-one)*(half+half*tanh(100.d0*(radblob-r)))
c       state(i,j,k,4) = cvmgt(denblob,one,r .lt. radblob)

      enddo
      enddo
      enddo

      do n = 2, numscal
      do k = lo_3,hi_3
      do j = lo_2,hi_2
      do i = lo_1,hi_1
        state(i,j,k,3+n) = zero
      enddo
      enddo
      enddo
      enddo

      return
      end

c *************************************************************************
c ** INITSHEAR **
c ** Initialize a constant density doubly-periodic shear problem
c *************************************************************************

      subroutine initshear(state,dx,DIMS,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T state(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3,numscal+BL_SPACEDIM)
      REAL_T  dx(3)

c     Local variables
      REAL_T x, y, z
      integer i, j, k, n

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

        x = dx(1)*(float(i) + half)
        y = dx(2)*(float(j) + half)
        z = dx(3)*(float(k) + half)

        if (zero_dir .eq. 3) then
          state(i,j,k,1) = tanh(30.d0*(fourth - abs(y-half)))
          state(i,j,k,2) = 0.05d0 * sin(two*Pi*x)
          state(i,j,k,3) = zero
        else if (zero_dir .eq. 2) then
          state(i,j,k,3) = tanh(30.d0*(fourth - abs(x-half)))
          state(i,j,k,1) = 0.05d0 * sin(two*Pi*z)
          state(i,j,k,2) = zero
        else if (zero_dir .eq. 1) then
          state(i,j,k,2) = tanh(30.d0*(fourth - abs(z-half)))
          state(i,j,k,3) = 0.05d0 * sin(two*Pi*y)
          state(i,j,k,1) = zero
        endif

        state(i,j,k,4) = one

      enddo
      enddo
      enddo

      do n = 2, numscal
      do k = lo_3,hi_3
      do j = lo_2,hi_2
      do i = lo_1,hi_1
        state(i,j,k,3+n) = zero
      enddo
      enddo
      enddo
      enddo

      return
      end

c *************************************************************************
c ** INITCHANNEL **
c ** Initialize the channel inflow problem
c *************************************************************************

      subroutine initchannel(state,dx,DIMS,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T state(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3,numscal+BL_SPACEDIM)
      REAL_T  dx(3)

c     Local variables
      REAL_T x, y, z, r
      integer i, j, k, n

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

c       state(i,j,k,1) = in_xvel
c       state(i,j,k,2) = in_yvel
c       state(i,j,k,3) = in_zvel

        state(i,j,k,1) = zero
        state(i,j,k,2) = zero
        state(i,j,k,3) = zero

      enddo
      enddo
      enddo

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

        x = dx(1)*(float(i) + half)
        y = dx(2)*(float(j) + half)
        z = dx(3)*(float(k) + half)
        r = sqrt((x-xblob)**2 + (y-yblob)**2 + (z-zblob)**2)

        state(i,j,k,4) = cvmgt(denblob,in_density,r .lt. radblob)
        if (numscal .ge. 2) 
     $    state(i,j,k,5) = cvmgt(one    ,in_tracer ,r .lt. radblob)

      enddo
      enddo
      enddo

      do n = 3, numscal
      do k = lo_3,hi_3
      do j = lo_2,hi_2
      do i = lo_1,hi_1
        state(i,j,k,3+n) = zero
      enddo
      enddo
      enddo
      enddo

      return
      end

c *************************************************************************
c ** INITPOISEUILLE **
c ** Initialize the Poiseuille flow problem.
c *************************************************************************

      subroutine initpoiseuille(state,dx,DIMS,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T state(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3,numscal+BL_SPACEDIM)
      REAL_T  dx(3)

c     Local variables
      REAL_T x, y, z, r
      integer i, j, k, n

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

        x = dx(1)*(float(i) + half)
        y = dx(2)*(float(j) + half)
        z = dx(3)*(float(k) + half)

        state(i,j,k,1) = zero
        state(i,j,k,2) = zero
        state(i,j,k,3) = one - (x-one)*(x-one)

c       state(i,j,k,1) = one - (y-one)*(y-one)
c       state(i,j,k,2) = zero
c       state(i,j,k,3) = zero

c       state(i,j,k,1) = zero
c       state(i,j,k,2) = one - (z-one)*(z-one)
c       state(i,j,k,3) = zero

      enddo
      enddo
      enddo

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

        x = dx(1)*(float(i) + half)
        y = dx(2)*(float(j) + half)
        z = dx(3)*(float(k) + half)
        r = sqrt((x-xblob)**2 + (y-yblob)**2 + (z-zblob)**2)

        state(i,j,k,4) = cvmgt(denblob,in_density,r .lt. radblob)
        if (numscal .ge. 2) 
     $    state(i,j,k,5) = cvmgt(one    ,in_tracer ,r .lt. radblob)

      enddo
      enddo
      enddo

      do n = 3, numscal
      do k = lo_3,hi_3
      do j = lo_2,hi_2
      do i = lo_1,hi_1
        state(i,j,k,3+n) = zero
      enddo
      enddo
      enddo
      enddo

      return
      end

c *************************************************************************
c ** INITFILE **
c ** Initialize the constant density flow-in-a-box problem
c *************************************************************************

      subroutine initfile(state,dx,DIMS,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T state(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3,numscal+BL_SPACEDIM)
      REAL_T  dx(3)

c     Local variables
      REAL_T x, y, z 
      REAL_T spx, spy, spz, cpx, cpy, cpz
      integer i, j, k, n
      integer ifile,jfile,kfile,ibc,jbc,kbc,id,jd
      REAL_T scalex,scaley,scalez
      REAL_T scratch(131,131)

      open(2,file='InitTurb',form='unformatted')
 
      rewind 2

      read(2)ifile,jfile,kfile
      read(2)scalex,scaley,scalez
      read(2)ibc,jbc,kbc

      write(*,*) " how did i get here"
      write(*,*)ifile,jfile,kfile
      write(*,*)scalex,scaley,scalez
      write(*,*)ibc,jbc,kbc

      write(*,*) lo_1,lo_2,lo_3
      write(*,*) hi_1,hi_2,hi_3

      do n = 1,3
      read(2)((scratch(id,jd),id=1,ifile),jd=1,jfile)
      do k = lo_3,hi_3

      read(2)((scratch(id,jd),id=1,ifile),jd=1,jfile)

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

      state(i,j,k,n) = scratch(i+1,j+1)

      enddo
      enddo
      enddo
      read(2)((scratch(id,jd),id=1,ifile),jd=1,jfile)
      read(2)((scratch(id,jd),id=1,ifile),jd=1,jfile)
      enddo

      do k = lo_3,hi_3
      do j = lo_2,hi_2
      do i = lo_1,hi_1
        state(i,j,k,4) = one
      enddo
      enddo
      enddo

      do n = 2, numscal
      do k = lo_3,hi_3
      do j = lo_2,hi_2
      do i = lo_1,hi_1
        state(i,j,k,3+n) = zero
      enddo
      enddo
      enddo
      enddo

      close(2)

      return
      end

      subroutine initplate(state,dx,DIMS,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T state(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3,numscal+BL_SPACEDIM)
      REAL_T  dx(3)

c     Local variables
      REAL_T x, y, z 
      REAL_T spx, spy, spz, cpx, cpy, cpz
      REAL_T holesp,holerad,root3,xloc,yloc,xcen,ycen
      REAL_T scale,mean
      integer icell,jcell,npts
      integer i, j, k, n

      holesp = .0048d0
      holerad = .0016d0
      root3 = sqrt(3.d0)
      
      mean = Pi*holerad**2/(0.5d0*root3*holesp**2)
      scale = 3.0 / mean
      do k = lo_3,hi_3
         do j = lo_2,hi_2
            do i = lo_1,hi_1
               
               x = dx(1)*(dfloat(i) + 0.5d0)
               y = dx(2)*(dfloat(j) + 0.5d0)
               z = dx(3)*(dfloat(k) + 0.5d0)
               
               
               if(y.ge.0.d0)then
                  jcell = int(y / (half*root3*holesp))
               else
                  jcell = -1-int(-y/(half*root3*holesp))
               endif
               yloc = y-dfloat(jcell)*half*root3*holesp
               x = x-y/root3
               if(x.ge.0.d0)then
                  icell = int(x / (holesp))
               else
                  icell = -1-int(-x/(holesp))
               endif
               
               xloc = x - holesp * dfloat(icell) + yloc/root3
               xcen =.75d0*holesp
               ycen =(root3*.25d0)*holesp
               if(((xloc-xcen)**2 + (yloc-ycen)**2).le. holerad**2)then
                  state(i,j,k,3) = scale*(1.d0 - mean)
               else
                  state(i,j,k,3) = scale*(0.d0 - mean)
               endif
c               state(i,j,k,1) = .10d0*sin(2.d0*Pi*y/.05)*
c     &              sin(2.d0*Pi*3.d0*z/.05)
c               state(i,j,k,2) = .10d0*sin(2.d0*Pi*2.d0*x/.05)*
c     &              sin(2.d0*Pi*4.d0*z/.05)
               state(i,j,k,1) = .03d0*sin(2.d0*Pi*10*y/.05)*
     &              sin(2.d0*Pi*7.d0*z/.05)
     &              + .07d0*sin(2.d0*Pi*7*(y-.0012)/.05)*
     &              sin(2.d0*Pi*9.d0*(z-.314)/.05)
               state(i,j,k,2) = .04d0*sin(2.d0*Pi*11.d0*x/.05)*
     &              sin(2.d0*Pi*13.d0*z/.05)
     &              + .06d0*sin(2.d0*Pi*8*(x-.1)/.05)*
     &              sin(2.d0*Pi*13.d0*(z-.378)/.05)
               state(i,j,k,4) = one
            enddo
         enddo
      enddo
      
      do n = 2, numscal
         do k = lo_3,hi_3
            do j = lo_2,hi_2
               do i = lo_1,hi_1
                  state(i,j,k,3+n) = zero
               enddo
            enddo
         enddo
      enddo
      
      end


c *************************************************************************
c ** DERVORT **
c ** Derive a cell-centered vorticity
c *************************************************************************

      subroutine FORT_DERVORT(state,derval,derlo_1,derlo_2,derlo_3,
     $                        derhi_1,derhi_2,derhi_3,DIMS,dx)

      implicit none

      integer DIMS
      integer derlo_1,derlo_2,derlo_3
      integer derhi_1,derhi_2,derhi_3
      REAL_T  state(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3,3)
      REAL_T  derval(derlo_1:derhi_1,derlo_2:derhi_2,derlo_3:derhi_3)
      REAL_T  dx(3)

c     Local variables
      integer i, j, k
      REAL_T derx, dery, derz

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

          derx = eighth*(state(i+1,j+1,k-1,3)+state(i-1,j+1,k-1,3)
     $                  +state(i+1,j+1,k+1,3)+state(i-1,j+1,k+1,3)
     $                  -state(i+1,j-1,k-1,3)-state(i-1,j-1,k-1,3)
     $                  -state(i+1,j-1,k+1,3)-state(i-1,j-1,k+1,3)) / dx(2) -
     $           eighth*(state(i+1,j+1,k+1,2)+state(i-1,j+1,k+1,2)
     $                  +state(i+1,j-1,k+1,2)+state(i-1,j-1,k+1,2)
     $                  -state(i+1,j+1,k-1,2)-state(i-1,j+1,k-1,2)
     $                  -state(i+1,j-1,k-1,2)-state(i-1,j-1,k-1,2)) / dx(3)

          dery = eighth*(state(i+1,j+1,k-1,3)+state(i+1,j-1,k-1,3)
     $                  +state(i+1,j+1,k+1,3)+state(i+1,j-1,k+1,3)
     $                  -state(i-1,j+1,k-1,3)-state(i-1,j-1,k-1,3)
     $                  -state(i-1,j+1,k+1,3)-state(i-1,j-1,k+1,3)) / dx(1) -
     $           eighth*(state(i+1,j+1,k+1,1)+state(i-1,j+1,k+1,1)
     $                  +state(i+1,j-1,k+1,1)+state(i-1,j-1,k+1,1)
     $                  -state(i+1,j+1,k-1,1)-state(i-1,j+1,k-1,1)
     $                  -state(i+1,j-1,k-1,1)-state(i-1,j-1,k-1,1)) / dx(3)

          derz = eighth*(state(i+1,j+1,k-1,2)+state(i+1,j-1,k-1,2)
     $                  +state(i+1,j+1,k+1,2)+state(i+1,j-1,k+1,2)
     $                  -state(i-1,j+1,k-1,2)-state(i-1,j-1,k-1,2)
     $                  -state(i-1,j+1,k+1,2)-state(i-1,j-1,k+1,2)) / dx(1) -
     $           eighth*(state(i+1,j+1,k-1,1)+state(i-1,j+1,k-1,1)
     $                  +state(i+1,j+1,k+1,1)+state(i-1,j+1,k+1,1)
     $                  -state(i+1,j-1,k-1,1)-state(i-1,j-1,k-1,1)
     $                  -state(i+1,j-1,k+1,1)-state(i-1,j-1,k+1,1)) / dx(2)

          derval(i,j,k) = sqrt(derx**2 + dery**2 + derz**2)

        enddo
       enddo
      enddo

      return
      end

c *************************************************************************
c ** DERAVGP **
c ** Average nodal pressure onto cell centers for plotting purposes
c *************************************************************************

      subroutine FORT_DERAVGP(pressure,dat,DIMS)

      implicit none

      integer DIMS
      REAL_T  pressure(lo_1:hi_1+1,lo_2:hi_2+1,lo_3:hi_3+1)
      REAL_T       dat(lo_1:hi_1  ,lo_2:hi_2  ,lo_3:hi_3)

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
          dat(i,j,k) = (pressure(i,j  ,k  ) + pressure(i+1,j  ,k  ) +
     $                  pressure(i,j+1,k  ) + pressure(i+1,j+1,k  ) +
     $                  pressure(i,j  ,k+1) + pressure(i+1,j  ,k+1) +
     $                  pressure(i,j+1,k+1) + pressure(i+1,j+1,k+1) ) * eighth
        enddo
       enddo
      enddo

      return
      end

c *************************************************************************
c ** FORT_SET_CELL_VELBC **
c ** set velocity bc for computation of derived variables
c *************************************************************************

      subroutine FORT_SET_CELL_VELBC(u,DIMS,bc,irz,visc_coef,dx,time)
      
      implicit none

#include "probdata.H"      

      integer DIMS
      REAL_T     u(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3,3)
      integer bc(2,3)
      integer irz
      REAL_T visc_coef
      REAL_T dx(2)
      REAL_T time

c     Local variables
      integer i, j, k, is, ie, js, je, ks, ke
      REAL_T x

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

      if (BCZ_LO .eq. OUTLET) then
        do j = js-1,je+1
        do i = is-1,ie+1
          u(i,j,ks-1,3) = u(i,j,ks,3)
          u(i,j,ks-1,2) = u(i,j,ks,2)
          u(i,j,ks-1,1) = u(i,j,ks,1)
        enddo
        enddo
      elseif (BCZ_LO .eq. INLET) then
        if (prob_type .eq. 5) then
          do j = js-1,je+1
          do i = is-1,ie+1
            x = (float(i)+half)*dx(1)
            u(i,j,ks-1,3) =  one - (x-one)*(x-one)
            u(i,j,ks-1,2) =  -u(i,j,ks,2)
            u(i,j,ks-1,1) =  -u(i,j,ks,1)
          enddo
          enddo
        else
          do j = js-1,je+1
          do i = is-1,ie+1
            u(i,j,ks-1,3) =  two* in_zvel - u(i,j,ks,3)
            u(i,j,ks-1,2) =  -u(i,j,ks,2)
            u(i,j,ks-1,1) =  -u(i,j,ks,1)
          enddo
          enddo
        endif
      elseif (BCZ_LO .eq. WALL) then
        do j = js-1,je+1
        do i = is-1,ie+1
           u(i,j,ks-1,3) =  -u(i,j,ks,3)
           u(i,j,ks-1,2) =  three*u(i,j,ks,2) - three*u(i,j,ks+1,2)+u(i,j,ks+2,2)
           u(i,j,ks-1,1) =  three*u(i,j,ks,1) - three*u(i,j,ks+1,1)+u(i,j,ks+2,1)
        enddo
        enddo
        if (visc_coef .gt. zero) then
           do j = js-1,je+1
           do i = is-1,ie+1
              u(i,j,ks-1,1) =  -u(i,j,ks,1)
              u(i,j,ks-1,2) =  -u(i,j,ks,2)
           enddo
           enddo
        endif
      endif

      if (BCZ_HI .eq. OUTLET) then
        do j = js-1,je+1
        do i = is-1,ie+1
          u(i,j,ke+1,3) = u(i,j,ke,3)
          u(i,j,ke+1,2) = u(i,j,ke,2)
          u(i,j,ke+1,1) = u(i,j,ke,1)
        enddo
        enddo
      elseif (BCZ_HI .eq. INLET) then 
        do j = js-1,je+1
        do i = is-1,ie+1
          u(i,j,ke+1,3) = two*in_zvel - u(i,j,ke,3)
          u(i,j,ke+1,2) = - u(i,j,ke,2)
          u(i,j,ke+1,1) = - u(i,j,ke,1)
        enddo
        enddo
      elseif (BCZ_HI .eq. WALL) then
        do j = js-1,je+1
        do i = is-1,ie+1
          u(i,j,ke+1,3) = -u(i,j,ke,3)
          u(i,j,ke+1,2) =  three*u(i,j,ke,2) - three*u(i,j,ke-1,2)+u(i,j,ke-2,2)
          u(i,j,ke+1,1) =  three*u(i,j,ke,1) - three*u(i,j,ke-1,1)+u(i,j,ke-2,1)
        enddo
        enddo
        if (visc_coef .gt. zero) then
           do j = js-1,je+1
           do i = is-1,ie+1
              u(i,j,ke+1,2) = -u(i,j,ke,2)
              u(i,j,ke+1,1) = -u(i,j,ke,1)
           enddo
           enddo
        endif
      endif

      if (BCY_LO .eq. OUTLET) then
        do k = ks-1,ke+1
        do i = is-1,ie+1
          u(i,js-1,k,3) = u(i,js,k,3)
          u(i,js-1,k,2) = u(i,js,k,2)
          u(i,js-1,k,1) = u(i,js,k,1)
        enddo
        enddo
      elseif (BCY_LO .eq. INLET) then
        do k = ks-1,ke+1
        do i = is-1,ie+1
          u(i,js-1,k,2) =  two* in_yvel - u(i,js,k,2)
          u(i,js-1,k,3) =  -u(i,js,k,3)
          u(i,js-1,k,1) =  -u(i,js,k,1)
        enddo
        enddo
      elseif (BCY_LO .eq. WALL) then
        do k = ks-1,ke+1
        do i = is-1,ie+1
           u(i,js-1,k,2) =  -u(i,js,k,2)
           u(i,js-1,k,1) =  three*u(i,js,k,1) - three*u(i,js+1,k,1)+u(i,js+2,k,1)
           u(i,js-1,k,3) =  three*u(i,js,k,3) - three*u(i,js+1,k,3)+u(i,js+2,k,3)
        enddo
        enddo
        if (visc_coef .gt. zero) then
           do k = ks-1,ke+1
           do i = is-1,ie+1
              u(i,js-1,k,1) =  -u(i,js,k,1)
              u(i,js-1,k,3) =  -u(i,js,k,3)
           enddo
           enddo
        endif
      endif

      if (BCY_HI .eq. OUTLET) then
        do k = ks-1,ke+1
        do i = is-1,ie+1
          u(i,je+1,k,3) = u(i,je,k,3)
          u(i,je+1,k,2) = u(i,je,k,2)
          u(i,je+1,k,1) = u(i,je,k,1)
        enddo
        enddo
      elseif (BCY_HI .eq. INLET) then 
        do k = ks-1,ke+1
        do i = is-1,ie+1
          u(i,je+1,k,2) = two*in_yvel - u(i,je,k,2)
          u(i,je+1,k,3) = - u(i,je,k,3)
          u(i,je+1,k,1) = - u(i,je,k,1)
        enddo
        enddo
      elseif (BCY_HI .eq. WALL) then
        do k = ks-1,ke+1
        do i = is-1,ie+1
          u(i,je+1,k,2) = -u(i,je,k,2)
          u(i,je+1,k,3) =  three*u(i,je,k,3) - three*u(i,je-1,k,3)+u(i,je-2,k,3)
          u(i,je+1,k,1) =  three*u(i,je,k,1) - three*u(i,je-1,k,1)+u(i,je-2,k,1)
        enddo
        enddo
        if (visc_coef .gt. zero) then
           do k = ks-1,ke+1
           do i = is-1,ie+1
              u(i,je+1,k,3) = -u(i,je,k,3)
              u(i,je+1,k,1) = -u(i,je,k,1)
           enddo
           enddo
        endif
      endif

      if (BCX_LO .eq. OUTLET) then
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(is-1,j,k,1) = u(is,j,k,1)
          u(is-1,j,k,2) = u(is,j,k,2)
          u(is-1,j,k,3) = u(is,j,k,3)
        enddo
        enddo
      elseif (BCX_LO .eq. INLET) then 
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(is-1,j,k,1) =  two*in_xvel - u(is,j,k,1)
          u(is-1,j,k,2) =  - u(is,j,k,2)
          u(is-1,j,k,3) =  - u(is,j,k,3)
        enddo
        enddo
      elseif (BCX_LO .eq. WALL) then
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(is-1,j,k,1) =  -u(is,j,k,1)
          u(is-1,j,k,2) =  three*u(is,j,k,2)-three*u(is+1,j,k,2)+u(is+2,j,k,2)
          u(is-1,j,k,3) =  three*u(is,j,k,3)-three*u(is+1,j,k,3)+u(is+2,j,k,3)
        enddo
        enddo
        if (visc_coef .gt. zero) then
           do k = ks-1,ke+1
           do j = js-1,je+1
              u(is-1,j,k,2) =  -u(is,j,k,2)
              u(is-1,j,k,3) =  -u(is,j,k,3)
           enddo
           enddo
        endif
      endif

      if (BCX_HI .eq. OUTLET) then
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(ie+1,j,k,1) = u(ie,j,k,1)
          u(ie+1,j,k,2) = u(ie,j,k,2)
          u(ie+1,j,k,3) = u(ie,j,k,3)
        enddo
        enddo
      elseif (BCX_HI .eq. INLET) then
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(ie+1,j,k,1) = two *in_xvel - u(ie,j,k,1)
          u(ie+1,j,k,2) = - u(ie,j,k,2)
          u(ie+1,j,k,3) = - u(ie,j,k,3)
        enddo
        enddo
      elseif (BCX_HI .eq. WALL) then
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(ie+1,j,k,1) = - u(ie,j,k,1)
          u(ie+1,j,k,2) =  three*u(ie,j,k,2)-three*u(ie-1,j,k,2)+u(ie-2,j,k,2)
          u(ie+1,j,k,3) =  three*u(ie,j,k,3)-three*u(ie-1,j,k,3)+u(ie-2,j,k,3)
        enddo
        enddo
        if (visc_coef .gt. zero) then
           do k = ks-1,ke+1
           do j = js-1,je+1
              u(ie+1,j,k,2) = - u(ie,j,k,2)
              u(ie+1,j,k,3) = - u(ie,j,k,3)
           enddo
           enddo
        endif
      endif

      return
      end

c *************************************************************************
c ** VELINFLOW **
c ** Impose the inflow boundary conditions on velocity
c *************************************************************************

      subroutine velinflow(u,DIMS,time,dx,idir,is_hi)

      implicit none

#include "probdata.H"

      integer DIMS
      REAL_T u(lo_1-3:hi_1+3,lo_2-3:hi_2+3,lo_3-3:hi_3+3)
      REAL_T time
      REAL_T dx(3)
      integer idir,is_hi

c     Local variables
      integer i,j,k
      REAL_T  x,y,z

      if (idir .eq. 0) then

        if (is_hi .eq. 0) then
          if (prob_type .eq. 5) then
            do k = lo_3-3,hi_3+3
            do j = lo_2-3,hi_2+3
              y = (float(j)+half)*dx(2)
              u(lo_1-1,j,k) = one - (y-one)*(y-one)
              u(lo_1-2,j,k) = one - (y-one)*(y-one)
              u(lo_1-3,j,k) = one - (y-one)*(y-one)
            enddo
            enddo
          else
            do k = lo_3-3,hi_3+3
            do j = lo_2-3,hi_2+3
              u(lo_1-1,j,k) = in_xvel
              u(lo_1-2,j,k) = in_xvel
              u(lo_1-3,j,k) = in_xvel
            enddo
            enddo
          endif
        else
          do k = lo_3-3,hi_3+3 
          do j = lo_2-3,hi_2+3
            u(hi_1+1,j,k) = in_xvel
            u(hi_1+2,j,k) = in_xvel
            u(hi_1+3,j,k) = in_xvel
          enddo
          enddo
        endif

      elseif (idir .eq. 1) then

        if (is_hi .eq. 0) then
          if (prob_type .eq. 5) then
            do k = lo_3-3,hi_3+3
            do i = lo_1-3,hi_1+3 
              z = (float(k)+half)*dx(3)
              u(i,lo_2-1,k) = one - (z-one)*(z-one)
              u(i,lo_2-2,k) = one - (z-one)*(z-one)
              u(i,lo_2-3,k) = one - (z-one)*(z-one)
            enddo
            enddo
          else
            do k = lo_3-3,hi_3+3
            do i = lo_1-3,hi_1+3 
              u(i,lo_2-1,k) = in_yvel
              u(i,lo_2-2,k) = in_yvel
              u(i,lo_2-3,k) = in_yvel
            enddo
            enddo
          endif
        else
          do k = lo_3-3,hi_3+3 
          do i = lo_1-3,hi_1+3
            u(i,hi_2+1,k) = in_yvel
            u(i,hi_2+2,k) = in_yvel
            u(i,hi_2+3,k) = in_yvel
          enddo
          enddo
        endif

      elseif (idir .eq. 2) then

        if (is_hi .eq. 0) then
          if (prob_type .eq. 5) then
            do j = lo_2-3,hi_2+3 
            do i = lo_1-3,hi_1+3 
              x = (float(i)+half)*dx(1)
              u(i,j,lo_3-1) = one - (x-one)*(x-one)
              u(i,j,lo_3-2) = one - (x-one)*(x-one)
              u(i,j,lo_3-3) = one - (x-one)*(x-one)
            enddo
            enddo
          else
            do j = lo_2-3,hi_2+3 
            do i = lo_1-3,hi_1+3 
              u(i,j,lo_3-1) = in_zvel
              u(i,j,lo_3-2) = in_zvel
              u(i,j,lo_3-3) = in_zvel
            enddo
            enddo
          endif
        else
          do j = lo_2-3,hi_2+3 
          do i = lo_1-3,hi_1+3 
            u(i,j,hi_3+1) = in_zvel
            u(i,j,hi_3+2) = in_zvel
            u(i,j,hi_3+3) = in_zvel
          enddo
          enddo
        endif

      else
        print *,'bogus idir in velinflow ',idir
        stop
      endif

      return
      end

c *************************************************************************
c ** SCALINFLOW **
c ** Impose the inflow boundary conditions on scalars
c *************************************************************************

      subroutine scalinflow(s,DIMS,SDIMS,time,dx,idir,is_hi,which_scal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer SDIMS
      REAL_T  s(slo_1:shi_1,slo_2:shi_2,slo_3:shi_3)
      REAL_T  time
      REAL_T  dx(3)
      integer idir, is_hi
      integer which_scal

c     Local variables
      integer i,j,k
      integer ng,ngmax
      REAL_T  inflow_val

      ngmax = lo_1-slo_1
    
      if (which_scal .eq. 0) then
        inflow_val = in_density
      elseif (which_scal .eq. 1) then
        inflow_val = in_tracer
      else
        print *,"STOP IN SCALINFLOW "
        print *," --  DONT HAVE VALUE FOR THIS VARIABLE "
        stop
      endif

      if (idir .eq. 0) then

        if (is_hi .eq. 0) then
          do ng = 1,ngmax
          do k = slo_3,shi_3
          do j = slo_2,shi_2
            s(lo_1-ng,j,k) = inflow_val
          enddo
          enddo
          enddo
        else
          do ng = 1,ngmax
          do k = slo_3,shi_3 
          do j = slo_2,shi_2 
            s(hi_1+ng,j,k) = inflow_val
          enddo
          enddo
          enddo
        endif

      elseif (idir .eq. 1) then

        if (is_hi .eq. 0) then
          do ng = 1,ngmax
          do k = slo_3,shi_3 
          do i = slo_1,shi_1 
            s(i,lo_2-ng,k) = inflow_val
          enddo
          enddo
          enddo
        else
          do ng = 1,ngmax
          do k = slo_3,shi_3 
          do i = slo_1,shi_1
            s(i,hi_2+ng,k) = inflow_val
          enddo
          enddo
          enddo
        endif

      elseif (idir .eq. 2) then

        if (is_hi .eq. 0) then
          do ng = 1,ngmax
          do j = slo_2,shi_2
          do i = slo_1,shi_1
            s(i,j,lo_3-ng) = inflow_val
          enddo
          enddo
          enddo
        else
          do ng = 1,ngmax
          do j = slo_2,shi_2 
          do i = slo_1,shi_1 
            s(i,j,hi_3+ng) = inflow_val
          enddo
          enddo
          enddo
        endif

      else

        print *,'bogus idir in scalinflow ',idir
        stop

      endif

      return
      end
