/*
** (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: DERIVE_3D.F,v 1.2 1999/05/24 18:11:42 car 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 "DERIVE_F.H"
#include "ArrayLim.H"
#include "integrator.fh"

#if defined(BL_USE_FLOAT) || defined(BL_T3E)
#define  BL_USE_FLOAT_CONST
#define  onetominussix 1.0e-6
#define  onetominusten 1.0e-10
#define  onetoten      1.0e+10
#define  onepointfour  1.4
#endif

#if defined(BL_USE_DOUBLE) && !defined(BL_T3E)
#define  BL_USE_DOUBLE_CONST
#define  onetominussix 1.0d-6
#define  onetominusten 1.0d-10
#define  onetoten      1.0d+10
#define  onepointfour  1.4d+00
#endif

#define SDIM 3      

c
c     A derived-quantity derivation routine that copies from input to output.
c
      subroutine FORT_DERCOPY (e,DIMS(e),nv,dat,DIMS(dat),ncomp,
     $                         lo,hi,domlo,domhi,delta,xlo,time,dt,bc,
     $                         level,gridno)
      integer    lo(SDIM), hi(SDIM)
      integer    DIMDEC(e)
      integer    DIMDEC(dat)
      integer    domlo(SDIM), domhi(SDIM)
      integer    nv, ncomp, level, gridno
      integer    bc(SDIM,2,ncomp)
      REAL_T     delta(SDIM), xlo(SDIM), time, dt
      REAL_T     e(DIMV(e),nv)
      REAL_T     dat(DIMV(dat),ncomp)

      integer    i,j,k,nc

      if (nv .ne. ncomp) then
         write(6,*) "FORT_DERCOPY: invalid call"
	 stop
      end if

      if ((e_l1 .ne. dat_l1) .or.
     $    (e_l2 .ne. dat_l2) .or.
     $    (e_l3 .ne. dat_l3) .or.
     $    (e_h1 .ne. dat_h1) .or.
     $    (e_h2 .ne. dat_h2) .or.
     $    (e_h3 .ne. dat_h3)) then
         write(6,*) "FORT_DERCOPY: invalid call"
	 stop
      end if

      do nc = 1, nv
         do k = e_l3, e_h3
            do j = e_l2, e_h2
               do i = e_l1, e_h1
                  e(i,j,k,nc) = dat(i,j,k,nc)
               enddo
            enddo
         enddo
      enddo

      end

c ::: -----------------------------------------------------------
c ::: This routine will derive log of given scalar quantity
c ::: 
c ::: 
c ::: INPUTS/OUTPUTS:
c ::: 
c ::: e        <=  logden array (cell centered)
c ::: elo,ehi   => index extent of e array
c ::: nv        => number of components in e array (should be 1)
c ::: dat       => data neded to derive logden
c :::		   should be density 
c ::: dlo,dhi   => index limits of dat array
c ::: ncomp     => number of components of dat array (3)
c ::: lo,hi     => subrange of e array where result is requested
c ::: domlo,hi  => index extent of problem domain (cell centered)
c ::: delta     => cell spacing
c ::: xlo       => physical location of lower left hand
c :::	           corner of e array
c ::: time      => problem evolution time
c ::: bc        => array of bndry types for component values
c :::              valid only if component touches bndry
c ::: -----------------------------------------------------------

      subroutine FORT_DERLOGS (e,DIMS(e),nv,dat,DIMS(dat),ncomp,
     $                         lo,hi,domlo,domhi,delta,xlo,time,dt,bc,
     $                         level,gridno)
      integer    lo(SDIM), hi(SDIM)
      integer    DIMDEC(e)
      integer    DIMDEC(dat)
      integer    domlo(SDIM), domhi(SDIM)
      integer    nv, ncomp, level, gridno
      integer    bc(SDIM,2,ncomp)
      REAL_T     delta(SDIM), xlo(SDIM), time, dt
      REAL_T     e(DIMV(e),nv)
      REAL_T     dat(DIMV(dat),ncomp)

      integer    i,j,k
      integer    nxlo, nxhi, nylo, nyhi, nzlo, nzhi
      REAL_T     rho
      REAL_T     sml

      parameter (sml = 1.0e-10)
c      
c::::: lets punt if not in domain interior
c
      nxlo = max(0,domlo(1)-lo(1))
      nxhi = max(0,hi(1)-domhi(1))
      nylo = max(0,domlo(2)-lo(2))
      nyhi = max(0,hi(2)-domhi(2))
      nzlo = max(0,domlo(3)-lo(3))
      nzhi = max(0,hi(3)-domhi(3))

      if (nxlo+nxhi+nylo+nyhi+nzlo+nzhi .gt. 0) then
         write(6,*) "FORT_DERLOGS: outside domain"
	 stop
      end if

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               rho = max(dat(i,j,k,1),sml)
               e(i,j,k,1) = log10(rho)
            enddo
         enddo
      enddo

      end

c ::: ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c ::: derive velocity:  this routine will derive velocity
c :::                   from momentum
c :::
c ::: INPUTS/OUTPUTS:
c :::
c ::: e        <=  velocity array (cell centered)
c ::: elo,ehi   => index extent of e array
c ::: nv        => number of components in e array (should be 1)
c ::: dat       => data neded to derive velocity
c ::: dlo,dhi   => index limits of dat array
c ::: ncomp     => number of components of dat array (2)
c ::: lo,hi     => subrange of e array where result is requested
c ::: domlo,hi  => index extent of problem domain (cell centered)
c ::: delta     => cell spacing
c ::: xlo       => physical location of lower left hand
c :::              corner of e array
c ::: time      => problem evolution time
c ::: bc        => array of bndry types for component values
c :::              valid only if component touches bndry
c ::: -----------------------------------------------------------
      subroutine FORT_DERVEL (e,DIMS(e),nv,dat,DIMS(dat),ncomp,
     $                        lo,hi,domlo,domhi,delta,xlo,time,dt,bc,
     $                        level,gridno)

      integer    lo(SDIM), hi(SDIM)
      integer    DIMDEC(e)
      integer    DIMDEC(dat)
      integer    domlo(SDIM), domhi(SDIM)
      integer    nv, ncomp, level, gridno
      integer    bc(SDIM,2,ncomp)
      REAL_T     delta(SDIM), xlo(SDIM), time, dt
      REAL_T     e(DIMV(e),nv)
      REAL_T     dat(DIMV(dat),ncomp)

      integer i,j,k
      integer    nlft, nrgt, nbot, ntop,nfrnt, nbck
      REAL_T     u, v, w
c
c::::: lets punt if not in domain interior
c
      nlft = max(0,domlo(1)-lo(1))
      nrgt = max(0,hi(1)-domhi(1))
      nbot = max(0,domlo(2)-lo(2))
      ntop = max(0,hi(2)-domhi(2))
      nfrnt = max(0,domlo(3)-lo(3))
      nbck = max(0,hi(3)-domhi(3))

      if (nlft+nrgt+nbot+ntop+nfrnt+nbck .gt. 0) then
         write(6,*) "FORT_DERXVEL: outside domain"
         stop
      end if

      do k = lo(3),hi(3)
         do j = lo(2),hi(2)
            do i = lo(1),hi(1)
               e(i,j,k,1) = dat(i,j,k,2)/dat(i,j,k,1)
            end do
         end do
      end do

      end

c ::: ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c ::: this thing will derive pressure.  Calls eos.
c :::
c :::
c ::: INPUTS/OUTPUTS:
c :::
c ::: e        <=  pressuree array (cell centered)
c ::: elo,ehi   => index extent of e array
c ::: nv        => number of components in e array (should be 1)
c ::: dat       => data neded to derive pressure
c ::: dlo,dhi   => index limits of dat array
c ::: ncomp     => number of components of dat array (4)
c ::: lo,hi     => subrange of e array where result is requested
c ::: domlo,hi  => index extent of problem domain (cell centered)
c ::: delta     => cell spacing
c ::: xlo       => physical location of lower left hand
c :::              corner of e array
c ::: time      => problem evolution time
c ::: bc        => array of bndry types for component values
c :::              valid only if component touches bndry
c ::: -----------------------------------------------------------

      subroutine FORT_DERPRES (e,DIMS(e),nv,dat,DIMS(dat),ncomp,
     $                         lo,hi,domlo,domhi,delta,xlo,time,dt,bc,
     $                         level,gridno)

      integer    lo(SDIM), hi(SDIM)
      integer    DIMDEC(e)
      integer    DIMDEC(dat)
      integer    domlo(SDIM), domhi(SDIM)
      integer    nv, ncomp, level, gridno
      integer    bc(SDIM,2,ncomp)
      REAL_T     delta(SDIM), xlo(SDIM), time, dt
      REAL_T     e(DIMV(e),nv)
      REAL_T     dat(DIMV(dat),ncomp)
c
c ::: local arrays
c
      REAL_T eint
      REAL_T cdum, gdum, csdum, rhomax, rhomin
c
c ::: local var
c
      integer i,j,k
      integer npts, ii, ist
      REAL_T rho, ux, uy,uz, pmax, pmin, bigp

#include "xxmeth.fh"

      smallp = onetominussix
      bigp = onetoten

      do k = lo(3),hi(3)
         do j = lo(2),hi(2)
            do i = lo(1), hi(1)
               rho = dat(i,j,k,1)
               ux = dat(i,j,k,2)/rho
               uy = dat(i,j,k,3)/rho
               uz = dat(i,j,k,4)/rho
               eint = (dat(i,j,k,5) - half*(ux**2+uy**2+uz**2))/rho
               e(i,j,k,2) = eint
               e(i,j,k,3) = rho
               e(i,j,k,4) = dat(i,j,k,6)/rho
            end do
         end do
      end do

      call eos(e(ARG_L1(e),ARG_L2(e),ARG_L3(e),3),
     $     e(ARG_L1(e),ARG_L2(e),ARG_L3(e),2),
     $     e(ARG_L1(e),ARG_L2(e),ARG_L3(e),4),
     $     DIMS(e),
     $     gdum,
     $     e(ARG_L1(e),ARG_L2(e),ARG_L3(e),1),
     $     cdum, csdum,
     $     DIMS(e),
     $     lo, hi, 0, 1, 0, 0)

      end

      subroutine eos(rho,eint,comp,DIMS(rho),gamc,p,c,csml,DIMS(c),
     $               lo,hi,lgamc,lp,lc,lcsml)

      integer lgamc, lp, lc, lcsml
      integer lo(3), hi(3)
      integer DIMDEC(rho)
      integer DIMDEC(c)
      REAL_T rho(DIMV(rho),1)
      REAL_T eint(DIMV(rho),1)
      REAL_T comp(DIMV(rho),1)
      REAL_T c(DIMV(c),1)
      REAL_T gamc(DIMV(c),1)
      REAL_T p(DIMV(c),1)
      REAL_T csml(DIMV(c),1)
      REAL_T pres, cc, psml
      integer j,k

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            call eosstrip(rho(lo(1),j,k,1),
     $                    eint(lo(1),j,k,1),
     $                    comp(lo(1),j,k,1),
     $                    gamc(lo(1),j,k,1),
     $                    p(lo(1),j,k,1),
     $                    c(lo(1),j,k,1),
     $                    csml(lo(1),j,k,1),
     $                    lo(1),hi(1),lgamc,lp,lc,lcsml,j,k)
         end do
      end do

      end

       subroutine eosstrip(rrr,eee,comp,gamiso,ppp,c,csml,nlo,nhi,
     &                lgamc,lp,lc,lcsml,jin,kin)

c :: 
c :: Inputs and Outpus
c :: rrr      => (const)  mass density
c :: eee      => (const)  internal energy per unit volume
c :: comp     => (const)  the volume fraction of HE 
c :: n        => (const)  size of all argument arrays
c :: nlo      => (const)  beginning location
c :: nhi      => (const)  end location
c :: gamiso  <=  (modify) sound speed gamma
c :: ppp     <=  (modify) pressure
c :: c       <=  (modify) sound speed
c :: csml    <=  (modify) sound speed floor
c :: lgamc    => (const)  =1 -> return gamiso
c :: lp       => (const)  =1 -> return pressure
c :: lc       => (const)  =1 -> return sound speed
c :: lcsml    => (const)  =1 -> return sound speed floor
 
c
c::::: dummy arguments
c
      integer    n, nlo, nhi
      integer    lgamc, lp, lc, lcsml
      REAL_T     rrr(nlo:nhi), eee(nlo:nhi), comp(nlo:nhi), ppp(nlo:nhi)
      REAL_T     gamiso(nlo:nhi), c(nlo:nhi), csml(nlo:nhi)
      REAL_T     comptmp

      integer    jin,kin
 
#include  "xxmeth.fh"
#include "probdata.H"
c 
c::::: local variables
c
      integer    k,npts
      REAL_T     ptmp,gamtmp,gamctmp

c::::: calculate gamma by linear interpolation.
c
      if (lgamc .eq. 1) then
         do k = nlo,nhi
            comptmp = max(min(comp(k),one),zero)
            gamiso(k) = one/(comptmp/gamcld+(one-comptmp)/gamamb)
         end do
      end if
c 
c::::: calculate presure in units of eee
c
      if (lp .eq. 1) then
         do k = nlo,nhi
            comptmp = max(min(comp(k),one),zero)
            gamtmp= one+one/(comptmp/(gamcld-one)+(one-comptmp)/(gamamb-one))
            ppp(k) = (gamtmp - one)*eee(k)*rrr(k)
         end do
      end if
 
      if (lcsml .eq. 1 .and. lc .ne. 1) then
         write(6,*) "EOS: cannot ask for csml without c"
	 stop
      end if

      if (lc .eq. 1) then
         if (lp .eq. 1 .and. lgamc .eq. 1) then
            do k = nlo,nhi
               c(k) = sqrt(gamiso(k)*abs(ppp(k))/max(rrr(k),smallr))
               c(k) = max(c(k),small)
            end do
	 else if (lp .eq. 1 .and. lgamc .ne. 1) then
c
c::::: have pressure but not gamiso 
c
            do k = nlo,nhi
               comptmp = max(min(comp(k),one),zero)
               gamtmp= one+one/(comptmp/(gamcld-one)+(one-comptmp)/(gamamb-one))
               c(k) = sqrt(gamtmp*abs(ppp(k))/max(rrr(k),smallr))
               c(k) = max(c(k),small)
            end do
	 else if (lgamc .eq. 1 .and. lp .ne. 1) then
c
c::::: have gamiso but not pressure	 
c
            do k = nlo,nhi
               comptmp = max(min(comp(k),one),zero)
               gamtmp= one+one/(comptmp/(gamcld-one)+(one-comptmp)/(gamamb-one))
               ptmp = (gamtmp - one)*eee(k)*rrr(k)
               c(k) = sqrt(gamiso(k)*abs(ptmp)/max(rrr(k),smallr))
               c(k) = max(c(k),small)
            end do
         else
            do k = nlo,nhi
               comptmp = max(min(comp(k),one),zero)
               gamtmp= one+one/(comptmp/(gamcld-one)+(one-comptmp)/(gamamb-one))
               ptmp = (gamtmp-one)*eee(k)*rrr(k)
               gamctmp = one/(comptmp/gamcld+(one-comptmp)/gamamb)
               c(k) = sqrt(gamctmp*abs(ptmp)/max(rrr(k),smallr))
               c(k) = max(c(k),small)
            end do
	 end if

	 if (lcsml .eq. 1) then
            do k = nlo,nhi
               csml(k) = max(small,small*c(k))
            end do
         end if
      end if

      end
