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

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, 
     $                  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)

      if (namlen .gt. maxlen) then
         write(6,*) 'probin file name too long'
         stop
      end if

      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
  
      write(6,*) ' '
      write(6,*) 'READING PROBIN_FILE ',probin(1:namlen)
      write(6,*) ' '

      read(untin,fortin)
      close(unit=untin)

      end

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

      subroutine FORT_INITDATA(u,v,w,scal,DIMS,dx,time,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T     u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     w(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numscal)
      REAL_T  dx(3)
      REAL_T  time

      if (prob_type .eq. 1) then

        call initspin(u,v,w,scal,dx,DIMS,numscal)

      else if (prob_type .eq. 2) then

        call initbubble(u,v,w,scal,dx,DIMS,numscal)

      else if (prob_type .eq. 3) then

        call initshear(u,v,w,scal,dx,DIMS,numscal)

      else if (prob_type .eq. 4) then

        call initchannel(u,v,w,scal,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(u,v,w,scal,dx,DIMS,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T     u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     w(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numscal)
      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-lo_1) + half)
        y = dx(2)*(float(j-lo_2) + half)
        z = dx(3)*(float(k-lo_3) + half)

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

        u(i,j,k) =  velfact*two*spy*cpy*spx**2
        v(i,j,k) = -velfact*two*spx*cpx*spy**2
        w(i,j,k) =  zero

        scal(i,j,k,1) = 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
        scal(i,j,k,n) = zero
      enddo
      enddo
      enddo
      enddo

      return
      end

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

      subroutine initbubble(u,v,w,scal,dx,DIMS,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T     u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     w(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numscal)
      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

        u(i,j,k) = zero
        v(i,j,k) = zero
        w(i,j,k) = zero

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

        scal(i,j,k,1) = one+(denblob-one)*(half+half*tanh(100.d0*(radblob-r)))
c       scal(i,j,k,1) = 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
        scal(i,j,k,n) = zero
      enddo
      enddo
      enddo
      enddo

      return
      end

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

      subroutine initshear(u,v,w,scal,dx,DIMS,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T     u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     w(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numscal)
      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-lo_1) + half)
        y = dx(2)*(float(j-lo_2) + half)
        z = dx(3)*(float(k-lo_3) + half)

        u(i,j,k) = tanh(30.d0*(fourth - abs(y-half)))
        v(i,j,k) = 0.05d0 * sin(two*Pi*x)
        w(i,j,k) = zero

        scal(i,j,k,1) = 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
        scal(i,j,k,n) = zero
      enddo
      enddo
      enddo
      enddo

      return
      end

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

      subroutine initchannel(u,v,w,scal,dx,DIMS,numscal)

      implicit none

#include "probdata.H"

      integer DIMS
      integer numscal
      REAL_T     u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     w(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,numscal)
      REAL_T  dx(3)

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

      if (numscal .lt. 2) then
        print *,"CHANNEL FLOW NEEDS MORE SCALARS"
        stop
      endif

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

        u(i,j,k) = in_xvel
        v(i,j,k) = in_yvel
        w(i,j,k) = in_zvel

      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-lo_1) + half)
        y = dx(2)*(float(j-lo_2) + half)
        z = dx(3)*(float(k-lo_3) + half)
        r = sqrt((x-xblob)**2 + (y-yblob)**2 + (z-zblob)**2)

        scal(i,j,k,1) = cvmgt(denblob,in_density,r .lt. radblob)
        scal(i,j,k,2) = 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
        scal(i,j,k,n) = zero
      enddo
      enddo
      enddo
      enddo

      return
      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-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1,5)
      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_SETCELLVELBC **
c ** set velocity bc for computation of derived variables
c *************************************************************************

      subroutine FORT_SETCELLVELBC(u,v,w,DIMS,bcx_lo,bcx_hi,bcy_lo,bcy_hi,
     $                             bcz_lo,bcz_hi,visc_coef,dx,time)
      
      implicit none

#include "probdata.H"      

      integer DIMS
      REAL_T     u(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T     w(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
      REAL_T visc_coef
      REAL_T dx(3)
      REAL_T time

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

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

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

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

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

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

      if (bcx_lo .eq. PERIODIC) then
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(is-1,j,k) = u(ie,j,k)
          v(is-1,j,k) = v(ie,j,k)
          w(is-1,j,k) = w(ie,j,k)
        enddo
        enddo
      elseif (bcx_lo .eq. OUTLET) then
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(is-1,j,k) = u(is,j,k)
          v(is-1,j,k) = v(is,j,k)
          w(is-1,j,k) = w(is,j,k)
        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) =  two*in_xvel - u(is,j,k)
          v(is-1,j,k) =  - v(is,j,k)
          w(is-1,j,k) =  - w(is,j,k)
        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) =  -u(is,j,k)
          v(is-1,j,k) =  three*v(is,j,k)-three*v(is+1,j,k)+v(is+2,j,k)
          w(is-1,j,k) =  three*w(is,j,k)-three*w(is+1,j,k)+w(is+2,j,k)
        enddo
        enddo
        if (visc_coef .gt. zero) then
           do k = ks-1,ke+1
           do j = js-1,je+1
              v(is-1,j,k) =  -v(is,j,k)
              w(is-1,j,k) =  -w(is,j,k)
           enddo
           enddo
        endif
      endif

      if (bcx_hi .eq. PERIODIC) then
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(ie+1,j,k) = u(is,j,k)
          v(ie+1,j,k) = v(is,j,k)
          w(ie+1,j,k) = w(is,j,k)
        enddo
        enddo
      elseif (bcx_hi .eq. OUTLET) then
        do k = ks-1,ke+1
        do j = js-1,je+1
          u(ie+1,j,k) = u(ie,j,k)
          v(ie+1,j,k) = v(ie,j,k)
          w(ie+1,j,k) = w(ie,j,k)
        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) = two *in_xvel - u(ie,j,k)
          v(ie+1,j,k) = - v(ie,j,k)
          w(ie+1,j,k) = - w(ie,j,k)
        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) = - u(ie,j,k)
          v(ie+1,j,k) =  three*v(ie,j,k)-three*v(ie-1,j,k)+v(ie-2,j,k)
          w(ie+1,j,k) =  three*w(ie,j,k)-three*w(ie-1,j,k)+w(ie-2,j,k)
        enddo
        enddo
        if (visc_coef .gt. zero) then
           do k = ks-1,ke+1
           do j = js-1,je+1
              v(ie+1,j,k) = - v(ie,j,k)
              w(ie+1,j,k) = - w(ie,j,k)
           enddo
           enddo
        endif
      endif

      return
      end


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

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

      implicit none

#include "probdata.H"

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

c     Local variables
      integer i,j,k

      if (idir .eq. 0) then

        if (is_hi .eq. 0) then
          do k = lo_3-1,hi_3+1 
          do j = lo_2-1,hi_2+1 
            u(lo_1-1,j,k) = in_xvel
          enddo
          enddo
        else
          do k = lo_3-1,hi_3+1 
          do j = lo_2-1,hi_2+1 
            u(hi_1+1,j,k) = in_xvel
          enddo
          enddo
        endif

      elseif (idir .eq. 1) then

        if (is_hi .eq. 0) then
          do k = lo_3-1,hi_3+1 
          do i = lo_1-1,hi_1+1 
            u(i,lo_2-1,k) = in_yvel
          enddo
          enddo
        else
          do k = lo_3-1,hi_3+1 
          do i = lo_1-1,hi_1+1 
            u(i,hi_2+1,k) = in_yvel
          enddo
          enddo
        endif

      elseif (idir .eq. 2) then

        if (is_hi .eq. 0) then
          do j = lo_2-1,hi_2+1 
          do i = lo_1-1,hi_1+1 
            u(i,j,lo_3-1) = in_zvel
          enddo
          enddo
        else
          do j = lo_2-1,hi_2+1 
          do i = lo_1-1,hi_1+1 
            u(i,j,hi_3+1) = 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,time,idir,is_hi,which_scal)

      implicit none

#include "probdata.H"

      integer DIMS
      REAL_T  s(lo_1-1:hi_1+1,lo_2-1:hi_2+1,lo_3-1:hi_3+1)
      REAL_T  time
      integer idir, is_hi
      integer which_scal

c     Local variables
      integer i,j,k
      REAL_T  inflow_val
    
      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 k = lo_3-1,hi_3+1 
          do j = lo_2-1,hi_2+1 
            s(lo_1-1,j,k) = inflow_val
          enddo
          enddo
        else
          do k = lo_3-1,hi_3+1 
          do j = lo_2-1,hi_2+1 
            s(hi_1+1,j,k) = inflow_val
          enddo
          enddo
        endif

      elseif (idir .eq. 1) then

        if (is_hi .eq. 0) then
          do k = lo_3-1,hi_3+1 
          do i = lo_1-1,hi_1+1 
            s(i,lo_2-1,k) = inflow_val
          enddo
          enddo
        else
          do k = lo_3-1,hi_3+1 
          do i = lo_1-1,hi_1+1 
            s(i,hi_2+1,k) = inflow_val
          enddo
          enddo
        endif

      elseif (idir .eq. 2) then

        if (is_hi .eq. 0) then
          do j = lo_2-1,hi_2+1 
          do i = lo_1-1,hi_1+1 
            s(i,j,lo_3-1) = inflow_val
          enddo
          enddo
        else
          do j = lo_2-1,hi_2+1 
          do i = lo_1-1,hi_1+1 
            s(i,j,hi_3+1) = inflow_val
          enddo
          enddo
        endif

      else

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

      endif

      return
      end
