submodule (stdlib_quadrature) stdlib_quadrature_simps
    use stdlib_error, only: check
    implicit none

    ! internal use only
    interface simps38
        module procedure simps38_dx_sp
        module procedure simps38_x_sp
        module procedure simps38_dx_dp
        module procedure simps38_x_dp
        module procedure simps38_dx_qp
        module procedure simps38_x_qp
    end interface simps38

    ! internal use only
    interface simps38_weights
        module procedure simps38_weights_sp
        module procedure simps38_weights_dp
        module procedure simps38_weights_qp
    end interface simps38_weights

contains

    pure recursive module function simps_dx_sp(y, dx, even) result(integral)
        real(sp), dimension(:), intent(in) :: y
        real(sp), intent(in) :: dx
        integer, intent(in), optional :: even
        real(sp) :: integral

        integer :: n

        n = size(y)

        select case (n)
        case (0:1)
            integral = 0.0_sp
        case (2)
            integral = 0.5_sp*dx*(y(1) + y(2))
        case (3)
            integral = dx/3.0_sp*(y(1) + 4*y(2) + y(3))
        case (4)
            integral = simps38(y, dx)
        ! case (5) not needed; handled by default
        case (6) ! needs special handling because of averaged 3/8's rule case
            if (present(even)) then
                if (even < 0) then
                    ! 3/8 rule on left
                    integral =  simps38(y(1:4), dx) + simps(y(4:6), dx)
                    return
                else if (even > 0) then
                    ! 3/8 rule on right
                    integral = simps(y(1:3), dx) + simps38(y(3:6), dx)
                    return
                else
                    ! fall through
                end if
            end if
            ! either `even` not present or is zero
            ! equivalent to averaging left and right
            integral = dx/48.0_sp * (17*(y(1) + y(6)) + 59*(y(2) + y(5)) + 44*(y(3) + y(4)))
        case default
            if (mod(n, 2) == 1) then
                integral = dx/3.0_sp*(y(1) + 4*sum(y(2:n-1:2)) + 2*sum(y(3:n-2:2)) + y(n))
            else
                if (present(even)) then
                    if (even < 0) then
                        ! 3/8th rule on left
                        integral = simps38(y(1:4), dx) + simps(y(4:n), dx)
                        return
                    else if (even > 0) then
                        ! 3/8 rule on right
                        integral = simps(y(1:n-3), dx) + simps38(y(n-3:n), dx)
                        return
                    else
                        ! fall through
                    end if
                end if
                ! either `even` not present or is zero
                ! equivalent to averaging left and right
                integral = dx/48.0_sp * (17*(y(1) + y(n)) + 59*(y(2) + y(n-1)) &
                        + 43*(y(3) + y(n-2)) + 49*(y(4) + y(n-3)) + 48*sum(y(5:n-4)))
            end if
        end select
    end function simps_dx_sp

    pure recursive module function simps_dx_dp(y, dx, even) result(integral)
        real(dp), dimension(:), intent(in) :: y
        real(dp), intent(in) :: dx
        integer, intent(in), optional :: even
        real(dp) :: integral

        integer :: n

        n = size(y)

        select case (n)
        case (0:1)
            integral = 0.0_dp
        case (2)
            integral = 0.5_dp*dx*(y(1) + y(2))
        case (3)
            integral = dx/3.0_dp*(y(1) + 4*y(2) + y(3))
        case (4)
            integral = simps38(y, dx)
        ! case (5) not needed; handled by default
        case (6) ! needs special handling because of averaged 3/8's rule case
            if (present(even)) then
                if (even < 0) then
                    ! 3/8 rule on left
                    integral =  simps38(y(1:4), dx) + simps(y(4:6), dx)
                    return
                else if (even > 0) then
                    ! 3/8 rule on right
                    integral = simps(y(1:3), dx) + simps38(y(3:6), dx)
                    return
                else
                    ! fall through
                end if
            end if
            ! either `even` not present or is zero
            ! equivalent to averaging left and right
            integral = dx/48.0_dp * (17*(y(1) + y(6)) + 59*(y(2) + y(5)) + 44*(y(3) + y(4)))
        case default
            if (mod(n, 2) == 1) then
                integral = dx/3.0_dp*(y(1) + 4*sum(y(2:n-1:2)) + 2*sum(y(3:n-2:2)) + y(n))
            else
                if (present(even)) then
                    if (even < 0) then
                        ! 3/8th rule on left
                        integral = simps38(y(1:4), dx) + simps(y(4:n), dx)
                        return
                    else if (even > 0) then
                        ! 3/8 rule on right
                        integral = simps(y(1:n-3), dx) + simps38(y(n-3:n), dx)
                        return
                    else
                        ! fall through
                    end if
                end if
                ! either `even` not present or is zero
                ! equivalent to averaging left and right
                integral = dx/48.0_dp * (17*(y(1) + y(n)) + 59*(y(2) + y(n-1)) &
                        + 43*(y(3) + y(n-2)) + 49*(y(4) + y(n-3)) + 48*sum(y(5:n-4)))
            end if
        end select
    end function simps_dx_dp

    pure recursive module function simps_dx_qp(y, dx, even) result(integral)
        real(qp), dimension(:), intent(in) :: y
        real(qp), intent(in) :: dx
        integer, intent(in), optional :: even
        real(qp) :: integral

        integer :: n

        n = size(y)

        select case (n)
        case (0:1)
            integral = 0.0_qp
        case (2)
            integral = 0.5_qp*dx*(y(1) + y(2))
        case (3)
            integral = dx/3.0_qp*(y(1) + 4*y(2) + y(3))
        case (4)
            integral = simps38(y, dx)
        ! case (5) not needed; handled by default
        case (6) ! needs special handling because of averaged 3/8's rule case
            if (present(even)) then
                if (even < 0) then
                    ! 3/8 rule on left
                    integral =  simps38(y(1:4), dx) + simps(y(4:6), dx)
                    return
                else if (even > 0) then
                    ! 3/8 rule on right
                    integral = simps(y(1:3), dx) + simps38(y(3:6), dx)
                    return
                else
                    ! fall through
                end if
            end if
            ! either `even` not present or is zero
            ! equivalent to averaging left and right
            integral = dx/48.0_qp * (17*(y(1) + y(6)) + 59*(y(2) + y(5)) + 44*(y(3) + y(4)))
        case default
            if (mod(n, 2) == 1) then
                integral = dx/3.0_qp*(y(1) + 4*sum(y(2:n-1:2)) + 2*sum(y(3:n-2:2)) + y(n))
            else
                if (present(even)) then
                    if (even < 0) then
                        ! 3/8th rule on left
                        integral = simps38(y(1:4), dx) + simps(y(4:n), dx)
                        return
                    else if (even > 0) then
                        ! 3/8 rule on right
                        integral = simps(y(1:n-3), dx) + simps38(y(n-3:n), dx)
                        return
                    else
                        ! fall through
                    end if
                end if
                ! either `even` not present or is zero
                ! equivalent to averaging left and right
                integral = dx/48.0_qp * (17*(y(1) + y(n)) + 59*(y(2) + y(n-1)) &
                        + 43*(y(3) + y(n-2)) + 49*(y(4) + y(n-3)) + 48*sum(y(5:n-4)))
            end if
        end select
    end function simps_dx_qp

    recursive module function simps_x_sp(y, x, even) result(integral)
        real(sp), dimension(:), intent(in) :: y
        real(sp), dimension(:), intent(in) :: x
        integer, intent(in), optional :: even
        real(sp) :: integral

        integer :: i
        integer :: n

        real(sp) :: h1, h2
        real(sp) :: a, b, c

        n = size(y)
        call check(size(x) == n, "simps: Arguments `x` and `y` must be the same size.")

        select case (n)
        case (0:1)
            integral = 0.0_sp
        case (2)
            integral = 0.5_sp*(x(2) - x(1))*(y(1) + y(2))
        case (3)
            h1 = x(2) - x(1)
            h2 = x(3) - x(2)
            a = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
            b = (h1+h2)**3/(6*h1*h2)
            c = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
            integral = a*y(1) + b*y(2) + c*y(3)
        case (4)
            integral = simps38(y, x)
        ! case (6) unneeded; handled by default
        case default
            if (mod(n, 2) == 1) then
                integral = 0.0_sp
                do i = 1, n-2, 2
                    h1 = x(i+1) - x(i)
                    h2 = x(i+2) - x(i+1)
                    a = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
                    b = (h1+h2)**3/(6*h1*h2)
                    c = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
                    integral = integral + a*y(i) + b*y(i+1) + c*y(i+2)
                end do
            else
                if (present(even)) then
                    if (even < 0) then
                        ! 3/8 rule on left
                        integral = simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n))
                        return
                    else if (even > 0) then
                        ! 3/8 rule on right
                        integral = simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n))
                        return
                    else
                        ! fall through
                    end if
                end if
                ! either `even` not present or is zero
                integral = 0.5_sp * ( simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n)) &
                    + simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n)) )
            end if
        end select
    end function simps_x_sp

    recursive module function simps_x_dp(y, x, even) result(integral)
        real(dp), dimension(:), intent(in) :: y
        real(dp), dimension(:), intent(in) :: x
        integer, intent(in), optional :: even
        real(dp) :: integral

        integer :: i
        integer :: n

        real(dp) :: h1, h2
        real(dp) :: a, b, c

        n = size(y)
        call check(size(x) == n, "simps: Arguments `x` and `y` must be the same size.")

        select case (n)
        case (0:1)
            integral = 0.0_dp
        case (2)
            integral = 0.5_dp*(x(2) - x(1))*(y(1) + y(2))
        case (3)
            h1 = x(2) - x(1)
            h2 = x(3) - x(2)
            a = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
            b = (h1+h2)**3/(6*h1*h2)
            c = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
            integral = a*y(1) + b*y(2) + c*y(3)
        case (4)
            integral = simps38(y, x)
        ! case (6) unneeded; handled by default
        case default
            if (mod(n, 2) == 1) then
                integral = 0.0_dp
                do i = 1, n-2, 2
                    h1 = x(i+1) - x(i)
                    h2 = x(i+2) - x(i+1)
                    a = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
                    b = (h1+h2)**3/(6*h1*h2)
                    c = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
                    integral = integral + a*y(i) + b*y(i+1) + c*y(i+2)
                end do
            else
                if (present(even)) then
                    if (even < 0) then
                        ! 3/8 rule on left
                        integral = simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n))
                        return
                    else if (even > 0) then
                        ! 3/8 rule on right
                        integral = simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n))
                        return
                    else
                        ! fall through
                    end if
                end if
                ! either `even` not present or is zero
                integral = 0.5_dp * ( simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n)) &
                    + simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n)) )
            end if
        end select
    end function simps_x_dp

    recursive module function simps_x_qp(y, x, even) result(integral)
        real(qp), dimension(:), intent(in) :: y
        real(qp), dimension(:), intent(in) :: x
        integer, intent(in), optional :: even
        real(qp) :: integral

        integer :: i
        integer :: n

        real(qp) :: h1, h2
        real(qp) :: a, b, c

        n = size(y)
        call check(size(x) == n, "simps: Arguments `x` and `y` must be the same size.")

        select case (n)
        case (0:1)
            integral = 0.0_qp
        case (2)
            integral = 0.5_qp*(x(2) - x(1))*(y(1) + y(2))
        case (3)
            h1 = x(2) - x(1)
            h2 = x(3) - x(2)
            a = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
            b = (h1+h2)**3/(6*h1*h2)
            c = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
            integral = a*y(1) + b*y(2) + c*y(3)
        case (4)
            integral = simps38(y, x)
        ! case (6) unneeded; handled by default
        case default
            if (mod(n, 2) == 1) then
                integral = 0.0_qp
                do i = 1, n-2, 2
                    h1 = x(i+1) - x(i)
                    h2 = x(i+2) - x(i+1)
                    a = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
                    b = (h1+h2)**3/(6*h1*h2)
                    c = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
                    integral = integral + a*y(i) + b*y(i+1) + c*y(i+2)
                end do
            else
                if (present(even)) then
                    if (even < 0) then
                        ! 3/8 rule on left
                        integral = simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n))
                        return
                    else if (even > 0) then
                        ! 3/8 rule on right
                        integral = simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n))
                        return
                    else
                        ! fall through
                    end if
                end if
                ! either `even` not present or is zero
                integral = 0.5_qp * ( simps38(y(1:4), x(1:4)) + simps(y(4:n), x(4:n)) &
                    + simps(y(1:n-3), x(1:n-3)) + simps38(y(n-3:n), x(n-3:n)) )
            end if
        end select
    end function simps_x_qp

    pure recursive module function simps_weights_sp(x, even) result(w)
        real(sp), dimension(:), intent(in) :: x
        integer, intent(in), optional :: even
        real(sp), dimension(size(x)) :: w

        integer :: i, n
        real(sp) :: h1, h2

        n = size(x)

        select case (n)
        case (0)
            ! no action needed
        case (1)
            w(1) = 0.0_sp
        case (2)
            w = 0.5_sp*(x(2) - x(1))
        case (3)
            h1 = x(2) - x(1)
            h2 = x(3) - x(2)
            w(1) = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
            w(2) = (h1+h2)**3/(6*h1*h2)
            w(3) = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
        case (4)
            w = simps38_weights(x)
        case default
            if (mod(n, 2) == 1) then
                w = 0.0_sp
                do i = 1, n-2, 2
                    h1 = x(i+1) - x(i)
                    h2 = x(i+2) - x(i+1)
                    w(i) = w(i) + (2*h1**2 + h1*h2 - h2**2)/(6*h1)
                    w(i+1) = w(i+1) + (h1+h2)**3/(6*h1*h2)
                    w(i+2) = w(i+2) + (2*h2**2 + h1*h2 - h1**2)/(6*h2)
                end do
            else
                if (present(even)) then
                    if (even < 0) then
                        ! 3/8 rule on left
                        w = 0.0_sp
                        w(1:4) = simps38_weights(x(1:4))
                        w(4:n) = w(4:n) + simps_weights(x(4:n)) ! position 4 needs both rules
                        return
                    else if (even > 0) then
                        ! 3/8 rule on right
                        w = 0.0_sp
                        w(1:n-3) = simps_weights(x(1:n-3))
                        w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n)) ! position n-3 needs both rules
                        return
                    else
                        ! fall through
                    end if
                end if
                ! either `even` not present or is zero
                w = 0.0_sp
                ! 3/8 rule on left
                w(1:4) = simps38_weights(x(1:4))
                w(4:n) = w(4:n) + simps_weights(x(4:n))
                ! 3/8 rule on right
                w(1:n-3) = w(1:n-3) + simps_weights(x(1:n-3))
                w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n))
                ! average
                w = 0.5_sp * w
            end if
        end select
    end function simps_weights_sp

    pure recursive module function simps_weights_dp(x, even) result(w)
        real(dp), dimension(:), intent(in) :: x
        integer, intent(in), optional :: even
        real(dp), dimension(size(x)) :: w

        integer :: i, n
        real(dp) :: h1, h2

        n = size(x)

        select case (n)
        case (0)
            ! no action needed
        case (1)
            w(1) = 0.0_dp
        case (2)
            w = 0.5_dp*(x(2) - x(1))
        case (3)
            h1 = x(2) - x(1)
            h2 = x(3) - x(2)
            w(1) = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
            w(2) = (h1+h2)**3/(6*h1*h2)
            w(3) = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
        case (4)
            w = simps38_weights(x)
        case default
            if (mod(n, 2) == 1) then
                w = 0.0_dp
                do i = 1, n-2, 2
                    h1 = x(i+1) - x(i)
                    h2 = x(i+2) - x(i+1)
                    w(i) = w(i) + (2*h1**2 + h1*h2 - h2**2)/(6*h1)
                    w(i+1) = w(i+1) + (h1+h2)**3/(6*h1*h2)
                    w(i+2) = w(i+2) + (2*h2**2 + h1*h2 - h1**2)/(6*h2)
                end do
            else
                if (present(even)) then
                    if (even < 0) then
                        ! 3/8 rule on left
                        w = 0.0_dp
                        w(1:4) = simps38_weights(x(1:4))
                        w(4:n) = w(4:n) + simps_weights(x(4:n)) ! position 4 needs both rules
                        return
                    else if (even > 0) then
                        ! 3/8 rule on right
                        w = 0.0_dp
                        w(1:n-3) = simps_weights(x(1:n-3))
                        w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n)) ! position n-3 needs both rules
                        return
                    else
                        ! fall through
                    end if
                end if
                ! either `even` not present or is zero
                w = 0.0_dp
                ! 3/8 rule on left
                w(1:4) = simps38_weights(x(1:4))
                w(4:n) = w(4:n) + simps_weights(x(4:n))
                ! 3/8 rule on right
                w(1:n-3) = w(1:n-3) + simps_weights(x(1:n-3))
                w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n))
                ! average
                w = 0.5_dp * w
            end if
        end select
    end function simps_weights_dp

    pure recursive module function simps_weights_qp(x, even) result(w)
        real(qp), dimension(:), intent(in) :: x
        integer, intent(in), optional :: even
        real(qp), dimension(size(x)) :: w

        integer :: i, n
        real(qp) :: h1, h2

        n = size(x)

        select case (n)
        case (0)
            ! no action needed
        case (1)
            w(1) = 0.0_qp
        case (2)
            w = 0.5_qp*(x(2) - x(1))
        case (3)
            h1 = x(2) - x(1)
            h2 = x(3) - x(2)
            w(1) = (2*h1**2 + h1*h2 - h2**2)/(6*h1)
            w(2) = (h1+h2)**3/(6*h1*h2)
            w(3) = (2*h2**2 + h1*h2 - h1**2)/(6*h2)
        case (4)
            w = simps38_weights(x)
        case default
            if (mod(n, 2) == 1) then
                w = 0.0_qp
                do i = 1, n-2, 2
                    h1 = x(i+1) - x(i)
                    h2 = x(i+2) - x(i+1)
                    w(i) = w(i) + (2*h1**2 + h1*h2 - h2**2)/(6*h1)
                    w(i+1) = w(i+1) + (h1+h2)**3/(6*h1*h2)
                    w(i+2) = w(i+2) + (2*h2**2 + h1*h2 - h1**2)/(6*h2)
                end do
            else
                if (present(even)) then
                    if (even < 0) then
                        ! 3/8 rule on left
                        w = 0.0_qp
                        w(1:4) = simps38_weights(x(1:4))
                        w(4:n) = w(4:n) + simps_weights(x(4:n)) ! position 4 needs both rules
                        return
                    else if (even > 0) then
                        ! 3/8 rule on right
                        w = 0.0_qp
                        w(1:n-3) = simps_weights(x(1:n-3))
                        w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n)) ! position n-3 needs both rules
                        return
                    else
                        ! fall through
                    end if
                end if
                ! either `even` not present or is zero
                w = 0.0_qp
                ! 3/8 rule on left
                w(1:4) = simps38_weights(x(1:4))
                w(4:n) = w(4:n) + simps_weights(x(4:n))
                ! 3/8 rule on right
                w(1:n-3) = w(1:n-3) + simps_weights(x(1:n-3))
                w(n-3:n) = w(n-3:n) + simps38_weights(x(n-3:n))
                ! average
                w = 0.5_qp * w
            end if
        end select
    end function simps_weights_qp

    pure function simps38_dx_sp(y, dx) result (integral)
        real(sp), dimension(4), intent(in) :: y
        real(sp), intent(in) :: dx
        real(sp) :: integral

        integral = 3.0_sp*dx/8.0_sp * (y(1) + y(4) + 3*(y(2) + y(3)))
    end function simps38_dx_sp

    pure function simps38_dx_dp(y, dx) result (integral)
        real(dp), dimension(4), intent(in) :: y
        real(dp), intent(in) :: dx
        real(dp) :: integral

        integral = 3.0_dp*dx/8.0_dp * (y(1) + y(4) + 3*(y(2) + y(3)))
    end function simps38_dx_dp

    pure function simps38_dx_qp(y, dx) result (integral)
        real(qp), dimension(4), intent(in) :: y
        real(qp), intent(in) :: dx
        real(qp) :: integral

        integral = 3.0_qp*dx/8.0_qp * (y(1) + y(4) + 3*(y(2) + y(3)))
    end function simps38_dx_qp

    pure function simps38_x_sp(y, x) result(integral)
        real(sp), dimension(4), intent(in) :: y
        real(sp), dimension(4), intent(in) :: x
        real(sp) :: integral

        real(sp) :: h1, h2, h3
        real(sp) :: a, b, c, d

        h1 = x(2) - x(1)
        h2 = x(3) - x(2)
        h3 = x(4) - x(3)

        a = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2))
        b = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3))
        c = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2))
        d = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3))

        integral = a*y(1) + b*y(2) + c*y(3) + d*y(4)
    end function simps38_x_sp

    pure function simps38_x_dp(y, x) result(integral)
        real(dp), dimension(4), intent(in) :: y
        real(dp), dimension(4), intent(in) :: x
        real(dp) :: integral

        real(dp) :: h1, h2, h3
        real(dp) :: a, b, c, d

        h1 = x(2) - x(1)
        h2 = x(3) - x(2)
        h3 = x(4) - x(3)

        a = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2))
        b = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3))
        c = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2))
        d = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3))

        integral = a*y(1) + b*y(2) + c*y(3) + d*y(4)
    end function simps38_x_dp

    pure function simps38_x_qp(y, x) result(integral)
        real(qp), dimension(4), intent(in) :: y
        real(qp), dimension(4), intent(in) :: x
        real(qp) :: integral

        real(qp) :: h1, h2, h3
        real(qp) :: a, b, c, d

        h1 = x(2) - x(1)
        h2 = x(3) - x(2)
        h3 = x(4) - x(3)

        a = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2))
        b = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3))
        c = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2))
        d = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3))

        integral = a*y(1) + b*y(2) + c*y(3) + d*y(4)
    end function simps38_x_qp

    pure function simps38_weights_sp(x) result(w)
        real(sp), intent(in) :: x(4)
        real(sp) :: w(size(x))

        real(sp) :: h1, h2, h3

        h1 = x(2) - x(1)
        h2 = x(3) - x(2)
        h3 = x(4) - x(3)

        w(1) = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2))
        w(2) = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3))
        w(3) = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2))
        w(4) = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3))
    end function simps38_weights_sp

    pure function simps38_weights_dp(x) result(w)
        real(dp), intent(in) :: x(4)
        real(dp) :: w(size(x))

        real(dp) :: h1, h2, h3

        h1 = x(2) - x(1)
        h2 = x(3) - x(2)
        h3 = x(4) - x(3)

        w(1) = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2))
        w(2) = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3))
        w(3) = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2))
        w(4) = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3))
    end function simps38_weights_dp

    pure function simps38_weights_qp(x) result(w)
        real(qp), intent(in) :: x(4)
        real(qp) :: w(size(x))

        real(qp) :: h1, h2, h3

        h1 = x(2) - x(1)
        h2 = x(3) - x(2)
        h3 = x(4) - x(3)

        w(1) = (h1+h2+h3)*(3*h1**2 + 2*h1*h2 - 2*h1*h3 - h2**2 + h3**2)/(12*h1*(h1+h2))
        w(2) = (h1+h2-h3)*(h1+h2+h3)**3/(12*h1*h2*(h2+h3))
        w(3) = (h2+h3-h1)*(h1+h2+h3)**3/(12*h2*h3*(h1+h2))
        w(4) = (h1+h2+h3)*(3*h3**2 + 2*h2*h3 - 2*h1*h3 - h2**2 + h1**2)/(12*h3*(h2+h3))
    end function simps38_weights_qp

end submodule stdlib_quadrature_simps


    use dflib
    !Author : globalpolicy
    !Blog   : c0dew0rth.blogspot.com
    !GitHub : globalpolicy
    !Date   : 11:01 AM - 11th August, 2019
    !Purpose: To draw flownet
    !Parameters : contourInterval, numDys, numDxs, DxsTillDam, reservoirHead, downstreamBoundaryHead

    !Built by observing structure of an example coefficient matrix from my Fortran Simulation notes
    !https://photos.app.goo.gl/BS5C2tp4MNMFp9Dh6 -> example grid
    !https://photos.app.goo.gl/GecBS62BS1hTPNri9 -> matrix construction
    !https://photos.app.goo.gl/WgKvzMWf63CRNBwZA -> final matrix
    !Great lectures I made my notes off of:
    !https://www.youtube.com/watch?v=FgR3KS51mbA - Prof. Wen Shen, Penn State University
    !https://www.youtube.com/watch?v=i0f2DegLBN8 - Sandip Mazumder

    implicit none

    integer i,j,col,row
    character(10) char
    real tmp,distance,smallestDistanceIndex,smallestDistance
    integer numDys,numDxs,numUnknowns,DxsTillDam
    integer(2) viewPortTopLeftx,viewPortTopLefty,viewPortBottomRightx,viewPortBottomRighty,viewPortWidth !viewPortWidth=viewPortHeight
    real reservoirHead,downstreamBoundaryHead
    real A(500,500),B(500,500),X(500,500),AInverse(500,500)
    logical status
    TYPE(wxycoord) wxy
    integer ret
    real H(500,500)
    real EquipotentialX(500,500),EquipotentialY(500,500) !one column for one head, same column's row element from each matrix give the equipotential point x,y
    real searchHead,currentHead,rightHead,upHead,contourInterval
    real interpolatedX,interpolatedY
    integer numberOfContours, contourId
    integer contourPointsCounters(500) !stores the number of equipotential points obtained for each contour

    contourInterval=10

    numDys=20 !total grid boxes along Y axis, enclosed within boundaries top and bottom
    numDxs=20 !total grid boxes along X axis, enclosed within boundaries left and right
    DxsTillDam=4

    reservoirHead=100
    downstreamBoundaryHead=50

    numUnknowns=numDys*numDxs
    numberOfContours=reservoirHead/contourInterval + 1

    !generate coefficient matrix A
    do i=1,numUnknowns !row index
        do j=1,numUnknowns !column index
            if(i.EQ.j) then

                A(i,j)=-4

                !for immediate right element of diagonal's row (right blob of Laplace computational stencil)
                if(MODULO(i,numDxs).EQ.1) then
                    A(i,j+1)=2
                elseif(MODULO(i,numDxs).EQ.0) then
                    A(i,j+1)=0
                    B(i,1)=B(i,1)-downstreamBoundaryHead
                else
                    A(i,j+1)=1
                endif

                !for immediate left element of diagonal's row (left blob of Laplace computational stencil)
                if(j.GT.1) then
                    if(MODULO(i,numDxs).EQ.1) then
                        A(i,j-1)=0
                    else
                        A(i,j-1)=1
                    endif
                endif

                !for far right element of diagonal's row (top blob of Laplace computational stencil)
                if(i.LE.numDxs) then
                    A(i,j+numDxs)=2
                elseif(j+numDxs.LE.numUnknowns) then
                    A(i,j+numDxs)=1
                else
                    if(j.LE.numUnknowns-(numDxs-DxsTillDam)) then
                        B(i,1)=B(i,1)+(-reservoirHead)
                    else
                        B(i,1)=B(i,1)+0
                    endif

                endif

                !for far left element of diagonal's row (bottom blob of Laplace computational stencil)
                if(j.GT.numDxs) then
                    A(i,j-numDxs)=1
                endif

            endif
        end do
    end do

    !generated coefficient matrix A written to file for inspection
    open(1,file='A.txt')
    do i=1,numUnknowns
        write(1,'(F5.1,$)') (A(i,j),j=1,numUnknowns)
        write(1,*)
    end do
    close(1)

    !generated B vector written to file for inspection
    open(1,file='B.txt')
    do i=1,numUnknowns
        write(1,*) B(i,1)
    end do
    close(1)

    call Inverse(A,AInverse,numUnknowns)
    X=matmul(AInverse,B)

    !calculated X vector
    open(1,file='X.txt')
    do i=1,numUnknowns
        write(1,*) X(i,1)
    end do
    close(1)

    !setup viewport
    viewPortWidth = 600
    viewPortTopLeftx = 200
    viewPortTopLefty = 80
    viewPortBottomRightx = int2(viewPortTopLeftx+real(numDxs)/real(numDys)*viewPortWidth)
    viewPortBottomRighty = int2(viewPortTopLefty+viewPortWidth)
    call SETVIEWPORT(200,80,viewPortBottomRightx,viewPortBottomRighty)
    status = SETCOLOR(4) !red
    status = FLOODFILL(51,81,4) !flood fill viewport
    status = SETWINDOW(.TRUE.,real(0,8),real(0,8),real(numDxs,8),real(numDys,8))
    status = SETCOLOR(1)

    !draw horizontal lines from bottom to top
    do i=0,numDys
        call MOVETO_W(0.0_8,real(i,8),wxy)
        ret = LINETO_W(real(numDxs,8),real(i,8))
    end do

    !draw vertical lines from left to right
    do i=0,numDxs
        call MOVETO_W(real(i,8),0.0_8,wxy)
        ret = LINETO_W(real(i,8),real(numDys,8))
    end do

    !populate non-last row of Head matrix from the computed X vector
    do i=1,numDys
        do j=1,numDxs+1
            if(j.EQ.numDxs+1) then !if final column
                H(i,j)=downstreamBoundaryHead
            else
                H(i,j)=X((i-1)*numDxs+j,1)
            endif
        end do
    end do

    !populate the last row
    do j=1,numDxs+1
        if(j.LE.DxsTillDam) then
            H(numDys+1,j)=reservoirHead
        else
            H(numDys+1,j)=0
        endif
    end do

    !output H matrix to file for inspection
    !observe that it is of the form (taking the referenced example at the top)
    !           h1           h2          h3       h4    downstreamBoundaryHead
    !           h5           h6          h7       h8    downstreamBoundaryHead
    !           h9          h10          h11      h12   downstreamBoundaryHead
    !   reservoirHead   reservoirHead    0        0     0
    !where h1,h2,... are computed heads from X vector
    !also observe that H matrix has exactly the same number of elements as nodes in our grid(i.e. numDys+1 by numDxs+1)
    open(1,file='H.txt')
    do i=1,numDys+1
        write(1,'(F5.1,$,"  ")') (H(i,j),j=1,numDxs+1)
        write(1,*)
    end do
    close(1)

    contourId=0
    do searchHead=0,reservoirHead,contourInterval
        contourId=contourId+1
        !iterate through grid nodes one column at a time, left to right, looking for same potential(searchHead) right and top
        !note that correspondence between our grid coordinate and H matrix's element is
        !Head at coordinate (col,row) of grid  = (row+1,col+1) element of H matrix
        !Makes use of the fact that in a row, head decreases from left to right.
        !Depending on column on grid, in a column, head decreases top to bottom for col<damX and increases for col>=damX
        do col=0,numDxs
10            do row=0,numDys
                currentHead=H(row+1,col+1)
                if(currentHead.NE.searchHead) then
                    if(col<numDxs) then !look toward east node
                        rightHead=H(row+1,col+2)
                        if(searchHead.LE.currentHead.AND.searchHead.GE.rightHead) then
                            interpolatedX=col+1/(rightHead-currentHead)*(searchHead-currentHead)
                            contourPointsCounters(contourId)=contourPointsCounters(contourId)+1
                            EquipotentialX(contourPointsCounters(contourId),contourId)=interpolatedX
                            EquipotentialY(contourPointsCounters(contourId),contourId)=row
                        endif

                    endif
                    if(row<numDys) then !look toward north node
                        upHead=H(row+2,col+1)
                        if(col<DxsTillDam) then !if we're left of dam
                            !head increases towards up
                            if(searchHead.GE.currentHead.AND.searchHead.LE.upHead) then
                                interpolatedY=row+1/(upHead-currentHead)*(searchHead-currentHead)
                                contourPointsCounters(contourId)=contourPointsCounters(contourId)+1
                                EquipotentialY(contourPointsCounters(contourId),contourId)=interpolatedY
                                EquipotentialX(contourPointsCounters(contourId),contourId)=col
                            endif
                        else !if we're at or right of dam's heel
                            !head decreases towards up
                            if(searchHead.LE.currentHead.AND.searchHead.GE.upHead) then
                                interpolatedY=row+1/(upHead-currentHead)*(searchHead-currentHead)
                                contourPointsCounters(contourId)=contourPointsCounters(contourId)+1
                                EquipotentialY(contourPointsCounters(contourId),contourId)=interpolatedY
                                EquipotentialX(contourPointsCounters(contourId),contourId)=col
                            endif
                        endif
                    endif
                endif
            end do
        end do
    end do

    !!----DEPRECATED METHOD----
    !!sort equipotential points in ascending (descending works too) order of x coordinate for proper equipotential line
    !!sketching (left to right in ascending, right to left in descending).
    !!EDIT : Equipotential curves that are improper functions (two y's for a x) don't behave nicely with
    !!this method though. Only a couple of curves, generally towards the center of the flownet are as such
    !!in my experience.
    !do contourId=1,numberOfContours
    !    do i=1,contourPointsCounters(contourId)
    !        do j=i,contourPointsCounters(contourId)
    !            if(EquipotentialX(j,contourId).LT.EquipotentialX(i,contourId)) then
    !                tmp=EquipotentialY(i,contourId)
    !                EquipotentialY(i,contourId)=EquipotentialY(j,contourId)
    !                EquipotentialY(j,contourId)=tmp
    !
    !                tmp=EquipotentialX(i,contourId)
    !                EquipotentialX(i,contourId)=EquipotentialX(j,contourId)
    !                EquipotentialX(j,contourId)=tmp
    !            endif
    !        end do
    !    end do
    !end do

    !equipotential points sorting for proper equipotential line sketching
    !first sort equipotential points in descending order of Y coordinate(topmost to bottom-most)
    !then sort based on shortest consecutive distance.
    !better than sorting by x coordinate but not totally devoid of some weird artifacts
    do contourId=1,numberOfContours
        !sort descending in Y coordinate
        do i=1,contourPointsCounters(contourId)
            do j=i,contourPointsCounters(contourId)
                if(EquipotentialY(j,contourId).GT.EquipotentialY(i,contourId)) then
                    !swap Y coordinate
                    tmp=EquipotentialY(i,contourId)
                    EquipotentialY(i,contourId)=EquipotentialY(j,contourId)
                    EquipotentialY(j,contourId)=tmp
                    !swap X coordinate
                    tmp=EquipotentialX(i,contourId)
                    EquipotentialX(i,contourId)=EquipotentialX(j,contourId)
                    EquipotentialX(j,contourId)=tmp
                endif
            end do
        end do
        !sort based on shortest consecutive distance (basically ordering the shortest path downward, downward coz the array is descending inY)
        do i=1,contourPointsCounters(contourId)-1
            smallestDistance=10000 !very large number
            do j=i+1,contourPointsCounters(contourId)
                !distance between i and j point
                distance = (EquipotentialX(i,contourId)-EquipotentialX(j,contourId))**2 + (EquipotentialY(i,contourId)-EquipotentialY(j,contourId))**2
                if(distance.LT.smallestDistance) then
                    smallestDistance=distance
                    smallestDistanceIndex=j
                endif
            end do
            !swap i+1 point and point at smallestDistanceIndex
            !X
            tmp = EquipotentialX(i+1,contourId)
            EquipotentialX(i+1,contourId) = EquipotentialX(smallestDistanceIndex,contourId)
            EquipotentialX(smallestDistanceIndex,contourId) = tmp
            !Y
            tmp = EquipotentialY(i+1,contourId)
            EquipotentialY(i+1,contourId) = EquipotentialY(smallestDistanceIndex,contourId)
            EquipotentialY(smallestDistanceIndex,contourId) = tmp
        end do
    end do

    !write equipotential points to file for observation
    open(1,file='Isobars.txt')
        do contourId=1,numberOfContours
            write(1,*) (contourId-1)*contourInterval
            write(1,'("(",F5.2,",",F5.2,")      ",$)') (EquipotentialX(i,contourId),EquipotentialY(i,contourId),i=1,contourPointsCounters(contourId))
            write(1,*) ''
        end do
    close(1)

    !draw equipotential lines
    do contourId=1,numberOfContours
        call MOVETO_W(real(EquipotentialX(1,contourId),8),real(EquipotentialY(1,contourId),8),wxy)

        !draw a circle on the equipotential point(not necessary)
        status = SETCOLOR(6)
        ret = ELLIPSE_W($GFILLINTERIOR,real(EquipotentialX(1,contourId)-0.015,8),real(EquipotentialY(1,contourId)+0.015,8),real(EquipotentialX(1,contourId)+0.015,8),real(EquipotentialY(1,contourId)-0.015,8))
        status = SETCOLOR(2)

        do i=2,contourPointsCounters(contourId)
            !draw a circle on the equipotential point(not necessary)
            status = SETCOLOR(6)
            ret = ELLIPSE_W($GFILLINTERIOR,real(EquipotentialX(i,contourId)-0.015,8),real(EquipotentialY(i,contourId)+0.015,8),real(EquipotentialX(i,contourId)+0.015,8),real(EquipotentialY(i,contourId)-0.015,8))
            status = SETCOLOR(2)

            !avoids jumping lines
            call GETCURRENTPOSITION_W(wxy)
            if(abs(wxy.wx-EquipotentialX(i,contourId)).GT.4.OR.abs(wxy.wy-EquipotentialY(i,contourId)).GT.4) then
                call MOVETO_W(real(EquipotentialX(i,contourId),8),real(EquipotentialY(i,contourId),8),wxy)
            endif

            ret = LINETO_W(real(EquipotentialX(i,contourId),8),real(EquipotentialY(i,contourId),8))

        end do
    end do

    !draw one grid length horizontal line on grid top representing base of dam
    status = SETCOLOR(6)
    call MOVETO_W(real(DxsTillDam,8),real(numDys,8),wxy)
    ret = LINETO_W(real(DxsTillDam+1,8),real(numDys,8))

    !write heads on grid nodes
    !note that correspondence between our grid coordinate and H matrix's element is
    !head at coordinate (col,row) of grid  = (row+1,col+1) element of H matrix
    status = SETCOLOR(8)
    status = INITIALIZEFONTS()
    status = SETFONT('t''Arial''h8w3pv')
    !loop for except the bottom and right boundaries and bottom-right node (else they're clipped)
    do i=0,numDxs-1
        do j=1,numDys
            call MOVETO_W(real(i,8),real(j,8),wxy)
            write(char,'(F6.2)') H(j+1,i+1)
            call OUTGTEXT(char)
        end do
    end do
    !for bottom boundary
    do i=0,numDxs-1
        call MOVETO_W(real(i,8),real(0,8)+0.1,wxy)
        write(char,'(F6.2)') H(0+1,i+1)
        call OUTGTEXT(char)
    end do
    !for right boundary
    do i=1,numDys
        call MOVETO_W(real(numDxs,8)-0.3,real(i,8),wxy)
        write(char,'(F6.2)') H(i+1,numDxs+1)
        call OUTGTEXT(char)
    end do
    !for bottom right node
    call MOVETO_W(real(numDxs,8)-0.3,real(0,8)+0.1,wxy)
    write(char,'(F6.2)') H(0+1,numDxs+1)
    call OUTGTEXT(char)

    end program

subroutine Inverse(X,XI,size)
dimension X(500,500),XI(500,500),originalX(500,500)
integer rowindex,colindex,size,tmpi,tmpj,i,j
real pivotelement

originalX=X

do i=1,size
    do j=1,size
        if(i.EQ.j) then
            XI(i,j)=1
        else
            XI(i,j)=0 !this is for good measure coz by default, XI may have been changed by the caller itself though it is 0 by default
        endif
    end do
end do

do rowindex=1,size !loop over rows of X

    pivotelement=X(rowindex,rowindex) !this is crucial!

    !divide the row by pivot element
    do colindex=1,size
        X(rowindex,colindex)=X(rowindex,colindex)/pivotelement
    end do
    do colindex=1,size
        XI(rowindex,colindex)=XI(rowindex,colindex)/pivotelement
    end do

    !perform row operations to make non-pivot elements of this column zero
    do i=1,size !i gives the row number being manipulated
        pivotelement=X(i,rowindex) !pivot element for the currently manipulated row. this i crucial

        if(i.NE.rowindex) then !row operations are for non-current rows only

            do j=1,size !column index for ith row of X matrix
                X(i,j)=X(i,j)-pivotelement*X(rowindex,j)
            end do
            do j=1,size !column index for ith row of XI matrix
                XI(i,j)=XI(i,j)-pivotelement*XI(rowindex,j)
            end do

        endif
    end do

end do

!restore X to original X since upon inversion completion, X has been reduced to an Identity matrix. good practice
X=originalX

end subroutine


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Computes the  mean value.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] nb_nod number of 1D GLL nodes
!> @param[in] xq coor GLL node
!> @param[in] val value in each GLL node
!> @param[in] xref x-coordinate of the monitor
!> @param[in] yref y-coordinate of the monitor
!> @param[in] zref z-coordinate of the monitor
!> @param[out] res mean value (interpolation)

      subroutine GET_MONITOR_VALUE(nb_nod, xq, val, xref, yref, zref, res)

      implicit none

      integer*4 :: nb_nod
      integer*4 :: i,j,k,h

      real*8 :: xref,yref,zref,res
      real*8 :: fx,fy,fz

      real*8, dimension(nb_nod) :: xq

      real*8, dimension(nb_nod,nb_nod,nb_nod) :: val

      res = 0.0d0

      do k = 1,nb_nod
         fz = 1.0d0
         do h = 1,nb_nod
            if (h.ne.k) fz = fz * (zref - xq(h)) / (xq(k) - xq(h))
         enddo

         do j = 1,nb_nod
            fy = 1.0d0
            do h = 1,nb_nod
               if (h.ne.j) fy = fy * (yref - xq(h)) / (xq(j) - xq(h))
            enddo

            do i = 1,nb_nod
               fx = 1.0d0
               do h = 1,nb_nod
                  if (h.ne.i) fx = fx * (xref - xq(h)) / (xq(i) - xq(h))
               enddo

               res = res + val(i,j,k) * fx * fy * fz
            enddo
         enddo
      enddo

      end subroutine GET_MONITOR_VALUE


PROGRAM main

  USE mo_kind, ONLY: dp, sp
  USE mo_fit,  ONLY: fitfun, fpoly_dp, fpoly_sp, polyfit, svdfit
  USE mo_fit,  ONLY: polyval
  use mo_ansi_colors, only: color, c_red, c_green

  IMPLICIT NONE

  LOGICAL                                :: isgood

  integer, parameter                     :: degree = 2
  integer                                :: i

  real(dp), dimension(11)                :: dx = (/ (i,i=0,10) /)
  real(dp), dimension(11)                :: dy = (/ 1,   6,  17,  34, 57,  86, 121, 162, 209, 262, 321 /)
  real(dp), dimension(11)                :: dsig
  real(dp), dimension(degree+1)          :: da, dw
  real(dp), dimension(degree+1,degree+1) :: dv
  real(dp)                               :: dchisq
  real(dp), dimension(2)                 :: dla
  real(dp)                               :: xdp = 3
  real(dp), dimension(4)                 :: xdpvec = (/ 0, 1, 2, 3 /)
  real(dp), dimension(3)                 :: polydp = (/ 1, 2, 1 /)

  real(sp), dimension(11)                :: sx = (/ (i,i=0,10) /)
  real(sp), dimension(11)                :: sy = (/ 1,   6,  17,  34, 57,  86, 121, 162, 209, 262, 321 /)
  real(sp), dimension(11)                :: ssig
  real(sp), dimension(degree+1)          :: sa, sw
  real(sp), dimension(degree+1,degree+1) :: sv
  real(sp)                               :: schisq
  real(sp), dimension(2)                 :: sla
  real(sp)                               :: xsp = 3
  real(sp), dimension(4)                 :: xspvec = (/ 0, 1, 2, 3 /)
  real(sp), dimension(3)                 :: polysp = (/ 1, 2, 1 /)

  Write(*,*) ''
  Write(*,*) 'Test mo_fit.f90'
  Write(*,*) ''
  Write(*,*) 'Output should read 1, 2, 3'

  ! Double precision
  Write(*,*) ''
  isgood = .true.
  da = polyfit(dx, dy, degree)
  write(*,*) da
  isgood = isgood .and. all((nint(1000._dp*da)-(/1000, 2000, 3000/)) == 0)
  dsig = 0.1
  call fitfun(dx, dy, dsig, da, fpoly_dp)
  write(*,*) da
  isgood = isgood .and. all((nint(1000._dp*da)-(/1000, 2000, 3000/)) == 0)
  call svdfit(dx, dy, dsig, da, dv, dw, dchisq, fpoly_dp)
  write(*,*) da
  isgood = isgood .and. all((nint(1000._dp*da)-(/1000, 2000, 3000/)) == 0)
  Write(*,*) ''
  Write(*,*) 'Output should read -44, 32'
  Write(*,*) ''
  dla = polyfit(dx, dy, 1)
  write(*,*) dla
  Write(*,*) ''
  Write(*,*) 'Output should read 16 & 1 4 9 16'
  Write(*,*) ''
  write(*,*) polyval( polydp, xdp)
  write(*,*) polyval( polydp, xdpvec)
  isgood = isgood .and. all((nint(1000._dp*polyval( polydp, xdpvec))-(/1000, 4000, 9000, 16000/)) == 0)

  if (isgood) then
     write(*,*) 'mo_fit double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_fit double precision ', color('failed!', c_red)
  endif

  ! Single precision
  Write(*,*) ''
  isgood = .true.
  sa = polyfit(sx, sy, degree)
  write(*,*) sa
  isgood = isgood .and. all((nint(1000._sp*sa)-(/1000, 2000, 3000/)) == 0)
  ssig = 0.1
  call fitfun(sx, sy, ssig, sa, fpoly_sp)
  write(*,*) sa
  isgood = isgood .and. all((nint(1000._sp*sa)-(/1000, 2000, 3000/)) == 0)
  call svdfit(sx, sy, ssig, sa, sv, sw, schisq, fpoly_sp)
  write(*,*) sa
  isgood = isgood .and. all((nint(1000._sp*sa)-(/1000, 2000, 3000/)) == 0)
  Write(*,*) ''
  Write(*,*) 'Output should read -44, 32'
  Write(*,*) ''
  sla = polyfit(sx, sy, 1)
  write(*,*) sla
  Write(*,*) ''
  Write(*,*) 'Output should read 16 & 1 4 9 16'
  Write(*,*) ''
  write(*,*) polyval( polysp, xsp)
  write(*,*) polyval( polysp, xspvec)
  isgood = isgood .and. all((nint(1000._sp*polyval( polysp, xspvec))-(/1000, 4000, 9000, 16000/)) == 0)

  if (isgood) then
     write(*,*) 'mo_fit single precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_fit single precision ', color('failed!', c_red)
  endif

END PROGRAM main


  ! ----------------------------------------------------------------------
  ! F11 normalization with fixed 180
  ! ----------------------------------------------------------------------
  ! Check the normalization of F11
  tot  = 0d0; tot2 = 0d0
  do j=1,n_ang
     !                  F11                      (sin phi)                      d phi        2pi
     tot  = tot +  p%F(ilam)%F11(j) * (sin(pi*(real(j)-0.5)/real(n_ang))) * (pi/180.d0) * (2.d0*pi)
     tot2 = tot2 + sin(pi*(real(j)-0.5)/real(n_ang))*pi/180.d0*2.d0*pi
  enddo
  ! print *,'theta integration gives: ',tot,tot/4.d0/pi

  ! do it again, using mu integration
  tot  = 0d0; tot2 = 0d0
  do j=1,n_ang-1
     !                  F11                      (sin phi)                      d phi        2pi
     tot  = tot +  2.d0*pi*p%F(ilam)%F11(j) * (cos(pi*(real(j)/real(n_ang))) - cos(pi*(real(j-1)/real(n_ang))))
  enddo
  ! print *,'mu    integration gives: ',tot,tot/4.d0/pi

     ! ----------------------------------------------------------------------
     ! F11 normalization after nang variable
     ! ----------------------------------------------------------------------
     ! Check the normalization of F11
     tot  = 0d0; tot2 = 0d0
     do j=1,nang
        !                  F11                      (sin phi)                      d phi        2pi
        tot  = tot  +  p%F(ilam)%F11(j) * (sin(pi*(real(j)-0.5)/real(nang))) * (pi/dble(nang)) * (2.d0*pi)
        tot2 = tot2 +                      sin(pi*(real(j)-0.5)/real(nang))  * (pi/dble(nang)) * (2.d0*pi)
     enddo
     print *,'theta integration gives: ',tot,tot/4.d0/pi

     ! do it again, using mu integration
     tot  = 0d0; tot2 = 0d0
     do j=1,nang-1
        !               2pi          F11                                     d mu
        tot  = tot +  2.d0*pi*p%F(ilam)%F11(j) * (cos(pi*(real(j)/real(nang))) - cos(pi*(real(j-1)/real(nang))))
     enddo
     print *,'mu    integration gives: ',tot,tot/4.d0/pi


!============================================================
!Procedure Collection by Shriraj Hegde
!-
!References:
!https://ww2.odu.edu/~agodunov/computing/programs/book2/Ch06/Inverse.f90
!https://stackoverflow.com/questions/13293964/module-calling-an-external-procedure-with-implicit-interface
!===========================================================

module linearAlgebra  !!add "use linearAlgebra" in the program,(add the module outside program block)
    implicit none  !!IMPORTANT, ALWAYS PLACE MODULES BEFORE PROGRAM else you will face (.mod) missing error
    contains
    subroutine printMatrix(array_2d)
        implicit none
        integer::i,j,n,m,t(2)
        real*8,intent(IN)::array_2d(:,:)
        t=SHAPE(array_2d);n=t(1);m=t(2) !determining shape
        do j=1,n
            do i=1,m
                write(*,"(F6.2)",advance='no') array_2d(j,i)  !add formatting as required
                write(*,"(A2)",advance='no')" "
            enddo
            do i=1,2   !(1,k) where k is the number of empty rows inbetween rows
                print*,''
            enddo
        enddo
    end subroutine printMatrix

    subroutine printVector(vector_1d_array)
        implicit none
        integer::i,t,j
        real*8,intent(IN)::vector_1d_array(:)
        t=size(vector_1d_array)
        do i=1,t
                write(*,"(F14.8)",advance='no')vector_1d_array(i)
            do j=1,0   !(1,k) where k is the number of empty rows inbetween rows
                print*,''
            enddo
        enddo
        print*,''
    end subroutine printVector

    function readMatrix(number_of_rows,number_of_columns)
    INTEGER,INTENT(IN)::number_of_rows,number_of_columns
    integer::i
    REAL*8::readMatrix(number_of_rows,number_of_columns)
    do i=1,number_of_rows
        READ*,readMatrix(i,:)
    enddo
    end function readMatrix

    function inverse(square_matrix)
    !============================================================
    ! Inverse matrix
    ! Method: Based on Doolittle LU factorization for Ax=b
    ! Alex G. December 2009
    ! Modified Shriraj Hegde - September 2020 (preserves input matrix,modified to function)
    !-----------------------------------------------------------
    ! input ...
    ! square_matrix(dimension,dimension) - array of coefficients for matrix A
    ! dimension      - dimension of square matrix
    ! output ...
    ! inverse(dimension,dimension) - inverse matrix of A
    ! get dimension of matrix by shape(matrix) which returns a 1d array
    !===========================================================
    implicit none
    integer dimension
    DOUBLE PRECISION,INTENT(IN):: square_matrix(:,:) !preserving the original matrix
    double precision,allocatable ::a(:,:), inverse(:,:)
    double precision,allocatable:: L(:,:), U(:,:), b(:), d(:), x(:)
    double precision coeff
    integer i, j, k,t(2)

    t=shape(square_matrix)

    if (t(1) .ne. t(2) ) then
        print*,"ERROR : NOT A SQUARE MATRIX (inverse function)"
        call exit
    endif

    dimension=t(1)

    ALLOCATE(a(dimension,dimension))
    ALLOCATE(inverse(dimension,dimension))
    ALLOCATE(L(dimension,dimension))
    ALLOCATE(U(dimension,dimension))
    ALLOCATE(b(dimension))
    ALLOCATE(d(dimension))
    ALLOCATE(x(dimension))

    !for preserving input matrix
    a=square_matrix;
    ! step 0: initialization for matrices L and U and b
    ! Fortran 90/95 aloows such operations on matrices
    L=0.0
    U=0.0
    b=0.0

    ! step 1: forward elimination
    do k=1, dimension-1
    do i=k+1,dimension
        coeff=a(i,k)/a(k,k)
        L(i,k) = coeff
        do j=k+1,dimension
            a(i,j) = a(i,j)-coeff*a(k,j)
        end do
    end do
    end do

    ! Step 2: prepare L and U matrices
    ! L matrix is a matrix of the elimination coefficient
    ! + the diagonal elements are 1.0
    do i=1,dimension
    L(i,i) = 1.0
    end do
    ! U matrix is the upper triangular part of A
    do j=1,dimension
    do i=1,j
        U(i,j) = a(i,j)
    end do
    end do

    ! Step 3: compute columns of the inverse matrix C
    do k=1,dimension
    b(k)=1.0
    d(1) = b(1)
    ! Step 3a: Solve Ld=b using the forward substitution
    do i=2,dimension
        d(i)=b(i)
        do j=1,i-1
        d(i) = d(i) - L(i,j)*d(j)
        end do
    end do
    ! Step 3b: Solve Ux=d using the back substitution
    x(dimension)=d(dimension)/U(dimension,dimension)
    do i = dimension-1,1,-1
        x(i) = d(i)
        do j=dimension,i+1,-1
        x(i)=x(i)-U(i,j)*x(j)
        end do
        x(i) = x(i)/u(i,i)
    end do
    ! Step 3c: fill the solutions x(n) into column k of C
    do i=1,dimension
        inverse(i,k) = x(i)
    end do
    b(k)=0.0
    end do

    inverse=inverse;
    end function inverse

    REAL*8 FUNCTION determinant(square_matrix)
    IMPLICIT NONE
    REAL*8, DIMENSION(:,:),INTENT(IN) :: square_matrix!preserving input
    REAL*8, DIMENSION(:,:),allocatable :: matrix
    REAL*8 :: m, temp
    INTEGER :: i, j, k, l,dimension,t(2)
    LOGICAL :: DetExists = .TRUE.
    t = shape(square_matrix)
    if (t(1) .ne. t(2)) then
        print*,"ERROR : NOT A SQUARE MATRIX (determinant function)"
        call exit
    endif

    allocate(matrix(t(1),t(1)))

    l = 1
    matrix = square_matrix
    !Convert to upper triangular form
    DO k = 1, dimension-1
        IF (matrix(k,k) == 0) THEN
            DetExists = .FALSE.
            DO i = k+1, dimension
                IF (matrix(i,k) /= 0) THEN
                    DO j = 1, dimension
                        temp = matrix(i,j)
                        matrix(i,j)= matrix(k,j)
                        matrix(k,j) = temp
                    END DO
                    DetExists = .TRUE.
                    l=-l
                    EXIT
                ENDIF
            END DO
            IF (DetExists .EQV. .FALSE.) THEN
                determinant = 0
                return
            END IF
        ENDIF
        DO j = k+1, dimension
            m = matrix(j,k)/matrix(k,k)
            DO i = k+1, dimension
                matrix(j,i) = matrix(j,i) - m*matrix(k,i)
            END DO
        END DO
    END DO

    !Calculate determinant by finding product of diagonal elements
    determinant = l
    DO i = 1, dimension
        determinant = determinant * matrix(i,i)
    END DO

    END FUNCTION determinant

end module


subroutine setprob

    implicit none
    character*25 :: fname
    integer :: iunit
    real(kind=8) :: rho,bulk,cc,zz,beta

    common /cparam/ rho,bulk,cc,zz
    common /cqinit/ beta

    ! Set the material parameters for the acoustic equations
    ! Passed to the Riemann solver rp1.f in a common block

    iunit = 7
    fname = 'setprob.data'
    ! open the unit with new routine from Clawpack 4.4 to skip over
    ! comment lines starting with #:
    call opendatafile(iunit, fname)

    ! density:
    read(7,*) rho

    ! bulk modulus:
    read(7,*) bulk

    ! sound speed:
    cc = dsqrt(bulk/rho)

    ! impedance:
    zz = cc*rho

    ! beta for initial conditions:
    read(7,*) beta

end subroutine setprob


! Program that solves the Laplace equation using Neumann's Boundary conditions
! Author: Anantha Rao
! Reg no: 20181044

program laplace_neumann
implicit none

      integer, parameter :: lx=34, ly=34 ! BOUNDARIES at x,y=0 and 34
      real*8 :: old_temp(1:lx, 1:ly), temp(1:lx, 1:ly)
      integer:: i,j,ii,jj,kk
      real*8 :: dx,dy, prefactor, shift_temp
      real*8 :: A(ly), B(ly), C(lx), D(lx)
      character(len=30) :: filename
      integer :: iunit, ci, cii, test, counter

      A = -70.0d0; B=-40.0d0; C=20.0d0; D=-10.0d0
      old_temp=0.0d0 ! at ZEROTH iteration

      dx=1.0d0; dy=dx
      test=0; counter=0; prefactor=(0.5d0*dx*dx*dy*dy)/(dx*dx + dy*dy)

      do  !LOOP OVER ITERATIONS
        counter=counter+1
        test=0

        ! UPDATE BOUNDARIES: NEUMANN CONDITIONS: LEAVING OUT CORNERS
        do j=2, ly-1
          temp(1,j) = 0.25d0*(2.0d0*old_temp(2,j) - 2.0d0*dx*A(j) + old_temp(1,j+1) + old_temp(1,j-1))
          temp(lx,j) = 0.25d0*(2.0d0*old_temp(lx-1,j) + 2.0d0*dx*B(j) + old_temp(lx,j+1) + old_temp(lx,j-1))
        end do

        do i=2,lx-1
          temp(i,1) =0.25d0*( old_temp(i+1,1)+ old_temp(i-1,1)+ 2.0d0*old_temp(i,2)- 2.0d0*dx*C(i))
          temp(i,ly) = 0.25d0*( old_temp(i+1,ly)+ old_temp(i-1,ly) + 2.0d0*old_temp(i,ly-1) + 2.0d0*dx*D(i))
        end do

        ! UPDATE THE VALUES AT 4 CORNERS
        temp(1,1)   = 0.5d0*(old_temp(1,2)     - dx*C(1)  + old_temp(2,1) - dx*A(1))
        temp(1,ly)  = 0.5d0*(old_temp(1,ly-1)  + dx*D(1)  + old_temp(2,ly)- dx*A(ly))
        temp(lx,1)  = 0.5d0*(old_temp(lx-1,1)  + dx*B(1)  +old_temp(lx,2)-dx*C(lx))
        temp(lx,ly) = 0.5d0*(old_temp(lx-1,ly) + dx*B(ly) +old_temp(lx,ly-1) + dx*D(lx))

        write(*,*) 'before update step', counter
        ! UPDATE STEP: THE INTERIOR OF THE LATTICE
        do jj=2, ly-1
        do ii=2, lx-1
            temp(ii,jj) = 0.25*( old_temp(ii-1,jj) + old_temp(ii+1,jj) + old_temp(ii,jj-1) + old_temp(ii,jj+1))
        end do
        end do

        write(*,*) 'before convergence check'
        ! CHECK FOR CONVERGENCE AT EACH LATTICE SITE
        do jj=1,ly
        do ii=1,lx
          if ((abs(temp(ii,jj) - old_temp(ii,jj))).gt.0.00001d0) test=1
        end do
        end do

        if(test.eq.0) exit ! EXIT CONDITION
        shift_temp =2000 - temp(1,1) ; temp=temp+shift_temp
        old_temp = temp  !AFTER TEST CONDITION

      end do
      write(*,*) 'counter',counter

      ! WRITE THE CONVERGED RESULT: SOLUTION TO THE EQN WITH BC
      iunit=71; ci=10000
      ! write(filename,'("initialize_",i0,".dat")') ci

      open(iunit, file='data.dat', status='new')
      do ii=1,lx
        do jj=1,ly
            write(iunit,*) ii,jj,temp(ii,jj)
        end do
      end do
      close(iunit)

!     open(newunit=iunit, file='data.dat')
!      do ii=1,lx
!        do jj=1,ly
!            write(iunit,*) ii,jj,temp(ii,jj)
!        end do
!      end do
!      close(iunit)

end program laplace_neumann


! { dg-do run }
! Tests the fix for pr28914, in which array constructors using the loop
! variable within a do loop for the implied do loop of the constructor
! would result in a corrupted do loop counter.
!
! Based on the testscase by Ed Korkven <kornkven@arsc.edu>
!
program pr28914
  implicit none
  integer n, i
  parameter (n = 66000) ! Problem manifests for n > 65535
  double precision a(n), summation

  summation = 0.0
  do i = 1, 1
    a = (/ (i, i = 1, n) /) ! This is legal and was broken
    a = sqrt(a)
    summation = SUM(a)
  enddo
  summation = abs(summation - 11303932.9138271_8)

  if (summation.gt.0.00001)   call abort()
end program pr28914


!!
!! Luke McCulloch
!! Module to compute Points on a plate
!! geo.f90
!! Inputs Number of points in X, NI
!!       Number of points in Y, NJ
!!       Physical (RECTangular) Plate Dimentions, lx, ly
!! Output The Array, "Points"
!!

MODULE geo

  use precise, only : defaultp
  use input

  IMPLICIT NONE
  INTEGER, PARAMETER, PRIVATE :: WP=defaultp
  !REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: pts, cells, t

CONTAINS

  Subroutine line(dx, L, xo, npts, pts, ncells, cells)
    ! Subroutine to Compute Points on a line

    INTEGER :: i       ! dummy index
    INTEGER :: npts    ! # of points
    INTEGER :: ncells  ! # of cells
    INTEGER :: nt      ! # of timesteps

    REAL(WP), ALLOCATABLE, DIMENSION(:,:) :: pts, cells
    real(wp) :: L, xo, dx, dt

    dx=L/(npts-1) !fence post!

    pts(1,1)=xo
    Do i = 2,npts
       pts(1,i)=pts(1,i-1)+dx
    End Do

    cells(1,1)=xo+(dx/2.)-dx
    Do i = 2,ncells
       cells(1,i)=cells(1,i-1)+dx
    End Do
    !write(*,*) 'cells'
    !write(*,'(1D16.8)') cells

  End Subroutine line

  Subroutine plate( NI, NJ, lx, ly, dx, dy, X, Y, Points )!!! Set lx and ly to 1 for initial tests
    ! Subroutine to Compute Points on a Plate

    INTEGER :: NI, NJ, i, j, ipt
    REAL(wp) :: lx, ly, dx, dy, Xo, Yo!, X, Y  ! Number of X points, Number of Y Points, Length of plate in x, Length of plate in Y, step x, step y

    REAL(wp), DIMENSION(2,NJ*NI) :: Points    ! Matrix of Points on the Plate
    REAL(wp), DIMENSION(NI,NJ) :: X
    REAL(wp), DIMENSION(NI,NJ) :: Y

    dx = lx/(NI-1)
    dy = ly/(NJ-1)

    Xo=0.
    Yo=0.

 !How do you want it?  Scalars or Vectors...
    ipt=1  ! point counter
    Do j = 1,NJ
       Do i = 1,NI
          X(i,j) = Xo+REAL(dx*i)-dx
          Y(i,j) = Yo+REAL(dy*j)-dy
          Points(:,ipt)=(/ X(i,j), Y(i,j) /)  ! Vector Version - Not used
          ipt=ipt+1
       End Do
       !ipt=ipt+1
    End Do

  END SUBROUTINE plate
END MODULE geo


module convert_mod
   implicit none
contains
   function cels_from_fahr(degrees_fahr) result(degrees_cels)
   real, intent(in) :: degrees_fahr
   real             :: degrees_cels
   degrees_cels = (degrees_fahr-32)/1.8
   end function cels_from_fahr
end module convert_mod

program xtemperature
   use convert_mod, only: cels_from_fahr
   real    :: deg
   integer :: i
   write (*,"(2a10)") "degrees_F","degrees_C"
   do i=12,100,20
      deg = real(i)
      write (*,"(2f10.1)") deg,cels_from_fahr(deg)
   end do
end program xtemperature


C Copyright (C) 2000, International Business Machines
C Corporation and others.  All Rights Reserved.
      DOUBLE PRECISION FUNCTION MVALUE( N, S, G, H, WRK, LWRK )
C
C  ***********************************************
C     Computes the value of the quadratic model
C
C          S' * G + 0.5 * S' * H * S
C  ***********************************************
C
      INTEGER          N, LWRK
      DOUBLE PRECISION S( N ), G( N ), H( N, N ), WRK( LWRK )

C
C  LOCAL VARIABLES
C

      DOUBLE PRECISION DDOT

      EXTERNAL         DDOT
C
C  SUBROUTINES AND FUNCTIONS CALLED:
C
C    BLAS            :       DSYMV, DDOT
C

      CALL DSYMV( 'U', N, 0.5D0, H, N, S, 1, 0.0D0, WRK, 1 )

      MVALUE = DDOT( N, S, 1, G, 1 ) + DDOT( N, S, 1, WRK, 1 )

      RETURN
      END


 SUBROUTINE MOVECT(FLAT,FLON,TLAT,TLON,CROT,SROT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 71314 $
!
! SUBPROGRAM:  MOVECT     MOVE A VECTOR ALONG A GREAT CIRCLE
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM PROVIDES THE ROTATION PARAMETERS
!           TO MOVE A VECTOR ALONG A GREAT CIRCLE FROM ONE
!           POSITION TO ANOTHER WHILE CONSERVING ITS ORIENTATION
!           WITH RESPECT TO THE GREAT CIRCLE.  THESE ROTATION
!           PARAMETERS ARE USEFUL FOR VECTOR INTERPOLATION.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
! 1999-04-08  IREDELL  GENERALIZE PRECISION
!
! USAGE:    CALL MOVECT(FLAT,FLON,TLAT,TLON,CROT,SROT)
!
!   INPUT ARGUMENT LIST:
!     FLAT     - REAL LATITUDE IN DEGREES FROM WHICH TO MOVE THE VECTOR
!     FLON     - REAL LONGITUDE IN DEGREES FROM WHICH TO MOVE THE VECTOR
!     TLAT     - REAL LATITUDE IN DEGREES TO WHICH TO MOVE THE VECTOR
!     TLON     - REAL LONGITUDE IN DEGREES TO WHICH TO MOVE THE VECTOR
!
!   OUTPUT ARGUMENT LIST:
!     CROT     - REAL CLOCKWISE VECTOR ROTATION COSINE
!     SROT     - REAL CLOCKWISE VECTOR ROTATION SINE
!                (UTO=CROT*UFROM-SROT*VFROM;
!                 VTO=SROT*UFROM+CROT*VFROM)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,         PARAMETER     :: KD=SELECTED_REAL_KIND(15,45)
!
 REAL,            INTENT(IN   ) :: FLAT, FLON
 REAL,            INTENT(IN   ) :: TLAT, TLON
 REAL,            INTENT(  OUT) :: CROT, SROT
!
 REAL(KIND=KD),   PARAMETER     :: CRDLIM=0.9999999
 REAL(KIND=KD),   PARAMETER     :: PI=3.14159265358979
 REAL(KIND=KD),   PARAMETER     :: DPR=180./PI
!
 REAL(KIND=KD)                  :: CTLAT,STLAT,CFLAT,SFLAT
 REAL(KIND=KD)                  :: CDLON,SDLON,CRD
 REAL(KIND=KD)                  :: SRD2RN,STR,CTR,SFR,CFR
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE COSINE OF THE RADIAL DISTANCE BETWEEN THE POINTS.
 CTLAT=COS(TLAT/DPR)
 STLAT=SIN(TLAT/DPR)
 CFLAT=COS(FLAT/DPR)
 SFLAT=SIN(FLAT/DPR)
 CDLON=COS((FLON-TLON)/DPR)
 SDLON=SIN((FLON-TLON)/DPR)
 CRD=STLAT*SFLAT+CTLAT*CFLAT*CDLON
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE ROTATIONS AT BOTH POINTS WITH RESPECT TO THE GREAT CIRCLE
!  AND COMBINE THEM TO GIVE THE TOTAL VECTOR ROTATION PARAMETERS.
 IF(ABS(CRD).LE.CRDLIM) THEN
   SRD2RN=-1/(1-CRD**2)
   STR=CFLAT*SDLON
   CTR=CFLAT*STLAT*CDLON-SFLAT*CTLAT
   SFR=CTLAT*SDLON
   CFR=CTLAT*SFLAT*CDLON-STLAT*CFLAT
   CROT=SRD2RN*(CTR*CFR-STR*SFR)
   SROT=SRD2RN*(CTR*SFR+STR*CFR)
!  USE A DIFFERENT APPROXIMATION FOR NEARLY COINCIDENT POINTS.
!  MOVING VECTORS TO ANTIPODAL POINTS IS AMBIGUOUS ANYWAY.
 ELSE
   CROT=CDLON
   SROT=SDLON*STLAT
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE MOVECT


SUBROUTINE eta_nonlinear(k,x,omega,time,n_four_modes,yy,eta,etax,etaxx,etat)
!
USE Precision
USE Constants
IMPLICIT NONE
INTEGER :: n_four_modes
REAL(KIND=long), INTENT(IN)  :: k,x,omega,time, yy(n_four_modes) ! GD: change yy(*)
REAL(KIND=long), INTENT(OUT) :: eta,etax
REAL(KIND=long), INTENT(OUT) :: etaxx,etat
! REAL(long), OPTIONAL :: y,etay,etayy !Boundary fitted ?
! Local variables
REAL(KIND=long) :: kx, sinkx, coskx, km
INTEGER    :: m
!
kx = k*x-omega*time
km=DBLE(n_four_modes)
coskx=half*yy(n_four_modes)*cos(km*kx)
sinkx=half*yy(n_four_modes)*sin(km*kx)
!
eta   = coskx
etax  = -km*sinkx
etaxx = -(km)**2*coskx
etat  = omega*km*sinkx
!FIXME optimizaton of loops (GD)
DO  m=1,n_four_modes-1
   km=DBLE(m)
   coskx=yy(m)*cos(km*kx)
   sinkx=yy(m)*sin(km*kx)
   ! Non-dimensional eta and derivatives
   eta  = eta   + coskx
   etax = etax  - km*sinkx
   etaxx= etaxx - km**2*coskx
   etat = etat  + omega*km*sinkx
ENDDO

END SUBROUTINE eta_nonlinear


! Lattice paths
!
! Starting in the top left corner of a 2x2 grid, and only being able to move to
! the right and down, there are exactly 6 routes to the bottom right corner.
!
!     ¯¯|    ¯|_     ¯|     |__     |_      |
!       |       |     |_       |      |_    |__
!
! How many such routes are there through a 20x20 grid?
module Problem15

    use FMZM

    implicit none
    private

    public :: solve
contains
    subroutine solve
        write (*, '(A)') 'Problem 15. Lattice paths.'

        write (*, '(A, A)') 'Path 1: ', pathes(40)
    end subroutine

    function pathes(width)
        integer, intent(in) :: width
        character(:), allocatable :: pathes

        type(IM) pathes_im

        pathes_im = factorial(40) / (factorial(20) * factorial(40 - 20))

        pathes = IM_format( 'i256', pathes_im)
        pathes = trim(adjustl(pathes))
    end function
end module


SUBROUTINE interp(k,dtim,rt,rl,al,nstep)
!
! This subroutine forms the load/time functions by interpolation.
! If dtim is not an exact multiple it stops one short.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::dtim,rt(:),rl(:)
 INTEGER,INTENT(IN)::k,nstep
 REAL(iwp),INTENT(IN OUT)::al(:,:)
 INTEGER::np,i,j
 REAL(iwp)::t,val
 np=SIZE(rt)
 al(1,k)=rl(1)
 t=rt(1)
 DO j=2,nstep
   t=t+dtim
   DO i=2,np
     IF(t.LE.rt(i))THEN
       val=rl(i-1)+((t-rt(i-1))/(rt(i)-rt(i-1)))*(rl(i)-rl(i-1))
       EXIT
     END IF
   END DO
   al(j,k)=val
 END DO
RETURN
END SUBROUTINE interp


        SUBROUTINE  PCOEF( N, X, Y, C )

C***********************************************************************
C Version "$Id: pcoef.f 1 2017-06-10 18:05:20Z coats $"
C EDSS/Models-3 I/O API.
C Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr.,
C (C) 2003-2010 by Baron Advanced Meteorological Systems.
C Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1
C See file "LGPL.txt" for conditions of use.
C.........................................................................
C  subroutine body starts at line  54
C
C  FUNCTION:  returns array C of polynomial coefficients
C	for the polynomial fitting the data
C       Y( K ) = P( X( K ) ) = sum_I
C
C  PRECONDITIONS REQUIRED:  none
C
C  SUBROUTINES AND FUNCTIONS CALLED:  none
C
C  REVISION  HISTORY:
C	Prototype 11/95 by CJC adapted from _Numerical_Recipes_,
C	section 3.5 (pp. 92-94), routine POLCOE
C       Modified 03/2010 by CJC: F90 changes for I/O API v3.1
C***********************************************************************

      IMPLICIT NONE

C...........   ARGUMENTS and their descriptions:

        INTEGER, INTENT(IN   ) :: N
        REAL   , INTENT(IN   ) :: X( N )
        REAL   , INTENT(IN   ) :: Y( N )
        REAL   , INTENT(  OUT) :: C( N )

C...........   PARAMETERS and their descriptions:

        INTEGER, PARAMETER :: NMAX = 15

C...........   SCRATCH LOCAL VARIABLES and their descriptions:

        INTEGER		I, J
        REAL		P, F, B
        REAL		S( NMAX )
        REAL		T( NMAX )
        CHARACTER*80    MESG

C***********************************************************************
C   begin body of subroutine  PCOEF

        IF ( N .GT. NMAX ) THEN
            WRITE( MESG, '(A, I5, 2X, A )' )
     &          'Requested degree', N, 'exceeds max=15'
            CALL M3EXIT( 'PCOEF', 0, 0, MESG, 2 )
        END IF

        DO  11  I = 1, N

            S( I ) = 0.0
            C( I ) = 0.0
            T( I ) = FLOAT( I )

11      CONTINUE

        S( N ) = -X( 1 )

        DO  22  I = 2, N
        DO  21  J = N - I + 1, N - 1

            S( J ) = S( J ) - X( I ) * S( J+1 )

21      CONTINUE
22      CONTINUE

        DO  33  I = 1, N

            P = T( N )

            DO  31  J = N - 1, 1, -1

                P = T( J ) * S( J+1 ) + P * X( I )

31          CONTINUE		!  end loop on J

            F = Y( I ) / P
            B = 1.0

            DO  32  J = N, 1, -1

                C( J ) = C( J ) + B * F
                B      = S( J ) + B * X( I )

32          CONTINUE	!  end loop on J

33      CONTINUE	!  end loop on I

        RETURN

        END SUBROUTINE PCOEF


program Montecarlo
    use omp_lib
    implicit none

    integer :: total_points, numthreads
    real :: calculate_pi
    real :: pi

    print*, "Enter the total amount of points for the calculation..."
    read*, total_points

    print*, "Enter the total amount of threads for the calculation..."
    read*, numthreads

    pi = calculate_pi(total_points, numthreads)

    write(*,*) 'PI = ', pi
end

real function calculate_pi(p, numthreads)
        integer :: p, numthreads
        integer*4 tid
        real in_area, x, y, z

        in_area = 0
        x = 0
        y = 0

        !$omp parallel private(x,y,z,in_area,tid,i) num_threads(numthreads)
        tid = omp_get_thread_num()

        do i=1,p/numthreads
            x = ran0(tid)
            y = ran0(tid)
            z = calculate_z(x,y)
            if (z .le. 1.) then
                !$omp critical
                in_area = in_area + 1
                !$omp end critical
                write(*,*) 'In Area = ', in_area, 'X = ', x, ' Y = ', y, ' Z = ', z
            else
                write(*,*) 'NOT In Area = X = ', x, ' Y = ', y, ' Z = ', z
            end if
        enddo
        !$omp end parallel

        calculate_pi = 4 * (p / in_area)

    return
end

real function calculate_z(x,y)
    real :: x, y
    real :: square_x, square_y
    square_x = x**2
    square_y = y**2
    calculate_z = sqrt(square_x + square_y)
end

real function ran0(seed)
    integer seed, ia, im, iq, ir, mask, k
    real ran0, am
    parameter (ia=16807, im=2147483647,am=1./im)
    iq = 127773, ir = 2836, mask = 123459876

    seed = ieor(seed, mask)

    k = seed / iq

    seed = ia * (seed - k * iq) - ir * k

    if (seed .lt. 0) then
        seed = seed + im
    end if

    ran0 = am * seed
    seed = ieor(seed,mask)

    return
end


!{ dg-do run }
! Test MATMUL for various arguments and results
! (test values checked with GNU octave).
! PR18857 was due to an incorrect assertion that component base==0
! for both input arguments and the result.
! provided by Paul Thomas - pault@gcc.gnu.org

Program matmul_1
  integer, parameter                                :: N = 5
  integer, parameter                                :: T = 4
  integer                                           :: i
  real(kind=T), dimension(:,:), allocatable         :: a, b, c
  real(kind=T), dimension(N,N)                      :: x, y, z

  allocate (a(2*N, N), b(N, N), c(2*N, N))

  do i = 1, 2*N
    a(i, :) = real (i)
  end do
  b = 4.0_T

  do i = 1, N
    x(i, :) = real (i)
  end do
  y = 2.0_T

!                           whole array

  z = 0.0_T
  z = matmul (x, y)
  if (sum (z) /= 750.0_T) call abort ()

!                           array sections

  c = 0.0_T
  c(1:3,1:2) = matmul (a(7:9,3:N), b(3:N,3:4))
  if (sum (c) /= 576.0_T) call abort ()

!                           uses a temp

  c = 0.0_T
  c = matmul (a, b + x)
  if (sum (c) /= 9625.0_T) call abort ()

!                           returns to a temp

  c = 0.0_T
  c = a + matmul (a, b)
  if (sum (c) /= 5775.0_T) call abort ()

  deallocate (a, b, c)

end program matmul_1


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C       Written by: Anshuk Attri
C
C       Contact: contact@anshukattri.in
C       Website: www.anshukattri.in/research
C       GITHUB: github.com/aa-tree/
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        SUBROUTINE GETBINOMIAL_SUM(K_POW, X_VAL, SUM_B)

        IMPLICIT NONE

        INCLUDE 'common.dat'

        REAL*8 K_POW, X_VAL, SUM_B

        INTEGER I, J
        REAL*8 COEFF, FAC_TEMP

C        WRITE(*,*) 'Inputs', K_POW, X_VAL

        IF(X_VAL .LT. 1) THEN

C
C       For n=0, we will assign the first coefficient (1).
C

        SUM_B=1.0D0

C
C       For n=1, we will calculate the coefficient. (k*x)
C

        SUM_B=SUM_B+(K_POW*X_VAL)

C
C       Now for the rest of the series.
C

        DO I=2,100

            COEFF=K_POW

            DO J=1,I-1
                COEFF=COEFF*(K_POW-J)
            END DO

            CALL CALC_FACTORIAL(I, FAC_TEMP)

            COEFF=COEFF/FAC_TEMP

            SUM_B=SUM_B+(COEFF*(X_VAL)**I)

        END DO

        ELSE
            !WRITE (*,*) 'Error in GETBINOMIAL_SUM.'
            !WRITE (*,*) 'X is not less than 1.'
!           STOP
        END IF

        RETURN
        END


C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C
C                                                            C
C  HIERARCHICAL CLUSTERING using (user-specified) criterion. C
C                                                            C
C  Parameters:                                               C
C                                                            C
C  N                 the number of points being clustered    C
C  DISS(LEN)         dissimilarities in lower half diagonal  C
C                    storage; LEN = N.N-1/2,                 C
C  IOPT              clustering criterion to be used,        C
C  IA, IB, CRIT      history of agglomerations; dimensions   C
C                    N, first N-1 locations only used,       C
C  MEMBR, NN, DISNN  vectors of length N, used to store      C
C                    cluster cardinalities, current nearest  C
C                    neighbour, and the dissimilarity assoc. C
C                    with the latter.                        C
C                    MEMBR must be initialized by R to the   C
C                    default of  rep(1, N)                   C
C  FLAG              boolean indicator of agglomerable obj./ C
C                    clusters.                               C
C                                                            C
C  F. Murtagh, ESA/ESO/STECF, Garching, February 1986.       C
C  Modifications for R: Ross Ihaka, Dec 1996                 C
C                       Fritz Leisch, Jun 2000               C
C  all vars declared:   Martin Maechler, Apr 2001            C
C                                                            C
c- R Bug PR#4195 fixed "along" qclust.c, given in the report C
C- Testing: --> "hclust" in ../../../../tests/reg-tests-1b.R C
C  "ward.D2" (iOpt = 8): Martin Maechler, Mar 2014           C
C------------------------------------------------------------C
      SUBROUTINE HCLUST(N,LEN,IOPT,IA,IB,CRIT,MEMBR,NN,DISNN,
     X                  FLAG,DISS)
c Args
      INTEGER N, LEN, IOPT
      INTEGER IA(N),IB(N), NN(N)
      LOGICAL FLAG(N), isWard
      DOUBLE PRECISION CRIT(N), MEMBR(N),DISS(LEN), DISNN(N)
c Var
      INTEGER IM, JJ, JM, I, NCL, J, IND, I2, J2, K, IND1, IND2
      DOUBLE PRECISION INF, DMIN, D12
c External function
      INTEGER IOFFST
c
c     was 1D+20
      DATA INF/1.D+300/
c
c     unnecessary initialization of im jj jm to keep g77 -Wall happy
c
      IM = 0
      JJ = 0
      JM = 0
C
C  Initializations
C
      DO I=1,N
C        We do not initialize MEMBR in order to be able to restart the
C        algorithm from a cut.
C        MEMBR(I)=1.
         FLAG(I)=.TRUE.
      end do
      NCL=N

      IF (iOpt .eq. 8) THEN ! Ward "D2" ---> using *squared* distances
         do I=1,LEN
            DISS(I)=DISS(I)*DISS(I)
         end do
      ENDIF

C
C  Carry out an agglomeration - first create list of NNs
C  Note NN and DISNN are the nearest neighbour and its distance
C  TO THE RIGHT of I.
C
      DO I=1,N-1
         DMIN=INF
         DO J=I+1,N
            IND=IOFFST(N,I,J)
            IF (DMIN .GT. DISS(IND)) THEN
               DMIN=DISS(IND)
               JM=J
            end if
         end do
         NN(I)=JM
         DISNN(I)=DMIN
      end do

C-- Repeat -------------------------------------------------------
  400 CONTINUE

C     Next, determine least diss. using list of NNs
      DMIN=INF
      DO I=1,N-1
         IF (FLAG(I) .AND. DISNN(I) .LT. DMIN) THEN
            DMIN=DISNN(I)
            IM=I
            JM=NN(I)
         end if
      end do
      NCL=NCL-1
C
C  This allows an agglomeration to be carried out.
C
      I2=MIN0(IM,JM)
      J2=MAX0(IM,JM)
      IA(N-NCL)=I2
      IB(N-NCL)=J2
C     WARD'S "D1", or "D2" MINIMUM VARIANCE METHOD -- iOpt = 1 or 8.
      isWard = (iOpt .eq. 1 .or. iOpt .eq. 8)
      IF (iOpt .eq. 8) DMIN = dsqrt(DMIN)
      CRIT(N-NCL)=DMIN
      FLAG(J2)=.FALSE.
C
C  Update dissimilarities from new cluster.
C
      DMIN=INF
      DO K=1,N
         IF (FLAG(K) .AND. K .NE. I2) THEN
            IF (I2.LT.K) THEN
               IND1=IOFFST(N,I2,K)
            ELSE
               IND1=IOFFST(N,K,I2)
            ENDIF
            IF (J2.LT.K) THEN
               IND2=IOFFST(N,J2,K)
            ELSE
               IND2=IOFFST(N,K,J2)
            ENDIF
            D12=DISS(IOFFST(N,I2,J2))
C
C     WARD'S "D1", or "D2" MINIMUM VARIANCE METHOD - IOPT=8.
            IF (isWard) THEN
               DISS(IND1)=(MEMBR(I2)+MEMBR(K))*DISS(IND1)+
     X              (MEMBR(J2)+MEMBR(K))*DISS(IND2) - MEMBR(K)*D12
               DISS(IND1)=DISS(IND1) / (MEMBR(I2)+MEMBR(J2)+MEMBR(K))
C
C     SINGLE LINK METHOD - IOPT=2.
            ELSEIF (IOPT.EQ.2) THEN
               DISS(IND1)=MIN(DISS(IND1),DISS(IND2))
C
C     COMPLETE LINK METHOD - IOPT=3.
            ELSEIF (IOPT.EQ.3) THEN
               DISS(IND1)=MAX(DISS(IND1),DISS(IND2))
C
C     AVERAGE LINK (OR GROUP AVERAGE) METHOD - IOPT=4.
            ELSEIF (IOPT.EQ.4) THEN
               DISS(IND1)= (MEMBR(I2)*DISS(IND1)+MEMBR(J2)*DISS(IND2))
     X                      / (MEMBR(I2)+MEMBR(J2))
C
C     MCQUITTY'S METHOD - IOPT=5.
            ELSEIF (IOPT.EQ.5) THEN
               DISS(IND1)=(DISS(IND1)+DISS(IND2)) / 2
C
C     MEDIAN (GOWER'S) METHOD aka "Weighted Centroid" - IOPT=6.
            ELSEIF (IOPT.EQ.6) THEN
               DISS(IND1)= ((DISS(IND1)+DISS(IND2)) - D12/2) / 2
C
C     Unweighted CENTROID METHOD - IOPT=7.
            ELSEIF (IOPT.EQ.7) THEN
               DISS(IND1)=(MEMBR(I2)*DISS(IND1)+MEMBR(J2)*DISS(IND2)-
     X              MEMBR(I2)*MEMBR(J2)*D12/(MEMBR(I2)+MEMBR(J2)))/
     X              (MEMBR(I2)+MEMBR(J2))
            ENDIF

C
            IF (I2 .lt. K) THEN
               IF (DISS(IND1) .LT. DMIN) THEN
                  DMIN=DISS(IND1)
                  JJ=K
               ENDIF
            else  ! i2 > k
c	     FIX: the rest of the else clause is a fix by JB to ensure
c            correct nearest neighbours are found when a non-monotone
c            clustering method (e.g. the centroid methods) are used
               if(DISS(IND1) .lt. DISNN(K)) then ! find nearest neighbour of i2
                  DISNN(K) = DISS(IND1)
                  NN(K) = I2
               end if
            ENDIF
         ENDIF
      END DO
      MEMBR(I2)=MEMBR(I2)+MEMBR(J2)
      DISNN(I2)=DMIN
      NN(I2)=JJ
C
C  Update list of NNs insofar as this is required.
C
      DO I=1,N-1
         IF (FLAG(I) .AND.
     X        ((NN(I).EQ.I2) .OR. (NN(I).EQ.J2))) THEN
C     (Redetermine NN of I:)
            DMIN=INF
            DO J=I+1,N
               if (FLAG(J)) then
                  IND=IOFFST(N,I,J)
                  if (DISS(IND) .lt. DMIN) then
                     DMIN=DISS(IND)
                     JJ=J
                  end if
               end if
            end do
            NN(I)=JJ
            DISNN(I)=DMIN
         end if
      end do
C
C  Repeat previous steps until N-1 agglomerations carried out.
C
      IF (NCL.GT.1) GOTO 400
C
C
      RETURN
      END
C     of HCLUST()
C
C
      INTEGER FUNCTION IOFFST(N,I,J)
C  Map row I and column J of upper half diagonal symmetric matrix
C  onto vector.
      INTEGER N,I,J
      IOFFST=J+(I-1)*N-(I*(I+1))/2
      RETURN
      END

C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++C
C                                                               C
C  Given a HIERARCHIC CLUSTERING, described as a sequence of    C
C  agglomerations, prepare the seq. of aggloms. and "horiz."    C
C  order of objects for plotting the dendrogram using S routine C
C  'plclust'.                                                   C
C                                                               C
C  Parameters:                                                  C
C                                                               C
C  IA, IB:       vectors of dimension N defining the agglomer-  C
C                 ations.                                       C
C  IIA, IIB:     used to store IA and IB values differently     C
C                (in form needed for S command 'plclust'        C
C  IORDER:       "horiz." order of objects for dendrogram       C
C                                                               C
C  F. Murtagh, ESA/ESO/STECF, Garching, June 1991               C
C                                                               C
C  HISTORY                                                      C
C                                                               C
C  Adapted from routine HCASS, which additionally determines    C
C   cluster assignments at all levels, at extra comput. expense C
C                                                               C
C---------------------------------------------------------------C
      SUBROUTINE HCASS2(N,IA,IB,IORDER,IIA,IIB)
c Args
      INTEGER N,IA(N),IB(N),IORDER(N),IIA(N),IIB(N)
c Var
      INTEGER I, J, K, K1, K2, LOC
C
C     Following bit is to get seq. of merges into format acceptable to plclust
C     I coded clusters as lowest seq. no. of constituents; S's 'hclust' codes
C     singletons as -ve numbers, and non-singletons with their seq. nos.
C
      do I=1,N
         IIA(I)=IA(I)
         IIB(I)=IB(I)
      end do
      do I=1,N-2
C        In the following, smallest (+ve or -ve) seq. no. wanted
         K=MIN(IA(I),IB(I))
         do J=I+1, N-1
            IF(IA(J).EQ.K) IIA(J)=-I
            IF(IB(J).EQ.K) IIB(J)=-I
         end do
      end do
      do I=1,N-1
         IIA(I)=-IIA(I)
         IIB(I)=-IIB(I)
      end do
      do I=1,N-1
         IF (IIA(I).GT.0 .AND. IIB(I).LT.0) THEN
            K = IIA(I)
            IIA(I) = IIB(I)
            IIB(I) = K
         ENDIF
         IF (IIA(I).GT.0 .AND. IIB(I).GT.0) THEN
            K1 = MIN(IIA(I),IIB(I))
            K2 = MAX(IIA(I),IIB(I))
            IIA(I) = K1
            IIB(I) = K2
         ENDIF
      end do
C
C
C     NEW PART FOR 'ORDER'
C
      IORDER(1) = IIA(N-1)
      IORDER(2) = IIB(N-1)
      LOC=2
      DO I=N-2,1,-1
         DO J=1,LOC
            IF(IORDER(J).EQ.I) THEN
C      REPLACE IORDER(J) WITH IIA(I) AND IIB(I)
               IORDER(J)=IIA(I)
               IF (J.EQ.LOC) THEN
                  LOC=LOC+1
                  IORDER(LOC)=IIB(I)
               else
                  LOC=LOC+1
                  do K=LOC,J+2,-1
                     IORDER(K)=IORDER(K-1)
                  end do
                  IORDER(J+1)=IIB(I)
               end if
               GOTO 171
            ENDIF
         end do
C     SHOULD NEVER REACH HERE
 171     CONTINUE
      end do
C
C
      do I=1,N
         IORDER(I) = -IORDER(I)
      end do
C
C
      RETURN
      END


program prueba

implicit none
real,allocatable,dimension(:,:)::A,L,U,C,inv
real,allocatable,dimension(:)::sol,B,D,H
real:: det
integer::n,m,f,i

call matriz(A,n,n) !ingresar una matriz nxm
call  matlu(A,n,n,L,U) !descomposicion L.U, ,
call matdet(A,n,det)  !determinante
call matcof(A,n,C,inv)  !matriz de cofactores

Write(*,*)"La matriz COFACTORES ES :"
do i=1,n,1
write(*,*) C(i,:)
end do

Write(*,*)"La matriz INVERSA ES :"
do i=1,n,1
write(*,*) inv(i,:)
end do

Write(*,*)"La matriz L ES :"
do i=1,n,1
write(*,*) L(i,:)
end do

Write(*,*)"La matriz U ES :"
do i=1,n,1
write(*,*) U(i,:)
end do

allocate(B(n))
do i=1,n
read(*,*) B(i)
end do

call solveLU(L,U,n,B,sol) !solucinador del sistema LUX=B.

call solcof(B,A,n,H)

 print*, det
 print*, sol(:)
 allocate(D(n))
 D=Matmul(A,sol)
 do i=1,n
 if (F(i)==B(i)) then
 print*, 'todo bien'
 else
 print*, 'todo mal',Matmul(A,sol)
end if
end do

do i=1,n
 write(*,*) H(i)
end do
!-----------------------------------------------------------------------
contains
! ----------------------------------------------------------------------
subroutine  matlu(A,n,m,L,U)

! esta subrutina come una matriz A con n filas y m columnas y devuelve una matriz L y una matriz U

implicit none
real,allocatable,dimension(:,:)::A,L,U,D
integer:: k,h,j,n,m

allocate(L(n,m),U(n,m),D(n,m))
D=A
U=A
do h= 1,m
 do j= 1,n
! j filas, h columnas
if (j>h) then
   do k=1,m
  	U(j,k)=A(j,k)-(A(j,h)/A(h,h))*A(h,k)
   end do
   L(j,h)=(A(j,h)*(1/A(h,h)))
else if (j==h) then
 L(j,h)=1
else
  L(j,h)=0
end if
 end do
A=U
end do
A=D
return
end subroutine
!--------------------------------------------------------------

subroutine matdet(A,n,det)
! esta matriz calcula determinante de una matriz A nxn

implicit none
real,allocatable,dimension(:,:)::A,L,U
integer:: i,n
real::det

if (n==1) then
 det=A(1,1)
else
call matlu(A,n,n,L,U)
det=1
do i=1,n
det=U(i,i)*det
end do
end if
return
end subroutine

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

subroutine matcof(A,n,C,inv)
! esta subrutina come una matriz A con n filas y m columnas y devuelve una matriz C de cofactores

implicit none
real,allocatable,dimension(:,:)::A,C,L,U,C2,inv
integer:: k,h,j,n,i,z
real::det
allocate(C(n,n),C2(n-1,n-1))

!h=f,k=c,i=f,j=c
do h=1,n
do k=1,n

do i=1,n
do j=1,n

!ME ARMO UNA MATRIZ SIN ESA FILA Y COLUMNA Y LE HAGO EL DETERMINANTE
if (j/=k.and.i/=h) then

   if (i<h.and.j<k) then
      C2(i,j)=A(i,j)
   else if (i<h.and.j>k) then
      C2(i,j-1)=A(i,j)
   else if (i>h.and.j<k) then
      C2(i-1,j)=A(i,j)
   else if (i>h.and.j>k) then
      C2(i-1,j-1)=A(i,j)
      else
   end if

end if

end do
end do
  call matdet(C2,(n-1),det)
  C(h,k)=det*((-1)**(h+k))
end do

end do

call matdet(A,n,det)

allocate(inv(n,n))

do i=1,n
do j=1,n
 inv(i,j)=C(j,i)/det
end do
end do

deallocate(C2)
return

end subroutine
!--------------------------------------------------------------
subroutine matriz(mat,fila,colum)
!esta subrutina te genera una matriz mat de fila y columna ingresada
real,allocatable,dimension(:,:)::mat
integer:: fila,colum,fila2,colum2,i

Write(*,*) "Ingrese las dimenciones de la matriz"
Write(*,*) "Filas"
read(*,*) fila
Write(*,*) "Columnas"
read(*,*) colum

allocate(mat(fila,colum))

write(*,*) "Ingrese los elementos de la matriz"
fila2=1
colum2=1

do while(fila2<=fila)
 do while(fila2<=fila.and.colum2<=colum)
 Write(*,*)"Ingrese el elemento de la matriz",fila2,",",colum2
 read(*,*)mat(fila2,colum2)
 colum2=colum2+1
end do
fila2=fila2+1
colum2=1
enddo
Write(*,*)"La matriz ingresada fue :"
do i=1,fila,1
write(*,*) mat(i,:)
end do
return
end subroutine

!---------------------------------------------
!error en la division. reveer
subroutine solveLU(L,U,n,B,solu)
! esta subrutina come una matriz L y U de la descomposicion LU, un vector B
! que es el resultado, donde todas tiene n filas y devuelve el vector solucion

implicit none
real,allocatable,dimension(:,:)::L,U
real,allocatable,dimension(:)::solu,B,sol2
integer:: j,i,n,k
real::suma,suma2

allocate(sol2(n),solu(n))
sol2(:)=1.0d0
solu(:)=1.0d0

do i=1,n

if (i==1) then
 sol2(1)=B(1)/L(1,1)
else
suma=0
do k=1,(i-1)
suma=L(i,k)*sol2(k)+suma
end do
sol2(i)=(1./(L(i,i)))*(B(i)-suma)
end if

end do

solu(n)=sol2(n)/U(n,n)

do i=1,(n-1)
suma2=0
do k=(n-i+1),n
suma2=U(n-i,k)*solu(k)+suma2
end do
solu(n-i)=(1./(U(n-i,n-i)))*(sol2(n-i)-suma2)
end do

deallocate (sol2)
return
end subroutine
!------------------------------
subroutine solcof(B,A,n,D)

implicit none
real,allocatable,dimension(:,:)::A,inv,C
real,allocatable,dimension(:)::D,B
integer:: n

call matcof(A,n,C,inv)
allocate(D(n))
D=matmul(inv,B)

return
end subroutine

end