!
! Copyright (c) 2020 TECHNICAL UNIVERSITY OF MUNICH, DEPARTMENT OF MECHANICAL ENGINEERING, CHAIR OF APPLIED MECHANICS,
! BOLTZMANNSTRASSE 15, 85748 GARCHING/MUNICH, GERMANY, RIXEN@TUM.DE.
!
! Distributed under 3-Clause BSD license. See LICENSE file for more information.
!

module shapefunction_fun
    use, intrinsic:: iso_fortran_env, only: dp=>real64
    implicit none

    contains

        ! -------------------------------------------------- Line 2 ---------------------------------------------------
        integer function line2_no_of_nodes()
            line2_no_of_nodes = 2
        end function line2_no_of_nodes

        integer function line2_no_of_local_coordinates()
            line2_no_of_local_coordinates = 1
        end function line2_no_of_local_coordinates

        real(dp) function line2_xi_lower()
            line2_xi_lower = -1.0_dp
        end function line2_xi_lower

        real(dp) function line2_xi_upper()
            line2_xi_upper = 1.0_dp
        end function line2_xi_upper

        subroutine line2_evaluate(xi, out)
            real(dp), intent(in) :: xi
            real(dp), intent(out) :: out(2)

            out = (/ 0.5_dp * (1.0_dp - xi), &
                     0.5_dp * (1.0_dp + xi) /)
        end subroutine line2_evaluate

        subroutine line2_jacobian(xi, out)
            real(dp), intent(in) :: xi
            real(dp), intent(out) :: out(2,1)
            out = reshape((/-0.5_dp, 0.5_dp/), shape=(/2,1/))
        end subroutine line2_jacobian

        !------------------------------------------------ Line 3 ------------------------------------------------------

        integer function line3_no_of_nodes()
            line3_no_of_nodes = 3
        end function line3_no_of_nodes

        integer function line3_no_of_local_coordinates()
            line3_no_of_local_coordinates = 1
        end function line3_no_of_local_coordinates

        real(dp) function line3_xi_lower()
            line3_xi_lower = -1.0_dp
        end function line3_xi_lower

        real(dp) function line3_xi_upper()
            line3_xi_upper = 1.0_dp
        end function line3_xi_upper

        subroutine line3_evaluate(xi, out)
            real(dp), intent(in) :: xi
            real(dp), intent(out) :: out(3)

            out = (/ -0.5_dp * xi * (1.0_dp - xi), &
                             0.5_dp * xi * (1.0_dp + xi), &
                             (1.0_dp - xi**2) /)
        end subroutine line3_evaluate

        subroutine line3_jacobian(xi, out)
            real(dp), intent(in) :: xi
            real(dp), intent(out) :: out(3,1)

            out = reshape((/1.0_dp*xi - 0.5_dp, 1.0_dp*xi + 0.5_dp, -2.0_dp*xi/), shape=(/3,1/))
        end subroutine line3_jacobian

        !------------------------------------------ Tri3 --------------------------------------------------------------
        integer function tri3_no_of_nodes()
            tri3_no_of_nodes = 3
        end function tri3_no_of_nodes

        integer function tri3_no_of_local_coordinates()
            tri3_no_of_local_coordinates = 2
        end function tri3_no_of_local_coordinates

        real(dp) function tri3_xi_lower()
            tri3_xi_lower = 0.0_dp
        end function tri3_xi_lower

        real(dp) function tri3_xi_upper()
            tri3_xi_upper = 1.0_dp
        end function tri3_xi_upper

        real(dp) function tri3_eta_lower(xi)
            real(dp), intent(in) :: xi
            tri3_eta_lower = 0.0_dp
        end function tri3_eta_lower

        real(dp) function tri3_eta_upper(xi)
            real(dp), intent(in) :: xi
            tri3_eta_upper = 1.0_dp - xi
        end function tri3_eta_upper

        subroutine tri3_evaluate(xi, eta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(out) :: out(3)

            out = (/ 1.0_dp - xi - eta, &
                              xi, &
                              eta /)
        end subroutine tri3_evaluate

        subroutine tri3_jacobian(xi, eta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(out) :: out(3,2)

            out = reshape([ -1.0_dp, 1.0_dp, 0.0_dp, -1.0_dp, 0.0_dp, 1.0_dp ], [3, 2])
        end subroutine tri3_jacobian

        !------------------------------------------------ Quad4 -------------------------------------------------------
        integer function quad4_no_of_nodes()
            quad4_no_of_nodes = 4
        end function quad4_no_of_nodes

        integer function quad4_no_of_local_coordinates()
            quad4_no_of_local_coordinates = 2
        end function quad4_no_of_local_coordinates

        real(dp) function quad4_xi_lower()
            quad4_xi_lower = -1.0_dp
        end function quad4_xi_lower

        real(dp) function quad4_xi_upper()
            quad4_xi_upper = 1.0_dp
        end function quad4_xi_upper

        real(dp) function quad4_eta_lower(xi)
            real(dp), intent(in) :: xi
            quad4_eta_lower = -1.0_dp
        end function quad4_eta_lower

        real(dp) function quad4_eta_upper(xi)
            real(dp), intent(in) :: xi
            quad4_eta_upper = 1.0_dp
        end function quad4_eta_upper

        subroutine quad4_evaluate(xi, eta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(out) :: out(4)

            out = (/ 0.25_dp * (1.0_dp - xi) * (1.0_dp - eta), &
                            0.25_dp * (1.0_dp + xi) * (1.0_dp - eta), &
                            0.25_dp * (1.0_dp + xi) * (1.0_dp + eta), &
                            0.25_dp * (1.0_dp - xi) * (1.0_dp + eta) /)
        end subroutine quad4_evaluate

        subroutine quad4_jacobian(xi, eta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(out) :: out(4,2)

            out = reshape((/ 0.25_dp * (eta - 1.0_dp), &
                            0.25_dp * (1.0_dp - eta), &
                            0.25_dp * (1.0_dp + eta), &
                            0.25_dp * (-1.0_dp - eta), &
                            0.25_dp * (xi - 1.0_dp), &
                            0.25_dp * (-xi - 1.0_dp), &
                            0.25_dp * (1.0_dp + xi), &
                            0.25_dp * (1.0_dp - xi)/), &
                            shape=(/4,2/))
        end subroutine quad4_jacobian

        !---------------------------------------------------------- Quad8 ---------------------------------------------
        integer function quad8_no_of_nodes()
            quad8_no_of_nodes = 8
        end function quad8_no_of_nodes

        integer function quad8_no_of_local_coordinates()
            quad8_no_of_local_coordinates = 2
        end function quad8_no_of_local_coordinates

        real(dp) function quad8_xi_lower()
            quad8_xi_lower = -1.0_dp
        end function quad8_xi_lower

        real(dp) function quad8_xi_upper()
            quad8_xi_upper = 1.0_dp
        end function quad8_xi_upper

        real(dp) function quad8_eta_lower(xi)
            real(dp), intent(in) :: xi
            quad8_eta_lower = -1.0_dp
        end function quad8_eta_lower

        real(dp) function quad8_eta_upper(xi)
            real(dp), intent(in) :: xi
            quad8_eta_upper = 1.0_dp
        end function quad8_eta_upper

        subroutine quad8_evaluate(xi, eta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(out) :: out(8)

            out = (/0.25_dp * ((1.0_dp + xi) * (1.0_dp + eta) - (1.0_dp - xi**2) * (1.0_dp + eta) - &
            (1.0_dp - eta**2) * (1.0_dp + xi)), &
                          0.25_dp *((1.0_dp - xi) * (1.0_dp + eta) - (1.0_dp - xi ** 2) * (1.0_dp + eta) &
                                  - (1.0_dp - eta ** 2) * (1.0_dp - xi)),&
                          0.25_dp *((1.0_dp - xi) * (1.0_dp - eta) - (1.0_dp - eta ** 2) * (1.0_dp - xi) &
                                  - (1.0_dp - xi ** 2) * (1.0_dp - eta)),&
                          0.25_dp *((1.0_dp + xi) * (1.0_dp - eta) - (1.0_dp - xi ** 2) * (1.0_dp - eta) &
                                  - (1.0_dp - eta ** 2) * (1.0_dp + xi)),&
                          0.5_dp * (1.0_dp - xi ** 2) * (1.0_dp + eta),&
                          0.5_dp * (1.0_dp - eta ** 2) * (1.0_dp - xi),&
                          0.5_dp * (1.0_dp - xi ** 2) * (1.0_dp - eta),&
                          0.5_dp * (1.0_dp - eta ** 2) * (1.0_dp + xi) /)
        end subroutine quad8_evaluate

        subroutine quad8_jacobian(xi, eta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(out) :: out(8,2)

            out = reshape((/ 0.25_dp * eta ** 2 + 0.25_dp * eta + 0.5_dp * xi * (eta + 1.0_dp), &
            -0.25_dp * eta ** 2 - 0.25_dp * eta + 0.5_dp * xi * (eta + 1.0_dp), &
            -0.25_dp * eta ** 2 + 0.25_dp * eta + 0.5_dp * xi * (1.0_dp - eta), &
            0.25_dp * eta ** 2 - 0.25_dp * eta + 0.5_dp * xi * (1.0_dp - eta), &
            -1.0_dp * xi * (eta + 1.0_dp), &
            0.5_dp * eta ** 2 - 0.5_dp, &
            -1.0_dp * xi * (1.0_dp - eta), &
            0.5_dp - 0.5_dp * eta ** 2, &
            0.5_dp * eta * (xi + 1.0_dp) + 0.25_dp * xi ** 2 + 0.25_dp * xi, &
            0.5_dp * eta * (1.0_dp - xi) + 0.25_dp * xi ** 2 - 0.25_dp * xi, &
            0.5_dp * eta * (1.0_dp - xi) - 0.25_dp * xi ** 2 + 0.25_dp * xi, &
            0.5_dp * eta * (xi + 1.0_dp) - 0.25_dp * xi ** 2 - 0.25_dp * xi, &
            0.5_dp - 0.5_dp * xi ** 2, &
            -1.0_dp * eta * (1.0_dp - xi), &
            0.5_dp * xi ** 2 - 0.5_dp, &
            -1.0_dp * eta * (xi + 1.0_dp) /), &
            shape=(/8, 2/))
        end subroutine quad8_jacobian

        !---------------------------------------------------------- Tri6 ---------------------------------------------
        integer function tri6_no_of_nodes()
            tri6_no_of_nodes = 6
        end function tri6_no_of_nodes

        integer function tri6_no_of_local_coordinates()
            tri6_no_of_local_coordinates = 2
        end function tri6_no_of_local_coordinates

        real(dp) function tri6_xi_lower()
            tri6_xi_lower = 0.0_dp
        end function tri6_xi_lower

        real(dp) function tri6_xi_upper()
            tri6_xi_upper = 1.0_dp
        end function tri6_xi_upper

        real(dp) function tri6_eta_lower(xi)
            real(dp), intent(in) :: xi
            tri6_eta_lower = 0.0_dp
        end function tri6_eta_lower

        real(dp) function tri6_eta_upper(xi)
            real(dp), intent(in) :: xi
            tri6_eta_upper = 1.0_dp - xi
        end function tri6_eta_upper

        subroutine tri6_evaluate(xi, eta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(out) :: out(6)

            out = (/ (1.0_dp - xi - eta) * (1.0_dp - 2.0_dp * (xi + eta)), &
                           - 2.0_dp * xi * (0.5_dp - xi), &
                           - 2.0_dp * eta * (0.5_dp - eta), &
                             4.0_dp * xi * (1.0_dp - xi - eta), &
                             4.0_dp * xi * eta, &
                             4.0_dp * eta * (1.0_dp - xi - eta) /)
        end subroutine tri6_evaluate

        subroutine tri6_jacobian(xi, eta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(out) :: out(6,2)

            out = reshape((/ 4.0_dp*eta + 4.0_dp*xi - 3.0_dp, &
                            4.0_dp*xi - 1.0_dp, &
                            0.0_dp, &
                            -4.0_dp*eta - 8.0_dp*xi + 4.0_dp, &
                            4.0_dp * eta, &
                            -4.0_dp*eta, &
                            4.0_dp*eta + 4.0_dp*xi - 3.0_dp, &
                            0.0_dp, &
                            4.0_dp*eta - 1.0_dp, &
                            -4.0_dp*xi, &
                            4.0_dp * xi, &
                            -8.0_dp*eta - 4.0_dp*xi + 4.0_dp /), &
                            shape = (/6, 2/))
        end subroutine tri6_jacobian

        !---------------------------------------------------------- Hexa8 ---------------------------------------------
        integer function hexa8_no_of_nodes()
            hexa8_no_of_nodes = 8
        end function hexa8_no_of_nodes

        integer function hexa8_no_of_local_coordinates()
            hexa8_no_of_local_coordinates = 3
        end function hexa8_no_of_local_coordinates

        real(dp) function hexa8_xi_lower()
            hexa8_xi_lower = -1.0_dp
        end function hexa8_xi_lower

        real(dp) function hexa8_xi_upper()
            hexa8_xi_upper = 1.0_dp
        end function hexa8_xi_upper

        real(dp) function hexa8_eta_lower(xi)
            real(dp), intent(in) :: xi
            hexa8_eta_lower = -1.0_dp
        end function hexa8_eta_lower

        real(dp) function hexa8_eta_upper(xi)
            real(dp), intent(in) :: xi
            hexa8_eta_upper = 1.0_dp
        end function hexa8_eta_upper

        real(dp) function hexa8_zeta_lower(xi, eta)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            hexa8_zeta_lower = -1.0_dp
        end function hexa8_zeta_lower

        real(dp) function hexa8_zeta_upper(xi, eta)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            hexa8_zeta_upper = 1.0_dp
        end function hexa8_zeta_upper

        subroutine hexa8_evaluate(xi, eta, zeta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(in) :: zeta
            real(dp), intent(out) :: out(8)

            out = (/ (-eta + 1.0_dp) * (-xi + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
                            (-eta + 1.0_dp) * (xi + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
                            (eta + 1.0_dp) * (xi + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
                            (eta + 1.0_dp) * (-xi + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
                            (-eta + 1.0_dp) * (-xi + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp, &
                            (-eta + 1.0_dp) * (xi + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp, &
                            (eta + 1.0_dp) * (xi + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp, &
                            (eta + 1.0_dp) * (-xi + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp /)
        end subroutine hexa8_evaluate

        subroutine hexa8_jacobian(xi, eta, zeta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(in) :: zeta
            real(dp), intent(out) :: out(8,3)

            out = reshape((/ -(-eta + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
            (-eta + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
            (eta + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
            -(eta + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
            -(-eta + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp, &
            (-eta + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp, &
            (eta + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp, &
            -(eta + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp, &
            -(-xi + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
            -(xi + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
            (xi + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
            (-xi + 1.0_dp) * (-zeta + 1.0_dp) / 8.0_dp, &
            -(-xi + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp, &
            -(xi + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp, &
            (xi + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp, &
            (-xi + 1.0_dp) * (zeta + 1.0_dp) / 8.0_dp, &
            -(-eta + 1.0_dp) * (-xi + 1.0_dp) / 8.0_dp, &
            -(-eta + 1.0_dp) * (xi + 1.0_dp) / 8.0_dp, &
            -(eta + 1.0_dp) * (xi + 1.0_dp) / 8.0_dp, &
            -(eta + 1.0_dp) * (-xi + 1.0_dp) / 8.0_dp, &
            (-eta + 1.0_dp) * (-xi + 1.0_dp) / 8.0_dp, &
            (-eta + 1.0_dp) * (xi + 1.0_dp) / 8.0_dp, &
            (eta + 1.0_dp) * (xi + 1.0_dp) / 8.0_dp, &
            (eta + 1.0_dp) * (-xi + 1.0_dp) / 8.0_dp /), &
            shape=(/8,3/))
        end subroutine hexa8_jacobian

        !---------------------------------------------------------- Tet4 ---------------------------------------------
        integer function tet4_no_of_nodes()
            tet4_no_of_nodes = 4
        end function tet4_no_of_nodes

        integer function tet4_no_of_local_coordinates()
            tet4_no_of_local_coordinates = 3
        end function tet4_no_of_local_coordinates

        real(dp) function tet4_xi_lower()
            tet4_xi_lower = 0.0_dp
        end function tet4_xi_lower

        real(dp) function tet4_xi_upper()
            tet4_xi_upper = 1.0_dp
        end function tet4_xi_upper

        real(dp) function tet4_eta_lower(xi)
            real(dp), intent(in) :: xi
            tet4_eta_lower = 0.0_dp
        end function tet4_eta_lower

        real(dp) function tet4_eta_upper(xi)
            real(dp), intent(in) :: xi
            tet4_eta_upper = 1.0_dp - xi
        end function tet4_eta_upper

        real(dp) function tet4_zeta_lower(xi, eta)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            tet4_zeta_lower = 0.0_dp
        end function tet4_zeta_lower

        real(dp) function tet4_zeta_upper(xi, eta)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            tet4_zeta_upper = 1.0_dp - xi - eta
        end function tet4_zeta_upper

        subroutine tet4_evaluate(xi, eta, zeta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(in) :: zeta
            real(dp), intent(out) :: out(4)

            out = (/ 1.0_dp - xi - eta - zeta, &
                           xi, &
                           eta, &
                           zeta /)
        end subroutine tet4_evaluate

        subroutine tet4_jacobian(xi, eta, zeta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(in) :: zeta
            real(dp), intent(out) :: out(4,3)

            out = reshape((/-1.0_dp, 1.0_dp, 0.0_dp, 0.0_dp, -1.0_dp, 0.0_dp, 1.0_dp, 0.0_dp, -1.0_dp, 0.0_dp, 0.0_dp,&
                    1.0_dp/),(/4,3/))
        end subroutine tet4_jacobian

        !---------------------------------------------------------- Hexa20 --------------------------------------------
        integer function hexa20_no_of_nodes()
            hexa20_no_of_nodes = 20
        end function hexa20_no_of_nodes

        integer function hexa20_no_of_local_coordinates()
            hexa20_no_of_local_coordinates = 3
        end function hexa20_no_of_local_coordinates

        real(dp) function hexa20_xi_lower()
            hexa20_xi_lower = -1.0_dp
        end function hexa20_xi_lower

        real(dp) function hexa20_xi_upper()
            hexa20_xi_upper = 1.0_dp
        end function hexa20_xi_upper

        real(dp) function hexa20_eta_lower(xi)
            real(dp), intent(in) :: xi
            hexa20_eta_lower = -1.0_dp
        end function hexa20_eta_lower

        real(dp) function hexa20_eta_upper(xi)
            real(dp), intent(in) :: xi
            hexa20_eta_upper = 1.0_dp
        end function hexa20_eta_upper

        real(dp) function hexa20_zeta_lower(xi, eta)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            hexa20_zeta_lower = -1.0_dp
        end function hexa20_zeta_lower

        real(dp) function hexa20_zeta_upper(xi, eta)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            hexa20_zeta_upper = 1.0_dp
        end function hexa20_zeta_upper

        subroutine hexa20_evaluate(xi, eta, zeta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(in) :: zeta
            real(dp), intent(out) :: out(20)

            out = (/ (1.0_dp - eta) * (1.0_dp - xi) * (1.0_dp - zeta) * (-eta - xi - zeta - 2.0_dp) / 8.0_dp, &
            (1.0_dp - eta) * (1.0_dp - zeta) * (xi + 1.0_dp) * (-eta + xi - zeta - 2.0_dp) / 8.0_dp, &
            (1.0_dp - zeta) * (eta + 1.0_dp) * (xi + 1.0_dp) * (eta + xi - zeta - 2.0_dp) / 8.0_dp, &
            (1.0_dp - xi) * (1.0_dp - zeta) * (eta + 1.0_dp) * (eta - xi - zeta - 2.0_dp) / 8.0_dp, &
            (1.0_dp - eta) * (1.0_dp - xi) * (zeta + 1.0_dp) * (-eta - xi + zeta - 2.0_dp) / 8.0_dp, &
            (1.0_dp - eta) * (xi + 1.0_dp) * (zeta + 1.0_dp) * (-eta + xi + zeta - 2.0_dp) / 8.0_dp, &
            (eta + 1.0_dp) * (xi + 1.0_dp) * (zeta + 1.0_dp) * (eta + xi + zeta - 2.0_dp) / 8.0_dp, &
            (1.0_dp - xi) * (eta + 1.0_dp) * (zeta + 1.0_dp) * (eta - xi + zeta - 2.0_dp) / 8.0_dp, &
            (0.25_dp - 0.25_dp * xi ** 2) * (1.0_dp - eta) * (1.0_dp - zeta), &
            (1.0_dp - eta ** 2) * (1.0_dp - zeta) * (0.25_dp * xi + 0.25), &
            (0.25_dp - 0.25_dp * xi ** 2) * (1.0_dp - zeta) * (eta + 1.0_dp), &
            (0.25_dp - 0.25_dp * xi) * (1.0_dp - eta ** 2) * (1.0_dp - zeta), &
            (0.25_dp - 0.25_dp * xi ** 2) * (1.0_dp - eta) * (zeta + 1.0_dp), &
            (1.0_dp - eta ** 2) * (0.25_dp * xi + 0.25) * (zeta + 1.0_dp), &
            (0.25_dp - 0.25_dp * xi ** 2) * (eta + 1.0_dp) * (zeta + 1.0_dp), &
            (0.25_dp - 0.25_dp * xi) * (1.0_dp - eta ** 2) * (zeta + 1.0_dp), &
            (0.25_dp - 0.25_dp * xi) * (1.0_dp - eta) * (1.0_dp - zeta ** 2), &
            (1.0_dp - eta) * (1.0_dp - zeta ** 2) * (0.25_dp * xi + 0.25), &
            (1.0_dp - zeta ** 2) * (eta + 1.0_dp) * (0.25_dp * xi + 0.25), &
            (0.25_dp - 0.25_dp * xi) * (1.0_dp - zeta ** 2) * (eta + 1.0_dp) /)
        end subroutine hexa20_evaluate

        subroutine hexa20_jacobian(xi, eta, zeta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(in) :: zeta
            real(dp), intent(out) :: out(20,3)

            out = reshape((/ -(1.0_dp / 8.0_dp - eta / 8.0_dp) * (1.0_dp - xi) * (1.0_dp - zeta) + (1.0_dp - zeta) * ( &
            eta / 8.0_dp - 1.0_dp / 8.0_dp) * (-eta - xi - zeta - 2.0_dp), &
            (1.0_dp / 8.0_dp - eta / 8.0_dp) * (1.0_dp - zeta) * (-eta + xi - zeta - 2.0_dp) + (1.0_dp - eta) * ( &
            1.0_dp - zeta) * (xi / 8.0_dp + 1.0_dp / 8.0_dp), &
            (1.0_dp - zeta) * (eta / 8.0_dp + 1.0_dp / 8.0_dp) * (xi + 1.0_dp) + (1.0_dp - zeta) * &
            (eta / 8.0_dp + 1.0_dp / 8.0_dp) * ( eta + xi - zeta - 2.0_dp), &
            -(1.0_dp - xi) * (1.0_dp - zeta) * (eta / 8.0_dp + 1.0_dp / 8.0_dp) + (1.0_dp - zeta) * ( &
            -eta / 8.0_dp - 1.0_dp / 8.0_dp) * (eta - xi - zeta - 2.0_dp), &
            -(1.0_dp - eta) * (1.0_dp - xi) * (zeta / 8.0_dp + 1.0_dp / 8.0_dp) - (1.0_dp - eta) * ( &
            zeta / 8.0_dp + 1.0_dp / 8.0_dp) * (-eta - xi + zeta - 2.0_dp), &
            (1.0_dp - eta) * (xi / 8.0_dp + 1.0_dp / 8.0_dp) * (zeta + 1.0_dp) + (1.0_dp - eta) * &
            (zeta / 8.0_dp + 1.0_dp / 8.0_dp) * (-eta + xi + zeta - 2.0_dp), &
            (eta / 8.0_dp + 1.0_dp / 8.0_dp) * (xi + 1) * (zeta + 1.0_dp) + (eta / 8.0_dp + 1.0_dp / 8.0_dp) * &
            (zeta + 1.0_dp) * ( eta + xi + zeta - 2.0_dp), &
            -(1.0_dp - xi) * (eta / 8.0_dp + 1.0_dp / 8.0_dp) * (zeta + 1.0_dp) - (eta / 8.0_dp + 1.0_dp / 8.0_dp) * &
            ( zeta + 1.0_dp) * (eta - xi + zeta - 2.0_dp), &
            -xi * (1.0_dp - eta) * (1.0_dp - zeta) / 2.0_dp, &
            (1.0_dp - eta ** 2) * (1.0_dp - zeta) / 4.0_dp, &
            -xi * (1.0_dp - zeta) * (eta + 1) / 2.0_dp, &
            -(1.0_dp - eta ** 2) * (1.0_dp - zeta) / 4.0_dp, &
            -xi * (1.0_dp - eta) * (zeta + 1.0_dp) / 2.0_dp, &
            (1.0_dp - eta ** 2) * (zeta + 1.0_dp) / 4.0_dp, &
            -xi * (eta + 1) * (zeta + 1) / 2.0_dp, &
            -(1.0_dp - eta ** 2) * (zeta + 1.0_dp) / 4.0_dp, &
            -(1.0_dp - eta) * (1.0_dp - zeta ** 2) / 4.0_dp, &
            (1.0_dp - eta) * (1.0_dp - zeta ** 2) / 4.0_dp, &
            (1.0_dp - zeta ** 2) * (eta + 1.0_dp) / 4.0_dp, &
            -(1.0_dp - zeta ** 2) * (eta + 1.0_dp) / 4.0_dp, &
            -(1.0_dp / 8.0_dp - eta / 8.0_dp) * (1.0_dp - xi) * (1.0_dp - zeta) + (1.0_dp - zeta) * &
            (xi / 8.0_dp - 1.0_dp / 8.0_dp) * ( -eta - xi - zeta - 2.0_dp), &
            -(1.0_dp - eta) * (1.0_dp - zeta) * (xi / 8.0_dp + 1.0_dp / 8.0_dp) + (1.0_dp - zeta) * ( &
            -xi / 8.0_dp - 1.0_dp / 8.0_dp) * (-eta + xi - zeta - 2.0_dp), &
            (1.0_dp - zeta) * (eta / 8.0_dp + 1.0_dp / 8.0_dp) * (xi + 1.0_dp) + (1.0_dp - zeta) * &
            (xi / 8.0_dp + 1.0_dp / 8.0_dp) * ( eta + xi - zeta - 2.0_dp), &
            (1.0_dp / 8.0_dp - xi / 8) * (1.0_dp - zeta) * (eta - xi - zeta - 2.0_dp) + (1.0_dp - xi) * &
            (1.0_dp - zeta) * ( eta / 8.0_dp + 1.0_dp / 8.0_dp), &
            -(1.0_dp - eta) * (1.0_dp - xi) * (zeta / 8.0_dp + 1.0_dp / 8.0_dp) + (1.0_dp - xi) * ( &
            -zeta / 8.0_dp - 1.0_dp / 8.0_dp) * (-eta - xi + zeta - 2.0_dp), &
            -(1.0_dp - eta) * (xi / 8.0_dp + 1.0_dp / 8.0_dp) * (zeta + 1.0_dp) - (xi / 8.0_dp + 1.0_dp / 8.0_dp) * &
            (zeta + 1.0_dp) * ( -eta + xi + zeta - 2.0_dp), &
            (eta / 8.0_dp + 1.0_dp / 8.0_dp) * (xi + 1) * (zeta + 1.0_dp) + (xi / 8.0_dp + 1.0_dp / 8.0_dp) * &
            (zeta + 1.0_dp) * ( eta + xi + zeta - 2.0_dp), &
            (1.0_dp - xi) * (eta / 8.0_dp + 1.0_dp / 8.0_dp) * (zeta + 1.0_dp) + (1.0_dp - xi) * &
            (zeta / 8.0_dp + 1.0_dp / 8.0_dp) * ( eta - xi + zeta - 2.0_dp), &
            (0.25_dp - xi ** 2 / 4.0_dp) * (zeta - 1.0_dp), &
            -2.0_dp * eta * (1.0_dp - zeta) * (xi / 4.0_dp + 0.25), &
            (0.25_dp - xi ** 2 / 4.0_dp) * (1.0_dp - zeta), &
            -2.0_dp * eta * (0.25_dp - xi / 4) * (1.0_dp - zeta), &
            (0.25_dp - xi ** 2 / 4.0_dp) * (-zeta - 1.0_dp), &
            -2.0_dp * eta * (xi / 4 + 0.25) * (zeta + 1.0_dp), &
            (0.25_dp - xi ** 2 / 4.0_dp) * (zeta + 1.0_dp), &
            -2.0_dp * eta * (0.25_dp - xi / 4.0_dp) * (zeta + 1.0_dp), &
            (0.25_dp - xi / 4.0_dp) * (zeta ** 2 - 1.0_dp), &
            (xi / 4.0_dp + 0.25) * (zeta ** 2 - 1.0_dp), &
            (1.0_dp - zeta ** 2) * (xi / 4.0_dp + 0.25), &
            (0.25_dp - xi / 4) * (1.0_dp - zeta ** 2), &
            -(1.0_dp / 8.0_dp - eta / 8.0_dp) * (1.0_dp - xi) * (1.0_dp - zeta) - (1.0_dp / 8.0_dp - eta / 8.0_dp) * &
                    (1.0_dp - xi) * ( -eta - xi - zeta - 2.0_dp), &
            -(1.0_dp - eta) * (1.0_dp - zeta) * (xi / 8.0_dp + 1.0_dp / 8.0_dp) - (1.0_dp - eta) * &
                    (xi / 8.0_dp + 1.0_dp / 8.0_dp) * ( -eta + xi - zeta - 2.0_dp), &
            -(1.0_dp - zeta) * (eta / 8.0_dp + 1.0_dp / 8.0_dp) * (xi + 1.0_dp) - (eta / 8.0_dp + 1.0_dp / 8.0_dp) * &
                    (xi + 1) * ( eta + xi - zeta - 2.0_dp), &
            -(1.0_dp - xi) * (1.0_dp - zeta) * (eta / 8.0_dp + 1.0_dp / 8.0_dp) - (1.0_dp - xi) * &
                    (eta / 8.0_dp + 1.0_dp / 8.0_dp) * ( eta - xi - zeta - 2.0_dp), &
            (1.0_dp / 8.0_dp - eta / 8.0_dp) * (1.0_dp - xi) * (-eta - xi + zeta - 2.0_dp) + (1.0_dp - eta) * &
                    (1.0_dp - xi) * ( zeta / 8.0_dp + 1.0_dp / 8.0_dp), &
            (1.0_dp - eta) * (xi / 8.0_dp + 1.0_dp / 8.0_dp) * (zeta + 1.0_dp) + (1.0_dp - eta) * &
                    (xi / 8.0_dp + 1.0_dp / 8.0_dp) * ( -eta + xi + zeta - 2.0_dp), &
            (eta / 8.0_dp + 1.0_dp / 8.0_dp) * (xi + 1) * (zeta + 1.0_dp) + (eta / 8.0_dp + 1.0_dp / 8.0_dp) * &
                    (xi + 1.0_dp) * ( eta + xi + zeta - 2.0_dp), &
            (1.0_dp - xi) * (eta / 8.0_dp + 1.0_dp / 8.0_dp) * (zeta + 1.0_dp) + (1.0_dp - xi) * &
                    (eta / 8.0_dp + 1.0_dp / 8.0_dp) * ( eta - xi + zeta - 2.0_dp), &
            (0.25_dp - xi ** 2 / 4.0_dp) * (eta - 1.0_dp), &
            (eta ** 2 - 1.0_dp) * (xi / 4.0_dp + 0.25), &
            (0.25_dp - xi ** 2 / 4.0_dp) * (-eta - 1), &
            (0.25_dp - xi / 4.0_dp) * (eta ** 2 - 1.0_dp), &
            (0.25_dp - xi ** 2 / 4.0_dp) * (1.0_dp - eta), &
            (1.0_dp - eta ** 2) * (xi / 4.0_dp + 0.25), &
            (0.25_dp - xi ** 2 / 4.0_dp) * (eta + 1.0_dp), &
            (0.25_dp - xi / 4.0_dp) * (1.0_dp - eta ** 2), &
            -2.0_dp * zeta * (0.25_dp - xi / 4.0_dp) * (1.0_dp - eta), &
            -2 * zeta * (1.0_dp - eta) * (xi / 4.0_dp + 0.25), &
            -2.0_dp * zeta * (eta + 1.0_dp) * (xi / 4.0_dp + 0.25), &
            -2.0_dp * zeta * (0.25_dp - xi / 4.0_dp) * (eta + 1.0_dp) /), &
            shape=(/20,3/))
        end subroutine hexa20_jacobian

        !---------------------------------------------------------- Tet10 ---------------------------------------------
        integer function tet10_no_of_nodes()
            tet10_no_of_nodes = 10
        end function tet10_no_of_nodes

        integer function tet10_no_of_local_coordinates()
            tet10_no_of_local_coordinates = 3
        end function tet10_no_of_local_coordinates

        real(dp) function tet10_xi_lower()
            tet10_xi_lower = 0.0_dp
        end function tet10_xi_lower

        real(dp) function tet10_xi_upper()
            tet10_xi_upper = 1.0_dp
        end function tet10_xi_upper

        real(dp) function tet10_eta_lower(xi)
            real(dp), intent(in) :: xi
            tet10_eta_lower = 0.0_dp
        end function tet10_eta_lower

        real(dp) function tet10_eta_upper(xi)
            real(dp), intent(in) :: xi
            tet10_eta_upper = 1.0_dp - xi
        end function tet10_eta_upper

        real(dp) function tet10_zeta_lower(xi, eta)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            tet10_zeta_lower = 0.0_dp
        end function tet10_zeta_lower

        real(dp) function tet10_zeta_upper(xi, eta)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            tet10_zeta_upper = 1.0_dp - xi - eta
        end function tet10_zeta_upper

        subroutine tet10_evaluate(xi, eta, zeta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(in) :: zeta
            real(dp), intent(out) :: out(10)

            out = (/ 2.0_dp * eta * (eta + xi + zeta - 1.0_dp) - eta + 2.0_dp * xi * ( &
                    eta + xi + zeta - 1.0_dp) - xi + 2.0_dp * zeta * ( &
                    eta + xi + zeta - 1.0_dp) - zeta + 1.0_dp, &
                    xi * (2.0_dp * xi - 1.0_dp), &
                    eta * (2.0_dp * eta - 1.0_dp), &
                    zeta * (2.0_dp * zeta - 1.0_dp), &
                    4.0_dp * xi * (-eta - xi - zeta + 1.0_dp), &
                    4.0_dp * eta * xi, &
                    4.0_dp * eta * (-eta - xi - zeta + 1.0_dp), &
                    4.0_dp * xi * zeta, &
                    4.0_dp * eta * zeta, &
                    4.0_dp * zeta * (-eta - xi - zeta + 1.0_dp) /)
        end subroutine tet10_evaluate

        subroutine tet10_jacobian(xi, eta, zeta, out)
            real(dp), intent(in) :: xi
            real(dp), intent(in) :: eta
            real(dp), intent(in) :: zeta
            real(dp), intent(out) :: out(10,3)

            out = reshape((/ 4.0_dp * eta + 4.0_dp * xi + 4.0_dp * zeta - 3.0_dp, &
            4.0_dp * xi - 1.0_dp, &
            0.0_dp, &
            0.0_dp, &
            -4.0_dp * eta - 8.0_dp * xi - 4.0_dp * zeta + 4.0_dp, &
            4.0_dp * eta, &
            -4.0_dp * eta, &
            4.0_dp * zeta, &
            0.0_dp, &
            -4.0_dp * zeta, &
            4.0_dp * eta + 4.0_dp * xi + 4.0_dp * zeta - 3.0_dp, &
            0.0_dp, &
            4.0_dp * eta - 1.0_dp, &
            0.0_dp, &
            -4.0_dp * xi, &
            4.0_dp * xi, &
            -8.0_dp * eta - 4.0_dp * xi - 4.0_dp * zeta + 4.0_dp, &
            0.0_dp, &
            4.0_dp * zeta, &
            -4.0_dp * zeta, &
            4.0_dp * eta + 4.0_dp * xi + 4.0_dp * zeta - 3.0_dp, &
            0.0_dp, &
            0.0_dp, &
            4.0_dp * zeta - 1.0_dp, &
            -4.0_dp * xi, &
            0.0_dp, &
            -4.0_dp * eta, &
            4.0_dp * xi, &
            4.0_dp * eta, &
            -4.0_dp * eta - 4.0_dp * xi - 8.0_dp * zeta + 4.0_dp /), &
            shape=(/10,3/))
        end subroutine tet10_jacobian

end module shapefunction_fun


! Copyright 2012-2018, University of Strathclyde
! Authors: Lawrence T. Campbell
! License: BSD-3-Clause

!> @author
!> Lawrence Campbell, Cynthia Nam
!> University of Strathclyde,
!> Glasgow, UK
!> @brief
!> Some basic low-level functions (Gaussian, linspace etc).

MODULE Functions

USE paratype
USE ParallelInfoType
USE error_fn
USE typesAndConstants

IMPLICIT NONE

CONTAINS
!********************************************************

  FUNCTION gaussian(x,xc,sigma)

    IMPLICIT NONE
!
! Return array of the Gaussian function for aray of
! points x
!
    REAL(KIND=WP), INTENT(IN) :: x(:)
    REAL (KIND=WP),INTENT(IN) :: xc,sigma
! Local vars
    REAL(KIND=WP), allocatable :: gaussian(:),&
         ngaussian(:)
    REAL(KIND=WP) ::pi,s_twopi_sigma

    allocate(gaussian(SIZE(x)),&
         ngaussian(SIZE(x)))

! BEGIN:-

    pi=4.0_WP*ATAN(1.0_WP)
    s_twopi_sigma=sqrt(2*pi)*sigma

    if (sigma > 0.0_wp) then
      ngaussian=exp(-((x-xc)/sigma)**2/2.0_WP)
    else
      ngaussian = 0.0_wp
    end if

    gaussian=ngaussian

    return

    deallocate(gaussian)

  END FUNCTION gaussian

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

  FUNCTION linspace(xstart,xend,n)

    IMPLICIT NONE
!
!Generate a uniform array of n values between xstart and xend
!
    REAL(KIND=WP),INTENT(IN) ::xstart,xend
    INTEGER(KIND=IP),INTENT(IN) :: n
    REAL(KIND=WP),DIMENSION(:), allocatable :: linspace

! Local vars:-

    REAL(KIND=WP) :: dx
    INTEGER(KIND=IP) :: i

! BEGIN:-

    allocate(linspace(n))

    IF(n>1) THEN
       dx=(xend-xstart)/REAL((n-1),KIND=WP)
       linspace=(/ (xstart+i*dx,i=0,(n-1))/)
    ELSE IF (n==1) THEN
       linspace=(/ xstart /)
    ELSE
       STOP "*** Number of points must be >0 in LINSPACE ***"
    END IF

    return
    deallocate(linspace)

  END FUNCTION linspace

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

  FUNCTION getx(i,i_nmp,s_xc,sigma,s_xstart,s_h_in,&
       s_tol_in)

    IMPLICIT NONE
!
! CALCULATE THE X VALUE WHERE IT HAS THE SAME AREA
! UNDER THE GAUSSIAN
!
    INTEGER(KIND=IP),INTENT(IN) :: i,i_nmp
    REAL(KIND=WP),INTENT(IN) :: s_xc,sigma,s_xstart
    REAL(KIND=WP),INTENT(IN),OPTIONAL :: s_h_in
    REAL(KIND=WP),INTENT(IN),OPTIONAL :: s_tol_in

! Local vars:-

    REAL(KIND=WP) :: s_h,s_tol,getx,s_A1,s_x,s_area, &
         s_integral,s_integralstart

! BEGIN:-

! Read in the input file name
    If (PRESENT(s_h_in)) then
       s_h = s_h_in
    else
       s_h = 1.0_WP
    endif
    If (PRESENT(s_tol_in)) then
       s_tol = s_tol_in
    else
       s_tol = 1e-4_WP
    endif

    s_A1=i*1.0_WP/REAL(i_nmp)
    s_x=s_xstart
    s_area=0.0_WP
    s_integralstart=0.5_WP*(1.0_WP+erf((s_x-s_xc)/(SQRT(2.0_WP)*sigma)))
    s_area=s_integralstart

    IF (s_A1<s_area)  THEN
       PRINT * ,"Error In 'getx (Dfunctions.f90)' Subroutine,",&
            " try to use less than ",i_nmp
       STOP
    ENDIF

10  s_integral=0.5_WP*(1.0_WP+erf((s_x+s_h-s_xc)/(SQRT(2.0_WP)*sigma)))-0.5_WP*(1.0_WP+erf((s_x-s_xc)/(SQRT(2.0_WP)*sigma)))

    IF (s_h>s_tol) THEN
       IF(s_area+s_integral>s_A1) THEN
          s_h=s_h/2.0_WP
          GOTO 10
       ELSE
          s_area=s_area+s_integral
          s_x=s_x+s_h
          GO TO 10
       ENDIF
    ELSE
       getx=s_x
    ENDIF

  END FUNCTION getx

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

  SUBROUTINE GaussianGrid(i_Macro,s_MeanGuass,s_SigmaGuass,s_start,s_end,sgrid)

    IMPLICIT NONE

    INTEGER(KIND=IP),INTENT(IN) :: i_Macro
    REAL(KIND=WP),INTENT(IN) :: s_MeanGuass,s_SigmaGuass,s_start,s_end

    REAL(KIND=WP),INTENT(OUT) :: sgrid(:)

! Local vars:-

    INTEGER(KIND=IP) :: i
    INTEGER(KIND=IP) :: nHalfGridPoints,nGridPoints
    REAL(KIND=WP) :: sHalfLength
    REAL(KIND=WP) :: sX, sY
    LOGICAL :: qEven

! BEGIN:-
! Number of grid points
    nGridPoints = i_Macro + 1_IP

! Calculate half the number of gridpoints  as grid is
! mirror image around centre
    nHalfGridPoints = ceiling(REAL(nGridPoints) / 2_WP)

! Find out if have even number of grid points
    If ((nHalfGridPoints * 2_IP).NE. nGridPoints) Then
       qEven = .FALSE.
    else
       qEven = .TRUE.
    End if

! Calculate half the electron pulse length
    sHalfLength = (abs(s_end - s_start)) / 2.0_WP

! Calculate constant
    sX =  erf((sHalfLength) /&
         (sqrt(2.0_WP) * s_SigmaGuass)) / i_Macro

! Grid start and end positions
    sGrid(1) = s_start
    sGrid(i_Macro + 1_IP) = s_end

! If have an even number of grid points
    If (qEven) Then

! Need only half area for first grid point as its
! position is mirror image around centre
       sY = sX / 2.0_WP
       Do i = 1_IP, nHalfGridPoints - 1_IP
          sGrid(nHalfGridPoints + i) = sqrt(2.0_WP)&
               * s_SigmaGuass * erfi((i+(i-1)) * sX)
       End do

       Do i = 2_IP, nHalfGridPoints
          sGrid(i) = -sGrid(nGridPoints - i + 1_IP)
       End do

! If have an odd number of grid points then have
! a grid point positioned at centre
    else
       sGrid(nHalfGridPoints) = 0.0_WP
       Do i = 1_IP, nHalfGridPoints - 2_IP
          sgrid(nHalfGridPoints + i) = sqrt(2.0_WP) *&
               s_SigmaGuass * erfi(2.0_WP*i * sX)
       End do
       Do i = 2_IP, nHalfGridPoints - 1_IP
          sgrid(i) = -sGrid(nGridPoints - i + 1_IP)
       End do
    End if

    sgrid(2_IP:(nGridPoints - 1_IP)) = &
         sgrid(2_IP:(nGridPoints - 1_IP)) + s_MeanGuass

  END SUBROUTINE GaussianGrid

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

  SUBROUTINE GaussianDistribution(i_Macro,s_grid,&
       s_MeanGuass,s_SigmaGuass,s_func)

    IMPLICIT NONE
!
! Input parameters
!
    INTEGER(KIND=IP),INTENT(IN) :: i_Macro
    REAL(KIND=WP),INTENT(IN)	:: s_MeanGuass,s_SigmaGuass
    REAL(KIND=WP),INTENT(IN) :: s_grid(:)
! Output parameters
    REAL(KIND=WP),INTENT(OUT) :: s_func(:)
! Local parameters
    INTEGER(KIND=IP) :: i
    REAL(KIND=WP) :: s_new
    REAL(KIND=WP),ALLOCATABLE :: s_d(:)

! BEGIN:-
    ALLOCATE(s_d(i_Macro))
    DO i=1,i_Macro
       s_new=0.5*(s_grid(i+1)+s_grid(i))
       s_func(i)=EXP(-((s_new-s_MeanGuass)/s_SigmaGuass)**2&
            /2.0_WP)
       s_d(i)=s_grid(i+1)-s_grid(i)
    ENDDO

    s_func=s_func/sum(s_d*s_func)

    DEALLOCATE(s_d)

  END SUBROUTINE GaussianDistribution

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

  SUBROUTINE GaussianDistributionz2(i_Macro,s_grid,&
       s_MeanGuass,s_SigmaGuass,s_func,&
       MPI_DOUBLE_PRECISION,MPI_SUM)

    IMPLICIT NONE
!
! Input parameters
!
    INTEGER(KIND=IP),INTENT(IN) :: i_Macro
    INTEGER(KIND=IP),INTENT(IN)	:: MPI_DOUBLE_PRECISION,&
         MPI_SUM
    REAL(KIND=WP),INTENT(IN) :: s_MeanGuass,s_SigmaGuass
    REAL(KIND=WP),INTENT(IN) :: s_grid(:)
! Output parameters
    REAL(KIND=WP),INTENT(OUT) :: s_func(:)
! Local parameters
    INTEGER(KIND=IP) :: i,error
    REAL(KIND=WP) :: s_new,tdenom,denom
    REAL(KIND=WP),ALLOCATABLE :: s_d(:)

! BEGIN:-

    ALLOCATE(s_d(i_Macro))
    DO i=1,i_Macro
       s_new=0.5*(s_grid(i+1)+s_grid(i))
       s_func(i)=EXP(-((s_new-s_MeanGuass)/s_SigmaGuass)**2&
            /2.0_WP)
       s_d(i)=s_grid(i+1)-s_grid(i)
    ENDDO
    tdenom = sum(s_d*s_func)

    CALL MPI_ALLREDUCE(tdenom,denom,1,MPI_DOUBLE_PRECISION,&
         MPI_SUM, &
         tProcInfo_G%comm,error)

    s_func=s_func/denom

    DEALLOCATE(s_d)

  END SUBROUTINE GaussianDistributionz2

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

  SUBROUTINE hpsort(N,RA)

    IMPLICIT NONE
!
! INPUTS & OUTPUTS PARAMETERS
!
    INTEGER(KIND=IP), INTENT(IN) :: N
    REAL(KIND=WP),INTENT(INOUT) :: RA(:)

! LOCAL PARAMETERS

    INTEGER(KIND=IP) :: i,IR,J,L
    REAL(KIND=WP) :: RRA

! BEGIN:-

    IF (N.LT.2_IP) return
    L=N/2_IP+1_IP
    IR=N
10  CONTINUE
    IF (L.GT.1_IP) THEN
       L=L-1
       RRA=RA(L)
    ELSE
       RRA=RA(IR)
       RA(IR)=RA(1)
       IR=IR-1_IP
       IF (IR.EQ.1_IP) THEN
          RA(1)=RRA
          RETURN
       ENDIF
    ENDIF
    i=L
    J=L+L
20  IF (J.LE.IR) THEN
       IF(J.LT.IR) THEN
          IF(RA(J).LT.RA(J+1_IP)) J=J+1_IP
       ENDIF
       IF(RRA.LT.RA(J)) THEN
          RA(I)=RA(J)
          I=J
          J=J+J
       ELSE
          J=IR+1_IP
       ENDIF
       GOTO 20
    ENDIF
    RA(I)=RRA
    GOTO 10

  END SUBROUTINE hpsort

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

  FUNCTION epsilonParameter(saw,sgamma_r,fx,fy)

    IMPLICIT NONE

    REAL(KIND=WP),INTENT(IN)  :: saw,sgamma_r,fx,fy

! Local vars:-

    REAL(KIND=WP) :: epsilonParameter
    REAL(KIND=WP) :: beta_av

! BEGIN:-

    beta_av = SQRT(sgamma_r**2 - 1.0_WP - saw**2)&
         /sgamma_r

    epsilonParameter=(1-beta_av)/beta_av

  END FUNCTION epsilonParameter

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

  FUNCTION GainLength(sWigglerWaveLength,rho)

    IMPLICIT NONE

    REAL(KIND=WP),INTENT(IN) :: sWigglerWaveLength,rho

! Local vars:-

    REAL(KIND=WP) :: GainLength

! BEGIN:-

    GainLength = sWigglerWaveLength/(4.0_WP * pi * rho)

  END FUNCTION GainLength
!********************************************************

  FUNCTION MatchedBeamRadius(srho, sEmit, k_beta)

    IMPLICIT NONE

    REAL(KIND=WP),INTENT(IN) :: srho, sEmit, k_beta

! Local vars:-

    REAL(KIND=WP) :: MatchedBeamRadius

! BEGiN:-

    MatchedBeamRadius = SQRT( sRho * 18.0_WP * sEmit /&
        k_beta)

  END FUNCTION MatchedBeamRadius

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

  FUNCTION DiffractionLength(z,sRaleighLength,sigma)

    IMPLICIT NONE

    REAL(KIND=WP),INTENT(IN) :: z,sRaleighLength,sigma

! Local vars:-

    REAL(KIND=WP) :: DiffractionLength

! BEGIN:-

    !IF(tProcInfo_G%QROOT)print *, 'RaleighLength= ',&
    !     sRaleighLength

    DiffractionLength = SQRT(2.0_WP*&
         ((z/sRaleighLength)**2 + 1.0_WP)) * 6.0_WP*sigma

  END FUNCTION DiffractionLength

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

  FUNCTION RaleighLength(srho,sigma)

! sigma of the seed field

    IMPLICIT NONE

    REAL(KIND=WP),INTENT(IN) :: srho,sigma

    REAL(KIND=WP) :: RaleighLength

! BEGIN:-

    RaleighLength = sigma**2/(2.0_WP*srho)

  END FUNCTION RaleighLength

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

  function arr_mean_para(s_ar)

! Return the mean of an array of real values

    use ParallelSetUp

    implicit none

    real(kind=wp), intent(in) :: s_ar(:)
    real(kind=wp) :: arr_mean_para
    real(kind=wp) :: loc_sum, glob_sum

    loc_sum = sum(s_ar)  ! local sum

    call sum_mpi_real(loc_sum,glob_sum)  ! sum globally

    arr_mean_para = glob_sum / size(s_ar)  ! get mean

  end function arr_mean_para

  function arr_mean_para_weighted(s_ar, weights)

! Return the mean of an array of real values

    use ParallelSetUp

    implicit none

    real(kind=wp), intent(in) :: s_ar(:), weights(:)
    real(kind=wp) :: arr_mean_para_weighted
    real(kind=wp) :: loc_sum, glob_sum, glob_weight_sum, &
                     loc_weight_sum

    loc_sum = sum(weights * s_ar)  ! local sum
    loc_weight_sum = sum(weights)

    call sum_mpi_real(loc_sum,glob_sum)  ! sum globally
    call sum_mpi_real(loc_weight_sum,glob_weight_sum)  ! sum globally

    arr_mean_para_weighted = glob_sum / glob_weight_sum  ! get mean

  end function arr_mean_para_weighted

END MODULE Functions


! --------------------------------------------------------------------------
! drawgraph.f90
! Test graphmod module
! --------------------------------------------------------------------------
program DrawGraph
    use graphmod

    implicit none
    real, parameter :: PI = 3.1415927
    integer, parameter :: NPTS = 80
    integer :: i
    real :: dt, t
    real :: x(NPTS), y(NPTS)

    t = 0.0
    dt = PI/20.0

    do i=1, NPTS
        y(i) = exp(-0.05*t) * sin(t)
        x(i) = t
        t = t + dt
    end do

    call setwindow(0.0, 4*PI, -1.0, 1.0)
    call grapher(x, y, "#", "Damped Oscilliations")

end program DrawGraph


c=======================================================================
c
c     subroutine CORVOLM
c
c     Empirical Vorrelation matrix, Volatility and Mean vector
c
c-----------------------------------------------------------------------
c
c     INPUT :
c            ndate  : estimation period                          integer
c            nasset : size of portfolio                          integer
c            rasset : returns assets during the estimation period
c                     vectorized matrix (ndate*nasset)            double
c
c     WORKSPACE :
c            dwork  : vector( nasset*(ndate+nasset) )             double
c
c     OUTPUT :
c            rmean  : mean returns  vector(nasset)                double
c            volat  : volatilities  vector(nasset)                double
c            corr   : correlation matrix  vector(nasset*nasset)   double
c            info   : = 0 successful exit                        integer
c
c     CALL   :
c        MCM     : computing the mean of each column of
c                  a vectorized full matrix
c        EMPCOV  : computes the empiric covariance matrix
c
c-----------------------------------------------------------------------
c
      subroutine corvolm ( ndate, nasset, rasset, dwork,
     &                     rmean, volat, corr, info)
c
      implicit none
c
      integer ndate, nasset, info
      double precision rasset(*), rmean(*), volat(*), corr(nasset,*)
      double precision dwork(*)
c
c     local variables
      integer prel, pcov, i, j, kij, kii
      double precision EPS, val
      parameter ( EPS = 1.E-30 )
c
c-----------------------------------------------------------------------
c
c     initialisations
      info = 0
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      prel = 1
c     prel   : pointer for relatives rents, so ( ndate*nasset ) more
      pcov = prel + ndate*nasset
c     pcov   : pointer for vectorized matrix
c              so (nasset*nasset) more
c
c     Total size of dwork array = nasset*(ndate+nasset)
c
c-----------------------------------------------------------------------
c
c     computing means of rents
      call MCM ( ndate, nasset, rasset, rmean )
c
c     computing empiric covariance matrix
      call empcov ( ndate, nasset, rasset, rmean,
     &              dwork(prel), dwork(pcov), info )
      IF (info .LT. 0) RETURN
c
c     computing of square root of diagonal
      do i=1,nasset
         kii = pcov + (i-1)*(nasset+1)
         val = dwork(kii)
         if ( val .GT. EPS ) then
            volat(i)= SQRT(val)
         else
            info = -5
         end if
      end do
c
c     builds the empirical correlation matrix
      corr(1,1) = 1.
      do j=2,nasset
         do i=1,j
            kij = pcov + (i-1)*nasset + (j-1)
            corr(i,j) = dwork(kij)/( volat(i)*volat(j) )
            if ( i.ne.j )corr(j,i) = corr(i,j)
         end do
         corr(j,j) = 1.
      end do
c
      return
      end


*DECK HWSPLR
      SUBROUTINE HWSPLR (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND,
     +   BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W)
C***BEGIN PROLOGUE  HWSPLR
C***PURPOSE  Solve a finite difference approximation to the Helmholtz
C            equation in polar coordinates.
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A1A
C***TYPE      SINGLE PRECISION (HWSPLR-S)
C***KEYWORDS  ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, POLAR
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     Subroutine HWSPLR solves a finite difference approximation to the
C     Helmholtz equation in polar coordinates:
C
C          (1/R)(d/dR)(R(dU/dR)) + (1/R**2)(d/dTHETA)(dU/dTHETA)
C
C                                + LAMBDA*U = F(R,THETA).
C
C
C
C
C     * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C             * * * * * *   On Input    * * * * * *
C
C     A,B
C       The range of R, i.e., A .LE. R .LE. B.  A must be less than B
C       and A must be non-negative.
C
C     M
C       The number of panels into which the interval (A,B) is
C       subdivided.  Hence, there will be M+1 grid points in the
C       R-direction given by R(I) = A+(I-1)DR, for I = 1,2,...,M+1,
C       where DR = (B-A)/M is the panel width. M must be greater than 3.
C
C     MBDCND
C       Indicates the type of boundary condition at R = A and R = B.
C
C       = 1  If the solution is specified at R = A and R = B.
C       = 2  If the solution is specified at R = A and the derivative of
C            the solution with respect to R is specified at R = B.
C       = 3  If the derivative of the solution with respect to R is
C            specified at R = A (see note below) and R = B.
C       = 4  If the derivative of the solution with respect to R is
C            specified at R = A (see note below) and the solution is
C            specified at R = B.
C       = 5  If the solution is unspecified at R = A = 0 and the
C            solution is specified at R = B.
C       = 6  If the solution is unspecified at R = A = 0 and the
C            derivative of the solution with respect to R is specified
C            at R = B.
C
C       NOTE:  If A = 0, do not use MBDCND = 3 or 4, but instead use
C              MBDCND = 1,2,5, or 6  .
C
C     BDA
C       A one-dimensional array of length N+1 that specifies the values
C       of the derivative of the solution with respect to R at R = A.
C       When MBDCND = 3 or 4,
C
C            BDA(J) = (d/dR)U(A,THETA(J)), J = 1,2,...,N+1  .
C
C       When MBDCND has any other value, BDA is a dummy variable.
C
C     BDB
C       A one-dimensional array of length N+1 that specifies the values
C       of the derivative of the solution with respect to R at R = B.
C       When MBDCND = 2,3, or 6,
C
C            BDB(J) = (d/dR)U(B,THETA(J)), J = 1,2,...,N+1  .
C
C       When MBDCND has any other value, BDB is a dummy variable.
C
C     C,D
C       The range of THETA, i.e., C .LE. THETA .LE. D.  C must be less
C       than D.
C
C     N
C       The number of panels into which the interval (C,D) is
C       subdivided.  Hence, there will be N+1 grid points in the
C       THETA-direction given by THETA(J) = C+(J-1)DTHETA for
C       J = 1,2,...,N+1, where DTHETA = (D-C)/N is the panel width.  N
C       must be greater than 3.
C
C     NBDCND
C       Indicates the type of boundary conditions at THETA = C and
C       at THETA = D.
C
C       = 0  If the solution is periodic in THETA, i.e.,
C            U(I,J) = U(I,N+J).
C       = 1  If the solution is specified at THETA = C and THETA = D
C            (see note below).
C       = 2  If the solution is specified at THETA = C and the
C            derivative of the solution with respect to THETA is
C            specified at THETA = D (see note below).
C       = 4  If the derivative of the solution with respect to THETA is
C            specified at THETA = C and the solution is specified at
C            THETA = D (see note below).
C
C       NOTE:  When NBDCND = 1,2, or 4, do not use MBDCND = 5 or 6
C              (the former indicates that the solution is specified at
C              R = 0, the latter indicates the solution is unspecified
C              at R = 0).  Use instead MBDCND = 1 or 2  .
C
C     BDC
C       A one-dimensional array of length M+1 that specifies the values
C       of the derivative of the solution with respect to THETA at
C       THETA = C.  When NBDCND = 3 or 4,
C
C            BDC(I) = (d/dTHETA)U(R(I),C), I = 1,2,...,M+1  .
C
C       When NBDCND has any other value, BDC is a dummy variable.
C
C     BDD
C       A one-dimensional array of length M+1 that specifies the values
C       of the derivative of the solution with respect to THETA at
C       THETA = D.  When NBDCND = 2 or 3,
C
C            BDD(I) = (d/dTHETA)U(R(I),D), I = 1,2,...,M+1  .
C
C       When NBDCND has any other value, BDD is a dummy variable.
C
C     ELMBDA
C       The constant LAMBDA in the Helmholtz equation.  If
C       LAMBDA .LT. 0, a solution may not exist.  However, HWSPLR will
C       attempt to find a solution.
C
C     F
C       A two-dimensional array that specifies the values of the right
C       side of the Helmholtz equation and boundary values (if any).
C       For I = 2,3,...,M and J = 2,3,...,N
C
C            F(I,J) = F(R(I),THETA(J)).
C
C       On the boundaries F is defined by
C
C            MBDCND   F(1,J)            F(M+1,J)
C            ------   -------------     -------------
C
C              1      U(A,THETA(J))     U(B,THETA(J))
C              2      U(A,THETA(J))     F(B,THETA(J))
C              3      F(A,THETA(J))     F(B,THETA(J))
C              4      F(A,THETA(J))     U(B,THETA(J))   J = 1,2,...,N+1
C              5      F(0,0)            U(B,THETA(J))
C              6      F(0,0)            F(B,THETA(J))
C
C            NBDCND   F(I,1)            F(I,N+1)
C            ------   ---------         ---------
C
C              0      F(R(I),C)         F(R(I),C)
C              1      U(R(I),C)         U(R(I),D)
C              2      U(R(I),C)         F(R(I),D)   I = 1,2,...,M+1
C              3      F(R(I),C)         F(R(I),D)
C              4      F(R(I),C)         U(R(I),D)
C
C       F must be dimensioned at least (M+1)*(N+1).
C
C       NOTE
C
C       If the table calls for both the solution U and the right side F
C       at a corner then the solution must be specified.
C
C
C     IDIMF
C       The row (or first) dimension of the array F as it appears in the
C       program calling HWSPLR.  This parameter is used to specify the
C       variable dimension of F.  IDIMF must be at least M+1  .
C
C     W
C       A one-dimensional array that must be provided by the user for
C       work space.  W may require up to 4*(N+1) +
C       (13 + INT(log2(N+1)))*(M+1) locations.  The actual number of
C       locations used is computed by HWSPLR and is returned in location
C       W(1).
C
C
C             * * * * * *   On Output     * * * * * *
C
C     F
C       Contains the solution U(I,J) of the finite difference
C       approximation for the grid point (R(I),THETA(J)),
C       I = 1,2,...,M+1, J = 1,2,...,N+1  .
C
C     PERTRB
C       If a combination of periodic, derivative, or unspecified
C       boundary conditions is specified for a Poisson equation
C       (LAMBDA = 0), a solution may not exist.  PERTRB is a constant,
C       calculated and subtracted from F, which ensures that a solution
C       exists.  HWSPLR then computes this solution, which is a least
C       squares solution to the original approximation.  This solution
C       plus any constant is also a solution.  Hence, the solution is
C       not unique.  PERTRB should be small compared to the right side.
C       Otherwise, a solution is obtained to an essentially different
C       problem.  This comparison should always be made to insure that a
C       meaningful solution has been obtained.
C
C     IERROR
C       An error flag that indicates invalid input parameters.  Except
C       for numbers 0 and 11, a solution is not attempted.
C
C       =  0  No error.
C       =  1  A .LT. 0  .
C       =  2  A .GE. B.
C       =  3  MBDCND .LT. 1 or MBDCND .GT. 6  .
C       =  4  C .GE. D.
C       =  5  N .LE. 3
C       =  6  NBDCND .LT. 0 or .GT. 4  .
C       =  7  A = 0, MBDCND = 3 or 4  .
C       =  8  A .GT. 0, MBDCND .GE. 5  .
C       =  9  MBDCND .GE. 5, NBDCND .NE. 0 and NBDCND .NE. 3  .
C       = 10  IDIMF .LT. M+1  .
C       = 11  LAMBDA .GT. 0  .
C       = 12  M .LE. 3
C
C       Since this is the only means of indicating a possibly incorrect
C       call to HWSPLR, the user should test IERROR after the call.
C
C     W
C       W(1) contains the required length of W.
C
C *Long Description:
C
C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension of   BDA(N+1),BDB(N+1),BDC(M+1),BDD(M+1),F(IDIMF,N+1),
C     Arguments      W(see argument list)
C
C     Latest         June 1, 1976
C     Revision
C
C     Subprograms    HWSPLR,GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE,
C     Required       TRIX,TRI3,PIMACH
C
C     Special        None
C     Conditions
C
C     Common         NONE
C     Blocks
C
C     I/O
C
C     Precision      Single
C
C     Specialist     Roland Sweet
C
C     Language       FORTRAN
C
C     History        Standardized April 1, 1973
C                    Revised January 1, 1976
C
C     Algorithm      The routine defines the finite difference
C                    equations, incorporates boundary data, and adjusts
C                    the right side of singular systems and then calls
C                    GENBUN to solve the system.
C
C     Space          13430(octal) = 5912(decimal)  locations on the NCAR
C     Required       Control Data 7600
C
C     Timing and        The execution time T on the NCAR Control Data
C     Accuracy       7600 for subroutine HWSPLR is roughly proportional
C                    to M*N*log2(N), but also depends on the input
C                    parameters NBDCND and MBDCND.  Some typical values
C                    are listed in the table below.
C                       The solution process employed results in a loss
C                    of no more than three significant digits for N and
C                    M as large as 64.  More detailed information about
C                    accuracy can be found in the documentation for
C                    subroutine GENBUN which is the routine that
C                    solves the finite difference equations.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32        1         0          31
C                        32        1         1          23
C                        32        3         3          36
C                        64        1         0         128
C                        64        1         1          96
C                        64        3         3         142
C
C     Portability    American National Standards Institute FORTRAN.
C                    The machine dependent constant PI is defined in
C                    function PIMACH.
C
C     Required       COS
C     Resident
C     Routines
C
C     Reference      Swarztrauber, P. and R. Sweet, 'Efficient FORTRAN
C                    Subprograms For The Solution Of Elliptic Equations'
C                    NCAR TN/IA-109, July, 1975, 138 pp.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  P. N. Swarztrauber and R. Sweet, Efficient Fortran
C                 subprograms for the solution of elliptic equations,
C                 NCAR TN/IA-109, July 1975, 138 pp.
C***ROUTINES CALLED  GENBUN
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HWSPLR
C
C
      DIMENSION       F(IDIMF,*)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
C***FIRST EXECUTABLE STATEMENT  HWSPLR
      IERROR = 0
      IF (A .LT. 0.) IERROR = 1
      IF (A .GE. B) IERROR = 2
      IF (MBDCND.LE.0 .OR. MBDCND.GE.7) IERROR = 3
      IF (C .GE. D) IERROR = 4
      IF (N .LE. 3) IERROR = 5
      IF (NBDCND.LE.-1 .OR. NBDCND.GE.5) IERROR = 6
      IF (A.EQ.0. .AND. (MBDCND.EQ.3 .OR. MBDCND.EQ.4)) IERROR = 7
      IF (A.GT.0. .AND. MBDCND.GE.5) IERROR = 8
      IF (MBDCND.GE.5 .AND. NBDCND.NE.0 .AND. NBDCND.NE.3) IERROR = 9
      IF (IDIMF .LT. M+1) IERROR = 10
      IF (M .LE. 3) IERROR = 12
      IF (IERROR .NE. 0) RETURN
      MP1 = M+1
      DELTAR = (B-A)/M
      DLRBY2 = DELTAR/2.
      DLRSQ = DELTAR**2
      NP1 = N+1
      DELTHT = (D-C)/N
      DLTHSQ = DELTHT**2
      NP = NBDCND+1
C
C     DEFINE RANGE OF INDICES I AND J FOR UNKNOWNS U(I,J).
C
      MSTART = 2
      MSTOP = MP1
      GO TO (101,105,102,103,104,105),MBDCND
  101 MSTOP = M
      GO TO 105
  102 MSTART = 1
      GO TO 105
  103 MSTART = 1
  104 MSTOP = M
  105 MUNK = MSTOP-MSTART+1
      NSTART = 1
      NSTOP = N
      GO TO (109,106,107,108,109),NP
  106 NSTART = 2
      GO TO 109
  107 NSTART = 2
  108 NSTOP = NP1
  109 NUNK = NSTOP-NSTART+1
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
      ID2 = MUNK
      ID3 = ID2+MUNK
      ID4 = ID3+MUNK
      ID5 = ID4+MUNK
      ID6 = ID5+MUNK
      A1 = 2./DLRSQ
      IJ = 0
      IF (MBDCND.EQ.3 .OR. MBDCND.EQ.4) IJ = 1
      DO 110 I=1,MUNK
         R = A+(I-IJ)*DELTAR
         J = ID5+I
         W(J) = R
         J = ID6+I
         W(J) = 1./R**2
         W(I) = (R-DLRBY2)/(R*DLRSQ)
         J = ID3+I
         W(J) = (R+DLRBY2)/(R*DLRSQ)
         J = ID2+I
         W(J) = -A1+ELMBDA
  110 CONTINUE
      GO TO (114,111,112,113,114,111),MBDCND
  111 W(ID2) = A1
      GO TO 114
  112 W(ID2) = A1
  113 W(ID3+1) = A1
  114 CONTINUE
C
C     ENTER BOUNDARY DATA FOR R-BOUNDARIES.
C
      GO TO (115,115,117,117,119,119),MBDCND
  115 A1 = W(1)
      DO 116 J=NSTART,NSTOP
         F(2,J) = F(2,J)-A1*F(1,J)
  116 CONTINUE
      GO TO 119
  117 A1 = 2.*DELTAR*W(1)
      DO 118 J=NSTART,NSTOP
         F(1,J) = F(1,J)+A1*BDA(J)
  118 CONTINUE
  119 GO TO (120,122,122,120,120,122),MBDCND
  120 A1 = W(ID4)
      DO 121 J=NSTART,NSTOP
         F(M,J) = F(M,J)-A1*F(MP1,J)
  121 CONTINUE
      GO TO 124
  122 A1 = 2.*DELTAR*W(ID4)
      DO 123 J=NSTART,NSTOP
         F(MP1,J) = F(MP1,J)-A1*BDB(J)
  123 CONTINUE
C
C     ENTER BOUNDARY DATA FOR THETA-BOUNDARIES.
C
  124 A1 = 1./DLTHSQ
      L = ID5-MSTART+1
      LP = ID6-MSTART+1
      GO TO (134,125,125,127,127),NP
  125 DO 126 I=MSTART,MSTOP
         J = I+LP
         F(I,2) = F(I,2)-A1*W(J)*F(I,1)
  126 CONTINUE
      GO TO 129
  127 A1 = 2./DELTHT
      DO 128 I=MSTART,MSTOP
         J = I+LP
         F(I,1) = F(I,1)+A1*W(J)*BDC(I)
  128 CONTINUE
  129 A1 = 1./DLTHSQ
      GO TO (134,130,132,132,130),NP
  130 DO 131 I=MSTART,MSTOP
         J = I+LP
         F(I,N) = F(I,N)-A1*W(J)*F(I,NP1)
  131 CONTINUE
      GO TO 134
  132 A1 = 2./DELTHT
      DO 133 I=MSTART,MSTOP
         J = I+LP
         F(I,NP1) = F(I,NP1)-A1*W(J)*BDD(I)
  133 CONTINUE
  134 CONTINUE
C
C     ADJUST RIGHT SIDE OF EQUATION FOR UNKNOWN AT POLE WHEN HAVE
C     DERIVATIVE SPECIFIED BOUNDARY CONDITIONS.
C
      IF (MBDCND.GE.5 .AND. NBDCND.EQ.3)
     1    F(1,1) = F(1,1)-(BDD(2)-BDC(2))*4./(N*DELTHT*DLRSQ)
C
C     ADJUST RIGHT SIDE OF SINGULAR PROBLEMS TO INSURE EXISTENCE OF A
C     SOLUTION.
C
      PERTRB = 0.
      IF (ELMBDA) 144,136,135
  135 IERROR = 11
      GO TO 144
  136 IF (NBDCND.NE.0 .AND. NBDCND.NE.3) GO TO 144
      S2 = 0.
      GO TO (144,144,137,144,144,138),MBDCND
  137 W(ID5+1) = .5*(W(ID5+2)-DLRBY2)
      S2 = .25*DELTAR
  138 A2 = 2.
      IF (NBDCND .EQ. 0) A2 = 1.
      J = ID5+MUNK
      W(J) = .5*(W(J-1)+DLRBY2)
      S = 0.
      DO 140 I=MSTART,MSTOP
         S1 = 0.
         IJ = NSTART+1
         K = NSTOP-1
         DO 139 J=IJ,K
            S1 = S1+F(I,J)
  139    CONTINUE
         J = I+L
         S = S+(A2*S1+F(I,NSTART)+F(I,NSTOP))*W(J)
  140 CONTINUE
      S2 = M*A+DELTAR*((M-1)*(M+1)*.5+.25)+S2
      S1 = (2.+A2*(NUNK-2))*S2
      IF (MBDCND .EQ. 3) GO TO 141
      S2 = N*A2*DELTAR/8.
      S = S+F(1,1)*S2
      S1 = S1+S2
  141 CONTINUE
      PERTRB = S/S1
      DO 143 I=MSTART,MSTOP
         DO 142 J=NSTART,NSTOP
            F(I,J) = F(I,J)-PERTRB
  142    CONTINUE
  143 CONTINUE
  144 CONTINUE
C
C     MULTIPLY I-TH EQUATION THROUGH BY (R(I)*DELTHT)**2.
C
      DO 146 I=MSTART,MSTOP
         K = I-MSTART+1
         J = I+LP
         A1 = DLTHSQ/W(J)
         W(K) = A1*W(K)
         J = ID2+K
         W(J) = A1*W(J)
         J = ID3+K
         W(J) = A1*W(J)
         DO 145 J=NSTART,NSTOP
            F(I,J) = A1*F(I,J)
  145    CONTINUE
  146 CONTINUE
      W(1) = 0.
      W(ID4) = 0.
C
C     CALL GENBUN TO SOLVE THE SYSTEM OF EQUATIONS.
C
      CALL GENBUN (NBDCND,NUNK,1,MUNK,W(1),W(ID2+1),W(ID3+1),IDIMF,
     1             F(MSTART,NSTART),IERR1,W(ID4+1))
      IWSTOR = W(ID4+1)+3*MUNK
      GO TO (157,157,157,157,148,147),MBDCND
C
C     ADJUST THE SOLUTION AS NECESSARY FOR THE PROBLEMS WHERE A = 0.
C
  147 IF (ELMBDA .NE. 0.) GO TO 148
      YPOLE = 0.
      GO TO 155
  148 CONTINUE
      J = ID5+MUNK
      W(J) = W(ID2)/W(ID3)
      DO 149 IP=3,MUNK
         I = MUNK-IP+2
         J = ID5+I
         LP = ID2+I
         K = ID3+I
         W(J) = W(I)/(W(LP)-W(K)*W(J+1))
  149 CONTINUE
      W(ID5+1) = -.5*DLTHSQ/(W(ID2+1)-W(ID3+1)*W(ID5+2))
      DO 150 I=2,MUNK
         J = ID5+I
         W(J) = -W(J)*W(J-1)
  150 CONTINUE
      S = 0.
      DO 151 J=NSTART,NSTOP
         S = S+F(2,J)
  151 CONTINUE
      A2 = NUNK
      IF (NBDCND .EQ. 0) GO TO 152
      S = S-.5*(F(2,NSTART)+F(2,NSTOP))
      A2 = A2-1.
  152 YPOLE = (.25*DLRSQ*F(1,1)-S/A2)/(W(ID5+1)-1.+ELMBDA*DLRSQ*.25)
      DO 154 I=MSTART,MSTOP
         K = L+I
         DO 153 J=NSTART,NSTOP
            F(I,J) = F(I,J)+YPOLE*W(K)
  153    CONTINUE
  154 CONTINUE
  155 DO 156 J=1,NP1
         F(1,J) = YPOLE
  156 CONTINUE
  157 CONTINUE
      IF (NBDCND .NE. 0) GO TO 159
      DO 158 I=MSTART,MSTOP
         F(I,NP1) = F(I,1)
  158 CONTINUE
  159 CONTINUE
      W(1) = IWSTOR
      RETURN
      END


module funcs

use, intrinsic:: iso_fortran_env, only: stderr=>error_unit
use assert, only: wp, isclose
use bessel
use trig
use rat, only: ratnorm, rdiv, rsub, radd, rmul, isfrac, lcm, gcd, isint, isreal, iscomplex, isdigit, isrational, &
  dec_to_frac, frac_to_mixed
use hyper
use stats
use fgamma

implicit none (type, external)

interface cuberoot
procedure cuberoot_r, cuberoot_c
end interface cuberoot

interface frac
procedure frac_r, frac_c
end interface frac

interface sinc
procedure sinc_r, sinc_c
end interface sinc

interface tanc
procedure tanc_r, tanc_c
end interface tanc

real(wp), parameter, private :: xinf = huge(0._wp), xmax = xinf, xmin = tiny(0._wp)
complex(wp), parameter, private :: c0 = (0._wp, 0._wp)

contains

!***********************************************************************************************************************************
!  FRAC
!
!  Fractional part of a number.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION FRAC_r (X) RESULT (Y)

real(wp), INTENT(IN) :: X
real(wp) ::  Z

Z = ABS(X)
Y = Z - INT(Z)
Y = SIGN(Y,X)

END FUNCTION FRAC_r

elemental complex(wp) FUNCTION FRAC_c (X) result(frac)

COMPLEX(wp), INTENT(IN) :: X
real(wp) :: XR, XI, YR, YI, ZR, ZI

XR = real(X, wp)
XI = AIMAG(X)

ZR = ABS(XR)
YR = ZR - INT(ZR)
YR = SIGN(YR,XR)

ZI = ABS(XI)
YI = ZI - INT(ZI)
YI = SIGN(YI,XI)

FRAC = CMPLX(YR,YI, wp)

END FUNCTION FRAC_c

!***********************************************************************************************************************************
!  RFRAC
!
!  Rational FRAC.
!***********************************************************************************************************************************

elemental SUBROUTINE RFRAC (N, D, NR, DR)

INTEGER, INTENT(IN) :: N, D
INTEGER, INTENT(OUT) :: NR, DR
INTEGER :: NI, NA, DA

NA = ABS(N)
DA = ABS(D)
NI = RINT (NA, DA)
CALL RSUB (NA, DA, NI, 1, NR, DR)
NR = SIGN(NR,N)
CALL RATNORM (NR, DR)

END SUBROUTINE RFRAC

!***********************************************************************************************************************************
!  CINT
!
!  Complex INT.
!***********************************************************************************************************************************

elemental complex(wp) FUNCTION CINT (X) RESULT (Y)

COMPLEX(wp), INTENT(IN) :: X

real(wp) :: YR, YI

YR = AINT(DBLE(X))
YI = AINT(AIMAG(X))
Y = CMPLX(YR,YI, wp)

END FUNCTION CINT

!***********************************************************************************************************************************
!  RINT
!
!  Rational INT.
!***********************************************************************************************************************************

elemental integer FUNCTION RINT (N, D) RESULT (R)

INTEGER, INTENT(IN) :: N, D
INTEGER :: NN, DN

NN = N
DN = D
CALL RATNORM (NN, DN)
R = NN / DN

END FUNCTION RINT

!***********************************************************************************************************************************
!  RNINT
!
!  Rational NINT.
!***********************************************************************************************************************************

elemental SUBROUTINE RNINT (N, D)

INTEGER, INTENT(IN OUT) :: N, D
INTEGER :: NN, DN, TN, TD

NN = N
DN = D
CALL RATNORM (NN, DN)

IF (NN .GE. 0) THEN
   CALL RADD (NN, DN, 1, 2, TN, TD)
   N = TN / TD
   D = 1
ELSE
   CALL RSUB (NN, DN, 1, 2, TN, TD)
   N = TN / TD
   D = 1
END IF

END SUBROUTINE RNINT

!***********************************************************************************************************************************
!  CMOD
!
!  Complex MOD.
!***********************************************************************************************************************************

elemental complex(wp) FUNCTION CMOD (X,Y) RESULT (Z)

COMPLEX(wp), INTENT(IN) :: X, Y

Z = X - CINT(X/Y)*Y

END FUNCTION CMOD

!***********************************************************************************************************************************
!  RMOD
!
!  Rational MOD.
!***********************************************************************************************************************************

elemental SUBROUTINE RMOD (N1, D1, N2, D2, NR, DR)

INTEGER, INTENT(IN) :: N1, D1, N2, D2
INTEGER, INTENT(OUT) :: NR, DR
INTEGER :: NAN, DAN, NBN, DBN, NT, DT, ITMP

NAN = N1
DAN = D1

NBN = N2
DBN = D2

CALL RATNORM (NAN,DAN)
CALL RATNORM (NBN,DBN)

CALL RDIV (NAN, DAN, NBN, DBN, NT, DT)
ITMP = RINT (NT, DT)
CALL RMUL (ITMP, 1, NBN, DBN, NT, DT)
CALL RSUB (NAN, DAN, NT, DT, NR, DR)
CALL RATNORM (NR, DR)

END SUBROUTINE RMOD

!***********************************************************************************************************************************
!  CUBEROOT
!
!  Computes the cube root.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION CUBEROOT_r(X)  result(cuberoot)
real(wp), INTENT(IN) :: X

 CUBEROOT = SIGN((ABS(X))**(1._wp / 3._wp),X)

END FUNCTION CUBEROOT_r

elemental complex(wp) FUNCTION CUBEROOT_c (Z) result(cuberoot)
COMPLEX(wp), INTENT(IN) :: Z

 CUBEROOT = Z**(1._wp / 3._wp)
END FUNCTION CUBEROOT_c

!***********************************************************************************************************************************
!  CLOG10
!
!  Complex common logarithm.
!***********************************************************************************************************************************

elemental complex(wp) FUNCTION CLOG10 (X)

COMPLEX(wp), INTENT(IN) :: X

 CLOG10 = LOG(X) / LOG(10._wp)

END FUNCTION CLOG10

elemental real(wp) FUNCTION LOG1P (X) RESULT (Y)
!  Compute log(1+x).
real(wp), INTENT(IN) :: X
real(wp) :: Z

Z = 1._wp + X
Y = LOG(Z) - ((Z-1._wp)-X) / Z                ! cancels errors with IEEE arithmetic

END FUNCTION LOG1P

elemental real(wp) FUNCTION SINC_r(X) result(sinc)
!  Sine cardinal (sinc) function.
real(wp), INTENT(IN) :: X

IF (isclose(x, 0._wp)) THEN
   sinc = 1._wp
ELSE
   sinc = SIN(X)/X
END IF
END FUNCTION SINC_r

elemental complex(wp) FUNCTION SINC_c (Z) RESULT (sinc)
!  Complex sine cardinal (sinc) function.
COMPLEX(wp), INTENT(IN) :: Z

IF (isclose(z, c0)) THEN
   sinc = (1._wp, 0._wp)
ELSE
   sinc = SIN(Z)/Z
END IF
END FUNCTION SINC_c

elemental real(wp) FUNCTION TANC_r(X) RESULT (tanc)
!  Tanc function.
real(wp), INTENT(IN) :: X

IF (isclose(x, 0._wp)) THEN
   tanc = 1._wp
ELSE
   tanc = TAN(X)/X
END IF
END FUNCTION TANC_r

elemental complex(wp) FUNCTION TANC_c (Z) RESULT (tanc)
!  Complex tanc function.
COMPLEX(wp), INTENT(IN) :: Z

IF (isclose(z, c0)) THEN
   tanc = (1._wp, 0._wp)
ELSE
   tanc = TAN(Z)/Z
END IF
END FUNCTION TANC_c

elemental real(wp) FUNCTION SINHC (X) RESULT (Y)
!  Sinhc function.
real(wp), INTENT(IN) :: X

IF (isclose(x, 0._wp)) THEN
   Y = 1._wp
ELSE
   Y = SINH(X)/X
END IF
END FUNCTION SINHC

elemental complex(wp) FUNCTION CSINHC (Z) RESULT (Y)
!  Complex sinhc function.
COMPLEX(wp), INTENT(IN) :: Z

IF (isclose(z, c0)) THEN
   Y = (1._wp,0._wp)
ELSE
   Y = SINH(Z)/Z
END IF
END FUNCTION CSINHC

!***********************************************************************************************************************************
!  TANHC
!
!  Tanhc function.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION TANHC (X) RESULT (Y)

real(wp), INTENT(IN) :: X

IF (X .EQ. 0._wp) THEN
   Y = 1._wp
ELSE
   Y = TANH(X) / X
END IF

END FUNCTION TANHC

!***********************************************************************************************************************************
!  CTANHC
!
!  Complex tanhc function.
!***********************************************************************************************************************************

elemental complex(wp) FUNCTION CTANHC (Z) RESULT (Y)

COMPLEX(wp), INTENT(IN) :: Z

IF (Z .EQ. (0._wp, 0._wp)) THEN
   Y = (1._wp, 0._wp)
ELSE
   Y = TANH(Z) / Z
END IF

END FUNCTION CTANHC

!***********************************************************************************************************************************
!  ERROR FUNCTIONS
!
!  From http://www.netlib.org/specfun
!
!  DERFCX
!***********************************************************************************************************************************

elemental real(wp) FUNCTION ERFCX(X)
real(wp), intent(in) :: X

erfcx = exp(x*x)*erfc(x)
END FUNCTION ERFCX

!***********************************************************************************************************************************
!  H2HMSD
!
!  Convert decimal hours to hours, minutes, and seconds. Seconds are returned as a real value.
!***********************************************************************************************************************************

elemental SUBROUTINE H2HMSD (DHR, IHR, IMIN, SEC)

real(wp), INTENT(IN) :: DHR
INTEGER, INTENT(OUT) :: IHR, IMIN
real(wp), INTENT(OUT) :: SEC
real(wp) :: TIME

TIME = DHR                                                                    ! hours
IHR = INT(TIME)                                                               ! hours
TIME = 60.0D0 * (TIME - IHR)                                                  ! minutes
IMIN = INT(TIME)                                                              ! minutes
SEC = 60.0D0 * (TIME - IMIN)                                                  ! seconds

END SUBROUTINE H2HMSD

!***********************************************************************************************************************************
!  HMS2H
!
!  Convert hours, minutes, and seconds to decimal hours.
!***********************************************************************************************************************************

elemental SUBROUTINE HMS2H (IHR, IMIN, SEC, DHR)

INTEGER, INTENT(IN) :: IHR, IMIN
real(wp), INTENT(IN) :: SEC
real(wp), INTENT(OUT) :: DHR

DHR = DBLE(IHR) + DBLE(IMIN)/60.0D0 + SEC/3600.0D0

END SUBROUTINE HMS2H

!***********************************************************************************************************************************
!  RIEMANNZETA
!
!  Riemann zeta function.
!
!  Algorithm from "Atlas for Computing Mathematical Functions" by W.J. Thompson, Wiley, 1997.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION RIEMANNZETA (S,EPS)

!     Riemann zeta - 1  for  x > 1

real(wp), INTENT(IN) :: S, EPS

real(wp) :: NSTERM, SUM, FN, NEGS
INTEGER :: N,K

!     Estimate N for accuracy  eps

NSTERM = S*(S+1.0D00)*(S+2.0D00)* &
  (S+3.0D00)*(S+4.0D00)/30240.0D00
N = int((NSTERM*(2.0D00**S)/EPS)**(1._wp/(S+5.0D00)))
IF ( N < 10 )  THEN
   N = 10
END IF

FN = N
NEGS = -S
!     Direct sum
SUM = 0.0D00
DO K =2, N-1
   SUM = SUM+K**NEGS
END DO

!     Add Euler-Maclaurin correction terms
SUM = SUM+(FN**NEGS)*(0.5D00+FN/(S-1.0D00) &
  +S*(1._wp-(S+ 1._wp)*(S+2.0D00)/ &
  (60.0D00*FN*FN)) &
  /(12.0D00*FN))+NSTERM/(FN**(S+5.0D00))
riemannZETA = SUM

END FUNCTION RIEMANNZETA

!***********************************************************************************************************************************
!  REDUCE
!
!  Reduce an angle to the range [angle_min, angle_max).
!***********************************************************************************************************************************

elemental real(wp) FUNCTION REDUCE (THETA, ANGLE_MIN) RESULT (RHO)

real(wp), PARAMETER :: tau = 2*4._wp*atan(1._wp)

real(wp), INTENT(IN) :: THETA
real(wp), INTENT(IN) :: ANGLE_MIN

real(wp) :: ANGLE_MAX
real(wp) :: REVS

!
!     Start of code.
!

ANGLE_MAX = ANGLE_MIN + tau

IF (THETA .LT. ANGLE_MIN) THEN
   REVS = AINT((ANGLE_MIN-THETA)/tau) + 1
   RHO = THETA + REVS*tau
ELSE IF (THETA .GE. ANGLE_MAX) THEN
   REVS = AINT((THETA-ANGLE_MIN)/tau)
   RHO = THETA - REVS*tau
ELSE
   RHO = THETA
END IF

END FUNCTION REDUCE

!***********************************************************************************************************************************
!  KEPLER
!
!  Solves the elliptical Kepler's equation by the Markley method.
!***********************************************************************************************************************************

elemental real(wp) FUNCTION KEPLER (MA, ECC) RESULT (E5)

real(wp), INTENT(IN) :: MA
real(wp), INTENT(IN) :: ECC

!     Parameters.
!
!     PI           = PI
!     tau        = 2*PI
!     PI_SQR       = PI**2
!     ONEP6_PI     = 1.6*PI
!     TWO_THIRDS   = 2/3
!     SIXTH        = 1/6
!     R24          = 1/24
!

real(wp), PARAMETER :: PI = 4._wp * atan(1._wp)

!
!     Other variables.
!

real(wp) :: ALPHA, D, Q, R, W, E1
real(wp) :: F, F1, F2, F3, F4, DELTA3, DELTA4, DELTA5
real(wp) :: SE, M

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

!
!     Start of code.
!
!     Put M in the range [-PI, PI) (required by the method).
!

M = REDUCE (MA, -PI)

!
!     Compute parameters.
!

ALPHA = (3*pi**2 + 1.6_wp*pi*(PI-ABS(M))/(1._wp+ECC)) / (pi**2 - 6.0D0)
D = 3.0D0*(1._wp-ECC) + ALPHA*ECC
Q = 2.0D0*ALPHA*D*(1._wp-ECC)-M**2
R = 3.0D0*ALPHA*D*(D-1.0D0+ECC)*M + M**3
W = (ABS(R) + SQRT(Q**3 + R**2)) ** (2._wp / 3._wp)

!
!     Compute first-order solution to Kepler's Equation (E1).
!

E1 = (2._wp*R*W/(W**2 + W*Q + Q**2) + M) / D

!
!     Save SIN(E1) into SE so we only have to evaluate it once.
!

SE = SIN(E1)

!
!     Find
!           F(E) = E - E SIN E - M
!
!     and its derivatives, through fourth order.
!

F  = E1 - ECC*SE - M
F1 = 1._wp - ECC*COS(E1)
F2 = ECC*SE
F3 = 1._wp - F1
F4 = -F2

!
!     Compute 3rd, 4th, and 5th-order corrections to E1.
!

DELTA3 = -F/(F1-0.5D0*F*F2/F1)
DELTA4 = -F/(F1+0.5D0*DELTA3*F2+ DELTA3**2*F3 / 6._wp)
DELTA5 = -F/(F1+0.5D0*DELTA4*F2+ DELTA4**2*F3 / 6._wp + DELTA4**3*F4 / 24._wp)

!
!     Find fifth-order refined estimate of E (E5).
!

E5 = E1 + DELTA5

!
!     Put E5 in the range [0, 2*PI) and return.
!

E5 = REDUCE (E5, 0._wp)

END FUNCTION KEPLER

elemental function toLower(str)
! Michael Hirsch
! can be trivially extended to non-ASCII
  character(*), intent(in) :: str
  character(len(str)) :: toLower
  character(*), parameter :: lower="abcdefghijklmnopqrstuvwxyz", &
                             upper="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  integer :: i,j

  toLower = str

  !do concurrent (i = 1:len(str)) ! FIXME: Flang
  do i=1,len(str)
    j = index(upper,str(i:i))
    if (j > 0) toLower(i:i) = lower(j:j)
  end do

end function toLower

elemental function toUpper(str)
! Michael Hirsch
! can be trivially extended to non-ASCII
  character(*), intent(in) :: str
  character(len(str)) :: toUpper
  character(*), parameter :: lower="abcdefghijklmnopqrstuvwxyz", &
                             upper="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  integer :: i,j

  toUpper = str

  !do concurrent (i = 1:len(str))  ! FIXME: Flang
  do i = 1,len(str)
    j = index(lower,str(i:i))
    if (j > 0) toUpper(i:i) = upper(j:j)
  end do

end function toUpper

end module funcs


subroutine euler(neq, tin, tout, nsteps, yin, yout)
  implicit none

  integer :: i
  integer, intent(in) :: neq, nsteps
  double precision :: yout(neq), f(neq), dt
  double precision, intent(in) :: tin, tout, yin(neq)

  yout = yin
  dt = ((tout - tin)/dble(nsteps))

  do i = 0, (nsteps - 1)
    call computef(neq, (tin + dble(i) * dt), yout, f)
    yout = (yout + dt * f)
  end do

  return
end


* GaussPivot.F
* Solution of the linear equation A.x = B by Gaussian elimination
* with partial pivoting
* this file is part of LoopTools
* last modified 24 Jan 06 th

* Author: Michael Rauch, 7 Dec 2004
* Reference: Folkmar Bornemann, course notes to
* Numerische Mathematik 1, Technische Universitaet, Munich, Germany

*#include "defs.h"

*#define MAXDIM 8

************************************************************************
* LUDecomp computes the LU decomposition of the n-by-n matrix A
* by Gaussian Elimination with partial pivoting;
* compact (in situ) storage scheme
* Input:
*   A: n-by-n matrix to LU-decompose
*   n: dimension of A
* Output:
*   A: mangled LU decomposition of A in the form
*     ( y11 y12 ... y1n )
*     ( x21 y22 ... y2n )
*     ( x31 x32 ... y3n )
*     ( ............... )
*     ( xn1 xn2 ... ynn )
*   where
*     (   1   0 ...   0 )  ( y11 y12 ... y1n )
*     ( x21   1 ...   0 )  (   0 y22 ... y2n )
*     ( x31 x32 ...   0 )  (   0   0 ... y3n )  =  Permutation(A)
*     ( ............... )  ( ............... )
*     ( xn1 xn2 ...   1 )  (   0   0 ... ynn )
*   perm: permutation vector

      subroutine XLUDecomp(A, n, perm)
      implicit none
      integer n, perm(n)
      double complex A(n,n)

      integer i, j, k, imax
      double complex tmp,czip
      double precision Amax
      parameter(czip=(0d0,0d0))
      do j = 1, n
* do U part (minus diagonal one)
        do i = 1, j - 1
          do k = 1, i - 1
            A(i,j) = A(i,j) - A(i,k)*A(k,j)
          enddo
        enddo

* do L part (plus diagonal from U case)
        Amax = 0d0
        imax = j
        do i = j, n
          tmp = czip
          do k = 1, j - 1
            tmp = tmp + A(i,k)*A(k,j)
          enddo
          A(i,j) = A(i,j) - tmp

* do partial pivoting ...
* find the pivot
          if( abs(A(i,j)) .gt. Amax ) then
            Amax = abs(A(i,j))
            imax = i
          endif
        enddo

* exchange rows
        perm(j) = imax
        do k = 1, n
          tmp = A(j,k)
          A(j,k) = A(imax,k)
          A(imax,k) = tmp
        enddo

* division by the pivot element
        if( A(j,j) .eq. czip ) then
          tmp = dcmplx(1D123)
        else
          tmp = 1/A(j,j)
        endif
        do i = j + 1, n
          A(i,j) = A(i,j)*tmp
        enddo
      enddo
      end

************************************************************************
* LUBackSubst computes the x in A.x = b from the LU-decomposed A.
* Input:
*   A: LU-decomposed n-by-n matrix A
*   b: input vector b in A.x = b
*   n: dimension of A
*   p: permutation vector from LU decomposition
* Output:
*   b: solution vector x in A.x = b

      subroutine XLUBackSubst(A, n, p, b)
      implicit none
      integer n, p(n)
      double complex A(n,n)
      double complex b(*)

      integer i, j
      double complex tmp

* permute b
      do i = 1, n
        tmp = b(i)
        b(i) = b(p(i))
        b(p(i)) = tmp
      enddo

* forward substitution L.Y = B
      do i = 1, n
        do j = 1, i - 1
          b(i) = b(i) - A(i,j)*b(j)
        enddo
      enddo

* backward substitution U.X = Y
      do i = n, 1, -1
        do j = i + 1, n
          b(i) = b(i) - A(i,j)*b(j)
        enddo
        b(i) = b(i)/A(i,i)
      enddo
      end


	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves nonlinear Schrodinger equation in 1 dimension
	! i*u_t+Es*|u|^2u+u_{xx}=0
	! using a second order time spectral splitting scheme
	!
	! The boundary conditions are u(0)=u(2*L*\pi)
	! The initial condition is u=exp(-x^2)
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Nt				= number of timesteps to take
	!  Tmax				= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  FFTW_IN_PLACE 	= value for FFTW input
	!  FFTW_MEASURE 	= value for FFTW input
	!  FFTW_EXHAUSTIVE 	= value for FFTW input
	!  FFTW_PATIENT 	= value for FFTW input
	!  FFTW_ESTIMATE 	= value for FFTW input
	!  FFTW_FORWARD     = value for FFTW input
	!  FFTW_BACKWARD	= value for FFTW input
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  L				= width of box
	!  ES				= +1 for focusing and -1 for defocusing
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  planfx			= Forward 1d fft plan in x
	!  planbx			= Backward 1d fft plan in x
	!  dt				= timestep
	! .. Arrays ..
	!  u				= approximate solution
	!  v				= Fourier transform of approximate solution
	! .. Vectors ..
	!  una 				= temporary field
	!  unb 				= temporary field
	!  vna 				= temporary field
	!  pot 				= potential
	!  kx				= fourier frequencies in x direction
	!  x				= x locations
	!  time				= times at which save data
	!  name_config		= array to store filename for data to be saved
	!  fftfx			= array to setup x Fourier transform
	!  fftbx			= array to setup x Fourier transform
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)

	PROGRAM main

	! Declare variables
	IMPLICIT NONE
	INTEGER(kind=4), PARAMETER 	:: Nx=8*256
	INTEGER(kind=4), PARAMETER	:: Nt=200
	REAL(kind=8), PARAMETER		&
		::  pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER	:: L=5.0d0
	REAL(kind=8), PARAMETER	:: Es=1.0d0
	REAL(kind=8)	:: dt=2.0d0/Nt
	COMPLEX(kind=8),  DIMENSION(:), ALLOCATABLE	:: kx
	REAL(kind=8),  DIMENSION(:), ALLOCATABLE	:: x
	COMPLEX(kind=8),  DIMENSION(:,:), ALLOCATABLE	:: u
	COMPLEX(kind=8),  DIMENSION(:,:), ALLOCATABLE	:: v
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE	:: una,vn
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE	:: unb,pot
	REAL(kind=8), DIMENSION(:), ALLOCATABLE		:: time
	INTEGER(kind=4)	:: i,j,k,n,modes,AllocateStatus
	INTEGER(kind=4)	:: start, finish, count_rate
	INTEGER(kind=4), PARAMETER	:: FFTW_IN_PLACE = 8, FFTW_MEASURE = 0, &
		FFTW_EXHAUSTIVE = 8, FFTW_PATIENT = 32, FFTW_ESTIMATE = 64
	INTEGER(kind=4), PARAMETER  :: FFTW_FORWARD = -1, FFTW_BACKWARD=1
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE	:: fftfx,fftbx
	INTEGER(kind=8)	:: planfx,planbx
  	CHARACTER*100	:: name_config

	CALL system_clock(start,count_rate)
	ALLOCATE(kx(1:Nx),x(1:Nx),u(1:Nx,1:Nt+1),v(1:Nx,1:Nt+1),&
		una(1:Nx),vn(1:Nx),unb(1:Nx),pot(1:Nx),time(1:Nt+1),&
		fftfx(1:Nx),fftbx(1:Nx),stat=AllocateStatus)
	IF (allocatestatus .ne. 0) STOP
	! set up ffts
	CALL dfftw_plan_dft_1d_(planfx,Nx,fftfx(1:Nx),fftbx(1:Nx),&
		FFTW_FORWARD,FFTW_PATIENT)
	CALL dfftw_plan_dft_1d_(planbx,Nx,fftbx(1:Nx),fftfx(1:Nx),&
		FFTW_BACKWARD,FFTW_PATIENT)
	PRINT *,'Setup FFTs'
		! setup fourier frequencies
	DO i=1,1+Nx/2
		kx(i)= cmplx(0.0d0,1.0d0)*(i-1.0d0)/L
	END DO
	kx(1+Nx/2)=0.0d0
	DO i = 1,Nx/2 -1
		kx(i+1+Nx/2)=-kx(1-i+Nx/2)
	END DO
	DO i=1,Nx
		x(i)=(-1.0d0 + 2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)))*pi*L
	END DO
	PRINT *,'Setup grid and fourier frequencies'

	DO i=1,Nx
		u(i,1)=exp(-1.0d0*(x(i)**2))
	END DO
	! transform initial data
	CALL dfftw_execute_dft_(planfx,u(1:Nx,1),v(1:Nx,1))
	PRINT *,'Got initial data, starting timestepping'
	time(1)=0.0d0
	DO n=1,Nt
		time(n+1)=n*dt
		DO i=1,Nx
			vn(i)=exp(0.5d0*dt*kx(i)*kx(i)*cmplx(0.0d0,1.0d0))*v(i,n)
		END DO
		CALL dfftw_execute_dft_(planbx,vn(1:Nx),una(1:Nx))
		! normalize
		DO i=1,Nx
			una(i)=una(1:Nx)/REAL(Nx,kind(0d0))
			pot(i)=Es*una(i)*conjg(una(i))
			unb(i)=exp(cmplx(0.0d0,-1.0d0)*dt*pot(i))*una(i)
		END DO
		CALL dfftw_execute_dft_(planfx,unb(1:Nx),vn(1:Nx))
		DO i=1,Nx
			v(i,n+1)=exp(0.50d0*dt*kx(i)*kx(i)*cmplx(0.0d0,1.0d0))*vn(i)
		END DO
		CALL dfftw_execute_dft_(planbx,v(1:Nx,n+1),u(1:Nx,n+1))
		! normalize
		DO i=1,Nx
			u(i,n+1)=u(i,n+1)/REAL(Nx,kind(0d0))
		END DO
	END DO
	PRINT *,'Finished time stepping'
	CALL system_clock(finish,count_rate)
	PRINT*,'Program took ',&
		REAL(finish-start,kind(0d0))/REAL(count_rate,kind(0d0)),'for execution'

	name_config = 'u.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Nt
		DO i=1,Nx
			WRITE(11,*) abs(u(i,j))**2
		END DO
	END DO
	CLOSE(11)

	name_config = 'tdata.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Nt
		WRITE(11,*) time(j)
	END DO
	CLOSE(11)

	name_config = 'xcoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO i=1,Nx
		WRITE(11,*) x(i)
	END DO
	CLOSE(11)

	PRINT *,'Saved data'

	CALL dfftw_destroy_plan_(planbx)
	CALL dfftw_destroy_plan_(planfx)
	CALL dfftw_cleanup_()

	DEALLOCATE(kx,x,u,v,una,vn,unb,&
				pot,time,fftfx,fftbx,&
	   			stat=AllocateStatus)
	IF (allocatestatus .ne. 0) STOP
	PRINT *,'deallocated memory'
	PRINT *,'Program execution complete'
	END PROGRAM main


program main

  implicit none

  integer, parameter :: sp = selected_real_kind(6)
  integer, parameter :: dp = selected_real_kind(15)
  integer, parameter :: n = 650, m = 700, p = 750
  real(kind=dp) :: a(n, m), b(m, p), c(n, p)
  real(kind=dp) :: val, err
  real :: tic, toc, dt

  integer :: i, j, k

  call random_number(a)
  call random_number(b)

  call cpu_time(tic)
  do i = 1, n
     do j = 1, p
        val = 0d0
        do k = 1, m
           val = val + a(i, k) * b(k, j)
        enddo
        c(i, j) = val
     enddo
  enddo
  call cpu_time(toc)
  dt = toc - tic

  err = maxval(abs(matmul(a, b) - c))
  print '(a, 1pes23.16, a, f8.4)', 'max error occured = ', err, &
        '; dt [sec] = ', toc - tic

end program main


    PROGRAM Testo
     USE Integer_Complex_Arithmetic
      IMPLICIT NONE
      TYPE(INTCOMPLEX) :: var1, var2, ans

       var1 = INTCOMPLEX(1,2)
       var2 = INTCOMPLEX(3,4)

       PRINT*, "(1,2)+(3,4)"
       ans = var1 + var2
       PRINT*, "Answer is ", ans
       PRINT*, ""

       PRINT*, "(1,2)-(3,4)"
       ans = var1 - var2
       PRINT*, "Answer is ", ans
       PRINT*, ""

       PRINT*, "(1,2)/(3,4)"
       ans = var1 / var2
       PRINT*, "Answer is ", ans
       PRINT*, ""

       PRINT*, "(3,4)/(3,4)"
       ans = var2 / var2
       PRINT*, "Answer is ", ans
       PRINT*, ""

       PRINT*, "(3,4)/(1,2)"
       ans = var2 / var1
       PRINT*, "Answer is ", ans
       PRINT*, ""

       PRINT*, "(1,2)*(3,4)"
       ans = var1 * var2
       PRINT*, "Answer is ", ans
       PRINT*, ""

       PRINT*, "(1,2)**3"
       ans = var1 ** 3
       PRINT*, "Answer is ", ans
       PRINT*, ""

       PRINT*, "+(1,2)"
       ans = +var1
       PRINT*, "Answer is ", ans
       PRINT*, ""

       PRINT*, "-(1,2)"
       ans = -var1
       PRINT*, "Answer is ", ans
       PRINT*, ""

       PRINT*, "(1,2)/(3,4)"
       ans = var1 / var2
       PRINT*, "Answer is ", ans
       PRINT*, ""

       PRINT*, "REAL(3,4)"
       PRINT*, REAL(INTCOMPLEX(3,4))
       PRINT*, ""

       PRINT*, "INT(3,4)"
       PRINT*, INT(INTCOMPLEX(3,4))
       PRINT*, ""

       PRINT*, "AIMAG(3,4)"
       PRINT*, AIMAG(INTCOMPLEX(3,4))
       PRINT*, ""

       PRINT*, "CONJG(3,4)"
       PRINT*, CONJG(INTCOMPLEX(3,4))
       PRINT*, ""

       PRINT*, "ABS(3,4)"
       PRINT*, ABS(INTCOMPLEX(3,4))

    END PROGRAM Testo