!*****************************************************************************************
!
!> Units test for 1d nearest neighbor interpolation.

    program nearest_neighbor_test

    use linear_interpolation_module
    use,intrinsic :: iso_fortran_env, only: wp => real64

    implicit none

    integer,parameter :: nx = 6  !! number of points in x
    real(wp),dimension(nx),parameter :: x         = [1.0_wp,2.0_wp,3.0_wp,4.0_wp,5.0_wp,6.0_wp]
    real(wp),dimension(nx),parameter :: fcn_1d    = [1.0_wp,2.0_wp,3.0_wp,4.0_wp,5.0_wp,6.0_wp]
    real(wp),dimension(nx),parameter :: x_to_test = [0.1_wp,2.1_wp,3.4_wp,4.0_wp,4.9_wp,9.0_wp]
    real(wp),parameter :: tol = 1.0e-14_wp  !! error tolerance

    type(nearest_interp_1d) :: s1
    real(wp) :: val,tru,err,errmax
    integer :: i,idx,iflag

    ! initialize
    call s1%initialize(x,fcn_1d,iflag)

    if (iflag/=0) then
        write(*,*) 'Error initializing 1D nearest neighbor interpolator. iflag=',iflag
        stop 1
    end if

    ! compute max error at interpolation points
     errmax = 0.0_wp
     do i=1,nx
        call s1%evaluate(x_to_test(i),val)
        tru     = x(i)
        write(*,*) val, tru
        err     = abs(tru-val)
        errmax  = max(err,errmax)
     end do

    ! check max error against tolerance
    write(*,*) '1D: max error:', errmax
    if (errmax >= tol) then
        write(*,*)  ' ** test failed ** '
    else
        write(*,*)  ' ** test passed ** '
    end if
    write(*,*) ''

    end program nearest_neighbor_test


module sort_data_module

    contains
    subroutine sort_data(raw_data, how_many)
        implicit none

        integer, intent(in) :: how_many
        real, dimension(:), intent(inout) :: raw_data

        call quicksort(1,how_many)

        contains
        recursive subroutine quicksort(l, r)
            implicit none

            integer, intent(in) :: l, r
            integer :: i, j
            real :: v, t

            i = l
            j = r
            v = raw_data(int((l+r)/2))
            do
                do while (raw_data(i)<v)
                    i = i+1
                end do
                do while (v<raw_data(j))
                    j = j-1
                end do
                if (i<=j) then
                    t = raw_data(i)
                    raw_data(i) = raw_data(j)
                    raw_data(j) = t
                    i = i+1
                    j = j-1
                end if
                if (i>j) exit
            end do
            if (l<j) then
                call quicksort(l,j)
            end if
            if (i<r) then
                call quicksort(i,r)
            end if
        end subroutine
    end subroutine
end module

program ch2005
    ! Recursive Subroutines - Quicksort
    use sort_data_module
    implicit none

    integer, parameter :: n = 10000
    real, dimension(:), allocatable :: x

    print *, ' Program starts'
    allocate(x(n))
    call random_number(x)
    call sort_data(x,n)
    print *, ' First 10 sorted numbers are'
    write(*,120) x(1:10)
    deallocate(x)
    print *, ' Program terminates'

120 format (2x, e14.6)
end program


module test_simps
    use stdlib_kinds, only: sp, dp, qp
    use testdrive, only : new_unittest, unittest_type, error_type, check
    use stdlib_quadrature, only: simps, simps_weights

    implicit none

    real(sp), parameter :: tol_sp = 1000 * epsilon(1.0_sp)
    real(dp), parameter :: tol_dp = 1000 * epsilon(1.0_dp)
    real(qp), parameter :: tol_qp = 1000 *epsilon(1.0_sp)

contains

    !> Collect all exported unit tests
    subroutine collect_simps(testsuite)
        !> Collection of tests
        type(unittest_type), allocatable, intent(out) :: testsuite(:)

        testsuite = [ &
            new_unittest("simps_sp", test_simps_sp), &
            new_unittest("simps_dp", test_simps_dp), &
            new_unittest("simps_qp", test_simps_qp), &
            new_unittest("simps_weights_sp", test_simps_weights_sp), &
            new_unittest("simps_weights_dp", test_simps_weights_dp), &
            new_unittest("simps_weights_qp", test_simps_weights_qp), &
            new_unittest("simps_zero_sp", test_simps_zero_sp), &
            new_unittest("simps_zero_dp", test_simps_zero_dp), &
            new_unittest("simps_zero_qp", test_simps_zero_qp), &
            new_unittest("simps_even_sp", test_simps_even_sp), &
            new_unittest("simps_even_dp", test_simps_even_dp), &
            new_unittest("simps_even_qp", test_simps_even_qp), &
            new_unittest("simps_weights_even_sp", test_simps_weights_even_sp), &
            new_unittest("simps_weights_even_dp", test_simps_weights_even_dp), &
            new_unittest("simps_weights_even_qp", test_simps_weights_even_qp), &
            new_unittest("simps_six_sp", test_simps_six_sp), &
            new_unittest("simps_six_dp", test_simps_six_dp), &
            new_unittest("simps_six_qp", test_simps_six_qp) &
            ]
    end subroutine collect_simps

    subroutine test_simps_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 13
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp) :: val
        real(sp) :: ans
        integer :: i

        y = [(real(i-1, sp)**2, i = 1, n)]

        val = simps(y, 1.0_sp)
        ans = 576.0_sp
        call check(error, val, ans, thr=tol_sp)
        if (allocated(error)) return

        val = simps(y, 0.5_sp)
        ans = 288.0_sp
        call check(error, val, ans, thr=tol_sp)
        if (allocated(error)) return

        x = [(0.25_sp*(i-1), i = 1, n)]
        val = simps(y, x)
        ans = 144.0_sp
        call check(error, val, ans, thr=tol_sp)
    end subroutine test_simps_sp

    subroutine test_simps_dp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 13
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp) :: val
        real(dp) :: ans
        integer :: i

        y = [(real(i-1, dp)**2, i = 1, n)]

        val = simps(y, 1.0_dp)
        ans = 576.0_dp
        call check(error, val, ans, thr=tol_dp)
        if (allocated(error)) return

        val = simps(y, 0.5_dp)
        ans = 288.0_dp
        call check(error, val, ans, thr=tol_dp)
        if (allocated(error)) return

        x = [(0.25_dp*(i-1), i = 1, n)]
        val = simps(y, x)
        ans = 144.0_dp
        call check(error, val, ans, thr=tol_dp)
    end subroutine test_simps_dp

    subroutine test_simps_qp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 13
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp) :: val
        real(qp) :: ans
        integer :: i

        y = [(real(i-1, qp)**2, i = 1, n)]

        val = simps(y, 1.0_qp)
        ans = 576.0_qp
        call check(error, val, ans, thr=tol_qp)
        if (allocated(error)) return

        val = simps(y, 0.5_qp)
        ans = 288.0_qp
        call check(error, val, ans, thr=tol_qp)
        if (allocated(error)) return

        x = [(0.25_qp*(i-1), i = 1, n)]
        val = simps(y, x)
        ans = 144.0_qp
        call check(error, val, ans, thr=tol_qp)
    end subroutine test_simps_qp

    subroutine test_simps_weights_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 17
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp), dimension(n) :: w
        integer :: i
        real(sp) :: val
        real(sp) :: ans

        y = [(real(i-1, sp), i = 1, n)]

        x = y
        w = simps_weights(x)
        val = sum(w*y)
        ans = simps(y, x)
        call check(error, val, ans, thr=tol_sp)
    end subroutine test_simps_weights_sp

    subroutine test_simps_weights_dp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 17
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp), dimension(n) :: w
        integer :: i
        real(dp) :: val
        real(dp) :: ans

        y = [(real(i-1, dp), i = 1, n)]

        x = y
        w = simps_weights(x)
        val = sum(w*y)
        ans = simps(y, x)
        call check(error, val, ans, thr=tol_dp)
    end subroutine test_simps_weights_dp

    subroutine test_simps_weights_qp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 17
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp), dimension(n) :: w
        integer :: i
        real(qp) :: val
        real(qp) :: ans

        y = [(real(i-1, qp), i = 1, n)]

        x = y
        w = simps_weights(x)
        val = sum(w*y)
        ans = simps(y, x)
        call check(error, val, ans, thr=tol_qp)
    end subroutine test_simps_weights_qp

    subroutine test_simps_zero_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        real(sp), dimension(0) :: a

        call check(error, abs(simps(a, 1.0_sp)) < epsilon(0.0_sp))
        if (allocated(error)) return
        call check(error, abs(simps([1.0_sp], 1.0_sp)) < epsilon(0.0_sp))
        if (allocated(error)) return
        call check(error, abs(simps(a, a)) < epsilon(0.0_sp))
        if (allocated(error)) return
        call check(error, abs(simps([1.0_sp], [1.0_sp])) < epsilon(0.0_sp))
    end subroutine test_simps_zero_sp

    subroutine test_simps_zero_dp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        real(dp), dimension(0) :: a

        call check(error, abs(simps(a, 1.0_dp)) < epsilon(0.0_dp))
        if (allocated(error)) return
        call check(error, abs(simps([1.0_dp], 1.0_dp)) < epsilon(0.0_dp))
        if (allocated(error)) return
        call check(error, abs(simps(a, a)) < epsilon(0.0_dp))
        if (allocated(error)) return
        call check(error, abs(simps([1.0_dp], [1.0_dp])) < epsilon(0.0_dp))
    end subroutine test_simps_zero_dp

    subroutine test_simps_zero_qp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        real(qp), dimension(0) :: a

        call check(error, abs(simps(a, 1.0_qp)) < epsilon(0.0_qp))
        if (allocated(error)) return
        call check(error, abs(simps([1.0_qp], 1.0_qp)) < epsilon(0.0_qp))
        if (allocated(error)) return
        call check(error, abs(simps(a, a)) < epsilon(0.0_qp))
        if (allocated(error)) return
        call check(error, abs(simps([1.0_qp], [1.0_qp])) < epsilon(0.0_qp))
    end subroutine test_simps_zero_qp

    subroutine test_simps_even_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 11
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp) :: val
        real(sp) :: ans
        integer :: i
        integer :: even

        y = [(3.0_sp*real(i-1, sp)**2, i = 1, n)]

        do even = -1, 1

            val = simps(y, 1.0_sp)
            ans = 1000.0_sp
            call check(error, val, ans, thr=tol_sp)
            if (allocated(error)) return

            val = simps(y, 0.5_sp)
            ans = 500.0_sp
            call check(error, val, ans, thr=tol_sp)
            if (allocated(error)) return

            x = [(0.25_sp*(i-1), i = 1, n)]
            val = simps(y, x)
            ans = 250.0_sp
            call check(error, val, ans, thr=tol_sp)
            if (allocated(error)) return
        end do
    end subroutine test_simps_even_sp

    subroutine test_simps_even_dp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 11
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp) :: val
        real(dp) :: ans
        integer :: i

        y = [(3.0_dp*real(i-1, dp)**2, i = 1, n)]

        val = simps(y, 1.0_dp)
        ans = 1000.0_dp
        call check(error, val, ans, thr=tol_dp)
        if (allocated(error)) return

        val = simps(y, 0.5_dp)
        ans = 500.0_dp
        call check(error, val, ans, thr=tol_dp)
        if (allocated(error)) return

        x = [(0.25_dp*(i-1), i = 1, n)]
        val = simps(y, x)
        ans = 250.0_dp
        call check(error, val, ans, thr=tol_dp)
    end subroutine test_simps_even_dp

    subroutine test_simps_even_qp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 11
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp) :: val
        real(qp) :: ans
        integer :: i
        integer :: even

        y = [(3.0_qp*real(i-1, qp)**2, i = 1, n)]

        do even = -1, 1

            val = simps(y, 1.0_qp)
            ans = 1000.0_qp
            call check(error, val, ans, thr=tol_qp)
            if (allocated(error)) return

            val = simps(y, 0.5_qp)
            ans = 500.0_qp
            call check(error, val, ans, thr=tol_qp)
            if (allocated(error)) return

            x = [(0.25_qp*(i-1), i = 1, n)]
            val = simps(y, x)
            ans = 250.0_qp
            call check(error, val, ans, thr=tol_qp)
            if (allocated(error)) return
        end do
    end subroutine test_simps_even_qp

    subroutine test_simps_weights_even_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 16
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp), dimension(n) :: w
        integer :: i
        real(sp) :: val
        real(sp) :: ans
        integer :: even

        y = [(real(i-1, sp), i = 1, n)]
        x = y

        do even = -1, 1
            w = simps_weights(x)
            val = sum(w*y)
            ans = simps(y, x)
            call check(error, val, ans, thr=tol_sp)
            if (allocated(error)) return
        end do
    end subroutine test_simps_weights_even_sp

    subroutine test_simps_weights_even_dp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 16
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp), dimension(n) :: w
        integer :: i
        real(dp) :: val
        real(dp) :: ans
        integer :: even

        y = [(real(i-1, dp), i = 1, n)]
        x = y

        do even = -1, 1
            w = simps_weights(x)
            val = sum(w*y)
            ans = simps(y, x)
            call check(error, val, ans, thr=tol_dp)
            if (allocated(error)) return
        end do
    end subroutine test_simps_weights_even_dp

    subroutine test_simps_weights_even_qp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 16
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp), dimension(n) :: w
        integer :: i
        real(qp) :: val
        real(qp) :: ans
        integer :: even

        y = [(real(i-1, qp), i = 1, n)]

        x = y

        do even = -1, 1
            w = simps_weights(x)
            val = sum(w*y)
            ans = simps(y, x)
            call check(error, val, ans, thr=tol_qp)
            if (allocated(error)) return
        end do
    end subroutine test_simps_weights_even_qp

    subroutine test_simps_six_sp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 6
        real(sp), dimension(n) :: y
        real(sp), dimension(n) :: x
        real(sp) :: val
        real(sp) :: ans
        integer :: i
        integer :: even

        y = [(3.0_sp*real(i-1, sp)**2, i = 1, n)]

        do even = -1, 1

            val = simps(y, 1.0_sp)
            ans = 125.0_sp
            call check(error, val, ans, thr=tol_sp)
            if (allocated(error)) return

            val = simps(y, 0.5_sp)
            ans = 62.5_sp
            call check(error, val, ans, thr=tol_sp)
            if (allocated(error)) return

            x = [(0.25_sp*(i-1), i = 1, n)]
            val = simps(y, x)
            ans = 31.25_sp
            call check(error, val, ans, thr=tol_sp)
            if (allocated(error)) return
        end do
    end subroutine test_simps_six_sp

    subroutine test_simps_six_dp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 6
        real(dp), dimension(n) :: y
        real(dp), dimension(n) :: x
        real(dp) :: val
        real(dp) :: ans
        integer :: i

        y = [(3.0_dp*real(i-1, dp)**2, i = 1, n)]

        val = simps(y, 1.0_dp)
        ans = 125.0_dp
        call check(error, val, ans, thr=tol_dp)
        if (allocated(error)) return

        val = simps(y, 0.5_dp)
        ans = 62.5_dp
        call check(error, val, ans, thr=tol_dp)
        if (allocated(error)) return

        x = [(0.25_dp*(i-1), i = 1, n)]
        val = simps(y, x)
        ans = 31.25_dp
        call check(error, val, ans, thr=tol_dp)
    end subroutine test_simps_six_dp

    subroutine test_simps_six_qp(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer, parameter :: n = 6
        real(qp), dimension(n) :: y
        real(qp), dimension(n) :: x
        real(qp) :: val
        real(qp) :: ans
        integer :: i
        integer :: even

        y = [(3.0_qp*real(i-1, qp)**2, i = 1, n)]

        do even = -1, 1

            val = simps(y, 1.0_qp)
            ans = 125.0_qp
            call check(error, val, ans, thr=tol_qp)
            if (allocated(error)) return

            val = simps(y, 0.5_qp)
            ans = 62.5_qp
            call check(error, val, ans, thr=tol_qp)
            if (allocated(error)) return

            x = [(0.25_qp*(i-1), i = 1, n)]
            val = simps(y, x)
            ans = 31.25_qp
            call check(error, val, ans, thr=tol_qp)
            if (allocated(error)) return
        end do
    end subroutine test_simps_six_qp

end module

program tester
    use, intrinsic :: iso_fortran_env, only : error_unit
    use testdrive, only : run_testsuite, new_testsuite, testsuite_type
    use test_simps, only : collect_simps
    implicit none
    integer :: stat, is
    type(testsuite_type), allocatable :: testsuites(:)
    character(len=*), parameter :: fmt = '("#", *(1x, a))'

    stat = 0

    testsuites = [ &
        new_testsuite("simps", collect_simps) &
        ]

    do is = 1, size(testsuites)
        write(error_unit, fmt) "Testing:", testsuites(is)%name
        call run_testsuite(testsuites(is)%collect, error_unit, stat)
    end do

    if (stat > 0) then
        write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
        error stop
    end if
end program


integer function f(i)
    implicit none
    integer, intent(in) :: i
    f = i**2
end function f


C Checking results for Fortran integer division as opposed to C integer division

      program main
      logical check_mod_div

      i = 3/ 2
      print *, i, "must be 1 and check_mod_div(3,2)",
     &     check_mod_div(3,2)

      i = (-3)/ 2
      print *, i, "must be -1 and check_mod_div(-3,2)",
     &     check_mod_div(-3,2)

      i = 3/(-2)
      print *, i, "must be -1 and check_mod_div(3,-2)",
     &     check_mod_div(3,-2)

      i = (-3)/(-2)
      print *, i, "must be 1 and check_mod_div(-3,-2)",
     &     check_mod_div(-3,-2)

      end

      logical function check_mod_div(i,j)
      check_mod_div = i.eq.((i/j)*j+mod(i,j))
      end


module my_lib

   implicit none
   !public :: mesh, linspace
   public :: linspace

   contains

  subroutine linspace(x, x_start, x_end, x_len)
    real, dimension(:), intent(out) :: x
    real :: x_start, x_end, dx
    integer :: x_len, i

    dx = (x_end - x_start) / (x_len - 1)
    x(1:x_len) = [(x_start + (i * dx), i = 0, x_len-1)]

  end subroutine linspace

end module my_lib


module special

! Special functions:
! This module offers some special functions such as
!- spherical Bessel functions
!- zeros of real Bessel functions
!- Bessel and Hankel functions of complex argument (wrapping the AMOS library
!   from http://netlib.org/amos)
!- Airy functions Ai and Bi

! Note on the AMOS wrappers: the AMOS routines generally offer the possibility
! of exponential scaling to remove exponential asymptotic behaviour.
! We do not expose the corresponding switches to the user, however, it is
! straight forward to add those.

! All references labelled with "NIST" refer to the NIST Handbook of
! Mathematical Functions (2010)

use types, only: dp
use constants, only: pi, i_
use utils, only: stop_error
use optimize, only: bisect
use amos
implicit none

private
public bessel_jn_zeros, spherical_bessel_jn, spherical_bessel_yn, &
       spherical_bessel_jn_zeros, &
       besselj, bessely, hankel1, hankel2, besseli, besselk, &  ! note the missing underscores in Bessel functions
       airyai, dairyai, airybi, dairybi  ! Airy functions Ai and Bi and their derivatives

! Bessel J function (first kind)
interface besselj
    module procedure besseljn_real
    module procedure besseljv_real
    module procedure besseljv_complex
end interface besselj

! Bessel Y function (second kind)
interface bessely
    module procedure besselyn_real
    module procedure besselyv_real
    module procedure besselyv_complex
end interface bessely

! Hankel H function of first kind
interface hankel1
    module procedure hankel1n_real
    module procedure hankel1v_real
    module procedure hankel1v_complex
end interface hankel1

! Hankel H function of second kind
interface hankel2
    module procedure hankel2n_real
    module procedure hankel2v_real
    module procedure hankel2v_complex
end interface hankel2

! modified Bessel function of first kind
interface besseli
    module procedure besseliv_real
    module procedure besseliv_complex
end interface besseli

! modified Bessel function of second kind
interface besselk
    module procedure besselkv_real
    module procedure besselkv_complex
end interface besselk

contains

function besseljn_real(order, x) result(res)
    integer, intent(in) :: order
    real(dp), intent(in) :: x
    real(dp) :: res

    ! convenience function that calls Bessel functions of integer order
    ! (intrinsic to F2008)

    if(abs(order) == 0) then
        res = bessel_j0(x)
    elseif(abs(order) == 1) then
        res = bessel_j1(x)
    else
        res = bessel_jn(abs(order), x)
    endif

    ! apply negative order NIST eq. (10.4.1) if needed:
    res = reflect(order)*res
end function besseljn_real

function besseljv_real(order, x) result(res)
    real(dp), intent(in) :: order, x
    real(dp) :: res
    complex(dp) :: resCmplx

    ! here, we do rely in an informed user: if the user wanted Bessel functions
    ! of integer order n, he/she should call bessel_jn() (as of F2008) directly.
    ! Hence, here we just convert the argument to a complex number and call the
    ! AMOS routine
    ! TODO: on the long run, wrap the cephes routines!

    resCmplx = besseljv_complex(order, cmplx(x, 0.0_dp, kind=dp))  ! negative order is handled in the routine called
    res = real(resCmplx)  ! Bessel functions of real arument are real
end function besseljv_real

function besseljv_complex(order, z) result(res)
    real(dp), intent(in) :: order
    complex(dp), intent(in) :: z
    complex(dp) :: res

    integer, parameter :: scaling=1, length=1
    real(dp) :: resReal(length), resImag(length), callorder
    integer :: underflows, ierr

    ! make sure AMOS zbesj() is called with postive order
    callorder = abs(order)

    call zbesj(real(z), aimag(z), callorder, scaling, length, resReal, resImag, underflows, ierr)
    if(ierr > 0) then
        if(ierr == 1) then
            print *, "IERR=1, INPUT ERROR - NO COMPUTATION"
        elseif(ierr == 2) then
            print *, "IERR=2, OVERFLOW - NO COMPUTATION, AIMAG(Z) TOO LARGE ON KODE=1"
        elseif(ierr == 3) then
            print *, "IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE"
            print *, "BUT LOSSES OF SIGNIFCANCE BY ARGUMENT"
            print *, "REDUCTION PRODUCE LESS THAN HALF OF MACHINE ACCURACY"
        elseif(ierr == 4) then
            print *, "IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTATION BECAUSE"
            print *, "OF COMPLETE LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION"
        elseif(ierr == 5) then
            print *, "IERR=5, ERROR - NO COMPUTATION ALGORITHM TERMINATION CONDITION NOT MET"
        endif
        call stop_error("besselj: zbesj error")
    endif

    ! take care of negative order if needed:
    if(order < 0.0_dp) then  ! use NIST eq. (10.4.7):
        res = exp(-pi*i_*callorder)*(resReal(1) + i_*resImag(1)) &
            & + i_*sin(pi*callorder)*hankel1(callorder, z)
    else
        res = resReal(1) +i_*resImag(1)
    endif
end function besseljv_complex

function besselyn_real(order, x) result(res)
    integer, intent(in) :: order
    real(dp), intent(in) :: x
    real(dp) :: res

    ! convenience function that calls Bessel functions of integer order
    ! (intrinsic to F2008)

    if(abs(order) == 0) then
        res = bessel_y0(x)
    elseif(abs(order) == 1) then
        res = bessel_y1(x)
    else
        res = bessel_yn(abs(order), x)
    endif
    res = reflect(order)*res  ! apply negative order eq. (10.4.1) from NIST
end function besselyn_real

function besselyv_real(order, x) result(res)
    real(dp), intent(in) :: order, x
    real(dp) :: res
    complex(dp) :: resCmplx

    resCmplx = besselyv_complex(order, x+0*i_)  ! neg. order handled in the routine called
    res = real(resCmplx)
end function besselyv_real

function besselyv_complex(order, z) result(res)
    real(dp), intent(in) :: order
    complex(dp), intent(in) :: z
    complex(dp) :: res

    integer, parameter :: scaling=1, length=1
    real(dp) :: workr(length), worki(length), resReal(length), resImag(length), callorder
    integer :: underflows, ierr

    ! make sure AMOS zbesy() is called with positive order:
    callorder = abs(order)

    call zbesy(real(z), aimag(z), callorder, scaling, length, resReal, resImag, underflows, workr, worki, ierr)
    if(ierr > 0) then
        if(ierr == 1) then
            print *, "IERR=1, INPUT ERROR - NO COMPUTATION"
        elseif(ierr == 2) then
            print *, "IERR=2, OVERFLOW - NO COMPUTATION, FNU IS TOO LARGE OR CABS(Z)"
            print *, "IS TOO SMALL OR BOTH"
        elseif(ierr == 3) then
            print *, "IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE BUT LOSSES OF SIGNIFCANCE"
            print *, "BY ARGUMENT REDUCTION PRODUCE LESS THAN HALF OF MACHINE ACCURACY"
        elseif(ierr == 4) then
            print *, "IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTATION BECAUSE OF COMPLETE"
            print *, "LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION"
        elseif(ierr == 5) then
            print *, "IERR=5, ERROR - NO COMPUTATION ALGORITHM TERMINATION CONDITION NOT MET"
        endif
        call stop_error("bessely: zbesy error")
    endif

    if(order < 0.0_dp) then  ! apply NIST eq. (10.4.7)
        res = exp(-callorder*pi*i_)*(resReal(1) + i_*resImag(1)) + &
            & sin(pi*callorder)*hankel1(callorder, z)
    else
        res = resReal(1) + i_*resImag(1)
    endif
end function besselyv_complex

function hankel1n_real(order, x) result(res)
    integer, intent(in) :: order
    real(dp), intent(in) :: x
    complex(dp) :: res

    ! There are two linearly independent solutions to Bessel's equation.
    ! Thus, the two Hankel functions can be written as superpositions of
    ! J and Y, which are taken to be the two linearly independent ones.
    ! NIST Handbook (10.4.3)

    ! negative order is taken care of according to NIST eq. (10.4.2)
    if(order == 0) then
        res = bessel_j0(x) + i_*bessel_y0(x)
    elseif(abs(order) == 1) then
        res = reflect(order)*(bessel_j1(x) + i_*bessel_y1(x))
    else
        res = reflect(order)*(bessel_jn(order, x) + i_*bessel_yn(order, x))
    endif
end function hankel1n_real

function hankel1v_real(order, x) result(res)
    real(dp), intent(in) :: order, x
    complex(dp) :: res

    res = hankel1v_complex(order, cmplx(x, 0.0_dp, kind=dp))
end function hankel1v_real

function hankel1v_complex(order, z) result(res)
    real(dp), intent(in) :: order
    complex(dp), intent(in) :: z
    complex(dp) :: res

    integer, parameter :: scaling=1, length=1, hankelkind=1
    real(dp) :: resReal(length), resImag(length), callorder
    integer :: underflows, ierr

    callorder = abs(order)

    call zbesh(real(z), aimag(z), callorder, scaling, hankelkind, length, resReal, resImag, underflows, ierr)
    if(ierr > 0) then
        if(ierr == 1) then
            print *, "IERR=1, INPUT ERROR - NO COMPUTATION"
        elseif(ierr == 2) then
            print *, "IERR=2, OVERFLOW - NO COMPUTATION, FNU TOO LARGE OR CABS(Z) TOO SMALL OR BOTH"
        elseif(ierr == 3) then
            print *, "IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE BUT LOSSES OF SIGNIFCANCE"
            print *, "BY ARGUMENT REDUCTION PRODUCE LESS THAN HALF OF MACHINE ACCURACY"
        elseif(ierr == 4) then
            print *, "IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTATION BECAUSE OF COMPLETE"
            print *, "LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION"
        elseif(ierr == 5) then
            print *, "IERR=5, ERROR - NO COMPUTATION ALGORITHM TERMINATION CONDITION NOT MET"
        endif
        call stop_error("hankel1: zbesh error")
    endif

    ! take care of negative orders if needed:
    res = Hrotate(1, order)*(resReal(1) + i_*resImag(1))
end function hankel1v_complex

function hankel2n_real(order, x) result(res)
    integer, intent(in) :: order
    real(dp), intent(in) :: x
    complex(dp) :: res

    ! convenience function that calls Bessel functions of integer order
    ! (intrinsic to F2008)

    if(abs(order) == 0) then
        res = bessel_j0(x) - i_*bessel_y0(x)
    elseif(abs(order) == 1) then
        res = reflect(order)*(bessel_j1(x) - i_*bessel_y1(x))
    else
        res = reflect(order)*(bessel_jn(order, x) - i_*bessel_yn(order, x))
    endif
end function hankel2n_real

function hankel2v_real(order, x) result(res)
    real(dp), intent(in) :: order, x
    complex(dp) :: res

    res = hankel2v_complex(order, cmplx(x, 0.0_dp, kind=dp))
end function hankel2v_real

function hankel2v_complex(order, z) result(res)
    real(dp), intent(in) :: order
    complex(dp), intent(in) :: z
    complex(dp) :: res

    integer, parameter :: scaling=1, length=1, hankelkind=2
    real(dp) :: resReal(length), resImag(length), callorder
    integer :: underflows, ierr

    callorder = abs(order)

    call zbesh(real(z), aimag(z), callorder, scaling, hankelkind, length, resReal, resImag, underflows, ierr)
    if(ierr > 0) then
        if(ierr == 1) then
            print *, "IERR=1, INPUT ERROR - NO COMPUTATION"
        elseif(ierr == 2) then
            print *, "IERR=2, OVERFLOW - NO COMPUTATION, FNU TOO LARGE OR CABS(Z) TOO SMALL OR BOTH"
        elseif(ierr == 3) then
            print *, "IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE BUT LOSSES OF SIGNIFCANCE"
            print *, "BY ARGUMENT REDUCTION PRODUCE LESS THAN HALF OF MACHINE ACCURACY"
        elseif(ierr == 4) then
            print *, "IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTATION BECAUSE OF COMPLETE"
            print *, "LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION"
        elseif(ierr == 5) then
            print *, "IERR=5, ERROR - NO COMPUTATION ALGORITHM TERMINATION CONDITION NOT MET"
        endif
        call stop_error("hankel2: zbesh error")
    endif

    ! take care of neg. orders by Hrotate() if needed:
    res = Hrotate(2, order)*(resReal(1) + i_*resImag(1))
end function hankel2v_complex

function besseliv_real(order, x) result(res)
    real(dp), intent(in) :: order, x
    real(dp) :: res
    complex(dp) :: resCmplx

    resCmplx = besseliv_complex(order, x+0*i_)
    res = real(resCmplx)
end function besseliv_real

function besseliv_complex(order, z) result(res)
    real(dp), intent(in) :: order
    complex(dp), intent(in) :: z
    complex(dp) :: res

    integer, parameter :: scaling=1, length=1
    real(dp) :: resReal(length), resImag(length), callorder
    integer :: underflows, ierr

    callorder = abs(order)

    call zbesi(real(z), aimag(z), callorder, scaling, length, resReal, resImag, underflows, ierr)
    if(ierr > 0) then
        if(ierr == 1) then
            print *, "IERR=1, INPUT ERROR - NO COMPUTATION"
        elseif(ierr == 2) then
            print *, "IERR=2, OVERFLOW - NO COMPUTATION, REAL(Z) TOO LARGE ON KODE=1"
        elseif(ierr == 3) then
            print *, "IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE BUT LOSSES OF SIGNIFCANCE"
            print *, "BY ARGUMENT REDUCTION PRODUCE LESS THAN HALF OF MACHINE ACCURACY"
        elseif(ierr == 4) then
            print *, "IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTATION BECAUSE OF COMPLETE"
            print *, "LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION"
        elseif(ierr == 5) then
            print *, "IERR=5, ERROR - NO COMPUTATION ALGORITHM TERMINATION CONDITION NOT MET"
        endif
        call stop_error("besseli: zbesi error")
    endif

    ! negative order from NIST Handbook, (10.27.2)
    if(order < 0.0_dp) then
        res = (resReal(1) + i_*resImag(1)) &
            & + 2.0_dp/pi*sin(callorder*pi)*besselk(callorder, z)
    else
        res = resReal(1) + i_*resImag(1)
    endif
end function besseliv_complex

function besselkv_real(order, x) result(res)
    real(dp), intent(in) :: order, x
    real(dp) :: res
    complex(dp) :: resCmplx

    resCmplx = besselkv_complex(order, x+0*i_)
    res = real(resCmplx)
end function besselkv_real

function besselkv_complex(order, z) result(res)
    real(dp), intent(in) :: order
    complex(dp), intent(in) :: z
    complex(dp) :: res

    integer, parameter :: scaling=1, length=1
    real(dp) :: resReal(length), resImag(length), callorder
    integer :: underflows, ierr

    ! K_{-v} = K_v; NIST Handbook (10.27.3)
    callorder = abs(order)

    call zbesk(real(z), aimag(z), callorder, scaling, length, resReal, resImag, underflows, ierr)
    if(ierr > 0) then
        if(ierr == 1) then
            print *, "IERR=1, INPUT ERROR - NO COMPUTATION"
        elseif(ierr == 2) then
            print *, "IERR=2, OVERFLOW - NO COMPUTATION, FNU IS TOO LARGE OR CABS(Z) IS TOO SMALL"
            print *, "OR BOTH"
        elseif(ierr == 3) then
            print *, "IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE BUT LOSSES OF SIGNIFCANCE"
            print *, "BY ARGUMENT REDUCTION PRODUCE LESS THAN HALF OF MACHINE ACCURACY"
        elseif(ierr == 4) then
            print *, "IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTATION BECAUSE OF COMPLETE"
            print *, "LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION"
        elseif(ierr == 5) then
            print *, "IERR=5, ERROR - NO COMPUTATION ALGORITHM TERMINATION CONDITION NOT MET"
        endif
        call stop_error("besselk: zbesk error")
    endif
    res = resReal(1) + i_*resImag(1)
end function besselkv_complex

function bessel_j0_zeros(nzeros, eps) result(zeros)
! Calculates zeros of bessel_j0().
! This function is then used in bessel_jn_zeros() to calculate zeros of j_n(x)
! for n > 0 by simply using the zeros of j_{n-1}(x), as they must lie between.
integer, intent(in) :: nzeros
real(dp), intent(in) :: eps
! zeros(i) is the i-th zero of bessel_j0(x)
real(dp) :: zeros(nzeros)
real(dp) :: points(0:nzeros)
integer :: n, j
! The zeros of j0(x) must lie between the 'points', as can be shown by:
!
!   In [97]: n = 100000; arange(1, n+1) * pi - scipy.special.jn_zeros(0, n)
!   Out[97]:
!   array([ 0.7367671 ,  0.7631072 ,  0.77105005, ...,  0.78539777,
!           0.78539777,  0.78539777])
!
! For large "x", the asymptotic is j0(x) ~ cos(x - ...), so there it holds and
! for small 'x', it just happens to be the case numerically (see above).

points = [ (n*pi, n = 0, nzeros) ]
do j = 1, nzeros
    zeros(j) = bisect(f, points(j-1), points(j), eps)
end do

contains

real(dp) function f(x)
real(dp), intent(in) :: x
f = bessel_j0(x)
end function

end function

function bessel_jn_zeros(nmax, nzeros, eps) result(zeros)
! Calculates 'nzeros' zeros of bessel_jn() for all n=0, 1, ..., nmax
! It uses the fact that zeros of j_{n-1}(x) lie between zeros of j_n(x) and
! uses bisection to calculate them.
integer, intent(in) :: nmax, nzeros
real(dp), intent(in) :: eps
! zeros(i, n) is the i-th zero of bessel_jn(n, x)
real(dp) :: zeros(nzeros, 0:nmax)
! points holds all zeros of j_{n-1} needed for j_n
real(dp) :: points(nmax+nzeros)
integer :: n, j
points = bessel_j0_zeros(nmax + nzeros, eps)
zeros(:, 0) = points(:nzeros)
do n = 1, nmax
    do j = 1, nmax + nzeros - n
        points(j) = bisect(f, points(j), points(j+1), eps)
    end do
    zeros(:, n) = points(:nzeros)
end do

contains

real(dp) function f(x)
real(dp), intent(in) :: x
f = bessel_jn(n, x)
end function

end function

real(dp) function spherical_bessel_jn(n, x) result(r)
integer, intent(in) :: n
real(dp), intent(in) :: x
integer :: nm
real(dp) :: sj(0:n), dj(0:n)
call sphj(n, x, nm, sj, dj)
if (nm /= n) call stop_error("spherical_bessel_jn: sphj didn't converge")
r = sj(n)
end function

real(dp) function spherical_bessel_yn(n, x) result(r)
integer, intent(in) :: n
real(dp), intent(in) :: x
integer :: nm
real(dp) :: sy(0:n), dy(0:n)
call sphy(n, x, nm, sy, dy)
if (nm /= n) call stop_error("spherical_bessel_yn: sphy didn't converge")
r = sy(n)
end function

function spherical_bessel_jn_zeros(nmax, nzeros, eps) result(zeros)
! Calculates 'nzeros' zeros of spherical_bessel_jn() for all n=0, 1, ..., nmax
! It uses the fact that zeros of j_{n-1}(x) lie between zeros of j_n(x) and
! uses bisection to calculate them.
integer, intent(in) :: nmax, nzeros
real(dp), intent(in) :: eps
! zeros(i, n) is the i-th zero of spherical_bessel_jn(n, x)
real(dp) :: zeros(nzeros, 0:nmax)
! points holds all zeros of j_{n-1} needed for j_n
real(dp) :: points(nmax+nzeros)
integer :: n, j
points = [ (n*pi, n = 1, nmax + nzeros) ]
zeros(:, 0) = points(:nzeros)
do n = 1, nmax
    do j = 1, nmax + nzeros - n
        points(j) = bisect(f, points(j), points(j+1), eps)
    end do
    zeros(:, n) = points(:nzeros)
end do

contains

    real(dp) function f(x)
        real(dp), intent(in) :: x
        f = spherical_bessel_jn(n, x)
    end function f

end function

! The SPHJ, SPHY, MSTA1, MSTA2 routines below are taken from SciPy's specfun.f.
! Authors: Shanjie Zhang and Jianming Jin
! Copyrighted but permission granted to use code in programs.
        SUBROUTINE SPHJ(N,X,NM,SJ,DJ)
!       =======================================================
!       Purpose: Compute spherical Bessel functions jn(x) and
!                their derivatives
!       Input :  x --- Argument of jn(x)
!                n --- Order of jn(x)  ( n = 0,1,… )
!       Output:  SJ(n) --- jn(x)
!                DJ(n) --- jn'(x)
!                NM --- Highest order computed
!       Routines called:
!                MSTA1 and MSTA2 for computing the starting
!                point for backward recurrence
!       =======================================================
!
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        IMPLICIT integer (I-N)
        DIMENSION SJ(0:N),DJ(0:N)
        NM=N
        IF (DABS(X).LT.1.0D-100) THEN
           DO 10 K=0,N
              SJ(K)=0.0D0
              DJ(K)=0.0D0
10         END DO
           SJ(0)=1.0D0
           IF (N.GT.0) THEN
              DJ(1)=.3333333333333333D0
           ENDIF
           RETURN
        ENDIF
        SJ(0)=DSIN(X)/X
        DJ(0)=(DCOS(X)-DSIN(X)/X)/X
        IF (N.LT.1) THEN
           RETURN
        ENDIF
        SJ(1)=(SJ(0)-DCOS(X))/X
        IF (N.GE.2) THEN
           SA=SJ(0)
           SB=SJ(1)
           M=MSTA1(X,200)
           IF (M.LT.N) THEN
              NM=M
           ELSE
              M=MSTA2(X,N,15)
           ENDIF
           F=0.0D0
           F0=0.0D0
           F1=1.0D0-100
           DO 15 K=M,0,-1
              F=(2.0D0*K+3.0D0)*F1/X-F0
              IF (K.LE.NM) SJ(K)=F
              F0=F1
              F1=F
15         END DO
           CS=0.0D0
           IF (DABS(SA).GT.DABS(SB)) CS=SA/F
           IF (DABS(SA).LE.DABS(SB)) CS=SB/F0
           DO 20 K=0,NM
              SJ(K)=CS*SJ(K)
20         END DO
        ENDIF
        DO 25 K=1,NM
           DJ(K)=SJ(K-1)-(K+1.0D0)*SJ(K)/X
25      END DO
        RETURN
        END

        SUBROUTINE SPHY(N,X,NM,SY,DY)
!       ======================================================
!       Purpose: Compute spherical Bessel functions yn(x) and
!                their derivatives
!       Input :  x --- Argument of yn(x) ( x ≥ 0 )
!                n --- Order of yn(x) ( n = 0,1,… )
!       Output:  SY(n) --- yn(x)
!                DY(n) --- yn'(x)
!                NM --- Highest order computed
!       ======================================================
!
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        IMPLICIT integer (I-N)
        DIMENSION SY(0:N),DY(0:N)
        NM=N
        IF (X.LT.1.0D-60) THEN
           DO 10 K=0,N
              SY(K)=-1.0D+300
              DY(K)=1.0D+300
10         END DO
           RETURN
        ENDIF
        SY(0)=-DCOS(X)/X
        F0=SY(0)
        DY(0)=(DSIN(X)+DCOS(X)/X)/X
        IF (N.LT.1) THEN
           RETURN
        ENDIF
        SY(1)=(SY(0)-DSIN(X))/X
        F1=SY(1)
        DO 15 K=2,N
           F=(2.0D0*K-1.0D0)*F1/X-F0
           SY(K)=F
           IF (DABS(F).GE.1.0D+300) GO TO 20
           F0=F1
           F1=F
15      END DO
20      NM=K-1
        DO 25 K=1,NM
           DY(K)=SY(K-1)-(K+1.0D0)*SY(K)/X
25      END DO
        RETURN
        END

        INTEGER FUNCTION MSTA1(X,MP)
!       ===================================================
!       Purpose: Determine the starting point for backward
!                recurrence such that the magnitude of
!                Jn(x) at that point is about 10^(-MP)
!       Input :  x     --- Argument of Jn(x)
!                MP    --- Value of magnitude
!       Output:  MSTA1 --- Starting point
!       ===================================================
!
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        IMPLICIT integer (I-N)
        A0=DABS(X)
        N0=INT(1.1D0*A0)+1
        F0=ENVJ(N0,A0)-MP
        N1=N0+5
        F1=ENVJ(N1,A0)-MP
        DO 10 IT=1,20
           NN=int(N1-(N1-N0)/(1.0D0-F0/F1))
           F=ENVJ(NN,A0)-MP
           IF(ABS(NN-N1).LT.1) GO TO 20
           N0=N1
           F0=F1
           N1=NN
           F1=F
 10     END DO
 20     MSTA1=NN
        RETURN
        END

        INTEGER FUNCTION MSTA2(X,N,MP)
!       ===================================================
!       Purpose: Determine the starting point for backward
!                recurrence such that all Jn(x) has MP
!                significant digits
!       Input :  x  --- Argument of Jn(x)
!                n  --- Order of Jn(x)
!                MP --- Significant digit
!       Output:  MSTA2 --- Starting point
!       ===================================================
!
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        IMPLICIT integer (I-N)
        A0=DABS(X)
        HMP=0.5D0*MP
        EJN=ENVJ(N,A0)
        IF (EJN.LE.HMP) THEN
           OBJ=MP
           N0=INT(1.1D0*A0)+1
        ELSE
           OBJ=HMP+EJN
           N0=N
        ENDIF
        F0=ENVJ(N0,A0)-OBJ
        N1=N0+5
        F1=ENVJ(N1,A0)-OBJ
        DO 10 IT=1,20
           NN=int(N1-(N1-N0)/(1.0D0-F0/F1))
           F=ENVJ(NN,A0)-OBJ
           IF (ABS(NN-N1).LT.1) GO TO 20
           N0=N1
           F0=F1
           N1=NN
           F1=F
10      END DO
20      MSTA2=NN+10
        RETURN
        END

        real(dp) function envj(n, x) result(r)
        integer, intent(in) :: n
        real(dp), intent(in) :: x
        r = log10(6.28_dp*n)/2 - n*log10(1.36_dp*x/n)
        end function

! Ai(z)
function airyai(z) result(res)
    implicit none
    complex(dp), intent(in) :: z
    complex(dp) :: res

    integer :: underflow, ierr
    real(dp) :: resReal, resImag
    integer, parameter :: deriv=0, scaling=1  ! compute unscaled Ai(z)

    call zairy(real(z), aimag(z), deriv, scaling, resReal, resImag, underflow, ierr)
    if(ierr > 0) then
        if(ierr == 1) then
            print *, "IERR=1, INPUT ERROR - NO COMPUTATION"
        elseif(ierr == 2) then
            print *, "IERR=2, OVERFLOW - NO COMPUTATION, REAL(ZTA) TOO LARGE ON KODE=1"
        elseif(ierr == 3) then
            print *, "IERR=3, CABS(Z) LARGE - COMPUTATION DONE BUT LOSSES OF SIGNIFCANCE"
            print *, "BY ARGUMENT REDUCTION PRODUCE LESS THAN HALF OF MACHINE ACCURACY"
        elseif(ierr == 4) then
            print *, "IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION BECAUSE OF COMPLETE"
            print *, "LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION"
        elseif(ierr == 5) then
            print *, "IERR=5, ERROR - NO COMPUTATION ALGORITHM TERMINATION CONDITION NOT MET"
        endif
        call stop_error("airyai: zairy error")
    endif
    res = resReal + i_*resImag
end function airyai

! d(Ai(z))/dz
function dairyai(z) result(res)
    implicit none
    complex(dp), intent(in) :: z
    complex(dp) :: res

    integer :: underflow, ierr
    real(dp) :: resReal, resImag
    integer, parameter :: deriv=1, scaling=1  ! compute unscaled d(Ai(z))/dz

    call zairy(real(z), aimag(z), deriv, scaling, resReal, resImag, underflow, ierr)
    if(ierr > 0) then
        if(ierr == 1) then
            print *, "IERR=1, INPUT ERROR - NO COMPUTATION"
        elseif(ierr == 2) then
            print *, "IERR=2, OVERFLOW - NO COMPUTATION, REAL(ZTA) TOO LARGE ON KODE=1"
        elseif(ierr == 3) then
            print *, "IERR=3, CABS(Z) LARGE - COMPUTATION DONE BUT LOSSES OF SIGNIFCANCE"
            print *, "BY ARGUMENT REDUCTION PRODUCE LESS THAN HALF OF MACHINE ACCURACY"
        elseif(ierr == 4) then
            print *, "IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION BECAUSE OF COMPLETE"
            print *, "LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION"
        elseif(ierr == 5) then
            print *, "IERR=5, ERROR - NO COMPUTATION ALGORITHM TERMINATION CONDITION NOT MET"
        endif
        call stop_error("dairyai: zairy error")
    endif
    res = resReal + i_*resImag
end function dairyai

! Bi(z)
function airybi(z) result(res)
    implicit none
    complex(dp), intent(in) :: z
    complex(dp) :: res

    integer :: ierr
    real(dp) :: resReal, resImag
    integer, parameter :: deriv=0, scaling=1  ! compute unscaled Bi(z)

    call zbiry(real(z), aimag(z), deriv, scaling, resReal, resImag, ierr)
    if(ierr > 0) then
        if(ierr == 1) then
            print *, "IERR=1, INPUT ERROR - NO COMPUTATION"
        elseif(ierr == 2) then
            print *, "IERR=2, OVERFLOW - NO COMPUTATION, REAL(Z) TOO LARGE ON KODE=1"
        elseif(ierr == 3) then
            print *, "IERR=3, CABS(Z) LARGE - COMPUTATION DONE BUT LOSSES OF SIGNIFCANCE"
            print *, "BY ARGUMENT REDUCTION PRODUCE LESS THAN HALF OF MACHINE ACCURACY"
        elseif(ierr == 4) then
            print *, "IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION BECAUSE OF COMPLETE"
            print *, "LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION"
        elseif(ierr == 5) then
            print *, "IERR=5, ERROR - NO COMPUTATION ALGORITHM TERMINATION CONDITION NOT MET"
        endif
        call stop_error("dairyai: zairy error")
    endif
    res = resReal + i_*resImag
end function airybi

! d(Bi(z))/dz
function dairybi(z) result(res)
    implicit none
    complex(dp), intent(in) :: z
    complex(dp) :: res

    integer :: ierr
    real(dp) :: resReal, resImag
    integer, parameter :: deriv=1, scaling=1  ! compute unscaled d(Bi(z))/dz

    call zbiry(real(z), aimag(z), deriv, scaling, resReal, resImag, ierr)
    if(ierr > 0) then
        if(ierr == 1) then
            print *, "IERR=1, INPUT ERROR - NO COMPUTATION"
        elseif(ierr == 2) then
            print *, "IERR=2, OVERFLOW - NO COMPUTATION, REAL(Z) TOO LARGE ON KODE=1"
        elseif(ierr == 3) then
            print *, "IERR=3, CABS(Z) LARGE - COMPUTATION DONE BUT LOSSES OF SIGNIFCANCE"
            print *, "BY ARGUMENT REDUCTION PRODUCE LESS THAN HALF OF MACHINE ACCURACY"
        elseif(ierr == 4) then
            print *, "IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION BECAUSE OF COMPLETE"
            print *, "LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION"
        elseif(ierr == 5) then
            print *, "IERR=5, ERROR - NO COMPUTATION ALGORITHM TERMINATION CONDITION NOT MET"
        endif
        call stop_error("dairyai: zairy error")
    endif
    res = resReal + i_*resImag
end function dairybi

! rotate Hankel functions of negative order:
function Hrotate(hkind, order) result(factor)
    integer, intent(in) :: hkind
    real(dp), intent(in) :: order
    complex(dp) :: factor

    ! NIST Handbook, 10.4.6; note the signs in the exponents
    ! (NIST gives formulas for order -v with positive v, our 'order' here is negative)

    if(order < 0.0_dp) then
        if(hkind == 1) then
            factor = exp(-pi*order*i_)
        elseif(hkind == 2) then
            factor = exp(pi*order*i_)
        endif
    else
        factor = (1.0_dp, 0.0_dp)
    endif

end function Hrotate

! 'reflect' negative integer order Bessel functions if needed
function reflect(order) result(res)
    integer, intent(in) :: order
    integer :: res

    if(order < 0) then
        res = (-1)**order
    else
        res = 1
    endif
end function

end module


program potential_calc
 implicit none
 real(8)::v(500),sig,sigsq,epslon,sr2,sr6,sr12,r
 integer::i
 sig = 3.405d0
 sigsq = sig * sig
 epslon = 120.0d0

 do i=20,150
   r = 0.10d0*i
   sr2 = (sigsq/(r**2))
   sr6 = sr2 * sr2 * sr2
   sr12 = sr6 * sr6
   v= 4*epslon*(sr12 -sr6)
   write(23,*)r,v
 end do
end program potential_calc


!
!     isoparametric implementation
!     element calculation
!
subroutine r_element(rs)
  use solid_variables, only: nsd_solid,nen_solid
  use r_common, only: h,r_p
  implicit none

  real(8) :: rs(1:nsd_solid)
  real(8) :: r,s,t

  cube: if (nen_solid .eq. 8) then

	 r=rs(1)
	 s=rs(2)
	 t=rs(3)

     h(1)=0.125d0*(1.0d0+r)*(1.0d0+s)*(1.0d0+t)
     h(2)=0.125d0*(1.0d0-r)*(1.0d0+s)*(1.0d0+t)
     h(3)=0.125d0*(1.0d0-r)*(1.0d0-s)*(1.0d0+t)
     h(4)=0.125d0*(1.0d0+r)*(1.0d0-s)*(1.0d0+t)
     h(5)=0.125d0*(1.0d0+r)*(1.0d0+s)*(1.0d0-t)
     h(6)=0.125d0*(1.0d0-r)*(1.0d0+s)*(1.0d0-t)
     h(7)=0.125d0*(1.0d0-r)*(1.0d0-s)*(1.0d0-t)
     h(8)=0.125d0*(1.0d0+r)*(1.0d0-s)*(1.0d0-t)

!     derivative of interpolation function
!     first derivative with respect to r
     r_p(1,1)= 0.125d0*(1.0d0+s)*(1.0d0+t)
     r_p(1,2)=-0.125d0*(1.0d0+s)*(1.0d0+t)
     r_p(1,3)=-0.125d0*(1.0d0-s)*(1.0d0+t)
     r_p(1,4)= 0.125d0*(1.0d0-s)*(1.0d0+t)
     r_p(1,5)= 0.125d0*(1.0d0+s)*(1.0d0-t)
     r_p(1,6)=-0.125d0*(1.0d0+s)*(1.0d0-t)
     r_p(1,7)=-0.125d0*(1.0d0-s)*(1.0d0-t)
     r_p(1,8)= 0.125d0*(1.0d0-s)*(1.0d0-t)

!     first derivative with resr_pect to s
     r_p(2,1)= 0.125d0*(1.0d0+r)*(1.0d0+t)
     r_p(2,2)= 0.125d0*(1.0d0-r)*(1.0d0+t)
     r_p(2,3)=-0.125d0*(1.0d0-r)*(1.0d0+t)
     r_p(2,4)=-0.125d0*(1.0d0+r)*(1.0d0+t)
     r_p(2,5)= 0.125d0*(1.0d0+r)*(1.0d0-t)
     r_p(2,6)= 0.125d0*(1.0d0-r)*(1.0d0-t)
     r_p(2,7)=-0.125d0*(1.0d0-r)*(1.0d0-t)
     r_p(2,8)=-0.125d0*(1.0d0+r)*(1.0d0-t)

!     first derivative with resr_pect to t
     r_p(3,1)= 0.125d0*(1.0d0+r)*(1.0d0+s)
     r_p(3,2)= 0.125d0*(1.0d0-r)*(1.0d0+s)
     r_p(3,3)= 0.125d0*(1.0d0-r)*(1.0d0-s)
     r_p(3,4)= 0.125d0*(1.0d0+r)*(1.0d0-s)
     r_p(3,5)=-0.125d0*(1.0d0+r)*(1.0d0+s)
     r_p(3,6)=-0.125d0*(1.0d0-r)*(1.0d0+s)
     r_p(3,7)=-0.125d0*(1.0d0-r)*(1.0d0-s)
     r_p(3,8)=-0.125d0*(1.0d0+r)*(1.0d0-s)
  endif cube

  tetr: if ((nen_solid .eq. 4).AND.(nsd_solid.eq.3)) then

  	 r=rs(1)
	 s=rs(2)
	 t=rs(3)

     h(1)=r
     h(2)=s
     h(3)=t
     h(4)=1-r-s-t
!
!     derivative of interpolation function
!     first derivative with respect to r
     r_p(1,1)= 1.0d0
     r_p(1,2)= 0.0d0
     r_p(1,3)= 0.0d0
     r_p(1,4)=-1.0d0
!
!     first derivative with respect to s
     r_p(2,1)= 0.0d0
     r_p(2,2)= 1.0d0
     r_p(2,3)= 0.0d0
     r_p(2,4)=-1.0d0
!
!     first derivative with respect to t
     r_p(3,1)= 0.0d0
     r_p(3,2)= 0.0d0
     r_p(3,3)= 1.0d0
     r_p(3,4)=-1.0d0
  endif tetr

!	Yaling Liu added triaguler element
!	h(nen_solid), r_p(nsd_solid,nen_solid)
  tria: if (nen_solid .eq. 3) then

  	 r=rs(1)
	 s=rs(2)

     h(1)=r
     h(2)=s
     h(3)=1-r-s
!
!     derivative of interpolation function
!     first derivative with respect to r
     r_p(1,1)= 1.0d0
     r_p(1,2)= 0.0d0
     r_p(1,3)=-1.0d0
!
!     first derivative with respect to s
     r_p(2,1)= 0.0d0
     r_p(2,2)= 1.0d0
     r_p(2,3)=-1.0d0

  endif tria

  quad: if ((nen_solid .eq. 4).and.(nsd_solid.eq.2)) then

  	 r=rs(1)
	 s=rs(2)

     h(1)=0.25d0*(1.0d0-r)*(1.0d0-s)
     h(2)=0.25d0*(1.0d0+r)*(1.0d0-s)
     h(3)=0.25d0*(1.0d0+r)*(1.0d0+s)
     h(4)=0.25d0*(1.0d0-r)*(1.0d0+s)

!     derivative of interpolation function
!     first derivative with respect to r
     r_p(1,1)=-0.25d0*(1.0d0+s)
     r_p(1,2)= 0.25d0*(1.0d0+s)
     r_p(1,3)= 0.25d0*(1.0d0-s)
     r_p(1,4)=-0.25d0*(1.0d0-s)
!
!     first derivative with resr_pect to s
     r_p(2,1)=-0.25d0*(1.0d0+r)
     r_p(2,2)=-0.25d0*(1.0d0-r)
     r_p(2,3)=+0.25d0*(1.0d0-r)
     r_p(2,4)=+0.25d0*(1.0d0+r)

  endif quad

  return
end subroutine r_element


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program delta
! Program to compute the great circle angle between two points
! on a sphere (e.g. Earth) given latitude and longitude
! Reads from standard input

implicit none

! variables
double precision :: lat1,lon1,lat2,lon2
double precision :: angle
integer          :: iostatus = 0

call get_args

do while (iostatus == 0)
   read(*,*,iostat=iostatus) lon1,lat1,lon2,lat2
   if (iostatus < 0) exit
   if (iostatus > 0) stop 'Some problem reading coordinates'
   write(*,'(f10.6)') angle(lat1,lon1,lat2,lon2)
enddo

contains

subroutine get_args()
   integer :: narg, iarg
   narg = command_argument_count()
   if (narg > 0) call usage
end subroutine get_args

subroutine usage()
   write(0,'(a)') 'Usage: delta < [(lon1, lat1, lon2, lat2) on stdin]', &
                  'Reads pairs of geographic coordinates in degrees and writes', &
                  'great circle distance on a sphere (in degrees) to stdout.'
   stop
end subroutine usage

end program delta

function angle(lat1i,lon1i,lat2i,lon2i)
implicit none
double precision :: angle
double precision, intent(in) :: lat1i,lon1i,lat2i,lon2i
double precision :: lat1,lon1,lat2,lon2
double precision, parameter :: pi=3.14159265358979323846264338327950288D0

lat1=lat1i*pi/1.8D2 ; lon1=lon1i*pi/1.8D2
lat2=lat2i*pi/1.8D2 ; lon2=lon2i*pi/1.8D2

angle=atan2( sqrt( (cos(lat2)*sin(lon2-lon1))**2 + (cos(lat1)*sin(lat2) - &
                   sin(lat1)*cos(lat2)*cos(lon2-lon1))**2) , &
            sin(lat1)*sin(lat2) + cos(lat1)*cos(lat2)*cos(lon2-lon1))

angle=angle*1.8D2/pi

end function angle


module util

implicit none

real(kind=8),parameter  :: pi=3.141592653589793238d0
complex(kind=8),parameter :: i_imag=cmplx(0,1,kind=8)

contains
! Returns the inverse of a matrix calculated by finding the LU
! decomposition.  Depends on LAPACK.
function inv(A) result(Ainv)
  complex(kind=8), dimension(:,:), intent(in) :: A
  complex(kind=8), dimension(size(A,1),size(A,2)) :: Ainv

  complex(kind=8), dimension(size(A,1)) :: work  ! work array for LAPACK
  integer, dimension(size(A,1)) :: ipiv   ! pivot indices
  integer :: n, info

  ! External procedures defined in LAPACK
  external ZGETRF
  external ZGETRI

  ! Store A in Ainv to prevent it from being overwritten by LAPACK
  Ainv = A
  n = size(A,1)

  ! ZGETRF computes an LU factorization of a general M-by-N matrix A
  ! using partial pivoting with row interchanges.
  call ZGETRF(n, n, Ainv, n, ipiv, info)

  if (info /= 0) then
     write(*,*) size(A,1)

     stop 'Matrix is numerically singular!'
  end if

  ! ZGETRI computes the inverse of a matrix using the LU factorization
  ! computed by ZGETRF.
  call ZGETRI(n, Ainv, n, ipiv, work, n, info)

  if (info /= 0) then
     stop 'Matrix inversion failed!'
  end if
  end function inv

  ! matrix inversion for real matrix
  function inv_real(A) result(Ainv)
  real(kind=8), dimension(:,:), intent(in) :: A
  real(kind=8), dimension(size(A,1),size(A,2)) :: Ainv

  real(kind=8), dimension(size(A,1)) :: work  ! work array for LAPACK
  integer, dimension(size(A,1)) :: ipiv   ! pivot indices
  integer :: n, info

  ! External procedures defined in LAPACK
  external DGETRF
  external DGETRI

  ! Store A in Ainv to prevent it from being overwritten by LAPACK
  Ainv = A
  n = size(A,1)

  ! DGETRF computes an LU factorization of a general M-by-N matrix A
  ! using partial pivoting with row interchanges.
  call DGETRF(n, n, Ainv, n, ipiv, info)

  if (info /= 0) then
     stop 'Matrix is numerically singular!'
  end if

  ! DGETRI computes the inverse of a matrix using the LU factorization
  ! computed by DGETRF.
  call DGETRI(n, Ainv, n, ipiv, work, n, info)

  if (info /= 0) then
     stop 'Matrix inversion failed!'
  end if
  end function inv_real

  function eyemat(n) result(mat)
  integer(kind=4),intent(in) :: n
  real(kind=8) :: mat(n,n)
  integer(kind=4) :: i
  mat = 0.0d0
  do i = 1, n
    mat(i,i) = 1.0d0
  end do
  end function eyemat

  subroutine eigenH(A,w,vecr)

  integer(kind=4) :: nwork=1
  integer(kind=4) :: info
  real(kind=8),allocatable :: rwork(:)
  complex(kind=8),allocatable :: work(:)
  complex(kind=8),intent(in) :: A(:,:)
  complex(kind=8),dimension(size(A,1),size(A,2)) :: At
  real(kind=8),dimension(size(A,1)),intent(out) :: w
  complex(kind=8),dimension(size(A,1),size(A,2)),&
               intent(out) :: vecr
  integer(kind=4) :: n

  n = size(A,1)
  At = A
  allocate(work(nwork))
  allocate(rwork(3*n))

  ! compute the eigenvalue and eigenvector
  ! of Hermitian matrix
  ! info = 0, the eigenvalues in ascending order
  call zheev("V","U",n,At(:,:),n,w,work,-1,rwork,info)

  if(real(work(1)).gt.nwork) then
        nwork=nint(2*real(work(1)))
        deallocate(work)
        allocate(work(nwork))
  end if

  call zheev("V","U",n,At(:,:),n,w,work,nwork,rwork,info)
  vecr = At
  end subroutine

  subroutine eigen(A,w,vecr)
  ! compute the eigenvalue and eigenvectors for a
  ! n by n nonsymmetric complex matrix
  complex(kind=8), dimension(:,:), intent(in) :: A
  complex(kind=8), dimension(size(A,1),size(A,2)) :: Atemp
  complex(kind=8), dimension(size(A,1),size(A,2)) :: Asq
  complex(kind=8), intent(out) :: w(size(A,1))
  complex(kind=8), allocatable :: work(:)
  real(kind=8), allocatable :: rwork(:)
  complex(kind=8), dimension(size(A,1),size(A,2)) :: vecl
  complex(kind=8),dimension(size(A,1),size(A,2)),intent(out) :: vecr
  integer(kind=4) :: lda,  info, nwork = 1

  Atemp = A

  if (size(A,1) /= size(A,2)) then
    stop 'Not a square matrix!'
  end if
  lda = max(size(A,1),1)
  allocate(rwork(max(1,2*lda)))
  allocate(work(nwork))

  call ZGEEV("N", "V", lda, Atemp, lda, w,&
   vecl, lda, vecr, lda,work,-1,&
   rwork, info)

  if(real(work(1)).gt.nwork) then
        nwork=nint(2*real(work(1)))
        deallocate(work)
        allocate(work(nwork))
  end if

  call ZGEEV("N", "V", lda, Atemp, lda, w,&
   vecl, lda, vecr, lda,work,nwork,&
   rwork, info)

  end subroutine eigen

  LOGICAL FUNCTION DUMMY_SELECT(ARG)
  IMPLICIT NONE

  COMPLEX(kind=8),intent(in) :: ARG

  DUMMY_SELECT = (ARG .EQ. ARG)

  end function DUMMY_SELECT

  function sqrtm(A) result(QUQH)
  ! Firstly, computes for an N-by-N complex nonsymmetric
  ! matrix A, the eigenvalues, the Schur form T.

  complex(kind=8), dimension(:,:), intent(in) :: A
  complex(kind=8), dimension(size(A,1),size(A,2)) :: S
  complex(kind=8) :: w(size(A,1))
  complex(kind=8), allocatable :: work(:)
  real(kind=8), allocatable :: rwork(:)
  logical,allocatable :: bwork(:)
  complex(kind=8), dimension(size(A,1),size(A,2)) :: q
  complex(kind=8), dimension(size(A,1),size(A,2)) :: U
  complex(kind=8), dimension(size(A,1),size(A,2)) :: QUQH
  complex(kind=8), dimension(size(A,1),size(A,2)) :: QU
  integer(kind=4) :: N,info,nwork = 1
  integer(kind=4) :: i,j,k,sdim, sdiag
  sdim = 0

  S = A

  if (size(A,1) /= size(A,2)) then
    stop 'Not a square matrix!'
  end if
  N = max(size(A,1),1)
  allocate(rwork(max(1,N)))
  allocate(bwork(N))
  allocate(work(nwork))

  call ZGEES('V', 'N',DUMMY_SELECT, N, &
   S, N, sdim, w,&
   q, N,work,-1,&
   rwork, bwork, info)

  if(real(work(1)).gt.nwork) then
        nwork=nint(2*real(work(1)))
        deallocate(work)
        allocate(work(nwork))
  end if

  call ZGEES('V', 'N',DUMMY_SELECT, N, &
  S, N, sdim, w,&
  q, N,work,nwork,&
  rwork, bwork, info)

  do j = 1,N-1              ! set the lower triangle to zero
        do i = j+1,N
           U(i,j) = 0.0d0
        enddo
  enddo

  do i = 1,N                ! set the diagonal elements
        U(i,i) = sqrt(S(i,i))
  enddo

  do sdiag = 1,N-1          ! loop over the N-1 super-diagonals
     do i = 1,N-sdiag
         j = i+sdiag
         U(i,j) = S(i,j)
         do k = i+1,j-1
             U(i,j) = U(i,j) - U(i,k)*U(k,j)
         enddo
         if (U(i,i) + U(j,j) .ne. cmplx(0.0,0.0,kind=8))then
             U(i,j) = U(i,j) / (U(i,i) + U(j,j))
         else
             U(i,j) = 0.0d0
         end if
     enddo
  enddo
  call ZGEMM('N', 'N', N, N, N, cmplx(1.0,0.0,kind=8), Q, N, U, N, cmplx(0.0,0.0,kind=8), QU, N)
  call ZGEMM('N', 'C', N, N, N, cmplx(1.0,0.0,kind=8), QU, N,Q, N, cmplx(0.0,0.0,kind=8), QUQH, N)
  if(info /= 0) then
       write(*,*) "zgemm returned info = ", info
       write(*,*) "the ", info, "-th argument had an illegal value"
  end if

  end function

  function lstsq(A, b) result(x)
  ! compute least square solution to A x = B for cmplx A, b
  complex(kind=8), intent(in) :: A(:,:), B(:,:)
  complex(kind=8), allocatable :: x(:,:)
  ! LAPACK variables:
  integer :: info, lda, ldb, lwork, m, n, nrhs, rank
  real(kind=8) :: rcond
  real(kind=8),allocatable :: rwork(:)
  complex(kind=8), allocatable :: work(:), At(:,:), Bt(:,:)
  integer, allocatable :: jpvt(:)

  m = size(A,1)
  n = size(A,2)
  nrhs = size(B,2)
  lda = max(1,m)
  ldb = max(1,m,n)
  allocate(x(n,nrhs), At(m,n), Bt(m,nrhs), &
            jpvt(n), work(1),rwork(2*n))
  rcond = 0.0
  jpvt(:) = 0
  Bt(:,:) = B(:,:)  ! only one right-hand side
  At(:,:) = A(:,:)
  call zgelsy(m, n, nrhs, At, lda, Bt, ldb,&
        jpvt, rcond, rank, work, &
         -1, rwork, info)  ! query optimal workspace size
  lwork = int(real(work(1)))
  deallocate(work)
  allocate(work(lwork))  ! allocate with ideal size

  call zgelsy(m, n, nrhs, At, lda, Bt, ldb,&
         jpvt, rcond, rank, work, &
         lwork, rwork, info)
  if(info /= 0) then
       write(*,*) "zgelsy returned info = ", info
       write(*,*) "the ", info, "-th argument had an illegal value"
  end if
  x(:,:) = Bt(:,:)
  end function lstsq

  function trace(A) result(X)
  complex(kind=8),intent(in) :: A(:,:)
  complex(kind=8) :: X
  integer(kind=4) :: i, n

  if (size(A,1) /= size(A,2)) then
    stop 'Not a square matrix!'
  end if

  n = size(A,1)

  X = 0.0d0

  do i = 1,n
    X = A(i,i) + X
  end do
  end function trace

  subroutine find_degenerate(eigval,start,idx_list,next_start,case_no,&
             deg_all)

  implicit none

  complex(kind=8),dimension(:),intent(in) :: eigval
  complex(kind=8) :: edeg
  integer(kind=4),intent(in) :: start
  integer(kind=4),dimension(:),intent(in) :: deg_all
  integer(kind=4),intent(out) :: next_start
  integer(kind=4),intent(out) :: case_no
  integer(kind=4),allocatable,intent(out) :: idx_list(:)
  integer(kind=4) :: ne, i, j, edeg_idx,&
                     n, itemp
  complex(kind=8),allocatable :: temp(:)

  itemp = 0
  next_start = 0
  case_no = 0 ! case number is zero meaning there are no degenerate states
  ne = size(eigval,1)
  outer: do i = start, ne-1
      do j = i+1,ne
          if ((abs(eigval(i)-eigval(j)) .lt. 1.0d-4).and.&
           (abs(abs(eigval(j))-1.0d0) .lt. 1.0d-3)) then
              case_no = 1
              edeg_idx = j
              itemp = i
              edeg = eigval(edeg_idx)
          end if
          if( case_no .eq. 1) exit outer
      end do
  end do outer

  next_start = itemp+1

  n = 0
  if (ALLOCATED(idx_list)) then
      deallocate(idx_list)
  end if
  allocate(idx_list(1))
  idx_list = 0

  allocate(temp(1))

  if (case_no .eq. 1) then
     do i = 1, ne
         if (abs(eigval(i)-edeg) .lt. 1.0d-4) then
             n = n + 1
             if (n.eq.1) then
                 idx_list(1) = i
                 temp(1) = i
             else
                 deallocate(idx_list)
                 allocate(idx_list(n))
                 idx_list(1:n-1) = temp(:)
                 idx_list(n) = i ! append new element

                 deallocate(temp)
                 allocate(temp(n))
                 temp = idx_list
             end if
         end if
     end do
     do i =1,size(idx_list,1)
         do j = 1,size(deg_all,1)
             if (idx_list(i).eq.deg_all(j)) then
                 deallocate(idx_list)
                 allocate(idx_list(1))
                 idx_list(1) = 0
             end if
         end do
     end do
  end if

  end subroutine find_degenerate

  function in_ws(a_vectors,k_pos) result(output)

    implicit none

    real(kind=8),intent(in) :: a_vectors(3,3), k_pos(3)
    real(kind=8) :: dist(125),dist_min,dist_min2
    real(kind=8) :: dist_remain(124)
    integer(kind=4) :: min_idx
    integer(kind=4) :: icnt,i1,i2,i3
    real(kind=8) :: ndiff(3)
    integer(kind=4) :: output

    dist = 0
    icnt = 0
    do i1 =-2,2
        do i2 =-2,2
            do i3 =-2,2
                ndiff(1) = dble(i1)
                ndiff(2) = dble(i2)
                ndiff(3) = dble(i3)

                icnt =icnt+ 1

                dist(icnt) = dot_product(k_pos-matmul(ndiff,a_vectors),&
                                         k_pos-matmul(ndiff,a_vectors))
            end do
        end do
    end do
    dist_min = minval(dist)
    ! find the second smallest element
    min_idx = minloc(dist,1)

    if (min_idx .eq. 1) then
        dist_remain = dist(2:125)
    else if (min_idx .eq. 125) then
        dist_remain = dist(1:124)
    else
        dist_remain(1:min_idx-1) = dist(1:min_idx-1)
        dist_remain(min_idx:124) = dist(min_idx+1:125)
    end if
    dist_min2 = minval(dist_remain)

    if (abs(dist_min2-dist_min).lt.1.0d-5) then
        output = 2
    else if (abs(dist(63)-dist_min) .lt. 1d-5) then
        output = 1
    else
        output = 0
    end if

    end function in_ws

    function in_ws_misori(a_vectors,k_pos,n1,n2,n3) result(output)

    implicit none

    real(kind=8),intent(in) :: a_vectors(3,3), k_pos(3)
    real(kind=8) :: dist((2*n1+1)*(2*n2+1)*(2*n3+1)),dist_min,dist_min2
    real(kind=8) :: dist_remain((2*n1+1)*(2*n2+1)*(2*n3+1)-1)
    integer(kind=4) :: min_idx
    integer(kind=4) :: icnt,i1,i2,i3
    integer(kind=4),intent(in) :: n1,n2,n3
    real(kind=8) :: ndiff(3)
    integer(kind=4) :: output
    integer(kind=4) :: ntot

    ntot = (2*n1+1)*(2*n2+1)*(2*n3+1)

    dist = 0
    icnt = 0
    do i1 =-n1,n1
        do i2 =-n2,n2
            do i3 =-n3,n3
                ndiff(1) = dble(i1)
                ndiff(2) = dble(i2)
                ndiff(3) = dble(i3)

                icnt =icnt+ 1

                dist(icnt) = dot_product(k_pos-matmul(ndiff,a_vectors),&
                                         k_pos-matmul(ndiff,a_vectors))
            end do
        end do
    end do
    dist_min = minval(dist)
    ! find the second smallest element
    min_idx = minloc(dist,1)

    if (min_idx .eq. 1) then
        dist_remain = dist(2:ntot)
    else if (min_idx .eq. ntot) then
        dist_remain = dist(1:ntot-1)
    else
        dist_remain(1:min_idx-1) = dist(1:min_idx-1)
        dist_remain(min_idx:ntot-1) = dist(min_idx+1:ntot)
    end if
    dist_min2 = minval(dist_remain)

    if (abs(dist_min2-dist_min).lt.1.0d-5) then
        output = 2
    else if (abs(dist((ntot+1)/2)-dist_min) .lt. 1d-5) then
        output = 1
    else
        output = 0
    end if

    end function in_ws_misori

    function move_in_ws3(k_pos,a_vectors) result(output)

    implicit none

    real(kind=8),intent(in) :: a_vectors(3,3), k_pos(3)
    real(kind=8) :: dist(125)
    integer(kind=4) :: i_min
    integer(kind=4) :: icnt,i1,i2,i3
    real(kind=8) :: ndiff(3)
    real(kind=8) :: output(3)
    real(kind=8) :: k_all(125,3)

    dist = 0
    icnt = 0
    k_all(:,:) = 0.0d0

    do i1 =-2,2
        do i2 =-2,2
            do i3 =-2,2
                ndiff(1) = dble(i1)
                ndiff(2) = dble(i2)
                ndiff(3) = dble(i3)

                icnt =icnt+ 1
                k_all(icnt,:) = ndiff
                dist(icnt) = dot_product(k_pos-matmul(ndiff,a_vectors),&
                                         k_pos-matmul(ndiff,a_vectors))
            end do
        end do
    end do
    i_min = minloc(dist,1)
    output = k_pos - matmul(k_all(i_min,:),a_vectors)

    end function move_in_ws3

    function move_in_ws2(k_pos,a_vectors) result(output)

    implicit none

    real(kind=8),intent(in) :: a_vectors(3,3), k_pos(3)
    real(kind=8) :: dist(25)
    integer(kind=4) :: i_min
    integer(kind=4) :: icnt,i1,i2,i3
    real(kind=8) :: ndiff(3)
    real(kind=8) :: output(3)
    real(kind=8) :: k_all(25,3)

    dist = 0
    icnt = 0
    k_all(:,:) = 0.0d0

    do i1 =-2,2
        do i2 =-2,2
                ndiff(1) = dble(i1)
                ndiff(2) = dble(i2)
                ndiff(3) = 0.0d0

                icnt =icnt+ 1
                k_all(icnt,:) = ndiff
                dist(icnt) = dot_product(k_pos-matmul(ndiff,a_vectors),&
                                         k_pos-matmul(ndiff,a_vectors))
        end do
    end do
    i_min = minloc(dist,1)
    output = k_pos - matmul(k_all(i_min,:),a_vectors)

    end function move_in_ws2

    function get_pos_index_in_pc(pos_sc,pos_pc,recivec) result(idx)

    implicit none

    real(kind=8),intent(in) :: pos_sc(3)
    real(kind=8),intent(in) :: pos_pc(:,:)
    real(kind=8),intent(in) :: recivec(3,3)
    integer(kind=4) :: natm_pc, i, idx
    real(kind=8) :: coord_crys_temp(3)

    natm_pc = size(pos_pc,1)
    do i = 1,natm_pc
        coord_crys_temp(:) = matmul(&
        pos_sc-pos_pc(i,1:3),recivec)
        if ((abs(coord_crys_temp(1)-nint(coord_crys_temp(1)))<1d-4).and.&
            (abs(coord_crys_temp(2)-nint(coord_crys_temp(2)))<1d-4).and.&
            (abs(coord_crys_temp(3)-nint(coord_crys_temp(3)))<1d-4)) then
            idx = int(pos_pc(i,4))
        end if
    end do

    end function get_pos_index_in_pc

    function fourier_transform(Ham,n,nb,G,R) result(Ham_f)

    ! Fourier transform of a block circualr matrix

    implicit none

    integer(kind=4),intent(in) :: n
    integer(kind=4),intent(in) :: nb
    real(kind=8),intent(in) :: G(3)
    real(kind=8),intent(in) :: R(3)
    complex(kind=8),intent(in) :: Ham(:,:)
    complex(kind=8) :: Ham_f(size(Ham,1),size(Ham,2))
    integer(kind=4) :: i,j,k,l
    integer(kind=4) :: na, mm

    na = n/nb
    Ham_f = 0.0d0

    do i = 1, nb
        do j = 1,nb
            Ham_f((i-1)*na+1:i*na,(i-1)*na+1:i*na) = &
            Ham_f((i-1)*na+1:i*na,(i-1)*na+1:i*na)+&
            Ham(1:na,(j-1)*na+1:j*na)*&
            exp(i_imag*dot_product(&
            G*dble(i-1)/dble(nb),&
            R*dble(j-1)))
        end do
    end do
    end function fourier_transform

    function decimation(Es_in0,e_in1,alpha_in,&
             beta_in,convergence) result(g)

    implicit none

    complex(kind=8),intent(in) :: Es_in0(:,:)
    complex(kind=8),intent(in) :: e_in1(:,:)
    complex(kind=8),intent(in) :: alpha_in(:,:)
    complex(kind=8),intent(in) :: beta_in(:,:)
    real(kind=8),intent(in) :: convergence
    complex(kind=8) :: Es0(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: e1(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: es(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: alpha(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: beta(size(Es_in0,1),size(Es_in0,2))
    complex(kind=8) :: ive(size(Es_in0,1),size(Es_in0,2))
    real(kind=8) :: maxdiff
    complex(kind=8) :: g(size(Es0,1),size(Es0,2))

    Es0 = Es_in0
    e1 = e_in1
    es = e_in1
    alpha = alpha_in
    beta = beta_in
    maxdiff = maxval(abs(alpha))
    do while( maxdiff .gt. convergence)
        ive = inv(Es0-e1)
        e1 = e1 + matmul(matmul(alpha,ive),beta)+&
                matmul(matmul(beta,ive),alpha)
        es = es + matmul(matmul(alpha,ive),beta)
        alpha = matmul(matmul(alpha,ive),alpha)
        beta = matmul(matmul(beta,ive),beta)
        maxdiff = maxval(abs(alpha))
    end do
    g = inv(Es0-es)

    end function decimation

    function gram_schmidt(U1) result(U2)

    implicit none
    complex(kind=8),intent(in) :: U1(:,:)
    complex(kind=8),dimension(size(U1,1),size(U1,2)) :: U2
    integer(kind=4) :: i,j,n

    U2 = U1
    n = size(U1,2)
    do i = 2,n
        do j=1,i-1
            U2(:,i) = U2(:,i) - &
             dot_product(U1(:,i),U2(:,j))/&
             dot_product(U2(:,j),U2(:,j))*&
             U2(:,j)
        end do
    end do

    do i = 1,n
        U2(:,i) = U2(:,i)/sqrt(dot_product(U2(:,i),U2(:,i)))
    end do

    end function

    function log_fbz(lambda,az) result(kz)

    implicit none
    complex(kind=8),intent(in) :: lambda
    real(kind=8),intent(in) :: az
    real(kind=8) :: kz, Gz

    Gz = 2*pi/az

    kz = modulo(real(log(lambda)/(i_imag*az)),Gz)
    if (kz.gt.Gz*0.5)then
        kz = kz - Gz ! make sure kz is inside fbz
    end if

    end function log_fbz

    function find_min_dist(kpoint,n) result(kmin)

    implicit none

    real(kind=8) :: kpoint(:,:)
    integer(kind=4) :: n,i
    real(kind=8) :: kabs(n)
    real(kind=8) :: kmin(3)
    integer(kind=4) :: minid

    do i = 1,n
        kabs(i) = dsqrt(dot_product(kpoint(i,:),kpoint(i,:)))
    end do

    minid = minloc(kabs,1)
    kmin = kpoint(minid,:)
    end function

    function hermitian(A) result(B)

    implicit none

    complex(kind=8) :: A(:,:)
    complex(kind=8) :: B(size(A,1),size(A,2))

    B = 0.5*(A+transpose(dconjg(A)))

    end function hermitian

    function antihermitian(A) result(B)

    implicit none

    complex(kind=8) :: A(:,:)
    complex(kind=8) :: B(size(A,1),size(A,2))

    B = 0.5*(A-transpose(dconjg(A)))

    end function antihermitian

end module util


! Compile with gfortran example.f90 -o example.exe -lfermidirac
program example
      implicit none
! interface for C library http://th.if.uj.edu.pl/~odrzywolek/homepage/codes/libfermidirac/libfermidirac.html
! See https://stackoverflow.com/tags/fortran-iso-c-binding/info
      interface
        real(C_DOUBLE) function ofermi(k, eta, theta) bind(C, name='Ffermi')
          use ISO_C_BINDING
          implicit none
          real(C_DOUBLE), value :: k, eta, theta
        end function ofermi
      end interface

      real*8   :: f
! evaluate the fermi function for k=4, eta=1, theta=1
      f = ofermi(4.0d0, 1.0d0, 1.0d0)
	  write(*,*) "Ffermi(4,1,1)= ",f

! Expected reference result
! Ffermi(4,1,1)=114.06687799137902589992508824775903265360960251309372394266372713106403373794999046746440912671766590817078780479429221800302036

end program example


module precision
  !! Provides kind attributes for setting machine-compiler-independent precision for real numbers. Here, we define "single precision" to mean 32-bit precision, "double precision" to mean 64-bit precision, and "quadruple precision" to mean 128-bit precision. This ensures that precision is preserved regardless of the compiler or computer architecture.

  implicit none

  integer, parameter :: sp = selected_real_kind(6, 37)
  !! Single precision: 32-bit real
  integer, parameter :: dp = selected_real_kind(15, 307)
  !! Double precision: 64-bit real
  integer, parameter :: qp = selected_real_kind(33, 4931)
  !! Quadruple precision: 128-bit real

contains

end module precision


MODULE Tavgmod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_tavg(tmin, &
        tmax, &
        tavg)
        IMPLICIT NONE
        REAL, INTENT(IN) :: tmin
        REAL, INTENT(IN) :: tmax
        REAL, INTENT(OUT) :: tavg
        !- Name: Tavg -Version: 1.0, -Time step: 1
        !- Description:
    !            * Title: Mean temperature  calculation
    !            * Author: STICS
    !            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    !            * Institution: INRA
    !            * Abstract: It simulates the depth of snow cover and recalculate weather data
        !- inputs:
    !            * name: tmin
    !                          ** description : current minimum air temperature
    !                          ** inputtype : variable
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 500.0
    !                          ** unit : degC
    !                          ** uri :
    !            * name: tmax
    !                          ** description : current maximum air temperature
    !                          ** inputtype : variable
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 100.0
    !                          ** unit : degC
    !                          ** uri :
        !- outputs:
    !            * name: tavg
    !                          ** description : mean temperature
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** min : 0.0
    !                          ** max : 500.0
    !                          ** unit : degC
    !                          ** uri :
        tavg = (tmin + tmax) / 2
    END SUBROUTINE model_tavg

END MODULE


program arrays_02
implicit none
integer, parameter :: dp = kind(0.d0)
real(dp) :: a(3), b
a(1) = 3._dp
a(2) = 2._dp
a(3) = 1._dp
b = sum(a)
if (abs(b-6._dp) > 1e-12_dp) error stop
end


! -*- Mode: Fortran90; -*-
!-----------------------------------------------------------------
! Daniel R. Reynolds
! SMU, Mathematics
! Math 6370
! 7 January 2009
!=================================================================

program MatVec
  !-----------------------------------------------------------------
  ! Description:
  !    Computes the product of an m*n matrix and an n-vector.
  !-----------------------------------------------------------------
  !======= Inclusions ===========

  !======= Declarations =========
  implicit none
  integer :: m, n, i, j
  double precision, allocatable :: A(:,:), x(:), b(:)
  double precision :: norm2, stime, ftime

  !======= Internals ============

  ! input the size of the system
  write(*,*) 'We will multiply an m*n matrix by an n-vector'
  write(*,*) '   enter m'
  read(*,*) m
  write(*,*) '   enter n'
  read(*,*) n
  if ((m < 1) .or. (n < 1)) then
     write(*,*)  ' illegal input, m =',m,' and n =',n,&
          ' must both be >= 1'
     stop
  endif

  ! initialize the matrix and vectors
  allocate(A(m,n),x(n),b(m))
  do j=1,n
     do i=1,m
        A(i,j) = 1.d0/(1.d0 + (i - j)**2)
     enddo
     x(j) = 1.d0
  enddo

  ! start timer
  call get_time(stime)

  ! compute matrix-vector product (row-based version)
  b = 0.d0
  do i=1,m
     do j=1,n
        b(i) = b(i) + A(i,j)*x(j)
     enddo
  enddo

  ! stop timer
  call get_time(ftime)

  ! output 2-norm of product and runtime to screen
  norm2 = 0.d0
  do i=1,m,1
     norm2 = norm2 + b(i)**2
  enddo
  write(*,*) '       matrix size =',m,' x ',n
  write(*,*) ' 2-norm of product =',sqrt(norm2)
  write(*,*) '           runtime =',ftime-stime

  ! output product to file
  open(101,file='b.txt',form='formatted')
  do i=1,m,1
     write(101,'(es22.15)') b(i)
  enddo
  close(101)

  ! free vectors
  deallocate(A,x,b)

end program MatVec
!=================================================================


      SUBROUTINE PCHEV(N, X, F, D, NVAL, XVAL, FVAL, DVAL, IERR)
      USE stel_kinds
      IMPLICIT NONE
!- ----------------------------------------------
!   D u m m y   A r g u m e n t s
!- ----------------------------------------------
      INTEGER :: N, NVAL, IERR
      REAL(rprec), DIMENSION(N) :: X, F, D
      REAL(rprec), DIMENSION(NVAL) :: XVAL, FVAL, DVAL
!- ----------------------------------------------
!   L o c a l   V a r i a b l e s
!- ----------------------------------------------
      INTEGER :: INCFD
      LOGICAL :: SKIP
!- ----------------------------------------------
!*  **BEGIN PROLOGUE  PCHEV
!*  **DATE WRITTEN   870828   (YYMMDD)
!*  **REVISION DATE  870828   (YYMMDD)
!*  **CATEGORY NO.  E3,H1
!*  **KEYWORDS  CUBIC HERMITE OR SPLINE DIFFERENTIATION,CUBIC HERMITE
!             EVALUATION,EASY TO USE SPLINE OR CUBIC HERMITE EVALUATOR
!*  **AUTHOR  KAHANER, D.K., (NBS)
!             SCIENTIFIC COMPUTING DIVISION
!             NATIONAL BUREAU OF STANDARDS
!             ROOM A161, TECHNOLOGY BUILDING
!             GAITHERSBURG, MARYLAND 20899
!             (301) 975-3808
!*  **PURPOSE  Evaluates the FUNCTION and first derivative of a piecewise
!            cubic Hermite or spline FUNCTION at an array of points XVAL,
!            easy to USE.
!*  **DESCRIPTION
!
!          PCHEV:  Piecewise Cubic Hermite or Spline Derivative Evaluator,
!                  Easy to Use.
!
!     From the book "Numerical Methods and Software"
!          by  D. Kahaner, C.  Moler, S. Nash
!                 Prentice HALL 1988
!
!     Evaluates the FUNCTION and first derivative of the cubic Hermite
!     or spline FUNCTION defined by  N, X, F, D, at the array of points
!
!     This is an easy to USE driver for the routines by F.N. Fritsch
!     described in reference (2) below. Those also have other capabilities.
!
! ----------------------------------------------------------------------
!
!  Calling sequence: CALL  PCHEV (N, X, F, D, NVAL, XVAL, FVAL, DVAL, IERR)
!
!     INTEGER N, NVAL, IERR
!     REAL X(N), F(N), D(N), XVAL(NVAL), FVAL(NVAL), DVAL(NVAL)
!
!   Parameters:
!
!     N -- (input) number of data points.  (Error RETURN IF N.LT.2 .)
!
!     X -- (input) REAL array of independent variable values.  The
!           elements of X must be strictly increasing:
!             X(I-1) .LT. X(I),  I = 2(1)N. (Error RETURN IF not.)
!
!     F -- (input) REAL array of FUNCTION values.  F(I) is
!           the value corresponding to X(I).
!
!     D -- (input) REAL array of derivative values.  D(I) is
!           the value corresponding to X(I).
!
!  NVAL -- (input) number of points at which the functions are to be
!           evaluated. ( error return if nval.lt.1 )
!
!  XVAl -- (input) real array of points at which the functions are to
!           be evaluated.
!
!          NOTES:
!           1. The evaluation will be most efficient IF the elements
!              of XVAL are increasing relative to X;
!              that is,   XVAL(J) .GE. X(I)
!              implies    XVAL(K) .GE. X(I),  ALL K.GE.J .
!           2. If ANY of the XVAL are outside the interval [X(1),X(N)],
!              values are extrapolated from the nearest extreme cubic,
!              and a warning error is returned.
!
!  FVAL -- (output) REAL array of values of the cubic Hermite FUNCTION
!           defined by  N, X, F, D  at the points  XVAL.
!
!  DVAL -- (output) REAL array of values of the first derivative of
!           the same FUNCTION at the points  XVAL.
!
!  IERR -- (output) error flag.
!           Normal RETURN:
!              IERR = 0  (no errors).
!           Warning error:
!              IERR.GT.0  means that extrapolation was performed at
!                 IERR points.
!           "Recoverable" errors:
!              IERR = -1  IF N.LT.2 .
!              IERR = -3  IF the X-array is not strictly increasing.
!              IERR = -4  IF NVAL.LT.1 .
!           (Output arrays have not been changed in any of these cases.)
!               NOTE:  The above errors are checked in the order listed,
!                   and following arguments have **NOT*! been validated.
!              IERR = -5  IF an error has occurred in the lower-level
!                         routine CHFDV.  NB: this should never happen.
!                         Notify the author **IMMEDIATELY*! If it does.
!
! ----------------------------------------------------------------------
!*  **REFERENCES  1. F.N.FRITSCH AND R.E.CARLSON, 'MONOTONE PIECEWISE CUBIC INTERPOLATION,'
!                   SIAM J.NUMER.ANAL. 17, 2 (APRIL 1980), 238-246.
!                2. F.N.FRITSCH, 'PIECEWISE CUBIC HERMITE INTERPOLATION PACKAGE, FINAL SPECIFICATIONS',
!                   LAWRENCE LIVERMORE NATIONAL LABORATORY, COMPUTER DOCUMENTATION UCID-30194, AUGUST 1982.
!*  **ROUTINES CALLED  PCHFD
!*  **END PROLOGUE  PCHEV
!
!  DECLARE LOCAL VARIABLES.
!
      DATA SKIP/.TRUE./
      DATA INCFD/1/

!
!
!***FIRST EXECUTABLE STATEMENT  PCHEV
!
      CALL PCHFD (N, X, F, D, INCFD, SKIP, NVAL, XVAL, FVAL,
     1 DVAL, IERR)
!
!
      RETURN
!
!- ------------ LAST LINE OF PCHEV FOLLOWS ------------------------------
      END SUBROUTINE PCHEV


      PROGRAM xqroot
C     driver for routine qroot
      INTEGER N,NTRY
      REAL EPS,TINY
      PARAMETER(N=7,EPS=1.0e-6,NTRY=10,TINY=1.0e-5)
      INTEGER i,j,nflag,nroot
      REAL p(N),b(NTRY),c(NTRY)
      DATA p/10.0,-18.0,25.0,-24.0,16.0,-6.0,1.0/
      write(*,'(/1x,a)') 'P(x)=x^6-6x^5+16x^4-24x^3+25x^2-18x+10'
      write(*,'(1x,a)') 'Quadratic factors x^2+Bx+C'
      write(*,'(/1x,a,t15,a,t27,a/)') 'Factor','B','C'
      nroot=0
      do 12 i=1,NTRY
        c(i)=0.5*i
        b(i)=-0.5*i
        call qroot(p,N,b(i),c(i),EPS)
        if (nroot.eq.0) then
          write(*,'(1x,i3,2x,2f12.6)') nroot,b(i),c(i)
          nroot=1
        else
          nflag=0
          do 11 j=1,nroot
            if (abs(b(i)-b(j)).lt.TINY.and.abs(c(i)-c(j)).lt.TINY)
     *           nflag=1
11        continue
          if (nflag.eq.0) then
            write(*,'(1x,i3,2x,2f12.6)') nroot,b(i),c(i)
            nroot=nroot+1
          endif
        endif
12    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xqroot.for