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

c
c $Id: PROB_3D.F,v 1.6 2003/01/22 23:11:05 lijewski Exp $
c

#undef  BL_LANG_CC
#ifndef BL_LANG_FORT
#define BL_LANG_FORT
#endif

#include "REAL.H"
#include "CONSTANTS.H"
#include "BC_TYPES.H"
#include "PROB_F.H"
#include "ArrayLim.H"
#include "integrator.fh"

#define SDIM 3


c ::: -----------------------------------------------------------
c ::: This routine is called at problem initialization time
c ::: and when restarting from a checkpoint file.
c ::: The purpose is (1) to specify the initial time value
c ::: (not all problems start at time=0.0) and (2) to read
c ::: problem specific data from a namelist or other input
c ::: files and possibly store them or derived information
c ::: in FORTRAN common blocks for later use.
c ::: 
c ::: INPUTS/OUTPUTS:
c ::: 
c ::: init      => TRUE if called at start of problem run
c :::              FALSE if called from restart
c ::: name      => name of "probin" file
c ::: namlen    => length of name
c ::: strttime <=  start problem with this time variable
c ::: 
c ::: -----------------------------------------------------------
c
      subroutine FORT_PROBINIT (init,name,namlen,problo,probhi)
      integer init,namlen
      integer name(namlen)
      REAL_T  problo(SDIM), probhi(SDIM)

      integer untin,i,j,k

#include "probdata.H"
#include "xxmeth.fh"

      namelist /fortin/ tol_int, dengrad, bubgrad,ecent,
     $                   xcloud,ycloud,zcloud,radius,pertmag,
     $                   denfact,shockpos,rmach,
     $                   gamamb,gamcld,difmag, iorder, smallr, smallp, small

      REAL_T rn
c
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

      pertmag = zero

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


c ::: define state of ambient gas
      rhoamb = one
      pamb = one/gamamb
      u1amb = zero
      u2amb = zero
      u3amb = zero
      eamb = pamb/((gamamb-one)*rhoamb)
c
c ::: define state of ambient but dense cloud
c
      rhocld = rhoamb*denfact
      pcld = pamb
      u1cld = u1amb
      u2cld = u2amb
      u3cld = u3amb
      ecld = pcld/((gamcld-one)*rhocld)
c
c ::: define state of shock
c
      ashk = sqrt(gamamb*pamb/rhoamb)
      u1shk = ashk*two*(rmach**2-one)/((gamamb+one)*rmach )
      u2shk = zero
      u3shk = zero
      rhoshk = rhoamb*((gamamb+one)*rmach**2)/((gamamb-one)*rmach**2 + two)
      pshk = pamb*(one + ( two*gamamb*(rmach**2 - one)) / (gamamb+one) )
      eshk = pshk / ((gamamb-one)*rhoshk)
     
      u1amb = u1amb - u1shk
      u1cld = u1cld - u1shk
      u1shk = zero
c
c ::: translate to conserved quantities
c
      eamb = rhoamb*(eamb + half*(u1amb**2 + u2amb**2 + u3amb**2))
      u1amb = rhoamb*u1amb
      u2amb = rhoamb*u2amb
      u3amb = rhoamb*u3amb

      eshk = rhoshk*(eshk + half*(u1shk**2 + u2shk**2 + u3shk**2))
      u1shk = rhoshk*u1shk
      u2shk = rhoshk*u2shk
      u3shk = rhoshk*u3shk

      ecld = rhocld*(ecld + half*(u1cld**2 + u2cld**2 + u3cld**2))
      u1cld = rhocld*u1cld
      u2cld = rhocld*u2cld
      u3cld = rhocld*u3cld

c
c  set random amplitudes
c
         if (pertmag .gt. zero) then

            do k = 4,8
               do j = 4,8
                  do i = 4,8
                     call blutilrand(rn)
                     ranampl(i,j,k) =  pertmag * two * (rn - half)
                     call blutilrand(rn)
                     ranphse(i,j,k) =   two * Pi * rn 
                  end do
               end do
            end do

         end if

      return
      end

c ::: -----------------------------------------------------------
c ::: This routine is called at problem setup time and is used
c ::: to initialize data on each grid.  
c ::: 
c ::: NOTE:  all arrays have one cell of ghost zones surrounding
c :::        the grid interior.  Values in these cells need not
c :::        be set here.
c ::: 
c ::: INPUTS/OUTPUTS:
c ::: 
c ::: level     => amr level of grid
c ::: time      => time at which to init data             
c ::: lo,hi     => index limits of grid interior (cell centered)
c ::: nstate    => number of state components.  You should know
c :::		   this already!
c ::: state     <=  Scalar array
c ::: delta     => cell size
c ::: xlo,xhi   => physical locations of lower left and upper
c :::              right hand corner of grid.  (does not include
c :::		   ghost region).
c ::: -----------------------------------------------------------
        subroutine FORT_INITDATA(level, time, lo, hi,
     $                           nstate, state, DIMS(state),
     $                           delta, xlo, xhi)

      integer    level, nstate
      integer    lo(SDIM),hi(SDIM)
      integer    DIMDEC(state)

      REAL_T     time, delta(SDIM)
      REAL_T     xlo(SDIM), xhi(SDIM)
      REAL_T     state(DIMV(state),nstate)

c     ::::: local variables
      REAL_T     pert, dist

#include "probdata.H"

c ::: local var
      integer i, j, k, ii, jj, kk, intsx, intsy, intsz
      integer iamp,jamp,kamp
      REAL_T  dx, dy, dz,  rsq
      REAL_T  xcen, ycen, zcen
      
      dx = delta(1)
      dy = delta(2)
      dz = delta(3)


      do k = lo(3), hi(3)   
       do j = lo(2), hi(2)     
         do i = lo(1), hi(1)   

              xcen = xlo(1) + dx*(float(i-lo(1)) + half)
              ycen = xlo(2) + dy*(float(j-lo(2)) + half)
              zcen = xlo(3) + dz*(float(k-lo(3)) + half)

              if (xcen .lt. shockpos) then
                  state(i,j,k,1) = rhoshk
                  state(i,j,k,2) = u1shk
                  state(i,j,k,3) = u2shk
                  state(i,j,k,4) = u3shk
                  state(i,j,k,5) = eshk
#if(NADV>0)
                  state(i,j,k,6) = zero
#endif
              else
                  rsq = (xcen-xcloud)**2+(ycen-ycloud)**2+
     1                  ((zcen-zcloud)**2)/ecent
                  dist = sqrt(rsq)
                  if (dist .le. radius) then
                      pert = one
                      do kamp = 4,8
                      do jamp = 4,8
                      do iamp = 4,8
 
                         pert = pert + ranampl(iamp,jamp,kamp)*
     &                        cos(ranphse(iamp,jamp,kamp)+two*Pi*kamp*(xcen-xcloud)/radius)*
     &                        cos(ranphse(iamp,jamp,kamp)+two*Pi*jamp*(ycen-ycloud)/radius)*
     &                        cos(ranphse(iamp,jamp,kamp)+two*Pi*iamp*(zcen-zcloud)/radius)

                      end do
                      end do
                      end do
                      state(i,j,k,1) = pert * rhocld
                      state(i,j,k,2) = pert * u1cld
                      state(i,j,k,3) = pert * u2cld
                      state(i,j,k,4) = pert * u3cld
                      state(i,j,k,5) = pert * ecld
#if(NADV>0)
                      state(i,j,k,6) = pert * rhocld
#endif
                  else
                      state(i,j,k,1) = rhoamb
                      state(i,j,k,2) = u1amb
                      state(i,j,k,3) = u2amb
                      state(i,j,k,4) = u3amb
                      state(i,j,k,5) = eamb
#if(NADV>0)
                      state(i,j,k,6) = zero
#endif
                  end if
              end if

         end do
       end do
      end do

      return
      end

c ::: -----------------------------------------------------------
c ::: This routine will tag high error cells based on the 
c ::: density gradient
c ::: 
c ::: INPUTS/OUTPUTS:
c ::: 
c ::: tag      <=  integer tag array
c ::: lo,hi     => index extent of tag array
c ::: set       => integer value to tag cell for refinement
c ::: clear     => integer value to untag cell
c ::: rho       => density array
c ::: ng        => number of ghost zones in rho array (should be 1)
c ::: nvar      => number of components in rho array (should be 1)
c ::: domlo,hi  => index extent of problem domain
c ::: delta     => cell spacing
c ::: xlo       => physical location of lower left hand
c :::	           corner of tag array
c ::: problo    => phys loc of lower left corner of prob domain
c ::: time      => problem evolution time
c ::: -----------------------------------------------------------
      subroutine FORT_DENERROR (tag,DIMS(tag),set,clear,
     &                          adv,DIMS(adv),lo,hi,nvar,
     &                          domlo,domhi,delta,xlo,
     &			        problo,time,level)

      integer   DIMDEC(tag)
      integer   DIMDEC(adv)
      integer   lo(SDIM), hi(SDIM)
      integer   nvar, set, clear, level
      integer   domlo(SDIM), domhi(SDIM)
      REAL_T    delta(SDIM), xlo(SDIM), problo(SDIM), time
      integer   tag(DIMV(tag))
      REAL_T    adv(DIMV(adv),nvar)
      REAL_T    x, y, z,ax, ay, az,aerr, denloc
      integer   i, j,k, leni, lenj, lenk
      REAL_T tracer
      logical ltest

#include "probdata.H"
#include "xxmeth.fh"

      leni = hi(1)-lo(1)
      lenj = hi(2)-lo(2)
      lenk = hi(3)-lo(3)
      
      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               ax = abs(adv(i+1,j,k,1) - adv(i-1,j,k,1))
               ay = abs(adv(i,j+1,k,1) - adv(i,j-1,k,1))
               az = abs(adv(i,j,k+1,1) - adv(i,j,k-1,1))
               aerr = max(ax,ay,az)
               denloc = min(adv(i,j,k,1),adv(i,j,k+1,1),adv(i,j,k-1,1))
               denloc = min(denloc,adv(i,j+1,k,1),adv(i,j-1,k,1))
               denloc = min(denloc,adv(i+1,j,k,1),adv(i-1,j,k,1))
               denloc = max(denloc,smallr)
               aerr = aerr / denloc
               tag(i,j,k) = cvmgt(set,tag(i,j,k),aerr.gt.dengrad)
            end do
         end do
      end do

      if (tol_int .gt. zero ) then
         do k = lo(3), hi(3)
            do j = lo(2), hi(2)
               do i = lo(1), hi(1)
                  tracer = adv(i,j,k,6)/adv(i,j,k,1)
                  ltest = (tracer.gt.tol_int) .and. (tracer.lt. (one-tol_int))
                  tag(i,j,k) = cvmgt(set,tag(i,j,k),ltest)
               end do
            end do
         end do
      end if

      end

c
c     Fill den, xmom, ymom, zden, eden as a group.
c
      subroutine FORT_HYPFILL (adv,DIMS(adv),domlo,domhi,delta,
     &                         xlo,time,bc)

      integer 	 DIMS(adv)
      integer    bc(SDIM,2,5)
      integer    domlo(SDIM), domhi(SDIM)
      REAL_T     delta(SDIM), xlo(SDIM), time
      REAL_T     adv(DIMV(adv),5)

      call FORT_DENFILL  (adv(ARG_L1(adv),ARG_L2(adv),ARG_L3(adv),1),
     & DIMS(adv),domlo,domhi,delta,xlo,time,bc(1,1,1))

      call FORT_XMOMFILL (adv(ARG_L1(adv),ARG_L2(adv),ARG_L3(adv),2),
     & DIMS(adv),domlo,domhi,delta,xlo,time,bc(1,1,2))

      call FORT_YMOMFILL (adv(ARG_L1(adv),ARG_L2(adv),ARG_L3(adv),3),
     & DIMS(adv),domlo,domhi,delta,xlo,time,bc(1,1,3))

      call FORT_ZMOMFILL (adv(ARG_L1(adv),ARG_L2(adv),ARG_L3(adv),4),
     & DIMS(adv),domlo,domhi,delta,xlo,time,bc(1,1,4))

      call FORT_EDENFILL (adv(ARG_L1(adv),ARG_L2(adv),ARG_L3(adv),5),
     & DIMS(adv),domlo,domhi,delta,xlo,time,bc(1,1,5))

      end

c ::: -----------------------------------------------------------
c ::: This routine is called during a filpatch operation when
c ::: the patch to be filled falls outside the interior
c ::: of the problem domain.  You are requested to supply the
c ::: data outside the problem interior in such a way that the
c ::: data is consistant with the types of the boundary conditions
c ::: you specified in the C++ code.  
c ::: 
c ::: NOTE:  you can assume all interior cells have been filled
c :::        with valid data.
c ::: 
c ::: INPUTS/OUTPUTS:
c ::: 
c ::: adv      <=  advected quantity array
c ::: lo,hi     => index extent of adv array
c ::: domlo,hi  => index extent of problem domain
c ::: delta     => cell spacing
c ::: xlo       => physical location of lower left hand
c :::	           corner of adv array
c ::: time      => problem evolution time
c ::: bc	=> array of boundary flags bc(SPACEDIM,lo:hi)
c ::: -----------------------------------------------------------

      subroutine FORT_DENFILL (adv,DIMS(adv),domlo,domhi,delta,
     &                         xlo,time,bc)

      integer 	 DIMS(adv)	
      integer    bc(SDIM,2)
      integer    domlo(SDIM), domhi(SDIM)
      REAL_T     delta(SDIM), xlo(SDIM), time
      REAL_T     adv(DIMV(adv))

      integer    i, j, k
      REAL_T     y,x
      integer    lo(SDIM),hi(SDIM)

#include "probdata.H"

      lo(1) = adv_l1
      lo(2) = adv_l2
      lo(3) = adv_l3
      hi(1) = adv_h1
      hi(2) = adv_h2
      hi(3) = adv_h3

      call filcc (adv,DIMS(adv),domlo,domhi,delta,xlo,bc)

      if (bc(1,1).eq.EXT_DIR.and.lo(1).lt.domlo(1)) then
         do i = lo(1), domlo(1)-1
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  adv(i,j,k) = rhoshk
               end do
            end do
         end do
      end if            

      if (bc(1,2).eq.EXT_DIR.and.hi(1).gt.domhi(1)) then
         do i = domhi(1)+1, hi(1)
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  adv(i,j,k) = rhoamb
               end do
            end do
	 end do
      end if            

      if (bc(2,1).eq.EXT_DIR.and.lo(2).lt.domlo(2)) then
         do j = lo(2), domlo(2)-1
            do i = lo(1), hi(1)
               do k = lo(3),hi(3)
                  adv(i,j,k) = adv(i,domlo(2),k)                     
               end do
            end do
	 end do
      end if            

      if (bc(2,2).eq.EXT_DIR.and.hi(2).gt.domhi(2)) then
         do j = domhi(2)+1, hi(2)
            do i = lo(1), hi(1)
               do k = lo(3),hi(3)
                  adv(i,j,k) = adv(i,domhi(2),k)                         
               end do
            end do
	 end do
      end if

      if (bc(3,1).eq.EXT_DIR.and.lo(3).lt.domlo(3)) then
         do k = lo(3), domlo(3)-1
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = adv(i,j,domlo(3))                     
               end do
            end do
	 end do
      end if            

      if (bc(3,2).eq.EXT_DIR.and.hi(3).gt.domhi(3)) then
         do k = domhi(3)+1, hi(3)
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = adv(i,j,domhi(3))                         
               end do
            end do
         end do
      end if          

      end

c ::: -----------------------------------------------------------
c ::: This routine is called during a filpatch operation when
c ::: the patch to be filled falls outside the interior
c ::: of the problem domain.  You are requested to supply the
c ::: data outside the problem interior in such a way that the
c ::: data is consistant with the types of the boundary conditions
c ::: you specified in the C++ code.  
c ::: 
c ::: NOTE:  you can assume all interior cells have been filled
c :::        with valid data.
c ::: 
c ::: INPUTS/OUTPUTS:
c ::: 
c ::: adv      <=  advected quantity array
c ::: lo,hi     => index extent of adv array
c ::: domlo,hi  => index extent of problem domain
c ::: delta     => cell spacing
c ::: xlo       => physical location of lower left hand
c :::	           corner of adv array
c ::: time      => problem evolution time
c ::: bc	=> array of boundary flags bc(SPACEDIM,lo:hi)
c ::: -----------------------------------------------------------

      subroutine FORT_XMOMFILL (adv,DIMS(adv),domlo,domhi,delta,
     &                          xlo,time,bc )

      integer    DIMS(adv)
      integer    bc(SDIM,2)
      integer    domlo(SDIM), domhi(SDIM)
      REAL_T     delta(SDIM), xlo(SDIM), time
      REAL_T     adv(DIMV(adv))

      integer    i, j,k
      REAL_T     y,x
      integer lo(SDIM),hi(SDIM)

       
#include "probdata.H"
      lo(1) = adv_l1
      lo(2) = adv_l2
      lo(3) = adv_l3
      hi(1) = adv_h1
      hi(2) = adv_h2
      hi(3) = adv_h3

      call filcc (adv,DIMS(adv),domlo,domhi,delta,xlo,bc)

      if (bc(1,1).eq.EXT_DIR.and.lo(1).lt.domlo(1)) then
         do i = lo(1), domlo(1)-1
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  adv(i,j,k) = u1shk
               end do
            end do
         end do
      end if            

      if (bc(1,2).eq.EXT_DIR.and.hi(1).gt.domhi(1)) then
         do i = domhi(1)+1, hi(1)
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  adv(i,j,k) = u1amb
               end do
            end do
         end do
      end if            

      if (bc(2,1).eq.EXT_DIR.and.lo(2).lt.domlo(2)) then
         do j = lo(2), domlo(2)-1
            do i = lo(1), hi(1)
               do k = lo(3), hi(3)
                  adv(i,j,k) = adv(i,domlo(2),k)                     
               end do
            end do
         end do
      end if

      if (bc(2,2).eq.EXT_DIR.and.hi(2).gt.domhi(2)) then
         do j = domhi(2)+1, hi(2)
            do i = lo(1), hi(1)
               do k = lo(3), hi(3)
                  adv(i,j,k) = adv(i,domhi(2),k)                     
               end do
            end do
         end do
      end if            

      if (bc(3,1).eq.EXT_DIR.and.lo(3).lt.domlo(3)) then
         do k = lo(3), domlo(3)-1
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = adv(i,j,domlo(3))                     
               end do
            end do
	 end do
      end if            

      if (bc(3,2).eq.EXT_DIR.and.hi(3).gt.domhi(3)) then
         do k = domhi(3)+1, hi(3)
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = adv(i,j,domhi(3))                         
               end do
            end do
         end do
      end if

      end

      subroutine FORT_YMOMFILL (adv,DIMS(adv),domlo,domhi,delta,
     &                          xlo,time,bc )

      integer    DIMS(adv)
      integer    lo(SDIM), hi(SDIM), bc(SDIM,2)
      integer    domlo(SDIM), domhi(SDIM)
      REAL_T     delta(SDIM), xlo(SDIM), time
      REAL_T     adv(DIMV(adv))

      integer    i, j, k   
      REAL_T     y,x

#include "probdata.H"

      lo(1) = adv_l1
      lo(2) = adv_l2
      lo(3) = adv_l3
      hi(1) = adv_h1
      hi(2) = adv_h2
      hi(3) = adv_h3

      call filcc (adv,DIMS(adv),domlo,domhi,delta,xlo,bc)

      if (bc(1,1).eq.EXT_DIR.and.lo(1).lt.domlo(1)) then
         do i = lo(1), domlo(1)-1
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  y = xlo(2) + delta(2)*(float(j-lo(2)) + 0.5)
                  adv(i,j,k) = u2shk
               end do
            end do
         end do
      end if            

      if (bc(1,2).eq.EXT_DIR.and.hi(1).gt.domhi(1)) then
         do i = domhi(1)+1, hi(1)
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  adv(i,j,k) = u2amb
               end do
            end do
         end do
      end if            

      if (bc(2,1).eq.EXT_DIR.and.lo(2).lt.domlo(2)) then
         do j = lo(2), domlo(2)-1
            do i = lo(1), hi(1)
               do k = lo(3), hi(3)
                  adv(i,j,k) = -adv(i,domlo(2),k)
               end do
            end do
	 end do
      end if            

      if (bc(2,2).eq.EXT_DIR.and.hi(2).gt.domhi(2)) then
         do j = domhi(2)+1, hi(2)
            do i = lo(1), hi(1)
               do k = lo(3), hi(3)
                  adv(i,j,k) = -adv(i,domhi(2),k)
               end do
            end do
         end do
      end if            

      if (bc(3,1).eq.EXT_DIR.and.lo(3).lt.domlo(3)) then
         do k = lo(3), domlo(3)-1
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = adv(i,j,domlo(3))                     
               end do
            end do
	 end do
      end if

      if (bc(3,2).eq.EXT_DIR.and.hi(3).gt.domhi(3)) then
         do k = domhi(3)+1, hi(3)
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = adv(i,j,domhi(3))                         
               end do
            end do
         end do
      end if

      end

      subroutine FORT_ZMOMFILL (adv,DIMS(adv),domlo,domhi,delta,
     &                          xlo,time,bc )

      integer    DIMS(adv)
      integer    bc(SDIM,2),lo(SDIM),hi(SDIM)
      integer    domlo(SDIM), domhi(SDIM)
      REAL_T     delta(SDIM), xlo(SDIM), time
      REAL_T     adv(DIMV(adv))

      integer    i, j, k
      REAL_T     y,x

#include "probdata.H"

      lo(1) = adv_l1
      lo(2) = adv_l2
      lo(3) = adv_l3
      hi(1) = adv_h1
      hi(2) = adv_h2
      hi(3) = adv_h3

      call filcc (adv,DIMS(adv),domlo,domhi,delta,xlo,bc)

      if (bc(1,1).eq.EXT_DIR.and.lo(1).lt.domlo(1)) then
         do i = lo(1), domlo(1)-1
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  adv(i,j,k) = u3shk
               end do
            end do
         end do
      end if            

      if (bc(1,2).eq.EXT_DIR.and.hi(1).gt.domhi(1)) then
         do i = domhi(1)+1, hi(1)
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  adv(i,j,k) = u3amb
               end do
            end do
         end do
      end if            

      if (bc(2,1).eq.EXT_DIR.and.lo(2).lt.domlo(2)) then
         do j = lo(2), domlo(2)-1
            do i = lo(1), hi(1)
               do k = lo(3), hi(3)
                  adv(i,j,k) = -adv(i,domlo(2),k)
               end do
            end do
	 end do
      end if            

      if (bc(2,2).eq.EXT_DIR.and.hi(2).gt.domhi(2)) then
         do j = domhi(2)+1, hi(2)
            do i = lo(1), hi(1)
               do k = lo(3), hi(3)
                  adv(i,j,k) = -adv(i,domhi(2),k)
               end do
            end do
         end do
      end if            

      if (bc(3,1).eq.EXT_DIR.and.lo(3).lt.domlo(3)) then
         do k = lo(3), domlo(3)-1
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = -adv(i,j,domlo(3))                     
               end do
            end do
	 end do
      end if            

      if (bc(3,2).eq.EXT_DIR.and.hi(3).gt.domhi(3)) then
         do k = domhi(3)+1, hi(3)
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = -adv(i,j,domhi(3))                         
               end do
            end do
         end do
      end if

      end

      subroutine FORT_EDENFILL (adv,DIMS(adv),domlo,domhi,delta,
     &                          xlo,time,bc )

      integer    DIMS(adv)
      integer    lo(SDIM), hi(SDIM), bc(SDIM,2)
      integer    domlo(SDIM), domhi(SDIM)
      REAL_T     delta(SDIM), xlo(SDIM), time
      REAL_T     adv(DIMV(adv))

      integer    i, j,k
      REAL_T     y,x

#include "probdata.H"

      lo(1) = adv_l1
      lo(2) = adv_l2
      lo(3) = adv_l3
      hi(1) = adv_h1
      hi(2) = adv_h2
      hi(3) = adv_h3

      call filcc (adv,DIMS(adv),domlo,domhi,delta,xlo,bc)

      if (bc(1,1).eq.EXT_DIR.and.lo(1).lt.domlo(1)) then
         do i = lo(1), domlo(1)-1
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  adv(i,j,k) = eshk
               end do
            end do
	 end do
      end if            

      if (bc(1,2).eq.EXT_DIR.and.hi(1).gt.domhi(1)) then
         do i = domhi(1)+1, hi(1)
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  adv(i,j,k) = eamb
               end do
            end do
	 end do
      end if            

      if (bc(2,1).eq.EXT_DIR.and.lo(2).lt.domlo(2)) then
         do j = lo(2), domlo(2)-1
            do i = lo(1), hi(1)
               do k = lo(3), hi(3)
                  adv(i,j,k) = adv(i,domlo(2),k)
               end do
            end do
	 end do
      end if            

      if (bc(2,2).eq.EXT_DIR.and.hi(2).gt.domhi(2)) then
         do j = domhi(2)+1, hi(2)
            do i = lo(1), hi(1)
               do k = lo(3), hi(3)
                  adv(i,j,k) = adv(i,domhi(2),k)
               end do
            end do
	 end do
      end if            

      if (bc(3,1).eq.EXT_DIR.and.lo(3).lt.domlo(3)) then
         do k = lo(3), domlo(3)-1
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = adv(i,j,domlo(3))                     
               end do
            end do
         end do
      end if            

      if (bc(3,2).eq.EXT_DIR.and.hi(3).gt.domhi(3)) then
         do k = domhi(3)+1, hi(3)
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = adv(i,j,domhi(3))                         
               end do
            end do
         end do
      end if

      end

      subroutine FORT_TRACFILL (adv,DIMS(adv),domlo,domhi,delta,
     &                          xlo,time,bc )

      integer    DIMS(adv)
      integer    lo(SDIM), hi(SDIM), bc(SDIM,2)
      integer    domlo(SDIM), domhi(SDIM)
      REAL_T     delta(SDIM), xlo(SDIM), time
      REAL_T     adv(DIMV(adv))

      integer    i, j,k
      REAL_T     y,x

#include "probdata.H"

      lo(1) = adv_l1
      lo(2) = adv_l2
      lo(3) = adv_l3
      hi(1) = adv_h1
      hi(2) = adv_h2
      hi(3) = adv_h3

      call filcc (adv,DIMS(adv),domlo,domhi,delta,xlo,bc)

      if (bc(1,1).eq.EXT_DIR.and.lo(1).lt.domlo(1)) then
         do i = lo(1), domlo(1)-1
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  adv(i,j,k) = zero
               end do
            end do
	 end do
      end if            

      if (bc(1,2).eq.EXT_DIR.and.hi(1).gt.domhi(1)) then
         do i = domhi(1)+1, hi(1)
            do j = lo(2), hi(2)
               do k = lo(3), hi(3)
                  adv(i,j,k) = zero
               end do
            end do
	 end do
      end if            

      if (bc(2,1).eq.EXT_DIR.and.lo(2).lt.domlo(2)) then
         do j = lo(2), domlo(2)-1
            do i = lo(1), hi(1)
               do k = lo(3), hi(3)
                  adv(i,j,k) = adv(i,domlo(2),k)
               end do
            end do
	 end do
      end if            

      if (bc(2,2).eq.EXT_DIR.and.hi(2).gt.domhi(2)) then
         do j = domhi(2)+1, hi(2)
            do i = lo(1), hi(1)
               do k = lo(3), hi(3)
                  adv(i,j,k) = adv(i,domhi(2),k)
               end do
            end do
	 end do
      end if            

      if (bc(3,1).eq.EXT_DIR.and.lo(3).lt.domlo(3)) then
         do k = lo(3), domlo(3)-1
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = adv(i,j,domlo(3))                     
               end do
            end do
         end do
      end if            

      if (bc(3,2).eq.EXT_DIR.and.hi(3).gt.domhi(3)) then
         do k = domhi(3)+1, hi(3)
            do i = lo(1), hi(1)
               do j = lo(2), hi(2)
                  adv(i,j,k) = adv(i,j,domhi(3))                         
               end do
            end do
         end do
      end if

      end

