/*
** (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) 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: HYPERCLAW_2D.F,v 1.1 2002/04/11 22:36:43 marc 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 "HYPERCLAW_F.H"
#include "ArrayLim.H"

#define SDIM 2

c :: 
c :: ----------------------------------------------------------
c :: estimate the timestep for this grid r
c :: 
c :: INPUTS/OUTPUTS
c :: state      =>  state array
c :: slo,shi    =>  index limits of state array
c :: c          =>   c array 
c :: clo,chi    =>  index limits of c array
c :: delta      =>  cell size
c :: dt        <=   timestep estimate
c :: 
c :: ----------------------------------------------------------
c :: 
#if 1
      subroutine FORT_ESTDT (state,DIMS(s),c,DIMS(c),lo,hi,delta,dt,nv)

      integer   nv
      integer lo(SDIM), hi(SDIM)
      integer   DIMDEC(s)
      integer   DIMDEC(c)
      REAL_T    dt
      REAL_T    delta(SDIM)
      REAL_T 	state(DIMV(s),nv)
      REAL_T 	c(DIMV(c))

      integer   i, j, is,ie,js,je
      REAL_T    ux,uy,dt1,dt2,dx,dy
      REAL_T    small,gdum,pdum,csdum
 
      is = lo(1)
      js = lo(2)
      ie = hi(1)
      je = hi(2)

      dx = delta(1)
      dy = delta(2)

      dt = bigreal
         do j = js, je         
            do i = is, ie             
               ux = state(i,j,2)/state(i,j,1)
               uy = state(i,j,3)/state(i,j,1)
               state(i,j,4) = state(i,j,4)/state(i,j,1) -
     $              half*(ux**2 + uy**2)
               state(i,j,5) = state(i,j,5)/state(i,j,1)
            end do
         end do
      call eos(state(is,js,1),state(is,js,4),state(is,js,5),
     $     DIMS(s),
     $     gdum,pdum,c,csdum,
     $     DIMS(c),
     $     lo, hi,0,0,1,0)
         do j = js, je           
            do i = is, ie         
               ux = abs(state(i,j,2))/state(i,j,1)
               uy = abs(state(i,j,3))/state(i,j,1)
               dt1 = dx/(c(i,j) + ux)
               dt2 = dy/(c(i,j) + uy)
               dt = min(dt,dt1,dt2)
            end do
         end do

      end
#else
      subroutine FORT_ESTDT (state,DIMS(s),c,DIMS(c),lo,hi,delta,dt,nv)

      integer   nv
      integer lo(SDIM), hi(SDIM)
      integer   DIMDEC(s)
      integer   DIMDEC(c)
      REAL_T    dt
      REAL_T    delta(SDIM)
      REAL_T 	state(DIMV(s),nv)
      REAL_T 	c(DIMV(c))

      integer   i, j, is,ie,js,je
      REAL_T    ux,uy,dt1,dt2,dx,dy
      REAL_T    small,gdum,pdum,csdum
 
      is = lo(1)
      js = lo(2)
      ie = hi(1)
      je = hi(2)

      dx = delta(1)
      dy = delta(2)

      dt = bigreal

      do j = js, je         
          do i = is, ie             
              ux = state(i,j,2)/state(i,j,1)
              uy = state(i,j,3)/state(i,j,1)
              state(i,j,4) = state(i,j,4)/state(i,j,1) -
     $                       half*(ux**2 + uy**2)
           end do
        end do
        
        call eos(state(is,js,1),state(is,js,4),gdum,pdum,
     $       c,csdum,lo,hi,0,0,1,0)
       do j = js, je           
          do i = is, ie         
              ux = abs(state(i,j,2))/state(i,j,1)
              uy = abs(state(i,j,3))/state(i,j,1)
              dt1 = dx/(c(i,j) + ux)
              dt2 = dy/(c(i,j) + uy)
              dt = min(dt,dt1,dt2)
           end do
        end do

      end
#endif
c :: ----------------------------------------------------------
c :: Volume-weight average the fine grid data onto the coarse
c :: grid.  Overlap is given in coarse grid coordinates.
c ::
c :: INPUTS / OUTPUTS:
c ::  crse      <=  coarse grid data
c ::  clo,chi    => index limits of crse array 
c ::  nvar	 => number of components in arrays
c ::  cv         => coarse grid volume array   
c ::  cvlo,cvhi  => index limits of cv   
c ::  fine       => fine grid data
c ::  flo,fhi    => index limits of fine array 
c ::  fv         => fine grid volume array
c ::  fvlo,fvhi  => index limits of fv array
c ::  lo,hi      => index limits of overlap (crse grid)
c ::  lrat       => refinement ratio
c :: ----------------------------------------------------------
c ::
      subroutine FORT_AVGDOWN (crse,DIMS(c),nvar,cv,DIMS(cv),
     &			       fine,DIMS(f),fv,DIMS(fv),lo,hi,lrat)
      integer  DIMDEC(c)
      integer  DIMDEC(cv)
      integer  DIMDEC(f)
      integer  DIMDEC(fv)
      integer  lo(SDIM), hi(SDIM)
      integer  nvar, lrat
      REAL_T   crse(DIMV(c),nvar)
      REAL_T   cv(DIMV(cv))
      REAL_T   fine(DIMV(f),nvar)
      REAL_T   fv(DIMV(fv))
      
      integer  i, j, n, ic, jc, ioff, joff
      integer  lenx, leny

      lenx = hi(1)-lo(1)+1
      leny = hi(2)-lo(2)+1

      if (lenx .ge. leny) then
         do n = 1, nvar
c
c         ::::: set coarse grid to zero on overlap
c
            do jc = lo(2), hi(2)
               do ic = lo(1), hi(1)
                  crse(ic,jc,n) = zero
               end do
            end do
c
c         ::::: sum fine data
c
            do joff = 0, lrat-1
               do jc = lo(2), hi(2)
                  j = jc*lrat + joff
                  do ioff = 0, lrat-1
                     do ic = lo(1), hi(1)
                        i = ic*lrat + ioff
                        crse(ic,jc,n) = crse(ic,jc,n) + fv(i,j)*fine(i,j,n)
                     end do
                  end do
               end do
            end do
c            
c         ::::: divide out by volume weight
c
            do jc = lo(2), hi(2)
               do ic = lo(1), hi(1)
                  crse(ic,jc,n) = crse(ic,jc,n)/cv(ic,jc)
               end do
            end do
            
         end do

      else

         do n = 1, nvar
c
c         ::::: set coarse grid to zero on overlap
c
            do ic = lo(1), hi(1)
               do jc = lo(2), hi(2)
                  crse(ic,jc,n) = zero
               end do
            end do
c
c         ::::: sum fine data
c
            do ioff = 0, lrat-1
               do ic = lo(1), hi(1)
                  i = ic*lrat + ioff
                  do joff = 0, lrat-1
                     do jc = lo(2), hi(2)
                        j = jc*lrat + joff
                        crse(ic,jc,n) = crse(ic,jc,n) + fv(i,j)*fine(i,j,n)
                     end do
                  end do
               end do
            end do
c	 	 
c         ::::: divide out by volume weight
c
            do ic = lo(1), hi(1)
               do jc = lo(2), hi(2)
                  crse(ic,jc,n) = crse(ic,jc,n)/cv(ic,jc)
               end do
            end do
            
         end do
      end if

      end

c :: ----------------------------------------------------------
c :: SUMMASS
c ::             MASS = sum{ vol(i,j)*rho(i,j) }
c ::
c :: INPUTS / OUTPUTS:
c ::  rho        => density field
c ::  rlo,rhi    => index limits of rho aray
c ::  lo,hi      => index limits of grid interior
c ::  delta	 => cell size
c ::  mass      <=  total mass
c ::  r		 => radius at cell center
c ::  irlo,hi    => index limits of r array
c ::  rz_flag    => == 1 if R_Z coords
c ::  tmp        => temp column array
c :: ----------------------------------------------------------
c ::
       subroutine FORT_SUMMASS(rho,DIMS(r),lo,hi,delta,mass,
     &                         r,irlo,irhi,rz_flag,tmp,tlo,thi)
       integer irlo, irhi, rz_flag
       integer DIMDEC(r)
       integer lo(2), hi(2)
       REAL_T  mass, delta(2)
       REAL_T  rho(DIMV(r))
       REAL_T  r(irlo:irhi)
       integer tlo,thi
       REAL_T  tmp(tlo:thi)

       integer i, j
       REAL_T  dr, dz, vol

       dr = delta(1)
       dz = delta(2)

       do j = lo(2),hi(2)
          tmp(j) = zero
       end do

       do i = lo(1), hi(1)
          vol = dr*dz
	  if (rz_flag .eq. 1) vol = vol*two*Pi*r(i)
          do j = lo(2), hi(2)
	     tmp(j) = tmp(j) + vol*rho(i,j)
	  end do
       end do

       mass = zero

       do j = lo(2), hi(2)
          mass = mass + tmp(j)
       end do

       end
