module open_linalg_m

    use, intrinsic :: iso_fortran_env, only: sp => real32, dp => real64, stderr => error_unit
    implicit none
    private

    public :: det, inv, matmul, operator(.i.), operator(.x.), solve

    interface operator(.x.)
        module procedure matmul_sp, matmul_dp, cmatmul_sp, cmatmul_dp, &
            rcmatmul_sp, rcmatmul_dp, crmatmul_sp, crmatmul_dp
    end interface

    interface matmul
        module procedure matmul_sp, matmul_dp, cmatmul_sp, cmatmul_dp, &
            rcmatmul_sp, rcmatmul_dp, crmatmul_sp, crmatmul_dp
    end interface matmul

    interface det
        module procedure det_sp, det_dp
    end interface det

    interface operator(.i.)
        module procedure inv_sp, inv_dp, cinv_sp, cinv_dp
    end interface

    interface inv
        module procedure inv_sp, inv_dp, cinv_sp, cinv_dp
    end interface inv

    interface solve
        module procedure solve_sp, solve_dp, csolve_sp, csolve_dp
    end interface solve

contains

    function inv_sp(a) result(b)
    !! calculate inverse of a single precision matrix
        real(sp), intent(in) :: a(:, :)
        real(sp) b(size(a, 2), size(a, 1))
        integer ipiv(size(a, 1)), info
        real(sp) work(size(a, 2))

        b = a
        ! http://www.netlib.org/lapack/explore-html/d8/ddc/group__real_g_ecomputational_ga8d99c11b94db3d5eac75cac46a0f2e17.html
        call sgetrf(size(a, 1), size(a, 2), b, size(a, 1), ipiv, info)
        if (info < 0) then
            write (stderr, *) 'sgetrf: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'sgetrf: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

        ! http://www.netlib.org/lapack/explore-html/d8/ddc/group__real_g_ecomputational_ga1af62182327d0be67b1717db399d7d83.html
        call sgetri(size(a, 2), b, size(a, 1), ipiv, work, size(a, 2), info)
        if (info < 0) then
            write (stderr, *) 'sgetri: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'sgetri: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

    end function inv_sp

    function inv_dp(a) result(b)
    !! calculate inverse of a double precision matrix
        real(dp), intent(in) :: a(:, :)
        real(dp) b(size(a, 2), size(a, 1))
        integer ipiv(size(a, 1)), info
        real(dp) work(size(a, 2))

        b = a
        ! http://www.netlib.org/lapack/explore-html/d8/ddc/group__real_g_ecomputational_ga8d99c11b94db3d5eac75cac46a0f2e17.html
        call dgetrf(size(a, 1), size(a, 2), b, size(a, 1), ipiv, info)
        if (info < 0) then
            write (stderr, *) 'dgetrf: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'dgetrf: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

        ! http://www.netlib.org/lapack/explore-html/d8/ddc/group__real_g_ecomputational_ga1af62182327d0be67b1717db399d7d83.html
        call dgetri(size(a, 2), b, size(a, 1), ipiv, work, size(a, 2), info)
        if (info < 0) then
            write (stderr, *) 'dgetri: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'dgetri: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

    end function inv_dp

    function cinv_sp(a) result(b)
    !! calculate inverse of a single precision matrix
        complex(sp), intent(in) :: a(:, :)
        complex(sp) b(size(a, 2), size(a, 1))
        integer ipiv(size(a, 1)), info
        complex(sp) work(size(a, 2))

        b = a
        ! http://www.netlib.org/lapack/explore-html/d8/ddc/group__real_g_ecomputational_ga8d99c11b94db3d5eac75cac46a0f2e17.html
        call cgetrf(size(a, 1), size(a, 2), b, size(a, 1), ipiv, info)
        if (info < 0) then
            write (stderr, *) 'cgetrf: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'cgetrf: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

        ! http://www.netlib.org/lapack/explore-html/d8/ddc/group__real_g_ecomputational_ga1af62182327d0be67b1717db399d7d83.html
        call cgetri(size(a, 2), b, size(a, 1), ipiv, work, size(a, 2), info)
        if (info < 0) then
            write (stderr, *) 'cgetri: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'cgetri: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

    end function cinv_sp

    function cinv_dp(a) result(b)
    !! calculate inverse of a double precision matrix
        complex(dp), intent(in) :: a(:, :)
        complex(dp) b(size(a, 2), size(a, 1))
        integer ipiv(size(a, 1)), info
        complex(dp) work(size(a, 2))

        b = a
        ! http://www.netlib.org/lapack/explore-html/d8/ddc/group__real_g_ecomputational_ga8d99c11b94db3d5eac75cac46a0f2e17.html
        call zgetrf(size(a, 1), size(a, 2), b, size(a, 1), ipiv, info)
        if (info < 0) then
            write (stderr, *) 'zgetrf: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'zgetrf: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

        ! http://www.netlib.org/lapack/explore-html/d8/ddc/group__real_g_ecomputational_ga1af62182327d0be67b1717db399d7d83.html
        call zgetri(size(a, 2), b, size(a, 1), ipiv, work, size(a, 2), info)
        if (info < 0) then
            write (stderr, *) 'zgetri: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'zgetri: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

    end function cinv_dp

    function solve_sp(a, b) result(x)
    !! solve linear system of single precision
        real(sp), intent(in) :: a(:, :), b(:, :)
        real(sp) x(size(b, 1), size(b, 2))

        real(sp) a_(size(a, 1), size(a, 2))
        integer ipiv(size(a, 1))
        integer info

        a_ = a; x = b
        ! http://www.netlib.org/lapack/explore-html/d0/db8/group__real_g_esolve_ga3b05fb3999b3d7351cb3101a1fd28e78.html
        call sgesv(size(a, 1), size(b, 2), a_, size(a, 1), ipiv, x, size(b, 1), info)

        if (info < 0) then
            write (stderr, *) 'sgesv: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'sgesv: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

    end function solve_sp

    function solve_dp(a, b) result(x)
    !! solve linear system of double precision
        real(dp), intent(in) :: a(:, :), b(:, :)
        real(dp) x(size(b, 1), size(b, 2))

        real(dp) a_(size(a, 1), size(a, 2))
        integer ipiv(size(a, 1))
        integer info

        a_ = a; x = b
        ! http://www.netlib.org/lapack/explore-html/d7/d3b/group__double_g_esolve_ga5ee879032a8365897c3ba91e3dc8d512.html
        call dgesv(size(a, 1), size(b, 2), a_, size(a, 1), ipiv, x, size(b, 1), info)

        if (info < 0) then
            write (stderr, *) 'dgesv: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'dgesv: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

    end function solve_dp

    function csolve_sp(a, b) result(x)
    !! solve linear system of single precision
        complex(sp), intent(in) :: a(:, :), b(:, :)
        complex(sp) x(size(b, 1), size(b, 2))

        complex(sp) a_(size(a, 1), size(a, 2))
        integer ipiv(size(a, 1))
        integer info

        a_ = a; x = b
        ! http://www.netlib.org/lapack/explore-html/d0/db8/group__real_g_esolve_ga3b05fb3999b3d7351cb3101a1fd28e78.html
        call cgesv(size(a, 1), size(b, 2), a_, size(a, 1), ipiv, x, size(b, 1), info)

        if (info < 0) then
            write (stderr, *) 'cgesv: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'cgesv: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

    end function csolve_sp

    function csolve_dp(a, b) result(x)
    !! solve linear system of double precision
        complex(dp), intent(in) :: a(:, :), b(:, :)
        complex(dp) x(size(b, 1), size(b, 2))

        complex(dp) a_(size(a, 1), size(a, 2))
        integer ipiv(size(a, 1))
        integer info

        a_ = a; x = b
        ! http://www.netlib.org/lapack/explore-html/d7/d3b/group__double_g_esolve_ga5ee879032a8365897c3ba91e3dc8d512.html
        call zgesv(size(a, 1), size(b, 2), a_, size(a, 1), ipiv, x, size(b, 1), info)

        if (info < 0) then
            write (stderr, *) 'zgesv: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'zgesv: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

    end function csolve_dp

    function det_sp(a) result(d)
    !! calculate determinant of a single precision matrix
        real(sp), intent(in) :: a(:, :)
        real(sp) d
        real(sp) a_(size(a, 1), size(a, 2))
        integer ipiv(size(a, 1)), info, i

        a_ = a
        ! http://www.netlib.org/lapack/explore-html/d8/ddc/group__real_g_ecomputational_ga8d99c11b94db3d5eac75cac46a0f2e17.html
        call sgetrf(size(a, 1), size(a, 2), a_, size(a, 1), ipiv, info)
        if (info < 0) then
            write (stderr, *) 'sgetrf: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'sgetrf: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

        d = 1.0_sp
        do i = 1, size(a, 2)
            if (ipiv(i) /= i) then
                d = -d*a_(i, i)
            else
                d = d*a_(i, i)
            end if
        end do

    end function det_sp

    function det_dp(a) result(d)
    !! calculate determinant of a double precision matrix
        real(dp), intent(in) :: a(:, :)
        real(dp) d
        real(dp) a_(size(a, 1), size(a, 2))
        integer ipiv(size(a, 1)), info, i

        a_ = a
        ! http://www.netlib.org/lapack/explore-html/d8/ddc/group__real_g_ecomputational_ga8d99c11b94db3d5eac75cac46a0f2e17.html
        call dgetrf(size(a, 1), size(a, 2), a_, size(a, 1), ipiv, info)
        if (info < 0) then
            write (stderr, *) 'dgetrf: illegal value in argument ', info
            error stop
        else if (info > 0) then
            write (stderr, *) 'dgetrf: singular matrix, U(i,i) is exactly zero, info = ', info
            error stop
        end if

        d = 1.0_dp
        do i = 1, size(a, 2)
            if (ipiv(i) /= i) then
                d = -d*a_(i, i)
            else
                d = d*a_(i, i)
            end if
        end do

    end function det_dp

    function matmul_sp(a, b) result(c)
    !! matrix multiplication of single precision matrices
        real(sp), intent(in) :: a(:, :), b(:, :)
        integer m, n, k
        real(sp) c(size(a, 1), size(b, 2))

        m = size(a, 1)
        n = size(b, 2)
        k = size(a, 2)
        ! http://www.netlib.org/lapack/explore-html/d1/d54/group__double__blas__level3_gaeda3cbd99c8fb834a60a6412878226e1.html
        call sgemm( &
            'N', 'N', &
            m, n, k, &
            1.0_sp, a, m, b, k, &
            0.0_sp, c, m)

    end function matmul_sp

    function matmul_dp(a, b) result(c)
    !! matrix multiplication of double precision matrices
        real(dp), intent(in) :: a(:, :), b(:, :)
        real(dp) c(size(a, 1), size(b, 2))
        integer m, n, k

        m = size(a, 1)
        n = size(b, 2)
        k = size(a, 2)
        ! http://www.netlib.org/lapack/explore-html/d1/d54/group__double__blas__level3_gaeda3cbd99c8fb834a60a6412878226e1.html
        call dgemm( &
            'N', 'N', &
            m, n, k, &
            1.0_dp, a, m, b, k, &
            0.0_dp, c, m)

    end function matmul_dp

    function cmatmul_sp(a, b) result(c)
    !! matrix multiplication of single precision complex matrices
        complex(sp), intent(in) :: a(:, :), b(:, :)
        complex(sp) c(size(a, 1), size(b, 2))
        integer m, n, k

        m = size(a, 1)
        n = size(b, 2)
        k = size(a, 2)
        ! http://www.netlib.org/lapack/explore-html/d1/d54/group__double__blas__level3_gaeda3cbd99c8fb834a60a6412878226e1.html
        call cgemm( &
            'N', 'N', &
            m, n, k, &
            (1.0_sp, 0.0_sp), a, m, b, k, &
            (0.0_sp, 0.0_sp), c, m)

    end function cmatmul_sp

    function cmatmul_dp(a, b) result(c)
    !! matrix multiplication of double precision complex matrices
        complex(dp), intent(in) :: a(:, :), b(:, :)
        complex(dp) c(size(a, 1), size(b, 2))
        integer m, n, k

        m = size(a, 1)
        n = size(b, 2)
        k = size(a, 2)
        ! http://www.netlib.org/lapack/explore-html/d1/d54/group__double__blas__level3_gaeda3cbd99c8fb834a60a6412878226e1.html
        call zgemm( &
            'N', 'N', &
            m, n, k, &
            (1.0_dp, 0.0_dp), a, m, b, k, &
            (0.0_dp, 0.0_dp), c, m)

    end function cmatmul_dp

    function rcmatmul_sp(a, b) result(c)
    !! matrix multiplication of single precision complex matrices
        real(sp), intent(in) :: a(:, :)
        complex(sp), intent(in) :: b(:, :)
        complex(sp) c(size(a, 1), size(b, 2))
        integer m, n, k

        m = size(a, 1)
        n = size(b, 2)
        k = size(a, 2)
        ! http://www.netlib.org/lapack/explore-html/d1/d54/group__double__blas__level3_gaeda3cbd99c8fb834a60a6412878226e1.html
        call cgemm( &
            'N', 'N', &
            m, n, k, &
            (1.0_sp, 0.0_sp), cmplx(a, kind=sp), m, b, k, &
            (0.0_sp, 0.0_sp), c, m)

    end function rcmatmul_sp

    function rcmatmul_dp(a, b) result(c)
    !! matrix multiplication of double precision complex matrices
        real(dp), intent(in) :: a(:, :)
        complex(dp), intent(in) :: b(:, :)
        complex(dp) c(size(a, 1), size(b, 2))
        integer m, n, k

        m = size(a, 1)
        n = size(b, 2)
        k = size(a, 2)
        ! http://www.netlib.org/lapack/explore-html/d1/d54/group__double__blas__level3_gaeda3cbd99c8fb834a60a6412878226e1.html
        call zgemm( &
            'N', 'N', &
            m, n, k, &
            (1.0_dp, 0.0_dp), cmplx(a, kind=dp), m, b, k, &
            (0.0_dp, 0.0_dp), c, m)

    end function rcmatmul_dp

    function crmatmul_sp(a, b) result(c)
    !! matrix multiplication of single precision complex matrices
        complex(sp), intent(in) :: a(:, :)
        real(sp), intent(in) :: b(:, :)
        complex(sp) c(size(a, 1), size(b, 2))
        integer m, n, k

        m = size(a, 1)
        n = size(b, 2)
        k = size(a, 2)
        ! http://www.netlib.org/lapack/explore-html/d1/d54/group__double__blas__level3_gaeda3cbd99c8fb834a60a6412878226e1.html
        call cgemm( &
            'N', 'N', &
            m, n, k, &
            (1.0_sp, 0.0_sp), a, m, cmplx(b, kind=sp), k, &
            (0.0_sp, 0.0_sp), c, m)

    end function crmatmul_sp

    function crmatmul_dp(a, b) result(c)
    !! matrix multiplication of double precision complex matrices
        complex(dp), intent(in) :: a(:, :)
        real(dp), intent(in) :: b(:, :)
        complex(dp) c(size(a, 1), size(b, 2))
        integer m, n, k

        m = size(a, 1)
        n = size(b, 2)
        k = size(a, 2)
        ! http://www.netlib.org/lapack/explore-html/d1/d54/group__double__blas__level3_gaeda3cbd99c8fb834a60a6412878226e1.html
        call zgemm( &
            'N', 'N', &
            m, n, k, &
            (1.0_dp, 0.0_dp), a, m, cmplx(b, kind=dp), k, &
            (0.0_dp, 0.0_dp), c, m)

    end function crmatmul_dp

end module open_linalg_m


c
c	MATH -- C callable math functions.  This is the only portable way
c	to access the Fortran intrinsic functions from C.  As a local
c	optimization it is possible to add defines to map these external
c	names onto the local Fortran library functions, but since C is not
c	generally used intensively for computations and all floating point
c	is done in double precision anyway, it is probably not worth it.
c

	integer function xnint (x)
	double precision x
		xnint = nint (x)
	end

	double precision function xexp (x)
	double precision x
		xexp = exp(x)
	end

	double precision function xlog (x)
	double precision x
		xlog = log(x)
	end

	double precision function xlog10 (x)
	double precision x
		xlog10 = log10(x)
	end

	double precision function xpow (x, y)
	double precision x
	double precision y
		xpow = x ** y
	end

	double precision function xsqrt (x)
	double precision x
		xsqrt = sqrt(x)
	end

	double precision function xsin (x)
	double precision x
		xsin = sin(x)
	end

	double precision function xcos (x)
	double precision x
		xcos = cos(x)
	end

	double precision function xtan (x)
	double precision x
		xtan = tan(x)
	end

	double precision function xasin (x)
	double precision x
		xasin = asin(x)
	end

	double precision function xacos (x)
	double precision x
		xacos = acos(x)
	end

	double precision function xatan (x)
	double precision x
		xatan = atan(x)
	end

	double precision function xatan2 (x, y)
	double precision x
	double precision y
		xatan2 = atan2(x,y)
	end


! { dg-do run }
!
! Testing IEEE modules on large real kinds

program test

  use ieee_arithmetic
  implicit none

  ! k1 and k2 will be large real kinds, if supported, and single/double
  ! otherwise
  integer, parameter :: k1 = &
    max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.))
  integer, parameter :: k2 = &
    max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0))

  real(kind=k1) :: x1, y1
  real(kind=k2) :: x2, y2
  logical :: l

  ! Checking ieee_is_finite

  if (.not. ieee_is_finite(huge(0._k1))) STOP 1
  if (ieee_is_finite(ieee_value(0._k1, ieee_negative_inf))) STOP 2
  x1 = -42
  if (.not. ieee_is_finite(x1)) STOP 3
  if (ieee_is_finite(sqrt(x1))) STOP 4

  if (.not. ieee_is_finite(huge(0._k2))) STOP 5
  if (ieee_is_finite(ieee_value(0._k2, ieee_negative_inf))) STOP 6
  x2 = -42
  if (.not. ieee_is_finite(x2)) STOP 7
  if (ieee_is_finite(sqrt(x2))) STOP 8

  ! Other ieee_is intrinsics

  if (ieee_is_nan(huge(0._k1))) STOP 9
  if (.not. ieee_is_negative(-huge(0._k1))) STOP 10
  if (.not. ieee_is_normal(-huge(0._k1))) STOP 11

  if (ieee_is_nan(huge(0._k2))) STOP 12
  if (.not. ieee_is_negative(-huge(0._k2))) STOP 13
  if (.not. ieee_is_normal(-huge(0._k2))) STOP 14

  ! ieee_support intrinsics

  if (.not. ieee_support_datatype(x1)) STOP 15
  if (.not. ieee_support_denormal(x1)) STOP 16
  if (.not. ieee_support_divide(x1)) STOP 17
  if (.not. ieee_support_inf(x1)) STOP 18
  if (.not. ieee_support_io(x1)) STOP 19
  if (.not. ieee_support_nan(x1)) STOP 20
  if (.not. ieee_support_rounding(ieee_nearest, x1)) STOP 21
  if (.not. ieee_support_sqrt(x1)) STOP 22
  if (.not. ieee_support_standard(x1)) STOP 23

  l = ieee_support_underflow_control(x1)

  if (.not. ieee_support_datatype(x2)) STOP 24
  if (.not. ieee_support_denormal(x2)) STOP 25
  if (.not. ieee_support_divide(x2)) STOP 26
  if (.not. ieee_support_inf(x2)) STOP 27
  if (.not. ieee_support_io(x2)) STOP 28
  if (.not. ieee_support_nan(x2)) STOP 29
  if (.not. ieee_support_rounding(ieee_nearest, x2)) STOP 30
  if (.not. ieee_support_sqrt(x2)) STOP 31
  if (.not. ieee_support_standard(x2)) STOP 32

  l = ieee_support_underflow_control(x2)

  ! ieee_value and ieee_class

  if (.not. ieee_is_nan(ieee_value(x1, ieee_quiet_nan))) STOP 33
  if (ieee_class(ieee_value(x1, ieee_positive_denormal)) &
    /= ieee_positive_denormal) STOP 34

  if (.not. ieee_is_nan(ieee_value(x2, ieee_quiet_nan))) STOP 35
  if (ieee_class(ieee_value(x2, ieee_positive_denormal)) &
    /= ieee_positive_denormal) STOP 36

  ! ieee_unordered

  if (.not. ieee_unordered(ieee_value(x1, ieee_quiet_nan), 0._k1)) STOP 37
  if (ieee_unordered(ieee_value(x1, ieee_negative_inf), 0._k1)) STOP 38

  if (.not. ieee_unordered(ieee_value(x2, ieee_quiet_nan), 0._k2)) STOP 39
  if (ieee_unordered(ieee_value(x2, ieee_negative_inf), 0._k2)) STOP 40

  ! ieee_copy_sign

  if (.not. ieee_class(ieee_copy_sign(ieee_value(x1, ieee_positive_inf), -1.)) &
            == ieee_negative_inf) STOP 41
  if (.not. ieee_class(ieee_copy_sign(0._k1, -42._k2)) &
            == ieee_negative_zero) STOP 42

  if (.not. ieee_class(ieee_copy_sign(ieee_value(x2, ieee_positive_inf), -1.)) &
            == ieee_negative_inf) STOP 43
  if (.not. ieee_class(ieee_copy_sign(0._k2, -42._k1)) &
            == ieee_negative_zero) STOP 44

  ! ieee_logb

  if (ieee_logb (42._k1) /= exponent(42._k1) - 1) STOP 45

  if (ieee_logb (42._k2) /= exponent(42._k2) - 1) STOP 46

  ! ieee_next_after

  if (ieee_next_after(42._k1, ieee_value(x1, ieee_positive_inf)) &
      /= 42._k1 + spacing(42._k1)) STOP 47

  if (ieee_next_after(42._k2, ieee_value(x2, ieee_positive_inf)) &
      /= 42._k2 + spacing(42._k2)) STOP 48

  ! ieee_rem

  if (ieee_class(ieee_rem(-42._k1, 2._k1)) /= ieee_negative_zero) &
    STOP 49

  if (ieee_class(ieee_rem(-42._k2, 2._k2)) /= ieee_negative_zero) &
    STOP 50

  ! ieee_rint

  if (ieee_rint(-1.1_k1) /= -1._k1) STOP 51
  if (ieee_rint(huge(x1)) /= huge(x1)) STOP 52

  if (ieee_rint(-1.1_k2) /= -1._k2) STOP 53
  if (ieee_rint(huge(x2)) /= huge(x2)) STOP 54

  ! ieee_scalb

  x1 = sqrt(42._k1)
  if (ieee_scalb(x1, 2) /= 4._k1 * x1) STOP 55
  if (ieee_scalb(x1, -2) /= x1 / 4._k1) STOP 56

  x2 = sqrt(42._k2)
  if (ieee_scalb(x2, 2) /= 4._k2 * x2) STOP 57
  if (ieee_scalb(x2, -2) /= x2 / 4._k2) STOP 58

end program test


! { dg-do run }
program aint_anint_1

  implicit none

  real(4) :: r = 42.7, r1, r2
  real(8) :: s = 42.7D0, s1, s2

  r1 = aint(r)
  r2 = aint(r,kind=8)
  if (abs(r1 - r2) > 0.1) STOP 1

  r1 = anint(r)
  r2 = anint(r,kind=8)
  if (abs(r1 - r2) > 0.1) STOP 2

  s1 = aint(s)
  s2 = aint(s, kind=4)
  if (abs(s1 - s2) > 0.1) STOP 3

  s1 = anint(s)
  s2 = anint(s, kind=4)
  if (abs(s1 - s2) > 0.1) STOP 4

end program aint_anint_1


    program demo_sqrt
    use, intrinsic :: iso_fortran_env, only : real_kinds, &
     & real32, real64, real128
    implicit none
    real(kind=real64) :: x, x2
    complex :: z, z2

       x = 2.0_real64
       z = (1.0, 2.0)
       write(*,*)x,z

       x2 = sqrt(x)
       z2 = sqrt(z)
       write(*,*)x2,z2

       x2 = x**0.5
       z2 = z**0.5
       write(*,*)x2,z2

    end program demo_sqrt


! KGEN-generated Fortran source file
!
! Filename    : mo_math_constants.f90
! Generated at: 2015-02-19 15:30:32
! KGEN version: 0.4.4

    MODULE mo_math_constants
        USE mo_kind, ONLY: wp
        IMPLICIT NONE
        PUBLIC
        ! Mathematical constants defined:
        !
        !--------------------------------------------------------------
        ! Fortran name | C name       | meaning                       |
        !--------------------------------------------------------------
        ! euler        | M_E          |  e                            |
        ! log2e        | M_LOG2E      |  log2(e)                      |
        ! log10e       | M_LOG10E     |  log10(e)                     |
        ! ln2          | M_LN2        |  ln(2)                        |
        ! ln10         | M_LN10       |  ln(10)                       |
        ! pi           | M_PI         |  pi                           |
        ! pi_2         | M_PI_2       |  pi/2                         |
        ! pi_4         | M_PI_4       |  pi/4                         |
        ! rpi          | M_1_PI       |  1/pi                         |
        ! rpi_2        | M_2_PI       |  2/pi                         |
        ! rsqrtpi_2    | M_2_SQRTPI   |  2/(sqrt(pi))                 |
        ! sqrt2        | M_SQRT2      |  sqrt(2)                      |
        ! sqrt1_2      | M_SQRT1_2    |  1/sqrt(2)                    |
        ! sqrt3        |              |  sqrt(3)                      |
        ! sqrt1_3      |              |  1/sqrt(3)                    |
        ! half angle of pentagon                                      |
        ! pi_5         |              |  pi/5                         |
        ! latitude of the lowest major  triangle corner               |
        ! and latitude of the major hexagonal faces centers           |
        ! phi0         |              |  pi/2 -2acos(1/(2*sin(pi/5))) |
        ! conversion factor from radians to degree                    |
        ! rad2deg      |              |  180/pi                       |
        ! conversion factor from degree to radians                    |
        ! deg2rad      |              |  pi/180                       |
        ! one_third    |              |  1/3                          |
        !-------------------------------------------------------------|
        REAL(KIND=wp), parameter :: pi        =  3.14159265358979323846264338327950288419717_wp

    ! read subroutines
    END MODULE mo_math_constants


FUNCTION betacf(a,b,x)
INTEGER MAXIT
REAL*8 betacf,a,b,x,EPS,FPMIN
PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30)
INTEGER m,m2
REAL*8 aa,c,d,del,h,qab,qam,qap
qab=a+b
qap=a+1.
qam=a-1.
c=1.
d=1.-qab*x/qap
if(abs(d).lt.FPMIN)d=FPMIN
d=1./d
h=d
do m=1,MAXIT
  m2=2*m
  aa=m*(b-m)*x/((qam+m2)*(a+m2))
  d=1.+aa*d
  if(abs(d).lt.FPMIN)d=FPMIN
  c=1.+aa/c
  if(abs(c).lt.FPMIN)c=FPMIN
  d=1./d
  h=h*d*c
  aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2))
  d=1.+aa*d
  if(abs(d).lt.FPMIN)d=FPMIN
  c=1.+aa/c
  if(abs(c).lt.FPMIN)c=FPMIN
  d=1./d
  del=d*c
  h=h*del
  if(abs(del-1.).lt.EPS)goto 1
enddo
pause 'a or b too big, or MAXIT too small in betacf'
1     betacf=h
return
END


subroutine ComputeDG82(DG82, lmax, m, theta0, exitstatus)
!-------------------------------------------------------------------------------
!
!   This routine will compute the kernel of Grunbaum et al. 1982
!   that commutes with the space concentration kernel. This
!   kernel is tridiagonal and has simple expressions for
!   its elements. Note that this kernel is multiplied by -1 in
!   comparison to Grunbaum et al. in order that the eigenvectors
!   will be listed in the same order as the eigenvectors of the
!   equivalent space concentration matrix Dllm. While the eigenfunctions
!   of this kernel correspond to the eigenvalues of Dllm, the eigenvalues
!   do NOT!
!
!   Calling Parameters
!       IN
!           lmax        Maximum spherical harmonic degree.
!           theta0      Angular radius of spherical cap IN RADIANS.
!           m           Angular order to concentration problem.
!
!       OUT
!           D0G82       Symmetric tridiagonal kernel with a maximum size of
!                       lmax+1 by lmax+1.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(out) :: DG82(:,:)
    real(dp), intent(in) :: theta0
    integer(int32), intent(in) :: lmax, m
    integer(int32), intent(out), optional :: exitstatus
    real(dp) :: x
    integer(int32) :: i, n

    if (present(exitstatus)) exitstatus = 0

    n = lmax + 1 - abs(m)

    if (n < 1) then
        print*, "Error --- ComputeDG82"
        print*, "abs(M) must be less than or equal to LMAX."
        print*, "Input values of l and m are ", lmax, m
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    else if (size(DG82(1,:)) < n .or. size(DG82(:,1)) < n) then
        print*, "Error --- ComputeDG82"
        print*, "DG82 must be dimensioned as (LMAX-abs(M)+1," // &
                "LMAX-abs(M)+1) where LMAX and M are ", lmax, m
        print*, "Input array is dimensioned as ", size(DG82(1,:)), &
                size(DG82(:,1))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    DG82 = 0.0d0

    x = cos(theta0)

    DG82(1,1) = x * dble(1+m) * dble(m)

    do i = 2, n, 1
        DG82(i,i) = x * dble(i+m) * dble(i+m-1)

        DG82(i,i-1) = - sqrt(dble(i-1+m)**2 - dble(m)**2) * &
                      ( dble(i-1+m)**2 - dble(lmax+1)**2 ) / &
                      sqrt(4.0_dp * dble(i-1+m)**2 - 1.0_dp)

        DG82(i-1,i) = DG82(i,i-1)

    end do

end subroutine ComputeDG82


! This is a collection of 3 routines to calculate the new mean
! and sum of squares of deviations about the mean (and hence the new
! sample variance or standard deviation) after:

! 1. A new observation becomes available (routine update).
! 2. An observation is dropped (routine downdate).
! 3. An observation is replaced with a new one (routine replace).

! Latest revision - 24 November 2001
! Alan Miller (amiller @ bigpond.net.au)

SUBROUTINE update(n, mean, sumsq, x)
! x contains the value of the new case.

IMPLICIT NONE

INTEGER, INTENT(IN OUT)  :: n
REAL, INTENT(IN OUT)     :: mean, sumsq
REAL, INTENT(IN)         :: x

! Local variable
REAL  :: dev

n = n + 1
dev = x - mean
mean = mean + dev/n
sumsq = sumsq + dev*(x - mean)

RETURN
END SUBROUTINE update

SUBROUTINE downdate(n, mean, sumsq, x)
! x contained the value to be removed.

IMPLICIT NONE

INTEGER, INTENT(IN OUT)  :: n
REAL, INTENT(IN OUT)     :: mean, sumsq
REAL, INTENT(IN)         :: x

! Local variable
REAL  :: dev

n = n - 1
dev = x - mean
mean = mean - dev/n
sumsq = sumsq - dev*(x - mean)

RETURN
END SUBROUTINE downdate

SUBROUTINE replace(n, mean, sumsq, x, y)
! x is the value to be removed and replaced with the value y.

IMPLICIT NONE

INTEGER, INTENT(IN)   :: n
REAL, INTENT(IN OUT)  :: mean, sumsq
REAL, INTENT(IN)      :: x, y

! Local variables
REAL  :: diff, devx

diff = y - x
devx = x - mean
mean = mean + diff/n
sumsq = sumsq + diff*(devx + y - mean)

RETURN
END SUBROUTINE replace


module callback_01

contains

real function cb(f, a, b)
real, intent(in) :: a, b
interface
    real function f(x)
    implicit none
    real, intent(in) :: x
    end function
end interface
cb = (b-a) + f(a) + f(b)
end function

subroutine foo(c, d)
real :: c, d
print *, cb(f, c, d)

contains

real function f(x)
real, intent(in) :: x
f = 2*x
end function f

end subroutine foo

end module

program main
  use callback_01
  call foo(1.5, 2.0)
end program


      SUBROUTINE STM(E, Y, Z, K, T, D, P, N)
!      ________________________________________________________
!     |                                                        |
!     |   FIND THE K-TH SMALLEST EIGENVALUE OF A TRIDIAGONAL   |
!     |  MATRIX WHOSE CROSS-DIAGONAL PRODUCTS ARE NONNEGATIVE  |
!     |USING BOTH THE BISECTION METHOD AND A NEWTON-LIKE METHOD|
!     |                                                        |
!     |    INPUT:                                              |
!     |                                                        |
!     |         Y,Z   --ENDS OF AN INTERVAL THAT CONTAINS THE  |
!     |                 DESIRED EIGENVALUE                     |
!     |                                                        |
!     |         K     --INDEX OF DESIRED EIGENVALUE            |
!     |                                                        |
!     |         T     --TOLERANCE (ITERATIONS CONTINUE UNTIL   |
!     |                 THE ERROR IN THE EIGENVALUE .LE. T)    |
!     |                                                        |
!     |         D     --DIAGONAL OF THE COEFFICIENT MATRIX A   |
!     |                                                        |
!     |         P     --CROSS-DIAGONAL PRODUCTS A SUB I+1,I    |
!     |                 TIMES A SUB I,I+1                      |
!     |                                                        |
!     |         N     --MATRIX DIMENSION                       |
!     |                                                        |
!     |    OUTPUT:                                             |
!     |                                                        |
!     |         E     --EIGENVALUE                             |
!     |                                                        |
!     |    BUILTIN FUNCTIONS: ABS,MAX,SIGN,SQRT              |
!     |    PACKAGE SUBROUTINES: CP,EQL,INP                     |
!     |________________________________________________________|
!
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER :: K, N
      REAL(rprec):: E, Y, Z, T
      REAL(rprec), DIMENSION(N) :: D, P
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      REAL(rprec), PARAMETER :: one = 1, zero = 0
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, J, M
      REAL(rprec) :: A,B,FL,FR,L,Q,R,S,U,V,
     1   W,D2,D3,D4,P2,P3,P4,D34,D42,D23
      REAL(rprec), DIMENSION(4) :: F, H, X
      REAL(rprec), DIMENSION(4) :: G
      REAL(rprec) :: C, GL, GR
!-----------------------------------------------
      L = Y
      R = Z
      IF ( L .LT. R ) GOTO 10
      L = Z
      R = Y
10    IF ( N .EQ. 1 ) GOTO 210
      S = T + T
      U = ONE
20    U = U/2
      A = ONE + U
      IF (A .GT. ONE) GOTO 20
      U = 5*U
      V = U/2
      CALL CP(L,FL,GL,I,D,P,N)
      CALL CP(R,FR,GR,J,D,P,N)
      IF ( I .GE. K ) GOTO 190
      IF ( J .LT. K ) GOTO 200
C     --------------------------------
C     |*** ISOLATE THE EIGENVALUE ***|
C     --------------------------------
30    E = R - L
      IF ( E .LE. S ) GOTO 180
      IF ( E .LE. U*(ABS(L)+ABS(R)) ) GOTO 180
      IF ( J .EQ. I+1 ) GOTO 70
40    A = .5*(L+R)
      CALL CP(A,B,C,M,D,P,N)
      IF ( K .LE. M ) GOTO 50
      L = A
      I = M
      FL = B
      GL = C
      GOTO 30
50    R = A
      J = M
      FR = B
      GR = C
      GOTO 30
60    E = R - L
      IF ( E .LE. S ) GOTO 180
      IF ( E .LE. U*(ABS(L)+ABS(R)) ) GOTO 180
70    X(1) = L
      F(1) = FL
      G(1) = GL
      X(2) = R
      F(2) = FR
      G(2) = GR
      CALL EQL(X,F,G,H,2)
      IF ( H(1) .EQ. H(2) ) GOTO 160
C     ---------------------
C     |*** SECANT STEP ***|
C     ---------------------
      A = X(1) - H(1)*(X(1)-X(2))/(H(1)-H(2))
      Q = A
      W = MAX(T,V*(ABS(L)+ABS(R)))
      IF ( ABS(A-L) .LT. W ) A = L + W
      IF ( ABS(A-R) .LT. W ) A = R - W
      CALL CP(A,B,C,J,D,P,N)
      IF ( I .GE. J ) GOTO 80
      R = A
      FR = B
      GR = C
      GOTO 90
80    L = A
      FL = B
      GL = C
90    X(3) = A
      F(3) = B
      G(3) = C
      W = R - L
      IF ( W .LE. S ) GOTO 220
      IF ( W .LE. U*(ABS(L)+ABS(R)) ) GOTO 220
      CALL EQL(X,F,G,H,3)
C     --------------------------------------
C     |*** QUADRATIC INTERPOLATION STEP ***|
C     --------------------------------------
      CALL INP(A,X(1),X(2),X(3),H(1),H(2),H(3),L,R)
      B = L
      IF ( ABS(A-L) .GT. ABS(A-R) ) B = R
C     ------------------------------------
C     |*** APPLY PSEUDO-NEWTON METHOD ***|
C     ------------------------------------
100   Q = A
      W = MAX(T,V*(ABS(L)+ABS(R)))
      IF ( ABS(A-L) .LT. W ) GOTO 110
      IF ( ABS(A-R) .GT. W ) GOTO 130
110   IF ( A+A .GT. L+R ) GOTO 120
      A = L + W
      GOTO 130
120   A = R - W
130   IF ( A .LE. L ) GOTO 160
      IF ( A .GE. R ) GOTO 160
      E = .5*E
      IF ( E .LT. ABS(B-A) ) GOTO 160
      CALL CP(A,B,C,J,D,P,N)
      IF ( I .GE. J ) GOTO 140
      R = A
      FR = B
      GR = C
      GOTO 150
140   L = A
      FL = B
      GL = C
150   W = R - L
      IF ( W .LE. S ) GOTO 220
      IF ( W .LE. U*(ABS(L)+ABS(R)) ) GOTO 220
      X(4) = A
      F(4) = B
      G(4) = C
      CALL EQL(X,F,G,H,4)
      IF ( X(1) .LT. L ) GOTO 160
      IF ( X(1) .GT. R ) GOTO 160
      B = X(1)
      D4 = X(4) - B
      D3 = X(3) - B
      D2 = X(2) - B
      D34 = X(3) - X(4)
      D42 = X(4) - X(2)
      D23 = X(2) - X(3)
      P2 = D2*(ONE+((D2/D3)*D42+(D2/D4)*D23)/D34)
      P3 = D3*(ONE+((D3/D2)*D34+(D3/D4)*D23)/D42)
      P4 = D4*(ONE+((D4/D2)*D34+(D4/D3)*D42)/D23)
      IF (P2 .NE. ZERO) P2 = (H(2)-H(1))/P2
      IF (P3 .NE. ZERO) P3 = (H(3)-H(1))/P3
      IF (P4 .NE. ZERO) P4 = (H(4)-H(1))/P4
      P2 = P2 + P3 + P4
      IF (P2 .EQ. ZERO) GOTO 160
      A = B - H(1)/P2
      GOTO 100
C     --------------------------
C     |*** BISECTION METHOD ***|
C     --------------------------
160   A = (L+R)/2
      CALL CP(A,B,C,J,D,P,N)
      IF ( I .GE. J ) GOTO 170
      R = A
      FR = B
      GR = C
      GOTO 60
170   L = A
      FL = B
      GL = C
      GOTO 60
180   E = (L+R)/2
      RETURN
190   E = L
      RETURN
200   E = R
      RETURN
210   E = D(1)
      IF ( L .GT. E ) E = L
      IF ( R .LT. E ) E = R
      RETURN
220   E = Q
      RETURN
      END SUBROUTINE STM


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_symtrid_specint
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes upper and lower bounds on the spectrum of a
! real symmetric tridiagonal matrix T.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  NEWT            LOGICAL
!                    .TRUE.: uses Newton's method to refine boundaries
!                    .FALSE.: only uses Gerschgorin bounds
!
!  N               INTEGER
!                    dimension of matrix
!
!  D               REAL(8) array of dimension (N)
!                    diagonal entries of T
!
!  E               REAL(8) array of dimension (N-1)
!                    subdiagonal entries of T
!
! OUTPUT VARIABLES:
!
!  A,B             REAL(8)
!                    upper and lower bounds on the spectrum of T
!
!  INFO            INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies A or B is NAN
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_symtrid_specint(NEWT,N,D,E,A,B,INFO)

  implicit none

  ! input variables
  logical, intent(in) :: NEWT
  integer, intent(in) :: N
  real(8), intent(in) :: D(N), E(N-1)
  real(8), intent(inout) :: A, B
  integer, intent(inout) :: INFO

  ! compute variables
  integer :: ii
  real(8) :: ta, tb
  real(8) :: tol = EISCOR_DBL_EPS

  ! initialize INFO
  INFO = 0

  ! initialize A and B
  A = D(1) - abs(E(1))
  B = D(1) + abs(E(1))

  ! loop through diagonals
  do ii=1,N-2

    ! compute ta and tb
    ta = D(ii) - abs(E(ii)) - abs(E(ii+1))
    tb = D(ii) + abs(E(ii)) + abs(E(ii+1))

    ! check A
    if (ta < A) then
      A = ta
    end if

    ! check B
    if (tb > B) then
      B = tb
    end if

  end do

  ! check final entry
  ta = D(N) - abs(E(N-1))
  tb = D(N) + abs(E(N-1))

  ! check A
  if (ta < A) then
    A = ta
  end if

  ! check B
  if (tb > B) then
    B = tb
  end if

  ! return if A and B are 0
  if ((A.EQ.0d0).AND.(B.EQ.0d0)) then
    return
  end if

  ! Newton updates
  if (NEWT) then

    ! maximum of 10 corrections
    do ii=1,10

      ! correction for A
      call d_symtrid_newtonstep(N,D,E,A,ta,INFO)

      ! check if INFO = -1
      if (INFO.EQ.-1) then
        ta = tol
        INFO = 0
      end if

      ! correction for B
      call d_symtrid_newtonstep(N,D,E,B,tb,INFO)

      ! check if INFO = -1
      if (INFO.EQ.-1) then
        tb = -tol
        INFO = 0
      end if

      ! update if not converged
      if ((abs(ta) > tol*abs(A)).AND.(abs(tb) > tol*abs(B))) then

        A = A - ta
        B = B - tb

      ! exit otherwise
      else

        exit

      end if

    end do

  end if

  ! check if A and B are NAN
  if ((A.NE.A).OR.(B.NE.B)) then
    INFO = -1
  end if

end subroutine d_symtrid_specint

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_symtrid_newtonstep
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes a Newton correction for a real number x of a
! real symmetric tridiagonal matrix T using Sturm sequences.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  D               REAL(8) array of dimension (N)
!                    diagonal entries of T
!
!  E               REAL(8) array of dimension (N)
!                    subdiagonal entries of T
!
!  X               REAL(8)
!                    input guess
!
! OUTPUT VARIABLES:
!
!  F               REAL(8)
!                    computed Newton correction at X
!
!  INFO            INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies zero derivative at X
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_symtrid_newtonstep(N,D,E,X,F,INFO)

  implicit none

  ! input variables
  integer, intent(in) :: N
  real(8), intent(in) :: D(N), E(N-1)
  real(8), intent(in) :: X
  real(8), intent(inout) :: F
  integer, intent(inout) :: INFO

  ! compute variables
  integer :: ii
  real(8) :: p0, p1, p2
  real(8) :: d0, d1, d2

  ! initialize INFO
  INFO = 0

  ! initialize p0, p1 and p2
  p0 = 1d0
  p1 = D(1) - X
  p2 = (D(2)-X)*p1 - E(1)*E(1)*p0

  ! initialize d0, d1 and d2
  d0 = 0d0
  d1 = -1d0
  d2 = -p1 + (D(2)-X)*d1 - E(1)*E(1)*d0

  ! loop through diagonals
  do ii=3,N

    ! update d0, d1 and d2
    d0 = -p2 + (D(ii)-X)*d2 - E(ii-1)*E(ii-1)*d1
    d1 = d2
    d2 = d0

    ! update p0, p1 and p2
    p0 = (D(ii)-X)*p2 - E(ii-1)*E(ii-1)*p1
    p1 = p2
    p2 = p0

  end do

  ! compute F
  ! if derivative is zero set Newton step
  ! to zero and throw error
  if (d2.EQ.0d0) then
     F = 0
     INFO = -1
  else
     F = p2/d2
  end if

end subroutine d_symtrid_newtonstep


      PROGRAM xpade
C     driver for routine pade
      INTEGER NMAX
      PARAMETER(NMAX=100)
      INTEGER j,k,n
      REAL resid
      DOUBLE PRECISION b,d,fac,fn,ratval,x,c(NMAX),cc(NMAX)
1     write(*,*) 'Enter n for PADE routine:'
      read(*,*,END=999) n
      fac=1
      do 11 j=1,2*n+1
        c(j)=fac/dble(j)
        cc(j)=c(j)
        fac=-fac
11    continue
      call pade(c,n,resid)
      write(*,'(1x,a,1pd16.8)') 'Norm of residual vector=',resid
      write(*,*) 'point, func. value, pade series, power series'
      do 13 j=1,21
        x=(j-1)*0.25
        b=0.
        do 12 k=2*n+1,1,-1
          b=b*x+cc(k)
12      continue
        d=ratval(x,c,n,n)
        write(*,'(1p4d16.8)') x,fn(x),d,b
13    continue
      goto 1
999   END
      DOUBLE PRECISION FUNCTION fn(x)
      DOUBLE PRECISION x
      if (x.eq.0.) then
        fn=1.
      else
        fn=log(1.+x)/x
      endif
      return
      END

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


cc Copyright (C) 2009: Zydrunas Gimbutas and Hong Xiao
cc Contact: Zydrunas Gimbutas <gimbutas@cims.nyu.edu>
cc          Hong Xiao <hxiao@ucdavis.edu>
cc
cc This software is being released under a modified FreeBSD license
cc (see COPYING in home directory).
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c       Quadratures for smooth functions on a cube
c
c       All quadratures are accurate to 15 digits
c       All weights are positive and inside the cube
c
c       Input:
c
c       n - the degree of the quadrature (must not exceed 15)
c
c       Output:
c
c       fort.11 - quadrature nodes and weights
c       fort.12 - quadrature nodes in gnuplot compatible format
c       fort.14 - cube as contructed in gnuplot compatible format
c
c       in gnuplot:
c
c       splot 'fort.14' w l, 'fort.12'
c
c
c
        implicit real *8 (a-h,o-z)
        real *8 rnodes(3,1000),weights(1000)
        real *8 rints(1000),z(3),pols(1000)
        real *8 work(100000)
c
c
        call prini(6,13)
c
c       SET ALL PARAMETERS
c
        PRINT *, 'ENTER mmax (1..15)'
        READ *, mmax
c
        call prinf('mmax=*',mmax,1)
c
c

c
c       ... retrieve the quadrature rule
c
        call cubearbq(mmax,rnodes,weights,numnodes)
c
        call prinf('nummodes=*',numnodes,1)
        call prin2('rnodes=*',rnodes,3*numnodes)
        call prin2('weights=*',weights,numnodes)
c
        d=0
        do i=1,numnodes
        d=d+weights(i)
        enddo
c
        call prin2('sum of weights=*',d,1)
c
c       ... plot the cube
c
        write(14,*) -1,-1,-1
        write(14,*) +1,-1,-1
        write(14,*) +1,+1,-1
        write(14,*) -1,+1,-1
        write(14,*) -1,-1,-1
        write(14,*)
c
        write(14,*) -1,-1,+1
        write(14,*) +1,-1,+1
        write(14,*) +1,+1,+1
        write(14,*) -1,+1,+1
        write(14,*) -1,-1,+1
        write(14,*)
c
        write(14,*) -1,-1,-1
        write(14,*) -1,-1,+1
        write(14,*)
        write(14,*) +1,-1,-1
        write(14,*) +1,-1,+1
        write(14,*)
        write(14,*) +1,+1,-1
        write(14,*) +1,+1,+1
        write(14,*)
        write(14,*) -1,+1,-1
        write(14,*) -1,+1,+1
        write(14,*)
c
c
c       ... dump the nodes into a file
c
        write(11,*) numnodes
        do i=1,numnodes
        write(11,1020) rnodes(1,i),rnodes(2,i),rnodes(3,i),weights(i)
        write(12,*) rnodes(1,i),rnodes(2,i),rnodes(3,i)
        enddo
 1010   format(i2)
 1020   format(4(e21.15,2x))
c

c
c       construct the matrix of values of the orthogonal polynomials
c       at the user-provided nodes
c
        npols=(mmax+1)*(mmax+2)*(mmax+3)/6
c
c
        do 1200 j=1,npols
        rints(j)=0
 1200 continue
c
c
        do 2400 i=1,numnodes
c
        z(1)=rnodes(1,i)
        z(2)=rnodes(2,i)
        z(3)=rnodes(3,i)
c
        call lege3eva(mmax,z,pols,work)
c
        do 2200 j=1,npols
c
        rints(j)=rints(j)+weights(i)*pols(j)

 2200 continue

 2400 continue
c
c
        call prin2('rints=*',rints,npols)
c
        vol=8.0d0
c
        d=0
        d=(rints(1)-sqrt(vol))**2
        do i=2,npols
        d=d+rints(i)**2
        enddo
c
        d=sqrt(d)/npols
c
        call prin2('error=*',d,1)
c
        stop
        end
c
c
c


c     program DRDHERQL
c>> 1996-05-28 DRDHERQL  Krogh Added external statement.
c>> 1994-10-19 DRDHERQL  Krogh  Changes to use M77CON
c>> 1994-09-23 DRDHERQL  CLL
c>> 1992-04-23 CLL
c>> 1992-03-04 DRDHERQL  Krogh Initial version.
c     Demonstrate Hermitian eigenvalue/eigenvector subroutine DHERQL.
c     ------------------------------------------------------------------
c--D replaces "?": DR?HERQL, ?HERQL, ?VECP, ?MATP, ?DOT
c     ------------------------------------------------------------------
      integer I, IERR, J, LDA, LDA3, N
      parameter (LDA = 4)
      parameter (LDA3 = 3*LDA)
      double precision AR(LDA, LDA), AI(LDA, LDA)
      double precision ARSAV(LDA, LDA), AISAV(LDA, LDA), ANORM
      external DDOT
      double precision DDOT, DR(LDA,LDA), DI(LDA,LDA), EVAL(LDA)
      double precision VR(LDA, LDA), VI(LDA, LDA), WORK(LDA3)
      data AR(1,1)          /  25.0d0 /
      data (AR(2,I), I=1,2) /  -3.0d0,  25.0d0 /
      data (AR(3,I), I=1,3) /  -08.0d0,  0.0d0,  25.0d0 /
      data (AR(4,I), I=1,4) /  0.0d0,  -08.0d0,  3.0d0, 25.0d0 /
      data AI(1,1)          /  0.0d0 /
      data (AI(2,I), I=1,2) /  4.0d0,  0.0d0 /
      data (AI(3,I), I=1,3) /  -06.0d0,  0.0d0, 0.0d0 /
      data (AI(4,I), I=1,4) / 0.0d0,  06.0d0, 4.0d0, 0.0d0 /
      data ANORM / 46.0d0 /
      data N /LDA/
c     ------------------------------------------------------------------
      print*,'DRDHERQL..  Demo driver for DHERQL.'
c
c     First copy AR() and AI() to ARSAV() and AISAV() for later
c     residual check.
c
      do 20 I = 1,N
         do 10 J = 1,I
            ARSAV(I,J) = AR(I,J)
            ARSAV(J,I) = ARSAV(I,J)
            AISAV(I,J) = AI(I,J)
            AISAV(J,I) = -AISAV(I,J)
   10    continue
   20 continue

      call DHERQL(AR, AI, LDA, N, EVAL, VR, VI, WORK, IERR)
      if (IERR .eq. 0) then
         call DVECP(EVAL, N, '0 Eigenvalues')
         call DMATP(VR,LDA,N,N,
     *     '0 Real parts of eigenvectors as column vectors')
         call DMATP(VI,LDA,N,N,
     *     '0 Imaginary parts of eigenvectors as column vectors')
c
c        As a check compute D = (ASAV*EVEC - EVEC*EVAL) / ANORM.
c        Expect D to be close to the machine precision.
c
         do 40 J = 1, LDA
            do 30 I = 1, LDA
               DR(I, J) = (DDOT(LDA,ARSAV(I,1),LDA,VR(1,J),1) -
     *                     DDOT(LDA,AISAV(I,1),LDA,VI(1,J),1) -
     *                     VR(I,J)*EVAL(J))/ANORM
               DI(I, J) = (DDOT(LDA,ARSAV(I,1),LDA,VI(1,J),1) +
     *                     DDOT(LDA,AISAV(I,1),LDA,VR(1,J),1) -
     *                     VI(I,J)*EVAL(J))/ANORM
   30       continue
   40    continue
       call DMATP(DR, LDA, N, N,
     * '0Real part of residual matrix D = (A*EVEC - EVEC*EVAL) / ANORM')
       call DMATP(DI, LDA, N, N,
     * '0Imag part of residual matrix D = (A*EVEC - EVEC*EVAL) / ANORM')
      else
         print '(/a,i5)',' Convergence failure in DHERQL, IERR =',IERR
      end if
      stop
      end


!*********************
program stommel
    use numz
    use input
    use constants
    use face
    implicit none
    real(b8)diff
    real(b8)dx2,dy2,bottom
    real(b8), allocatable:: psi(:,:)     ! our calculation grid
    real(b8), allocatable:: new_psi(:,:) ! temp storage for the grid
    real(b8) t1,t2,walltime
    integer i,j,i1,i2,j1,j2
    integer iout
! get the input.  see above for typical values
    read(*,*)nx,ny
    read(*,*)lx,ly
    read(*,*)alpha,beta,gamma
    read(*,*)steps
! allocate the grid to size nx * ny plus the boundary cells
    allocate(psi(0:nx+1,0:ny+1))
    allocate(new_psi(0:nx+1,0:ny+1))
    allocate(for(0:nx+1,0:ny+1))
! calculate the constants for the calculations
    dx=lx/(nx+1)
    dy=ly/(ny+1)
    dx2=dx*dx
    dy2=dy*dy
    bottom=2.0_b8*(dx2+dy2)
    a1=(dy2/bottom)+(beta*dx2*dy2)/(2.0_b8*gamma*dx*bottom)
    a2=(dy2/bottom)-(beta*dx2*dy2)/(2.0_b8*gamma*dx*bottom)
    a3=dx2/bottom
    a4=dx2/bottom
    a5=dx2*dy2/(gamma*bottom)
    a6=pi/(ly)
! set initial guess for the value of the grid
    psi=1.0_b8
! set the indices for the interior of the grid
    i1=1
    i2=nx
    j1=1
    j2=ny
! set boundary conditions
    call bc(psi,i1,i2,j1,j2)
! set the force array
    call do_force(i1,i2,j1,j2)
    new_psi=psi
! do the jacobian iterations
    iout=steps/100
    if(iout == 0)iout=1
    t1=walltime()
    do i=1,steps
        call do_jacobi(psi,new_psi,diff,i1,i2,j1,j2)
	if(mod(i,iout) .eq. 0)write(*,'(i6,1x,g20.10)')i,diff
    enddo
    t2=walltime()
    write(*,'("run time =",f10.2)')t2-t1
! write out the final grid
    call write_grid(psi,i1,i2,j1,j2)
end program stommel


program Newton
	real*8 x(2),t,g(2),A(2,2),Gni(2,2),b(2),f,p(2),ans,aro(2)
	data x /0,0/
	data A /2,-1,-1,2/
	data Gni /0.6666667,0.3333334,0.3333334,0.666666667/
	data b /-10,-4/
	open(13,file="Newton")
	write(13,"(5A13)")"f","x1","x2","g1","g2"
	do
	g=matmul(A,x)+b
	f=60-10*x(1)-4*x(2)+x(1)*x(1)+x(2)*x(2)-x(1)*x(2)
	write(13,"(5f13.6)")f,x,g
	call onedimenmul(g,g,2,ans)
	if(ans<0.01) exit
	p=matmul(-Gni,g)
	x=x+p
	end do
	close(13)
end program Newton

	subroutine onedimenmul(m1,m2,n,ans)
	integer n
	real*8 m1(n),m2(n),ans
	ans=0
	do i=1,n
		ans=m1(i)*m2(i)+ans
	end do
	end subroutine onedimenmul


!------------------------------------------------------------------
! Program to test if my concept for checking that two structures
! are equal works properly.
!
! Works by generating two equal geometric shapes as points
! (sets of coordinates on a grid), but located at different
! positions on the grid. If it works correctly, after
! aligning with the main rotation axis with the z-axis,
! and moving the center of mass to (0,0,0)
! for both structures, both sets of points should
! have the same set of coordinates, and a comparison routine
! should find that for every point in structure 1, there is
! a point with equal coordinates in structure 2.
!------------------------------------------------------------------

program abcd
use global_module
use auxilary_subroutines
implicit none

real(kind=8), allocatable, dimension(:,:) :: matrixa, matrixb
real(kind=8), allocatable, dimension(:) :: mass
integer :: i, j, n, test_variable

n = 20
allocate( matrixa(n,3), matrixb(n,3), mass(n) )

! The points are hydrogen atoms (needed for some of the
! subrutines that are called). The same mass array is used for matrixa
! and matrixb
do i = 1, n
   mass(i) = 1.0
end do

! Define the coordinates of points on the grid. You can see the shape
! when the files are printed. It's kinda like an L:
do i = 1, 10
   matrixa(i,1) = i
   matrixa(i,2) = 0
   matrixa(i,3) = 0
end do

do i = 1, 5
   matrixa(10+i,1) = i
   matrixa(10+i,2) = 1
   matrixa(10+i,3) = 0
end do

do i = 1, 5
   matrixa(15+i,1) = 1
   matrixa(15+i,2) = i
   matrixa(15+i,3) = 0
end do

! Print the .xyz file of these "hydrogen" points on the grid:
open(unit=1, file='file1-1.xyz', action='write', status='replace')
write(1,'(A2)') '20'
write(1,'(A4)') 'abcd'
do i = 1, 20
   write(1,'(A19,3F11.7)') ' H                 ', (matrixa(i,j), j = 1, 3)
end do
close(1)

! Move them so that the main rotation axis is aligned with the
! z-axis axis and the center of mass is at (0,0,0):
call center_and_main_inertia_vector (mass,n,matrixa)

! And print the new coordinates:
open(unit=2, file='file1-2.xyz', action='write', status='replace')
write(2,'(A2)') '20'
write(2,'(A4)') 'abcd'
do i = 1, 20
   write(2,'(A19,3F11.7)') ' H                 ', (matrixa(i,j), j = 1, 3)
end do

close(2)

! Now, make another set of hydrogen atoms of the same shape, but
! rotated about itself:
do i = 1, 10
   matrixb(i,1) = i
   matrixb(i,2) = 0
   matrixb(i,3) = 0
end do

do i = 1, 5
   matrixb(10+i,1) = i
   matrixb(10+i,2) = -1
   matrixb(10+i,3) = 0
end do

do i = 1, 5
   matrixb(15+i,1) = 1
   matrixb(15+i,2) = -i
   matrixb(15+i,3) = 0
end do

! And write them to a file:
open(unit=3, file='file2-1.xyz', action='write', status='replace')
write(3,'(A2)') '20'
write(3,'(A4)') 'abcd'
do i = 1, 20
   write(3,'(A19,3F11.7)') ' H                 ', (matrixb(i,j), j = 1, 3)
end do
close(3)

! And move them so that the center of mass is at (0,0,0)
! and the main rotation axis is aligned with the z-axis:
call center_and_main_inertia_vector (mass,n,matrixb)

! And write the new, translated coordinates to a file:
open(unit=4, file='file2-2.xyz', action='write', status='replace')
write(4,'(A2)') '20'
write(4,'(A4)') 'abcd'
do i = 1, 20
   write(4,'(A19,3F11.7)') ' H                 ', (matrixb(i,j), j = 1, 3)
end do

close(4)

! and now, compare matrixa(file1-2.xyz) and matrixb(file2-2.xyz):
call compare(matrixa,matrixb,n,test_variable)

end program abcd


      subroutine ZQUO(CNUM,CDENOM,CQUOT)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1995-10-30 ZQUO  Krogh   Fixed so M77CON can get S.P. for C conv.
C>> 1987-12-07 ZQUO  Lawson  Initial code.
c--Z replaces "?": ?QUO
C
C     Computes the quotient of two double precision complex numbers.
C     Computes Z = U / V where the data is given as
C        CNUM(1)   = Real part of U
C        CNUM(2)   = Imaginary part of U
C        CDENOM(1) = Real part of V
C        CDENOM(2) = Imaginary part of V
C     Result returned as
C        CQUOT(1)  = Real part of Z
C        CQUOT(2)  = Imaginary part of Z
C
c     If CDENOM = (0,0) this subr will divide by zero.  We assume this
c     will activate a system error stop.
C     C.L.Lawson & S.Chan, JPL, June 3,1986. 2/17/87.
C     ------------------------------------------------------------------
C
      double precision CNUM(2),CDENOM(2),CQUOT(2)
      double precision A1,B1,C1,D1,DENOM, ONE
      parameter(ONE = 1.0D0)
C
      if(abs(CDENOM(1)) .gt. abs(CDENOM(2))) then
         A1 = CNUM(1)/CDENOM(1)
         B1 = CNUM(2)/CDENOM(1)
         D1 = CDENOM(2)/CDENOM(1)
         DENOM = ONE + D1*D1
         CQUOT(1) = (A1 + B1*D1) / DENOM
         CQUOT(2) = (B1 - A1*D1) / DENOM
      else
         A1 = CNUM(1)/CDENOM(2)
         B1 = CNUM(2)/CDENOM(2)
         C1 = CDENOM(1)/CDENOM(2)
         DENOM = ONE + C1*C1
         CQUOT(1) = (A1*C1 + B1) / DENOM
         CQUOT(2) = (B1*C1 - A1) / DENOM
      end if
      return
      end


*DECK CASIN
      COMPLEX FUNCTION CASIN (ZINP)
C***BEGIN PROLOGUE  CASIN
C***PURPOSE  Compute the complex arc sine.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4A
C***TYPE      COMPLEX (CASIN-C)
C***KEYWORDS  ARC SINE, ELEMENTARY FUNCTIONS, FNLIB, TRIGONOMETRIC
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CASIN(ZINP) calculates the complex trigonometric arc sine of ZINP.
C The result is in units of radians, and the real part is in the first
C or fourth quadrant.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CASIN
      COMPLEX ZINP, Z, Z2, SQZP1, CI
      LOGICAL FIRST
      SAVE PI2, PI, CI, NTERMS, RMIN, FIRST
      DATA PI2 /1.5707963267 9489661923E0/
      DATA PI /3.1415926535 8979324E0/
      DATA CI /(0.,1.)/
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  CASIN
      IF (FIRST) THEN
C NTERMS = LOG(EPS)/LOG(RMAX)  WHERE RMAX = 0.1
         NTERMS = -0.4343*LOG(R1MACH(3))
         RMIN = SQRT (6.0*R1MACH(3))
      ENDIF
      FIRST = .FALSE.
C
      Z = ZINP
      R = ABS (Z)
      IF (R.GT.0.1) GO TO 30
C
      CASIN = Z
      IF (R.LT.RMIN) RETURN
C
      CASIN = (0.0, 0.0)
      Z2 = Z*Z
      DO 20 I=1,NTERMS
        TWOI = 2*(NTERMS-I) + 1
        CASIN = 1.0/TWOI + TWOI*CASIN*Z2/(TWOI+1.0)
 20   CONTINUE
      CASIN = Z*CASIN
      RETURN
C
 30   IF (REAL(ZINP).LT.0.0) Z = -ZINP
C
      SQZP1 = SQRT (Z+1.0)
      IF (AIMAG(SQZP1).LT.0.) SQZP1 = -SQZP1
      CASIN = PI2 - CI * LOG (Z + SQZP1*SQRT(Z-1.0))
C
      IF (REAL(CASIN).GT.PI2) CASIN = PI - CASIN
      IF (REAL(CASIN).LE.(-PI2)) CASIN = -PI - CASIN
      IF (REAL(ZINP).LT.0.) CASIN = -CASIN
C
      RETURN
      END