!##############################################################################
!# ****************************************************************************
!# <name> element_tri2d </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains the implementations of the 2D triangle basis functions.
!#
!# </purpose>
!##############################################################################

module element_tri2d

!$ use omp_lib
  use fsystem
  use elementbase
  use derivatives
  use perfconfig
  use mprimitives

  implicit none

  private

  public :: elem_eval_P0_2D
  public :: elem_eval_P1_2D
  public :: elem_eval_P1T_2D
  public :: elem_eval_P2_2D
  public :: elem_eval_P2E_2D
  public :: elem_eval_P3_2D
  public :: elem_eval_RT1_2D
  public :: elem_eval_DCP1_2D

contains

  ! ----------------------------------------------------------------------------
  ! General information: Function values and derivatives of
  !                      triangular elements
  !                      with linear transformation from the reference
  !                      to the real element.
  !
  ! The element subroutines return
  ! - the function value and
  ! - the X- and Y-derivatives
  ! of the basis function in a (cubature) point (x,y) on the real mesh!
  ! The coordinates of a (cubature) point is given
  ! - as coordinate triple (xi1, xi2, xi3) on the reference element, if the
  !   the element is parametric; the actual cubature point is then at
  !   (x,y) = s(t(xi1,xi2,xi3))
  ! - as coordinate pair (x,y) on the real element, if the element is
  !   nonparametric.
  ! The mapping  s=(s1,s2):R^2->R^2  is the bilinear mapping "sigma" from
  ! transformation.f90, that maps the reference element T^ to the real
  ! element T; its shape is of no importance here.
  ! The transformation t:R^3->R^2 maps the coordinates from the barycenric
  ! coordinate system on the reference element to the standard space
  ! (to get the (X,Y) coordinate on the reference element), so
  !
  !    t(xi1,xi2,xi3) = xi2 * [1,0]  +  xi3 * [0,1]
  !
  ! The linear transformation s(.) from the reference to the real element
  ! has the form
  !
  !    s(X,Y) = c1  +  c2 X  +  c3 Y  =:  (x,y)
  !
  ! Let u be an arbitrary FE (basis) function on an element T and
  ! p be the associated polynomial on the reference element T^. Then,
  ! we can obtain the function value of u at (x,y) easily:
  !
  !   u(x,y) = u(s(t(xi1,xi2,xi3)) = p(t^-1(s^-1(x,y))) = p(xi1,xi2,xi3)
  !
  !   [0,1]
  !   | \               s(t(.))                C
  !   |   \           --------->              / \
  !   |  T^ \                               /     \
  !   |       \                           /    T    \
  !   [0,0]----[1,0]                     A-----------B
  !
  ! The derivative is a little bit harder to calculate because of the
  ! mapping. We have:
  !
  !    grad(u)(x,y) = grad( p(t^-1(s^-1(x,y))) )
  !
  ! Let us use the notation
  !
  !    P(X,Y)  :=  p( t^-1 (X,Y) )  =  p (xi1,xi2,xi3)
  !
  ! which is the 'standard' form of the polynomials on the
  ! reference element without barycentric coordinates involved (i.e.
  ! for the P1-element it is of the form P(x,y) = c1 x + c2 y + c3).
  !
  ! Because of the chain rule, we have:
  !
  !    grad( p( t^-1 (s^-1) ) ) = (DP)( (s^-1) * D(s^-1) )
  !
  !       = ( P_X(s^-1)  P_Y(s^-1)) * ( (s1^-1)_x   (s1^-1)_y )
  !                                   ( (s2^-1)_x   (s2^-1)_y )
  !
  !      =: ( P_X(s^-1)  P_Y(s^-1)) * ( e f )
  !                                   ( g h )
  !
  ! With s^-1(x,y)=(X,Y), we therefore have:
  !
  !    grad(u)(x,y) = ( P_X(X,Y) * e  +  P_Y(X,Y) * g )
  !                   ( P_X(X,Y) * f  +  P_Y(X,Y) * h )
  !
  ! Now, from e.g. http://mathworld.wolfram.com/MatrixInverse.html we know,
  ! that:
  !
  !     A = ( a b )    =>   A^-1  =  1/det(A) (  d -b )
  !         ( c d )                           ( -c  a )
  !
  ! Therefore:
  !
  !    ( e f )  =  D(s^-1)  =  (Ds)^-1  =  1/(ad-bc) (  d -b )
  !    ( g h )                                       ( -c  a )
  !
  ! with
  !
  !    A = ( a b )  =  ( s1_X   s1_Y )  =  ( B-A  C-A )
  !        ( c d )     ( s2_X   s2_Y )
  !
  ! being the matrix from the transformation (according to
  ! http://mathworld.wolfram.com/BarycentricCoordinates.html).
  !
  ! -----------------------------------------------------------------------------

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

  ! -------------- NEW ELEMENT INTERFACE IMPLEMENTATIONS FOLLOW --------------

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

  !************************************************************************
  ! Parametric P0 element
  !************************************************************************

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

 subroutine elem_eval_P0_2D (celement, reval, Bder, Dbas, rperfconfig)

!<description>
  ! This subroutine simultaneously calculates the values of the basic
  ! functions of the finite element at multiple given points on the
  ! reference element for multiple given elements.
!</description>

!<input>
  ! The element specifier.
  integer(I32), intent(in)                       :: celement

  ! t_evalElementSet-structure that contains cell-specific information and
  ! coordinates of the evaluation points. revalElementSet must be prepared
  ! for the evaluation.
  type(t_evalElementSet), intent(in)             :: reval

  ! Derivative quantifier array. array [1..DER_MAXNDER] of boolean.
  ! If bder(DER_xxxx)=true, the corresponding derivative (identified
  ! by DER_xxxx) is computed by the element (if supported). Otherwise,
  ! the element might skip the computation of that value type, i.e.
  ! the corresponding value 'Dvalue(DER_xxxx)' is undefined.
  logical, dimension(:), intent(in)              :: Bder

  ! Local performance configuration.
  type(t_perfconfig), intent(in)                 :: rperfconfig
!</input>

!<output>
  ! Value/derivatives of basis functions.
  ! array [1..EL_MAXNBAS,1..DER_MAXNDER,1..npointsPerElement,nelements] of double
  ! Bder(DER_FUNC)=true  => Dbas(i,DER_FUNC,j) defines the value of the i-th
  !   basis function of the finite element in the point Dcoords(j) on the
  !   reference element,
  !   Dvalue(i,DER_DERIV_X) the value of the x-derivative of the i-th
  !   basis function,...
  ! Bder(DER_xxxx)=false => Dbas(i,DER_xxxx,.) is undefined.
  !
  ! Due to the fact that this is a vector valued basis function, the
  ! meaning of Dbas is extended. There is
  !  Dbas(i        ,:,:,:) = values of the first basis function
  !  Dbas(i+ndofloc,:,:,:) = values of the 2nd basis function,
  ! with ndofloc the number of local DOFs per element.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

!</subroutine>

    integer :: i   ! point counter
    integer :: j   ! element counter

    ! P0 is a single basis function, constant in the element.
    ! The function value of the basis function is =1, the derivatives are all 0!

    !$omp parallel do default(shared) private(i) &
    !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
    do j=1,reval%nelements

      do i=1,reval%npointsPerElement
        Dbas(1,DER_FUNC,i,j) = 1.0_DP
      end do

    end do
    !$omp end parallel do

  end subroutine

  !************************************************************************
  ! Parametric P1 element
  !************************************************************************

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

 subroutine elem_eval_P1_2D (celement, reval, Bder, Dbas, rperfconfig)

!<description>
  ! This subroutine simultaneously calculates the values of the basic
  ! functions of the finite element at multiple given points on the
  ! reference element for multiple given elements.
!</description>

!<input>
  ! The element specifier.
  integer(I32), intent(in)                       :: celement

  ! t_evalElementSet-structure that contains cell-specific information and
  ! coordinates of the evaluation points. revalElementSet must be prepared
  ! for the evaluation.
  type(t_evalElementSet), intent(in)             :: reval

  ! Derivative quantifier array. array [1..DER_MAXNDER] of boolean.
  ! If bder(DER_xxxx)=true, the corresponding derivative (identified
  ! by DER_xxxx) is computed by the element (if supported). Otherwise,
  ! the element might skip the computation of that value type, i.e.
  ! the corresponding value 'Dvalue(DER_xxxx)' is undefined.
  logical, dimension(:), intent(in)              :: Bder

  ! Local performance configuration.
  type(t_perfconfig), intent(in)                 :: rperfconfig
!</input>

!<output>
  ! Value/derivatives of basis functions.
  ! array [1..EL_MAXNBAS,1..DER_MAXNDER,1..npointsPerElement,nelements] of double
  ! Bder(DER_FUNC)=true  => Dbas(i,DER_FUNC,j) defines the value of the i-th
  !   basis function of the finite element in the point Dcoords(j) on the
  !   reference element,
  !   Dvalue(i,DER_DERIV_X) the value of the x-derivative of the i-th
  !   basis function,...
  ! Bder(DER_xxxx)=false => Dbas(i,DER_xxxx,.) is undefined.
  !
  ! Due to the fact that this is a vector valued basis function, the
  ! meaning of Dbas is extended. There is
  !  Dbas(i        ,:,:,:) = values of the first basis function
  !  Dbas(i+ndofloc,:,:,:) = values of the 2nd basis function,
  ! with ndofloc the number of local DOFs per element.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

!</subroutine>

    real(DP), dimension(reval%npointsPerElement) :: dxj !auxiliary variable

    integer :: i   ! point counter
    integer :: j   ! element counter

    ! The P1 space consists of 'linear' finite elements. We have three basis
    ! functions on the reference element, which can be written down in
    ! standard coordinates (-> P(.)) as well as in barycentric coordinates
    ! (-> p(.)). These are:
    !
    !   p1(xi1,xi2,xi3) = xi1 =  1 - X - Y  = P1(X,Y)
    !   p2(xi1,xi2,xi3) = xi2 =  X          = P2(X,Y)
    !   p3(xi1,xi2,xi3) = xi3 =  Y          = P3(X,Y)

    !if function values are desired
    if (Bder(DER_FUNC)) then

      !$omp parallel do default(shared) private(i) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements

        do i=1,reval%npointsPerElement
          Dbas(1,DER_FUNC,i,j) = reval%p_DpointsRef(1,i,j)
          Dbas(2,DER_FUNC,i,j) = reval%p_DpointsRef(2,i,j)
          Dbas(3,DER_FUNC,i,j) = reval%p_DpointsRef(3,i,j)
        end do

      end do
      !$omp end parallel do

    end if

    !if x-or y-derivatives are desired
    if ((Bder(DER_DERIV_X)) .or. (Bder(DER_DERIV_Y))) then

      !$omp parallel do default(shared) private(i,Dxj) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements
        Dxj(:) = 1E0_DP / reval%p_Ddetj(1:reval%npointsPerElement,j)

        do i=1,reval%npointsPerElement
          !x-derivatives on current element
          Dbas(1,DER_DERIV_X,i,j) = -(reval%p_Djac(4,i,j)-reval%p_Djac(2,i,j))*Dxj(i)
          Dbas(2,DER_DERIV_X,i,j) =  reval%p_Djac(4,i,j)*Dxj(i)
          Dbas(3,DER_DERIV_X,i,j) = -reval%p_Djac(2,i,j)*Dxj(i)

          !y-derivatives on current element
          Dbas(1,DER_DERIV_Y,i,j) = (reval%p_Djac(3,i,j)-reval%p_Djac(1,i,j))*Dxj(i)
          Dbas(2,DER_DERIV_Y,i,j) = -reval%p_Djac(3,i,j)*Dxj(i)
          Dbas(3,DER_DERIV_Y,i,j) =  reval%p_Djac(1,i,j)*Dxj(i)
        end do

      end do
      !$omp end parallel do

    end if

  end subroutine

  !************************************************************************
  ! Parametric P2 element
  !************************************************************************

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

 subroutine elem_eval_P2_2D (celement, reval, Bder, Dbas, rperfconfig)

!<description>
  ! This subroutine simultaneously calculates the values of the basic
  ! functions of the finite element at multiple given points on the
  ! reference element for multiple given elements.
!</description>

!<input>
  ! The element specifier.
  integer(I32), intent(in)                       :: celement

  ! t_evalElementSet-structure that contains cell-specific information and
  ! coordinates of the evaluation points. revalElementSet must be prepared
  ! for the evaluation.
  type(t_evalElementSet), intent(in)             :: reval

  ! Derivative quantifier array. array [1..DER_MAXNDER] of boolean.
  ! If bder(DER_xxxx)=true, the corresponding derivative (identified
  ! by DER_xxxx) is computed by the element (if supported). Otherwise,
  ! the element might skip the computation of that value type, i.e.
  ! the corresponding value 'Dvalue(DER_xxxx)' is undefined.
  logical, dimension(:), intent(in)              :: Bder

  ! Local performance configuration.
  type(t_perfconfig), intent(in)                 :: rperfconfig
!</input>

!<output>
  ! Value/derivatives of basis functions.
  ! array [1..EL_MAXNBAS,1..DER_MAXNDER,1..npointsPerElement,nelements] of double
  ! Bder(DER_FUNC)=true  => Dbas(i,DER_FUNC,j) defines the value of the i-th
  !   basis function of the finite element in the point Dcoords(j) on the
  !   reference element,
  !   Dvalue(i,DER_DERIV_X) the value of the x-derivative of the i-th
  !   basis function,...
  ! Bder(DER_xxxx)=false => Dbas(i,DER_xxxx,.) is undefined.
  !
  ! Due to the fact that this is a vector valued basis function, the
  ! meaning of Dbas is extended. There is
  !  Dbas(i        ,:,:,:) = values of the first basis function
  !  Dbas(i+ndofloc,:,:,:) = values of the 2nd basis function,
  ! with ndofloc the number of local DOFs per element.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

!</subroutine>

    real(DP), dimension(reval%npointsPerElement) :: dxj !auxiliary variable
    real(DP) :: dp1,dp2,dp3 !auxiliary variable

    integer :: i   ! point counter
    integer :: j   ! element counter

    ! The P2 element is specified by six polynomials on the reference
    ! element.
    ! These six polynomials are:
    !
    ! p1(xi1,xi2,xi3) = xi1 * (2 * xi1 - 1)
    ! p2(xi1,xi2,xi3) = xi2 * (2 * xi2 - 1)
    ! p3(xi1,xi2,xi3) = xi3 * (2 * xi3 - 1)
    ! p4(xi1,xi2,xi3) = 4 * xi1 * xi2
    ! p5(xi1,xi2,xi3) = 4 * xi2 * xi3
    ! p6(xi1,xi2,xi3) = 4 * xi1 * xi3

    !if function values are desired
    if (Bder(DER_FUNC)) then

      !$omp parallel do default(shared) private(i) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements

        do i=1,reval%npointsPerElement
          Dbas(1,DER_FUNC,i,j)= reval%p_DpointsRef(1,i,j)*(reval%p_DpointsRef(1,i,j)- &
                                reval%p_DpointsRef(2,i,j)-reval%p_DpointsRef(3,i,j))
          Dbas(2,DER_FUNC,i,j)= reval%p_DpointsRef(2,i,j)*(reval%p_DpointsRef(2,i,j)- &
                                reval%p_DpointsRef(1,i,j)-reval%p_DpointsRef(3,i,j))
          Dbas(3,DER_FUNC,i,j)= reval%p_DpointsRef(3,i,j)*(reval%p_DpointsRef(3,i,j)- &
                                reval%p_DpointsRef(1,i,j)-reval%p_DpointsRef(2,i,j))
          Dbas(4,DER_FUNC,i,j)= 4.0_DP*reval%p_DpointsRef(1,i,j)*reval%p_DpointsRef(2,i,j)
          Dbas(5,DER_FUNC,i,j)= 4.0_DP*reval%p_DpointsRef(2,i,j)*reval%p_DpointsRef(3,i,j)
          Dbas(6,DER_FUNC,i,j)= 4.0_DP*reval%p_DpointsRef(1,i,j)*reval%p_DpointsRef(3,i,j)
        end do

      end do
      !$omp end parallel do

    end if

    !if x-or y-derivatives are desired
    if ((Bder(DER_DERIV_X)) .or. (Bder(DER_DERIV_Y))) then

      !$omp parallel do default(shared) private(i,Dxj,dp1,dp2,dp3) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements
        Dxj(:) = 1E0_DP / reval%p_Ddetj(1:reval%npointsPerElement,j)

        do i=1,reval%npointsPerElement

          dp1=(1.0_DP-4.0_DP*reval%p_DpointsRef(1,i,j))*Dxj(i)
          dp2=(4.0_DP*reval%p_DpointsRef(2,i,j)-1.0_DP)*Dxj(i)
          dp3=(4.0_DP*reval%p_DpointsRef(3,i,j)-1.0_DP)*Dxj(i)

          !x-derivatives on current element
          Dbas(1,DER_DERIV_X,i,j)= (reval%p_Djac(4,i,j)-reval%p_Djac(2,i,j))*dp1
          Dbas(2,DER_DERIV_X,i,j)= reval%p_Djac(4,i,j)*dp2
          Dbas(3,DER_DERIV_X,i,j)=-reval%p_Djac(2,i,j)*dp3
          Dbas(4,DER_DERIV_X,i,j)= &
              4.0_DP*(reval%p_DpointsRef(1,i,j)*reval%p_Djac(4,i,j)- &
                      reval%p_DpointsRef(2,i,j)*(reval%p_Djac(4,i,j)- &
                                                 reval%p_Djac(2,i,j)))*Dxj(i)
          Dbas(5,DER_DERIV_X,i,j)= &
              4.0_DP*(reval%p_DpointsRef(3,i,j)*reval%p_Djac(4,i,j)- &
                      reval%p_DpointsRef(2,i,j)*reval%p_Djac(2,i,j))*Dxj(i)
          Dbas(6,DER_DERIV_X,i,j)= &
              4.0_DP*(-reval%p_DpointsRef(1,i,j)*reval%p_Djac(2,i,j)- &
                       reval%p_DpointsRef(3,i,j)*(reval%p_Djac(4,i,j)- &
                                                  reval%p_Djac(2,i,j)))*Dxj(i)

          !y-derivatives on current element
          Dbas(1,DER_DERIV_Y,i,j)=-(reval%p_Djac(3,i,j)-reval%p_Djac(1,i,j))*dp1
          Dbas(2,DER_DERIV_Y,i,j)=-reval%p_Djac(3,i,j)*dp2
          Dbas(3,DER_DERIV_Y,i,j)= reval%p_Djac(1,i,j)*dp3
          Dbas(4,DER_DERIV_Y,i,j)= &
              4.0_DP*(-reval%p_DpointsRef(1,i,j)*reval%p_Djac(3,i,j)+ &
                       reval%p_DpointsRef(2,i,j)*(reval%p_Djac(3,i,j)- &
                                                  reval%p_Djac(1,i,j)))*Dxj(i)
          Dbas(5,DER_DERIV_Y,i,j)= &
              4.0_DP*(-reval%p_DpointsRef(3,i,j)*reval%p_Djac(3,i,j)+ &
                       reval%p_DpointsRef(2,i,j)*reval%p_Djac(1,i,j))*Dxj(i)
          Dbas(6,DER_DERIV_Y,i,j)= &
              4.0_DP*(reval%p_DpointsRef(1,i,j)*reval%p_Djac(1,i,j)+ &
                      reval%p_DpointsRef(3,i,j)*(reval%p_Djac(3,i,j)- &
                                                 reval%p_Djac(1,i,j)))*Dxj(i)
        end do

      end do
      !$omp end parallel do

    end if

  end subroutine

  !************************************************************************
  ! Parametric extended P2 element
  !************************************************************************

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

 subroutine elem_eval_P2E_2D (celement, reval, Bder, Dbas, rperfconfig)

!<description>
  ! This subroutine simultaneously calculates the values of the basic
  ! functions of the finite element at multiple given points on the
  ! reference element for multiple given elements.
!</description>

!<input>
  ! The element specifier.
  integer(I32), intent(in)                       :: celement

  ! t_evalElementSet-structure that contains cell-specific information and
  ! coordinates of the evaluation points. revalElementSet must be prepared
  ! for the evaluation.
  type(t_evalElementSet), intent(in)             :: reval

  ! Derivative quantifier array. array [1..DER_MAXNDER] of boolean.
  ! If bder(DER_xxxx)=true, the corresponding derivative (identified
  ! by DER_xxxx) is computed by the element (if supported). Otherwise,
  ! the element might skip the computation of that value type, i.e.
  ! the corresponding value 'Dvalue(DER_xxxx)' is undefined.
  logical, dimension(:), intent(in)              :: Bder

  ! Local performance configuration.
  type(t_perfconfig), intent(in)                 :: rperfconfig
!</input>

!<output>
  ! Value/derivatives of basis functions.
  ! array [1..EL_MAXNBAS,1..DER_MAXNDER,1..npointsPerElement,nelements] of double
  ! Bder(DER_FUNC)=true  => Dbas(i,DER_FUNC,j) defines the value of the i-th
  !   basis function of the finite element in the point Dcoords(j) on the
  !   reference element,
  !   Dvalue(i,DER_DERIV_X) the value of the x-derivative of the i-th
  !   basis function,...
  ! Bder(DER_xxxx)=false => Dbas(i,DER_xxxx,.) is undefined.
  !
  ! Due to the fact that this is a vector valued basis function, the
  ! meaning of Dbas is extended. There is
  !  Dbas(i        ,:,:,:) = values of the first basis function
  !  Dbas(i+ndofloc,:,:,:) = values of the 2nd basis function,
  ! with ndofloc the number of local DOFs per element.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

!</subroutine>

    real(DP), dimension(reval%npointsPerElement) :: dxj !auxiliary variable
    real(DP) :: dp1,dp2,dp3,dp4,dp5,dp6 !auxiliary variable

    integer :: i   ! point counter
    integer :: j   ! element counter

    ! The extended P2 element is specified by seven polynomials on the
    ! reference element.
    ! These seven polynomials are:
    !
    ! p1(xi1,xi2,xi3) = xi1 * (2 * xi1 - 1) +  3 * xi1 * xi2 * xi3
    ! p2(xi1,xi2,xi3) = xi2 * (2 * xi2 - 1) +  3 * xi1 * xi2 * xi3
    ! p3(xi1,xi2,xi3) = xi3 * (2 * xi3 - 1) +  3 * xi1 * xi2 * xi3
    ! p4(xi1,xi2,xi3) = 4 * xi1 * xi2       - 12 * xi1 * xi2 * xi3
    ! p5(xi1,xi2,xi3) = 4 * xi2 * xi3       - 12 * xi1 * xi2 * xi3
    ! p6(xi1,xi2,xi3) = 4 * xi1 * xi3       - 12 * xi1 * xi2 * xi3
    ! p7(xi1,xi2,xi3) =                       27 * xi1 * xi2 * xi3

    !if function values are desired
    if (Bder(DER_FUNC)) then

      !$omp parallel do default(shared) private(i) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements

        do i=1,reval%npointsPerElement
          Dbas(1,DER_FUNC,i,j)=&
              reval%p_DpointsRef(1,i,j)*(reval%p_DpointsRef(1,i,j)- &
              reval%p_DpointsRef(2,i,j)-reval%p_DpointsRef(3,i,j))+ &
              3.0_DP*reval%p_DpointsRef(1,i,j)* &
                     reval%p_DpointsRef(2,i,j)* &
                     reval%p_DpointsRef(3,i,j)
          Dbas(2,DER_FUNC,i,j)=&
              reval%p_DpointsRef(2,i,j)*(reval%p_DpointsRef(2,i,j)- &
              reval%p_DpointsRef(1,i,j)-reval%p_DpointsRef(3,i,j))+ &
              3.0_DP*reval%p_DpointsRef(1,i,j)* &
                     reval%p_DpointsRef(2,i,j)* &
                     reval%p_DpointsRef(3,i,j)
          Dbas(3,DER_FUNC,i,j)=&
              reval%p_DpointsRef(3,i,j)*(reval%p_DpointsRef(3,i,j)- &
              reval%p_DpointsRef(1,i,j)-reval%p_DpointsRef(2,i,j))+ &
              3.0_DP*reval%p_DpointsRef(1,i,j)* &
                     reval%p_DpointsRef(2,i,j)* &
                     reval%p_DpointsRef(3,i,j)
          Dbas(4,DER_FUNC,i,j)=&
              4.0_DP*reval%p_DpointsRef(1,i,j)*reval%p_DpointsRef(2,i,j)- &
              12.0_DP*reval%p_DpointsRef(1,i,j)* &
                      reval%p_DpointsRef(2,i,j)* &
                      reval%p_DpointsRef(3,i,j)
          Dbas(5,DER_FUNC,i,j)=&
              4.0_DP*reval%p_DpointsRef(2,i,j)*reval%p_DpointsRef(3,i,j)- &
              12.0_DP*reval%p_DpointsRef(1,i,j)* &
                      reval%p_DpointsRef(2,i,j)* &
                      reval%p_DpointsRef(3,i,j)
          Dbas(6,DER_FUNC,i,j)=&
              4.0_DP*reval%p_DpointsRef(1,i,j)*reval%p_DpointsRef(3,i,j)- &
              12.0_DP*reval%p_DpointsRef(1,i,j)* &
                      reval%p_DpointsRef(2,i,j)* &
                      reval%p_DpointsRef(3,i,j)
          Dbas(7,DER_FUNC,i,j)=&
              27.0_DP*reval%p_DpointsRef(1,i,j)* &
                      reval%p_DpointsRef(2,i,j)* &
                      reval%p_DpointsRef(3,i,j)
        end do

      end do
      !$omp end parallel do

    end if

    !if x-or y-derivatives are desired
    if ((Bder(DER_DERIV_X)) .or. (Bder(DER_DERIV_Y))) then

      !$omp parallel do default(shared) private(i,Dxj,dp1,dp2,dp3,dp4,dp5,dp6) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements
        Dxj(:) = 1E0_DP / reval%p_Ddetj(1:reval%npointsPerElement,j)

        do i=1,reval%npointsPerElement

          dp1=(1.0_DP-4.0_DP*reval%p_DpointsRef(1,i,j))*Dxj(i)
          dp2=(4.0_DP*reval%p_DpointsRef(2,i,j)-1.0_DP)*Dxj(i)
          dp3=(4.0_DP*reval%p_DpointsRef(3,i,j)-1.0_DP)*Dxj(i)
          dp4=3.0_DP*reval%p_DpointsRef(3,i,j)*(reval%p_DpointsRef(1,i,j)- &
                                                reval%p_DpointsRef(2,i,j))*Dxj(i)
          dp5=3.0_DP*reval%p_DpointsRef(2,i,j)*(reval%p_DpointsRef(1,i,j)- &
                                                reval%p_DpointsRef(3,i,j))*Dxj(i)

          !x-derivatives on current element
          dp6=dp4*reval%p_Djac(4,i,j)-dp5*reval%p_Djac(2,i,j)

          Dbas(1,DER_DERIV_X,i,j)= (reval%p_Djac(4,i,j)- &
                                    reval%p_Djac(2,i,j))*dp1+dp6
          Dbas(2,DER_DERIV_X,i,j)= reval%p_Djac(4,i,j)*dp2+dp6
          Dbas(3,DER_DERIV_X,i,j)=-reval%p_Djac(2,i,j)*dp3+dp6
          Dbas(4,DER_DERIV_X,i,j)=-4.0_DP*dp6+ &
              4.0_DP*(reval%p_DpointsRef(1,i,j)*reval%p_Djac(4,i,j) &
              -reval%p_DpointsRef(2,i,j)*(reval%p_Djac(4,i,j)- &
                                          reval%p_Djac(2,i,j)))*Dxj(i)
          Dbas(5,DER_DERIV_X,i,j)=-4.0_DP*dp6+ &
              4.0_DP*(reval%p_DpointsRef(3,i,j)*reval%p_Djac(4,i,j) &
              -reval%p_DpointsRef(2,i,j)*reval%p_Djac(2,i,j))*Dxj(i)
          Dbas(6,DER_DERIV_X,i,j)=-4.0_DP*dp6+ &
              4.0_DP*(-reval%p_DpointsRef(1,i,j)*reval%p_Djac(2,i,j)&
              -reval%p_DpointsRef(3,i,j)*(reval%p_Djac(4,i,j)- &
                                          reval%p_Djac(2,i,j)))*Dxj(i)
          Dbas(7,DER_DERIV_X,i,j)= 9.0_DP*dp6

          !y-derivatives on current element
          dp6=dp4*reval%p_Djac(3,i,j)-dp5*reval%p_Djac(1,i,j)

          Dbas(1,DER_DERIV_Y,i,j)=-(reval%p_Djac(3,i,j)- &
                                    reval%p_Djac(1,i,j))*dp1-dp6
          Dbas(2,DER_DERIV_Y,i,j)=-reval%p_Djac(3,i,j)*dp2-dp6
          Dbas(3,DER_DERIV_Y,i,j)= reval%p_Djac(1,i,j)*dp3-dp6
          Dbas(4,DER_DERIV_Y,i,j)= 4.0_DP*dp6+ &
              4.0_DP*(-reval%p_DpointsRef(1,i,j)*reval%p_Djac(3,i,j) &
                      +reval%p_DpointsRef(2,i,j)*(reval%p_Djac(3,i,j)- &
                                                  reval%p_Djac(1,i,j)))*Dxj(i)
          Dbas(5,DER_DERIV_Y,i,j)= 4.0_DP*dp6+ &
              4.0_DP*(-reval%p_DpointsRef(3,i,j)*reval%p_Djac(3,i,j) &
                      +reval%p_DpointsRef(2,i,j)*reval%p_Djac(1,i,j))*Dxj(i)
          Dbas(6,DER_DERIV_Y,i,j)= 4.0_DP*dp6+ &
              4.0_DP*(reval%p_DpointsRef(1,i,j)*reval%p_Djac(1,i,j) &
                      +reval%p_DpointsRef(3,i,j)*(reval%p_Djac(3,i,j)- &
                                                  reval%p_Djac(1,i,j)))*Dxj(i)
          Dbas(7,DER_DERIV_Y,i,j)=-9.0_DP*dp6
        end do

      end do
      !$omp end parallel do

    end if

  end subroutine

  !************************************************************************
  ! Parametric P3 element
  !************************************************************************

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

 subroutine elem_eval_P3_2D (celement, reval, Bder, Dbas, rperfconfig)

!<description>
  ! This subroutine simultaneously calculates the values of the basic
  ! functions of the finite element at multiple given points on the
  ! reference element for multiple given elements.
!</description>

!<input>
  ! The element specifier.
  integer(I32), intent(in)                       :: celement

  ! t_evalElementSet-structure that contains cell-specific information and
  ! coordinates of the evaluation points. revalElementSet must be prepared
  ! for the evaluation.
  type(t_evalElementSet), intent(in)             :: reval

  ! Derivative quantifier array. array [1..DER_MAXNDER] of boolean.
  ! If bder(DER_xxxx)=true, the corresponding derivative (identified
  ! by DER_xxxx) is computed by the element (if supported). Otherwise,
  ! the element might skip the computation of that value type, i.e.
  ! the corresponding value 'Dvalue(DER_xxxx)' is undefined.
  logical, dimension(:), intent(in)              :: Bder

  ! Local performance configuration.
  type(t_perfconfig), intent(in)                 :: rperfconfig
!</input>

!<output>
  ! Value/derivatives of basis functions.
  ! array [1..EL_MAXNBAS,1..DER_MAXNDER,1..npointsPerElement,nelements] of double
  ! Bder(DER_FUNC)=true  => Dbas(i,DER_FUNC,j) defines the value of the i-th
  !   basis function of the finite element in the point Dcoords(j) on the
  !   reference element,
  !   Dvalue(i,DER_DERIV_X) the value of the x-derivative of the i-th
  !   basis function,...
  ! Bder(DER_xxxx)=false => Dbas(i,DER_xxxx,.) is undefined.
  !
  ! Due to the fact that this is a vector valued basis function, the
  ! meaning of Dbas is extended. There is
  !  Dbas(i        ,:,:,:) = values of the first basis function
  !  Dbas(i+ndofloc,:,:,:) = values of the 2nd basis function,
  ! with ndofloc the number of local DOFs per element.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

!</subroutine>

    real(DP), dimension(reval%npointsPerElement) :: dxj !auxiliary variable
    real(DP) :: dp1,dp2,dp3,dp4,dp5,dp6,dp7,dp8,dp9,dp10,dp11,dp12,dp13,dp14 !auxiliary variable

    integer :: i   ! point counter
    integer :: j   ! element counter

    ! The P3_2D element is specified by six polynomials on the reference element.
    ! These ten polynomials are:
    !
    !  p1(xi1,xi2,xi3) = 0.5 * xi1 * (3*xi1-1) * (3*xi1-2)
    !  p2(xi1,xi2,xi3) = 0.5 * xi2 * (3*xi2-1) * (3*xi2-2)
    !  p3(xi1,xi2,xi3) = 0.5 * xi3 * (3*xi3-1) * (3*xi3-2)
    !  p4(xi1,xi2,xi3) = 4.5 * xi1 * xi2 * (3*xi1-1)
    !  p5(xi1,xi2,xi3) = 4.5 * xi2 * xi3 * (3*xi2-1)
    !  p6(xi1,xi2,xi3) = 4.5 * xi3 * xi1 * (3*xi3-1)
    !  p7(xi1,xi2,xi3) = 4.5 * xi2 * xi1 * (3*xi2-1)
    !  p8(xi1,xi2,xi3) = 4.5 * xi3 * xi2 * (3*xi3-1)
    !  p9(xi1,xi2,xi3) = 4.5 * xi1 * xi3 * (3*xi1-1)
    ! p10(xi1,xi2,xi3) = 27 * xi1 * xi2 * xi3

    !if function values are desired
    if (Bder(DER_FUNC)) then

      !$omp parallel do default(shared) private(i) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements

        do i=1,reval%npointsPerElement
          Dbas(1,DER_FUNC,i,j)= 0.5_DP*reval%p_DpointsRef(1,i,j)* &
                                       (3.0_DP*reval%p_DpointsRef(1,i,j)-1.0_DP)* &
                                       (3.0_DP*reval%p_DpointsRef(1,i,j)-2.0_DP)
          Dbas(2,DER_FUNC,i,j)= 0.5_DP*reval%p_DpointsRef(2,i,j)* &
                                       (3.0_DP*reval%p_DpointsRef(2,i,j)-1.0_DP)* &
                                       (3.0_DP*reval%p_DpointsRef(2,i,j)-2.0_DP)
          Dbas(3,DER_FUNC,i,j)= 0.5_DP*reval%p_DpointsRef(3,i,j)* &
                                       (3.0_DP*reval%p_DpointsRef(3,i,j)-1.0_DP)* &
                                       (3.0_DP*reval%p_DpointsRef(3,i,j)-2.0_DP)
          Dbas(4,DER_FUNC,i,j)= 4.5_DP*reval%p_DpointsRef(1,i,j)* &
                                       reval%p_DpointsRef(2,i,j)* &
                                       (3.0_DP*reval%p_DpointsRef(1,i,j)-1.0_DP)
          Dbas(5,DER_FUNC,i,j)= 4.5_DP*reval%p_DpointsRef(2,i,j)* &
                                       reval%p_DpointsRef(3,i,j)* &
                                       (3.0_DP*reval%p_DpointsRef(2,i,j)-1.0_DP)
          Dbas(6,DER_FUNC,i,j)= 4.5_DP*reval%p_DpointsRef(3,i,j)* &
                                       reval%p_DpointsRef(1,i,j)* &
                                       (3.0_DP*reval%p_DpointsRef(3,i,j)-1.0_DP)
          Dbas(7,DER_FUNC,i,j)= 4.5_DP*reval%p_DpointsRef(2,i,j)* &
                                       reval%p_DpointsRef(1,i,j)* &
                                       (3.0_DP*reval%p_DpointsRef(2,i,j)-1.0_DP)
          Dbas(8,DER_FUNC,i,j)= 4.5_DP*reval%p_DpointsRef(3,i,j)* &
                                       reval%p_DpointsRef(2,i,j)* &
                                       (3.0_DP*reval%p_DpointsRef(3,i,j)-1.0_DP)
          Dbas(9,DER_FUNC,i,j)= 4.5_DP*reval%p_DpointsRef(1,i,j)* &
                                       reval%p_DpointsRef(3,i,j)* &
                                       (3.0_DP*reval%p_DpointsRef(1,i,j)-1.0_DP)
          Dbas(10,DER_FUNC,i,j)= 27.0_DP*reval%p_DpointsRef(1,i,j)* &
                                         reval%p_DpointsRef(2,i,j)* &
                                         reval%p_DpointsRef(3,i,j)
        end do

      end do
      !$omp end parallel do

    end if

    !if x-or y-derivatives are desired
    if ((Bder(DER_DERIV_X)) .or. (Bder(DER_DERIV_Y))) then

      !$omp parallel do default(shared) &
      !$omp private(i,Dxj,dp1,dp2,dp3,dp4,dp5,dp6,dp7,dp8,dp9,dp10,dp11,dp12) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements
        Dxj(:) = 1E0_DP / reval%p_Ddetj(1:reval%npointsPerElement,j)

        do i=1,reval%npointsPerElement

          dp1=-(4.5_DP*reval%p_DpointsRef(1,i,j)* &
              (3.0_DP*reval%p_DpointsRef(1,i,j)-2.0_DP)-1.0_DP)*Dxj(i)
          dp2= (4.5_DP*reval%p_DpointsRef(2,i,j)* &
              (3.0_DP*reval%p_DpointsRef(2,i,j)-2.0_DP)-1.0_DP)*Dxj(i)
          dp3= (4.5_DP*reval%p_DpointsRef(3,i,j)* &
              (3.0_DP*reval%p_DpointsRef(3,i,j)-2.0_DP)-1.0_DP)*Dxj(i)

          dp4= 4.5_DP*reval%p_DpointsRef(2,i,j)* &
              (1.0_DP-6.0_DP*reval%p_DpointsRef(1,i,j))*Dxj(i)
          dp5= 4.5_DP*reval%p_DpointsRef(3,i,j)* &
              (6.0_DP*reval%p_DpointsRef(2,i,j)-1.0_DP)*Dxj(i)
          dp6= 4.5_DP*reval%p_DpointsRef(1,i,j)* &
              (6.0_DP*reval%p_DpointsRef(3,i,j)-1.0_DP)*Dxj(i)

          dp7= 4.5_DP*reval%p_DpointsRef(1,i,j)* &
              (6.0_DP*reval%p_DpointsRef(2,i,j)-1.0_DP)*Dxj(i)
          dp8= 4.5_DP*reval%p_DpointsRef(2,i,j)* &
              (6.0_DP*reval%p_DpointsRef(3,i,j)-1.0_DP)*Dxj(i)
          dp9= 4.5_DP*reval%p_DpointsRef(3,i,j)* &
              (1.0_DP-6.0_DP*reval%p_DpointsRef(1,i,j))*Dxj(i)

          dp10=4.5_DP*reval%p_DpointsRef(1,i,j)* &
              (3.0_DP*reval%p_DpointsRef(1,i,j)-1.0_DP)*Dxj(i)
          dp11=4.5_DP*reval%p_DpointsRef(2,i,j)* &
              (3.0_DP*reval%p_DpointsRef(2,i,j)-1.0_DP)*Dxj(i)
          dp12=4.5_DP*reval%p_DpointsRef(3,i,j)* &
              (3.0_DP*reval%p_DpointsRef(3,i,j)-1.0_DP)*Dxj(i)

          dp13=27.0_DP*reval%p_DpointsRef(3,i,j)*(reval%p_DpointsRef(1,i,j)- &
                                                  reval%p_DpointsRef(2,i,j))*Dxj(i)
          dp14=27.0_DP*reval%p_DpointsRef(2,i,j)*(reval%p_DpointsRef(1,i,j)- &
                                                  reval%p_DpointsRef(3,i,j))*Dxj(i)

          !x-derivatives on current element
          Dbas(1,DER_DERIV_X,i,j)= (reval%p_Djac(4,i,j)-reval%p_Djac(2,i,j))*dp1
          Dbas(2,DER_DERIV_X,i,j)= reval%p_Djac(4,i,j)*dp2
          Dbas(3,DER_DERIV_X,i,j)=-reval%p_Djac(2,i,j)*dp3

          Dbas(4,DER_DERIV_X,i,j)= (reval%p_Djac(4,i,j)-reval%p_Djac(2,i,j))*dp4+ &
                                   reval%p_Djac(4,i,j)*dp10
          Dbas(5,DER_DERIV_X,i,j)= reval%p_Djac(4,i,j)*dp5-reval%p_Djac(2,i,j)*dp11
          Dbas(6,DER_DERIV_X,i,j)= (reval%p_Djac(2,i,j)-reval%p_Djac(4,i,j))*dp12- &
                                   reval%p_Djac(2,i,j)*dp6

          Dbas(7,DER_DERIV_X,i,j)= (reval%p_Djac(2,i,j)-reval%p_Djac(4,i,j))*dp11+ &
                                   reval%p_Djac(4,i,j)*dp7
          Dbas(8,DER_DERIV_X,i,j)= reval%p_Djac(4,i,j)*dp12-reval%p_Djac(2,i,j)*dp8
          Dbas(9,DER_DERIV_X,i,j)= (reval%p_Djac(4,i,j)-reval%p_Djac(2,i,j))*dp9- &
                                   reval%p_Djac(2,i,j)*dp10
          Dbas(10,DER_DERIV_X,i,j)= dp13*reval%p_Djac(4,i,j)-dp14*reval%p_Djac(2,i,j)

          !y-derivatives on current element
          Dbas(1,DER_DERIV_Y,i,j)=-(reval%p_Djac(3,i,j)-reval%p_Djac(1,i,j))*dp1
          Dbas(2,DER_DERIV_Y,i,j)=-reval%p_Djac(3,i,j)*dp2
          Dbas(3,DER_DERIV_Y,i,j)= reval%p_Djac(1,i,j)*dp3

          Dbas(4,DER_DERIV_Y,i,j)=-(reval%p_Djac(3,i,j)-reval%p_Djac(1,i,j))*dp4- &
                                   reval%p_Djac(3,i,j)*dp10
          Dbas(5,DER_DERIV_Y,i,j)=-reval%p_Djac(3,i,j)*dp5+reval%p_Djac(1,i,j)*dp11
          Dbas(6,DER_DERIV_Y,i,j)=-(reval%p_Djac(1,i,j)-reval%p_Djac(3,i,j))*dp12+ &
                                   reval%p_Djac(1,i,j)*dp6

          Dbas(7,DER_DERIV_Y,i,j)=-(reval%p_Djac(1,i,j)-reval%p_Djac(3,i,j))*dp11-&
                                   reval%p_Djac(3,i,j)*dp7
          Dbas(8,DER_DERIV_Y,i,j)=-reval%p_Djac(3,i,j)*dp12+reval%p_Djac(1,i,j)*dp8
          Dbas(9,DER_DERIV_Y,i,j)=-(reval%p_Djac(3,i,j)-reval%p_Djac(1,i,j))*dp9+&
                                   reval%p_Djac(1,i,j)*dp10
          Dbas(10,DER_DERIV_Y,i,j)= -dp13*reval%p_Djac(3,i,j)+dp14*reval%p_Djac(1,i,j)
        end do

      end do
      !$omp end parallel do

    end if

  end subroutine

  !************************************************************************
  ! Parametric P1~ element
  !************************************************************************

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

 subroutine elem_eval_P1T_2D (celement, reval, Bder, Dbas, rperfconfig)

!<description>
  ! This subroutine simultaneously calculates the values of the basic
  ! functions of the finite element at multiple given points on the
  ! reference element for multiple given elements.
!</description>

!<input>
  ! The element specifier.
  integer(I32), intent(in)                       :: celement

  ! t_evalElementSet-structure that contains cell-specific information and
  ! coordinates of the evaluation points. revalElementSet must be prepared
  ! for the evaluation.
  type(t_evalElementSet), intent(in)             :: reval

  ! Derivative quantifier array. array [1..DER_MAXNDER] of boolean.
  ! If bder(DER_xxxx)=true, the corresponding derivative (identified
  ! by DER_xxxx) is computed by the element (if supported). Otherwise,
  ! the element might skip the computation of that value type, i.e.
  ! the corresponding value 'Dvalue(DER_xxxx)' is undefined.
  logical, dimension(:), intent(in)              :: Bder

  ! Local performance configuration.
  type(t_perfconfig), intent(in)                 :: rperfconfig
!</input>

!<output>
  ! Value/derivatives of basis functions.
  ! array [1..EL_MAXNBAS,1..DER_MAXNDER,1..npointsPerElement,nelements] of double
  ! Bder(DER_FUNC)=true  => Dbas(i,DER_FUNC,j) defines the value of the i-th
  !   basis function of the finite element in the point Dcoords(j) on the
  !   reference element,
  !   Dvalue(i,DER_DERIV_X) the value of the x-derivative of the i-th
  !   basis function,...
  ! Bder(DER_xxxx)=false => Dbas(i,DER_xxxx,.) is undefined.
  !
  ! Due to the fact that this is a vector valued basis function, the
  ! meaning of Dbas is extended. There is
  !  Dbas(i        ,:,:,:) = values of the first basis function
  !  Dbas(i+ndofloc,:,:,:) = values of the 2nd basis function,
  ! with ndofloc the number of local DOFs per element.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

!</subroutine>

    real(DP), dimension(reval%npointsPerElement) :: dxj !auxiliary variable

    integer :: i   ! point counter
    integer :: j   ! element counter

    ! The P1~ space consists of 'linear' finite elements. We have three basis
    ! functions on the reference element, which can be written down in
    ! standard coordinates (-> P(.)) as well as in barycentric coordinates
    ! (-> p(.)). These are:
    !
    !   p1(xi1,xi2,xi3) = 1 - 2*xi3 =  1 - 2*Y       = P1(X,Y)
    !   p2(xi1,xi2,xi3) = 1 - 2*xi1 = -1 + 2*X + 2*Y = P2(X,Y)
    !   p3(xi1,xi2,xi3) = 1 - 2*xi2 =  1 - 2*X       = P3(X,Y)

    !if function values are desired
    if (Bder(DER_FUNC)) then

      !$omp parallel do default(shared) private(i) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements

        do i=1,reval%npointsPerElement
          Dbas(1,DER_FUNC,i,j) = 1._DP -2E0_DP*reval%p_DpointsRef(3,i,j)
          Dbas(2,DER_FUNC,i,j) = 1._DP -2E0_DP*reval%p_DpointsRef(1,i,j)
          Dbas(3,DER_FUNC,i,j) = 1._DP -2E0_DP*reval%p_DpointsRef(2,i,j)
        end do

      end do
      !$omp end parallel do

    end if

    !if x-or y-derivatives are desired
    if ((Bder(DER_DERIV_X)) .or. (Bder(DER_DERIV_Y))) then

      !$omp parallel do default(shared) private(i,Dxj) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements
        Dxj(:) = 1E0_DP / reval%p_Ddetj(1:reval%npointsPerElement,j)

        do i=1,reval%npointsPerElement
          !x-derivatives on current element
          Dbas(1,DER_DERIV_X,i,j) = 2E0_DP*reval%p_Djac(2,i,j)*Dxj(i)
          Dbas(2,DER_DERIV_X,i,j) = 2E0_DP*(reval%p_Djac(4,i,j)- &
                                            reval%p_Djac(2,i,j))*Dxj(i)
          Dbas(3,DER_DERIV_X,i,j) = -2E0_DP*reval%p_Djac(4,i,j)*Dxj(i)

          !y-derivatives on current element
          Dbas(1,DER_DERIV_Y,i,j) = -2E0_DP*reval%p_Djac(1,i,j)*Dxj(i)
          Dbas(2,DER_DERIV_Y,i,j) = -2E0_DP*(reval%p_Djac(3,i,j)- &
                                             reval%p_Djac(1,i,j))*Dxj(i)
          Dbas(3,DER_DERIV_Y,i,j) =  2E0_DP*reval%p_Djac(3,i,j)*Dxj(i)
        end do

      end do
      !$omp end parallel do

    end if

  end subroutine

  !************************************************************************
  ! Lowest order Raviart-Thomas element
  !************************************************************************

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

 subroutine elem_eval_RT1_2D (celement, reval, Bder, Dbas, rperfconfig)

!<description>
  ! This subroutine simultaneously calculates the values of the basic
  ! functions of the finite element at multiple given points on the
  ! reference element for multiple given elements.
!</description>

!<input>
  ! The element specifier.
  integer(I32), intent(in)                       :: celement

  ! t_evalElementSet-structure that contains cell-specific information and
  ! coordinates of the evaluation points. revalElementSet must be prepared
  ! for the evaluation.
  type(t_evalElementSet), intent(in)             :: reval

  ! Derivative quantifier array. array [1..DER_MAXNDER] of boolean.
  ! If bder(DER_xxxx)=true, the corresponding derivative (identified
  ! by DER_xxxx) is computed by the element (if supported). Otherwise,
  ! the element might skip the computation of that value type, i.e.
  ! the corresponding value 'Dvalue(DER_xxxx)' is undefined.
  logical, dimension(:), intent(in)              :: Bder

  ! Local performance configuration.
  type(t_perfconfig), intent(in)                 :: rperfconfig
!</input>

!<output>
  ! Value/derivatives of basis functions.
  ! array [1..EL_MAXNBAS,1..DER_MAXNDER,1..npointsPerElement,nelements] of double
  ! Bder(DER_FUNC)=true  => Dbas(i,DER_FUNC,j) defines the value of the i-th
  !   basis function of the finite element in the point Dcoords(j) on the
  !   reference element,
  !   Dvalue(i,DER_DERIV_X) the value of the x-derivative of the i-th
  !   basis function,...
  ! Bder(DER_xxxx)=false => Dbas(i,DER_xxxx,.) is undefined.
  !
  ! Due to the fact that this is a vector valued basis function, the
  ! meaning of Dbas is extended. There is
  !  Dbas(i        ,:,:,:) = values of the first basis function
  !  Dbas(i+ndofloc,:,:,:) = values of the 2nd basis function,
  ! with ndofloc the number of local DOFs per element.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

!</subroutine>

  ! Element Description
  ! -------------------
  ! The lowest order Raviart-Thomas element is a vector-valued finite element.
  ! On each cell, one has two P1 polynoms defined as follows:
  !
  !   v = ( v_1 ) = ( a + c x )
  !       ( v_2 )   ( b + c y )
  !
  ! with a,b,c three coefficients. The element has three degrees of
  ! freedom per element which are, however, not a,b,c but the normal
  ! flux through each edge of the triangle:
  !
  !      x3
  !      |\
  !      | \  _
  !      |  \ /|
  !    <-3   2
  !      |    \
  !      |     \
  !      |      \
  !     x1---1---x2
  !          |
  !          v
  !
  ! The three DOFs are
  !    d1=<v,n1>,
  !    d2=<v,n2> and
  !    d3=<v,n3> with
  ! ni the three normal vectors.
  !
  ! We apply a nonparametric approach here...

    ! Local variables
    real(DP), dimension(3,3) :: Da,Dcoeff
    real(DP) :: dlen1,dlen2,dlen3
    real(DP) :: dx1,dy1,dx2,dy2,dx3,dy3, dx,dy
    real(DP) :: dnx1,dny1,dnx2,dny2,dnx3,dny3
    real(DP) :: dmx1,dmy1,dmx2,dmy2,dmx3,dmy3
    real(DP) :: da1,da2,da3,db1,db2,db3,dc1,dc2,dc3
    integer :: itwist,i,iel
    real(DP) :: dtwist1,dtwist2,dtwist3
    logical :: bsuccess

    ! Loop through all elements
    !$omp parallel do default(shared)&
    !$omp private(dx1,dx2,dx3,dy1,dy2,dy3,dlen1,dlen2,dlen3,&
    !$omp         dnx1,dnx2,dnx3,dny1,dny2,dny3,dmx1,dmx2,dmx3,&
    !$omp         dmy1,dmy2,dmy3,itwist,dtwist1,dtwist2,dtwist3)&
    !$omp if(reval%nelements > reval%p_rperfconfig%NELEMMIN_OMP)
    do iel = 1, reval%nelements

      ! Get the twist indices that define the orientation of our edges.
      ! A value of 1 is standard, a value of -1 results in a change of the
      ! sign in the basis functions.
      ! itwistIndex is a bitfield. Each bit specifies the orientation of an edge.
      ! We use the bit to calculate a "1.0" if the edge has positive orientation
      ! and "-1.0" if it has negative orientation.
      itwist = reval%p_ItwistIndex(iel)
      dtwist1 = real(1-iand(int(ishft(itwist, 1)),2),DP)
      dtwist2 = real(1-iand(int(ishft(itwist, 0)),2),DP)
      dtwist3 = real(1-iand(int(ishft(itwist,-1)),2),DP)

      ! Calculate the three normal vectors...
      !
      ! Element corners
      dx1 = reval%p_Dcoords(1,1,iel)
      dy1 = reval%p_Dcoords(2,1,iel)
      dx2 = reval%p_Dcoords(1,2,iel)
      dy2 = reval%p_Dcoords(2,2,iel)
      dx3 = reval%p_Dcoords(1,3,iel)
      dy3 = reval%p_Dcoords(2,3,iel)

      ! Inverse of the edge length
      dlen1 = 1.0_DP/sqrt( (dx2-dx1)**2 + (dy2-dy1)**2 )
      dlen2 = 1.0_DP/sqrt( (dx3-dx2)**2 + (dy3-dy2)**2 )
      dlen3 = 1.0_DP/sqrt( (dx1-dx3)**2 + (dy1-dy3)**2 )

      ! Calculate the normal vectors to the edges from the corners.
      ! The tangential vectors of the edges are
      !
      !    t1 = (x2-x1) / ||x2-x1||
      !    t2 = (x3-x2) / ||x3-x2||
      !    t3 = (x1-x3) / ||x1-x3||
      !
      ! The corresponding normals are calculated from
      !
      !    ni = ( ti2, -ti1 )
      !
      dnx1 = (dy2-dy1)  *dlen1*dtwist1
      dny1 = -(dx2-dx1) *dlen1*dtwist1

      dnx2 = (dy3-dy2)  *dlen2*dtwist2
      dny2 = -(dx3-dx2) *dlen2*dtwist2

      dnx3 = (dy1-dy3)  *dlen3*dtwist3
      dny3 = -(dx1-dx3) *dlen3*dtwist3

      ! Midpoints of the edges
      dmx1 = 0.5_DP*(dx1+dx2)
      dmx2 = 0.5_DP*(dx2+dx3)
      dmx3 = 0.5_DP*(dx3+dx1)

      dmy1 = 0.5_DP*(dy1+dy2)
      dmy2 = 0.5_DP*(dy2+dy3)
      dmy3 = 0.5_DP*(dy3+dy1)

      ! Set up a transformation matrix to calculate the a,b and c.
      !
      ! The conditions to be solved for one basis function read:
      !
      !   < v,ni > = di
      !
      ! or more exactly
      !
      !   n1x (a+cx)  +  n1y (b+cy)  =  d1
      !   n2x (a+cx)  +  n2y (b+cy)  =  d2
      !   n3x (a+cx)  +  n3y (b+cy)  =  d3
      !
      ! or equivalently
      !
      !  ( n1x  n1y  (n1x x + n1y y) )  ( a )  =  ( d1 )
      !  ( n2x  n2y  (n2x x + n2y y) )  ( b )     ( d2 )
      !  ( n3x  n3y  (n3x x + n3y y) )  ( c )     ( d3 )
      !
      ! Set up this matrix. For (x,y), insert the midpoint of the edge
      ! corresponding to the normal.

      Da(1,1) = dnx1
      Da(2,1) = dnx2
      Da(3,1) = dnx3

      Da(1,2) = dny1
      Da(2,2) = dny2
      Da(3,2) = dny3

      Da(1,3) = dnx1*dmx1 + dny1*dmy1
      Da(2,3) = dnx2*dmx2 + dny2*dmy2
      Da(3,3) = dnx3*dmx3 + dny3*dmy3

      ! Taking the inverse will give us all a,b and c of
      ! the three basis functions:
      !
      !  ( n1x  n1y  (n1x x + n1y y) )  ( a1  a2  a3 )  =  ( 1  0  0 )
      !  ( n2x  n2y  (n2x x + n2y y) )  ( b1  b2  b3 )     ( 0  1  0 )
      !  ( n3x  n3y  (n3x x + n3y y) )  ( c1  c2  c3 )     ( 0  0  1 )
      !
      !                                 --------------
      !                                 Inverse of the matrix
      call mprim_invert3x3MatrixDirect(Da,Dcoeff,bsuccess)

      da1 = Dcoeff(1,1)
      db1 = Dcoeff(2,1)
      dc1 = Dcoeff(3,1)

      da2 = Dcoeff(1,2)
      db2 = Dcoeff(2,2)
      dc2 = Dcoeff(3,2)

      da3 = Dcoeff(1,3)
      db3 = Dcoeff(2,3)
      dc3 = Dcoeff(3,3)

      ! Loop through all points on the current element
      do i = 1, reval%npointsPerElement

        ! Get the point coordinates
        dx = reval%p_DpointsReal(1,i,iel)
        dy = reval%p_DpointsReal(2,i,iel)

        ! Evaluate basis functions.
        !
        !   v = ( a + c*x )
        !       ( b + c*y )
        Dbas(1,DER_FUNC2D,i,iel) = da1 + dc1*dx
        Dbas(2,DER_FUNC2D,i,iel) = da2 + dc2*dx
        Dbas(3,DER_FUNC2D,i,iel) = da3 + dc3*dx

        Dbas(4,DER_FUNC2D,i,iel) = db1 + dc1*dy
        Dbas(5,DER_FUNC2D,i,iel) = db2 + dc2*dy
        Dbas(6,DER_FUNC2D,i,iel) = db3 + dc3*dy

        ! 1st derivative is also directly available and
        ! costs no additional time to be computed.
        Dbas(1,DER_DERIV2D_X,i,iel) = dc1
        Dbas(2,DER_DERIV2D_X,i,iel) = dc2
        Dbas(3,DER_DERIV2D_X,i,iel) = dc3

        Dbas(4,DER_DERIV2D_X,i,iel) = 0.0_DP
        Dbas(5,DER_DERIV2D_X,i,iel) = 0.0_DP
        Dbas(6,DER_DERIV2D_X,i,iel) = 0.0_DP

        Dbas(1,DER_DERIV2D_Y,i,iel) = 0.0_DP
        Dbas(2,DER_DERIV2D_Y,i,iel) = 0.0_DP
        Dbas(3,DER_DERIV2D_Y,i,iel) = 0.0_DP

        Dbas(4,DER_DERIV2D_Y,i,iel) = dc1
        Dbas(5,DER_DERIV2D_Y,i,iel) = dc2
        Dbas(6,DER_DERIV2D_Y,i,iel) = dc3

      end do ! i

    end do ! iel
    !$omp end parallel do

  ! From these three DOFs, one can extract the three coefficients
  ! a,b,c that define the polynoms of the x- and y-velocity as
  ! follows. One takes into account that the d_i are constant
  ! along the complete edge, including the corner.
  ! So there is for the reference element
  !
  !    d1 = <v,n1> = -(b+cy)
  !    d2 = <v,n2> = 1/sqrt(2) ( a + b + cx + cy )
  !    d3 = <v,n3> = -(a+cx)
  !
  ! On the reference triangle, this implies
  !
  !    d1 = -b                        due to y=0
  !    d2 = 1/sqrt(2) ( a + b + c )   for x=y=1/2 on the edge
  !    d3 = -a                        due to x=0
  !
  ! and thus,
  !
  !    b = -d1
  !    a = -d3
  !    c = sqrt(2)*d2 + d1 + d3
  !
  ! The coefficients of the three local basis functions per element
  ! therefore read
  !
  !   d1=1:  a1 = 0 ,  b1 = -1,  c1 = 1
  !   d2=1:  a2 = 0 ,  b2 = 0 ,  c2 = sqrt(2)
  !   d3=1:  s3 = -1,  b3 = 0 ,  c3 = 1
  !
  ! However, one problem remains - the coordinates are given in
  ! barycentric coordinates. However, this is not really a
  ! problem since
  !
  !    xi1 = 1-x-y
  !    xi2 = x
  !    xi3 = y
  !
  ! so we can just work with xi1 and xi2 instead of x and y.
  !
  ! WARNING: The DOF corresponds to the amount of flow in normal
  ! direction of the edge. However, "normal direction" refers
  ! to the *global* orientation of the edge. Hence, we have to take
  ! this global orientation into account, which is realised by
  ! the "twist indices". If the bit in the twist index corresponding
  ! to the edge is =0, the basis function to this edge is defined as
  ! above. if it is =-1, the orientation is negative and we have
  ! to switch the sign in the basis functions appropriately!
  !
  ! The construction that takes the twist indices into account
  ! reads as follows. For the reference element, there is
  !
  !    d1 = <v,d1 n1> = -(b+cy) * t1
  !    d2 = <v,d2 n2> = 1/sqrt(2) ( a + b + cx + cy ) * t2
  !    d3 = <v,d3 n3> = -(a+cx) * t3
  !
  ! with ti=1 or =-1 depending on the orientation of edge i.
  !
  ! On the reference triangle, this implies
  !
  !    d1 = -b * t1                       due to y=0
  !    d2 = 1/sqrt(2) ( a + b + c ) * t2  for x=y=1/2 on the edge
  !    d3 = -a * t3                       due to x=0
  !
  ! and thus,
  !
  !    b = -d1 * t1
  !    a = -d3 * t3
  !    c = sqrt(2)*d2*t2 + d1*t1 + d3*t3
  !
  ! The coefficients of the three local basis functions per element
  ! therefore read
  !
  !   d1=1:  a1 = 0  ,  b1 = -t1,  c1 = t1
  !   d2=1:  a2 = 0  ,  b2 = 0  ,  c2 = sqrt(2)*t2
  !   d3=1:  a3 = -t3,  b3 = 0  ,  c3 = t3
  !

!  ! Local variables
!  real(DP) :: dxi1,dxi2,dxj,dtwist1,dtwist2,dtwist3
!  integer :: i,j
!  integer :: itwist
!
!    ! Calculate function values?
!    if(Bder(DER_FUNC2D)) then
!
!      ! If function values are desired, calculate them.
!
!      ! Loop through all elements
!      !$omp parallel do default(shared) private(i,dxi1,dxi2,itwist,dtwist1,dtwist2,dtwist3)&
!      !$omp if(reval%nelements > reval%p_rperfconfig%NELEMMIN_OMP)
!      do j = 1, reval%nelements
!
!        ! Get the twist indices that define the orientation of our edges.
!        ! A value of 1 is standard, a value of -1 results in a change of the
!        ! sign in the basis functions.
!        ! itwistIndex is a bitfield. Each bit specifies the orientation of an edge.
!        ! We use the bit to calculate a "1.0" if the edge has positive orientation
!        ! and "-1.0" if it has negative orientation.
!        itwist = reval%p_ItwistIndex(j)
!        dtwist1 = real(1-iand(int(ishft(itwist, 1)),2),DP)
!        dtwist2 = real(1-iand(int(ishft(itwist, 0)),2),DP)
!        dtwist3 = real(1-iand(int(ishft(itwist,-1)),2),DP)
!
!        ! Loop through all points on the current element
!        do i = 1, reval%npointsPerElement
!
!          ! Get the point coordinates
!          dxi1 = reval%p_DpointsRef(2,i,j)
!          dxi2 = reval%p_DpointsRef(3,i,j)
!
!          ! Evaluate basis functions
!          !
!          !   v1 = (       t1 x )
!          !        ( -t1 + t1 y )
!          !
!          !   v2 = ( sqrt(2) t2 x )
!          !        ( sqrt(2) t2 y )
!          !
!          !   v3 = ( -t3 + t3 x )
!          !        (       t3 y )
!          Dbas(1,DER_FUNC2D,i,j) = dtwist1*dxi1
!          Dbas(2,DER_FUNC2D,i,j) = dtwist2*sqrt(2.0_DP)*dxi1
!          Dbas(3,DER_FUNC2D,i,j) = dtwist3*(-1.0_DP + dxi1)
!
!          Dbas(4,DER_FUNC2D,i,j) = dtwist1*(-1.0_DP + dxi2)
!          Dbas(5,DER_FUNC2D,i,j) = dtwist2*sqrt(2.0_DP)*dxi2
!          Dbas(6,DER_FUNC2D,i,j) = dtwist3*dxi2
!
!        end do ! i
!
!      end do ! j
!      !$omp end parallel do
!
!    end if
!
!    ! Calculate derivatives?
!    if ((Bder(DER_DERIV_X)) .or. (Bder(DER_DERIV_Y))) then
!
!      ! If function values are desired, calculate them.
!
!      ! Loop through all elements
!      !$omp parallel do default(shared) private(i,dxi1,dxi2,dxj)&
!      !$omp if(reval%nelements > reval%p_rperfconfig%NELEMMIN_OMP)
!      do j = 1, reval%nelements
!
!        ! Loop through all points on the current element
!        do i = 1, reval%npointsPerElement
!
!          ! Get the point coordinates
!          dxi1 = reval%p_DpointsRef(1,i,j)
!          dxi2 = reval%p_DpointsRef(2,i,j)
!
!          ! Multiplier for the inverse of the mapping
!          dxj = 1.0_DP / reval%p_Ddetj(i,j)
!
!          ! Evaluate basis functions
!          !
!          ! v1 = (0,-1) + (x,y)
!          ! v2 = sqrt(2)* (x,y)
!          ! v3 = (-1,0) + (x,y)
!          !
!          ! => Dv1 = Dv3 = (1 0) , Dv2 = ( sqrt(2)          )
!          !                (0 1)         (          sqrt(2) )
!          !
!          ! Dvi is multiplied to the mapping matrix which gives the
!          ! actual derivative:
!          !    (1 0) * (e f) = (e f) = 1/(ad-bc) (  d -b )
!          !    (0 1)   (g h)   (g h)             ( -c  a )
!          Dbas(1,DER_DERIV_X,i,j) =  dtwist1*reval%p_Djac(4,i,j)*dxj
!          Dbas(2,DER_DERIV_X,i,j) =  dtwist2*sqrt(2.0_DP)*reval%p_Djac(4,i,j)*dxj
!          Dbas(3,DER_DERIV_X,i,j) =  dtwist3*reval%p_Djac(4,i,j)*dxj
!
!          Dbas(4,DER_DERIV_X,i,j) = -dtwist1*reval%p_Djac(2,i,j)*dxj
!          Dbas(5,DER_DERIV_X,i,j) = -dtwist2*sqrt(2.0_DP)*reval%p_Djac(2,i,j)*dxj
!          Dbas(6,DER_DERIV_X,i,j) = -dtwist3*reval%p_Djac(2,i,j)*dxj
!
!          Dbas(1,DER_DERIV_Y,i,j) = -dtwist1*reval%p_Djac(3,i,j)*dxj
!          Dbas(2,DER_DERIV_Y,i,j) = -dtwist2*sqrt(2.0_DP)*reval%p_Djac(3,i,j)*dxj
!          Dbas(3,DER_DERIV_Y,i,j) = -dtwist3*reval%p_Djac(3,i,j)*dxj
!
!          Dbas(4,DER_DERIV_Y,i,j) =  dtwist1*reval%p_Djac(1,i,j)*dxj
!          Dbas(5,DER_DERIV_Y,i,j) =  dtwist2*sqrt(2.0_DP)*reval%p_Djac(1,i,j)*dxj
!          Dbas(6,DER_DERIV_Y,i,j) =  dtwist3*reval%p_Djac(1,i,j)*dxj
!
!        end do ! i
!
!      end do ! j
!      !$omp end parallel do

  end subroutine

  !************************************************************************
  ! Discontinuous P1 element
  !************************************************************************

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

 subroutine elem_eval_DCP1_2D (celement, reval, Bder, Dbas, rperfconfig)

!<description>
  ! This subroutine simultaneously calculates the values of the basic
  ! functions of the finite element at multiple given points on the
  ! reference element for multiple given elements.
!</description>

!<input>
  ! The element specifier.
  integer(I32), intent(in)                       :: celement

  ! t_evalElementSet-structure that contains cell-specific information and
  ! coordinates of the evaluation points. revalElementSet must be prepared
  ! for the evaluation.
  type(t_evalElementSet), intent(in)             :: reval

  ! Derivative quantifier array. array [1..DER_MAXNDER] of boolean.
  ! If bder(DER_xxxx)=true, the corresponding derivative (identified
  ! by DER_xxxx) is computed by the element (if supported). Otherwise,
  ! the element might skip the computation of that value type, i.e.
  ! the corresponding value 'Dvalue(DER_xxxx)' is undefined.
  logical, dimension(:), intent(in)              :: Bder

  ! Local performance configuration.
  type(t_perfconfig), intent(in)                 :: rperfconfig
!</input>

!<output>
  ! Value/derivatives of basis functions.
  ! array [1..EL_MAXNBAS,1..DER_MAXNDER,1..npointsPerElement,nelements] of double
  ! Bder(DER_FUNC)=true  => Dbas(i,DER_FUNC,j) defines the value of the i-th
  !   basis function of the finite element in the point Dcoords(j) on the
  !   reference element,
  !   Dvalue(i,DER_DERIV_X) the value of the x-derivative of the i-th
  !   basis function,...
  ! Bder(DER_xxxx)=false => Dbas(i,DER_xxxx,.) is undefined.
  !
  ! Due to the fact that this is a vector valued basis function, the
  ! meaning of Dbas is extended. There is
  !  Dbas(i        ,:,:,:) = values of the first basis function
  !  Dbas(i+ndofloc,:,:,:) = values of the 2nd basis function,
  ! with ndofloc the number of local DOFs per element.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

!</subroutine>

    real(DP), dimension(reval%npointsPerElement) :: dxj !auxiliary variable

    integer :: i   ! point counter
    integer :: j   ! element counter

    !if function values are desired
    if (Bder(DER_FUNC)) then

      !$omp parallel do default(shared) private(i) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements

        ! There are three basis functions on the reference element:
        !   phi_1 = 1
        !   phi_2 = xi   = lambda_2 (in barycentric coordinates)
        !   phi_3 = eta  = lambda_3 (in barycentric coordinates)

        do i=1,reval%npointsPerElement
          Dbas(1,DER_FUNC,i,j) = 1.0_DP
          Dbas(2,DER_FUNC,i,j) = reval%p_DpointsRef(2,i,j)
          Dbas(3,DER_FUNC,i,j) = reval%p_DpointsRef(3,i,j)
        end do

      end do
      !$omp end parallel do

    end if

    !if x-or y-derivatives are desired
    if ((Bder(DER_DERIV_X)) .or. (Bder(DER_DERIV_Y))) then

      !$omp parallel do default(shared) private(i,Dxj) &
      !$omp if(reval%nelements > rperfconfig%NELEMMIN_OMP)
      do j=1,reval%nelements
        Dxj(:) = 1E0_DP / reval%p_Ddetj(1:reval%npointsPerElement,j)

        !x-derivatives on current element
        do i=1,reval%npointsPerElement
          Dbas(1,DER_DERIV_X,i,j) = 0.0_DP
          Dbas(2,DER_DERIV_X,i,j) =  reval%p_Djac(4,i,j)*Dxj(i)
          Dbas(3,DER_DERIV_X,i,j) = -reval%p_Djac(2,i,j)*Dxj(i)

          !y-derivatives on current element
          Dbas(1,DER_DERIV_Y,i,j) = 0.0_DP
          Dbas(2,DER_DERIV_Y,i,j) = -reval%p_Djac(3,i,j)*Dxj(i)
          Dbas(3,DER_DERIV_Y,i,j) =  reval%p_Djac(1,i,j)*Dxj(i)
        end do

      end do
      !$omp end parallel do

    end if

  end subroutine

end module


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!> @brief cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in J/kg/K)
!> @param[in] i cell index, direction I0
!> @param[in] j cell index, direction J0
!> @param[in] k cell index, direction K0
!> @param[in] ismpl local sample index
!> @return cpf  [J/kg/K]
!> @details
!> cpf(i,j,k,ismpl) calculates the isobaric heat capacity in (in
!> J/kg/K)\n of pure water, given temperature (t, in C), and
!> pressure (p,in Pa)\n at node(i,j,k).\n \n
!>
!> method: c_p = d/dT E, E= fluid enthalpy.\n \n
!>
!>  Main source Zyvoloski1997: \n
!>
!> Zyvoloski, G.A., Robinson, B.A., Dash, Z.V., & Trease, L.L. Summary
!> of the models and methods for the FEHM application - a
!> finite-element heat- and mass-transfer code. United
!> States. doi:10.2172/565545. \n \n
!>
!> Alternative source (same text, more modern, without doi): \n
!> https://fehm.lanl.gov/orgs/ees/fehm/pdfs/fehm_mms.pdf \n \n
!>
!> The table of coefficients from Zyvoloski1997 describes the physical
!> values found in Haar1984: \n
!>
!> Lester Haar, John Gallagher, George Kell, NBS/NRC Steam Tables:
!> Thermodynamic and Transport Properties and Computer Programs for
!> Vapor and Liquid States of Water in SI Units, Hemisphere Publishing
!> Corporation, Washington, 1984. \n \n
!>
!> range of validity:\n
!> pressures      0.001 - 110 MPa,\n
!> temperature   15 - 350 degC\n
      double precision function cpf(i,j,k,ismpl)
        use arrays, only: pres, temp
        use mod_flow, only: pa_conv1

        implicit none

        ! Location indices
        integer, intent (in) :: i
        integer, intent (in) :: j
        integer, intent (in) :: k

        ! Sample index
        integer :: ismpl

        ! Temperature (degC)
        double precision :: tlocal

        ! Pressure (MPa)
        double precision :: plocal

        ! Enthalpy (J/kg)
        double precision :: enth

        ! Derivative of enthalpy wrt T (J/kg/K)
        double precision :: denthdt

        ! Monomials of temperature and pressure
        double precision :: t, t2, t3
        double precision :: p, p2, p3, p4
        double precision :: tp, t2p, tp2

        ! Coefficients of numerator of rational function approximation
        double precision, parameter :: Y0 = 0.25623465D-3
        double precision, parameter :: Y1 = 0.10184405D-2
        double precision, parameter :: Y2 = 0.22554970D-4
        double precision, parameter :: Y3 = 0.34836663D-7
        double precision, parameter :: Y4 = 0.41769866D-2
        double precision, parameter :: Y5 = -0.21244879D-4
        double precision, parameter :: Y6 = 0.25493516D-7
        double precision, parameter :: Y7 = 0.89557885D-4
        double precision, parameter :: Y8 = 0.10855046D-6
        double precision, parameter :: Y9 = -0.21720560D-6

        ! Coefficients of denominator of rational function approximation
        double precision, parameter :: Z0 = 0.10000000D+1
        double precision, parameter :: Z1 = 0.23513278D-1
        double precision, parameter :: Z2 = 0.48716386D-4
        double precision, parameter :: Z3 = -0.19935046D-8
        double precision, parameter :: Z4 = -0.50770309D-2
        double precision, parameter :: Z5 = 0.57780287D-5
        double precision, parameter :: Z6 = 0.90972916D-9
        double precision, parameter :: Z7 = -0.58981537D-4
        double precision, parameter :: Z8 = -0.12990752D-7
        double precision, parameter :: Z9 = 0.45872518D-8

        ! Numerator and denominator of rational function approximation
        double precision :: ta, tb

        ! Derivative of numerator wrt T
        double precision :: da

        ! Derivative of denominator wrt T
        double precision :: db

        ! Denominator squared
        double precision :: b2

        ! Local Pressure in MPa
        plocal = pres(i,j,k,ismpl)*pa_conv1

        ! Local Temperature in degC
        tlocal = temp(i,j,k,ismpl)

        ! Temperature out of bounds
        if (tlocal > 360.0d0) then
          write (*,*) "[E1]: Error: Temperature (",&
              tlocal,") out of bounds (> 360 degC) at ", i,j,k
          stop
        end if
        if (tlocal < 0.0d0) then
          ! Relax table boundary of 15degC to error boundary 0degC
          write (*,*) "[E2]: Error: Temperature (",&
              tlocal,") out of bounds (< 0 degC) at ", i,j,k
          stop
        end if

        ! Pressure out of bounds
        if (plocal > 110.0d0) then
          write (*,*) "[E3]: Error: Pressure (",&
              plocal,") out of bounds (> 110 MPa) at ", i,j,k
          stop
        end if
        if (plocal < 0.001d0) then
          write (*,*) "[E4]: Error: Pressure (",&
              plocal,") out of bounds (< 0.001 MPa) at ", i,j,k
          stop
        end if

        ! Compute monomials in pressure and temperature
        p = plocal
        t = tlocal
        p2 = p*p
        p3 = p2*p
        p4 = p3*p
        t2 = t*t
        t3 = t2*t
        tp = p*t
        tp2 = t*p2
        t2p = t2*p

        ! Numerator of rational function approximation
        ta = Y0 + Y1*p + Y2*p2 + Y3*p3 + Y4*t + &
            Y5*t2 + Y6*t3 + Y7*tp + Y8*tp2 + Y9*t2p

        ! Denominator of rational function approximation
        tb = Z0 + Z1*p + Z2*p2 + Z3*p3 + Z4*t + &
            Z5*t2 + Z6*t3 + Z7*tp + Z8*tp2 + Z9*t2p

        ! Enthalpy
        enth = ta/tb

        ! Derivative of numerator
        da = Y4 + 2.0d0*Y5*t + 3.0d0*Y6*t2 + Y7*p + &
            Y8*p2 + 2.0d0*Y9*tp

        ! Derivative of denominator
        db = Z4 + 2.0d0*Z5*t + 3.0d0*Z6*t2 + Z7*p + &
            Z8*p2 + 2.0d0*Z9*tp

        ! Denominator squared
        b2 = tb*tb

        ! Derivative, quotient rule
        denthdt = da/tb - ta*db/b2

        ! Isobaric heat capacity (J/kg/K)
        cpf = denthdt*1.0d6

        return

      end function cpf


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_od_chirot
      CONTAINS
      SUBROUTINE od_chirot(
     >                  odi,ods,bmat,k,
     <                  kr,phas)

****************************************************************
*     perform symmetry operations of the cylindrical group
*     of symmetries on the reciprocal vector k, given in internal
*     coordinates
*                                       Y.Mokrousov
****************************************************************

      USE m_types, ONLY : od_inp, od_sym

      IMPLICIT NONE
!     ..
      TYPE (od_inp), INTENT (IN) :: odi
      TYPE (od_sym), INTENT (IN) :: ods
      INTEGER, INTENT (IN)  :: k(3)
      REAL,    INTENT (IN)  :: bmat(3,3)
      REAL,    INTENT (OUT) :: kr(3,ods%nop)
      COMPLEX, INTENT (OUT) :: phas(ods%nop)
!     ..
!     .. Local Scalars ..
      INTEGER n,inv
!     ..
!     ..

      DO n = 1,ods%nop
         kr(1,n) = k(1)*ods%mrot(1,1,n) +
     +             k(2)*ods%mrot(2,1,n) +
     +             k(3)*ods%mrot(3,1,n)
         kr(2,n) = k(1)*ods%mrot(1,2,n) +
     +             k(2)*ods%mrot(2,2,n) +
     +             k(3)*ods%mrot(3,2,n)
         kr(3,n) = k(1)*ods%mrot(1,3,n) +
     +             k(2)*ods%mrot(2,3,n) +
     +             k(3)*ods%mrot(3,3,n)
      ENDDO

      IF (odi%chi.NE.1) THEN
         DO n = 1,ods%nop
            inv = ods%invtab(n)
            phas(n) = exp(cmplx(0.,bmat(3,3)*kr(3,n)*ods%tau(3,inv)))
         END DO
      ELSE
         DO n = 1,ods%nop
            phas(n) = cmplx(1.,0.)
         END DO
      END IF

      RETURN
      END SUBROUTINE od_chirot
      END MODULE m_od_chirot


      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44

c EXAMPLE # 1
c Purpose: To test the Metropolis algorithm in three dimensions.
c The example below is to fit a circle to 6 data points, two
c of which do not lie on the circle.
c Notice the cost function rewards for including lots of data
c points and is allowed to reject points which fall far from the
c fitted function.
      real range(3),answer(3),array(500),array2(500),i2,i3,i4,i5,d(500)
      real sum,sres,sumres,serror,terror
      real*8 PI
      data PI/3.141592653589793D0/
      integer i1,npts,nnd
      character*80 msg
      character*255 polartbl
      external cost
      numten=1000
      limit=5000
      iprint=0
      narg=3
      norm=330

c (1)=a (2)=b (3)=theta

      call xvparm('POLARTBL', polartbl, icnt, idef, 1)
c     xvfilename generated error in VMS so took it out

      do 60 ii=1,5
      npts=0
      sum=0.
      sumres=0.
      sres=0.
      serror=0.
      nnd=0.
      answer(1)=4095.
      answer(2)=0.
      answer(3)=90.
      data range/1000.,1000.,90./

c      open(11,name=polartbl,type='old',err=999)
      open(11,file=polartbl,status='old',err=999)
      read(11,1)
      read(11,1)
1     format(a)
      do 10 I=1,500
	read(11,2,end=50,err=999)I1,I2,I3,I4,I5
2       format(I6,1X,E18.12,1X,E18.12,1X,E18.12,1X,E18.12)
        npts=npts+1
        array(I)=I4
        array2(I)=I2
        if (I4 .lt. answer(1)) then
		answer(1)=I4
        endif
	if (I4 .gt. answer(2)) then
		answer(2)=I4
        endif
10    continue
	answer(2)=answer(2)-answer(1)
50    close(11,err=999)

      call metropolis(cost,narg,array,array2,range,numten,answer,
     +                 limit,norm,npts,iprint,ind)
      if(ind.eq.0)then
        write(msg,*)'guess number:',(ii)
        call xvmessage(msg,' ')
         write(msg,*)'answer=',(answer(j),j=1,narg)
         call xvmessage(msg,' ')

        do j=1,npts

	 d(j)=abs(answer(1)+answer(2)*
     &		(cos((array2(j)-answer(3))*PI/180.)**2)  -array(j))
         sres=sres+abs(d(j))
	 sumres=sumres+d(j)*d(j)

	enddo

        mean=sres/npts
        sigma=sqrt(sumres/npts - mean*mean)
        write(msg,*)'sigma=',(sigma)
        call xvmessage(msg,' ')
	do j=1,npts
	   if (d(j) .lt. sigma) then
		nnd=nnd+1
		serror=serror+d(j)/array(j)
	   endif
	enddo
	terror=serror/nnd
        write(msg,*)'error=',(terror)
        call xvmessage(msg,' ')

      else
         call xvmessage('no solution',' ')
      endif
60    continue
      return

999   call xvmessage('Error reading input file',' ')
      call abend
      end

      subroutine  cost(x,array,array2,n,error,ind)
c Returns the cost function resulting from guessing x (answer).
c This could be any function or logical operation.

c X     is the solution vector.
c ARRAY is an array of N data points if needed.
c ARRAY2 is another array of N elements if needed.
c N      is the number of elements/data points in ARRAY & ARRAY2.
c ERROR is the returned cost.
c IND   is 0 for normal return, 1 for abnormal return.
c        If METROPOLIS senses an indicator of 1 it will generate another
c        guess somewhere else & try again.

c (1)=radius (2)=x_center (3)=y_center
      real array(n),array2(n),x(4),dr(500)

      ind=1
      if(x(1).lt.0.)return
      if(x(1).gt.4095.)return
      if(x(2).gt.4095.)return
      if(x(3).gt.180.)return
      if(x(2).lt.0.)return
      if(x(3).lt.0.)return
      sumdr=0.
      sum=0.
      range=1000
      m=0
      do j=1,n
        dr(j)=abs(x(1)+x(2)*(cos((array2(j)-x(3))*PI/180.)**2)
     &					- array(j))
        sum=sum+dr(j)
        if(dr(j).lt.range)then
           m=m+1
           sumdr=sumdr+dr(j)
        endif
      enddo
      if(m.eq.0)then
         error=sum/n + range/n
      else
         error=sumdr/m + range/m
      endif
      ind=0
      return
      end


C
C**********************  weightneighnode *******************************
C
C  calculate for each node the value
C  1/r_i where r_i is the distance of the node to the centroid
C  of element T_i, where T_i is a neighboring element of the node
C  this distancs will be used as  a weighting
C
C***********************************************************************
C
      SUBROUTINE weightneighnode(N,NT,x,y,z,xbar,ybar,zbar,TETRA,
     1                          disnod,weightnod)
C
      IMPLICIT  NONE
      INTEGER   i,j,k,elle,inod
      INTEGER   N,NT
      INTEGER   TETRA(5,*),cont(N)
      real*8    x(*),y(*),z(*),xbar(*),ybar(*),zbar(*)
      real*8    disnod(24,*),weightnod(*),aux
C
      do i=1,n
        cont(i)=1
        weightnod(i)=0.d0
        do j=1,24
         disnod(j,i)=0.d0
        end do
      end do
c     write(118,*) 'nodo', 'tetraedro'
      DO k=1,NT
         DO elle=1,4
           inod=TETRA(elle,K)
           aux=dsqrt((x(inod)-xbar(k))**2+(y(inod)-ybar(k))**2 +
     1            (z(inod)-zbar(k))**2 )
           aux=1.0d0/aux
           disnod(cont(inod),inod)=aux
           cont(inod)=cont(inod)+1
           weightnod(inod)=weightnod(inod)+aux
         END DO
      END DO

      RETURN
      END


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE JAC3D ( SSI, SSJ, SSK, DPSHG, WRT_BUG_THIS_TIME, JAC, JACI, DETJ )

! Computes Jacobian for 3D elements.

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_BUG, WRT_ERR, WRT_LOG, BUG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  JACOBIAN_BEGEND
      USE CONSTANTS_1, ONLY           :  ZERO
      USE PARAMS, ONLY                :  EPSIL
      USE MODEL_STUF, ONLY            :  EID, ELGP, NUM_EMG_FATAL_ERRS, TYPE, XEL
      USE DEBUG_PARAMETERS, ONLY      :  DEBUG

      USE JAC3D_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'JAC3D'
      CHARACTER( 1*BYTE), INTENT(IN)  :: WRT_BUG_THIS_TIME ! If 'Y' then write to BUG file if WRT_BUG array says to

      INTEGER(LONG)                   :: I,J               ! DO loop indices
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = JACOBIAN_BEGEND

      REAL(DOUBLE) , INTENT(IN)       :: SSI               ! A Gauss point coord.
      REAL(DOUBLE) , INTENT(IN)       :: SSJ               ! A Gauss point coord.
      REAL(DOUBLE) , INTENT(IN)       :: SSK               ! A Gauss point coord.
      REAL(DOUBLE) , INTENT(IN)       :: DPSHG(3,ELGP)     ! 3 x ELGP array of derivatives of element shape functions evaluated at
!                                                            Gauss abscissa coords
      REAL(DOUBLE) , INTENT(OUT)      :: DETJ              ! Determinant of JAC
      REAL(DOUBLE) , INTENT(OUT)      :: JAC(3,3)          ! 3 x 3 Jacobian matrix
      REAL(DOUBLE) , INTENT(OUT)      :: JACI(3,3)         ! 3 x 3 inverse of JAC
      REAL(DOUBLE)                    :: B(3,3)            ! Array used in calculating inverse of JAC
      REAL(DOUBLE)                    :: EPS1              ! A small number to compare real zero
      REAL(DOUBLE)                    :: XL(ELGP,3)        ! Array of local element coords for the element (note: cannot use XEL
!                                                            directly since it is dimensioned MELGP x 3, not ELGP x 3)

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC, WRT_BUG_THIS_TIME, WRT_BUG(7), WRT_BUG(8), WRT_BUG(9)
 9001    FORMAT(1X,A,' BEGN ',F10.3, 3X, A1, 3(I3))
      ENDIF
! **********************************************************************************************************************************
! Initialize outputs

      DETJ = ZERO

      DO I=1,3
         DO J=1,3
            JAC(I,J)  = ZERO
            JACI(I,J) = ZERO
         ENDDO
      ENDDO

      EPS1 = EPSIL(1)

      DO I=1,ELGP                                          ! Use XL array since XEL is dimensioned MELGP x 3, not ELGP x 3
         DO J=1,3
            XL(I,J) = XEL(I,J)
         ENDDO
      ENDDO

      CALL MATMULT_FFF ( DPSHG, XL, 3, ELGP, 3, JAC )

      B(1,1) = JAC(2,2)*JAC(3,3) - JAC(2,3)*JAC(3,2)
      B(1,2) = JAC(2,1)*JAC(3,3) - JAC(2,3)*JAC(3,1)
      B(1,3) = JAC(2,1)*JAC(3,2) - JAC(2,2)*JAC(3,1)

      B(2,1) = JAC(1,2)*JAC(3,3) - JAC(1,3)*JAC(3,2)
      B(2,2) = JAC(1,1)*JAC(3,3) - JAC(1,3)*JAC(3,1)
      B(2,3) = JAC(1,1)*JAC(3,2) - JAC(1,2)*JAC(3,1)

      B(3,1) = JAC(1,2)*JAC(2,3) - JAC(1,3)*JAC(2,2)
      B(3,2) = JAC(1,1)*JAC(2,3) - JAC(1,3)*JAC(2,1)
      B(3,3) = JAC(1,1)*JAC(2,2) - JAC(1,2)*JAC(2,1)

      DETJ = JAC(1,1)*(JAC(2,2)*JAC(3,3)  - JAC(2,3)*JAC(3,2))                                                                     &
           - JAC(1,2)*(JAC(2,1)*JAC(3,3)  - JAC(2,3)*JAC(3,1))                                                                     &
           + JAC(1,3)*(JAC(2,1)*JAC(3,2)  - JAC(2,2)*JAC(3,1))

      IF ((WRT_BUG_THIS_TIME == 'Y') .AND. (WRT_BUG(7) > 0)) THEN
         WRITE(BUG,1101) SSI, SSJ, SSK
         WRITE(BUG,1102)
         DO I=1,3
            WRITE(BUG,1103) (JAC(I,J),J=1,3)
         ENDDO
         WRITE(BUG,*)
         WRITE(BUG,*)
         WRITE(BUG,1104) DETJ
         WRITE(BUG,*)
         WRITE(BUG,*)
      ENDIF

! If DETJ is not zero, continue. Else, write error and return:

      IF (DETJ > EPS1) THEN

         JACI(1,1) =  B(1,1)/DETJ
         JACI(1,2) = -B(2,1)/DETJ
         JACI(1,3) =  B(3,1)/DETJ

         JACI(2,1) = -B(1,2)/DETJ
         JACI(2,2) =  B(2,2)/DETJ
         JACI(2,3) = -B(3,2)/DETJ

         JACI(3,1) =  B(1,3)/DETJ
         JACI(3,2) = -B(2,3)/DETJ
         JACI(3,3) =  B(3,3)/DETJ

         IF ((WRT_BUG_THIS_TIME == 'Y') .AND. (WRT_BUG(7) > 0)) THEN
            WRITE(BUG,1105)
            DO I=1,3
               WRITE(BUG,1103) (JACI(I,J),J=1,3)
            ENDDO
            WRITE(BUG,*)
            WRITE(BUG,*)
            WRITE(BUG,1106)
         ENDIF

      ELSE

         WRITE(ERR,1928) EID,TYPE,DETJ
         WRITE(F06,1928) EID,TYPE,DETJ
         NUM_EMG_FATAL_ERRS = NUM_EMG_FATAL_ERRS + 1
         FATAL_ERR = FATAL_ERR + 1
         RETURN

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
 1928 FORMAT(' *ERROR  1928: ELEMENT ',I8,', TYPE ',A,', HAS JACOBIAN LESS THAN OR EQUAL TO ZERO ( = ',1ES8.1,'). BAD GEOMETRY')

 1101 format(39x,'Outputs from subroutine JAC3D for Gauss point location:',/,39x,'------------------------------------------------'&
                 '-------',/,41x,'SSI = ', F9.6, '   ','SSJ = ', F9.6, '   ', 'SSK = ', F9.6,/)

 1102 FORMAT(58X,'Jacobian matrix:')

 1103 FORMAT(40X,3(1ES16.6))

 1104 FORMAT(53X,'Determinant of the Jacobian:',/,58X,1ES15.6)

 1105 FORMAT(51X,'Inverse of the Jacobian matrix:')

 1106 FORMAT(' ::::::::::::::::::::::::::::::END DEBUG( 6) OUTPUT FROM SHAPE FUNCTION AND JACOBIAN MATRIX SUBROUTINES:::::::::::', &
             '::::::::::::::::::',/,                                                                                &
             ' __________________________________________________________________________________________________________________',&
             '_________________',/)

11228 format(20(1es14.6))

11229 format(3(1es14.6))

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

      END SUBROUTINE JAC3D


module precision

! Real kinds

integer, parameter :: kr4 = selected_real_kind(6,37)       ! single precision real
integer, parameter :: kr8 = selected_real_kind(15,307)     ! double precision real

! Integer kinds

integer, parameter :: ki4 = selected_int_kind(9)           ! single precision integer
integer, parameter :: ki8 = selected_int_kind(18)          ! double precision integer

!Complex kinds

integer, parameter :: kc4 = kr4                            ! single precision complex
integer, parameter :: kc8 = kr8                            ! double precision complex

end module precision


!@(#) Shows various combinations of viewing and projection transformations
!
program fviews
!(LICENSE:PD)

   use M_draw

   integer,parameter :: BLACK=0, GREEN=2, RED=1, MAGENTA=5, YELLOW=3
   character(len=50) :: device

   print*,'Enter output device:'
   read(*,'(a)') device

   call vinit(device)

   call color(BLACK)
   call clear

!
! we want to draw just within the boundaries of the screen
!
   call viewport(-0.9, 0.9, -0.9, 0.9)

!
! set the world size
!
   call ortho2(-5.0, 5.0, -5.0, 5.0)

!
! draw a boundary frame
!
   call color(RED)
   call rect(-5.0, -5.0, 5.0, 5.0)

!
! set up a perspective projection with a field of view of
! 40.0 degrees, aspect ratio of 1.0, near clipping plane 0.1,
! and the far clipping plane at 1000.0.
!
   call perspective(40.0, 1.0, 0.1, 1000.0)
!
! we want the drawing to be done with our eye point at (5.0, 8.0, 5.0)
! looking towards (0.0, 0.0, 0.0). The last parameter gives a twist
! in degrees around the line of sight, in this case zero.
!
   call lookat(5.0, 8.0, 5.0, 0.0, 0.0, 0.0, 0.0)

   call drawtetra()

!
! set the text size
!
   call textsize(0.6, 0.9)

   call move2(-4.5, -4.5)
   call drawstr('perspective/lookat')

   idum=getkey()

!
! window can also be used to give a perspective projection. Its
! arguments are 6 clipping planes, left, right, bottom, top, near,
! and far.
!
   call window(-5.0, 5.0, -5.0, 5.0, -5.0, 5.0)
!
! as window replaces the current transformation matrix we must
! specify our viewpoint again.
!
   call lookat(5.0, 8.0, 5.0, 0.0, 0.0, 0.0, 0.0)

   call color(BLACK)
   call clear

   call color(GREEN)
   call rect(-5.0, -5.0, 5.0, 5.0)

   call drawtetra

   call textsize(0.6, 0.9)
   call move2(-4.5,-4.5)
   call drawstr('window/lookat')

   idum=getkey()

!
! set up our original perspective projection again.
!
   call perspective(40.0, 1.0, 0.1, 1000.0)
!
! polarview also specifies our viewpoint, but, unlike lookat, in polar
! coordinates. Its arguments are the distance from the world origin, an
! azimuthal angle in the x-y plane measured from the y axis, an
! incidence angle in the y-z plane measured from the z axis, and a
! twist around the line of sight.
!
   call polarview(15.0, 30.0, 30.0, 30.0)

   call color(BLACK)
   call clear

   call color(MAGENTA)
   call rect(-5.0, -5.0, 5.0, 5.0)

   call drawtetra

   call move2(-4.5,-4.5)
   call textsize(0.6, 0.9)
   call drawstr('perspective/polarview')

   idum=getkey()

!
! once more with window for comparison
!
   call window(-4.0, 4.0, -4.0, 4.0, -4.0, 4.0)
   call polarview(6.0, 20.0, -30.0, 70.0)

   call color(BLACK)
   call clear

   call color(YELLOW)
   call rect(-5.0, -5.0, 5.0, 5.0)

   call drawtetra

   call move2(-4.5,-4.5)
   call textsize(0.6, 0.9)
   call drawstr('window/polarview')

   idum=getkey()

   call vexit

end program fviews

!
! drawtetra
!
! generate a tetrahedron as a series of move draws
!
!
subroutine drawtetra

   use M_draw

   integer,parameter :: WHITE = 7

   call move(-0.5,  0.866, -0.5)
   call draw(-0.5, -0.866, -0.5)
   call draw( 1.0,  0.0,   -0.5)
   call draw(-0.5,  0.866, -0.5)
   call draw( 0.0,  0.0,    1.5)
   call draw(-0.5, -0.866, -0.5)
   call move( 1.0,  0.0,   -0.5)
   call draw( 0.0,  0.0,    1.5)

!
!    Label the vertices.
!
   call color(WHITE)
   call textsize(0.3, 0.5)
   call move(-0.5,  0.866, -0.5)
   call drawchar('a')
   call move(-0.5, -0.866, -0.5)
   call drawchar('b')
   call move( 1.0,  0.0,   -0.5)
   call drawchar('c')
   call move( 0.0,  0.0,    1.5)
   call drawchar('d')

end subroutine drawtetra


! { dg-do run }
! { dg-options "-fbounds-check" }
! { dg-shouldfail "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 1: is 2, should be 3" }
program main
  real, dimension(3,2) :: a
  real, dimension(2,3) :: b
  real, dimension(:,:), allocatable :: ret
  allocate (ret(3,3))
  a = 1.0
  b = 2.3
  ret = matmul(a,b)  ! This is OK
  deallocate(ret)
  allocate(ret(2,3))
  ret = matmul(a,b)  ! This should throw an error.
end program main
! { dg-output "Fortran runtime error: Incorrect extent in return array in MATMUL intrinsic for dimension 1: is 2, should be 3" }


      program result
      implicit none
      integer,parameter::in = 17, in2 = 18
      integer :: i, n_trial
      real*8,allocatable::energ(:),time(:)
      real*8 sum, mean

      i = 1

      allocate(energ(10000))
      allocate(time(10000))

      open(in, file = "data.dat", status = 'unknown')
      open(in2, file = "time.dat", status = 'unknown')

      do
        read(in,*,end=100) energ(i)
        i = i + 1
      enddo
  100 close(in)

      n_trial = i - 1
      print *, "trial", n_trial

!     calculate mean of energy
      sum = 0

      do i = 1, n_trial
        sum = sum + energ(i)
      enddo

      mean = sum / n_trial

      print *, "mean_energ", mean

!     calculate standard deviation of energy
      sum = 0

      do i = 1, n_trial
        sum = sum + (energ(i) - mean)**2
      enddo
      print *, "std_energ",sqrt(sum / (n_trial-1))

      deallocate(energ)

      i = 1
      do
        read(in2,*,end=200) time(i)
        i = i + 1
      enddo
  200 close(in2)

      n_trial = i - 1
      print *, "trial", n_trial

!     calculate mean of time
      sum = 0

      do i = 1, n_trial
        sum = sum + time(i)
      enddo

      mean = sum / n_trial

      print *, "mean_time", mean

!     calculate standard deviation of time
      sum = 0

      do i = 1, n_trial
        sum = sum + (time(i) - mean)**2
      enddo
      print *, "std_time", sqrt(sum / (n_trial-1))

      deallocate(time)

      end program result


module points

    type point
        real :: x, y
    end type point

    interface
       module function point_dist(a, b) result(distance)
         type(point), intent(in) :: a, b
         real :: distance
       end function point_dist
    end interface

end module points


! { dg-do run }
!*==CENTCM.spg  processed by SPAG 6.55Dc at 09:26 on 23 Sep 2005
      SUBROUTINE CENTCM
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (NM=16384)
      PARAMETER (NG=100)
      PARAMETER (NH=100)
      PARAMETER (MU=20)
      PARAMETER (NL=1)
      PARAMETER (LL=10*NM)
      PARAMETER (KP=2001,KR=2001,KG=2001)
      COMMON /LCS   / X0(3,-2:NM) , X(3,-2:NM,5) , XIN(3,-2:NM)
      COMMON /MOLEC / LPBc(3) , MOLsp , MOLsa , NBX , NBY , NBZ , NPLa ,&
     &                LPBcsm
      cm1 = 0.D0
      cm2 = 0.D0
      cm3 = 0.D0
      DO i = 1 , MOLsa
         cm1 = cm1 + X0(1,i)
         cm2 = cm2 + X0(2,i)
         cm3 = cm3 + X0(3,i)
      ENDDO
      cm1 = cm1/MOLsa
      cm2 = cm2/MOLsa
      cm3 = cm3/MOLsa
      IF ( (cm1.EQ.0.D0) .AND. (cm2.EQ.0.D0) .AND. (cm3.EQ.0.D0) )      &
     &     RETURN
      DO i = 1 , MOLsa
        X0(1,i) = X0(1,i) - cm1
        X0(2,i) = X0(2,i) - cm2
        X0(3,i) = X0(3,i) - cm3
        XIN(1,i) = XIN(1,i) - cm1
        XIN(2,i) = XIN(2,i) - cm2
        XIN(3,i) = XIN(3,i) - cm3
      ENDDO
      CONTINUE
      END
      PROGRAM test
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER (NM=16384)
      PARAMETER (NG=100)
      PARAMETER (NH=100)
      PARAMETER (MU=20)
      PARAMETER (NL=1)
      PARAMETER (LL=10*NM)
      PARAMETER (KP=2001,KR=2001,KG=2001)
      COMMON /LCS   / X0(3,-2:NM) , X(3,-2:NM,5) , XIN(3,-2:NM)
      COMMON /MOLEC / LPBc(3) , MOLsp , MOLsa , NBX , NBY , NBZ , NPLa ,&
     &                LPBcsm
      MOLsa = 10
      X0 = 1.
      CALL CENTCM
      END


    program demo_transfer
    use,intrinsic :: iso_fortran_env, only : int32, real32
    integer(kind=int32) :: i = 2143289344
    real(kind=real32)   :: x
    character(len=10)   :: string
    character(len=1)    :: chars(10)
       x=transfer(i, 1.0)    ! prints "nan" on i686
       ! the bit patterns are the same
       write(*,'(b0,1x,g0)')x,x ! create a NaN
       write(*,'(b0,1x,g0)')i,i

       ! a string to an array of characters
       string='abcdefghij'
       chars=transfer(string,chars)
       write(*,'(*("[",a,"]":,1x))')string
       write(*,'(*("[",a,"]":,1x))')chars
    end program demo_transfer


! Recursive Fortran 95 quicksort routine
! sorts real (kind=8) numbers into ascending numerical order
! Author: Juli Rew, SCD Consulting (juliana@ucar.edu), 9/03
! Based on algorithm from Cormen et al., Introduction to Algorithms,
! 1997 printing
! Made F conformant by Walt Brainerd
module qsort_c_module
  implicit none
  public :: QsortC
  private :: Partition

contains

  recursive subroutine QsortC(A)
    real (kind=8), intent(in out), dimension(:) :: A
    integer :: iq
    if(size(A) > 1) then
      call Partition(A, iq)
      call QsortC(A(:iq-1))
      call QsortC(A(iq:))
    endif
  end subroutine QsortC

  subroutine Partition(A, marker)
    real (kind=8), intent(in out), dimension(:) :: A
    integer, intent(out) :: marker
    integer :: i, j
    real (kind=8) :: temp
    real (kind=8) :: x      ! pivot point
    x = A(1)
    i= 0
    j= size(A) + 1
    do
      j = j-1
      do
        if (A(j) <= x) exit
        j = j-1
      end do
      i = i+1
      do
        if (A(i) >= x) exit
        i = i+1
      end do
      if (i < j) then
        ! exchange A(i) and A(j)
        temp = A(i)
        A(i) = A(j)
        A(j) = temp
      elseif (i == j) then
        marker = i+1
        return
      else
        marker = i
        return
      endif
    end do
  end subroutine Partition

end module qsort_c_module

!~ program www_fcode_cn
  !~ use qsort_c_module
  !~ implicit none
  !~ integer, parameter :: r = 10
  !~ real (kind=8), dimension(1:r) :: myarray = (/0, 50, 20, 25, 90, 10, 5, 1, 99, 75/)
  !~ print *, "YuanSuZU:", myarray
  !~ call QsortC(myarray)
  !~ print *, "PaiXuHou:", myarray
!~ end program www_fcode_cn


      subroutine time_delay (transflag, ith,cur_node,
     2     par1v, par2v, par3v, fm,
     2     ret_factor, rseed, tau_zero, concv, timev)
!***********************************************************************
! $Id: time_delay.f,v 1.1 2006/05/17 15:23:25 zvd Exp $
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!
! PURPOSE
!
! To calculate particle time delay using type curves.
! (such as Sudicky and Frind)
!
!**********************************************************************
!
! Initial implementation: 05-MAY-99, Programmer: Zora Dash
!     for FEHM Version 2.10 [10086-STN-2.10-00]
!
!**********************************************************************

      use comunits, only : error_unit_number
      use compfrac
      implicit none

      real*8  par1v, par2v, par3v, tau_zero, timev, concv, timedelay
      real*8 interp
      real*8 ret_factor
      real ran_sp
      integer fm
      integer rseed
      integer transflag
      real inverf, fact_term, concvr
      integer ith, cur_node
      integer ierr, iptty

      ierr = error_unit_number
      iptty = 6

      if(transflag.eq.1.or.transflag.eq.2) then

         timev = par2v*tau_zero
      else

! Generate random concentration value
         concv = ran_sp (rseed)

         if(par1v.lt.0.) then
c     Error function solution - infinite fracture spacing

            concvr = concv
            timedelay = ret_factor +
     2           par2v*tau_zero/(par1v**2*inverf(concvr)**2)
            timev = timedelay*tau_zero
         else
            if (.not. pfrac_read) then
               write (ierr, 10)
!               write (iout, 10)
               if (iptty .gt. 0) write (iptty, 10)
               stop
            else
! Find time delay
               timedelay = interp (ith, cur_node,
     2              par1v/par2v, par2v/par2v, par3v, fm, concv)
! Compute adjusted time
               timev = timedelay * par2v**2 +  tau_zero * ret_factor
            end if
         end if
      end if
 10   format ("Dispersion type curve data not input")
      end


!==========================================================================
elemental function gsw_dynamic_enthalpy (sa, ct, p)
!==========================================================================
!
!  Calculates dynamic enthalpy of seawater using the computationally-
!  efficient expression for specific volume in terms of SA, CT and p
!  (Roquet et al., 2014).  Dynamic enthalpy is defined as enthalpy minus
!  potential enthalpy (Young, 2010).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  dynamic_enthalpy  =  dynamic enthalpy                           [ J/kg ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : db2pa, gsw_sfac, offset

use gsw_mod_specvol_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p

real (r8) :: gsw_dynamic_enthalpy

real (r8) :: dynamic_enthalpy_part, xs, ys, z

xs = sqrt(gsw_sfac*sa + offset)
ys = ct*0.025_r8
z = p*1e-4_r8

dynamic_enthalpy_part =  z*(h001 + xs*(h101 + xs*(h201 + xs*(h301 + xs*(h401 &
    + xs*(h501 + h601*xs))))) + ys*(h011 + xs*(h111 + xs*(h211 + xs*(h311 &
    + xs*(h411 + h511*xs)))) + ys*(h021 + xs*(h121 + xs*(h221 + xs*(h321 &
    + h421*xs))) + ys*(h031 + xs*(h131 + xs*(h231 + h331*xs)) + ys*(h041 &
    + xs*(h141 + h241*xs) + ys*(h051 + h151*xs + h061*ys))))) + z*(h002 &
    + xs*(h102 + xs*(h202 + xs*(h302 + xs*(h402 + h502*xs)))) + ys*(h012 &
    + xs*(h112 + xs*(h212 + xs*(h312 + h412*xs))) + ys*(h022 + xs*(h122 &
    + xs*(h222 + h322*xs)) + ys*(h032 + xs*(h132 + h232*xs) + ys*(h042 &
    + h142*xs + h052*ys)))) + z*(h003 + xs*(h103 + xs*(h203 + xs*(h303 &
    + h403*xs))) + ys*(h013 + xs*(h113 + xs*(h213 + h313*xs)) + ys*(h023 &
    + xs*(h123 + h223*xs) + ys*(h033 + h133*xs + h043*ys))) + z*(h004 &
    + xs*(h104 + h204*xs) + ys*(h014 + h114*xs + h024*ys) + z*(h005 &
    + h105*xs + h015*ys + z*(h006 + h007*z))))))

gsw_dynamic_enthalpy = dynamic_enthalpy_part*db2pa*1e4_r8

return
end function

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