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

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_density, in_tracer,
     $                  xblob, yblob, 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,*) ' '
c      call flush(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,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)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,numscal)
      REAL_T  dx(2)
      REAL_T  time

      print *,' '

      if (prob_type .eq. 1) then

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

      else if (prob_type .eq. 2) then

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

      else if (prob_type .eq. 3) then

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

      else if (prob_type .eq. 4) then

        call initchannel(u,v,scal,dx,DIMS,numscal)

      else if (prob_type .eq. 5) then

        call initxypoiseuille(u,v,scal,dx,DIMS,numscal)

      else if (prob_type .eq. 6) then

        call initrzpoiseuille(u,v,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,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)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,numscal)
      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)

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

        scal(i,j,1) = one

      enddo
      enddo

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

      return
      end

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

      subroutine initbubble(u,v,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)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,numscal)
      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

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

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

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

      enddo
      enddo

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

      return
      end

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

      subroutine initshear(u,v,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)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,numscal)
      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)

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

        scal(i,j,1) = 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
        scal(i,j,n) = sqrt(x*x+y*y)
c       scal(i,j,n) = zero
      enddo
      enddo
      enddo

      return
      end

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

      subroutine initchannel(u,v,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)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,numscal)
      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)

        u(i,j) = in_xvel
        v(i,j) = in_yvel

        scal(i,j,1) = cvmgt(denblob,in_density,r .lt. radblob)

      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)
          scal(i,j,2) = 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
        scal(i,j,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(u,v,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)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,numscal)
      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)

        u(i,j) = zero
        v(i,j) = (one-(x-one)*(x-one))
        scal(i,j,1) = 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)
          scal(i,j,2) = 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
        scal(i,j,n) = zero
      enddo
      enddo
      enddo

      return
      end

c *************************************************************************
c ** INITRZPOISEUILLE **
c ** Initialize the Poiseuille (viscous flow in a circular pipe) problem
c *************************************************************************

      subroutine initrzpoiseuille(u,v,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)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      REAL_T  scal(lo_1-1:hi_1+1,lo_2-1:hi_2+1,numscal)
      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)

        u(i,j) = zero
        v(i,j) = (one-x*x)
        scal(i,j,1) = 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)
          scal(i,j,2) = 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
        scal(i,j,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-1:hi_1+1,lo_2-1:hi_2+1,4)
      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,v,DIMS,bcx_lo,bcx_hi,bcy_lo,bcy_hi,
     &                               irz,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)
      REAL_T     v(lo_1-1:hi_1+1,lo_2-1:hi_2+1)
      integer bcx_lo,bcx_hi
      integer bcy_lo,bcy_hi
      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,ie
          v(i,js-1) = v(i,js)
          u(i,js-1) = u(i,js)
        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) = -u(i,js)
            v(i,js-1) = (one-(x-one)*(x-one))
          enddo
        elseif (prob_type .eq. 6) then
          do i = is-1,ie+1 
            x = (float(i)+half)*dx(1)
            u(i,js-1) = -u(i,js)
            v(i,js-1) = (one-x*x)
          enddo
        else 
          do i = is-1,ie+1
            v(i,js-1) =  two* in_yvel - v(i,js)
            u(i,js-1) =  -u(i,js)
          enddo
        endif
      elseif (bcy_lo .eq. WALL) then
        do i = is-1,ie+1
           v(i,js-1) =  -v(i,js)
           u(i,js-1) =  three*u(i,js) - three*u(i,js+1)+u(i,js+2)
        enddo
        if (visc_coef .gt. zero) then
           do i = is-1,ie+1
              u(i,js-1) =  -u(i,js)
           enddo
        endif
      elseif (bcy_lo .eq. PERIODIC) then
        do i = is,ie
          u(i,js-1) = u(i,je)
          v(i,js-1) = v(i,je)
        enddo
      endif

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

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

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

      return
      end

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

      subroutine velinflow(u,DIMS,time,dy,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)
      REAL_T time
      REAL_T dy
      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-1,hi_2+1 
            u(lo_1-1,j) = in_xvel
          enddo
        else
          do j = lo_2-1,hi_2+1 
            u(hi_1+1,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-1,hi_1+1 
              x = (float(i)+half)*dy
              u(i,lo_2-1) = (one-(x-one)*(x-one))
            enddo
          elseif (prob_type .eq. 6) then
            do i = lo_1-1,hi_1+1 
              x = (float(i)+half)*dy
              u(i,lo_2-1) = (one-x*x)
            enddo
          else 
            do i = lo_1-1,hi_1+1 
              u(i,lo_2-1) = in_yvel
            enddo
          endif
        else
          do i = lo_1-1,hi_1+1 
            u(i,hi_2+1) = 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,time,dy,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)
      REAL_T  time
      REAL_T  dy
      integer idir
      integer is_hi
      integer which_scal

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

      elseif (idir .eq. 1) then

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

      else

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

      endif

      return
      end
