!     Author:  S.J. Mosso

!     Last change:  SJM  March 27 2005
!     Corrected problem where grazing plane-polyhedra intersections
!     in PLANE_POLY_INT3D resulted in '... facial edge not found...'

MODULE overlap_module

  IMPLICIT NONE

  SAVE

   ! number of spatial dimensions
   INTEGER, PARAMETER :: ndim = 3

   ! number of vector dimensions
   INTEGER, PARAMETER :: mdim = 3

!   INTEGER, PARAMETER :: RK = 8
   INTEGER, PARAMETER :: RK = KIND(1.0d0)

   REAL(RK), PARAMETER :: S0   =   0.0_RK
   REAL(RK), PARAMETER :: S1   =   1.0_RK
   REAL(RK), PARAMETER :: S2   =   2.0_RK
   REAL(RK), PARAMETER :: S6   =   6.0_RK
   REAL(RK), PARAMETER :: S100 = 100.0_Rk
   REAL(RK), PARAMETER :: F1o2 = S1 / S2
   REAL(RK), PARAMETER :: F1o6 = S1 / S6

   ! Define a 'special' number of undefined
   REAL(RK), PARAMETER :: undef = 123451234._RK

   ! Define a small number
   REAL(RK), PARAMETER :: small = 1.e-10_RK

   INTEGER, PARAMETER :: maxFaces = 18
   INTEGER, PARAMETER :: maxCrnrs = 50
   INTEGER, PARAMETER :: maxCperF =  8
   INTEGER, PARAMETER :: maxEperF = 10
   INTEGER, PARAMETER :: maxEperV =  8
   INTEGER, PARAMETER :: maxEdges = 30

  TYPE vector_type
     REAL(RK), DIMENSION(mdim) :: x
  END TYPE vector_type

  TYPE(vector_type), PARAMETER :: vector_undef = &
                     vector_type( (/ UNDEF,UNDEF,UNDEF /) )
  TYPE(vector_type), PARAMETER :: Origin = &
                     vector_type ( (/ 0.0_RK, 0.0_RK, 0.0_RK /) )

  TYPE PLANE_TYPE
     TYPE(VECTOR_TYPE) :: n
     REAL(RK)          :: p
  END TYPE PLANE_TYPE

  TYPE (PLANE_TYPE), PARAMETER :: Plane_Undef = &
          PLANE_TYPE ( VECTOR_UNDEF, HUGE( S1 ) )

  TYPE poly3D_type
     INTEGER                                         :: numCrnr
     TYPE(VECTOR_TYPE), DIMENSION(maxCrnrs)          :: Crnr
     INTEGER                                         :: numFaces
     INTEGER                                         :: numEdges
     INTEGER,           DIMENSION(         maxFaces) :: nEdgeofFace
     INTEGER,           DIMENSION(maxEperF,maxFaces) :: EdgeofFace
     INTEGER,           DIMENSION(   2    ,maxEdges) :: CrnrofEdge
     INTEGER,           DIMENSION(         maxCrnrs) :: nEdgeofCrnr
     INTEGER,           DIMENSION(maxEperV,maxCrnrs) :: EdgeofCrnr
  END TYPE poly3D_type

  INTEGER :: ic_undef

  TYPE(POLY3D_TYPE), PARAMETER :: POLY3D_Init = POLY3D_TYPE( 0,  &
                       (/ (VECTOR_UNDEF,ic_undef=1,maxCrnrs) /), &
                                                              0, &
                                                              0, &
                       (/ (0,           ic_undef=1,maxFaces) /), &
              RESHAPE( (/ (0,  ic_undef=1,maxEperF*maxFaces) /), &
                       (/ maxEperF,maxFaces /)                ), &
              RESHAPE( (/ (0,  ic_undef=1,    2   *maxEdges) /), &
                       (/    2    ,maxEdges /)                ), &
                       (/ (0,           ic_undef=1,maxCrnrs) /), &
              RESHAPE( (/ (0,  ic_undef=1,maxEperV*maxCrnrs) /), &
                       (/ maxEperV,maxCrnrs /)                )  )

  INTERFACE Plane_Poly_Int
     MODULE PROCEDURE Plane_Poly_Int3D
  END INTERFACE

  INTERFACE Poly_Poly_Int
     MODULE PROCEDURE Poly_Poly_Int3D
  END INTERFACE

  INTERFACE ASSIGNMENT (=)
     MODULE PROCEDURE Poly3D_2_Poly3D
  END INTERFACE

  INTERFACE Volume_Poly
     MODULE PROCEDURE volm_Poly3D
  END INTERFACE

  INTERFACE OPERATOR (-)
     MODULE PROCEDURE negate_vector
     MODULE PROCEDURE negate_vector_array
     MODULE PROCEDURE subtract_vector
  END INTERFACE

  INTERFACE OPERATOR (+)
     MODULE PROCEDURE add_vector
  END INTERFACE

  INTERFACE OPERATOR (*)
     MODULE PROCEDURE scalar_mult_vector
     MODULE PROCEDURE vector_mult_scalar
     MODULE PROCEDURE vector_dot_vector
  END INTERFACE

  INTERFACE OPERATOR (/)
     MODULE PROCEDURE vector_div_scalar
  END INTERFACE

  INTERFACE ABS
     MODULE PROCEDURE abs_of_vector
  END INTERFACE

  INTERFACE ASSIGNMENT (=)
     MODULE PROCEDURE Vector_2_Vector
  END INTERFACE

CONTAINS

   SUBROUTINE Vol_Poly_Poly_Int (Tet, Hex, Vol)

   IMPLICIT NONE

   TYPE(POLY3D_TYPE), INTENT(IN)  :: Tet
   TYPE(POLY3D_TYPE), INTENT(IN)  :: Hex
   REAL(RK),          INTENT(OUT) :: Vol

   !------------------------------------------------------------------

   TYPE(POLY3D_TYPE) :: Int

   !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

   call Poly_Poly_Int3D (Tet, Hex, Int)
   Vol = Volm_Poly3D (Int)

   END SUBROUTINE Vol_Poly_Poly_Int

   SUBROUTINE Poly_Poly_Int3D (Poly1, Poly2, Int)

   IMPLICIT NONE

   TYPE(POLY3D_TYPE), INTENT(IN)  :: Poly1
   TYPE(POLY3D_TYPE), INTENT(IN)  :: Poly2
   TYPE(POLY3D_TYPE), INTENT(OUT) :: Int

   !------------------------------------------------------------------

   INTEGER :: f
   TYPE(plane_type) :: facet1
   INTEGER :: ie1, ie2, iP1, iP2, iP3
   TYPE(vector_type) :: P1, P2, P3
   TYPE(POLY3D_TYPE) :: Tmp

   !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

   Tmp = Poly2
   do f = 1, Poly1%numFaces

     ie1 = Poly1%EdgeofFace(1,f)
     ie2 = Poly1%EdgeofFace(2,f)
     call Get_Edge_Crnrs (Poly1, ie1, iP1, iP2)
     call Get_Edge_Crnrs (Poly1, ie2, iP2, iP3)

     P1 = Poly1%Crnr(iP1)
     P2 = Poly1%Crnr(iP2)
     P3 = Poly1%Crnr(iP3)

     facet1 = Plane_from_Points (P1, P2, P3)

     call Plane_Poly_Int3D (facet1, Tmp, Int)

     if (Int%numCrnr < 4) then
       EXIT
     else
       Tmp = Int
     end if
   end do

   END SUBROUTINE poly_poly_int3D

    SUBROUTINE PLANE_POLY_INT3D (plane, Poly, Int)

    !==================================================================
    !  This subroutine calculates the vertices of a polygon, Poly, that
    !  define the portion of the polygon that lies behind plane.
    !==================================================================

    IMPLICIT NONE

    TYPE(plane_type),  INTENT(IN)    :: plane
    TYPE(poly3D_type), INTENT(IN)    :: Poly
    TYPE(poly3D_type), INTENT(INOUT) :: Int

    !------------------------------------------------------------------

    REAL(RK), DIMENSION(maxCrnrs) :: CrnrDist, fDist
    REAL(RK) :: maxDist, minDist
    INTEGER :: c, f, e

    TYPE(VECTOR_TYPE) :: Crnr
    INTEGER :: n, nCrnr

    INTEGER                      :: iP1, iP2, ie
    TYPE(vector_type)            :: P1, P2, Vint
    REAL(RK)                     :: dP1, dP2

    INTEGER, DIMENSION(maxCrnrs) :: newCrnr
    INTEGER, DIMENSION(maxEdges) :: newEdge, facet_newEdge
    INTEGER :: newC, newE, last_newE, numE, nOrigC
    INTEGER :: nEdgeBehind

    INTEGER :: PolyiP1, PolyiP2
    INTEGER :: IntiP1, IntiP2, last_IntiP1, last_IntiP2
    INTEGER :: oldE, last_oldE, Polyf, Intf
    INTEGER :: ie1, et, nleft, efrst

    INTEGER, DIMENSION(maxEperV,MaxCrnrs) :: EdgeofCrnr
    INTEGER, DIMENSION(maxEperF,maxFaces) :: EdgeofFace
    LOGICAL :: lError

    !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

    Int = POLY3D_Init

    newCrnr = 0
    newEdge = 0

    ! Compute each of Poly's corners'
    ! signed distance from the plane.
    call Poly_Crnr_Plane_Dist (Poly, plane, CrnrDist)

    nCrnr   = Poly%numCrnr
    maxDist = MAXVAL( CrnrDist(1:nCrnr) )
    minDist = MINVAL( CrnrDist(1:nCrnr) )

    if (maxDist <= S0) then

      ! If all corners of Poly are behind the plane,
      ! return Poly as the intersection.
      Int = Poly
      RETURN

    ELSEIF (minDist >= S0) then

      ! If all corners of Poly are in front of the plane,
      ! return an empty Polyhedra as the intersection.
      RETURN

    end if

    ! Some of Poly is behind Plane and some of Poly
    ! is in-front of Plane. Intersect Poly with Plane
    ! and store the portion behind or on Plane in
    ! the intersection polyhedron, Int.

    ! Loop over Poly's corners. If they reside
    ! behind or on the plane, assign them
    ! corner storage in the intersection polygon.
    newC = 0
    do c = 1, Poly%numCrnr
      if (CrnrDist(c) <= S0) then
        call Store_Poly_Crnr (Int, Poly%Crnr(c), newC)
        newCrnr(c)     = newC
      end if
    end do
    Int%numCrnr = newC

    ! The corners that existed in Poly, also
    ! exist in Int from Corner(1:nOrigC).
    ! Intersection corners will be
    ! stored following these.
    nOrigC = newC

    ! Loop over Poly's edges. If they reside
    ! behind or on the plane, assign them
    ! edge storage in the intersection polygon.
    newE            = 0
    Int%nEdgeofCrnr = 0
    do e = 1, Poly%numEdges

      call Get_Edge_Crnrs (Poly, e, PolyiP1, PolyiP2)

      if (CrnrDist(PolyiP1) <= S0) then
        if (CrnrDist(PolyiP2) <= S0) then

          ! The entire edge is behind the plane.
          ! Store the entire edge in the intersection Poly.
          IntiP1     = newCrnr(PolyiP1)
          IntiP2     = newCrnr(PolyiP2)
          call Store_Poly_Edge (Int, IntiP1, IntiP2, iE)
          newE       = iE
          newEdge(e) = iE

        else if (CrnrDist(PolyiP1) < S0) then

          ! The edge intersects the plane. Compute the
          ! intersection point, add it to Int's list
          ! of corners and store this modified edge in Int.
          newE = newE + 1

          P1   = Poly%Crnr(PolyiP1)
          P2   = Poly%Crnr(PolyiP2)
          dP1  = CrnrDist(PolyiP1)
          dP2  = CrnrDist(PolyiP2)
          call Edge_IntwPlane (P1, dP1, P2, dP2, Vint)

          ! add the intersection point
          ! to Int's list of corners
          call Store_Poly_Crnr (Int, Vint, IntiP2)
          IntiP1     = newCrnr(PolyiP1)
          newC       = IntiP2

          ! Store the edge in Int's edge list.
          call Store_Poly_Edge (Int, IntiP1, IntiP2, iE)

          newE       = iE
          newEdge(e) = iE

        end if

      elseif (CrnrDist(PolyiP2) < S0) then

        ! The edge intersects the plane.
        ! Compute the intersection point,
        P1   = Poly%Crnr(PolyiP1)
        P2   = Poly%Crnr(PolyiP2)
        dP1  = CrnrDist(PolyiP1)
        dP2  = CrnrDist(PolyiP2)
        call Edge_IntwPlane (P1, dP1, P2, dP2, Vint)

        ! add the intersection point
        ! to Int's list of corners
        call Store_Poly_Crnr (Int, Vint, IntiP1)
        IntiP2     = newCrnr(PolyiP2)
        newC       = IntiP1

        ! Store the edge in Int's edge list.
        call Store_Poly_Edge (Int, IntiP1, IntiP2, iE)

        newE       = iE
        newEdge(e) = iE

      end if
    end do

    ! Examine each face of Poly. If all or part of
    ! the face lies behind the plane, store the
    ! proper portion of the face in Int.
    do Polyf = 1,Poly%numFaces

      ! If more than a single edge of face Polyf of Poly
      ! lies behind the plane, store the face in Int.
      ! Form a list of the edges for this facet
      ! that are on or behind the plane.
      nEdgeBehind   = 0
      facet_newEdge = 0
      do e = 1, Poly%nEdgeofFace(Polyf)
        oldE = Poly%EdgeofFace(e,Polyf)
        if (oldE > 0) then
          ie = newEdge(oldE)
        else
          ie = -newEdge(-oldE)
        end if
        if (ie /= 0) then
          nEdgeBehind                = nEdgeBehind + 1
          facet_newEdge(nEdgeBehind) = ie
        end if
      end do

      if (nEdgeBehind > 1) then
        ! This face comprises a part of Poly
        ! behind the plane. Associate the
        ! edge with this face in the
        ! intersection polyhedra, Int.
        ! If the plane cuts through the face,
        ! a new edge will be created. This
        ! new edge will extend from iPI1 to
        ! iPI2.

        ! Allocate the face in Int.
        Intf         = Int%numFaces + 1
        Int%numFaces = Intf
        if (Intf > maxFaces) then
          write (*,*) 'ERROR PLANE_POLY_INT3D: Too many faces'
          STOP
        end if

        ! We have formed a list of the edges for this face
        ! that are already stored in the polyhedra Int.
        ! These edges now will be associated with this
        ! facet of Int. There may be an intersection edge
        ! that cuts across the facet in the input polyhedra.
        ! This cut will become a new edge. To check for
        ! this cut edge, check that the starting and
        ! ending vertices are the same. If they are
        ! different, a cut edge should be constructed
        ! that connects these two vertices.
        last_newE = facet_newEdge(nEdgeBehind)
        call Get_Edge_Crnrs (Int,  last_newE, last_IntiP1, last_IntiP2)

        do e = 1, nEdgeBehind

          newE = facet_newEdge(e)    ! the edge in Poly

          if (newE == 0) then
            ! The edge is not part of the intersection.
            ! This is an error because the edges that
            ! are part of the intersection have been
            ! compressed in a loop above.
            write (*,*) 'ERROR PLANE_POLY_INT3D: Compressed list '// &
                        'facet_oldedge contains a zero'
            STOP
          end if

          call Get_Edge_Crnrs (Int,  newE, IntiP1,  IntiP2)

          ! Is there an intersection edge cutting across the
          ! Poly face?
          if (IntiP1 /= last_IntiP2) then
              call Store_Poly_Edge (Int, last_IntiP2, IntiP1, iE)
              call Store_Poly_Edge_of_Face (Int, iE, Intf)
          end if

          ! Store this edge
          call Store_Poly_Edge_of_Face (Int, newE, Intf)

          last_IntiP1 = IntiP1
          last_IntiP2 = IntiP2

        end do

      end if
    enddo

    ! If the plane intersected the polygon at other than a single point,
    ! there is an intersection face that needs to be constructed in Int.
    ! This face is composed of the unpaired edges in Int. For instance,
    ! most edges +iE and -iE will be a part of adjacent faces of Int.
    ! We will compose the intersection face by eliminating all paired
    ! edges. Only the intersection face will remain.
    EdgeofCrnr (1:maxEperV,1:maxCrnrs) = Int%EdgeofCrnr (1:maxEperV,1:maxCrnrs)
    EdgeofFace (1:maxEperF,1:maxFaces) = Int%EdgeofFace (1:maxEperF,1:maxFaces)
    do f = 1, Int%numFaces
      do e = 1, Int%nEdgeofFace(f)

        ! Grab an edge of Int that is part of face f
        ! and its endpoints.
        ie1 = EdgeofFace(e,f)
        call Get_Edge_Crnrs (Int, ie1, iP1, iP2)

        ! Delete the edge from the list of edges
        ! emanating from iP1
        lError = .TRUE.
        do et = 1, Int%nEdgeofCrnr(iP1)
          if (EdgeofCrnr(et,iP1) == ie1) then
            EdgeofCrnr(et,iP1) = 0
            lError             = .FALSE.
            EXIT
          end if
        end do

        if (lError) then
          write (*,*) 'ERROR PLANE_POLY_INT3D: facial edge not found at start corner'
          write (*,*) 'Input Poly is: '
          call Print_Poly (Poly)
          write (*,*) ' '
          write (*,*) 'Current Intersection Poly is:'
          call Print_Poly (Int)
          STOP
        end if

      end do
    end do

    do
      ! If any edges remain in the list, arrange their
      ! opposites into the intersection face.
      nleft = 0
      efrst = 0
      do c = 1, Int%numCrnr
        do e = 1, Int%nEdgeofCrnr(c)
          if (EdgeofCrnr(e,c) /= 0) then
            nleft = nleft + 1
            efrst = EdgeofCrnr(e,c)
          end if
        end do
      end do

      if (nleft == 0) EXIT

      f            = Int%numFaces + 1
      Int%numFaces = f
      if (f > maxFaces) then
        write (*,*) 'ERROR PLANE_POLY_INT3D: maxFaces too small'
        STOP
      end if
      ie1 = efrst
      call Store_Poly_Edge_of_Face (Int, ie1, f)
      do c = 1, nleft-1
        call Get_Edge_Crnrs (Int, ie1, iP1, iP2)
        do e = 1, INT%nEdgeofCrnr(iP2)
          if (EdgeofCrnr(e,iP2) /= 0) then
            ie1 = EdgeofCrnr(e,iP2)
            CYCLE
          end if
        end do
        if (ie1 /= efrst) then
          call Store_Poly_Edge_of_Face (Int, ie1, f)
        else
          EXIT
        endif
      enddo

      ! We've closed the face. Zero the edges we've used
      ! in constructing this face.
      do iE = 1, Int%nEdgeofFace(f)
        ie1 = Int%EdgeofFace(iE,f)
        call Get_Edge_Crnrs (Int, ie1, iP1, iP2)
        lError = .TRUE.
        do n = 1, Int%nEdgeofCrnr(iP1)
          if (EdgeofCrnr(n,iP1) == ie1) then
            EdgeofCrnr(n,iP1) = 0
            lError = .FALSE.
            EXIT
          endif
        enddo
        if (lError) then
          write (*,*) 'ERROR PLANE_POLY_INT3D: Lost the edge trail!'
          STOP
        endif
      enddo
    enddo

    END SUBROUTINE PLANE_POLY_INT3D

   SUBROUTINE Poly_Crnr_Plane_Dist (Poly, plane, CrnrDist)

  !==================================================================
  ! This routine is passed a three-dimensional Polyhedra, Poly, and
  ! a plane. It calculates the signed distance of each corner in
  ! Poly from the plane.
  !==================================================================

   IMPLICIT NONE

   TYPE(Poly3D_Type),               INTENT(IN)    :: Poly
   TYPE(Plane_Type),                INTENT(IN)    :: plane
   REAL(RK),          DIMENSION(:), INTENT(INOUT) :: CrnrDist

   !------------------------------------------------------------------

   INTEGER :: Size_of_Dist
   INTEGER :: c, nCrnr

   !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

   Size_of_Dist = SIZE( CrnrDist )
   if (Size_of_Dist < Poly%numCrnr) then
     write (*,*) 'ERROR Poly_Plane_Dist: not enough entries in CrnrDist'
     STOP
   end if

   CrnrDist(1:Size_of_Dist) = S0
   nCrnr                    = Poly%numCrnr
   do c = 1, nCrnr
     CrnrDist(c) = Point_Dist_Plane (Poly%Crnr(c), plane)
   end do

   END SUBROUTINE Poly_Crnr_Plane_Dist

   SUBROUTINE Edge_IntwPlane (P1, dP1, P2, dP2, Vint)

   IMPLICIT NONE

   TYPE(vector_type), INTENT(IN)  :: P1
   REAL(RK),          INTENT(IN)  :: dP1
   TYPE(vector_type), INTENT(IN)  :: P2
   REAL(RK),          INTENT(IN)  :: dP2
   TYPE(vector_type), INTENT(OUT) :: Vint

   !------------------------------------------------------------------

   REAL(RK) :: small_dist
   REAL(RK) :: dsign, denom, frac

   !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

!   small_dist = S100 * SPACING( S1 )
   small_dist = 0.0_RK

   ! Avoid roundoff by picking the point closest to the plane.
   if (ABS( dP2 ) < ABS( dP1 )) then
     denom = dP1 - dP2
     dsign = SIGN( S1, denom )
     denom = MAX( ABS(denom), small_dist )
     denom = dsign * denom
     frac  = -dP2 / denom
     Vint  = P2 + frac * (P1 - P2)
   else
     denom = dP2 - dP1
     dsign = SIGN( S1, denom )
     denom = MAX( ABS(denom), small_dist )
     denom = dsign * denom
     frac  = -dP1 / denom
     Vint  = P1 + frac * (P2 - P1)
   end if

   END SUBROUTINE Edge_IntwPlane

  TYPE(Poly3D_Type) FUNCTION Load_Tet (Th1, Th2, Th3, Th4)

  TYPE(VECTOR_TYPE), INTENT(IN) :: Th1, Th2, Th3, Th4

  Load_Tet = Poly3D_Init

  Load_Tet%numCrnr = 4
  Load_Tet%Crnr(1) = Th1
  Load_Tet%Crnr(2) = Th2
  Load_Tet%Crnr(3) = Th3
  Load_Tet%Crnr(4) = Th4

  Load_Tet%numFaces = 4
  Load_Tet%numEdges = 6

  Load_Tet%nEdgeofFace(1:4) = 3

  Load_Tet%EdgeofFace(1:3,1) = (/  1,  5, -4 /)
  Load_Tet%EdgeofFace(1:3,2) = (/  2,  6, -5 /)
  Load_Tet%EdgeofFace(1:3,3) = (/  3,  4, -6 /)
  Load_Tet%EdgeofFace(1:3,4) = (/ -1, -3, -2 /)

  Load_Tet%CrnrofEdge(1:2,1) = (/ 1, 2 /)
  Load_Tet%CrnrofEdge(1:2,2) = (/ 2, 3 /)
  Load_Tet%CrnrofEdge(1:2,3) = (/ 3, 1 /)
  Load_Tet%CrnrofEdge(1:2,4) = (/ 1, 4 /)
  Load_Tet%CrnrofEdge(1:2,5) = (/ 2, 4 /)
  Load_Tet%CrnrofEdge(1:2,6) = (/ 3, 4 /)

  Load_Tet%nEdgeofCrnr(1:4)  = 3

  Load_Tet%EdgeofCrnr(1:3,1) = (/  1, -3,  4 /)
  Load_Tet%EdgeofCrnr(1:3,2) = (/  2, -1,  5 /)
  Load_Tet%EdgeofCrnr(1:3,3) = (/  3, -2,  6 /)
  Load_Tet%EdgeofCrnr(1:3,4) = (/ -4, -5, -6 /)

  END FUNCTION Load_Tet

  TYPE(Poly3D_Type) FUNCTION Load_Hex (Hx1, Hx2, Hx3, Hx4, &
                                       Hx5, Hx6, Hx7, Hx8)

  TYPE(VECTOR_TYPE), INTENT(IN) :: Hx1, Hx2, Hx3, Hx4
  TYPE(VECTOR_TYPE), INTENT(IN) :: Hx5, Hx6, Hx7, Hx8

  Load_Hex = Poly3D_Init

  Load_Hex%numCrnr = 8

  Load_Hex%Crnr(1) = Hx1
  Load_Hex%Crnr(2) = Hx2
  Load_Hex%Crnr(3) = Hx3
  Load_Hex%Crnr(4) = Hx4
  Load_Hex%Crnr(5) = Hx5
  Load_Hex%Crnr(6) = Hx6
  Load_Hex%Crnr(7) = Hx7
  Load_Hex%Crnr(8) = Hx8

  Load_Hex%numFaces =  6
  Load_Hex%numEdges = 12

  Load_Hex%nEdgeofFace(1:6) = 4

  Load_Hex%EdgeofFace(1:4,1) = (/   3,   2,  -4,  -1 /)
  Load_Hex%EdgeofFace(1:4,2) = (/   5,   8,  -6,  -7 /)
  Load_Hex%EdgeofFace(1:4,3) = (/   1,  11,  -5,  -9 /)
  Load_Hex%EdgeofFace(1:4,4) = (/  10,   6, -12,  -2 /)
  Load_Hex%EdgeofFace(1:4,5) = (/   9,   7, -10,  -3 /)
  Load_Hex%EdgeofFace(1:4,6) = (/   4,  12,  -8, -11 /)

  Load_Hex%CrnrofEdge(1:2, 1) = (/ 1, 2 /)
  Load_Hex%CrnrofEdge(1:2, 2) = (/ 4, 3 /)
  Load_Hex%CrnrofEdge(1:2, 3) = (/ 1, 4 /)
  Load_Hex%CrnrofEdge(1:2, 4) = (/ 2, 3 /)
  Load_Hex%CrnrofEdge(1:2, 5) = (/ 5, 6 /)
  Load_Hex%CrnrofEdge(1:2, 6) = (/ 8, 7 /)
  Load_Hex%CrnrofEdge(1:2, 7) = (/ 5, 8 /)
  Load_Hex%CrnrofEdge(1:2, 8) = (/ 6, 7 /)
  Load_Hex%CrnrofEdge(1:2, 9) = (/ 1, 5 /)
  Load_Hex%CrnrofEdge(1:2,10) = (/ 4, 8 /)
  Load_Hex%CrnrofEdge(1:2,11) = (/ 2, 6 /)
  Load_Hex%CrnrofEdge(1:2,12) = (/ 3, 7 /)

  Load_Hex%nEdgeofCrnr( 1:8) = 3

  Load_Hex%EdgeofCrnr(1:3,1) = (/   1,   3,   9 /)
  Load_Hex%EdgeofCrnr(1:3,2) = (/  -1,   4,  11 /)
  Load_Hex%EdgeofCrnr(1:3,3) = (/  -4,  -2,  12 /)
  Load_Hex%EdgeofCrnr(1:3,4) = (/   2,  -3,  10 /)
  Load_Hex%EdgeofCrnr(1:3,5) = (/   5,   7,  -9 /)
  Load_Hex%EdgeofCrnr(1:3,6) = (/  -5,   8, -11 /)
  Load_Hex%EdgeofCrnr(1:3,7) = (/  -6,  -8, -12 /)
  Load_Hex%EdgeofCrnr(1:3,8) = (/  -7,   6, -10 /)

  END FUNCTION Load_Hex

  SUBROUTINE Get_Edge_Crnrs (Poly, iE, iP1, iP2)

  IMPLICIT NONE

  !==================================================================
  ! A Three-Dimensional Polyhedra, Poly, is passed to this routine.
  ! iE is an edge index in Poly. This routine returns the starting
  ! and ending corner indices of the edge.
  !==================================================================

  TYPE(Poly3D_Type), INTENT(IN)  :: Poly
  INTEGER,           INTENT(IN)  :: iE
  INTEGER,           INTENT(OUT) :: iP1, iP2

  !------------------------------------------------------------------
  !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  if (ABS( iE ) > Poly%numEdges .OR. iE == 0) then
    write (*,*) 'ERROR GET_EDGE_CRNRS: illegal edge number passed in'
    STOP
  end if

  if (iE > 0) then
    iP1 = Poly%CrnrofEdge(1,iE)
    iP2 = Poly%CrnrofEdge(2,iE)
  else
    iP1 = Poly%CrnrofEdge(2,-iE)
    iP2 = Poly%CrnrofEdge(1,-iE)
  end if

  END SUBROUTINE Get_Edge_Crnrs

  SUBROUTINE Store_Poly_Crnr (Poly, C, iP)

  IMPLICIT NONE

  !==================================================================
  ! A Three-Dimensional Polyhedra, Poly, is passed to this routine.
  ! The position vector of acorner of the polyhedra is passed in
  ! as C. This routine stores the new Corner in Poly and returns
  ! its corner index in Poly as iP.
  !
  ! It is assumed that the corner DOES NOT currently exist in Poly.
  ! If it is possible that the corner already exists in Poly, a more
  ! extensive routine should be used that will check for the it's
  ! existence before storing it.
  !
  !==================================================================

  TYPE(Poly3D_Type), INTENT(INOUT) :: Poly
  TYPE(Vector_Type), INTENT(IN)    :: C
  INTEGER,           INTENT(OUT)   :: iP

  !------------------------------------------------------------------

  !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  iP = Poly%numCrnr + 1
  if (iP > maxCrnrs) then
    write (*,*) 'ERROR STORE_POLY_CRNR: Parameter maxCrnrs too small'
    STOP
  end if

  Poly%numCrnr = iP

  Poly%Crnr(iP) = C

  END SUBROUTINE Store_Poly_Crnr

  SUBROUTINE Store_Poly_Edge (Poly, iP1, iP2, iE)

  IMPLICIT NONE

  !==================================================================
  ! A Three-Dimensional Polyhedra, Poly, is passed to this routine.
  ! Two edge corner indices are also passed. The edge starting
  ! index is iP1 and the ending index is iP2. This routine stores
  ! the edge in Poly and returns its edge index, iE.
  !
  !==================================================================

  TYPE(Poly3D_Type), INTENT(INOUT) :: Poly
  INTEGER,           INTENT(IN)    :: iP1
  INTEGER,           INTENT(IN)    :: iP2
  INTEGER,           INTENT(OUT)   :: iE

  !------------------------------------------------------------------

  INTEGER :: e, numE, tiP1, tiP2

  !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  if (iP1 > Poly%numCrnr .OR. iP1 < 0) then
    write (*,*) 'ERROR STORE_POLY_EDGE: illegal starting corner index'
    STOP
  end if

  if (iP2 > Poly%numCrnr .OR. iP2 < 0) then
    write (*,*) 'ERROR STORE_POLY_EDGE: illegal ending corner index'
    STOP
  end if

  ! The edge may already exist in Poly. An economical test
  ! is to look at the edges associated with corner iP1.
  ! If any of these edges stop at iP2, return this edge
  ! as iE and don't re-store the edge in Poly.
  do e = 1, Poly%nEdgeofCrnr(iP1)

    iE = Poly%EdgeofCrnr(e,iP1)

    call Get_Edge_Crnrs (Poly, iE, tiP1, tiP2)

    if (tiP2 == iP2) then
      RETURN
    endif
  end do

  ! The edge doens't currently exist in Poly,
  ! create it.
  iE = Poly%numEdges + 1
  if (iE > maxEdges) then
    write (*,*) 'ERROR STORE_POLY_EDGE: parameter maxEdges too small'
    STOP
  end if

  Poly%numEdges = iE

  ! Store the edge in Poly's edge list.
  Poly%CrnrofEdge(1,iE) = iP1
  Poly%CrnrofEdge(2,iE) = iP2

  ! Associate the edge with the
  ! starting corner of the edge.
  numE = Poly%nEdgeofCrnr(iP1) + 1
  if (numE > maxEperV) then
    write (*,*) 'ERROR STORE_POLY_EDGE: parameter maxEperV too small'
    STOP
  end if
  Poly%nEdgeofCrnr(iP1)     = numE
  Poly%EdgeofCrnr(numE,iP1) = iE

  ! Associate the edge with the
  ! ending corner of the edge.
  numE = Poly%nEdgeofCrnr(iP2) + 1
  if (numE > maxEperV) then
    write (*,*) 'ERROR STORE_POLY_EDGE: parameter maxEperV too small'
    STOP
  end if
  Poly%nEdgeofCrnr(iP2)     = numE
  Poly%EdgeofCrnr(numE,iP2) = -iE

  END SUBROUTINE Store_Poly_Edge

  SUBROUTINE Store_Poly_Edge_of_Face (Poly, e, f)

  IMPLICIT NONE

  !==================================================================
  ! A Three-Dimensional Polyhedra, Poly, is passed to this routine.
  ! It is also passed an edge index, e, and a face index, f, for
  ! for entries in Poly. The edge e is stored as the 'next' edge
  ! in face, f.
  !
  !==================================================================

  TYPE(Poly3D_Type), INTENT(INOUT) :: Poly
  INTEGER,           INTENT(IN)    :: e
  INTEGER,           INTENT(IN)    :: f

  !------------------------------------------------------------------

  INTEGER :: n

  !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  if (Poly%numEdges < ABS( e )) then
    write (*,*) 'ERROR STORE_POLY_EDGE_OF_FACE: index of edge ',  &
                'passed is > # of edges in Poly'
    STOP
  end if
  if (Poly%numFaces < f) then
    write (*,*) 'ERROR STORE_POLY_EDGE_OF_FACE: index of face ',  &
                'passed is > # of faces in Poly'
    STOP
  end if
  if (f < 0) then
    write (*,*) 'ERROR STORE_POLY_EDGE_OF_FACE: index of face ',  &
                'passed is < 0'
    STOP
  end if

  ! Determine if the edge is already stored as part of this face.
  n = Poly%nEdgeofFace(f)
  if (n > 0) then
    if (Poly%EdgeofFace(1,f) == e .OR. &
        Poly%EdgeofFace(n,f) == e      ) then
      RETURN
    endif
  end if

  n = Poly%nEdgeofFace(f) + 1
  if (n > maxEperF) then
    write (*,*) 'ERROR STORE_POLY_EDGE_OF_FACE: too many edges ',  &
                'stored on face'
    STOP
  endif

  Poly%nEdgeofFace(  f) = n
  Poly%EdgeofFace (n,f) = e

  END SUBROUTINE Store_Poly_Edge_of_Face

  REAL(RK) FUNCTION volm_poly3D (Poly)

  !==================================================================
  ! Compute the volume of the polygon, Poly
  !==================================================================

  IMPLICIT NONE

  TYPE(POLY3D_TYPE), INTENT(IN)  :: Poly

  !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  volm_poly3D = volm_poly_3d_cart (Poly)

  END FUNCTION volm_poly3D

  REAL(RK) FUNCTION volm_poly_3d_cart (Poly)

  !==================================================================
  ! Compute the volume of the polygon for 3D in Cartesian coordinates
  !==================================================================

  IMPLICIT NONE

  TYPE(POLY3D_TYPE), INTENT(IN)  :: Poly

  !------------------------------------------------------------------

  INTEGER :: f, e, c, ie, iP1, iP2
  TYPE(VECTOR_TYPE) :: Pm, Fm, Fa, P1, P2
  REAL(RK) :: denom, Vol

  !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  volm_poly_3d_cart = 0.0_RK

  if (Poly%numCrnr > 3) then

    Pm = Poly%Crnr(1)

    Vol = 0.0_RK
    do f = 1, Poly%numFaces

      if (Poly%nEdgeofFace(f) > 2) then
        ie = Poly%EdgeofFace(1,f)
        call Get_Edge_Crnrs (Poly, ie, iP1, iP2)
        Fm = Poly%Crnr(iP1)

        Fa = ORIGIN
        do e = 2, Poly%nEdgeofFace(f)

          ie = Poly%EdgeofFace(e,f)
          call Get_Edge_Crnrs (Poly, ie, iP1, iP2)

          P1 = Poly%Crnr(iP1)
          P2 = Poly%Crnr(iP2)

          Fa = Fa + Vector_Cross_Prod (P1-Fm, P2-Fm)
        end do
        Vol = Vol + Fa*(Fm - Pm)

      end if
    end do

    volm_poly_3d_cart = Vol / 6.0_RK

  endif

  END FUNCTION volm_poly_3d_cart

  SUBROUTINE Poly3D_2_Poly3D (Trg, Src)

  !==================================================================
  !  This subroutine places the contents of the Polygon Src into
  !  the Polygon Trg.
  !==================================================================

  IMPLICIT NONE

  TYPE(POLY3D_TYPE), INTENT(OUT) :: Trg
  TYPE(POLY3D_TYPE), INTENT(IN)  :: Src

  INTEGER :: c, f, e

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  Trg%numCrnr = Src%numCrnr
  do c = 1,maxCrnrs
    Trg%Crnr(c) = Src%Crnr(c)
  enddo
  Trg%numFaces = Src%numFaces
  Trg%numEdges = Src%numEdges
  do f = 1, maxFaces
    Trg%nEdgeofFace(f) = Src%nEdgeofFace(f)
    do e = 1, maxEperF
      Trg%EdgeofFace(e,f) = Src%EdgeofFace(e,f)
    end do
  enddo
  do e = 1, maxEdges
    Trg%CrnrofEdge(1,e) = Src%CrnrofEdge(1,e)
    Trg%CrnrofEdge(2,e) = Src%CrnrofEdge(2,e)
  end do
  do c = 1, maxCrnrs
    Trg%nEdgeofCrnr(c) = Src%nEdgeofCrnr(c)
    do e = 1, maxEperV
      Trg%EdgeofCrnr(e,c) = Src%EdgeofCrnr(e,c)
    end do
  end do

  END SUBROUTINE Poly3D_2_Poly3D

  REAL(RK) FUNCTION Point_Dist_Plane (point, plane)

  !==================================================================
  ! This logical function determines if the location in point is
  ! physically behind the plane.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: point
  TYPE(PLANE_TYPE),  INTENT(IN) :: plane

  !------------------------------------------------------------------

  INTEGER :: n, small_dist

  !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  Point_Dist_Plane = Point * Plane%n - Plane%p

!  small_dist = S100 * SPACING( S1 )
  small_dist = 0.0_RK

  if (ABS( Point_Dist_Plane ) < small_dist) then
    Point_Dist_Plane = S0
  end if

  END FUNCTION Point_Dist_Plane

  TYPE(PLANE_TYPE) FUNCTION Plane_from_Points (Pt1, Pt2, Pt3)

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: Pt1
  TYPE(VECTOR_TYPE), INTENT(IN) :: Pt2
  TYPE(VECTOR_TYPE), INTENT(IN) :: Pt3

  !------------------------------------------------------------------

  INTEGER, DIMENSION(1) :: n
  TYPE(VECTOR_TYPE) :: nrml
  REAL(RK) :: p

  !<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  nrml              = Vector_Cross_Prod (Pt3 - Pt2, Pt1 - Pt2)
  nrml              = nrmlz_vector (nrml)
  p                 = nrml * Pt1
  Plane_from_Points = PLANE_TYPE ( nrml, p )

  END FUNCTION Plane_from_Points

  TYPE(VECTOR_TYPE) FUNCTION NEGATE_VECTOR (A)

  !==================================================================
  !  This function returns a directed line segment by negating
  !  vector A.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: A

  !------------------------------------------------------------------

  INTEGER :: d

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  do d = 1,mdim
    negate_vector%x(d) = -A%x(d)
  enddo

  END FUNCTION NEGATE_VECTOR

  FUNCTION NEGATE_VECTOR_ARRAY (A) RESULT(B)

  !==================================================================
  !  This function returns an array of vectors by negating an array
  !  of vectors A.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), DIMENSION(:),      INTENT(IN) :: A
  TYPE(VECTOR_TYPE), DIMENSION(SIZE(A))            :: B

  !------------------------------------------------------------------

  INTEGER :: l

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  do l = 1,SIZE(A)
    B(l) = -A(l)
  enddo

  END FUNCTION NEGATE_VECTOR_ARRAY

  TYPE(VECTOR_TYPE) FUNCTION SUBTRACT_VECTOR (A, B)

  !==================================================================
  !  This function returns a directed line segment by subtracting
  !  vector B from vector A.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: A, B

  !------------------------------------------------------------------

  INTEGER :: d

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  do d = 1,mdim
     subtract_vector%x(d) = A%x(d) - B%x(d)
  enddo

  END FUNCTION SUBTRACT_VECTOR

  TYPE(VECTOR_TYPE) FUNCTION ADD_VECTOR (A, B)

  !==================================================================
  !  This function returns a directed line segment by adding
  !  point B to point A.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: A, B

  !------------------------------------------------------------------

  INTEGER :: d

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  do d = 1,mdim
     add_vector%x(d) = A%x(d) + B%x(d)
  enddo

  END FUNCTION ADD_VECTOR

  TYPE(VECTOR_TYPE) FUNCTION scalar_mult_vector (A, B)

  !==================================================================
  !  This function returns a directed line segment by multiplying
  !  the scalar A with the vector B.
  !==================================================================

  IMPLICIT NONE

  REAL(RK),          INTENT(IN) :: A
  TYPE(VECTOR_TYPE), INTENT(IN) :: B

  !------------------------------------------------------------------

  INTEGER :: d

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  do d = 1,mdim
     scalar_mult_vector%x(d) = A * B%x(d)
  enddo

  END FUNCTION scalar_mult_vector

  TYPE(VECTOR_TYPE) FUNCTION vector_mult_scalar (A, B)

  !==================================================================
  !  This function returns a directed line segment by multiplying
  !  the scalar B with the vector A.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: A
  REAL(RK),          INTENT(IN) :: B

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  vector_mult_scalar = scalar_mult_vector (B, A)

  END FUNCTION vector_mult_scalar

  REAL(RK) FUNCTION vector_dot_vector (A, B)

  !==================================================================
  !  This function returns the dot product of vector A with
  !  vector B.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: A
  TYPE(VECTOR_TYPE), INTENT(IN) :: B

  !------------------------------------------------------------------

  REAL(RK) :: dot
  INTEGER :: n

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  dot = 0.0_RK
  do n = 1,mdim
     dot = dot + A%x(n)*B%x(n)
  enddo
  vector_dot_vector = dot

  END FUNCTION vector_dot_vector

  TYPE(VECTOR_TYPE) FUNCTION vector_div_scalar (A, B)

  !==================================================================
  !  This function returns a directed line segment by dividing
  !  the vector A by the scalar B.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: A
  REAL(RK),          INTENT(IN) :: B

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  vector_div_scalar = &
               scalar_mult_vector (S1/SIGN(MAX(ABS(B),small),B), A)

  END FUNCTION vector_div_scalar

  TYPE(VECTOR_TYPE) FUNCTION abs_of_vector (A)

  !==================================================================
  !  This function returns the absolute value of each
  !  component of the vector A.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: A

  !------------------------------------------------------------------

  INTEGER :: d

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  do d = 1,mdim
     abs_of_vector%x(d) = ABS (A%x(d))
  enddo

  END FUNCTION abs_of_vector

  REAL(RK) FUNCTION vector_lngth (A)

  !==================================================================
  !  This function returns the length of the vector A.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: A

  !------------------------------------------------------------------

  INTEGER :: d
  REAL(RK) :: vector_sum

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  vector_sum = 0.0_RK
  do d = 1,mdim
     vector_sum = vector_sum + A%x(d)**2
  enddo
  vector_lngth = SQRT (vector_sum)

  END FUNCTION vector_lngth

  TYPE(VECTOR_TYPE) FUNCTION nrmlz_vector (A)

  !==================================================================
  !  This function is passed a vector A and this routine normalizes
  !  the components.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: A

  !------------------------------------------------------------------

  INTEGER :: d
  REAL(RK) :: Length

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  Length = 1.0_RK / MAX (vector_lngth(A), small)

  do d = 1,mdim
     nrmlz_vector%x(d) = A%x(d) * Length
  enddo

  END FUNCTION nrmlz_vector

  FUNCTION vector_cross_prod (A, B) RESULT (C)

  !==================================================================
  !  This function returns the vector cross product of A x B.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(IN) :: A, B
  TYPE(VECTOR_TYPE)             :: C

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  C%x(1) =  A%x(2) * B%x(3) - A%x(3) * B%x(2)
  C%x(2) =  A%x(3) * B%x(1) - A%x(1) * B%x(3)
  C%x(3) =  A%x(1) * B%x(2) - A%x(2) * B%x(1)

  END FUNCTION vector_cross_prod

  SUBROUTINE Vector_2_Vector (Trg, Src)

  !==================================================================
  !  This subroutine places the contents of the vector Src into
  !  the vector Trg.
  !==================================================================

  IMPLICIT NONE

  TYPE(VECTOR_TYPE), INTENT(OUT) :: Trg
  TYPE(VECTOR_TYPE), INTENT(IN)  :: Src

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

  Trg%x(1:mdim) = Src%x(1:mdim)

  END SUBROUTINE Vector_2_Vector

  SUBROUTINE Print_Poly_Mathematica (Poly)

   IMPLICIT NONE

   !===================================================================
   ! This routine prints the poly_type description of a poly.
   !===================================================================

   TYPE(poly3D_type), INTENT(IN) :: Poly

   !-------------------------------------------------------------------

   INTEGER :: nn, face, edge, e, iv1, iv2

   ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

   write (*,*) ' '
   do face = 1, Poly%numFaces
     write (*,*) 'Polygon[{'
     do edge = 1, Poly%nEdgeofFace(face)
       e = Poly%EdgeofFace(edge,face)
       call Get_Edge_Crnrs (Poly, e, iv1, iv2)
       write (*,*) '{',Poly%Crnr(iv1)%x(1),',', Poly%Crnr(iv1)%x(2),',', Poly%Crnr(iv1)%x(3),'},'
     enddo
     write (*,*) '}],'
   enddo

  END SUBROUTINE Print_Poly_Mathematica

  SUBROUTINE Check_Poly_Edges (Poly, Plane)

  IMPLICIT NONE

  !===================================================================
  ! This routine prints the poly_type description of a poly.
  !===================================================================

  TYPE(poly3D_type), INTENT(IN) :: Poly
  TYPE(plane_type),  INTENT(IN) :: Plane

  !-------------------------------------------------------------------

  INTEGER :: nn, face, edge, e, iv1, iv2
  INTEGER, DIMENSION(maxEperF,maxFaces) :: tmp_EdgeofFace
  LOGICAL, DIMENSION(-Poly%numEdges:Poly%numEdges) :: Possible_Edges
  LOGICAL :: Error_Found

  ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

! ALLOCATE (Possible_Edges(-Poly%numEdgesPoly%:numEdges))

  ! Copy the poly's edges to a temporary array
  tmp_EdgeofFace = 0
  do face = 1, Poly%numFaces
    do edge = 1, Poly%nEdgeofFace(face)
      tmp_EdgeofFace(edge,face) = Poly%EdgeofFace(edge,face)
    enddo
  enddo

  ! Initialize the list of possible edges
  do edge = 1, Poly%numEdges
    Possible_Edges(-edge) = .TRUE.
    Possible_Edges( edge) = .TRUE.
  enddo

  ! Look for each edge between -numEdges:-1 and 1:numEdges
  ! Zero each edge once.
  Error_Found = .FALSE.
  do face = 1, Poly%numFaces
    do edge = 1, Poly%nEdgeofFace(face)
      e = Poly%EdgeofFace(edge,face)
      if (e < -Poly%numEdges .OR. &
          e == 0             .OR. &
          e >  Poly%numEdges      ) then
        write (*,*) 'ERROR Check_Poly_Edges: illegal edge found'
        Error_Found = .TRUE.
      endif
      if (Possible_Edges(e)) then
        Possible_Edges(e) = .FALSE.
      else
        write (*,*) 'ERROR Check_Poly_Edges: Edge ',e,' used multiple times'
        Error_Found = .TRUE.
      endif
    enddo
  enddo

  do edge = -Poly%numEdges,-1
    if (Possible_Edges(edge)) then
      Error_Found = .TRUE.
      write (*,*) 'ERROR Check_Poly_Edges: edge ',edge,' not used'
    endif
  enddo

  do edge = 1, Poly%numEdges
    if (Possible_Edges(edge)) then
      Error_Found = .TRUE.
      write (*,*) 'ERROR Check_Poly_Edges: edge ',edge,' not used'
    endif
  enddo

  if (Error_Found) then
    call Print_Poly (Poly)
    STOP
  endif

  END SUBROUTINE Check_Poly_Edges

  SUBROUTINE Print_Poly (Poly)

   IMPLICIT NONE

   !===================================================================
   ! This routine prints the poly_type description of a poly.
   !===================================================================

   TYPE(poly3D_type), INTENT(IN) :: Poly

   !-------------------------------------------------------------------

   INTEGER  :: crnr, face, edge, numEdges
   INTEGER  :: e1, e2, iv1, iv2, iv3
   REAL(RK) :: FaceArea, SubArea
   TYPE(Vector_type) :: Pvt, V1, V2, V3, A123, Ann

   TYPE(Vector_type) :: Pt9, Pt13, Pt16
   TYPE(Vector_type) :: Pt4, Pt14, Pt15
   TYPE(Plane_type)  :: Face11, Face12

   ! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>

   write (*,*)
   write (*,*) 'Poly has ',Poly%numCrnr,' corners'
   do crnr = 1, Poly%numCrnr
     write (*,5) ' Crnr(',crnr,') = {',Poly%Crnr(crnr)%x(1), &
                               ', ',   Poly%Crnr(crnr)%x(2),'}'
5    format (a,i2,a,1pe12.5,a,1pe12.5,a)
   enddo

   do edge = 1, Poly%numEdges
     write (*,10) ' Edge(',edge,') = {',Poly%CrnrofEdge(1,edge), &
                                ', ',   Poly%CrnrofEdge(2,edge),'}'
10   format (a,i3,a,i4,a,i4,a)
   enddo

   write (*,*) 'Poly Edges:'
   do face = 1, Poly%numFaces
     write (*,*) 'Polygon face: ', face
     numEdges = Poly%nEdgeofFace(face)
     write (*,15) '        edges: ',Poly%EdgeofFace(1:numEdges,face)
15   format (a, 10i4)
     FaceArea = 0.0_RK
     e1 = Poly%EdgeofFace(1,face)
     e2 = Poly%EdgeofFace(2,face)
     call Get_Edge_Crnrs (Poly, e1, iV1, iV2)
     call Get_Edge_Crnrs (Poly, e2, iV2, iV3)
     V1 = Poly%Crnr(iV1)
     V2 = Poly%Crnr(iV2)
     V3 = Poly%Crnr(iV3)
     FaceArea =  Vector_Lngth( Vector_Cross_Prod (V2-V1, V3-V1) )
     if (Poly%nEdgeofFace(face) > 3) then
       Pvt  = V1
       A123 = Vector_Cross_Prod (V2-V1, V3-V1)
       A123 = nrmlz_vector (A123)
       do edge = 3, Poly%nEdgeofFace(face)-1
         e1       = Poly%EdgeofFace(edge,face)
         call Get_Edge_Crnrs (Poly, e1, iV1, iV2)
         V1       = Poly%Crnr(iV1)
         V2       = Poly%Crnr(iV2)
         Ann      = Vector_Cross_Prod (V1-Pvt, V2-Pvt)
         SubArea  = Vector_Lngth( Ann )
         FaceArea = FaceArea + SubArea
         Ann      = nrmlz_vector (Ann)
         write (*,*) 'Face Sub Dot = ',A123*Ann,' SubArea = ',SubArea
       enddo
     endif
     write (*,*) 'Face area = ',FaceArea
   enddo

   Face11 = Plane_from_Points (Pt9, Pt13, Pt16)
   Face12 = Plane_from_Points (Pt15, Pt14, Pt4)

   write (*,*) 'Pt9  dist = ',Point_Dist_Plane (Pt9,  Face12)
   write (*,*) 'Pt13 dist = ',Point_Dist_Plane (Pt13, Face12)
   write (*,*) 'Pt16 dist = ',Point_Dist_Plane (Pt16, Face12)

   write (*,*) 'Pt4  dist = ',Point_Dist_Plane (Pt4,  Face11)
   write (*,*) 'Pt14 dist = ',Point_Dist_Plane (Pt14, Face11)
   write (*,*) 'Pt15 dist = ',Point_Dist_Plane (Pt15, Face11)

  END SUBROUTINE Print_Poly

END MODULE OVERLAP_MODULE


module representations

    implicit none

contains

subroutine get_indices(natoms, nuclear_charges, type1, n, type1_indices)
    integer, intent(in) :: natoms
    integer, intent(in) :: type1
    integer, dimension(:), intent(in) :: nuclear_charges

    integer, intent(out) :: n
    integer, dimension(:), intent(out) :: type1_indices
    integer :: j

    !$OMP PARALLEL DO REDUCTION(+:n)
    do j = 1, natoms
        if (nuclear_charges(j) == type1) then
            ! this shouldn't be a race condition
            n = n + 1
            type1_indices(n) = j
        endif
    enddo
    !$OMP END PARALLEL DO

end subroutine get_indices

end module representations

subroutine fgenerate_coulomb_matrix(atomic_charges, coordinates, nmax, cm)

    implicit none

    double precision, dimension(:), intent(in) :: atomic_charges
    double precision, dimension(:,:), intent(in) :: coordinates

    integer, intent(in) :: nmax

    double precision, dimension(((nmax + 1) * nmax) / 2), intent(out):: cm

    double precision, allocatable, dimension(:) :: row_norms
    double precision :: pair_norm
    double precision :: huge_double

    integer, allocatable, dimension(:) :: sorted_atoms

    double precision, allocatable, dimension(:,:) :: pair_distance_matrix

    integer :: i, j, m, n, idx
    integer :: natoms

    if (size(coordinates, dim=1) /= size(atomic_charges, dim=1)) then
        write(*,*) "ERROR: Coulomb matrix generation"
        write(*,*) size(coordinates, dim=1), "coordinates, but", &
            & size(atomic_charges, dim=1), "atom_types!"
        stop
    else
        natoms = size(atomic_charges, dim=1)
    endif

    ! Allocate temporary
    allocate(pair_distance_matrix(natoms,natoms))
    allocate(row_norms(natoms))
    allocate(sorted_atoms(natoms))

    huge_double = huge(row_norms(1))

    ! Calculate row-2-norms and store pair-distances in pair_distance_matrix
    row_norms = 0.0d0

    !$OMP PARALLEL DO PRIVATE(pair_norm) REDUCTION(+:row_norms)
    do i = 1, natoms
        pair_norm = 0.5d0 * atomic_charges(i) ** 2.4d0
        row_norms(i) = row_norms(i) + pair_norm * pair_norm
        pair_distance_matrix(i, i) = pair_norm
    enddo
    !$OMP END PARALLEL DO

    !$OMP PARALLEL DO PRIVATE(pair_norm) REDUCTION(+:row_norms)
    do i = 1, natoms
        do j = i+1, natoms
            pair_norm = atomic_charges(i) * atomic_charges(j) &
                & / sqrt(sum((coordinates(j,:) - coordinates(i,:))**2))

            pair_distance_matrix(i, j) = pair_norm
            pair_distance_matrix(j, i) = pair_norm
            pair_norm = pair_norm * pair_norm
            row_norms(j) = row_norms(j) + pair_norm
            row_norms(i) = row_norms(i) + pair_norm
        enddo
    enddo
    !$OMP END PARALLEL DO

    !Generate sorted list of atom ids by row_norms - not really (easily) parallelizable
    do i = 1, natoms
        j = minloc(row_norms, dim=1)
        sorted_atoms(natoms - i + 1) = j
        row_norms(j) = huge_double
    enddo

    ! Fill coulomb matrix according to sorted row-2-norms
    cm = 0.0d0
    !$OMP PARALLEL DO PRIVATE(idx, i, j)
    do m = 1, natoms
        i = sorted_atoms(m)
        idx = (m*m+m)/2 - m
        do n = 1, m
            j = sorted_atoms(n)
            cm(idx+n) = pair_distance_matrix(i, j)
        enddo
    enddo
    !$OMP END PARALLEL DO

    ! Clean up
    deallocate(pair_distance_matrix)
    deallocate(row_norms)
    deallocate(sorted_atoms)
end subroutine fgenerate_coulomb_matrix

subroutine fgenerate_unsorted_coulomb_matrix(atomic_charges, coordinates, nmax, cm)

    implicit none

    double precision, dimension(:), intent(in) :: atomic_charges
    double precision, dimension(:,:), intent(in) :: coordinates

    integer, intent(in) :: nmax

    double precision, dimension(((nmax + 1) * nmax) / 2), intent(out):: cm

    double precision :: pair_norm

    double precision, allocatable, dimension(:,:) :: pair_distance_matrix

    integer :: i, j, m, n, idx
    integer :: natoms

    if (size(coordinates, dim=1) /= size(atomic_charges, dim=1)) then
        write(*,*) "ERROR: Coulomb matrix generation"
        write(*,*) size(coordinates, dim=1), "coordinates, but", &
            & size(atomic_charges, dim=1), "atom_types!"
        stop
    else
        natoms = size(atomic_charges, dim=1)
    endif

    ! Allocate temporary
    allocate(pair_distance_matrix(natoms,natoms))

    !$OMP PARALLEL DO PRIVATE(pair_norm)
    do i = 1, natoms
        pair_norm = 0.5d0 * atomic_charges(i) ** 2.4d0
        pair_distance_matrix(i, i) = pair_norm
    enddo
    !$OMP END PARALLEL DO

    !$OMP PARALLEL DO PRIVATE(pair_norm)
    do i = 1, natoms
        do j = i+1, natoms
            pair_norm = atomic_charges(i) * atomic_charges(j) &
                & / sqrt(sum((coordinates(j,:) - coordinates(i,:))**2))

            pair_distance_matrix(i, j) = pair_norm
            pair_distance_matrix(j, i) = pair_norm
        enddo
    enddo
    !$OMP END PARALLEL DO

    cm = 0.0d0
    !$OMP PARALLEL DO PRIVATE(idx)
    do m = 1, natoms
        idx = (m*m+m)/2 - m
        do n = 1, m
            cm(idx+n) = pair_distance_matrix(m, n)
        enddo
    enddo
    !$OMP END PARALLEL DO

    ! Clean up
    deallocate(pair_distance_matrix)

end subroutine fgenerate_unsorted_coulomb_matrix

subroutine fgenerate_local_coulomb_matrix(central_atom_indices, central_natoms, &
        & atomic_charges, coordinates, natoms, nmax, cent_cutoff, cent_decay, &
        & int_cutoff, int_decay, cm)

    implicit none

    integer, intent(in) :: central_natoms
    integer, dimension(:), intent(in) :: central_atom_indices
    double precision, dimension(:), intent(in) :: atomic_charges
    double precision, dimension(:,:), intent(in) :: coordinates
    integer,intent(in) :: natoms
    integer, intent(in) :: nmax
    double precision, intent(inout) :: cent_cutoff, cent_decay, int_cutoff, int_decay

    double precision, dimension(central_natoms, ((nmax + 1) * nmax) / 2), intent(out):: cm

    integer :: idx

    double precision, allocatable, dimension(:, :) :: row_norms
    double precision :: pair_norm
    double precision :: prefactor
    double precision :: norm
    double precision :: huge_double

    integer, allocatable, dimension(:, :) :: sorted_atoms_all
    integer, allocatable, dimension(:) :: cutoff_count

    double precision, allocatable, dimension(:, :, :) :: pair_distance_matrix
    double precision, allocatable, dimension(:, :) :: distance_matrix

    integer i, j, m, n, k, l

    double precision, parameter :: pi = 4.0d0 * atan(1.0d0)

    if (size(coordinates, dim=1) /= size(atomic_charges, dim=1)) then
        write(*,*) "ERROR: Coulomb matrix generation"
        write(*,*) size(coordinates, dim=1), "coordinates, but", &
            & size(atomic_charges, dim=1), "atom_types!"
        stop
    endif

    ! Allocate temporary
    allocate(distance_matrix(natoms,natoms))
    allocate(cutoff_count(natoms))

    huge_double = huge(distance_matrix(1,1))

    if (cent_cutoff < 0) then
        cent_cutoff = huge_double
    endif

    if ((int_cutoff < 0) .OR. (int_cutoff > 2 * cent_cutoff)) then
        int_cutoff = 2 * cent_cutoff
    endif

    if (cent_decay < 0) then
        cent_decay = 0.0d0
    else if (cent_decay > cent_cutoff) then
        cent_decay = cent_cutoff
    endif

    if (int_decay < 0) then
        int_decay = 0.0d0
    else if (int_decay > int_cutoff) then
        int_decay = int_cutoff
    endif

    cutoff_count = 1

    !$OMP PARALLEL DO PRIVATE(norm) REDUCTION(+:cutoff_count)
    do i = 1, natoms
        distance_matrix(i, i) = 0.0d0
        do j = i+1, natoms
            norm = sqrt(sum((coordinates(j,:) - coordinates(i,:))**2))
            distance_matrix(i, j) = norm
            distance_matrix(j, i) = norm
            if (norm < cent_cutoff) then
                cutoff_count(i) = cutoff_count(i) + 1
                cutoff_count(j) = cutoff_count(j) + 1
            endif
        enddo
    enddo
    !$OMP END PARALLEL DO

    do i = 1, central_natoms
        j = central_atom_indices(i)
        if (cutoff_count(j) > nmax) then
            write(*,*) "ERROR: Coulomb matrix generation"
            write(*,*) nmax, "size set, but", &
                & cutoff_count(j), "size needed!"
            stop
        endif
    enddo

    ! Allocate temporary
    allocate(pair_distance_matrix(natoms, natoms, central_natoms))
    allocate(row_norms(natoms, central_natoms))

    pair_distance_matrix = 0.0d0
    row_norms = 0.0d0

    !$OMP PARALLEL DO PRIVATE(pair_norm, prefactor, k) REDUCTION(+:row_norms) COLLAPSE(2)
    do i = 1, natoms
        do l = 1, central_natoms
            k = central_atom_indices(l)
            ! self interaction
            if (distance_matrix(i,k) > cent_cutoff) then
                cycle
            endif

            prefactor = 1.0d0
            if (distance_matrix(i,k) > cent_cutoff - cent_decay) then
                prefactor = 0.5d0 * (cos(pi &
                    & * (distance_matrix(i,k) - cent_cutoff + cent_decay) / cent_decay) + 1)
            endif

            pair_norm = prefactor * prefactor * 0.5d0 * atomic_charges(i) ** 2.4d0
            pair_distance_matrix(i,i,l) = pair_norm
            row_norms(i,l) = row_norms(i,l) + pair_norm * pair_norm

            do j = i+1, natoms
                if (distance_matrix(j,k) > cent_cutoff) then
                    cycle
                endif

                if (distance_matrix(i,j) > int_cutoff) then
                    cycle
                endif

                pair_norm = prefactor * atomic_charges(i) * atomic_charges(j) &
                    & / distance_matrix(j, i)

                if (distance_matrix(i,j) > int_cutoff - int_decay) then
                    pair_norm = pair_norm * 0.5d0 * (cos(pi &
                        & * (distance_matrix(i,j) - int_cutoff + int_decay) / int_decay) + 1)
                endif

                if (distance_matrix(j,k) > cent_cutoff - cent_decay) then
                    pair_norm = pair_norm * 0.5d0 * (cos(pi &
                        & * (distance_matrix(j,k) - cent_cutoff + cent_decay) / cent_decay) + 1)
                endif

                pair_distance_matrix(i, j, l) = pair_norm
                pair_distance_matrix(j, i, l) = pair_norm
                pair_norm = pair_norm * pair_norm
                row_norms(i,l) = row_norms(i,l) + pair_norm
                row_norms(j,l) = row_norms(j,l) + pair_norm
            enddo
        enddo
    enddo
    !$OMP END PARALLEL DO

    ! Allocate temporary
    allocate(sorted_atoms_all(natoms, central_natoms))

    !$OMP PARALLEL DO PRIVATE(k)
        do l = 1, central_natoms
            k = central_atom_indices(l)
            row_norms(k,l) = huge_double
        enddo
    !$OMP END PARALLEL DO

    !$OMP PARALLEL DO PRIVATE(j,k)
        do l = 1, central_natoms
            k = central_atom_indices(l)
            !$OMP CRITICAL
                do i = 1, cutoff_count(k)
                    j = maxloc(row_norms(:,l), dim=1)
                    sorted_atoms_all(i, l) = j
                    row_norms(j,l) = 0.0d0
                enddo
            !$OMP END CRITICAL
        enddo
    !$OMP END PARALLEL DO

    ! Clean up
    deallocate(row_norms)

    ! Fill coulomb matrix according to sorted row-2-norms
    cm = 0.0d0

    !$OMP PARALLEL DO PRIVATE(i, j, k, idx)
        do l = 1, central_natoms
            k = central_atom_indices(l)
            do m = 1, cutoff_count(k)
                i = sorted_atoms_all(m, l)
                idx = (m*m+m)/2 - m
                do n = 1, m
                    j = sorted_atoms_all(n, l)
                    cm(l, idx+n) = pair_distance_matrix(i,j,l)
                enddo
            enddo
        enddo
    !$OMP END PARALLEL DO

    ! Clean up
    deallocate(sorted_atoms_all)
    deallocate(pair_distance_matrix)

end subroutine fgenerate_local_coulomb_matrix

subroutine fgenerate_atomic_coulomb_matrix(central_atom_indices, central_natoms, atomic_charges, &
        & coordinates, natoms, nmax, cent_cutoff, cent_decay, int_cutoff, int_decay, cm)

    implicit none

    integer, dimension(:), intent(in) :: central_atom_indices
    integer, intent(in) :: central_natoms
    double precision, dimension(:), intent(in) :: atomic_charges
    double precision, dimension(:,:), intent(in) :: coordinates
    integer,intent(in) :: natoms
    integer, intent(in) :: nmax
    double precision, intent(inout) :: cent_cutoff, cent_decay, int_cutoff, int_decay

    double precision, dimension(central_natoms, ((nmax + 1) * nmax) / 2), intent(out):: cm

    integer :: idx

    double precision :: pair_norm
    double precision :: prefactor
    double precision :: norm
    double precision :: huge_double

    integer, allocatable, dimension(:, :) :: sorted_atoms_all
    integer, allocatable, dimension(:) :: cutoff_count

    double precision, allocatable, dimension(:, :) :: pair_distance_matrix
    double precision, allocatable, dimension(:, :) :: distance_matrix
    double precision, allocatable, dimension(:, :) :: distance_matrix_tmp

    integer i, j, m, n, k, l

    double precision, parameter :: pi = 4.0d0 * atan(1.0d0)

    if (size(coordinates, dim=1) /= size(atomic_charges, dim=1)) then
        write(*,*) "ERROR: Coulomb matrix generation"
        write(*,*) size(coordinates, dim=1), "coordinates, but", &
            & size(atomic_charges, dim=1), "atom_types!"
        stop
    endif

    ! Allocate temporary
    allocate(distance_matrix(natoms,natoms))
    allocate(cutoff_count(natoms))

    huge_double = huge(distance_matrix(1,1))

    if (cent_cutoff < 0) then
        cent_cutoff = huge_double
    endif

    if ((int_cutoff < 0) .OR. (int_cutoff > 2 * cent_cutoff)) then
        int_cutoff = 2 * cent_cutoff
    endif

    if (cent_decay < 0) then
        cent_decay = 0.0d0
    else if (cent_decay > cent_cutoff) then
        cent_decay = cent_cutoff
    endif

    if (int_decay < 0) then
        int_decay = 0.0d0
    else if (int_decay > int_cutoff) then
        int_decay = int_cutoff
    endif

    cutoff_count = 1

    !$OMP PARALLEL DO PRIVATE(norm) REDUCTION(+:cutoff_count)
    do i = 1, natoms
        distance_matrix(i, i) = 0.0d0
        do j = i+1, natoms
            norm = sqrt(sum((coordinates(j,:) - coordinates(i,:))**2))
            distance_matrix(i, j) = norm
            distance_matrix(j, i) = norm
            if (norm < cent_cutoff) then
                cutoff_count(i) = cutoff_count(i) + 1
                cutoff_count(j) = cutoff_count(j) + 1
            endif
        enddo
    enddo
    !$OMP END PARALLEL DO

    do i = 1, central_natoms
        k = central_atom_indices(i)
        if (cutoff_count(k) > nmax) then
            write(*,*) "ERROR: Coulomb matrix generation"
            write(*,*) nmax, "size set, but", &
                & cutoff_count(k), "size needed!"
            stop
        endif
    enddo

    ! Allocate temporary
    allocate(pair_distance_matrix(natoms, natoms))

    pair_distance_matrix = 0.0d0

    !$OMP PARALLEL DO PRIVATE(pair_norm)
        do i = 1, natoms
            pair_distance_matrix(i, i) = 0.5d0 * atomic_charges(i) ** 2.4d0
            do j = i+1, natoms
                if (distance_matrix(j,i) > int_cutoff) then
                    cycle
                endif
                pair_norm = atomic_charges(i) * atomic_charges(j) &
                    & / distance_matrix(j, i)
                if (distance_matrix(j,i) > int_cutoff - int_decay) then
                    pair_norm = pair_norm * 0.5d0 * (cos(pi &
                        & * (distance_matrix(j,i) - int_cutoff + int_decay) / int_decay) + 1)
                endif

                pair_distance_matrix(i, j) = pair_norm
                pair_distance_matrix(j, i) = pair_norm
            enddo
        enddo
    !$OMP END PARALLEL DO

    ! Allocate temporary
    allocate(distance_matrix_tmp(natoms, natoms))
    allocate(sorted_atoms_all(natoms, central_natoms))

    distance_matrix_tmp = distance_matrix
    !Generate sorted list of atom ids by distance matrix
    !$OMP PARALLEL DO PRIVATE(j, k)
    do l = 1, central_natoms
        k = central_atom_indices(l)
        !$OMP CRITICAL
            do i = 1, cutoff_count(k)
                j = minloc(distance_matrix_tmp(:,k), dim=1)
                sorted_atoms_all(i, l) = j
                distance_matrix_tmp(j, k) = huge_double
            enddo
        !$OMP END CRITICAL
    enddo
    !$OMP END PARALLEL DO

    ! Clean up
    deallocate(distance_matrix_tmp)

    ! Fill coulomb matrix according to sorted distances
    cm = 0.0d0

    pair_norm = 0.0d0

    !$OMP PARALLEL DO PRIVATE(i, prefactor, idx, j, pair_norm, k)
    do l = 1, central_natoms
        k = central_atom_indices(l)
        do m = 1, cutoff_count(k)
            i = sorted_atoms_all(m, l)

            if (distance_matrix(i,k) > cent_cutoff) then
                cycle
            endif
            prefactor = 1.0d0
            if (distance_matrix(i,k) > cent_cutoff - cent_decay) then
                prefactor = 0.5d0 * (cos(pi &
                    & * (distance_matrix(i,k) - cent_cutoff + cent_decay) &
                    & / cent_decay) + 1.0d0)
            endif

            idx = (m*m+m)/2 - m
            do n = 1, m
                j = sorted_atoms_all(n, l)

                pair_norm = prefactor * pair_distance_matrix(i, j)
                if (distance_matrix(j,k) > cent_cutoff - cent_decay) then
                    pair_norm = pair_norm * 0.5d0 * (cos(pi &
                        & * (distance_matrix(j,k) - cent_cutoff + cent_decay) &
                        & / cent_decay) + 1)
                endif
                cm(l, idx+n) = pair_norm
            enddo
        enddo
    enddo

    ! Clean up
    deallocate(distance_matrix)
    deallocate(pair_distance_matrix)
    deallocate(sorted_atoms_all)
    deallocate(cutoff_count)

end subroutine fgenerate_atomic_coulomb_matrix

subroutine fgenerate_eigenvalue_coulomb_matrix(atomic_charges, coordinates, nmax, sorted_eigenvalues)

    implicit none

    double precision, dimension(:), intent(in) :: atomic_charges
    double precision, dimension(:,:), intent(in) :: coordinates

    integer, intent(in) :: nmax

    double precision, dimension(nmax), intent(out) :: sorted_eigenvalues

    double precision :: pair_norm
    double precision :: huge_double

    double precision, allocatable, dimension(:,:) :: pair_distance_matrix

    double precision, allocatable, dimension(:) :: work
    double precision, allocatable, dimension(:) :: eigenvalues

    integer :: i, j, info, lwork
    integer :: natoms

    if (size(coordinates, dim=1) /= size(atomic_charges, dim=1)) then
        write(*,*) "ERROR: Coulomb matrix generation"
        write(*,*) size(coordinates, dim=1), "coordinates, but", &
            & size(atomic_charges, dim=1), "atom_types!"
        stop
    else
        natoms = size(atomic_charges, dim=1)
    endif

    ! Allocate temporary
    allocate(pair_distance_matrix(nmax,nmax))

    huge_double = huge(pair_distance_matrix(1,1))

    pair_distance_matrix(:,:) = 0.0d0

    !$OMP PARALLEL DO PRIVATE(pair_norm)
    do i = 1, natoms
        pair_norm = 0.5d0 * atomic_charges(i) ** 2.4d0
        pair_distance_matrix(i, i) = pair_norm
    enddo
    !$OMP END PARALLEL DO

    !$OMP PARALLEL DO PRIVATE(pair_norm)
    do i = 1, natoms
        do j = i+1, natoms
            pair_norm = atomic_charges(i) * atomic_charges(j) &
                & / sqrt(sum((coordinates(j,:) - coordinates(i,:))**2))

            pair_distance_matrix(i, j) = pair_norm
        enddo
    enddo
    !$OMP END PARALLEL DO

    lwork = 4 * nmax
    ! Allocate temporary
    allocate(work(lwork))
    allocate(eigenvalues(nmax))
    call dsyev("N", "U", nmax, pair_distance_matrix, nmax, eigenvalues, work, lwork, info)
    if (info > 0) then
        write (*,*) "WARNING: Eigenvalue routine DSYEV() exited with error code:", info
    endif

    ! Clean up
    deallocate(work)
    deallocate(pair_distance_matrix)

    !sort
    do i = 1, nmax
        j = minloc(eigenvalues, dim=1)
        sorted_eigenvalues(nmax - i + 1) = eigenvalues(j)
        eigenvalues(j) = huge_double
    enddo

    ! Clean up
    deallocate(eigenvalues)

end subroutine fgenerate_eigenvalue_coulomb_matrix

subroutine fgenerate_bob(atomic_charges, coordinates, nuclear_charges, id, &
    & nmax, ncm, cm)

    use representations, only: get_indices
    implicit none

    double precision, dimension(:), intent(in) :: atomic_charges
    double precision, dimension(:,:), intent(in) :: coordinates
    integer, dimension(:), intent(in) :: nuclear_charges
    integer, dimension(:), intent(in) :: id
    integer, dimension(:), intent(in) :: nmax
    integer, intent(in) :: ncm

    double precision, dimension(ncm), intent(out):: cm

    integer :: n, i, j, k, l, idx1, idx2, nid, nbag
    integer :: natoms, natoms1, natoms2, type1, type2

    integer, allocatable, dimension(:) :: type1_indices
    integer, allocatable, dimension(:) :: type2_indices
    integer, allocatable, dimension(:) :: start_indices

    double precision :: pair_norm
    double precision :: huge_double

    double precision, allocatable, dimension(:) :: bag
    double precision, allocatable, dimension(:,:) :: pair_distance_matrix

    if (size(coordinates, dim=1) /= size(atomic_charges, dim=1)) then
        write(*,*) "ERROR: Bag of Bonds generation"
        write(*,*) size(coordinates, dim=1), "coordinates, but", &
            & size(atomic_charges, dim=1), "atom_types!"
        stop
    else if (size(coordinates, dim=1) /= size(nuclear_charges, dim=1)) then
        write(*,*) "ERROR: Coulomb matrix generation"
        write(*,*) size(coordinates, dim=1), "coordinates, but", &
            & size(nuclear_charges, dim=1), "atom_types!"
        stop
    else
        natoms = size(atomic_charges, dim=1)
    endif

    if (size(id, dim=1) /= size(nmax, dim=1)) then
        write(*,*) "ERROR: Bag of Bonds generation"
        write(*,*) size(id, dim=1), "unique atom types, but", &
            & size(nmax, dim=1), "max size!"
        stop
    else
        nid = size(id, dim=1)
    endif

    n = 0
    !$OMP PARALLEL DO REDUCTION(+:n)
        do i = 1, nid
            n = n + nmax(i) * (1 + nmax(i))
            do j = 1, i - 1
                n = n + 2 * nmax(i) * nmax(j)
            enddo
        enddo
    !$OMP END PARALLEL DO

    if (n /= 2*ncm) then
        write(*,*) "ERROR: Bag of Bonds generation"
        write(*,*) "Inferred vector size", n, "but given size", ncm
        stop
    endif

    ! Allocate temporary
    allocate(pair_distance_matrix(natoms,natoms))
    huge_double = huge(pair_distance_matrix(1,1))

    !$OMP PARALLEL DO PRIVATE(pair_norm)
    do i = 1, natoms
        do j = i+1, natoms
            pair_norm = atomic_charges(i) * atomic_charges(j) &
                & / sqrt(sum((coordinates(j,:) - coordinates(i,:))**2))

            pair_distance_matrix(i, j) = pair_norm
            pair_distance_matrix(j, i) = pair_norm
        enddo
    enddo
    !$OMP END PARALLEL DO

    ! Allocate temporary
    ! Too large but easier
    allocate(type1_indices(maxval(nmax, dim=1)))
    allocate(type2_indices(maxval(nmax, dim=1)))

    ! Get max bag size
    nbag = 0
    do i = 1, nid
        nbag = max(n, (nmax(i) * (nmax(i) - 1))/2)
        do j = 1, i - 1
            nbag = max(n, nmax(i) * nmax(j))
        enddo
    enddo

    ! Allocate temporary
    ! Too large but easier
    allocate(bag(nbag))
    allocate(start_indices(nid))

    ! get start indices
    start_indices(1) = 0
    do i = 2, nid
        start_indices(i) = (nmax(i-1) * (nmax(i-1) + 1)) / 2 + start_indices(i-1)
        do j = i, nid
            start_indices(i) = start_indices(i) + nmax(j) * nmax(i-1)
        enddo
    enddo

    cm = 0.0d0

    !$OMP PARALLEL DO PRIVATE(type1, type1_indices, l, &
    !$OMP& bag, natoms1, idx1, idx2, k, nbag, type2, natoms2, type2_indices)
    do i = 1, nid
        type1 = id(i)
        natoms1 = 0

        call get_indices(natoms, nuclear_charges, type1, natoms1, type1_indices)

        bag = 0.0d0

        do j = 1, natoms1
            idx1 = type1_indices(j)
            cm(start_indices(i) + j) = 0.5d0 * atomic_charges(idx1) ** 2.4d0
            k = (j * j - 3 * j) / 2
            do l = 1, j - 1
                idx2 = type1_indices(l)
                bag(k + l + 1) = pair_distance_matrix(idx1, idx2)
            enddo
        enddo

        start_indices(i) = start_indices(i) + nmax(i)

        nbag = (nmax(i) * nmax(i) - nmax(i)) / 2
        ! sort
        do j = 1, nbag
            k = minloc(bag(:nbag), dim=1)
            cm(start_indices(i) + nbag - j + 1) = bag(k)
            bag(k) = huge_double
        enddo

        start_indices(i) = start_indices(i) + nbag

        do j = i + 1, nid
            type2 = id(j)
            natoms2 = 0

            call get_indices(natoms, nuclear_charges, type2, natoms2, type2_indices)

            bag = 0.0d0

            do k = 1, natoms1
                idx1 = type1_indices(k)
                do l = 1, natoms2
                    idx2 = type2_indices(l)
                    bag(natoms2 * (k - 1) + l) = pair_distance_matrix(idx1, idx2)
                enddo
            enddo

            ! sort
            nbag = nmax(i) * nmax(j)
            do k = 1, nbag
                l = minloc(bag(:nbag), dim=1)
                cm(start_indices(i) + nbag - k + 1) = bag(l)
                bag(l) = huge_double
            enddo

            start_indices(i) = start_indices(i) + nbag
        enddo
    enddo
    !$OMP END PARALLEL DO

    ! Clean up
    deallocate(pair_distance_matrix)
    deallocate(bag)
    deallocate(type1_indices)
    deallocate(type2_indices)
    deallocate(start_indices)

end subroutine fgenerate_bob


module modAcc
implicit none
private
integer, public, parameter :: KRL = selected_real_kind(14)

type, public :: AccType
    real(KRL), private :: dn, dsum
    complex(KRL), private :: fn, fsum
    integer, private :: jn, jsum, icod
    contains
    procedure, private :: initd, initf, initi
    generic, public :: init => initd, initf, initi
    procedure, private :: dfun, ffun, jfun
    generic, public :: fun => dfun, jfun, ffun
end type AccType

contains

subroutine initd(self, dd)
    class(AccType), intent(inout) :: self
    real(KRL), intent(in) :: dd
    self%dn = dd
    self%icod = 1
end subroutine initd

subroutine initf(self, ff)
    class(AccType), intent(inout) :: self
    complex(KRL), intent(in) :: ff
    self%fn = ff
    self%icod = 2
end subroutine initf

subroutine initi(self, jj)
    class(AccType), intent(inout) :: self
    integer, intent(in) :: jj
    self%jn = jj
    self%icod = 3
end subroutine initi

real(KRL) function dfun(self, di)
    class(AccType), intent(inout) :: self
    real(KRL), intent(in) :: di
    self%dsum = self%dsum + di
    dfun = self%dn + self%dsum
end function dfun

complex(KRL) function ffun(self, fi)
    class(AccType), intent(inout) :: self
    complex(KRL), intent(in) :: fi
    self%fsum = self%fsum + fi
    ffun = self%fn + self%fsum
end function ffun

integer function jfun(self, ji)
    class(AccType), intent(inout) :: self
    integer, intent(in) :: ji
    self%jsum = self%jsum + ji
    jfun = self%jn + self%jsum
end function jfun

end module modAcc

program test
    use modAcc
    implicit none
    type(AccType) :: x, y
    integer :: itemp
    real(KRL) :: temp
    call x%init(1.0_KRL)
    temp = x%fun(5.0_KRL)
    call y%init(3)
    print *, x%fun(2.3_KRL)
    itemp = y%fun(5)
    print *, y%fun(2)
end program test


	FUNCTION PS_EQLV ( nparm, data, thepar, tvflag )
C************************************************************************
C* PS_EQLV								*
C*									*
C* This function returns the lowest pressure along the sounding at	*
C* which the equivalent potential temperature of the sounding is	*
C* equal to THEPAR.  TVFLAG determines if temperature or virtual	*
C* temperature is used in the calculation.				*
C*									*
C* REAL PS_EQLV ( NPARM, DATA, THEPAR, TVFLAG )				*
C*									*
C* Input parameters:							*
C*	NPARM		INTEGER		Number of dat set parameters	*
C*	DATA (NPARM,*)	REAL		Station data			*
C*	THEPAR		REAL		Parcel THTE in Kelvin		*
C*	TVFLAG		LOGICAL		Temperature flag		*
C*									*
C* Output parameters:							*
C*	PS_EQLV		REAL		Equilibrium level in millibars	*
C**									*
C* Log:									*
C* G. Huffman/USRA	 8/89	Adapted from PS_LIFT			*
C* J. Nielsen/TAMU	 5/92	Do not check below surface		*
C* S. Jacobs/EAI	 3/93	Cleaned up				*
C* P. Neilley/NCAR	 6/94	Ignore missing data; changed iterations *
C* T. Lee/GSC		 8/97	Cleaned up; added a temperature flag	*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	PARAMETER	( EPSI = .6077 )
	REAL		data ( nparm, * )
C*
	REAL		datlev ( MMPARM ), outdat ( 10 )
	LOGICAL		good, belowg, tvflag
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	PS_EQLV = RMISSD
	iret = 0
C
	IF  ( ERMISS ( thepar ) )  RETURN
C
C*	Find the highest level which reports pressure and temperature
C*	data.  Get the temperature.
C
	CALL PC_FTOP  ( data, nparm, numlev, outdat, ier )
	IF  ( numlev .le. 1 )  RETURN
	pbot  = outdat (1)
	IF  ( tvflag )  THEN
	    tebot = outdat (7)
	  ELSE
	    tebot = outdat (2)
	END IF
C
C*	Compute top level parcel temperature. Return if the environmetal
C*	temperature is less than the parcel's.
C
	tpbotk = PR_TMST ( thepar, pbot, 0. )
	tpbot  = PR_TMKC ( tpbotk )
	IF  ( tvflag )  THEN
	    tpbotk = PR_TVRK ( tpbot, tpbot, pbot )
	    tpbot  = PR_TMKC ( tpbotk )
	END IF
	IF  ( tebot .lt. tpbot )  RETURN
C
C*	Get LFC pressure.  Return if it's missing.
C
	plfc  = PS_LFCV ( data, nparm, thepar, tvflag )
	IF  ( ERMISS ( plfc ) )  RETURN
C
C*	Loop down through the sounding until the first crossing is hit.
C*	Missing PRES or TMPC is an error.
C
	good = .true.
	belowg = .false.
	DO  WHILE ( ( tebot .gt. tpbot ) .and. ( good ) .and.
     +		    ( .not. belowg ) )
	    ptop   = pbot
	    tetop  = tebot
	    numlev = numlev - 1
	    IF  ( numlev .eq. 0 )  THEN
		good = .false.
	      ELSE
		CALL PC_GLEV  ( numlev, data, nparm, datlev, ier )
		CALL PC_COMP  ( 5,    datlev, outdat, ier )
C
C*	        At or below LFC?
C
		IF  ( outdat (1) .ge. plfc )  THEN
		    belowg = .true.
C
C*	        Embedded missing data?  If so, skip this level.
C*              Also skip this level if thte not calculable.
C
		  ELSE IF  ( ( .not. ERMISS ( outdat(1) ) ) .and.
     +			     ( .not. ERMISS ( outdat(2) ) ) )  THEN

		    pbot  = outdat (1)
		    IF  ( tvflag )  THEN
			tebot = outdat (7)
		      ELSE
			tebot = outdat (2)
		    END IF
		    tpbotk = PR_TMST ( thepar, pbot, 0. )
		    tpbot  = PR_TMKC ( tpbotk )
		    IF  ( tvflag )  THEN
			tpbotk = PR_TVRK ( tpbot, tpbot, pbot )
			tpbot  = PR_TMKC ( tpbotk )
		    END IF
		END IF
	    END IF
	END DO
C
C*	If sounding is not complete, return missing.
C
	IF  ( .not. good )  RETURN
C
C*	If we've traversed the whole sounding, return missing.
C
	IF  ( belowg )  RETURN
C
C*	Interpolation for virtual temperature case:
C*
C*	Assume linear LN(P) variation for the temperature and mixing
C*	ratio (q).  Find the linear equations for T and q, and equate
C*	the virtual temperatures at the intersecting point for the
C*	parcel and the environment. Solve for P.
C
	IF  ( tvflag )  THEN
C
C*	    Get enviromental data at the pressure levels..
C
	    CALL PC_CMDT ( 5, 6, 7, ptop, 1, data, outdat, ier )
	    ptt  =  PR_TMCK ( outdat (2) )
	    IF  ( ERMISS ( outdat (3) ) ) outdat (3) = outdat (2)
	    pmx  =  PR_MIXR ( outdat (3), ptop )
	    CALL PC_CMDT ( 5, 6, 7, pbot, 1, data, outdat, ier )
	    qtt  =  PR_TMCK ( outdat (2) )
	    IF  ( ERMISS ( outdat (3) ) ) outdat (3) = outdat (2)
	    qmx  =  PR_MIXR ( outdat (3), pbot )
C
C*	    Compute linear coefficients for T and q on the
C*	    environmental temperature profile.
C
	    rpb  = ALOG ( pbot )
	    rpt  = ALOG ( ptop )
	    pdf  = ( rpb - rpt )
	    ae   = ( qmx - pmx ) * .001 / pdf
	    be   = ( pmx * rpb - qmx * rpt ) *.001 / pdf
	    ce   = ( qtt - ptt ) / pdf
	    de   = ( ptt * rpb - qtt * rpt ) / pdf
C
C*	    Get parcel data at the pressure levels.
C
	    xtt  =  PR_TMST ( thepar, ptop, 0. )
	    xttc =  PR_TMKC ( xtt )
	    xmx  =  PR_MIXR ( xttc, ptop )
	    ytt  =  PR_TMST ( thepar, pbot, 0. )
	    yttc =  PR_TMKC ( ytt )
	    ymx  =  PR_MIXR ( yttc, pbot )
C
C*	    Compute linear coefficients for T and q on the parcel
C*	    temperature profile.
C
	    ap   = ( ymx - xmx ) * .001 / pdf
	    bp   = ( xmx * rpb - ymx * rpt ) * .001 / pdf
	    cp   = ( ytt - xtt ) / pdf
	    dp   = ( xtt * rpb - ytt * rpt ) / pdf
C
C*	    Solve for P.
C
	    a    = ap * cp - ae * ce
	    b    = ( bp * cp - be * ce ) + ( ap * dp - ae * de )
     +		   + ( cp - ce ) / .6078
	    c    = bp * dp - be * de + ( dp - de ) / .6078
	    pest = ( - b + ( b ** 2 - 4. * a * c ) ** .5 ) / ( 2. * a )
	    pest = EXP ( pest )
	    PS_EQLV = pest
	  ELSE
C
C*	    Interpolation for temperature case:
C*
C*	    Do a linear interpolation in LN(P) to get PEST, an estimate
C*	    of the pressure that corresponds to THEPAR.  Iterately get
C*	    the interpolated data at PEST, compute the saturated THTE
C*	    at that level, and do a linear interpolation in LN(P) for
C*	    the new PEST.
C
	    tebot = PR_THTE ( pbot, tebot, tebot )
	    tetop = PR_THTE ( ptop, tetop, tetop )
C
	    oldest = RMISSD
	    pest   = pbot * ( ptop / pbot ) ** ( (thepar - tebot) /
     +					         (tetop  - tebot) )
C
C*	    Iterate until guess is within "close". Changed to 1.0 from
C*	    0.01.  Also iterate only until mxiter is achieved.
C
            close = 1.0
            mxiter = 100
            n = 0
	    DO  WHILE ( ( ABS ( pest - oldest ) .gt. close ) .and.
     +		        ( n .le. mxiter ) )
	        n = n + 1
	        oldest = pest
	        CALL PC_CMDT  ( 5, 6, 7, oldest, 1, data, outdat, ier )
C
	        teest = PR_THTE ( outdat (1), outdat (2), outdat (2) )
	        pest  = oldest * ( ptop / oldest ) **
     +			( (thepar - teest) / (tetop  - teest) )
	    END DO
C*
	    IF  ( n .gt. mxiter )  THEN
	        PS_EQLV = RMISSD
	      ELSE
	        PS_EQLV = pest
	    END IF
	END IF
C*
	RETURN
	END


c------------------------------------------------------------------------
c
c This file contains functions for dealing with higher order shape
c functions at the element level.
c
c Christian Whiting, Winter 1999
c------------------------------------------------------------------------

      subroutine getsgn(ien, sgn)
c------------------------------------------------------------------------
c     returns the matrix of mode signs used for negating higher order
c     basis functions. Connectivity array is assumed to have negative
c     signs on all modes to be negated.
c------------------------------------------------------------------------
      include "common.h"

      dimension ien(npro,nshl),  sgn(npro,nshl)

      do i=nenl+1,nshl
         where ( ien(:,i) < 0 )
            sgn(:,i) = -one
         elsewhere
            sgn(:,i) = one
         endwhere
      enddo

      return
      end

      subroutine getshp(shp, shgl, sgn, shape, shdrv)
c------------------------------------------------------------------------
c     returns the matrix of element shape functions with the higher
c     order modes correctly negated at the current quadrature point.
c------------------------------------------------------------------------
      include "common.h"

      dimension shp(nshl,ngauss),   shgl(nsd,nshl,ngauss),
     &          sgn(npro,nshl),     shape(npro,nshl),
     &          shdrv(npro,nsd,nshl)

      do i=1,nenl
         shape(:,i) = shp(i,intp)
         do j=1,3
            shdrv(:,j,i) = shgl(j,i,intp)
         enddo
      enddo
      if ( ipord > 1 ) then
         do i=nenl+1,nshl
            shape(:,i) = sgn(:,i) * shp(i,intp)
            do j=1,3
               shdrv(:,j,i) = shgl(j,i,intp)*sgn(:,i)
            enddo
         enddo
      endif

      return
      end

      subroutine getshpb(shp, shgl, sgn, shape, shdrv)
c------------------------------------------------------------------------
c     returns the matrix of element shape functions with the higher
c     order modes correctly negated at the current quadrature point.
c------------------------------------------------------------------------
      include "common.h"

      dimension shp(nshl,ngaussb),  shgl(nsd,nshl,ngaussb),
     &          sgn(npro,nshl),     shape(npro,nshl),
     &          shdrv(npro,nsd,nshl)

      do i=1,nenl
         shape(:,i) = shp(i,intp)
         do j=1,3
            shdrv(:,j,i) = shgl(j,i,intp)
         enddo
      enddo
      if ( ipord > 1 ) then
         do i=nenl+1,nshl
            shape(:,i) = sgn(:,i) * shp(i,intp)
            do j=1,3
               shdrv(:,j,i) = shgl(j,i,intp)*sgn(:,i)
            enddo
         enddo
      endif

      return
      end

      subroutine getbnodes(lnode)
c------------------------------------------------------------------------
c     compute the higher order modes that lie on the boundary of the
c     element.
c------------------------------------------------------------------------
      include "common.h"

      dimension lnode(27)

c
c.... boundary triangle of tet element
c
      if (lcsyst .eq. 1) then
         do n = 1, nenbl
            lnode(n) = n
         enddo
         if( ipord>1 ) then
            nem = ipord-1
            do n=1,3*nem
               lnode(nenbl+n) = nenbl+1+n
            enddo
         endif
         if( ipord>2 ) then
            nfm = (ipord-2)*(ipord-1)/2
            do n=1,nfm
               lnode(3+3*nem+n) = 4+6*nem+n
            enddo
         endif
c
c.....boundary quadrilateral for a hex element
c
      else if(lcsyst .eq. 2) then
         do n = 1, nenbl
            lnode(n) = n
         enddo
         if( ipord > 1) then
            nem = ipord -1
            do n=1,4*nem
               lnode(nenbl+n) = 8+n
            enddo
         endif

         if( ipord > 3) then
            nfm = (ipord-2)*(ipord-3)/2
            do n=1,nfm
               lnode(4+4*nem+n) = 8+12*nem+n
            enddo
         endif
c
c
c.... This renumbers the boundary nodes for a wedge element when the
c     boundary element is a quad face.  From lnode = [1 2 3 4]
c                                        to   lnode = [1 4 5 2]
c
      else if(lcsyst .eq. 3) then
         do n = 1, nenbl
            lnode(n) = n
         enddo
c
c     Need to implement for cubic, this valid only for ipord=2
c
         if( ipord>1 ) then
            nem = ipord-1
            do n=1,3*nem
               lnode(nenbl+n) = 6+n
            enddo
         endif
c
c     Boundary quad of wedge element
c
      else if(lcsyst .eq. 4) then
         lnode(1) = 1
         lnode(2) = 4
         lnode(3) = 5
         lnode(4) = 2
c$$$c
c$$$c     Need to implement for cubic, this valid only for ipord=2
c$$$c
c$$$         if( ipord > 1) then
c$$$            lnode(5) = 9
c$$$            lnode(6) = 15
c$$$            lnode(7) = 12
c$$$            lnode(8) = 13
c$$$               nem = ipord -1
c$$$               do n=1,4*nem
c$$$                  lnode(nenbl+n) = 6+n
c$$$               enddo
c$$$         endif
c
c     Boundary quad of pyramid element
c
      else if(lcsyst .eq. 5) then
         lnode(1) = 1
         lnode(2) = 2
         lnode(3) = 3
         lnode(4) = 4
c$$$  c
c$$$  c     Need to implement for cubic, this valid only for ipord=2
c$$$  c
c$$$            if( ipord > 1) then
c$$$               lnode(5) = 9
c$$$               lnode(6) = 15
c$$$               lnode(7) = 12
c$$$               lnode(8) = 13
c$$$               nem = ipord -1
c$$$               do n=1,4*nem
c$$$                  lnode(nenbl+n) = 6+n
c$$$               enddo
c$$$            endif
c
c     Boundary triangle of pyramid element
c
      else if(lcsyst .eq. 6) then
         lnode(1) = 1
         lnode(2) = 5
         lnode(3) = 2
c$$$c
c$$$c     Need to implement for cubic, this valid only for ipord=2
c$$$c
c$$$            if( ipord > 1) then
c$$$               lnode(5) = 9
c$$$               lnode(6) = 15
c$$$               lnode(7) = 12
c$$$               lnode(8) = 13
c$$$               nem = ipord -1
c$$$               do n=1,4*nem
c$$$                  lnode(nenbl+n) = 6+n
c$$$               enddo
c$$$            endif
c
c.... other element types need to be implemented
c
      else
         write (*,*) 'Boundary element not implemented for lcyst='
     &        ,lcsyst
         stop
      endif

      return
      end

c-----------------------------------------------------------------------
c
c  Evaluate coefficient vector at its interpolation points
c
c-----------------------------------------------------------------------
      subroutine evalAtInterp( ycoeff,  yvals,  x,   nvars, npts )

      use     pointer_data
      include "common.h"

      integer nvars, npts, nHits(nshg)

      real*8  ycoeff(nshg,ndof),   yvals(nshg,nvars),
     &        shp(nshl,npts),      shgl(nsd,nshl,npts),
     &        intpnt(3,npts),      x(numnp,nsd)

      real*8, allocatable :: ycl(:,:,:)
      real*8, allocatable :: xl(:,:,:)
      real*8, allocatable :: yvl(:,:,:)
      real*8, allocatable :: sgn(:,:)

      yvals = zero
c
c.... generate the shape functions at the interpolation points
c
      call getIntPnts(intpnt,npts)
      do i=1,npts
         call shpTet(ipord,intpnt(:,i),shp(:,i),shgl(:,:,i))
      enddo
c
c.... loop over element blocks
c
      nHits = 0
      do iblk = 1, nelblk
         iel    = lcblk(1,iblk)
         lcsyst = lcblk(3,iblk)
         nenl   = lcblk(5,iblk) ! no. of vertices per element
         nshl   = lcblk(10,iblk)
         ndofl  = lcblk(8,iblk)
         npro   = lcblk(1,iblk+1) - iel

         allocate ( ycl(npro,nshl,ndof ) )
         allocate ( yvl(npro,nshl,nvars) )
         allocate ( xl(npro,nenl,nsd   ) )
         allocate ( sgn(npro,nshl)       )

         call getsgn(mien(iblk)%p,sgn)

         call localy( ycoeff, ycl, mien(iblk)%p, ndof,  'gather  ')
         call localx( x,      xl,  mien(iblk)%p, nsd,   'gather  ')

         call eval  ( xl,       ycl,      yvl,
     &                shp,      shgl,     sgn,
     &                nvars,    npts    )

c
c.... average coefficients since stresses may be discontinuous
c
         call localSum( yvals,    yvl,    mien(iblk)%p,
     &                  nHits,    nVars)

         deallocate ( ycl )
         deallocate ( yvl )
         deallocate ( sgn )
         deallocate ( xl  )
c
      enddo

c
c.... average the global values
c
      do i = 1, nshg
         do j = 1, nvars
            yvals(i,j) = yvals(i,j)/nHits(i) !(real(nHits(i),8))
         enddo
      enddo

      return
      end

c-----------------------------------------------------------------------
c
c  evaluate in element coordinate system
c
c-----------------------------------------------------------------------
      subroutine eval( xl,      ycl,     yvl,
     &                 shp,     shgl,    sgn,
     &                 nvars,   npts )

      include "common.h"

      integer nvars
c
      real*8  ycl(npro,nshl,ndof),   yvl(npro,nshl,nvars),
     &        sgn(npro,nshl),        shape(npro,nshl),
     &        shdrv(npro,nsd,nshl),  shp(nshl,npts),
     &        shgl(nsd,nshl,npts),   xl(npro,nenl,nsd),
     &        shg(npro,nshl,nsd),    gradV(npro,nsd,nsd),
     &        dxidx(npro,nsd,nsd),   tmp(npro), wtmp

      yvl = zero
c
c.... loop over interpolation points
c
      do intp = 1, npts
         call getshp(shp,          shgl,      sgn,
     &               shape,        shdrv)

c
c.... pressure and velocity
c
         do i = 1, nshl
            do j = 1, 4
               yvl(:,intp,j) = yvl(:,intp,j) + shape(:,i) * ycl(:,i,j)
            enddo
         enddo
c
c.... viscous stress
c
         call e3metric( xl,         shdrv,      dxidx,
     &                  shg,        tmp)

         gradV = zero
         do n = 1, nshl
            gradV(:,1,1) = gradV(:,1,1) + shg(:,n,1) * ycl(:,n,2)
            gradV(:,2,1) = gradV(:,2,1) + shg(:,n,1) * ycl(:,n,3)
            gradV(:,3,1) = gradV(:,3,1) + shg(:,n,1) * ycl(:,n,4)
c
            gradV(:,1,2) = gradV(:,1,2) + shg(:,n,2) * ycl(:,n,2)
            gradV(:,2,2) = gradV(:,2,2) + shg(:,n,2) * ycl(:,n,3)
            gradV(:,3,2) = gradV(:,3,2) + shg(:,n,2) * ycl(:,n,4)
c
            gradV(:,1,3) = gradV(:,1,3) + shg(:,n,3) * ycl(:,n,2)
            gradV(:,2,3) = gradV(:,2,3) + shg(:,n,3) * ycl(:,n,3)
            gradV(:,3,3) = gradV(:,3,3) + shg(:,n,3) * ycl(:,n,4)
         enddo

         rmu = datmat(1,2,1)

         yvl(:,intp,6 ) = two * rmu * gradV(:,1,1)
         yvl(:,intp,7 ) = two * rmu * gradV(:,2,2)
         yvl(:,intp,8 ) = two * rmu * gradV(:,3,3)

         yvl(:,intp,9 ) = rmu * ( gradV(:,1,2) + gradV(:,2,1) )
         yvl(:,intp,10) = rmu * ( gradV(:,1,3) + gradV(:,3,1) )
         yvl(:,intp,11) = rmu * ( gradV(:,2,3) + gradV(:,3,2) )

c
c.... loop over interpolation points
c
      enddo

      return
      end


! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
! Slow manifolds computation in the self-coupled FitzHugh-Nagumo system
! ----------------------------------------------------------------------
! Continuation of canard orbits in parameter space
! ----------------------------------------------------------------------
! Ref.: Desroches, Krauskopf and Osinga, preprint of the UoB, 2009
! URL : http://rose.bris.ac.uk/dspace/handle/1983/1312
! ----------------------------------------------------------------------
! ----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

       DOUBLE PRECISION v, h, s, epsilon, gamma, delta, T

       ! Define the state variables
       v = U(1)
       h = U(2)
       s = U(3)

       ! Define the system parameters
       epsilon = PAR(1)
       gamma   = PAR(2)
       delta   = PAR(3)

       ! Define the integration time as a parameter
       T       = PAR(11)

       ! Define the right-hand sides
       F(1) = T * (h - (v**3 - v + 1) / 2 - gamma * s * v)
       F(2) = T * (-epsilon * (2 * h + 2.6d0 * v))
       F(3) = T * (-epsilon * delta * s)

      END SUBROUTINE FUNC

! ----------------------------------------------------------------------
! ----------------------------------------------------------------------

      SUBROUTINE STPNT
      END SUBROUTINE STPNT

! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

       ! Define the critical manifold S as {(v,h,s) ; 2*h-v^3+v-1-s*v=0}
       ! (we use the fact that gamma is fixed at the value 0.5)

       ! Define boundary conditions */
       FB(1) = U0(1) - PAR(4)  ! Initial point is on the intersection between S
       FB(2) = U0(2) - PAR(7)  ! and the plane {h=-6.0}
       FB(3) = 2*U0(2)-U0(1)**3+U0(1)-1-U0(3)*U0(1)

       FB(4) = U1(1)
       FB(5) = U1(2) - 0.5
       FB(6) = U1(3) - PAR(6)  ! End point is in a cross-section containing the
                               ! folded node: Sigma_fn={s=0.27970}
      END SUBROUTINE BCND

! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
      SUBROUTINE PVLS
      END SUBROUTINE PVLS
! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
      SUBROUTINE ICND
      END SUBROUTINE ICND
! ----------------------------------------------------------------------
! ----------------------------------------------------------------------
      SUBROUTINE FOPT
      END SUBROUTINE FOPT