program test_var
    use stdlib_experimental_error, only: assert
    use stdlib_experimental_kinds, only: sp, dp, int32, int64
    use stdlib_experimental_stats, only: var
    implicit none

    real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
    real(dp), parameter :: dptol = 1000 * epsilon(1._dp)

    integer(int32) :: i321(5) = [1, 2, 3, 4, 5]
    integer(int64) :: i641(5) = [1, 2, 3, 4, 5]

    integer(int32), allocatable :: i32(:,:), i323(:, :, :)
    integer(int64), allocatable :: i64(:,:), i643(:, :, :)

    real(sp) :: s1(5) = [1.0_sp, 2.0_sp, 3.0_sp, 4.0_sp, 5.0_sp]
    real(dp) :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp]

    real(sp), allocatable :: s(:, :), s3(:, :, :)
    real(dp), allocatable :: d3(:, :, :)
    real(dp) :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 7._dp,&
                                   2._dp, 4._dp, 6._dp, 8._dp,&
                                   9._dp, 10._dp, 11._dp, 12._dp], [4, 3])

    complex(sp) :: cs1(5) = [ cmplx(0.57706_sp, 0.00000_sp),&
                            cmplx(0.00000_sp, 1.44065_sp),&
                            cmplx(1.26401_sp, 0.00000_sp),&
                            cmplx(0.00000_sp, 0.88833_sp),&
                            cmplx(1.14352_sp, 0.00000_sp)]
    complex(dp) :: cd1(5) = [ cmplx(0.57706_dp, 0.00000_dp),&
                            cmplx(0.00000_dp, 1.44065_dp),&
                            cmplx(1.26401_dp, 0.00000_dp),&
                            cmplx(0.00000_dp, 0.88833_dp),&
                            cmplx(1.14352_dp, 0.00000_dp)]
    complex(sp) :: cs(5,3)
    complex(dp) :: cd(5,3)

    !sp
    !1dim
    print*,' test_sp_1dim'
    call assert( abs(var(s1) - 2.5) < sptol)
    call assert( abs(var(s1, dim=1) - 2.5) < sptol)

    print*,' test_sp_1dim_mask'
    call assert( isnan(var(s1, .false.)))
    call assert( isnan(var(s1, 1, .false.)))

    print*,' test_sp_1dim_mask_array'
    call assert( abs(var(s1, s1 < 5) - 5./3.) < sptol)
    call assert( isnan((var(s1, s1 < 0.))))
    call assert( isnan((var(s1, s1 == 1.))))
    call assert( abs(var(s1, 1, s1 < 5) - 5./3.) < sptol)

    !2dim
    print*,' test_sp_2dim'
    s = d
    call assert( abs(var(s) - 13) < sptol)
    call assert( all( abs( var(s, 1) - [20. / 3., 20. / 3., 5. / 3.]) < sptol))
    call assert( all( abs( var(s, 2) - [19.0, 43. / 3., 31. / 3. , 7.0]) < sptol))

    print*,' test_sp_2dim_mask'
    call assert( isnan(var(s, .false.)))
    call assert( any(isnan(var(s, 1, .false.))))
    call assert( any(isnan(var(s, 2, .false.))))

    print*,' test_sp_2dim_mask_array'
    call assert( abs(var(s, s < 11) - 27.5 / 3.) < sptol)
    call assert( all( abs( var(s, 1, s < 11) - [20. / 3., 20. / 3., 0.5]) < sptol))
    call assert( all( abs( var(s, 2, s < 11) - [19.0, 43. / 3., 0.5 , 0.5]) < sptol))

    !3dim
    allocate(s3(size(s,1),size(s,2),3))
    s3(:,:,1)=s;
    s3(:,:,2)=s*2;
    s3(:,:,3)=s*4;

    print*,' test_sp_3dim'
    call assert( abs(var(s3) - 153.4) < sptol)
    call assert( all( abs( var(s3, 1) -&
                 reshape([20. / 3., 20. / 3., 5. / 3.,&
                          4* 20. / 3., 4* 20. / 3., 4* 5. / 3.,&
                          16* 20. / 3., 16* 20. / 3., 16* 5. / 3.],&
                          [size(s3,2), size(s3,3)]))&
                 < sptol))
    call assert( all( abs( var(s3, 2) -&
                 reshape([19.0, 43. / 3., 31. / 3. , 7.0,&
                          4* 19.0, 4* 43. / 3., 4* 31. / 3. , 4* 7.0,&
                          16* 19.0, 16* 43. / 3., 16* 31. / 3. , 16* 7.0],&
                          [size(s3,1), size(s3,3)] ))&
                 < sptol))
    call assert( all(abs( var(s3, 3) -&
                 reshape([ 7./3., 21., 175./3.,&
                           343./3., 28./3., 112./3.,&
                           84., 448./3., 189.,&
                           700./3., 847./3., 336.], [size(s3,1), size(s3,2)] ))&
                 < sptol))

    print*,' test_sp_3dim_mask'
    call assert( isnan(var(s3, .false.)))
    call assert( any(isnan(var(s3, 1, .false.))))
    call assert( any(isnan(var(s3, 2, .false.))))
    call assert( any(isnan(var(s3, 3, .false.))))

    print*,' test_sp_3dim_mask_array'
    call assert( abs(var(s3, s3 < 11) - 8.2205877_sp) < sptol)
    call assert( all( abs( var(s3, 1, s3 < 45) -&
                  reshape([20./3., 20./3., 5./3.,  80./3., 80./3., 20./3.,&
                           320./3., 320./3., 16.],&
                  [size(s3, 2), size(s3, 3)])) < sptol ))
    call assert( any( isnan( var(s3, 2, s3 < 25))))
    call assert( all( abs( var(s3, 3, s3 < 25) -&
                 reshape([ 7./3., 21., 175./3.,&
                           24.5, 28./3., 112./3.,&
                           84., 32., 40.5,&
                           50., 60.5, 72.], [size(s3,1), size(s3,2)] ))&
                 < sptol ))

    !dp
    !1dim
    print*,' test_dp_1dim'
    call assert( abs(var(d1) - 2.5) < dptol)
    call assert( abs(var(d1, 1) - 2.5) < dptol)

    print*,' test_dp_1dim_mask'
    call assert( isnan(var(d1, .false.)))
    call assert( isnan(var(d1, 1, .false.)))

    print*,' test_dp_1dim_mask_array'
    call assert( abs(var(d1, d1 < 5) - 5._dp/3._dp) < dptol)
    call assert( isnan((var(d1, d1 < 0.))))
    call assert( isnan((var(d1, d1 == 1.))))
    call assert( abs(var(d1, 1, d1 < 5) - 5._dp/3._dp) < dptol)

    !2dim
    print*,' test_dp_2dim'
    call assert( abs(var(d) - 13) < dptol)
    call assert( all( abs( var(d,1) -&
                 [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol))
    call assert( all( abs( var(d,2) -&
                 [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol))

    print*,' test_dp_2dim_mask'
    call assert( isnan(var(d, .false.)))
    call assert( any(isnan(var(d, 1, .false.))))
    call assert( any(isnan(var(d, 2, .false.))))

    print*,' test_dp_2dim_mask_array'
    call assert( abs(var(d, d < 11) - 27.5_dp / 3._dp) < dptol)
    call assert( all( abs( var(d, 1, d < 11) -&
                 [20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol))
    call assert( all( abs( var(d, 2, d < 11) -&
                 [19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol))

    !3dim
    allocate(d3(size(d,1),size(d,2),3))
    d3(:,:,1)=d;
    d3(:,:,2)=d*2;
    d3(:,:,3)=d*4;

    print*,' test_dp_3dim'
    call assert( abs(var(d3) - 153.4_dp) < dptol)
    call assert( all( abs( var(d3, 1) -&
                 reshape([20._dp / 3._dp, 20._dp / 3._dp, 5._dp / 3._dp,&
                          4* 20._dp / 3._dp, 4* 20._dp / 3._dp, 4* 5._dp / 3._dp,&
                          16* 20._dp / 3._dp, 16* 20._dp / 3._dp, 16* 5._dp / 3._dp],&
                          [size(d3,2), size(d3,3)]))&
                 < dptol))
    print*,' test_dp_3dim'
    call assert( all( abs( var(d3, 2) -&
                 reshape([19.0_dp, 43._dp / 3._dp, 31._dp / 3._dp , 7.0_dp,&
                          4* 19.0_dp, 4* 43._dp / 3._dp, 4* 31._dp / 3._dp , 4* 7.0_dp,&
                          16* 19.0_dp, 16* 43._dp / 3._dp, 16* 31._dp / 3._dp ,&
                          16* 7.0_dp],&
                          [size(d3,1), size(d3,3)] ))&
                 < dptol))
    print*,' test_dp_3dim'
    call assert( all(abs( var(d3, 3) -&
                 reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
                           343._dp/3._dp, 28._dp/3._dp, 112._dp/3._dp,&
                           84._dp, 448._dp/3._dp, 189._dp,&
                           700._dp/3._dp, 847._dp/3._dp, 336._dp],&
                           [size(d3,1), size(d3,2)] ))&
                 < dptol))

    print*,' test_dp_3dim_mask'
    call assert( isnan(var(d3, .false.)))
    call assert( any(isnan(var(d3, 1, .false.))))
    call assert( any(isnan(var(d3, 2, .false.))))
    call assert( any(isnan(var(d3, 3, .false.))))

    print*,' test_dp_3dim_mask_array'
    call assert( abs(var(d3, d3 < 25) - 46.041379310344823_dp) < dptol)
    call assert( all( abs( var(d3, 1, d3 < 45) -&
                  reshape([20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp,&
                           80._dp/3._dp, 80._dp/3._dp, 20._dp/3._dp,&
                           320._dp/3._dp, 320._dp/3._dp, 16._dp],&
                           [size(d3, 2), size(d3, 3)]))&
                  < dptol ))
    call assert( any( isnan( var(d3, 2, d3 < 25))))
    call assert( all( abs( var(d3, 3, d3 < 25) -&
                 reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
                           24.5_dp, 28._dp/3._dp, 112._dp/3._dp,&
                           84._dp, 32._dp, 40.5_dp,&
                           50._dp, 60.5_dp, 72._dp],&
                           [size(d3,1), size(d3,2)] ))&
                 < dptol ))

    !int32
    !1dim
    print*,' test_int32_1dim'
    call assert( abs(var(i321) - 2.5) < dptol)
    call assert( abs(var(i321, 1) - 2.5) < dptol)

    print*,' test_int32_1dim_mask'
    call assert( isnan(var(i321, .false.)))
    call assert( isnan(var(i321, 1, .false.)))

    print*,' test_int32_1dim_mask_array'
    call assert( abs(var(i321, i321 < 5) - 5._dp/3._dp) < dptol)
    call assert( isnan((var(i321, i321 < 0))))
    call assert( isnan((var(i321, i321 == 1))))
    call assert( abs(var(i321, 1, i321 < 5) - 5._dp/3._dp) < dptol)

    !2dim
    print*,' test_int32_2dim'
    i32 = d
    call assert( abs(var(i32) - 13) < dptol)
    call assert( all( abs( var(i32,1) -&
                 [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol))
    call assert( all( abs( var(i32,2) -&
                 [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol))

    print*,' test_int32_2dim_mask'
    call assert( isnan(var(i32, .false.)))
    call assert( any(isnan(var(i32, 1, .false.))))
    call assert( any(isnan(var(i32, 2, .false.))))

    print*,' test_int32_2dim_mask_array'
    call assert( abs(var(i32, i32 < 11) - 27.5_dp / 3._dp) < dptol)
    call assert( all( abs( var(i32, 1, i32 < 11) -&
                 [20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol))
    call assert( all( abs( var(i32, 2, i32 < 11) -&
                 [19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol))

    !3dim
    allocate(i323(size(d,1),size(d,2),3))
    i323(:,:,1)=d;
    i323(:,:,2)=d*2;
    i323(:,:,3)=d*4;

    print*,' test_int32_3dim'
    call assert( abs(var(i323) - 153.4_dp) < dptol)
    call assert( all( abs( var(i323, 1) -&
                 reshape([20._dp / 3._dp, 20._dp / 3._dp, 5._dp / 3._dp,&
                          4* 20._dp / 3._dp, 4* 20._dp / 3._dp, 4* 5._dp / 3._dp,&
                          16* 20._dp / 3._dp, 16* 20._dp / 3._dp, 16* 5._dp / 3._dp],&
                          [size(i323,2), size(i323,3)]))&
                 < dptol))
    call assert( all( abs( var(i323, 2) -&
                 reshape([19.0_dp, 43._dp / 3._dp, 31._dp / 3._dp , 7.0_dp,&
                          4* 19.0_dp, 4* 43._dp / 3._dp, 4* 31._dp / 3._dp , 4* 7.0_dp,&
                          16* 19.0_dp, 16* 43._dp / 3._dp, 16* 31._dp / 3._dp ,&
                          16* 7.0_dp],&
                          [size(i323,1), size(i323,3)] ))&
                 < dptol))
    call assert( all(abs( var(i323, 3) -&
                 reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
                           343._dp/3._dp, 28._dp/3._dp, 112._dp/3._dp,&
                           84._dp, 448._dp/3._dp, 189._dp,&
                           700._dp/3._dp, 847._dp/3._dp, 336._dp],&
                           [size(i323,1), size(i323,2)] ))&
                 < dptol))

    print*,' test_int32_3dim_mask'
    call assert( isnan(var(i323, .false.)))
    call assert( any(isnan(var(i323, 1, .false.))))
    call assert( any(isnan(var(i323, 2, .false.))))
    call assert( any(isnan(var(i323, 3, .false.))))

    print*,' test_int32_3dim_mask_array'
    call assert( abs(var(i323, i323 < 25) - 46.041379310344823_dp) < dptol)
    call assert( all( abs( var(i323, 1, i323 < 45) -&
                  reshape([20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp,&
                           80._dp/3._dp, 80._dp/3._dp, 20._dp/3._dp,&
                           320._dp/3._dp, 320._dp/3._dp, 16._dp],&
                           [size(i323, 2), size(i323, 3)]))&
                  < dptol ))
    call assert( any( isnan( var(i323, 2, i323 < 25))))
    call assert( all( abs( var(i323, 3, i323 < 25) -&
                 reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
                           24.5_dp, 28._dp/3._dp, 112._dp/3._dp,&
                           84._dp, 32._dp, 40.5_dp,&
                           50._dp, 60.5_dp, 72._dp],&
                           [size(i323,1), size(i323,2)] ))&
                 < dptol ))

    !int64
    !1dim
    print*,' test_int64_1dim'
    call assert( abs(var(i641) - 2.5) < dptol)
    call assert( abs(var(i641, 1) - 2.5) < dptol)

    print*,' test_int64_1dim_mask'
    call assert( isnan(var(i641, .false.)))
    call assert( isnan(var(i641, 1, .false.)))

    print*,' test_int641_1dim_mask_array'
    call assert( abs(var(i641, i641 < 5) - 5._dp/3._dp) < dptol)
    call assert( isnan((var(i641, i641 < 0))))
    call assert( isnan((var(i641, i641 == 1))))
    call assert( abs(var(i641, 1, i641 < 5) - 5._dp/3._dp) < dptol)

    !2dim
    print*,' test_int64_2dim'
    i64 = d
    call assert( abs(var(i64) - 13) < dptol)
    call assert( all( abs( var(i64,1) -&
                 [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol))
    call assert( all( abs( var(i64,2) -&
                 [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol))

    print*,' test_int64_2dim_mask'
    call assert( isnan(var(i64, .false.)))
    call assert( any(isnan(var(i64, 1, .false.))))
    call assert( any(isnan(var(i64, 2, .false.))))

    print*,' test_int64_2dim_mask_array'
    call assert( abs(var(i64, i64 < 11) - 27.5_dp / 3._dp) < dptol)
    call assert( all( abs( var(i64, 1, i64 < 11) -&
                 [20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol))
    call assert( all( abs( var(i64, 2, i64 < 11) -&
                 [19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol))

    !3dim
    allocate(i643(size(d,1),size(d,2),3))
    i643(:,:,1)=d;
    i643(:,:,2)=d*2;
    i643(:,:,3)=d*4;

    print*,' test_int32_3dim'
    call assert( abs(var(i643) - 153.4_dp) < dptol)
    call assert( all( abs( var(i643, 1) -&
                 reshape([20._dp / 3._dp, 20._dp / 3._dp, 5._dp / 3._dp,&
                          4* 20._dp / 3._dp, 4* 20._dp / 3._dp, 4* 5._dp / 3._dp,&
                          16* 20._dp / 3._dp, 16* 20._dp / 3._dp, 16* 5._dp / 3._dp],&
                          [size(i643,2), size(i643,3)]))&
                 < dptol))
    call assert( all( abs( var(i643, 2) -&
                 reshape([19.0_dp, 43._dp / 3._dp, 31._dp / 3._dp , 7.0_dp,&
                          4* 19.0_dp, 4* 43._dp / 3._dp, 4* 31._dp / 3._dp , 4* 7.0_dp,&
                          16* 19.0_dp, 16* 43._dp / 3._dp, 16* 31._dp / 3._dp ,&
                          16* 7.0_dp],&
                          [size(i643,1), size(i643,3)] ))&
                 < dptol))
    call assert( all(abs( var(i643, 3) -&
                 reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
                           343._dp/3._dp, 28._dp/3._dp, 112._dp/3._dp,&
                           84._dp, 448._dp/3._dp, 189._dp,&
                           700._dp/3._dp, 847._dp/3._dp, 336._dp],&
                           [size(i643,1), size(i643,2)] ))&
                 < dptol))

    print*,' test_int32_3dim_mask'
    call assert( isnan(var(i643, .false.)))
    call assert( any(isnan(var(i643, 1, .false.))))
    call assert( any(isnan(var(i643, 2, .false.))))
    call assert( any(isnan(var(i643, 3, .false.))))

    print*,' test_int64_3dim_mask_array'
    call assert( abs(var(i643, i643 < 25) - 46.041379310344823_dp) < dptol)
    call assert( all( abs( var(i643, 1, i643 < 45) -&
                  reshape([20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp,&
                           80._dp/3._dp, 80._dp/3._dp, 20._dp/3._dp,&
                           320._dp/3._dp, 320._dp/3._dp, 16._dp],&
                           [size(i643, 2), size(i643, 3)]))&
                  < dptol ))
    call assert( any( isnan( var(i643, 2, i643 < 25))))
    call assert( all( abs( var(i643, 3, i643 < 25) -&
                 reshape([ 7._dp/3._dp, 21._dp, 175._dp/3._dp,&
                           24.5_dp, 28._dp/3._dp, 112._dp/3._dp,&
                           84._dp, 32._dp, 40.5_dp,&
                           50._dp, 60.5_dp, 72._dp],&
                           [size(i643,1), size(i643,2)] ))&
                 < dptol ))

    !csp
    !1dim
    print*,' test_csp_1dim'
    call assert( abs(var(cs1) - (var(real(cs1)) + var(aimag(cs1)))) < sptol)
    call assert( abs(var(cs1, dim=1) - (var(real(cs1),1) + var(aimag(cs1), 1)) ) < sptol)

    print*,' test_csp_1dim_mask'
    call assert( isnan(var(cs1, .false.)))
    call assert( isnan(var(cs1, 1, .false.)))

    print*,' test_csp_1dim_mask_array'
    call assert( abs(var(cs1, aimag(cs1) == 0) - var(real(cs1), aimag(cs1) == 0)) < sptol)
    call assert( abs(var(cs1, 1, aimag(cs1) == 0) - var(real(cs1), 1, aimag(cs1) == 0)) < sptol)

    !2dim
    cs(:,1) = cs1
    cs(:,2) = cs1*3_sp
    cs(:,3) = cs1*1.5_sp

    print*,' test_csp_2dim'
    call assert( abs(var(cs) - (var(real(cs)) + var(aimag(cs)))) < sptol)
    call assert( all( abs( var(cs, 1) - (var(real(cs), 1) + var(aimag(cs), 1))) < sptol))
    call assert( all( abs( var(cs, 2) - (var(real(cs), 2) + var(aimag(cs), 2))) < sptol))

    print*,' test_csp_2dim_mask'
    call assert( isnan(var(cs, .false.)))
    call assert( any(isnan(var(cs, 1, .false.))))
    call assert( any(isnan(var(cs, 2, .false.))))

    print*,' test_csp_2dim_mask_array'
    call assert( abs(var(cs, aimag(cs) == 0) - var(real(cs), aimag(cs) == 0)) < sptol)
    call assert( all( abs( var(cs, 1, aimag(cs) == 0) - var(real(cs), 1, aimag(cs) == 0)) < sptol))
    call assert( any( isnan( var(cs, 2, aimag(cs) == 0))))

    !cdp
    !1dim
    print*,' test_cdp_1dim'
    call assert( abs(var(cd1) - (var(real(cd1)) + var(aimag(cd1)))) < dptol)
    call assert( abs(var(cd1, dim=1) - (var(real(cd1),1) + var(aimag(cd1), 1)) ) < dptol)

    print*,' test_cdp_1dim_mask'
    call assert( isnan(var(cd1, .false.)))
    call assert( isnan(var(cd1, 1, .false.)))

    print*,' test_cdp_1dim_mask_array'
    call assert( abs(var(cd1, aimag(cd1) == 0) - var(real(cd1), aimag(cd1) == 0)) < dptol)
    call assert( abs(var(cd1, 1, aimag(cd1) == 0) - var(real(cd1), 1, aimag(cd1) == 0)) < dptol)

    !2dim
    cd(:,1) = cd1
    cd(:,2) = cd1*3_sp
    cd(:,3) = cd1*1.5_sp

    print*,' test_cdp_2dim'
    call assert( abs(var(cd) - (var(real(cd)) + var(aimag(cd)))) < dptol)
    call assert( all( abs( var(cd, 1) - (var(real(cd), 1) + var(aimag(cd), 1))) < dptol))
    call assert( all( abs( var(cd, 2) - (var(real(cd), 2) + var(aimag(cd), 2))) < dptol))

    print*,' test_cdp_2dim_mask'
    call assert( isnan(var(cd, .false.)))
    call assert( any(isnan(var(cd, 1, .false.))))
    call assert( any(isnan(var(cd, 2, .false.))))

    print*,' test_cdp_2dim_mask_array'
    call assert( abs(var(cd, aimag(cd) == 0) - var(real(cd), aimag(cd) == 0)) < dptol)
    call assert( all( abs( var(cd, 1, aimag(cd) == 0) - var(real(cd), 1, aimag(cd) == 0)) < dptol))
    call assert( any( isnan( var(cd, 2, aimag(cd) == 0))))

end program


C     ===================================================
      SUBROUTINE GETDA (EE,EP,YJB,Q2JB,XDA,Q2DA,YDA,TH_E)
C     ===================================================

      IMPLICIT NONE

      REAL EE,EP,YJB,Q2JB,XDA,Q2DA,YDA,TH_E,A,B,COSG,G,SING,X0,
     &     COSTH,SINTH,BETA,DELTA

      REAL NO_USE
      DATA NO_USE / -999.99 /

      A    = Q2JB*(1.0-YJB)
      B    = 4.0*(EE**2)*(YJB**2)

      IF ( (A+B).EQ.0 ) THEN
        YDA  = NO_USE
        XDA  = NO_USE
        Q2DA = NO_USE
        GOTO 100
      ENDIF

      COSG = (A-B)/(A+B)
      G    = ACOS(COSG)
      SING = SIN(G)

      X0     = EE/EP
      COSTH  = COS(TH_E)
      SINTH  = SIN(TH_E)
      BETA   = SING + SINTH - SIN(TH_E+G)
      DELTA  = SING + SINTH + SIN(TH_E+G)

      IF (BETA.NE.0) THEN
        YDA    = ( SINTH*(1-COSG) )/ BETA
        Q2DA   = ( 4*(EE**2)*SING*(1+COSTH) )/ BETA
        XDA    = (X0*DELTA) / BETA
      ELSE
        YDA  = NO_USE
        XDA  = NO_USE
        Q2DA = NO_USE
      ENDIF

100   CONTINUE

      RETURN
      END


*DECK DBINT4
      SUBROUTINE DBINT4 (X, Y, NDATA, IBCL, IBCR, FBCL, FBCR, KNTOPT, T,
     +   BCOEF, N, K, W)
C***BEGIN PROLOGUE  DBINT4
C***PURPOSE  Compute the B-representation of a cubic spline
C            which interpolates given data.
C***LIBRARY   SLATEC
C***CATEGORY  E1A
C***TYPE      DOUBLE PRECISION (BINT4-S, DBINT4-D)
C***KEYWORDS  B-SPLINE, CUBIC SPLINES, DATA FITTING, INTERPOLATION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C     Abstract    **** a double precision routine ****
C
C         DBINT4 computes the B representation (T,BCOEF,N,K) of a
C         cubic spline (K=4) which interpolates data (X(I),Y(I)),
C         I=1,NDATA.  Parameters IBCL, IBCR, FBCL, FBCR allow the
C         specification of the spline first or second derivative at
C         both X(1) and X(NDATA).  When this data is not specified
C         by the problem, it is common practice to use a natural
C         spline by setting second derivatives at X(1) and X(NDATA)
C         to zero (IBCL=IBCR=2,FBCL=FBCR=0.0).  The spline is defined
C         on T(4) .LE. X .LE. T(N+1) with (ordered) interior knots at
C         X(I) values where N=NDATA+2.  The knots T(1),T(2),T(3) lie to
C         the left of T(4)=X(1) and the knots T(N+2), T(N+3), T(N+4)
C         lie to the right of T(N+1)=X(NDATA) in increasing order.  If
C         no extrapolation outside (X(1),X(NDATA)) is anticipated, the
C         knots T(1)=T(2)=T(3)=T(4)=X(1) and T(N+2)=T(N+3)=T(N+4)=
C         T(N+1)=X(NDATA) can be specified by KNTOPT=1.  KNTOPT=2
C         selects a knot placement for T(1), T(2), T(3) to make the
C         first 7 knots symmetric about T(4)=X(1) and similarly for
C         T(N+2), T(N+3), T(N+4) about T(N+1)=X(NDATA).  KNTOPT=3
C         allows the user to make his own selection, in increasing
C         order, for T(1), T(2), T(3) to the left of X(1) and T(N+2),
C         T(N+3), T(N+4) to the right of X(NDATA) in the work array
C         W(1) through W(6).  In any case, the interpolation on
C         T(4) .LE. X .LE. T(N+1) by using function DBVALU is unique
C         for given boundary conditions.
C
C     Description of Arguments
C
C         Input      X,Y,FBCL,FBCR,W are double precision
C           X      - X vector of abscissae of length NDATA, distinct
C                    and in increasing order
C           Y      - Y vector of ordinates of length NDATA
C           NDATA  - number of data points, NDATA .GE. 2
C           IBCL   - selection parameter for left boundary condition
C                    IBCL = 1 constrain the first derivative at
C                             X(1) to FBCL
C                         = 2 constrain the second derivative at
C                             X(1) to FBCL
C           IBCR   - selection parameter for right boundary condition
C                    IBCR = 1 constrain first derivative at
C                             X(NDATA) to FBCR
C                    IBCR = 2 constrain second derivative at
C                             X(NDATA) to FBCR
C           FBCL   - left boundary values governed by IBCL
C           FBCR   - right boundary values governed by IBCR
C           KNTOPT - knot selection parameter
C                    KNTOPT = 1 sets knot multiplicity at T(4) and
C                               T(N+1) to 4
C                           = 2 sets a symmetric placement of knots
C                               about T(4) and T(N+1)
C                           = 3 sets T(I)=W(I) and T(N+1+I)=W(3+I),I=1,3
C                               where W(I),I=1,6 is supplied by the user
C           W      - work array of dimension at least 5*(NDATA+2)
C                    If KNTOPT=3, then W(1),W(2),W(3) are knot values to
C                    the left of X(1) and W(4),W(5),W(6) are knot
C                    values to the right of X(NDATA) in increasing
C                    order to be supplied by the user
C
C         Output     T,BCOEF are double precision
C           T      - knot array of length N+4
C           BCOEF  - B spline coefficient array of length N
C           N      - number of coefficients, N=NDATA+2
C           K      - order of spline, K=4
C
C     Error Conditions
C         Improper  input is a fatal error
C         Singular system of equations is a fatal error
C
C***REFERENCES  D. E. Amos, Computation with splines and B-splines,
C                 Report SAND78-1968, Sandia Laboratories, March 1979.
C               Carl de Boor, Package for calculating with B-splines,
C                 SIAM Journal on Numerical Analysis 14, 3 (June 1977),
C                 pp. 441-472.
C               Carl de Boor, A Practical Guide to Splines, Applied
C                 Mathematics Series 27, Springer-Verlag, New York,
C                 1978.
C***ROUTINES CALLED  D1MACH, DBNFAC, DBNSLV, DBSPVD, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800901  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   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DBINT4
C
      INTEGER I, IBCL, IBCR, IFLAG, ILB, ILEFT, IT, IUB, IW, IWP, J,
     1 JW, K, KNTOPT, N, NDATA, NDM, NP, NWROW
      DOUBLE PRECISION BCOEF,FBCL,FBCR,T,TOL,TXN,TX1,VNIKX,W,WDTOL,
     1 WORK,X,XL,Y
      DOUBLE PRECISION D1MACH
      DIMENSION X(*), Y(*), T(*), BCOEF(*), W(5,*), VNIKX(4,4), WORK(15)
C***FIRST EXECUTABLE STATEMENT  DBINT4
      WDTOL = D1MACH(4)
      TOL = SQRT(WDTOL)
      IF (NDATA.LT.2) GO TO 200
      NDM = NDATA - 1
      DO 10 I=1,NDM
        IF (X(I).GE.X(I+1)) GO TO 210
   10 CONTINUE
      IF (IBCL.LT.1 .OR. IBCL.GT.2) GO TO 220
      IF (IBCR.LT.1 .OR. IBCR.GT.2) GO TO 230
      IF (KNTOPT.LT.1 .OR. KNTOPT.GT.3) GO TO 240
      K = 4
      N = NDATA + 2
      NP = N + 1
      DO 20 I=1,NDATA
        T(I+3) = X(I)
   20 CONTINUE
      GO TO (30, 50, 90), KNTOPT
C     SET UP KNOT ARRAY WITH MULTIPLICITY 4 AT X(1) AND X(NDATA)
   30 CONTINUE
      DO 40 I=1,3
        T(4-I) = X(1)
        T(NP+I) = X(NDATA)
   40 CONTINUE
      GO TO 110
C     SET UP KNOT ARRAY WITH SYMMETRIC PLACEMENT ABOUT END POINTS
   50 CONTINUE
      IF (NDATA.GT.3) GO TO 70
      XL = (X(NDATA)-X(1))/3.0D0
      DO 60 I=1,3
        T(4-I) = T(5-I) - XL
        T(NP+I) = T(NP+I-1) + XL
   60 CONTINUE
      GO TO 110
   70 CONTINUE
      TX1 = X(1) + X(1)
      TXN = X(NDATA) + X(NDATA)
      DO 80 I=1,3
        T(4-I) = TX1 - X(I+1)
        T(NP+I) = TXN - X(NDATA-I)
   80 CONTINUE
      GO TO 110
C     SET UP KNOT ARRAY LESS THAN X(1) AND GREATER THAN X(NDATA) TO BE
C     SUPPLIED BY USER IN WORK LOCATIONS W(1) THROUGH W(6) WHEN KNTOPT=3
   90 CONTINUE
      DO 100 I=1,3
        T(4-I) = W(4-I,1)
        JW = MAX(1,I-1)
        IW = MOD(I+2,5)+1
        T(NP+I) = W(IW,JW)
        IF (T(4-I).GT.T(5-I)) GO TO 250
        IF (T(NP+I).LT.T(NP+I-1)) GO TO 250
  100 CONTINUE
  110 CONTINUE
C
      DO 130 I=1,5
        DO 120 J=1,N
          W(I,J) = 0.0D0
  120   CONTINUE
  130 CONTINUE
C     SET UP LEFT INTERPOLATION POINT AND LEFT BOUNDARY CONDITION FOR
C     RIGHT LIMITS
      IT = IBCL + 1
      CALL DBSPVD(T, K, IT, X(1), K, 4, VNIKX, WORK)
      IW = 0
      IF (ABS(VNIKX(3,1)).LT.TOL) IW = 1
      DO 140 J=1,3
        W(J+1,4-J) = VNIKX(4-J,IT)
        W(J,4-J) = VNIKX(4-J,1)
  140 CONTINUE
      BCOEF(1) = Y(1)
      BCOEF(2) = FBCL
C     SET UP INTERPOLATION EQUATIONS FOR POINTS I=2 TO I=NDATA-1
      ILEFT = 4
      IF (NDM.LT.2) GO TO 170
      DO 160 I=2,NDM
        ILEFT = ILEFT + 1
        CALL DBSPVD(T, K, 1, X(I), ILEFT, 4, VNIKX, WORK)
        DO 150 J=1,3
          W(J+1,3+I-J) = VNIKX(4-J,1)
  150   CONTINUE
        BCOEF(I+1) = Y(I)
  160 CONTINUE
C     SET UP RIGHT INTERPOLATION POINT AND RIGHT BOUNDARY CONDITION FOR
C     LEFT LIMITS(ILEFT IS ASSOCIATED WITH T(N)=X(NDATA-1))
  170 CONTINUE
      IT = IBCR + 1
      CALL DBSPVD(T, K, IT, X(NDATA), ILEFT, 4, VNIKX, WORK)
      JW = 0
      IF (ABS(VNIKX(2,1)).LT.TOL) JW = 1
      DO 180 J=1,3
        W(J+1,3+NDATA-J) = VNIKX(5-J,IT)
        W(J+2,3+NDATA-J) = VNIKX(5-J,1)
  180 CONTINUE
      BCOEF(N-1) = FBCR
      BCOEF(N) = Y(NDATA)
C     SOLVE SYSTEM OF EQUATIONS
      ILB = 2 - JW
      IUB = 2 - IW
      NWROW = 5
      IWP = IW + 1
      CALL DBNFAC(W(IWP,1), NWROW, N, ILB, IUB, IFLAG)
      IF (IFLAG.EQ.2) GO TO 190
      CALL DBNSLV(W(IWP,1), NWROW, N, ILB, IUB, BCOEF)
      RETURN
C
C
  190 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINT4',
     +   'THE SYSTEM OF EQUATIONS IS SINGULAR', 2, 1)
      RETURN
  200 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINT4', 'NDATA IS LESS THAN 2', 2, 1)
      RETURN
  210 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINT4',
     +   'X VALUES ARE NOT DISTINCT OR NOT ORDERED', 2, 1)
      RETURN
  220 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINT4', 'IBCL IS NOT 1 OR 2', 2, 1)
      RETURN
  230 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINT4', 'IBCR IS NOT 1 OR 2', 2, 1)
      RETURN
  240 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINT4', 'KNTOPT IS NOT 1, 2, OR 3', 2,
     +   1)
      RETURN
  250 CONTINUE
      CALL XERMSG ('SLATEC', 'DBINT4',
     +   'KNOT INPUT THROUGH W ARRAY IS NOT ORDERED PROPERLY', 2, 1)
      RETURN
      END


program main
    use FEMSolverClass
    implicit none

    type(FEMSolver_) :: solver
    type(FEMDomain_),target :: domains(1)
    type(IO_) :: f
    integer(int32) :: i
    real(real64) :: Vs,t,dt,E_Al
    real(real64),allocatable :: Mode_U(:),mode_Ut(:),freq(:),eigen_value(:),eigen_vectors(:,:)
    integer(int32),allocatable :: node_list(:)
    integer(int32),allocatable :: node_list_x(:)
    integer(int32),allocatable :: node_list_y(:)
    integer(int32),allocatable :: node_list_z(:)
    ! Modal analysis
    !Create file or...
    call domains(1)%create("Cube3D",x_num=2,y_num=4,z_num=20)
    call domains(1)%resize(x=1.0d0)
    call domains(1)%resize(y=5.0d0)
    call domains(1)%resize(z=50.0d0)
    call domains(1)%vtk("AlminiumBar")

    !read file
    !call domains(1) % read("mesh.vtk")

    call solver%init(NumDomain=1,NumInterfaceElement=0)
    call solver%setDomain(FEMDomain=domains(1),DomainID=1)
    call solver%setCRS(DOF=3)

    !$OMP parallel do
    do i=1,domains(1)%ne()
        call solver%setMatrix(&
            DomainID=1,&
            ElementID=i,&
            DOF=3,&
            Matrix=domains(1)%MassMatrix(ElementID=i,Density=2.70d0,DOF=3) &
            )
    enddo
    !$OMP end parallel do

    call solver%keepThisMatrixAs("B")
    call solver%zeros()

    print *, "Save Stiffness Matrix"

    E_Al = 70.0d0*1000.0d0!*1000.0d0
    !$OMP parallel do
    do i=1,domains(1)%ne()
        call solver%setMatrix(&
            DomainID=1,&
            ElementID=i,&
            DOF=3,&
            Matrix=domains(1)%StiffnessMatrix(ElementID=i,E=E_Al,v=0.300d0) &
            )
    enddo
    !$OMP end parallel do

    call solver%keepThisMatrixAs("A")

    ! Eigen value problem solver by scipy

    print *, "solver%eig"
    node_list = domains(1)%getNodeList(&
        zmin = domains(1)%zmax() )
    node_list_x =(node_list(:)-1)*3+1
    call solver%fix_eig(IDs=node_list_x)
    node_list_y =(node_list(:)-1)*3+2
    call solver%fix_eig(IDs=node_list_y)
    node_list_z =(node_list(:)-1)*3+3
    call solver%fix_eig(IDs=node_list_z)

    node_list = domains(1)%getNodeList(&
        zmax = domains(1)%zmin() )
    node_list_x =(node_list(:)-1)*3+1
    call solver%fix_eig(IDs=node_list_x)
    node_list_y =(node_list(:)-1)*3+2
    call solver%fix_eig(IDs=node_list_y)
    node_list_z =(node_list(:)-1)*3+3
    call solver%fix_eig(IDs=node_list_z)

    node_list = domains(1)%getNodeList(&
        ymax = domains(1)%ymin() )
    node_list_x =(node_list(:)-1)*3+1
    call solver%fix_eig(IDs=node_list_x)
    node_list_y =(node_list(:)-1)*3+2
    call solver%fix_eig(IDs=node_list_y)
    node_list_z =(node_list(:)-1)*3+3
    call solver%fix_eig(IDs=node_list_z)

    call solver%eig(eigen_value=eigen_value,eigen_vectors=eigen_vectors)

    ! read results
    freq = sqrt(abs(eigen_value))/2.0d0/3.141590d0
    dt = 0.10d0

    ! 20 modes
    do i_i=1,20
        mode_U = zeros(size(eigen_vectors,1))
        mode_U = eigen_vectors(:,i_i)
        dt = 1.0d0/freq(i_i)/100.0d0
        do j_j=1,100
            t = dt * dble(j_j-1)
            mode_Ut = mode_U*cos( 2.0d0*3.140d0*freq(i_i)*t )

            domains(1)%mesh%nodcoord = domains(1)%mesh%nodcoord &
            +10.0d0*reshape(mode_Ut,domains(1)%nn(),3 )

            call domains(1)%vtk("Mode_Fortran_"+str(i_i)+"_t_"+str(j_j))
            domains(1)%mesh%nodcoord = domains(1)%mesh%nodcoord &
            -10.0d0*reshape(mode_Ut,domains(1)%nn(),3 )
        enddo
    enddo

    print *, "Freq (Hz)"
    call print(sqrt(abs(eigen_value(1:30)))/2.0d0/3.141590d0 )

end program main


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                     C
C        SUBROUTINE CALCULATING THE FINITE REAL PART OF THE           C
C          GENERAL MASSIVE TWO POINT FUNCTION                         C
C                                                                     C
C           B02(P.P,M1,M2,MU**2)                                      C
C           BP02(P.P,M1,M2,MU**2)                                     C
C                                                                     C
C        LAST CHANGE:                                                 C
C         24.02.99 [TP] : B02P CASES                                  C
C         28.05.01 [TP] : B(0,M,0)                                    C
C                                                                     C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c ---------------------------------------------------------------------
      real*8 function B02(s,m1,m2,mu2)

      implicit none

      real*8     s,m1,m2,mu2,m12,m22
      complex*16 zkappa,x1,x2

      m12 = m1**2
      m22 = m2**2

      zkappa=sqrt(dcmplx(s**2+m12**2+m22**2
     &                     -2.D0*(s*m12+s*m22+m12*m22)))

      if (s.eq.0.D0) then
         if (m12.eq.m22) then
            B02=-log(m12/mu2)
         else
            if ((m12.ne.0.D0).and.(m22.ne.0.D0)) then
               B02=1.D0 - m12/(m12-m22)*log(m12/mu2)
     &                  + m22/(m12-m22)*log(m22/mu2)
            elseif (m12.eq.0.D0) then
               B02=1.D0 - log(m22/mu2)
            elseif (m22.eq.0.D0) then
               B02=1.D0 - log(m12/mu2)
            end if
         endif
      else
         if ((m12.eq.0.D0).and.(m22.eq.0.D0)) then
            B02=2.D0 - log(s/mu2)
         elseif ((m12.eq.s).and.(m22.eq.0.D0)) then
            B02=2.D0 - log(m12/mu2)
         elseif ((m22.eq.s).and.(m12.eq.0.D0)) then
            B02=2.D0 - log(m22/mu2)
         elseif (m12.eq.0.D0) then
            B02=2.D0 - (s-m22)/s*log( abs(m22-s)/m22 )
     &                 - log(m22/mu2)
         elseif (m22.eq.0.D0) then
            B02=2.D0 - (s-m12)/s*log( abs(m12-s)/m12 )
     &                 - log(m12/mu2)
         else
            x1=dcmplx( (s-m22+m12+zkappa)/(2.D0*s) )
            x2=dcmplx( (s-m22+m12-zkappa)/(2.D0*s) )
            B02=real( 2.D0 + log(mu2/m22)
     &                       + x1*log(1.D0-1.D0/x1)
     &                       + x2*log(1.D0-1.D0/x2))
         endif
      endif

      return
      end

c ---------------------------------------------------------------------
      real*8 function BP02(s,m1,m2,mu2)

      implicit none

      real*8     s,m1,m2,mu2,m12,m22
      complex*16 zkappa,x1,x2

      m12 = m1**2
      m22 = m2**2

      zkappa=sqrt(dcmplx(s**2+m12**2+m22**2
     &                    -2.D0*(s*m12+s*m22+m12*m22)))

      if (s.eq.0.D0) then
         if (m12.eq.m22) then
            BP02=1.D0/(6.D0*m12)
         else
            BP02=( (m12+m22)/2.D0
     &        - m12*m22/(m12-m22)*log(m12/m22) )/(m12-m22)**2
         endif
      elseif ((s.eq.m12).and.(m22.eq.0.D0)) then
         BP02=( -1.D0 + log(m12/mu2)/2.D0 )/m12
      elseif ((s.eq.m22).and.(m12.eq.0.D0)) then
         BP02=( -1.D0 + log(m22/mu2)/2.D0 )/m22
      elseif ((m12.eq.0.D0).and.(m22.ne.0.D0)) then
         BP02=( -1.D0 - m22/s*log(abs(m22-s)/m22) )/s
      elseif ((m22.eq.0.D0).and.(m12.ne.0.D0)) then
         BP02=( -1.D0 - m12/s*log(abs(m12-s)/m12) )/s
      else
         x1=dcmplx( (s-m22+m12+zkappa)/(2.D0*s) )
         x2=dcmplx( (s-m22+m12-zkappa)/(2.D0*s) )
         BP02=real( -1.D0 + ( x1*(1.D0-x1)*log(1.D0-1.D0/x1)
     &                       - x2*(1.D0-x2)*log(1.D0-1.D0/x2) )
     &                                                  /(x1-x2) )/s
      endif

      return
      end


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of SQRT()
module m
  implicit none
  ! +Inf
  real(8), parameter :: inf8 = z'7ff0000000000000'
  logical, parameter :: test_inf8 = sqrt(inf8) == inf8
  ! max finite
  real(8), parameter :: h8 = huge(1.0_8), h8z = z'7fefffffffffffff'
  logical, parameter :: test_h8 = h8 == h8z
  real(8), parameter :: sqrt_h8 = sqrt(h8), sqrt_h8z = z'5fefffffffffffff'
  logical, parameter :: test_sqrt_h8 = sqrt_h8 == sqrt_h8z
  real(8), parameter :: sqr_sqrt_h8 = sqrt_h8 * sqrt_h8, sqr_sqrt_h8z = z'7feffffffffffffe'
  logical, parameter :: test_sqr_sqrt_h8 = sqr_sqrt_h8 == sqr_sqrt_h8z
  ! -0 (sqrt is -0)
  real(8), parameter :: n08 = z'8000000000000000'
  real(8), parameter :: sqrt_n08 = sqrt(n08)
!WARN: division by zero
  real(8), parameter :: inf_n08 = 1.0_8 / sqrt_n08, inf_n08z = z'fff0000000000000'
  logical, parameter :: test_n08 = inf_n08 == inf_n08z
  ! min normal
  real(8), parameter :: t8 = tiny(1.0_8), t8z = z'0010000000000000'
  logical, parameter :: test_t8 = t8 == t8z
  real(8), parameter :: sqrt_t8 = sqrt(t8), sqrt_t8z = z'2000000000000000'
  logical, parameter :: test_sqrt_t8 = sqrt_t8 == sqrt_t8z
  real(8), parameter :: sqr_sqrt_t8 = sqrt_t8 * sqrt_t8
  logical, parameter :: test_sqr_sqrt_t8 = sqr_sqrt_t8 == t8
  ! max subnormal
  real(8), parameter :: maxs8 = z'000fffffffffffff'
  real(8), parameter :: sqrt_maxs8 = sqrt(maxs8), sqrt_maxs8z = z'1fffffffffffffff'
  logical, parameter :: test_sqrt_maxs8 = sqrt_maxs8 == sqrt_maxs8z
  ! min subnormal
  real(8), parameter :: mins8 = z'1'
  real(8), parameter :: sqrt_mins8 = sqrt(mins8), sqrt_mins8z = z'1e60000000000000'
  logical, parameter :: test_sqrt_mins8 = sqrt_mins8 == sqrt_mins8z
  real(8), parameter :: sqr_sqrt_mins8 = sqrt_mins8 * sqrt_mins8
  logical, parameter :: test_sqr_sqrt_mins8 = sqr_sqrt_mins8 == mins8
  ! regression tests: cases near 1.
  real(4), parameter :: sqrt_under1 = sqrt(.96875)
  logical, parameter :: test_sqrt_under1 = sqrt_under1 == .984250962734222412109375
  ! oddball case: the value before 1. is also its own sqrt, but not its own square
  real(4), parameter :: before_1 = z'3f7fffff' ! .999999940395355224609375
  real(4), parameter :: sqrt_before_1 = sqrt(before_1)
  logical, parameter :: test_before_1 = sqrt_before_1 == before_1
  real(4), parameter :: sq_sqrt_before_1 = sqrt_before_1 * sqrt_before_1
  logical, parameter :: test_sq_before_1 = sq_sqrt_before_1 < before_1
end module


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download

program sys_sim5

! Work done during last week of January 2002 (28 Jan init) to investigate
! impacts of sampling error from small ensembles on update for a single
! variable that is exactly observed; applicable to observation variable
! priors. Small sample estimates of variance have approximately normal
! (or is it exactly normal) error distributions. BUT, when one computes
! the updated variance there is a bias. Of course, one must also account
! for the increased uncertainty in the estimate of the mean resulting from
! errors in the computation of the variance.

! This piece looks at what large sample MC gives for correct updated
! distribution statistics in preparation for correcting EAKF for the small
! sample problems.

use random_seq_mod, only : random_seq_type, init_random_seq, random_gaussian, &
   twod_gaussians, random_uniform

implicit none

type (random_seq_type) :: r
double precision, allocatable :: rnum(:)
double precision :: sigma_y_p, y_p, sigma_y_o, y_o, var_of_var
double precision :: sum_mean, sum_mean_2, sum_var, var, sigma_y_u
double precision :: y_u, sample_mean, sample_var, inf_var, inf_u
double precision :: temp_mean, pre_var_sum, mean_var
integer :: n, n_samples, i, j

! Initialize repeatable random sequence
call init_random_seq(r)

! For now have a set of free parameters that may be too large
write(*, *) 'Input prior variance of observation variable'
read(*, *) sigma_y_p
write(*, *) 'Input prior value of observation variable'
read(*, *) y_p
write(*, *) 'Input variance of observing instrument'
read(*, *) sigma_y_o
write(*, *) 'input value of observation '
read(*, *) y_o
write(*, *) 'Input ensemble size'
read(*, *) n

write(*, *) 'Input number of samples for statistics'
read(*, *) n_samples

! Allocate storage for computing sample variance
allocate(rnum(n))

! Compute the variance of the variance distribution
var_of_var = 2.0 * sigma_y_p**4 / (n - 1.0)

write(*, *) 'var and var of var', real(sigma_y_p), real(var_of_var)

! Initialize summations
sum_mean = 0.0
sum_mean_2 = 0.0
sum_var = 0.0
pre_var_sum = 0.0

! Loop through the number of samples
do i = 1, n_samples

! We are given the sample variance, what is a sample of the underlying
! variance distribution
! Could do this from distribution, but it doesn't apply for small samples
!!!   var = random_gaussian(r, sigma_y_p, sqrt(var_of_var))

! Compute the sample variance for this ensemble size
   do j = 1, n
      rnum(j) =  random_gaussian(r, dble(0.0), sqrt(sigma_y_p))
   end do

! Compute the sample variance
   call sample_mean_var(rnum, n, temp_mean, var)

   pre_var_sum = pre_var_sum + var

! Given this var, compute updated var and mean
   sigma_y_u = (1.0 / (1.0 / var + 1.0 / sigma_y_o))
   y_u = sigma_y_u * (y_p / var + y_o / sigma_y_o)

if(var < 0.0) write(*, *) 'var is , y_u, si', real(var), real(y_u), real(sigma_y_u)

! Need to keep sum of the means, sum of the mean squared, sum of the var
   sum_mean = sum_mean + y_u
   sum_mean_2 = sum_mean_2 + (y_u)**2
   sum_var = sum_var + sigma_y_u

end do

! Output the mean and variance corresponding to finite sample
! See working notes, 29 Jan 2002
sample_mean = sum_mean / n_samples
sample_var = (SUM_var + sum_mean_2) / n_samples - sample_mean**2
write(*, *) 'sample mean and var ', real(sample_mean), real(sample_var)

! What would happen without these assumptions
inf_var = (1.0 / (1.0 / sigma_y_p + 1.0 / sigma_y_o))
inf_u = inf_var * (y_p / sigma_y_p + y_o / sigma_y_o)
write(*, *) 'infini mean and var ', real(inf_u), real(INF_var)

mean_var = sum_var / n_samples
write(*, *) 'mean var i s ', real(mean_var)
write(*, *) 'pre mean var ', real(pre_var_sum / n_samples)

write(*, *) '-----------------'
write(*, *) 'normalized sample var - mean var ', real((sample_var - sum_var / n_samples) / (y_o - y_p)**2)
write(*, *) 'ratio of mean_var to prior var ', real(mean_var /sigma_y_p)
write(*, *) 'fraction of movement ', real((sample_mean - y_o) / (y_p - y_o))
write(*, *) 'expected fraction of movement ', real((inf_u - y_o) / (y_p - y_o))

end program sys_sim5

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

subroutine comp_correl(ens, n, correl)

implicit none

integer, intent(in) :: n
double precision, intent(in) :: ens(2, n)
double precision, intent(out) :: correl
double precision :: sum_x, sum_y, sum_xy, sum_x2, sum_y2

sum_x = sum(ens(2, :))
sum_y = sum(ens(1, :))
sum_xy = sum(ens(2, :) * ens(1, :))
sum_x2 = sum(ens(2, :) * ens(2, :))

! Computation of correlation
sum_y2 = sum(ens(1, :) * ens(1, :))

correl = (n * sum_xy - sum_x * sum_y) / &
   sqrt((n * sum_x2 - sum_x**2) * (n * sum_y2 - sum_y**2))

end subroutine comp_correl

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

subroutine sample_mean_var(x, n, mean, var)

implicit none

integer, intent(in) :: n
double precision, intent(in) :: x(n)
double precision, intent(out) :: mean, var

double precision :: sx, s_x2

sx = sum(x)
s_x2 = sum(x * x)
mean = sx / n
var = (s_x2 - sx**2 / n) / (n - 1)

end subroutine sample_mean_var


program uranium
! Calculates Hydrogen like relativistic energies for Z=92 (U)
!
! The purpose of this test is to check that:
! a) all U energies can converge to 1e-6
! b) that it converges when using very rough initial estimate
use dftatom
implicit none

! Atomic number:
integer, parameter :: Z = 92
! Mesh parameters:
real(dp), parameter :: r_min = 1e-8_dp, r_max = 50.0_dp, a = 6.2e7_dp
integer, parameter :: NN = 4500

real(dp), parameter :: c = 137.035999037_dp, eps = 5e-7_dp
integer :: n, l, relat, converged, relat_max
real(dp) :: r(NN+1), u(size(r)), Ein, E, E_exact, error, P(size(r)), Q(size(r))
real(dp) :: Rp(NN+1)

r = mesh_exp(r_min, r_max, a, NN)
Rp = mesh_exp_deriv(r_min, r_max, a, NN)
u(:) = -Z/r

print *, "Hydrogen like relativistic energies for Z=92 (U)"
print *, "Mesh parameters (r_min, r_max, a, N):"
print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
print *
print "(A3, A3, A3, A15, A15, A10)", "n", "l", "k", "E", "E_exact", "Error"
print *
do n = 1, 7
    do l = 0, n-1
        if (l == 0) then
            relat_max = 2
        else
            relat_max = 3
        end if
        do relat = 2, relat_max
            E_exact = E_nl(c, n, l, Z, relat)
            Ein = -100
            call solve_radial_eigenproblem(n, l, Ein, eps, 100, R, Rp, u, &
                Z, c, relat, .true., -10000._dp, 0._dp,  converged, E, P, Q)
            error = abs(E - E_exact)
            if (converged /= 0) call stop_error("Not converged")
            print "(I3, I3, I3, F15.6, F15.6, ES10.2)", n, l, relat-2, &
                E, E_exact, error
            if (error > 1e-6_dp) call stop_error("Error is higher than 1e-6")
        end do
    end do
end do
end program


      function hru_erfc(xx)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    erfc is the complementary error function;
!!    erf(B) is the error function for B
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Abs

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      implicit none

      real, parameter :: c1 = .19684             !              |
      real, parameter :: c2 = .115194            !              |
      real, parameter :: c3 = .00034             !              |
      real, parameter :: c4 = .019527            !              |
      real, intent (in) :: xx                    !              |
      real :: x                                  !none          |variable to hold intermediate
                                                 !              |calculation result
      real :: erf                                !              |
      real :: hru_erfc                           !              |

      x = 0.
      erf = 0.
      hru_erfc = 0.

      x = Abs(1.4142 * xx)
      erf = 1. - (1. + c1 * x + c2 * x * x + c3 * x**3 + c4 * x**4) **  (-4)
      if (xx < 0.) erf = -erf

      hru_erfc = 1. - erf

      return
      end function


module kramers_kronig
    use constants, only: zero, real12, cmplx_zero, cmplx_i, fatal_error_from_call
    use definedtypes
    use greensroutines
    use one_dimensional_FT, only: oneD_fft, forward_fft, backward_fft

    implicit none
    private
    public hilbert_transform

contains

    pure subroutine hilbert_transform(input, result, ierr)
        real(real12), intent(in) :: input(:)
        real(real12), intent(out) :: result(:)
        integer, intent(out) :: ierr

        complex(real12) :: full_freq(2*size(input)), positive_only(size(input))
        integer :: ierr1

        ierr = 0
        if (size(input) /= size(result)) ierr = 1
        if (ierr /= 0) return

        positive_only = cmplx_zero
        positive_only(1:size(input))%re = input(1:size(input))
        full_freq(1:size(input)) = conjg(positive_only(size(input):1)) ! impose negative frequency condition
        full_freq(size(input) + 1:2*size(input)) = positive_only(1:size(input))

        ! Hilbert transform (AIP Advances *2*, 032144 (2012) eqn (6))
        call oneD_fft(full_freq, forward_fft, ierr1)
        full_freq = cmplx_i*full_freq
        full_freq(1:size(input)) = -full_freq(1:size(input))
        call oneD_fft(full_freq, backward_fft, ierr1)

        result = full_freq(size(input) + 1:2*size(input))%re

    end subroutine hilbert_transform

end module


program fisher_estimate

  USE healpix_types

	implicit none
	integer(i4b)::i,jlo,l
	integer,parameter :: lmax=3500
	real(dp), parameter ::fsky=1d0,thetaFWHM=1d0*0.000290888209d0
	real(dp), allocatable, dimension(:,:)::Cl
	real(dp), allocatable, dimension(:):: xa,ya,y2a,deltaCl,deltaCl_pol,y_pol,y_pol2,x_pol !! variable for spline the TT spectrum and EE
	character(len=128) :: filename
	integer  :: ios,err,istat
	real(dp)::logCl,logCl_pol,fisher,fisher_pol, variance,variance_pol
	filename='/Users/alessandromanzotti/Downloads/camb/test_scal2Cls.dat'

	open(unit=10, file=filename, iostat=ios, &
             status="old", action="read", form='formatted')

	if ( ios /= 0 ) stop "Error opening file name"
	allocate(cl(lmax,4), stat=err)
	if (err /= 0) print *, "array: Allocation request denied"
	allocate(xa(lmax),ya(lmax),y2a(lmax),deltaCl(lmax),y_pol(lmax),y_pol2(lmax),deltaCl_pol(lmax) ,stat=err)
	if (err /= 0) print *, "array: Allocation request denied"
	!! read the Cl from camb

	do i = 1, lmax, 1

		read(10, *) cl(i,1),cl(i,2),cl(i,3)
		if ( istat /= 0 ) stop "Read error in file 10"

	end do

!	write(*,*) cl(10,1),cl(10,2)

!! normalize CAMB
	do i = 1, lmax, 1
		l=cl(i,1)
		cl(i,2)=cl(i,2)*(twopi/(l*(l+1)))/(7.4311e12)
		cl(i,3)=cl(i,3)*(twopi/(l*(l+1)))/(7.4311e12)

	end do
	write(*,*) cl(10,1),cl(10,2),cl(10,3)

	!!! spline the TT spectrum

	xa=log(cl(:,1)) !log(l)
	ya=log(cl(:,1)**2*cl(:,2)) !log (l^2 Cl)
	call spline(xa,ya,lmax,1.d30,1.d30,y2a)

!!! spline the EE spectrum

	xa=log(cl(:,1)) !log(l)
	y_pol=log(cl(:,1)**2*cl(:,3)) !log (l^2 CEE)
        write(*,*) shape(y_pol),shape(xa),shape(y_pol2)
	call spline(xa,y_pol,lmax,1.d30,1.d30,y_pol2)

!	write(*,*) shape(y2a),y2a(10)
	write(*,*) 'power spectrum TT&EE splined'
!	logCl=logl2Cl(10._dp)
!	write(*,*) 'power spectrum splined'!,logl2Cl(11._dp),dlnl2Cldlogl(11d0)

	!!! prepare for fishere elements, compute deltaCl

	!!! deltaCl=sqrt(2/(2l+1)fsky) (Cl+Nl) we need delta cl squared

	do i = 1, lmax, 1
           l=cl(i,1)
           !deltaCl(i)=(2d0/((2*cl(i,1)+1)*fsky))*(cl(i,2)+((4d-6)*(3.1415926535d0/10800))**2*exp(l*(l+1)*((thetaFWHM)**2)/(8d0*log(2d0))))**2 !! add noise
           deltaCl(i)=(2d0/((2*cl(i,1)+1)))*(cl(i,2))**2 !! no noise
           deltaCl_pol(i)=(2d0/((2*cl(i,1)+1)))*(cl(i,3))**2 !! no noise POL

	end do

        !! COMPUTE OUTPUT ANS PRINT
        open(unit=30, file='variancenonoisenofsky_fisher.txt')

!! fisher elements  sum_l 1/deltaC (deriv)^2
	fisher=0d0
	do i = 1, lmax, 1
		write(*,*) fisher
		fisher=fisher+(1/deltaCl(i))*(dlnl2Cldlogl(DBLE(i)))**2*(cl(i,2))**2
		write(30,*) cl(i,1),1/fisher

	end do
        close(30)
!! now get variance of the parameter from  fisher

        open(unit=60, file='variancenonoisenofsky_fisher_pol.txt')
        fisher_pol=0d0
	do i = 1, lmax, 1
	!	write(*,*) fisher
		fisher_pol=fisher_pol+(1/deltaCl_pol(i))*(dlnl2Cldlogl_pol(DBLE(i)))**2*(cl(i,3))**2
		write(60,*) cl(i,1),1/fisher_pol

	end do
        close(60)

	open(unit=20, file='derivatives.txt')

	do i = 1, lmax, 1

		write(20,*) cl(i,1),dlnl2Cldlogl(DBLE(i)),logl2Cl(dble(i))

	end do
	close(unit=20)

	open(unit=20, file='derivatives_pol.txt')

	do i = 1, lmax, 1

		write(20,*) cl(i,1),dlnl2Cldlogl_pol(DBLE(i)),logl2Cl_pol(dble(i))

	end do
	close(unit=20)

	variance=(1/fisher)

	write(*,*) 'your variance is sigma=',variance

	if (allocated(cl)) deallocate(cl, stat=err)
	if (err /= 0) print *, "array: Deallocation request denied"

	Contains

		!!! the two functions to get lnl2Cl from spline

real(DP) FUNCTION logl2Cl(ak)
  IMPLICIT none
  real(dp) :: a,b,h,x,y,ak
  x  = log(ak)
  CALL hunt(xa,lmax,x,jlo)
  h=xa(jlo+1)-xa(jlo)
  a=(xa(jlo+1)-x)/h
  b=(x-xa(jlo))/h
  y=a*ya(jlo)+b*ya(jlo+1)+((a**3-a)*y2a(jlo)+(b**3-b)*y2a(jlo+1))*(h**2)/6.
  logl2Cl = y
  100 return
END FUNCTION logl2Cl

	real(DP) FUNCTION logl2Cl_pol(ak)
  IMPLICIT none
  real(dp) :: a,b,h,x,y,ak
  x  = log(ak)
  CALL hunt(xa,lmax,x,jlo)
  h=xa(jlo+1)-xa(jlo)
  a=(xa(jlo+1)-x)/h
  b=(x-xa(jlo))/h
  y=a*y_pol(jlo)+b*y_pol(jlo+1)+((a**3-a)*y_pol2(jlo)+(b**3-b)*y_pol2(jlo+1))*(h**2)/6.
  logl2Cl_pol = y
  100 return
END FUNCTION logl2Cl_pol

DOUBLE PRECISION FUNCTION dlnl2Cldlogl(ak)
  IMPLICIT none
  DOUBLE PRECISION :: a,b,h,x,y,ak
  x  = log(ak)
  CALL hunt(xa,lmax,x,jlo)
  h=xa(jlo+1)-xa(jlo)
  a=(xa(jlo+1)-x)/h
  b=(x-xa(jlo))/h
  y=(ya(jlo+1)-ya(jlo))/h+(-(3.*a**2-1.)*y2a(jlo)+(3.*b**2-1.)*y2a(jlo+1))*h/6.
  dlnl2Cldlogl = y
  return
	END FUNCTION dlnl2Cldlogl

DOUBLE PRECISION FUNCTION dlnl2Cldlogl_pol(ak)
  IMPLICIT none
  DOUBLE PRECISION :: a,b,h,x,y,ak
  x  = log(ak)
  CALL hunt(xa,lmax,x,jlo)
  h=xa(jlo+1)-xa(jlo)
  a=(xa(jlo+1)-x)/h
  b=(x-xa(jlo))/h
  y=(y_pol(jlo+1)-y_pol(jlo))/h+(-(3.*a**2-1.)*y_pol2(jlo)+(3.*b**2-1.)*y_pol2(jlo+1))*h/6.
  dlnl2Cldlogl_pol = y
  return
END FUNCTION dlnl2Cldlogl_pol

	end program fisher_estimate


      DOUBLE PRECISION FUNCTION dstrem(z)
      IMPLICIT DOUBLE PRECISION (a-h,o-p,r-z),INTEGER (i-n),LOGICAL (q)
C**********************************************************************
C
C     DOUBLE PRECISION FUNCTION DSTREM( Z )
C             Double precision Sterling Remainder
C
C
C                              Function
C
C
C     Returns   Log(Gamma(Z))  -  Sterling(Z)  where   Sterling(Z)  is
C     Sterling's Approximation to Log(Gamma(Z))
C
C     Sterling(Z) = LOG( SQRT( 2*PI ) ) + ( Z-0.5 ) * LOG( Z ) - Z
C
C
C                              Arguments
C
C
C     Z --> Value at which Sterling remainder calculated
C           Must be positive.
C                  DOUBLE PRECISION Z
C
C
C                              Method
C
C
C
C     If Z >= 6 uses 9 terms of series in Bernoulli numbers
C     (Values calculated using Maple)
C     Otherwise computes difference explicitly
C
C**********************************************************************

C     .. Parameters ..
      DOUBLE PRECISION hln2pi
      PARAMETER (hln2pi=0.91893853320467274178D0)
      INTEGER ncoef
      PARAMETER (ncoef=10)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION z
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION sterl
C     ..
C     .. Local Arrays ..
      DOUBLE PRECISION coef(ncoef)
C     ..
C     .. External Functions ..
      DOUBLE PRECISION devlpl,dlngam
      EXTERNAL devlpl,dlngam
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC log
C     ..
C     .. Data statements ..
      DATA coef/0.0D0,0.0833333333333333333333333333333D0,
     +     -0.00277777777777777777777777777778D0,
     +     0.000793650793650793650793650793651D0,
     +     -0.000595238095238095238095238095238D0,
     +     0.000841750841750841750841750841751D0,
     +     -0.00191752691752691752691752691753D0,
     +     0.00641025641025641025641025641026D0,
     +     -0.0295506535947712418300653594771D0,
     +     0.179644372368830573164938490016D0/
C     ..
C     .. Executable Statements ..

C    For information, here are the next 11 coefficients of the
C    remainder term in Sterling's formula
C            -1.39243221690590111642743221691
C            13.4028640441683919944789510007
C            -156.848284626002017306365132452
C            2193.10333333333333333333333333
C            -36108.7712537249893571732652192
C            691472.268851313067108395250776
C            -0.152382215394074161922833649589D8
C            0.382900751391414141414141414141D9
C            -0.108822660357843910890151491655D11
C            0.347320283765002252252252252252D12
C            -0.123696021422692744542517103493D14
C

      IF (z.LE.0.0D0) STOP 'Zero or negative argument in DSTREM'
      IF (.NOT. (z.GT.6.0D0)) GO TO 10
      dstrem = devlpl(coef,10,1.0D0/z**2)*z
      GO TO 20

   10 sterl = hln2pi + (z-0.5D0)*log(z) - z
      dstrem = dlngam(z) - sterl
   20 RETURN

      END


      SUBROUTINE MB04MD( N, MAXRED, A, LDA, SCALE, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce the 1-norm of a general real matrix A by balancing.
C     This involves diagonal similarity transformations applied
C     iteratively to A to make the rows and columns as close in norm as
C     possible.
C
C     This routine can be used instead LAPACK Library routine DGEBAL,
C     when no reduction of the 1-norm of the matrix is possible with
C     DGEBAL, as for upper triangular matrices. LAPACK Library routine
C     DGEBAK, with parameters ILO = 1, IHI = N, and JOB = 'S', should
C     be used to apply the backward transformation.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     MAXRED  (input/output) DOUBLE PRECISION
C             On entry, the maximum allowed reduction in the 1-norm of
C             A (in an iteration) if zero rows or columns are
C             encountered.
C             If MAXRED > 0.0, MAXRED must be larger than one (to enable
C             the norm reduction).
C             If MAXRED <= 0.0, then the value 10.0 for MAXRED is
C             used.
C             On exit, if the 1-norm of the given matrix A is non-zero,
C             the ratio between the 1-norm of the given matrix and the
C             1-norm of the balanced matrix. Usually, this ratio will be
C             larger than one, but it can sometimes be one, or even less
C             than one (for instance, for some companion matrices).
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the input matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the balanced matrix.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     SCALE   (output) DOUBLE PRECISION array, dimension (N)
C             The scaling factors applied to A.  If D(j) is the scaling
C             factor applied to row and column j, then SCALE(j) = D(j),
C             for j = 1,...,N.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit.
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Balancing consists of applying a diagonal similarity
C     transformation inv(D) * A * D to make the 1-norms of each row
C     of A and its corresponding column nearly equal.
C
C     Information about the diagonal matrix D is returned in the vector
C     SCALE.
C
C     REFERENCES
C
C     [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1997.
C     Supersedes Release 2.0 routine MB04AD by T.W.C. Williams,
C     Kingston Polytechnic, United Kingdom, October 1984.
C     This subroutine is based on LAPACK routine DGEBAL, and routine
C     BALABC (A. Varga, German Aerospace Research Establishment, DLR).
C
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Balancing, eigenvalue, matrix algebra, matrix operations,
C     similarity transformation.
C
C  *********************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
      DOUBLE PRECISION   SCLFAC
      PARAMETER          ( SCLFAC = 1.0D+1 )
      DOUBLE PRECISION   FACTOR, MAXR
      PARAMETER          ( FACTOR = 0.95D+0, MAXR = 10.0D+0 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, N
      DOUBLE PRECISION   MAXRED
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), SCALE( * )
C     ..
C     .. Local Scalars ..
      LOGICAL            NOCONV
      INTEGER            I, ICA, IRA, J
      DOUBLE PRECISION   ANORM, C, CA, F, G, MAXNRM, R, RA, S, SFMAX1,
     $                   SFMAX2, SFMIN1, SFMIN2, SRED
C     ..
C     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE, IDAMAX
C     ..
C     .. External Subroutines ..
      EXTERNAL           DSCAL, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Test the scalar input arguments.
C
      INFO  = 0
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( MAXRED.GT.ZERO .AND. MAXRED.LT.ONE ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04MD', -INFO )
         RETURN
      END IF
C
      IF( N.EQ.0 )
     $   RETURN
C
      DO 10 I = 1, N
         SCALE( I ) = ONE
   10 CONTINUE
C
C     Compute the 1-norm of matrix A and exit if it is zero.
C
      ANORM = DLANGE( '1-norm', N, N, A, LDA, SCALE )
      IF( ANORM.EQ.ZERO )
     $   RETURN
C
C     Set some machine parameters and the maximum reduction in the
C     1-norm of A if zero rows or columns are encountered.
C
      SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
      SFMAX1 = ONE / SFMIN1
      SFMIN2 = SFMIN1*SCLFAC
      SFMAX2 = ONE / SFMIN2
C
      SRED = MAXRED
      IF( SRED.LE.ZERO ) SRED = MAXR
C
      MAXNRM = MAX( ANORM/SRED, SFMIN1 )
C
C     Balance the matrix.
C
C     Iterative loop for norm reduction.
C
   20 CONTINUE
      NOCONV = .FALSE.
C
      DO 80 I = 1, N
         C = ZERO
         R = ZERO
C
         DO 30 J = 1, N
            IF( J.EQ.I )
     $         GO TO 30
            C = C + ABS( A( J, I ) )
            R = R + ABS( A( I, J ) )
   30    CONTINUE
         ICA = IDAMAX( N, A( 1, I ), 1 )
         CA = ABS( A( ICA, I ) )
         IRA = IDAMAX( N, A( I, 1 ), LDA )
         RA = ABS( A( I, IRA ) )
C
C        Special case of zero C and/or R.
C
         IF( C.EQ.ZERO .AND. R.EQ.ZERO )
     $      GO TO 80
         IF( C.EQ.ZERO ) THEN
            IF( R.LE.MAXNRM)
     $         GO TO 80
            C = MAXNRM
         END IF
         IF( R.EQ.ZERO ) THEN
            IF( C.LE.MAXNRM )
     $         GO TO 80
            R = MAXNRM
         END IF
C
C        Guard against zero C or R due to underflow.
C
         G = R / SCLFAC
         F = ONE
         S = C + R
   40    CONTINUE
         IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.
     $       MIN( R, G, RA ).LE.SFMIN2 )GO TO 50
         F = F*SCLFAC
         C = C*SCLFAC
         CA = CA*SCLFAC
         R = R / SCLFAC
         G = G / SCLFAC
         RA = RA / SCLFAC
         GO TO 40
C
   50    CONTINUE
         G = C / SCLFAC
   60    CONTINUE
         IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.
     $       MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 70
         F = F / SCLFAC
         C = C / SCLFAC
         G = G / SCLFAC
         CA = CA / SCLFAC
         R = R*SCLFAC
         RA = RA*SCLFAC
         GO TO 60
C
C        Now balance.
C
   70    CONTINUE
         IF( ( C+R ).GE.FACTOR*S )
     $      GO TO 80
         IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
            IF( F*SCALE( I ).LE.SFMIN1 )
     $         GO TO 80
         END IF
         IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
            IF( SCALE( I ).GE.SFMAX1 / F )
     $         GO TO 80
         END IF
         G = ONE / F
         SCALE( I ) = SCALE( I )*F
         NOCONV = .TRUE.
C
         CALL DSCAL( N, G, A( I, 1 ), LDA )
         CALL DSCAL( N, F, A( 1, I ), 1 )
C
   80 CONTINUE
C
      IF( NOCONV )
     $   GO TO 20
C
C     Set the norm reduction parameter.
C
      MAXRED = ANORM/DLANGE( '1-norm', N, N, A, LDA, SCALE )
C
      RETURN
C *** End of MB04MD ***
      END


MODULE interpolation_functions
! Module containing functions necessary for 3DInterpolation
CONTAINS
INTEGER FUNCTION fact(n)
      ! Retruns the factorial of n
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: n
      INTEGER p,i
      p = 1
      do i = 1, n
	    p = p * i
      end do
      fact = p
END FUNCTION fact

! Returns the inverse of a matrix calculated by finding the LU
! decomposition.  Depends on LAPACK.
function inv(A) result(Ainv)
IMPLICIT NONE
  INTEGER, PARAMETER :: dp = selected_real_kind(15, 307)
  real(KIND=dp), dimension(:,:), intent(in) :: A
  real(KIND=dp), dimension(size(A,1),size(A,2)) :: Ainv

  real(KIND=dp), dimension(size(A,1)) :: work  ! work array for LAPACK
  integer, dimension(size(A,1)) :: ipiv   ! pivot indices
  integer :: N,M,info,i
  ! External procedures defined in LAPACK
  external DGETRF
  external DGETRI

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

  M = size(A,1)
  N = size(A,2)

  ! DGETRF computes an LU factorization of a general M-by-N matrix A
  ! using partial pivoting with row interchanges.
  call DGETRF(M, N, Ainv, M, 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(M, Ainv, M, ipiv, work, M, info)

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


module calculations
    use input
    use global_variables
    implicit none
    contains

    subroutine calc
        implicit none
        double precision :: sum1
        integer :: i,j,k

        allocate(N_result(N_modes,nlines))
        allocate(v_result(N_modes,nlines))
        allocate(t_result(nlines))
        allocate(N_total(nlines))
        allocate(dp_g(nlines))
        allocate(v_g(nlines))
        allocate(sigma_g(nlines))
        allocate(M(2*(N_modes+1)))

        OPEN(unit = 15, file = "results_raw.dat")
		    DO i = 1,nlines
			    READ(15,*)M
                t_result(i) = M(1)
                DO j = 1,N_modes
                    N_result(j,i) = M(2*j);
                    v_result(j,i) = M(2*j+1)/M(2*j);
                END DO

                !!! Geometric Mean Diameter Calculation
                sum1 = 0
                N_total(i) = 0
                DO k = 1,N_modes
                    sum1 = sum1 + N_result(k,i)*log(v_result(k,i))
                    N_total(i) = N_total(i) + N_result(k,i)
                END DO

                v_g(i) = exp((1/N_total(i))*(sum1))
                dp_g(i) = (6*v_g(i)/PI)**(1.0/3)

                !!! Geometric Std. Deviation Calculation
                sum1 = 0
                DO k = 1,N_modes
                    sum1 = sum1 + N_result(k,i)*((log((6*v_result(k,i)/PI)**(1.0/3))-log(dp_g(i)))**2.0)/(N_total(i)-1)
                END DO
                sigma_g(i) = exp(sum1**(0.5))
		    END DO
		CLOSE (unit = 15)

        OPEN(UNIT=7, FILE = 'results.dat')
         WRITE(7,*)"  t (s)       ", "N_total (#/m3)", "  dp_g (m)    ", "  sigma_g"
            DO i = 1,nlines
                WRITE(7,67) time(i), N_total(i), dp_g(i), sigma_g(i)
            END DO
        67  FORMAT(100E14.6)

    end subroutine calc
end module calculations


! =============================================================================
!           Module to compute 1D derivatives of Fourier series
! =============================================================================
module deriv1d
    use constants, only : pi, zero
    implicit none

    contains

        subroutine init_deriv(n, l, k)
            integer,          intent(in)  :: n
            double precision, intent(in)  :: l
            double precision, intent(out) :: k(n)
            double precision              :: sc
            integer                       :: i

            ! define wavenumber array:
            if (l .ne. zero) then
                ! define wavenumbers:
                sc = pi / l
                do i = 1, n
                    k(i) = sc * dble(i)
                enddo
            else
                ! catastrophic end to run if wave number definition fails:
                write(*,*) '**********************************************'
                write(*,*) ' Wavenumber array definition not possible.'
                write(*,*) ' Domain length equal to zero not allowed.'
                write(*,*) ' STOPPING...'
                write(*,*) '**********************************************'
                stop
            endif
        end subroutine

        ! Calculates m derivatives of length n for the array var(m,n)
        ! and stores the result in der(m,n).
        ! *** Both var and der are assumed to be Fourier ***
        !   *** coeffiecients in their second argument ***
        subroutine deriv(m, n, k, var, der)
            integer,          intent(in)  :: m, n
            double precision, intent(in)  :: k(n), var(m,n)
            double precision, intent(out) :: der(m,n)
            integer                       :: nw, np2, i, j, ic
            double precision              :: ktmp

            nw = n / 2
            np2 = n + 2

            ! Carry out differentiation by wavenumber multiplication:
            do j=1,m
                der(j, 1) = zero
            enddo

            do i = 2, n - nw
                ktmp = k(2*(i-1))
                ic = np2 - i
                do j = 1, m
                    der(j, i) = -ktmp * var(j,ic)
                    der(j,ic) =  ktmp * var(j ,i)
                enddo
            enddo

            if (mod(n,2) == 0) then
                ic=nw+1
                do j = 1, m
                    der(j,ic) = zero
                enddo
            endif
        end subroutine

        ! Calculates m derivatives of length n for the array var(m,n)
        ! and stores the result in der(m,n), where var is represented by a
        ! cosine series. Note der is therefore a sine series.
        ! *** Both var and der are assumed to be Fourier ***
        !   *** coeffiecients in their second argument ***
        subroutine deriv_c(m, n, k, var, der)
            integer,          intent(in)  :: m, n
            double precision, intent(in)  :: k(n), var(m,0:n)
            double precision, intent(out) :: der(m,n)
            integer                       :: i, j
            double precision              :: ktmp

            ! Carry out differentiation by wavenumber multiplication:
            do i = 1, n-1
                ktmp = -k(i)
                do j = 1, m
                    der(j,i) = ktmp * var(j,i)
                enddo
            enddo

            do j = 1, m
                der(j, n) = zero
            enddo
        end subroutine

        ! Calculates m derivatives of length n for the array var(m,n)
        ! and stores the result in der(m,n), where var is represented by a
        ! sine series. Note der is therefore a cosine series.
        ! *** Both var and der are assumed to be Fourier ***
        !   *** coeffiecients in their second argument ***
        subroutine deriv_s(m, n, k, var, der)
            integer,          intent(in)  :: m,n
            double precision, intent(in)  :: k(n), var(m,n)
            double precision, intent(out) :: der(m, 0:n)
            integer                       :: i, j
            double precision              :: ktmp

            ! Carry out differentiation by wavenumber multiplication:
            do i = 1, n-1
                ktmp = k(i)
                do j = 1, m
                    der(j,i) = ktmp * var(j,i)
                enddo
            enddo

            do j = 1, m
                der(j, 0) = zero
                der(j, n) = zero
            enddo
        end subroutine
end module


!*********************************************************
!>
! Integration Functions:
!
!  * Gauss-Legendre Integration:

module integration
  implicit none

  private
  integer, parameter :: dp = kind(0.d0)
  real(dp) :: glx128(64), glw128(64)
  real(dp) :: glx512(256), glw512(256)
  real(dp) :: glx1024(512), glw1024(512)
  real(dp) :: g30k61_gx(15), g30k61_gw(15), g30k61_kx(31), g30k61_kw(31)

  public :: readGLParameters
  public :: gaussLegendre, gaussLegendreCmplx
  public :: readGKParameters

contains

  subroutine readGLParameters()
    implicit none
    integer :: i

    open(unit=1,file='data/gl128.dat',status='old')
    do i=1,64
      read(1,*) glx128(i), glw128(i)
    end do
    close(1)
    open(unit=1,file='data/gl512.dat',status='old')
    do i=1,256
      read(1,*) glx512(i), glw512(i)
    end do
    close(1)
    open(unit=1,file='data/gl1024.dat',status='old')
    do i=1,512
      read(1,*) glx1024(i), glw1024(i)
    end do
    close(1)
  end subroutine

  subroutine readGKParameters()
    implicit none
    integer :: i, numLines

    open(unit=1,file='data/g30k61.dat',status='old')
    read(1,*) numLines
    do i=1,numLines
      read(1,*) g30k61_gx(i), g30k61_gw(i)
    end do
    read(1,*) numLines
    do i=1,numLines
      read(1,*) g30k61_kx(i), g30k61_kw(i)
    end do
    close(1)
  end subroutine

  real(dp) function gaussLegendre(f,a,b,n,consts)
    implicit none
    integer :: i, n
    real(dp) :: consts(n), a, b, t0, dt, sumIntegral
    interface
      function f(n,c,x)
        integer, parameter :: dp = kind(0.d0)
        integer :: n
        real(dp) :: c(n), x, f
      end function f
    end interface

    t0 = (a+b)/2.d0
    dt = (b-a)/2.d0
    sumIntegral = 0.d0

    ! Using glx128 and glw128
    do i=64,1,-1
      sumIntegral = sumIntegral+glw128(i)*f(n,consts,t0-dt*glx128(i))
    end do
    do i=1,64
      sumIntegral = sumIntegral+glw128(i)*f(n,consts,t0+dt*glx128(i))
    end do

    ! Using glx512 and glw512
    ! do i=256,1,-1
    !   sumIntegral = sumIntegral+glw512(i)*f(n,consts,t0-dt*glx512(i))
    ! end do
    ! do i=1,256
    !    sumIntegral = sumIntegral+glw512(i)*f(n,consts,t0+dt*glx512(i))
    ! end do

    ! Using glx1024 and glw1024
    ! do i=512,1,-1
    !   sumIntegral = sumIntegral+glw1024(i)*f(n,consts,t0-dt*glx1024(i))
    ! end do
    ! do i=1,512
    !   sumIntegral = sumIntegral+glw1024(i)*f(n,consts,t0+dt*glx1024(i))
    ! end do
    gaussLegendre = sumIntegral*dt
  end function

  complex(dp) function gaussLegendreCmplx(f,a,b,n,consts)
    implicit none
    integer :: i, n
    real(dp) :: a, b, t0, dt, sumReal, sumCmplx
    complex(dp) :: consts(n)
    interface
      function f(n,c,x)
        integer, parameter :: dp = kind(0.d0)
        integer :: n
        real(dp) :: x
        complex(dp) :: c(n), f
      end function
    end interface

    t0 = (a+b)/2.d0
    dt = (b-a)/2.d0
    sumReal = 0.d0
    sumCmplx = 0.d0

    ! Using glx128 and glw128
    do i=64,1,-1
      sumReal = sumReal+glw128(i)*real(f(n,consts,t0-dt*glx128(i)))
      sumCmplx = sumCmplx+glw128(i)*aimag(f(n,consts,t0-dt*glx128(i)))
    end do
    do i=1,64
      sumReal = sumReal+glw128(i)*real(f(n,consts,t0+dt*glx128(i)))
      sumCmplx = sumCmplx+glw128(i)*aimag(f(n,consts,t0+dt*glx128(i)))
    end do

    ! Using glx512 and glw512
    ! do i=256,1,-1
    !   sumIntegral = sumIntegral+glw512(i)*f(n,consts,t0-dt*glx512(i))
    ! end do
    ! do i=1,256
    !    sumIntegral = sumIntegral+glw512(i)*f(n,consts,t0+dt*glx512(i))
    ! end do

    ! Using glx1024 and glw1024
    ! do i=512,1,-1
    !   sumIntegral = sumIntegral+glw1024(i)*f(n,consts,t0-dt*glx1024(i))
    ! end do
    ! do i=1,512
    !   sumIntegral = sumIntegral+glw1024(i)*f(n,consts,t0+dt*glx1024(i))
    ! end do
    gaussLegendreCmplx = cmplx(sumReal*dt,sumCmplx*dt,dp)
  end function

end module


      double precision function asGamma1(mt,besq,omsq)
C--   Author: John M. Campbell and R.K. Ellis, January 2012
C-----Taken from formula (5) of
C-----Fermilab-PUB-12-078-T
      implicit none
      include 'constants.f'
      include 'qcdcouple.f'
      include 'ewcouple.f'
      double precision mt,P0,P3,PP,PM,W0,WP,wm,YW,z,omsq,om,be,
     & P0b,P3b,Pmb,PPb,Ywb,Wmb,f,besq,ddilog,GammaInfty,term4,
     & term7,term9

c     Statement functions.
      P0(z)=0.5d0*(1d0-omsq+z)
      P3(z)=0.5d0*dsqrt(1d0+omsq**2+z**2-2d0*(omsq+z+omsq*z))
      PP(z)=P0(z)+P3(z)
      PM(z)=P0(z)-P3(z)
      W0(z)=0.5d0*(1d0+omsq-z)
      WP(z)=W0(z)+P3(z)
      WM(z)=W0(z)-P3(z)
      YW(z)=0.5d0*dlog(WP(z)/WM(z))
c      YP(z)=0.5d0*dlog(PP(z)/PM(z))
c     End statement functions.

      f=(1d0-besq)**2+omsq*(1d0+besq)-2d0*omsq**2
      om=sqrt(omsq)
      be=sqrt(besq)
      P0b=P0(besq)
      P3b=P3(besq)
      Pmb=PM(besq)
      Wmb=WM(besq)
c      WPb=WP(besq)
      PPb=PP(besq)
c      Ypb=YP(besq)
      Ywb=YW(besq)

      GammaInfty=Gf*mt**3/8d0/pi/rt2
      if (besq .gt. 0d0) then
c      term4=Ypb*dlog(4d0*P3b**2/Ppb**2/Wpb)
      term4=(log(PPb)-log(be))*dlog(4d0*P3b**2*Wmb/(omsq*PPb**2))
      term7=
     & +(3d0-besq+11d0*besq**2-besq**3+omsq*(6d0-12d0*besq+2d0*besq**2)
     & -omsq**2*(21d0+5d0*besq)+12d0*omsq**3)*log(Ppb)
     & -(-besq+11d0*besq**2-besq**3+omsq*(-12d0*besq+2d0*besq**2)
     & -omsq**2*(5d0*besq))*log(be)
c     & -(3d0+6d0*omsq-omsq**2*21d0+12d0*omsq**3)*log(be)
      term9=
     & +6d0*(1d0-4d0*besq+3d0*besq**2+omsq*(3d0+besq)-4d0*omsq**2)
     & *(P3b-0.5d0*(1d0-omsq))*dlog(be)
     & +3d0*(1d0-omsq)*(-4d0*besq+3d0*besq**2+omsq*(besq))*dlog(be)
c     & +3d0*(1d0-omsq)*(1d0+3d0*omsq-4d0*omsq**2)*dlog(be)
      else
      term4=log(PPb)*dlog(4d0*P3b**2*Wmb/(omsq*PPb**2))
      term7=
     & +(3d0-besq+11d0*besq**2-besq**3+omsq*(6d0-12d0*besq+2d0*besq**2)
     & -omsq**2*(21d0+5d0*besq)+12d0*omsq**3)*log(Ppb)
      term9=0d0
      endif

c--- equation for alphas*Gamma1
      asGamma1=GammaInfty*ason2pi*Cf*(
     & 8d0*f*P0b*(ddilog(1d0-Pmb)-ddilog(1d0-Ppb)
     &  -2d0*ddilog(1d0-Pmb/Ppb)+term4
     &  +Ywb*dlog(Ppb))
     & +4d0*(1d0-besq)*((1d0-besq)**2+omsq*(1d0+besq)-4d0*omsq**2)*Ywb
     & +term7
     & +8d0*f*P3b*dlog(om/4d0/P3b**2)+term9
     & +(5d0-22d0*besq+5d0*besq**2+9d0*omsq*(1d0+besq)-6d0*omsq**2)*P3b)

      return
      end


! annealing_revcom.f90 --
!     Template for the reverse communication interface
!     to the simulated annealing module
!
!     Usage:
!     - Fill in the code to evaluate the function (in the
!       widest sense of the word) that must be minimised.
!     - If needed, fill in the code to write a report on
!       the progress
!     - Use the file as an include file for a function
!       or subroutine:
!
!       subroutine minimize( f, range, params, x )
!           interface
!               real function f( x, params )
!                   use PARAM_DEF
!                   real, dimension(:), intent(in) :: x
!                   type(FUNC_PARAMS), intent(in)  :: params
!               end function
!           end interface
!
!           real, dimension(2,:) :: range    ! range and x are predefined
!           real, dimension(:)   :: x        ! variables, as are value and task
!
!           type(FUNC_PARAMS)    :: params
!
!           include 'annealing_decl.f90'
!
!           call set_parameters( anneal_data, ...)
!
!           include 'filled_in.f90' ! Filled in template
!
!       end subroutine
!

     do
         call get_next_step( anneal_data, range, x, value, task )

         select case ( task )
             case ( annealing_value )
                 !
                 ! Fill in the evaluation of the function
                 !
                 value = f(x)

             case ( annealing_report )
                 !
                 ! Fill in the reporting code
                 !
                 write(*,*) 'Value so far: ', value ' - vector: ', x

             case ( annealing_done )
                 exit
         end select
     enddo


program test_splines
use types, only: dp
use constants, only: pi
use utils, only: assert
use mesh, only: meshexp, linspace
use splines, only: spline3, iix, iixmin, spline3ders
implicit none

real(dp), parameter :: eps = 1e-12
real(dp), allocatable :: x(:), y(:), x2(:), y2(:)
integer :: N, N2, i, ip
real(dp) :: t1, t2

! Basics:
allocate(x(5), y(5))
x = [0._dp, 1._dp, 2._dp, 3._dp, 4._dp]
y = [0._dp, 1._dp, 2._dp, 3._dp, 4._dp]
call assert(all(abs(spline3(x, y, [0._dp]) - [0._dp]) < eps))
call assert(all(abs(spline3(x, y, [0._dp, 0.5_dp, 1._dp, 10._dp]) - &
        [0._dp, 0.5_dp, 1._dp, 10._dp]) < eps))
call assert(all(abs(spline3(x, y, [10._dp, 1._dp, 0._dp, 0.5_dp, 1._dp, &
        10._dp]) - [10._dp, 1._dp, 0._dp, 0.5_dp, 1._dp, 10._dp]) < eps))

x = linspace(0.0_dp, pi, 5)
y = sin(x)
allocate(x2(100))
x2 = linspace(0.0_dp, pi, 100)
call assert(all(abs(spline3(x, y, x2) - sin(x2)) < 1.2e-2_dp))
deallocate(x, y, x2)

! Test iix correctness:
N = 100000
N2 = 1000
allocate(x(N+1), x2(N2+1))
x = meshexp(1e-7_dp, 50._dp, 1e5_dp, N)
x2 = meshexp(0._dp, 51._dp, 200._dp, N2)
call cpu_time(t1)
do i = 1, N2+1
    ip = iix(x2(i), x)
    if (x2(i) < x(1)) then
        call assert(ip == 1)
    elseif (x2(i) > x(size(x))) then
        call assert(ip == size(x)-1)
    else
        call assert(x(ip) <= x2(i) .and. x2(i) <= x(ip+1))
    end if
end do
call cpu_time(t2)
print *, "Pure iix:", t2-t1

! Test faster indexing:
call cpu_time(t1)
ip = 0
do i = 1, N2+1
    ip = iixmin(x2(i), x, ip)
    if (x2(i) < x(1)) then
        call assert(ip == 1)
    elseif (x2(i) > x(size(x))) then
        call assert(ip == size(x)-1)
    else
        call assert(x(ip) <= x2(i) .and. x2(i) <= x(ip+1))
    end if
end do
call cpu_time(t2)
print *, "Reducing size iix:", t2-t1
deallocate(x, x2)

! Correctness. This tests that BC at each end is correct:
N = 10
N2 = 1000
allocate(x(N+1), y(N+1), x2(N2+1), y2(N2+1))
x = meshexp(0._dp, pi/2, 1._dp, N)
y = sin(x)
x2 = meshexp(-pi/2, 3*pi/4, 1._dp, N2)
y2 = spline3(x, y, x2)
call assert(abs(y2(1) - sin(x2(1))) < 5e-2_dp)
call assert(abs(y2(size(y2)) - sin(x2(size(x2)))) < 5e-2_dp)
! 1st derivative
call spline3ders(x, y, x2, dynew=y2)
call assert(abs(y2(1) - cos(x2(1))) < 0.2_dp)
call assert(abs(y2(size(y2)) - cos(x2(size(x2)))) < 0.2_dp)
! 2nd derivative
call spline3ders(x, y, x2, d2ynew=y2)
call assert(abs(y2(1) + sin(x2(1))) < 0.52_dp)
call assert(abs(y2(size(y2)) + sin(x2(size(x2)))) < 0.52_dp)

x = meshexp(0._dp, 1._dp, 1._dp, N)
y = x**2
x2 = meshexp(-10._dp, 10._dp, 1._dp, N2)
y2 = spline3(x, y, x2)
call assert(abs(y2(1) - x2(1)**2) < 1e-10_dp)
call assert(abs(y2(size(y2)) - x2(size(x2))**2) < 1e-10_dp)
! 1st derivative
call spline3ders(x, y, x2, dynew=y2)
call assert(abs(y2(1) - 2*x2(1)) < 1e-10_dp)
call assert(abs(y2(size(y2)) - 2*x2(size(x2))) < 1e-10_dp)
! 2nd derivative
call spline3ders(x, y, x2, d2ynew=y2)
call assert(maxval(abs(y2 - 2)) < 1e-10_dp)
deallocate(x, y, x2, y2)

! Test speed
N  = 1000
N2 = 10000
allocate(x(N+1), y(N+1), x2(N2+1), y2(N2+1))
x = meshexp(1e-7_dp, 50._dp, 1e5_dp, N)
x2 = meshexp(0._dp, 51._dp, 200._dp, N2)
y = sin(x)
call cpu_time(t1)
y2 = spline3(x, y, x2)
call cpu_time(t2)
print *, "Spline time:", t2-t1

end program


module module1
    integer :: n
contains
    recursive subroutine sub1(x)
        integer, intent(inout) :: x
        integer :: y
        y = 0
        if (x < n) then
            x = x + 1
            y = x**2
            print *, 'x = ', x, ', y = ', y
            call sub1(x)
            print *, 'x = ', x, ', y = ', y
        end if
    end
end

program main
    use module1
    integer :: x = 0
    print *, 'Enter number of repeats'
    read (*, *) n
    call sub1(x)
end program main


module input_parameters
	implicit none
	integer,parameter :: n=10 !value of DEGREE of POLYNOMIAL -1 for eg. n=5 will generate 4th order polynomial
	integer,parameter :: m=100 !number of discritisation points
	real(4),parameter :: lb=-1.0d0 !lower limit for x
	real(4),parameter :: rb=1.0d0 !upper limit for x

end module input_parameters


      SUBROUTINE MB03RX( JOBV, N, KL, KU, A, LDA, X, LDX, WR, WI,
     $                   DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reorder the diagonal blocks of the principal submatrix between
C     the indices KL and KU (KU >= KL) of a real Schur form matrix A
C     together with their eigenvalues, using orthogonal similarity
C     transformations, such that the block specified by KU is moved in
C     the position KL. The transformations are optionally postmultiplied
C     in a given matrix X.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBV    CHARACTER*1
C             Specifies whether or not the transformations are
C             accumulated, as follows:
C             = 'N':  The transformations are not accumulated;
C             = 'V':  The transformations are accumulated in X (the
C                     given matrix X is updated).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and X.  N >= 0.
C
C     KL      (input) INTEGER
C             The lower boundary index for the rows and columns of the
C             principal submatrix of A whose diagonal blocks are to be
C             reordered, and also the target position for the block to
C             be moved.  1 <= KL <= KU <= N.
C
C     KU      (input/output) INTEGER
C             On entry, KU specifies the upper boundary index for the
C             rows and columns of the principal submatrix of A whose
C             diagonal blocks are to be reordered, and also the original
C             position for the block to be moved.  1 <= KL <= KU <= N.
C             On exit, KU specifies the upper boundary index for the
C             rows and columns of the principal submatrix of A whose
C             diagonal blocks have been reordered. The given value will
C             be increased by 1 if the moved block was 2-by-2 and it has
C             been replaced by two 1-by-1 blocks. Otherwise, its input
C             value is preserved.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A in real Schur canonical form.
C             On exit, the leading N-by-N part of this array contains
C             the ordered real Schur canonical form.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     X       (input/output) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if JOBV = 'V', the leading N-by-N part of this
C             array must contain a given matrix X.
C             On exit, if JOBV = 'V', the leading N-by-N part of this
C             array contains the product of the given matrix X and the
C             transformation matrix that performed the reordering of A.
C             If JOBV = 'N', this array is not referenced.
C
C     LDX     INTEGER
C             The leading dimension of array X.
C             LDX >= 1,        if JOBV = 'N';
C             LDX >= MAX(1,N), if JOBV = 'V'.
C
C     WR,     (input/output) DOUBLE PRECISION arrays, dimension (N)
C     WI      On entry, these arrays must contain the real and imaginary
C             parts, respectively, of the eigenvalues of the matrix A.
C             On exit, these arrays contain the real and imaginary
C             parts, respectively, of the eigenvalues of the matrix A,
C             possibly reordered.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N)
C
C     METHOD
C
C     An attempt is made to move the block in the position (KU,KU) to
C     the position (KL,KL) by a sequence of orthogonal similarity
C     transformations, each swapping two consecutive blocks. The
C     standard algorithm [1], [2] usually succeeds to perform this
C     reordering. A failure of this algorithm means that two consecutive
C     blocks (one of them being the desired block possibly moved) are
C     too close to swap. In such a case, the leading block of the two
C     is tried to be moved in the position (KL,KL) and the procedure is
C     repeated.
C
C     REFERENCES
C
C     [1] Stewart, G.W.
C         HQR3 and EXCHQZ: FORTRAN subroutines for calculating and
C         ordering the eigenvalues of a real upper Hessenberg matrix.
C         ACM TOMS, 2, pp. 275-280, 1976.
C
C     [2] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically stable. If some eigenvalues are
C     ill-conditioned, their returned values could differ much from
C     their input values.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Eigenvalue, orthogonal transformation, real Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBV
      INTEGER           KL, KU, LDA, LDX, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), DWORK(*), WI(*), WR(*), X(LDX,*)
C     .. Local Scalars ..
      INTEGER           IERR, IFST, ILST, L
C     .. External Subroutines ..
      EXTERNAL          DTREXC
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, SQRT
C     .. Executable Statements ..
C
      IF ( KU.GT.KL ) THEN
C
C        Try to move the block in position (KU,KU) to position (KL,KL).
C
         IFST = KU
C        REPEAT
   10    CONTINUE
         ILST = KL
         CALL DTREXC( JOBV, N, A, LDA, X, LDX, IFST, ILST, DWORK, IERR )
         IF ( IERR.NE.0 ) THEN
C
C           During calculations, two adjacent blocks were too close
C           to swap; the desired block cannot be moved further, but the
C           block above it is suitable and is tried for moving. The
C           number of repeat cycles is usually 1, and at most the number
C           of blocks between the current position and the position KL.
C
            IFST = ILST - 1
            IF ( IFST.GT.1 ) THEN
               IF ( A(IFST,IFST-1).NE.ZERO )
     $            IFST = ILST - 2
            END IF
            IF ( ILST.GT.KL )
     $         GO TO 10
         END IF
C        UNTIL ( ILST.EQ.KL on output from DTREXC )
C
C        Recompute the eigenvalues for the modified part of A.
C        Note that KU must be incremented if the moved block was 2-by-2
C        and it has been replaced by two 1-by-1 blocks.
C
         IF ( WI(KU).NE.ZERO ) THEN
            IF ( A(KU+1,KU).EQ.ZERO )
     $         KU = KU + 1
         END IF
C
         L = KL
C        WHILE ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) DO
   20    IF ( L.LT.KU .OR. ( L.EQ.KU .AND. L.LT.N ) ) THEN
            IF ( A(L+1,L).NE.ZERO ) THEN
C
C              A 2x2 block.
C
               WR(L)   =  A(L,L)
               WR(L+1) =  WR(L)
               WI(L)   =  SQRT( ABS( A(L,L+1) ) )*
     $                    SQRT( ABS( A(L+1,L) ) )
               WI(L+1) = -WI(L)
               L = L + 2
            ELSE
C
C              An 1x1 block.
C
               WR(L) = A(L,L)
               WI(L) = ZERO
               L = L + 1
            END IF
            GO TO 20
         ELSE IF ( L.EQ.N ) THEN
            WR(L) = A(L,L)
            WI(L) = ZERO
         END IF
C        END WHILE 20
      END IF
C
      RETURN
C *** Last line of MB03RX ***
      END


!*********************************************************************
! This file is part of Polylogarithm.
!
! Polylogarithm is licenced under the MIT License.
!*********************************************************************

!*********************************************************************
!> @brief Complex polylogarithm \f$\operatorname{Li}_5(z)\f$
!> @param z complex argument
!> @return \f$\operatorname{Li}_5(z)\f$
!> @author Alexander Voigt
!*********************************************************************
double complex function cdli5(z)
  implicit none
  double complex :: z, u, u2, u4, u8, c4, lmz, rest, fast_pos_cdlog
  double precision :: rz, iz, nz, pz, lnz, arg
  double precision, parameter :: PI    = 3.1415926535897932D0
  double precision, parameter :: PI2   = 9.8696044010893586D0
  double precision, parameter :: PI4   = 97.409091034002437D0
  double precision, parameter :: zeta5 = 1.0369277551433699D0
  double precision, parameter :: c1    = 1.0823232337111382D0 ! zeta(4)
  double precision, parameter :: c2    = 0.60102845157979714D0 ! zeta(3)/2
  double precision, parameter :: c3    = 0.27415567780803774D0
  double precision, parameter :: c5    = -1D0/240
  double precision, parameter :: bf(19) = (/           &
      1.0D0                 , -15.0D0/32.0D0         , &
      1.3953189300411523D-01, -2.8633777006172840D-02, &
      4.0317412551440329D-03, -3.3985018004115226D-04, &
      4.5445184621617666D-06,  2.3916808048569012D-06, &
     -1.2762692600122747D-07, -3.1628984306505932D-08, &
      3.2848118445335192D-09,  4.7613713995660579D-10, &
     -8.0846898171909830D-11, -7.2387648587737207D-12, &
      1.9439760115173968D-12,  1.0256978405977236D-13, &
     -4.6180551009884830D-14, -1.1535857196470580D-15, &
      1.0903545401333394D-15                           /)
  double precision, parameter :: cs(6) = (/            &
     -1.1574074074074074D-04, 2.0667989417989418D-07,  &
     -1.0935444136502338D-09, 8.6986487449450412D-12,  &
     -8.6899587861588824D-14, 1.0081254080218813D-15   /)

  rz = real(z)
  iz = aimag(z)

   if (iz .eq. 0) then
      if (rz .eq. 0) then
         cdli5 = 0
         return
      endif
      if (rz .eq. 1) then
         cdli5 = zeta5
         return
      endif
      if (rz .eq. -1) then
         cdli5 = -15*zeta5/16
         return
      endif
   endif

   nz  = rz**2 + iz**2
   pz  = datan2(iz, rz)
   lnz = 0.5D0*log(nz)

   if (lnz**2 + pz**2 .lt. 1) then ! |log(z)| < 1
      u = dcmplx(lnz, pz) ! log(z)
      u2 = u**2
      c4 = (25D0/12 - fast_pos_cdlog(-u))/24
      cdli5 =                &
         zeta5 + u * c1 +    &
         u2 * (c2 + u * c3 + &
         u2 * (c4 + u * c5 + &
         u2 * (cs(1) +       &
         u2 * (cs(2) +       &
         u2 * (cs(3) +       &
         u2 * (cs(4) +       &
         u2 * (cs(5) +       &
         u2 * (cs(6)))))))))
      return
   endif

   if (nz .le. 1) then
      u = -fast_pos_cdlog(1 - z)
      rest = 0
   else ! nz > 1
      if (pz .gt. 0) then
         arg = pz - PI
      else
         arg = pz + PI
      endif
      lmz = dcmplx(lnz, arg) ! log(-z)
      u = -fast_pos_cdlog(1 - 1/z)
      rest = -lmz*(7*PI4 + lmz**2*(10*PI2 + 3*lmz**2))/360
   endif

   u2 = u**2
   u4 = u2**2
   u8 = u4**2

   cdli5 =                                                   &
      rest +                                                 &
      u*bf(1) +                                              &
      u2*(bf(2) + u*bf(3)) +                                 &
      u4*(bf(4) + u*bf(5) + u2*(bf(6) + u*bf(7))) +          &
      u8*(bf(8) + u*bf(9) + u2*(bf(10) + u*bf(11)) +         &
          u4*(bf(12) + u*bf(13) + u2*(bf(14) + u*bf(15)))) + &
      u8*u8*(bf(16) + u*bf(17) + u2*(bf(18) + u*bf(19)))

end function cdli5


PROGRAM NONSQUARES

  IMPLICIT NONE

  INTEGER :: m, n, nonsqr

  DO n = 1, 22
    nonsqr =  n + FLOOR(0.5 + SQRT(REAL(n)))  ! or could use NINT(SQRT(REAL(n)))
    WRITE(*,*) nonsqr
  END DO

  DO n = 1, 1000000
    nonsqr =  n + FLOOR(0.5 + SQRT(REAL(n)))
    m = INT(SQRT(REAL(nonsqr)))
    IF (m*m == nonsqr) THEN
      WRITE(*,*) "Square found, n=", n
    END IF
  END DO

END PROGRAM NONSQUARES


C     12/12/2003 VERSION CHANGED ON AUG 26 2005.  IMPLICIT NONE WAS ADDED.
C     Same as SUNLOC August 01, 1998, 01:04:31 PM, except this also returns R.
	SUBROUTINE SUNLOC1(LYEAR,IDAYJL,ISECDY, SUNLAT,SUNLON,R)
	IMPLICIT NONE

	REAL(8) XDAY,TX
      REAL(4) Z(3),X(3),TOSUN(3),PROJECT(3)
	real(8) D01,D11,S11,C11,S21,C21
	real(8) D02,D12,S12,C12,S22,C22
	real(8) slope,period,ecc,xinc,rad,xfac,alpha,t0,t,ang,cosinc
	real(8) amag,xphi,eot,hang,sinang,cosang,sinhang,coshang,corrlat,corrlon
	real(4) phi
	integer(4) istart,lyear,idayjl,isecdy
	real(4) sunlat,sunlon,r

	DATA D01,D11,S11,C11,S21,C21/ -1.15538E-3, -6.86302E-8, -8.48082E-1, -1.29184E-1, -3.18681E-2, -5.59290E-4/
	DATA D02,D12,S12,C12,S22,C22/ -1.57115E-3, -3.82973E-5, -9.91281E-4, -2.75336E-2,  1.83422E-2,  1.09567E-3/
	DATA SLOPE/1.81818E-5/ !=0.2/11000.0
	DATA PERIOD,ECC,XINC/365.2422,0.016708617,23.43929111/
      DATA RAD/0.01745329252/
	DATA ISTART/1/

	IF(ISTART.EQ.1) THEN
      XFAC=360./PERIOD
      ALPHA=XFAC*(355.5674 - 0.3210) !WINTER SOLSTICES DEC 21 13:37, 2000; ADDITION OFFSET OF .321 TO COMPENSTATE FOR ECC
	T0=XFAC*2.2083 !PERIHELION JAN 3, 5 HOURS, 2000
	Z(1)=SIND(XINC)*COSD(ALPHA)
	Z(2)=SIND(XINC)*SIND(ALPHA)
	Z(3)=COSD(XINC)
	X(1)=COSD(XINC)*COSD(ALPHA+180)
	X(2)=COSD(XINC)*SIND(ALPHA+180)
	X(3)=SIND(XINC)
	ENDIF

	IF(LYEAR.LT.1950 .OR. LYEAR.GT.2099) STOP 'ERROR IN LYEAR'
	XDAY=365.D0*(LYEAR-1950) + (IDAYJL-1) + ISECDY/86400.D0   + INT((LYEAR-1949)/4) - 18262.D0   !TDAY=0 FOR JAN 1 0Z, 2000
      TX=XFAC*XDAY
      T=MOD(TX,360.D0)
      IF(T.LT.0) T=T+360.

      ANG=T+2.*ECC*(SIND(T-T0)+SIND(T0))/RAD
      R=1.-ECC*COSD(T-T0)

      TOSUN(1)=-COSD(ANG)
      TOSUN(2)=-SIND(ANG)
      TOSUN(3)=0
      COSINC=DOT_PRODUCT(TOSUN,Z)
      SUNLAT=90-ACOSD(COSINC)

      PROJECT=TOSUN - COSINC*Z
	AMAG=SQRT(PROJECT(1)**2 + PROJECT(2)**2 + PROJECT(3)**2)
	PROJECT=PROJECT/AMAG
      CALL FINDANG(X,PROJECT,Z, PHI)
      XPHI=PHI-9.6 -0.326
	EOT=T-XPHI
	IF(EOT.LT.-180) EOT=EOT+360
	IF(EOT.GT. 180) EOT=EOT-360

	SUNLON=180-360*ISECDY/86400. - EOT
	IF(SUNLON.LT.0) SUNLON=SUNLON+360.

	ANG=XFAC*XDAY
	HANG=0.5*ANG
	SINANG=SIND(ANG)
	COSANG=COSD(ANG)
	SINHANG=SIND(HANG)
	COSHANG=COSD(HANG)
	CORRLAT = D01 + D11*XDAY + SLOPE*XDAY*(S11*SINANG + C11*COSANG + S21*SINHANG + C21*COSHANG)
	CORRLON = D02 + D12*XDAY +             S12*SINANG + C12*COSANG + S22*SINHANG + C22*COSHANG

	SUNLAT=SUNLAT + CORRLAT
	SUNLON=SUNLON + CORRLON
	IF(SUNLON.LT.  0) SUNLON=SUNLON+360
	IF(SUNLON.GE.360) SUNLON=SUNLON-360

      RETURN
      END

      SUBROUTINE FINDANG(X,Y,Z, ANG)
	implicit none

	REAL(4) X(3),Y(3),Z(3),D(3)
	real(4) sinang,cosang,ang

      D(1)=X(2)*Y(3)-X(3)*Y(2)
      D(2)=X(3)*Y(1)-X(1)*Y(3)
      D(3)=X(1)*Y(2)-X(2)*Y(1)
      SINANG=SQRT(D(1)**2+D(2)**2+D(3)**2)
	IF(DOT_PRODUCT(D,Z).LT.0) SINANG=-SINANG
      COSANG=DOT_PRODUCT(X,Y)
	ANG=ATAN2D(SINANG,COSANG)
	IF(ANG.LT.0) ANG=ANG+360.
      RETURN
      END