/*
** (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,hi_1,hi_2
#define SDIMS slo_1,slo_2,shi_1,shi_2

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,numscal+BL_SPACEDIM)
      REAL_T  dx(2)
      REAL_T  time

      print *,' '

      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 initxypoiseuille(state,dx,DIMS,numscal)

      else if (prob_type .eq. 6) then

        call initrzpoiseuille(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,numscal+BL_SPACEDIM)
      REAL_T  dx(2)

c     Local variables
      REAL_T x, y
      REAL_T spx, spy, cpx, cpy
      integer i, j, n

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

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

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

        state(i,j,1) =  velfact*two*spy*cpy*spx**2
        state(i,j,2) = -velfact*two*spx*cpx*spy**2

        state(i,j,3) = one

      enddo
      enddo

      do n = 2, numscal
      do j = lo_2,hi_2
      do i = lo_1,hi_1
        x = dx(1)*(float(i) + half) - 0.5d0
        y = dx(2)*(float(j) + half) - 0.5d0
        state(i,j,2+n) = sqrt(x*x+y*y)
      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,numscal+BL_SPACEDIM)
      REAL_T  dx(2)

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

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

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

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

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

      enddo
      enddo

      do n = 2, numscal
      do j = lo_2,hi_2
      do i = lo_1,hi_1
        state(i,j,2+n) = zero
      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,numscal+BL_SPACEDIM)
      REAL_T  dx(2)

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

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

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

        state(i,j,1) = tanh(30.d0*(fourth - abs(y-half)))
        state(i,j,2) = 0.05d0 * sin(two*Pi*x)

        state(i,j,3) = one

      enddo
      enddo

      do n = 2, numscal
      do j = lo_2,hi_2
      do i = lo_1,hi_1
        x = dx(1)*(float(i) + half) - 0.5d0
        y = dx(2)*(float(j) + half) - 0.5d0
        state(i,j,2+n) = sqrt(x*x+y*y)
      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,numscal+BL_SPACEDIM)
      REAL_T  dx(2)

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

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

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

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

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

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

        state(i,j,3) = cvmgt(denblob,in_density,r .lt. radblob)
        state(i,j,4) = cvmgt(one    ,in_tracer ,r .lt. radblob)

      enddo
      enddo

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

      return
      end

c *************************************************************************
c ** INITXYPOISEUILLE **
c ** Initialize the Poiseuille (viscous flow in an x-y pipe) problem
c *************************************************************************

      subroutine initxypoiseuille(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,numscal+BL_SPACEDIM)
      REAL_T  dx(2)

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

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

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

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

      enddo
      enddo

      if (numscal .ge. 2) then
        do j = lo_2,hi_2
        do i = lo_1,hi_1
          x = dx(1)*(float(i) + half)
          y = dx(2)*(float(j) + half)
          r = sqrt((x-xblob)**2 + (y-yblob)**2)
          state(i,j,4) = cvmgt(one    ,in_tracer ,r .lt. radblob)
        enddo
        enddo
      endif

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

      return
      end

c *************************************************************************
c ** INITRZPOISEUILLE **
c ** Initialize the Poiseuille (viscous flow in an r-z pipe) problem
c *************************************************************************

      subroutine initrzpoiseuille(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,numscal+BL_SPACEDIM)
      REAL_T  dx(2)

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

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

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

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

      enddo
      enddo

      if (numscal .ge. 2) then
        do j = lo_2,hi_2
        do i = lo_1,hi_1
          x = dx(1)*(float(i) + half)
          y = dx(2)*(float(j) + half)
          r = sqrt((x-xblob)**2 + (y-yblob)**2)
          state(i,j,4) = cvmgt(one    ,in_tracer ,r .lt. radblob)
        enddo
        enddo
      endif

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

      return
      end

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

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

      implicit none

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

c     Local variables
      integer i, j

      do j = lo_2, hi_2 
      do i = lo_1, hi_1 
          derval(i,j) = fourth*(state(i+1,j+1,2)+state(i+1,j-1,2)- 
     $                          state(i-1,j+1,2)-state(i-1,j-1,2)) / dx(1) -
     $                  fourth*(state(i+1,j+1,1)+state(i-1,j+1,1)- 
     $                          state(i+1,j-1,1)-state(i-1,j-1,1)) / dx(2)
      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)
      REAL_T       dat(lo_1:hi_1  ,lo_2:hi_2  )

c     Local variables
      integer i, j

      do j = lo_2, hi_2
        do i = lo_1, hi_1
          dat(i,j) = (pressure(i,j  ) + pressure(i+1,j  ) +
     $                pressure(i,j+1) + pressure(i+1,j+1) ) * fourth
      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,2)
      integer bc(2,2)
      integer irz
      REAL_T visc_coef
      REAL_T dx(2)
      REAL_T time

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

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

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

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

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

      if (BCX_HI .eq. OUTLET) then
        do j = js-1,je+1
          u(ie+1,j,1) = u(ie,j,1)
          u(ie+1,j,2) = u(ie,j,2)
        enddo
      elseif (BCX_HI .eq. INLET) then
        do j = js-1,je+1
          u(ie+1,j,1) = two *in_xvel - u(ie,j,1)
          u(ie+1,j,2) = - u(ie,j,2)
        enddo
      elseif (BCX_HI .eq. WALL) then
        do j = js-1,je+1
          u(ie+1,j,1) = - u(ie,j,1)
          u(ie+1,j,2) =  three*u(ie,j,2)-three*u(ie-1,j,2)+u(ie-2,j,2)
        enddo
        if (visc_coef .gt. zero) then
           do j = js-1,je+1
              u(ie+1,j,2) = - u(ie,j,2)
           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)
      REAL_T time
      REAL_T dx(2)
      integer idir
      integer is_hi

c     Local variables
      integer i,j
      REAL_T x

      if (idir .eq. 0) then

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

      elseif (idir .eq. 1) then

        if (is_hi .eq. 0) then
          if (prob_type .eq. 5) then
            do i = lo_1-3,hi_1+3 
              x = (float(i)+half)*dx(1)
              u(i,lo_2-1) = one-(x-one)*(x-one)
              u(i,lo_2-2) = one-(x-one)*(x-one)
              u(i,lo_2-3) = one-(x-one)*(x-one)
            enddo
          elseif (prob_type .eq. 6) then
            do i = lo_1-3,hi_1+3 
              x = (float(i)+half)*dx(1)
              u(i,lo_2-1) = one-x*x
              u(i,lo_2-2) = one-x*x
              u(i,lo_2-3) = one-x*x
            enddo
          else
            do i = lo_1-3,hi_1+3 
              u(i,lo_2-1) = in_yvel
              u(i,lo_2-2) = in_yvel
              u(i,lo_2-3) = in_yvel
            enddo
          endif
        else
          do i = lo_1-3,hi_1+3 
            u(i,hi_2+1) = in_yvel
            u(i,lo_2-2) = in_yvel
            u(i,lo_2-3) = in_yvel
          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)
      REAL_T  time
      REAL_T  dx(2)
      integer idir
      integer is_hi
      integer which_scal

c     Local variables
      integer i,j
      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 j = slo_2,shi_2
            s(lo_1-ng,j) = inflow_val
          enddo
          enddo
        else 
          do ng=1,ngmax
          do j = slo_2,shi_2
            s(hi_1+ng,j) = inflow_val
          enddo
          enddo
        endif

      elseif (idir .eq. 1) then

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

      else

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

      endif

      return
      end
