!##############################################################################
!# ****************************************************************************
!# <name> geometryaux </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains low level auxiliary functions for geometric
!# objects like lines, triangles, quads or similar.
!#
!# The following routines can be found here:
!#
!#  1.) gaux_getAspectRatio_quad2D
!#      -> Calculate the aspect ratio of a 2D quadrilateral
!#
!#  2.) gaux_getArea_tria2D
!#      -> Calculate the signed area of a 2D triangle
!#
!#  3.) gaux_getArea_quad2D
!#      -> Calculate the area of a 2D quadrilateral
!#
!#  4.) gaux_getVolume_tetra3D
!#      -> Calculate the volume of a 3D tetrahedron
!#
!#  5.) gaux_getVolume_hexa3D
!#      -> Calculate the volume of a 3D hexahedron.
!#
!#  6.) gaux_isIntersection_line2D
!#      -> Checks if two (finite) lines in 2D intersect
!#
!#  7.) gaux_getIntersection_ray2D
!#      -> Calculates the intersection point of two rays (if they intersect)
!#
!#  8.) gaux_isInElement_quad2D
!#      -> Checks if a point is inside of a 2D quadrilateral
!#
!#  9.) gaux_isInElement_tri2D
!#      -> Checks if a point is inside of a 2D triangle
!#
!# 10.) gaux_getBarycentricCoords_tri2D
!#      -> Calculates the barycentric coordinates of a point relative
!#         to a specified triangle in 2D
!#
!# 11.) gaux_isFlipped_hexa3D
!#      -> Checks whether a hexahedron is flipped or not.
!#
!# 12.) gaux_isInElement_hexa
!#      -> Checks whether a point is in a hexa or not
!#
!# 13.) gaux_isIntersection_face
!#      -> test for face/line segment intersection
!#
!# 14.) gaux_isIntersection_triangle
!#      -> test for triangle/line segment intersection
!#
!# 15.) gaux_intersect_edgecircle
!#      -> calculates intersection of edge and circle
!#
!# 16.) gaux_intersect_quadcircle
!#      -> calculates intersection of quad and circle
!#
!# 17.) gaux_getDirectedExtentQuad2D
!#      -> Calculates the maximum length of a line in a given direction
!#         when embedded in a 2D quadrilateral
!#
!# </purpose>
!##############################################################################

module geometryaux

!$ use omp_lib
  use fsystem
  use basicgeometry
  use genoutput

  implicit none

  private

  public :: gaux_getAspectRatio_quad2D
  public :: gaux_getArea_tria2D
  public :: gaux_getArea_quad2D
  public :: gaux_getVolume_tetra3D
  public :: gaux_getVolume_hexa3D
  public :: gaux_isIntersection_line2D
  public :: gaux_getIntersection_ray2D
  public :: gaux_isIntersection_face
  public :: gaux_isInElement_quad2D
  public :: gaux_isInElement_tri2D
  public :: gaux_getBarycentricCoords_tri2D
  public :: gaux_isFlipped_hexa3D
  public :: gaux_isInElement_tetra
  public :: gaux_isInElement_hexa
  public :: gaux_calcDistPEdg2D
  public :: gaux_projectPointPlane
  public :: gaux_isInElement_hexa_aligned
  public :: gaux_intersect_edgecircle
  public :: gaux_intersect_quadcircle
  public :: gaux_getDirectedExtentQuad2D

contains

  ! ***************************************************************************

!<function>

  pure real(DP) function gaux_getAspectRatio_quad2D (Dpoints)

!<description>
  ! This routine calculates the aspect ratio of a 2D quadrilateral
  ! polygon. The polygon is given by the coordinates of its four corners,
  ! counterclockwise.
!</description>

!<input>
  ! The coordinates of the four corners of the polygon, ordered
  ! counterclockwise.
  ! Dpoints(1,.) = x-coordinates,
  ! Dpoints(2,.) = y-coordinates
  real(DP), dimension(2,4), intent(in) :: Dpoints
!</input>

!<result>
  ! The aspect ratio of the polygon.
!</result>

!</function>

    real(DP) :: XM1,XM2,XM3,XM4,YM1,YM2,YM3,YM4,LE1,LE2

    ! Calculate the position of the edge mitpoints
    XM1 = (Dpoints(1,2)+Dpoints(1,1))*0.5_DP
    YM1 = (Dpoints(2,2)+Dpoints(2,1))*0.5_DP
    XM2 = (Dpoints(1,3)+Dpoints(1,2))*0.5_DP
    YM2 = (Dpoints(2,3)+Dpoints(2,2))*0.5_DP
    XM3 = (Dpoints(1,4)+Dpoints(1,3))*0.5_DP
    YM3 = (Dpoints(2,4)+Dpoints(2,3))*0.5_DP
    XM4 = (Dpoints(1,1)+Dpoints(1,4))*0.5_DP
    YM4 = (Dpoints(2,1)+Dpoints(2,4))*0.5_DP

    ! Calculate the length of the edge between opposite midpoints
    ! (squared)...
    LE1 = (XM3-XM1)**2+(YM3-YM1)**2
    LE2 = (XM4-XM2)**2+(YM4-YM2)**2

    ! ...and the aspect ratio.
    gaux_getAspectRatio_quad2D = sqrt(LE1/max(LE2,1E-10_DP))

  end function

  ! ***************************************************************************

!<function>

  pure real(DP) function gaux_getArea_tria2D (Dpoints)

!<description>
    ! This routine calculates the signed area of a 2D triangular
    ! polygon. The polygon is given by the coordinates of its three
    ! corners, counterclockwise.
!</description>

!<input>
  ! The coordinates of the three corners of the polygon, ordered
  ! counterclockwise.
  ! Dpoints(1,.) = x-coordinates,
  ! Dpoints(2,.) = y-coordinates
    real(DP), dimension(2,3), intent(in) :: Dpoints
!</input>

!<result>
  ! The signed area of the polygon.
!</result>
!</function>

    gaux_getArea_tria2D = 0.5_DP*( &
        (Dpoints(1,2)-Dpoints(1,1))*(Dpoints(2,3)-Dpoints(2,1))-&
        (Dpoints(1,3)-Dpoints(1,1))*(Dpoints(2,2)-Dpoints(2,1)) )
  end function gaux_getArea_tria2D

  ! ***************************************************************************

!<function>

  real(DP) function gaux_getArea_quad2D (Dpoints)

!<description>
    ! This routine calculates the area of a 2D quadrilateral
    ! polygon. The polygon is given by the coordinates of its three
    ! corners, counterclockwise.
!</description>

!<input>
  ! The coordinates of the four corners of the polygon, ordered
  ! counterclockwise.
  ! Dpoints(1,.) = x-coordinates,
  ! Dpoints(2,.) = y-coordinates
    real(DP), dimension(2,4), intent(in) :: Dpoints
!</input>

!<result>
  ! The area of the polygon.
!</result>
!</function>

    ! local variables
    !INTEGER, DIMENSION(3), PARAMETER :: IpointSubset = (/1,3,4/)
    !REAL(DP), DIMENSION(2,3) :: Dpoints2
    !REAL(DP) :: daux1,daux2

    ! First approach (slow):
    ! Add the area of two subtriangles to get the area of the quad.
    !
    !Dpoints2 = Dpoints(:,IpointSubset)
    !daux1 = ABS(gaux_getArea_tria2D(Dpoints(:,1:3))) + &
    !        ABS(gaux_getArea_tria2D(Dpoints2))

    ! For computing the area of the quad, we use a formula documented at
    !
    !   http://softsurfer.com/Archive/algorithm_0101/algorithm_0101.htm
    !
    ! The formula was discovered by Pierre Varignon and first published in 1731.
    !
    ! `In modern linear algebra, as already noted, the area of a planar parallelogram
    !  is the magnitude of the cross product of two adjacent edge vectors.  So, for
    !  any 3D planar parallelogram V0V1V2V3, we have:`
    !
    !     A(V0V1V2V3) = 2 A(M0M1M2M3)
    !                 = 2 | (V1-V0) X (V3-V0) |     (cross product)
    !                 = ...
    !                 = (x1-x0)(y3-y0) - (x3-x1)(y1-y0)
    !
    !                     V3                V2
    !                       +--------------+
    !                     /              /
    !                   /              /
    !                 /              /
    !               /              /
    !             /              /
    !           /              /
    !         /              /
    !       +--------------+
    !     V0                V1
    !
    !
    ! `Next, for an arbitrary quadrilateral, one can compute its area using a
    !  parallelogram discovered by Pierre Varignon (first published in 1731).
    !  It is amazing that the Greeks missed Varignon`s simple result which was
    !  discovered 2000 years after Euclid!  Given any quadrilateral, one can take
    !  the midpoints of its 4 edges to get 4 vertices which form a new quadrilateral.
    !  It is then easy to show that this midpoint quadrilateral is always a
    !  parallelogram, called the "Varignon parallelogram", and that its area is
    !  exactly one-half the area of the original quadrilateral.  So, for a
    !  quadrilateral Q=V0V1V2V3, let this parallelogram have midpoint vertices
    !  M0M1M2M3 as shown in the diagram:`
    !
    !     V3         M2          V2
    !       +---------X---------+
    !       |       /   \       |
    !       |    /         \    |
    !       | /               \ |
    !    M3 X                   X M1
    !       | \               / |
    !       |    \         /    |
    !       |       \   /       |
    !       +---------X---------+
    !     V0         M0          V1
    !
    ! `From elementary geometry, we know that in triangle V0V1V2 the midpoint
    !  line M0M1 is parallel to the base V0V2.  In triangle V0V1V2V3, the line M3M2
    !  is parallel to that same base V0V2.  Thus, M0M1 and M3M2 are parallel to each other.
    !  Similarly, M0M3 and M1M2 are parallel, which shows that M0M1M2M3 is a parallelogram.
    !  The area relation is also easy to demonstrate, and we can compute the quadrilateral`s
    !  area as:`
    !
    !     A(V0V1V2V3) = 2 A(M0M1M2M3)
    !                 = 2 | (M1-M0) X (M3-M0) |     (cross product)
    !                 = ...
    !                 = 1/2 | (V2-V0) X (V3-V1) |
    !                 = ...
    !                 = (x2-x0)(y3-y1) - (x3-x1)(y2-y0)
    !
    ! `This formula for an arbitrary quadrilateral is just as efficient as the one for an
    !  arbitrary triangle, using only 2 multiplications and 5 additions.  For simple
    !  quadrilaterals, the area is positive when the vertices are oriented counterclockwise,
    !  and negative when they are clockwise.  However, it also works for nonsimple
    !  quadrilaterals and is equal to the difference in area of the two regions the
    !  quadrilateral bounds.  For example, in the following diagram where I is the
    !  self-intersection point of a nonsimple quadrilateral V0V1V2V3, we have:`
    !
    !     A(V0V1V2V3) = A(V0V1I) + A(IV2V3)
    !                 = A(V0V1I) + A(IV2V2)
    !
    !     V2                V3
    !       +--------------+
    !         \           /
    !           \       /
    !             \   /
    !               + I
    !             /   \                 .
    !           /       \               .
    !         /           \             .
    !       +--------------+
    !     V0                 V1

    gaux_getArea_quad2D = &
            0.5_DP *  abs( (Dpoints(1,3) - Dpoints(1,1) ) * &
                           (Dpoints(2,4) - Dpoints(2,2) ) - &
                           (Dpoints(1,4) - Dpoints(1,2) ) * &
                           (Dpoints(2,3) - Dpoints(2,1) ) )

  end function gaux_getArea_quad2D

!************************************************************************

!<function>

  pure real(DP) function gaux_getVolume_tetra3D (Dpoints)

!<description>
  ! This function calculates the volume of a 3D tetrahedron. The
  ! tetrahedron is given by the coordinates of its four corners.
!</description>

!<input>
  ! The coordinates of the four corners of the tetrahedron.
  ! Dpoints(1,.) = x-coordinates,
  ! Dpoints(2,.) = y-coordinates,
  ! Dpoints(3,.) = z-coordinates
  real(DP), dimension(3,4), intent(in) :: Dpoints
!</input>

!<result>
  ! The volume of the tetrahedron.
!</result>
!</function>

    ! A temporary array for the edge lengths
    real(DP), dimension(3,3) :: Dv

    Dv(1:3,1) = Dpoints(1:3,1) - Dpoints(1:3,4)
    Dv(1:3,2) = Dpoints(1:3,2) - Dpoints(1:3,4)
    Dv(1:3,3) = Dpoints(1:3,3) - Dpoints(1:3,4)

    ! Return the absolute volume
    gaux_getVolume_tetra3D = abs(&
        Dv(1,1) * (Dv(2,2)*Dv(3,3) - Dv(3,2)*Dv(2,3)) + &
        Dv(2,1) * (Dv(3,2)*Dv(1,3) - Dv(1,2)*Dv(3,3)) + &
        Dv(3,1) * (Dv(1,2)*Dv(2,3) - Dv(2,2)*Dv(1,3))) / 6.0_DP

  end function gaux_getVolume_tetra3D

!************************************************************************

!<function>

  pure real(DP) function gaux_getVolume_hexa3D (Dv)

!<description>
  ! This function calculates the volume of a 3D hexahedron. The
  ! hexahedron is given by the coordinates of its eight corners.
!</description>

!<input>
  ! The coordinates of the eight corners of the hexahedron.
  ! Dv(1,.) = x-coordinates,
  ! Dv(2,.) = y-coordinates,
  ! Dv(3,.) = z-coordinates
  real(DP), dimension(3,8), intent(in) :: Dv
!</input>

!<result>
  ! The volume of the hexahedron.
!</result>
!</function>

    ! Return the absolute volume
    gaux_getVolume_hexa3D = (1.0_DP / 6.0_DP) * (&
        abs((Dv(1,4)-Dv(1,1))*(Dv(2,4)-Dv(2,3))*(Dv(3,4)-Dv(3,8))&
           +(Dv(2,4)-Dv(2,1))*(Dv(3,4)-Dv(3,3))*(Dv(1,4)-Dv(1,8))&
           +(Dv(3,4)-Dv(3,1))*(Dv(1,4)-Dv(1,3))*(Dv(2,4)-Dv(2,8))&
           -(Dv(1,4)-Dv(1,8))*(Dv(2,4)-Dv(2,3))*(Dv(3,4)-Dv(3,1))&
           -(Dv(2,4)-Dv(2,8))*(Dv(3,4)-Dv(3,3))*(Dv(1,4)-Dv(1,1))&
           -(Dv(3,4)-Dv(3,8))*(Dv(1,4)-Dv(1,3))*(Dv(2,4)-Dv(2,1)))+&
        abs((Dv(1,2)-Dv(1,3))*(Dv(2,2)-Dv(2,1))*(Dv(3,2)-Dv(3,6))&
           +(Dv(2,2)-Dv(2,3))*(Dv(3,2)-Dv(3,1))*(Dv(1,2)-Dv(1,6))&
           +(Dv(3,2)-Dv(3,3))*(Dv(1,2)-Dv(1,1))*(Dv(2,2)-Dv(2,6))&
           -(Dv(1,2)-Dv(1,6))*(Dv(2,2)-Dv(2,1))*(Dv(3,2)-Dv(3,3))&
           -(Dv(2,2)-Dv(2,6))*(Dv(3,2)-Dv(3,1))*(Dv(1,2)-Dv(1,3))&
           -(Dv(3,2)-Dv(3,6))*(Dv(1,2)-Dv(1,1))*(Dv(2,2)-Dv(2,3)))+&
        abs((Dv(1,5)-Dv(1,8))*(Dv(2,5)-Dv(2,6))*(Dv(3,5)-Dv(3,1))&
           +(Dv(2,5)-Dv(2,8))*(Dv(3,5)-Dv(3,6))*(Dv(1,5)-Dv(1,1))&
           +(Dv(3,5)-Dv(3,8))*(Dv(1,5)-Dv(1,6))*(Dv(2,5)-Dv(2,1))&
           -(Dv(1,5)-Dv(1,1))*(Dv(2,5)-Dv(2,6))*(Dv(3,5)-Dv(3,8))&
           -(Dv(2,5)-Dv(2,1))*(Dv(3,5)-Dv(3,6))*(Dv(1,5)-Dv(1,8))&
           -(Dv(3,5)-Dv(3,1))*(Dv(1,5)-Dv(1,6))*(Dv(2,5)-Dv(2,8)))+&
        abs((Dv(1,7)-Dv(1,6))*(Dv(2,7)-Dv(2,8))*(Dv(3,7)-Dv(3,3))&
           +(Dv(2,7)-Dv(2,6))*(Dv(3,7)-Dv(3,8))*(Dv(1,7)-Dv(1,3))&
           +(Dv(3,7)-Dv(3,6))*(Dv(1,7)-Dv(1,8))*(Dv(2,7)-Dv(2,3))&
           -(Dv(1,7)-Dv(1,3))*(Dv(2,7)-Dv(2,8))*(Dv(3,7)-Dv(3,6))&
           -(Dv(2,7)-Dv(2,3))*(Dv(3,7)-Dv(3,8))*(Dv(1,7)-Dv(1,6))&
           -(Dv(3,7)-Dv(3,3))*(Dv(1,7)-Dv(1,8))*(Dv(2,7)-Dv(2,6)))+&
        abs((Dv(1,1)-Dv(1,3))*(Dv(2,1)-Dv(2,8))*(Dv(3,1)-Dv(3,6))&
           +(Dv(2,1)-Dv(2,3))*(Dv(3,1)-Dv(3,8))*(Dv(1,1)-Dv(1,6))&
           +(Dv(3,1)-Dv(3,3))*(Dv(1,1)-Dv(1,8))*(Dv(2,1)-Dv(2,6))&
           -(Dv(1,1)-Dv(1,6))*(Dv(2,1)-Dv(2,8))*(Dv(3,1)-Dv(3,3))&
           -(Dv(2,1)-Dv(2,6))*(Dv(3,1)-Dv(3,8))*(Dv(1,1)-Dv(1,3))&
           -(Dv(3,1)-Dv(3,6))*(Dv(1,1)-Dv(1,8))*(Dv(2,1)-Dv(2,3))))

  end function gaux_getVolume_hexa3D

!************************************************************************

!<subroutine>

  elemental subroutine gaux_isIntersection_line2D(&
      dx1,dy1,dx2,dy2,dx3,dy3,dx4,dy4, bintersect)

!<description>
  ! Checks whether the two 2D lines given by the start/endpoints
  ! (x1,y1)->(x2,y2) and (x3,y3)->(x4,y4) intersect each other.
!</description>

!<input>
  ! First point on ray 1.
  real(DP), intent(in) :: dx1,dy1

  ! A second point on ray 1. Must be different to (dx1,dy1)
  real(DP), intent(in) :: dx2,dy2

  ! First point on ray 2.
  real(DP), intent(in) :: dx3,dy3

  ! A second point on ray 2. Must be different to (dx3,dy3)
  real(DP), intent(in) :: dx4,dy4
!</input>

!<result>
  ! TRUE if the two rays intersect. FALSE otherwise.
  logical, intent(out) :: bintersect
!</result>

!</subroutine>

    ! local variables: aux parameters
    real(DP) :: daux1, daux2, daux3, daux4

    ! position of point 3 with respect to line between 1 and 2

    daux3 = (dx2-dx1)*(dy3-dy1) - (dy2-dy1)*(dx3-dx1)

    ! position of point 4 with respect to line between 1 and 2

    daux4 = (dx2-dx1)*(dy4-dy1) - (dy2-dy1)*(dx4-dx1)

    ! position of point 1 with respect to line between 3 and 4

    daux1 = (dx4-dx3)*(dy1-dy3) - (dy4-dy3)*(dx1-dx3)

    ! position of point 2 with respect to line between 3 and 4

    daux2 = (dx4-dx3)*(dy2-dy3) - (dy4-dy3)*(dx2-dx3)

    ! Determine if the lines truely intersect by checking the sign

    bintersect = ((daux3*daux4 .le. 0.0_DP) .and. &
                  (daux1*daux2 .le. 0.0_DP))

  end subroutine

!************************************************************************

!<subroutine>

  elemental subroutine gaux_getIntersection_ray2D(&
      dx0,dy0,dx1,dy1,dx2,dy2,dx3,dy3, dx,dy, iintersect, da)

!<description>
  ! Calculates the intersection point of two 2D rays given by
  ! (x1,y1)->(x2,y2) and (x3,y3)->(x4,y4).
!</description>

!<input>
  ! First point on ray 1.
  real(DP), intent(in) :: dx0,dy0

  ! A second point on ray 1. Must be different to (dx1,dy1)
  real(DP), intent(in) :: dx1,dy1

  ! First point on ray 2.
  real(DP), intent(in) :: dx2,dy2

  ! A second point on ray 2. Must be different to (dx3,dy3)
  real(DP), intent(in) :: dx3,dy3
!</input>

!<result>
  ! Intersection point.
  ! If the two rays do not intersect or are identical, this is set to (0,0).
  real(DP), intent(out) :: dx,dy

  ! Returns the type of intersection between the rays.
  ! =-1: The rays are the same
  ! = 0: The rays do not intersect.
  ! = 1: The rays intersect in exactly one point.
  integer, intent(out) :: iintersect

  ! Parameter value of the intersection.
  ! The intersection point (dx,dy) can be found at position
  ! (dx,dy) = (dx0,dy0) + da*(dx1-dx0,dy1-dy0).
  ! If iintersect<>1, da is set to 0.
  real(DP), intent(out) :: da
!</result>

!</subroutine>

    ! local variables
    real(DP) :: ddet

    ! Initial setting of the destination point
    dx = 0.0_DP
    dy = 0.0_DP
    iintersect = 0

    ! We have (hopefully) the situation
    !
    !               (X1,Y1)
    !                  |
    !                  |
    !  (X2,Y2) --------+--------- (X3,Y3)
    !                  |
    !                  |
    !               (X0,Y0)
    !
    ! and want to calculate the intersection point. This means
    ! we have to solve the linear system
    !
    !  ( X1-X0  X2-X3 ) * (a) = ( X2-X0 )
    !  ( Y1-Y0  Y2-Y3 )   (b)   ( Y2-Y0 )
    !
    ! to get the "parameter" values a,b along the two lines where
    ! the intersection occurs.
    !
    ! The determinant of the system is:

    ddet = dx1*dy2-dx1*dy3-dx0*dy2+dx0*dy3-dy1*dx2+dy1*dx3+dy0*dx2-dy0*dx3

    ! If it is =0, the lines are the same or completely different...

    if (ddet .eq. 0.0_DP) then

      ! If the vector (X2,Y2)->(X0,Y0) is linear dependent to
      ! (X2,Y2)->(X3,Y3), the lines are the same.

      ddet = -dy0*dx2-dx3*dy2+dy0*dx3+dx2*dy3+dx0*dy2-dx0*dy3

      if (ddet .eq. 0.0_DP) then
        iintersect = -1
      end if

      da = 0

    else

      ! There is an intersection point. Calculate one of the
      ! "parameter" values along the two lines.

      da = (dy0*dx2+dx3*dy2-dy0*dx3-dx2*dy3-dx0*dy2+dx0*dy3) / ddet

      !  The intersection point is then

      dx = da*dx1 + (1.0_DP-da)*dx0
      dy = da*dy1 + (1.0_DP-da)*dy0

      iintersect = 1

    end if

  end subroutine

!************************************************************************

#if defined(DEBUG) || defined(_DEBUG)
  subroutine gaux_isInElement_quad2D(dx,dy,DcornerCoords,binside)
#else

!<subroutine>
  pure subroutine gaux_isInElement_quad2D(dx,dy,DcornerCoords,binside)
#endif

!<description>
  ! Checks if a point (dx,dy) is inside of a 2D quadrilateral element
  ! given by the corners DcornerCoords.
!</description>

!<input>
  ! Point to check
  real(DP), intent(in) :: dx,dy

  ! Array with coordinates of the four corner points of the element.
  ! The corners must be ordered in counterclockwise order.
  !
  ! Note: For performance reasons, this array is defined as
  !   explicit array of dimension (2,4). As this deactivates array
  !   checking in Fortran, the caller must take care to specify exactly
  !   this type of array here!
#if defined(DEBUG) || defined(_DEBUG)
  real(DP), dimension(2,4), intent(in) :: DcornerCoords
#endif
!</input>

#if !defined(DEBUG) && !defined(_DEBUG)
  real(DP), dimension(:,:), intent(in) :: DcornerCoords
#endif

!<result>
  ! TRUE if (dx,dy) is inside of the element. FALSE otherwise.
  logical, intent(out) :: binside
!</result>

!</subroutine>

    ! local variables

    integer, parameter :: NVE = 4
    integer, dimension(4), parameter :: Inext = (/2,3,4,1/)
    real(DP) :: dxmid,dymid,dxdist,dydist,dxnormal,dynormal
    integer :: ive,ive2
    real(DP) :: dsproduct

#if defined(DEBUG) || defined(_DEBUG)
    if (ubound(DcornerCoords,1) .ne. NDIM2D) then
      call output_line ('Dimension 1 is not =2!',&
          OU_CLASS_ERROR,OU_MODE_STD,'gaux_isInElement_quad2D')
      call sys_halt()
    end if
#endif

    binside = .true.

    ! Compute edge-midpoints and normal vectors to the four
    ! edges on element IEL

    do ive=1,NVE

      ive2 = Inext(ive)   ! Use of Inext avoids a division by avoiding MOD!

      ! compute midpoints of element edges

      dxmid = 0.5_DP*(DcornerCoords(1,ive) + DcornerCoords(1,ive2))
      dymid = 0.5_DP*(DcornerCoords(2,ive) + DcornerCoords(2,ive2))

      ! compute normal vectors to element edges

      dxnormal =  DcornerCoords(2,ive2) - DcornerCoords(2,ive)
      dynormal = -DcornerCoords(1,ive2) + DcornerCoords(1,ive)

      ! compute vectors from edge midpoints to node 'ivt'

      dxdist = dx - dxmid
      dydist = dy - dymid

      ! Check whether 'ivt' belongs to element 'iel' or not by
      ! multiplying distance vectors with corresponding normal vectors.
      ! The sign of this scalar product determines whether we are
      ! 'left' or 'right' of the edge (because of the cosine formula).
      ! If the point is "righthand" of all four edges, it is inside
      ! of the element.

      dsproduct = dxdist*dxnormal + dydist*dynormal

      ! Actually we have to check against <=0, but it is more advisable
      ! to check against something that is 'near' 0 in terms
      ! of machine exactness...
      binside = binside .and. (dsproduct .le. SYS_EPSREAL_DP*100.0_DP)

    end do

  end subroutine

!************************************************************************

!<subroutine>

  pure subroutine gaux_getBarycentricCoords_tri2D(&
      DcornerCoords,dx,dy,dxi1,dxi2,dxi3)

!<description>
  ! Calculates the barycentric coordinates (dxi1,dxi2,dxi3) of a
  ! point (dx,dy) relative to a 2D triangular element specified by
  ! the coordinates of the three corners in DcornerCoords.
!</description>

!<input>
  ! Point in real coordinates
  real(DP), intent(in) :: dx,dy

  ! Array with coordinates of the three corner points of the element.
  ! The corners must be ordered in counterclockwise order.
  real(DP), dimension(:,:), intent(in) :: DcornerCoords
!</input>

!<result>
  ! The barycentric coordinates of (dx,dy) relative to the element
  ! specified by DcornerCoords.
  real(DP), intent(out) :: dxi1,dxi2,dxi3
!</result>

!</subroutine>

    ! local variables
    real(DP) :: DAX, DAY, DBX, DBY, DCX, DCY, DDET

    DAX = DcornerCoords(1, 1)
    DAY = DcornerCoords(2, 1)
    DBX = DcornerCoords(1, 2)
    DBY = DcornerCoords(2, 2)
    DCX = DcornerCoords(1, 3)
    DCY = DcornerCoords(2, 3)

    ! Example where to find this formula here:
    ! http://home.t-online.de/home/nagel.klaus/matdir/bary.htm

    DDET = 1.0_DP / ( DAX*(DBY-DCY) + DBX*(DCY-DAY) + DCX*(DAY-DBY) )
    dxi1 = (dx*(DBY-DCY)+DBX*(DCY-dy)+DCX*(dy-DBY)) * DDET
    dxi2 = (DAX*(dy-DCY)+dx*(DCY-DAY)+DCX*(DAY-dy)) * DDET
    dxi3 = (DAX*(DBY-dy)+DBX*(dy-DAY)+dx*(DAY-DBY)) * DDET

  end subroutine

!************************************************************************

!<subroutine>

  pure subroutine gaux_isInElement_tri2D(dx,dy,DcornerCoords,binside)

!<description>
  ! Checks if a point (dx,dy) is inside of a 2D triangular element
  ! given by the corners DcornerCoords.
!</description>

!<input>
  ! Point to check
  real(DP), intent(in) :: dx,dy

  ! Array with coordinates of the four corner points of the element.
  ! The corners must be ordered in counterclockwise order.
  !
  ! Note: For performance reasons, this array is defined as
  !   explicit array of dimension (2,4). As this deactivates array
  !   checking in Fortran, the caller must take care to specify exactly
  !   this type of array here!
  real(DP), dimension(2,4), intent(in) :: DcornerCoords
!</input>

!<result>
  ! TRUE if (dx,dy) is inside of the element. FALSE otherwise.
  logical, intent(out) :: binside
!</result>

!</subroutine>

    real(DP) :: dxi1,dxi2,dxi3

    ! We use barycentric coordinates for that task.
    ! Calculate the barycentric coordinates of the point relative
    ! to the element specified by DcornerCoords.
    call gaux_getBarycentricCoords_tri2D (DcornerCoords,dx,dy,&
        dxi1,dxi2,dxi3)

    ! If all barycentric coordinates are in the range [0..1],
    ! we are inside of the element
    binside = (dxi1 .ge. 0.0_DP) .and. (dxi1 .le. 1.0_DP) .and. &
              (dxi2 .ge. 0.0_DP) .and. (dxi2 .le. 1.0_DP) .and. &
              (dxi3 .ge. 0.0_DP) .and. (dxi3 .le. 1.0_DP)

  end subroutine

!************************************************************************

!<function>

  pure logical function gaux_isFlipped_hexa3D (Dpoints)

!<description>
  ! This function checks whether a 3D hexahedron is flipped.
!</description>

!<input>
  ! The coordinates of the eight corners of the hexahedron.
  ! Dpoints(1,.) = x-coordinates,
  ! Dpoints(2,.) = y-coordinates,
  ! Dpoints(3,.) = z-coordinates
  real(DP), dimension(3,8), intent(in) :: Dpoints
!</input>

!<result>
  ! .TRUE. if the hexahedron is flipped, otherwise .FALSE.
!</result>
!</function>

    ! Three vectors connecting two opposite faces of the hexahedron,
    ! and a normal vector
    real(DP), dimension(3) :: Du,Dv,Dw,Dn
    real(DP) :: dt

    Du(:) = 0.25_DP * (Dpoints(:,5)+Dpoints(:,6)+Dpoints(:,7)+Dpoints(:,8)&
                      -Dpoints(:,1)-Dpoints(:,2)-Dpoints(:,3)-Dpoints(:,4))
    Dv(:) = 0.25_DP * (Dpoints(:,3)+Dpoints(:,4)+Dpoints(:,7)+Dpoints(:,8)&
                      -Dpoints(:,1)-Dpoints(:,2)-Dpoints(:,5)-Dpoints(:,6))
    Dw(:) = 0.25_DP * (Dpoints(:,1)+Dpoints(:,4)+Dpoints(:,5)+Dpoints(:,8)&
                      -Dpoints(:,2)-Dpoints(:,3)-Dpoints(:,6)-Dpoints(:,7))

    ! Calculate normal n := u x v with 3d cross product
    Dn(1) = Du(2)*Dv(3) - Du(3)*Dv(2)
    Dn(2) = Du(3)*Dv(1) - Du(1)*Dv(3)
    Dn(3) = Du(1)*Dv(2) - Du(2)*Dv(1)

    ! Calculate scalar product t := < n, w >
    dt = Dn(1)*Dw(1) + Dn(2)*Dw(2) + Dn(3)*Dw(3)

    ! Now if dt < 0, then the hexahedron is flipped
    gaux_isFlipped_hexa3D = (dt .lt. 0.0_DP)

  end function gaux_isFlipped_hexa3D

!************************************************************************

!<subroutine>

  pure subroutine gaux_isInElement_tetra(dx,dy,dz,Dpoints,binside)

!<description>
  ! Checks if a point (dx,dy) is inside of a 2D triangular element
  ! given by the corners DcornerCoords.
!</description>

!<input>
  ! Point to check
  real(DP), intent(in) :: dx,dy,dz

  ! Array with coordinates of the four corner points of the element.
  ! The corners must be ordered in counterclockwise order.
  !
  ! Note: For performance reasons, this array is defined as
  !   explicit array of dimension (3,4). As this deactivates array
  !   checking in Fortran, the caller must take care to specify exactly
  !   this type of array here!
  real(DP), dimension(3,4), intent(in) :: Dpoints
!</input>

!<result>
  ! TRUE if (dx,dy) is inside of the element. FALSE otherwise.
  logical, intent(out) :: binside
!</result>

!</subroutine>
  real(DP), dimension(3,4) :: Dnormals
  real(DP), dimension(3,4) :: Dpv
  real(DP), dimension(3,1) :: DP1
  real(DP) :: ddot1,ddot2,ddot3,ddot4

  DP1(1,1)=dx
  DP1(2,1)=dy
  DP1(3,1)=dz

  ! compute the face normals
  Dnormals(1,1) = ((Dpoints(2,2) - Dpoints(2,4)) * (Dpoints(3,3) - Dpoints(3,4))) &
                - ((Dpoints(3,2) - Dpoints(3,4)) * (Dpoints(2,3) - Dpoints(2,4)))

  Dnormals(2,1) = ((Dpoints(3,2) - Dpoints(3,4)) * (Dpoints(1,3) - Dpoints(1,4))) &
                - ((Dpoints(1,2) - Dpoints(1,4)) * (Dpoints(3,3) - Dpoints(3,4)))

  Dnormals(3,1) = ((Dpoints(1,2) - Dpoints(1,4)) * (Dpoints(2,3) - Dpoints(2,4))) &
                - ((Dpoints(2,2) - Dpoints(2,4)) * (Dpoints(1,3) - Dpoints(1,4)))

  Dnormals(1,2) = ((Dpoints(2,1) - Dpoints(2,3)) * (Dpoints(3,4) - Dpoints(3,3))) &
                - ((Dpoints(3,1) - Dpoints(3,3)) * (Dpoints(2,4) - Dpoints(2,3)))

  Dnormals(2,2) = ((Dpoints(3,1) - Dpoints(3,3)) * (Dpoints(1,4) - Dpoints(1,3))) &
                - ((Dpoints(1,1) - Dpoints(1,3)) * (Dpoints(3,4) - Dpoints(3,3)))

  Dnormals(3,2) = ((Dpoints(1,1) - Dpoints(1,3)) * (Dpoints(2,4) - Dpoints(2,3))) &
                - ((Dpoints(2,1) - Dpoints(2,3)) * (Dpoints(1,4) - Dpoints(1,3)))

  Dnormals(1,3) = ((Dpoints(2,4) - Dpoints(2,2)) * (Dpoints(3,1) - Dpoints(3,2))) &
                - ((Dpoints(3,4) - Dpoints(3,2)) * (Dpoints(2,1) - Dpoints(2,2)))

  Dnormals(2,3) = ((Dpoints(3,4) - Dpoints(3,2)) * (Dpoints(1,1) - Dpoints(1,2))) &
                - ((Dpoints(1,4) - Dpoints(1,2)) * (Dpoints(3,1) - Dpoints(3,2)))

  Dnormals(3,3) = ((Dpoints(1,4) - Dpoints(1,2)) * (Dpoints(2,1) - Dpoints(2,2))) &
                - ((Dpoints(2,4) - Dpoints(2,2)) * (Dpoints(1,1) - Dpoints(1,2)))

  Dnormals(1,4) = ((Dpoints(2,3) - Dpoints(2,1)) * (Dpoints(3,2) - Dpoints(3,1))) &
                - ((Dpoints(3,3) - Dpoints(3,1)) * (Dpoints(2,2) - Dpoints(2,1)))

  Dnormals(2,4) = ((Dpoints(3,3) - Dpoints(3,1)) * (Dpoints(1,2) - Dpoints(1,1))) &
                - ((Dpoints(1,3) - Dpoints(1,1)) * (Dpoints(3,2) - Dpoints(3,1)))

  Dnormals(3,4) = ((Dpoints(1,3) - Dpoints(1,1)) * (Dpoints(2,2) - Dpoints(2,1))) &
                - ((Dpoints(2,3) - Dpoints(2,1)) * (Dpoints(1,2) - Dpoints(1,1)))

  ! calculate all p-v
  Dpv(1:3,1)= DP1(1:3,1) - Dpoints(1:3,4)

  Dpv(1:3,2)= DP1(1:3,1) - Dpoints(1:3,3)

  Dpv(1:3,3)= DP1(1:3,1) - Dpoints(1:3,2)

  Dpv(1:3,4)= DP1(1:3,1) - Dpoints(1:3,1)

  ddot1 = Dpv(1,1) * Dnormals(1,1) + Dpv(2,1) * Dnormals(2,1) + Dpv(3,1) * Dnormals(3,1)
  ddot2 = Dpv(1,2) * Dnormals(1,2) + Dpv(2,2) * Dnormals(2,2) + Dpv(3,2) * Dnormals(3,2)
  ddot3 = Dpv(1,3) * Dnormals(1,3) + Dpv(2,3) * Dnormals(2,3) + Dpv(3,3) * Dnormals(3,3)
  ddot4 = Dpv(1,4) * Dnormals(1,4) + Dpv(2,4) * Dnormals(2,4) + Dpv(3,4) * Dnormals(3,4)

  if((ddot1 .le. 0.0001_dp).and.(ddot2 .le. 0.0001_dp).and.(ddot3 .le. 0.0001_dp).and.(ddot4 .le. 0.0001_dp))then
    binside = .true.
  else
    binside = .false.
  end if

  end subroutine

!************************************************************************

!<subroutine>

  pure subroutine gaux_isInElement_hexa(dx,dy,dz,Dpoints,binside)

!<description>
  ! Checks whether a point (dx,dy,dz) is inside of a hexahedron
!</description>

!<input>
  ! Point to check
  real(DP), intent(in) :: dx,dy,dz

  ! Array with coordinates of the four corner points of the element.
  ! The corners must be ordered in counterclockwise order!
  !
  ! Note: For performance reasons, this array is defined as
  !   explicit array of dimension (3,8). As this deactivates array
  !   checking in Fortran, the caller must take care to specify exactly
  !   this type of array here!
  real(DP), dimension(3,8), intent(in) :: Dpoints
!</input>

!<result>
  ! TRUE if (dx,dy) is inside of the element. FALSE otherwise.
  logical, intent(out) :: binside
!</result>

!</subroutine>
  real(dp), dimension(3,6) :: dnormals
  real(DP), dimension(3,6) :: Dpv
  real(DP), dimension(3,1) :: DP1
  real(DP) :: ddot1,ddot2,ddot3,ddot4,ddot5,ddot6,length
  real(DP) :: eps
  integer :: i

  DP1(1,1)=dx
  DP1(2,1)=dy
  DP1(3,1)=dz

  eps=1e-10

  ! compute the face normals 1
  Dnormals(1,1) = ((Dpoints(2,4) - Dpoints(2,1)) * (Dpoints(3,2) - Dpoints(3,1))) &
                - ((Dpoints(3,4) - Dpoints(3,1)) * (Dpoints(2,2) - Dpoints(2,1)))

  Dnormals(2,1) = ((Dpoints(3,4) - Dpoints(3,1)) * (Dpoints(1,2) - Dpoints(1,1))) &
                - ((Dpoints(1,4) - Dpoints(1,1)) * (Dpoints(3,2) - Dpoints(3,1)))

  Dnormals(3,1) = ((Dpoints(1,4) - Dpoints(1,1)) * (Dpoints(2,2) - Dpoints(2,1))) &
                - ((Dpoints(2,4) - Dpoints(2,1)) * (Dpoints(1,2) - Dpoints(1,1)))

  ! compute the face normals 2
  Dnormals(1,2) = ((Dpoints(2,2) - Dpoints(2,1)) * (Dpoints(3,5) - Dpoints(3,1))) &
                - ((Dpoints(3,2) - Dpoints(3,1)) * (Dpoints(2,5) - Dpoints(2,1)))

  Dnormals(2,2) = ((Dpoints(3,2) - Dpoints(3,1)) * (Dpoints(1,5) - Dpoints(1,1))) &
                - ((Dpoints(1,2) - Dpoints(1,1)) * (Dpoints(3,5) - Dpoints(3,1)))

  Dnormals(3,2) = ((Dpoints(1,2) - Dpoints(1,1)) * (Dpoints(2,5) - Dpoints(2,1))) &
                - ((Dpoints(2,2) - Dpoints(2,1)) * (Dpoints(1,5) - Dpoints(1,1)))
  ! compute the face normals 3
  Dnormals(1,3) = ((Dpoints(2,7) - Dpoints(2,3)) * (Dpoints(3,2) - Dpoints(3,3))) &
                - ((Dpoints(3,7) - Dpoints(3,3)) * (Dpoints(2,2) - Dpoints(2,3)))

  Dnormals(2,3) = ((Dpoints(3,7) - Dpoints(3,3)) * (Dpoints(1,2) - Dpoints(1,3))) &
                - ((Dpoints(1,7) - Dpoints(1,3)) * (Dpoints(3,2) - Dpoints(3,3)))

  Dnormals(3,3) = ((Dpoints(1,7) - Dpoints(1,3)) * (Dpoints(2,2) - Dpoints(2,3))) &
                - ((Dpoints(2,7) - Dpoints(2,3)) * (Dpoints(1,2) - Dpoints(1,3)))
  ! compute the face normals 4
  Dnormals(1,4) = ((Dpoints(2,4) - Dpoints(2,3)) * (Dpoints(3,7) - Dpoints(3,3))) &
                - ((Dpoints(3,4) - Dpoints(3,3)) * (Dpoints(2,7) - Dpoints(2,3)))

  Dnormals(2,4) = ((Dpoints(3,4) - Dpoints(3,3)) * (Dpoints(1,7) - Dpoints(1,3))) &
                - ((Dpoints(1,4) - Dpoints(1,3)) * (Dpoints(3,7) - Dpoints(3,3)))

  Dnormals(3,4) = ((Dpoints(1,4) - Dpoints(1,3)) * (Dpoints(2,7) - Dpoints(2,3))) &
                - ((Dpoints(2,4) - Dpoints(2,3)) * (Dpoints(1,7) - Dpoints(1,3)))
  ! compute the face normals 5
  Dnormals(1,5) = ((Dpoints(2,4) - Dpoints(2,8)) * (Dpoints(3,5) - Dpoints(3,8))) &
                - ((Dpoints(3,4) - Dpoints(3,8)) * (Dpoints(2,5) - Dpoints(2,8)))

  Dnormals(2,5) = ((Dpoints(3,4) - Dpoints(3,8)) * (Dpoints(1,5) - Dpoints(1,8))) &
                - ((Dpoints(1,4) - Dpoints(1,8)) * (Dpoints(3,5) - Dpoints(3,8)))

  Dnormals(3,5) = ((Dpoints(1,4) - Dpoints(1,8)) * (Dpoints(2,5) - Dpoints(2,8))) &
                - ((Dpoints(2,4) - Dpoints(2,8)) * (Dpoints(1,5) - Dpoints(1,8)))

  ! compute the face normals 6
  Dnormals(1,6) = ((Dpoints(2,7) - Dpoints(2,6)) * (Dpoints(3,5) - Dpoints(3,6))) &
                - ((Dpoints(3,7) - Dpoints(3,6)) * (Dpoints(2,5) - Dpoints(2,6)))

  Dnormals(2,6) = ((Dpoints(3,7) - Dpoints(3,6)) * (Dpoints(1,5) - Dpoints(1,6))) &
                - ((Dpoints(1,7) - Dpoints(1,6)) * (Dpoints(3,5) - Dpoints(3,6)))

  Dnormals(3,6) = ((Dpoints(1,7) - Dpoints(1,6)) * (Dpoints(2,5) - Dpoints(2,6))) &
                - ((Dpoints(2,7) - Dpoints(2,6)) * (Dpoints(1,5) - Dpoints(1,6)))

  do i=1,6
    length=sqrt(Dnormals(1,i)**2+Dnormals(2,i)**2+Dnormals(3,i)**2)
    Dnormals(1,i)=Dnormals(1,i)/length
    Dnormals(2,i)=Dnormals(2,i)/length
    Dnormals(3,i)=Dnormals(3,i)/length
  end do

  ! calculate all p-v
  Dpv(1:3,1)= DP1(1:3,1) - Dpoints(1:3,1)

  Dpv(1:3,2)= DP1(1:3,1) - Dpoints(1:3,2)

  Dpv(1:3,3)= DP1(1:3,1) - Dpoints(1:3,3)

  Dpv(1:3,4)= DP1(1:3,1) - Dpoints(1:3,4)

  Dpv(1:3,5)= DP1(1:3,1) - Dpoints(1:3,5)

  Dpv(1:3,6)= DP1(1:3,1) - Dpoints(1:3,6)

  ddot1 = Dpv(1,1) * Dnormals(1,1) + Dpv(2,1) * Dnormals(2,1) + Dpv(3,1) * Dnormals(3,1)
  ddot2 = Dpv(1,2) * Dnormals(1,2) + Dpv(2,2) * Dnormals(2,2) + Dpv(3,2) * Dnormals(3,2)
  ddot3 = Dpv(1,3) * Dnormals(1,3) + Dpv(2,3) * Dnormals(2,3) + Dpv(3,3) * Dnormals(3,3)
  ddot4 = Dpv(1,4) * Dnormals(1,4) + Dpv(2,4) * Dnormals(2,4) + Dpv(3,4) * Dnormals(3,4)
  ddot5 = Dpv(1,5) * Dnormals(1,5) + Dpv(2,5) * Dnormals(2,5) + Dpv(3,5) * Dnormals(3,5)
  ddot6 = Dpv(1,6) * Dnormals(1,6) + Dpv(2,6) * Dnormals(2,6) + Dpv(3,6) * Dnormals(3,6)

  if((ddot1 .le. eps).and.(ddot2 .le. eps).and.(ddot3 .le. eps).and.&
     (ddot4 .le. eps).and.(ddot5 .le. eps).and.(ddot6 .le. eps))then
    binside = .true.
  else
    binside = .false.
  end if

  end subroutine

!************************************************************************

!<subroutine>

  pure subroutine gaux_isIntersection_face(&
      Dpoint1,Dpoint2,Dface, bintersect)

!<description>
! This routine calculates whether there is
! an intersection between the face Dface and the
! line defined by the vertices Dpoint1 and Dface
! the face is split into two triangles, the
! triangles are tested for intersection
!</description>

!<input>
  ! First point on ray
  real(DP), dimension(3), intent(in) :: Dpoint1

  ! second point on ray
  real(DP), dimension(3), intent(in) :: Dpoint2

  ! Vertices of the face
  real(DP), dimension(3,4), intent(in) :: Dface

  ! TRUE if the two rays intersect. FALSE otherwise.
  logical, intent(out) :: bintersect
!</result>

!</subroutine>

    ! we split up the face into two triangles
    real(DP), dimension(3,3) :: Dtri1
    real(DP), dimension(3,3) :: Dtri2

    ! build the first triangle
    Dtri1(1:3,1)=Dface(1:3,1)
    Dtri1(1:3,2)=Dface(1:3,2)
    Dtri1(1:3,3)=Dface(1:3,4)

    ! build the second triangle
    Dtri2(1:3,1)=Dface(1:3,2)
    Dtri2(1:3,2)=Dface(1:3,3)
    Dtri2(1:3,3)=Dface(1:3,4)

    ! test for intersection
    call gaux_isIntersection_triangle(Dpoint1,Dpoint2,Dtri1,bintersect)

    if (bintersect) then
      return
    end if

    ! test for intersection
    call gaux_isIntersection_triangle(Dpoint1,Dpoint2,Dtri2,bintersect)

    if (bintersect) then
      return
    end if

    ! no intersection
    bintersect = .false.

  end subroutine

!************************************************************************

!<subroutine>

  pure subroutine gaux_isIntersection_triangle(&
      Dpoint1,Dpoint2,Dtri, bintersect)

!<description>
! This routine calculates whether there is
! an intersection between the triangle Dtri and
! the line segment between Dpoint1 and Dpoint2
!</description>

!<input>
  ! start of the ray
  real(DP), dimension(3), intent(in) :: Dpoint1

  ! 2nd point of the ray
  real(DP), dimension(3), intent(in) :: Dpoint2

  ! Vertices of the face
  real(DP), dimension(3,3), intent(in) :: Dtri

  ! TRUE if the two rays intersect. FALSE otherwise.
  logical, intent(out) :: bintersect
!</result>

!</subroutine>
  real(dp) :: eps, dot, dot2, dot3, u, v, t
  real(dp), dimension(3) :: De1, De2, p, s, q, Ddirect

  ! our epsilon when we test for zero
  eps = 0.000001_dp
  ! the algorithm is as follows, it is called the Moeller & Trumbore algorithm
  !
  ! A * B with
  !
  ! A := 1/dot(Ddirect x (Dtri(:,2)-Dtri(:,0)),(Dtri(:,1)-Dtri(:,0)))
  !
  !      |dot((Dpoint2-Dtri(:,0)) x (Dtri(:,1)-Dtri(:,0)),(Dtri(:,2)-Dtri(:,0)))|
  ! B := |dot(Ddirect x (Dtri(:,2)-Dtri(:,0))            ,(Dpoint2-Dtri(:,0)))  |
  !      |dot((Dpoint2-Dtri(:,0)) x (Dtri(:,1)-Dtri(:,0)),Ddirect))             |

  Ddirect(1:3) = Dpoint2(1:3) - Dpoint1(1:3)

  De1(1:3) = Dtri(1:3,2) - Dtri(1:3,1)
  De2(1:3) = Dtri(1:3,3) - Dtri(1:3,1)

  p(1) = Ddirect(2)*De2(3) - Ddirect(3)*De2(2)
  p(2) = Ddirect(3)*De2(1) - Ddirect(1)*De2(3)
  p(3) = Ddirect(1)*De2(2) - Ddirect(2)*De2(1)

  dot = p(1) * De1(1) + p(2) * De1(2) + p(3) * De1(3)

  if(dot > -eps .and. dot < eps)then
    bintersect = .false.
    return
  end if

  dot = 1.0_dp/dot

  s(:) = Dpoint1(:) - Dtri(:,1)

  dot2 =  s(1) * p(1) + s(2) * p(2) + s(3) * p(3)

  u = dot * dot2

  if(u < 0.0_dp .or. u > 1.0_dp)then
    bintersect = .false.
    return
  end if

  q(1) = s(2)*De1(3) - s(3)*De1(2)
  q(2) = s(3)*De1(1) - s(1)*De1(3)
  q(3) = s(1)*De1(2) - s(2)*De1(1)

  dot3 =  q(1) * Ddirect(1) + q(2) * Ddirect(2) + q(3) * Ddirect(3)

  v = dot * dot3

  if(v < 0.0_dp .or. v > 1.0_dp)then
    bintersect = .false.
    return
  end if

  t = dot * (De2(1) * q(1) + De2(2) * q(2) + De2(3) * q(3))

  if(t > 0.0_dp .and. t < 1.0_dp)then
    bintersect = .true.
  end if

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine gaux_calcDistPEdg2D(DpointA,Dedge1,Dedge2,dist,t)

!<description>
    ! Calculated the distance between a point and an edge in 2d
!</description>

!<input>
  !
  ! The coordinates of the point
  ! DpointA(1) = x-coordinates,
  ! DpointA(2) = y-coordinates
  real(DP), dimension(2), intent(in) :: DpointA
  ! the first vertex of the edge in real coordinates
  real(DP), dimension(2), intent(in) :: Dedge1
  ! the 2nd vertex of the edge in real coordinates
  real(DP), dimension(2), intent(in) :: Dedge2
!</input>
  real(dp), intent(out)              :: dist
  real(dp), intent(out)              :: t
!<result>
  ! The distance
!</result>
!</subroutine>
  ! parameter in the edge equation: edge=Dedge1+t*(Dedge2-Dedge1), t in [0,1]
  real(dp) :: r2
  real(DP), dimension(2) :: r,YP

  r(:)=Dedge2(:)-Dedge1(:)

  r2=r(1)**2+r(2)**2
  YP(:)=DpointA(:)-Dedge1(:)
  t=r(1)*YP(1)+r(2)*YP(2)
  t=t/r2

  if(t .le. 0.0_dp)then
    dist = sqrt(YP(1)**2 + YP(2)**2)
    return
  else if(t .ge. 1.0_dp)then
    YP(:)=DpointA(:)-Dedge2(:)
    dist = sqrt(YP(1)**2 + YP(2)**2)
  return
  else
    r(:)=r(:)*t
    r(:)=r(:)+Dedge1(:)
    YP(:)=DpointA(:)-r(:)
    dist = sqrt(YP(1)**2 + YP(2)**2)
    return
  end if

  end subroutine gaux_calcDistPEdg2D

!************************************************************************

!<subroutine>

 pure subroutine gaux_projectPointPlane(DPoint,DR1,DR2,DQ,DQP)
!<description>
  ! This routine projects a point onto a plane.
  ! the plane must be entered in parameterform that means:E= p + alpha*r1 + beta*r2
  ! the code will transform this to point normal form and calculate the result
!</description>

!<input>
  ! the p in the equation for E above
  real(DP), dimension(3), intent(in) :: DPoint
  ! the r1 in the equation for E above
  real(DP), dimension(3), intent(in) :: DR1
  ! the r2 in the equation for E above
  real(DP), dimension(3), intent(in) :: DR2
  ! the point that should be projected
!</input>
!<inputoutput>
  real(DP), dimension(3), intent(inout) :: DQ
  ! the projection of DQ onto the plane
  real(DP), dimension(3), intent(inout) :: DQP
!</inputoutput>
!</subroutine>
  ! local variables
  real(DP) :: d,n,q
  real(DP), dimension(3) :: DN, DNscaled

  DN(1)=DR1(2)*DR2(3)-DR1(3)*DR2(2)
  DN(2)=DR1(3)*DR2(1)-DR1(1)*DR2(3)
  DN(3)=DR1(1)*DR2(2)-DR1(2)*DR2(1)

  n=sqrt(DN(1)**2 + DN(2)**2 + DN(3)**2)
  DN(:)=DN(:)/n

  d = -1.0_dp * (DN(1)*DPoint(1)+DN(2)*DPoint(2)+DN(3)*DPoint(3))

  q = (DQ(1)*DN(1)+DQ(2)*DN(2)+DQ(3)*DN(3))+d

  DNscaled(:)=q*DN(:)

  DQP(:)=DQ(:)-DNscaled(:)

  end subroutine

!************************************************************************

!<subroutine>

  pure subroutine gaux_isInElement_hexa_aligned(dx,dy,dz,Dpoints,binside)

!<description>
  ! Checks whether a point (dx,dy,dz) is inside of a hexahedron
  ! The subroutine is faster than the general subroutine
  ! but it does not give correct results if the sides of the hexa
  ! are not aligned with the coordinate axes
!</description>

!<input>
  ! Point to check
  real(DP), intent(in) :: dx,dy,dz

  ! Array with coordinates of the four corner points of the element.
  ! The corners must be ordered in counterclockwise order!
  !
  ! Note: For performance reasons, this array is defined as
  !   explicit array of dimension (3,8). As this deactivates array
  !   checking in Fortran, the caller must take care to specify exactly
  !   this type of array here!
  real(DP), dimension(3,8), intent(in) :: Dpoints
!</input>

!<result>
  ! TRUE if (dx,dy) is inside of the element. FALSE otherwise.
  logical, intent(out) :: binside
!</result>

!</subroutine>
  real(DP), dimension(3,1) :: DP1
  real(DP) :: xmin,xmax,ymin,ymax,zmin,zmax,eps
  integer :: i

  DP1(1,1)=dx
  DP1(2,1)=dy
  DP1(3,1)=dz

  eps=1e-10

  xmin=1e+32
  xmax=-1e+32
  ymin=1e+32
  ymax=-1e+32
  zmin=1e+32
  zmax=-1e+32

  do i=1,8

    if(Dpoints(1,i).lt.xmin)then
      xmin=Dpoints(1,i)
    end if
    if(Dpoints(1,i).gt.xmax)then
      xmax=Dpoints(1,i)
    end if

    if(Dpoints(2,i).lt.ymin)then
      ymin=Dpoints(2,i)
    end if
    if(Dpoints(2,i).gt.ymax)then
      ymax=Dpoints(2,i)
    end if

    if(Dpoints(3,i).lt.zmin)then
      zmin=Dpoints(3,i)
    end if
    if(Dpoints(3,i).gt.zmax)then
      zmax=Dpoints(3,i)
    end if

  end do

  if((dx .ge. xmin).and.(dx .le. xmax).and. &
     (dy .ge. ymin).and.(dy .le. ymax).and. &
     (dz .ge. zmin).and.(dz .le. zmax))then
     binside=.true.
  else
     binside=.false.
  end if

  end subroutine

!************************************************************************

!<subroutine>

  pure subroutine gaux_intersect_quadcircle(drad,Dc,Dquad,Iresult,Dintersection)

!<description>
  ! This routine calculates the number of intersections
  ! of a circle with a quad and returns the intersection points
!</description>

!<input>
  ! Radius of the circle
  real(DP), intent(in) :: drad
  ! the center of the circle
  real(DP), dimension(2),intent(in) :: Dc

  ! The four corner vertices of the quad
  real(DP), dimension(2,4), intent(in) :: Dquad
!</input>

!<result>
  ! There are at maximum 8 intersections between a circle and a quad
  ! if the quad is
  !
  !   1----2
  !   |    |
  !   4----3
  ! Iresult(1)=2 if there are 2 intersection on edge 12
  ! Iresult(1)=1 if there is 1 intersection on edge 12
  ! Iresult(1)=0 if there is no intersection on edge 12
  ! Iresult(2)=2 if there are 2 intersection on edge 23
  ! ... and so on
  integer, dimension(4), intent(out) :: Iresult
  ! the possible 8 points of intersection
  ! if Iresult(1)=2 then Dintersection(:,1-2) stores the
  ! 2 points of intersection on edge 12
  ! if Iresult(1)=1 then Dintersection(:,1) stores the
  ! point of intersection on edge 12 and Dintersection(:,2) is empty
  ! ... and so on
  real(DP), dimension(2,8), intent(out) :: Dintersection
!</result>

!</subroutine>
  real(DP), dimension(2,2) :: Dedge
  real(DP), dimension(2,2) :: Dintersec
  integer :: i,iintersections

  Dintersection=0
  Iresult=0
  ! loop over all edges of the quad
  do i=1,4
    iintersections=0
    Dintersec=0
    Dedge(:,1) = Dquad(:,i)
    Dedge(:,2) = Dquad(:,mod(i,4)+1)
    call gaux_intersect_edgecircle(drad,Dc,Dedge,iintersections,Dintersec)
    Iresult(i)=iintersections
    Dintersection(:,2*i-1)=Dintersec(:,1)
    Dintersection(:,2*i)=Dintersec(:,2)
  end do

  end subroutine

!************************************************************************

!<subroutine>

  pure subroutine gaux_intersect_edgecircle(drad,Dc,Dedge,iresult,Dintersec)

!<description>
  ! computes the number and the intersection points of a circle and an edge
!</description>

!<input>
  ! radius of the circle
  real(DP), intent(in) :: drad
  ! Center of the circle
  real(DP), dimension(2),intent(in) :: Dc
  ! The two points of the edge
  real(DP), dimension(2,2), intent(in) :: Dedge
!</input>

!<result>
  ! The coordinates of the intersection points
  real(DP), dimension(2,2),intent(inout) :: Dintersec
  ! the number of intersection points on the edge
  integer, intent(out) :: iresult
!</result>

!</subroutine>
  real(dp), dimension(2) :: Ddir,Dp1
  real(DP), dimension(2) :: Ddelta
  real(DP) :: t,root,diff,dir2,eps,dirdotdelta,dt1,dt2
  integer :: idresult

  eps=1e-10

  ! initialise by 0
  idresult = 0
  Dintersec=0

  ! get direction vector of the edge
  Ddir(:)=Dedge(:,2)-Dedge(:,1)

  Dp1(:)=Dedge(:,1)

  Ddelta(:)=Dp1(:)-Dc(:)

  dir2=Ddir(1)**2+Ddir(2)**2

  diff=(Ddelta(1)**2+Ddelta(2)**2)-drad**2

  dirdotdelta = Ddir(1)*Ddelta(1)+Ddir(2)*Ddelta(2)

  root = dirdotdelta**2 - dir2*diff

  ! the term under the root is negative, there is no intersection
  if(root < 0.0_dp)then
    return
  end if

  ! the term under the root is equal to 0, we have one intersection 't'
  if((0.0 .le. root).and.(root .le. eps))then
    root=0.0_dp
    t= -Ddir(1)*Ddelta(1)-Ddir(2)*Ddelta(2) /dir2
    ! we need point of intersection to be on the segment
    if((0.0_dp .le. t).and.(t .le. 1.0_dp))then
      iresult = 1
      Dintersec(:,1)=Dp1(:)+ t*Ddir(:)
    end if
  ! the term under the root is greater than zero
  ! we have to intersections dt1,dt2
  else
    dt1=(-dirdotdelta + root)/dir2
    dt2=(-dirdotdelta - root)/dir2
    if((0.0_dp .le. dt1).and.(dt1 .le. 1.0_dp))then
      iresult = iresult + 1
      Dintersec(:,1)=Dp1(:)+ dt1*Ddir(:)
    end if
    if((0.0_dp .le. dt2).and.(dt2 .le. 1.0_dp))then
      iresult = iresult + 1
      Dintersec(:,2)=Dp1(:)+ dt2*Ddir(:)
    end if
  end if

  end subroutine

  ! ***************************************************************************

!<subroutine>

  pure subroutine gaux_getDirectedExtentQuad2D (Dcorners,dbeta1,dbeta2,dlen)

  !<description>
    ! Calculates the maximum length of a line in direction (dbeta1,dbeta2)
    ! when embedded in a 2D quadrilateral with corners Dcoords.
    !
    ! Remarks: The cell is assumed to be convex. The routine "shoots" a
    ! ray from each corner in direction (dbeta1,dbeta2) and detects
    ! where it hits the opposite side of the cell.
  !</description>

  !<input>
    ! Coordinates of the corners defining the cell.
    real(DP), dimension(:,:), intent(in) :: Dcorners

    ! Direction of the line. It is assumed that the vector is normalised,
    ! i.e., ||(dbeta1,dbeta2)||_2 = 1.
    real(DP), intent(in) :: dbeta1, dbeta2

  !</input>

  !<output>
    ! Maximum length of the line.
    real(DP), intent(out) :: dlen
  !</output>

!</subroutine>

    ! local variables
    real(DP) :: x1,y1,x2,y2,x3,y3,x4,y4, dx,dy, dalpha
    integer :: iintersect

    ! Fetch the coordinates of these corners

    x1=Dcorners(1,1)
    y1=Dcorners(2,1)
    x2=Dcorners(1,2)
    y2=Dcorners(2,2)
    x3=Dcorners(1,3)
    y3=Dcorners(2,3)
    x4=Dcorners(1,4)
    y4=Dcorners(2,4)

    dlen=0.0_DP

    ! Calculate the `maximum possible cell width in direction (dbeta1,dbeta2)`;
    ! The picture in mind is the following:
    !
    !          G3
    !   +-------------X-------+
    !   |            /        |
    !   |           /         |
    !   |          /          |
    !   |         /           |
    !   |        /            |
    ! G4|       /             | G2
    !   |      ^ (beta1,beta2)|
    !   |     /               |
    !   |    /                |
    !   |   /                 |
    !   |  /                  |
    !   | /                   |
    !   |/                    |
    !   O---------------------+
    !            G1
    !
    ! The vector (beta1,beta2) indicates the direction of the flow.
    ! A particle starting in point O moves at most up to point X.
    ! The length of the line (O,X) is returned.
    !
    ! Loop through the four corners of cell and check for a line
    ! with slope BETA=(xbeta1,xbeta2) starting in this corner whether it
    ! really intersects with one of the edges of the element. Remark
    ! that we only have to check the two opposite edges to the current
    ! corner!

    ! -----------------------------------------------------------------
    ! Check the first corner.
    ! We obtain dalpha, which may be negative if direction (dbeta1,dbeta2)
    ! points outside of the element and we would have to use
    ! (-dbeta1,-dbeta2) instead.

    call gaux_getIntersection_ray2D(&
        x1,y1, x1+dbeta1,y1+dbeta2, x2,y2, x3,y3, dx,dy, iintersect, dalpha)
    dlen=max(abs(dalpha),dlen)

    call gaux_getIntersection_ray2D(&
        x1,y1, x1+dbeta1,y1+dbeta2, x3,y3, x4,y4, dx,dy, iintersect, dalpha)

    dlen=max(abs(dalpha),dlen)

    ! -----------------------------------------------------------------
    ! The second one...

    call gaux_getIntersection_ray2D(&
        x2,y2, x2+dbeta1,y2+dbeta2, x4,y4, x1,y1, dx,dy, iintersect, dalpha)
    dlen=max(abs(dalpha),dlen)

    call gaux_getIntersection_ray2D(&
        x2,y2, x2+dbeta1,y2+dbeta2, x4,y4, x3,y3, dx,dy, iintersect, dalpha)
    dlen=max(abs(dalpha),dlen)

    ! -----------------------------------------------------------------
    ! The third one...

    call gaux_getIntersection_ray2D(&
        x3,y3, x3+dbeta1,y3+dbeta2, x1,y1, x2,y2, dx,dy, iintersect, dalpha)
    dlen=max(abs(dalpha),dlen)

    call gaux_getIntersection_ray2D(&
        x3,y3, x3+dbeta1,y3+dbeta2, x1,y1, x4,y4, dx,dy, iintersect, dalpha)
    dlen=max(abs(dalpha),dlen)

    ! -----------------------------------------------------------------
    ! And the fourth=last one...

    call gaux_getIntersection_ray2D(&
        x4,y4, x4+dbeta1,y4+dbeta2, x2,y2, x1,y1, dx,dy, iintersect, dalpha)
    dlen=max(abs(dalpha),dlen)

    call gaux_getIntersection_ray2D(&
        x4,y4, x4+dbeta1,y4+dbeta2, x2,y2, x3,y3, dx,dy, iintersect, dalpha)
    dlen=max(abs(dalpha),dlen)

  end subroutine

end module


subroutine cubic_bezier(img, p1, p2, p3, p4, color)
  type(rgbimage), intent(inout) :: img
  type(point), intent(in) :: p1, p2, p3, p4
  type(rgb), intent(in) :: color

  integer :: i, j
  real :: pts(0:N_SEG,0:1), t, a, b, c, d, x, y

  do i = 0, N_SEG
     t = real(i) / real(N_SEG)
     a = (1.0 - t)**3.0
     b = 3.0 * t * (1.0 - t)**2
     c = 3.0 * (1.0 - t) * t**2
     d = t**3.0
     x = a * p1%x + b * p2%x + c * p3%x + d * p4%x
     y = a * p1%y + b * p2%y + c * p3%y + d * p4%y
     pts(i,0) = x
     pts(i,1) = y
  end do

  do i = 0, N_SEG-1
     j = i + 1
     call draw_line(img, point(pts(i,0), pts(i,1)), &
                    point(pts(j,0), pts(j,1)), color)
  end do

end subroutine cubic_bezier


program main
  ! Default
  implicit none

  ! Parameters
  integer(4), parameter :: window_size = 13

  ! Big-ass number
  character(*), parameter :: row01 = &
       '73167176531330624919225119674426574742355349194934'
  character(*), parameter :: row02 = &
       '96983520312774506326239578318016984801869478851843'
  character(*), parameter :: row03 = &
       '85861560789112949495459501737958331952853208805511'
  character(*), parameter :: row04 = &
       '12540698747158523863050715693290963295227443043557'
  character(*), parameter :: row05 = &
       '66896648950445244523161731856403098711121722383113'
  character(*), parameter :: row06 = &
       '62229893423380308135336276614282806444486645238749'
  character(*), parameter :: row07 = &
       '30358907296290491560440772390713810515859307960866'
  character(*), parameter :: row08 = &
       '70172427121883998797908792274921901699720888093776'
  character(*), parameter :: row09 = &
       '65727333001053367881220235421809751254540594752243'
  character(*), parameter :: row10 = &
       '52584907711670556013604839586446706324415722155397'
  character(*), parameter :: row11 = &
       '53697817977846174064955149290862569321978468622482'
  character(*), parameter :: row12 = &
       '83972241375657056057490261407972968652414535100474'
  character(*), parameter :: row13 = &
       '82166370484403199890008895243450658541227588666881'
  character(*), parameter :: row14 = &
       '16427171479924442928230863465674813919123162824586'
  character(*), parameter :: row15 = &
       '17866458359124566529476545682848912883142607690042'
  character(*), parameter :: row16 = &
       '24219022671055626321111109370544217506941658960408'
  character(*), parameter :: row17 = &
       '07198403850962455444362981230987879927244284909188'
  character(*), parameter :: row18 = &
       '84580156166097919133875499200524063689912560717606'
  character(*), parameter :: row19 = &
       '05886116467109405077541002256983155200055935729725'
  character(*), parameter :: row20 = &
       '71636269561882670428252483600823257530420752963450'

  character(*), parameter :: big_num = row01//row02//row03//row04//row05//row06&
       //row07//row08//row09//row10//row11//row12//row13//row14//row15//row16&
       //row17//row18//row19//row20

  integer(4), parameter :: len_str = len_trim(big_num)

  ! Variables
  integer(8) :: prod,max_prod
  integer(4) :: i

  ! Do work
  max_prod = 0
  do i=1,len_str-window_size+1
     prod = calc_prod(big_num,i)
     max_prod = max(prod,max_prod)
  enddo

  ! Write out result
  write(*,*) 'The largest product of ',window_size,' consecutive numbers is: ',&
       max_prod

contains

  pure function calc_prod(num,istart)
    ! Default
    implicit none

    ! Function arguments
    character(*), intent(in) :: num
    integer(4),   intent(in) :: istart
    integer(8)               :: calc_prod

    ! Local variables
    integer(4) :: i
    integer(8) :: prod,fac

    ! Compute the product of the factors
    prod = 1
    do i=istart,istart+window_size-1
       read(num(i:i),'(i1)') fac
       prod = prod*fac
    enddo

    calc_prod = prod
    return
  end function calc_prod

end program main


    program demo_acosh
    use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
    implicit none
    real(kind=dp), dimension(3) :: x = [ 1.0d0, 2.0d0, 3.0d0 ]
       write (*,*) acosh(x)
    end program demo_acosh


module quadglobal

!   This work was supported by the Director, Office of Science, Division
!   of Mathematical, Information, and Computational Sciences of the
!   U.S. Department of Energy under contract number DE-AC02-05CH11231.

!   This program demonstrates the 2D quadrature routine 'quadtsq2d'.

!   David H. Bailey      2007-03-23

!   The function quadtsq2d is suitable to integrate any function that is
!   continuous, infinitely differentiable and integrable on a 2D finite open
!   interval.  Singularities or vertical derivatives are permitted on the
!   boundaries.  This can also be used for certain integrals on infinite
!   intervals, by making a suitable change of variable.

!   The function(s) to be integrated is(are) defined in external function
!   subprogram(s) -- see the sample function subprograms below.  The name(s) of
!   the function subprogram(s) must be included in appropriate type and external
!   statements in the main program.

!   Inputs set in parameter statement below:
!   ndebug Debug level setting.  Default = 2.
!   ndigits1  Primary working precision.  With QD precision, set to 64.
!   nepsilson1  Log10 of the desired tolerance.  Normally set to - ndigits1.
!   nquadl  Max number of phases in quadrature routine; adding 1 increases
!           (possibly doubles) the number of accurate digits in the result,
!           but also roughly *quadruples* the run time.
!   nq2     Space parameter for wk and xk arrays in the calling program.  By
!           default it is set to 8 * 2^nq1.  Increase nq2 if directed by a
!           message in subroutine initqts.

use qdmodule
implicit none
integer ndebug, nquadl, ndigits1, nepsilon1, nwords1, nq1, nq2, nqmx
parameter (ndebug = 2, nquadl = 6, ndigits1 = 64, nepsilon1 = -64, &
  nwords1 = 2, nq1 = nquadl, nq2 = 8 * 2**nq1)
type (qd_real) xk(-nq2:nq2), wk(-nq2:nq2)
end module

! program tquadtsq2d
subroutine f_main
use qdmodule
use quadglobal
implicit none
integer i, n, n1
double precision dplog10q, d1, d2, second, tm0, tm1
type (qd_real) cat, catalan, err, quadtsq2d, fun01, fun02, fun03, fun04, &
  t1, t2, t3, t4, x1, x2, y1, y2
external quadtsq2d, catalan, fun01, fun02, fun03, fun04, second
integer*4 old_cw

!  This line must be present in DD and QD main programs.

call f_fpu_fix_start (old_cw)

write (6, 1) ndigits1, nepsilon1, nquadl
1 format ('Quadtsq2d test'/'Digits =',i6,'  Epsilon =',i6,'   Quadlevel =',i6)

!   Initialize quadrature tables wk and xk (weights and abscissas).

tm0 = second ()
call initqts
tm1 = second ()
write (6, 2) tm1 - tm0
2 format ('Quadrature initialization completed: cpu time =',f12.6)
cat = catalan ()

!   Begin quadrature tests.

write (6, 11)
11 format (/ &
  'Problem 1: Int_-1^1 Int_-1^1 1/(1+x^2+y^2) dx dy = 4*log(2+sqrt(3))-2*pi/3')
x1 = -1.d0
x2 = 1.d0
y1 = -1.d0
y2 = 1.d0
tm0 = second ()
t1 = quadtsq2d (fun01, x1, x2, y1, y2)
tm1 = second ()
write (6, 3) tm1 - tm0
3 format ('Quadrature completed: CPU time =',f12.6/'Result =')
call qdwrite (6, t1)
t2 = 4.d0 * log (2.d0 + sqrt (qdreal (3.d0))) - 2.d0 * qdpi () / 3.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1
4 format ('Actual error =',f10.6,'x10^',i5)

write (6, 12)
12 format (/&
  'Problem 2: Int_0^pi Int_0^pi log (2-cos(s)-cos(t)) = 4*pi*cat- pi^2*log(2)')
x1 = 0.d0
x2 = qdpi()
y1 = 0.d0
y2 = qdpi()
tm0 = second ()
t1 = quadtsq2d (fun02, x1, x2, y1, y2)
tm1 = second ()
t2 = 4.d0 * qdpi() * cat - qdpi()**2 * log (qdreal (2.d0))
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 13)
13 format (/&
  'Problem 3: Int_0^inf Int_0^inf sqrt(x^2+xy+y^2) * exp(-x-y) = 1 + 3/4*log(3)')
x1 = 0.d0
x2 = 1.d0
y1 = 0.d0
y2 = 1.d0
tm0 = second ()
t1 = quadtsq2d (fun03, x1, x2, y1, y2)
tm1 = second ()
t2 = 1.d0 + 0.75d0 * log (qdreal (3.d0))
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 14)
14 format (/&
  'Problem 4: Int_0^1 Int_0^1 1/(sqrt((1-x)*(1-y))*(x+y)) dx dy = 4*cat')
x1 = 0.d0
x2 = 1.d0
y1 = 0.d0
y2 = 1.d0
tm0 = second ()
t1 = quadtsq2d (fun04, x1, x2, y1, y2)
tm1 = second ()
t2 = 4.d0 * cat
write (6, 3) tm1 - tm0
call qdwrite (6, t1)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

call f_fpu_fix_end (old_cw)
stop
end

function fun01 (s, t)

!   fun01 (s,t) = 1/sqrt[1+s^2+t^2]

use qdmodule
implicit none
type (qd_real) fun01, s, t

fun01 = 1.d0 / sqrt (1.d0 + s**2 + t**2)
return
end

function fun02 (s, t)

!   fun02 (s,t) = log (2 - cos(s) - cos(t))

use qdmodule
implicit none
type (qd_real) fun02, s, t, t1

t1 = 2.d0 - cos (s) - cos (t)
if (t1 > 0.d0) then
  fun02 = log (2.d0 - cos (s) - cos (t))
else
  fun02 = 0.d0
endif
return
end

function fun03 (s, t)

!   fun03 (s,t) = ((1/s-1)^2 + (1/s-1)*(1/t-1) + (1/t-1)^2)
!                / (s^2 * t^2 * exp(1/s + 1/t - 2)

use qdmodule
implicit none
type (qd_real) fun03, s, t, s1, t1, sq
external dplog10q

if (s > 3.d-3 .and. t > 3.d-3) then
  s1 = 1.d0 / s - 1.d0
  t1 = 1.d0 / t - 1.d0
  sq = sqrt (s1**2 + s1 * t1 + t1**2)
  fun03 = sq / (s**2 * t**2) * exp (-s1 - t1)
else
  fun03 = 0.d0
endif

return
end

function fun04 (s, t)

!   fun04 (s,t) = 1/(sqrt((1-s)*(1-t)) * (s+t))

use qdmodule
implicit none
type (qd_real) fun04, s, t

fun04 = 1.d0 / (sqrt ((1.d0 - s) * (1.d0 - t)) * (s + t))
return
end

subroutine initqts

!   This subroutine initializes the quadrature arays xk and wk for
!   tanh-sinh quadrature.  The argument nq2 is set to 8 * 2^nq1 in module
!   quadmod above.  Increase nq2 if directed by a message produced below.
!   One option here is to set

!   x(k) = 1.d0 / (t3 * t4)

!   instead of the line below.  This change stores 1 - absicssas in x(k),
!   which can be used to improve quadrature result accuracy in some cases.

use qdmodule
use quadglobal
implicit none
integer i, ierror, iprint, j, k, k1
double precision eps, h
parameter (iprint = 1000)
type (qd_real) pi, p2, t1, t2, t3, t4, t5, u1, u2

pi = qdpi()
eps = 10.d0 ** nepsilon1
if (ndebug >= 1) then
  write (6, 1)
1 format ('initqts: Tanh-sinh quadrature initialization')
endif

p2 = 0.5d0 * pi
h = 0.5d0 ** nq1

do k = 0, nq2
  if (ndebug >= 2 .and. mod (k, iprint) == 0) write (6, *) k, nq2
  t1 = dble (k) * h

!   xk(k) = 1 - tanh (u1) = 1 /(e^u1 * cosh (u1))
!   wk(k) = u2 / cosh (u1)^2
!   where u1 = pi/2 * cosh (t1), u2 = pi/2 * sinh (t1)

  t2 = exp (t1)
  u1 = 0.5d0 * p2 * (t2 + 1.d0 / t2)
  u2 = 0.5d0 * p2 * (t2 - 1.d0 / t2)
  t3 = exp (u2)
  t4 = 0.5d0 * (t3 + 1.d0 / t3)
  xk(k) = 1.d0 - 1.d0 / (t3 * t4)
  wk(k) = u1 / t4 ** 2
  if (k > 0) then
    xk(-k) = - xk(k)
    wk(-k) = wk(k)
  endif
  if (wk(k) < eps) goto 100
enddo

write (6, 2) nq2
2 format ('initqts: Table space parameter is too small; value =',i8)
stop

100 continue

nqmx = k
if (ndebug >= 2) then
  write (6, 3) k
3 format ('initqts: Table spaced used =',i8)
  write (6, *) 'final xk, wk ='
  call qdwrite (6, xk(k), wk(k))
endif

return
end

function quadtsq2d (fun, x1, x2, y1, y2)

!   This performs 2-D tanh-sinh quadrature.  No attempt is made in this code
!   to estimate errors.
!   David H. Bailey     2007-03-23

use qdmodule
use quadglobal
implicit none
integer i, j, k, n
double precision h
type (qd_real) ax, bx, ay, by, quadtsq2d, fun, s1, t1, t2, &
  x1, x2, xx1, y1, y2, yy1
external fun

ax = 0.5d0 * (x2 - x1)
bx = 0.5d0 * (x2 + x1)
ay = 0.5d0 * (y2 - y1)
by = 0.5d0 * (y2 + y1)

if (nqmx == 0) then
  write (6, 1)
1 format ('quadtsq2d: quadrature arrays have not been initialized')
  stop
endif
h = 0.5d0 ** nq1
s1 = 0.d0

do k = -nqmx, nqmx
!   write (6, *) k, nqmx
  yy1 = ay * xk(k) + by

  do j = -nqmx, nqmx
    xx1 = ax * xk(j) + bx
    t1 = fun (xx1, yy1)
    s1 = s1 + wk(j) * wk(k) * t1
  enddo
enddo

quadtsq2d = ax * ay * h**2 * s1
return
end

function catalan ()
use qdmodule
implicit none
integer k
real*8 dk, eps
type (qd_real) catalan, c1, c2, c4, c8, r16, t1, t2, t3
type (qd_real) x1, x2, x3, x4, x5, x6

c1 = 1.d0
c2 = 2.d0
c4 = 4.d0
c8 = 8.d0
r16 = 1.d0 / 16.d0
t1 = 0.d0
t2 = 1.d0
eps = 1.d-64

do k = 0, 10000000
  dk = k
  t3 = t2 * (c8 / (8.d0 * dk + 1.d0) ** 2 + c8 / (8.d0 * dk + 2.d0) ** 2 &
       + c4 / (8.d0 * dk + 3.d0) ** 2 - c2 / (8.d0 * dk + 5.d0) ** 2 &
       - c2 / (8.d0 * dk + 6.d0) ** 2 - c1 / (8.d0 * dk + 7.d0) ** 2)
  t1 = t1 + t3
  t2 = r16 * t2
  if (t3 < 1.d-5 * eps) goto 100
enddo

write (6, *) 'catalan: error - contact author'

100 continue

catalan = 1.d0 / 8.d0 * qdpi() * log (c2) + 1.d0 / 16.d0 * t1
return
end

function dplog10q (a)

!   For input MP value a, this routine returns a DP approximation to log10 (a).

use qdmodule
implicit none
integer ia
double precision da, dplog10q, t1
type (qd_real) a

! call mpmdc (a%mpr, da, ia)
da = a
ia = 0
if (da .eq. 0.d0) then
  dplog10q = -9999.d0
else
  dplog10q = log10 (abs (da)) + ia * log10 (2.d0)
endif

100 continue
return
end

subroutine decmdq (a, b, ib)

!   For input MP value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use qdmodule
implicit none
integer ia, ib
double precision da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)
type (qd_real) a

! call mpmdc (a%mpr, da, ia)
da = a
ia = 0
if (da .ne. 0.d0) then
  t1 = xlt * ia + log10 (abs (da))
  ib = t1
  if (t1 .lt. 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end


!==============================================================================!
  module Const_Mod
!------------------------------------------------------------------------------!
!   Constants definitions for all other modules.                               !
!------------------------------------------------------------------------------!
  implicit none
!==============================================================================!

  !----------------------------------------!
  !   A few handy mathematical constants   !
  !----------------------------------------!
  real,    parameter :: HUGE     = 1.e+30
  real,    parameter :: TINY     = 1.e-30
  integer, parameter :: HUGE_INT = 9223372036854775807

  ! Big and small numbers in metric system
  real, parameter :: TERA  = 1.e+12
  real, parameter :: GIGA  = 1.e+9
  real, parameter :: MEGA  = 1.e+6
  real, parameter :: KILO  = 1.e+3
  real, parameter :: MILI  = 1.e-3
  real, parameter :: MICRO = 1.e-6
  real, parameter :: NANO  = 1.e-9
  real, parameter :: PICO  = 1.e-12

  ! Archimedes’ constant
  real, parameter :: PI = 3.14159265359

  ! Gravitational constant for Earth (where we are most of the time)
  real, parameter :: EARTH_G = 9.807

  ! These are often used in turbulence models
  real, parameter :: ONE_THIRD  = 0.33333333333333333
  real, parameter :: TWO_THIRDS = 1.0 - ONE_THIRD
  real, parameter :: ONE_SIXTH  = ONE_THIRD * 0.5

  ! Maximum number of domains
  integer, parameter :: MD = 4

  end module


module constants
  !======================================================
  !
  !	Module containing parameters needed for several
  !       other routines
  !
  !
  !   Pedro Peixoto - 03-03-2011
  !======================================================
  implicit none
  save
  public

  !---------------------------------------------------
  !Kind attributions
  !---------------------------------------------------

  integer, parameter :: i2  = selected_real_kind(2,20)
  integer, parameter :: i4  = selected_real_kind(6,20)
  integer, parameter :: i8  = selected_real_kind(14,40)

  integer, parameter :: r4  = selected_real_kind(6,37)
  integer, parameter :: r8  = selected_real_kind(12,100)
  integer, parameter :: r16 = max(r8,selected_real_kind(27,2400))

  !---------------------------------------------------
  ! General Parameters
  !---------------------------------------------------

  !Pi
  real(r8), parameter :: pi   = 4._r8* 0.78539816339744830961566 !datan (1._r8)
  real(r8), parameter :: pi2  = 2._r8*pi
  real(r8), parameter :: pio2 = pi/2._r8
  real(r8), parameter :: piby2 = pi*0.5_r8
  real(r8), parameter :: pio4 = pi/4._r8

  !Degrees to radians coversion (multiply to obtain conversion)
  real(r8), parameter :: deg2rad = pi / 180._r8

  !Radians to Degrees coversion (multiply to obtain conversion)
  real(r8), parameter :: rad2deg = 1._r8/deg2rad

  !Very small real number (aprox 1.10e-7)
  !real(r8), parameter :: eps = epsilon(1.)
  real(r8), parameter :: eps = epsilon(1.)

  !Very very small real number (aprox 1.10e-16)
  real(r8), parameter :: eps2 = epsilon(pi)

  !---------------------------------------------------
  ! Physical Parameters
  !---------------------------------------------------

  ! Earth mean radius (meters)
  real(r8), parameter :: erad     = 6.37122e6_r8
  real(r8), parameter :: rearth     = 6.37122e6_r8
  real(r8), parameter :: eradi    = 1._r8/6.37122e6_r8
  real(r8), parameter :: unitspharea    = 4._r8*pi

  !Gravitational accerlaration of the Earth (m/s^2)
  real(r8), parameter  :: grav    = 9.80616_r8
  real(r8), parameter  :: gravity = 9.80616_r8
  real(r8), parameter  :: gravi   = 1._r8/9.80616_r8

  ! Angular velocity of the Earth (rot/s)
  real (r8), parameter :: omega   = 7.292e-5_r8
  real (r8), parameter :: rotatn   = 7.292e-5_r8

  !Days to seconds
  real (r8), parameter :: day2sec = 86400_r8
  real (r8), parameter :: sec2day = 1._r8/86400_r8

  ! Dry air gas constant [J/(kg K)]
  real(r8), parameter :: rdry     = 287.

  ! Dry air spec heat at const P [J/(kg K)]
  real(r8), parameter :: cp       = 1004.

  ! Dry air spec heat at const vol [J/(kg K)]
  real(r8), parameter :: cv       = 717.

  ! Water vapor gas constant [J/(kg K)]
  real(r8), parameter :: rvap     = 461.

  ! Reference pressure [Pa]
  real(r8), parameter :: p00      = 1.e5

  ! 0 Celsius temperature [K]
  real(r8), parameter :: t00      = 273.15

  !---------------------------------------------------
  ! Directories
  !--------------------------------------------------
  !Output data directory
  character (len=60), parameter::  datadir= "data/"
  !Grid data directory
  character (len=60), parameter::  griddir= "grid/"
  !Directory for ploting thing using GMT
  character (len=60), parameter::  gmtdir = "gmt/"
  !Sources directory
  character (len=60), parameter::  srcdir = "src/"
  !Parameter files  directory
  character (len=60), parameter::  pardir = "par/"
  !Reference solutions directory - data will be read from here
  character (len=60), parameter::  refdir = "ref/"

  !---------------------------------------------------
  ! Parameters files
  !--------------------------------------------------
  !character (len=60), parameter::  deformpar = "deform.par"
  !character (len=60), parameter::  meshpar = "mesh.par"
  !character (len=60), parameter::  simulpar = "simul.par"

  !---------------------------------------------------
  ! Global constant variables
  !---------------------------------------------------
  !Flag for verbose output
  logical :: showonscreen=.false.

  !Simulation to be done
  integer (i4) :: simulcase

end module constants


MODULE quadrature_mod
  USE input_mod,ONLY: runend
  IMPLICIT NONE

CONTAINS
!******************************************************************************
!**              Gaussian Quadrature (Point and coefficients)                **
!******************************************************************************
 SUBROUTINE gauscheb(ngauss,gpoin,gcoef)
  IMPLICIT NONE
  !--Dummy arguments
  INTEGER(kind=4),INTENT(IN) :: ngauss
  REAL(kind=8),INTENT(OUT) :: gpoin(ngauss),gcoef(ngauss)

  SELECT CASE (ngauss)
  CASE (1)
    gpoin=(/ 0.d0 /)
    gcoef=(/ 2.d0 /)
  CASE (2)
    gpoin=(/ -1.d0/SQRT(3.d0),1.d0/SQRT(3.d0) /)
    gcoef=(/ 1.d0,1.d0 /)
  CASE (3)
    gpoin=(/ -SQRT(3.d0/5.d0),0.d0,SQRT(3.d0/5.d0) /)
    gcoef=(/ 5.d0/9.d0,8.d0/9.d0,5.d0/9.d0 /)
  CASE DEFAULT                         !
    CALL runend('QUADRATURE: NGAUS not implemented')
  END SELECT
 END SUBROUTINE gauscheb

END MODULE quadrature_mod


	SUBROUTINE enercalc(myid,Nx,Ny,Nz,dt,Es,modescalereal,enkin,enstr,&
				enpot,en,kx,ky,kz,tempu,tempv,v,vold,u,uold,decomp)
	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This subroutine program calculates the energy for the nonlinear
	! Klein-Gordon equation in 3 dimensions
	! u_{tt}-(u_{xx}+u_{yy}+u_{zz})+u=Es*|u|^2u
	!
	! The energy density is given by
	! 0.5u_t^2+0.5u_x^2+0.5u_y^2+0.5u_z^2+0.5u^2+Es*0.25u^4
	!
	! INPUT
	!
	! .. Scalars ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nz				= number of modes in z - power of 2 for FFT
	!  dt				= timestep
	!  Es				= +1 for focusing, -1 for defocusing
	!  modescalereal	= parameter to scale after doing backward FFT
	!  myid				= Process id
	! .. Arrays ..
	!  u 				= approximate solution
	!  v 				= Fourier transform of approximate solution
	!  uold 			= approximate solution
	!  vold 			= Fourier transform of approximate solution
	!  tempu			= array to hold temporary values - real space
	!  tempv			= array to hold temporary values - fourier space
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  kz				= fourier frequencies in z direction
	! .. Special Structures ..
	!  decomp			= contains information on domain decomposition
	!					see http://www.2decomp.org/ for more information
	! OUTPUT
	!
	! .. Scalars ..
	!  enkin			= Kinetic energy
	!  enstr			= Strain energy
	!  enpot			= Potential energy
	!  en				= Total energy
	!
	! LOCAL VARIABLES
	!
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  k				= loop counter in z direction
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! 2DECOMP&FFT	 -- Domain decomposition and Fast Fourier Library
	!			(http://www.2decomp.org/index.html)
	! MPI library
	USE decomp_2d
	USE decomp_2d_fft
	USE decomp_2d_io
	IMPLICIT NONE
	INCLUDE 'mpif.h'
	! Declare variables
	INTEGER(KIND=4), INTENT(IN)								:: Nx,Ny,Nz,myid
	REAL(KIND=8), INTENT(IN)								:: dt,Es,modescalereal
	TYPE(DECOMP_INFO), INTENT(IN)							:: decomp
	COMPLEX(KIND=8), DIMENSION(decomp%zst(1):decomp%zen(1)),INTENT(IN)	:: kx
	COMPLEX(KIND=8), DIMENSION(decomp%zst(2):decomp%zen(2)),INTENT(IN)	:: ky
	COMPLEX(KIND=8), DIMENSION(decomp%zst(3):decomp%zen(3)),INTENT(IN)	:: kz
	COMPLEX(KIND=8), DIMENSION(decomp%xst(1):decomp%xen(1),&
   								decomp%xst(2):decomp%xen(2),&
   								decomp%xst(3):decomp%xen(3)),&
   													INTENT(IN)	:: u,uold
	COMPLEX(KIND=8), DIMENSION(decomp%zst(1):decomp%zen(1),&
            					decomp%zst(2):decomp%zen(2),&
            					decomp%zst(3):decomp%zen(3)),&
            										INTENT(IN)	:: v,vold
	COMPLEX(KIND=8), DIMENSION(decomp%xst(1):decomp%xen(1),&
   								decomp%xst(2):decomp%xen(2),&
   								decomp%xst(3):decomp%xen(3)),&
   													INTENT(INOUT) :: tempu
	COMPLEX(KIND=8), DIMENSION(decomp%zst(1):decomp%zen(1),&
            					decomp%zst(2):decomp%zen(2),&
            					decomp%zst(3):decomp%zen(3)),&
            										INTENT(INOUT):: tempv
	REAL(KIND=8), INTENT(OUT)							:: enkin,enstr
	REAL(KIND=8), INTENT(OUT)							:: enpot,en
	INTEGER(KIND=4)										:: i,j,k

	!.. Strain energy ..
	DO k=decomp%zst(3),decomp%zen(3)
		DO j=decomp%zst(2),decomp%zen(2)
			DO i=decomp%zst(1),decomp%zen(1)
				tempv(i,j,k)=0.5d0*kx(i)*(vold(i,j,k)+v(i,j,k))
			END DO
		END DO
	END DO
	CALL decomp_2d_fft_3d(tempv,tempu,DECOMP_2D_FFT_BACKWARD)

	DO k=decomp%xst(3),decomp%xen(3)
		DO j=decomp%xst(2),decomp%xen(2)
			DO i=decomp%xst(1),decomp%xen(1)
				tempu(i,j,k)=abs(tempu(i,j,k)*modescalereal)**2
			END DO
		END DO
	END DO
	CALL decomp_2d_fft_3d(tempu,tempv,DECOMP_2D_FFT_FORWARD)
	IF(myid.eq.0) THEN
		enstr=0.5d0*REAL(abs(tempv(1,1,1)),kind(0d0))
	END IF
	DO k=decomp%zst(3),decomp%zen(3)
		DO j=decomp%zst(2),decomp%zen(2)
			DO i=decomp%zst(1),decomp%zen(1)
				tempv(i,j,k)=0.5d0*ky(j)*(vold(i,j,k)+v(i,j,k))
			END DO
		END DO
	END DO
	CALL decomp_2d_fft_3d(tempv,tempu,DECOMP_2D_FFT_BACKWARD)
	DO k=decomp%xst(3),decomp%xen(3)
		DO j=decomp%xst(2),decomp%xen(2)
			DO i=decomp%xst(1),decomp%xen(1)
				tempu(i,j,k)=abs(tempu(i,j,k)*modescalereal)**2
			END DO
		END DO
	END DO
	CALL decomp_2d_fft_3d(tempu,tempv,DECOMP_2D_FFT_FORWARD)
	IF(myid.eq.0) THEN
		enstr=enstr+0.5d0*REAL(abs(tempv(1,1,1)),kind(0d0))
	END IF
	DO k=decomp%zst(3),decomp%zen(3)
		DO j=decomp%zst(2),decomp%zen(2)
			DO i=decomp%zst(1),decomp%zen(1)
				tempv(i,j,k)=0.5d0*kz(k)*(vold(i,j,k)+v(i,j,k))
			END DO
		END DO
	END DO
	CALL decomp_2d_fft_3d(tempv,tempu,DECOMP_2D_FFT_BACKWARD)
	DO k=decomp%xst(3),decomp%xen(3)
		DO j=decomp%xst(2),decomp%xen(2)
			DO i=decomp%xst(1),decomp%xen(1)
				tempu(i,j,k)=abs(tempu(i,j,k)*modescalereal)**2
			END DO
		END DO
	END DO
	CALL decomp_2d_fft_3d(tempu,tempv,DECOMP_2D_FFT_FORWARD)
	IF(myid.eq.0) THEN
		enstr=enstr+0.5d0*REAL(abs(tempv(1,1,1)),kind(0d0))
	END IF
	! .. Kinetic Energy ..
	DO k=decomp%xst(3),decomp%xen(3)
		DO j=decomp%xst(2),decomp%xen(2)
			DO i=decomp%xst(1),decomp%xen(1)
				tempu(i,j,k)=( abs(u(i,j,k)-uold(i,j,k))/dt )**2
			END DO
		END DO
	END DO
	CALL decomp_2d_fft_3d(tempu,tempv,DECOMP_2D_FFT_FORWARD)
	IF(myid.eq.0) THEN
		enkin=0.5d0*REAL(abs(tempv(1,1,1)),kind(0d0))
	END IF
	! .. Potential Energy ..
	DO k=decomp%xst(3),decomp%xen(3)
		DO j=decomp%xst(2),decomp%xen(2)
			DO i=decomp%xst(1),decomp%xen(1)
				tempu(i,j,k)=0.5d0*(abs((u(i,j,k)+uold(i,j,k))*0.50d0))**2&
					-0.125d0*Es*(abs(u(i,j,k))**4+abs(uold(i,j,k))**4)
			END DO
		END DO
	END DO
	CALL decomp_2d_fft_3d(tempu,tempv,DECOMP_2D_FFT_FORWARD)
	IF(myid.eq.0) THEN
		enpot=REAL(abs(tempv(1,1,1)),kind(0d0))
		en=enpot+enkin+enstr
	END IF
	END SUBROUTINE enercalc