submodule(forlab) forlab_inv
    use forlab_kinds

contains
        module procedure inv_rsp
        !! inv0 computes the real matrix inverse.
            integer :: i, j, k, m
            real(sp) :: D
            real(sp), dimension(:), allocatable :: x, y, e
            real(sp), dimension(:, :), allocatable :: L, U
            real(sp) :: flag
            if (issquare(A)) then
                m = size(A, 1)
                if (m .le. 3) then
                    D = det(A)
                else
                    D = det(A, L, U)
                end if
                if (D .ne. 0.) then
                    inv_rsp = zeros(m, m, flag)
                    if (m .eq. 2) then
                        inv_rsp (1, 1) = A(2, 2)
                        inv_rsp (1, 2) = -A(1, 2)
                        inv_rsp (2, 1) = -A(2, 1)
                        inv_rsp (2, 2) = A(1, 1)
                        inv_rsp = inv_rsp/D
                    elseif (m .eq. 3) then
                        inv_rsp (1, 1) = A(2, 2)*A(3, 3) - A(2, 3)*A(3, 2)
                        inv_rsp (1, 2) = A(1, 3)*A(3, 2) - A(1, 2)*A(3, 3)
                        inv_rsp (1, 3) = A(1, 2)*A(2, 3) - A(1, 3)*A(2, 2)
                        inv_rsp (2, 1) = A(2, 3)*A(3, 1) - A(2, 1)*A(3, 3)
                        inv_rsp (2, 2) = A(1, 1)*A(3, 3) - A(1, 3)*A(3, 1)
                        inv_rsp (2, 3) = A(1, 3)*A(2, 1) - A(1, 1)*A(2, 3)
                        inv_rsp (3, 1) = A(2, 1)*A(3, 2) - A(2, 2)*A(3, 1)
                        inv_rsp (3, 2) = A(1, 2)*A(3, 1) - A(1, 1)*A(3, 2)
                        inv_rsp (3, 3) = A(1, 1)*A(2, 2) - A(1, 2)*A(2, 1)
                        inv_rsp = inv_rsp/D
                    else
                        do k = 1, m
                            x = zeros(m, flag)
                            y = zeros(m, flag)
                            e = zeros(m, flag)
                            e(k) = 1.
                            y(1) = e(1)

                            ! Forward substitution: Ly = e
                            !==============================
                            do i = 2, m
                                y(i) = e(i)
                                do j = 1, i - 1
                                    y(i) = y(i) - y(j)*L(i, j)
                                end do
                            end do

                            ! Back substitution: Ux = y
                            !===========================
                            x(m) = y(m)/U(m, m)
                            do i = m - 1, 1, -1
                                x(i) = y(i)
                                do j = m, i + 1, -1
                                    x(i) = x(i) - x(j)*U(i, j)
                                end do
                                x(i) = x(i)/U(i, i)
                            end do

                            ! The column k of the inverse is x
                            !==================================
                            inv_rsp (:, k) = x
                        end do
                    end if
                else
                    stop "Error: in det(A), A is not inversible (= 0)."
                end if
            else
                stop "Error: in inv(A), A should be square."
            end if
            return
        end procedure

        module procedure inv_rdp
        !! inv0 computes the real matrix inverse.
            integer :: i, j, k, m
            real(dp) :: D
            real(dp), dimension(:), allocatable :: x, y, e
            real(dp), dimension(:, :), allocatable :: L, U
            real(dp) :: flag
            if (issquare(A)) then
                m = size(A, 1)
                if (m .le. 3) then
                    D = det(A)
                else
                    D = det(A, L, U)
                end if
                if (D .ne. 0.) then
                    inv_rdp = zeros(m, m, flag)
                    if (m .eq. 2) then
                        inv_rdp (1, 1) = A(2, 2)
                        inv_rdp (1, 2) = -A(1, 2)
                        inv_rdp (2, 1) = -A(2, 1)
                        inv_rdp (2, 2) = A(1, 1)
                        inv_rdp = inv_rdp/D
                    elseif (m .eq. 3) then
                        inv_rdp (1, 1) = A(2, 2)*A(3, 3) - A(2, 3)*A(3, 2)
                        inv_rdp (1, 2) = A(1, 3)*A(3, 2) - A(1, 2)*A(3, 3)
                        inv_rdp (1, 3) = A(1, 2)*A(2, 3) - A(1, 3)*A(2, 2)
                        inv_rdp (2, 1) = A(2, 3)*A(3, 1) - A(2, 1)*A(3, 3)
                        inv_rdp (2, 2) = A(1, 1)*A(3, 3) - A(1, 3)*A(3, 1)
                        inv_rdp (2, 3) = A(1, 3)*A(2, 1) - A(1, 1)*A(2, 3)
                        inv_rdp (3, 1) = A(2, 1)*A(3, 2) - A(2, 2)*A(3, 1)
                        inv_rdp (3, 2) = A(1, 2)*A(3, 1) - A(1, 1)*A(3, 2)
                        inv_rdp (3, 3) = A(1, 1)*A(2, 2) - A(1, 2)*A(2, 1)
                        inv_rdp = inv_rdp/D
                    else
                        do k = 1, m
                            x = zeros(m, flag)
                            y = zeros(m, flag)
                            e = zeros(m, flag)
                            e(k) = 1.
                            y(1) = e(1)

                            ! Forward substitution: Ly = e
                            !==============================
                            do i = 2, m
                                y(i) = e(i)
                                do j = 1, i - 1
                                    y(i) = y(i) - y(j)*L(i, j)
                                end do
                            end do

                            ! Back substitution: Ux = y
                            !===========================
                            x(m) = y(m)/U(m, m)
                            do i = m - 1, 1, -1
                                x(i) = y(i)
                                do j = m, i + 1, -1
                                    x(i) = x(i) - x(j)*U(i, j)
                                end do
                                x(i) = x(i)/U(i, i)
                            end do

                            ! The column k of the inverse is x
                            !==================================
                            inv_rdp (:, k) = x
                        end do
                    end if
                else
                    stop "Error: in det(A), A is not inversible (= 0)."
                end if
            else
                stop "Error: in inv(A), A should be square."
            end if
            return
        end procedure

        module procedure inv_rqp
        !! inv0 computes the real matrix inverse.
            integer :: i, j, k, m
            real(qp) :: D
            real(qp), dimension(:), allocatable :: x, y, e
            real(qp), dimension(:, :), allocatable :: L, U
            real(qp) :: flag
            if (issquare(A)) then
                m = size(A, 1)
                if (m .le. 3) then
                    D = det(A)
                else
                    D = det(A, L, U)
                end if
                if (D .ne. 0.) then
                    inv_rqp = zeros(m, m, flag)
                    if (m .eq. 2) then
                        inv_rqp (1, 1) = A(2, 2)
                        inv_rqp (1, 2) = -A(1, 2)
                        inv_rqp (2, 1) = -A(2, 1)
                        inv_rqp (2, 2) = A(1, 1)
                        inv_rqp = inv_rqp/D
                    elseif (m .eq. 3) then
                        inv_rqp (1, 1) = A(2, 2)*A(3, 3) - A(2, 3)*A(3, 2)
                        inv_rqp (1, 2) = A(1, 3)*A(3, 2) - A(1, 2)*A(3, 3)
                        inv_rqp (1, 3) = A(1, 2)*A(2, 3) - A(1, 3)*A(2, 2)
                        inv_rqp (2, 1) = A(2, 3)*A(3, 1) - A(2, 1)*A(3, 3)
                        inv_rqp (2, 2) = A(1, 1)*A(3, 3) - A(1, 3)*A(3, 1)
                        inv_rqp (2, 3) = A(1, 3)*A(2, 1) - A(1, 1)*A(2, 3)
                        inv_rqp (3, 1) = A(2, 1)*A(3, 2) - A(2, 2)*A(3, 1)
                        inv_rqp (3, 2) = A(1, 2)*A(3, 1) - A(1, 1)*A(3, 2)
                        inv_rqp (3, 3) = A(1, 1)*A(2, 2) - A(1, 2)*A(2, 1)
                        inv_rqp = inv_rqp/D
                    else
                        do k = 1, m
                            x = zeros(m, flag)
                            y = zeros(m, flag)
                            e = zeros(m, flag)
                            e(k) = 1.
                            y(1) = e(1)

                            ! Forward substitution: Ly = e
                            !==============================
                            do i = 2, m
                                y(i) = e(i)
                                do j = 1, i - 1
                                    y(i) = y(i) - y(j)*L(i, j)
                                end do
                            end do

                            ! Back substitution: Ux = y
                            !===========================
                            x(m) = y(m)/U(m, m)
                            do i = m - 1, 1, -1
                                x(i) = y(i)
                                do j = m, i + 1, -1
                                    x(i) = x(i) - x(j)*U(i, j)
                                end do
                                x(i) = x(i)/U(i, i)
                            end do

                            ! The column k of the inverse is x
                            !==================================
                            inv_rqp (:, k) = x
                        end do
                    end if
                else
                    stop "Error: in det(A), A is not inversible (= 0)."
                end if
            else
                stop "Error: in inv(A), A should be square."
            end if
            return
        end procedure

        module procedure inv_csp
        !! inv computes the complex matrix inverse.
            real(sp), dimension(:, :), allocatable :: ar, ai
        !! AR stores the real part, AI stores the imaginary part
            integer :: flag, n
            real(sp) :: d, p, t, q, s, b
            integer, dimension(:), allocatable :: is, js
            integer :: i, j, k
            real(sp) :: flag

            if (issquare(A)) then
                n = size(A, 1)
                inv_csp = zeros(n, n, flag)
                ar = zeros(n, n, flag)
                ai = zeros(n, n, flag)
                allocate(is(n),js(n))
                is = 0
                js = 0
                forall (i=1:n, j=1:n)
                    ar(i, j) = real(A(i, j)); ai(i, j) = imag(A(i, j))
                end forall
                flag = 1
                do k = 1, n
                    d = 0.0
                    do i = k, n
                        do j = k, n
                            p = ar(i, j)*ar(i, j) + ai(i, j)*ai(i, j)
                            if (p .gt. d) then
                                d = p
                                is(k) = i
                                js(k) = j
                            end if
                        end do
                    end do
                    if (d + 1.0 .eq. 1.0) then
                        flag = 0
                        stop 'ERROR: A is not inversible (= 0)'
                    end if
                    do j = 1, n
                        t = ar(k, j)
                        ar(k, j) = ar(is(k), j)
                        ar(is(k), j) = t
                        t = ai(k, j)
                        ai(k, j) = ai(is(k), j)
                        ai(is(k), j) = t
                    end do
                    do i = 1, n
                        t = ar(i, k)
                        ar(i, k) = ar(i, js(k))
                        ar(i, js(k)) = t
                        t = ai(i, k)
                        ai(i, k) = ai(i, js(k))
                        ai(i, js(k)) = t
                    end do
                    ar(k, k) = ar(k, k)/d
                    ai(k, k) = -ai(k, k)/d
                    do j = 1, n
                        if (j .ne. k) then
                            p = ar(k, j)*ar(k, k)
                            q = ai(k, j)*ai(k, k)
                            s = (ar(k, j) + ai(k, j))*(ar(k, k) + ai(k, k))
                            ar(k, j) = p - q
                            ai(k, j) = s - p - q
                        end if
                    end do
                    do i = 1, n
                        if (i .ne. k) then
                            do j = 1, n
                                if (j .ne. k) then
                                    p = ar(k, j)*ar(i, k)
                                    q = ai(k, j)*ai(i, k)
                                    s = (ar(k, j) + ai(k, j))*(ar(i, k) + ai(i, k))
                                    t = p - q
                                    b = s - p - q
                                    ar(i, j) = ar(i, j) - t
                                    ai(i, j) = ai(i, j) - b
                                end if
                            end do
                        end if
                    end do
                    do i = 1, n
                        if (i .ne. k) then
                            p = ar(i, k)*ar(k, k)
                            q = ai(i, k)*ai(k, k)
                            s = (ar(i, k) + ai(i, k))*(ar(k, k) + ai(k, k))
                            ar(i, k) = q - p
                            ai(i, k) = p + q - s
                        end if
                    end do
                end do
                do k = n, 1, -1
                    do j = 1, n
                        t = ar(k, j)
                        ar(k, j) = ar(js(k), j)
                        ar(js(k), j) = t
                        t = ai(k, j)
                        ai(k, j) = ai(js(k), j)
                        ai(js(k), j) = t
                    end do
                    do i = 1, n
                        t = ar(i, k)
                        ar(i, k) = ar(i, is(k))
                        ar(i, is(k)) = t
                        t = ai(i, k)
                        ai(i, k) = ai(i, is(k))
                        ai(i, is(k)) = t
                    end do
                end do
                forall (i=1:n, j=1:n)
                    inv_csp (i, j) = dcmplx(ar(i, j), ai(i, j))
                end forall
            else
                stop 'Error: in inv(A), A should be square.'
            end if
            return
        end procedure

        module procedure inv_cdp
        !! inv computes the complex matrix inverse.
            real(dp), dimension(:, :), allocatable :: ar, ai
        !! AR stores the real part, AI stores the imaginary part
            integer :: flag, n
            real(dp) :: d, p, t, q, s, b
            integer, dimension(:), allocatable :: is, js
            integer :: i, j, k
            real(dp) :: flag

            if (issquare(A)) then
                n = size(A, 1)
                inv_cdp = zeros(n, n, flag)
                ar = zeros(n, n, flag)
                ai = zeros(n, n, flag)
                allocate(is(n),js(n))
                is = 0
                js = 0
                forall (i=1:n, j=1:n)
                    ar(i, j) = real(A(i, j)); ai(i, j) = imag(A(i, j))
                end forall
                flag = 1
                do k = 1, n
                    d = 0.0
                    do i = k, n
                        do j = k, n
                            p = ar(i, j)*ar(i, j) + ai(i, j)*ai(i, j)
                            if (p .gt. d) then
                                d = p
                                is(k) = i
                                js(k) = j
                            end if
                        end do
                    end do
                    if (d + 1.0 .eq. 1.0) then
                        flag = 0
                        stop 'ERROR: A is not inversible (= 0)'
                    end if
                    do j = 1, n
                        t = ar(k, j)
                        ar(k, j) = ar(is(k), j)
                        ar(is(k), j) = t
                        t = ai(k, j)
                        ai(k, j) = ai(is(k), j)
                        ai(is(k), j) = t
                    end do
                    do i = 1, n
                        t = ar(i, k)
                        ar(i, k) = ar(i, js(k))
                        ar(i, js(k)) = t
                        t = ai(i, k)
                        ai(i, k) = ai(i, js(k))
                        ai(i, js(k)) = t
                    end do
                    ar(k, k) = ar(k, k)/d
                    ai(k, k) = -ai(k, k)/d
                    do j = 1, n
                        if (j .ne. k) then
                            p = ar(k, j)*ar(k, k)
                            q = ai(k, j)*ai(k, k)
                            s = (ar(k, j) + ai(k, j))*(ar(k, k) + ai(k, k))
                            ar(k, j) = p - q
                            ai(k, j) = s - p - q
                        end if
                    end do
                    do i = 1, n
                        if (i .ne. k) then
                            do j = 1, n
                                if (j .ne. k) then
                                    p = ar(k, j)*ar(i, k)
                                    q = ai(k, j)*ai(i, k)
                                    s = (ar(k, j) + ai(k, j))*(ar(i, k) + ai(i, k))
                                    t = p - q
                                    b = s - p - q
                                    ar(i, j) = ar(i, j) - t
                                    ai(i, j) = ai(i, j) - b
                                end if
                            end do
                        end if
                    end do
                    do i = 1, n
                        if (i .ne. k) then
                            p = ar(i, k)*ar(k, k)
                            q = ai(i, k)*ai(k, k)
                            s = (ar(i, k) + ai(i, k))*(ar(k, k) + ai(k, k))
                            ar(i, k) = q - p
                            ai(i, k) = p + q - s
                        end if
                    end do
                end do
                do k = n, 1, -1
                    do j = 1, n
                        t = ar(k, j)
                        ar(k, j) = ar(js(k), j)
                        ar(js(k), j) = t
                        t = ai(k, j)
                        ai(k, j) = ai(js(k), j)
                        ai(js(k), j) = t
                    end do
                    do i = 1, n
                        t = ar(i, k)
                        ar(i, k) = ar(i, is(k))
                        ar(i, is(k)) = t
                        t = ai(i, k)
                        ai(i, k) = ai(i, is(k))
                        ai(i, is(k)) = t
                    end do
                end do
                forall (i=1:n, j=1:n)
                    inv_cdp (i, j) = dcmplx(ar(i, j), ai(i, j))
                end forall
            else
                stop 'Error: in inv(A), A should be square.'
            end if
            return
        end procedure

        module procedure inv_cqp
        !! inv computes the complex matrix inverse.
            real(qp), dimension(:, :), allocatable :: ar, ai
        !! AR stores the real part, AI stores the imaginary part
            integer :: flag, n
            real(qp) :: d, p, t, q, s, b
            integer, dimension(:), allocatable :: is, js
            integer :: i, j, k
            real(qp) :: flag

            if (issquare(A)) then
                n = size(A, 1)
                inv_cqp = zeros(n, n, flag)
                ar = zeros(n, n, flag)
                ai = zeros(n, n, flag)
                allocate(is(n),js(n))
                is = 0
                js = 0
                forall (i=1:n, j=1:n)
                    ar(i, j) = real(A(i, j)); ai(i, j) = imag(A(i, j))
                end forall
                flag = 1
                do k = 1, n
                    d = 0.0
                    do i = k, n
                        do j = k, n
                            p = ar(i, j)*ar(i, j) + ai(i, j)*ai(i, j)
                            if (p .gt. d) then
                                d = p
                                is(k) = i
                                js(k) = j
                            end if
                        end do
                    end do
                    if (d + 1.0 .eq. 1.0) then
                        flag = 0
                        stop 'ERROR: A is not inversible (= 0)'
                    end if
                    do j = 1, n
                        t = ar(k, j)
                        ar(k, j) = ar(is(k), j)
                        ar(is(k), j) = t
                        t = ai(k, j)
                        ai(k, j) = ai(is(k), j)
                        ai(is(k), j) = t
                    end do
                    do i = 1, n
                        t = ar(i, k)
                        ar(i, k) = ar(i, js(k))
                        ar(i, js(k)) = t
                        t = ai(i, k)
                        ai(i, k) = ai(i, js(k))
                        ai(i, js(k)) = t
                    end do
                    ar(k, k) = ar(k, k)/d
                    ai(k, k) = -ai(k, k)/d
                    do j = 1, n
                        if (j .ne. k) then
                            p = ar(k, j)*ar(k, k)
                            q = ai(k, j)*ai(k, k)
                            s = (ar(k, j) + ai(k, j))*(ar(k, k) + ai(k, k))
                            ar(k, j) = p - q
                            ai(k, j) = s - p - q
                        end if
                    end do
                    do i = 1, n
                        if (i .ne. k) then
                            do j = 1, n
                                if (j .ne. k) then
                                    p = ar(k, j)*ar(i, k)
                                    q = ai(k, j)*ai(i, k)
                                    s = (ar(k, j) + ai(k, j))*(ar(i, k) + ai(i, k))
                                    t = p - q
                                    b = s - p - q
                                    ar(i, j) = ar(i, j) - t
                                    ai(i, j) = ai(i, j) - b
                                end if
                            end do
                        end if
                    end do
                    do i = 1, n
                        if (i .ne. k) then
                            p = ar(i, k)*ar(k, k)
                            q = ai(i, k)*ai(k, k)
                            s = (ar(i, k) + ai(i, k))*(ar(k, k) + ai(k, k))
                            ar(i, k) = q - p
                            ai(i, k) = p + q - s
                        end if
                    end do
                end do
                do k = n, 1, -1
                    do j = 1, n
                        t = ar(k, j)
                        ar(k, j) = ar(js(k), j)
                        ar(js(k), j) = t
                        t = ai(k, j)
                        ai(k, j) = ai(js(k), j)
                        ai(js(k), j) = t
                    end do
                    do i = 1, n
                        t = ar(i, k)
                        ar(i, k) = ar(i, is(k))
                        ar(i, is(k)) = t
                        t = ai(i, k)
                        ai(i, k) = ai(i, is(k))
                        ai(i, is(k)) = t
                    end do
                end do
                forall (i=1:n, j=1:n)
                    inv_cqp (i, j) = dcmplx(ar(i, j), ai(i, j))
                end forall
            else
                stop 'Error: in inv(A), A should be square.'
            end if
            return
        end procedure
end submodule


Program Main
    !====================================================================
    !  eigenvalues and eigenvectors of a real symmetric matrix
    !  Method: calls Jacobi
    !====================================================================
    implicit none
    integer, parameter :: n=3
    double precision :: a(n,n), x(n,n)
    double precision, parameter:: abserr=1.0e-09
    integer i, j

    ! matrix A
      data (a(1,i), i=1,3) /  2.0, -1.0,  0.0 /
      data (a(2,i), i=1,3) / -1.0,  2.0, -1.0 /
      data (a(3,i), i=1,3) /  0.0, -1.0,  2.0 /

    ! print a header and the original matrix
      write (*,200)
      do i=1,n
         write (*,201) (a(i,j),j=1,n)
      end do

      call Jacobi(a,x,abserr,n)

    ! print solutions
      write (*,202)
      write (*,201) (a(i,i),i=1,n)
      write (*,203)
      do i = 1,n
         write (*,201)  (x(i,j),j=1,n)
      end do

    200 format (' Eigenvalues and eigenvectors (Jacobi method) ',/, &
                ' Matrix A')
    201 format (6f12.6)
    202 format (/,' Eigenvalues')
    203 format (/,' Eigenvectors')
end program main

subroutine Jacobi(a,x,abserr,n)
    !===========================================================
    ! Evaluate eigenvalues and eigenvectors
    ! of a real symmetric matrix a(n,n): a*x = lambda*x
    ! method: Jacobi method for symmetric matrices
    ! Alex G. (December 2009)
    !-----------------------------------------------------------
    ! input ...
    ! a(n,n) - array of coefficients for matrix A
    ! n      - number of equations
    ! abserr - abs tolerance [sum of (off-diagonal elements)^2]
    ! output ...
    ! a(i,i) - eigenvalues
    ! x(i,j) - eigenvectors
    ! comments ...
    !===========================================================
    implicit none
    integer i, j, k, n
    double precision a(n,n),x(n,n)
    double precision abserr, b2, bar
    double precision beta, coeff, c, s, cs, sc

    ! initialize x(i,j)=0, x(i,i)=1
    ! *** the array operation x=0.0 is specific for Fortran 90/95
    x = 0.0
    do i=1,n
      x(i,i) = 1.0
    end do

    ! find the sum of all off-diagonal elements (squared)
    b2 = 0.0
    do i=1,n
      do j=1,n
        if (i.ne.j) b2 = b2 + a(i,j)**2
      end do
    end do

    if (b2 <= abserr) return

    ! average for off-diagonal elements /2
    bar = 0.5*b2/float(n*n)

    do while (b2.gt.abserr)
      do i=1,n-1
        do j=i+1,n
          if (a(j,i)**2 <= bar) cycle  ! do not touch small elements
          b2 = b2 - 2.0*a(j,i)**2
          bar = 0.5*b2/float(n*n)
    ! calculate coefficient c and s for Givens matrix
          beta = (a(j,j)-a(i,i))/(2.0*a(j,i))
          coeff = 0.5*beta/sqrt(1.0+beta**2)
          s = sqrt(max(0.5+coeff,0.0))
          c = sqrt(max(0.5-coeff,0.0))
    ! recalculate rows i and j
          do k=1,n
            cs =  c*a(i,k)+s*a(j,k)
            sc = -s*a(i,k)+c*a(j,k)
            a(i,k) = cs
            a(j,k) = sc
          end do
    ! new matrix a_{k+1} from a_{k}, and eigenvectors
          do k=1,n
            cs =  c*a(k,i)+s*a(k,j)
            sc = -s*a(k,i)+c*a(k,j)
            a(k,i) = cs
            a(k,j) = sc
            cs =  c*x(k,i)+s*x(k,j)
            sc = -s*x(k,i)+c*x(k,j)
            x(k,i) = cs
            x(k,j) = sc
          end do
        end do
      end do
    end do
    return
end

Numerical Differentiation and Jacobi Method of Diagonalization/Find Eigenvalue, Diagonalize.f90


-- Empty, the type with no constructors
data Empty : Type

-- Unit, the type with one constructor
data Unit : Type
| void    : Unit

-- Bool, the type with two constructors
data Bool : Type
| true    : Bool
| false   : Bool

-- Natural numbers
data Nat : Type
| succ   : (n : Nat) -> Nat
| zero   : Nat

-- Simple pairs
data Pair : (A : Type) -> Type
| new     : (A : Type, x : A, y : A) -> Pair(A)

-- Polymorphic lists
data List : (A : Type) -> Type
| cons    : (A : Type, x : A, xs : List(A)) -> List(A)
| nil     : (A : Type)                      -> List(A)

-- Vectors, i.e., lists with statically known lengths
data Vect : (A : Type, n : Nat) -> Type
| cons    : (A : Type, n : Nat, x : A, xs : Vect(A, n)) -> Vect(A, Nat.succ(n))
| nil     : (A : Type)                                  -> Vect(A, Nat.zero)

-- Equality type: holds a proof that two values are identical
data Eq : (A : Type, x : A, y : A) -> Type
| refl  : (A : Type, x : A) -> Eq(A, x, x)

-- Polymorphic identity function for a type P
let the(P : Type, x : P) =>
    x

-- Boolean negation
let not(b : Bool) =>
    case b
    | true  => Bool.false
    | false => Bool.true
    : Bool

-- Predecessor of a natural number
let pred(a : Nat) =>
    case a
    | succ(pred) => pred
    | zero       => Nat.zero
    : Nat

-- Double of a number: the keyword `fold` is used for recursion
let double(a : Nat) =>
    case a
    | succ(pred) => Nat.succ(Nat.succ(fold(pred)))
    | zero       => Nat.zero
    : Nat

-- Addition of natural numbers
let add(a : Nat, b : Nat) =>
    (case a
    | succ(pred) => (b : Nat) => Nat.succ(fold(pred, b))
    | zero       => (b : Nat) => b
    : () => (a : Nat) -> Nat)(b)

-- First element of a pair
let fst(A : Type, pair : Pair(A)) =>
    case pair
    | new(A, x, y) => x
    : (A) => A

-- Second element of a pair
let snd(A : Type, pair : Pair(A)) =>
    case pair
    | new(A, x, y) => y
    : (A) => A

-- Principle of explosion: from falsehood, everything follows
let EFQ(P : Type, f : Empty) =>
    case f : P

-- Returns the first element of a vector which is *statically*
-- asserted to be non-empty, preventing runtime errors.
let head(A : Type, n : Nat, vect : Vect(A, Nat.succ(n))) =>
    case vect
    | cons(A, n, x, xs) => x
    | nil(A)            => Unit.void
    : (A, n) => case n
        | succ(m) => A
        | zero    => Unit
        : Type

-- Returns a vector without its first element
let tail(A : Type, n : Nat, vect : Vect(A, Nat.succ(n))) =>
    case vect
    | cons(A0, n0, x, xs) => xs
    | nil(A)              => Vect.nil(A)
    : (A, n) => Vect(A, pred(n))

-- The induction principle on natural numbers
-- can be obtained from total pattern-matching
-- This function gets somewhat bloated by type
-- sigs; could be improved with bidirectional?
let induction(n : Nat) =>
    case n
    | succ(pred) =>
        ( P : (n : Nat) -> Type
        , s : (n : Nat, p : P(n)) -> P(Nat.succ(n))
        , z : P(Nat.zero))
        => s(pred, fold(pred, P, s, z))
    | zero =>
        ( P : (n : Nat) -> Type
        , s : (n : Nat, p : P(n)) -> P(Nat.succ(n))
        , z : P(Nat.zero))
        => z
    : () =>
        ( P : (n : Nat) -> Type
        , s : (n : Nat, p : P(n)) -> P(Nat.succ(n))
        , z : P(Nat.zero))
        -> P(self)

-- The number 2
let two
  Nat.succ(Nat.succ(Nat.zero))

-- The number 4
let four
  add(two, two)

-- Proof that `2 + 2 == 4`
let two-plus-two-is-four
  the(Eq(Nat,add(two,two),four), Eq.refl(Nat,four))

-- Congruence of equality: a proof that `a == b` implies `f(a) == f(b)`
let cong
    ( A : Type
    , B : Type
    , a : A
    , b : A
    , e : Eq(A, a, b)) =>
    case e
    | refl(A, x) => (f : (x : A) -> B) => Eq.refl(B, f(x))
    : (A, a, b)  => (f : (x : A) -> B) -> Eq(B, f(a), f(b))

-- Symmetry of equality: a proof that `a == b` implies `b == a`
let sym
    ( A : Type
    , a : A
    , b : A
    , e : Eq(A, a, b)) =>
    case e
    | refl(A, x) => Eq.refl(A, x)
    : (A, a, b)  => Eq(A, b, a)

-- Substitution of equality: if `a == b`, then `a` can be replaced by `b` in a proof `P`
let subst
    ( A : Type
    , x : A
    , y : A
    , e : Eq(A, x, y)) =>
    case e
    | refl(A, x) => (P : (x : A) -> Type, px : P(x)) => px
    : (A, x, y)  => (P : (x : A) -> Type, px : P(x)) -> P(y)

-- Proof that `a + 0 == a`
let add-n-zero(n : Nat) =>
    case n
    | succ(a) => cong(Nat, Nat, add(a, Nat.zero), a, fold(a), Nat.succ)
    | zero    => Eq.refl(Nat, Nat.zero)
    : Eq(Nat, add(self, Nat.zero), self)

-- Proof that `a + (1 + b) == 1 + (a + b)`
let add-n-succ-m(n : Nat) =>
    case n
    | succ(n) => (m : Nat) => cong(Nat, Nat, add(n, Nat.succ(m)), Nat.succ(add(n,m)), fold(n,m), Nat.succ)
    | zero    => (m : Nat) => Eq.refl(Nat, Nat.succ(m))
    : ()      => (m : Nat) -> Eq(Nat, add(self, Nat.succ(m)), Nat.succ(add(self, m)))

-- Proof that `a + b = b + a`
let add-comm(n : Nat) =>
    case n
    | succ(n) => (m : Nat) =>
        subst(Nat, add(m,n), add(n,m), fold(m,n), (x : Nat) => Eq(Nat, Nat.succ(x), add(m, Nat.succ(n))),
        sym(Nat, add(m, Nat.succ(n)), Nat.succ(add(m, n)), add-n-succ-m(m, n)))
    | zero    => (m : Nat) => sym(Nat, add(m, Nat.zero), m, add-n-zero(m))
    : ()      => (m : Nat) -> Eq(Nat, add(self, m), add(m, self))

let main (a : Nat, b : Nat, e : Eq(Nat, a, b)) => sym(Nat, a, b, e)


module sub
	contains

		subroutine subm(N)
		integer::N
		real*8 a(N,N),B(N,N),x

		write(*,*)"input the Matrix"
		read(*,*)((A(i,j),j=1,N),i=1,N)
		do i=1,N
			do j=1,N
				if(i==j) then
				B(i,j)=1
				else
				B(i,j)=0
				end if
			end do
		end do
		do j=1,N
			x=A(j,j)
			do k=1,N
				A(j,k)=A(j,k)/x
				B(j,k)=B(j,k)/x

			end do
			do i=1,N
				if(i/=j)then
				x=A(i,j)
				do k=1,N
				A(i,k)=A(i,k)-A(j,k)*x
				B(i,k)=B(i,k)-x*B(j,k)
				end do
				end if
			end do
		end do
		write(*,'(f22.6)')((B(i,j),j=1,N),i=1,N)

		end subroutine subm

end module


!Factorial Function
real*8 function factorial(n)
    implicit none
    integer, intent(in) :: n
    real*8 :: Ans
    integer :: i

    Ans = 1
    do i=1,n
        Ans = Ans * dble(i)
    end do

    factorial = Ans
end function factorial

!Function to compute radial Zernike polynomial at radius rho of order n,m
real*8 function radialpoly(rho,n,m)
    !Declarations
    implicit none
    real*8, intent(in) :: rho
    integer, intent(in) :: n,m
    real*8 :: output
    real*8 :: const, factorial
    integer :: j

    !n,m are assumed to be valid (m>=n, n-abs(m) is even)
    !Following Python module convention, negative m indicates sinusoidal Zernike
    output = 0.
    if (rho<=1) then
        do j = 0,(n-abs(m))/2
            const = (-1)**j*factorial(n-j)/factorial(j)/factorial((n+m)/2-j)/factorial((n-m)/2-j)
            output = output + const*rho**(n-2*j)
        end do
    end if

    radialpoly = output

end function radialpoly

!This function makes use of the q recursive method to compute a Zernike
!Radial polynomial
recursive function fastradpoly(rho,n,m) result(output)
  !Declarations
  implicit none
  real*8, intent(in) :: rho,n,m
  !integer, intent(in) :: n,m
  real*8 :: output,r2,r4,h1,h2,h3,tempm

  !Handle rho=0
  if (rho==0) then
    if (m==0) then
      output = (-1.)**(n/2)
      return
    else
      output = 0.
      return
    end if
  end if

  !Three possibilities, m=n, m=n-2, m<n-2
  if (m==n) then
    output = rho**n
    return
  else if (m==n-2) then
    output = n*rho**n - (n-1)*rho**(n-2)
    return
  else
    tempm = n-4
    r4 = rho**n
    r2 = n*rho**n - (n-1)*rho**(n-2)
    do while(tempm >= m)
      h3 = -4*(tempm+2)*(tempm+1)/(n+tempm+2)/(n-tempm)
      h2 = h3*(n+tempm+4)*(n-tempm-2)/4./(tempm+3) + (tempm+2)
      h1 = .5*(tempm+4)*(tempm+3) - (tempm+4)*h2 + h3*(n+tempm+6)*(n-tempm-4)/8.
      output = h1*r4 + (h2 + h3/rho**2)*r2
      if (tempm == m) then
        return
      end if
      r4 = r2
      r2 = output
      tempm = tempm - 2
    end do
  end if

end function fastradpoly

!This function makes use of the q recursive method to compute a Zernike
!Radial polynomial DERIVATIVE
recursive function fastradder(rho,n,m) result(output)
  !Declarations
  implicit none
  real*8, intent(in) :: rho
  real*8, intent(in) :: n,m
  real*8 :: output,r2,r4,h1,h2,h3,fastradpoly,tempm

  !Handle rho=0
  if (rho==0) then
    if (m==1) then
      output = (-1.)**((n-1)/2)*(n+1)/2
      return
    else
      output = 0.
      return
    end if
  end if

  !Three possibilities, m=n, m=n-2, m<n-2
  if (m==n) then
    output = n*rho**(n-1)
    return
  else if (m==n-2) then
    output = n*(n*rho**(n-1)) - (n-1)*(n-2)*rho**(n-3)
    return
  else
    tempm = n-4
    r4 = n*rho**(n-1)
    r2 = n*(n*rho**(n-1)) - (n-1)*(n-2)*rho**(n-3)
    do while(tempm >= m)
      h3 = -4*(tempm+2)*(tempm+1)/(n+tempm+2)/(n-tempm)
      h2 = h3*(n+tempm+4)*(n-tempm-2)/4./(tempm+3) + (tempm+2)
      h1 = .5*(tempm+4)*(tempm+3) - (tempm+4)*h2 + h3*(n+tempm+6)*(n-tempm-4)/8.
      !Might need to literally copy and paste fastradpoly here to save on function call...
      output = h1*r4 + (h2 + h3/rho**2)*r2 - 2*h3*fastradpoly(rho,n,tempm+2)/rho**3
      if (tempm == m) then
        return
      end if
      r4 = r2
      r2 = output
      tempm = tempm - 2
    end do
  end if

end function fastradder

!This function will return a vector of Zernike polynomial evaluations for
!a point (rho,theta) and a number N of standard Zernike polynomials
!Start at n=0, and loop up in radial order
!For each radial order, start at Znn, and recursively calculate down
!Adding azimuthal dependence is easy, just note what overall index you're at
!and add sinmt if odd and cosmt if even, where Z1 = 1, so Z2=2rcost
!Still need special handling of rho=0
subroutine zernset(rho,theta,rorder,aorder,znum,polyout,derrho,dertheta)
  !Declarations
  implicit none
  integer, intent(in) :: znum
  integer, intent(in) :: rorder(znum),aorder(znum)
  real*8, intent(in) :: rho,theta
  real*8, intent(out) :: polyout(znum),derrho(znum),dertheta(znum)
  real*8, allocatable :: rnm(:,:),rprime(:,:)
  integer :: i,j,radnum,tznum
  real*8 :: n,m,mm,h1,h2,h3,norm
  real*8 :: fastradpoly,fastradder,zernthetader,zernrhoder,zernike

  !Allocate temp output array for full sets of radial polynomials
  !Will slice off unused terms at the end
  tznum = 1
  radnum = 1
  do while(tznum < znum)
    tznum = tznum + (radnum + 1)
    radnum = radnum + 1
  end do
  !print *, tznum, " ", radnum
  !Allocate radnum by radnum arrays for radial polynomials
  !This is much larger than necessary, but for practical purposes this should be ok
  allocate(rnm(radnum,radnum))
  allocate(rprime(radnum,radnum))

  !Compute radial polynomials and derivatives
  do i=1,radnum
    n = dble(i)-1
    do j=int(n)+1,1,-2
      m = dble(j)-1
      !Handle case rho=0
      if (rho==0) then
        if (m==1) then
          rprime(i,j) = (-1.)**((n-1)/2)*(n+1)/2
          rnm(i,j) = 0.
        else if (m==0) then
          rprime(i,j) = 0.
          rnm(i,j) = (-1.)**(n/2)
        else
          rprime(i,j) = 0.
          rnm(i,j) = 0.
        end if
      !Handle general case
      else
        if (n==m) then
          rnm(i,j) = rho**n
          rprime(i,j) = n*rho**(n-1)
        else if (m==n-2) then
          rnm(i,j) = n*rnm(i,i) - (n-1)*rnm(i-2,i-2)
          rprime(i,j) = n*rprime(i,i) - (n-1)*rprime(i-2,i-2)
        else
          h3 = -4*(m+2)*(m+1)/(n+m+2)/(n-m)
          h2 = h3*(n+m+4)*(n-m-2)/4./(m+3) + (m+2)
          h1 = .5*(m+4)*(m+3) - (m+4)*h2 + h3*(n+m+6)*(n-m-4)/8.
          rnm(i,j) = h1*rnm(i,j+4) + (h2+h3/rho**2)*rnm(i,j+2)
          rprime(i,j) = h1*rprime(i,j+4) + (h2+h3/rho**2)*rprime(i,j+2) - 2*h3/rho**3*rnm(i,j+2)
        end if
      end if
      !print *, i-1, " ", j-1
      !print *, rnm(i,j), " ", fastradpoly(rho,dble(i-1),dble(j-1))
      !print *, rprime(i,j), " ", fastradder(rho,dble(i-1),dble(j-1))
    end do
  end do

  !Radial terms are computed. Now construct Zernike, Zernderrho, and Zerndertheta
  !Use standard order up to znum
  do i=1,znum
    !Rorder and Aorder are passed to this function
    !Simply construct if statement on m, and compute all three!
    n = rorder(i)
    mm = aorder(i)
    m = abs(mm)
    norm = sqrt(2*(n+1))
    if (mm<0) then
        polyout(i) = norm * rnm(int(n)+1,int(m)+1) * sin(m*theta)
        derrho(i) = norm * rprime(int(n)+1,int(m)+1) * sin(m*theta)
        dertheta(i) = norm * rnm(int(n)+1,int(m)+1) * cos(m*theta) * m
    else if (mm>0) then
        polyout(i) = norm * rnm(int(n)+1,int(m)+1) * cos(m*theta)
        derrho(i) = norm * rprime(int(n)+1,int(m)+1) * cos(m*theta)
        dertheta(i) = -norm * rnm(int(n)+1,int(m)+1) * sin(m*theta) * m
    else
        polyout(i) = norm*sqrt(0.5)*rnm(int(n)+1,int(m)+1)
        derrho(i) = norm*sqrt(0.5)*rprime(int(n)+1,int(m)+1)
        dertheta(i) = 0.
    end if
    !print *, dertheta(i), " ",zernthetader(rho,theta,int(n),int(mm))
  end do

end subroutine zernset

!Function to compute full Zernike polynomial at radius rho and angle theta of order n,m
!Following Python Zernike mod conventions
real*8 function zernike(rho,theta,n,m)
    !Declarations
    implicit none
    real*8, intent(in) :: rho,theta
    integer, intent(in) :: n,m
    real*8 :: fastradpoly,rnm,znm,norm

    !Compute radial polynomial
    rnm = fastradpoly(rho,dble(n),abs(dble(m)))

    !Compute full Zernike polynomial
    norm = sqrt(2*(dble(n)+1))
    if (m<0) then
        znm = norm * rnm * sin(m*theta)
    else if (m>0) then
        znm = norm * rnm * cos(m*theta)
    else
        znm = norm*sqrt(0.5)*rnm
    end if

    !Return Zernike polynomial
    zernike = znm

end function zernike

!Function to compute radial polynomial derivative
real*8 function radialder(rho,n,m)
    !Declarations
    implicit none
    real*8, intent(in) :: rho
    integer, intent(in) :: n,m
    real*8 :: output
    real*8 :: const, factorial
    integer :: j
    !n,m are assumed to be valid (m>=n, n-abs(m) is even)
    !Following Python module convention, negative m indicates sinusoidal Zernike
    output = 0.
    if (rho<=1) then
        do j = 0,(n-abs(m))/2
            const = (-1)**j*factorial(n-j)/factorial(j)/factorial((n+m)/2-j)/factorial((n-m)/2-j)
            output = output + const*(n-2*j)*rho**(n-2*j-1)
        end do
    end if

    radialder = output

end function radialder

!Function to compute partial Zernike derivative wrt rho
real*8 function zernrhoder(rho,theta,n,m)
    !Declarations
    implicit none
    real*8, intent(in) :: rho,theta
    integer, intent(in) :: n,m
    real*8 :: fastradder, rnm, norm, znm

    !Compute radial polynomial
    rnm = fastradder(rho,dble(n),abs(dble(m)))

    !Compute full Zernike polynomial
    norm = sqrt(2*(dble(n)+1))
    if (m<0) then
        znm = norm * rnm * sin(abs(m)*theta)
    else if (m>0) then
        znm = norm * rnm * cos(m*theta)
    else
        znm = norm*sqrt(0.5)*rnm
    end if

    !Return Zernike polynomial
    zernrhoder = znm

end function zernrhoder

!Function to compute partial Zernike derivative wrt theta
real*8 function zernthetader(rho,theta,n,m)
    !Declarations
    implicit none
    real*8, intent(in) :: rho,theta
    integer, intent(in) :: n,m
    real*8 :: rnm, znm, fastradpoly, norm

    !Compute radial polynomial
    rnm = fastradpoly(rho,dble(n),abs(dble(m)))

    !Compute full Zernike polynomial
    norm = sqrt(2*(dble(n)+1))
    if (m<0) then
        znm = norm * rnm * abs(m) * cos(abs(m)*theta)
    else if (m>0) then
        znm = -norm * rnm * m * sin(m*theta)
    else
        znm = 0.
    end if

    !Return Zernike polynomial
    zernthetader = znm

end function zernthetader

!This function computes a Legendre polynomial of order n
real*8 function legendre(x,n)
  !Declarations
  implicit none
  real*8, intent(in) :: x
  integer, intent(in) :: n
  integer :: i
  real*8 :: factorial,x2

  if (abs(x) > 1.) then
    x2 = x/abs(x)
  else
    x2 = x
  end if

  legendre = 0.
  if (n==0) then
    legendre = 1.
  else
    do i=0,floor(real(n)/2)
      legendre = legendre + (-1)**(i)*factorial(2*n-2*i)/factorial(i)/factorial(n-i)/factorial(n-2*i)/2**n*x2**(n-2*i)
    end do
  end if

end function legendre

!This function computes a Legendre polynomial first derivative of order n
real*8 function legendrep(x,n)
  !Declarations
  implicit none
  real*8, intent(in) :: x
  integer, intent(in) :: n
  integer :: i
  real*8 :: factorial

  legendrep = 0.
  if (n==0) then
    legendrep = 0.
  else if (n==1) then
    legendrep = 1.
  else if (x==0. .and. mod(n,2)==0) then
    legendrep = 0.
  else
    do i=0,floor(real(n)/2)
      legendrep = legendrep + (-1)**(i)*factorial(2*n-2*i)/factorial(i)/factorial(n-i)/factorial(n-2*i)/2**n*(n-2*i)*x**(n-2*i-1)
    end do
  end if

  if (abs(x) > 1.) then
    legendrep = 0.
  end if

end function legendrep


    MODULE random_normal_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      FUNCTION random_normal(mean,sd)
! .. Use Statements ..
        USE random_standard_normal_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        REAL :: random_normal
! ..
! .. Scalar Arguments ..
        REAL, INTENT (IN) :: mean, sd
! ..
! .. Executable Statements ..

!**********************************************************************
!     REAL FUNCTION GENNOR( MEAN, SD )
!         GENerate random deviate from a NORmal distribution
!                              Function
!     Generates a single random deviate from a normal distribution
!     with mean, MEAN, and standard deviation, SD.
!                              Arguments
!     MEAN --> Mean of the normal distribution.
!                              REAL MEAN
!     SD --> Standard deviation of the normal distribution.
!                              REAL SD
!     JJV                      (SD >= 0)
!     GENNOR <-- Generated normal deviate.
!                              REAL GENNOR
!                              Method
!     Renames SNORM from TOMS as slightly modified by BWB to use RANF
!     instead of SUNIF.
!     For details see:
!               Ahrens, J.H. and Dieter, U.
!               Extensions of Forsythe's Method for Random
!               Sampling from the Normal Distribution.
!               Math. Comput., 27,124 (Oct. 1973), 927 - 937.
!**********************************************************************
!     JJV added check to ensure SD >= 0.0
        IF (sd<0.0) THEN
          WRITE (*,*) 'SD < 0.0 in GENNOR - ABORT'
          WRITE (*,*) 'Value of SD: ', sd
          STOP 'SD < 0.0 in GENNOR - ABORT'
        END IF

        random_normal = sd*random_standard_normal() + mean
        RETURN

      END FUNCTION random_normal

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

    END MODULE random_normal_mod


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!     this program tests subroutine compute_gaussian_latitudes_and_weights for computing
!     the Gauss Legendre points and weights in file compute_gaussian_latitudes_and_weights.f
!     It tests only the april 2002 version and not the
!     older version in file compute_gaussian_latitudes_and_weights.old.f
!     gauss points and weights are computed using newtons method
!     with equally spaced points as first guess. Points are
!     computed as theta_i where x_i = cos(theta_i)
!     the method is discussed in "On computing the Gauss_Legendre
!     points and weights" by Paul N Swarztrauber, accepted for
!     publication in the SIAM journal of scientific computing.
!                         April 2002
!
program test_gaussian_latitudes_and_weights_routines

    use, intrinsic :: ISO_Fortran_env, only: &
        sp => REAL32, &
        stdout => OUTPUT_UNIT

    use spherepack, only: &
        ip, & ! Integer precision
        wp, & ! Working precision
        compute_gaussian_latitudes_and_weights, pi

    ! Explicit typing only
    implicit none

    real(wp) :: dmax
    real(wp) :: hold
    integer(ip) :: i
    integer(ip) :: ido
    integer(ip) :: ierror
    integer(ip) :: irm
    integer(ip) :: ldw
    integer(ip) :: lwork
    integer(ip), parameter :: NLAT = 63
    real(wp) :: pmax
    real(wp) :: rerr
    real(wp) :: rmax

    real(wp) :: sums

    real(wp) :: tdoub
    real(wp) :: tsing
    real(wp) :: wmax

    real(wp) :: theta(NLAT), wts(NLAT), work(NLAT+2)
    real(wp) :: dtheta(NLAT), dwts(NLAT)
    real(wp) :: dwmx, tmax, dwmax, dtmax
    real     :: theta_sp(NLAT), wts_sp(NLAT), work_sp(nlat + 1)
    real     :: diff(NLAT)
    real(sp) :: t1(2), t2(2)
    real     :: sumw

    ! Description
    write (stdout, '(/a/)') &
        '     gaussian_latitudes_and_weights_routines *** TEST RUN *** '

    lwork = NLAT+1
    hold = etime(t1)
    hold = t1(1)
    call gsqd(NLAT, theta, wts, work, lwork, ierror)
    tdoub = etime(t1)
    tdoub = t1(1)-hold

    ! Check error flag
    if (ierror /= 0) write (stdout, '(a, i5)') ' ierror = ', ierror

    write (stdout, '(a, 1pe15.6)') ' tdoub ', tdoub

    ! Compare double with double
    ldw = NLAT+2
    hold = etime(t1)
    hold = t1(1)
    call compute_gaussian_latitudes_and_weights(NLAT, dtheta, dwts, ierror)
    tdoub = etime(t1)
    tdoub = t1(1)-hold

    if (ierror /= 0) write (stdout, '(a, i5)') ' ierror = ', ierror

    write (stdout, '(a, 1pe15.6)') &
        ' tdoub compute_gaussian_latitudes_and_weights', tdoub

    dwmx = 0.0
    tmax = 0.0
    dwmax = 0.0
    dtmax = 0.0
    ido = (nlat + 1)/2

    do i=1, ido
        dtmax = max(dtmax, abs(theta(i)-dtheta(i)))
        dwmax = max(dwmax, abs(wts(i)-dwts(i)))
        tmax = max(tmax, abs(theta(i)))
        dwmx = max(dwmx, abs(wts(i)))
    end do

    dtmax = dtmax/tmax
    dwmax = dwmax/dwmx
    write (stdout, 33) NLAT, dtmax, dwmax
33  format(' nlat', i6, '  points ', 1pd15.6, ' weights ', d15.6)

    sumw = sum(wts)

    write (stdout, 638) sumw
638 format('  sumw ', 1pd39.30)

    hold = etime(t2)
    hold = t2(1)
    lwork = NLAT+2
    call sgaqd(NLAT, theta_sp, wts_sp, work_sp, lwork, ierror)
    tsing = etime(t2)
    tsing = t2(1)-hold
    if (ierror /= 0) write (stdout, 5) ierror
5   format(' iserror=', i5)

    sums =sum(wts_sp)

    write (stdout, 636) sums
636 format('  sums ', 1pe24.15)
    dmax = 0.0
    wmax = 0.0
    rmax = 0.0
    ido = (nlat + 1)/2
    do i=1, ido
        diff(i) = wts(i)-wts_sp(i)
        dmax = max(dmax, abs(diff(i)))
        wmax = max(wmax, abs(wts_sp(i)))
        rerr = abs(diff(i)/wts_sp(i))
        if (rerr>rmax) then
            rmax = rerr
            irm = i
        end if
6       format(' wts ', 1pd15.6, ' swts ', e15.6, ' rpter ', e15.6)
    end do

    !      write (stdout, 7) (diff(i), i=nlat-25, nlat)
7   format(' diff in weights'/(1p8e10.03))
    dmax = dmax/wmax
    write (stdout, 9) NLAT, irm, dmax, rmax
9   format(' weights: nlat ', i6, ' irele ', i6, &
        ' dmax ', 1pe15.6, ' rmax ', 1pe15.6)
    dmax = 0.0
    pmax = 0.0
    rmax = 0.0
    do i=1, ido
        diff(i) = theta(i)-theta_sp(i)
        dmax = max(dmax, abs(diff(i)))
        pmax = max(pmax, abs(theta_sp(i)))
        rerr = abs(diff(i)/theta_sp(i))
        if (rerr>rmax) then
            rmax = rerr
            irm = i
        end if
    end do
    !      write (stdout, 11) (diff(i), i=nlat-25, nlat)
11  format(' diff in points'/(1p8e10.03))
    dmax = dmax/pmax
    write (stdout, 12) NLAT, irm, dmax, rmax
12  format(' points:  nlat ', i6, ' irele ', i6, &
        ' dmax ', 1pe15.6, ' rmax ', 1pe15.6)

    dmax = 0.0
    do i=1, NLAT
        diff(i) = cos(theta(i))-cos(theta_sp(i))
        dmax = max(dmax, abs(diff(i)))
    end do

    ! format(' diff in points'/(1p8e10.03))
    write (stdout, 112) dmax
112 format(' max difference in mu', 1pe15.6)
    write (stdout, 1) NLAT, tsing, tdoub
1   format(' nlat', i6, ' tsing', 1pe15.6, ' tdoub', e15.6)

contains
    !
    !     subroutine gsqd is a single precision version of compute_gaussian_latitudes_and_weights.
    !     gauss points and weights are computed using newtons method
    !     with equally spaced points as first guess. Points are
    !     computed as theta_i where x_i = cos(theta_i)
    !     the method is discussed in "On computing the Gauss_Legendre
    !     points and weights" by Paul N Swarztrauber, accepted for
    !     publication in the SIAM journal of scientific computing.
    !                         April 2002
    !
    subroutine gsqd(nlat, theta, wts, dwork, ldwork, ierror)

        integer(ip) :: i
        integer(ip) :: ierror
        integer(ip) :: ldwork
        integer(ip) :: nlat
        integer(ip) :: ns2
        !
        !
        !     subroutine gsqd computes the nlat gaussian colatitudes and weights
        !     in real. The colatitudes are in radians and lie in the
        !     in the interval (0, pi).
        !
        !     input parameters
        !
        !     nlat    the number of gaussian colatitudes in the interval (0, pi)
        !             (between the two poles).  nlat must be greater than zero.
        !
        !     dwork   a real temporary workspace.
        !
        !     ldwork  the length of the workspace  in the routine calling gsqd
        !             ldwork must be at least nlat+1.
        !
        !     output parameters
        !
        !     theta   a real vector of length nlat containing the
        !             nlat gaussian colatitudes on the sphere in increasing radians
        !             in the interval (0, pi).
        !
        !     wts     a real vector of length nlat containing the
        !             nlat gaussian weights.
        !
        !     ierror = 0 no errors
        !            = 1 if ldwork.lt.nlat+1
        !            = 2 if nlat<=0
        !
        !  *****************************************************************
        !
        dimension dwork(nlat + 1), theta(nlat), wts(nlat)
        real HALF_PI, x, theta, wts, dwork
        ierror = 1
        !
        !     check workspace length
        !
        if (ldwork<nlat+1) return
        ierror = 2
        if (nlat<=0) return
        ierror = 0
        !
        !     compute weights and points analytically when nlat=1, 2
        !
        if (nlat==1) then
            theta(1) = acos(0.0)
            wts(1) = 2.0
            return
        end if
        if (nlat==2) then
            x = sqrt(1.0/3.0)
            theta(1) = acos(x)
            theta(2) = acos(-x)
            wts(1) = 1.0
            wts(2) = 1.0
            return
        end if
        !
        !     compute points
        !
        call gsqd_lower_utility_routine(nlat, theta, dwork)
        !
        !     compute weights
        !
        call egwts(nlat, theta, wts, dwork)
        !
        !     extend points and weights via symmetries
        !
        HALF_PI = acos(-1.0)
        ns2 = nlat/2
        do i=1, ns2
            wts(nlat-i+1) = wts(i)
            theta(nlat-i+1) = HALF_PI-theta(i)
        end do
        return
    end subroutine gsqd
    !
    subroutine gsqd_lower_utility_routine(nlat, theta, cp)

        real(wp) :: eps
        real(wp) :: summation

        integer(ip) :: it
        integer(ip) :: nhalf
        integer(ip) :: nix
        integer(ip) :: nlat
        integer(ip) :: ns2
        real  theta((nlat + 1)/2), cp(nlat/2+1)
        real pi, HALF_PI, dtheta, dthalf, &
            cmax, dcor, pb, dpb, sgnd, zero, zlast
        !
        eps = sqrt(epsilon(1.0))
        eps = eps*sqrt(eps)
        PI = acos(-1.0)
        HALF_PI = PI/2
        theta(1) = HALF_PI
        if (nlat==1) goto 30
        ns2 = nlat/2
        nhalf = (nlat + 1)/2
        !
        call dlfcz (nlat, cp)
        !
        !      check fourier-legendre coefficients
        !
        summation = sum(cp(1:ns2+1))/ns2

        !format(' check on dble f-l coefficients ', 1pe15.6)
        !
        dtheta = HALF_PI/nhalf
        dthalf = dtheta/2.0
        cmax = .2*dtheta
        if (mod(nlat, 2)/=0) then
            theta(nhalf) = HALF_PI
            zero = HALF_PI-dtheta
            nix = nhalf-1
        else
            zero = HALF_PI-dthalf
            nix = nhalf
        end if
9       it = 0
10      it = it+1
        zlast = zero
        !
        !     newton iterations to convergence
        !
        call lft (0, nlat, zero, cp, pb)
        call dlft (0, nlat, zero, cp, dpb)
        dcor = pb/dpb
        sgnd = 1.0
        if (dcor /= 0.0) sgnd = dcor/abs(dcor)
        !      write (stdout, 2) nix, zero, theta(nix), dcor, cmax, sgnd
2       format(i7, 1p5d15.6)
        dcor = sgnd*min(abs(dcor), cmax)
        zero = zero-dcor
        if (abs(zero-zlast)>eps*abs(zero)) goto 10
        theta(nix) = zero
        nix = nix-1
        if (nix==0) goto 30
        if (nix==nhalf-1)  zero = 3.0*zero-pi
        if (nix<nhalf-1)  zero = zero+zero-theta(nix+2)
        goto 9
30      return
    end subroutine gsqd_lower_utility_routine

    subroutine egwts(n, theta, wts, work)

        integer(ip) :: n
        !
        !     computes gauss weights as described in swarztrauber
        !     and spotz, generalized harmonic transforms
        !
        real theta(n), wts(n), work(n+1)
        !
        call egwts1(n, theta, wts, work, work(n/2+2))

    end subroutine egwts

    subroutine egwts1(n, theta, wts, dcp, cp)

        integer(ip) :: i
        integer(ip) :: n
        integer(ip) :: nhalf
        real theta((n+1)/2), wts((n+1)/2), cp((n-1)/2+1), &
            dcp(n/2+1), fn, sqnn, pb, dpb
        fn = n
        sqnn = sqrt((fn+fn-1)*(fn+fn+1))
        call dlfcz (n-1, cp)
        call dlfcz (n, dcp)
        nhalf = (n+1)/2
        do i=1, nhalf
            call lft(0, n-1, theta(i), cp, pb)
            call dlft(0, n, theta(i), dcp, dpb)
            wts(i) = -sqnn*sin(theta(i))/(fn*pb*dpb)
        end do

    end subroutine egwts1

    subroutine lfc (m, n, cp)

        integer(ip) :: i
        integer(ip) :: l
        integer(ip) :: m
        integer(ip) :: ma
        integer(ip) :: n
        integer(ip) :: nex
        integer(ip) :: nmms2
        !
        real cp, fnum, fden, fnmh, a1, b1, c1, cp2, fnnp1, fnmsq, fk, &
            t1, t2, pm1, sc10, sc20, sc40
        dimension       cp(n/2+1)
        parameter (sc10=1024.0)
        parameter (sc20=sc10*sc10)
        parameter (sc40=sc20*sc20)
        !
        cp(1) = 0.0
        ma = iabs(m)
        if (ma > n) return
        if (n-1< 0) then
            goto 2
        else if (n-1 == 0) then
            goto 3
        else
            goto 5
        end if
2       cp(1) = sqrt(2.0)
        return
3       if (ma /= 0) goto 4
        cp(1) = sqrt(1.5)
        return
4       cp(1) = sqrt(.75)
        if (m == -1) cp(1) = -cp(1)
        return
5       if (mod(n+ma, 2) /= 0) goto 10
        nmms2 = (n-ma)/2
        fnum = n+ma+1
        fnmh = n-ma+1
        pm1 = 1.0
        goto 15
10      nmms2 = (n-ma-1)/2
        fnum = n+ma+2
        fnmh = n-ma+2
        pm1 = -1.0
        !      t1 = 1.
        !      t1 = 2.0**(n-1)
        !      t1 = 1.0/t1
15      t1 = 1.0/sc20
        nex = 20
        fden = 2.0
        if (nmms2 < 1) goto 20
        do 18 i=1, nmms2
            t1 = fnum*t1/fden
            if (t1 > sc20) then
                t1 = t1/sc40
                nex = nex+40
            end if
            fnum = fnum+2.
            fden = fden+2.
18      continue
20      t1 = t1/2.0**(n-1-nex)
        if (mod(ma/2, 2) /= 0) t1 = -t1
        t2 = 1.
        if (ma == 0) goto 26
        do 25 i=1, ma
            t2 = fnmh*t2/(fnmh+pm1)
            fnmh = fnmh+2.
25      continue
26      cp2 = t1*sqrt((n+.5)*t2)
        fnnp1 = n*(n+1)
        fnmsq = fnnp1-2.0*ma*ma
        l = (n+1)/2
        if (mod(n, 2) == 0 .and. mod(ma, 2) == 0) l = l+1
        cp(l) = cp2
        if (m >= 0) goto 29
        if (mod(ma, 2) /= 0) cp(l) = -cp(l)
29      if (l <= 1) return
        fk = n
        a1 = (fk-2.)*(fk-1.)-fnnp1
        b1 = 2.*(fk*fk-fnmsq)
        cp(l-1) = b1*cp(l)/a1
30      l = l-1
        if (l <= 1) return
        fk = fk-2.
        a1 = (fk-2.)*(fk-1.)-fnnp1
        b1 = -2.*(fk*fk-fnmsq)
        c1 = (fk+1.)*(fk+2.)-fnnp1
        cp(l-1) = -(b1*cp(l)+c1*cp(l+1))/a1
        goto 30
    end subroutine lfc
    subroutine lft (m, n, theta, cp, pb)

        integer(ip) :: k
        integer(ip) :: kdo
        integer(ip) :: m
        integer(ip) :: mmod
        integer(ip) :: n
        integer(ip) :: nmod
        real cp(*), pb, theta, cdt, sdt, cth, sth, chh
        cdt = cos(2.0*theta)
        sdt = sin(2.0*theta)
        nmod=mod(n, 2)
        mmod=mod(m, 2)
        if (nmod< 0) then
            goto 1
        else if (nmod == 0) then
            goto 1
        else
            goto 2
        end if
1       if (mmod< 0) then
            goto 3
        else if (mmod == 0) then
            goto 3
        else
            goto 4
        end if
        !
        !     n even, m even
        !
3       kdo=n/2
        pb = .5*cp(1)
        if (n == 0) return
        cth = cdt
        sth = sdt
        do 170 k=1, kdo
            !     pb = pb+cp(k+1)*cos(2*k*theta)
            pb = pb+cp(k+1)*cth
            chh = cdt*cth-sdt*sth
            sth = sdt*cth+cdt*sth
            cth = chh
170     continue
        return
        !
        !     n even, m odd
        !
4       kdo = n/2
        pb = 0.0
        cth = cdt
        sth = sdt
        do 180 k=1, kdo
            !     pb = pb+cp(k)*sin(2*k*theta)
            pb = pb+cp(k)*sth
            chh = cdt*cth-sdt*sth
            sth = sdt*cth+cdt*sth
            cth = chh
180     continue
        return
2       if (mmod< 0) then
            goto 13
        else if (mmod == 0) then
            goto 13
        else
            goto 14
        end if
        !
        !     n odd, m even
        !
13      kdo = (n+1)/2
        pb = 0.0
        cth = cos(theta)
        sth = sin(theta)
        do 190 k=1, kdo
            !     pb = pb+cp(k)*cos((2*k-1)*theta)
            pb = pb+cp(k)*cth
            chh = cdt*cth-sdt*sth
            sth = sdt*cth+cdt*sth
            cth = chh
190     continue
        return
        !
        !     n odd, m odd
        !
14      kdo = (n+1)/2
        pb = 0.0
        cth = cos(theta)
        sth = sin(theta)
        do 200 k=1, kdo
            !     pb = pb+cp(k)*sin((2*k-1)*theta)
            pb = pb+cp(k)*sth
            chh = cdt*cth-sdt*sth
            sth = sdt*cth+cdt*sth
            cth = chh
200     continue
        return
    end subroutine lft
    subroutine dlft (m, n, theta, cp, pb)

        integer(ip) :: k
        integer(ip) :: kdo
        integer(ip) :: m
        integer(ip) :: mmod
        integer(ip) :: n
        integer(ip) :: nmod
        !
        !     computes the derivative of pmn(theta) with respect to theta
        !
        dimension cp(1)
        real cp, pb, theta, cdt, sdt, cth, sth, chh
        cdt = cos(2.0*theta)
        sdt = sin(2.0*theta)
        nmod=mod(n, 2)
        mmod=mod(abs(m), 2)
        if (nmod< 0) then
            goto 1
        else if (nmod == 0) then
            goto 1
        else
            goto 2
        end if
1       if (mmod< 0) then
            goto 3
        else if (mmod == 0) then
            goto 3
        else
            goto 4
        end if
        !
        !     n even, m even
        !
3       kdo=n/2
        pb = 0.0
        if (n == 0) return
        cth = cdt
        sth = sdt
        do 170 k=1, kdo
            !     pb = pb+cp(k+1)*cos(2*k*theta)
            pb = pb-2.0*k*cp(k+1)*sth
            chh = cdt*cth-sdt*sth
            sth = sdt*cth+cdt*sth
            cth = chh
170     continue
        return
        !
        !     n even, m odd
        !
4       kdo = n/2
        pb = 0.0
        cth = cdt
        sth = sdt
        do 180 k=1, kdo
            !     pb = pb+cp(k)*sin(2*k*theta)
            pb = pb+2.0*k*cp(k)*cth
            chh = cdt*cth-sdt*sth
            sth = sdt*cth+cdt*sth
            cth = chh
180     continue
        return
2       if (mmod< 0) then
            goto 13
        else if (mmod == 0) then
            goto 13
        else
            goto 14
        end if
        !
        !     n odd, m even
        !
13      kdo = (n+1)/2
        pb = 0.0
        cth = cos(theta)
        sth = sin(theta)
        do 190 k=1, kdo
            !     pb = pb+cp(k)*cos((2*k-1)*theta)
            pb = pb-(2.0*k-1)*cp(k)*sth
            chh = cdt*cth-sdt*sth
            sth = sdt*cth+cdt*sth
            cth = chh
190     continue
        return
        !
        !     n odd, m odd
        !
14      kdo = (n+1)/2
        pb = 0.0
        cth = cos(theta)
        sth = sin(theta)
        do 200 k=1, kdo
            !     pb = pb+cp(k)*sin((2*k-1)*theta)
            pb = pb+(2.0*k-1)*cp(k)*cth
            chh = cdt*cth-sdt*sth
            sth = sdt*cth+cdt*sth
            cth = chh
200     continue

    end subroutine dlft

    subroutine dlfcz(n, cp)

        integer(ip) :: i
        integer(ip) :: ic
        integer(ip) :: j
        integer(ip) :: n
        integer(ip) :: ncp
        !
        !     computes the fourier coefficients of the legendre
        !     polynomials. n is the degree and integer(n/2+1)
        !     coefficients are returned in cp
        !
        real cp(n/2+1)
        real cn, t1, t2, t3, t4, coef, fi
        !
        cn = 2.0
        write (stdout, 9) cn
9       format(' check1 on dble cn ', 1pd20.011)
        if (n>0) then
            ic = 0
            fi = 0.0
            do i=1, n
                fi = fi+2.0
                cn = (1.0-1.0/fi**2)*cn
                if (abs(cn) > 5.0 .and. ic == 0) then
                    ic = 1
                    write (stdout, 7) i, cn
7                   format('  i ', i7, ' check3 on cn', 1pd15.6)
                end if
            end do
        end if
        write (stdout, 8) cn
8       format(' check2 on dble cn ', 1pd20.011)
        cn = sqrt(cn)
        ncp = n/2+1
        t1 = -1.0
        t2 = n+1.0
        t3 = 0.0
        t4 = n+n+1.0
        cp(ncp) = cn
        coef = 1.0
        write (stdout, 11) cn
11      format(' check on dble cn ', 1pd20.011)
        !      do j = ncp-1, 1, -1
        j = ncp
10      j = j-1
        t1 = t1+2.0
        t2 = t2-1.0
        t3 = t3+1.0
        t4 = t4-2.0
        coef = (t1*t2)/(t3*t4)*coef
        cp(j) = coef*cn
        if (j>1) goto 10
        !      end do
        return
    end subroutine dlfcz
    !
    subroutine sgaqd(nlat, theta, wts, w, lwork, ierror)

        real(wp) :: cmax
        real(wp) :: cz
        real(wp) :: dcor
        real(wp) :: dpb
        real(wp) :: dthalf
        real(wp) :: dtheta
        real(wp) :: eps
        integer(ip) :: i
        integer(ip) :: idx
        integer(ip) :: ierror
        integer(ip) :: it
        integer(ip) :: itmax
        integer(ip) :: lwork
        integer(ip) :: mnlat
        integer(ip) :: nhalf
        integer(ip) :: nix
        integer(ip) :: nlat
        integer(ip) :: ns2
        real(wp) :: pb
        real(wp) :: pi
        real(wp) :: HALF_PI
        real(wp) :: sgnd
        real(wp) :: theta
        real(wp) :: w
        real(wp) :: wts
        real(wp) :: x
        real(wp) :: zero
        real(wp) :: zhold
        real(wp) :: zlast
        real(wp) :: zprev
        !
        !                             February 2002
        !
        !     gauss points and weights are computed using the fourier-newton
        !     described in "on computing the points and weights for
        !     gauss-legendre quadrature", paul n. swarztrauber, siam journal
        !     on scientific computing that has been accepted for publication.
        !     This routine is faster and more accurate than older program
        !     with the same name.
        !
        !     subroutine sgaqd computes the nlat gaussian colatitudes and
        !     weights in single precision. the colatitudes are in radians
        !     and lie in the interval (0, pi).
        !
        !     input parameters
        !
        !     nlat    the number of gaussian colatitudes in the interval (0, pi)
        !             (between the two poles).  nlat must be greater than zero.
        !
        !     w       unused variable that permits a simple exchange with the
        !             old routine with the same name in spherepack.
        !
        !     lwork   unused variable that permits a simple exchange with the
        !             old routine with the same name in spherepack.
        !
        !     output parameters
        !
        !     theta   a vector of length nlat containing the nlat gaussian
        !             colatitudes on the sphere in increasing radians
        !             in the interval (0, pi).
        !
        !     wts     a vector of length nlat containing the
        !                   nlat gaussian weights.
        !
        !     ierror = 0 no errors
        !            = 1 if nlat<=0
        !
        !  *****************************************************************
        !
        dimension theta(nlat), wts(nlat), w(*)
        real(wp) :: summation
        !
        !     check workspace length
        !
        ierror = 1
        if (nlat<=0) return
        ierror = 0
        !
        !     compute weights and points analytically when nlat=1, 2
        !
        if (nlat==1) then
            theta(1) = acos(0.0)
            wts(1) = 2.0
            return
        end if
        if (nlat==2) then
            x = sqrt(1.0/3.0)
            theta(1) = acos(x)
            theta(2) = acos(-x)
            wts(1) = 1.0
            wts(2) = 1.0
            return
        end if
        eps = sqrt(epsilon(1.0))
        eps = eps*sqrt(eps)
        HALF_PI = acos(0.0)
        pi = HALF_PI+HALF_PI
        mnlat = mod(nlat, 2)
        ns2 = nlat/2
        nhalf = (nlat + 1)/2
        idx = ns2+2
        !
        call lfcz (nlat, cz, theta(ns2+1), wts(ns2+1))
        !
        dtheta = HALF_PI/nhalf
        dthalf = dtheta/2.0
        cmax = .2*dtheta
        !
        !     estimate first point next to theta = pi/2
        !
        if (mnlat/=0) then
            zprev = HALF_PI
            zero = HALF_PI-dtheta
            nix = nhalf-1
        else
            zero = HALF_PI-dthalf
            nix = nhalf
        end if
        itmax = 0
9       it = 0
10      it = it+1
        zlast = zero
        !
        !     newton iterations
        !
        call slpdp (nlat, zero, cz, theta(ns2+1), wts(ns2+1), pb, dpb)
        dcor = pb/dpb
        sgnd = 1.0
        if (dcor /= 0.0) sgnd = dcor/abs(dcor)
        dcor = sgnd*min(abs(dcor), cmax)
        zero = zero-dcor
        if (abs(zero-zlast)>eps*abs(zero)) goto 10
        theta(nix) = zero
        zhold = zero
        !      wts(nix) = (nlat+nlat+1)/(dpb*dpb)
        !
        !     yakimiw's formula permits using old pb and dpb
        !
        wts(nix) = (nlat+nlat+1)/(dpb+pb*cos(zlast)/sin(zlast))**2
        nix = nix-1
        if (nix==0) goto 30
        if (nix==nhalf-1)  zero = 3.0*zero-pi
        if (nix<nhalf-1)  zero = zero+zero-zprev
        zprev = zhold
        goto 9
        !
        !     extend points and weights via symmetries
        !
30      if (mnlat/=0) then
            theta(nhalf) = HALF_PI
            call slpdp (nlat, HALF_PI, cz, theta(ns2+1), wts(ns2+1), pb, dpb)
            wts(nhalf) = (nlat+nlat+1)/(dpb*dpb)
        end if
        do i=1, ns2
            wts(nlat-i+1) = wts(i)
            theta(nlat-i+1) = pi-theta(i)
        end do
        summation = 0.0
        do i=1, nlat
            summation = summation+wts(i)
        end do
        do i=1, nlat
            wts(i) = 2.0*wts(i)/summation
        end do
        return
    end subroutine sgaqd
    subroutine lfcz(n, cz, cp, dcp)

        real(wp) :: cp
        real(wp) :: cz
        real(wp) :: dcp
        integer(ip) :: j
        integer(ip) :: n
        integer(ip) :: ncp
        real(wp) :: t1
        real(wp) :: t2
        real(wp) :: t3
        real(wp) :: t4
        !
        !     computes the fourier coefficients of the legendre
        !     polynomial p_n^0 and its derivative.
        !     n is the degree and n/2 or (n+1)/2
        !     coefficients are returned in cp depending on whether
        !     n is even or odd. The same number of coefficients
        !     are returned in dcp. For n even the constant
        !     coefficient is returned in cz.
        !
        dimension cp((n+1)/2), dcp((n+1)/2)
        ncp = (n+1)/2
        t1 = -1.0
        t2 = n+1.0
        t3 = 0.0
        t4 = n+n+1.0
        if (mod(n, 2)==0) then
            cp(ncp) = 1.0
            do j = ncp, 2, -1
                t1 = t1+2.0
                t2 = t2-1.0
                t3 = t3+1.0
                t4 = t4-2.0
                cp(j-1) = (t1*t2)/(t3*t4)*cp(j)
            end do
            t1 = t1+2.0
            t2 = t2-1.0
            t3 = t3+1.0
            t4 = t4-2.0
            cz = (t1*t2)/(t3*t4)*cp(1)
            do j=1, ncp
                dcp(j) = (j+j)*cp(j)
            end do
        else
            cp(ncp) = 1.0
            do j = ncp-1, 1, -1
                t1 = t1+2.0
                t2 = t2-1.0
                t3 = t3+1.0
                t4 = t4-2.0
                cp(j) = (t1*t2)/(t3*t4)*cp(j+1)
            end do
            do j=1, ncp
                dcp(j) = (j+j-1)*cp(j)
            end do
        end if

    end subroutine lfcz

    subroutine slpdp (n, theta, cz, cp, dcp, pb, dpb)

        real(wp) :: cdt
        real(wp) :: chh
        real(wp) :: cp
        real(wp) :: cost
        real(wp) :: cz
        real(wp) :: dcp
        real(wp) :: dpb
        real(wp) :: fn
        integer(ip) :: k
        integer(ip) :: kdo
        integer(ip) :: n
        real(wp) :: pb
        real(wp) :: sdt
        real(wp) :: sint
        real(wp) :: theta
        !
        !     computes pn(theta) and its derivative dpb(theta) with
        !                          respect to theta
        !
        dimension cp(n/2+1), dcp(n/2+1)
        !
        fn = real(n)
        cdt = cos(2.0*theta)
        sdt = sin(2.0*theta)
        if (mod(n, 2) ==0) then
            !
            !     n even
            !
            kdo = n/2
            pb = .5*cz
            dpb = 0.0
            if (n > 0) then
                cost = cdt
                sint = sdt
                do k=1, kdo
                    !      pb = pb+cp(k)*cos(2*k*theta)
                    pb = pb+cp(k)*cost
                    !      dpb = dpb-(k+k)*cp(k)*sin(2*k*theta)
                    dpb = dpb-dcp(k)*sint
                    chh = cdt*cost-sdt*sint
                    sint = sdt*cost+cdt*sint
                    cost = chh
                end do
            end if
        else
            !
            !     n odd
            !
            kdo = (n+1)/2
            pb = 0.0
            dpb = 0.0
            cost = cos(theta)
            sint = sin(theta)
            do k=1, kdo
                !      pb = pb+cp(k)*cos((2*k-1)*theta)
                pb = pb+cp(k)*cost
                !      dpb = dpb-(k+k-1)*cp(k)*sin((2*k-1)*theta)
                dpb = dpb-dcp(k)*sint
                chh = cdt*cost-sdt*sint
                sint = sdt*cost+cdt*sint
                cost = chh
            end do
        end if

    end subroutine slpdp

end program test_gaussian_latitudes_and_weights_routines


!> Test rkf45 demo1,
!> solve a Bernoulli differential equation using rkf45:
!> y' = y - 2*x/y
program rkf45_demo1

    use rkf45_module, only: rkf45, rk

    integer, parameter :: neqn = 1
    real(rk) :: t = 0.0_rk, t_out = 0.0_rk, y(neqn)
    real(rk) :: relerr = epsilon(1.0), abserr = epsilon(1.0)
    integer :: flag = 1
    integer :: iwork(5), i, n_step = 5
    real(rk) :: work(3 + 6*neqn)
    real(rk) :: t_start = 0.0_rk, t_end = 1.0_rk

    print "(A/)", "rkf45 demo1: solve a Bernoulli differential equation, y' = y - 2*x/y"
    print "(A6, *(A18))", "T", "Y", "Y_Exact", "Error"

    y = 1.0
    do i = 1, n_step

        t = t_start + (i - 1)*(t_end - t_start)/n_step
        t_out = t_start + i*(t_end - t_start)/n_step
        call rkf45(fcn, neqn, y, t, t_out, relerr, abserr, flag, work, iwork)

        print "(F6.2, 3ES18.10)", t, y(1), fx(t), fx(t) - y(1)

    end do

contains

    !> Evaluates the derivative for the ODE
    subroutine fcn(t, y, yp)
        real(rk), intent(in) :: t
        real(rk), intent(in) :: y(:)
        real(rk), intent(out) :: yp(:)

        yp(1) = y(1) - 2.0_rk*t/y(1)

    end subroutine fcn

    !> Exact solution
    real(rk) function fx(t)
        real(rk), intent(in) :: t

        fx = sqrt(1.0_rk + 2.0_rk*t)

    end function fx

end program rkf45_demo1


      Subroutine gravity(lat,g)
c       calculates g as a funciton of latitude using the 1980 IUGG formula
c
c       Bulletin Geodesique, Vol 62, No 3, 1988 (Geodesist's Handbook)
c       p 356, 1980 Gravity Formula (IUGG, H. Moritz)
c       units are in m/sec^2 and have a relative precision of 1 part
c       in 10^10 (0.1 microGal)
c       code by M. Zumberge.
c
c       check values are:
c
c        g = 9.780326772 at latitude  0.0
c        g = 9.806199203 at latitude 45.0
c        g = 9.832186368 at latitude 90.0
c
      real*8 gamma, c1, c2, c3, c4, phi, lat, g

      gamma = 9.7803267715
      c1 = 0.0052790414
      c2 = 0.0000232718
      c3 = 0.0000001262
      c4 = 0.0000000007
      phi = lat * 3.14159265358979 / 180.0
      g = gamma * (1.0
     $ + c1 * ((sin(phi))**2)
     $ + c2 * ((sin(phi))**4)
     $ + c3 * ((sin(phi))**6)
     $ + c4 * ((sin(phi))**8))
c
      return
      end


      SUBROUTINE moment(data,n,ave,adev,sdev,var,skew,curt)
!****  From Numerical Recipes
!  Given an array of DATA of length N, this routine returns its mean AVE,
!  average deviation ADEV, standard deviation SDEV, variance VAR,
!  skewness SKEW, and kurtosis CURT.
      INTEGER n
      REAL adev,ave,curt,sdev,skew,var,data(n)
      INTEGER j
      REAL p,s,ep

      IF(n.le.1) PRINT*,' n must be at least 2 in moment'
      s=0.
      do 11 j=1,n
        s=s+data(j)
11    continue
      ave=s/n
      adev=0.
      var=0.
      skew=0.
      curt=0.
      ep=0.
      do 12 j=1,n
        s=data(j)-ave
        ep=ep+s
        adev=adev+abs(s)
        p=s*s
        var=var+p
        p=p*s
        skew=skew+p
        p=p*s
        curt=curt+p
12    continue
      adev=adev/n
      var=(var-ep**2/n)/(n-1)
      sdev=sqrt(var)
      if(var.ne.0.)then
        skew=skew/(n*sdev**3)
        curt=curt/(n*var**2)-3.
      else
         PRINT*,' no skew or kurtosis when zero variance in moment'
      endif
      return
      END


    program demo_norm2
    implicit none
    integer :: i

    real :: x(3,3) = reshape([ &
       1, 2, 3, &
       4, 5 ,6, &
       7, 8, 9  &
    ],shape(x),order=[2,1])

    write(*,*) 'x='
    write(*,'(4x,3f4.0)')transpose(x)

    write(*,*) 'norm2(x)=',norm2(x)

    write(*,*) 'x**2='
    write(*,'(4x,3f4.0)')transpose(x**2)
    write(*,*)'sqrt(sum(x**2))=',sqrt(sum(x**2))

    end program demo_norm2


      double precision function DPVAL(KORDER, NPC, XI, PC, X, IDERIV)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DPVAL Krogh  Changes to use M77CON
c>> 1992-10-27 DPVAL C. L. Lawson, JPL  Saving LEFTI
c>> 1988-03-16 C. L. Lawson, JPL
c
c     Computes value at X of the derivative of order IDERIV of a
c     piecewise polynomial given by coeffs relative to the Power basis.
c     The piecewise polynomial is specified by the arguments
c     XI, PC, NPC, KORDER.
c     The "proper interpolation interval" for X is from XI(1) to
c     XI(NPC+1), but extrapolation will be used outside this interval.
c     Based on subroutine PPVALU given on pp. 89-90 of
c     A PRACTICAL GUIDE TO SPLINES by Carl De Boor, Springer-Verlag,
c     1978, however PPVALU uses the Taylor basis and this subr uses
c     the Power basis.
c     The cases of IDERIV = 0, 1, or 2 are coded individually for
c     best efficiency.  The cases of 3 .le. IDERIV .lt. KORDER are
c     treated in a general way.
c     The result is zero when IDERIV .ge. KORDER.
c     ------------------------------------------------------------------
c     KORDER   [in]  Order of the polynomial pieces.  This is one
c           greater than the degree of the pieces.  KORDER is also the
c           leading dimension of the array PC(,).
c     NPC   [in]  Number of polynomial pieces.
c     (XI(j), j = 1, ..., NPC+1)  [in]  Breakpoints defining the
c           subintervals over which the polynomial pieces are defined.
c     ((PC(i,j), i = 1, ..., KORDER), j = 1, ..., NPC)  [in]
c           PC(*,j) contains the coefficients to be used to evaluate
c           the polynomial piece between XI(j) and XI(j+1).
c           PC(i,j) is the coefficient to be multiplied times
c           (X - X(j))**(i-1).
c     X  [in]  Abcissa at which function is to be evaluated.
c     IDERIV   [in]  Order of derivative to be evaluated.
c           Require IDERIV .ge. 0.  IDERIV = 0 means to evaluate the
c           function itself.  Derivatives of order .ge. KORDER will
c           be zero.
c     DPVAL [out]    The computed value or derivative value.
c     ------------------------------------------------------------------
c--D replaces "?": ?PVAL, ?SFIND
c     ------------------------------------------------------------------
      integer I, IDERIV, LEFTI, KORDER, MODE, NPC
      double precision DX, FAC, FAC1, FAC2
      double precision ONE, X, XI(NPC+1), PC(KORDER,NPC), VAL, ZERO
      parameter(ONE=1.0D0, ZERO=0.0D0)
      save LEFTI
      data LEFTI / 1/
c     ------------------------------------------------------------------
      call DSFIND ( XI, 1, NPC+1, X, LEFTI, MODE )
      DX = X - XI(LEFTI)

      if(IDERIV .eq. 0) then
         VAL = PC(KORDER,LEFTI)
         do 10  I  = KORDER-1, 1, -1
            VAL = VAL * DX + PC(I,LEFTI)
   10    continue
      elseif(IDERIV .eq. 1) then
         FAC1 = dble(KORDER-1)
         VAL = FAC1 * PC(KORDER,LEFTI)
         do 20 I = KORDER-1, 2, -1
            FAC1 = FAC1 - ONE
            VAL = VAL * DX + FAC1 * PC(I,LEFTI)
   20    continue
      elseif(IDERIV .eq. 2) then
         FAC1 = dble(KORDER-1)
         FAC2 = FAC1 - ONE
         VAL = FAC1 * FAC2 * PC(KORDER,LEFTI)
         do 30 I = KORDER-1, 3, -1
            FAC1 = FAC2
            FAC2 = FAC2 - ONE
            VAL = VAL * DX + FAC1 * FAC2 * PC(I,LEFTI)
   30    continue
      elseif(IDERIV .ge. KORDER) then
         VAL = ZERO
      else
c                           Here when 3 .le. IDERIV .lt. KORDER
c
         FAC1 = dble(KORDER-1)
         FAC2 = FAC1
         FAC = FAC1
         do 40 I = 2, IDERIV
            FAC2 = FAC2 - ONE
            FAC = FAC * FAC2
   40    continue
         VAL = FAC * PC(KORDER,LEFTI)
         do 60 I = KORDER-1, IDERIV+1, -1
            FAC2 = FAC2 - ONE
            FAC = (FAC / FAC1) * FAC2
            FAC1 = FAC1 - ONE
            VAL = VAL * DX + FAC * PC(I,LEFTI)
   60    continue
      endif
      DPVAL = VAL
      return
      end


! Exercise 2, p. 68
!
! Calculating the temperature due to cold front passage

program ex_2

    use iso_fortran_env, only: real32, int32, output_unit

    implicit none

    real(real32), parameter :: temp1 = 12.  ! temperature in Atlanta (°C)
    real(real32), parameter :: temp2 = 24.  ! temperature in Miami (°C)

    real(real32), parameter :: dx = 960.    ! distance between Atlanta & Miami (km)
    real(real32), parameter :: c = 20.      ! speed in km/h

    real(real32), parameter :: dt = 1.      ! time increment (h)

    real(real32), dimension(8) :: timestamps = [6, 12, 18, 24, 30, 36, 42, 48]
    real(real32), dimension(8) :: result

    integer(int32) :: i

    ! update temperature in Miami
    result = update_temp(temp1, temp2, c, dx, timestamps)

    ! print result to screen
    do i = 1, 8
        write(output_unit, *) "Temperature after", timestamps(i), " hours is" , result(i), "degrees."
    end do

    contains

        real(real32) pure elemental function update_temp(temp1, temp2, c, dx, dt)
            real(real32), intent(in) :: temp1, temp2, c, dx, dt

            update_temp = temp2 - c * (temp2 - temp1) / dx * dt
        end function update_temp

end program ex_2


      program atmos_gaussian
      implicit none
c
c --- Usage: echo JH | atmos_gaussian
c ---   print the 2*JH latitudes of the specified gaussian grid
c
c --- A "Gaussian" grid, is regular in longitude and
c ---   almost regular in latitude (Hortal and Simmons, 1991).
c --- https://en.wikipedia.org/wiki/Gaussian_grid
c
      integer              :: jh,j
      real*8               :: pscale
      real*4,  allocatable :: plat(:)
      real*8,  allocatable :: slat(:)
c
      read(5,*) jh
c
      allocate( plat(2*jh) )
      allocate( slat(  jh) )
c
      call glat8(jh,slat)
      pscale = 180.d0/acos(-1.d0)
      do j= 1,jh
        plat(2*jh+1-j) =  pscale*asin(slat(j))
        plat(       j) = -plat(2*jh+1-j)
      enddo !j
      do j= 1,2*jh
        write(6,'(f10.5)') plat(j)
      enddo
      end
      SUBROUTINE GLAT8(JH,SLAT)
      IMPLICIT NONE
C
      INTEGER JH
      REAL*8  SLAT(JH)
C
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    GLAT        COMPUTE GAUSSIAN LATITUDE FUNCTIONS
C   PRGMMR: IREDELL          ORG: W/NMC23     DATE: 92-10-31
C
C ABSTRACT: COMPUTES SINES OF GAUSSIAN LATITUDE BY ITERATION.
C
C PROGRAM HISTORY LOG:
C   91-10-31  MARK IREDELL
C
C USAGE:    CALL GLAT(JH,SLAT)
C
C   INPUT ARGUMENT LIST:
C     JH       - INTEGER NUMBER OF GAUSSIAN LATITUDES IN A HEMISPHERE
C
C   OUTPUT ARGUMENT LIST:
C     SLAT     - REAL (JH) SINES OF (POSITIVE) GAUSSIAN LATITUDE
C
C ATTRIBUTES:
C   LANGUAGE: CRAY FORTRAN
C
C$$$
C
      INTEGER   JBZ
      PARAMETER(JBZ=50)
      REAL*8    PI,C,EPS
      PARAMETER(PI=3.14159265358979,C=(1.-(2./PI)**2)*0.25,EPS=1.E-14)
C
      INTEGER ITS,J,N
      REAL*8  PKM2,R,SP,SPMAX
      REAL*8  PK(JH),PKM1(JH)
C
      REAL*8  BZ(JBZ)
      DATA BZ        / 2.4048255577,  5.5200781103,
     $  8.6537279129, 11.7915344391, 14.9309177086, 18.0710639679,
     $ 21.2116366299, 24.3524715308, 27.4934791320, 30.6346064684,
     $ 33.7758202136, 36.9170983537, 40.0584257646, 43.1997917132,
     $ 46.3411883717, 49.4826098974, 52.6240518411, 55.7655107550,
     $ 58.9069839261, 62.0484691902, 65.1899648002, 68.3314693299,
     $ 71.4729816036, 74.6145006437, 77.7560256304, 80.8975558711,
     $ 84.0390907769, 87.1806298436, 90.3221726372, 93.4637187819,
     $ 96.6052679510, 99.7468198587, 102.888374254, 106.029930916,
     $ 109.171489649, 112.313050280, 115.454612653, 118.596176630,
     $ 121.737742088, 124.879308913, 128.020877005, 131.162446275,
     $ 134.304016638, 137.445588020, 140.587160352, 143.728733573,
     $ 146.870307625, 150.011882457, 153.153458019, 156.295034268 /
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  ESTIMATE LATITUDES USING BESSEL FUNCTION
      R=1./SQRT((2*JH+0.5)**2+C)
      DO J=1,MIN(JH,JBZ)
        SLAT(J)=COS(BZ(J)*R)
      ENDDO
      DO J=JBZ+1,JH
        SLAT(J)=COS((BZ(JBZ)+(J-JBZ)*PI)*R)
      ENDDO
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  CONVERGE UNTIL ALL SINES OF GAUSSIAN LATITUDE ARE WITHIN EPS
      DO 110 ITS= 1,999
        SPMAX=0.
        DO J=1,JH
          PKM1(J)=1.
          PK(J)=SLAT(J)
        ENDDO
        DO N=2,2*JH
          DO J=1,JH
            PKM2=PKM1(J)
            PKM1(J)=PK(J)
            PK(J)=((2*N-1)*SLAT(J)*PKM1(J)-(N-1)*PKM2)/N
          ENDDO
        ENDDO
        DO J=1,JH
          SP=PK(J)*(1.-SLAT(J)**2)/(2*JH*(PKM1(J)-SLAT(J)*PK(J)))
          SLAT(J)=SLAT(J)-SP
          SPMAX=MAX(SPMAX,ABS(SP))
        ENDDO
        IF     (SPMAX.LE.EPS) THEN
          GOTO 1110
        ENDIF
  110 CONTINUE
 1110 CONTINUE
      RETURN
C     END OF GLAT8.
      END


program test_kernel

  use mo_kind,   only: i4, dp
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_kernel, only: kernel_regression_h, kernel_regression
  use mo_kernel, only: kernel_density_h, kernel_density
  use mo_kernel, only: kernel_cumdensity
  !$ USE omp_lib,    only: OMP_GET_THREAD_NUM, OMP_GET_NUM_THREADS
  ! use IEEE_exceptions

  implicit none

  integer(i4)                            :: ii, nn
  real(dp),    dimension(2)              :: h
  real(dp),    dimension(10,2)           :: x
  real(dp),    dimension(10)             :: y
  real(dp),    dimension(10)             :: ysmooth
  logical                                :: isgood
  integer(i4), dimension(10)             :: test1

  real(dp),    dimension(:), allocatable :: xin_1d      ! measured
  real(dp),    dimension(:), allocatable :: yin_1d      ! smoothed at x_in

  ! for OMP
  !$  integer(i4)                           :: n_threads

  !$  write(*,*) '--------------------------------------------------'
  !$  write(*,*) ' This program is parallel.'
  !$OMP parallel
  !$    n_threads = OMP_GET_NUM_THREADS()
  !$OMP end parallel
  !$  write(*,*) ' It will run using ',n_threads,' threads'
  !$  write(*,*) '--------------------------------------------------'

  nn = size(x,1)
  forall(ii=1:nn) x(ii,1) = real(ii-1,dp)/9.0_dp
  forall(ii=1:nn) x(ii,2) = 1.0_dp / (real(ii-1,dp)/9.0_dp + 0.1_dp)
  y(:) = 1.0_dp + x(:,1)**2 - sin(x(:,2))** 2

  isgood = .true.
  write(*,*) '  '

  ! ---------------------------------------------------------------------------------
  write(*,*) 'Testing approximation of bandwith h for regression'

  h = kernel_regression_h(x,y,silverman=.true.)
  write(*,*) '   Bandwith h (Silvermans rule)  : ', h
  if ( int(h(1)*10000.0_dp,i4) .ne.  2291_i4 ) isgood = .false.
  if ( int(h(2)*10000.0_dp,i4) .ne. 19033_i4 ) isgood = .false.

  h = kernel_regression_h(x,y,silverman=.false.)
  write(*,*) '   Bandwith h (Cross-validation) : ', h
  if ( int(h(1)*10000.0_dp,i4) .ne.  1726_i4 ) isgood = .false.
  if ( int(h(2)*10000.0_dp,i4) .ne. 95169_i4 ) isgood = .false.
  write(*,*) ' '

  ! ---------------------------------------------------------------------------------
  write(*,*) 'Testing kernel regression using bandwith h approximated by cross-validation'
  ysmooth = kernel_regression(x,y,silverman=.false.)

  write(*,*) '   x1        x2        y approx.   y input  '
  do ii=1,nn
     write(*,'(A4,F7.4,A3,F7.4,A3,F7.4,A5,F7.4)') '    ',x(ii,1), '   ',x(ii,2), '   ', ysmooth(ii), '     ', y(ii)
  end do
  write(*,*) ' '

  test1 = (/ 5224_i4, 5256_i4, 5417_i4, 5178_i4, 4764_i4, 4923_i4, 6034_i4, 7774_i4, 9545_i4, 10960_i4 /)
  do ii=1,10
     if (int(ysmooth(ii)*10000.0_dp,i4) .ne. test1(ii)) isgood = .false.
  end do

  ! ---------------------------------------------------------------------------------
  ! Test data: 20 temperature data of Guayaquil
  nn = 20_i4
  allocate(xin_1d(nn))
  allocate(yin_1d(nn))
  xin_1d = (/ 26.1_dp, 24.5_dp, 24.8_dp, 24.5_dp, 24.1_dp, &
       24.3_dp, 26.4_dp, 24.9_dp, 23.7_dp, 23.5_dp, &
       24.0_dp, 24.1_dp, 23.7_dp, 24.3_dp, 26.6_dp, &
       24.6_dp, 24.8_dp, 24.4_dp, 26.8_dp, 25.2_dp /)

  ! ---------------------------------------------------------------------------------
  write(*,*)'Testing approximation of bandwith h for density estimation'

  h(1)        = kernel_density_h(xin_1d(:),silverman=.false.)
  write(*,*) '   estimated h: ',h(1)

  if (int(h(1)*10000.0_dp,i4) .ne. 4582_i4) isgood = .false.

  write(*,*) ' '

  ! ---------------------------------------------------------------------------------
  write(*,*) 'Testing kernel prob. density (PDF) estimation'

  yin_1d = kernel_density(xin_1d, h=h(1), silverman=.false.)

  write(*,'(A4,A7,A4,A7)') '    ','x      ','    ','pdf(x) '
  do ii=1,size(yin_1d)
     write(*,'(A4,F7.4,A4,F8.5)') '    ', xin_1d(ii), '    ',yin_1d(ii)
  end do

  test1 = (/ 1260_i4, 4713_i4, 3900_i4, 4713_i4, 4443_i4, 4773_i4, 1498_i4, 3494_i4, 3035_i4, 2214_i4 /)
  do ii=1,10
     if (int(yin_1d(ii)*10000.0_dp,i4) .ne. test1(ii)) isgood = .false.
  end do

  write(*,*) ' '

  ! ---------------------------------------------------------------------------------
  write(*,*) 'Testing kernel cum. density (CDF) estimation'

  yin_1d = kernel_cumdensity(xin_1d, h=h(1), silverman=.false., romberg=.false.)

  write(*,'(A4,A7,A4,A7)') '    ','x      ','    ','cdf(x) '
  do ii=1,size(yin_1d)
     write(*,'(A4,F7.4,A4,F8.5)') '    ', xin_1d(ii), '    ', yin_1d(ii)
  end do

  ! With normalisation: test1 = (/ 8847_i4, 4544_i4, 6062_i4, 4544_i4, 2363_i4, 3437_i4, 9332_i4, 6490_i4, 0607_i4, 0_i4 /)
  test1 = (/ 8461_i4, 4744_i4, 6055_i4, 4744_i4, 2861_i4, 3789_i4, 8880_i4, 6425_i4, 1344_i4, 819_i4 /)
  do ii=1,10
     if (int(yin_1d(ii)*10000.0_dp,i4) .ne. test1(ii)) isgood = .false.
  end do

  write(*,*) ' '

  ! ---------------------------------------------------------------------------------
  if (isgood) then
     write(*,*) 'mo_kernel ', color('o.k.', c_green)
  else
     write(*,*) 'mo_kernel ', color('failed!', c_red)
  end if

end program test_kernel


! contain math_mod
    ! mod_pow(b,exp,m)
        ! solve:: ret = mod( b**exp, m )繰り返し二乗法で高速化
        ! input:: b, exp, m
        ! output:: ret
    ! mod_inv(a,m)
        ! solve:: mod(ax, m) = 1
        !      => ax + my = 1
        ! input:: a,m
        ! output:: x <- inverse of a at mod m
    ! lcm(a,b)
        ! solve:: ret = lcm(a,b)
        ! input:: a, b
        ! output:: ret
    ! gcd(a,b)
        ! solve:: ret = gcd(a,b)
        ! input:: a, b
        ! output:: ret
    ! extgcd(a,b,x,y)
        ! solve:: ax + by = gcd(a,b) (拡張ユークリッドの互除法)
        ! input:: a, b
        ! output::  x, y, gcd(a,b)
    ! chineserem(b,m,md)
        ! solve:: mod(b_1*k_1, m_1) = x (-> b_1の倍数をm_1で割ったあまりがx)
        !          :
        !         mod(b_n*k_n, m_n) = x を満たす最小のx
        ! input:: b(1:n), m(1:n)
        ! output:: x (< md)
! combination_mod
    ! make_fraction(n,md)
        ! solve:: generate frac, ifrac (frac(i) = i! % md, ifrac(i) = mod_inv(i!))
        ! input:: n, md
        ! output:: none
    ! perm(n,p,md)
        ! solve:: ret = nPp % md (n個のものをp個選んで並べる並べ方。をmdで割った値)
        ! input:: n, p, md
        ! output:: ret
    ! comb(n,p,md)
        ! solve:: ret = nCp % md (n個のものをp個選ぶ選び方。をmdで割った値)
        ! input:: n, p, md
        ! output:: ret

module math_mod
    use,intrinsic :: iso_fortran_env
    implicit none
contains
    function mod_pow(base, exponent, m) result(ret)
        integer(int64),intent(in):: m
        integer(int64),value:: base, exponent
        integer(int64):: ret

        ret = 1
        do while(exponent > 0)
            if (btest(exponent, 0)) ret=mod(ret*base,m)
            base=mod(base*base,m)
            exponent=shiftr(exponent,1)
        end do
    end function

    recursive function mod_inv(a,m) result(ret)
        integer(int64),intent(in):: a,m
        integer(int64):: ret, gcd_ma, x, y

        gcd_ma = extgcd(a,m,x,y)

        if (gcd_ma /= 1_int64) then
            ret = -1_int64
        else
            ret = modulo(x,m)
        end if
    end function

    function lcm(a, b) result(ret)
        integer(int64),intent(in):: a,b
        integer(int64):: ret

        ret = a*b/gcd(a,b)
    end function

    recursive function gcd(a, b) result(ret)
        integer(int64),intent(in):: a,b
        integer(int64):: ret

        if (b == 0_int64) then
            ret = a
        else
            ret = gcd(b, mod(a,b))
        end if
    end function

    recursive function extgcd(a, b, x, y) result(ret)
        integer(int64),value:: a,b
        integer(int64),intent(out):: x,y
        integer(int64):: ret ! gcd(a,b)

        if (b==0_int64) then
            ret = a
            x = 1_int64
            y = 0_int64
        else
            ret = extgcd(b, mod(a,b), y, x)
            y = y - a/b * x
        end if
    end function

    function chineserem(b, m, md) result(ret)
        integer(int64),allocatable:: b(:),m(:)
        integer(int64):: md
        integer(int64),allocatable:: x0(:), mmul(:)
        integer(int64):: ret, i, j, g, gi, gj
        integer(int64):: t

        do i=1_int64,size(b)
            do j=1_int64, i-1_int64
                g = gcd(m(i),m(j))
                if (mod(b(i)-b(j), g) /= 0_int64) then
                    ret = -1_int64
                    return
                end if
                m(i) = m(i) / g
                m(j) = m(j) / g
                gi = gcd(m(i),g)
                gj = g/gi
                do while(g /= 1)
                    g = gcd(gi,gj)
                    gi = gi*g
                    gj = gj/g
                end do
                m(i) = m(i)*gi
                m(j) = m(j)*gj
                b(i) = mod(b(i), m(i))
                b(j) = mod(b(j), m(j))
            end do
        end do

        m = [m,md]
        allocate(x0(size(m)), source=0_int64)
        allocate(mmul(size(m)), source=1_int64)

        do i=1_int64,size(b)
            t = modulo((b(i)-x0(i)) * mod_inv(mmul(i), m(i)), m(i))
            do j=i+1,size(m)
                x0(j) = modulo(x0(j) + t * mmul(j), m(j))
                mmul(j) = modulo(mmul(j)*m(i), m(j))
            end do
        end do
        ret = modulo(x0(size(x0)), md)
    end function
end module

module combination_mod
    use,intrinsic :: iso_fortran_env
    use math_mod
    implicit none
    public
    integer(int64), allocatable, private:: frac(:), ifrac(:)
contains
    subroutine make_fraction(n,md)
        integer(int64),intent(in):: n, md
        integer(int64):: i

        allocate(frac(0:n), ifrac(0:n))
        frac(0) = 1; ifrac(0) = 1
        do i=1,n
            frac(i) = mod(frac(i-1)*i, md)
            ifrac(i) = mod_inv(frac(i),md)
        end do
    end subroutine

    function perm(n,p,md) result(ret)
        integer(int64),intent(in):: n,p,md
        integer(int64):: ret

        ret = mod(frac(n)*ifrac(n-p), md)
    end function

    function comb(n,p,md) result(ret)
        integer(int64),intent(in):: n,p,md
        integer(int64):: ret

        ret = mod(mod(frac(n)*ifrac(p),md)*ifrac(n-p),md)
    end function
end module

module algorithm_mod
    use math_mod
    use combination_mod
    implicit none
end module