/*
** (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 "ArrayLim.H"
#include "CONSTANTS.H"
      
#define SDIM 3

      subroutine HACKD(d,DIMS(d),dx,domnlo)
      implicit none
      integer DIMDEC(d)
      REAL_T d(DIMV(d))
      REAL_T dx(SDIM), domnlo(SDIM)
      integer i,j,k
      REAL_T x,y,z,r

      do k=ARG_L3(d),ARG_H3(d)
         z = (float(k)+0.5d0)*dx(3) + domnlo(3)
         do j=ARG_L2(d),ARG_H2(d)
            y = (float(j)+0.5d0)*dx(2) + domnlo(2)
            do i=ARG_L1(d),ARG_H1(d)
               x = (float(i)+0.5d0)*dx(1) + domnlo(1)
               
               r = dsqrt(x**2 + y**2 + z**2)

#if 0
               if (r.gt.0.03) then
                  d(i,j,k) = 5000.d0
               else
                  d(i,j,k) = 0.d0
                  cnt = cnt + 1
               endif
#elif 1
               if (x.gt.-.059999) then
                  d(i,j,k) = 5000.d0
               else
                  d(i,j,k) = 0.d0
               endif
#else
               r = dsqrt(x**2 + y**2 + (z-.06d0)**2)
               if (r.gt.0.015d0) then
                  d(i,j,k) = 5000.d0
               else
                  d(i,j,k) = 0.d0
               endif
#endif

            enddo
         enddo
      enddo
      end


      subroutine BILIN(c,DIMS(c), f, DIMS(f),r)
      implicit none
      integer r
      integer DIMDEC(c)
      integer DIMDEC(f)
      REAL_T c(DIMV(c))
      REAL_T f(DIMV(f))
      integer i,j,k,ii,jj,kk
      REAL_T x,y,z

      do k=ARG_L3(c),ARG_H3(c)
         do j=ARG_L2(c),ARG_H2(c)
            do i=ARG_L1(c),ARG_H1(c)
               do ii=0,r-1
                  do jj=0,r-1
                     do kk=0,r-1
                        f(r*i+ii,r*j+jj,r*k+kk) = c(i,j,k)
                     enddo
                  enddo
               enddo
            enddo
         enddo
      enddo

      do k=ARG_L3(c),ARG_H3(c)-1
         do j=ARG_L2(c),ARG_H2(c)-1
            do i=ARG_L1(c),ARG_H1(c)-1
               do ii=1,r
                  do jj=1,r
                     do kk=1,r
                        x = (float(ii)-0.5d0)/(float(r))
                        y = (float(jj)-0.5d0)/(float(r))
                        z = (float(kk)-0.5d0)/(float(r))
                        f(r*i+ii,r*j+jj,r*k+kk) =
     &                       c(i,j,k)*(1.d0-x)*(1.d0-y)*(1.d0-z) +
     &                       c(i+1,j,k)*x*(1.d0-y)*(1.d0-z) +
     &                       c(i,j+1,k)*(1.d0-x)*y*(1.d0-z) +
     &                       c(i+1,j+1,k)*x*y*(1.d0-z) +
     &                       c(i,j,k+1)*(1.d0-x)*(1.d0-y)*z +
     &                       c(i+1,j,k+1)*x*(1.d0-y)*z +
     &                       c(i,j+1,k+1)*(1.d0-x)*y*z +
     &                       c(i+1,j+1,k+1)*x*y*z
                     enddo
                  enddo
               enddo               
            enddo
         enddo
      enddo
            
      end

      subroutine PROCESS(lo, hi, domlo, tf, DIMS(tf), T, DIMS(T),
     &     listi, listj, listk, listlen, delta, area, sVal, imeth)
      implicit none
      integer lo(SDIM), hi(SDIM), domlo(SDIM)
      integer DIMDEC(T)
      integer DIMDEC(tf)
      REAL_T T(DIMV(T))
      integer tf(DIMV(tf))
      integer listi(*)
      integer listj(*)
      integer listk(*)
      integer listlen
      REAL_T delta(SDIM)
      REAL_T area, sVal
      integer imeth

      integer i,j,k,n,klo,ierr
      REAL_T Tb(2,2,2),myArea
      logical isOne, isZero

      klo = MAX(lo(3) - 1,domlo(3))

      do k=klo,hi(3)
         do j=lo(2)-1,hi(2)
            do i=lo(1)-1,hi(1)
               if (T(i,j,k).LE.sVal) then
                  tf(i,j,k) = 0
               else
                  tf(i,j,k) = 1
               end if
            end do
         end do
      end do

      listlen = 0
      do k=klo,hi(3)-1
         do j=lo(2)-1,hi(2)-1
            do i=lo(1)-1,hi(1)-1

               isOne =  (tf(i+1,j,k).eq.1)
     &              .or.(tf(i,j+1,k).eq.1)
     &              .or.(tf(i,j,k+1).eq.1)

               isZero = (tf(i+1,j,k).eq.0)
     &              .or.(tf(i,j+1,k).eq.0)
     &              .or.(tf(i,j,k+1).eq.0)

               if ( ((tf(i,j,k).eq.0).and.isOne).or.
     &              ((tf(i,j,k).eq.1).and.isZero)) then

                  listlen = listlen + 1
                  listi(listlen) = i
                  listj(listlen) = j
                  listk(listlen) = k
               end if
            end do
         end do
      end do

      area = zero
      do n=1,listlen
         i = listi(n)
         j = listj(n)
         k = listk(n)
         Tb(1,1,1) = T(  i,  j,  k)
         Tb(2,1,1) = T(i+1,  j,  k)
         Tb(1,2,1) = T(  i,j+1,  k)
         Tb(2,2,1) = T(i+1,j+1,  k)
         Tb(1,1,2) = T(  i,  j,k+1)
         Tb(2,1,2) = T(i+1,  j,k+1)
         Tb(1,2,2) = T(  i,j+1,k+1)
         Tb(2,2,2) = T(i+1,j+1,k+1)
         if (imeth.eq.1) then
            ierr = 0
            call jarea(Tb,sVal,delta,myArea,ierr)
            if (ierr.ne.0) then
               print *,'something bad happened'
               exit
            endif
         else
            call temparea(Tb,sVal,delta,myArea)
         endif
         area = area + myArea
      end do

      end


      subroutine jarea (c, c0, h, value, code)

c     input:
c
c     c   is the (2x2x2) array of corner values
c     c0  is the desired level set
c     h   is the (3) array of grid spacings
c
c     output:
c     value  is the area (0 when an error occurs)
c     code   is the integer output code (0 means no error)

      implicit none

      integer edges
      integer faces
      integer nodes

      parameter (edges = 12)
      parameter (faces = 6)
      parameter (nodes = 8)

      double precision c0
      double precision c(2, 2, 2)
      double precision coordinate(nodes, 3)
      double precision ex
      double precision h(3)
      double precision point(edges, 3)
      double precision temp
      double precision v(nodes)
      double precision v1
      double precision v2
      double precision value
      double precision x0
      double precision x1
      double precision x2
      double precision y0
      double precision y1
      double precision y2
      double precision z0
      double precision z1
      double precision z2

      integer code
      integer count
      integer currentedge
      integer currentface
      integer cutedges
      integer edge
      integer edge2corner(edges, 2)
      integer edge2face(edges, 2)
      integer edgelist(edges)
      integer face2edge(faces, 4)
      integer i
      integer j
      integer k
      integer n
      integer n1
      integer n2
      integer nextedge
      integer nextface
      integer p
      integer points
      integer start

      logical cut(edges)

      data ((edge2corner(i, j), j = 1, 2), i = 1, edges) /
     1     5, 6,
     2     5, 7,
     3     8, 7,
     4     6, 8,
     5     2, 4,
     6     3, 4,
     7     1, 3,
     8     1, 2,
     9     2, 6,
     X     1, 5,
     1     3, 7,
     2     4, 8 /

      data ((edge2face(i, j), j = 1, 2), i = 1, edges) /
     1     4, 6,
     2     1, 4,
     3     4, 5,
     4     3, 4,
     5     2, 3,
     6     2, 5,
     7     1, 2,
     8     2, 6,
     9     3, 6,
     X     1, 6,
     1     1, 5,
     2     3, 5 /

      data ((face2edge(i, j), j = 1, 4), i = 1, faces) /
     1     2, 11, 7, 10,
     2     7, 6, 5, 8,
     3     4, 9, 5, 12,
     4     1, 4, 3, 2,
     5     3, 12, 6, 11,
     6     1, 10, 8, 9 /

c     initialize output values

      code = 0
      value = 0

c     store node values and coordinates

      n = 0
      do i = 1, 2
         do j = 1, 2
            do k = 1, 2
               n = n + 1
               v(n) = c(i, j, k)
               if (i .eq. 1) then
                  coordinate(n, 1) = 0
               else
                  coordinate(n, 1) = h(1)
               endif
               if (j .eq. 1) then
                  coordinate(n, 2) = 0
               else
                  coordinate(n, 2) = h(2)
               endif
               if (k .eq. 1) then
                  coordinate(n, 3) = 0
               else
                  coordinate(n, 3) = h(3)
               endif
            enddo
         enddo
      enddo

c     mark the cut edges and find the cut points

      start = 0
      do edge = 1, edges
         n1 = edge2corner(edge, 1)
         n2 = edge2corner(edge, 2)
         v1 = v(n1)
         v2 = v(n2)
         cut(edge) =
     &        (v1 .lt. c0 .and. c0 .lt. v2) .or.
     &        (v2 .lt. c0 .and. c0 .lt. v1)

         if (cut(edge)) then
            start = edge
            do p = 1, 3
               point(edge, p) =
     &              coordinate(n1, p) * abs ((v1 - c0) / (v1 - v2)) +
     &              coordinate(n2, p) * abs ((c0 - v2) / (v1 - v2))
            enddo
         endif
      enddo

c     exit if there are no cut edges

      if (start .eq. 0) go to 99999

c     make a list of cut edges by traversing the faces

      cutedges = 1
      edgelist(cutedges) = start
      currentedge = start
      currentface = edge2face(currentedge, 1)

 1100 continue
      count = 0
      nextedge = 0
      do i = 1, 4
         edge = face2edge(currentface, i)
         if (cut(edge) .and. .not. (edge .eq. currentedge)) then
            count = count + 1
            nextedge = edge
         endif
      enddo

      if (count .ne. 1) then
c        some face has other than 0 or 2 cut edges
         code = 1
         go to 99999
      endif

      if (nextedge .ne. edgelist(1)) then
         if (currentface .eq. edge2face(nextedge, 1)) then
            currentface = edge2face(nextedge, 2)
         else
            currentface = edge2face(nextedge, 1)
         endif
         currentedge = nextedge
         cutedges = cutedges + 1
         edgelist(cutedges) = currentedge
         go to 1100
      endif

      count = 0
      do edge = 1, edges
         if (cut(edge)) then
            count = count + 1
         endif
      enddo

      if (count .ne. cutedges) then
c        the traverse omits some cut edges
         code = 2
         go to 99999
      endif

c     sum the triangular areas

      edge = edgelist(1)
      x0 = point(edge, 1)
      y0 = point(edge, 2)
      z0 = point(edge, 3)
      do i = 2, cutedges - 1
         edge = edgelist(i)
         x1 = point(edge, 1) - x0
         y1 = point(edge, 2) - y0
         z1 = point(edge, 3) - z0
         edge = edgelist(i + 1)
         x2 = point(edge, 1) - x0
         y2 = point(edge, 2) - y0
         z2 = point(edge, 3) - z0
         temp = sqrt ( abs (
     &        x2**2*y1**2 - 2*x1*x2*y1*y2 + x1**2*y2**2 +
     &        x2**2*z1**2 + y2**2*z1**2 - 2*x1*x2*z1*z2 -
     &        2*y1*y2*z1*z2 + x1**2*z2**2 + y1**2*z2**2)) / 2
         value = value + temp
      enddo

c     exit

99999 continue
      end

      subroutine temparea(T,Tlev,delta,Area)

      REAL_T T(2,2,2),Tlev
      REAL_T delta(3),Area


      REAL_T axp,axm,ayp,aym,azp,azm

      REAL_T facearea,t11,t12,t21,t22,dx,dy,dz

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


      t11 = T(1,1,1)
      t21 = T(2,1,1)
      t12 = T(1,2,1)
      t22 = T(2,2,1)

      azm = facearea(t11,t21,t12,t22,dx,dy,Tlev)

      t11 = T(1,1,2)
      t21 = T(2,1,2)
      t12 = T(1,2,2)
      t22 = T(2,2,2)

      azp = facearea(t11,t21,t12,t22,dx,dy,Tlev)

      t11 = T(1,1,1)
      t21 = T(1,2,1)
      t12 = T(1,1,2)
      t22 = T(1,2,2)

      axm = facearea(t11,t21,t12,t22,dy,dz,Tlev)

      t11 = T(2,1,1)
      t21 = T(2,2,1)
      t12 = T(2,1,2)
      t22 = T(2,2,2)

      axp = facearea(t11,t21,t12,t22,dy,dz,Tlev)

      t11 = T(1,1,1)
      t21 = T(2,1,1)
      t12 = T(1,1,2)
      t22 = T(2,1,2)

      aym = facearea(t11,t21,t12,t22,dy,dz,Tlev)

      t11 = T(1,2,1)
      t21 = T(2,2,1)
      t12 = T(1,2,2)
      t22 = T(2,2,2)

      ayp = facearea(t11,t21,t12,t22,dy,dz,Tlev)

      Area = dsqrt((azp-azm)**2+ (ayp-aym)**2 + (axp-axm)**2)

      return
      end

      REAL_T function facearea(t11,t21,t12,t22,
     1           dx,dy,Tlev)

      REAL_T t11,t12,t21,t22,dx,dy,Tlev

      REAL_T lengless,lengmore
      REAL_T edge1,edge2,edge3,edge4

      if(t11.gt.Tlev)then
        if(t21.gt.Tlev)then
          if(t12.gt.Tlev)then
            if(t22.gt.Tlev)then
              facearea = dx*dy
            else
              edge1=lengless(t12,t22,Tlev,dx)
              edge2=lengless(t21,t22,Tlev,dy)
              facearea = dx*dy-edge1*edge2*half
            endif
          else
            if(t22.gt.Tlev)then
              edge1=lengless(t12,t22,Tlev,dx)
              edge2=lengless(t11,t12,Tlev,dy)
              facearea = dx*dy-edge1*edge2*half
            else
              edge1=lengmore(t21,t22,Tlev,dy)
              edge2=lengmore(t11,t12,Tlev,dy)
              facearea = dx*(edge1+edge2)*half
            endif
          endif
        else
          if(t12.gt.Tlev)then
            if(t22.gt.Tlev)then
              edge1=lengless(t11,t21,Tlev,dx)
              edge2=lengless(t21,t22,Tlev,dy)
              facearea = dx*dy-edge1*edge2*half
            else
              edge1=lengmore(t11,t21,Tlev,dx)
              edge2=lengmore(t12,t22,Tlev,dx)
              facearea = dy*half*(edge1+edge2)
            endif
          else
            if(t22.gt.Tlev)then
              edge1=lengmore(t11,t21,Tlev,dx)
              edge2=lengmore(t21,t22,Tlev,dy)
              edge3=lengmore(t12,t22,Tlev,dx)
              edge4=lengmore(t11,t12,Tlev,dy)
              facearea = half*(edge1*edge4+edge2*edge3)
            else
              edge1=lengmore(t11,t21,Tlev,dx)
              edge2=lengmore(t11,t12,Tlev,dy)
              facearea = half*edge1*edge2
            endif
          endif
        endif
      else
        if(t21.gt.Tlev)then
          if(t12.gt.Tlev)then
            if(t22.gt.Tlev)then
              edge1=lengmore(t11,t21,Tlev,dx)
              edge2=lengmore(t11,t12,Tlev,dy)
              facearea = dx*dy-half*edge1*edge2
            else
              edge1=lengmore(t11,t21,Tlev,dx)
              edge2=lengmore(t21,t22,Tlev,dy)
              edge3=lengmore(t12,t22,Tlev,dx)
              edge4=lengmore(t11,t12,Tlev,dy)
              facearea = dx*dy-half*(edge1*edge4+edge2*edge3)
            endif
          else
            if(t22.gt.Tlev)then
              edge1=lengmore(t11,t21,Tlev,dx)
              edge2=lengmore(t12,t22,Tlev,dx)
              facearea = dy*half*(edge1+edge2)
            else
              edge1=lengmore(t11,t21,Tlev,dx)
              edge2=lengmore(t21,t22,Tlev,dy)
              facearea = half*edge1*edge2
            endif
          endif
        else
          if(t12.gt.Tlev)then
            if(t22.gt.Tlev)then
              edge1=lengmore(t21,t22,Tlev,dy)
              edge2=lengmore(t11,t12,Tlev,dy)
              facearea = dx*(edge1+edge2)*half
            else
              edge1=lengmore(t12,t22,Tlev,dx)
              edge2=lengmore(t11,t12,Tlev,dy)
              facearea = half*edge1*edge2
            endif
          else
            if(t22.gt.Tlev)then
              edge1=lengmore(t12,t22,Tlev,dx)
              edge2=lengmore(t21,t22,Tlev,dy)
              facearea = half*edge1*edge2
            else
              facearea = zero
            endif
          endif
        endif
      endif
      
      return
      end

      REAL_T function lengless(t1,t2,Tlev,dx)
      REAL_T t1,t2,Tlev,dx
      if(t1.lt.Tlev)then
           lengless = (TLev -t1)*dx/(t2-t1)
      else
           lengless = (TLev -t2)*dx/(t1-t2)
      endif
      return
      end

      REAL_T function lengmore(t1,t2,Tlev,dx)
      REAL_T  t1,t2,Tlev,dx
      if(t1.lt.Tlev)then
           lengmore = dx -(TLev -t1)*dx/(t2-t1)
      else
           lengmore = dx - (TLev -t2)*dx/(t1-t2)
      endif
      return
      end
