/*
** (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_2D.F,v 1.20 2002/07/23 17:11:56 lijewski Exp $
c

#include "CONSTANTS.H"
#include "Derived.H"

#define DIM 2

c
c The following routine does NOT have the signature of a derived function.
c
c This routine assumes domain is of form: [(0,0),(xlen,ylen)]
c
       subroutine FORT_RANDMOVE (a,DIMS(c),b,c,d,u,nspec,x,y,spec,
     &                           dx,dy,dt,dxinv,dyinv)

       implicit none

       integer DIMDEC(c), nspec, spec
       REAL_T  x, y, dx, dy, dt, dxinv, dyinv
       REAL_T  a(DIMV(c),0:nspec-1)
       REAL_T  b(DIMV(c),0:nspec-1)
       REAL_T  c(DIMV(c),0:nspec-1)
       REAL_T  d(DIMV(c),0:nspec-1)
       REAL_T  u(DIMV(c),2)

       integer i, ix, iy
       REAL_T  rn

       if (spec.lt.zero.or.spec.ge.nspec) stop 'bad species ref (df)'
       !
       ! First advect stuff ...
       !
       ix = x * dxinv
       iy = y * dyinv

       if ((ix.ge.c_l1.and.ix.le.c_h1) .and.
     &      (iy.ge.c_l2.and.iy.le.c_h2)) then

          x = x + u(ix,iy,1) * dt
          y = y + u(ix,iy,2) * dt

          if (x.lt.zero) x = -x

       end if
       !
       ! Now do the stochastic diffusion ...
       !
       ix = x * dxinv
       iy = y * dyinv

       if ((ix.ge.c_l1.and.ix.le.c_h1) .and.
     &      (iy.ge.c_l2.and.iy.le.c_h2)) then

          call blutilrand(rn)

          if (rn.lt.a(ix,iy,spec)*dt) then
             x = x - dx
          else if (rn.lt.b(ix,iy,spec)*dt) then
             x = x + dx
          else if (rn.lt.c(ix,iy,spec)*dt) then
             y = y - dy
          else if (rn.lt.d(ix,iy,spec)*dt) then
             y = y + dy
          end if

       end if

       end

       subroutine FORT_MAXDTDIFF (d,DIMS(c),nspec,x,y,spec,
     &                            dx,dy,dt,dxinv,dyinv)

       implicit none

       integer DIMDEC(c), nspec, spec
       REAL_T  x, y, dx, dy, dt, dxinv, dyinv
       REAL_T  d(DIMV(c),0:nspec-1)

       integer i, j, ilo, ihi, jlo, jhi, ix, iy
       REAL_T  rn, dmax

       if (spec.lt.zero.or.spec.ge.nspec) stop 'bad species ref (df)'

       ix   = x * dxinv
       iy   = y * dyinv
       dmax = 0

       if ((ix.ge.c_l1.and.ix.le.c_h1) .and.
     &      (iy.ge.c_l2.and.iy.le.c_h2)) then

          ilo = max(ix-2,c_l1)
          ihi = min(ix+2,c_h1)
          jlo = max(iy-2,c_l2)
          jhi = min(iy+2,c_h2)

          do i = ilo, ihi
             do j = jlo, jhi
                dmax = max(dmax,d(i,j,spec))
             end do
          end do

       end if

       if (dmax.gt.zero) dt = min(dt,.1/dmax)

       end
c
c This routine assumes domain is of form: [(0,0),(xlen,ylen)]
c
c conc is really conc.invert(1) so we can multiply instead of divide ...
c
       subroutine FORT_CHEMMOVE (rf,DIMS(c),rr,conc,nspec,nreac,
     &                           edges,edgeslen,pedges,x,y,spec,
     &                           dx,dy,dt,rxn,dxinv,dyinv)

       implicit none

       integer DIMDEC(c), nspec, nreac, spec, rxn
       integer edgeslen, edges(0:edgeslen-1), pedges(0:nspec-1)
       REAL_T  x, y, dx, dy, dt, dxinv, dyinv
       REAL_T  rf(DIMV(c),0:nreac-1)
       REAL_T  rr(DIMV(c),0:nreac-1)
       REAL_T  conc(DIMV(c),0:nspec-1)

       integer i, ix, iy, ie, nedges, rxnid, factor, tospec, nu
       REAL_T  rn, lambda, netreact

       if (spec.lt.zero.or.spec.ge.nspec) stop 'bad species ref (ch)'

       ix = x * dxinv
       iy = y * dyinv

       if ((ix.ge.c_l1.and.ix.le.c_h1) .and.
     &      (iy.ge.c_l2.and.iy.le.c_h2)) then

          call blutilrand(rn)

          if (pedges(spec).lt.zero) stop 'invalid reaction ref (ch)'

          lambda = 0
          nedges = edges(pedges(spec))

          if (nedges.le.zero) stop 'nedges must be positive (ch)'

          do ie = 0, nedges-1

             rxnid  = edges(pedges(spec)+ie*4+1)
             factor = edges(pedges(spec)+ie*4+2)
             tospec = edges(pedges(spec)+ie*4+3)
             nu     = edges(pedges(spec)+ie*4+4)

             if (factor.gt.zero) then
c                netreact = max(rf(ix,iy,rxnid)-rr(ix,iy,rxnid),zero)
                netreact = rf(ix,iy,rxnid)
                lambda   = nu*lambda+netreact*conc(ix,iy,spec)*dt/factor
             else
c                netreact = max(rr(ix,iy,rxnid)-rf(ix,iy,rxnid),zero)
                netreact = rr(ix,iy,rxnid)
                lambda   = nu*lambda-netreact*conc(ix,iy,spec)*dt/factor
             end if

             if (rn.lt.lambda) then
                rxn  = rxnid
                spec = tospec
                goto 100
             end if

          end do

       end if

100    continue

       end

       subroutine FORT_MAXLAMBDA (rf,DIMS(c),rr,conc,nspec,nreac,
     &                            edges,edgeslen,pedges)

       implicit none

       integer DIMDEC(c), nspec, nreac
       integer edgeslen, edges(0:edgeslen-1), pedges(0:nspec-1)
       REAL_T  rf(DIMV(c),0:nreac-1)
       REAL_T  rr(DIMV(c),0:nreac-1)
       REAL_T  conc(DIMV(c),0:nspec-1)

       integer i, ispec, ix, iy, ie, nedges, rxnid, factor, tospec, nu
       REAL_T  rn, lambda, lmax, netreact

       do ispec = 0, nspec-1

          lmax   = 0
          nedges = edges(pedges(ispec))

          do ix = c_l1, c_h1
             do iy = c_l2, c_h2

                lambda = 0

                do ie = 0, nedges-1
                   rxnid  = edges(pedges(ispec)+ie*4+1)
                   factor = edges(pedges(ispec)+ie*4+2)
                   tospec = edges(pedges(ispec)+ie*4+3)
                   nu     = edges(pedges(ispec)+ie*4+4)

                   if (factor.gt.zero) then
c                      netreact = max(rf(ix,iy,rxnid)-rr(ix,iy,rxnid),zero)
                      netreact = rf(ix,iy,rxnid)
                      lambda   = nu*lambda+netreact*conc(ix,iy,ispec)/factor
                   else
c                      netreact = max(rr(ix,iy,rxnid)-rf(ix,iy,rxnid),zero)
                      netreact = rr(ix,iy,rxnid)
                      lambda   = nu*lambda-netreact*conc(ix,iy,ispec)/factor
                   end if
                end do

                lmax = max(lmax,lambda)

             end do
          end do

          write(*,*) 'spec = ', ispec, 'lmax = ', lmax

       end do

       end

       subroutine FORT_MAXDTLAMBDA (rf,DIMS(c),rr,conc,nspec,nreac,
     &                              edges,edgeslen,pedges,x,y,spec,
     &                              dx,dy,dt,dxinv,dyinv)

       implicit none

       integer DIMDEC(c), nspec, nreac, spec
       integer edgeslen, edges(0:edgeslen-1), pedges(0:nspec-1)
       REAL_T  x, y, dx, dy, dt, dxinv, dyinv
       REAL_T  rf(DIMV(c),0:nreac-1)
       REAL_T  rr(DIMV(c),0:nreac-1)
       REAL_T  conc(DIMV(c),0:nspec-1)

       integer i, j, ix, iy, ie, nedges, rxnid, factor, tospec, nu
       integer ilo, ihi, jlo, jhi, ipos
       REAL_T  lambda, lmax, netreact

       if (spec.lt.zero.or.spec.ge.nspec) stop 'bad species ref (ch)'

       ix   = x * dxinv
       iy   = y * dyinv
       lmax = 0

       if (pedges(spec).lt.zero) stop 'invalid reaction ref (ch)'

       lambda = 0
       nedges = edges(pedges(spec))

       if (nedges.le.zero) stop 'nedges must be positive (ch)'

       do ie = 0, nedges-1
          rxnid  = edges(pedges(spec)+ie*4+1)
          factor = edges(pedges(spec)+ie*4+2)
          tospec = edges(pedges(spec)+ie*4+3)
          nu     = edges(pedges(spec)+ie*4+4)

          if (factor.gt.zero) then
c             netreact = max(rf(ix,iy,rxnid)-rr(ix,iy,rxnid),zero)
             netreact = rf(ix,iy,rxnid)
             lambda   = nu*lambda+netreact*conc(ix,iy,spec)/factor
          else
c             netreact = max(rr(ix,iy,rxnid)-rf(ix,iy,rxnid),zero)
             netreact = rr(ix,iy,rxnid)
             lambda   = nu*lambda-netreact*conc(ix,iy,spec)/factor
          end if
       end do

       lmax = max(lmax,lambda)

       if (lmax.gt.zero) dt = min(dt,.1/lmax)

       end

      subroutine FORT_PROBFAB (rf,DIMS(c),rr,prob,DIMS(p),
     &                         nspec,nreac,ispec,
     &                         edges,edgeslen,pedges,isrz,dx,dy)

       implicit none

       integer DIMDEC(c), DIMDEC(p), nspec, nreac, ispec, isrz
       integer edgeslen, edges(0:edgeslen-1), pedges(0:nspec-1)
       REAL_T  rf(DIMV(c),0:nreac-1)
       REAL_T  rr(DIMV(c),0:nreac-1)
       REAL_T  prob(DIMV(p)), dx, dy

       integer ix, iy, ie, nedges, rxnid, factor, nu
       REAL_T  lambda, lmax, vol

       if (ispec.lt.zero.or.ispec.gt.nspec-1) stop 'invalid ispec'

       nedges = edges(pedges(ispec))

       do iy = p_l2, p_h2
          do ix = p_l1, p_h1

             vol = dx*dy

             if (isrz.ne.0) vol = vol*half*Pi*dx*(2*p_l1+1)

             lambda = 0

             do ie = 0, nedges-1

                rxnid  = edges(pedges(ispec)+ie*4+1)
                factor = edges(pedges(ispec)+ie*4+2)
                nu     = edges(pedges(ispec)+ie*4+4)

                if (factor.gt.zero) then
                   lambda = nu*lambda + rf(ix,iy,rxnid)/factor
                else
                   lambda = nu*lambda - rr(ix,iy,rxnid)/factor
                end if

             end do

             prob(ix,iy) = lambda*vol

          end do
       end do

       end

       subroutine FORT_ACCUMPROB (prob, DIMS(p), totreact, cumprob)

       implicit none

       integer DIMDEC(p)
       REAL_T  prob(DIMV(p)), totreact, cumprob

       integer ix, iy

       do iy = p_l2, p_h2
          do ix = p_l1, p_h1

             prob(ix,iy) = cumprob+prob(ix,iy)/totreact
             cumprob     = prob(ix,iy)

          enddo
       enddo

       end

       subroutine FORT_SELECTPOS (prob,DIMS(c),rn,dx,dy,x,y)

       implicit none

       integer DIMDEC(c)
       REAL_T  prob(DIMV(c))
       REAL_T  dx,dy,x,y,rn

       integer ix, iy

       do iy = c_l2, c_h2-1
           if (rn.le.prob(c_h1,iy)) go to 100
       enddo

100    continue

       do ix = c_l1, c_h1-1
          if (rn.le.prob(ix,iy)) go to 200
       enddo

200    continue

       x = (ix+half)*dx
       y = (iy+half)*dy

       end
