module test_var
    use testdrive, only : new_unittest, unittest_type, error_type, check
    use stdlib_kinds, only: sp, dp, int32, int64
    use stdlib_stats, only: var
    use,intrinsic :: ieee_arithmetic, only : ieee_is_nan
    implicit none

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

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

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

    real(dp), parameter :: 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])
    real(dp), parameter :: d3(4, 3, 3) = reshape([d, d*2, d*4], shape(d3))
    real(sp), parameter :: s(4, 3) = d
    real(sp), parameter :: s3(4, 3, 3) = reshape([s, s*2, s*4], shape(s3))

    integer(int32), parameter :: i32(4, 3) = d
    integer(int32), parameter :: i323(4, 3, 3) = d3
    integer(int64), parameter :: i64(4, 3) = d
    integer(int64), parameter :: i643(4, 3, 3) = d3

    complex(sp), parameter :: cs1(5) = [ cmplx(0.57706_sp, 0.00000_sp, sp),&
                            cmplx(0.00000_sp, 1.44065_sp, sp),&
                            cmplx(1.26401_sp, 0.00000_sp, sp),&
                            cmplx(0.00000_sp, 0.88833_sp, sp),&
                            cmplx(1.14352_sp, 0.00000_sp, sp)]
    complex(dp), parameter :: cd1(5) = [ cmplx(0.57706_dp, 0.00000_dp,kind=dp),&
                            cmplx(0.00000_dp, 1.44065_dp,kind=dp),&
                            cmplx(1.26401_dp, 0.00000_dp,kind=dp),&
                            cmplx(0.00000_dp, 0.88833_dp,kind=dp),&
                            cmplx(1.14352_dp, 0.00000_dp,kind=dp)]
    complex(sp), parameter :: cs(5,3) = reshape([cs1, cs1*3.0_sp, cs1*1.5_sp], shape(cs))
    complex(dp), parameter :: cd(5,3) = reshape([cd1, cd1*3.0_dp, cd1*1.5_dp], shape(cd))

contains

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

        testsuite = [ &
            new_unittest("sp_1dim", test_sp_1dim), &
            new_unittest("sp_1dim_mask", test_sp_1dim_mask), &
            new_unittest("sp_2dim", test_sp_2dim), &
            new_unittest("sp_2dim_mask", test_sp_2dim_mask), &
            new_unittest("sp_2dim_mask_array", test_sp_2dim_mask_array), &
            new_unittest("sp_3dim", test_sp_3dim), &
            new_unittest("sp_3dim_mask", test_sp_3dim_mask), &
            new_unittest("sp_3dim_mask_array", test_sp_3dim_mask_array), &
            new_unittest("dp_1dim", test_dp_1dim), &
            new_unittest("dp_1dim_mask", test_dp_1dim_mask), &
            new_unittest("dp_1dim_mask_array", test_dp_1dim_mask_array), &
            new_unittest("dp_2dim", test_dp_2dim), &
            new_unittest("dp_2dim_mask", test_dp_2dim_mask), &
            new_unittest("dp_2dim_mask_array", test_dp_2dim_mask_array), &
            new_unittest("dp_3dim", test_dp_3dim), &
            new_unittest("dp_3dim_mask", test_dp_3dim_mask), &
            new_unittest("dp_3dim_mask_array", test_dp_3dim_mask_array), &
            new_unittest("int32_1dim", test_int32_1dim), &
            new_unittest("int32_1dim_mask", test_int32_1dim_mask), &
            new_unittest("int32_1dim_mask_array", test_int32_1dim_mask_array), &
            new_unittest("int32_2dim", test_int32_2dim), &
            new_unittest("int32_2dim_mask", test_int32_2dim_mask), &
            new_unittest("int32_2dim_mask_array", test_int32_2dim_mask_array), &
            new_unittest("int32_3dim", test_int32_3dim), &
            new_unittest("int32_3dim_mask", test_int32_3dim_mask), &
            new_unittest("int32_3dim_mask_array", test_int32_3dim_mask_array), &
            new_unittest("int64_1dim", test_int64_1dim), &
            new_unittest("int64_1dim_mask", test_int64_1dim_mask), &
            new_unittest("int641_1dim_mask_array", test_int641_1dim_mask_array), &
            new_unittest("int64_2dim", test_int64_2dim), &
            new_unittest("int64_2dim_mask", test_int64_2dim_mask), &
            new_unittest("int64_2dim_mask_array", test_int64_2dim_mask_array), &
            new_unittest("int64_3dim", test_int64_3dim), &
            new_unittest("int64_3dim_mask", test_int64_3dim_mask), &
            new_unittest("int64_3dim_mask_array", test_int64_3dim_mask_array), &
            new_unittest("csp_1dim", test_csp_1dim), &
            new_unittest("csp_1dim_mask", test_csp_1dim_mask), &
            new_unittest("csp_1dim_mask_array", test_csp_1dim_mask_array), &
            new_unittest("csp_2dim", test_csp_2dim), &
            new_unittest("csp_2dim_mask", test_csp_2dim_mask), &
            new_unittest("csp_2dim_mask_array", test_csp_2dim_mask_array), &
            new_unittest("cdp_1dim", test_cdp_1dim), &
            new_unittest("cdp_1dim_mask", test_cdp_1dim_mask), &
            new_unittest("cdp_1dim_mask_array", test_cdp_1dim_mask_array), &
            new_unittest("cdp_2dim", test_cdp_2dim), &
            new_unittest("cdp_2dim_mask", test_cdp_2dim_mask), &
            new_unittest("cdp_2dim_mask_array", test_cdp_2dim_mask_array) &
            ]
    end subroutine collect_var

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

        call check(error, abs(var(s1) - 2.5) < sptol)
        call check(error, abs(var(s1, dim=1) - 2.5) < sptol)

    end subroutine test_sp_1dim

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

        call check(error, ieee_is_nan(var(s1, .false.)))
        call check(error, ieee_is_nan(var(s1, 1, .false.)))

    end subroutine test_sp_1dim_mask

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

        call check(error, abs(var(s1, s1 < 5) - 5./3.) < sptol)
        call check(error, ieee_is_nan((var(s1, s1 < 0.))))
        call check(error, ieee_is_nan((var(s1, s1 == 1.))))
        call check(error, abs(var(s1, 1, s1 < 5) - 5./3.) < sptol)

    end subroutine test_sp_1dim_mask_array

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

        call check(error, abs(var(s) - 13) < sptol)
        call check(error, all( abs( var(s, 1) - [20. / 3., 20. / 3., 5. / 3.]) < sptol))
        call check(error, all( abs( var(s, 2) - [19.0, 43. / 3., 31. / 3. , 7.0]) < sptol))

    end subroutine test_sp_2dim

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

        call check(error, ieee_is_nan(var(s, .false.)))
        call check(error, any(ieee_is_nan(var(s, 1, .false.))))
        call check(error, any(ieee_is_nan(var(s, 2, .false.))))

    end subroutine test_sp_2dim_mask

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

        call check(error, abs(var(s, s < 11) - 27.5 / 3.) < sptol)
        call check(error, all( abs( var(s, 1, s < 11) - [20. / 3., 20. / 3., 0.5]) < sptol))
        call check(error, all( abs( var(s, 2, s < 11) - [19.0, 43. / 3., 0.5 , 0.5]) < sptol))

    end subroutine test_sp_2dim_mask_array

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

        call check(error, abs(var(s3) - 153.4) < sptol)
        call check(error, 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 check(error, 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 check(error, 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))

    end subroutine test_sp_3dim

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

        call check(error, ieee_is_nan(var(s3, .false.)))
        call check(error, any(ieee_is_nan(var(s3, 1, .false.))))
        call check(error, any(ieee_is_nan(var(s3, 2, .false.))))
        call check(error, any(ieee_is_nan(var(s3, 3, .false.))))

    end subroutine test_sp_3dim_mask

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

        call check(error, abs(var(s3, s3 < 11) - 8.2205877_sp) < sptol)
        call check(error, 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 check(error, any( ieee_is_nan( var(s3, 2, s3 < 25))))
        call check(error, 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 ))

    end subroutine test_sp_3dim_mask_array

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

        call check(error, abs(var(d1) - 2.5) < dptol)
        call check(error, abs(var(d1, 1) - 2.5) < dptol)

    end subroutine test_dp_1dim

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

        call check(error, ieee_is_nan(var(d1, .false.)))
        call check(error, ieee_is_nan(var(d1, 1, .false.)))

    end subroutine test_dp_1dim_mask

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

        call check(error, abs(var(d1, d1 < 5) - 5._dp/3._dp) < dptol)
        call check(error, ieee_is_nan((var(d1, d1 < 0.))))
        call check(error, ieee_is_nan((var(d1, d1 == 1.))))
        call check(error, abs(var(d1, 1, d1 < 5) - 5._dp/3._dp) < dptol)

    end subroutine test_dp_1dim_mask_array

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

        call check(error, abs(var(d) - 13) < dptol)
        call check(error, all( abs( var(d,1) -&
            [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol))
        call check(error, all( abs( var(d,2) -&
            [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol))

    end subroutine test_dp_2dim

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

    call check(error, ieee_is_nan(var(d, .false.)))
    call check(error, any(ieee_is_nan(var(d, 1, .false.))))
    call check(error, any(ieee_is_nan(var(d, 2, .false.))))

    end subroutine test_dp_2dim_mask

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

    call check(error, abs(var(d, d < 11) - 27.5_dp / 3._dp) < dptol)
    call check(error, all( abs( var(d, 1, d < 11) -&
                 [20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol))
    call check(error, all( abs( var(d, 2, d < 11) -&
                 [19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol))

    end subroutine test_dp_2dim_mask_array

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

        call check(error, abs(var(d3) - 153.4_dp) < dptol)
        call check(error, 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))
        call check(error, 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))
        call check(error, 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))

    end subroutine test_dp_3dim

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

        call check(error, ieee_is_nan(var(d3, .false.)))
        call check(error, any(ieee_is_nan(var(d3, 1, .false.))))
        call check(error, any(ieee_is_nan(var(d3, 2, .false.))))
        call check(error, any(ieee_is_nan(var(d3, 3, .false.))))

    end subroutine test_dp_3dim_mask

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

        call check(error, abs(var(d3, d3 < 25) - 46.041379310344823_dp) < dptol)
        call check(error, 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 check(error, any( ieee_is_nan( var(d3, 2, d3 < 25))))
        call check(error, 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 ))

    end subroutine test_dp_3dim_mask_array

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

        call check(error, abs(var(i321) - 2.5) < dptol)
        call check(error, abs(var(i321, 1) - 2.5) < dptol)

    end subroutine test_int32_1dim

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

        call check(error, ieee_is_nan(var(i321, .false.)))
        call check(error, ieee_is_nan(var(i321, 1, .false.)))

    end subroutine test_int32_1dim_mask

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

        call check(error, abs(var(i321, i321 < 5) - 5._dp/3._dp) < dptol)
        call check(error, ieee_is_nan((var(i321, i321 < 0))))
        call check(error, ieee_is_nan((var(i321, i321 == 1))))
        call check(error, abs(var(i321, 1, i321 < 5) - 5._dp/3._dp) < dptol)

    end subroutine test_int32_1dim_mask_array

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

        call check(error, abs(var(i32) - 13) < dptol)
        call check(error, all( abs( var(i32,1) -&
            [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol))
        call check(error, all( abs( var(i32,2) -&
            [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol))

    end subroutine test_int32_2dim

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

        call check(error, ieee_is_nan(var(i32, .false.)))
        call check(error, any(ieee_is_nan(var(i32, 1, .false.))))
        call check(error, any(ieee_is_nan(var(i32, 2, .false.))))

    end subroutine test_int32_2dim_mask

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

        call check(error, abs(var(i32, i32 < 11) - 27.5_dp / 3._dp) < dptol)
        call check(error, all( abs( var(i32, 1, i32 < 11) -&
            [20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol))
        call check(error, all( abs( var(i32, 2, i32 < 11) -&
            [19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol))

    end subroutine test_int32_2dim_mask_array

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

        call check(error, abs(var(i323) - 153.4_dp) < dptol)
        call check(error, 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 check(error, 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 check(error, 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))

    end subroutine test_int32_3dim

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

        call check(error, ieee_is_nan(var(i323, .false.)))
        call check(error, any(ieee_is_nan(var(i323, 1, .false.))))
        call check(error, any(ieee_is_nan(var(i323, 2, .false.))))
        call check(error, any(ieee_is_nan(var(i323, 3, .false.))))

    end subroutine test_int32_3dim_mask

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

        call check(error, abs(var(i323, i323 < 25) - 46.041379310344823_dp) < dptol)
        call check(error, 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 check(error, any( ieee_is_nan( var(i323, 2, i323 < 25))))
        call check(error, 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 ))

    end subroutine test_int32_3dim_mask_array

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

        call check(error, abs(var(i641) - 2.5) < dptol)
        call check(error, abs(var(i641, 1) - 2.5) < dptol)

    end subroutine test_int64_1dim

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

        call check(error, ieee_is_nan(var(i641, .false.)))
        call check(error, ieee_is_nan(var(i641, 1, .false.)))

    end subroutine test_int64_1dim_mask

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

        call check(error, abs(var(i641, i641 < 5) - 5._dp/3._dp) < dptol)
        call check(error, ieee_is_nan((var(i641, i641 < 0))))
        call check(error, ieee_is_nan((var(i641, i641 == 1))))
        call check(error, abs(var(i641, 1, i641 < 5) - 5._dp/3._dp) < dptol)

    end subroutine test_int641_1dim_mask_array

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

        call check(error, abs(var(i64) - 13) < dptol)
        call check(error, all( abs( var(i64,1) -&
            [20._dp/3._dp, 20._dp/3._dp, 5._dp/3._dp]) < dptol))
        call check(error, all( abs( var(i64,2) -&
            [19.0_dp, 43._dp/3._dp, 31._dp/3._dp, 7.0_dp]) < dptol))

    end subroutine test_int64_2dim

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

        call check(error, ieee_is_nan(var(i64, .false.)))
        call check(error, any(ieee_is_nan(var(i64, 1, .false.))))
        call check(error, any(ieee_is_nan(var(i64, 2, .false.))))

    end subroutine test_int64_2dim_mask

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

        call check(error, abs(var(i64, i64 < 11) - 27.5_dp / 3._dp) < dptol)
        call check(error, all( abs( var(i64, 1, i64 < 11) -&
            [20._dp / 3._dp, 20._dp / 3._dp, 0.5_dp]) < dptol))
        call check(error, all( abs( var(i64, 2, i64 < 11) -&
            [19.0_dp, 43._dp / 3._dp, 0.5_dp, 0.5_dp]) < dptol))

    end subroutine test_int64_2dim_mask_array

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

        call check(error, abs(var(i643) - 153.4_dp) < dptol)
        call check(error, 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 check(error, 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 check(error, 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))

    end subroutine test_int64_3dim

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

        call check(error, ieee_is_nan(var(i643, .false.)))
        call check(error, any(ieee_is_nan(var(i643, 1, .false.))))
        call check(error, any(ieee_is_nan(var(i643, 2, .false.))))
        call check(error, any(ieee_is_nan(var(i643, 3, .false.))))

    end subroutine test_int64_3dim_mask

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

        call check(error, abs(var(i643, i643 < 25) - 46.041379310344823_dp) < dptol)
        call check(error, 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 check(error, any( ieee_is_nan( var(i643, 2, i643 < 25))))
        call check(error, 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 ))

    end subroutine test_int64_3dim_mask_array

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

        call check(error, abs(var(cs1) - (var(real(cs1)) + var(aimag(cs1)))) < sptol)
        call check(error, abs(var(cs1, dim=1) - (var(real(cs1),1) + var(aimag(cs1), 1)) ) < sptol)

    end subroutine test_csp_1dim

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

        call check(error, ieee_is_nan(var(cs1, .false.)))
        call check(error, ieee_is_nan(var(cs1, 1, .false.)))

    end subroutine test_csp_1dim_mask

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

        call check(error, abs(var(cs1, aimag(cs1) == 0) - var(real(cs1), aimag(cs1) == 0)) < sptol)
        call check(error, abs(var(cs1, 1, aimag(cs1) == 0) - var(real(cs1), 1, aimag(cs1) == 0)) < sptol)

    end subroutine test_csp_1dim_mask_array

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

        call check(error, abs(var(cs) - (var(real(cs)) + var(aimag(cs)))) < sptol)
        call check(error, all( abs( var(cs, 1) - (var(real(cs), 1) + var(aimag(cs), 1))) < sptol))
        call check(error, all( abs( var(cs, 2) - (var(real(cs), 2) + var(aimag(cs), 2))) < sptol))

    end subroutine test_csp_2dim

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

        call check(error, ieee_is_nan(var(cs, .false.)))
        call check(error, any(ieee_is_nan(var(cs, 1, .false.))))
        call check(error, any(ieee_is_nan(var(cs, 2, .false.))))

    end subroutine test_csp_2dim_mask

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

        call check(error, abs(var(cs, aimag(cs) == 0) - var(real(cs), aimag(cs) == 0)) < sptol)
        call check(error, all( abs( var(cs, 1, aimag(cs) == 0) - var(real(cs), 1, aimag(cs) == 0)) < sptol))
        call check(error, any( ieee_is_nan( var(cs, 2, aimag(cs) == 0))))

    end subroutine test_csp_2dim_mask_array

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

        call check(error, abs(var(cd1) - (var(real(cd1)) + var(aimag(cd1)))) < dptol)
        call check(error, abs(var(cd1, dim=1) - (var(real(cd1),1) + var(aimag(cd1), 1)) ) < dptol)

    end subroutine test_cdp_1dim

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

        call check(error, ieee_is_nan(var(cd1, .false.)))
        call check(error, ieee_is_nan(var(cd1, 1, .false.)))

    end subroutine test_cdp_1dim_mask

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

        call check(error, abs(var(cd1, aimag(cd1) == 0) - var(real(cd1), aimag(cd1) == 0)) < dptol)
        call check(error, abs(var(cd1, 1, aimag(cd1) == 0) - var(real(cd1), 1, aimag(cd1) == 0)) < dptol)

    end subroutine test_cdp_1dim_mask_array

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

        call check(error, abs(var(cd) - (var(real(cd)) + var(aimag(cd)))) < dptol)
        call check(error, all( abs( var(cd, 1) - (var(real(cd), 1) + var(aimag(cd), 1))) < dptol))
        call check(error, all( abs( var(cd, 2) - (var(real(cd), 2) + var(aimag(cd), 2))) < dptol))

    end subroutine test_cdp_2dim

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

        call check(error, ieee_is_nan(var(cd, .false.)))
        call check(error, any(ieee_is_nan(var(cd, 1, .false.))))
        call check(error, any(ieee_is_nan(var(cd, 2, .false.))))

    end subroutine test_cdp_2dim_mask

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

        call check(error, abs(var(cd, aimag(cd) == 0) - var(real(cd), aimag(cd) == 0)) < dptol)
        call check(error, all( abs( var(cd, 1, aimag(cd) == 0) - var(real(cd), 1, aimag(cd) == 0)) < dptol))
        call check(error, any( ieee_is_nan( var(cd, 2, aimag(cd) == 0))))

    end subroutine test_cdp_2dim_mask_array

end module

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

    stat = 0

    testsuites = [ &
        new_testsuite("var", collect_var) &
        ]

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

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


      PROGRAM xlocate
C     driver for routine locate
      INTEGER N
      PARAMETER(N=100)
      INTEGER i,j
      REAL x,xx(N)
C     create array to be searched
      do 11 i=1,N
        xx(i)=exp(i/20.0)-74.0
11    continue
      write(*,*) 'Result of:   j=0 indicates x too small'
      write(*,*) '           j=100 indicates x too large'
      write(*,'(t5,a7,t17,a1,t24,a5,t34,a7)') 'locate ','j',
     *     'xx(j)','xx(j+1)'
C     perform test
      do 12 i=1,19
        x=-100.0+200.0*i/20.0
        call locate(xx,N,x,j)
        if (j.eq.0) then
          write(*,'(1x,f10.4,i6,a12,f12.6)') x,j,'lower lim',xx(j+1)
        else if (j.eq.N) then
          write(*,'(1x,f10.4,i6,f12.6,a12)') x,j,xx(j),'upper lim'
        else
          write(*,'(1x,f10.4,i6,2f12.6)') x,j,xx(j),xx(j+1)
        endif
12    continue
      END

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


subroutine bis(a,b,ET,x)

  implicit none

!!!!!!!!!!!!!!!!!
  !              AUTOR: BYRON J. ENCINAS
  !
  !                    PROPÓSITO:
  !      APROXIMAR RAÍCES REALES PARA FUNCIONES
  !      MEDIANTE MÉTODOS DE BISECCIÓN
  !
!!!!!!!!!!!!!!!!!!

  integer,parameter::q=selected_real_kind(32,600)
  real,external::F
  real,intent(INOUT)::a,b,ET,x
  real(kind=q)::G,j
  integer::i,k

!======================================================

G = F(b)*F(a)		!!! Variable G nos comunica si hay cambio de signo en el primer intervalo

IF(G==0 .OR. G>0)THEN		!!!verificación
WRITE(*,*)'No hay cambio de signo'
STOP

ELSE !!!cambio de signo, LISTOS PARA CONTINUAR CON APROXIMACION

!!!!!===============CALCULO DE ERRORES: !!!BISECCION============================

!=====================================================================
	IF(ET==0)then
	k=200			!!! condicionamos el numero de iteraciones, si es otorgado por el usuario
	ELSE 			!!! si no, se realizan 200 iteraciones
	j= log((b-a)/ET)/0.69314718056 -1
	k=NINT(j)+1
	END IF
!=======================================================================

WRITE(*,*)'X_n                     F(x_n)                a_n                b_n'
	!=============================================================
	Do i=1,k
x = (a + b)/2
	!====================
	WRITE(*,*) x,F(x),a,b

	IF(F(x) /= 0)THEN

	IF(F(x)*F(a)<0)then
	!Si F(x)*F(a_n) <0 entonces hay cambio de signo
	!h<d por lo tanto daremos el nuevo valor de x a d (el limite superior)
	b = x
	else
	a = x
	END IF

	END IF

	!============================

	END DO

END IF

END Subroutine


FUNCTION daylen(dlat,idoy,riseangle)
!
IMPLICIT NONE
!
! Function arguments
!
REAL :: dlat,riseangle
INTEGER :: idoy
REAL :: daylen
!
! Local variables
!
REAL :: dec,h
REAL :: declination,hourangle
!
!     + + + purpose + + +
!     this function calculates the daylength (hours) for any simulation
!     site based on the global position of the site, and day of the
!     year.  the inputs for the function are day of the year, and latitude
!     of the site.

!     + + + keywords + + +
!     day length

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     idoy - day of year
!     daylen - the length of the day. Returns the value of this function.
!     dlat - latitude of the site, degrees (north > 0, south < 0)
!     riseangle - angle of earths rotation where sunrise occurs.
!                 This varies depending on whether you are calculating
!                 direct beam, civil twilight, nautical twilight or
!                 astronomical twilight daylength

!     + + + local variables + + +

!     + + + local variable definitions + + +
!     dec - declination of earth with respect to the sun (degrees)
!     declination -
!     h - hour angle (degrees)
!     hourangle - a function. This variable holds the value returned by
!                 the Hourangle function. Debe assumed this definition

!     + + + common blocks + + +
!     include 'p1unconv.inc'

!     + + + function declarations + + +

!     + + + end specifications + + +

!     declination angle (dec)
!
dec = declination(idoy)

!     sunrise or sunset hour angle
h = hourangle(dlat,dec,riseangle)

!     calculate the length of the day
daylen = 2.0*h/15.0
!
END FUNCTION daylen

Project Documents/Source Code Original/Daylen.f90


	!------------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves nonlinear Klein-Gordon equation in 1 dimension
	! u_{tt}-u_{xx}+u=Es*|u|^2u
	! using a second order implicit-explicit time stepping scheme.
	!
	! The boundary conditions are u(x=0)=u(2*Lx*\pi),
	! The initial condition is u=sqrt(2)*sech((x-c*t)/sqrt(1-c^2));
	!
	! .. Parameters ..
	!  Nx                   = number of modes in x - power of 2 for FFT
	!  Nt			= number of timesteps to take
	!  Tmax			= maximum simulation time
	!  plotgap		= number of timesteps between plots
	!  FFTW_IN_PLACE 	= value for FFTW input
	!  FFTW_MEASURE 	= value for FFTW input
	!  FFTW_EXHAUSTIVE 	= value for FFTW input
	!  FFTW_PATIENT 	= value for FFTW input
	!  FFTW_ESTIMATE 	= value for FFTW input
	!  FFTW_FORWARD         = value for FFTW input
	!  FFTW_BACKWARD	= value for FFTW input
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx			= width of box in x direction
	!  ES			= +1 for focusing and -1 for defocusing
	! .. Scalars ..
	!  i			= loop counter in x direction
	!  n			= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start		= variable to record start time of program
	!  finish		= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  planfx		= Forward 2d fft plan
	!  planbx		= Backward 2d fft plan
	!  dt			= timestep
	!  ierr			= error code
	!  plotnum		= number of plot
	! .. Arrays ..
	!  unew 		= approximate solution
	!  vnew 		= Fourier transform of approximate solution
	!  u 			= approximate solution
	!  v 			= Fourier transform of approximate solution
	!  uold 		= approximate solution
	!  vold 		= Fourier transform of approximate solution
	!  nonlin 		= nonlinear term, u^3
	!  nonlinhat 		= Fourier transform of nonlinear term, u^3
	! .. Vectors ..
	!  kx			= fourier frequencies in x direction
	!  x			= x locations
	!  time			= times at which save data
	!  en			= total energy
	!  enstr		= strain energy
	!  enpot		= potential energy
	!  enkin		= kinetic energy
	!  name_config		= array to store filename for data to be saved
	!  fftfx		= array to setup 1D Fourier transform
	!  fftbx		= array to setup 1D Fourier transform
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!	getgrid.f90	-- Get initial grid of points
	! 	initialdata.f90 -- Get initial data
	!	enercalc.f90 -- Subroutine to calculate the energy
	!	savedata.f90 -- Save initial data
	!	storeold.f90 -- Store old data
	! External libraries required
	! 	FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)
	! 	MPI library

	PROGRAM Kg
	USE mpi
	! Declare variables
	IMPLICIT NONE
	INTEGER(kind=4), PARAMETER		:: Nx=512
	INTEGER(kind=4), PARAMETER		:: Nt=128
	INTEGER(kind=4), PARAMETER		:: plotgap=32
	REAL(kind=8), PARAMETER			:: &
		pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER			::  Lx=9.0d0
	REAL(kind=8), PARAMETER			::  Es=1.0d0
        REAL(kind=8), PARAMETER         	::  c=0.5
	REAL(kind=8)				::  dt=0.50d0/REAL(Nt,kind(0d0))
	COMPLEX(kind=8), DIMENSION(1:1+Nx/2)	::  kx
	REAL(kind=8),  	 DIMENSION(1:Nx)	::  x
	REAL(kind=8), DIMENSION(1:Nx)           ::  u,nonlin
	COMPLEX(kind=8), DIMENSION(1:1+Nx/2)    ::  v,nonlinhat
	REAL(kind=8), DIMENSION(1:Nx)           ::  uold
	COMPLEX(kind=8), DIMENSION(1:1+Nx/2)    ::  vold
	REAL(kind=8), DIMENSION(1:Nx)           ::  unew
	COMPLEX(kind=8), DIMENSION(1:1+Nx/2)    ::  vnew
	REAL(kind=8), DIMENSION(1:Nt+1)         ::  time,enkin,enstr,enpot,en
        REAL(kind=8)                            ::  runtime,start,finish,err
	INTEGER(kind=4)				::  ierr,i,n,nn
	INTEGER(kind=4)				::  plotnum
	INTEGER(kind=4), PARAMETER		::  ntable=2*Nx+64, nwork=4*Nx
	INTEGER(kind=4), PARAMETER		::  isign=0, isignf=-1, isignb=1
	REAL(kind=8),PARAMETER                  ::  scale=1.0d0,scalef=1.0d0,scaleb=1.0d0/DBLE(Nx)
        REAL(kind=8), DIMENSION(1:ntable), SAVE ::  tabledz,tablezd
        REAL(kind=8), DIMENSION(1:nwork)        ::  work
        INTEGER(kind=4), SAVE                   ::  isys
        CHARACTER*100				::  name_config

        CALL MPI_INIT(ierr)
	! set up fft
        CALL DZFFT(isign,Nx,scale,u,v,tabledz,work,isys)
        CALL ZDFFT(isign,Nx,scale,v,u,tablezd,work,isys)

	PRINT *,'Setup FFTs'
	! setup fourier frequencies
	CALL getgrid(Nx,Lx,pi,name_config,x,kx)
	PRINT *,'Setup grid and fourier frequencies'
	CALL initialdata(Nx,dt,c,x,u,uold)
	plotnum=1
	name_config = 'data/u'
	!CALL savedata(Nx,plotnum,name_config,u)
        CALL DZFFT(isignf,Nx,scalef,u,   v,   tabledz,work,isys)
        CALL DZFFT(isignf,Nx,scalef,uold,vold,tabledz,work,isys)
        PRINT *,'Transformed initialdata'
	CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
			enkin(plotnum),enstr(plotnum),&
			enpot(plotnum),en(plotnum),&
			kx,nonlin,nonlinhat,&
			v,vold,u,uold,tabledz,tablezd,work)

	PRINT *,'Got initial data, starting timestepping'
	time(plotnum)=0.0d0
        start = MPI_WTIME()
        nn=1
	DO n=1,(Nt/3)
                ! Iteration 1
		DO i=1,Nx
			nonlin(i)=u(i)**3
		END DO
                CALL DZFFT(isignf,Nx,scalef,nonlin,nonlinhat,tabledz,work,isys)
		DO i=1,Nx/2 + 1
			vnew(i)=( 0.25d0*(kx(i)*kx(i) - 1.0d0) &
				*(2.0d0*v(i)+vold(i)) &
				+(2.0d0*v(i)-vold(i))/(dt*dt) &
				+Es*nonlinhat(i) ) &
				/(1.0d0/(dt*dt) - 0.25d0*(kx(i)*kx(i) - 1.0d0))
		END DO
                CALL ZDFFT(isignb,Nx,scaleb,vnew,unew,tablezd,work,isys)
                nn=nn+1
		IF (mod(nn,plotgap)==0) then
			plotnum=plotnum+1
			time(plotnum)=n*dt
			PRINT *,'time',n*dt
			CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
				enkin(plotnum),enstr(plotnum),&
				enpot(plotnum),en(plotnum),kx,&
				nonlin,nonlinhat,vnew,v,unew,u,&
                                tabledz,tablezd,work)
		END IF

                ! Iteration 2
                DO i=1,Nx
                        nonlin(i)=unew(i)**3
                END DO
                CALL DZFFT(isignf,Nx,scalef,nonlin,nonlinhat,tabledz,work,isys)
                DO i=1,Nx/2 + 1
                        vold(i)=( 0.25d0*(kx(i)*kx(i) - 1.0d0) &
                                *(2.0d0*vnew(i)+v(i)) &
                                +(2.0d0*vnew(i)-v(i))/(dt*dt) &
                                +Es*nonlinhat(i) ) &
                                /(1.0d0/(dt*dt) - 0.25d0*(kx(i)*kx(i)-1.0d0))
                END DO
                call ZDFFT(isignb,Nx,scaleb,vold,uold,tablezd,work,isys)
                nn=nn+1
                IF (mod(nn,plotgap)==0) then
                        plotnum=plotnum+1
                        time(plotnum)=n*dt
                        PRINT *,'time',n*dt
                        CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
                                enkin(plotnum),enstr(plotnum),&
                                enpot(plotnum),en(plotnum),kx,&
                                nonlin,nonlinhat,vold,vnew,uold,unew,&
                                tabledz,tablezd,work)
                END IF

                ! Iteration 3
                DO i=1,Nx
                        nonlin(i)=uold(i)**3
                END DO
                CALL DZFFT(isignf,Nx,scalef,nonlin,nonlinhat,tabledz,work,isys)
                DO i=1,Nx/2 + 1
                        v(i)=( 0.25d0*(kx(i)*kx(i) - 1.0d0) &
                                *(2.0d0*vold(i)+vnew(i)) &
                                +(2.0d0*vold(i)-vnew(i))/(dt*dt) &
                                +Es*nonlinhat(i) ) &
                                /(1.0d0/(dt*dt) - 0.25d0*(kx(i)*kx(i)-1.0d0))
                END DO
                CALL ZDFFT(isignb,Nx,scaleb,v,u,tablezd,work,isys)
                nn=nn+1
                IF (mod(nn,plotgap)==0) then
                        plotnum=plotnum+1
                        time(plotnum)=n*dt
                        PRINT *,'time',n*dt
                        CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
                                enkin(plotnum),enstr(plotnum),&
                                enpot(plotnum),en(plotnum),kx,&
                                nonlin,nonlinhat,v,vold,u,uold,&
                                tabledz,tablezd,work)
                END IF
	END DO
        ! clean up steps
        IF (mod(Nt,3).GT.0) THEN
                DO i=1,Nx
                        nonlin(i)=u(i)**3
                END DO
                CALL DZFFT(isignf,Nx,scalef,nonlin,nonlinhat,tabledz,work,isys)
                DO i=1,Nx/2 + 1
                        vnew(i)=( 0.25d0*(kx(i)*kx(i) - 1.0d0) &
                                *(2.0d0*v(i)+vold(i)) &
                                +(2.0d0*v(i)-vold(i))/(dt*dt) &
                                +Es*nonlinhat(i) ) &
                                /(1.0d0/(dt*dt) - 0.25d0*(kx(i)*kx(i)-1.0d0))
                END DO
                CALL ZDFFT(isignb,Nx,scaleb,vnew,unew,tablezd,work,isys)
                nn=nn+1
                IF (mod(nn,plotgap)==0) then
                        plotnum=plotnum+1
                        time(plotnum)=n*dt
                        PRINT *,'time',n*dt
                        CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
                                enkin(plotnum),enstr(plotnum),&
                                enpot(plotnum),en(plotnum),kx,&
                                nonlin,nonlinhat,vnew,v,unew,u,&
                                tabledz,tablezd,work)
                END IF

        END IF
        IF (mod(Nt,3).GT.1) THEN
                DO i=1,Nx
                        nonlin(i)=unew(i)**3
                END DO
                CALL DZFFT(isignf,Nx,scalef,nonlin,nonlinhat,tabledz,work,isys)
                DO i=1,Nx/2 +1
                        vold(i)=( 0.25d0*(kx(i)*kx(i) - 1.0d0) &
                                *(2.0d0*vnew(i)+v(i)) &
                                +(2.0d0*vnew(i)-v(i))/(dt*dt) &
                                +Es*nonlinhat(i) ) &
                                /(1.0d0/(dt*dt) -0.25d0*(kx(i)*kx(i)-1.0d0))
                END DO
                CALL ZDFFT(isignb,Nx,scaleb,vold,uold,tablezd,work,isys)
                nn=nn+1
                IF (mod(nn,plotgap)==0) then
                        plotnum=plotnum+1
                        time(plotnum)=n*dt
                        PRINT *,'time',n*dt
                        CALL enercalc(Nx,isignf,isignb,isys,ntable,nwork,dt,Es,&
                                      enkin(plotnum),enstr(plotnum),&
                                      enpot(plotnum),en(plotnum),kx,&
                                      nonlin,nonlinhat,vold,vnew,uold,unew,&
                                      tabledz,tablezd,work)
                END IF
        END IF
	PRINT *,'Finished time stepping'
        finish = MPI_WTIME()
        runtime=REAL(finish-start,kind(0d0))
	PRINT*,'Program took ',runtime,'for Time stepping'
	CALL saveresults(Nt,plotgap,time(1:1+n/plotgap),en(1:1+n/plotgap),&
			enstr(1:1+n/plotgap),enkin(1:1+n/plotgap),&
                        enpot(1:1+n/plotgap))

	! Save times at which output was made in text format
	PRINT *,'Saved data'
        IF(mod(Nt,3)==0) CALL errorcalc(Nt,Nx,dt,c,x,unew,err)
        IF(mod(Nt,3)==1) CALL errorcalc(Nt,Nx,dt,c,x,uold,err)
        IF(mod(Nt,3)==2) CALL errorcalc(Nt,Nx,dt,c,x,u,err)
        name_config = 'data/errortime'
        CALL savetimeanderror(Nx,Nt,err,runtime,name_config)

	PRINT *,'Program execution complete'
        CALL MPI_FINALIZE(ierr)
	END PROGRAM Kg


!-----------------------------------------------------------------------
! Saturation specific humidity
!-----------------------------------------------------------------------
subroutine QSAT(water,P,T,Qs)

use Constants, only : &
  eps,               &! Ratio of molecular weights of water and dry air
  e0,                &! Saturation vapour pressure at Tm (Pa)
  Tm                  ! Melting point (K)

implicit none

logical, intent(in) :: &
  water               ! Saturation wrt water if TRUE

real*8, intent(in) :: &
  P,                 &! Air pressure (Pa)
  T                   ! Temperature (K)

real*8, intent(out) :: &
  Qs                  ! Saturation specific humidity

real*8 :: &
  Tc,                &! Temperature (C)
  es                  ! Saturation vapour pressure (Pa)

Tc = T - Tm
if (Tc > 0 .or. water) then
  es = e0*exp(17.5043*Tc / (241.3 + Tc))
else
  es = e0*exp(22.4422*Tc / (272.186 + Tc))
end if
Qs = eps*es / P

end subroutine QSAT


program test_fft
  use adjac
  use adjac_fft
  implicit none

  integer, parameter :: n = 127
  type(adjac_double), dimension(2,2*n,3) :: x
  double precision, dimension(2,2*n,3) :: x_value
  double precision, dimension(2*n,2*n) :: jac
  complex(kind=kind(0d0)) :: v1, v2
  integer :: i, j

  do i = 1, n
     x_value(1,2*i-1,2) = 1 + i + i**2
     x_value(1,2*i,2) = 0
     call adjac_set_independent(x(1,2*i-1,2), x_value(1,2*i-1,2), 2*i-1)
     call adjac_set_independent(x(1,2*i,2), x_value(1,2*i,2), 2*i)
  end do

  write(*,*) 'forward transform'
  call fft(x_value(1,:,2))
  call fft(x(1,:,2))
  call adjac_get_dense_jacobian(x(1,:,2), jac)

  do i = 1, n
     v1 = x(1,i,2)%value
     v2 = x_value(1,i,2)
     if (abs(v1 - v2) > 1d-10) then
        write(*,*) 'FAIL', i, v1, v2
        stop
     end if
     do j = 1, n
        v1 = jac(2*i-1,2*j-1) + (0,1)*jac(2*i,2*j-1)
        v2 = exp(-2*(0,3.141592653589793d0)*(i-1)*(j-1)/n)
        if (abs(v1 - v2) > 1d-10) then
           write(*,*) 'FAIL', i, j, v1, v2
           stop
        end if
     end do
  end do
  write(*,*) 'OK'

  write(*,*) 'inverse transform'
  call ifft(x_value(1,:,2))
  call ifft(x(1,:,2))
  call adjac_get_dense_jacobian(x(1,:,2), jac)

  do i = 1, n
     if (mod(i,2) == 1) then
        v2 = 1 + (1 + i/2) + (1 + i/2)**2
     else
        v2 = 0
     end if

     v1 = x(1,i,2)%value
     if (abs(v1 - v2) > 1d-10) then
        write(*,*) 'FAIL', 'avalue', i, v1, v2
        stop
     end if

     v2 = x_value(1,i,2)
     if (abs(v1 - v2) > 1d-10) then
        write(*,*) 'FAIL', 'value', i, v1, v2
        stop
     end if

     do j = 1, n
        v1 = jac(2*i-1,2*j-1) + (0,1)*jac(2*i,2*j-1)
        if (i == j) then
           v2 = 1
        else
           v2 = 0
        end if
        if (abs(v1 - v2) > 1d-10) then
           write(*,*) 'FAIL', i, j, v1, v2
           stop
        end if
     end do
  end do
  write(*,*) 'OK'
end program test_fft


program test_funcs

use funcs
use assert, only: assert_isclose, wp

implicit none (type, external)

real(wp), parameter :: pi = 4._wp * atan(1._wp), pi3 = pi/3
complex(wp), parameter :: cpi = (pi, pi)
integer :: N,D

call assert_isclose(csc(acsc(pi3)), pi3)

if (.not.isdigit('3')) stop 1
if (isdigit('x')) stop 1

N=6; D=10
call ratnorm(N,D)
if (.not. N==3 .and. D==5) stop 1

call assert_isclose(frac(pi), pi-3)
call assert_isclose(frac(-pi), -pi+3)

print *,'OK RPN test'
end program


module ex_stdlib_function
    use, intrinsic :: iso_fortran_env
    use :: stdlib_optval
    use :: stdlib_math
    use :: stdlib_linalg
    use :: stdlib_specialfunctions
    use :: stdlib_quadrature
    use :: stdlib_random
    use :: stdlib_stats
    use :: stdlib_stats_distribution_uniform
    use :: stdlib_sorting
    implicit none
    private
    public :: ex_stdlib_optval
    public :: ex_stdlib_math
    public :: ex_stdlib_linalg
    public :: ex_stdlib_specialfunctions
    public :: ex_stdlib_quadrature
    public :: ex_stdlib_random
    public :: ex_stdlib_stats
    public :: ex_stdlib_stats_distribution_uniform
    public :: ex_stdlib_sorting

contains
    !| optional引数がないときに標準値を返す関数optvalの使用例．
    subroutine ex_stdlib_optval()
        implicit none

        ! 1 0
        print *, optval(1, default=0), optval(default=0)

        ! 1.00000000 0.00000000
        print *, optval(1., default=0.), optval(default=0.)

        ! 1.0000000000000000 0.0000000000000000
        print *, optval(1d0, default=0d0), optval(default=0d0)

        ! T F
        print *, optval(.true., default=.false.), optval(default=.false.)

        ! (1.00000000,2.00000000) (0.00000000,0.00000000)
        print *, optval((1., 2.), default=(0., 0.)), optval(default=(0., 0.))

        block
            real(real64) :: x = 64.

            ! 8.0000000000000000 3.9999999999999996
            print *, root(x), root(x, 3)
        end block
    contains
        !| xのn乗根を計算する．
        real(real64) function root(x, n)
            implicit none
            real(real64), intent(in) :: x
                !! 被開平数
            integer(int32), intent(in), optional :: n
                !! 指数

            root = x**(1d0/optval(n, 2)) ! nが無いときは2が使われる
        end function root
    end subroutine ex_stdlib_optval

    !| stdlib_mathで定義されている手続の使用例．
    subroutine ex_stdlib_math()
        implicit none

        block
            ! [start, end]を等間隔に分割した数を配列で返す．
            ! 戻り値の型は，[start,end]の型と同じ．

            ! 0.00000000      0.200000003      0.400000006      0.600000024      0.800000012       1.00000000
            print *, linspace(start=0., end=1., n=6)

            ! 0.0000000000000000 0.20000000000000001 0.40000000000000002 0.60000000000000009 0.80000000000000004 1.0000000000000000
            print *, linspace(0d0, 1d0, 6)

            ! 整数型で範囲を指定すると，戻り値は倍精度実数
            ! 0.0000000000000000 0.20000000000000001 0.40000000000000002 0.60000000000000009 0.80000000000000004 1.0000000000000000
            print *, linspace(0, 1, 6)
        end block

        block
            complex(real64) :: start, end
            complex(real64), allocatable :: z(:)
            start = cmplx(1d0, 0d0)
            end = cmplx(0d0, 1d0)

            ! (1.0000000000000000,0.0000000000000000) (0.80000000000000004,0.20000000000000001) (0.59999999999999998,0.40000000000000002)
            ! (0.39999999999999991,0.60000000000000009) (0.19999999999999996,0.80000000000000004) (0.0000000000000000,1.0000000000000000)
            z = linspace(start, end, 6)
            print *, z
        end block

        block

            ! [base**start, base**end]の範囲を対数で分割する数を配列で返す．
            ! 戻り値の型は，基本的に[start,end]あるいはbaseの型と同じ．

            ! baseが倍精度実数なので倍精度実数で返す．
            ! 1.0000000000000000E-003   1.0000000000000000E-002  0.10000000000000001        1.0000000000000000        10.000000000000000
            print *, logspace(-3, 1, n=5, base=10d0)

            ! start, endが単精度実数なので単精度実数で返す．
            ! 1.00000005E-03   9.99999978E-03  0.100000001       1.00000000       10.0000000
            print *, logspace(-3., 1., n=5, base=10)

            ! start, end, baseが全て整数なら，整数で値を返す．
            !  0           0           0           1          10
            print *, logspace(start=-3, end=1, n=5, base=10)
        end block

        block
            ! 指定された区間を等間隔に分割した値をもつ配列で返す．

            ! 引数を整数で指定する．
            ! 引数が一つの場合は終端として扱い，始点を1，間隔を1として扱う．
            ! 1           2           3
            print *, arange(3) ! = arange(1,3,1)

            ! 終端が負の場合，始点は1，間隔を-1として扱う．
            ! 1           0          -1
            print *, arange(-1) ! = arange(1,-1,-1)

            ! 始点と終点を指定．間隔を1として扱う．
            ! 0           1           2
            print *, arange(0, 2) ! = arange(0, 2, 1)

            ! 始点，終点，間隔を指定．
            ! 0           2
            print *, arange(0, 2, 2)

            ! 引数を実数で指定する．
            ! 引数が一つの場合は終端として扱い，始点を1，間隔を1として扱う．
            ! 1.00000000       2.00000000       3.00000000
            print *, arange(3.0) ! = arange(1.0,3.0,1.0)

            ! 終端が負の場合，始点は1，間隔を-1として扱う．
            ! 1.00000000       0.00000000      -1.00000000
            print *, arange(-1.0) ! = arange(1.0,-1.0,-1.0)

            ! 始点と終点を指定．間隔を1として扱う．
            ! 0.00000000       1.00000000       2.00000000
            print *, arange(0.0, 2.0) ! = arange(0.0, 2.0, 1.0)

            ! 始点，終点，間隔を指定．
            ! 0.00000000      0.200000003
            print *, arange(0.0, 0.2, 0.2)
        end block

        block
            ! 指定された数値の範囲[xmin, xmax]から外れた入力値xに対して，最も近い範囲内の値を返す．

            ! [-5, 5]の範囲から外れた値10に対して5を返す．
            ! 5
            print *, clip(10, -5, 5)

            ! [0.0, 0.1]の範囲から外れた値-1.0に対して0.0を返す．
            ! 0.00000000
            print *, clip(-1.0, 0.0, 0.1)
        end block

        block
            ! 二つの数の最大公約数を計算する．
            ! 6
            print *, gcd(48, 18)
        end block
    end subroutine ex_stdlib_math

    !| stdlib_linalgで定義されている手続の使用例．
    subroutine ex_stdlib_linalg()
        implicit none

        block
            real(real32), allocatable :: v(:)
            real(real32), allocatable :: A(:, :)

            ! ベクトル（1次元配列）を入力として，その値を対角成分にもつ行列を返す．
            ! [1, 1]を対角成分として行列を作る．
            !  i\j 1 2
            !    +-----
            !   1| 1 0
            !   2| 0 1
            v = [1, 1]
            A = diag(v)
            print *, A

            ! [1,2,3,4]を対角成分にもつ行列を返す．
            !  i\j 1  2  3  4
            !    +-----------
            !   1| 1  0  0  0
            !   2| 0  2  0  0
            !   3| 0  0  3  0
            !   4| 0  0  0  4
            A = diag(arange(1, 4))
            print *, A

            block
                real(real32), allocatable :: u(:)
                real(real32), allocatable :: l(:)
                real(real32), allocatable :: d(:)

                allocate (l(3), source=-1.)
                allocate (u(3), source=1.)
                allocate (d(4), source=-2.)

                ! 対角線を1下にずらし，[-1, -1, -1]を成分にもつ行列を返す．
                !  i\j 1  2  3  4
                !    +-----------
                !   1| 0  0  0  0
                !   2|-1  0  0  0
                !   3| 0 -1  0  0
                !   4| 0  0 -1  0
                A = diag(l, -1)
                print *, A

                ! 対角線を1上にずらし，[1, 1, 1]を成分にもつ行列を返す．
                !  i\j 1  2  3  4
                !    +-----------
                !   1| 0  1  0  0
                !   2| 0  0  1  0
                !   3| 0  0  0  1
                !   4| 0  0  0  0
                A = diag(u, 1)
                print *, A

                !  i\j 1  2  3  4
                !    +-----------
                !   1| 2  1  0  0
                !   2|-1  2  1  0
                !   3| 0 -1  2  1
                !   4| 0  0 -1  2
                A = diag(l, -1) + diag(d) + diag(u, 1)
                print *, A
            end block
        end block

        block
            ! 単位行列を返す．

            ! 2行2列の単位行列を返す．
            !  i\j 1 2
            !    +-----
            !   1| 1 0
            !   2| 0 1
            print *, eye(2)

            ! 3行3列の単位行列を返す．
            !  i\j 1  2  3
            !    +--------
            !   1| 1  0  0
            !   2| 0  1  0
            !   3| 0  0  1
            print *, eye(3)

            ! 2行1列の単位行列を返す
            !  i\j 1
            !    +--
            !   1| 1
            !   2| 0
            print *, eye(2, 1)

            ! 3行3列の単位行列を返す．
            !  i\j 1  2  3
            !    +--------
            !   1| 1  0  0
            !   2| 0  1  0
            !   3| 0  0  1
            print *, eye(3, 3)

            ! 3行2列の単位行列を返す．
            !  i\j 1  2
            !    +-----
            !   1| 1  0
            !   2| 0  1
            !   3| 0  0
            print *, eye(3, 2)
        end block

        block
            real(real32) :: A(3, 3)

            ! 行列のtraceを計算する．
            !  i\j 1  2  3
            !    +--------
            !   1| 1  0  0
            !   2| 0  1  0
            !   3| 0  0  1
            ! 3
            A = eye(3, 3)
            print *, trace(A)

            !  i\j 1  2  3
            !    +--------
            !   1| 1  4  7
            !   2| 2  5  8
            !   3| 3  6  9
            ! 15
            A = reshape([1, 2, 3, 4, 5, 6, 7, 8, 9], [3, 3])
            print *, trace(A)
        end block

        block
            real(real32), allocatable :: A(:, :), u(:), v(:)

            ! 直積u×v^Tを計算する．
            !  i\j  1  2  3
            !    +---------
            !   1|  4  5  6
            !   2|  8 10 12
            !   3| 12 15 18
            u = [real :: 1, 2, 3]
            v = [real :: 4, 5, 6]
            A = outer_product(u, v)
            print *, A
        end block
    end subroutine ex_stdlib_linalg

    !| stdlib_specialfunctionsで定義されている手続の使用例．
    subroutine ex_stdlib_specialfunctions()
        implicit none

        block
            real(real64) :: x
            x = 1d-1

            ! ルジャンドル多項式
            ! P_0(x) = 1
            ! 1.0000000000000000        1.0000000000000000
            print *, legendre(0, x), 1d0

            ! P_1(x) = x
            ! 0.10000000000000001       0.10000000000000001
            print *, legendre(1, x), x ! x

            ! P_2(x) = (3d0*x**2 - 1d0)/2d0
            ! -0.48499999999999999      -0.48499999999999999
            print *, legendre(2, x), (3d0*x**2 - 1d0)/2d0

            ! P_3(x) = (5d0*x**3 - 3d0*x)/2d0
            ! -0.14749999999999999      -0.14750000000000002
            print *, legendre(3, x), (5d0*x**3 - 3d0*x)/2d0

            ! P_10(x) = (46189d0*x**10 - 109395d0*x**8 + 90090d0*x**6 - 30030d0*x**4 + 3465d0*x**2 - 63d0)/256d0
            ! -0.12212499738710939      -0.12212499738710936
            print *, legendre(10, x), (46189d0*x**10 - 109395d0*x**8 + 90090d0*x**6 - 30030d0*x**4 + 3465d0*x**2 - 63d0)/256d0
        end block
    end subroutine ex_stdlib_specialfunctions

    !| stdlib_quadratureで定義されている手続の使用例．
    subroutine ex_stdlib_quadrature()
        implicit none

        real(real32) :: x(6), f(6)
        real(real32) :: w(6)

        x = linspace(-1., 1., 6)
        f = 5.*x**4
        ! x = [-1.0 -0.6 -0.2 0.2 0.6 1.0 ]
        ! f = [5.0 0.648 8E-03 8E-03  0.648 5.0 ]

        block
            ! 台形則で関数値fを積分する．
            ! 関数値と座標値を指定する．
            ! 2.52479982
            print *, trapz(f, x)

            ! 関数値とそのサンプリング点の間隔を指定する．
            ! 2.52480006
            print *, trapz(f, dx=0.4)

            ! サンプリング点の間隔の指定誤り．
            ! 3.15600014
            print *, trapz(f, dx=0.5)
        end block

        block
            ! 与えられたx座標値に対して，重み係数を返す．
            ! 0.199999988      0.400000006      0.400000036      0.400000006      0.399999976      0.199999988
            w = trapz_weights(x)
            print *, w

            ! 重み係数wと関数値fを用いて積分する．
            ! 0.999999940      0.259200007       3.19999922E-03   3.20000271E-03  0.259199977      0.999999940
            ! 2.52480006
            print *, f*w
            print *, sum(f*w)
        end block

        block
            ! シンプソン則で関数値fを積分する．
            ! 関数値と座標値を指定する．
            ! 2.05973339
            print *, simps(f, x)

            ! 関数値とそのサンプリング点の間隔を指定する．
            ! 2.05973339
            print *, simps(f, dx=0.4)

            ! サンプリング点の間隔の指定誤り．
            ! 2.57466650
            print *, simps(f, dx=0.5)
        end block

        block
            ! 与えられたx座標値に対して，重み係数を返す．
            ! 0.141666651      0.491666645      0.366666734      0.366666734      0.491666645      0.141666681
            w = simps_weights(x)
            print *, w

            ! 重み係数wと関数値fを用いて積分する．
            ! 0.708333254      0.318599999       2.93333293E-03   2.93333642E-03  0.318599999      0.708333373
            ! 2.05973339
            print *, f*w
            print *, sum(f*w)
        end block

        block
            real(real64) :: x(6), w(6)

            ! Gauss-Legendre求積法のノードと重みを計算する．
            ! -0.93246951420315205      -0.66120938646626448      -0.23861918608319693       0.23861918608319693       0.66120938646626448       0.93246951420315205
            ! 0.17132449237917019       0.36076157304813866       0.46791393457269126       0.46791393457269126       0.36076157304813866       0.17132449237917019
            call gauss_legendre(x, w)
            print *, x
            print *, w

            ! ノードと重みを使って，xが[-1, 1]の範囲で5x^4を積分する．
            ! 1.9999999999999987
            print *, sum(5.*x**4*w)
        end block

        block
            real(real64) :: x(6), w(6)

            ! Gauss-Legendre-Lobatto求積法のノードと重みを計算する．
            ! -1.0000000000000000      -0.76505532392946474      -0.28523151648064510       0.28523151648064510       0.76505532392946474        1.0000000000000000
            ! 6.6666666666666666E-002  0.37847495629784678       0.55485837703548646       0.55485837703548646       0.37847495629784678        6.6666666666666666E-002
            call gauss_legendre_lobatto(x, w)
            print *, x
            print *, w

            ! ノードと重みを使って，xが[-1, 1]の範囲で5x^4を積分する．
            ! 1.9999999999999993
            print *, sum(5.*x**4*w)
        end block
    end subroutine ex_stdlib_quadrature

    !| stdlib_randomで定義されている手続の使用例．
    subroutine ex_stdlib_random()
        implicit none

        integer(int32) :: seed_put, seed_get

        ! 乱数の種を設定・取得する．
        seed_put = 135792468
        call random_seed(seed_put, seed_get)

        ! 入力された整数のkindに基づいて，その整数の範囲で擬似乱数を生成する．
        ! 1バイト整数の範囲 [-2^7, 2^7 -1]内で乱数を生成する．
        ! -90
        print *, dist_rand(0_int8)

        ! 2バイト整数の範囲 [-2^15, 2^15 -1]内で乱数を生成する．
        ! -32725
        print *, dist_rand(0_int16)

        ! 4バイト整数の範囲 [-2^31, 2^31 -1]内で乱数を生成する．
        ! -1601563881
        print *, dist_rand(0_int32)

        ! 8バイト整数の範囲 [-2^63, 2^63 -1]内で乱数を生成する．
        ! 180977695517992208
        print *, dist_rand(0_int64)
    end subroutine ex_stdlib_random

    !| stdlib_statsで定義されている手続の使用例．
    subroutine ex_stdlib_stats()
        implicit none
        real(real32) :: x(1:6) = [1., 2., 3., 4., 5., 6.]
        real(real32) :: y(1:2, 1:3) = reshape([1., 2., 3., 4., 5., 6.], [2, 3])

        ! x = [1,2,3,4,5,6]^T
        ! y =
        !   i\j 1  2  3
        !     +--------
        !    1| 1  3  5
        !    2| 2  4  6

        block
            ! 平均値を計算する．
            ! 配列の全要素の平均を計算する．=(1+2+3+4+5+6)/6
            ! 3.50000000
            print *, mean(x)

            ! 配列の全要素のうち，3より大きい値の平均を計算する．=(4_5+6)/3
            ! 5.00000000
            print *, mean(x, mask=(x > 3.))

            ! 配列の全要素の平均を計算する．=(1+2+3+4+5+6)/6
            ! 3.50000000
            print *, mean(y)

            ! 配列の第1次元方向成分の平均を計算する．=[(1+2)/2, (3+4)/2, (5+6)/2]
            ! 1.50000000       3.50000000       5.50000000
            print *, mean(y, dim=1)

            ! 配列の第1次元方向成分のうち，3より大きい値の平均を計算する．=[存在しない, 4/1, (5+6)/2]
            ! 成分が0個の場合，0/0のためNaNになる．
            ! NaN   4.00000000       5.50000000
            print *, mean(y, dim=1, mask=(y > 3.))
        end block

        block
            real(real32) :: x(1:6) = [1., 1., 6., 7., 8., 9.]
            real(real32) :: y(1:3, 1:2) = reshape([0., 1., 6., 7., 8., 9.], [3, 2])
            ! x = [1,1,6,7,8,9]^T
            ! y =
            !   i\j 1  2
            !     +-----
            !    1| 0  7
            !    2| 1  8
            !    3| 6  9

            ! 中央値を計算する．
            ! 配列の全要素の成分から中央値を計算する．=(6+7)/2
            ! 6.50000000
            print *, median(x)

            ! 配列の全要素の成分のうち6より大きい値[7,8,9]の中央値を計算する．
            ! 8.00000000
            print *, median(x, mask=(x > 6.))

            ! 配列の全要素の成分から中央値を計算する．=(6+7)/2
            ! 6.50000000
            print *, median(y)

            ! 配列の第1次元方向成分の中央値を計算する．= [median([0,1,6]), median(7,8,9)]
            ! 1.00000000       8.00000000
            print *, median(y, dim=1)

            ! 配列の第1次元方向成分のうち，3より大きい値の中央値を計算する．=[median([6]), median(7,8,9)]
            ! 6.00000000       8.00000000
            print *, median(y, dim=1, mask=(y > 3.))
        end block

        block
            ! 配列の分散varianceを計算する．
            ! 計算式はvar(array) = 1/(n-1) sum_i (array(i) - mean(array))^2, nは要素数．

            ! x = [1,2,3,4,5,6]^T
            ! y =
            !   i\j 1  2  3
            !     +--------
            !    1| 1  3  5
            !    2| 2  4  6

            ! 全要素の分散を計算する．
            ! 3.50000000
            print *, var(x)

            ! corrected=.false.の場合(n-1)ではなくnでスケーリングする．
            ! 2.91666675
            print *, var(x, corrected=.false.)

            ! 全要素の分散を計算する．
            ! 3.50000000
            print *, var(y)

            ! 配列の第1次元方向成分の分散を計算する．=[var([1,2]), var([3,4]), var([5,6])]
            ! 0.500000000      0.500000000      0.500000000
            print *, var(y, dim=1)

            ! 配列の第1次元方向成分のうち，3より大きい値の分散を計算する．=[var([]), var([4]), var([5,6])]
            ! NaN              NaN  0.500000000
            print *, var(y, dim=1, mask=y > 3.)

            ! 配列の第1次元方向成分のうち，3より大きい値の分散を計算する．=[var([]), var([4]), var([5,6])]
            ! n-1ではなくnでスケーリングする．
            ! NaN   0.00000000      0.250000000
            print *, var(y, dim=1, mask=y > 3., corrected=.false.)
        end block

        block
            ! 指定された配列の次元における共分散covarianceを計算する．
            ! 計算式はcov(array) = 1/(n-1) sum_i (array(i) - mean(array) * (array(i) - mean(array))), nは要素数．

            ! x = [1,2,3,4,5,6]^T
            ! y =
            !   i\j 1  2  3
            !     +--------
            !    1| 1  3  5
            !    2| 2  4  6

            ! 全要素の共分散を計算する．
            ! 3.50000000
            print *, cov(x, dim=1)

            ! n-1ではなくnでスケーリングする．
            ! 2.91666675
            print *, cov(x, dim=1, corrected=.false.)

            ! 配列の第1次元方向成分の分散を計算する．
            ! yの場合，計算中に用いているmeanが3成分の配列を返すので，各次元で3個の共分散が得られ，合計で3x3=9個の値が返される．
            ! 0.500000000      0.500000000      0.500000000      0.500000000      0.500000000      0.500000000      0.500000000      0.500000000      0.500000000
            print *, cov(y, dim=1)
        end block

        block
            real(real32) :: y(1:2, 1:3) = reshape([-1., 40., -3., 4., 10., 6.], [2, 3])

            ! x = [1,2,3,4,5,6]^T
            ! y =
            !   i\j  1  2   3
            !     +----------
            !    1| -1 -3  10
            !    2| 40  4   6

            ! Pearsonの相関係数を計算する．
            ! 計算式はcorr(x, y) = cov(x, y) / sqrt( var(x) * var(y))

            ! 全要素を用いて相関係数を計算する．
            ! 1.00000000
            print *, corr(x, dim=1)

            ! 配列の第1次元方向成分の分散を計算する．
            ! yの場合，計算中に用いているcovが9成分の配列を返すので，corrの戻り値も9個になる．
            ! 1.00000000       1.00000000     -0.999999940       1.00000000       1.00000000     -0.999999940      -1.00000000      -1.00000000      0.999999940
            print *, corr(y, dim=1)

            ! 配列の第2次元方向成分の分散を計算する．
            ! 計算中に用いているcovが4成分の配列を返すので，corrの戻り値も4個になる．
            ! 1.00000000     -0.324803889     -0.324803889      0.999999940
            print *, corr(y, dim=2)
        end block

        block

            ! x = [1,2,3,4,5,6]^T

            ! k次のモーメントを計算する．
            ! 計算式は moment(array) = 1/n sum_i (array(i) - mean(array))^k
            ! 中心が与えられている時の計算式はmoment(array) = 1/n sum_i (array(i) - center)^k

            ! 配列の全要素を用いて2次のモーメントを計算する．
            ! 2.91666675
            print *, moment(x, order=2)

            ! 配列の全要素を用いて2次のモーメントを計算する．
            ! 2.91666675
            print *, moment(y, order=2)

            ! 配列の第1次元方向成分を用いて2次のモーメントを計算する．=[moment([1,2], 2), moment([3,4], 2), moment([5,6], 2)]
            ! 0.250000000      0.250000000      0.250000000
            print *, moment(y, order=2, dim=1)

            ! 配列の第1次元方向成分のうち，3より大きい値を用いて2次のモーメントを計算する．=[moment([], 2), moment([4], 2), moment([5,6], 2)]
            ! NaN   0.00000000      0.250000000
            print *, moment(y, 2, 1, mask=(y > 3.))

            ! 中心を与えて2次のモーメントを計算する．
            ! 15.1666670
            print *, moment(x, 2, center=0.)

            ! 中心を与えて，配列の第1次元方向成分を用いて2次のモーメントを計算する．=[moment([1,2], 2, 0), moment([3,4], 2, 0), moment([5,6], 2, 0)]
            ! 1.50000000       3.50000000       5.50000000
            print *, moment(y, 1, 1, center=0.)
        end block
    end subroutine ex_stdlib_stats

    !| stdlib_stats_distribution_uniformで定義されている手続の使用例．
    subroutine ex_stdlib_stats_distribution_uniform()
        use :: stdlib_math
        implicit none
        real(real32) :: x(10)
        integer(int32) :: n(10)
        complex(real32) :: z(10)
        integer :: seed_put, seed_get

        n = arange(10)
        x = arange(10.)
        z = linspace(cmplx(1., 1.), cmplx(10., 10.), 10)
        ! n = [1 2 3 4 5 6 7 8 9 10]
        ! x = [1. 2. 3. 4. 5. 6. 7. 8. 9. 10.]
        ! z = [(1.,1.) (2.,2.) (3.,3.) (4.,4.) (5.,5.) (6.,6.) (7.,7.) (8.,8.) (9..9.) (10.,10.)]

        block
            seed_put = 32165498
            call random_seed(seed_put, seed_get)

            ! Fisher-Yatesアルゴリズムに基づいてランダムに並び替える．

            ! 整数を並び替える．
            ! 10 6 9 2 8 1 3 5 7 4
            print *, shuffle(n)

            ! 実数を並び替える．
            ! 5. 10. 9. 4. 3. 8. 2. 1. 7. 6.
            print *, shuffle(x)

            ! 複素数を並び替える．
            ! (8.,8.) (7.,7.) (4.,4.) (1.,1.) (5.,5.) (9.,9.) (6.,6.) (3.,3.) (2.,2.) (10.,10.)
            print *, shuffle(z)
        end block

        block

            seed_put = 1234567
            call random_seed(seed_put, seed_get)

            ! [0,1]の範囲で一様分布を返す．

            ! 引数を何も指定しなければ，[0,1]の範囲で，単精度実数として値を返す．
            ! 0.161520019
            print *, rvs_uniform()

            ! scaleが指定されると，[0,scale]の範囲で一様分布を返す．
            ! scaleの型によって戻り値の型が決定される．
            ! [0,3.]の範囲で単精度実数値を返す．
            ! 1.65974522
            print *, rvs_uniform(scale=3.0)

            ! [0,20]の範囲で整数値を返す．
            ! 14
            print *, rvs_uniform(scale=20)

            ! locとscaleが指定されると，[loc,loc+scale]の範囲で一様分布を返す．
            ! locおよびscaleの型によって戻り値の型が決定される．
            ! [-0.5,0.5]の範囲で値を返す．
            ! 0.486900032
            print *, rvs_uniform(loc=-0.5, scale=1.0)

            ! arrayを指定すると，array_sizeの数だけ値を返す．
            ! -0.885760069     -0.219811499     -0.145343125     -0.535613418     -0.715533257     -0.251231968     -0.698165953     -0.662991643     -0.431156635     -0.403834939
            print *, rvs_uniform(loc=-1.0, scale=1.0, array_size=10) ![-1.,1.]

            block
                real :: a(3, 4, 5), b(3, 4, 5)

                ! [-0.5, 0.5]の範囲で，60個の値を返す．
                a = -0.5
                b = 1.0
                print *, rvs_uniform(loc=a, scale=b)
            end block
        end block

        block

            seed_put = 1234567
            call random_seed(seed_put, seed_get)

            ! 一様分布の確率密度関数を計算する．

            ! [2, 12]の範囲で，x=3における確率密度関数を計算する．
            ! 9.09090936E-02
            print *, pdf_uniform(x=3, loc=2, scale=10)

            ! [0, 1]の範囲で，x=0.5における確率密度関数を計算する．
            ! 1.00000000
            print *, pdf_uniform(0.5, 0.0, 1.0)

            ! [-1, 1]の範囲で，x=0.7における確率密度関数を計算する．
            ! 0.500000000
            print *, pdf_uniform(0.7, -1.0, 2.0)

            block
                real(real32) :: a(3, 4, 5), b(3, 4, 5), x(3, 4, 5)

                a(:, :, :) = 0.
                b(:, :, :) = 2.
                ! [0,2]の範囲で連続分布の値を60個取得する．
                x = reshape(rvs_uniform(0., 2., size(a)), shape(a))
                ! [0,2]の範囲で，xにおける確率密度関数を60個計算する．
                print *, pdf_uniform(x, a, b)
            end block
        end block

        block

            seed_put = 1234567
            call random_seed(seed_put, seed_get)

            ! 累積分布関数を計算する．
            ! [0, 1]の範囲で，x=0.5における累積分布関数を計算する．
            ! 0.500000000
            print *, cdf_uniform(x=0.5, loc=0., scale=1.)

            ! [-1.0, 1.0]の範囲で，x=0.7における累積分布関数を計算する
            ! 0.850000024
            print *, cdf_uniform(0.7, -1.0, 2.0)

            ! [2, 12]の範囲で，x=6における累積分布関数を計算する
            ! 0.454545468
            print *, cdf_uniform(x=6, loc=2, scale=10) ! a cumulative at 6 in [2, 10]

            block
                real(real32) :: a(3, 4, 5), b(3, 4, 5), x(3, 4, 5)

                a(:, :, :) = -1.
                b(:, :, :) = 2.
                ! [0,2]の範囲で連続分布の値を60個取得する．
                x = reshape(rvs_uniform(-1.0, 2.0, size(a)), shape(a))
                ! [0,2]の範囲で，xにおける累積分布関数を60個計算する．
                print *, cdf_uniform(x, a, b)
            end block
        end block
    end subroutine ex_stdlib_stats_distribution_uniform

    !| stdlib_sortingで定義されている手続の使用例．
    subroutine ex_stdlib_sorting()
        implicit none

        integer(int32), allocatable :: array(:)
        array = [5, 4, 3, 1, 10, 4, 9]

        block
            ! イントロソートを利用して並び替える．
            ! 1 3 4 4 5 9 10
            call sort(array)
            print *, array

            ! イントロソートを利用して逆順に並び替える．
            ! 10 9 5 4 4 3 1
            call sort(array, reverse=.true.)
            print *, array
        end block

        block
            integer(int32), allocatable :: work(:)

            array = [5, 4, 3, 1, 10, 4, 9]
            allocate (work, mold=array)

            ! Rustのソートアルゴリズムを利用して並び替える．
            ! 1 3 4 4 5 9 10
            call ord_sort(array, work)
            print *, array

            ! Rustのソートアルゴリズムを利用して逆順に並び替える．
            ! 10 9 5 4 4 3 1
            call ord_sort(array, work, reverse=.true.)
            print *, array
        end block

        block
            integer(int32), allocatable :: work(:)
            integer(int_size), allocatable :: index(:), iwork(:)

            array = [5, 4, 3, 1, 10, 4, 9]
            allocate (index(1:size(array)))
            allocate (work(1:size(array)/2))
            allocate (iwork(1:size(array)/2))

            ! ord_sortを利用して並び替えのインデックスを返す．
            call sort_index(array, index, work, iwork)
            ! 1 3 4 4 5 9 10
            ! 4 3 2 6 1 7 5
            print *, array
            print *, index

            ! indexを用いて並び替える．
            array = [5, 4, 3, 1, 10, 4, 9]
            array = array(index)
            ! array(1) = array(index(1)) = array(4) = 1
            ! array(2) = array(index(2)) = array(3) = 3
            ! array(3) = array(index(3)) = array(2) = 4
            ! array(4) = array(index(4)) = array(6) = 4
            ! array(5) = array(index(5)) = array(1) = 5
            ! array(6) = array(index(6)) = array(7) = 9
            ! array(7) = array(index(7)) = array(5) = 10
            ! 1 3 4 4 5 9 10
            print *, array
        end block
    end subroutine ex_stdlib_sorting
end module ex_stdlib_function


program notas
implicit none

real, dimension(1:36) :: p1, p2, m
real :: conta, contr, pa, pr
integer :: c

open(1, FILE = "NOTAS.csv")

read(1,*)

do c = 1,36
    read(1,*) p1(c), p2(c)
end do

close(1)

do c = 1,36
    m(c) = (p1(c)+p2(c))/2d0
end do

conta = 0
contr = 0

do c = 1,36

    if (m(c) .ge. 5.0) then
	write(*,*) p1(c), p2(c), m(c), "A"
	conta = conta + 1
	pa = (conta/36d0)*100

    else if (m(c) .lt. 5.0) then
	write(*,*) p1(c), p2(c), m(c), "R"
	contr = contr + 1
	pr = (contr/36d0)*100

    end if

end do

write(*,*) "O número de aprovados é",conta,"e a porcentagem é",pa
write(*,*) "O número de reprovados é",contr,"e sua porcentagem é",pr

open(3,file = "notasfinais.txt")

1 format(3(F5.2, 1X),A1)

    do c = 1,36

	if (m(c) .ge. 5.0) then
    	    write(3,1) p1(c), p2(c), m(c), "A"
	else if (m(c) .lt. 5.0) then
	    write(3,1) p1(c), p2(c), m(c), "R"

	end if

    end do

close (3)

end program notas


module const

  implicit none

	! geo-physical constants

  real,parameter :: Radius_of_Earth		= 6.371*1.e6	! m
  real,parameter :: Acc_dueto_Gravity		= 9.8100	! m/s/s
  real,parameter :: Earths_angular_velocity	= 7.292e-5	! /s

  real,parameter :: R_EARTH	= Radius_of_Earth
  real,parameter :: G_EARTH	= Acc_dueto_Gravity
  real,parameter :: OMEGA	= Earths_angular_velocity

				! = 2*sin(ONEPI/4) = sqrt(2.)*OMEGA
  real,parameter :: Coriolis_45			= 1.4142136 * OMEGA
  real,parameter :: Rate_of_Coriolis_45		= Coriolis_45 / R_EARTH

  real,parameter :: BETA	= Rate_of_Coriolis_45

				! = 4*atan(1.)
  real,parameter :: ONEPI=3.1415927

  real,parameter :: T_ref	= 273.15	! Kelvin
  real,parameter :: P_ref	= 1000.		! mbar
  real,parameter :: R_dry	= 287.00    ! Gas constant of dry air

  real,parameter :: RHOBAR = 1.24 ! mean sea-level density, kg/m^3
end module const
!.


! $UWHPSC/codes/f2py/jacobi1

! For use with f2py:
!   $ f2py -m jacobi1 -c jacobi1.f90
! Then in Python you can import jacobi1 and use it to take a fixed number of
! iterations using Jacobi in one space dimension to solve
!      u(i-1) - 2*u(i) + u(i+1) = -dx**2 * f(i).
! Python call:
!   >>> u = jacobi1.iterate(u0, iters, f)
! where
!   iters is the number of iterations to take,
!   u0(0:n+1) is the initial guess (with desired boundary values
!             in u0(0) and u0(n+1), these are not changed.
!   f(0:n+1) contains values of f(x) at each grid point.
!

subroutine iterate(u0,iters,f,u,n)
    implicit none
    integer, intent(in) :: n, iters
    real(kind=8), dimension(0:n+1), intent(in) :: u0, f
    real(kind=8), dimension(0:n+1), intent(out) :: u

    ! local variables:
    real(kind=8), dimension(:), allocatable :: uold
    real(kind=8) :: dx
    integer :: i, iter

    ! allocate storage for boundary points too:
    allocate(uold(0:n+1))

    ! grid spacing:
    dx = 1.d0 / (n+1.d0)

    uold = u0

    ! initialize boundary values of u:
    u(0) = u0(0)
    u(n+1) = u0(n+1)

    ! take the iterations requested:
    do iter=1,iters
        do i=1,n
            u(i) = 0.5d0*(uold(i-1) + uold(i+1) + dx**2*f(i))
            enddo
        uold = u
        enddo

end subroutine iterate


!
!
FUNCTION J_INDEX(L,M)
IMPLICIT NONE
INTEGER J_INDEX, L, M
!
! given l (degree) and m(order), this function computes
! the j-index "J", with J=l(l+1)/2+m+1 - GS 14-09-2007
!
 If(l<0.or.m<0.or.m>l) then
	  Write(88,*) "J_INDEX: The degree and order are out of bounds"
 	  Write(88,*) "The program will STOP -------------------------"
 	  Write(*, *) "J_INDEX: The degree and order are out of bounds"
 	  Write(*, *) "The program will STOP -------------------------"
          call stop_config
	  Stop
 endif
!
  J_INDEX = l*(l+1)/2+m+1
!
END FUNCTION J_INDEX
!
!
!


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C          PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE HWSCRT TO SOLVE
C     THE EQUATION
C
C     (D/DX)(DU/DX) + (D/DY)(DU/DY) - 4*U
C
C     = (2 - (4 + PI**2/4)*X**2)*COS((Y+1)*PI/2)
C
C     WITH THE BOUNDARY CONDITIONS
C     ON THE RECTANGLE 0 .LT. X .LT. 2, -1 .LT. Y .LT. 3 WITH THE
C
C     U(0,Y) = 0
C                                          -1 .LE. Y .LE. 3
C     (DU/DX)(2,Y) = 4*COS((Y+1)*PI/2)
C
C     AND WITH U PERIODIC IN Y.
C          THE X-INTERVAL WILL BE DIVIDED INTO 40 PANELS AND THE
C     Y-INTERVAL WILL BE DIVIDED INTO 80 PANELS.
C
      DIMENSION       F(45,82)   ,BDB(81)    ,W(1103)    ,X(41)      ,
     1                Y(81)
C
C     FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF.  ALSO NOTE THAT W
C     IS DIMENSIONED 4*(N+1) + (13 + INT(LOG2(N+1)))*(M+1) .
C
      IDIMF = 45
      A = 0.
      B = 2.
      M = 40
      MBDCND = 2
      C = -1.
      D = 3.
      N = 80
      NBDCND = 0
      ELMBDA = -4.
C
C     AUXILIARY QUANTITIES.
C
      PI = PIMACH(DUM)
      PIBY2 = PI/2.
      PISQ = PI**2
      MP1 = M+1
      NP1 = N+1
C
C     GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING
C     BOUNDARY DATA AND THE RIGHT SIDE OF THE HELMHOLTZ EQUATION.
C
      DO 101 I=1,MP1
         X(I) = FLOAT(I-1)/20.
  101 CONTINUE
      DO 102 J=1,NP1
         Y(J) = -1.+FLOAT(J-1)/20.
  102 CONTINUE
C
C     GENERATE BOUNDARY DATA.
C
      DO 103 J=1,NP1
         BDB(J) = 4.*COS((Y(J)+1.)*PIBY2)
  103 CONTINUE
C
C     BDA, BDC, AND BDD ARE DUMMY VARIABLES.
C
      DO 104 J=1,NP1
         F(1,J) = 0.
  104 CONTINUE
C
C     GENERATE RIGHT SIDE OF EQUATION.
C
      DO 106 I=2,MP1
         DO 105 J=1,NP1
            F(I,J) = (2.-(4.+PISQ/4.)*X(I)**2)*COS((Y(J)+1.)*PIBY2)
  105    CONTINUE
  106 CONTINUE
      CALL HWSCRT (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F,
     1             IDIMF,PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR.  THE EXACT SOLUTION IS
C                U(X,Y) = X**2*COS((Y+1)*PIBY2)
C
      ERR = 0.
      DO 108 I=1,MP1
         DO 107 J=1,NP1
            Z = ABS(F(I,J)-X(I)**2*COS((Y(J)+1.)*PIBY2))
            IF (Z .GT. ERR) ERR = Z
  107    CONTINUE
  108 CONTINUE
      PRINT 1001 , IERROR,ERR,W(1)
      STOP
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE HWSCRT EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 5.36508E-04/
     4        12X,32HREQUIRED LENGTH OF W ARRAY = 880//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5/
     7        12X,28HREQUIRED LENGTH OF W ARRAY =,F4.0)
C
      END


!***************************************************************************************************
!> Subroutine factorial
!Factorial function returns n!
!This is limited to numbers n<17 for computer feasibility.
!***************************************************************************************************
integer function factorial(n)
	implicit none

	integer, intent(in) :: n
	integer :: i, temp

	if(n >= 17) then
		write(*,*) 'error factorial too large'
	endif

	temp=1
	do i=1,n
		temp=temp*i
	end do
	factorial=temp
end function

!***************************************************************************************************
!> Subroutine binomial
!Binomial function returns n choose k
!***************************************************************************************************
integer function binomial(n,k)
	implicit none

	integer, intent(in) :: n, k
	integer, external :: factorial

	binomial=factorial(n)/(factorial(k)*factorial(n-k))

end function

!***************************************************************************************************
!> function TotalRateCheck() - checks if our total rate still matches the actual total rate
!This function is used as a diagnostic tool, it calcuates the total rate of all reactions in the
!system and compares it to totalRate, in order to test whether totalRate is being properly updated.
!***************************************************************************************************
double precision function TotalRateCheck()
	use mod_constants
	use mod_globalVariables
	use mod_structures
	implicit none

	integer :: i
	double precision :: rate, rateCell, rateCascade
	type(reaction), pointer :: reactionCurrent
	type(cascade), pointer :: cascadeCurrent

	CascadeCurrent=>ActiveCascades
	rate=0d0

	!Compute total rate of all reactions in the coarse mesh
	do i=1,numCells
		rateCell=0d0
		reactionCurrent=>reactionList(i)

		do while(associated(reactionCurrent))
			rate=rate+reactionCurrent%reactionRate
			rateCell=rateCell+reactionCurrent%reactionRate
			reactionCurrent=>reactionCurrent%next
		end do

		if(dabs(totalRateVol(i)-rateCell) > 1d0) then
			write(*,*) 'Error: total rate differs significantly from expected in cell', i
			write(*,*) 'TotalRateVol', totalRateVol(i), 'expected value', rateCell
			call MPI_ABORT(comm,ierr)
		end if
		totalRateVol(i)=rateCell			!Also updating the total rate within each volume element
	end do

	!Compute total rate of all reactions in the fine meshes by going through active cascades
	do while(associated(CascadeCurrent))

		do i=1,numCellsCascade
			rateCascade=0d0
			reactionCurrent=>CascadeCurrent%reactionList(i)
			do while(associated(reactionCurrent))
				rate=rate+reactionCurrent%reactionRate
				rateCascade=rateCascade+reactionCurrent%reactionRate
				reactionCurrent=>reactionCurrent%next
			end do

			if(dabs(CascadeCurrent%totalRate(i)-rateCascade) > 1d0) then
				write(*,*) 'Error: total rate differs significantly from expected in cascade', &
						CascadeCurrent%cascadeID
				write(*,*) 'TotalRateCascade', CascadeCurrent%totalRate(i), 'Expected Value', rateCascade
			end if
			CascadeCurrent%totalRate(i)=rateCascade
		end do
		CascadeCurrent=>CascadeCurrent%next
	end do

	!Compare rate to totalRate and return error if different
	!if(myProc%taskid==MASTER) then
	!	if (rate==totalRate) then
	!		write(*,*) 'TotalRate correct', totalRate
	!	else
	!		write(*,*) 'TotalRate incorrect ', 'totalRate=', totalRate, 'actual total rate=', rate
	!	end if
	!end if

	TotalRateCheck=rate
end function

!***************************************************************************************************
!> Function total rate cascade - finds total reaction rate within cascade
!***************************************************************************************************
double precision function totalRateCascade(CascadeCurrent)
	use mod_structures
	use mod_globalVariables
	implicit none

	type(cascade), pointer, intent(in) :: CascadeCurrent
	integer :: i
	double precision :: rateSum

	rateSum=0d0
	do i=1,numCellsCascade
		rateSum=rateSum+CascadeCurrent%totalRate(i)
	end do
	totalRateCascade=rateSum

end function


!!     ==================================================================
subroutine clawpack46_setaux(mbc,mx,my,mz,xlower,ylower,zlower, &
                  dx,dy,dz,maux,aux)
!!     ==================================================================

    !!
    !!   # set auxiliary arrays
    !!
    !!   # advection
    !!   #    aux(i,j,k,1) is u velocity on left face of cell
    !!   #    aux(i,j,k,2) is v velocity on bottom face of cell
    !!   #    aux(i,j,k,3) is w velocity on back face of cell
    !!

    implicit none

    integer  :: mx, my, mz, mbc, maux
    double precision :: xlower, ylower, zlower, dx, dy, dz
    double precision :: aux(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,maux)

    double precision :: xc(1-mbc:mx+mbc)
    double precision :: yc(1-mbc:my+mbc)
    double precision :: zc(1-mbc:mz+mbc)

    integer :: i,j,k
    double precision :: dx2, dy2, dz2, compute_u, compute_v, compute_w

    do i = 1-mbc,mx+mbc
        xc(i) = xlower + (i-0.5d0)*dx
    enddo

    do j = 1-mbc,my+mbc
        yc(j) = ylower + (j-0.5d0)*dy
    end do

    do k = 1-mbc,mz+mbc
        zc(k) = zlower + (k-0.5d0)*dz
    end do

    dx2 = 0.5d0*dx
    dy2 = 0.5d0*dy
    dz2 = 0.5d0*dz

    do  k = 1-mbc,mz+mbc
        do j = 1-mbc,my+mbc
            do i = 1-mbc,mx+mbc
                aux(i,j,k,1) = compute_u(xc(i)-dx2, yc(j),zc(k))
                aux(i,j,k,2) = compute_v(xc(i),yc(j)-dy2, zc(k))
                aux(i,j,k,3) = compute_w(xc(i),yc(j), zc(k)-dz2)
            enddo
        enddo
    enddo

    return
end subroutine clawpack46_setaux

double precision function compute_u(x,y,z)
    implicit none
    double precision :: x,y,z,pi, pi2

    common /compi/ pi, pi2

    compute_u = 2.d0 * dsin(pi*x)**2 * dsin(pi2*y) * dsin(pi2*z)
end function compute_u

double precision function compute_v(x,y,z)
    implicit none
    double precision :: x,y,z,pi, pi2

    common /compi/ pi, pi2

    compute_v = -dsin(pi2*x) * dsin(pi*y)**2 * dsin(pi2*z)
end function compute_v

double precision function compute_w(x,y,z)
    implicit none
    double precision :: x,y,z,pi, pi2

    common /compi/ pi, pi2

    compute_w = -dsin(pi2*x) * dsin(pi2*y) * dsin(pi*z)**2
end function compute_w