!##############################################################################
!# ****************************************************************************
!# <name> element_line1d </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains the implementations of the 1D line basis functions.
!#
!# </purpose>
!##############################################################################

module element_line1d

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

  implicit none

  private

  public :: elem_eval_P0_1D
  public :: elem_eval_P1_1D
  public :: elem_eval_P2_1D
  public :: elem_eval_S31_1D
  public :: elem_eval_PN_1D
  public :: elem_eval_DG_T0_1D
  public :: elem_eval_DG_T1_1D
  public :: elem_eval_DG_T2_1D

contains

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

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

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

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

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

  subroutine elem_eval_P0_1D (celement, reval, Bder, Dbas)

!<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
!</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.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

! </subroutine>

  ! Element Description
  ! -------------------
  ! The P0_1D element is specified by a single basis function per element.
  !
  ! The function value of the basis function is =1, the derivatives are all 0!

  ! Local variables
  integer :: i,j

    ! Calculate function values?
    if(Bder(DER_FUNC1D)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(i) &
      !$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

          ! Evaluate basis functions
          Dbas(1,DER_FUNC1D,i,j) = 1.0_DP

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

  end subroutine

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

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

  subroutine elem_eval_P1_1D (celement, reval, Bder, Dbas)

!<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
!</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.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

! </subroutine>

  ! Element Description
  ! -------------------
  ! The P1_1D element is specified by two polynomials per element.
  !
  ! The basis polynomials are constructed from the following set of monomials:
  !
  ! { 1, x }
  !
  ! The basis polynomials Pi are constructed such that they fulfill the
  ! following conditions:
  !
  ! For all i = 1,...,2:
  ! {
  !   For all j = 1,...,2:
  !   {
  !     Pi(vj) = kronecker(i,j)
  !   }
  ! }
  !
  ! With:
  ! vj being the j-th local corner vertice of the line
  !
  ! On the reference element, the above combination of monomial set and
  ! basis polynomial conditions leads to the following basis polynomials:
  !
  ! P1(x) = 1/2 * (1 - x)
  ! P2(x) = 1/2 * (1 + x)

  ! Local variables
  real(DP) :: ddet,dx
  integer :: i,j

    ! Calculate function values?
    if(Bder(DER_FUNC1D)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(i,dx) &
      !$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
          dx = reval%p_DpointsRef(1,i,j)

          ! Evaluate basis functions
          Dbas(1,DER_FUNC1D,i,j) = 0.5_DP*(1.0_DP-dx)
          Dbas(2,DER_FUNC1D,i,j) = 0.5_DP*(1.0_DP+dx)

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

    ! Calculate derivatives?
    if(Bder(DER_DERIV1D_X)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(i,ddet) &
      !$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 Jacobian determinant
          ddet = 1.0_DP / reval%p_Ddetj(i,j)

          ! X-derivatives on real element
          Dbas(1,DER_DERIV1D_X,i,j) = -0.5_DP*ddet
          Dbas(2,DER_DERIV1D_X,i,j) =  0.5_DP*ddet

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

  end subroutine

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

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

  subroutine elem_eval_P2_1D (celement, reval, Bder, Dbas)

!<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
!</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.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

! </subroutine>

  ! Element Description
  ! -------------------
  ! The P2_1D element is specified by three polynomials per element.
  !
  ! The basis polynomials are constructed from the following set of monomials:
  !
  ! { 1, x, x^2 }
  !
  ! The basis polynomials Pi are constructed such that they fulfill the
  ! following conditions:
  !
  ! For all i = 1,...,3:
  ! {
  !   For all j = 1,...,2:
  !   {
  !     Pi(vj) = kronecker(i,j)
  !   }
  !   Pi(x) = kronecker(i,3)
  ! }
  !
  ! With:
  ! vj being the j-th local corner vertice of the line
  ! x being the midpoint of the line
  !
  ! On the reference element, the above combination of monomial set and
  ! basis polynomial conditions leads to the following basis polynomials:
  !
  ! P1(x) = 1/2 * x * (x - 1)
  ! P2(x) = 1/2 * x * (x + 1)
  ! P3(x) = 1 - x^2

  ! Local variables
  real(DP) :: ddet,dx
  integer :: i,j

    ! Calculate function values?
    if(Bder(DER_FUNC1D)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(i,dx) &
      !$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
          dx = reval%p_DpointsRef(1,i,j)

          ! Evaluate basis functions
          Dbas(1,DER_FUNC1D,i,j) = 0.5_DP*dx*(dx-1.0_DP)
          Dbas(2,DER_FUNC1D,i,j) = 0.5_DP*dx*(dx+1.0_DP)
          Dbas(3,DER_FUNC1D,i,j) = (1.0_DP - dx)*(1.0_DP + dx)

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

    ! Calculate derivatives?
    if(Bder(DER_DERIV1D_X)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(i,dx,ddet) &
      !$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
          dx = reval%p_DpointsRef(1,i,j)

          ! Get Jacobian determinant
          ddet = 1.0_DP / reval%p_Ddetj(i,j)

          ! X-derivatives on real element
          Dbas(1,DER_DERIV1D_X,i,j) = (dx - 0.5_DP)*ddet
          Dbas(2,DER_DERIV1D_X,i,j) = (dx + 0.5_DP)*ddet
          Dbas(3,DER_DERIV1D_X,i,j) = -2.0_DP*dx*ddet

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

  end subroutine

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

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

  subroutine elem_eval_S31_1D (celement, reval, Bder, Dbas)

!<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
!</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.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

! </subroutine>

  ! Element Description
  ! -------------------
  ! The S31_1D element is specified by four polynomials per element.
  !
  ! The basis polynomials are constructed from the following set of monomials:
  !
  ! { 1, x, x^2, x^3 }
  !
  ! The basis polynomials Pi are constructed such that they fulfill the
  ! following conditions:
  !
  ! For all i = 1,...,4:
  ! {
  !   For all j = 1,...,2:
  !   {
  !     Pi  (vj) = kronecker(i,j)
  !     Pi_x(vj) = kronecker(i,j+2)
  !   }
  ! }
  !
  ! With:
  ! vj being the j-th local corner vertice of the line
  ! Pi_x being the first derivative of Pi in real coordinates
  !
  ! On the reference element, the above combination of monomial set and
  ! basis polynomial conditions leads to the following basis polynomials:
  !
  !  P1(x) = 1/4 * x * (x^2 - 3) + 1/2
  !  P2(x) = 1/4 * x * (3 - x^2) + 1/2
  !  P3(x) = 1/4 * L * (x + 1) * (x - 1)^2
  !  P4(x) = 1/4 * L * (x - 1) * (x + 1)^2
  !
  ! where L := 1/2 * (v_{i+1} - v_{i}) denotes the half length of the
  ! element.

  ! Local variables
  real(DP) :: ddet,dx,dlen
  integer :: i,j

    ! Calculate function values?
    if(Bder(DER_FUNC1D)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(dlen,dx,i)&
      !$omp if(reval%nelements > reval%p_rperfconfig%NELEMMIN_OMP)
      do j = 1, reval%nelements

        ! Calculate length of element
        dlen = 0.5_DP * (reval%p_Dcoords(1,2,j) - reval%p_Dcoords(1,1,j))

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

          ! Get the point coordinates
          dx = reval%p_DpointsRef(1,i,j)

          ! Evaluate basis functions
          Dbas(1,DER_FUNC1D,i,j) =  0.25_DP*dx*(dx*dx - 3.0_DP) + 0.5_DP
          Dbas(2,DER_FUNC1D,i,j) = -0.25_DP*dx*(dx*dx - 3.0_DP) + 0.5_DP
          Dbas(3,DER_FUNC1D,i,j) =  0.25_DP*dlen*(dx + 1.0_DP)*(dx - 1.0_DP)**2
          Dbas(4,DER_FUNC1D,i,j) =  0.25_DP*dlen*(dx - 1.0_DP)*(dx + 1.0_DP)**2

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

    ! Calculate derivatives?
    if(Bder(DER_DERIV1D_X)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(ddet,dlen,dx,i)&
      !$omp if(reval%nelements > reval%p_rperfconfig%NELEMMIN_OMP)
      do j = 1, reval%nelements

        ! Calculate length of element
        dlen = 0.5_DP * (reval%p_Dcoords(1,2,j) - reval%p_Dcoords(1,1,j))

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

          ! Get the point coordinates
          dx = reval%p_DpointsRef(1,i,j)

          ! Get Jacobian determinant
          ddet = 1.0_DP / reval%p_Ddetj(i,j)

          ! X-derivatives on real element
          Dbas(1,DER_DERIV1D_X,i,j) =  0.75_DP*(dx - 1.0_DP)*(dx + 1.0_DP)*ddet
          Dbas(2,DER_DERIV1D_X,i,j) = -0.75_DP*(dx - 1.0_DP)*(dx + 1.0_DP)*ddet
          Dbas(3,DER_DERIV1D_X,i,j) =  0.25_DP*dlen*(3.0_DP*dx + 1.0_DP)*(dx - 1.0_DP)*ddet
          Dbas(4,DER_DERIV1D_X,i,j) =  0.25_DP*dlen*(3.0_DP*dx - 1.0_DP)*(dx + 1.0_DP)*ddet

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

  end subroutine

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

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

  subroutine elem_eval_PN_1D (celement, reval, Bder, Dbas)

!<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
!</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.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

! </subroutine>

  ! Element Description
  ! -------------------
  ! TODO

  ! Local variables
  real(DP) :: ddet,dx,dx2
  integer :: i,j,k,n

    ! Get the degree of the element
    n = iand(int(ishft(celement,-16)),255)+1

    ! Calculate function values?
    if(Bder(DER_FUNC1D)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(ddet,dx,dx2,i,k)&
      !$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
          dx = reval%p_DpointsRef(1,i,j)

          ! Evaluate P1 basis functions
          Dbas(1,DER_FUNC1D,i,j) = 0.5_DP*(1.0_DP-dx)
          Dbas(2,DER_FUNC1D,i,j) = 0.5_DP*(1.0_DP+dx)

          ! Evaluate basis functions of even degree >= 2
          dx2 = 1.0_DP
          do k = 3, n, 2
            dx2 = dx2*dx*dx
            Dbas(k,DER_FUNC1D,i,j) = 1.0_DP - dx2
          end do

          ! Evaluate basis functions of odd degree >= 3
          dx2 = 1.0_DP
          do k = 4, n, 2
            dx2 = dx2*dx*dx
            Dbas(k,DER_FUNC1D,i,j) = (dx2 - 1.0_DP)*dx
          end do

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

    ! Calculate derivatives?
    if(Bder(DER_DERIV1D_X)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(ddet,dx,dx2,i,k)&
      !$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
          dx = reval%p_DpointsRef(1,i,j)

          ! Get Jacobian determinant
          ddet = 1.0_DP / reval%p_Ddetj(i,j)

          ! X-derivatives on real element of P1 basis functions
          Dbas(1,DER_DERIV1D_X,i,j) = -0.5_DP*ddet
          Dbas(2,DER_DERIV1D_X,i,j) =  0.5_DP*ddet

          ! X-derivatives on real element of basis functions of
          ! even degree >= 2
          dx2 = dx*ddet
          do k = 3, n, 2
            Dbas(k,DER_DERIV1D_X,i,j) = -real(k-1,DP)*dx2
            dx2 = dx2*dx*dx
          end do

          ! X-derivatives on real element of basis functions of
          ! odd degree >= 3
          dx2 = ddet
          do k = 4, n, 2
            dx2 = dx2*dx*dx
            Dbas(k,DER_DERIV1D_X,i,j) = real(k-1,DP)*dx2 - ddet
          end do

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

  end subroutine

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

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

  subroutine elem_eval_DG_T0_1D (celement, reval, Bder, Dbas)

!<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
!</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.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

! </subroutine>

  ! Element Description
  ! -------------------
  ! The P0_1D element is specified by a single basis function per element.
  !
  ! The function value of the basis function is =1, the derivatives are all 0!

  ! Local variables
  integer :: i,j

    ! Calculate function values?
    if(Bder(DER_FUNC1D)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(i) &
      !$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

          ! Evaluate basis functions
          Dbas(1,DER_FUNC1D,i,j) = 1.0_DP

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

  end subroutine

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

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

  subroutine elem_eval_DG_T1_1D (celement, reval, Bder, Dbas)

!<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
!</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.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

! </subroutine>

  ! Element Description
  ! -------------------
  ! TODO

  ! Local variables
  integer :: i,j

    ! Calculate function values?
    if(Bder(DER_FUNC1D)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(i) &
      !$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

          ! Evaluate basis functions
          Dbas(1,DER_FUNC1D,i,j) = 1.0_DP
          Dbas(2,DER_FUNC1D,i,j) = reval%p_DpointsRef(1,i,j)

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

    ! Calculate derivatives?
    if(Bder(DER_DERIV1D_X)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(i) &
      !$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

          ! X-derivatives on real element
          Dbas(1,DER_DERIV1D_X,i,j) = 0.0_DP
          Dbas(2,DER_DERIV1D_X,i,j) = 1.0_DP / reval%p_Ddetj(i,j)

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

  end subroutine

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

!<subroutine>

#ifndef USE_OPENMP
  pure &
#endif

  subroutine elem_eval_DG_T2_1D (celement, reval, Bder, Dbas)

!<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
!</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.
  real(DP), dimension(:,:,:,:), intent(out)      :: Dbas
!</output>

! </subroutine>

  ! Element Description
  ! -------------------
  ! TODO

  ! Local variables
  real(DP) :: ddet,dx
  integer :: i,j

    ! Calculate function values?
    if(Bder(DER_FUNC1D)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(i,dx) &
      !$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
          dx = reval%p_DpointsRef(1,i,j)

          ! Evaluate basis functions
          Dbas(1,DER_FUNC1D,i,j) = 1.0_DP
          Dbas(2,DER_FUNC1D,i,j) = dx
          Dbas(3,DER_FUNC1D,i,j) = 0.5_DP*dx*dx-1.0_DP/6.0_DP

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

    ! Calculate derivatives?
    if(Bder(DER_DERIV1D_X)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(i,dx,ddet) &
      !$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
          dx = reval%p_DpointsRef(1,i,j)

          ! Get Jacobian determinant
          ddet = 1.0_DP / reval%p_Ddetj(i,j)

          ! X-derivatives on real element
          Dbas(1,DER_DERIV1D_X,i,j) = 0.0_DP
          Dbas(2,DER_DERIV1D_X,i,j) = ddet
          Dbas(3,DER_DERIV1D_X,i,j) = dx*ddet

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

    ! Calculate derivatives?
    if(Bder(DER_DERIV1D_XX)) then

      ! Loop through all elements
      !$omp parallel do default(shared) private(i,ddet) &
      !$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 Jacobian determinant
          ddet = 1.0_DP / reval%p_Ddetj(i,j)

          ! X-derivatives on real element
          Dbas(1,DER_DERIV1D_X,i,j) = 0.0_DP
          Dbas(2,DER_DERIV1D_X,i,j) = 0.0_DP
          Dbas(3,DER_DERIV1D_X,i,j) = ddet

        end do ! i

      end do ! j
      !$omp end parallel do

    end if

  end subroutine

end module


! ##############################################################################
! gamma function

module gamma

  use types ! set type precision

  ! user has default access to all functions
  public

  ! user should npt access these functions
  !private :: gser, gcf

  contains

    ! ##########################################################################
    ! ##########################################################################

    function gamm(xx) result(o)

      real(dp) o, xx

      o = exp(gammln(xx))
      return

    end function gamm

    subroutine gammv(xx, output, n)
      ! wrapper for python

      real(dp) xx(n), output(n)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = gamm(xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = gamm(xx(i)) ! function reference
      end do

    end subroutine gammv

    subroutine gammv2(xx, output, n, m)
      ! wrapper for python

      real(dp) xx(n, m), output(n, m)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = gamm(xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = gamm(xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = gamm(xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = gamm(xx(i, i2)) ! function reference
        end do

      end do

    end subroutine gammv2

    ! ##########################################################################
    ! ##########################################################################

    function gammln(xx) result(o)
      ! Numerical Recipes 3Ed 6.1

      real(dp) o, xx
      integer j
      real(dp) ser, tmp, x, y
      real(dp) :: stp = 2.5066282746310005_dp
      real(DP), dimension(6) :: cof = (/76.18009172947146_dp,&
      -86.50532032941677_dp, 24.01409824083091_dp,&
      -1.231739572450155_dp, 0.1208650973866179e-2_dp,&
      -0.5395239384953e-5_dp/)

      x = xx
      y = x
      tmp = x + 5.5_dp
      tmp = (x + 0.5_dp) * log(tmp) - tmp
      ser = 1.000000000190015_dp
      do 11 j = 1, 6
          y = y + 1.D0
          ser = ser + cof(j) / y
      11 continue

      o = tmp + log(stp * ser / x)

    end function gammln

    subroutine gammlnv(xx, output, n)
      ! wrapper for python

      real(dp) xx(n), output(n)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = gammln(xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = gammln(xx(i)) ! function reference
      end do

    end subroutine gammlnv

    subroutine gammlnv2(xx, output, n, m)
      ! wrapper for python

      real(dp) xx(n, m), output(n, m)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = gammln(xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = gammln(xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = gammln(xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = gammln(xx(i, i2)) ! function reference
        end do

      end do

    end subroutine gammlnv2

    ! ##########################################################################
    ! ##########################################################################

    function gammp(a, x) result(o)
      ! Numerical Recipes 3Ed 6.2
      ! incomplete gamma function P(a,x)

      real(dp) a, x, o

      if (x == 0.0_dp) then
        o = 0.0_dp
        return
      ! could implement gammp_approx method from
      else if (x < a + 1.0_dp) then
        o = gser(a,x)
        return
      end if

      o = 1.0 - gcf(a,x)
      return

    end function gammp

    subroutine gammpv(aa, xx, output, n)
      ! wrapper for python

      real(dp) aa(n), xx(n), output(n)

      !f2py intent(in) :: aa, xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = gammp(aa(i+j-1), xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = gammp(aa(i), xx(i)) ! function reference
      end do

    end subroutine gammpv

    subroutine gammpv2(aa, xx, output, n, m)
      ! wrapper for python

      real(dp) aa(n, m), xx(n, m), output(n, m)

      !f2py intent(in) :: aa, xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = gammp(aa(i+j-1, i2+j2-1), xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = gammp(aa(i+j-1, i2), xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = gammp(aa(i, i2+j2-1), xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = gammp(aa(i, i2), xx(i, i2)) ! function reference
        end do

      end do

    end subroutine gammpv2

    ! ##########################################################################
    ! ##########################################################################

    function gammq(a, x) result(o)
      ! Numerical Recipes 3Ed 6.2
      ! incomplete gamma function Q(a,x) = 1 - P(a,x)

      real(dp) a, x, o

      if (x == 0.0_dp) then
        o = 1.0_dp
        return
      ! could implement gammp_approx method (see section 6.2 of source)
      else if (x < a + 1.0_dp) then
        o = 1.0 - gser(a,x)
        return
      end if

      o = gcf(a,x)
      return

    end function gammq

    subroutine gammqv(aa, xx, output, n)
      ! wrapper for python

      real(dp) aa(n), xx(n), output(n)

      !f2py intent(in) :: aa, xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = gammq(aa(i+j-1), xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = gammq(aa(i), xx(i)) ! function reference
      end do

    end subroutine gammqv

    subroutine gammqv2(aa, xx, output, n, m)
      ! wrapper for python

      real(dp) aa(n, m), xx(n, m), output(n, m)

      !f2py intent(in) :: aa, xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = gammq(aa(i+j-1, i2+j2-1), xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = gammq(aa(i+j-1, i2), xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = gammq(aa(i, i2+j2-1), xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = gammq(aa(i, i2), xx(i, i2)) ! function reference
        end do

      end do

    end subroutine gammqv2

    ! ##########################################################################
    ! ##########################################################################

    function gser(a, x) result(o)
      ! Numerical Recipes 3Ed 6.2
      ! incomplete gamma function P(a,x) evaluated as a series

      real(dp) a, x, o
      real(dp) sum, del, ap, gln
      real(dp) :: EPS=3.e-7

      gln = gammln(a)
      ap = a
      sum = 1.0_dp / a
      del = sum

      do while (true == true)

        ap = ap + 1.0_dp
        del = del * x / ap
        sum = sum + del

        if (abs(del) < abs(sum) * EPS) then
          o = sum * exp( -x + a * log(x) - gln)
          return
        end if

      end do

    end function gser

    ! ##########################################################################
    ! ##########################################################################

    function gcf(a, x) result(o)
      ! Numerical Recipes 3Ed 6.2
      ! incomplete gamma function Q(a,x) evaluated by the continued fraction representation

      real(dp) a, x, o
      integer(dp) i
      real(dp) an, b, c, d, del, h
      real(dp) :: EPS = 3.e-7, FPMIN = 1.e-30

      gln = gammln(a)
      b = x + 1.0_dp - a
      c = 1.0_dp / FPMIN
      d = 1.0_dp / b
      h = d
      i = 1

      do while (true == true)

        an = -i * (i - a)
        b = b + 2.0_dp
        d = an * d + b

        if (abs(d) < FPMIN) then
          d = FPMIN
        end if

        c = b + an / c

        if (abs(c) < FPMIN) then
          c = FPMIN
        end if

        d = 1.0_dp / d
        del = d * c
        h = h * del

        if (abs(del - 1.0_dp) < EPS) then
           exit
        end if

        i = i + 1

      end do

      o =  exp( -x + a * log(x) - gln) * h

    end function gcf

    ! ##########################################################################
    ! ##########################################################################

end module gamma

! ##############################################################################
! error function

module error_function

  use types ! set type precision
  use gamma

  ! user has default access to all functions
  public

  contains

    ! ##########################################################################
    ! ##########################################################################

    function erf(x) result(o)
      ! Numerical Recipes in C 2Ed 6.2

      ! could replace with Chebyshev coefficiant method
      ! see section 6.2.2 of Numerical Recipes 3Ed
      ! this is different then calling erfcc

      real(dp) x, o

      if (x < 0.0_dp) then
        o = -gammp(.5_dp, x**2)
      else
        o = gammp(.5_dp, x**2)
      end if

      return

    end function erf

    subroutine erfv(xx, output, n)
      ! wrapper for python

      real(dp) xx(n), output(n)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = erf(xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = erf(xx(i)) ! function reference
      end do

    end subroutine erfv

    subroutine erfv2(xx, output, n, m)
      ! wrapper for python

      real(dp) xx(n, m), output(n, m)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = erf(xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = erf(xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = erf(xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = erf(xx(i, i2)) ! function reference
        end do

      end do

    end subroutine erfv2

    ! ##########################################################################
    ! ##########################################################################

    function erfc(x) result(o)
      ! Numerical Recipes in C 2Ed 6.2

      ! could replace with Chebyshev coefficiant method
      ! see section 6.2.2 of Numerical Recipes 3Ed
      ! this is different then calling erfcc

      real(dp) x, o

      if(x < 0.0_dp) then
        o = 1.0_dp + gammp(.5_dp, x**2)
      else
        o = gammq(.5_dp, x**2)
      end if

      return

    end function erfc

    subroutine erfcv(xx, output, n)
      ! wrapper for python

      real(dp) xx(n), output(n)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = erfc(xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = erfc(xx(i)) ! function reference
      end do

    end subroutine erfcv

    subroutine erfcv2(xx, output, n, m)
      ! wrapper for python

      real(dp) xx(n, m), output(n, m)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = erfc(xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = erfc(xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = erfc(xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = erfc(xx(i, i2)) ! function reference
        end do

      end do

    end subroutine erfcv2

    ! ##########################################################################
    ! ##########################################################################

    function erfcc(x) result(o)
      ! Numerical Recipes in C 2Ed 6.2

      real(dp) x, o
      real(dp) t,z

      z = abs(x)
      t = 1.0_dp / (1.0_dp + 0.5_dp * z)
      o = t * exp(-z*z-1.26551223 + t * (1.00002368 + t * (.37409196 &
        * t * (.09678418 + t * (-.18628806 + t * (.27886807 + t * (-1.13520398 &
        * t * (1.48851587 + t * (-.82215223 + t * .17087277)))))))))

      if (x< 0.0_dp) then
        o = 2.0_dp - o
      end if

      return

    end function erfcc

    subroutine erfccv(xx, output, n)
      ! wrapper for python

      real(dp) xx(n), output(n)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = erfcc(xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = erfcc(xx(i)) ! function reference
      end do

    end subroutine erfccv

    subroutine erfccv2(xx, output, n, m)
      ! wrapper for python

      real(dp) xx(n, m), output(n, m)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = erfcc(xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = erfcc(xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = erfcc(xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = erfcc(xx(i, i2)) ! function reference
        end do

      end do

    end subroutine erfccv2

    ! ##########################################################################
    ! ##########################################################################

    function inverfc(p) result(o)
      ! Numerical Recipes 3Ed 6.2

      real(dp) p, o
      real(dp) err, t, pp
      integer j

      if (p >= 2.0_dp) then
        o = -100_dp
        return
      else if (p <= 0.0_dp) then
        o = 100_dp
        return
      else if (p == 1.0_dp) then
        o = 0.0_dp
        return
      end if

      if (p < 1.0_dp) then
        pp = p
      else
        pp = 2.0_dp - p
      end if

      t = sqrt(-2.0_dp * log(pp / 2.0_dp))

      o = -0.70711_dp * ((2.30753_dp + t * 0.27061) / (1.0_dp + t * (0.99229_dp + &
        t * 0.04481_dp)) - t)

      j = 0
      do 11 j = 1, 2
        err = erfc(o) - pp
        o = o + err / (1.12837916709551257_dp * exp(-1.0 * sqrt(o)) - o * err)
      11 continue

      if (p >= 1.0_dp) then
        o = -o
      end if

      return

    end function inverfc

    subroutine inverfcv(xx, output, n)
      ! wrapper for python

      real(dp) xx(n), output(n)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = inverfc(xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = inverfc(xx(i)) ! function reference
      end do

    end subroutine inverfcv

    subroutine inverfcv2(xx, output, n, m)
      ! wrapper for python

      real(dp) xx(n, m), output(n, m)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = inverfc(xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = inverfc(xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = inverfc(xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = inverfc(xx(i, i2)) ! function reference
        end do

      end do

    end subroutine inverfcv2

    ! ##########################################################################
    ! ##########################################################################

    function inverf(p) result(o)
      ! Numerical Recipes 3Ed 6.2

      real(dp) p, o

      o = inverfc(1.0_dp - p)

      return

    end function inverf

    subroutine inverfv(xx, output, n)
      ! wrapper for python

      real(dp) xx(n), output(n)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = inverf(xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = inverf(xx(i)) ! function reference
      end do

    end subroutine inverfv

    subroutine inverfv2(xx, output, n, m)
      ! wrapper for python

      real(dp) xx(n, m), output(n, m)

      !f2py intent(in) :: xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = inverf(xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = inverf(xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = inverf(xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = inverf(xx(i, i2)) ! function reference
        end do

      end do

    end subroutine inverfv2

    ! ##########################################################################
    ! ##########################################################################

end module error_function


! NOMENCLATURE
!------------------------------------------
!nj = NUMBER OF NODES
!nm = NUMBER OF MEMBERS
!npj = NUMBER OF LOADED JOINTS
!nmp = NUMBER OF MATERIAL PROPERTIES
!npm = NUMBER OF LOADED MEMBERS
!nxsp = NUMBER OF CROSS-SECTIONS
!neq = NUMBER OF EQUATIONS TO BE SOLVED
!npc = NUMBER OF LOADED CASES
!x,y = CO-ORDINATES
!idf = DEGREE OF FREEDOM
!zi = MOMENT OF INERTIA
!em = ELASTIC MODULOUS
!fj = APPLIED LOADS MATRIX
!xsp = CROSS-SECTIONAL PROPERTIES
!nxsp = NUMBER OF CROSS-SECTIONAL PROPERTIES
!mcp = MEMBER CONNECTIVITY
!acs = DISPLACEMENT VECTOR
!im = MOMENT OF INERTIA
!nip = NUMBER OF MOMENT OF INERTIAS
!xdst = POINT LOAD DISTANCE FROM LEFT
!PL = POINT LOAD MAGNITUDE
!UDL = UDL MAGNITUDE
!**************************************************************************************************

program FrameAnalysis

real,dimension(:,:),allocatable::a,fj,acs,ds,xdst,PL,UDL
real,dimension(:,:,:),allocatable::Aml
real,dimension(:),allocatable::x,y,em,xsp,q,im
integer,dimension(:),allocatable::idf
integer,dimension(:,:),allocatable:: mcp

!To compile f95 to executable: gfortran -o program/<executable_filename> program/FrameAnalysis.f95

!OPEN INPUT FILE AS UNIT 5
open(5,file="program/data_in.txt")

!OPEN OUTPUT FILE AS UNIT 8
open(8,file="program/data_out.txt")

!OPEN OUTPUT FILE AS UNIT 9 (JSON string)
open(9,file="program/data_out.json")

write(9,*)'{'

!**************************************************************************************************
! READ INPUT DATA
!**************************************************************************************************

!(1)INITIALIZE DATA
read(5,*)nj,nm,nmp,nxsp,nip,npc
neq=nj*3
allocate (acs(neq,npc),q(neq),a(neq,neq),ds(neq,npc),fj(neq,npc))
allocate (xdst(nm,npc),PL(nm,npc),UDL(nm,npc),Aml(6,nm,npc))
!(2)JOINT DATA
allocate (idf(neq),x(nj),y(nj))
do k=1,nj
  read(5,*)j,x(j),y(j),idf(3*j-2),idf(3*j-1),idf(3*j)
end do
!(3)MEMBER PROPERTIES
allocate (em(nmp))
do k=1,nmp
  read(5,*)j,em(j)
end do
!(4)CROSS-SECTIONAL PROPERTIES
allocate (xsp(nxsp))
do k=1,nxsp
  read(5,*)j,xsp(j)
end do
!(5)MOMENT OF INERTIAS
allocate(im(nip))
do k=1,nip
  read(5,*)j,im(j)
end do
!(6)MEMBER DATA
allocate (mcp(nm,5))
do k=1,nm
  read(5,*)j,mcp(j,1:5)
end do
!SET BANDWIDTH
nbw=0
nbt=0
do i=1,nm
  nbt=mcp(i,2)*3-(mcp(i,1)*3-2)+1
  if (nbt>nbw) then
    nbw=nbt
  end if
end do
!**************************************************************************************************
! PROGRAM INFORMATION
!**************************************************************************************************
write(8,*)
write(8,500)
write(8,505)'PLANE FRAME ANALYSIS PROGRAM'
write(8,505)'DEVELOPED BY: FREDERIC LAVOIE'
write(8,500)
write(8,*)
write(8,*)
!**************************************************************************************************
! PRINTOUT INPUT DATA
!**************************************************************************************************
write(8,500)
write(8,507)'INPUT DATA'
write(8,500)
write(8,*)
write(8,501)'NUMBER OF JOINTS =',nj
write(8,501)'NUMBER OF MEMBERS =',nm
! write(8,501)'NUMBER OF LOAD CASES =',npc
write(8,*)
write(8,*)
write(8,*)'JOINT DATA'
write(8,500)
write(8,503)
write(8,504)
do j=1,nj
  write(8,502)j,x(j),y(j),idf(3*j-2),idf(3*j-1),idf(3*j)
end do
write(8,*)
write(8,*)
write(8,*)'MEMBER PROPERTY DATA'
write(8,500)
write(8,*)
write(8,509)
write(8,510)
do j=1,nmp
  write(8,506)j,em(j)
end do
write(8,*)
write(8,*)
write(8,*)'CROSS-SECTIONAL PROPERTY DATA'
write(8,500)
write(8,*)
write(8,511)
do j=1,nxsp
  write(8,512)j,xsp(j)
end do
write(8,*)
write(8,*)
write(8,*)'MOMENT OF INERTIAS'
write(8,500)
write(8,*)
write(8,525)
write(8,524)
do j=1,nip
  write(8,526)j,im(j)
end do
write(8,*)
write(8,*)
write(8,*)'MEMBER DATA'
write(8,500)
write(8,*)
write(8,513)
write(8,514)
do j=1,nm
  write(8,508)j,mcp(j,1:5)
end do
write(8,*)
write(8,*)
write(8,*)'JOINT LOADS'
write(8,500)
write(8,*)

!**************************************************************************************************
! CALL SUBROUTINES
!**************************************************************************************************

call fstiff(x,y,em,im,xsp,mcp,idf,nj,nm,neq,nbw,a,nxsp,nmp,nip)

fj(:,:)=0
xdst(:,:)=0
PL(:,:)=0
UDL(:,:)=0
do i=1,npc
  read(5,*)npj,npm
  do k=1,npj
    read(5,*)j,fj(j*3-2,i),fj(j*3-1,i),fj(j*3,i)
  end do
  do k=1,npm
    read(5,*)j,xdst(j,i),PL(j,i),UDL(j,i)
  end do
  if (npc>1) then
    write(8,518)'LOAD CASE',i
    write(8,515)
    write(8,516)
    do j=1,nj
      write(8,517)j,fj(j*3-2,i),fj(j*3-1,i),fj(j*3,i)
    end do
    write(8,528)
    write(8,529)
    do j=1,nm
      write(8,527)j,xdst(j,i),PL(j,i),UDL(j,i)
    end do
    write(8,*)
    else
    write(8,515)
    write(8,516)
    do j=1,nj
      write(8,517)j,fj(j*3-2,1),fj(j*3-1,1),fj(j*3,1)
    end do
    write(8,528)
    write(8,529)
    do j=1,nm
      write(8,527)j,xdst(j,1),PL(j,1),UDL(j,1)
    end do
    write(8,*)
  end if
end do

call loads(x,y,nm,em,xsp,im,nmp,nip,nxsp,npc,UDL,xdst,PL,neq,fj,idf,mcp,acs,Aml)

call eqn(a,acs,nbw,neq,npc)

!**************************************************************************************************
! PRINTOUT PRIMARY UNKNOWNS
!**************************************************************************************************
write(8,*)
write(8,500)
write(8,519)'PRIMARY UNKNOWNS'
write(8,500)
write(8,*)
write(8,521)
write(8,522)
write(8,523)
write(9,*)' "primaryUnknowns":'
do i=1,npc
  write(9,*)'   ['
  if (npc>1) then
    write(8,*)
    write(8,518)'LOAD CASE',i

    do j=1,nj
      write(8,520)j,acs(j*3-2,i),acs(j*3-1,i),acs(j*3,i)
      if (j==nj) then
        write(9,600)'      [',acs(j*3-2,i),',',acs(j*3-1,i),',',acs(j*3,i),']'
      else
        write(9,600)'      [',acs(j*3-2,i),',',acs(j*3-1,i),',',acs(j*3,i),'],'
      end if
    end do

    else
    do j=1,nj
      write(8,520)j,acs(j*3-2,1),acs(j*3-1,1),acs(j*3,1)
      if (j==nj) then
        write(9,600)'      [',acs(j*3-2,1),',',acs(j*3-1,1),',',acs(j*3,1),']'
      else
        write(9,600)'      [',acs(j*3-2,1),',',acs(j*3-1,1),',',acs(j*3,1),'],'
      end if
    end do
  end if
  write(9,*)'   ],'
end do
write(9,*)

!**************************************************************************************************
! PRINTOUT SECONDARY UNKNOWNS
!**************************************************************************************************
write(8,*)
write(8,500)
write(8,519)'SECONDARY UNKNOWNS'
write(8,500)
write(8,*)
write(8,*)

call mforce(x,y,em,xsp,mcp,idf,nj,nm,neq,nmp,npc,acs,fj,nxsp,im,nip,Aml)

!**************************************************************************************************
! FORMAT STATEMENTS
!**************************************************************************************************
500 format(71('-'))
501 format(a25,i3)
502 format(i3,4x,f8.1,2x,f8.1,4x,b2,2x,b2,2x,b2)
503 format('JOINT',7x,'COORDINATES',9x,'D.O.F')
504 format('NUMBER',7x,'X',7x,'Y',8x,'X',3x,'Y',3x,'R')
505 format(17x,a35)
506 format(i3,2x,es10.1)
507 format(17x,a25)
508 format(4x,i3,7x,i3,5x,i3,8x,i3,11x,i3,11x,i3)
509 format(8x,'ELASTIC')
510 format(2x,'#',5x,'MODULUS')
511 format(2x,'#',6x,'AREA')
512 format(i3,2x,es10.1)
513 format(3x,'MEMBER',5x,'MEMBER  NODES',4x,' MATERIAL ',4x,'X-SECTIONAL',4x,' INERTIA')
514 format(3x,'NUMBER',5x,'j-END   k-END',4x,'PROPERTY #',4x,'PROPERTY # ',4x,'PROPERTY #')
515 format(2x,'JOINT',23x,'JOINT LOADS')
516 format(2x,'NUMBER',13x,'X',13x,'Y',10x,'MOMENT')
517 format(2x,i3,8x,f10.2,4x,f10.2,4x,f10.2)
518 format(a10,i3)
519 format(14x,a35)
520 format(4x,i3,5x,es14.3,4x,es14.3,4x,es14.3)
521 format(3x,'  NODE  ',21x,'JOINT')
522 format(3x,' NUMBER ',20x,'DISPLACEMENT')
523 format(20x,'X',17x,'Y',14x,'ROTATION')
524 format(2x,'#',5x,'INERTIA')
525 format(8x,'MOMENT OF')
526 format(i3,3x,es10.1)
527 format(2x,i3,8x,f10.2,4x,es10.2,5x,es10.2)
528 format(2x,'MEMBER',21x,'MEMBER LOADS')
529 format(2x,'NUMBER',10x,'X-DIST.',10x,'PL',10x,'UDL')
600 format(A,F25.4,A,F25.4,A,F25.4,A)

write(9,*)'}'
!**************************************************************************************************
!**************************************************************************************************
!**************************************************************************************************
!                            SUBROUTINES
!**************************************************************************************************
!**************************************************************************************************
!**************************************************************************************************
contains
!**************************************************************************************************
!**************************************************************************************************
subroutine fstiff(x,y,em,im,xsp,mcp,idf,nj,nm,neq,nbw,a,nxsp,nmp,nip)
real,dimension(nmp)::em
real,dimension(nip)::im
real,dimension(neq,neq)::a
real,dimension(nj)::x,y
real,dimension(nxsp)::xsp
real,dimension(6,6)::sm,r,rt,smrt,sms
integer,dimension(neq)::idf
integer,dimension(nm,5)::mcp
integer,dimension(6)::id
real::iim

sm(:,:)=0
r(:,:)=0
rt(:,:)=0
smrt(:,:)=0
sms(:,:)=0
a(:,:)=0

do i=1,nm
  xj=x(mcp(i,1))
  yj=y(mcp(i,1))
  xk=x(mcp(i,2))
  yk=y(mcp(i,2))
  eem=em(mcp(i,3))
  xxsp=xsp(mcp(i,4))
  iim=im(mcp(i,5))

  call fmstiff(xj,yj,xk,yk,eem,xxsp,iim,sm)
  call frotmat(xj,yj,xk,yk,r,rt)
  call multmat(6,6,6,rt,sm,smrt)
  call multmat(6,6,6,smrt,r,sms)

  id(1)=3*mcp(i,1)-2
  id(2)=3*mcp(i,1)-1
  id(3)=3*mcp(i,1)
  id(4)=3*mcp(i,2)-2
  id(5)=3*mcp(i,2)-1
  id(6)=3*mcp(i,2)

  !ASSEMBLE GLOBAL STIFFNESS MATRIX
  do nr=1,6
    do nc=1,6
  !CHECK IF STIFFNESS COEFFICIENT IS ABOVE DIAGONAL, ONLY
  !STORE VALUES ON OR ABOVE
    kn=id(nr)-id(nc)
    if(kn<0) goto 110
    ic=id(nc)
    ir=kn+1
    a(ir,ic)=a(ir,ic)+sms(nr,nc)
110 end do
  end do
end do

!APPLY JOINT RESTRAINT
do j=1,neq
  ic=j
  if(idf(ic)>0)then
    a(1,ic)=1.0
!PUT ZEROS INTO ROW AND COLUMN
    ir=ic
    do m=2,nbw
      a(m,ic)=0.0
      ir=ir-1
      if(ir>0) then
        a(m,ir)=0.0
      end if
    end do
  end if
end do

end subroutine fstiff
!**************************************************************************************************
!**************************************************************************************************
subroutine fmstiff(xa,ya,xb,yb,em,xsa,im,sm)
real,dimension(6,6)::sm
real::im
sm(:,:)=0.0
!COMPUTE LENGTH
dx=xb-xa
dy=yb-ya
d=(dx**2+dy**2)**0.5
!COMPUTE AE/L
!COMPUTE EI/L
aed=xsa*em/d
sm(1,1)=aed
sm(4,4)=aed
sm(1,4)=-aed
sm(4,1)=-aed
sm(2,2)=12*em*im/(d**3)
sm(5,5)=12*em*im/(d**3)
sm(2,5)=-12*em*im/(d**3)
sm(5,2)=-12*em*im/(d**3)
sm(3,2)=6*em*im/(d**2)
sm(2,3)=6*em*im/(d**2)
sm(6,2)=6*em*im/(d**2)
sm(2,6)=6*em*im/(d**2)
sm(5,3)=-6*em*im/(d**2)
sm(3,5)=-6*em*im/(d**2)
sm(6,5)=-6*em*im/(d**2)
sm(5,6)=-6*em*im/(d**2)
sm(3,3)=4*em*im/d
sm(6,6)=4*em*im/d
sm(6,3)=2*em*im/d
sm(3,6)=2*em*im/d

end subroutine fmstiff
!**************************************************************************************************
!**************************************************************************************************
subroutine frotmat(xa,ya,xb,yb,r,rt)
real,dimension(6,6)::r,rt
r(:,:)=0.0
rt(:,:)=0.0
!COMPUTE LENGTH
dx=xb-xa
dy=yb-ya
d=(dx**2+dy**2)**0.5
!FORM ROTATION MATRIX
r(1,1)=dx/d
r(1,2)=dy/d
r(2,1)=dy/d*(-1)
r(2,2)=dx/d
r(3,3)=1
r(4,4)=dx/d
r(4,5)=dy/d
r(5,4)=dy/d*(-1)
r(5,5)=dx/d
r(6,6)=1
!TRANSPOSE
do jj=1,6
  do ii=1,6
    rt(jj,ii)=r(ii,jj)
  end do
end do
end subroutine frotmat
!**************************************************************************************************
!**************************************************************************************************
subroutine multmat(m,n,np,a,b,c)
real,dimension(m,n)::a
real,dimension(n,np)::b
real,dimension(m,np)::c
c(:,:)=0.0
do mm=1,m
  do ji=1,np
    do kk=1,n
      c(mm,ji)=c(mm,ji)+a(mm,kk)*b(kk,ji)
    end do
  end do
end do
end subroutine multmat
!**************************************************************************************************
!**************************************************************************************************
subroutine loads(x,y,nm,em,xsp,im,nmp,nip,nxsp,npc,UDL,xdst,PL,neq,fj,idf,mcp,acs,Aml)

real::a,b,px,py,iim
real,dimension(neq,npc)::fj,acs,aams
integer,dimension(neq)::idf
integer,dimension(nm,5)::mcp
integer,dimension(6)::id
real,dimension(nj)::x,y
real,dimension(nmp)::em
real,dimension(nxsp)::xsp
real,dimension(nip)::im
real,dimension(nm,npc)::xdst,PL,UDL
real,dimension(6,1)::ams,am
real,dimension(6,nm,npc)::Aml
real,dimension(6,6)::r,rt

acs(:,:)=0
aams(:,:)=0
Aml(:,:,:)=0

do i=1,npc
  do j=1,nm

    am(:,:)=0
    ams(:,:)=0
    id(:)=0
    r(:,:)=0
    rt(:,:)=0

    xj=x(mcp(j,1))
    yj=y(mcp(j,1))
    xk=x(mcp(j,2))
    yk=y(mcp(j,2))
    eem=em(mcp(j,3))
    xxsp=xsp(mcp(j,4))
    iim=im(mcp(j,5))

    dx=xk-xj
    dy=yk-yj
    d=(dx**2+dy**2)**0.5

    id(1)=3*mcp(j,1)-2
    id(2)=3*mcp(j,1)-1
    id(3)=3*mcp(j,1)
    id(4)=3*mcp(j,2)-2
    id(5)=3*mcp(j,2)-1
    id(6)=3*mcp(j,2)

    px=PL(j,i)*dy/d
    py=PL(j,i)*dx/d
    a=xdst(j,i)
    b=d-a
    Aml(1,j,i)=Aml(1,j,i)-(px*b/d)
    Aml(2,j,i)=Aml(2,j,i)-((py*b**2)*(3*a+b)/d**3)
    Aml(3,j,i)=Aml(3,j,i)-((py*b**2*a)/d**2)
    Aml(4,j,i)=Aml(4,j,i)-(px*a/d)
    Aml(5,j,i)=Aml(5,j,i)-((py*a**2)*(a+3*b)/d**3)
    Aml(6,j,i)=Aml(6,j,i)+((py*a**2*b)/d**2)

    wx=UDL(j,i)*dy/d
    wy=UDL(j,i)*dx/d
    Aml(1,j,i)=Aml(1,j,i)-(wx*D/2)
    Aml(2,j,i)=Aml(2,j,i)-(wy*D/2)
    Aml(3,j,i)=Aml(3,j,i)-((wy*d**2)/12)
    Aml(4,j,i)=Aml(4,j,i)-(wx*d/2)
    Aml(5,j,i)=Aml(5,j,i)-(wy*d/2)
    Aml(6,j,i)=Aml(6,j,i)+((wy*d**2)/12)

    call frotmat(xj,yj,xk,yk,r,rt)

    do k=1,6
      am(k,1)=Aml(k,j,i)
    end do

    call multmat(6,6,1,rt,am,ams)

    do k=1,6
      aams(id(k),i)=aams(id(k),i)+ams(k,1)
    end do

  end do
end do

do k=1,npc
  do j=1,neq
    acs(j,k)=fj(j,k)-aams(j,k)
!CHECK RESTRAINT CONDITIONS
    if(idf(j)>0)then
      acs(j,k)=0.0
    end if
  end do
end do
end subroutine loads
!**************************************************************************************************
!**************************************************************************************************
subroutine eqn(a,b,m,n,x)
!   call eqn(a,acs,nbw,neq,npc)

integer:: k,l,nm,n,mr,j,jl,i,m1,max,ii,i1,kk,min,m,z,x
real:: pivot,c,sum
real,dimension(n,n):: a
real,dimension(n,x):: b

nm=n-1
do 200 k=1,nm
  pivot=a(1,k)
  mr=min(m,n-k+1)

  do 180 l=2,mr
      c=a(l,k)/pivot
!            -   0   +
     if (c) 150,180,150
150    i=0
       j=k+l-1

       do 160 jl=l,mr
         i=i+1
160      a(i,j)=a(i,j)-a(jl,k)*c
180      a(l,k)=c

200  continue
!z=1
do z=1,x
  !FORWARD SUBSTITUTION  (ld) * y = b TO STORE y IN b
  m1=m-1
  b(1,z)=b(1,z)/a(1,1)
  do i=2,n
    l=max(1,i-m1)
    sum=0.0
    ii=i+1
    i1=i-1
    do k=l,i1
      j=ii-k
      sum=sum+a(j,k)*b(k,z)*a(1,k)
    end do
    b(i,z)=(b(i,z)-sum)/a(1,i)
  end do
  !BACK SUBSTITUTION  l tr * x = y  TO STORE  x IN b.
  do kk=1,nm
    i=n-kk
    i1=min(n,i+m1)
    sum=0.0
    l=i+1
    do k=l,i1
      j=k-i+1
      sum=sum+a(j,i)*b(k,z)
    end do
    b(i,z)=b(i,z)-sum
  end do
end do
end subroutine eqn
!**************************************************************************************************
!**************************************************************************************************
subroutine mforce(x,y,em,xsp,mcp,idf,nj,nm,neq,nmp,npc,acs,fj,nxsp,im,nip,Aml)
real,dimension(nj)::x,y
integer,dimension(6)::id
real,dimension(neq,npc)::fj,acs,dms,am,ams
real,dimension(nmp)::em
real,dimension(nip)::im
real,dimension(nxsp)::xsp
real,dimension(6,nm,npc)::Aml
integer,dimension(neq)::idf
integer,dimension(nm,5)::mcp
real,dimension(6,6)::sm,r,rt,smr
real::iim
real,dimension(neq)::ar

write(8,105)
write(8,*)
write(9,*)' "secondaryUnknowns":'
do k=1,npc
  write(9,111)'    ['
  ar(:)=0
  do i=1,nm

    am(:,:)=0
    dms(:,:)=0
    ams(:,:)=0
    r(:,:)=0
    rt(:,:)=0
    sm(:,:)=0
    smr(:,:)=0

    xj=x(mcp(i,1))
    yj=y(mcp(i,1))
    xk=x(mcp(i,2))
    yk=y(mcp(i,2))
    eem=em(mcp(i,3))
    xxsp=xsp(mcp(i,4))
    iim=im(mcp(i,5))
    call fmstiff(xj,yj,xk,yk,eem,xxsp,iim,sm)
    call frotmat(xj,yj,xk,yk,r,rt)
    call multmat(6,6,6,sm,r,smr)
    id(1)=3*mcp(i,1)-2
    id(2)=3*mcp(i,1)-1
    id(3)=3*mcp(i,1)
    id(4)=3*mcp(i,2)-2
    id(5)=3*mcp(i,2)-1
    id(6)=3*mcp(i,2)
    do j=1,6
      dms(j,1)=dms(j,1)+acs(id(j),k)
    end do
    call multmat(6,6,1,smr,dms,am)
!   PRINT {Am}i
    do j=1,6
      am(j,1)=am(j,1)+Aml(j,i,k)
    end do
    write(8,104)i,am(1,1),am(2,1),am(3,1)
    write(8,108)am(4,1),am(5,1),am(6,1)
    write(9,110)'      [',am(1,1),',',am(2,1),',',am(3,1),',',am(4,1),',',am(5,1),',',am(6,1),'],'

!   SUM THE MEMBER FORCES INTO REACTIONS
    call multmat(6,6,1,rt,am,ams)
!   STORE FIXED END FORCES FOR SUPPORTED JOINTS
!   {Ar}
    do j=1,6
      if(idf(id(j))>0) then
        ar(id(j))=ar(id(j))+ams(j,1)
      end if
    end do
  end do
! INCLUDE JOINT LOADS THAT OCCURE AT SUPPORTS

  do j=1,neq
    if(idf(j)>0) then
      ar(j)=ar(j)-fj(j,k)
    end if
  end do
! PRINT OUT REACTIONS
  write(8,*)
  write(8,101)
  write(8,*)
  write(8,102)
  write(8,103)
  do j=1,nj
    if(j==nj) then
      if((idf(j*3-2)+idf(j*3-1)+idf(j*3))>0) then
        write(8,100)j,ar(j*3-2),ar(j*3-1),ar(j*3)
      end if
      write(9,112)'      [',j,',',ar(j*3-2),',',ar(j*3-1),',',ar(j*3),']'
    else
      if((idf(j*3-2)+idf(j*3-1)+idf(j*3))>0) then
        write(8,100)j,ar(j*3-2),ar(j*3-1),ar(j*3)
      end if
      write(9,112)'      [',j,',',ar(j*3-2),',',ar(j*3-1),',',ar(j*3),'],'
    end if
  end do
  write(8,*)
  write(8,106)
  write(8,*)
  if (npc>1)then
    if (k<npc)then
      write(8,107)
      write(8,*)
    end if
  end if
  write(9,*)'   ]'
end do

100 format(4x,i3,5x,es12.3,4x,es12.3,4x,es12.3)
101 format(3x,'SUPPORT  REACTIONS')
102 format(3x,'JOINT')
103 format(3x,'NUMBER',9X,'X',15x,'Y',13x,'MOMENT')
104 format(3x,'MEMBER',1x,i3,4x,es12.3,4x,es12.3,4x,es12.3)
105 format(3x,'MEMBER END FORCES')
106 format(71('-'))
107 format(3x,'MEMBER END FORCES')
108 format(17x,es12.3,4x,es12.3,4x,es12.3)
110 format(A,F25.4,A,F25.4,A,F25.4,A,F25.4,A,F25.4,A,F25.4,A)
111 format(A,i3,A)
112 format(A,i4,A,F25.4,A,F25.4,A,F25.4,A)
end subroutine mforce
!**************************************************************************************************
!**************************************************************************************************
end program


      subroutine kshmul (a,b,x,nrow)
      implicit double precision (a-h,o-z)
      dimension a(*),b(*),x(*)
c
c          routine to perform matrix multiplication a * b = x
c          for a triangular matrix a
c
c          author   - Gregory A. Wrenn
c          location - Lockheed Engineering and Sciences Co.
c                     144 Research Drive
c                     Hampton, Va. 23666
c
c          last modification - 17 July 1996
c
      k = 0
      do 10 i = 1,nrow
        x(i) = 0.0
   10 continue
      do 20 i = 1,nrow
      do 20 j = 1,i
        k = k + 1
        x(i) = x(i) + a(k) * b(j)
        if (j .lt. i) x(j) = x(j) + a(k) * b(i)
   20 continue
c
      return
      end