From 345dfbc251090567fa91f51603a0edefebdcf7a2 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 10:42:16 -0500 Subject: [PATCH 01/42] initial commit --- src/Makefile.manual | 22 +- src/stdlib_stats_distribution_gamma.fypp | 319 +++++++++++++++++++++++ 2 files changed, 338 insertions(+), 3 deletions(-) create mode 100644 src/stdlib_stats_distribution_gamma.fypp diff --git a/src/Makefile.manual b/src/Makefile.manual index 872f704c0..4617499ba 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -1,4 +1,4 @@ -SRC = f18estop.f90 \ +noSRC = f18estop.f90 \ stdlib_ascii.f90 \ stdlib_bitsets.f90 \ stdlib_bitsets_64.f90 \ @@ -15,8 +15,11 @@ SRC = f18estop.f90 \ stdlib_stats.f90 \ stdlib_stats_mean.f90 \ stdlib_stats_moment.f90 \ - stdlib_stats_var.f90 - + stdlib_stats_var.f90 \ + stdlib_stats_distribution_PRNG.f90 \ + stdlib_stats_distribution_uniform.f90 \ + stdlib_stats_distribution_normal.f90 + LIB = libstdlib.a @@ -67,6 +70,16 @@ stdlib_stats_var.o: \ stdlib_optval.o \ stdlib_kinds.o \ stdlib_stats.o +stdlib_stats_distribution_PRNG.o: stdlib_kinds.o +stdlib_stats_distribution_uniform.o: \ + stdlib_kinds.o \ + stdlib_error.o \ + stdlib_stats_distribution_PRNG.o +stdlib_stats_distribution_normal.o: \ + stdlib_kinds.o \ + stdlib_error.o \ + stdlib_stats_distribution.PRNG.o \ + stdlib_stats_distribution.uniform.o # Fortran sources that are built from fypp templates stdlib_bitsets_64.f90: stdlib_bitsets_64.fypp @@ -80,3 +93,6 @@ stdlib_stats.f90: stdlib_stats.fypp stdlib_stats_mean.f90: stdlib_stats_mean.fypp stdlib_stats_moment.f90: stdlib_stats_moment.fypp stdlib_stats_var.f90: stdlib_stats_var.fypp +stdlib_stats_distribution_PRNG.f90: stdlib_stats_distribution_PRNG.fypp +stdlib_stats_distribution_uniform.f90: stdlib_stats_distribution_uniform.fypp +stdlib_stats_distribution_normal.f90: stdlib_stats_distribution_normal.fypp \ No newline at end of file diff --git a/src/stdlib_stats_distribution_gamma.fypp b/src/stdlib_stats_distribution_gamma.fypp new file mode 100644 index 000000000..f6d0a516b --- /dev/null +++ b/src/stdlib_stats_distribution_gamma.fypp @@ -0,0 +1,319 @@ +#:include "common.fypp" +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES +Module stdlib_stats_distribution_gamma + use stdlib_kinds + use stdlib_error, only : error_stop + use stdlib_stats_distribution_PRNG, only : dist_rand + use stdlib_stats_distribution_uniform, only : uni=>uniform_distribution_rvs + use stdlib_stats_distribution_normal, only : rnor=>normal_distribution_rvs + use stdlib_stats_distribution_special, only : ingamma=>ingamma_low, log_gamma + + implicit none + private + integer(int64), parameter :: INT_ONE = 1_int64 + real, parameter :: tol = 1.0E-5, sq = 0.0331 + real, save :: alpha = 0., d, c + + public :: gamma_distribution_rvs + public :: gamma_distribution_pdf + public :: gamma_distribution_cdf + + interface gamma_distribution_rvs + !! Version experimental + !! + !! Gamma Distribution Random Variates + !! ([Specification](../page/specs/stdlib_stats_distribution_gamma.html# + !! description)) + !! + #:for k1, t1 in RC_KINDS_TYPES + module procedure gamma_dist_rvs_1_${t1[0]}$${k1}$ ! 1 argument + #:endfor + + #:for k1, t1 in RC_KINDS_TYPES + module procedure gamma_dist_rvs_${t1[0]}$${k1}$ ! 2 arguments + #:endfor + + #:for k1, t1 in RC_KINDS_TYPES + module procedure gamma_dist_rvs_array_${t1[0]}$${k1}$ ! 3 arguments + #:endfor + end interface gamma_distribution_rvs + + interface gamma_distribution_pdf + !! Version experimental + !! + !! Gamma Distribution Probability Density Function + !! ([Specification](../page/specs/stdlib_stats_distribution_gamma.html# + !! description)) + !! + #:for k1, t1 in RC_KINDS_TYPES + module procedure gamma_dist_pdf_${t1[0]}$${k1}$ + #:endfor + end interface gamma_distribution_pdf + + interface gamma_distribution_cdf + !! Version experimental + !! + !! Gamma Distribution Cumulative Distribution Function + !! ([Specification](../page/specs/stdlib_stats_distribution_gamma.html# + !! description)) + !! + #:for k1, t1 in RC_KINDS_TYPES + module procedure gamma_dist_cdf_${t1[0]}$${k1}$ + #:endfor + end interface gamma_distribution_cdf + + + contains + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function gamma_dist_rvs_1_${t1[0]}$${k1}$(shape) result(res) + ! Gamma random variate + ! + ${t1}$, intent(in) :: shape + ${t1}$ :: res + ${t1}$ :: x, v, u, zz + + if(shape <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & + //" shape parameter must be greater than zero") + zz = shape + if(zz < 1._${k1}$) zz = 1._${k1}$ + zz + if(abs(real(zz) - alpha) > tol) then + alpha = real(zz) + d = alpha - 1. / 3. + c = 1. / (3. * sqrt(d)) + endif + do + do + x = rnor( ) + v = 1._${k1}$ + c * x + v = v * v * v + if(v > 0.) exit + end do + x = x * x + u = uni( ) + if(u < (1._${k1}$ - sq * x * x)) exit + if(log(u) < 0.5_${k1}$ * x + d * (1._${k1}$ - v + log(v))) exit + end do + res = d * v + if(shape < 1.) then + u = uni( ) + res = res * u ** (1._${k1}$ / shape) + endif + return + end function gamma_dist_rvs_1_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + impure elemental function gamma_dist_rvs_1_${t1[0]}$${k1}$(shape) result(res) + ! Gamma distributed complex. The real part and imaginary part are + ! independent of each other. + ! + ${t1}$, intent(in) :: shape + ${t1}$ :: res + real(${k1}$) :: tr, ti + + tr = gamma_dist_rvs_1_r${k1}$(real(shape)) + ti = gamma_dist_rvs_1_r${k1}$(aimag(shape)) + res = cmplx(tr,ti) + return + end function gamma_dist_rvs_1_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function gamma_dist_rvs_${t1[0]}$${k1}$(shape, rate) & + result(res) + ${t1}$, intent(in) :: shape, rate + ${t1}$ :: res + ${t1}$ :: x, v, u, zz + + if(shape <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & + //" shape parameter must be greater than zero") + if(rate <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & + //" rate parameter must be greater than zero") + zz = shape + if(zz < 1._${k1}$) zz = 1._${k1}$ + zz + if(abs(real(zz) - alpha) > tol) then + alpha = real(zz) + d = alpha - 1. / 3. + c = 1. / (3. * sqrt(d)) + endif + do + do + x = rnor( ) + v = 1._${k1}$ + c * x + v = v * v * v + if(v > 0) exit + end do + x = x * x + u = uni( ) + if(u < (1._${k1}$ - sq * x * x)) exit + if(log(u) < 0.5_${k1}$ * x + d * (1._${k1}$ - v + log(v))) exit + end do + res = d * v + if(shape < 1._${k1}$) then + u = uni( ) + res = res * u ** (1._${k1}$ / shape) + endif + res = res / rate + return + end function gamma_dist_rvs_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + impure elemental function gamma_dist_rvs_${t1[0]}$${k1}$(shape, rate) & + result(res) + ! Gamma distributed complex. The real part and imaginary part are & + ! independent of each other. + ! + ${t1}$, intent(in) :: shape, rate + ${t1}$ :: res + real(${k1}$) :: tr, ti + + tr = gamma_dist_rvs_r${k1}$(real(shape), real(rate)) + ti = gamma_dist_rvs_r${k1}$(aimag(shape), aimag(rate)) + res = cmplx(tr, ti) + return + end function gamma_dist_rvs_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + function gamma_dist_rvs_array_${t1[0]}$${k1}$(shape, rate, array_size) & + result(res) + ${t1}$, intent(in) :: shape, rate + ${t1}$, allocatable :: res(:) + integer, intent(in) :: array_size + ${t1}$ :: x, v, u, zz, re + integer :: i + + if(shape <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & + //" shape parameter must be greater than zero") + if(rate <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & + //" rate parameter must be greater than zero") + allocate(res(array_size)) + zz = shape + if(zz < 1._${k1}$) zz = 1._${k1}$ + zz + if(abs(real(zz) - alpha) > tol) then + alpha = real(zz) + d = alpha - 1. / 3. + c = 1. / (3. * sqrt(d)) + endif + do i = 1, array_size + do + do + x = rnor( ) + v = 1._${k1}$ + c * x + v = v * v * v + if(v > 0) exit + end do + x = x * x + u = uni( ) + if(u < (1._${k1}$ - sq * x * x)) exit + if(log(u) < 0.5_${k1}$ * x + d * (1._${k1}$ - v + log(v))) exit + end do + re = d * v + if(shape < 1._${k1}$) then + u = uni( ) + re = re * u ** (1._${k1}$ / shape) + endif + res(i) = re / rate + end do + return + end function gamma_dist_rvs_array_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + function gamma_dist_rvs_array_${t1[0]}$${k1}$(shape, rate, array_size) & + result(res) + ${t1}$, intent(in) :: shape, rate + ${t1}$, allocatable :: res(:) + integer, intent(in) :: array_size + integer :: i + real(${k1}$) :: tr, ti + + allocate(res(array_size)) + do i = 1, array_size + tr = gamma_dist_rvs_r${k1}$(real(shape), real(rate)) + ti = gamma_dist_rvs_r${k1}$(aimag(shape), aimag(rate)) + res(i) = cmplx(tr, ti) + end do + return + end function gamma_dist_rvs_array_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function gamma_dist_pdf_${t1[0]}$${k1}$(x, shape, rate) & + result(res) + ! Gamma distributed probability function + ! + ${t1}$, intent(in) :: x, shape, rate + real :: res + + if(rate <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & + //" rate parameter must be greaeter than zero") + if(shape <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & + //" shape parameter must be greater than zero") + if(x == 0.0_${k1}$) then + if(shape <= 1.0_${k1}$) then + res = huge(1.0) + 1.0 + else + res = 0.0_${k1}$ + endif + else + res = exp((shape - 1._${k1}$) * log(x) - x * rate + shape * & + log(rate) - log_gamma(shape)) + endif + return + end function gamma_dist_pdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + impure elemental function gamma_dist_pdf_${t1[0]}$${k1}$(x, shape, rate) & + result(res) + ${t1}$, intent(in) :: x, shape, rate + real :: res + + res = gamma_dist_pdf_r${k1}$(real(x), real(shape), real(rate)) + res = res * gamma_dist_pdf_r${k1}$(aimag(x), aimag(shape), aimag(rate)) + return + end function gamma_dist_pdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function gamma_dist_cdf_${t1[0]}$${k1}$(x, shape, rate) & + result(res) + ! Gamma random cumulative distribution function + ! + ${t1}$, intent(in) :: x, shape, rate + real :: res + + if(rate <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & + //" rate parameter must be greaeter than zero") + if(shape <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & + //" shape parameter must be greater than zero") + res = ingamma(shape, rate * x) / gamma(shape) + return + end function gamma_dist_cdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + impure elemental function gamma_dist_cdf_${t1[0]}$${k1}$(x, shape, rate) & + result(res) + ${t1}$, intent(in) :: x, shape, rate + real :: res + + res = gamma_dist_cdf_r${k1}$(real(x), real(shape), real(rate)) + res = res * gamma_dist_cdf_r${k1}$(aimag(x), aimag(shape), aimag(rate)) + end function gamma_dist_cdf_${t1[0]}$${k1}$ + + #:endfor + +end module stdlib_stats_distribution_gamma \ No newline at end of file From f3622c47239f371387cc9c4d1c262c713c78acb5 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 10:44:15 -0500 Subject: [PATCH 02/42] Update CMakeLists.txt --- src/CMakeLists.txt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 02604959e..d128b83a0 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -18,6 +18,11 @@ set(fppFiles stdlib_quadrature.fypp stdlib_quadrature_trapz.fypp stdlib_quadrature_simps.fypp + stdlib_stats_distribution_PRNG.fypp + stdlib_stats_distribution_uniform.fypp + stdlib_stats_distribution_normal.fypp + stdlib_stats_distribution_special.fypp + stdlib_stats_distribution_gamma.fypp ) From 290a11130dd2a0d464632b07423ee03d16cc58a8 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 10:53:22 -0500 Subject: [PATCH 03/42] Update Makefile.manual --- src/Makefile.manual | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/src/Makefile.manual b/src/Makefile.manual index 4617499ba..8df7dc069 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -18,7 +18,9 @@ noSRC = f18estop.f90 \ stdlib_stats_var.f90 \ stdlib_stats_distribution_PRNG.f90 \ stdlib_stats_distribution_uniform.f90 \ - stdlib_stats_distribution_normal.f90 + stdlib_stats_distribution_normal.f90 \ + stdlib_stats_distribution_special.f90 \ + stdlib_stats_distribution_gamma.f90 LIB = libstdlib.a @@ -72,15 +74,24 @@ stdlib_stats_var.o: \ stdlib_stats.o stdlib_stats_distribution_PRNG.o: stdlib_kinds.o stdlib_stats_distribution_uniform.o: \ - stdlib_kinds.o \ + stdlib_kinds.o \ stdlib_error.o \ stdlib_stats_distribution_PRNG.o stdlib_stats_distribution_normal.o: \ - stdlib_kinds.o \ + stdlib_kinds.o \ stdlib_error.o \ stdlib_stats_distribution.PRNG.o \ stdlib_stats_distribution.uniform.o - +stdlib_stats_distribution_special.o: \ + stdlib_kinds.o \ + stdlib_error.o +stdlib_stats_distribution_gamma.o: \ + stdlib_kinds.o \ + stdlib_error.o \ + stdlib_stats_distribution.uniform.o \ + stdlib_stats_distribution.normal.o \ + stdlib_stats_distribution.special.o + # Fortran sources that are built from fypp templates stdlib_bitsets_64.f90: stdlib_bitsets_64.fypp stdlib_bitsets_large.f90: stdlib_bitsets_large.fypp @@ -95,4 +106,6 @@ stdlib_stats_moment.f90: stdlib_stats_moment.fypp stdlib_stats_var.f90: stdlib_stats_var.fypp stdlib_stats_distribution_PRNG.f90: stdlib_stats_distribution_PRNG.fypp stdlib_stats_distribution_uniform.f90: stdlib_stats_distribution_uniform.fypp -stdlib_stats_distribution_normal.f90: stdlib_stats_distribution_normal.fypp \ No newline at end of file +stdlib_stats_distribution_normal.f90: stdlib_stats_distribution_normal.fypp +stdlib_stats_distribution_special.f90: stdlib_stats_distribution_special.fypp +stdlib_stats_distribution_gamma.f90: stdlib_stats_distribution_gamma.fypp From e4f3de1bbe961aaeafeb09a382cfefe5248f9954 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 10:55:19 -0500 Subject: [PATCH 04/42] Update Makefile.manual --- src/Makefile.manual | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Makefile.manual b/src/Makefile.manual index 8df7dc069..82d326113 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -1,4 +1,4 @@ -noSRC = f18estop.f90 \ +SRC = f18estop.f90 \ stdlib_ascii.f90 \ stdlib_bitsets.f90 \ stdlib_bitsets_64.f90 \ From e026ab7ea5c82fbd1b02c9e1de61761320c79c3d Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 11:07:26 -0500 Subject: [PATCH 05/42] initial commit --- src/stdlib_stats_distribution_PRNG.fypp | 212 ++++++++ src/stdlib_stats_distribution_normal.fypp | 366 +++++++++++++ src/stdlib_stats_distribution_special.fypp | 598 +++++++++++++++++++++ src/stdlib_stats_distribution_uniform.fypp | 482 +++++++++++++++++ 4 files changed, 1658 insertions(+) create mode 100644 src/stdlib_stats_distribution_PRNG.fypp create mode 100644 src/stdlib_stats_distribution_normal.fypp create mode 100644 src/stdlib_stats_distribution_special.fypp create mode 100644 src/stdlib_stats_distribution_uniform.fypp diff --git a/src/stdlib_stats_distribution_PRNG.fypp b/src/stdlib_stats_distribution_PRNG.fypp new file mode 100644 index 000000000..d1bda107a --- /dev/null +++ b/src/stdlib_stats_distribution_PRNG.fypp @@ -0,0 +1,212 @@ +#:include "common.fypp" +module stdlib_stats_distribution_PRNG + use stdlib_kinds, only: int8, int16, int32, int64 + implicit none + private + integer, parameter :: MAX_INT_BIT_SIZE = bit_size(1_int64) + integer(int64), save :: st(4), si = 614872703977525537_int64 + logical, save :: seed_initialized = .false. + + public :: random_seed + public :: dist_rand + public :: jump + public :: long_jump + + + interface dist_rand + !! Version experimental + !! + !! Generation of random integers with different kinds + !! ([Specification](../page/specs/stdlib_stats_distribution_PRNG.html# + !! description)) + #:for k1, t1 in INT_KINDS_TYPES + module procedure dist_rand_${t1[0]}$${k1}$ + #:endfor + end interface dist_rand + + interface random_seed + !! Version experimental + !! + !! Set seed value for random number generator + !! ([Specification](../page/specs/stdlib_stats_distribution_PRNG.html# + !! description)) + !! + #:for k1, t1 in INT_KINDS_TYPES + module procedure random_distribution_seed_${t1[0]}$${k1}$ + #:endfor + end interface random_seed + + + contains + + #:for k1, t1 in INT_KINDS_TYPES + function dist_rand_${t1[0]}$${k1}$(n) result(res) + !! Random integer generation for various kinds + !! result = [-2^k, 2^k - 1], k = 7, 15, 31, 63, depending on input kind + !! Result will be operated by bitwise operators to generate desired integer + !! and real pseudorandom numbers + !! + ${t1}$, intent(in) :: n + ${t1}$ :: res + integer :: k + + k = MAX_INT_BIT_SIZE - bit_size(n) + res = shiftr(xoshiro256ss( ), k) + end function dist_rand_${t1[0]}$${k1}$ + + #:endfor + + function xoshiro256ss( ) result (res) + ! Generate random 64-bit integers + ! Written in 2018 by David Blackman and Sebastiano Vigna (vigna@acm.org) + ! http://prng.di.unimi.it/xoshiro256starstar.c + ! + ! This is xoshiro256** 1.0, one of our all-purpose, rock-solid + ! generators. It has excellent (sub-ns) speed, a state (256 bits) that is + ! large enough for any parallel application, and it passes all tests we + ! are aware of. + ! + ! The state must be seeded so that it is not everywhere zero. If you have + ! a 64-bit seed, we suggest to seed a splitmix64 generator and use its + ! output to fill st. + ! + ! Fortran 90 version translated from C by Jim-215-Fisher + ! + integer(int64) :: res, t + + if(.not. seed_initialized) call random_distribution_seed_iint64(si,t) + res = rol64(st(2) * 5 , 7) * 9 + t = shiftl(st(2), 17) + st(3) = ieor(st(3), st(1)) + st(4) = ieor(st(4), st(2)) + st(2) = ieor(st(2), st(3)) + st(1) = ieor(st(1), st(4)) + st(3) = ieor(st(3), t) + st(4) = rol64(st(4), 45) + end function xoshiro256ss + + function rol64(x, k) result(res) + integer(int64), intent(in) :: x + integer, intent(in) :: k + integer(int64) :: t1, t2, res + + t1 = shiftr(x, (64 - k)) + t2 = shiftl(x, k) + res = ior(t1, t2) + end function rol64 + + + subroutine jump + ! This is the jump function for the xoshiro256ss generator. It is equivalent + ! to 2^128 calls to xoshiro256ss(); it can be used to generate 2^128 + ! non-overlapping subsequences for parallel computations. + ! Written in 2018 by David Blackman and Sebastiano Vigna (vigna@acm.org) + ! http://prng.di.unimi.it/xoshiro256starstar.c + ! + ! Fortran 90 version translated from C by Jim-215-Fisher + integer(int64) :: jp(4) = [1733541517147835066_int64, & + -3051731464161248980_int64, & + -6244198995065845334_int64, & + 4155657270789760540_int64] + integer(int64) :: s1 = 0, s2 = 0, s3 = 0, s4 = 0, c = 1_int64 + integer :: i, j, k + + do i = 1, 4 + do j = 1, 64 + if(iand(jp(i), shiftl(c, j - 1)) /= 0) then + s1 = ieor(s1, st(1)) + s2 = ieor(s2, st(2)) + s3 = ieor(s3, st(3)) + s4 = ieor(s4, st(4)) + end if + k = xoshiro256ss( ) + end do + end do + st(1) = s1 + st(2) = s2 + st(3) = s3 + st(4) = s4 + end subroutine jump + + subroutine long_jump + ! This is the long-jump function for the xoshiro256ss generator. It is + ! equivalent to 2^192 calls to xoshiro256ss(); it can be used to generate + ! 2^64 starting points, from each of which jump() will generate 2^64 + ! non-overlapping subsequences for parallel distributed computations + ! Written in 2018 by David Blackman and Sebastiano Vigna (vigna@acm.org) + ! http://prng.di.unimi.it/xoshiro256starstar.c + ! + ! Fortran 90 version translated from C by Jim-215-Fisher + integer(int64) :: jp(4) = [8566230491382795199_int64, & + -4251311993797857357_int64, & + 8606660816089834049_int64, & + 4111957640723818037_int64] + integer(int64) :: s1 = 0, s2 = 0, s3 = 0, s4 = 0, c = 1_int64 + integer(int32) :: i, j, k + + do i = 1, 4 + do j = 1, 64 + if(iand(jp(i), shiftl(c, j - 1)) /= 0) then + s1 = ieor(s1, st(1)) + s2 = ieor(s2, st(2)) + s3 = ieor(s3, st(3)) + s4 = ieor(s4, st(4)) + end if + k = xoshiro256ss() + end do + end do + st(1) = s1 + st(2) = s2 + st(3) = s3 + st(4) = s4 + end subroutine long_jump + + function splitmix64(s) result(res) + ! Written in 2015 by Sebastiano Vigna (vigna@acm.org) + ! This is a fixed-increment version of Java 8's SplittableRandom + ! generator. + ! See http://dx.doi.org/10.1145/2714064.2660195 and + ! http://docs.oracle.com/javase/8/docs/api/java/util/SplittableRandom.html + ! + ! It is a very fast generator passing BigCrush, and it can be useful if + ! for some reason you absolutely want 64 bits of state. + ! + ! Fortran 90 translated from C by Jim-215-Fisher + ! + integer(int64) :: res, int01, int02, int03 + integer(int64), intent(in), optional :: s + data int01, int02, int03/-7046029254386353131_int64, & + -4658895280553007687_int64, & + -7723592293110705685_int64/ + + if(present(s)) si = s + res = si + si = res + int01 + res = ieor(res, shiftr(res, 30)) * int02 + res = ieor(res, shiftr(res, 27)) * int03 + res = ieor(res, shiftr(res, 31)) + end function splitmix64 + + #:for k1, t1 in INT_KINDS_TYPES + subroutine random_distribution_seed_${t1[0]}$${k1}$(put, get) + !! Set seed value for random number generator + !! + ${t1}$, intent(in) :: put + ${t1}$, intent(out) :: get + integer(int64) :: tmp + integer :: i + + tmp = splitmix64(int(put, kind = int64)) + do i = 1, 10 + tmp = splitmix64( ) + end do + do i = 1, 4 + tmp = splitmix64( ) + st(i) = tmp + end do + get = int(tmp, kind = ${k1}$) + seed_initialized = .true. + end subroutine random_distribution_seed_${t1[0]}$${k1}$ + + #:endfor +end module stdlib_stats_distribution_PRNG \ No newline at end of file diff --git a/src/stdlib_stats_distribution_normal.fypp b/src/stdlib_stats_distribution_normal.fypp new file mode 100644 index 000000000..007007b59 --- /dev/null +++ b/src/stdlib_stats_distribution_normal.fypp @@ -0,0 +1,366 @@ +#:include "common.fypp" +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES +Module stdlib_stats_distribution_normal + use stdlib_kinds + use stdlib_error, only : error_stop + use stdlib_stats_distribution_PRNG, only : dist_rand + use stdlib_stats_distribution_uniform, only : uni=>uniform_distribution_rvs + + implicit none + private + + real(dp), parameter :: HALF = 0.5_dp, ONE = 1.0_dp, TWO = 2.0_dp + integer, save :: kn(0:127) + real(dp), save :: wn(0:127), fn(0:127) + logical, save :: zig_norm_initialized = .false. + + public :: normal_distribution_rvs + public :: normal_distribution_pdf + public :: normal_distribution_cdf + + interface normal_distribution_rvs + !! Version experimental + !! + !! Normal Distribution Random Variates + !!([Specification](../page/specs/stdlib_stats_distribution_normal.html# + !! description)) + !! + module procedure norm_dist_rvs_0_rsp !0 dummy variable + + #:for k1, t1 in RC_KINDS_TYPES + module procedure norm_dist_rvs_${t1[0]}$${k1}$ !2 dummy variables + #:endfor + + #:for k1, t1 in RC_KINDS_TYPES + module procedure norm_dist_rvs_array_${t1[0]}$${k1}$ !3 dummy variables + #:endfor + end interface normal_distribution_rvs + + interface normal_distribution_pdf + !! Version experimental + !! + !! Normal Distribution Probability Density Function + !!([Specification](../page/specs/stdlib_stats_distribution_normal.html# + !! description)) + !! + #:for k1, t1 in RC_KINDS_TYPES + module procedure norm_dist_pdf_${t1[0]}$${k1}$ + #:endfor + end interface normal_distribution_pdf + + interface normal_distribution_cdf + !! Version experimental + !! + !! Normal Distribution Cumulative Distribution Function + !!([Specification](../page/specs/stdlib_stats_distribution_normal.html# + !! description)) + !! + #:for k1, t1 in RC_KINDS_TYPES + module procedure norm_dist_cdf_${t1[0]}$${k1}$ + #:endfor + end interface normal_distribution_cdf + + + contains + + subroutine zigset + ! Marsaglia & Tsang generator for random normals & random exponentials. + ! Translated from C by Alan Miller (amiller@bigpond.net.au) + ! + ! Marsaglia, G. & Tsang, W.W. (2000) `The ziggurat method for generating + ! random variables', J. Statist. Software, v5(8). + ! + ! This is an electronic journal which can be downloaded from: + ! http://www.jstatsoft.org/v05/i08 + ! + ! N.B. It is assumed that all integers are 32-bit. + ! + ! Latest version - 1 January 2001 + ! + real(dp), parameter :: M1 = 2147483648.0_dp + real(dp) :: dn = 3.442619855899_dp, tn, & + vn = 0.00991256303526217_dp, q + integer :: i + + tn = dn + ! tables for random normals + q = vn * exp(HALF * dn * dn) + kn(0) = int((dn / q) * M1, kind = int32) + kn(1) = 0 + wn(0) = q / M1 + wn(127) = dn / M1 + fn(0) = ONE + fn(127) = exp( -HALF * dn * dn ) + do i = 126, 1, -1 + dn = sqrt( -TWO * log( vn / dn + exp( -HALF * dn * dn ) ) ) + kn(i+1) = int((dn / tn) * M1, kind = int32) + tn = dn + fn(i) = exp(-HALF * dn * dn) + wn(i) = dn / M1 + end do + zig_norm_initialized = .true. + return + end subroutine zigset + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function norm_dist_rvs_0_${t1[0]}$${k1}$( ) result(res) + ! Standard normal random vairate (0,1) + ! + ${t1}$ :: res + ${t1}$, parameter :: r = 3.442619855899_${k1}$, rr = 1.0_${k1}$ / r + ${t1}$ :: x, y + integer :: hz, iz + + if( .not. zig_norm_initialized ) call zigset + iz = 0 + ! original algorithm use 32bit + hz = dist_rand(iz) + + iz = iand( hz, 127 ) + if( abs( hz ) < kn(iz) ) then + res = hz * wn(iz) + else + L1: do + L2: if( iz == 0 ) then + do + x = -log( uni( ) ) * rr + y = -log( uni( ) ) + if( y + y >= x * x ) exit + end do + res = r + x + if( hz <= 0 ) res = -res + exit L1 + end if L2 + x = hz * wn(iz) + if( fn(iz) + uni( ) * (fn(iz-1) - fn(iz)) < & + exp(-HALF * x * x) ) then + res = x + exit L1 + end if + + !original algorithm use 32bit + hz = dist_rand(iz) + iz = iand( hz, 127 ) + if( abs( hz ) < kn(iz) ) then + res = hz * wn(iz) + exit L1 + end if + end do L1 + end if + return + end function norm_dist_rvs_0_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function norm_dist_rvs_${t1[0]}$${k1}$(loc, scale) & + result(res) + ! Normal random variate (loc, scale) + ! + ${t1}$, intent(in) :: loc, scale + ${t1}$ :: res + ${t1}$, parameter :: r = 3.442619855899_${k1}$, rr = 1.0_${k1}$ / r + ${t1}$ :: x, y + integer :: hz, iz + + if(scale==0._${k1}$) call error_stop("Error: Normal distribution scale" & + //" parameter must be non-zero") + if( .not. zig_norm_initialized ) call zigset + iz = 0 + ! original algorithm use 32bit + hz = dist_rand(iz) + + iz = iand( hz, 127 ) + if( abs( hz ) < kn(iz) ) then + res = hz * wn(iz) + else + L1: do + L2: if( iz == 0 ) then + do + x = -log( uni( ) ) * rr + y = -log( uni( ) ) + if( y + y >= x * x ) exit + end do + res = r + x + if( hz <= 0 ) res = -res + exit L1 + end if L2 + x = hz * wn(iz) + if( fn(iz) + uni( ) * (fn(iz-1) - fn(iz)) < & + exp(-HALF * x * x) ) then + res = x + exit L1 + end if + + !original algorithm use 32bit + hz = dist_rand(iz) + iz = iand( hz, 127 ) + if( abs( hz ) < kn(iz) ) then + res = hz * wn(iz) + exit L1 + end if + end do L1 + end if + res = res * scale + loc + return + end function norm_dist_rvs_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + impure elemental function norm_dist_rvs_${t1[0]}$${k1}$(loc, scale) & + result(res) + ! Normal distributed complex. The real part and imaginary part are & + ! independent of each other. + ! + ${t1}$, intent(in) :: loc, scale + ${t1}$ :: res + real(${k1}$) :: tr, ti + + tr = norm_dist_rvs_r${k1}$(real(loc), real(scale)) + ti = norm_dist_rvs_r${k1}$(aimag(loc), aimag(scale)) + res = cmplx(tr, ti) + return + end function norm_dist_rvs_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + function norm_dist_rvs_array_${t1[0]}$${k1}$(loc, scale, array_size) & + result(res) + ${t1}$, intent(in) :: loc, scale + integer, intent(in) :: array_size + ${t1}$, allocatable :: res(:) + ${t1}$, parameter :: r = 3.442619855899_${k1}$, rr = 1.0_${k1}$ / r + ${t1}$ :: x, y, re + integer :: hz, iz, i + + if(scale==0._${k1}$) call error_stop("Error: Normal distribution scale" & + //" parameter must be non-zero") + if( .not. zig_norm_initialized ) call zigset + allocate(res(array_size)) + do i = 1, array_size + iz = 0 + ! original algorithm use 32bit + hz = dist_rand(iz) + + iz = iand( hz, 127 ) + if( abs( hz ) < kn(iz) ) then + re = hz * wn(iz) + else + L1: do + L2: if( iz == 0 ) then + do + x = -log( uni( ) ) * rr + y = -log( uni( ) ) + if( y + y >= x * x ) exit + end do + re = r + x + if( hz <= 0 ) re = -re + exit L1 + end if L2 + x = hz * wn(iz) + if( fn(iz) + uni( ) * (fn(iz-1) - fn(iz)) < & + exp(-HALF * x * x) ) then + re = x + exit L1 + end if + + !original algorithm use 32bit + hz = dist_rand(iz) + iz = iand( hz, 127 ) + if( abs( hz ) < kn(iz) ) then + re = hz * wn(iz) + exit L1 + end if + end do L1 + end if + res(i) = re * scale + loc + end do + return + end function norm_dist_rvs_array_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + function norm_dist_rvs_array_${t1[0]}$${k1}$(loc, scale, array_size) & + result(res) + ${t1}$, intent(in) :: loc, scale + integer, intent(in) :: array_size + integer :: i + ${t1}$, allocatable :: res(:) + real(${k1}$) :: tr, ti + + allocate(res(array_size)) + do i = 1, array_size + tr = norm_dist_rvs_r${k1}$(real(loc), real(scale)) + ti = norm_dist_rvs_r${k1}$(aimag(loc), aimag(scale)) + res(i) = cmplx(tr, ti) + end do + return + end function norm_dist_rvs_array_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function norm_dist_pdf_${t1[0]}$${k1}$(x, loc, scale) & + result(res) + ! Normal distributed probability function + ! + ${t1}$, intent(in) :: x, loc, scale + real :: res + ${t1}$, parameter :: sqrt_2_pi = sqrt(2.0_${k1}$ * acos(-1.0_${k1}$)) + + if(scale==0._${k1}$) call error_stop("Error: Normal distribution scale" & + //" parameter must be non-zero") + res = exp(- 0.5_${k1}$ * (x - loc) * (x - loc) / (scale * scale)) / & + (sqrt_2_Pi * scale) + return + end function norm_dist_pdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + impure elemental function norm_dist_pdf_${t1[0]}$${k1}$(x, loc, scale) & + result(res) + ${t1}$, intent(in) :: x, loc, scale + real :: res + + res = norm_dist_pdf_r${k1}$(real(x), real(loc), real(scale)) + res = res * norm_dist_pdf_r${k1}$(aimag(x), aimag(loc), aimag(scale)) + return + end function norm_dist_pdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function norm_dist_cdf_${t1[0]}$${k1}$(x, loc, scale) & + result(res) + ! Normal random cumulative distribution function + ! + ${t1}$, intent(in) :: x, loc, scale + real :: res + ${t1}$, parameter :: sqrt_2 = sqrt(2.0_${k1}$) + + if(scale==0._${k1}$) call error_stop("Error: Normal distribution scale" & + //" parameter must be non-zero") + res = (1.0_${k1}$ + erf((x - loc) / (scale * sqrt_2))) / 2.0_${k1}$ + return + end function norm_dist_cdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + impure elemental function norm_dist_cdf_${t1[0]}$${k1}$(x, loc, scale) & + result(res) + ${t1}$, intent(in) :: x, loc, scale + real :: res + + res = norm_dist_cdf_r${k1}$(real(x), real(loc), real(scale)) + res = res * norm_dist_cdf_r${k1}$(aimag(x), aimag(loc), aimag(scale)) + return + end function norm_dist_cdf_${t1[0]}$${k1}$ + + #:endfor + +end module stdlib_stats_distribution_normal \ No newline at end of file diff --git a/src/stdlib_stats_distribution_special.fypp b/src/stdlib_stats_distribution_special.fypp new file mode 100644 index 000000000..a178d1813 --- /dev/null +++ b/src/stdlib_stats_distribution_special.fypp @@ -0,0 +1,598 @@ +#:include "common.fypp" +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES +#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES +Module stdlib_stats_distribution_special + use stdlib_kinds + use stdlib_error, only : error_stop + + implicit none + private + real(qp), parameter :: D(0:10) = [2.48574089138753565546e-5_qp, & + 1.05142378581721974210_qp, & + -3.45687097222016235469_qp, & + 4.51227709466894823700_qp, & + -2.98285225323576655721_qp, & + 1.05639711577126713077_qp, & + -1.95428773191645869583e-1_qp, & + 1.70970543404441224307e-2_qp, & + -5.71926117404305781283e-4_qp, & + 4.63399473359905636708e-6_qp, & + -2.71994908488607703910e-9_qp] + real(qp), parameter :: R = 10.900511_qp, HALF = 0.5_qp, & + sqep = log(2.0_qp * sqrt(exp(1.0_qp) / acos(-1.0_qp))) + real(dp), parameter :: ep_machine = 2.2e-16_dp, dm = 1.0e-300_dp + + ! for stdlib_distribution internal use + + public :: log_gamma, log_factorial + public :: ingamma_low, log_ingamma_low, ingamma_up, log_ingamma_up + public :: regamma_p, regamma_q + public :: beta, log_beta, inbeta + + interface log_gamma + ! Logrithm of gamma function with real variable + ! + #:for k1, t1 in REAL_KINDS_TYPES + module procedure l_gamma_${t1[0]}$${k1}$ + #:endfor + end interface log_gamma + + interface log_factorial + ! Logrithm of factorial n!, integer variable + ! + #:for k1, t1 in INT_KINDS_TYPES + module procedure l_factorial_1_${t1[0]}$${k1}$ !1 dummy + #:endfor + + #: for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + module procedure l_factorial_${t1[0]}$${k1}$${k2}$ !2 dummy + #:endfor + #:endfor + end interface log_factorial + + + interface ingamma_low + ! Lower incomplete gamma function + ! + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure ingamma_low_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface ingamma_low + + interface log_ingamma_low + ! Logrithm of lower incomplete gamma function + ! + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure l_ingamma_low_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface log_ingamma_low + + interface ingamma_up + ! Upper incomplete gamma function + ! + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure ingamma_up_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface ingamma_up + + interface log_ingamma_up + ! Logrithm of upper incomplete gamma function + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure l_ingamma_up_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface log_ingamma_up + + interface regamma_p + ! Regularized (normalized) lower incomplete gamma function, P + ! + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure regamma_p_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface regamma_p + + interface regamma_q + ! Regularized (normalized) upper incomplete gamma function, Q + ! + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure regamma_q_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface regamma_q + + interface gpx + ! Evaluation of incomplete gamma function + ! + #:for k1, t1 in REAL_KINDS_TYPES + module procedure gpx_${t1[0]}$${k1}$ + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + module procedure gpx_${t1[0]}$${k1}$${k2}$ + #:endfor + #:endfor + end interface gpx + + interface beta + ! Beta function + ! + #:for k1, t1 in REAL_KINDS_TYPES + module procedure beta_${t1[0]}$${k1}$ + #:endfor + end interface beta + + interface log_beta + ! Logrithm of beta function + ! + #:for k1, t1 in REAL_KINDS_TYPES + module procedure l_beta_${t1[0]}$${k1}$ + #:endfor + end interface log_beta + + interface inbeta + ! Incomplete beta function + ! + #:for k1, t1 in REAL_KINDS_TYPES + module procedure inbeta_${t1[0]}$${k1}$ + #:endfor + end interface inbeta + + + contains + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function l_gamma_${t1[0]}$${k1}$(x) result (res) + ! Log gamma function for any positive real number i,e, {R+} + ! + ${t1}$, intent(in) :: x + ${t1}$ :: res + real(qp) :: q, sum + integer :: i + + if(x <= 0) call error_stop("Error: Gamma function augument must be" & + //" greater than 0") + if(x == 1.0_${k1}$ .or. x == 2.0_${k1}$) then + res = 0.0_${k1}$ + else + q = x - HALF + sum = D(0) + do i=1, 10 + sum = sum + D(i) / (x - 1.0_qp + i) + end do + res = real(sqep + log(sum) - q + q * log(q + R), kind=${k1}$) + endif + return + end function l_gamma_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + impure elemental function l_factorial_1_${t1[0]}$${k1}$(n) result(res) + ! Log(n!) with single precision result, n is integer + ! + ${t1}$, intent(in) :: n + real :: res + + if(n < 0) call error_stop("Error: Factorial function augument must" & + //" be no less than 0") + select case(n) + case (0) + res = 0.0 + case (1) + res = 0.0 + case (2:) + res = log_gamma(real(n+1)) + end select + return + end function l_factorial_1_${t1[0]}$${k1}$ + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + impure elemental function l_factorial_${t1[0]}$${k1}$${k2}$(n,x) result(res) + ! Log(n!) with required prescision for result, n is integer, x is a real & + ! for specified kind + ! + ${t1}$, intent(in) :: n + ${t2}$, intent(in) :: x + ${t2}$ :: res + + if(n < 0) call error_stop("Error: factorial function augument must" & + //" be no less than 0") + select case(n) + case (0) + res = 0.0_${k2}$ + case (1) + res = 0.0_${k2}$ + case (2:) + res = log_gamma(real((n+1), kind=${k2}$)) + end select + return + end function l_factorial_${t1[0]}$${k1}$${k2}$ + #:endfor + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function gpx_${t1[0]}$${k1}$(s, x) result(res) + ! Approximation of incomplete gamma G function + ! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and + ! Accurate Evaluation of a Generalized Incomplete Gamma Function", ACM + ! Transactions on Mathematical Software, March 2020. + ! + ${t1}$, intent(in) :: x, s + real(dp) :: res + real(dp) :: a, b, g, c, d, y + integer :: n + + if(x < 0) then + call error_stop("Error: Incomplete gamma function with negative x" & + //" must come with integer of s") + elseif(s >= x) then + a = s + g = 1.0_${k1}$ / a + c = g + do + a = a + 1.0_${k1}$ + c = c * x / a + g = g + c + if(abs(c) < ep_machine) exit + end do + else + a = 1.0_dp + b = real(x + 1 - s, kind=dp) + g = a / b + c = a / dm + d = 1.0_dp / b + n = 2 + do + a = -(n - 1) * (n - s - 1) + b = x + 2 * n - 1.0_dp - s + d = d * a + b + if(d == 0.0_dp) d = dm + c = b + a / c + if(c == 0.0_dp) c = dm + d = 1.0_dp / d + y = c * d + g = g * y + n = n + 1 + if(abs(y - 1.0_dp) < ep_machine) exit + end do + endif + res = g + return + end function gpx_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + impure elemental function gpx_${t1[0]}$${k1}$${k2}$(s, x) result(res) + ! Approximation of incomplete gamma G function + ! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and + ! Accurate Evaluation of a Generalized Incomplete Gamma Function", ACM + ! Transactions on Mathematical Software, March 2020. + ! + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + real(dp) :: res + ${t2}$ :: p_lim + real(dp) :: a, b, g, c, d, y + integer :: n + + if(x < -9) then + p_lim = 5.0_${k2}$ * (sqrt(abs(x)) - 1.0_${k2}$) + elseif(x >= -9 .and. x <= 0) then + p_lim = 0.0_${k2}$ + else + p_lim = x + endif + if(s >= p_lim) then + a = s + g = 1.0_${k2}$ / a + c = g + do + a = a + 1.0_${k2}$ + c = c * x / a + g = g + c + if(abs(c) < ep_machine) exit + end do + elseif(x >= 0.0_${k2}$) then + a = 1.0_dp + b = real(x + 1 - s, kind=dp) + g = a / b + c = a / dm + d = 1.0_dp / b + n = 2 + do + a = -(n - 1) * (n - s - 1) + b = x + 2 * n - 1.0_dp - s + d = d * a + b + if(d == 0.0_dp) d = dm + c = b + a / c + if(c == 0.0_dp) c = dm + d = 1.0_dp / d + y = c * d + g = g * y + n = n + 1 + if(abs(y - 1.0_dp) < ep_machine) exit + end do + elseif(abs(x) > max(1, s - 1)) then + a = -x + c = 1.0_dp / a + d = real(s - 1, kind=dp) + b = c * (a - d) + n = 1 + do + c = d * (d - 1) / (a * a) + d = d - 2 + y = c * ( a - d) + b = b + y + n = n + 1 + if(n > (s - 2) / 2 .or. y < b * ep_machine) exit + end do + if(y >= b * ep_machine .and. mod(s, 2) /= 0) b = b + d * c / a + g = ((-1) ** s * exp(-a + log_gamma(real(s, kind=dp)) - (s - 1) * & + log(a)) + b ) / a + endif + res = g + return + end function gpx_${t1[0]}$${k1}$${k2}$ + + #:endfor + #:endfor + + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + impure elemental function ingamma_low_${t1[0]}$${k1}$${k2}$(s, x) & + result(res) + ! Approximation of lower incomplete gamma function + ! + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res + real(dp) :: s1, y + + if(s < 0) call error_stop("Error: Lower incomplete gamma function" & + //" input s value must be greater than 0") + if(x == 0.0_dp) then + res = real(0.0, kind=${k2}$) + elseif(x > 0.0_dp .and. x <= s) then + s1 = -x + s * log(x) + res = real(gpx(s,x) * exp(s1), kind=${k2}$) + elseif(x > s) then + s1 = log_gamma(real(s, kind=dp)) + y = 1.0_dp - exp(-x + s * log(x) - s1) * gpx(s,x) + res = real(y * exp(s1), kind=${k2}$) + else + s1 = -x + s * log(-x) + res = real((-1)**s * gpx(s,x) * exp(s1), kind=${k2}$) + endif + return + end function ingamma_low_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + impure elemental function l_ingamma_low_${t1[0]}$${k1}$${k2}$(s, x) & + result(res) + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res + + res = log(ingamma_low(s,x)) + end function l_ingamma_low_${t1[0]}$${k1}$${k2}$ + + #:endif + #:endfor + #:endfor + + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + impure elemental function ingamma_up_${t1[0]}$${k1}$${k2}$(s, x) & + result(res) + ! Approximation of upper incomplete gamma function + ! + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res + + res = exp(log_gamma(real(s, kind=${k2}$))) - ingamma_low(s,x) + return + end function ingamma_up_${t1[0]}$${k1}$${k2}$ + + #:endif + #:endfor + #:endfor + + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and ( k1 != k2)) + impure elemental function l_ingamma_up_${t1[0]}$${k1}$${k2}$(s, x) & + result(res) + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res + + res = log(ingamma_up(s,x)) + end function l_ingamma_up_${t1[0]}$${k1}$${k2}$ + + #:endif + #:endfor + #:endfor + + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + impure elemental function regamma_p_${t1[0]}$${k1}$${k2}$(s, x) result(res) + ! Approximation of regulated incomplet gamma function P(s,x) + ! + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res + real(dp) :: s1 + + if(s < 0) call error_stop("Error: Regularized incomplete gamma" & + //" function P input s value must be greater than 0") + s1 = -x + s * log(abs(x)) - log_gamma(real(s, kind=${k2}$)) + if(x == 0.0_dp) then + res = real(0.0, kind=${k2}$) + elseif(x > 0.0_dp .and. x <= s) then + res = real(gpx(s,x) * exp(s1), kind=${k2}$) + elseif(x > s) then + res = 1.0_dp - exp(s1) * gpx(s,x) + else + res = real((-1)**s * gpx(s,x) * exp(s1), kind=${k2}$) + endif + return + end function regamma_p_${t1[0]}$${k1}$${k2}$ + + #:endif + #:endfor + #:endfor + + #:for k1, t1 in IR_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + impure elemental function regamma_q_${t1[0]}$${k1}$${k2}$(s, x) & + result(res) + ! Approximation of regulated incomplet gamma function Q(s,x) + ! + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res + + res = real(1.0_dp - regamma_p_${t1[0]}$${k1}$${k2}$(s,x), kind=${k2}$) + return + end function regamma_q_${t1[0]}$${k1}$${k2}$ + + #:endif + #:endfor + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function beta_${t1[0]}$${k1}$(a, b) result(res) + ! Evaluation of beta function through gamma function + ! + ${t1}$, intent(in) :: a, b + ${t1}$ :: res + + if(a <= 0 .or. b <= 0) call error_stop("Error: Beta function auguments"& + //" a, b values must be greater than 0") + res = exp(log_gamma(a) + log_gamma(b) - log_gamma(a+b)) + return + end function beta_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function l_beta_${t1[0]}$${k1}$(a, b) result(res) + ! Logrithm of beta function through log(gamma) + ! + ${t1}$, intent(in) :: a, b + ${t1}$ :: res + + if(a <= 0 .or. b <= 0) call error_stop("Error: Logrithm of Beta" & + //" function auguments a, b values must be greater than 0") + res = log_gamma(a) + log_gamma(b) - log_gamma(a+b) + return + end function l_beta_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function inbeta_${t1[0]}$${k1}$(x, a, b) result(res) + ! Evaluation of incomplete beta function using continued fractions + ! "Computation of Special Functions" by S. Zhang and J. Jin, 1996 + ! + ${t1}$, intent(in) :: x, a, b + ${t1}$ :: res + real :: s0, ak, ak2 + integer :: n, k + real(dp) :: an, bn, g, c, d, y + + if(a <= 0 .or. b <= 0) call error_stop("Error: Incomplete beta" & + //" function auguments a, b values must be greater than 0") + s0 = (a + 1) / (a + b + 2) + an = 1.0_dp + bn = 1.0_dp + g = a / b + c = a / dm + d = 1.0_dp / b + n = 1 + if(x < s0) then + do + if(mod(n, 2) == 0) then + k = n / 2; ak = a + 2 * k + an = k * x * (b - k) / (ak * ak - ak) + else + k = (n - 1) / 2; ak = a + k; ak2 = ak + k + an = - (ak + b) * ak * x / (ak2 * ak2 + ak2) + endif + d = d * an + bn + if(d == 0.0_dp) d = dm + c = bn + an / c + if(c == 0.0_dp) c = dm + d = 1.0_dp / d + y = c * d + g = g * y + n = n + 1 + if(abs(y - 1.0_dp) < ep_machine) exit + end do + g = x ** a * (1.0_${k1}$ - x) ** b * g / (a * beta(a, b)) + else + do + if(mod(n, 2) == 0) then + k = n / 2; ak = b + 2 * k + an = k * (1.0_dp - x) * (a - k) + else + k = (n - 1) / 2; ak = b + k; ak2 = ak + k + an = - ak * (1.0_dp - x) * (a + ak) / (ak2 * ak2 + ak2) + endif + d = d * an + bn + if(d == 0.0_dp) d = dm + c = bn + an / c + if(c == 0.0_dp) c = dm + d = 1.0_dp / d + y = c * d + g = g * y + n = n + 1 + if(abs(y - 1.0_dp) < ep_machine) exit + end do + g = x ** a * (1.0_${k1}$ - x) ** b * g / (b * beta(a, b)) + g = 1.0_${k1}$ - g + endif + res = g + end function inbeta_${t1[0]}$${k1}$ + + #:endfor + +end module stdlib_stats_distribution_special diff --git a/src/stdlib_stats_distribution_uniform.fypp b/src/stdlib_stats_distribution_uniform.fypp new file mode 100644 index 000000000..089ab8001 --- /dev/null +++ b/src/stdlib_stats_distribution_uniform.fypp @@ -0,0 +1,482 @@ +#:include "common.fypp" +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES +#:set ALL_KINDS_TYPES = INT_KINDS_TYPES + RC_KINDS_TYPES +Module stdlib_stats_distribution_uniform + use stdlib_kinds + use stdlib_error, only : error_stop + use stdlib_stats_distribution_PRNG, only : dist_rand + + implicit none + private + + real(dp), parameter :: MESENNE_NUMBER = 1.0_dp / (2.0_dp ** 53 - 1.0_dp) + integer(int64), parameter :: INT_ONE = 1_int64 + + public :: uniform_distribution_rvs + public :: uniform_distribution_pdf + public :: uniform_distribution_cdf + public :: shuffle + + interface uniform_distribution_rvs + !! Version experimental + !! + !! Get uniformly distributed random variate for integer, real and complex + !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# + !! description)) + + module procedure unif_dist_rvs_0_rsp ! 0 dummy variable + + #:for k1, t1 in ALL_KINDS_TYPES + module procedure unif_dist_rvs_1_${t1[0]}$${k1}$ ! 1 dummy variable + #:endfor + + #:for k1, t1 in ALL_KINDS_TYPES + module procedure unif_dist_rvs_${t1[0]}$${k1}$ ! 2 dummy variables + #:endfor + + #:for k1, t1 in ALL_KINDS_TYPES + module procedure unif_dist_rvs_array_${t1[0]}$${k1}$ ! 3 dummy variables + #:endfor + end interface uniform_distribution_rvs + + interface uniform_distribution_pdf + !! Version experiment + !! + !! Get uniform distribution probability density (pdf) for integer, real and complex variables + !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# + !! description)) + + #:for k1, t1 in ALL_KINDS_TYPES + module procedure unif_dist_pdf_${t1[0]}$${k1}$ + #:endfor + end interface uniform_distribution_pdf + + interface uniform_distribution_cdf + !! Version experimental + !! + !! Get uniform distribution cumulative distribution function (cdf) for integer, real and complex variables + !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# + !! description)) + !! + #:for k1, t1 in ALL_KINDS_TYPES + module procedure unif_dist_cdf_${t1[0]}$${k1}$ + #:endfor + end interface uniform_distribution_cdf + + interface shuffle + !! Version experimental + !! + !! Fisher-Yates shuffle algorithm for a rank one array of integer, real and complex variables + !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# + !! description)) + !! + #:for k1, t1 in ALL_KINDS_TYPES + module procedure shuffle_${t1[0]}$${k1}$ + #:endfor + end interface shuffle + + + contains + + #:for k1, t1 in INT_KINDS_TYPES + impure elemental function unif_dist_rvs_1_${t1[0]}$${k1}$(scale) result(res) + ! Uniformly distributed integer in [0, scale] + ! Bitmask with rejection + ! https://www.pcg-random.org/posts/bounded-rands.html + ! + ! Fortran 90 translated from c by Jim-215-fisher + ${t1}$, intent(in) :: scale + ${t1}$ :: res, u, mask, n + integer :: zeros, bits_left, bits + + n = scale + if(n <= 0_${k1}$) call error_stop("Error: Uniform distribution scale" & + //" parameter must be positive") + zeros = leadz(n) + bits = bit_size(n) - zeros + mask = shiftr(not(0_${k1}$), zeros) + L1 : do + u = dist_rand(n) + res = iand(u, mask) + if(res <= n) exit L1 + bits_left = zeros + L2 : do + if(bits_left < bits) exit L2 + u = shiftr(u, bits) + res = iand(u, mask) + if(res <= n) exit L1 + bits_left = bits_left - bits + end do L2 + end do L1 + return + end function unif_dist_rvs_1_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + impure elemental function unif_dist_rvs_${t1[0]}$${k1}$(loc, scale) & + result( res ) + ! Uniformly distributed integer in [loc, loc + scale] + ! + ${t1}$, intent(in) :: loc, scale + ${t1}$ :: res + + if(scale == 0_${k1}$) call error_stop("Error: Uniform distribution" & + //" scale parameter must be non-zero") + res = loc + unif_dist_rvs_1_${t1[0]}$${k1}$(scale) + return + end function unif_dist_rvs_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function unif_dist_rvs_0_${t1[0]}$${k1}$( ) result(res) + ! Uniformly distributed float in [0,1] + ! Based on the paper by Frederic Goualard, "Generating Random Floating- + ! Point Numbers By Dividing Integers: a Case Study", Proceedings of + ! ICCS 2020, June 20202, Amsterdam, Netherlands + ! + ${t1}$ :: res + integer(int64) :: tmp + + tmp = shiftr(dist_rand(INT_ONE), 11) ! Get random from [0,2^53-1] + res = real(tmp * MESENNE_NUMBER, kind =${k1}$) ! convert to [0,1] + return + end function unif_dist_rvs_0_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function unif_dist_rvs_1_${t1[0]}$${k1}$(scale) result(res) + ! Uniformly distributed float in [0, scale] + ! + ${t1}$, intent(in) :: scale + ${t1}$ :: res + + if(scale == 0._${k1}$) call error_stop("Error: Uniform distribution" & + //" scale parameter must be non-zero") + res = scale * unif_dist_rvs_0_${t1[0]}$${k1}$( ) + return + end function unif_dist_rvs_1_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function unif_dist_rvs_${t1[0]}$${k1}$(loc, scale) & + result(res) + ! Uniformly distributed float in [loc, loc + scale] + ! + ${t1}$, intent(in) :: loc, scale + ${t1}$ :: res + + if(scale == 0._${k1}$) call error_stop("Error: Uniform distribution" & + //" scale parameter must be non-zero") + res = loc + scale * unif_dist_rvs_0_${t1[0]}$${k1}$( ) + return + end function unif_dist_rvs_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + impure elemental function unif_dist_rvs_1_${t1[0]}$${k1}$(scale) result(res) + ! Uniformly distributed complex in [(0,0i), (scale, i(scale)] + ! The real part and imaginary part are independent of each other, so that + ! the joint distribution is on an unit square [(0,0i), scale,i(scale)] + ! + ${t1}$, intent(in) :: scale + ${t1}$ :: res + real(${k1}$) :: r1, r2, tr, ti + + if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error: Uniform" & + //" distribution scale parameter must be non-zero") + r1 = unif_dist_rvs_0_r${k1}$( ) + if(real(scale) == 0.0_${k1}$) then + ti = aimag(scale) * r1 + tr = 0.0_${k1}$ + elseif(aimag(scale) == 0.0_${k1}$) then + tr = real(scale) * r1 + ti = 0.0_${k1}$ + else + r2 = unif_dist_rvs_0_r${k1}$( ) + tr = real(scale) * r1 + ti = aimag(scale) * r2 + endif + res = cmplx(tr, ti) + return + end function unif_dist_rvs_1_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + impure elemental function unif_dist_rvs_${t1[0]}$${k1}$(loc, scale) & + result(res) + ! Uniformly distributed complex in [(loc,iloc), (loc + scale, i(loc + scale)] + ! The real part and imaginary part are independent of each other, so that + ! the joint distribution is on an unit square [(loc,iloc), (loc + scale, + ! i(loc + scale))] + ! + ${t1}$, intent(in) :: loc, scale + ${t1}$ :: res + real(${k1}$) :: r1, r2, tr, ti + + if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error: Uniform" & + //" distribution scale parameter must be non-zero") + r1 = unif_dist_rvs_0_r${k1}$( ) + if(real(scale) == 0.0_${k1}$) then + tr = real(loc) + ti = aimag(loc) + aimag(scale) * r1 + elseif(aimag(scale) == 0.0_${k1}$) then + tr = real(loc) + real(scale) * r1 + ti = aimag(loc) + else + r2 = unif_dist_rvs_0_r${k1}$( ) + tr = real(loc) + real(scale) * r1 + ti = aimag(loc) + aimag(scale) * r2 + endif + res = cmplx(tr, ti) + return + end function unif_dist_rvs_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + function unif_dist_rvs_array_${t1[0]}$${k1}$(loc, scale, array_size) & + result(res) + ${t1}$, intent(in) :: loc, scale + ${t1}$, allocatable :: res(:) + ${t1}$ :: u, mask, n, nn + integer, intent(in) :: array_size + integer :: i, zeros, bits_left, bits + + n = scale + if(n == 0_${k1}$) call error_stop("Error: Uniform distribution" & + //" scale parameter must be non-zero") + allocate(res(array_size)) + zeros = leadz(n) + bits = bit_size(n) - zeros + mask = shiftr(not(0_${k1}$), zeros) + do i = 1, array_size + L1 : do + u = dist_rand(n) + nn = iand(u, mask) + if(nn <= n) exit L1 + bits_left = zeros + L2 : do + if(bits_left < bits) exit L2 + u = shiftr(u, bits) + nn = iand(u, mask) + if(nn <= n) exit L1 + bits_left = bits_left - bits + end do L2 + end do L1 + res(i) = loc + nn + end do + return + end function unif_dist_rvs_array_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + function unif_dist_rvs_array_${t1[0]}$${k1}$(loc, scale, array_size) & + result(res) + ${t1}$, intent(in) :: loc, scale + ${t1}$, allocatable :: res(:) + ${t1}$ :: t + integer, intent(in) :: array_size + integer(int64) :: tmp + integer :: i + + + if(scale == 0._${k1}$) call error_stop("Error: Uniform distribution" & + //" scale parameter must be non-zero") + allocate(res(array_size)) + do i = 1, array_size + tmp = shiftr(dist_rand(INT_ONE), 11) + t = real(tmp * MESENNE_NUMBER, kind = ${k1}$) + res(i) = loc + scale * t + enddo + return + end function unif_dist_rvs_array_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + function unif_dist_rvs_array_${t1[0]}$${k1}$(loc, scale, array_size) & + result(res) + ${t1}$, intent(in) :: loc, scale + ${t1}$, allocatable :: res(:) + real(${k1}$) :: r1, r2, tr, ti + integer, intent(in) :: array_size + integer(int64) :: tmp + integer :: i + + + if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error: Uniform" & + //" distribution scale parameter must be non-zero") + allocate(res(array_size)) + do i = 1, array_size + tmp = shiftr(dist_rand(INT_ONE), 11) + r1 = real(tmp * MESENNE_NUMBER, kind = ${k1}$) + if(real(scale) == 0.0_${k1}$) then + tr = real(loc) + ti = aimag(loc) + aimag(scale) * r1 + elseif(aimag(scale) == 0.0_${k1}$) then + tr = real(loc) + real(scale) * r1 + ti = aimag(loc) + else + tmp = shiftr(dist_rand(INT_ONE), 11) + r2 = real(tmp * MESENNE_NUMBER, kind = ${k1}$) + tr = real(loc) + real(scale) * r1 + ti = aimag(loc) + aimag(scale) * r2 + endif + res(i) = cmplx(tr, ti) + enddo + return + end function unif_dist_rvs_array_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + elemental function unif_dist_pdf_${t1[0]}$${k1}$(x, loc, scale) result(res) + ${t1}$, intent(in) :: x, loc, scale + real :: res + + if(scale == 0) then + res = 0.0 + elseif(x < loc .or. x >loc + scale) then + res = 0.0 + else + res = 1. / (scale + 1) + end if + return + end function unif_dist_pdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + elemental function unif_dist_pdf_${t1[0]}$${k1}$(x, loc, scale) result(res) + ${t1}$, intent(in) :: x, loc, scale + real :: res + + if(scale == 0.0_${k1}$) then + res = 0.0 + elseif(x <= loc .or. x >= (loc + scale)) then + res = 0.0 + else + res = 1.0 / scale + end if + return + end function unif_dist_pdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + elemental function unif_dist_pdf_${t1[0]}$${k1}$(x, loc, scale) result(res) + ${t1}$, intent(in) :: x, loc, scale + real :: res + real(${k1}$) :: tr, ti + + tr = real(loc) + real(scale); ti = aimag(loc) + aimag(scale) + if(scale == (0.0_${k1}$,0.0_${k1}$)) then + res = 0.0 + elseif((real(x) >= real(loc) .and. real(x) <= tr) .and. & + (aimag(x) >= aimag(loc) .and. aimag(x) <= ti)) then + res = 1.0 / (real(scale) * aimag(scale)) + else + res = 0.0 + end if + return + end function unif_dist_pdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + elemental function unif_dist_cdf_${t1[0]}$${k1}$(x, loc, scale) result(res) + ${t1}$, intent(in) :: x, loc, scale + real :: res + + if(scale == 0) then + res = 0.0 + elseif(x < loc) then + res = 0.0 + elseif(x >= loc .and. x <= (loc + scale)) then + res = real((x - loc + 1)) / real((scale + 1)) + else + res = 1.0 + end if + return + end function unif_dist_cdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + elemental function unif_dist_cdf_${t1[0]}$${k1}$(x, loc, scale) result(res) + ${t1}$, intent(in) :: x, loc, scale + real :: res + + if(scale == 0.0_${k1}$) then + res = 0.0 + elseif(x < loc) then + res = 0.0 + elseif(x >= loc .and. x <= (loc + scale)) then + res = (x - loc) / scale + else + res = 1.0 + end if + return + end function unif_dist_cdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in CMPLX_KINDS_TYPES + elemental function unif_dist_cdf_${t1[0]}$${k1}$(x, loc, scale) result(res) + ${t1}$, intent(in) :: x, loc, scale + real :: res + logical :: r1, r2, i1, i2 + + if(scale == (0.0_${k1}$,0.0_${k1}$)) then + res = 0.0 + return + endif + r1 = real(x) < real(loc) + r2 = real(x) > (real(loc) + real(scale)) + i1 = aimag(x) < aimag(loc) + i2 = aimag(x) > (aimag(loc) + aimag(scale)) + if(r1 .or. i1) then + res = 0.0 + elseif((.not. r1) .and. (.not. r2) .and. i2) then + res = (real(x) - real(loc)) / real(scale) + elseif((.not. i1) .and. (.not. i2) .and. r2) then + res = (aimag(x) - aimag(loc)) / aimag(scale) + elseif((.not. r1) .and. (.not. r2) .and. (.not. i1) .and. (.not. i2)) & + then + res = (real(x) - real(loc)) * (aimag(x) - aimag(loc)) / & + (real(scale) * aimag(scale)) + elseif(r2 .and. i2)then + res = 1.0 + end if + return + end function unif_dist_cdf_${t1[0]}$${k1}$ + + #:endfor + + #:for k1, t1 in ALL_KINDS_TYPES + function shuffle_${t1[0]}$${k1}$( list ) result(res) + ${t1}$, intent(in) :: list(:) + ${t1}$, allocatable :: res(:) + ${t1}$ :: tmp + integer :: n, i, j + + n = size(list) + allocate(res(n), source=list) + do i = 1, n - 1 + j = uniform_distribution_rvs(n - i) + i + tmp = res(i) + res(i) = res(j) + res(j) = tmp + end do + return + end function shuffle_${t1[0]}$${k1}$ + + #:endfor +end module stdlib_stats_distribution_uniform \ No newline at end of file From 58cd41ebd077cdd3dae7cec33d4d58fff9279458 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 11:09:11 -0500 Subject: [PATCH 06/42] initial commit --- src/tests/stats/test_distribution_gamma.f90 | 530 ++++++++++++++++++++ 1 file changed, 530 insertions(+) create mode 100644 src/tests/stats/test_distribution_gamma.f90 diff --git a/src/tests/stats/test_distribution_gamma.f90 b/src/tests/stats/test_distribution_gamma.f90 new file mode 100644 index 000000000..797d03d8b --- /dev/null +++ b/src/tests/stats/test_distribution_gamma.f90 @@ -0,0 +1,530 @@ +program test_distribution_gamma + use stdlib_kinds + use stdlib_error, only : check + use stdlib_stats_distribution_PRNG, only: random_seed + use stdlib_stats_distribution_gamma, gamma_rvs => gamma_distribution_rvs, & + gamma_pdf => gamma_distribution_pdf, & + gamma_cdf => gamma_distribution_cdf + + implicit none + real(sp), parameter :: sptol = 1000 * epsilon(1.0_sp) + real(dp), parameter :: dptol = 1000 * epsilon(1.0_dp) + real(qp), parameter :: qptol = 1000 * epsilon(1.0_qp) + logical :: warn = .true. + integer :: put, get + + put = 1234567 + call random_seed(put, get) + + call test_gamma_random_generator + + call test_gamma_rvs_rsp + call test_gamma_rvs_rdp + call test_gamma_rvs_rqp + call test_gamma_rvs_csp + call test_gamma_rvs_cdp + call test_gamma_rvs_cqp + + call test_gamma_pdf_rsp + call test_gamma_pdf_rdp + call test_gamma_pdf_rqp + call test_gamma_pdf_csp + call test_gamma_pdf_cdp + call test_gamma_pdf_cqp + + call test_gamma_cdf_rsp + call test_gamma_cdf_rdp + call test_gamma_cdf_rqp + call test_gamma_cdf_csp + call test_gamma_cdf_cdp + call test_gamma_cdf_cqp + + + contains + + subroutine test_gamma_random_generator + integer :: i, j, freq(0:1000), num=10000000 + real(dp) :: chisq, expct + + print *, "" + print *, "Test gamma random generator with chi-squared" + freq = 0 + do i = 1, num + j = 1000 * gamma_cdf(gamma_rvs(2.0,1.5),2.0,1.5) + freq(j) = freq(j) + 1 + end do + chisq = 0.0_dp + expct = num / 1000 + do i = 0, 999 + chisq = chisq + (freq(i) - expct) ** 2 / expct + end do + write(*,*) "The critical values for chi-squared with 1000 d. of f. is" & + //" 1143.92" + write(*,*) "Chi-squared for gamma random generator is : ", chisq + call check((chisq < 1143.9), & + msg="gamma randomness failed chi-squared test", warn=warn) + end subroutine test_gamma_random_generator + + subroutine test_gamma_rvs_rsp + real(sp) :: res(10), gshape, scale + integer :: i, n, k = 5 + integer :: put, get + real(sp) :: ans(10) = [0.857589039350877514111471181067133115_sp, & + 1.02066235929592669341367273855793615_sp, & + 0.997539313039285858469791992057480517_sp, & + 0.976533566171099213454202419140525167_sp, & + 0.418534850809151373739671312677149231_sp, & + 2.20122874546440374485431246113130646_sp, & + 2.06395422779089208145254668611859318_sp, & + 3.17946689363011574223408637477787452_sp, & + 1.93297441375957258760155732080675223_sp, & + 1.02579597344383310585282655020137840_sp] + + print *, "Test gamma_distribution_rvs_rsp" + put = 639741825 + call random_seed(put, get) + gshape = 2.0_sp; scale = 1.0_sp + do i = 1, 5 + res(i) = gamma_rvs(gshape, scale) + end do + res(6:10) = gamma_rvs(gshape, scale, k) + call check(all(abs(res - ans) < sptol), & + msg="gamma_distribution_rvs_rsp failed", warn=warn) + end subroutine test_gamma_rvs_rsp + + subroutine test_gamma_rvs_rdp + real(dp) :: res(10), gshape, scale + integer :: i, n, k = 5 + integer :: put, get + real(dp) :: ans(10) = [0.857589039350877514111471181067133115_dp, & + 1.02066235929592669341367273855793615_dp, & + 0.997539313039285858469791992057480517_dp, & + 0.976533566171099213454202419140525167_dp, & + 0.418534850809151373739671312677149231_dp, & + 2.20122874546440374485431246113130646_dp, & + 2.06395422779089208145254668611859318_dp, & + 3.17946689363011574223408637477787452_dp, & + 1.93297441375957258760155732080675223_dp, & + 1.02579597344383310585282655020137840_dp] + + print *, "Test gamma_distribution_rvs_rdp" + put = 639741825 + call random_seed(put, get) + gshape = 2.0_dp; scale = 1.0_dp + do i = 1, 5 + res(i) = gamma_rvs(gshape, scale) + end do + res(6:10) = gamma_rvs(gshape, scale, k) + call check(all(abs(res - ans) < dptol), & + msg="gamma_distribution_rvs_rdp failed", warn=warn) + end subroutine test_gamma_rvs_rdp + + subroutine test_gamma_rvs_rqp + real(qp) :: res(10), gshape, scale + integer :: i, n, k = 5 + integer :: put, get + real(qp) :: ans(10) = [0.857589039350877514111471181067133115_qp, & + 1.02066235929592669341367273855793615_qp, & + 0.997539313039285858469791992057480517_qp, & + 0.976533566171099213454202419140525167_qp, & + 0.418534850809151373739671312677149231_qp, & + 2.20122874546440374485431246113130646_qp, & + 2.06395422779089208145254668611859318_qp, & + 3.17946689363011574223408637477787452_qp, & + 1.93297441375957258760155732080675223_qp, & + 1.02579597344383310585282655020137840_qp] + + print *, "Test gamma_distribution_rvs_rqp" + put = 639741825 + call random_seed(put, get) + gshape = 2.0_qp; scale = 1.0_qp + do i = 1, 5 + res(i) = gamma_rvs(gshape, scale) + end do + res(6:10) = gamma_rvs(gshape, scale, k) + call check(all(abs(res - ans) < qptol), & + msg="gamma_distribution_rvs_rqp failed", warn=warn) + end subroutine test_gamma_rvs_rqp + + subroutine test_gamma_rvs_csp + complex(sp) :: res(10), gshape, scale + integer :: i, n, k = 5 + integer :: put, get + complex(sp) :: ans(10) = [(1.07198631763458251953125000000000000_sp, & + 0.467755347490310668945312500000000000_sp), & + (0.423825174570083618164062500000000000_sp, & + 0.963404953479766845703125000000000000_sp), & + (2.75153589248657226562500000000000000_sp, & + 0.148371994495391845703125000000000000_sp), & + (1.45363664627075195312500000000000000_sp, & + 0.568527400493621826171875000000000000_sp), & + (0.345591425895690917968750000000000000_sp, & + 4.962176829576492309570312500000000000E-0002_sp), & + (1.96578848361968994140625000000000000_sp, & + 3.11243152618408203125000000000000000_sp), & + (3.41551613807678222656250000000000000_sp, & + 5.049489438533782958984375000000000000E-0002_sp), & + (0.945943951606750488281250000000000000_sp, & + 0.456915855407714843750000000000000000_sp), & + (1.14931583404541015625000000000000000_sp, & + 0.129447638988494873046875000000000000_sp), & + (2.96914696693420410156250000000000000_sp, & + 1.16174089908599853515625000000000000_sp)] + + print *, "Test gamma_distribution_rvs_csp" + put = 639741825 + call random_seed(put, get) + gshape = (2.0_sp, 0.7_sp); scale = (0.8_sp, 1.2_sp) + do i = 1, 5 + res(i) = gamma_rvs(gshape, scale) + end do + res(6:10) = gamma_rvs(gshape, scale, k) + call check(all(abs(res - ans) < sptol), & + msg="gamma_distribution_rvs_csp failed", warn=warn) + end subroutine test_gamma_rvs_csp + + subroutine test_gamma_rvs_cdp + complex(dp) :: res(10), gshape, scale + integer :: i, n, k = 5 + integer :: put, get + complex(dp) :: ans(10) = [(1.07198631763458251953125000000000000_dp, & + 0.467755347490310668945312500000000000_dp), & + (0.423825174570083618164062500000000000_dp, & + 0.963404953479766845703125000000000000_dp), & + (2.75153589248657226562500000000000000_dp, & + 0.148371994495391845703125000000000000_dp), & + (1.45363664627075195312500000000000000_dp, & + 0.568527400493621826171875000000000000_dp), & + (0.345591425895690917968750000000000000_dp, & + 4.962176829576492309570312500000000000E-0002_dp), & + (1.96578848361968994140625000000000000_dp, & + 3.11243152618408203125000000000000000_dp), & + (3.41551613807678222656250000000000000_dp, & + 5.049489438533782958984375000000000000E-0002_dp), & + (0.945943951606750488281250000000000000_dp, & + 0.456915855407714843750000000000000000_dp), & + (1.14931583404541015625000000000000000_dp, & + 0.129447638988494873046875000000000000_dp), & + (2.96914696693420410156250000000000000_dp, & + 1.16174089908599853515625000000000000_dp)] + + print *, "Test gamma_distribution_rvs_cdp" + put = 639741825 + call random_seed(put, get) + gshape = (2.0_dp, 0.7_dp); scale = (0.8_dp, 1.2_dp) + do i = 1, 5 + res(i) = gamma_rvs(gshape, scale) + end do + res(6:10) = gamma_rvs(gshape, scale, k) + call check(all(abs(res - ans) < dptol), & + msg="gamma_distribution_rvs_cdp failed", warn=warn) + end subroutine test_gamma_rvs_cdp + + subroutine test_gamma_rvs_cqp + complex(qp) :: res(10), gshape, scale + integer :: i, n, k = 5 + integer :: put, get + complex(qp) :: ans(10) = [(1.07198631763458251953125000000000000_qp, & + 0.467755347490310668945312500000000000_qp), & + (0.423825174570083618164062500000000000_qp, & + 0.963404953479766845703125000000000000_qp), & + (2.75153589248657226562500000000000000_qp, & + 0.148371994495391845703125000000000000_qp), & + (1.45363664627075195312500000000000000_qp, & + 0.568527400493621826171875000000000000_qp), & + (0.345591425895690917968750000000000000_qp, & + 4.962176829576492309570312500000000000E-0002_qp), & + (1.96578848361968994140625000000000000_qp, & + 3.11243152618408203125000000000000000_qp), & + (3.41551613807678222656250000000000000_qp, & + 5.049489438533782958984375000000000000E-0002_qp), & + (0.945943951606750488281250000000000000_qp, & + 0.456915855407714843750000000000000000_qp), & + (1.14931583404541015625000000000000000_qp, & + 0.129447638988494873046875000000000000_qp), & + (2.96914696693420410156250000000000000_qp, & + 1.16174089908599853515625000000000000_qp)] + + print *, "Test gamma_distribution_rvs_cqp" + put = 639741825 + call random_seed(put, get) + gshape = (2.0_qp, 0.7_qp); scale = (0.8_qp, 1.2_qp) + do i = 1, 5 + res(i) = gamma_rvs(gshape, scale) + end do + res(6:10) = gamma_rvs(gshape, scale, k) + call check(all(abs(res - ans) < qptol), & + msg="gamma_distribution_rvs_cqp failed", warn=warn) + end subroutine test_gamma_rvs_cqp + + + + subroutine test_gamma_pdf_rsp + real(sp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [3.44954208E-02, 3.44954208E-02, 3.44954208E-02, & + 0.291166335, 0.283382922, 0.279222697, 0.364406645, & + 0.243792102,6.38156384E-02,0.258446008, 0.172681183, & + 0.311812222, 0.240270957, 0.367655009, 9.90117192E-02] + + print *, "Test gamma_distribution_pdf_rsp" + put = 345987126 + call random_seed(put, get) + gshape = 2.0_sp; scale = 1.0_sp + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_pdf(x1, gshape, scale) + res(:, 2:5) = gamma_pdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans, [3,5])) < sptol), & + msg="gamma_distribution_pdf_rsp failed", warn=warn) + end subroutine test_gamma_pdf_rsp + + subroutine test_gamma_pdf_rdp + real(dp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [3.44954208E-02, 3.44954208E-02, 3.44954208E-02, & + 0.291166335, 0.283382922, 0.279222697, 0.364406645, & + 0.243792102,6.38156384E-02,0.258446008, 0.172681183, & + 0.311812222, 0.240270957, 0.367655009, 9.90117192E-02] + + print *, "Test gamma_distribution_pdf_rdp" + put = 345987126 + call random_seed(put, get) + gshape = 2.0_dp; scale = 1.0_dp + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_pdf(x1, gshape, scale) + res(:, 2:5) = gamma_pdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans, [3,5])) < dptol), & + msg="gamma_distribution_pdf_rdp failed", warn=warn) + end subroutine test_gamma_pdf_rdp + + subroutine test_gamma_pdf_rqp + real(qp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [3.44954208E-02, 3.44954208E-02, 3.44954208E-02, & + 0.291166335, 0.283382922, 0.279222697, 0.364406645, & + 0.243792102,6.38156384E-02,0.258446008, 0.172681183, & + 0.311812222, 0.240270957, 0.367655009, 9.90117192E-02] + + print *, "Test gamma_distribution_pdf_rqp" + put = 345987126 + call random_seed(put, get) + gshape = 2.0_qp; scale = 1.0_qp + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_pdf(x1, gshape, scale) + res(:, 2:5) = gamma_pdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans, [3,5])) < qptol), & + msg="gamma_distribution_pdf_rqp failed", warn=warn) + end subroutine test_gamma_pdf_rqp + + subroutine test_gamma_pdf_csp + complex(sp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [0.115542844,0.115542844,0.115542844, 9.26823243E-02, & + 0.401668519, 0.374689817, 0.147123635, 0.225616276, & + 0.127654046, 3.91825065E-02, 2.58735381E-03, & + 0.101058327, 0.240440935, 4.98853484E-03, 0.110858262] + + print *, "Test gamma_distribution_pdf_csp" + put = 345987126 + call random_seed(put, get) + gshape = (2.0_sp, 0.7_sp); scale = (0.8_sp, 1.2_sp) + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_pdf(x1, gshape, scale) + res(:, 2:5) = gamma_pdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans, [3,5])) < sptol), & + msg="gamma_distribution_pdf_csp failed", warn=warn) + end subroutine test_gamma_pdf_csp + + subroutine test_gamma_pdf_cdp + complex(dp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [0.115542844,0.115542844,0.115542844, 9.26823243E-02, & + 0.401668519, 0.374689817, 0.147123635, 0.225616276, & + 0.127654046, 3.91825065E-02, 2.58735381E-03, & + 0.101058327, 0.240440935, 4.98853484E-03, 0.110858262] + + print *, "Test gamma_distribution_pdf_cdp" + put = 345987126 + call random_seed(put, get) + gshape = (2.0_dp, 0.7_dp); scale = (0.8_dp, 1.2_dp) + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_pdf(x1, gshape, scale) + res(:, 2:5) = gamma_pdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans, [3,5])) < dptol), & + msg="gamma_distribution_pdf_cdp failed", warn=warn) + end subroutine test_gamma_pdf_cdp + + subroutine test_gamma_pdf_cqp + complex(qp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [0.115542844,0.115542844,0.115542844, 9.26823243E-02, & + 0.401668519, 0.374689817, 0.147123635, 0.225616276, & + 0.127654046, 3.91825065E-02, 2.58735381E-03, & + 0.101058327, 0.240440935, 4.98853484E-03, 0.110858262] + + print *, "Test gamma_distribution_pdf_cqp" + put = 345987126 + call random_seed(put, get) + gshape = (2.0_qp, 0.7_qp); scale = (0.8_qp, 1.2_qp) + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_pdf(x1, gshape, scale) + res(:, 2:5) = gamma_pdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans, [3,5])) < qptol), & + msg="gamma_distribution_pdf_cqp failed", warn=warn) + end subroutine test_gamma_pdf_cqp + + + subroutine test_gamma_cdf_rsp + real(sp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [5.48762567E-02, 5.48762567E-02, 5.48762567E-02, & + 0.315411955, 0.385681599, 0.232208580, 0.393366873, & + 0.805594206, 0.886319339, 0.376679629, 0.141763687, & + 0.455908805, 0.278569371, 0.181033060, 0.729863822] + + print *, "Test gamma_distribution_cdf_rsp" + put = 567985123 + call random_seed(put, get) + gshape = 2.0_sp; scale = 2.0_sp + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_cdf(x1, gshape, scale) + res(:, 2:5) = gamma_cdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans,[3,5])) < sptol), & + msg="gamma_distribution_cdf_rsp failed", warn=warn) + end subroutine test_gamma_cdf_rsp + + subroutine test_gamma_cdf_rdp + real(dp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [5.48762567E-02, 5.48762567E-02, 5.48762567E-02, & + 0.315411955, 0.385681599, 0.232208580, 0.393366873, & + 0.805594206, 0.886319339, 0.376679629, 0.141763687, & + 0.455908805, 0.278569371, 0.181033060, 0.729863822] + + print *, "Test gamma_distribution_cdf_rdp" + put = 567985123 + call random_seed(put, get) + gshape = 2.0_dp; scale = 2.0_dp + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_cdf(x1, gshape, scale) + res(:, 2:5) = gamma_cdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans,[3,5])) < dptol), & + msg="gamma_distribution_cdf_rdp failed", warn=warn) + end subroutine test_gamma_cdf_rdp + + subroutine test_gamma_cdf_rqp + real(qp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [5.48762567E-02, 5.48762567E-02, 5.48762567E-02, & + 0.315411955, 0.385681599, 0.232208580, 0.393366873, & + 0.805594206, 0.886319339, 0.376679629, 0.141763687, & + 0.455908805, 0.278569371, 0.181033060, 0.729863822] + + print *, "Test gamma_distribution_cdf_rqp" + put = 567985123 + call random_seed(put, get) + gshape = 2.0_qp; scale = 2.0_qp + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_cdf(x1, gshape, scale) + res(:, 2:5) = gamma_cdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans,[3,5])) < qptol), & + msg="gamma_distribution_cdf_rqp failed", warn=warn) + end subroutine test_gamma_cdf_rqp + + subroutine test_gamma_cdf_csp + complex(sp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [3.21221203E-02, 3.21221203E-02, 3.21221203E-02, & + 0.209311500,0.779570222, 0.170826405, 2.75949780E-02,& + 2.37940717E-02, 5.22981845E-02, 0.223270506, & + 0.273653150, 3.49688679E-02,0.580260038, 0.230904028,& + 0.250726104] + + print *, "Test gamma_distribution_cdf_csp" + put = 567985123 + call random_seed(put, get) + gshape = (2.0_sp, 0.7_sp); scale = (0.8_sp, 1.2_sp) + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_cdf(x1, gshape, scale) + res(:, 2:5) = gamma_cdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans,[3,5])) < sptol), & + msg="gamma_distribution_cdf_csp failed", warn=warn) + end subroutine test_gamma_cdf_csp + + subroutine test_gamma_cdf_cdp + complex(dp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [3.21221203E-02, 3.21221203E-02, 3.21221203E-02, & + 0.209311500,0.779570222, 0.170826405, 2.75949780E-02,& + 2.37940717E-02, 5.22981845E-02, 0.223270506, & + 0.273653150, 3.49688679E-02,0.580260038, 0.230904028,& + 0.250726104] + + print *, "Test gamma_distribution_cdf_cdp" + put = 567985123 + call random_seed(put, get) + gshape = (2.0_dp, 0.7_dp); scale = (0.8_dp, 1.2_dp) + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_cdf(x1, gshape, scale) + res(:, 2:5) = gamma_cdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans,[3,5])) < dptol), & + msg="gamma_distribution_cdf_cdp failed", warn=warn) + end subroutine test_gamma_cdf_cdp + + subroutine test_gamma_cdf_cqp + complex(qp) :: x1, x2(3,4), gshape, scale + real :: res(3,5) + integer :: i, n + integer :: put, get + real :: ans(15) = [3.21221203E-02, 3.21221203E-02, 3.21221203E-02, & + 0.209311500,0.779570222, 0.170826405, 2.75949780E-02,& + 2.37940717E-02, 5.22981845E-02, 0.223270506, & + 0.273653150, 3.49688679E-02,0.580260038, 0.230904028,& + 0.250726104] + + print *, "Test gamma_distribution_cdf_cqp" + put = 567985123 + call random_seed(put, get) + gshape = (2.0_qp, 0.7_qp); scale = (0.8_qp, 1.2_qp) + x1 = gamma_rvs(gshape, scale) + x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) + res(:,1) = gamma_cdf(x1, gshape, scale) + res(:, 2:5) = gamma_cdf(x2, gshape, scale) + call check(all(abs(res - reshape(ans,[3,5])) < qptol), & + msg="gamma_distribution_cdf_cqp failed", warn=warn) + end subroutine test_gamma_cdf_cqp + +end program test_distribution_gamma \ No newline at end of file From 24bf3c437861842175453581cb11cf3989f20e52 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 11:11:58 -0500 Subject: [PATCH 07/42] Update CMakeLists.txt --- src/tests/stats/CMakeLists.txt | 1 + 1 file changed, 1 insertion(+) diff --git a/src/tests/stats/CMakeLists.txt b/src/tests/stats/CMakeLists.txt index 36ffc7aeb..3e68796b2 100644 --- a/src/tests/stats/CMakeLists.txt +++ b/src/tests/stats/CMakeLists.txt @@ -5,6 +5,7 @@ ADDTEST(moment) ADDTEST(rawmoment) ADDTEST(var) ADDTEST(varn) +ADDTEST(distribtuion_gamma) if(DEFINED CMAKE_MAXIMUM_RANK) if(${CMAKE_MAXIMUM_RANK} GREATER 7) From 4136ca8f7b7d8ab3ab2fd33558322d760b6cb618 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 11:12:25 -0500 Subject: [PATCH 08/42] Update Makefile.manual --- src/tests/stats/Makefile.manual | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/stats/Makefile.manual b/src/tests/stats/Makefile.manual index aacaf98ab..055b037c9 100644 --- a/src/tests/stats/Makefile.manual +++ b/src/tests/stats/Makefile.manual @@ -1,3 +1,3 @@ -PROGS_SRC = test_mean.f90 test_moment.f90 test_var.f90 +PROGS_SRC = test_mean.f90 test_moment.f90 test_var.f90 test_distribution_gamma.f90 include ../Makefile.manual.test.mk From 82c1f05b99ef5b22297280e35d1a8d6a52168fab Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 11:13:13 -0500 Subject: [PATCH 09/42] initial commit --- doc/specs/stdlib_stats_distribution_gamma.md | 237 +++++++++++++++++++ 1 file changed, 237 insertions(+) create mode 100644 doc/specs/stdlib_stats_distribution_gamma.md diff --git a/doc/specs/stdlib_stats_distribution_gamma.md b/doc/specs/stdlib_stats_distribution_gamma.md new file mode 100644 index 000000000..f638762e1 --- /dev/null +++ b/doc/specs/stdlib_stats_distribution_gamma.md @@ -0,0 +1,237 @@ +--- + +title: stats_distribution +--- + +# Statistical Distributions -- Gamma Distribution Module + +[TOC] + +## `gamma_distribution_rvs` - gamma distribution random variates + +### Status + +Experimental + +### Description + +With one augument for shape parameter, the function returns a standard gamma distributed random variate \(\gamma\)(shape) with `rate = 1.0`. The function is elemental. For complex auguments, the real and imaginary parts are independent of each other. + +With two auguments, the function return a scalar gamma distributed random variate \(\gamma\)(shape, rate). + +### Syntax + +`result = [[stdlib_stats_distribution_gamma(module):gamma_distribution_rvs(interface)]](shape [, rate] [[, array_size]])` + +### Arguments + +`shape` : has `intent(in)` ans is a scalar of type `real` or `complx`. + +`rate`: optional argument has `intent(in)` and is a scalar of type `real` or `complx`. + +`array_size`: optional argument has `intent(in)` and is a scalar of type `integer`. + +### Return value + +The result is a scalar or rank one array, with a size of `array_size`, of type `real` or `complx`. + +### Example + +```fortran +program demo_gamma_rvs + use stdlib_stats_distribution_PRNG, only : random_seed + use stdlib_stats_distribution_gamma, only: rgamma => gamma_distribution_rvs + + implicit none + real :: g(2,3,4) + complx :: shape, scale + integer :: put, get + + put = 1234567 + call random_seed(put, get) + + print *, rgamma(2.0) + !single standard gamma random variate with shape of 2.0, rate=1.0 + +! 2.50538206 + + print *, rgamma(3.0,2.0) !gamma random variate with shape=3.0, rate=2.0 + +! 1.30591583 + + g(:,:,:) = 0.5 + print *, rgamma(g) + !a rank 3 array of 60 standard gamma random variates with rate=0.5 + +! [1.03841162, 1.33044529, 0.912742674, 0.131288037, 0.638593793, +! 1.03565669E-02, 0.624804378, 1.12179172, 4.91380468E-02, 6.69969944E-03, +! 6.67014271E-02, 0.132111162, 0.101102419, 0.648416579, 1.14922595, +! 2.29003578E-02, 1.85964716E-04, 1.21213868E-02, 1.69112933, +! 7.30440915E-02, 0.395139128, 0.182758048, 0.427981257, 0.985665262] + + print *, rgamma(0.5,1.0,10) + ! an array of 10 random variates with shape=0.5, rate=1.0 + +! [1.39297554E-04, 0.296419382, 0.352113068, 2.80515051, 3.65264394E-04, +! 0.197743446, 5.54569438E-02, 9.30598825E-02, 1.02596343, 1.85311246] + + shape = (3.0, 4.0) + scale = (2.0, 0.7) + print *, rgamma(shape,scale) + !single complex gamma random variate with real part of shape = 3.0, rate=2.0; imagainary part of shape=4.0, rate=0.7 + +! (0.826188326,3.54749799) + +end program demo_gamma_rvs +``` + +## `gamma_distribution_pdf` - gamma probability density function + +### Status + +Experimental + +### Description + +The probability density function of the continuous gamma distribution. + +$$ f(x)= \frac{scale^{shape}}{\Gamma (shape)}x^{shape-1}e^{-scale \times x} , for \;\; x>0, shape, scale>0$$ + +### Syntax + +`result = [[stdlib_stats_distribution_gamma(module):gamma_distribution_pdf(interface)]](x, shape, rate)` + +### Arguments + +`x`: has `intent(in)` and is a scalar of type `real` or `complx`. + +`shape` has `intent(in)` and is a scalar of type real` or `complx`. + +`rate`: has `intent(in)` and is a scalar of type `real` or `complx`. + +The function is elemental, i.e., all auguments could be arrays conformable to each other. All arguments must have the same type. + +### Return value + +The result is a scalar or an array, with a shape conformable to auguments, of type `real`. + +### Example + +```fortran +program demo_gamma_pdf + use stdlib_stats_distribution_PRNG, onyl : random_seed + use stdlib_stats_distribution_gamma, only: rgamma => gamma_distribution_rvs,& + gamma_pdf => gamma_distribution_pdf + + implicit none + real :: x(2,3,4),g(2,3,4),s(2,3,4) + complx :: shape, scale + integer :: put, get + + put = 1234567 + call random_seed(put, get) + + print *, gamma_pdf(1.0, 1.0, 1.0) + !a probability density at 1.0 with shape=1.0, rate=1.0 + +! 0.367879450 + + g(:,:,:) = 2.0 + s(:,:,:) = 1.0 + x = reshape(rgamma(2.0, 1.0, 24),[2,3,4]) ! gamma random variates array + print *, gamma_pdf(x,g,s) ! a rank 3 gamma probability density array + +! [0.204550430, 0.320178866, 0.274986655, 0.348611295, 0.101865448, +! 0.102199331, 0.358981341, 0.223676488, 0.254329354, 0.356714427, +! 0.267390072, 0.305148095, 0.367848188, 7.26194456E-02, 1.49471285E-02, +! 0.246272027, 0.360770017, 0.339665830, 0.101558588, 0.358678699, +! 0.224196941, 0.359253854, 7.56355673E-02, 0.251869917] + + shape = (1.0, 1.5) + scale = (1.0, 2.) + print *, gamma_pdf((1.5,1.0), shape, scale) + ! a complex expon probability density function at (1.5,1.0) with real part of shape=1.0, rate=1.0 and imaginary part of shape=1.5, rate=2.0 + +! 9.63761061E-02 + +end program demo_gamma_pdf +``` + +## `gamma_distribution_cdf` - gamma cumulative distribution function + +### Status + +Experimental + +### Description + +Cumulative distribution function of the gamma continuous distribution + +$$ F(x)= \frac{\gamma (shape, scale \times x)}{\Gamma (shape)}, for \;\; x>0, shape, scale>0} $$ + +### Syntax + +`result = [[stdlib_stats_distribution_gamma(module):gamma_distribution_cdf(interface)]](x, shape, rate)` + +### Arguments + +`x`: has `intent(in)` and is a scalar of type `real` or `complx`. + +`shape`: has `intent(in)` and is a scalar of type `real` or `complx`. + +`rate`: has `intent(in)` and is a scalar of type `real` or `complx`. + +The function is elemental, i.e., all auguments could be arrays conformable to each other. All arguments must have the same type. + +### Return value + +The result is a scalar of type `real` with a shape conformable to auguments. + +### Example + +```fortran +program demo_gamma_cdf + use stdlib_stats_distribution_PRNG, onyl : random_seed + use stdlib_stats_distribution_gamma, only: rgamma => gamma_distribution_rvs,& + gamma_cdf => gamma_distribution_cdf + + implicit none + real :: x(2,3,4),g(2,3,4),s(2,3,4) + complx :: shape, scale + integer :: seed_put, seed_get + + seed_put = 1234567 + call random_seed(seed_put, seed_get) + + print *, gamma_cdf(1.0, 0.5,1.0) + ! a standard gamma cumulative at 1.0 with a shape=0.5, rate=1.0 + +! 0.842700839 + + print *, gamma_cdf(2.0, 1.5,2.0) + ! a cumulative at 2.0 with a shape=1.5, rate=2.0 + +! 0.953988254 + + g(:,:,:) = 1.0 + s(:,:,:) = 1.0 + x = reshape(rgamma(1.0, 1.0, 24),[2,3,4]) + !gamma random variates array with a shape=1.0, rate=1.0 + print *, gamma_cdf(x,g,s) ! a rank 3 standard gamma cumulative array + +! [0.710880339, 0.472411335, 0.578345954, 0.383050948, 0.870905757, +! 0.870430350, 0.170215249, 0.677347481, 0.620089889, 0.161825046, +! 4.17549349E-02, 0.510665894, 0.252201647, 0.911497891, 0.984424412, +! 0.635621786, 0.177783430, 0.414842933, 0.871342421, 0.338317066, +! 2.06879266E-02, 0.335232288, 0.907408893, 0.624871135] + + shape = (.7, 2.1) + scale = (0.5,1.0) + print *, gamma_cdf((0.5,0.5),shape,scale) + !complex gamma cumulative distribution at (0.5,0.5) with real part of shape=0.7,rate=0.5 and imaginary part of shape=2.1,rate=1.0 + +! 2.87349485E-02 + +end program demo_gamma_cdf + +``` From ddc9267ec7ad96000728125fe1d470cc5ec2e2fa Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 11:14:50 -0500 Subject: [PATCH 10/42] Update index.md --- doc/specs/index.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/specs/index.md b/doc/specs/index.md index 91284c2df..245f1f7f0 100644 --- a/doc/specs/index.md +++ b/doc/specs/index.md @@ -17,6 +17,8 @@ This is and index/directory of the specifications (specs) for each new module/fe - [optval](./stdlib_optval.html) - Fallback value for optional arguments - [quadrature](./stdlib_quadrature.html) - Numerical integration - [stats](./stdlib_stats.html) - Descriptive Statistics + - [stats_distribution](./stdlib_stats_distribution_gamma.html) - Gamma Distribution + ## Missing specs From 525ef4b604542bfbe93ef0ce579bb87e223f7d10 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 11:15:28 -0500 Subject: [PATCH 11/42] Update index.md --- doc/specs/index.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/index.md b/doc/specs/index.md index 245f1f7f0..db49f14b2 100644 --- a/doc/specs/index.md +++ b/doc/specs/index.md @@ -17,7 +17,7 @@ This is and index/directory of the specifications (specs) for each new module/fe - [optval](./stdlib_optval.html) - Fallback value for optional arguments - [quadrature](./stdlib_quadrature.html) - Numerical integration - [stats](./stdlib_stats.html) - Descriptive Statistics - - [stats_distribution](./stdlib_stats_distribution_gamma.html) - Gamma Distribution + - [stats_distribution_gamma](./stdlib_stats_distribution_gamma.html) - Gamma Distribution ## Missing specs From c4acb4385394cefcfeb7c9eea064b18db851881a Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 12:45:06 -0500 Subject: [PATCH 12/42] Update CMakeLists.txt --- src/tests/stats/CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tests/stats/CMakeLists.txt b/src/tests/stats/CMakeLists.txt index 3e68796b2..7e338cb0b 100644 --- a/src/tests/stats/CMakeLists.txt +++ b/src/tests/stats/CMakeLists.txt @@ -5,7 +5,7 @@ ADDTEST(moment) ADDTEST(rawmoment) ADDTEST(var) ADDTEST(varn) -ADDTEST(distribtuion_gamma) +ADDTEST(distribution_gamma) if(DEFINED CMAKE_MAXIMUM_RANK) if(${CMAKE_MAXIMUM_RANK} GREATER 7) From 3bf0ad02008804905f21ac786a7fc9f9511b0f5e Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 15:18:40 -0500 Subject: [PATCH 13/42] remove tabs --- src/stdlib_stats_distribution_special.fypp | 948 ++++++++++----------- 1 file changed, 474 insertions(+), 474 deletions(-) diff --git a/src/stdlib_stats_distribution_special.fypp b/src/stdlib_stats_distribution_special.fypp index a178d1813..659d4663a 100644 --- a/src/stdlib_stats_distribution_special.fypp +++ b/src/stdlib_stats_distribution_special.fypp @@ -4,595 +4,595 @@ Module stdlib_stats_distribution_special use stdlib_kinds use stdlib_error, only : error_stop - - implicit none - private - real(qp), parameter :: D(0:10) = [2.48574089138753565546e-5_qp, & - 1.05142378581721974210_qp, & - -3.45687097222016235469_qp, & - 4.51227709466894823700_qp, & - -2.98285225323576655721_qp, & - 1.05639711577126713077_qp, & - -1.95428773191645869583e-1_qp, & - 1.70970543404441224307e-2_qp, & - -5.71926117404305781283e-4_qp, & - 4.63399473359905636708e-6_qp, & - -2.71994908488607703910e-9_qp] + + implicit none + private + real(qp), parameter :: D(0:10) = [2.48574089138753565546e-5_qp, & + 1.05142378581721974210_qp, & + -3.45687097222016235469_qp, & + 4.51227709466894823700_qp, & + -2.98285225323576655721_qp, & + 1.05639711577126713077_qp, & + -1.95428773191645869583e-1_qp, & + 1.70970543404441224307e-2_qp, & + -5.71926117404305781283e-4_qp, & + 4.63399473359905636708e-6_qp, & + -2.71994908488607703910e-9_qp] real(qp), parameter :: R = 10.900511_qp, HALF = 0.5_qp, & - sqep = log(2.0_qp * sqrt(exp(1.0_qp) / acos(-1.0_qp))) + sqep = log(2.0_qp * sqrt(exp(1.0_qp) / acos(-1.0_qp))) real(dp), parameter :: ep_machine = 2.2e-16_dp, dm = 1.0e-300_dp ! for stdlib_distribution internal use - + public :: log_gamma, log_factorial - public :: ingamma_low, log_ingamma_low, ingamma_up, log_ingamma_up + public :: ingamma_low, log_ingamma_low, ingamma_up, log_ingamma_up public :: regamma_p, regamma_q - public :: beta, log_beta, inbeta + public :: beta, log_beta, inbeta interface log_gamma - ! Logrithm of gamma function with real variable - ! - #:for k1, t1 in REAL_KINDS_TYPES - module procedure l_gamma_${t1[0]}$${k1}$ - #:endfor - end interface log_gamma - + ! Logrithm of gamma function with real variable + ! + #:for k1, t1 in REAL_KINDS_TYPES + module procedure l_gamma_${t1[0]}$${k1}$ + #:endfor + end interface log_gamma + interface log_factorial - ! Logrithm of factorial n!, integer variable - ! + ! Logrithm of factorial n!, integer variable + ! #:for k1, t1 in INT_KINDS_TYPES - module procedure l_factorial_1_${t1[0]}$${k1}$ !1 dummy - #:endfor + module procedure l_factorial_1_${t1[0]}$${k1}$ !1 dummy + #:endfor + + #: for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + module procedure l_factorial_${t1[0]}$${k1}$${k2}$ !2 dummy + #:endfor + #:endfor + end interface log_factorial - #: for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - module procedure l_factorial_${t1[0]}$${k1}$${k2}$ !2 dummy - #:endfor - #:endfor - end interface log_factorial - interface ingamma_low - ! Lower incomplete gamma function - ! + ! Lower incomplete gamma function + ! #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure ingamma_low_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface ingamma_low + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure ingamma_low_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface ingamma_low interface log_ingamma_low - ! Logrithm of lower incomplete gamma function - ! + ! Logrithm of lower incomplete gamma function + ! #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure l_ingamma_low_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface log_ingamma_low + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure l_ingamma_low_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface log_ingamma_low interface ingamma_up - ! Upper incomplete gamma function - ! + ! Upper incomplete gamma function + ! #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure ingamma_up_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface ingamma_up + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure ingamma_up_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface ingamma_up interface log_ingamma_up - ! Logrithm of upper incomplete gamma function + ! Logrithm of upper incomplete gamma function #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure l_ingamma_up_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface log_ingamma_up + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure l_ingamma_up_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface log_ingamma_up interface regamma_p - ! Regularized (normalized) lower incomplete gamma function, P - ! + ! Regularized (normalized) lower incomplete gamma function, P + ! #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure regamma_p_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface regamma_p + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure regamma_p_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface regamma_p interface regamma_q - ! Regularized (normalized) upper incomplete gamma function, Q - ! + ! Regularized (normalized) upper incomplete gamma function, Q + ! #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure regamma_q_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface regamma_q + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + module procedure regamma_q_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor + end interface regamma_q interface gpx - ! Evaluation of incomplete gamma function - ! - #:for k1, t1 in REAL_KINDS_TYPES - module procedure gpx_${t1[0]}$${k1}$ - #:endfor + ! Evaluation of incomplete gamma function + ! + #:for k1, t1 in REAL_KINDS_TYPES + module procedure gpx_${t1[0]}$${k1}$ + #:endfor #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - module procedure gpx_${t1[0]}$${k1}$${k2}$ - #:endfor - #:endfor - end interface gpx + #:for k2, t2 in REAL_KINDS_TYPES + module procedure gpx_${t1[0]}$${k1}$${k2}$ + #:endfor + #:endfor + end interface gpx interface beta - ! Beta function - ! - #:for k1, t1 in REAL_KINDS_TYPES - module procedure beta_${t1[0]}$${k1}$ - #:endfor - end interface beta + ! Beta function + ! + #:for k1, t1 in REAL_KINDS_TYPES + module procedure beta_${t1[0]}$${k1}$ + #:endfor + end interface beta interface log_beta - ! Logrithm of beta function - ! - #:for k1, t1 in REAL_KINDS_TYPES - module procedure l_beta_${t1[0]}$${k1}$ - #:endfor - end interface log_beta + ! Logrithm of beta function + ! + #:for k1, t1 in REAL_KINDS_TYPES + module procedure l_beta_${t1[0]}$${k1}$ + #:endfor + end interface log_beta interface inbeta - ! Incomplete beta function - ! - #:for k1, t1 in REAL_KINDS_TYPES - module procedure inbeta_${t1[0]}$${k1}$ - #:endfor - end interface inbeta + ! Incomplete beta function + ! + #:for k1, t1 in REAL_KINDS_TYPES + module procedure inbeta_${t1[0]}$${k1}$ + #:endfor + end interface inbeta contains #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function l_gamma_${t1[0]}$${k1}$(x) result (res) - ! Log gamma function for any positive real number i,e, {R+} - ! - ${t1}$, intent(in) :: x - ${t1}$ :: res - real(qp) :: q, sum + impure elemental function l_gamma_${t1[0]}$${k1}$(x) result (res) + ! Log gamma function for any positive real number i,e, {R+} + ! + ${t1}$, intent(in) :: x + ${t1}$ :: res + real(qp) :: q, sum integer :: i if(x <= 0) call error_stop("Error: Gamma function augument must be" & - //" greater than 0") - if(x == 1.0_${k1}$ .or. x == 2.0_${k1}$) then - res = 0.0_${k1}$ - else + //" greater than 0") + if(x == 1.0_${k1}$ .or. x == 2.0_${k1}$) then + res = 0.0_${k1}$ + else q = x - HALF - sum = D(0) - do i=1, 10 - sum = sum + D(i) / (x - 1.0_qp + i) - end do - res = real(sqep + log(sum) - q + q * log(q + R), kind=${k1}$) - endif - return - end function l_gamma_${t1[0]}$${k1}$ - - #:endfor + sum = D(0) + do i=1, 10 + sum = sum + D(i) / (x - 1.0_qp + i) + end do + res = real(sqep + log(sum) - q + q * log(q + R), kind=${k1}$) + endif + return + end function l_gamma_${t1[0]}$${k1}$ + + #:endfor #:for k1, t1 in INT_KINDS_TYPES - impure elemental function l_factorial_1_${t1[0]}$${k1}$(n) result(res) - ! Log(n!) with single precision result, n is integer - ! - ${t1}$, intent(in) :: n - real :: res + impure elemental function l_factorial_1_${t1[0]}$${k1}$(n) result(res) + ! Log(n!) with single precision result, n is integer + ! + ${t1}$, intent(in) :: n + real :: res if(n < 0) call error_stop("Error: Factorial function augument must" & //" be no less than 0") select case(n) - case (0) - res = 0.0 - case (1) - res = 0.0 - case (2:) - res = log_gamma(real(n+1)) - end select - return - end function l_factorial_1_${t1[0]}$${k1}$ - #:endfor + case (0) + res = 0.0 + case (1) + res = 0.0 + case (2:) + res = log_gamma(real(n+1)) + end select + return + end function l_factorial_1_${t1[0]}$${k1}$ + #:endfor #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - impure elemental function l_factorial_${t1[0]}$${k1}$${k2}$(n,x) result(res) - ! Log(n!) with required prescision for result, n is integer, x is a real & - ! for specified kind - ! - ${t1}$, intent(in) :: n - ${t2}$, intent(in) :: x - ${t2}$ :: res + #:for k2, t2 in REAL_KINDS_TYPES + impure elemental function l_factorial_${t1[0]}$${k1}$${k2}$(n,x) result(res) + ! Log(n!) with required prescision for result, n is integer, x is a real & + ! for specified kind + ! + ${t1}$, intent(in) :: n + ${t2}$, intent(in) :: x + ${t2}$ :: res if(n < 0) call error_stop("Error: factorial function augument must" & //" be no less than 0") select case(n) - case (0) - res = 0.0_${k2}$ - case (1) - res = 0.0_${k2}$ - case (2:) - res = log_gamma(real((n+1), kind=${k2}$)) - end select - return - end function l_factorial_${t1[0]}$${k1}$${k2}$ - #:endfor - #:endfor - + case (0) + res = 0.0_${k2}$ + case (1) + res = 0.0_${k2}$ + case (2:) + res = log_gamma(real((n+1), kind=${k2}$)) + end select + return + end function l_factorial_${t1[0]}$${k1}$${k2}$ + #:endfor + #:endfor + #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function gpx_${t1[0]}$${k1}$(s, x) result(res) - ! Approximation of incomplete gamma G function - ! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and + impure elemental function gpx_${t1[0]}$${k1}$(s, x) result(res) + ! Approximation of incomplete gamma G function + ! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and ! Accurate Evaluation of a Generalized Incomplete Gamma Function", ACM - ! Transactions on Mathematical Software, March 2020. - ! - ${t1}$, intent(in) :: x, s - real(dp) :: res - real(dp) :: a, b, g, c, d, y - integer :: n - - if(x < 0) then - call error_stop("Error: Incomplete gamma function with negative x" & - //" must come with integer of s") - elseif(s >= x) then - a = s - g = 1.0_${k1}$ / a - c = g - do - a = a + 1.0_${k1}$ - c = c * x / a - g = g + c - if(abs(c) < ep_machine) exit - end do - else - a = 1.0_dp - b = real(x + 1 - s, kind=dp) - g = a / b - c = a / dm - d = 1.0_dp / b - n = 2 - do - a = -(n - 1) * (n - s - 1) - b = x + 2 * n - 1.0_dp - s - d = d * a + b - if(d == 0.0_dp) d = dm - c = b + a / c - if(c == 0.0_dp) c = dm - d = 1.0_dp / d - y = c * d - g = g * y - n = n + 1 - if(abs(y - 1.0_dp) < ep_machine) exit - end do - endif - res = g - return - end function gpx_${t1[0]}$${k1}$ - - #:endfor + ! Transactions on Mathematical Software, March 2020. + ! + ${t1}$, intent(in) :: x, s + real(dp) :: res + real(dp) :: a, b, g, c, d, y + integer :: n + + if(x < 0) then + call error_stop("Error: Incomplete gamma function with negative x" & + //" must come with integer of s") + elseif(s >= x) then + a = s + g = 1.0_${k1}$ / a + c = g + do + a = a + 1.0_${k1}$ + c = c * x / a + g = g + c + if(abs(c) < ep_machine) exit + end do + else + a = 1.0_dp + b = real(x + 1 - s, kind=dp) + g = a / b + c = a / dm + d = 1.0_dp / b + n = 2 + do + a = -(n - 1) * (n - s - 1) + b = x + 2 * n - 1.0_dp - s + d = d * a + b + if(d == 0.0_dp) d = dm + c = b + a / c + if(c == 0.0_dp) c = dm + d = 1.0_dp / d + y = c * d + g = g * y + n = n + 1 + if(abs(y - 1.0_dp) < ep_machine) exit + end do + endif + res = g + return + end function gpx_${t1[0]}$${k1}$ + + #:endfor #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - impure elemental function gpx_${t1[0]}$${k1}$${k2}$(s, x) result(res) - ! Approximation of incomplete gamma G function - ! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and + #:for k2, t2 in REAL_KINDS_TYPES + impure elemental function gpx_${t1[0]}$${k1}$${k2}$(s, x) result(res) + ! Approximation of incomplete gamma G function + ! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and ! Accurate Evaluation of a Generalized Incomplete Gamma Function", ACM - ! Transactions on Mathematical Software, March 2020. - ! - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - real(dp) :: res - ${t2}$ :: p_lim - real(dp) :: a, b, g, c, d, y - integer :: n - - if(x < -9) then - p_lim = 5.0_${k2}$ * (sqrt(abs(x)) - 1.0_${k2}$) - elseif(x >= -9 .and. x <= 0) then - p_lim = 0.0_${k2}$ - else - p_lim = x - endif - if(s >= p_lim) then - a = s - g = 1.0_${k2}$ / a - c = g - do - a = a + 1.0_${k2}$ - c = c * x / a - g = g + c - if(abs(c) < ep_machine) exit - end do - elseif(x >= 0.0_${k2}$) then - a = 1.0_dp - b = real(x + 1 - s, kind=dp) - g = a / b - c = a / dm - d = 1.0_dp / b - n = 2 - do - a = -(n - 1) * (n - s - 1) - b = x + 2 * n - 1.0_dp - s - d = d * a + b - if(d == 0.0_dp) d = dm - c = b + a / c - if(c == 0.0_dp) c = dm - d = 1.0_dp / d - y = c * d - g = g * y - n = n + 1 - if(abs(y - 1.0_dp) < ep_machine) exit - end do - elseif(abs(x) > max(1, s - 1)) then - a = -x - c = 1.0_dp / a - d = real(s - 1, kind=dp) - b = c * (a - d) - n = 1 - do + ! Transactions on Mathematical Software, March 2020. + ! + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + real(dp) :: res + ${t2}$ :: p_lim + real(dp) :: a, b, g, c, d, y + integer :: n + + if(x < -9) then + p_lim = 5.0_${k2}$ * (sqrt(abs(x)) - 1.0_${k2}$) + elseif(x >= -9 .and. x <= 0) then + p_lim = 0.0_${k2}$ + else + p_lim = x + endif + if(s >= p_lim) then + a = s + g = 1.0_${k2}$ / a + c = g + do + a = a + 1.0_${k2}$ + c = c * x / a + g = g + c + if(abs(c) < ep_machine) exit + end do + elseif(x >= 0.0_${k2}$) then + a = 1.0_dp + b = real(x + 1 - s, kind=dp) + g = a / b + c = a / dm + d = 1.0_dp / b + n = 2 + do + a = -(n - 1) * (n - s - 1) + b = x + 2 * n - 1.0_dp - s + d = d * a + b + if(d == 0.0_dp) d = dm + c = b + a / c + if(c == 0.0_dp) c = dm + d = 1.0_dp / d + y = c * d + g = g * y + n = n + 1 + if(abs(y - 1.0_dp) < ep_machine) exit + end do + elseif(abs(x) > max(1, s - 1)) then + a = -x + c = 1.0_dp / a + d = real(s - 1, kind=dp) + b = c * (a - d) + n = 1 + do c = d * (d - 1) / (a * a) - d = d - 2 - y = c * ( a - d) - b = b + y - n = n + 1 - if(n > (s - 2) / 2 .or. y < b * ep_machine) exit - end do - if(y >= b * ep_machine .and. mod(s, 2) /= 0) b = b + d * c / a - g = ((-1) ** s * exp(-a + log_gamma(real(s, kind=dp)) - (s - 1) * & - log(a)) + b ) / a - endif - res = g - return - end function gpx_${t1[0]}$${k1}$${k2}$ - + d = d - 2 + y = c * ( a - d) + b = b + y + n = n + 1 + if(n > (s - 2) / 2 .or. y < b * ep_machine) exit + end do + if(y >= b * ep_machine .and. mod(s, 2) /= 0) b = b + d * c / a + g = ((-1) ** s * exp(-a + log_gamma(real(s, kind=dp)) - (s - 1) * & + log(a)) + b ) / a + endif + res = g + return + end function gpx_${t1[0]}$${k1}$${k2}$ + #:endfor - #:endfor + #:endfor #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - impure elemental function ingamma_low_${t1[0]}$${k1}$${k2}$(s, x) & - result(res) - ! Approximation of lower incomplete gamma function - ! - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res - real(dp) :: s1, y + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + impure elemental function ingamma_low_${t1[0]}$${k1}$${k2}$(s, x) & + result(res) + ! Approximation of lower incomplete gamma function + ! + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res + real(dp) :: s1, y if(s < 0) call error_stop("Error: Lower incomplete gamma function" & - //" input s value must be greater than 0") - if(x == 0.0_dp) then - res = real(0.0, kind=${k2}$) - elseif(x > 0.0_dp .and. x <= s) then - s1 = -x + s * log(x) - res = real(gpx(s,x) * exp(s1), kind=${k2}$) - elseif(x > s) then - s1 = log_gamma(real(s, kind=dp)) - y = 1.0_dp - exp(-x + s * log(x) - s1) * gpx(s,x) - res = real(y * exp(s1), kind=${k2}$) - else - s1 = -x + s * log(-x) - res = real((-1)**s * gpx(s,x) * exp(s1), kind=${k2}$) - endif - return - end function ingamma_low_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor + //" input s value must be greater than 0") + if(x == 0.0_dp) then + res = real(0.0, kind=${k2}$) + elseif(x > 0.0_dp .and. x <= s) then + s1 = -x + s * log(x) + res = real(gpx(s,x) * exp(s1), kind=${k2}$) + elseif(x > s) then + s1 = log_gamma(real(s, kind=dp)) + y = 1.0_dp - exp(-x + s * log(x) - s1) * gpx(s,x) + res = real(y * exp(s1), kind=${k2}$) + else + s1 = -x + s * log(-x) + res = real((-1)**s * gpx(s,x) * exp(s1), kind=${k2}$) + endif + return + end function ingamma_low_${t1[0]}$${k1}$${k2}$ + #:endif + #:endfor + #:endfor #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - impure elemental function l_ingamma_low_${t1[0]}$${k1}$${k2}$(s, x) & - result(res) - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + impure elemental function l_ingamma_low_${t1[0]}$${k1}$${k2}$(s, x) & + result(res) + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res res = log(ingamma_low(s,x)) end function l_ingamma_low_${t1[0]}$${k1}$${k2}$ #:endif - #:endfor - #:endfor + #:endfor + #:endfor #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - impure elemental function ingamma_up_${t1[0]}$${k1}$${k2}$(s, x) & - result(res) - ! Approximation of upper incomplete gamma function - ! - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + impure elemental function ingamma_up_${t1[0]}$${k1}$${k2}$(s, x) & + result(res) + ! Approximation of upper incomplete gamma function + ! + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res res = exp(log_gamma(real(s, kind=${k2}$))) - ingamma_low(s,x) - return - end function ingamma_up_${t1[0]}$${k1}$${k2}$ + return + end function ingamma_up_${t1[0]}$${k1}$${k2}$ #:endif - #:endfor - #:endfor + #:endfor + #:endfor #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and ( k1 != k2)) - impure elemental function l_ingamma_up_${t1[0]}$${k1}$${k2}$(s, x) & - result(res) - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and ( k1 != k2)) + impure elemental function l_ingamma_up_${t1[0]}$${k1}$${k2}$(s, x) & + result(res) + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res res = log(ingamma_up(s,x)) end function l_ingamma_up_${t1[0]}$${k1}$${k2}$ #:endif - #:endfor - #:endfor + #:endfor + #:endfor #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - impure elemental function regamma_p_${t1[0]}$${k1}$${k2}$(s, x) result(res) - ! Approximation of regulated incomplet gamma function P(s,x) - ! - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + impure elemental function regamma_p_${t1[0]}$${k1}$${k2}$(s, x) result(res) + ! Approximation of regulated incomplet gamma function P(s,x) + ! + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res real(dp) :: s1 if(s < 0) call error_stop("Error: Regularized incomplete gamma" & - //" function P input s value must be greater than 0") - s1 = -x + s * log(abs(x)) - log_gamma(real(s, kind=${k2}$)) - if(x == 0.0_dp) then - res = real(0.0, kind=${k2}$) - elseif(x > 0.0_dp .and. x <= s) then - res = real(gpx(s,x) * exp(s1), kind=${k2}$) - elseif(x > s) then - res = 1.0_dp - exp(s1) * gpx(s,x) - else - res = real((-1)**s * gpx(s,x) * exp(s1), kind=${k2}$) - endif - return - end function regamma_p_${t1[0]}$${k1}$${k2}$ - - #:endif - #:endfor - #:endfor + //" function P input s value must be greater than 0") + s1 = -x + s * log(abs(x)) - log_gamma(real(s, kind=${k2}$)) + if(x == 0.0_dp) then + res = real(0.0, kind=${k2}$) + elseif(x > 0.0_dp .and. x <= s) then + res = real(gpx(s,x) * exp(s1), kind=${k2}$) + elseif(x > s) then + res = 1.0_dp - exp(s1) * gpx(s,x) + else + res = real((-1)**s * gpx(s,x) * exp(s1), kind=${k2}$) + endif + return + end function regamma_p_${t1[0]}$${k1}$${k2}$ + + #:endif + #:endfor + #:endfor #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - impure elemental function regamma_q_${t1[0]}$${k1}$${k2}$(s, x) & - result(res) - ! Approximation of regulated incomplet gamma function Q(s,x) - ! - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res + #:for k2, t2 in REAL_KINDS_TYPES + #:if not ((t1[0] == "r") and (k1 != k2)) + impure elemental function regamma_q_${t1[0]}$${k1}$${k2}$(s, x) & + result(res) + ! Approximation of regulated incomplet gamma function Q(s,x) + ! + ${t1}$, intent(in) :: s + ${t2}$, intent(in) :: x + ${t2}$ :: res res = real(1.0_dp - regamma_p_${t1[0]}$${k1}$${k2}$(s,x), kind=${k2}$) - return - end function regamma_q_${t1[0]}$${k1}$${k2}$ - - #:endif - #:endfor - #:endfor + return + end function regamma_q_${t1[0]}$${k1}$${k2}$ + + #:endif + #:endfor + #:endfor #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function beta_${t1[0]}$${k1}$(a, b) result(res) - ! Evaluation of beta function through gamma function - ! - ${t1}$, intent(in) :: a, b - ${t1}$ :: res + impure elemental function beta_${t1[0]}$${k1}$(a, b) result(res) + ! Evaluation of beta function through gamma function + ! + ${t1}$, intent(in) :: a, b + ${t1}$ :: res if(a <= 0 .or. b <= 0) call error_stop("Error: Beta function auguments"& - //" a, b values must be greater than 0") + //" a, b values must be greater than 0") res = exp(log_gamma(a) + log_gamma(b) - log_gamma(a+b)) - return - end function beta_${t1[0]}$${k1}$ - - #:endfor + return + end function beta_${t1[0]}$${k1}$ + + #:endfor #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function l_beta_${t1[0]}$${k1}$(a, b) result(res) - ! Logrithm of beta function through log(gamma) - ! - ${t1}$, intent(in) :: a, b - ${t1}$ :: res + impure elemental function l_beta_${t1[0]}$${k1}$(a, b) result(res) + ! Logrithm of beta function through log(gamma) + ! + ${t1}$, intent(in) :: a, b + ${t1}$ :: res if(a <= 0 .or. b <= 0) call error_stop("Error: Logrithm of Beta" & - //" function auguments a, b values must be greater than 0") + //" function auguments a, b values must be greater than 0") res = log_gamma(a) + log_gamma(b) - log_gamma(a+b) - return - end function l_beta_${t1[0]}$${k1}$ - - #:endfor - + return + end function l_beta_${t1[0]}$${k1}$ + + #:endfor + #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function inbeta_${t1[0]}$${k1}$(x, a, b) result(res) - ! Evaluation of incomplete beta function using continued fractions - ! "Computation of Special Functions" by S. Zhang and J. Jin, 1996 - ! - ${t1}$, intent(in) :: x, a, b - ${t1}$ :: res + impure elemental function inbeta_${t1[0]}$${k1}$(x, a, b) result(res) + ! Evaluation of incomplete beta function using continued fractions + ! "Computation of Special Functions" by S. Zhang and J. Jin, 1996 + ! + ${t1}$, intent(in) :: x, a, b + ${t1}$ :: res real :: s0, ak, ak2 - integer :: n, k - real(dp) :: an, bn, g, c, d, y + integer :: n, k + real(dp) :: an, bn, g, c, d, y if(a <= 0 .or. b <= 0) call error_stop("Error: Incomplete beta" & - //" function auguments a, b values must be greater than 0") + //" function auguments a, b values must be greater than 0") s0 = (a + 1) / (a + b + 2) - an = 1.0_dp - bn = 1.0_dp - g = a / b - c = a / dm - d = 1.0_dp / b - n = 1 - if(x < s0) then - do - if(mod(n, 2) == 0) then - k = n / 2; ak = a + 2 * k - an = k * x * (b - k) / (ak * ak - ak) - else - k = (n - 1) / 2; ak = a + k; ak2 = ak + k - an = - (ak + b) * ak * x / (ak2 * ak2 + ak2) - endif - d = d * an + bn - if(d == 0.0_dp) d = dm - c = bn + an / c - if(c == 0.0_dp) c = dm - d = 1.0_dp / d - y = c * d - g = g * y - n = n + 1 - if(abs(y - 1.0_dp) < ep_machine) exit - end do - g = x ** a * (1.0_${k1}$ - x) ** b * g / (a * beta(a, b)) + an = 1.0_dp + bn = 1.0_dp + g = a / b + c = a / dm + d = 1.0_dp / b + n = 1 + if(x < s0) then + do + if(mod(n, 2) == 0) then + k = n / 2; ak = a + 2 * k + an = k * x * (b - k) / (ak * ak - ak) + else + k = (n - 1) / 2; ak = a + k; ak2 = ak + k + an = - (ak + b) * ak * x / (ak2 * ak2 + ak2) + endif + d = d * an + bn + if(d == 0.0_dp) d = dm + c = bn + an / c + if(c == 0.0_dp) c = dm + d = 1.0_dp / d + y = c * d + g = g * y + n = n + 1 + if(abs(y - 1.0_dp) < ep_machine) exit + end do + g = x ** a * (1.0_${k1}$ - x) ** b * g / (a * beta(a, b)) else - do - if(mod(n, 2) == 0) then - k = n / 2; ak = b + 2 * k - an = k * (1.0_dp - x) * (a - k) - else - k = (n - 1) / 2; ak = b + k; ak2 = ak + k - an = - ak * (1.0_dp - x) * (a + ak) / (ak2 * ak2 + ak2) - endif - d = d * an + bn - if(d == 0.0_dp) d = dm - c = bn + an / c - if(c == 0.0_dp) c = dm - d = 1.0_dp / d - y = c * d - g = g * y - n = n + 1 - if(abs(y - 1.0_dp) < ep_machine) exit - end do - g = x ** a * (1.0_${k1}$ - x) ** b * g / (b * beta(a, b)) - g = 1.0_${k1}$ - g - endif - res = g - end function inbeta_${t1[0]}$${k1}$ - - #:endfor + do + if(mod(n, 2) == 0) then + k = n / 2; ak = b + 2 * k + an = k * (1.0_dp - x) * (a - k) + else + k = (n - 1) / 2; ak = b + k; ak2 = ak + k + an = - ak * (1.0_dp - x) * (a + ak) / (ak2 * ak2 + ak2) + endif + d = d * an + bn + if(d == 0.0_dp) d = dm + c = bn + an / c + if(c == 0.0_dp) c = dm + d = 1.0_dp / d + y = c * d + g = g * y + n = n + 1 + if(abs(y - 1.0_dp) < ep_machine) exit + end do + g = x ** a * (1.0_${k1}$ - x) ** b * g / (b * beta(a, b)) + g = 1.0_${k1}$ - g + endif + res = g + end function inbeta_${t1[0]}$${k1}$ + + #:endfor end module stdlib_stats_distribution_special From c95d32a74fbfcc52b0cd4cee0e722b6506e783cc Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 17:51:38 -0500 Subject: [PATCH 14/42] kind match --- src/stdlib_stats_distribution_special.fypp | 169 +++++++++++---------- 1 file changed, 92 insertions(+), 77 deletions(-) diff --git a/src/stdlib_stats_distribution_special.fypp b/src/stdlib_stats_distribution_special.fypp index 659d4663a..d26bc74b7 100644 --- a/src/stdlib_stats_distribution_special.fypp +++ b/src/stdlib_stats_distribution_special.fypp @@ -24,18 +24,18 @@ Module stdlib_stats_distribution_special ! for stdlib_distribution internal use - public :: log_gamma, log_factorial + public :: loggamma, log_factorial public :: ingamma_low, log_ingamma_low, ingamma_up, log_ingamma_up public :: regamma_p, regamma_q public :: beta, log_beta, inbeta - interface log_gamma + interface loggamma ! Logrithm of gamma function with real variable ! #:for k1, t1 in REAL_KINDS_TYPES module procedure l_gamma_${t1[0]}$${k1}$ #:endfor - end interface log_gamma + end interface loggamma interface log_factorial ! Logrithm of factorial n!, integer variable @@ -173,15 +173,15 @@ Module stdlib_stats_distribution_special real(qp) :: q, sum integer :: i - if(x <= 0) call error_stop("Error: Gamma function augument must be" & - //" greater than 0") + if(x <= 0._${k1}$) call error_stop("Error: Gamma function augument" & + //" must be greater than 0") if(x == 1.0_${k1}$ .or. x == 2.0_${k1}$) then res = 0.0_${k1}$ else - q = x - HALF + q = real(x, qp) - HALF sum = D(0) do i=1, 10 - sum = sum + D(i) / (x - 1.0_qp + i) + sum = sum + D(i) / (real(x, qp) - 1.0_qp + real(i, qp)) end do res = real(sqep + log(sum) - q + q * log(q + R), kind=${k1}$) endif @@ -205,7 +205,7 @@ Module stdlib_stats_distribution_special case (1) res = 0.0 case (2:) - res = log_gamma(real(n+1)) + res = loggamma(real(n+1, dp)) end select return end function l_factorial_1_${t1[0]}$${k1}$ @@ -229,7 +229,7 @@ Module stdlib_stats_distribution_special case (1) res = 0.0_${k2}$ case (2:) - res = log_gamma(real((n+1), kind=${k2}$)) + res = loggamma(real(n + 1, kind=${k2}$)) end select return end function l_factorial_${t1[0]}$${k1}$${k2}$ @@ -242,35 +242,37 @@ Module stdlib_stats_distribution_special ! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and ! Accurate Evaluation of a Generalized Incomplete Gamma Function", ACM ! Transactions on Mathematical Software, March 2020. + ! + ! Fortran 90 program by Jim-215-Fisher ! ${t1}$, intent(in) :: x, s real(dp) :: res real(dp) :: a, b, g, c, d, y integer :: n - if(x < 0) then + if(x < 0._${k1}$) then call error_stop("Error: Incomplete gamma function with negative x" & //" must come with integer of s") elseif(s >= x) then - a = s - g = 1.0_${k1}$ / a + a = real(s, dp) + g = 1.0_dp / a c = g do - a = a + 1.0_${k1}$ - c = c * x / a + a = a + 1.0_dp + c = c * real(x, dp) / a g = g + c if(abs(c) < ep_machine) exit end do else a = 1.0_dp - b = real(x + 1 - s, kind=dp) + b = real(x + 1 - s, dp) g = a / b c = a / dm d = 1.0_dp / b n = 2 do - a = -(n - 1) * (n - s - 1) - b = x + 2 * n - 1.0_dp - s + a = -(n - 1) * real((n - 1 - s), dp) + b = real(x - s, dp) + 2 * n - 1.0_dp d = d * a + b if(d == 0.0_dp) d = dm c = b + a / c @@ -303,33 +305,33 @@ Module stdlib_stats_distribution_special real(dp) :: a, b, g, c, d, y integer :: n - if(x < -9) then + if(x < -9._${k2}$) then p_lim = 5.0_${k2}$ * (sqrt(abs(x)) - 1.0_${k2}$) - elseif(x >= -9 .and. x <= 0) then + elseif(x >= -9.0_${k2}$ .and. x <= 0.0_${k2}$) then p_lim = 0.0_${k2}$ else p_lim = x endif - if(s >= p_lim) then - a = s - g = 1.0_${k2}$ / a + if(real(s, ${k2}$) >= p_lim) then + a = real(s, dp) + g = 1.0_dp / a c = g do - a = a + 1.0_${k2}$ + a = a + 1.0_dp c = c * x / a g = g + c if(abs(c) < ep_machine) exit end do elseif(x >= 0.0_${k2}$) then a = 1.0_dp - b = real(x + 1 - s, kind=dp) + b = real(x, dp) + (1 - s) g = a / b c = a / dm d = 1.0_dp / b n = 2 do - a = -(n - 1) * (n - s - 1) - b = x + 2 * n - 1.0_dp - s + a = -(n - 1) * real((n - s - 1), dp) + b = real(x - s, dp) + 2 * n - 1.0_dp d = d * a + b if(d == 0.0_dp) d = dm c = b + a / c @@ -340,22 +342,23 @@ Module stdlib_stats_distribution_special n = n + 1 if(abs(y - 1.0_dp) < ep_machine) exit end do - elseif(abs(x) > max(1, s - 1)) then - a = -x + elseif(abs(x) > real(max(1_${k1}$, s - 1), ${k2}$)) then + a = real(-x, dp) c = 1.0_dp / a - d = real(s - 1, kind=dp) + d = real(s - 1, dp) b = c * (a - d) n = 1 do - c = d * (d - 1) / (a * a) - d = d - 2 + c = d * (d - 1.0_dp) / (a * a) + d = d - 2.0_dp y = c * ( a - d) b = b + y n = n + 1 - if(n > (s - 2) / 2 .or. y < b * ep_machine) exit + if(int(n, ${k1}$) > (s - 2) / 2 .or. y < b * ep_machine) exit end do - if(y >= b * ep_machine .and. mod(s, 2) /= 0) b = b + d * c / a - g = ((-1) ** s * exp(-a + log_gamma(real(s, kind=dp)) - (s - 1) * & + if(y >= b * ep_machine .and. mod(s, 2_${k1}$) /= 0_${k1}$) & + b = b + d * c / a + g = ((-1) ** s * exp(-a + loggamma(real(s, dp)) - (s - 1) * & log(a)) + b ) / a endif res = g @@ -375,21 +378,27 @@ Module stdlib_stats_distribution_special ${t1}$, intent(in) :: s ${t2}$, intent(in) :: x ${t2}$ :: res - real(dp) :: s1, y - - if(s < 0) call error_stop("Error: Lower incomplete gamma function" & - //" input s value must be greater than 0") - if(x == 0.0_dp) then - res = real(0.0, kind=${k2}$) - elseif(x > 0.0_dp .and. x <= s) then - s1 = -x + s * log(x) + real(dp) :: s1, y, xx, ss + + #:if t1[0] == "i" + if(s < 0_${k1}$) call error_stop("Error: Lower incomplete gamma" & + //" function input s value must be greater than 0") + #:else + if(s < 0._${k1}$) call error_stop("Error: Lower incomplete gamma" & + //" function input s value must be greater than 0") + #:endif + xx = real(x, dp); ss = real(s, dp) + if(x == 0.0_${k2}$) then + res = 0.0_${k2}$ + elseif(x > 0.0_${k2}$ .and. x <= real(s, ${k2}$)) then + s1 = -xx + ss * log(xx) res = real(gpx(s,x) * exp(s1), kind=${k2}$) - elseif(x > s) then - s1 = log_gamma(real(s, kind=dp)) - y = 1.0_dp - exp(-x + s * log(x) - s1) * gpx(s,x) + elseif(x > real(s, ${k2}$)) then + s1 = loggamma(ss) + y = 1.0_dp - exp(-xx + ss * log(xx) - s1) * gpx(s,x) res = real(y * exp(s1), kind=${k2}$) else - s1 = -x + s * log(-x) + s1 = -xx + ss * log(-xx) res = real((-1)**s * gpx(s,x) * exp(s1), kind=${k2}$) endif return @@ -425,7 +434,7 @@ Module stdlib_stats_distribution_special ${t2}$, intent(in) :: x ${t2}$ :: res - res = exp(log_gamma(real(s, kind=${k2}$))) - ingamma_low(s,x) + res = exp(loggamma(real(s, kind=${k2}$))) - ingamma_low(s,x) return end function ingamma_up_${t1[0]}$${k1}$${k2}$ @@ -458,16 +467,22 @@ Module stdlib_stats_distribution_special ${t1}$, intent(in) :: s ${t2}$, intent(in) :: x ${t2}$ :: res - real(dp) :: s1 - - if(s < 0) call error_stop("Error: Regularized incomplete gamma" & - //" function P input s value must be greater than 0") - s1 = -x + s * log(abs(x)) - log_gamma(real(s, kind=${k2}$)) - if(x == 0.0_dp) then - res = real(0.0, kind=${k2}$) - elseif(x > 0.0_dp .and. x <= s) then + real(dp) :: s1, xx, ss + + #:if t1[0] == "i" + if(s < 0_${k1}$) call error_stop("Error: Lower incomplete gamma" & + //" function input s value must be greater than 0") + #:else + if(s < 0._${k1}$) call error_stop("Error: Lower incomplete gamma" & + //" function input s value must be greater than 0") + #:endif + xx = real(x, dp); ss = real(s, dp) + s1 = -xx + ss * log(abs(xx)) - loggamma(ss) + if(x == 0.0_${k2}$) then + res = 0.0_${k2}$ + elseif(x > 0.0_${k2}$ .and. x <= real(s, ${k2}$)) then res = real(gpx(s,x) * exp(s1), kind=${k2}$) - elseif(x > s) then + elseif(x > real(s, ${k2}$)) then res = 1.0_dp - exp(s1) * gpx(s,x) else res = real((-1)**s * gpx(s,x) * exp(s1), kind=${k2}$) @@ -490,7 +505,7 @@ Module stdlib_stats_distribution_special ${t2}$, intent(in) :: x ${t2}$ :: res - res = real(1.0_dp - regamma_p_${t1[0]}$${k1}$${k2}$(s,x), kind=${k2}$) + res = real(1.0_dp - regamma_p(s,x), kind=${k2}$) return end function regamma_q_${t1[0]}$${k1}$${k2}$ @@ -505,9 +520,9 @@ Module stdlib_stats_distribution_special ${t1}$, intent(in) :: a, b ${t1}$ :: res - if(a <= 0 .or. b <= 0) call error_stop("Error: Beta function auguments"& - //" a, b values must be greater than 0") - res = exp(log_gamma(a) + log_gamma(b) - log_gamma(a+b)) + if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error: Beta" & + //" function auguments a, b values must be greater than 0") + res = exp(loggamma(a) + loggamma(b) - loggamma(a+b)) return end function beta_${t1[0]}$${k1}$ @@ -520,9 +535,9 @@ Module stdlib_stats_distribution_special ${t1}$, intent(in) :: a, b ${t1}$ :: res - if(a <= 0 .or. b <= 0) call error_stop("Error: Logrithm of Beta" & - //" function auguments a, b values must be greater than 0") - res = log_gamma(a) + log_gamma(b) - log_gamma(a+b) + if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error: Beta" & + //" function auguments a, b values must be greater than 0") + res = loggamma(a) + loggamma(b) - loggamma(a+b) return end function l_beta_${t1[0]}$${k1}$ @@ -535,27 +550,27 @@ Module stdlib_stats_distribution_special ! ${t1}$, intent(in) :: x, a, b ${t1}$ :: res - real :: s0, ak, ak2 integer :: n, k - real(dp) :: an, bn, g, c, d, y + real(dp) :: an, bn, g, c, d, y, s0, ak, ak2 - if(a <= 0 .or. b <= 0) call error_stop("Error: Incomplete beta" & - //" function auguments a, b values must be greater than 0") + if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error:" & + //" Incomplete beta function auguments a, b values must be" & + //" greater than 0") s0 = (a + 1) / (a + b + 2) an = 1.0_dp bn = 1.0_dp - g = a / b - c = a / dm - d = 1.0_dp / b + g = an / bn + c = an / dm + d = 1.0_dp / bn n = 1 - if(x < s0) then + if(x < real(s0, ${k1}$)) then do if(mod(n, 2) == 0) then - k = n / 2; ak = a + 2 * k - an = k * x * (b - k) / (ak * ak - ak) + k = n / 2; ak = real(a + 2 * k, dp) + an = k * real(x, dp) * (b - k) / (ak * ak - ak) else - k = (n - 1) / 2; ak = a + k; ak2 = ak + k - an = - (ak + b) * ak * x / (ak2 * ak2 + ak2) + k = (n - 1) / 2; ak = real(a + k, dp); ak2 = ak + k + an = - (ak + b) * ak * real(x, dp) / (ak2 * ak2 + ak2) endif d = d * an + bn if(d == 0.0_dp) d = dm @@ -571,8 +586,8 @@ Module stdlib_stats_distribution_special else do if(mod(n, 2) == 0) then - k = n / 2; ak = b + 2 * k - an = k * (1.0_dp - x) * (a - k) + k = n / 2; ak = real(b + 2 * k, dp) + an = k * (1.0_dp - x) * (a - k) / (ak * ak - ak) else k = (n - 1) / 2; ak = b + k; ak2 = ak + k an = - ak * (1.0_dp - x) * (a + ak) / (ak2 * ak2 + ak2) From 23844a2b9b10e7262cc91885577564826872d6a4 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 18:08:33 -0500 Subject: [PATCH 15/42] ch. log_gamma to loggamma --- src/stdlib_stats_distribution_gamma.fypp | 5 ++--- src/stdlib_stats_distribution_special.fypp | 5 +++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/stdlib_stats_distribution_gamma.fypp b/src/stdlib_stats_distribution_gamma.fypp index f6d0a516b..b809bd763 100644 --- a/src/stdlib_stats_distribution_gamma.fypp +++ b/src/stdlib_stats_distribution_gamma.fypp @@ -3,10 +3,9 @@ Module stdlib_stats_distribution_gamma use stdlib_kinds use stdlib_error, only : error_stop - use stdlib_stats_distribution_PRNG, only : dist_rand use stdlib_stats_distribution_uniform, only : uni=>uniform_distribution_rvs use stdlib_stats_distribution_normal, only : rnor=>normal_distribution_rvs - use stdlib_stats_distribution_special, only : ingamma=>ingamma_low, log_gamma + use stdlib_stats_distribution_special, only : ingamma=>ingamma_low, loggamma implicit none private @@ -266,7 +265,7 @@ Module stdlib_stats_distribution_gamma endif else res = exp((shape - 1._${k1}$) * log(x) - x * rate + shape * & - log(rate) - log_gamma(shape)) + log(rate) - loggamma(shape)) endif return end function gamma_dist_pdf_${t1[0]}$${k1}$ diff --git a/src/stdlib_stats_distribution_special.fypp b/src/stdlib_stats_distribution_special.fypp index d26bc74b7..a6fa3b32b 100644 --- a/src/stdlib_stats_distribution_special.fypp +++ b/src/stdlib_stats_distribution_special.fypp @@ -342,7 +342,7 @@ Module stdlib_stats_distribution_special n = n + 1 if(abs(y - 1.0_dp) < ep_machine) exit end do - elseif(abs(x) > real(max(1_${k1}$, s - 1), ${k2}$)) then + elseif(abs(x) > real(max(1_${k1}$, s - 1_${k1}$), ${k2}$)) then a = real(-x, dp) c = 1.0_dp / a d = real(s - 1, dp) @@ -354,7 +354,8 @@ Module stdlib_stats_distribution_special y = c * ( a - d) b = b + y n = n + 1 - if(int(n, ${k1}$) > (s - 2) / 2 .or. y < b * ep_machine) exit + if(int(n, ${k1}$) > (s - 2_${k1}$) / 2_${k1}$ .or. y < b * & + ep_machine) exit end do if(y >= b * ep_machine .and. mod(s, 2_${k1}$) /= 0_${k1}$) & b = b + d * c / a From 2dc28890f530412840e7248fe05e95523e839178 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 18:14:38 -0500 Subject: [PATCH 16/42] remove tab --- src/stdlib_stats_distribution_special.fypp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stdlib_stats_distribution_special.fypp b/src/stdlib_stats_distribution_special.fypp index a6fa3b32b..ca1992f9e 100644 --- a/src/stdlib_stats_distribution_special.fypp +++ b/src/stdlib_stats_distribution_special.fypp @@ -355,7 +355,7 @@ Module stdlib_stats_distribution_special b = b + y n = n + 1 if(int(n, ${k1}$) > (s - 2_${k1}$) / 2_${k1}$ .or. y < b * & - ep_machine) exit + ep_machine) exit end do if(y >= b * ep_machine .and. mod(s, 2_${k1}$) /= 0_${k1}$) & b = b + d * c / a From 6a0cdcaa25585d0d03f820e62cafec0e2fc4c3ff Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 22 Dec 2020 19:40:38 -0500 Subject: [PATCH 17/42] Update Makefile.manual --- src/Makefile.manual | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Makefile.manual b/src/Makefile.manual index 82d326113..557eb9834 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -80,17 +80,17 @@ stdlib_stats_distribution_uniform.o: \ stdlib_stats_distribution_normal.o: \ stdlib_kinds.o \ stdlib_error.o \ - stdlib_stats_distribution.PRNG.o \ - stdlib_stats_distribution.uniform.o + stdlib_stats_distribution_PRNG.o \ + stdlib_stats_distribution_uniform.o stdlib_stats_distribution_special.o: \ stdlib_kinds.o \ stdlib_error.o stdlib_stats_distribution_gamma.o: \ stdlib_kinds.o \ stdlib_error.o \ - stdlib_stats_distribution.uniform.o \ - stdlib_stats_distribution.normal.o \ - stdlib_stats_distribution.special.o + stdlib_stats_distribution_uniform.o \ + stdlib_stats_distribution_normal.o \ + stdlib_stats_distribution_special.o # Fortran sources that are built from fypp templates stdlib_bitsets_64.f90: stdlib_bitsets_64.fypp From 53a2ee79620b75d20b9ef9791bca328aaf89fd5a Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Mon, 28 Dec 2020 11:14:17 -0500 Subject: [PATCH 18/42] Update stdlib_stats_distribution_gamma.md --- doc/specs/stdlib_stats_distribution_gamma.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/specs/stdlib_stats_distribution_gamma.md b/doc/specs/stdlib_stats_distribution_gamma.md index f638762e1..14041d1dc 100644 --- a/doc/specs/stdlib_stats_distribution_gamma.md +++ b/doc/specs/stdlib_stats_distribution_gamma.md @@ -119,7 +119,7 @@ The result is a scalar or an array, with a shape conformable to auguments, of ty ```fortran program demo_gamma_pdf - use stdlib_stats_distribution_PRNG, onyl : random_seed + use stdlib_stats_distribution_PRNG, only : random_seed use stdlib_stats_distribution_gamma, only: rgamma => gamma_distribution_rvs,& gamma_pdf => gamma_distribution_pdf @@ -191,7 +191,7 @@ The result is a scalar of type `real` with a shape conformable to auguments. ```fortran program demo_gamma_cdf - use stdlib_stats_distribution_PRNG, onyl : random_seed + use stdlib_stats_distribution_PRNG, only : random_seed use stdlib_stats_distribution_gamma, only: rgamma => gamma_distribution_rvs,& gamma_cdf => gamma_distribution_cdf From bf35c1acba98663c5ab27944b61776f351ad0d63 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 29 Dec 2020 15:09:59 -0500 Subject: [PATCH 19/42] Update stdlib_stats_distribution_gamma.md --- doc/specs/stdlib_stats_distribution_gamma.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_stats_distribution_gamma.md b/doc/specs/stdlib_stats_distribution_gamma.md index 14041d1dc..b9bc30fd1 100644 --- a/doc/specs/stdlib_stats_distribution_gamma.md +++ b/doc/specs/stdlib_stats_distribution_gamma.md @@ -61,7 +61,7 @@ program demo_gamma_rvs g(:,:,:) = 0.5 print *, rgamma(g) - !a rank 3 array of 60 standard gamma random variates with rate=0.5 + !a rank 3 array of 24 standard gamma random variates with rate=0.5 ! [1.03841162, 1.33044529, 0.912742674, 0.131288037, 0.638593793, ! 1.03565669E-02, 0.624804378, 1.12179172, 4.91380468E-02, 6.69969944E-03, From 53382a32d2d22c3d48a0676865a93dfd5922b356 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 29 Dec 2020 15:46:43 -0500 Subject: [PATCH 20/42] Update stdlib_stats_distribution_gamma.md --- doc/specs/stdlib_stats_distribution_gamma.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/specs/stdlib_stats_distribution_gamma.md b/doc/specs/stdlib_stats_distribution_gamma.md index b9bc30fd1..9aab8235f 100644 --- a/doc/specs/stdlib_stats_distribution_gamma.md +++ b/doc/specs/stdlib_stats_distribution_gamma.md @@ -97,6 +97,8 @@ The probability density function of the continuous gamma distribution. $$ f(x)= \frac{scale^{shape}}{\Gamma (shape)}x^{shape-1}e^{-scale \times x} , for \;\; x>0, shape, scale>0$$ +x is supported in (0, \infty) + ### Syntax `result = [[stdlib_stats_distribution_gamma(module):gamma_distribution_pdf(interface)]](x, shape, rate)` @@ -169,6 +171,8 @@ Cumulative distribution function of the gamma continuous distribution $$ F(x)= \frac{\gamma (shape, scale \times x)}{\Gamma (shape)}, for \;\; x>0, shape, scale>0} $$ +x is supported in (0, \infty) + ### Syntax `result = [[stdlib_stats_distribution_gamma(module):gamma_distribution_cdf(interface)]](x, shape, rate)` From 16491e19ae4c61a000baa37e6288a4aaea34a749 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 29 Dec 2020 16:45:12 -0500 Subject: [PATCH 21/42] Update stdlib_stats_distribution_gamma.md --- doc/specs/stdlib_stats_distribution_gamma.md | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/doc/specs/stdlib_stats_distribution_gamma.md b/doc/specs/stdlib_stats_distribution_gamma.md index 9aab8235f..d06bda1e6 100644 --- a/doc/specs/stdlib_stats_distribution_gamma.md +++ b/doc/specs/stdlib_stats_distribution_gamma.md @@ -17,7 +17,11 @@ Experimental With one augument for shape parameter, the function returns a standard gamma distributed random variate \(\gamma\)(shape) with `rate = 1.0`. The function is elemental. For complex auguments, the real and imaginary parts are independent of each other. -With two auguments, the function return a scalar gamma distributed random variate \(\gamma\)(shape, rate). +With two auguments, the function returns a scalar gamma distributed random variate \(\gamma\)(shape, rate) and is elemental. + +With three auguments, the function returns a rank one array of gamma distribution random variates. + +The parameters shape and rate must be greater than 0. ### Syntax From 73db71a15a72581776f85e4536e73445c991e4bb Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 29 Dec 2020 17:02:41 -0500 Subject: [PATCH 22/42] Update stdlib_stats_distribution_gamma.md --- doc/specs/stdlib_stats_distribution_gamma.md | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/specs/stdlib_stats_distribution_gamma.md b/doc/specs/stdlib_stats_distribution_gamma.md index d06bda1e6..9f7fce04c 100644 --- a/doc/specs/stdlib_stats_distribution_gamma.md +++ b/doc/specs/stdlib_stats_distribution_gamma.md @@ -35,6 +35,8 @@ The parameters shape and rate must be greater than 0. `array_size`: optional argument has `intent(in)` and is a scalar of type `integer`. +`shape` and `rate` must be the same type. + ### Return value The result is a scalar or rank one array, with a size of `array_size`, of type `real` or `complx`. @@ -111,7 +113,7 @@ x is supported in (0, \infty) `x`: has `intent(in)` and is a scalar of type `real` or `complx`. -`shape` has `intent(in)` and is a scalar of type real` or `complx`. +`shape` has `intent(in)` and is a scalar of type `real` or `complx`. `rate`: has `intent(in)` and is a scalar of type `real` or `complx`. From 2f529994b6f0dca41529bdc95375a9542db434f1 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 29 Dec 2020 17:44:32 -0500 Subject: [PATCH 23/42] Update Makefile.manual --- src/Makefile.manual | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Makefile.manual b/src/Makefile.manual index 557eb9834..ffa4d0998 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -14,7 +14,9 @@ SRC = f18estop.f90 \ stdlib_quadrature_trapz.f90 \ stdlib_stats.f90 \ stdlib_stats_mean.f90 \ - stdlib_stats_moment.f90 \ + stdlib_stats_moment_all.f90 \ + stdlib_stats_moment_mask.f90 \ + stdlib_stats_moment_scalar.f90 \ stdlib_stats_var.f90 \ stdlib_stats_distribution_PRNG.f90 \ stdlib_stats_distribution_uniform.f90 \ From f023b39b24e60643147da027f65057f2ea7f056a Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Tue, 29 Dec 2020 17:48:35 -0500 Subject: [PATCH 24/42] Update Makefile.manual --- src/Makefile.manual | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Makefile.manual b/src/Makefile.manual index ffa4d0998..0840ceac0 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -14,6 +14,7 @@ SRC = f18estop.f90 \ stdlib_quadrature_trapz.f90 \ stdlib_stats.f90 \ stdlib_stats_mean.f90 \ + stdlib_stats_moment.f90 \ stdlib_stats_moment_all.f90 \ stdlib_stats_moment_mask.f90 \ stdlib_stats_moment_scalar.f90 \ From b4c73f6d47a3c25913c4406e53e5c5c5aa9bbc44 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 31 Dec 2020 18:42:34 -0500 Subject: [PATCH 25/42] Update CMakeLists.txt --- src/CMakeLists.txt | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index d128b83a0..f17389d56 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -18,11 +18,7 @@ set(fppFiles stdlib_quadrature.fypp stdlib_quadrature_trapz.fypp stdlib_quadrature_simps.fypp - stdlib_stats_distribution_PRNG.fypp - stdlib_stats_distribution_uniform.fypp - stdlib_stats_distribution_normal.fypp - stdlib_stats_distribution_special.fypp - stdlib_stats_distribution_gamma.fypp + ) From 947c2f179e63a0b22c772bdab7e894f85a8a97be Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 31 Dec 2020 18:43:34 -0500 Subject: [PATCH 26/42] Update Makefile.manual --- src/Makefile.manual | 33 ++------------------------------- 1 file changed, 2 insertions(+), 31 deletions(-) diff --git a/src/Makefile.manual b/src/Makefile.manual index 0840ceac0..96a27c94f 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -18,13 +18,8 @@ SRC = f18estop.f90 \ stdlib_stats_moment_all.f90 \ stdlib_stats_moment_mask.f90 \ stdlib_stats_moment_scalar.f90 \ - stdlib_stats_var.f90 \ - stdlib_stats_distribution_PRNG.f90 \ - stdlib_stats_distribution_uniform.f90 \ - stdlib_stats_distribution_normal.f90 \ - stdlib_stats_distribution_special.f90 \ - stdlib_stats_distribution_gamma.f90 - + stdlib_stats_var.f90 + LIB = libstdlib.a @@ -75,25 +70,6 @@ stdlib_stats_var.o: \ stdlib_optval.o \ stdlib_kinds.o \ stdlib_stats.o -stdlib_stats_distribution_PRNG.o: stdlib_kinds.o -stdlib_stats_distribution_uniform.o: \ - stdlib_kinds.o \ - stdlib_error.o \ - stdlib_stats_distribution_PRNG.o -stdlib_stats_distribution_normal.o: \ - stdlib_kinds.o \ - stdlib_error.o \ - stdlib_stats_distribution_PRNG.o \ - stdlib_stats_distribution_uniform.o -stdlib_stats_distribution_special.o: \ - stdlib_kinds.o \ - stdlib_error.o -stdlib_stats_distribution_gamma.o: \ - stdlib_kinds.o \ - stdlib_error.o \ - stdlib_stats_distribution_uniform.o \ - stdlib_stats_distribution_normal.o \ - stdlib_stats_distribution_special.o # Fortran sources that are built from fypp templates stdlib_bitsets_64.f90: stdlib_bitsets_64.fypp @@ -107,8 +83,3 @@ stdlib_stats.f90: stdlib_stats.fypp stdlib_stats_mean.f90: stdlib_stats_mean.fypp stdlib_stats_moment.f90: stdlib_stats_moment.fypp stdlib_stats_var.f90: stdlib_stats_var.fypp -stdlib_stats_distribution_PRNG.f90: stdlib_stats_distribution_PRNG.fypp -stdlib_stats_distribution_uniform.f90: stdlib_stats_distribution_uniform.fypp -stdlib_stats_distribution_normal.f90: stdlib_stats_distribution_normal.fypp -stdlib_stats_distribution_special.f90: stdlib_stats_distribution_special.fypp -stdlib_stats_distribution_gamma.f90: stdlib_stats_distribution_gamma.fypp From 37bbf4baa996e4962a822655833c3701583d3512 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 31 Dec 2020 18:52:06 -0500 Subject: [PATCH 27/42] Update Makefile.manual --- src/Makefile.manual | 33 +++++++++++++++++++++++++++++++-- 1 file changed, 31 insertions(+), 2 deletions(-) diff --git a/src/Makefile.manual b/src/Makefile.manual index 242158c4a..a15c6cc3c 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -18,7 +18,12 @@ SRC = f18estop.f90 \ stdlib_stats_moment_all.f90 \ stdlib_stats_moment_mask.f90 \ stdlib_stats_moment_scalar.f90 \ - stdlib_stats_var.f90 + stdlib_stats_var.f90 \ + stdlib_stats_distribution_PRNG.f90 \ + stdlib_stats_distribution_uniform.f90 \ + stdlib_stats_distribution_normal.f90 \ + stdlib_stats_distribution_special.f90 \ + stdlib_stats_distribution_gamma.f90 LIB = libstdlib.a @@ -70,7 +75,26 @@ stdlib_stats_var.o: \ stdlib_optval.o \ stdlib_kinds.o \ stdlib_stats.o - +stdlib_stats_distribution_PRNG.o: stdlib_kinds.o +stdlib_stats_distribution_uniform.o: \ + stdlib_kinds.o \ + stdlib_error.o \ + stdlib_stats_distribution_PRNG.o +stdlib_stats_distribution_normal.o: \ + stdlib_kinds.o \ + stdlib_error.o \ + stdlib_stats_distribution_PRNG.o \ + stdlib_stats_distribution_uniform.o +stdlib_stats_distribution_special.o: \ + stdlib_kinds.o \ + stdlib_error.o +stdlib_stats_distribution_gamma.o: \ + stdlib_kinds.o \ + stdlib_error.o \ + stdlib_stats_distribution_uniform.o \ + stdlib_stats_distribution_normal.o \ + stdlib_stats_distribution_special.o + # Fortran sources that are built from fypp templates stdlib_bitsets_64.f90: stdlib_bitsets_64.fypp stdlib_bitsets_large.f90: stdlib_bitsets_large.fypp @@ -86,3 +110,8 @@ stdlib_stats_moment_all.f90: stdlib_stats_moment_all.fypp stdlib_stats_moment_mask.f90: stdlib_stats_moment_mask.fypp stdlib_stats_moment_scalar.f90: stdlib_stats_moment_scalar.fypp stdlib_stats_var.f90: stdlib_stats_var.fypp +stdlib_stats_distribution_PRNG.f90: stdlib_stats_distribution_PRNG.fypp +stdlib_stats_distribution_uniform.f90: stdlib_stats_distribution_uniform.fypp +stdlib_stats_distribution_normal.f90: stdlib_stats_distribution_normal.fypp +stdlib_stats_distribution_special.f90: stdlib_stats_distribution_special.fypp +stdlib_stats_distribution_gamma.f90: stdlib_stats_distribution_gamma.fypp From 6d109290a920bddbf9126446eca043113cfa8653 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 31 Dec 2020 18:53:27 -0500 Subject: [PATCH 28/42] Update CMakeLists.txt --- src/CMakeLists.txt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 1704e12ab..35eb09b5f 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -21,6 +21,11 @@ set(fppFiles stdlib_quadrature.fypp stdlib_quadrature_trapz.fypp stdlib_quadrature_simps.fypp + stdlib_stats_distribution_PRNG.fypp + stdlib_stats_distribution_uniform.fypp + stdlib_stats_distribution_normal.fypp + stdlib_stats_distribution_special.fypp + stdlib_stats_distribution_gamma.fypp ) From 1cb36d35e38b5c0274b7057a2e00b23b9704713d Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 21 Jan 2021 20:34:04 -0500 Subject: [PATCH 29/42] Update Makefile.manual --- src/Makefile.manual | 119 ++++++++++++++++++++------------------------ 1 file changed, 54 insertions(+), 65 deletions(-) diff --git a/src/Makefile.manual b/src/Makefile.manual index a15c6cc3c..9351a374a 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -1,34 +1,35 @@ +SRCFYPP =\ + stdlib_bitsets_64.fypp \ + stdlib_bitsets_large.fypp \ + stdlib_bitsets.fypp \ + stdlib_io.fypp \ + stdlib_linalg.fypp \ + stdlib_linalg_diag.fypp \ + stdlib_optval.fypp \ + stdlib_quadrature.fypp \ + stdlib_quadrature_trapz.fypp \ + stdlib_quadrature_simps.fypp \ + stdlib_stats.fypp \ + stdlib_stats_corr.fypp \ + stdlib_stats_cov.fypp \ + stdlib_stats_mean.fypp \ + stdlib_stats_moment.fypp \ + stdlib_stats_moment_all.fypp \ + stdlib_stats_moment_mask.fypp \ + stdlib_stats_moment_scalar.fypp \ + stdlib_stats_var.fypp + SRC = f18estop.f90 \ stdlib_ascii.f90 \ - stdlib_bitsets.f90 \ - stdlib_bitsets_64.f90 \ - stdlib_bitsets_large.f90 \ stdlib_error.f90 \ - stdlib_io.f90 \ stdlib_kinds.f90 \ - stdlib_linalg.f90 \ - stdlib_linalg_diag.f90 \ stdlib_logger.f90 \ - stdlib_optval.f90 \ - stdlib_quadrature.f90 \ - stdlib_quadrature_trapz.f90 \ - stdlib_stats.f90 \ - stdlib_stats_mean.f90 \ - stdlib_stats_moment.f90 \ - stdlib_stats_moment_all.f90 \ - stdlib_stats_moment_mask.f90 \ - stdlib_stats_moment_scalar.f90 \ - stdlib_stats_var.f90 \ - stdlib_stats_distribution_PRNG.f90 \ - stdlib_stats_distribution_uniform.f90 \ - stdlib_stats_distribution_normal.f90 \ - stdlib_stats_distribution_special.f90 \ - stdlib_stats_distribution_gamma.f90 + $(SRCGEN) LIB = libstdlib.a - +SRCGEN = $(SRCFYPP:.fypp=.f90) OBJS = $(SRC:.f90=.o) MODS = $(OBJS:.o=.mod) SMODS = $(OBJS:.o=*.smod) @@ -41,12 +42,12 @@ $(LIB): $(OBJS) ar rcs $@ $(OBJS) clean: - $(RM) $(LIB) $(OBJS) $(MODS) $(SMODS) + $(RM) $(LIB) $(OBJS) $(MODS) $(SMODS) $(SRCGEN) %.o: %.f90 $(FC) $(FFLAGS) -c $< -%.f90: %.fypp +$(SRCGEN): %.f90: %.fypp common.fypp fypp $(FYPPFLAGS) $< $@ # Fortran module dependencies @@ -59,10 +60,32 @@ stdlib_io.o: \ stdlib_error.o \ stdlib_optval.o \ stdlib_kinds.o -stdlib_linalg_diag.o: stdlib_kinds.o +stdlib_linalg.o: \ + stdlib_kinds.o +stdlib_linalg_diag.o: \ + stdlib_linalg.o \ + stdlib_kinds.o stdlib_logger.o: stdlib_ascii.o stdlib_optval.o stdlib_optval.o: stdlib_kinds.o stdlib_quadrature.o: stdlib_kinds.o +stdlib_quadrature_simps.o: \ + stdlib_quadrature.o \ + stdlib_error.o \ + stdlib_kinds.o +stdlib_quadrature_trapz.o: \ + stdlib_quadrature.o \ + stdlib_error.o \ + stdlib_kinds.o +stdlib_stats.o: \ + stdlib_kinds.o +stdlib_stats_corr.o: \ + stdlib_optval.o \ + stdlib_kinds.o \ + stdlib_stats.o +stdlib_stats_cov.o: \ + stdlib_optval.o \ + stdlib_kinds.o \ + stdlib_stats.o stdlib_stats_mean.o: \ stdlib_optval.o \ stdlib_kinds.o \ @@ -71,47 +94,13 @@ stdlib_stats_moment.o: \ stdlib_optval.o \ stdlib_kinds.o \ stdlib_stats.o +stdlib_stats_moment_all.o: \ + stdlib_stats_moment.o +stdlib_stats_moment_mask.o: \ + stdlib_stats_moment.o +stdlib_stats_moment_scalar.o: \ + stdlib_stats_moment.o stdlib_stats_var.o: \ stdlib_optval.o \ stdlib_kinds.o \ stdlib_stats.o -stdlib_stats_distribution_PRNG.o: stdlib_kinds.o -stdlib_stats_distribution_uniform.o: \ - stdlib_kinds.o \ - stdlib_error.o \ - stdlib_stats_distribution_PRNG.o -stdlib_stats_distribution_normal.o: \ - stdlib_kinds.o \ - stdlib_error.o \ - stdlib_stats_distribution_PRNG.o \ - stdlib_stats_distribution_uniform.o -stdlib_stats_distribution_special.o: \ - stdlib_kinds.o \ - stdlib_error.o -stdlib_stats_distribution_gamma.o: \ - stdlib_kinds.o \ - stdlib_error.o \ - stdlib_stats_distribution_uniform.o \ - stdlib_stats_distribution_normal.o \ - stdlib_stats_distribution_special.o - -# Fortran sources that are built from fypp templates -stdlib_bitsets_64.f90: stdlib_bitsets_64.fypp -stdlib_bitsets_large.f90: stdlib_bitsets_large.fypp -stdlib_bitsets.f90: stdlib_bitsets.fypp -stdlib_io.f90: stdlib_io.fypp -stdlib_linalg.f90: stdlib_linalg.fypp -stdlib_linalg_diag.f90: stdlib_linalg_diag.fypp -stdlib_quadrature.f90: stdlib_quadrature.fypp -stdlib_stats.f90: stdlib_stats.fypp -stdlib_stats_mean.f90: stdlib_stats_mean.fypp -stdlib_stats_moment.f90: stdlib_stats_moment.fypp -stdlib_stats_moment_all.f90: stdlib_stats_moment_all.fypp -stdlib_stats_moment_mask.f90: stdlib_stats_moment_mask.fypp -stdlib_stats_moment_scalar.f90: stdlib_stats_moment_scalar.fypp -stdlib_stats_var.f90: stdlib_stats_var.fypp -stdlib_stats_distribution_PRNG.f90: stdlib_stats_distribution_PRNG.fypp -stdlib_stats_distribution_uniform.f90: stdlib_stats_distribution_uniform.fypp -stdlib_stats_distribution_normal.f90: stdlib_stats_distribution_normal.fypp -stdlib_stats_distribution_special.f90: stdlib_stats_distribution_special.fypp -stdlib_stats_distribution_gamma.f90: stdlib_stats_distribution_gamma.fypp From 2a6b431be10bf1e516a1e8313358d6d60b207b08 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 21 Jan 2021 20:35:22 -0500 Subject: [PATCH 30/42] Update CMakeLists.txt --- src/CMakeLists.txt | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 35eb09b5f..1704e12ab 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -21,11 +21,6 @@ set(fppFiles stdlib_quadrature.fypp stdlib_quadrature_trapz.fypp stdlib_quadrature_simps.fypp - stdlib_stats_distribution_PRNG.fypp - stdlib_stats_distribution_uniform.fypp - stdlib_stats_distribution_normal.fypp - stdlib_stats_distribution_special.fypp - stdlib_stats_distribution_gamma.fypp ) From 4424811e1340a3e71cc6d86ca81fb52538fa9a3f Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 21 Jan 2021 20:51:32 -0500 Subject: [PATCH 31/42] Update CMakeLists.txt --- src/CMakeLists.txt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 02413b415..0173ebac7 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -21,6 +21,11 @@ set(fppFiles stdlib_quadrature.fypp stdlib_quadrature_trapz.fypp stdlib_quadrature_simps.fypp + stdlib_stats_distribution_PRNG.fypp + stdlib_stats_distribution_uniform.fypp + stdlib_stats_distribution_normal.fypp + stdlib_stats_distribution_special.fypp + stdlib_stats_distribution_gamma.fypp ) From d4e5e869910d90e343a9b8e90e3a4150a9a16c07 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 21 Jan 2021 20:56:01 -0500 Subject: [PATCH 32/42] Update Makefile.manual --- src/Makefile.manual | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/src/Makefile.manual b/src/Makefile.manual index 9351a374a..e4f5a9617 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -17,7 +17,12 @@ SRCFYPP =\ stdlib_stats_moment_all.fypp \ stdlib_stats_moment_mask.fypp \ stdlib_stats_moment_scalar.fypp \ - stdlib_stats_var.fypp + stdlib_stats_var.fypp \ + stdlib_stats_distribution_PRNG.fypp \ + stdlib_stats_distribution_uniform.fypp \ + stdlib_stats_distribution_normal.fypp \ + stdlib_stats_distribution_special.fypp \ + stdlib_stats_distribution_gamma.fypp SRC = f18estop.f90 \ stdlib_ascii.f90 \ @@ -104,3 +109,25 @@ stdlib_stats_var.o: \ stdlib_optval.o \ stdlib_kinds.o \ stdlib_stats.o +stdlib_stats_distribution_PRNG.o: \ + stdlib_kinds.o \ + stdlib_error.o +stdlib_stats_distribution_uniform.o: \ + stdlib_kinds.o \ + stdlib_error.o \ + stdlib_stats_distribution_PRNG.o +stdlib_stats_distribution_normal.o: \ + stdlib_kinds.o \ + stdlib_error.o \ + stdlib_stats_distribution_PRNG.o \ + stdlib_stats_distribution_uniform.o +stdlib_stats_distribution_special.o: \ + stdlib_kinds.o \ + stdlib_error.o +stdlib_stats_distribution_gamma.o: \ + stdlib_kinds.o \ + stdlib_error.o \ + stdlib_stats_distribution_PRNG.o \ + stdlib_stats_distribution_uniform.o \ + stdlib_stats_distribution_normal.o \ + stdlib_stats_distribution_special.o From e5101980b8a9bbcfb7c4ce5afe58f126ffc0c947 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 21 Jan 2021 20:57:21 -0500 Subject: [PATCH 33/42] Add files via upload --- src/stdlib_stats_distribution_PRNG.fypp | 75 ++------------ src/stdlib_stats_distribution_gamma.fypp | 114 +++++++++++---------- src/stdlib_stats_distribution_normal.fypp | 50 ++++----- src/stdlib_stats_distribution_special.fypp | 46 ++++----- src/stdlib_stats_distribution_uniform.fypp | 60 ++++++----- 5 files changed, 149 insertions(+), 196 deletions(-) diff --git a/src/stdlib_stats_distribution_PRNG.fypp b/src/stdlib_stats_distribution_PRNG.fypp index d1bda107a..3fdbf0438 100644 --- a/src/stdlib_stats_distribution_PRNG.fypp +++ b/src/stdlib_stats_distribution_PRNG.fypp @@ -1,16 +1,16 @@ #:include "common.fypp" module stdlib_stats_distribution_PRNG use stdlib_kinds, only: int8, int16, int32, int64 + use stdlib_error implicit none private integer, parameter :: MAX_INT_BIT_SIZE = bit_size(1_int64) - integer(int64), save :: st(4), si = 614872703977525537_int64 + integer(int64), save :: st(4) ! internal states for xoshiro256ss function + integer(int64), save :: si = 614872703977525537_int64 ! default seed value logical, save :: seed_initialized = .false. public :: random_seed public :: dist_rand - public :: jump - public :: long_jump interface dist_rand @@ -51,6 +51,8 @@ module stdlib_stats_distribution_PRNG integer :: k k = MAX_INT_BIT_SIZE - bit_size(n) + if(k < 0) call error_stop("Error(dist_rand): Integer bit size is" & + //" greater than 64bit") res = shiftr(xoshiro256ss( ), k) end function dist_rand_${t1[0]}$${k1}$ @@ -96,71 +98,6 @@ module stdlib_stats_distribution_PRNG end function rol64 - subroutine jump - ! This is the jump function for the xoshiro256ss generator. It is equivalent - ! to 2^128 calls to xoshiro256ss(); it can be used to generate 2^128 - ! non-overlapping subsequences for parallel computations. - ! Written in 2018 by David Blackman and Sebastiano Vigna (vigna@acm.org) - ! http://prng.di.unimi.it/xoshiro256starstar.c - ! - ! Fortran 90 version translated from C by Jim-215-Fisher - integer(int64) :: jp(4) = [1733541517147835066_int64, & - -3051731464161248980_int64, & - -6244198995065845334_int64, & - 4155657270789760540_int64] - integer(int64) :: s1 = 0, s2 = 0, s3 = 0, s4 = 0, c = 1_int64 - integer :: i, j, k - - do i = 1, 4 - do j = 1, 64 - if(iand(jp(i), shiftl(c, j - 1)) /= 0) then - s1 = ieor(s1, st(1)) - s2 = ieor(s2, st(2)) - s3 = ieor(s3, st(3)) - s4 = ieor(s4, st(4)) - end if - k = xoshiro256ss( ) - end do - end do - st(1) = s1 - st(2) = s2 - st(3) = s3 - st(4) = s4 - end subroutine jump - - subroutine long_jump - ! This is the long-jump function for the xoshiro256ss generator. It is - ! equivalent to 2^192 calls to xoshiro256ss(); it can be used to generate - ! 2^64 starting points, from each of which jump() will generate 2^64 - ! non-overlapping subsequences for parallel distributed computations - ! Written in 2018 by David Blackman and Sebastiano Vigna (vigna@acm.org) - ! http://prng.di.unimi.it/xoshiro256starstar.c - ! - ! Fortran 90 version translated from C by Jim-215-Fisher - integer(int64) :: jp(4) = [8566230491382795199_int64, & - -4251311993797857357_int64, & - 8606660816089834049_int64, & - 4111957640723818037_int64] - integer(int64) :: s1 = 0, s2 = 0, s3 = 0, s4 = 0, c = 1_int64 - integer(int32) :: i, j, k - - do i = 1, 4 - do j = 1, 64 - if(iand(jp(i), shiftl(c, j - 1)) /= 0) then - s1 = ieor(s1, st(1)) - s2 = ieor(s2, st(2)) - s3 = ieor(s3, st(3)) - s4 = ieor(s4, st(4)) - end if - k = xoshiro256ss() - end do - end do - st(1) = s1 - st(2) = s2 - st(3) = s3 - st(4) = s4 - end subroutine long_jump - function splitmix64(s) result(res) ! Written in 2015 by Sebastiano Vigna (vigna@acm.org) ! This is a fixed-increment version of Java 8's SplittableRandom @@ -178,6 +115,8 @@ module stdlib_stats_distribution_PRNG data int01, int02, int03/-7046029254386353131_int64, & -4658895280553007687_int64, & -7723592293110705685_int64/ + ! Values are converted from C unsigned integer of 0x9e3779b97f4a7c15, + ! 0xbf58476d1ce4e5b9, 0x94d049bb133111eb if(present(s)) si = s res = si diff --git a/src/stdlib_stats_distribution_gamma.fypp b/src/stdlib_stats_distribution_gamma.fypp index b809bd763..8ef94a8c2 100644 --- a/src/stdlib_stats_distribution_gamma.fypp +++ b/src/stdlib_stats_distribution_gamma.fypp @@ -10,8 +10,6 @@ Module stdlib_stats_distribution_gamma implicit none private integer(int64), parameter :: INT_ONE = 1_int64 - real, parameter :: tol = 1.0E-5, sq = 0.0331 - real, save :: alpha = 0., d, c public :: gamma_distribution_rvs public :: gamma_distribution_pdf @@ -44,7 +42,7 @@ Module stdlib_stats_distribution_gamma !! ([Specification](../page/specs/stdlib_stats_distribution_gamma.html# !! description)) !! - #:for k1, t1 in RC_KINDS_TYPES + #:for k1, t1 in RC_KINDS_TYPES module procedure gamma_dist_pdf_${t1[0]}$${k1}$ #:endfor end interface gamma_distribution_pdf @@ -70,32 +68,34 @@ Module stdlib_stats_distribution_gamma ! ${t1}$, intent(in) :: shape ${t1}$ :: res - ${t1}$ :: x, v, u, zz + ${t1}$ :: x, v, u, zz, tol = 1000 * epsilon(1.0_${k1}$) + ${t1}$, save :: alpha = 0._${k1}$, d, c, sq = 0.0331_${k1}$ + + if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs): Gamma" & + //" distribution shape parameter must be greater than zero") - if(shape <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & - //" shape parameter must be greater than zero") zz = shape if(zz < 1._${k1}$) zz = 1._${k1}$ + zz - if(abs(real(zz) - alpha) > tol) then - alpha = real(zz) - d = alpha - 1. / 3. - c = 1. / (3. * sqrt(d)) + if(abs(zz - alpha) > tol) then + alpha = zz + d = alpha - 1._${k1}$ / 3._${k1}$ + c = 1._${k1}$ / (3._${k1}$ * sqrt(d)) endif do do - x = rnor( ) + x = rnor(0.0_${k1}$, 1.0_${k1}$) v = 1._${k1}$ + c * x v = v * v * v - if(v > 0.) exit + if(v > 0._${k1}$) exit end do x = x * x - u = uni( ) + u = uni(1.0_${k1}$) if(u < (1._${k1}$ - sq * x * x)) exit if(log(u) < 0.5_${k1}$ * x + d * (1._${k1}$ - v + log(v))) exit end do res = d * v - if(shape < 1.) then - u = uni( ) + if(shape < 1._${k1}$) then + u = uni(1.0_${k1}$) res = res * u ** (1._${k1}$ / shape) endif return @@ -114,7 +114,7 @@ Module stdlib_stats_distribution_gamma tr = gamma_dist_rvs_1_r${k1}$(real(shape)) ti = gamma_dist_rvs_1_r${k1}$(aimag(shape)) - res = cmplx(tr,ti) + res = cmplx(tr,ti, kind=${k1}$) return end function gamma_dist_rvs_1_${t1[0]}$${k1}$ @@ -125,34 +125,37 @@ Module stdlib_stats_distribution_gamma result(res) ${t1}$, intent(in) :: shape, rate ${t1}$ :: res - ${t1}$ :: x, v, u, zz + ${t1}$ :: x, v, u, zz, tol = 1000 * epsilon(1.0_${k1}$) + ${t1}$, save :: alpha = 0._${k1}$, d, c, sq = 0.0331_${k1}$ + + if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs): Gamma" & + //" distribution shape parameter must be greater than zero") + + if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs): Gamma" & + //" distribution rate parameter must be greater than zero") - if(shape <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & - //" shape parameter must be greater than zero") - if(rate <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & - //" rate parameter must be greater than zero") zz = shape if(zz < 1._${k1}$) zz = 1._${k1}$ + zz - if(abs(real(zz) - alpha) > tol) then - alpha = real(zz) - d = alpha - 1. / 3. - c = 1. / (3. * sqrt(d)) + if(abs(zz - alpha) > tol) then + alpha = zz + d = alpha - 1._${k1}$ / 3._${k1}$ + c = 1._${k1}$ / (3._${k1}$ * sqrt(d)) endif do do - x = rnor( ) + x = rnor(0.0_${k1}$, 1.0_${k1}$) v = 1._${k1}$ + c * x v = v * v * v - if(v > 0) exit + if(v > 0._${k1}$) exit end do x = x * x - u = uni( ) + u = uni(1.0_${k1}$) if(u < (1._${k1}$ - sq * x * x)) exit if(log(u) < 0.5_${k1}$ * x + d * (1._${k1}$ - v + log(v))) exit end do res = d * v if(shape < 1._${k1}$) then - u = uni( ) + u = uni(1.0_${k1}$) res = res * u ** (1._${k1}$ / shape) endif res = res / rate @@ -173,7 +176,7 @@ Module stdlib_stats_distribution_gamma tr = gamma_dist_rvs_r${k1}$(real(shape), real(rate)) ti = gamma_dist_rvs_r${k1}$(aimag(shape), aimag(rate)) - res = cmplx(tr, ti) + res = cmplx(tr, ti, kind=${k1}$) return end function gamma_dist_rvs_${t1[0]}$${k1}$ @@ -185,37 +188,40 @@ Module stdlib_stats_distribution_gamma ${t1}$, intent(in) :: shape, rate ${t1}$, allocatable :: res(:) integer, intent(in) :: array_size - ${t1}$ :: x, v, u, zz, re + ${t1}$ :: x, v, u, zz, tol = 1000 * epsilon(1.0_${k1}$), re + ${t1}$, save :: alpha = 0._${k1}$, d, c, sq = 0.0331_${k1}$ integer :: i - if(shape <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & - //" shape parameter must be greater than zero") - if(rate <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & - //" rate parameter must be greater than zero") + if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs_array):" & + //" Gamma distribution shape parameter must be greater than zero") + + if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs_array):" & + //' Gamma distribution rate parameter must be greater than zero") + allocate(res(array_size)) zz = shape if(zz < 1._${k1}$) zz = 1._${k1}$ + zz - if(abs(real(zz) - alpha) > tol) then - alpha = real(zz) - d = alpha - 1. / 3. - c = 1. / (3. * sqrt(d)) + if(abs(zz - alpha) > tol) then + alpha = zz + d = alpha - 1._${k1}$ / 3._${k1}$ + c = 1._${k1}$ / (3._${k1}$ * sqrt(d)) endif do i = 1, array_size do do - x = rnor( ) + x = rnor(0.0_${k1}$, 1.0_${k1}$) v = 1._${k1}$ + c * x v = v * v * v - if(v > 0) exit + if(v > 0._${k1}$) exit end do x = x * x - u = uni( ) + u = uni(1.0_${k1}$) if(u < (1._${k1}$ - sq * x * x)) exit if(log(u) < 0.5_${k1}$ * x + d * (1._${k1}$ - v + log(v))) exit end do re = d * v if(shape < 1._${k1}$) then - u = uni( ) + u = uni(1.0_${k1}$) re = re * u ** (1._${k1}$ / shape) endif res(i) = re / rate @@ -238,7 +244,7 @@ Module stdlib_stats_distribution_gamma do i = 1, array_size tr = gamma_dist_rvs_r${k1}$(real(shape), real(rate)) ti = gamma_dist_rvs_r${k1}$(aimag(shape), aimag(rate)) - res(i) = cmplx(tr, ti) + res(i) = cmplx(tr, ti, kind=${k1}$) end do return end function gamma_dist_rvs_array_${t1[0]}$${k1}$ @@ -253,10 +259,12 @@ Module stdlib_stats_distribution_gamma ${t1}$, intent(in) :: x, shape, rate real :: res - if(rate <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & - //" rate parameter must be greaeter than zero") - if(shape <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & - //" shape parameter must be greater than zero") + if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & + //" distribution rate parameter must be greaeter than zero") + if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & + //" distribution shape parameter must be greater than zero") + if(x <= 0.0_${k1}$) call error_stop("Error)gamma_dist_pdf): Gamma" & + //" distribution variate x must be greater than zero") if(x == 0.0_${k1}$) then if(shape <= 1.0_${k1}$) then res = huge(1.0) + 1.0 @@ -293,10 +301,12 @@ Module stdlib_stats_distribution_gamma ${t1}$, intent(in) :: x, shape, rate real :: res - if(rate <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & - //" rate parameter must be greaeter than zero") - if(shape <= 0.0_${k1}$) call error_stop("Error: Gamma distribution" & - //" shape parameter must be greater than zero") + if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & + //" distribution rate parameter must be greaeter than zero") + if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & + //" distribution shape parameter must be greater than zero") + if(x <= 0.0_${k1}$) call error_stop("Error)gamma_dist_pdf): Gamma" & + //" distribution variate x must be greater than zero") res = ingamma(shape, rate * x) / gamma(shape) return end function gamma_dist_cdf_${t1[0]}$${k1}$ diff --git a/src/stdlib_stats_distribution_normal.fypp b/src/stdlib_stats_distribution_normal.fypp index 007007b59..fecef90e8 100644 --- a/src/stdlib_stats_distribution_normal.fypp +++ b/src/stdlib_stats_distribution_normal.fypp @@ -114,7 +114,7 @@ Module stdlib_stats_distribution_normal if( .not. zig_norm_initialized ) call zigset iz = 0 ! original algorithm use 32bit - hz = dist_rand(iz) + hz = dist_rand(1_int32) iz = iand( hz, 127 ) if( abs( hz ) < kn(iz) ) then @@ -123,8 +123,8 @@ Module stdlib_stats_distribution_normal L1: do L2: if( iz == 0 ) then do - x = -log( uni( ) ) * rr - y = -log( uni( ) ) + x = -log( uni(1.0_${k1}$) ) * rr + y = -log( uni(1.0_${k1}$) ) if( y + y >= x * x ) exit end do res = r + x @@ -132,14 +132,14 @@ Module stdlib_stats_distribution_normal exit L1 end if L2 x = hz * wn(iz) - if( fn(iz) + uni( ) * (fn(iz-1) - fn(iz)) < & + if( fn(iz) + uni(1.0_${k1}$) * (fn(iz-1) - fn(iz)) < & exp(-HALF * x * x) ) then res = x exit L1 end if !original algorithm use 32bit - hz = dist_rand(iz) + hz = dist_rand(1_int32) iz = iand( hz, 127 ) if( abs( hz ) < kn(iz) ) then res = hz * wn(iz) @@ -163,12 +163,12 @@ Module stdlib_stats_distribution_normal ${t1}$ :: x, y integer :: hz, iz - if(scale==0._${k1}$) call error_stop("Error: Normal distribution scale" & - //" parameter must be non-zero") + if(scale==0._${k1}$) call error_stop("Error(norm_dist_rvs): Normal" & + //" distribution scale parameter must be non-zero") if( .not. zig_norm_initialized ) call zigset iz = 0 ! original algorithm use 32bit - hz = dist_rand(iz) + hz = dist_rand(1_int32) iz = iand( hz, 127 ) if( abs( hz ) < kn(iz) ) then @@ -177,8 +177,8 @@ Module stdlib_stats_distribution_normal L1: do L2: if( iz == 0 ) then do - x = -log( uni( ) ) * rr - y = -log( uni( ) ) + x = -log( uni(1.0_${k1}$) ) * rr + y = -log( uni(1.0_${k1}$) ) if( y + y >= x * x ) exit end do res = r + x @@ -186,14 +186,14 @@ Module stdlib_stats_distribution_normal exit L1 end if L2 x = hz * wn(iz) - if( fn(iz) + uni( ) * (fn(iz-1) - fn(iz)) < & + if( fn(iz) + uni(1.0_${k1}$) * (fn(iz-1) - fn(iz)) < & exp(-HALF * x * x) ) then res = x exit L1 end if !original algorithm use 32bit - hz = dist_rand(iz) + hz = dist_rand(1_int32) iz = iand( hz, 127 ) if( abs( hz ) < kn(iz) ) then res = hz * wn(iz) @@ -219,7 +219,7 @@ Module stdlib_stats_distribution_normal tr = norm_dist_rvs_r${k1}$(real(loc), real(scale)) ti = norm_dist_rvs_r${k1}$(aimag(loc), aimag(scale)) - res = cmplx(tr, ti) + res = cmplx(tr, ti, kind=${k1}$) return end function norm_dist_rvs_${t1[0]}$${k1}$ @@ -235,14 +235,14 @@ Module stdlib_stats_distribution_normal ${t1}$ :: x, y, re integer :: hz, iz, i - if(scale==0._${k1}$) call error_stop("Error: Normal distribution scale" & - //" parameter must be non-zero") + if(scale==0._${k1}$) call error_stop("Error(norm_dist_rvs_array):" & + //" Normal distribution scale parameter must be non-zero") if( .not. zig_norm_initialized ) call zigset allocate(res(array_size)) do i = 1, array_size iz = 0 ! original algorithm use 32bit - hz = dist_rand(iz) + hz = dist_rand(1_int32) iz = iand( hz, 127 ) if( abs( hz ) < kn(iz) ) then @@ -251,8 +251,8 @@ Module stdlib_stats_distribution_normal L1: do L2: if( iz == 0 ) then do - x = -log( uni( ) ) * rr - y = -log( uni( ) ) + x = -log( uni(1.0_${k1}$) ) * rr + y = -log( uni(1.0_${k1}$) ) if( y + y >= x * x ) exit end do re = r + x @@ -260,14 +260,14 @@ Module stdlib_stats_distribution_normal exit L1 end if L2 x = hz * wn(iz) - if( fn(iz) + uni( ) * (fn(iz-1) - fn(iz)) < & + if( fn(iz) + uni(1.0_${k1}$) * (fn(iz-1) - fn(iz)) < & exp(-HALF * x * x) ) then re = x exit L1 end if !original algorithm use 32bit - hz = dist_rand(iz) + hz = dist_rand(1_int32) iz = iand( hz, 127 ) if( abs( hz ) < kn(iz) ) then re = hz * wn(iz) @@ -295,7 +295,7 @@ Module stdlib_stats_distribution_normal do i = 1, array_size tr = norm_dist_rvs_r${k1}$(real(loc), real(scale)) ti = norm_dist_rvs_r${k1}$(aimag(loc), aimag(scale)) - res(i) = cmplx(tr, ti) + res(i) = cmplx(tr, ti, kind=${k1}$) end do return end function norm_dist_rvs_array_${t1[0]}$${k1}$ @@ -311,8 +311,8 @@ Module stdlib_stats_distribution_normal real :: res ${t1}$, parameter :: sqrt_2_pi = sqrt(2.0_${k1}$ * acos(-1.0_${k1}$)) - if(scale==0._${k1}$) call error_stop("Error: Normal distribution scale" & - //" parameter must be non-zero") + if(scale==0._${k1}$) call error_stop("Error(norm_dist_pdf):" & + //" Normal distribution scale parameter must be non-zero") res = exp(- 0.5_${k1}$ * (x - loc) * (x - loc) / (scale * scale)) / & (sqrt_2_Pi * scale) return @@ -342,8 +342,8 @@ Module stdlib_stats_distribution_normal real :: res ${t1}$, parameter :: sqrt_2 = sqrt(2.0_${k1}$) - if(scale==0._${k1}$) call error_stop("Error: Normal distribution scale" & - //" parameter must be non-zero") + if(scale==0._${k1}$) call error_stop("Error(norm_dist_cdf):" & + //" Normal distribution scale parameter must be non-zero") res = (1.0_${k1}$ + erf((x - loc) / (scale * sqrt_2))) / 2.0_${k1}$ return end function norm_dist_cdf_${t1[0]}$${k1}$ diff --git a/src/stdlib_stats_distribution_special.fypp b/src/stdlib_stats_distribution_special.fypp index ca1992f9e..1c71b0106 100644 --- a/src/stdlib_stats_distribution_special.fypp +++ b/src/stdlib_stats_distribution_special.fypp @@ -173,8 +173,8 @@ Module stdlib_stats_distribution_special real(qp) :: q, sum integer :: i - if(x <= 0._${k1}$) call error_stop("Error: Gamma function augument" & - //" must be greater than 0") + if(x <= 0._${k1}$) call error_stop("Error(l_gamma): Gamma function" & + //" augument must be greater than 0") if(x == 1.0_${k1}$ .or. x == 2.0_${k1}$) then res = 0.0_${k1}$ else @@ -197,8 +197,8 @@ Module stdlib_stats_distribution_special ${t1}$, intent(in) :: n real :: res - if(n < 0) call error_stop("Error: Factorial function augument must" & - //" be no less than 0") + if(n < 0) call error_stop("Error(l_factorial): Factorial function" & + //" augument must be no less than 0") select case(n) case (0) res = 0.0 @@ -221,8 +221,8 @@ Module stdlib_stats_distribution_special ${t2}$, intent(in) :: x ${t2}$ :: res - if(n < 0) call error_stop("Error: factorial function augument must" & - //" be no less than 0") + if(n < 0) call error_stop("Error(l_factorial): Factorial function" & + //" augument must be no less than 0") select case(n) case (0) res = 0.0_${k2}$ @@ -251,8 +251,8 @@ Module stdlib_stats_distribution_special integer :: n if(x < 0._${k1}$) then - call error_stop("Error: Incomplete gamma function with negative x" & - //" must come with integer of s") + call error_stop("Error(gpx): Incomplete gamma function with" & + //" negative x must come with integer of s") elseif(s >= x) then a = real(s, dp) g = 1.0_dp / a @@ -382,11 +382,11 @@ Module stdlib_stats_distribution_special real(dp) :: s1, y, xx, ss #:if t1[0] == "i" - if(s < 0_${k1}$) call error_stop("Error: Lower incomplete gamma" & - //" function input s value must be greater than 0") + if(s < 0_${k1}$) call error_stop("Error(ingamma_low): Lower" & + //" incomplete gamma function input s value must be greater than 0") #:else - if(s < 0._${k1}$) call error_stop("Error: Lower incomplete gamma" & - //" function input s value must be greater than 0") + if(s < 0._${k1}$) call error_stop("Error(ingamma_low): Lower" & + //" incomplete gamma function input s value must be greater than 0") #:endif xx = real(x, dp); ss = real(s, dp) if(x == 0.0_${k2}$) then @@ -471,11 +471,11 @@ Module stdlib_stats_distribution_special real(dp) :: s1, xx, ss #:if t1[0] == "i" - if(s < 0_${k1}$) call error_stop("Error: Lower incomplete gamma" & - //" function input s value must be greater than 0") + if(s < 0_${k1}$) call error_stop("Error(regamma_p): Lower incomplete" & + //" gamma function input s value must be greater than 0") #:else - if(s < 0._${k1}$) call error_stop("Error: Lower incomplete gamma" & - //" function input s value must be greater than 0") + if(s < 0._${k1}$) call error_stop("Error(regamma_p): Lower incomplete" & + //" gamma function input s value must be greater than 0") #:endif xx = real(x, dp); ss = real(s, dp) s1 = -xx + ss * log(abs(xx)) - loggamma(ss) @@ -521,8 +521,8 @@ Module stdlib_stats_distribution_special ${t1}$, intent(in) :: a, b ${t1}$ :: res - if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error: Beta" & - //" function auguments a, b values must be greater than 0") + if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error(beta):" & + //" Beta function auguments a, b values must be greater than 0") res = exp(loggamma(a) + loggamma(b) - loggamma(a+b)) return end function beta_${t1[0]}$${k1}$ @@ -536,8 +536,8 @@ Module stdlib_stats_distribution_special ${t1}$, intent(in) :: a, b ${t1}$ :: res - if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error: Beta" & - //" function auguments a, b values must be greater than 0") + if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error(l_beta):"& + //" Beta function auguments a, b values must be greater than 0") res = loggamma(a) + loggamma(b) - loggamma(a+b) return end function l_beta_${t1[0]}$${k1}$ @@ -554,9 +554,9 @@ Module stdlib_stats_distribution_special integer :: n, k real(dp) :: an, bn, g, c, d, y, s0, ak, ak2 - if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error:" & - //" Incomplete beta function auguments a, b values must be" & - //" greater than 0") + if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error(inbeta):"& + //" Incomplete beta function auguments a, b values must be greater" & + //" than 0") s0 = (a + 1) / (a + b + 2) an = 1.0_dp bn = 1.0_dp diff --git a/src/stdlib_stats_distribution_uniform.fypp b/src/stdlib_stats_distribution_uniform.fypp index 089ab8001..b538144f8 100644 --- a/src/stdlib_stats_distribution_uniform.fypp +++ b/src/stdlib_stats_distribution_uniform.fypp @@ -42,7 +42,8 @@ Module stdlib_stats_distribution_uniform interface uniform_distribution_pdf !! Version experiment !! - !! Get uniform distribution probability density (pdf) for integer, real and complex variables + !! Get uniform distribution probability density (pdf) for integer, real and + !! complex variables !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# !! description)) @@ -54,7 +55,8 @@ Module stdlib_stats_distribution_uniform interface uniform_distribution_cdf !! Version experimental !! - !! Get uniform distribution cumulative distribution function (cdf) for integer, real and complex variables + !! Get uniform distribution cumulative distribution function (cdf) for + !! integer, real and complex variables !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# !! description)) !! @@ -66,7 +68,8 @@ Module stdlib_stats_distribution_uniform interface shuffle !! Version experimental !! - !! Fisher-Yates shuffle algorithm for a rank one array of integer, real and complex variables + !! Fisher-Yates shuffle algorithm for a rank one array of integer, real and + !! complex variables !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# !! description)) !! @@ -85,13 +88,14 @@ Module stdlib_stats_distribution_uniform ! https://www.pcg-random.org/posts/bounded-rands.html ! ! Fortran 90 translated from c by Jim-215-fisher + ! ${t1}$, intent(in) :: scale ${t1}$ :: res, u, mask, n integer :: zeros, bits_left, bits n = scale - if(n <= 0_${k1}$) call error_stop("Error: Uniform distribution scale" & - //" parameter must be positive") + if(n <= 0_${k1}$) call error_stop("Error(unif_dist_rvs_1): Uniform" & + //" distribution scale parameter must be positive") zeros = leadz(n) bits = bit_size(n) - zeros mask = shiftr(not(0_${k1}$), zeros) @@ -121,8 +125,8 @@ Module stdlib_stats_distribution_uniform ${t1}$, intent(in) :: loc, scale ${t1}$ :: res - if(scale == 0_${k1}$) call error_stop("Error: Uniform distribution" & - //" scale parameter must be non-zero") + if(scale <= 0_${k1}$) call error_stop("Error(unif_dist_rvs): Uniform" & + //" distribution scale parameter must be positive") res = loc + unif_dist_rvs_1_${t1[0]}$${k1}$(scale) return end function unif_dist_rvs_${t1[0]}$${k1}$ @@ -134,7 +138,7 @@ Module stdlib_stats_distribution_uniform ! Uniformly distributed float in [0,1] ! Based on the paper by Frederic Goualard, "Generating Random Floating- ! Point Numbers By Dividing Integers: a Case Study", Proceedings of - ! ICCS 2020, June 20202, Amsterdam, Netherlands + ! ICCS 2020, June 2020, Amsterdam, Netherlands ! ${t1}$ :: res integer(int64) :: tmp @@ -153,8 +157,8 @@ Module stdlib_stats_distribution_uniform ${t1}$, intent(in) :: scale ${t1}$ :: res - if(scale == 0._${k1}$) call error_stop("Error: Uniform distribution" & - //" scale parameter must be non-zero") + if(scale == 0._${k1}$) call error_stop("Error(unif_dist_rvs_1): " & + //"Uniform distribution scale parameter must be non-zero") res = scale * unif_dist_rvs_0_${t1[0]}$${k1}$( ) return end function unif_dist_rvs_1_${t1[0]}$${k1}$ @@ -169,8 +173,8 @@ Module stdlib_stats_distribution_uniform ${t1}$, intent(in) :: loc, scale ${t1}$ :: res - if(scale == 0._${k1}$) call error_stop("Error: Uniform distribution" & - //" scale parameter must be non-zero") + if(scale == 0._${k1}$) call error_stop("Error(unif_dist_rvs): " & + //"Uniform distribution scale parameter must be non-zero") res = loc + scale * unif_dist_rvs_0_${t1[0]}$${k1}$( ) return end function unif_dist_rvs_${t1[0]}$${k1}$ @@ -187,8 +191,8 @@ Module stdlib_stats_distribution_uniform ${t1}$ :: res real(${k1}$) :: r1, r2, tr, ti - if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error: Uniform" & - //" distribution scale parameter must be non-zero") + if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error(uni_dist_" & + //"rvs_1): Uniform distribution scale parameter must be non-zero") r1 = unif_dist_rvs_0_r${k1}$( ) if(real(scale) == 0.0_${k1}$) then ti = aimag(scale) * r1 @@ -201,7 +205,7 @@ Module stdlib_stats_distribution_uniform tr = real(scale) * r1 ti = aimag(scale) * r2 endif - res = cmplx(tr, ti) + res = cmplx(tr, ti, kind=${k1}$) return end function unif_dist_rvs_1_${t1[0]}$${k1}$ @@ -219,8 +223,8 @@ Module stdlib_stats_distribution_uniform ${t1}$ :: res real(${k1}$) :: r1, r2, tr, ti - if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error: Uniform" & - //" distribution scale parameter must be non-zero") + if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error(uni_dist_" & + //"rvs): Uniform distribution scale parameter must be non-zero") r1 = unif_dist_rvs_0_r${k1}$( ) if(real(scale) == 0.0_${k1}$) then tr = real(loc) @@ -233,7 +237,7 @@ Module stdlib_stats_distribution_uniform tr = real(loc) + real(scale) * r1 ti = aimag(loc) + aimag(scale) * r2 endif - res = cmplx(tr, ti) + res = cmplx(tr, ti, kind=${k1}$) return end function unif_dist_rvs_${t1[0]}$${k1}$ @@ -249,8 +253,8 @@ Module stdlib_stats_distribution_uniform integer :: i, zeros, bits_left, bits n = scale - if(n == 0_${k1}$) call error_stop("Error: Uniform distribution" & - //" scale parameter must be non-zero") + if(n == 0_${k1}$) call error_stop("Error(unif_dist_rvs_array): Uniform" & + //" distribution scale parameter must be non-zero") allocate(res(array_size)) zeros = leadz(n) bits = bit_size(n) - zeros @@ -287,8 +291,8 @@ Module stdlib_stats_distribution_uniform integer :: i - if(scale == 0._${k1}$) call error_stop("Error: Uniform distribution" & - //" scale parameter must be non-zero") + if(scale == 0._${k1}$) call error_stop("Error(unif_dist_rvs_array):" & + //" Uniform distribution scale parameter must be non-zero") allocate(res(array_size)) do i = 1, array_size tmp = shiftr(dist_rand(INT_ONE), 11) @@ -311,8 +315,8 @@ Module stdlib_stats_distribution_uniform integer :: i - if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error: Uniform" & - //" distribution scale parameter must be non-zero") + if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error(unif_dist_"& + //"rvs_array): Uniform distribution scale parameter must be non-zero") allocate(res(array_size)) do i = 1, array_size tmp = shiftr(dist_rand(INT_ONE), 11) @@ -329,7 +333,7 @@ Module stdlib_stats_distribution_uniform tr = real(loc) + real(scale) * r1 ti = aimag(loc) + aimag(scale) * r2 endif - res(i) = cmplx(tr, ti) + res(i) = cmplx(tr, ti, kind=${k1}$) enddo return end function unif_dist_rvs_array_${t1[0]}$${k1}$ @@ -343,10 +347,10 @@ Module stdlib_stats_distribution_uniform if(scale == 0) then res = 0.0 - elseif(x < loc .or. x >loc + scale) then + elseif(x < loc .or. x > (loc + scale)) then res = 0.0 else - res = 1. / (scale + 1) + res = 1. / (scale + 1_${k1}$) end if return end function unif_dist_pdf_${t1[0]}$${k1}$ @@ -400,7 +404,7 @@ Module stdlib_stats_distribution_uniform elseif(x < loc) then res = 0.0 elseif(x >= loc .and. x <= (loc + scale)) then - res = real((x - loc + 1)) / real((scale + 1)) + res = real((x - loc + 1_${k1}$)) / real((scale + 1_${k1}$)) else res = 1.0 end if From ec8733b86a91381e92125e8ea423bbb4adb1124f Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 21 Jan 2021 20:57:58 -0500 Subject: [PATCH 34/42] Add files via upload --- doc/specs/stdlib_stats_distribution_gamma.md | 85 +++++++++----------- 1 file changed, 39 insertions(+), 46 deletions(-) diff --git a/doc/specs/stdlib_stats_distribution_gamma.md b/doc/specs/stdlib_stats_distribution_gamma.md index 9f7fce04c..7d7bf342f 100644 --- a/doc/specs/stdlib_stats_distribution_gamma.md +++ b/doc/specs/stdlib_stats_distribution_gamma.md @@ -17,11 +17,7 @@ Experimental With one augument for shape parameter, the function returns a standard gamma distributed random variate \(\gamma\)(shape) with `rate = 1.0`. The function is elemental. For complex auguments, the real and imaginary parts are independent of each other. -With two auguments, the function returns a scalar gamma distributed random variate \(\gamma\)(shape, rate) and is elemental. - -With three auguments, the function returns a rank one array of gamma distribution random variates. - -The parameters shape and rate must be greater than 0. +With two auguments, the function return a scalar gamma distributed random variate \(\gamma\)(shape, rate). ### Syntax @@ -29,17 +25,15 @@ The parameters shape and rate must be greater than 0. ### Arguments -`shape` : has `intent(in)` ans is a scalar of type `real` or `complx`. +`shape` : has `intent(in)` and is a scalar of type `real` or `complex`. -`rate`: optional argument has `intent(in)` and is a scalar of type `real` or `complx`. +`rate`: optional argument has `intent(in)` and is a scalar of type `real` or `complex`. `array_size`: optional argument has `intent(in)` and is a scalar of type `integer`. -`shape` and `rate` must be the same type. - ### Return value -The result is a scalar or rank one array, with a size of `array_size`, of type `real` or `complx`. +The result is a scalar or rank one array, with a size of `array_size`, of type `real` or `complex`. ### Example @@ -50,7 +44,7 @@ program demo_gamma_rvs implicit none real :: g(2,3,4) - complx :: shape, scale + complex :: shape, scale integer :: put, get put = 1234567 @@ -67,24 +61,25 @@ program demo_gamma_rvs g(:,:,:) = 0.5 print *, rgamma(g) - !a rank 3 array of 24 standard gamma random variates with rate=0.5 + !a rank 3 array of 60 standard gamma random variates with rate=0.5 -! [1.03841162, 1.33044529, 0.912742674, 0.131288037, 0.638593793, -! 1.03565669E-02, 0.624804378, 1.12179172, 4.91380468E-02, 6.69969944E-03, -! 6.67014271E-02, 0.132111162, 0.101102419, 0.648416579, 1.14922595, -! 2.29003578E-02, 1.85964716E-04, 1.21213868E-02, 1.69112933, -! 7.30440915E-02, 0.395139128, 0.182758048, 0.427981257, 0.985665262] +! 1.03841162 1.33044529 0.912742674 0.131288037 0.638593793 +! 1.03565669E-02 0.624804378 1.12179172 4.91380468E-02 6.69969944E-03 +! 6.67014271E-02 0.132111162 0.101102419 0.648416579 1.14922595 +! 2.29003578E-02 1.85964716E-04 1.21213868E-02 1.69112933 +! 7.30440915E-02 0.395139128 0.182758048 0.427981257 0.985665262 print *, rgamma(0.5,1.0,10) ! an array of 10 random variates with shape=0.5, rate=1.0 -! [1.39297554E-04, 0.296419382, 0.352113068, 2.80515051, 3.65264394E-04, -! 0.197743446, 5.54569438E-02, 9.30598825E-02, 1.02596343, 1.85311246] +! 1.39297554E-04 0.296419382 0.352113068 2.80515051 3.65264394E-04 +! 0.197743446 5.54569438E-02 9.30598825E-02 1.02596343 1.85311246 shape = (3.0, 4.0) scale = (2.0, 0.7) print *, rgamma(shape,scale) - !single complex gamma random variate with real part of shape = 3.0, rate=2.0; imagainary part of shape=4.0, rate=0.7 + !single complex gamma random variate with real part of shape = 3.0, + !rate=2.0; imagainary part of shape=4.0, rate=0.7 ! (0.826188326,3.54749799) @@ -103,19 +98,17 @@ The probability density function of the continuous gamma distribution. $$ f(x)= \frac{scale^{shape}}{\Gamma (shape)}x^{shape-1}e^{-scale \times x} , for \;\; x>0, shape, scale>0$$ -x is supported in (0, \infty) - ### Syntax `result = [[stdlib_stats_distribution_gamma(module):gamma_distribution_pdf(interface)]](x, shape, rate)` ### Arguments -`x`: has `intent(in)` and is a scalar of type `real` or `complx`. +`x`: has `intent(in)` and is a scalar of type `real` or `complex`. -`shape` has `intent(in)` and is a scalar of type `real` or `complx`. +`shape` has `intent(in)` and is a scalar of type real` or `complex`. -`rate`: has `intent(in)` and is a scalar of type `real` or `complx`. +`rate`: has `intent(in)` and is a scalar of type `real` or `complex`. The function is elemental, i.e., all auguments could be arrays conformable to each other. All arguments must have the same type. @@ -127,13 +120,13 @@ The result is a scalar or an array, with a shape conformable to auguments, of ty ```fortran program demo_gamma_pdf - use stdlib_stats_distribution_PRNG, only : random_seed + use stdlib_stats_distribution_PRNG, onyl : random_seed use stdlib_stats_distribution_gamma, only: rgamma => gamma_distribution_rvs,& gamma_pdf => gamma_distribution_pdf implicit none real :: x(2,3,4),g(2,3,4),s(2,3,4) - complx :: shape, scale + complex :: shape, scale integer :: put, get put = 1234567 @@ -149,16 +142,17 @@ program demo_gamma_pdf x = reshape(rgamma(2.0, 1.0, 24),[2,3,4]) ! gamma random variates array print *, gamma_pdf(x,g,s) ! a rank 3 gamma probability density array -! [0.204550430, 0.320178866, 0.274986655, 0.348611295, 0.101865448, -! 0.102199331, 0.358981341, 0.223676488, 0.254329354, 0.356714427, -! 0.267390072, 0.305148095, 0.367848188, 7.26194456E-02, 1.49471285E-02, -! 0.246272027, 0.360770017, 0.339665830, 0.101558588, 0.358678699, -! 0.224196941, 0.359253854, 7.56355673E-02, 0.251869917] +! 0.204550430 0.320178866 0.274986655 0.348611295 0.101865448 +! 0.102199331 0.358981341 0.223676488 0.254329354 0.356714427 +! 0.267390072 0.305148095 0.367848188 7.26194456E-02 1.49471285E-02 +! 0.246272027 0.360770017 0.339665830 0.101558588 0.358678699 +! 0.224196941 0.359253854 7.56355673E-02 0.251869917 shape = (1.0, 1.5) scale = (1.0, 2.) print *, gamma_pdf((1.5,1.0), shape, scale) - ! a complex expon probability density function at (1.5,1.0) with real part of shape=1.0, rate=1.0 and imaginary part of shape=1.5, rate=2.0 + ! a complex expon probability density function at (1.5,1.0) with real part + !of shape=1.0, rate=1.0 and imaginary part of shape=1.5, rate=2.0 ! 9.63761061E-02 @@ -177,19 +171,17 @@ Cumulative distribution function of the gamma continuous distribution $$ F(x)= \frac{\gamma (shape, scale \times x)}{\Gamma (shape)}, for \;\; x>0, shape, scale>0} $$ -x is supported in (0, \infty) - ### Syntax `result = [[stdlib_stats_distribution_gamma(module):gamma_distribution_cdf(interface)]](x, shape, rate)` ### Arguments -`x`: has `intent(in)` and is a scalar of type `real` or `complx`. +`x`: has `intent(in)` and is a scalar of type `real` or `complex`. -`shape`: has `intent(in)` and is a scalar of type `real` or `complx`. +`shape`: has `intent(in)` and is a scalar of type `real` or `complex`. -`rate`: has `intent(in)` and is a scalar of type `real` or `complx`. +`rate`: has `intent(in)` and is a scalar of type `real` or `complex`. The function is elemental, i.e., all auguments could be arrays conformable to each other. All arguments must have the same type. @@ -201,13 +193,13 @@ The result is a scalar of type `real` with a shape conformable to auguments. ```fortran program demo_gamma_cdf - use stdlib_stats_distribution_PRNG, only : random_seed + use stdlib_stats_distribution_PRNG, onyl : random_seed use stdlib_stats_distribution_gamma, only: rgamma => gamma_distribution_rvs,& gamma_cdf => gamma_distribution_cdf implicit none real :: x(2,3,4),g(2,3,4),s(2,3,4) - complx :: shape, scale + complex :: shape, scale integer :: seed_put, seed_get seed_put = 1234567 @@ -229,16 +221,17 @@ program demo_gamma_cdf !gamma random variates array with a shape=1.0, rate=1.0 print *, gamma_cdf(x,g,s) ! a rank 3 standard gamma cumulative array -! [0.710880339, 0.472411335, 0.578345954, 0.383050948, 0.870905757, -! 0.870430350, 0.170215249, 0.677347481, 0.620089889, 0.161825046, -! 4.17549349E-02, 0.510665894, 0.252201647, 0.911497891, 0.984424412, -! 0.635621786, 0.177783430, 0.414842933, 0.871342421, 0.338317066, -! 2.06879266E-02, 0.335232288, 0.907408893, 0.624871135] +! 0.710880339 0.472411335 0.578345954 0.383050948 0.870905757 +! 0.870430350 0.170215249 0.677347481 0.620089889 0.161825046 +! 4.17549349E-02 0.510665894 0.252201647 0.911497891 0.984424412 +! 0.635621786 0.177783430 0.414842933 0.871342421 0.338317066 +! 2.06879266E-02 0.335232288 0.907408893 0.624871135 shape = (.7, 2.1) scale = (0.5,1.0) print *, gamma_cdf((0.5,0.5),shape,scale) - !complex gamma cumulative distribution at (0.5,0.5) with real part of shape=0.7,rate=0.5 and imaginary part of shape=2.1,rate=1.0 + !complex gamma cumulative distribution at (0.5,0.5) with real part of + !shape=0.7,rate=0.5 and imaginary part of shape=2.1,rate=1.0 ! 2.87349485E-02 From a8bdb4188ce8f65c8bdae161cca9655549f4bc85 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 21 Jan 2021 21:04:11 -0500 Subject: [PATCH 35/42] Add files via upload --- src/stdlib_stats_distribution_gamma.fypp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/stdlib_stats_distribution_gamma.fypp b/src/stdlib_stats_distribution_gamma.fypp index 8ef94a8c2..488e37858 100644 --- a/src/stdlib_stats_distribution_gamma.fypp +++ b/src/stdlib_stats_distribution_gamma.fypp @@ -196,7 +196,7 @@ Module stdlib_stats_distribution_gamma //" Gamma distribution shape parameter must be greater than zero") if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs_array):" & - //' Gamma distribution rate parameter must be greater than zero") + //" Gamma distribution rate parameter must be greater than zero") allocate(res(array_size)) zz = shape @@ -263,7 +263,7 @@ Module stdlib_stats_distribution_gamma //" distribution rate parameter must be greaeter than zero") if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & //" distribution shape parameter must be greater than zero") - if(x <= 0.0_${k1}$) call error_stop("Error)gamma_dist_pdf): Gamma" & + if(x <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & //" distribution variate x must be greater than zero") if(x == 0.0_${k1}$) then if(shape <= 1.0_${k1}$) then @@ -305,7 +305,7 @@ Module stdlib_stats_distribution_gamma //" distribution rate parameter must be greaeter than zero") if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & //" distribution shape parameter must be greater than zero") - if(x <= 0.0_${k1}$) call error_stop("Error)gamma_dist_pdf): Gamma" & + if(x <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & //" distribution variate x must be greater than zero") res = ingamma(shape, rate * x) / gamma(shape) return From eb358462bd1c11887ad4f7cd5536cd2cfd297dbb Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Thu, 21 Jan 2021 22:32:45 -0500 Subject: [PATCH 36/42] Update Makefile.manual --- src/Makefile.manual | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Makefile.manual b/src/Makefile.manual index e4f5a9617..fd07bb96c 100644 --- a/src/Makefile.manual +++ b/src/Makefile.manual @@ -121,7 +121,7 @@ stdlib_stats_distribution_normal.o: \ stdlib_error.o \ stdlib_stats_distribution_PRNG.o \ stdlib_stats_distribution_uniform.o -stdlib_stats_distribution_special.o: \ +stdlib_stats_distribution_special.o: \ stdlib_kinds.o \ stdlib_error.o stdlib_stats_distribution_gamma.o: \ From 044751037a5a67214982f7c719bf28e84da5bdb7 Mon Sep 17 00:00:00 2001 From: jim-215-fisher Date: Mon, 17 Jan 2022 21:22:01 -0500 Subject: [PATCH 37/42] test --- src/CMakeLists.txt | 124 ----------------- src/Makefile.manual | 243 --------------------------------- src/tests/stats/CMakeLists.txt | 38 ------ 3 files changed, 405 deletions(-) delete mode 100644 src/CMakeLists.txt delete mode 100644 src/Makefile.manual delete mode 100644 src/tests/stats/CMakeLists.txt diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt deleted file mode 100644 index f1f9051dd..000000000 --- a/src/CMakeLists.txt +++ /dev/null @@ -1,124 +0,0 @@ -#### Pre-process: .fpp -> .f90 via Fypp - -# Create a list of the files to be preprocessed -set(fppFiles - stdlib_ascii.fypp - stdlib_bitsets.fypp - stdlib_bitsets_64.fypp - stdlib_bitsets_large.fypp - stdlib_hash_32bit.fypp - stdlib_hash_32bit_fnv.fypp - stdlib_hash_32bit_nm.fypp - stdlib_hash_32bit_water.fypp - stdlib_hash_64bit.fypp - stdlib_hash_64bit_fnv.fypp - stdlib_hash_64bit_pengy.fypp - stdlib_hash_64bit_spookyv2.fypp - stdlib_io.fypp - stdlib_io_npy.fypp - stdlib_io_npy_load.fypp - stdlib_io_npy_save.fypp - stdlib_kinds.fypp - stdlib_linalg.fypp - stdlib_linalg_diag.fypp - stdlib_linalg_outer_product.fypp - stdlib_optval.fypp - stdlib_selection.fypp - stdlib_sorting.fypp - stdlib_sorting_ord_sort.fypp - stdlib_sorting_sort.fypp - stdlib_sorting_sort_index.fypp - stdlib_stats.fypp - stdlib_stats_corr.fypp - stdlib_stats_cov.fypp - stdlib_stats_mean.fypp - stdlib_stats_median.fypp - stdlib_stats_moment.fypp - stdlib_stats_moment_all.fypp - stdlib_stats_moment_mask.fypp - stdlib_stats_moment_scalar.fypp - stdlib_stats_distribution_uniform.fypp - stdlib_stats_distribution_normal.fypp - stdlib_stats_distribution_exponential.fypp - stdlib_stats_var.fypp - stdlib_quadrature.fypp - stdlib_quadrature_trapz.fypp - stdlib_quadrature_simps.fypp - stdlib_random.fypp - stdlib_math.fypp - stdlib_math_linspace.fypp - stdlib_math_logspace.fypp - stdlib_math_arange.fypp - stdlib_math_is_close.fypp - stdlib_math_all_close.fypp - stdlib_string_type.fypp - stdlib_string_type_constructor.fypp - stdlib_strings_to_string.fypp - stdlib_strings.fypp - stdlib_version.fypp -) - - -# Custom preprocessor flags -if(DEFINED CMAKE_MAXIMUM_RANK) - set(fyppFlags "-DMAXRANK=${CMAKE_MAXIMUM_RANK}") -elseif(f03rank) - set(fyppFlags) -else() - set(fyppFlags "-DVERSION90") -endif() - -list( - APPEND fyppFlags - "-DWITH_QP=$" - "-DWITH_XDP=$" - "-DPROJECT_VERSION_MAJOR=${PROJECT_VERSION_MAJOR}" - "-DPROJECT_VERSION_MINOR=${PROJECT_VERSION_MINOR}" - "-DPROJECT_VERSION_PATCH=${PROJECT_VERSION_PATCH}" -) - -fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) - -set(SRC - stdlib_array.f90 - stdlib_error.f90 - stdlib_logger.f90 - stdlib_system.F90 - stdlib_specialfunctions.f90 - stdlib_specialfunctions_legendre.f90 - stdlib_quadrature_gauss.f90 - stdlib_stringlist_type.f90 - ${outFiles} -) - -add_library(${PROJECT_NAME} ${SRC}) - -set(LIB_MOD_DIR ${CMAKE_CURRENT_BINARY_DIR}/mod_files/) -# We need the module directory before we finish the configure stage since the -# build interface might resolve before the module directory is generated by CMake -if(NOT EXISTS "${LIB_MOD_DIR}") - make_directory("${LIB_MOD_DIR}") -endif() - -set_target_properties(${PROJECT_NAME} PROPERTIES - Fortran_MODULE_DIRECTORY ${LIB_MOD_DIR}) -target_include_directories(${PROJECT_NAME} PUBLIC - $ - $ -) - -if(f18errorstop) - target_sources(${PROJECT_NAME} PRIVATE f18estop.f90) -else() - target_sources(${PROJECT_NAME} PRIVATE f08estop.f90) -endif() - -add_subdirectory(tests) - -install(TARGETS ${PROJECT_NAME} - EXPORT ${PROJECT_NAME}-targets - RUNTIME DESTINATION "${CMAKE_INSTALL_BINDIR}" - ARCHIVE DESTINATION "${CMAKE_INSTALL_LIBDIR}" - LIBRARY DESTINATION "${CMAKE_INSTALL_LIBDIR}" -) -install(DIRECTORY ${LIB_MOD_DIR} DESTINATION "${CMAKE_INSTALL_MODULEDIR}") diff --git a/src/Makefile.manual b/src/Makefile.manual deleted file mode 100644 index f61a6fef6..000000000 --- a/src/Makefile.manual +++ /dev/null @@ -1,243 +0,0 @@ -SRCFYPP = \ - stdlib_hash_32bit_fnv.fypp \ - stdlib_hash_32bit_nm.fypp \ - stdlib_hash_32bit_water.fypp \ - stdlib_hash_64bit_fnv.fypp \ - stdlib_hash_64bit_pengy.fypp \ - stdlib_hash_64bit_spookyv2.fypp \ - stdlib_ascii.fypp \ - stdlib_bitsets_64.fypp \ - stdlib_bitsets_large.fypp \ - stdlib_bitsets.fypp \ - stdlib_hash_32bit.fypp \ - stdlib_hash_64bit.fypp \ - stdlib_io.fypp \ - stdlib_io_npy.fypp \ - stdlib_io_npy_load.fypp \ - stdlib_io_npy_save.fypp \ - stdlib_kinds.fypp \ - stdlib_linalg.fypp \ - stdlib_linalg_diag.fypp \ - stdlib_linalg_outer_product.fypp \ - stdlib_math_arange.fypp \ - stdlib_optval.fypp \ - stdlib_quadrature.fypp \ - stdlib_quadrature_trapz.fypp \ - stdlib_quadrature_simps.fypp \ - stdlib_selection.fypp \ - stdlib_random.fypp \ - stdlib_sorting.fypp \ - stdlib_sorting_ord_sort.fypp \ - stdlib_sorting_sort.fypp \ - stdlib_sorting_sort_index.fypp \ - stdlib_stats.fypp \ - stdlib_stats_corr.fypp \ - stdlib_stats_cov.fypp \ - stdlib_stats_mean.fypp \ - stdlib_stats_median.fypp \ - stdlib_stats_moment.fypp \ - stdlib_stats_moment_all.fypp \ - stdlib_stats_moment_mask.fypp \ - stdlib_stats_moment_scalar.fypp \ - stdlib_stats_distribution_uniform.fypp \ - stdlib_stats_distribution_normal.fypp \ - stdlib_stats_distribution_exponential.fypp \ - stdlib_stats_var.fypp \ - stdlib_math.fypp \ - stdlib_math_linspace.fypp \ - stdlib_math_logspace.fypp \ - stdlib_math_is_close.fypp \ - stdlib_math_all_close.fypp \ - stdlib_string_type.fypp \ - stdlib_string_type_constructor.fypp \ - stdlib_strings.fypp \ - stdlib_strings_to_string.fypp \ - stdlib_version.fypp - -SRC = f18estop.f90 \ - stdlib_array.f90 \ - stdlib_error.f90 \ - stdlib_specialfunctions.f90 \ - stdlib_specialfunctions_legendre.f90 \ - stdlib_io.f90 \ - stdlib_logger.f90 \ - stdlib_quadrature_gauss.f90 \ - stdlib_strings.f90 \ - stdlib_stringlist_type.f90 \ - $(SRCGEN) - -LIB = libstdlib.a - - -SRCGEN = $(SRCFYPP:.fypp=.f90) -OBJS = $(SRC:.f90=.o) -MODS = $(OBJS:.o=.mod) -SMODS = $(OBJS:.o=*.smod) - -.PHONY: all clean - -all: $(LIB) - -$(LIB): $(OBJS) - ar rcs $@ $(OBJS) - -clean: - $(RM) $(LIB) $(OBJS) $(MODS) $(SMODS) $(SRCGEN) - -%.o: %.f90 - $(FC) $(FFLAGS) -c $< - -$(SRCGEN): %.f90: %.fypp common.fypp - fypp $(FYPPFLAGS) $< $@ - -# Fortran module dependencies -f18estop.o: stdlib_error.o -stdlib_hash_32bit_fnv.o: \ - stdlib_hash_32bit.o -stdlib_hash_32bit.o: \ - stdlib_kinds.o -stdlib_hash_32bit_nm.o: \ - stdlib_hash_32bit.o -stdlib_hash_32bit_water.o: \ - stdlib_hash_32bit.o -stdlib_hash_64bit_fnv.o: \ - stdlib_hash_64bit.o -stdlib_hash_64bit.o: \ - stdlib_kinds.o -stdlib_hash_64bit_pengy.o: \ - stdlib_hash_64bit.o -stdlib_hash_64bit_spookyv2.o: \ - stdlib_hash_64bit.o -stdlib_ascii.o: stdlib_kinds.o -stdlib_bitsets.o: stdlib_kinds.o \ - stdlib_optval.o -stdlib_bitsets_64.o: stdlib_bitsets.o -stdlib_bitsets_large.o: stdlib_bitsets.o -stdlib_error.o: stdlib_optval.o -stdlib_specialfunctions.o: stdlib_kinds.o -stdlib_specialfunctions_legendre.o: stdlib_kinds.o stdlib_specialfunctions.o -stdlib_io.o: \ - stdlib_ascii.o \ - stdlib_error.o \ - stdlib_optval.o \ - stdlib_kinds.o \ - stdlib_string_type.o \ - stdlib_ascii.o -stdlib_io_npy.o: \ - stdlib_kinds.o -stdlib_io_npy_load.o: \ - stdlib_io_npy.o \ - stdlib_error.o \ - stdlib_strings.o -stdlib_io_npy_save.o: \ - stdlib_io_npy.o \ - stdlib_error.o \ - stdlib_strings.o -stdlib_linalg.o: \ - stdlib_kinds.o \ - stdlib_optval.o \ - stdlib_error.o -stdlib_linalg_diag.o: \ - stdlib_linalg.o \ - stdlib_kinds.o -stdlib_linalg_outer_product.o: \ - stdlib_linalg.o -stdlib_logger.o: stdlib_ascii.o stdlib_optval.o -stdlib_optval.o: stdlib_kinds.o -stdlib_quadrature.o: stdlib_kinds.o -stdlib_quadrature_gauss.o: stdlib_kinds.o stdlib_quadrature.o -stdlib_quadrature_simps.o: \ - stdlib_quadrature.o \ - stdlib_error.o \ - stdlib_kinds.o -stdlib_quadrature_trapz.o: \ - stdlib_quadrature.o \ - stdlib_error.o \ - stdlib_kinds.o -stdlib_selection.o: \ - stdlib_kinds.o -stdlib_sorting.o: \ - stdlib_kinds.o \ - stdlib_string_type.o -stdlib_sorting_ord_sort.o: \ - stdlib_sorting.o -stdlib_sorting_sort.o: \ - stdlib_sorting.o -stdlib_sorting_sort_index.o: \ - stdlib_sorting.o -stdlib_stats.o: \ - stdlib_kinds.o -stdlib_stats_corr.o: \ - stdlib_optval.o \ - stdlib_kinds.o \ - stdlib_stats.o -stdlib_stats_cov.o: \ - stdlib_optval.o \ - stdlib_kinds.o \ - stdlib_stats.o -stdlib_stats_mean.o: \ - stdlib_optval.o \ - stdlib_kinds.o \ - stdlib_stats.o -stdlib_stats_median.o: \ - stdlib_optval.o \ - stdlib_kinds.o \ - stdlib_selection.o \ - stdlib_stats.o -stdlib_stats_moment.o: \ - stdlib_optval.o \ - stdlib_kinds.o \ - stdlib_stats.o -stdlib_stats_moment_all.o: \ - stdlib_stats_moment.o -stdlib_stats_moment_mask.o: \ - stdlib_stats_moment.o -stdlib_stats_moment_scalar.o: \ - stdlib_stats_moment.o -stdlib_stats_var.o: \ - stdlib_optval.o \ - stdlib_kinds.o \ - stdlib_stats.o -stdlib_stats_distribution_uniform.o: \ - stdlib_kinds.o \ - stdlib_error.o \ - stdlib_random.o -stdlib_stats_distribution_normal.o: \ - stdlib_kinds.o \ - stdlib_error.o \ - stdlib_random.o \ - stdlib_stats_distribution_uniform.o -stdlib_stats_distribution_exponential.o: \ - stdlib_kinds.o \ - stdlib_error.o \ - stdlib_random.o \ - stdlib_stats_distribution_uniform.o -stdlib_random.o: \ - stdlib_kinds.o \ - stdlib_error.o -stdlib_string_type.o: stdlib_ascii.o \ - stdlib_kinds.o -stdlib_string_type_constructor.o: stdlib_string_type.o \ - stdlib_strings_to_string.o \ - stdlib_strings.o -stdlib_strings.o: stdlib_ascii.o \ - stdlib_string_type.o \ - stdlib_optval.o \ - stdlib_kinds.o -stdlib_strings_to_string.o: stdlib_strings.o -stdlib_math.o: stdlib_kinds.o \ - stdlib_optval.o -stdlib_math_linspace.o: \ - stdlib_math.o -stdlib_math_logspace.o: \ - stdlib_math_linspace.o -stdlib_math_arange.o: \ - stdlib_math.o -stdlib_math_is_close.o: \ - stdlib_math.o -stdlib_math_all_close.o: \ - stdlib_math.o \ - stdlib_math_is_close.o -stdlib_stringlist_type.o: stdlib_string_type.o \ - stdlib_math.o \ - stdlib_optval.o diff --git a/src/tests/stats/CMakeLists.txt b/src/tests/stats/CMakeLists.txt deleted file mode 100644 index b705f9e6b..000000000 --- a/src/tests/stats/CMakeLists.txt +++ /dev/null @@ -1,38 +0,0 @@ -### Pre-process: .fpp -> .f90 via Fypp - -# Create a list of the files to be preprocessed -set(fppFiles - test_mean.fypp - test_mean_f03.fypp - test_median.fypp - test_distribution_uniform.fypp - test_distribution_normal.fypp - test_distribution_exponential.fypp -) - -fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) - -ADDTEST(corr) -ADDTEST(cov) -ADDTEST(mean) -ADDTEST(median) -ADDTEST(moment) -ADDTEST(rawmoment) -ADDTEST(var) -ADDTEST(varn) -<<<<<<< HEAD -ADDTEST(distribution_gamma) -======= -ADDTEST(random) -ADDTEST(distribution_uniform) -ADDTEST(distribution_normal) -ADDTEST(distribution_exponential) ->>>>>>> upstream/master - -if(DEFINED CMAKE_MAXIMUM_RANK) - if(${CMAKE_MAXIMUM_RANK} GREATER 7) - ADDTEST(mean_f03) - endif() -elseif(f03rank) - ADDTEST(mean_f03) -endif() From 49413338bf55a206d521aaa594efb07f6f516f35 Mon Sep 17 00:00:00 2001 From: jim-215-fisher Date: Fri, 17 Jun 2022 23:48:57 -0400 Subject: [PATCH 38/42] merge to master --- .github/workflows/CI.yml | 12 - API-doc-FORD-file.md | 1 + CHANGELOG.md | 23 +- CMakeLists.txt | 34 +- Makefile.manual | 33 - README.md | 31 +- VERSION | 2 +- WORKFLOW.md | 27 +- config/DefaultFlags.cmake | 50 + doc/specs/stdlib_io.md | 48 +- doc/specs/stdlib_math.md | 154 +- doc/specs/stdlib_quadrature.md | 4 +- doc/specs/stdlib_specialfunctions_gamma.md | 437 ++++++ src/CMakeLists.txt | 144 ++ src/stdlib_io.fypp | 89 +- src/stdlib_io_npy_load.fypp | 8 +- src/stdlib_io_npy_save.fypp | 8 +- src/stdlib_math.fypp | 45 +- src/stdlib_math_diff.fypp | 139 ++ src/stdlib_quadrature_gauss.f90 | 2 - src/stdlib_specialfunctions_gamma.fypp | 1289 +++++++++++++++++ src/tests/CMakeLists.txt | 1 + src/tests/Makefile.manual | 39 - src/tests/Makefile.manual.test.mk | 27 - src/tests/array/Makefile.manual | 4 - src/tests/ascii/Makefile.manual | 4 - src/tests/bitsets/Makefile.manual | 3 - src/tests/hash_functions/CMakeLists.txt | 41 +- src/tests/hash_functions/Makefile.manual | 47 - src/tests/hash_functions_perf/CMakeLists.txt | 8 + src/tests/hash_functions_perf/Makefile.manual | 3 - src/tests/io/Makefile.manual | 20 - src/tests/io/test_loadtxt.f90 | 24 + src/tests/linalg/Makefile.manual | 14 - src/tests/logger/Makefile.manual | 4 - src/tests/math/CMakeLists.txt | 1 - src/tests/math/Makefile.manual | 12 - src/tests/math/test_math_arange.f90 | 86 -- src/tests/math/test_stdlib_math.fypp | 196 ++- src/tests/quadrature/Makefile.manual | 12 - src/tests/quadrature/test_gauss.f90 | 22 +- src/tests/selection/Makefile.manual | 10 - src/tests/sorting/Makefile.manual | 3 - src/tests/specialfunctions/CMakeLists.txt | 10 + .../Makefile.manual | 6 +- .../test_specialfunctions_gamma.fypp | 587 ++++++++ src/tests/stats/CMakeLists.txt | 34 + src/tests/string/Makefile.manual | 11 - src/tests/stringlist/Makefile.manual | 5 - 49 files changed, 3273 insertions(+), 541 deletions(-) delete mode 100644 Makefile.manual create mode 100644 config/DefaultFlags.cmake create mode 100644 doc/specs/stdlib_specialfunctions_gamma.md create mode 100644 src/CMakeLists.txt create mode 100644 src/stdlib_math_diff.fypp create mode 100644 src/stdlib_specialfunctions_gamma.fypp delete mode 100644 src/tests/Makefile.manual delete mode 100644 src/tests/Makefile.manual.test.mk delete mode 100644 src/tests/array/Makefile.manual delete mode 100644 src/tests/ascii/Makefile.manual delete mode 100644 src/tests/bitsets/Makefile.manual delete mode 100644 src/tests/hash_functions/Makefile.manual delete mode 100755 src/tests/hash_functions_perf/Makefile.manual delete mode 100644 src/tests/io/Makefile.manual delete mode 100644 src/tests/linalg/Makefile.manual delete mode 100644 src/tests/logger/Makefile.manual delete mode 100644 src/tests/math/Makefile.manual delete mode 100644 src/tests/math/test_math_arange.f90 delete mode 100644 src/tests/quadrature/Makefile.manual delete mode 100644 src/tests/selection/Makefile.manual delete mode 100644 src/tests/sorting/Makefile.manual create mode 100644 src/tests/specialfunctions/CMakeLists.txt rename src/tests/{optval => specialfunctions}/Makefile.manual (74%) create mode 100644 src/tests/specialfunctions/test_specialfunctions_gamma.fypp create mode 100644 src/tests/stats/CMakeLists.txt delete mode 100644 src/tests/string/Makefile.manual delete mode 100644 src/tests/stringlist/Makefile.manual diff --git a/.github/workflows/CI.yml b/.github/workflows/CI.yml index 2bba4d8a1..1798963f4 100644 --- a/.github/workflows/CI.yml +++ b/.github/workflows/CI.yml @@ -26,9 +26,6 @@ jobs: - os: ubuntu-latest gcc_v: 10 build: cmake-inline - - os: ubuntu-latest - gcc_v: 10 - build: make env: FC: gfortran-${{ matrix.gcc_v }} CC: gcc-${{ matrix.gcc_v }} @@ -95,15 +92,6 @@ jobs: if: ${{ contains(matrix.build, 'cmake') }} run: cmake --install ${{ env.BUILD_DIR }} - - name: Test manual makefiles - if: ${{ matrix.build == 'make' }} - run: | - make -f Makefile.manual -j - make -f Makefile.manual test - make -f Makefile.manual clean - env: - ADD_FYPPFLAGS: "-DMAXRANK=4" - intel-build: runs-on: ${{ matrix.os }} strategy: diff --git a/API-doc-FORD-file.md b/API-doc-FORD-file.md index 5240093ae..0db3e0a21 100644 --- a/API-doc-FORD-file.md +++ b/API-doc-FORD-file.md @@ -2,6 +2,7 @@ project: Fortran-lang/stdlib summary: A community driven standard library for (modern) Fortran src_dir: src +include: src exclude_dir: src/tests output_dir: API-doc page_dir: doc diff --git a/CHANGELOG.md b/CHANGELOG.md index c3122b909..66178af36 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,17 @@ -# Unreleased +# Version 0.2.1 -Features available from the latest git source +Full release notes available at [v0.2.1] tag. + +[v0.2.1]: https://github.com/fortran-lang/stdlib/releases/tag/v0.2.1 + +- build system related bugfixes + + +# Version 0.2.0 + +Full release notes available at [v0.2.0] tag. + +[v0.2.0]: https://github.com/fortran-lang/stdlib/releases/tag/v0.2.0 - new module `stdlib_hash_32bit` [#573](https://github.com/fortran-lang/stdlib/pull/573) @@ -36,6 +47,8 @@ Features available from the latest git source [#488](https://github.com/fortran-lang/stdlib/pull/488) - new procedures `arg`, `argd` and `argpi` [#498](https://github.com/fortran-lang/stdlib/pull/498) + - new procedure `diff` + [#605](https://github.com/fortran-lang/stdlib/pull/605) Changes to existing modules @@ -47,6 +60,12 @@ Changes to existing modules [#562](https://github.com/fortran-lang/stdlib/pull/562) - support for quadruple precision made optional [#565](https://github.com/fortran-lang/stdlib/pull/565) +- change in module `stdlib_io` + - Modified format constants, and made public + [#617](https://github.com/fortran-lang/stdlib/pull/617) +- change in module `stdlib_math` + - Minor update to `stdlib_math` module and document + [#624](https://github.com/fortran-lang/stdlib/pull/624) # Version 0.1.0 diff --git a/CMakeLists.txt b/CMakeLists.txt index f257972df..0b78699e8 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,4 +1,8 @@ cmake_minimum_required(VERSION 3.14.0) + +# Include overwrites before setting up the project +set(CMAKE_USER_MAKE_RULES_OVERRIDE ${CMAKE_CURRENT_SOURCE_DIR}/config/DefaultFlags.cmake) + project(fortran_stdlib LANGUAGES Fortran DESCRIPTION "Community driven and agreed upon de facto standard library for Fortran" @@ -12,7 +16,7 @@ list(GET VERSION_LIST 1 PROJECT_VERSION_MINOR) list(GET VERSION_LIST 2 PROJECT_VERSION_PATCH) unset(VERSION_LIST) -enable_testing() +include(CTest) # Follow GNU conventions for installation directories include(GNUInstallDirs) @@ -22,31 +26,9 @@ include(${PROJECT_SOURCE_DIR}/cmake/stdlib.cmake) # --- CMake specific configuration and package data export add_subdirectory(config) -# --- compiler options -if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU) - if(CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 9.0) - message(FATAL_ERROR "GCC Version 9 or newer required") - endif() - add_compile_options(-fimplicit-none) - add_compile_options(-ffree-line-length-132) - add_compile_options(-fno-range-check) # Needed for gfortran 9 and - # earlier for hash functions - add_compile_options(-Wall) - add_compile_options(-Wextra) - add_compile_options(-Wimplicit-procedure) - # -pedantic-errors triggers a false positive for optional arguments of elemental functions, - # see test_optval and https://gcc.gnu.org/bugzilla/show_bug.cgi?id=95446 - if(CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 11.0) - add_compile_options(-pedantic-errors) - endif() - add_compile_options(-std=f2018) -elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^Intel") - if(WIN32) - set(fortran_flags /stand:f18 /warn:declarations,general,usage,interfaces,unused) - else() - set(fortran_flags -stand f18 -warn declarations,general,usage,interfaces,unused) - endif() - add_compile_options("$<$:${fortran_flags}>") +# --- compiler selection +if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU AND CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 9.0) + message(FATAL_ERROR "GCC Version 9 or newer required") endif() # --- compiler feature checks diff --git a/Makefile.manual b/Makefile.manual deleted file mode 100644 index 288c18f01..000000000 --- a/Makefile.manual +++ /dev/null @@ -1,33 +0,0 @@ -# Fortran stdlib Makefile - -FC ?= gfortran -# -fno-range-check needed for hash functions for gfortran-9 -FFLAGS ?= -Wall -Wextra -Wimplicit-interface -fPIC -g -fcheck=all -fno-range-check -ADD_FYPPFLAGS ?= - -VERSION := $(subst ., ,$(file < VERSION)) -VERSION_FYPPFLAGS += \ - -DPROJECT_VERSION_MAJOR=$(word 1,$(VERSION)) \ - -DPROJECT_VERSION_MINOR=$(word 2,$(VERSION)) \ - -DPROJECT_VERSION_PATCH=$(word 3,$(VERSION)) - -FYPPFLAGS := $(ADD_FYPPFLAGS) $(VERSION_FYPPFLAGS) - -export FC -export FFLAGS -export FYPPFLAGS - -.PHONY: all clean test - -all: - $(MAKE) -f Makefile.manual --directory=src - $(MAKE) -f Makefile.manual --directory=src/tests - -test: - $(MAKE) -f Makefile.manual --directory=src/tests test - @echo - @echo "All tests passed." - -clean: - $(MAKE) -f Makefile.manual clean --directory=src - $(MAKE) -f Makefile.manual clean --directory=src/tests diff --git a/README.md b/README.md index 733a23a27..366fb9f5e 100644 --- a/README.md +++ b/README.md @@ -10,7 +10,6 @@ - [Requirements](#requirements) - [Supported compilers](#supported-compilers) - [Build with CMake](#build-with-cmake) - - [Build with make](#build-with-make) - [Build with fortran-lang/fpm](#build-with-fortran-langfpm) * [Using stdlib in your project](#using-stdlib-in-your-project) * [Documentation](#documentation) @@ -133,6 +132,7 @@ Important options are The minimum required rank to compile this project is 4. Compiling with maximum rank 15 can be resource intensive and requires at least 16 GB of memory to allow parallel compilation or 4 GB memory for sequential compilation. - `-DBUILD_SHARED_LIBS` set to `on` in case you want link your application dynamically against the standard library (default: `off`). +- `-DBUILD_TESTING` set to `off` in case you want to disable the stdlib tests (default: `on`). For example, to configure a build using the Ninja backend while specifying compiler flags `FFLAGS`, generating procedures up to rank 7, and installing to your home directory, use @@ -167,26 +167,6 @@ If at some point you wish to recompile `stdlib` with different options, you migh want to delete the `build` folder. This will ensure that cached variables from earlier builds do not affect the new build. - -### Build with make - -Alternatively, you can build using provided Makefiles: - -```sh -make -f Makefile.manual -``` - -You can limit the maximum rank by setting ``-DMAXRANK=`` in the ``ADD_FYPPFLAGS`` environment variable (which can reduce the compilation time): - -```sh -make -f Makefile.manual ADD_FYPPFLAGS=-DMAXRANK=4 -``` - -You can also specify the compiler and compiler-flags by setting the ``FC`` and ``FFLAGS`` environmental variables. Among other things, this facilitates use of compiler optimizations that are not specified in the Makefile.manual defaults. -```sh -make -f Makefile.manual ADD_FYPPFLAGS=-DMAXRANK=4 FC=gfortran FFLAGS="-O3" -``` - ### Build with [fortran-lang/fpm](https://github.com/fortran-lang/fpm) Fortran Package Manager (fpm) is a package manager and build system for Fortran. @@ -223,15 +203,6 @@ target_link_libraries( To make the installed stdlib project discoverable add the stdlib directory to the ``CMAKE_PREFIX_PATH``. The usual install location of the package files is ``$PREFIX/lib/cmake/fortran_stdlib``. -For non-CMake build systems (like make) you can use the exported pkg-config file by setting ``PKG_CONFIG_PATH`` to include the directory containing the exported pc-file. -The usual install location of the pc-file is ``$PREFIX/lib/pkgconfig``. -In make you can obtain the required compile and link arguments with - -```make -STDLIB_CFLAGS := $(shell pkg-config --cflags fortran_stdlib) -STDLIB_LIBS := $(shell pkg-config --libs fortran_stdlib) -``` - ## Documentation Documentation is a work in progress (see issue [#4](https://github.com/fortran-lang/stdlib/issues/4)) but already available at [stdlib.fortran-lang.org](https://stdlib.fortran-lang.org). diff --git a/VERSION b/VERSION index 6e8bf73aa..0c62199f1 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -0.1.0 +0.2.1 diff --git a/WORKFLOW.md b/WORKFLOW.md index c6d72b3b5..e9ffe14a3 100644 --- a/WORKFLOW.md +++ b/WORKFLOW.md @@ -61,14 +61,10 @@ You are welcome to propose changes to this workflow by opening an [issue](https://github.com/fortran-lang/stdlib/issues). -## Build system - -This project supports two build systems right now, CMake and make. -Eventually, stdlib will be using the Fortran package manager -([fpm](https://github.com/fortran-lang/fpm)) as build system as well. -The effort of supporting fpm is tracked in issue -[#279](https://github.com/fortran-lang/stdlib/issues/279). +## Build systems +This project supports two build systems, +[fpm](https://github.com/fortran-lang/fpm) and CMake. ### CMake build files @@ -113,20 +109,3 @@ The project is usable as CMake subproject. Explicit references to break subproject builds. An example project is available [here](https://github.com/fortran-lang/stdlib-cmake-example) to test the CMake subproject integration. - - -### Make build files - -The build files for ``make`` are using the name ``Makefile.manual`` to -not conflict with the in-tree build of CMake. -This project uses recursive make to transverse the subdirectory structure -from the top-level makefile, called ``Makefile.manual``, and the build -happens in-tree, *i.e.* build artifacts are present along with the source code. - -New source files are added in ``src/Makefile.manual`` and include manual -dependency definitions through the object files to allow parallel -compilation. -Tests are generated by the make include file ``src/tests/Makefile.manual.test.mk`` -and defined in the subdirectories of the ``src/tests`` as entries in ``PROGS_SRC``. -New subdirectories have to be explicitly added to ``src/tests/Makefile.manual`` -or are ignored. diff --git a/config/DefaultFlags.cmake b/config/DefaultFlags.cmake new file mode 100644 index 000000000..eafe7a409 --- /dev/null +++ b/config/DefaultFlags.cmake @@ -0,0 +1,50 @@ +if(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU") + set( + CMAKE_Fortran_FLAGS_INIT + "-fimplicit-none" + "-ffree-line-length-132" + ) + set( + CMAKE_Fortran_FLAGS_RELEASE_INIT + ) + set( + CMAKE_Fortran_FLAGS_DEBUG_INIT + "-Wall" + "-Wextra" + "-Wimplicit-procedure" + "-std=f2018" + ) +elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^Intel") + set( + CMAKE_Fortran_FLAGS_INIT + ) + set( + CMAKE_Fortran_FLAGS_RELEASE_INIT + ) + if(WIN32) + set( + CMAKE_Fortran_FLAGS_DEBUG_INIT + "/stand:f18" + "/warn:declarations,general,usage,interfaces,unused" + ) + else() + set( + CMAKE_Fortran_FLAGS_DEBUG_INIT + "-stand f18" + "-warn declarations,general,usage,interfaces,unused" + ) + endif() +else() + set( + CMAKE_Fortran_FLAGS_INIT + ) + set( + CMAKE_Fortran_FLAGS_RELEASE_INIT + ) + set( + CMAKE_Fortran_FLAGS_DEBUG_INIT + ) +endif() +string(REPLACE ";" " " CMAKE_Fortran_FLAGS_INIT "${CMAKE_Fortran_FLAGS_INIT}") +string(REPLACE ";" " " CMAKE_Fortran_FLAGS_RELEASE_INIT "${CMAKE_Fortran_FLAGS_RELEASE_INIT}") +string(REPLACE ";" " " CMAKE_Fortran_FLAGS_DEBUG_INIT "${CMAKE_Fortran_FLAGS_DEBUG_INIT}") diff --git a/doc/specs/stdlib_io.md b/doc/specs/stdlib_io.md index 0c70be26e..971a8ee29 100644 --- a/doc/specs/stdlib_io.md +++ b/doc/specs/stdlib_io.md @@ -17,7 +17,7 @@ Loads a rank-2 `array` from a text file. ### Syntax -`call [[stdlib_io(module):loadtxt(interface)]](filename, array)` +`call [[stdlib_io(module):loadtxt(interface)]](filename, array [, skiprows] [, max_rows])` ### Arguments @@ -25,6 +25,10 @@ Loads a rank-2 `array` from a text file. `array`: Shall be an allocatable rank-2 array of type `real`, `complex` or `integer`. +`skiprows` (optional): Skip the first `skiprows` lines. If skipping more rows than present, a 0-sized array will be returned. The default is 0. + +`max_rows` (optional): Read `max_rows` lines of content after `skiprows` lines. A negative value results in reading all lines. A value of zero results in no lines to be read. The default value is -1. + ### Return value Returns an allocated rank-2 `array` with the content of `filename`. @@ -273,3 +277,45 @@ program demo_getline end do end program demo_getline ``` + +## Formatting constants + +### Status + +Experimental + +### Description + +Formatting constants for printing out integer, floating point, and complex numbers at their full precision. +Provides formats for all kinds as defined in the `stdlib_kinds` module. + +### Example + +```fortran +program demo_fmt_constants + use, stdlib_kinds, only : int32, int64, sp, dp + use stdlib_io, only : FMT_INT, FMT_REAL_SP, FMT_REAL_DP, FMT_COMPLEX_SP, FMT_COMPLEX_DP + implicit none + + integer(kind=int32) :: i32 + integer(kind=int64) :: i64 + real(kind=sp) :: r32 + real(kind=dp) :: r64 + complex(kind=sp) :: c32 + complex(kind=dp) :: c64 + + i32 = 100_int32 + i64 = 100_int64 + r32 = 100.0_sp + r64 = 100.0_dp + c32 = cmplx(100.0_sp, kind=sp) + c64 = cmplx(100.0_dp, kind=dp) + + print "(2("//FMT_INT//",1x))", i32, i64 ! outputs: 100 100 + print FMT_REAL_SP, r32 ! outputs: 1.00000000E+02 + print FMT_REAL_DP, r64 ! outputs: 1.0000000000000000E+002 + print FMT_COMPLEX_SP, c32 ! outputs: 1.00000000E+02 0.00000000E+00 + print FMT_COMPLEX_DP, c64 ! outputs: 1.0000000000000000E+002 0.0000000000000000E+000 + +end program demo_fmt_constants +``` diff --git a/doc/specs/stdlib_math.md b/doc/specs/stdlib_math.md index 665d6ee5f..9091b836d 100644 --- a/doc/specs/stdlib_math.md +++ b/doc/specs/stdlib_math.md @@ -320,7 +320,7 @@ program demo_logspace_rstart_cbase end program demo_logspace_rstart_cbase ``` -### `arange` +### `arange` function #### Status @@ -332,7 +332,7 @@ Pure function. #### Description -Creates a one-dimensional `array` of the `integer/real` type with fixed-spaced values of given spacing, within a given interval. +Creates a rank-1 `array` of the `integer/real` type with fixed-spaced values of given spacing, within a given interval. #### Syntax @@ -360,7 +360,7 @@ If `step < 0`, the `step` argument will be corrected to `abs(step)` by the inter #### Return value -Returns a one-dimensional `array` of fixed-spaced values. +Returns a rank-1 `array` of fixed-spaced values. For `integer` type arguments, the length of the result vector is `(end - start)/step + 1`. For `real` type arguments, the length of the result vector is `floor((end - start)/step) + 1`. @@ -371,25 +371,25 @@ For `real` type arguments, the length of the result vector is `floor((end - star program demo_math_arange use stdlib_math, only: arange - print *, arange(3) !! [1,2,3] - print *, arange(-1) !! [1,0,-1] - print *, arange(0,2) !! [0,1,2] - print *, arange(1,-1) !! [1,0,-1] - print *, arange(0, 2, 2) !! [0,2] + print *, arange(3) ! [1,2,3] + print *, arange(-1) ! [1,0,-1] + print *, arange(0,2) ! [0,1,2] + print *, arange(1,-1) ! [1,0,-1] + print *, arange(0, 2, 2) ! [0,2] - print *, arange(3.0) !! [1.0,2.0,3.0] - print *, arange(0.0,5.0) !! [0.0,1.0,2.0,3.0,4.0,5.0] - print *, arange(0.0,6.0,2.5) !! [0.0,2.5,5.0] + print *, arange(3.0) ! [1.0,2.0,3.0] + print *, arange(0.0,5.0) ! [0.0,1.0,2.0,3.0,4.0,5.0] + print *, arange(0.0,6.0,2.5) ! [0.0,2.5,5.0] - print *, (1.0,1.0)*arange(3) !! [(1.0,1.0),(2.0,2.0),[3.0,3.0]] + print *, (1.0,1.0)*arange(3) ! [(1.0,1.0),(2.0,2.0),[3.0,3.0]] - print *, arange(0.0,2.0,-2.0) !! [0.0,2.0]. Not recommended: `step` argument is negative! - print *, arange(0.0,2.0,0.0) !! [0.0,1.0,2.0]. Not recommended: `step` argument is zero! + print *, arange(0.0,2.0,-2.0) ! [0.0,2.0]. Not recommended: `step` argument is negative! + print *, arange(0.0,2.0,0.0) ! [0.0,1.0,2.0]. Not recommended: `step` argument is zero! end program demo_math_arange ``` -### `arg` - Computes the phase angle in radian of a complex scalar +### `arg` function #### Status @@ -424,13 +424,14 @@ Notes: Although the angle of the complex number `0` is undefined, `arg((0,0))` r ```fortran program demo_math_arg use stdlib_math, only: arg - print *, arg((0.0, 0.0)) !! 0.0 - print *, arg((3.0, 4.0)) !! 0.927 - print *, arg(2.0*exp((0.0, 0.5))) !! 0.5 + print *, arg((0.0, 0.0)) ! 0.0 + print *, arg((3.0, 4.0)) ! 0.927 + print *, arg(2.0*exp((0.0, 0.5))) ! 0.5 + print *, arg([(0.0, 1.0), (1.0, 0.0), (0.0, -1.0), (-1.0, 0.0)]) ! [π/2, 0.0, -π/2, π] end program demo_math_arg ``` -### `argd` - Computes the phase angle in degree of a complex scalar +### `argd` function #### Status @@ -465,13 +466,14 @@ Notes: Although the angle of the complex number `0` is undefined, `argd((0,0))` ```fortran program demo_math_argd use stdlib_math, only: argd - print *, argd((0.0, 0.0)) !! 0.0 - print *, argd((3.0, 4.0)) !! 53.1° - print *, argd(2.0*exp((0.0, 0.5))) !! 28.64° + print *, argd((0.0, 0.0)) ! 0.0° + print *, argd((3.0, 4.0)) ! 53.1° + print *, argd(2.0*exp((0.0, 0.5))) ! 28.64° + print *, argd([(0.0, 1.0), (1.0, 0.0), (0.0, -1.0), (-1.0, 0.0)]) ! [90°, 0°, -90°, 180°] end program demo_math_argd ``` -### `argpi` - Computes the phase angle in circular of a complex scalar +### `argpi` function #### Status @@ -506,13 +508,14 @@ Notes: Although the angle of the complex number `0` is undefined, `argpi((0,0))` ```fortran program demo_math_argpi use stdlib_math, only: argpi - print *, argpi((0.0, 0.0)) !! 0.0 - print *, argpi((3.0, 4.0)) !! 0.295 - print *, argpi(2.0*exp((0.0, 0.5))) !! 0.159 + print *, argpi((0.0, 0.0)) ! 0.0 + print *, argpi((3.0, 4.0)) ! 0.295 + print *, argpi(2.0*exp((0.0, 0.5))) ! 0.159 + print *, argpi([(0.0, 1.0), (1.0, 0.0), (0.0, -1.0), (-1.0, 0.0)]) ! [0.5, 0.0, -0.5, 1.0] end program demo_math_argpi ``` -### `is_close` +### `is_close` function #### Description @@ -577,15 +580,15 @@ program demo_math_is_close y = -3 NAN = sqrt(y) - print *, is_close(x,[real :: 1, 2.1]) !! [T, F] - print *, is_close(2.0, 2.1, abs_tol=0.1) !! T - print *, NAN, is_close(2.0, NAN), is_close(2.0, NAN, equal_nan=.true.) !! NAN, F, F - print *, is_close(NAN, NAN), is_close(NAN, NAN, equal_nan=.true.) !! F, T + print *, is_close(x,[real :: 1, 2.1]) ! [T, F] + print *, is_close(2.0, 2.1, abs_tol=0.1) ! T + print *, NAN, is_close(2.0, NAN), is_close(2.0, NAN, equal_nan=.true.) ! NAN, F, F + print *, is_close(NAN, NAN), is_close(NAN, NAN, equal_nan=.true.) ! F, T end program demo_math_is_close ``` -### `all_close` +### `all_close` function #### Description @@ -643,9 +646,92 @@ program demo_math_all_close NAN = sqrt(y) z = (1.0, 1.0) - print *, all_close(z+cmplx(1.0e-11, 1.0e-11), z) !! T + print *, all_close(z+cmplx(1.0e-11, 1.0e-11), z) ! T print *, NAN, all_close([NAN], [NAN]), all_close([NAN], [NAN], equal_nan=.true.) - !! NAN, F, T + ! NAN, F, T end program demo_math_all_close ``` + +### `diff` function + +#### Description + +Computes differences between adjacent elements of an array. + +#### Syntax + +For a rank-1 array: +`y = [[stdlib_math(module):diff(interface)]](x [, n, prepend, append])` + +and for a rank-2 array: +`y = [[stdlib_math(module):diff(interface)]](x [, n, dim, prepend, append])` + +#### Status + +Experimental. + +#### Class + +Pure function. + +#### Arguments + +`x`: The array to take a difference of. +Shall be a `real/integer` and `rank-1/rank-2` array. +This argument is `intent(in)`. + +`n`: How many times to iteratively calculate the difference. +Shall be an `integer` scalar. +This argument is `intent(in)` and `optional`, and has value of `1` by default. + +`dim`: The dimension of the input array along which to calculate the difference. +Its value must be between `1` and `rank(x)`. +Shall be an `integer` scalar. +This argument is `intent(in)` and `optional` and has a value of `1` by default. + +`prepend`, `append`: Arrays to prepend or append to a along axis prior to performing the difference. +The dimension and shape must match a except along axis. +Shall be a `real/integer` and `rank-1/rank-2` array. +This argument is `intent(in)` and `optional`, which is no value by default. + +Note: + +- The `x`, `prepend` and `append` arguments must have the same `type`, `kind` and `rank`. +- If the value of `n` is less than or equal to `0` (which is not recommended), the return value of `diff` is `x`. +- If the value of `dim` is not equal to `1` or `2` (which is not recommended), +`1` will be used by the internal process of `diff`. + + +#### Result value + +Returns the finite difference of the input array. +Shall be a `real/integer` and `rank-1/rank-2` array. +When both `prepend` and `append` are not present, the result `y` has one fewer element than `x` alongside the dimension `dim`. + +#### Example + +```fortran +program demo_diff + + use stdlib_math, only: diff + implicit none + + integer :: i(7) = [1, 1, 2, 3, 5, 8, 13] + real :: x(6) = [0, 5, 15, 30, 50, 75] + integer :: A(3, 3) = reshape([1, 7, 17, 3, 11, 19, 5, 13, 23], [3, 3]) + integer :: Y(3, 2) + + print *, diff(i) ! [0, 1, 1, 2, 3, 5] + print *, diff(x, 2) ! [5.0, 5.0, 5.0, 5.0] + + Y = diff(A, n=1, dim=2) + print *, Y(1, :) ! [2, 2] + print *, Y(2, :) ! [4, 2] + print *, Y(3, :) ! [2, 4] + + print *, diff(i, prepend=[0]) ! [1, 0, 1, 1, 2, 3, 5] + print *, diff(i, append=[21]) ! [0, 1, 1, 2, 3, 5, 8] + +end program demo_diff +``` \ No newline at end of file diff --git a/doc/specs/stdlib_quadrature.md b/doc/specs/stdlib_quadrature.md index d4d39dfcf..bd67f8af0 100644 --- a/doc/specs/stdlib_quadrature.md +++ b/doc/specs/stdlib_quadrature.md @@ -14,7 +14,7 @@ Experimental ### Description -Returns the trapezoidal rule integral of an array `y` representing discrete samples of a function. The integral is computed assuming either equidistant abscissas with spacing `dx` or arbitary abscissas `x`. +Returns the trapezoidal rule integral of an array `y` representing discrete samples of a function. The integral is computed assuming either equidistant abscissas with spacing `dx` or arbitrary abscissas `x`. ### Syntax @@ -99,7 +99,7 @@ Experimental ### Description -Returns the Simpson's rule integral of an array `y` representing discrete samples of a function. The integral is computed assuming either equidistant abscissas with spacing `dx` or arbitary abscissas `x`. +Returns the Simpson's rule integral of an array `y` representing discrete samples of a function. The integral is computed assuming either equidistant abscissas with spacing `dx` or arbitrary abscissas `x`. Simpson's ordinary ("1/3") rule is used for odd-length arrays. For even-length arrays, Simpson's 3/8 rule is also utilized in a way that depends on the value of `even`. If `even` is negative (positive), the 3/8 rule is used at the beginning (end) of the array. If `even` is zero or not present, the result is as if the 3/8 rule were first used at the beginning of the array, then at the end of the array, and these two results were averaged. diff --git a/doc/specs/stdlib_specialfunctions_gamma.md b/doc/specs/stdlib_specialfunctions_gamma.md new file mode 100644 index 000000000..bd277d4d8 --- /dev/null +++ b/doc/specs/stdlib_specialfunctions_gamma.md @@ -0,0 +1,437 @@ +--- +title: specialfunctions_gamma +--- + +# Special functions gamma + +[TOC] + +## `gamma` - Calculate the gamma function + +### Status + +Experimental + +### Description + +The gamma function is defined as the analytic continuation of a convergent improper integral function on the whole complex plane except zero and negative integers: + +\Gamma(z)=\int_{0}^{\infty}x^{z-1}e^{-x}dx, \;\; z\in \mathbb{C} \setminus 0, -1, -2, \cdots + +Fortran 2018 standard implements the intrinsic gamma function of real type argument in single and double precisions. Here the gamma function is extended to both integer and complex arguments. The values of the gamma function with integer arguments are exact. The values of the gamma function with complex arguments are approximated in single and double precisions by using Lanczos approximation. + +### Syntax + +`result = [[stdlib_specialfunctions_gamma(module):gamma(interface)]] (x)` + +### Class + +Elemental function + +### Arguments + +`x`: should be a positive integer or a complex type number + +### Return value + +The function returns a value with the same type and kind as input argument. + +### Example +```fortran +program demo_gamma + use stdlib_kinds, only : dp, int64 + use stdlib_specialfunctions_gamma, only : gamma + implicit none + + integer :: i + integer(int64) :: n + real :: x + real(dp) :: y + complex :: z + complex(dp) :: z1 + + i = 10 + n = 15_int64 + x = 2.5 + y = 4.3_dp + z = (2.3, 0.6) + z1 = (-4.2_dp, 3.1_dp) + + print *, gamma(i) !integer gives exact result +! 362880 + + print *, gamma(n) +! 87178291200 + + print *, gamma(x) ! intrinsic function call +! 1.32934034 + + print *, gamma(y) ! intrinsic function call +! 8.8553433604540341 + + print *, gamma(z) +! (0.988054395, 0.383354813) + + print *, gamma(z1) +! (-2.78916032990983999E-005, 9.83164600163221218E-006) +end program demo_gamma +``` + +## `log_gamma` - Calculate the natural logarithm of the gamma function + +### Status + +Experimental + +### Description + +Mathematically, logarithm of gamma function is a special function with complex arguments by itself. Due to the different branch cut structures and a different principal branch, natural logarithm of gamma function log_gamma(z) with complex argument is different from the ln(Gamma(z)). The two have the same real part but different imaginary part. + +Fortran 2018 standard implements intrinsic log_gamma function of absolute value of real type argument in single and double precision. Here the log_gamma function is extended to both integer and complex arguments. The values of log_gamma function with complex arguments are approximated in single and double precisions by using Stirling's approximation. + +### Syntax + +`result = [[stdlib_specialfunctions_gamma(module):log_gamma(interface)]] (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a positive integer or a complex type number. + +### Return value + +The function returns real single precision values for integer input arguments, while it returns complex values with the same kind as complex input arguments. + +### Example + +```fortran +program demo_log_gamma + use stdlib_kinds, only : dp + use stdlib_specialfunctions_gamma, only : log_gamma + implicit none + + integer :: i + real :: x + real(dp) :: y + complex :: z + complex(dp) :: z1 + + i = 10 + x = 8.76 + y = x + z = (5.345, -3.467) + z1 = z + print *, log_gamma(i) !default single precision output +!12.8018274 + + print *, log_gamma(x) !intrinsic function call + +!10.0942659 + + print *, log_gamma(y) !intrinsic function call + +!10.094265528673880 + + print *, log_gamma(z) !same kind as input + +!(2.56165648, -5.73382425) + + print *, log_gamma(z1) + +!(2.5616575105114614, -5.7338247782852498) +end program demo_log_gamma +``` + +## `log_factorial` - calculate the logarithm of a factorial + +### Status + +Experimental + +### Description + +Compute the natural logarithm of factorial, log(n!) + +### Syntax + +`result = [[stdlib_specialfunctions_gamma(module):log_factorial(interface)]] (x)` + +### Class + +Elemental function + +### Arguments + +`x`: Shall be a positive integer type number. + +### Return value + +The function returns real type values with single precision. + +### Example +```fortran +program demo_log_factorial + use stdlib_kinds, only : int64 + use stdlib_specialfunctions_gamma, only : lf => log_factorial + implicit none + integer :: n + + n = 10 + print *, lf(n) + +! 15.1044130 + + print *, lf(35_int64) + +! 92.1361771 +end program demo_log_factorial +``` + +## `lower_incomplete_gamma` - calculate lower incomplete gamma integral + +### Status + +Experimental + +### Description + +The lower incomplete gamma function is defined as: + +\gamma(p,x)=\int_{0}^{x}t^{p-1}e^{-t}dt, \;\; p > 0, x\in \mathbb{R} + +When x < 0, p must be positive integer. + +### Syntax + +`result = [[stdlib_specialfunctions_gamma(module):lower_incomplete_gamma(interface)]] (p, x)` + +### Class + +Elemental function + +### Arguments + +`p`: is a positive integer or real type argument. + +`x`: is a real type argument. + +### Return value + +The function returns a real type value with the same kind as argument x. + +### Example +```fortran +program demo_ligamma + use stdlib_specialfunctions_gamma, only : lig => lower_incomplete_gamma + implicit none + integer :: p + real :: p1, x + + p = 3 + p1 = 2.3 + print *, lig(p, -5.0) + +! -2521.02417 + + print *, lig(p1, 5.0) + +! 1.09715652 +end demo_ligamma +``` + +## `upper_incomplete_gamma` - calculate the upper incomplete gamma integral + +### Status + +Experimental + +### Description + +The upper incomplete gamma function is defined as: + +\Gamma (p, x) = \int_{x}^{\infty }t^{p-1}e^{-t}dt, \; \; p >0,\; x \in \mathbb{R} + +When x < 0, p must be a positive integer. + +### Syntax + +`result = [[stdlib_specialfunctions_gamma(module):upper_incomplete_gamma(interface)]] (p, x)` + +### Class + +Elemental function + +### Arguments + +`p`: is a positive integer or real type argument. + +`x`: is a real type argument. + +### Return value + +The function returns a real type value with the same kind as argument x. + +### Example +```fortran +program demo_uigamma + use stdlib_specialfunctions_gamma, only : uig => upper_incomplete_gamma + implicit none + + print *, uig(3, -5.0) + +!2523.02295 + + print *, uig(2.3, 5.0) + +!6.95552528E-02 +end program demo_uigamma +``` + +## `log_lower_incomplete_gamma` - calculate the natural logarithm of the lower incomplete gamma integral + +### Status + +Experimental + +### Description + +Compute the natural logarithm of the absolute value of the lower incomplete gamma function. + +### Syntax + +`result = [[stdlib_specialfunctions_gamma(module):log_lower_incomplete_gamma(interface)]] (p, x)` + +### Class + +Elemental function + +### Arguments + +`p`: is a positive integer or real type argument. + +`x`: is a real type argument. + +### Return value + +The function returns a real type value with the same kind as argument x. + + +## `log_upper_incomplete_gamma` - calculate logarithm of the upper incomplete gamma integral + +### Status + +Experimental + +### Description + +Compute the natural logarithm of the absolute value of the upper incomplete gamma function. + +### Syntax + +`result = [[stdlib_specialfunctions_gamma(module):log_upper_incomplete_gamma(interface)]] (p, x)` + +### Class + +Elemental function + +### Arguments + +`p`: is a positive integer or real type argument. + +`x`: is a real type argument. + +### Return value + +The function returns a real type value with the same kind as argument x. + + +## `regularized_gamma_p` - calculate the gamma quotient P + +### Status + +Experimental + +### Description + +The regularized gamma quotient P, also known as normalized incomplete gamma function, is defined as: + +P(p,x)=\gamma(p,x)/\Gamma(p) + +The values of regularized gamma P is in the range of [0, 1] + +### Syntax + +`result = [[stdlib_specialfunctions_gamma(module):regularized_gamma_p(interface)]] (p, x)` + +### Class + +Elemental function + +### Arguments + +`p`: is a positive integer or real type argument. + +`x`: is a real type argument. + +### Return value + +The function returns a real type value with the same kind as argument x. + +### Example +```fortran +program demo_gamma_p + use stdlib_specialfunctions_gamma, only : rgp => regularized_gamma_p + implicit none + + print *, rgp(3.0, 5.0) + +! 0.875347972 +end program demo_gamma_p +``` + +## `regularized_gamma_q` - calculate the gamma quotient Q + +### Status + +Experimental + +### Description + +The regularized gamma quotient Q is defined as: + +Q(p,x)=\Gamma(p,x)/\Gamma(p)=1-P(p,x) + +The values of regularized gamma Q is in the range of [0, 1] + +### Syntax + +`result = [[stdlib_specialfunctions_gamma(module):regularized_gamma_q(interface)]] (p, x)` + +### Class + +Elemental function + +### Arguments + +`p`: is a positive integer or real type argument. + +`x`: is a real type argument. + +### Return value + +The function returns a real type value with the same kind as argument x. + +### Example +```fortran +program demo_gamma_q + use stdlib_specialfunctions_gamma, only : rgq => regularized_gamma_q + implicit none + + print *, rgq(3.0, 5.0) + +! 0.124652028 +end program demo_gamma_q +``` diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt new file mode 100644 index 000000000..40a5940a6 --- /dev/null +++ b/src/CMakeLists.txt @@ -0,0 +1,144 @@ +#### Pre-process: .fpp -> .f90 via Fypp + +# Create a list of the files to be preprocessed +set(fppFiles + stdlib_ascii.fypp + stdlib_bitsets.fypp + stdlib_bitsets_64.fypp + stdlib_bitsets_large.fypp + stdlib_hash_32bit.fypp + stdlib_hash_32bit_fnv.fypp + stdlib_hash_32bit_nm.fypp + stdlib_hash_32bit_water.fypp + stdlib_hash_64bit.fypp + stdlib_hash_64bit_fnv.fypp + stdlib_hash_64bit_pengy.fypp + stdlib_hash_64bit_spookyv2.fypp + stdlib_io.fypp + stdlib_io_npy.fypp + stdlib_io_npy_load.fypp + stdlib_io_npy_save.fypp + stdlib_kinds.fypp + stdlib_linalg.fypp + stdlib_linalg_diag.fypp + stdlib_linalg_outer_product.fypp + stdlib_optval.fypp + stdlib_selection.fypp + stdlib_sorting.fypp + stdlib_sorting_ord_sort.fypp + stdlib_sorting_sort.fypp + stdlib_sorting_sort_index.fypp + stdlib_specialfunctions_gamma.fypp + stdlib_stats.fypp + stdlib_stats_corr.fypp + stdlib_stats_cov.fypp + stdlib_stats_mean.fypp + stdlib_stats_median.fypp + stdlib_stats_moment.fypp + stdlib_stats_moment_all.fypp + stdlib_stats_moment_mask.fypp + stdlib_stats_moment_scalar.fypp + stdlib_stats_distribution_uniform.fypp + stdlib_stats_distribution_normal.fypp + stdlib_stats_distribution_exponential.fypp + stdlib_stats_var.fypp + stdlib_quadrature.fypp + stdlib_quadrature_trapz.fypp + stdlib_quadrature_simps.fypp + stdlib_random.fypp + stdlib_math.fypp + stdlib_math_linspace.fypp + stdlib_math_logspace.fypp + stdlib_math_arange.fypp + stdlib_math_is_close.fypp + stdlib_math_all_close.fypp + stdlib_math_diff.fypp + stdlib_string_type.fypp + stdlib_string_type_constructor.fypp + stdlib_strings_to_string.fypp + stdlib_strings.fypp + stdlib_version.fypp +) + + +# Custom preprocessor flags +if(DEFINED CMAKE_MAXIMUM_RANK) + set(fyppFlags "-DMAXRANK=${CMAKE_MAXIMUM_RANK}") +elseif(f03rank) + set(fyppFlags) +else() + set(fyppFlags "-DVERSION90") +endif() + +list( + APPEND fyppFlags + "-DWITH_QP=$" + "-DWITH_XDP=$" + "-DPROJECT_VERSION_MAJOR=${PROJECT_VERSION_MAJOR}" + "-DPROJECT_VERSION_MINOR=${PROJECT_VERSION_MINOR}" + "-DPROJECT_VERSION_PATCH=${PROJECT_VERSION_PATCH}" +) + +fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) + +set(SRC + stdlib_array.f90 + stdlib_error.f90 + stdlib_logger.f90 + stdlib_system.F90 + stdlib_specialfunctions.f90 + stdlib_specialfunctions_legendre.f90 + stdlib_quadrature_gauss.f90 + stdlib_stringlist_type.f90 + ${outFiles} +) + +add_library(${PROJECT_NAME} ${SRC}) + +set_target_properties( + ${PROJECT_NAME} + PROPERTIES + POSITION_INDEPENDENT_CODE ON + WINDOWS_EXPORT_ALL_SYMBOLS ON +) + +if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU AND CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 10.0) + target_compile_options( + ${PROJECT_NAME} + PRIVATE + $<$:-fno-range-check> + ) +endif() + +set(LIB_MOD_DIR ${CMAKE_CURRENT_BINARY_DIR}/mod_files/) +# We need the module directory before we finish the configure stage since the +# build interface might resolve before the module directory is generated by CMake +if(NOT EXISTS "${LIB_MOD_DIR}") + make_directory("${LIB_MOD_DIR}") +endif() + +set_target_properties(${PROJECT_NAME} PROPERTIES + Fortran_MODULE_DIRECTORY ${LIB_MOD_DIR}) +target_include_directories(${PROJECT_NAME} PUBLIC + $ + $ +) + +if(f18errorstop) + target_sources(${PROJECT_NAME} PRIVATE f18estop.f90) +else() + target_sources(${PROJECT_NAME} PRIVATE f08estop.f90) +endif() + +if(BUILD_TESTING) + enable_testing() + add_subdirectory(tests) +endif() + +install(TARGETS ${PROJECT_NAME} + EXPORT ${PROJECT_NAME}-targets + RUNTIME DESTINATION "${CMAKE_INSTALL_BINDIR}" + ARCHIVE DESTINATION "${CMAKE_INSTALL_LIBDIR}" + LIBRARY DESTINATION "${CMAKE_INSTALL_LIBDIR}" +) +install(DIRECTORY ${LIB_MOD_DIR} DESTINATION "${CMAKE_INSTALL_MODULEDIR}") diff --git a/src/stdlib_io.fypp b/src/stdlib_io.fypp index a1af943d4..c0f84932e 100644 --- a/src/stdlib_io.fypp +++ b/src/stdlib_io.fypp @@ -21,17 +21,32 @@ module stdlib_io ! Private API that is exposed so that we can test it in tests public :: parse_mode - ! Format strings with edit descriptors for each type and kind + !> Version: experimental + !> + !> Format strings with edit descriptors for each type and kind + !> ([Specification](../page/specs/stdlib_io.html)) character(*), parameter :: & - FMT_INT = '(*(i0,1x))', & - FMT_REAL_SP = '(*(es15.8e2,1x))', & - FMT_REAL_DP = '(*(es24.16e3,1x))', & - FMT_REAL_XDP = '(*(es26.18e3,1x))', & - FMT_REAL_QP = '(*(es44.35e4,1x))', & - FMT_COMPLEX_SP = '(*(es15.8e2,1x,es15.8e2))', & - FMT_COMPLEX_DP = '(*(es24.16e3,1x,es24.16e3))', & - FMT_COMPLEX_XDP = '(*(es26.18e3,1x,es26.18e3))', & - FMT_COMPLEX_QP = '(*(es44.35e4,1x,es44.35e4))' + !> Format string for integers + FMT_INT = '(i0)', & + !> Format string for single precision real numbers + FMT_REAL_SP = '(es15.8e2)', & + !> Format string for souble precision real numbers + FMT_REAL_DP = '(es24.16e3)', & + !> Format string for extended double precision real numbers + FMT_REAL_XDP = '(es26.18e3)', & + !> Format string for quadruple precision real numbers + FMT_REAL_QP = '(es44.35e4)', & + !> Format string for single precision complex numbers + FMT_COMPLEX_SP = '(es15.8e2,1x,es15.8e2)', & + !> Format string for double precision complex numbers + FMT_COMPLEX_DP = '(es24.16e3,1x,es24.16e3)', & + !> Format string for extended double precision complex numbers + FMT_COMPLEX_XDP = '(es26.18e3,1x,es26.18e3)', & + !> Format string for quadruple precision complex numbers + FMT_COMPLEX_QP = '(es44.35e4,1x,es44.35e4)' + + public :: FMT_INT, FMT_REAL_SP, FMT_REAL_DP, FMT_REAL_XDP, FMT_REAL_QP + public :: FMT_COMPLEX_SP, FMT_COMPLEX_DP, FMT_COMPLEX_XDP, FMT_COMPLEX_QP !> Version: experimental !> @@ -66,7 +81,7 @@ module stdlib_io contains #:for k1, t1 in KINDS_TYPES - subroutine loadtxt_${t1[0]}$${k1}$(filename, d) + subroutine loadtxt_${t1[0]}$${k1}$(filename, d, skiprows, max_rows) !! version: experimental !! !! Loads a 2D array from a text file. @@ -78,6 +93,13 @@ contains character(len=*), intent(in) :: filename !! The array 'd' will be automatically allocated with the correct dimensions ${t1}$, allocatable, intent(out) :: d(:,:) + !! Skip the first `skiprows` lines. If skipping more rows than present, a 0-sized array will be returned. The default is 0. + integer, intent(in), optional :: skiprows + !! Read `max_rows` lines of content after `skiprows` lines. + !! A negative value results in reading all lines. + !! A value of zero results in no lines to be read. + !! The default value is -1. + integer, intent(in), optional :: max_rows !! !! Example !! ------- @@ -96,25 +118,36 @@ contains !! ... !! integer :: s - integer :: nrow, ncol, i + integer :: nrow, ncol, i, skiprows_, max_rows_ + + skiprows_ = max(optval(skiprows, 0), 0) + max_rows_ = optval(max_rows, -1) s = open(filename) + ! determine number or rows + nrow = number_of_rows(s) + skiprows_ = min(skiprows_, nrow) + if ( max_rows_ < 0 .or. max_rows_ > (nrow - skiprows_) ) max_rows_ = nrow - skiprows_ + ! determine number of columns - ncol = number_of_columns(s) + ncol = 0 + if ( skiprows_ < nrow ) ncol = number_of_columns(s, skiprows=skiprows_) #:if 'complex' in t1 ncol = ncol / 2 #:endif - ! determine number or rows - nrow = number_of_rows(s) + allocate(d(max_rows_, ncol)) - allocate(d(nrow, ncol)) - do i = 1, nrow + do i = 1, skiprows_ + read(s, *) + end do + + do i = 1, max_rows_ #:if 'real' in t1 - read(s, FMT_REAL_${k1}$) d(i, :) + read(s, "(*"//FMT_REAL_${k1}$(1:len(FMT_REAL_${k1}$)-1)//",1x))") d(i, :) #:elif 'complex' in t1 - read(s, FMT_COMPLEX_${k1}$) d(i, :) + read(s, "(*"//FMT_COMPLEX_${k1}$(1:len(FMT_COMPLEX_${k1}$)-1)//",1x))") d(i, :) #:else read(s, *) d(i, :) #:endif @@ -150,11 +183,11 @@ contains s = open(filename, "w") do i = 1, size(d, 1) #:if 'real' in t1 - write(s, FMT_REAL_${k1}$) d(i, :) + write(s, "(*"//FMT_REAL_${k1}$(1:len(FMT_REAL_${k1}$)-1)//",1x))") d(i, :) #:elif 'complex' in t1 - write(s, FMT_COMPLEX_${k1}$) d(i, :) + write(s, "(*"//FMT_COMPLEX_${k1}$(1:len(FMT_COMPLEX_${k1}$)-1)//",1x))") d(i, :) #:elif 'integer' in t1 - write(s, FMT_INT) d(i, :) + write(s, "(*"//FMT_INT(1:len(FMT_INT)-1)//",1x))") d(i, :) #:else write(s, *) d(i, :) #:endif @@ -164,17 +197,25 @@ contains #:endfor - integer function number_of_columns(s) + integer function number_of_columns(s, skiprows) !! version: experimental !! !! determine number of columns integer,intent(in) :: s + integer, intent(in), optional :: skiprows - integer :: ios + integer :: ios, skiprows_, i character :: c logical :: lastblank + skiprows_ = optval(skiprows, 0) + rewind(s) + + do i = 1, skiprows_ + read(s, *) + end do + number_of_columns = 0 lastblank = .true. do diff --git a/src/stdlib_io_npy_load.fypp b/src/stdlib_io_npy_load.fypp index 965efd32e..01fce87a9 100644 --- a/src/stdlib_io_npy_load.fypp +++ b/src/stdlib_io_npy_load.fypp @@ -134,12 +134,12 @@ contains if (major > 1) then header_len = ichar(buf(1)) & - & + ichar(buf(2)) * 2**8 & - & + ichar(buf(3)) * 2**16 & - & + ichar(buf(4)) * 2**32 + & + ichar(buf(2)) * 256**1 & + & + ichar(buf(3)) * 256**2 & + & + ichar(buf(4)) * 256**3 else header_len = ichar(buf(1)) & - & + ichar(buf(2)) * 2**8 + & + ichar(buf(2)) * 256**1 end if allocate(character(header_len) :: dict, stat=stat) if (stat /= 0) return diff --git a/src/stdlib_io_npy_save.fypp b/src/stdlib_io_npy_save.fypp index abee741af..706c3cd90 100644 --- a/src/stdlib_io_npy_save.fypp +++ b/src/stdlib_io_npy_save.fypp @@ -60,10 +60,10 @@ contains !> String of bytes character(len=4) :: str - str = achar(mod(val, 2**8)) // & - & achar(mod(val, 2**16) / 2**8) // & - & achar(mod(val, 2**32) / 2**16) // & - & achar(val / 2**32) + str = achar(mod(val, 256**1)) // & + & achar(mod(val, 256**2) / 256**1) // & + & achar(mod(val, 256**3) / 256**2) // & + & achar(val / 256**3) end function to_bytes_i4 diff --git a/src/stdlib_math.fypp b/src/stdlib_math.fypp index 82f5961b2..c75b4d9f5 100644 --- a/src/stdlib_math.fypp +++ b/src/stdlib_math.fypp @@ -14,7 +14,7 @@ module stdlib_math public :: EULERS_NUMBER_QP #:endif public :: DEFAULT_LINSPACE_LENGTH, DEFAULT_LOGSPACE_BASE, DEFAULT_LOGSPACE_LENGTH - public :: arange, arg, argd, argpi, is_close, all_close + public :: arange, arg, argd, argpi, is_close, all_close, diff integer, parameter :: DEFAULT_LINSPACE_LENGTH = 100 integer, parameter :: DEFAULT_LOGSPACE_LENGTH = 50 @@ -287,7 +287,7 @@ module stdlib_math !> !> `arange` creates a one-dimensional `array` of the `integer/real` type !> with fixed-spaced values of given spacing, within a given interval. - !> ([Specification](../page/specs/stdlib_math.html#arange)) + !> ([Specification](../page/specs/stdlib_math.html#arange-function)) interface arange #:set RI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES #:for k1, t1 in RI_KINDS_TYPES @@ -302,7 +302,7 @@ module stdlib_math !> Version: experimental !> !> `arg` computes the phase angle in the interval (-π,π]. - !> ([Specification](../page/specs/stdlib_math.html#arg)) + !> ([Specification](../page/specs/stdlib_math.html#arg-function)) interface arg #:for k1 in CMPLX_KINDS procedure :: arg_${k1}$ @@ -312,7 +312,7 @@ module stdlib_math !> Version: experimental !> !> `argd` computes the phase angle of degree version in the interval (-180.0,180.0]. - !> ([Specification](../page/specs/stdlib_math.html#argd)) + !> ([Specification](../page/specs/stdlib_math.html#argd-function)) interface argd #:for k1 in CMPLX_KINDS procedure :: argd_${k1}$ @@ -322,7 +322,7 @@ module stdlib_math !> Version: experimental !> !> `argpi` computes the phase angle of circular version in the interval (-1.0,1.0]. - !> ([Specification](../page/specs/stdlib_math.html#argpi)) + !> ([Specification](../page/specs/stdlib_math.html#argpi-function)) interface argpi #:for k1 in CMPLX_KINDS procedure :: argpi_${k1}$ @@ -330,7 +330,7 @@ module stdlib_math end interface argpi !> Returns a boolean scalar/array where two scalar/arrays are element-wise equal within a tolerance. - !> ([Specification](../page/specs/stdlib_math.html#is_close)) + !> ([Specification](../page/specs/stdlib_math.html#is_close-function)) interface is_close #:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES #:for k1, t1 in RC_KINDS_TYPES @@ -345,7 +345,7 @@ module stdlib_math !> Version: experimental !> !> Returns a boolean scalar where two arrays are element-wise equal within a tolerance. - !> ([Specification](../page/specs/stdlib_math.html#all_close)) + !> ([Specification](../page/specs/stdlib_math.html#all_close-function)) interface all_close #:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES #:set RANKS = range(1, MAXRANK + 1) @@ -359,6 +359,28 @@ module stdlib_math #:endfor #:endfor end interface all_close + + !> Version: experimental + !> + !> Computes differences between adjacent elements of an array. + !> ([Specification](../page/specs/stdlib_math.html#diff-function)) + interface diff + #:set RI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES + #:for k1, t1 in RI_KINDS_TYPES + pure module function diff_1_${k1}$(x, n, prepend, append) result(y) + ${t1}$, intent(in) :: x(:) + integer, intent(in), optional :: n + ${t1}$, intent(in), optional :: prepend(:), append(:) + ${t1}$, allocatable :: y(:) + end function diff_1_${k1}$ + pure module function diff_2_${k1}$(X, n, dim, prepend, append) result(y) + ${t1}$, intent(in) :: x(:, :) + integer, intent(in), optional :: n, dim + ${t1}$, intent(in), optional :: prepend(:, :), append(:, :) + ${t1}$, allocatable :: y(:, :) + end function diff_2_${k1}$ + #:endfor + end interface diff contains @@ -387,8 +409,8 @@ contains ${t1}$, intent(in) :: z real(${k1}$) :: result - result = merge(0.0_${k1}$, atan2(z%im, z%re), z == (0.0_${k1}$, 0.0_${k1}$)) & - *180.0_${k1}$/PI_${k1}$ + result = merge(0.0_${k1}$, atan2(z%im, z%re)*180.0_${k1}$/PI_${k1}$, & + z == (0.0_${k1}$, 0.0_${k1}$)) end function argd_${k1}$ @@ -396,8 +418,9 @@ contains ${t1}$, intent(in) :: z real(${k1}$) :: result - result = merge(0.0_${k1}$, atan2(z%im, z%re), z == (0.0_${k1}$, 0.0_${k1}$)) & - /PI_${k1}$ + result = merge(0.0_${k1}$, atan2(z%im, z%re)/PI_${k1}$, & + z == (0.0_${k1}$, 0.0_${k1}$)) + end function argpi_${k1}$ #:endfor diff --git a/src/stdlib_math_diff.fypp b/src/stdlib_math_diff.fypp new file mode 100644 index 000000000..eb8cb0bc2 --- /dev/null +++ b/src/stdlib_math_diff.fypp @@ -0,0 +1,139 @@ +!> Inspired by original code (MIT license) written in 2016 by Keurfon Luu (keurfonluu@outlook.com) +!> https://github.com/keurfonluu/Forlab + +#:include "common.fypp" +#:set RI_KINDS_TYPES = REAL_KINDS_TYPES + INT_KINDS_TYPES +submodule (stdlib_math) stdlib_math_diff + + implicit none + +contains + + !> `diff` computes differences of adjacent elements of an array. + + #:for k1, t1 in RI_KINDS_TYPES + pure module function diff_1_${k1}$(x, n, prepend, append) result(y) + ${t1}$, intent(in) :: x(:) + integer, intent(in), optional :: n + ${t1}$, intent(in), optional :: prepend(:), append(:) + ${t1}$, allocatable :: y(:) + integer :: size_prepend, size_append, size_x, size_work + integer :: n_, i + + n_ = optval(n, 1) + if (n_ <= 0) then + y = x + return + end if + + size_prepend = 0 + size_append = 0 + if (present(prepend)) size_prepend = size(prepend) + if (present(append)) size_append = size(append) + size_x = size(x) + size_work = size_x + size_prepend + size_append + + if (size_work <= n_) then + allocate(y(0)) + return + end if + + !> Use a quick exit for the common case, to avoid memory allocation. + if (size_prepend == 0 .and. size_append == 0 .and. n_ == 1) then + y = x(2:) - x(1:size_x-1) + return + end if + + block + ${t1}$ :: work(size_work) + if (size_prepend > 0) work(:size_prepend) = prepend + work(size_prepend+1:size_prepend+size_x) = x + if (size_append > 0) work(size_prepend+size_x+1:) = append + + do i = 1, n_ + work(1:size_work-i) = work(2:size_work-i+1) - work(1:size_work-i) + end do + + y = work(1:size_work-n_) + end block + + end function diff_1_${k1}$ + + pure module function diff_2_${k1}$(x, n, dim, prepend, append) result(y) + ${t1}$, intent(in) :: x(:, :) + integer, intent(in), optional :: n, dim + ${t1}$, intent(in), optional :: prepend(:, :), append(:, :) + ${t1}$, allocatable :: y(:, :) + integer :: size_prepend, size_append, size_x, size_work + integer :: n_, dim_, i + + n_ = optval(n, 1) + if (n_ <= 0) then + y = x + return + end if + + size_prepend = 0 + size_append = 0 + if (present(dim)) then + if (dim == 1 .or. dim == 2) then + dim_ = dim + else + dim_ = 1 + end if + else + dim_ = 1 + end if + + if (present(prepend)) size_prepend = size(prepend, dim_) + if (present(append)) size_append = size(append, dim_) + size_x = size(x, dim_) + size_work = size_x + size_prepend + size_append + + if (size_work <= n_) then + allocate(y(0, 0)) + return + end if + + !> Use a quick exit for the common case, to avoid memory allocation. + if (size_prepend == 0 .and. size_append == 0 .and. n_ == 1) then + if (dim_ == 1) then + y = x(2:, :) - x(1:size_x-1, :) + elseif (dim_ == 2) then + y = x(:, 2:) - x(:, 1:size_x-1) + end if + return + end if + + if (dim_ == 1) then + block + ${t1}$ :: work(size_work, size(x, 2)) + if (size_prepend > 0) work(1:size_prepend, :) = prepend + work(size_prepend+1:size_x+size_prepend, :) = x + if (size_append > 0) work(size_x+size_prepend+1:, :) = append + do i = 1, n_ + work(1:size_work-i, :) = work(2:size_work-i+1, :) - work(1:size_work-i, :) + end do + + y = work(1:size_work-n_, :) + end block + + elseif (dim_ == 2) then + block + ${t1}$ :: work(size(x, 1), size_work) + if (size_prepend > 0) work(:, 1:size_prepend) = prepend + work(:, size_prepend+1:size_x+size_prepend) = x + if (size_append > 0) work(:, size_x+size_prepend+1:) = append + do i = 1, n_ + work(:, 1:size_work-i) = work(:, 2:size_work-i+1) - work(:, 1:size_work-i) + end do + + y = work(:, 1:size_work-n_) + end block + + end if + + end function diff_2_${k1}$ + #:endfor + +end submodule stdlib_math_diff \ No newline at end of file diff --git a/src/stdlib_quadrature_gauss.f90 b/src/stdlib_quadrature_gauss.f90 index 0a346db48..fd1afa1e6 100644 --- a/src/stdlib_quadrature_gauss.f90 +++ b/src/stdlib_quadrature_gauss.f90 @@ -56,8 +56,6 @@ pure module subroutine gauss_legendre_fp64 (x, w, interval) if (present(interval)) then associate ( a => interval(1) , b => interval(2) ) x = 0.5_dp*(b-a)*x+0.5_dp*(b+a) - x(1) = interval(1) - x(size(x)) = interval(2) w = 0.5_dp*(b-a)*w end associate end if diff --git a/src/stdlib_specialfunctions_gamma.fypp b/src/stdlib_specialfunctions_gamma.fypp new file mode 100644 index 000000000..7129fddf4 --- /dev/null +++ b/src/stdlib_specialfunctions_gamma.fypp @@ -0,0 +1,1289 @@ +#:set WITH_QP = False +#:set WITH_XDP = False +#:include "common.fypp" +#:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES +module stdlib_specialfunctions_gamma + use iso_fortran_env, only : qp => real128 + use stdlib_kinds, only : sp, dp, int8, int16, int32, int64 + use stdlib_error, only : error_stop + + implicit none + private + + integer(int8), parameter :: max_fact_int8 = 6_int8 + integer(int16), parameter :: max_fact_int16 = 8_int16 + integer(int32), parameter :: max_fact_int32 = 13_int32 + integer(int64), parameter :: max_fact_int64 = 21_int64 + + #:for k1, t1 in REAL_KINDS_TYPES + ${t1}$, parameter :: tol_${k1}$ = epsilon(1.0_${k1}$) + #:endfor + real(qp), parameter :: tol_qp = epsilon(1.0_qp) + + + + public :: gamma, log_gamma, log_factorial + public :: lower_incomplete_gamma, log_lower_incomplete_gamma + public :: upper_incomplete_gamma, log_upper_incomplete_gamma + public :: regularized_gamma_p, regularized_gamma_q + + + + interface gamma + !! Gamma function for integer and complex numbers + !! + #:for k1, t1 in CI_KINDS_TYPES + module procedure gamma_${t1[0]}$${k1}$ + #:endfor + end interface gamma + + + + interface log_gamma + !! Logarithm of gamma function + !! + #:for k1, t1 in CI_KINDS_TYPES + module procedure l_gamma_${t1[0]}$${k1}$ + #:endfor + end interface log_gamma + + + + interface log_factorial + !! Logarithm of factorial n!, integer variable + !! + #:for k1, t1 in INT_KINDS_TYPES + module procedure l_factorial_${t1[0]}$${k1}$ + #:endfor + end interface log_factorial + + + + interface lower_incomplete_gamma + !! Lower incomplete gamma function + !! + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + module procedure ingamma_low_${t1[0]}$${k1}$${k2}$ + #:endfor + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + module procedure ingamma_low_${t1[0]}$${k1}$ + #:endfor + end interface lower_incomplete_gamma + + + + interface log_lower_incomplete_gamma + !! Logarithm of lower incomplete gamma function + !! + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + module procedure l_ingamma_low_${t1[0]}$${k1}$${k2}$ + #:endfor + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + module procedure l_ingamma_low_${t1[0]}$${k1}$ + #:endfor + end interface log_lower_incomplete_gamma + + + + interface upper_incomplete_gamma + !! Upper incomplete gamma function + !! + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + module procedure ingamma_up_${t1[0]}$${k1}$${k2}$ + #:endfor + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + module procedure ingamma_up_${t1[0]}$${k1}$ + #:endfor + end interface upper_incomplete_gamma + + + + interface log_upper_incomplete_gamma + !! Logarithm of upper incomplete gamma function + !! + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + module procedure l_ingamma_up_${t1[0]}$${k1}$${k2}$ + #:endfor + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + module procedure l_ingamma_up_${t1[0]}$${k1}$ + #:endfor + end interface log_upper_incomplete_gamma + + + + interface regularized_gamma_p + !! Regularized (normalized) lower incomplete gamma function, P + !! + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + module procedure regamma_p_${t1[0]}$${k1}$${k2}$ + #:endfor + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + module procedure regamma_p_${t1[0]}$${k1}$ + #:endfor + end interface regularized_gamma_p + + + + interface regularized_gamma_q + !! Regularized (normalized) upper incomplete gamma function, Q + !! + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + module procedure regamma_q_${t1[0]}$${k1}$${k2}$ + #:endfor + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + module procedure regamma_q_${t1[0]}$${k1}$ + #:endfor + end interface regularized_gamma_q + + + + interface gpx + ! Incomplete gamma G function. + ! Internal use only + ! + #:for k1, t1 in REAL_KINDS_TYPES + module procedure gpx_${t1[0]}$${k1}$ !for real p and x + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + module procedure gpx_${t1[0]}$${k1}$${k2}$ !for integer p and real x + #:endfor + #:endfor + end interface gpx + + + + interface l_gamma + ! Logarithm of gamma with integer argument for designated output kind. + ! Internal use only + ! + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + module procedure l_gamma_${t1[0]}$${k1}$${k2}$ + #:endfor + #:endfor + end interface l_gamma + + + + + +contains + + #:for k1, t1 in INT_KINDS_TYPES + impure elemental function gamma_${t1[0]}$${k1}$(z) result(res) + ${t1}$, intent(in) :: z + ${t1}$ :: res, i + ${t1}$, parameter :: zero = 0_${k1}$, one = 1_${k1}$ + + if(z <= zero) call error_stop("Error(gamma): Gamma function argument" & + //" must be positive integer.") + + if(z > max_fact_${k1}$) call error_stop("Error(gamma): Gamma function" & + //" integer argument is greater than the upper limit from which an"& + //" integer overflow will be generated. Suggest switch to high " & + //" precision or convert to real data type") + + res = one + + do i = one, z - one + + res = res * i + + end do + + end function gamma_${t1[0]}$${k1}$ + + #:endfor + + + + + #:for k1, t1 in CMPLX_KINDS_TYPES + #:if k1 == "sp" + #:set k2 = "dp" + #:elif k1 == "dp" + #:set k2 = "qp" + #:endif + #:set t2 = "real({})".format(k2) + + impure elemental function gamma_${t1[0]}$${k1}$(z) result(res) + ${t1}$, intent(in) :: z + ${t1}$ :: res + integer :: i + + real(${k1}$), parameter :: zero_k1 = 0.0_${k1}$ + ${t2}$, parameter :: zero = 0.0_${k2}$, half = 0.5_${k2}$, & + one = 1.0_${k2}$, pi = acos(- one), sqpi = sqrt(pi) + complex(${k2}$) :: y, x, sum + + #:if k1 == "sp" + #! for single precision input, using double precision for calculation + + integer, parameter :: n = 10 + ${t2}$, parameter :: r = 10.900511_${k2}$ + ${t2}$, parameter :: d(0 : n) = [2.48574089138753566e-5_${k2}$, & + 1.05142378581721974_${k2}$, & + -3.45687097222016235_${k2}$, & + 4.51227709466894824_${k2}$, & + -2.98285225323576656_${k2}$, & + 1.05639711577126713_${k2}$, & + -1.95428773191645870e-1_${k2}$, & + 1.70970543404441224e-2_${k2}$, & + -5.71926117404305781e-4_${k2}$, & + 4.63399473359905637e-6_${k2}$, & + -2.71994908488607704e-9_${k2}$] + ! parameters from above referenced source. + + #:elif k1 == "dp" + #! for double precision input, using quadruple precision for calculation + + integer, parameter :: n = 24 + ${t2}$, parameter :: r = 25.617904_${k2}$ + ${t2}$, parameter :: d(0 : n)= & + [1.0087261714899910504854136977047144166e-11_${k2}$, & + 1.6339627701280724777912729825256860624_${k2}$, & + -1.4205787702221583745972794018472259342e+1_${k2}$, & + 5.6689501646428786119793943350900908698e+1_${k2}$, & + -1.3766376824252176069406853670529834070e+2_${k2}$, & + 2.2739972766608392140035874845640820558e+2_${k2}$, & + -2.7058382145757164380300118233258834430e+2_${k2}$, & + 2.39614374587263042692333711131832094166e+2_${k2}$, & + -1.6090450559507517723393498276315290189e+2_${k2}$, & + 8.27378183187161305711485619113605553100e+1_${k2}$, & + -3.2678977082742592701862249152153110206e+1_${k2}$, & + 9.89018079175824824537131521501652931756_${k2}$, & + -2.2762136356329318377213053650799013041_${k2}$, & + 3.93265017303573867227590563182750070164e-1_${k2}$, & + -5.0051054352146209116457193223422284239e-2_${k2}$, & + 4.57142601898244576789629257292603538238e-3_${k2}$, & + -2.8922592124650765614787233510990416584e-4_${k2}$, & + 1.20833375377219592849746118012697473202e-5_${k2}$, & + -3.1220812187551248389268359432609135033e-7_${k2}$, & + 4.55117045361638520378367871355819524460e-9_${k2}$, & + -3.2757632817493581828033170342853173968e-11_${k2}$, & + 9.49784279240135747819870224486376897253e-14_${k2}$, & + -7.9480594917454410117072562195702526836e-17_${k2}$, & + 1.04692819439870077791406760109955648941e-20_${k2}$, & + -5.8990280044857540075384586350723191533e-26_${k2}$] + ! parameters from above referenced source. + + #:endif + + + + if(abs(z % im) < tol_${k1}$) then + + res = cmplx(gamma(z % re), kind = ${k1}$) + return + + end if + + if(z % re > zero_k1) then + + y = z - one + + else + + x = cmplx(abs(z % re), - z % im, kind = ${k1}$) + y = x - one + + end if + + sum = cmplx(d(0), kind = ${k2}$) + + do i = 1, n + + sum = sum + d(i) / (y + i) + + end do + + y = exp((y + half) * log(y + half + r) - y) * sum + + y = y * 2 / sqpi !Re(z) > 0 return + + if(z % re < zero_k1 ) then + + y = - pi / (sin(pi * x) * x * y) !Re(z) < 0 return + + end if + + res = y + end function gamma_${t1[0]}$${k1}$ + + #:endfor + + + + + #:for k1, t1 in INT_KINDS_TYPES + impure elemental function l_gamma_${t1[0]}$${k1}$(z) result(res) + ! + ! Logarithm of gamma function for integer input + ! + ${t1}$, intent(in) :: z + real :: res + ${t1}$ :: i + ${t1}$, parameter :: zero = 0_${k1}$, one = 1_${k1}$, two = 2_${k1}$ + + if(z <= zero) call error_stop("Error(log_gamma): Gamma function" & + //" argument must be positive integer.") + + select case(z) + + case (one) + + res = 0.0 + + case (two :) + + res = 0.0 + + do i = one, z - one + + res = res + log(real(i)) + + end do + + end select + end function l_gamma_${t1[0]}$${k1}$ + + #:endfor + + + + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + + impure elemental function l_gamma_${t1[0]}$${k1}$${k2}$(z, x) result(res) + ! + ! Logarithm of gamma function for integer input with defined precision output + ! + ${t1}$, intent(in) :: z + ${t2}$, intent(in) :: x + ${t2}$ :: res + ${t1}$ :: i + ${t1}$, parameter :: zero = 0_${k1}$, one = 1_${k1}$, two = 2_${k1}$ + ${t2}$, parameter :: zero_k2 = 0.0_${k2}$ + + if(z <= zero) call error_stop("Error(log_gamma): Gamma function" & + //" argument must be positive integer.") + + select case(z) + + case (one) + + res = zero_k2 + + case (two :) + + res = zero_k2 + + do i = one, z - one + + res = res + log(real(i, ${k2}$)) + + end do + + end select + end function l_gamma_${t1[0]}$${k1}$${k2}$ + + #:endfor + #:endfor + + + + + #:for k1, t1 in CMPLX_KINDS_TYPES + #:if k1 == "sp" + #:set k2 = "dp" + #:elif k1 == "dp" + #:set k2 = "qp" + #:endif + #:set t2 = "real({})".format(k2) + impure elemental function l_gamma_${t1[0]}$${k1}$(z) result (res) + ! + ! log_gamma function for any complex number, excluding negative whole number + ! "Computation of special functions", Shanjie Zhang & Jianmin Jin, 1996, p.48 + ! "Computing the principal branch of log-gamma", D.E.G. Hare, + ! J. of Algorithms, 25(2), 1997 p. 221–236 + ! + ! Fortran 90 program by Jim-215-Fisher + ! + ${t1}$, intent(in) :: z + ${t1}$ :: res, z1, z2 + real(${k1}$) :: d + integer :: m, i + complex(${k2}$) :: zr, zr2, sum, s + real(${k1}$), parameter :: z_limit = 10_${k1}$, zero_k1 = 0.0_${k1}$ + integer, parameter :: n = 20 + ${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$, & + pi = acos(-one), ln2pi = log(2 * pi) + ${t2}$, parameter :: a(n) = [ & + .8333333333333333333333333333333333333333E-1_${k2}$,& + -.2777777777777777777777777777777777777778E-2_${k2}$,& + .7936507936507936507936507936507936507937E-3_${k2}$,& + -.5952380952380952380952380952380952380952E-3_${k2}$,& + .8417508417508417508417508417508417508418E-3_${k2}$,& + -.1917526917526917526917526917526917526918E-2_${k2}$,& + .6410256410256410256410256410256410256410E-2_${k2}$,& + -.2955065359477124183006535947712418300654E-1_${k2}$,& + .1796443723688305731649384900158893966944E+0_${k2}$,& + -.1392432216905901116427432216905901116427E+1_${k2}$,& + .1340286404416839199447895100069013112491E+2_${k2}$,& + -.1568482846260020173063651324520889738281E+3_${k2}$,& + .2193103333333333333333333333333333333333E+4_${k2}$,& + -.3610877125372498935717326521924223073648E+5_${k2}$,& + .6914722688513130671083952507756734675533E+6_${k2}$,& + -.1523822153940741619228336495888678051866E+8_${k2}$,& + .3829007513914141414141414141414141414141E+9_${k2}$,& + -.1088226603578439108901514916552510537473E+11_${k2}$,& + .3473202837650022522522522522522522522523E+12_${k2}$,& + -.1236960214226927445425171034927132488108E+14_${k2}$] + ! parameters from above reference + + z2 = z + + if(z % re < zero_k1) then + + z2 = cmplx(abs(z % re), - z % im, kind = ${k1}$) + 1 + + end if + + d = hypot(z2 % re, z2 % im) + z1 = z2 + m = 0 + + if(d <= z_limit) then !for small |z| + + m = ceiling(z_limit - d) + z1 = z2 + m + + end if + + zr = one / z1 + zr2 = zr * zr + + sum = (((a(20) * zr2 + a(19)) * zr2 + a(18)) * zr2 + a(17)) * zr2 + sum = (((sum + a(16)) * zr2 + a(15)) * zr2 + a(14)) * zr2 + sum = (((sum + a(13)) * zr2 + a(12)) * zr2 + a(11)) * zr2 + sum = (((sum + a(10)) * zr2 + a(9)) * zr2 + a(8)) * zr2 + sum = (((sum + a(7)) * zr2 + a(6)) * zr2 + a(5)) * zr2 + sum = (((sum + a(4)) * zr2 + a(3)) * zr2 + a(2)) * zr2 + sum = (sum + a(1)) * zr + ln2pi / 2 - z1 + (z1 - 0.5_${k2}$) * log(z1) + + if(m /= 0) then + + s = cmplx(zero, zero, kind = ${k2}$) + + do i = 1, m + + s = s + log(cmplx(z1, kind = ${k2}$) - i) + + end do + + sum = sum - s + + end if + + if(z % re < zero_k1) then + + sum = log(pi) - log(sin(pi * z)) - sum + m = ceiling((2 * z % re - 3) / 4) + sum % im = sum % im + 2 * pi * m * sign(1.0_${k1}$, z % im) + + end if + + res = cmplx(sum, kind = ${k1}$) + end function l_gamma_${t1[0]}$${k1}$ + + #:endfor + + + + + #:for k1, t1 in INT_KINDS_TYPES + impure elemental function l_factorial_${t1[0]}$${k1}$(n) result(res) + ! + ! Log(n!) + ! + ${t1}$, intent(in) :: n + real :: res + ${t1}$, parameter :: zero = 0_${k1}$, one = 1_${k1}$, two = 2_${k1}$ + real, parameter :: zero_k2 = 0.0 + + if(n < zero) call error_stop("Error(l_factorial): Logarithm of" & + //" factorial function argument must be non-negative") + + select case(n) + + case (zero) + + res = zero_k2 + + case (one) + + res = zero_k2 + + case (two : ) + + res = l_gamma(n + 1, 1.0D0) + + end select + end function l_factorial_${t1[0]}$${k1}$ + + #:endfor + + + + #:for k1, t1 in REAL_KINDS_TYPES + #:if k1 == "sp" + #:set k2 = "dp" + #:elif k1 == "dp" + #:set k2 = "qp" + #:endif + #:set t2 = "real({})".format(k2) + + impure elemental function gpx_${t1[0]}$${k1}$(p, x) result(res) + ! + ! Approximation of incomplete gamma G function with real argument p. + ! + ! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and + ! Accurate Evaluation of a Generalized Incomplete Gamma Function", ACM + ! Transactions on Mathematical Software, March 2020. + ! + ! Fortran 90 program by Jim-215-Fisher + ! + ${t1}$, intent(in) :: p, x + integer :: n, m + + ${t2}$ :: res, p_lim, a, b, g, c, d, y, ss + ${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$ + ${t2}$, parameter :: dm = tiny(1.0_${k2}$) * 10 ** 6 + ${t1}$, parameter :: zero_k1 = 0.0_${k1}$ + + if(p <= zero_k1) call error_stop("Error(gpx): Incomplete gamma" & + //" function must have a positive parameter p") + + if(x < -9.0_${k1}$) then + + p_lim = 5.0_${k1}$ * (sqrt(abs(x)) - 1.0_${k1}$) + + elseif(x >= -9.0_${k1}$ .and. x <= zero_k1) then + + p_lim = zero_k1 + + else + + p_lim = x + + endif + + if(x < zero_k1 .and. p < p_lim .and. abs(anint(p) - p) > tol_${k1}$) & + call error_stop("Error(gpx): Incomplete gamma function with " & + //"negative x must come with a whole number p not too small") + + if(p >= p_lim) then !use modified Lentz method of continued fraction + !for eq. (15) in the above reference. + a = one + b = p + g = a / b + c = a / dm + d = one / b + n = 2 + + do + + if(mod(n, 2) == 0) then + a = (one - p - n / 2) * x + else + a = (n / 2) * x + end if + + b = p - one + n + d = d * a + b + + if(d == zero) d = dm + + c = b + a / c + + if(c == zero) c = dm + + d = one / d + y = c * d + g = g * y + n = n + 1 + + if(abs(y - one) < tol_${k2}$) exit + + end do + + else if(x >= zero_k1) then !use modified Lentz method of continued + !fraction for eq. (16) in the reference. + a = one + b = x + one - p + g = a / b + c = a / dm + d = one / b + n = 2 + + do + + a = (n - 1) * (1 + p - n) + b = b + 2 + d = d * a + b + + if(d == zero) d = dm + + c = b + a / c + + if(c == zero) c = dm + + d = one / d + y = c * d + g = g * y + n = n + 1 + + if(abs(y - one) < tol_${k2}$) exit + + end do + + else !Algorithm 2 in the reference + + m = nint(ss) + a = - x + c = one / a + d = p - one + b = c * (a - d) + n = 1 + + do + + c = d * (d - one) / (a * a) + d = d - 2 + y = c * (a - d) + b = b + y + n = n + 1 + + if(n > int((p - 2) / 2) .or. y < b * tol_${k2}$) exit + + end do + + if(y >= b * tol_${k2}$ .and. mod(m , 2) /= 0) b = b + d * c / a + + g = ((-1) ** m * exp(-a + log_gamma(p) - (p - 1) * log(a)) + b) / a + end if + + res = g + end function gpx_${t1[0]}$${k1}$ + + #:endfor + + + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + impure elemental function gpx_${t1[0]}$${k1}$${k2}$(p, x) result(res) + ! + ! Approximation of incomplete gamma G function with integer argument p. + ! + ! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and + ! Accurate Evaluation of a Generalized Incomplete Gamma Function", ACM + ! Transactions on Mathematical Software, March 2020. + ! + ${t1}$, intent(in) :: p + ${t2}$, intent(in) :: x + ${t2}$ :: res, p_lim, a, b, g, c, d, y + integer :: n, m + ${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$ + ${t2}$, parameter :: dm = tiny(1.0_${k2}$) * 10 ** 6 + ${t1}$, parameter :: zero_k1 = 0_${k1}$, two = 2_${k1}$ + + if(p <= zero_k1) call error_stop("Error(gpx): Incomplete gamma " & + //"function must have a positive parameter p") + + if(x < -9.0_${k2}$) then + + p_lim = 5.0_${k2}$ * (sqrt(abs(x)) - 1.0_${k2}$) + + else if(x >= -9.0_${k2}$ .and. x <= zero) then + + p_lim = zero + + else + + p_lim = x + + end if + + if(real(p, ${k2}$) >= p_lim) then + + a = one + b = p + g = a / b + c = a / dm + d = one / b + n = 2 + + do + + if(mod(n, 2) == 0) then + + a = (1 - p - n / 2) * x + + else + + a = (n / 2) * x + + end if + + b = p - 1 + n + d = d * a + b + + if(d == zero) d = dm + + c = b + a / c + + if(c == zero) c = dm + + d = one / d + y = c * d + g = g * y + n = n + 1 + + if(abs(y - one) < tol_${k2}$) exit + + end do + + else if(x >= zero) then + + a = one + b = x + 1 - p + g = a / b + c = a / dm + d = one / b + n = 2 + + do + + a = -(n - 1) * (n - 1 - p) + b = b + 2 + d = d * a + b + + if(d == zero) d = dm + + c = b + a / c + + if(c == zero) c = dm + + d = one / d + y = c * d + g = g * y + n = n + 1 + + if(abs(y - one) < tol_${k2}$) exit + + end do + + else + + a = -x + c = one / a + d = p - 1 + b = c * (a - d) + n = 1 + + do + + c = d * (d - one) / (a * a) + d = d - 2 + y = c * ( a - d) + b = b + y + n = n + 1 + + if(int(n, ${k1}$) > (p - two) / two .or. y < b * tol_${k2}$) exit + + end do + + if(y >= b * tol_${k2}$ .and. mod(p, two) /= zero_k1) & + b = b + d * c / a + + g = ((-1) ** p * exp(-a + l_gamma(p, one) - (p - 1) * log(a)) & + + b ) / a + + end if + + res = g + end function gpx_${t1[0]}$${k1}$${k2}$ + + #:endfor + #:endfor + + + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function ingamma_low_${t1[0]}$${k1}$(p, x) result(res) + ! + ! Approximation of lower incomplete gamma function with real p. + ! + ${t1}$, intent(in) :: p, x + ${t1}$ :: res, s1, y + ${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$ + + if(x == zero) then + + res = zero + + else if(x > p) then + + s1 = log_gamma(p) + y = one - exp(-x + p * log(x) - s1) * gpx(p, x) + res = exp(s1 + log(y)) + + else if(x <= p .and. x > zero) then + + s1 = -x + p * log(x) + res = gpx(p, x) * exp(s1) + + else + + call error_stop("Error(Logarithm of upper incomplete gamma " & + //"function): negative x must be with integer p") + + end if + end function ingamma_low_${t1[0]}$${k1}$ + + #:endfor + + + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + impure elemental function ingamma_low_${t1[0]}$${k1}$${k2}$(p, x) & + result(res) + ! + ! Approximation of lower incomplete gamma function with integer p. + ! + ${t1}$, intent(in) :: p + ${t2}$, intent(in) :: x + ${t2}$ :: res, s1, y + ${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$ + + if(x == zero) then + + res = zero + + else if(x > real(p, ${k2}$)) then + + s1 = l_gamma(p, one) + y = one - exp(-x + p * log(x) - s1) * gpx(p, x) + res = exp(s1 + log(y)) + + else if(x <= real(p, ${k2}$) .and. x > zero) then + + s1 = -x + p * log(x) + res = gpx(p, x) * exp(s1) + + else + + s1 = -x + p * log(abs(x)) + res = gpx(p, x) * exp(s1) + res = (-1) ** p * res + + end if + end function ingamma_low_${t1[0]}$${k1}$${k2}$ + + #:endfor + #:endfor + + + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function l_ingamma_low_${t1[0]}$${k1}$(p, x) result(res) + + ${t1}$, intent(in) :: p, x + ${t1}$ :: res, s1, y + ${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$ + + + if(x == zero) then + + res = zero + + else if(x > p) then + + s1 = log_gamma(p) + y = one - exp(-x + p * log(x) - s1) * gpx(p, x) + res = s1 + log(y) + + else if(x <= p .and. x > zero) then + + s1 = -x + p * log(abs(x)) + res = log(abs(gpx(p, x))) + s1 + + else + + call error_stop("Error(Logarithm of upper incomplete gamma " & + //"function): negative x must be with integer p") + + end if + end function l_ingamma_low_${t1[0]}$${k1}$ + + #:endfor + + + + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + impure elemental function l_ingamma_low_${t1[0]}$${k1}$${k2}$(p, x) & + result(res) + + ${t1}$, intent(in) :: p + ${t2}$, intent(in) :: x + ${t2}$ :: res, s1, y + ${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$ + + if(x == zero) then + + res = zero + + else if(x > real(p, ${k2}$)) then + + s1 = l_gamma(p, one) + y = one - exp(-x + p * log(x) - s1) * gpx(p, x) + res = s1 + log(y) + + else if(x <= real(p, ${k2}$)) then + + s1 = -x + p * log(abs(x)) + res = log(abs(gpx(p, x))) + s1 + + end if + end function l_ingamma_low_${t1[0]}$${k1}$${k2}$ + + #:endfor + #:endfor + + + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function ingamma_up_${t1[0]}$${k1}$(p, x) result(res) + ! + ! Approximation of upper incomplete gamma function with real p. + ! + ${t1}$, intent(in) :: p, x + ${t1}$ :: res, s1, y + ${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$ + + if(x == zero) then + + res = gamma(p) + + else if(x > p) then + + s1 = -x + p * log(x) + res = gpx(p, x) * exp(s1) + + else if(x <= p .and. x > zero) then + + y = log_gamma(p) + s1 = -x + p * log(x) - y + res = (one - gpx(p, x) * exp(s1)) * exp(y) + + else + + + call error_stop("Error(Logarithm of upper incomplete gamma " & + //"function): negative x must be with integer p") + + end if + end function ingamma_up_${t1[0]}$${k1}$ + + #:endfor + + + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + impure elemental function ingamma_up_${t1[0]}$${k1}$${k2}$(p, x) & + result(res) + ! + ! Approximation of upper incomplete gamma function with integer p. + ! + ${t1}$, intent(in) :: p + ${t2}$, intent(in) :: x + ${t2}$ :: res, s1, y + ${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$ + + if(x == zero) then + + res = gamma(real(p, ${k2}$)) + + else if(x > real(p, ${k2}$)) then + + s1 = -x + p * log(x) + res = gpx(p, x) * exp(s1) + + else if(x <= real(p, ${k2}$) .and. x > zero) then + + y = l_gamma(p, one) + s1 = -x + p * log(x) - y + res = gpx(p, x) * exp(s1) + res = (one - res) * exp(y) + + else + + y = l_gamma(p, one) + s1 = -x + p * log(abs(x)) - y + res = gpx(p, x) * exp(s1) + res = (one - (-1) ** p * res) * exp(y) + + end if + end function ingamma_up_${t1[0]}$${k1}$${k2}$ + + #:endfor + #:endfor + + + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function l_ingamma_up_${t1[0]}$${k1}$(p, x) result(res) + + ${t1}$, intent(in) :: p, x + ${t1}$ :: res, s1, y + ${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$ + + + if(x == zero) then + + res = log_gamma(p) + + else if(x > p) then + + s1 = -x + p * log(x) + res = log(gpx(p, x)) + s1 + + else if(x <= p .and. x > zero) then + + y= log_gamma(p) + s1 = -x + p * log(x) - y + res = gpx(p, x) * exp(s1) + res = log(one - res) + y + + else + + call error_stop("Error(Logarithm of upper incomplete gamma " & + //"function): negative x must be with integer p") + + end if + end function l_ingamma_up_${t1[0]}$${k1}$ + + #:endfor + + + + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + impure elemental function l_ingamma_up_${t1[0]}$${k1}$${k2}$(p, x) & + result(res) + + ${t1}$, intent(in) :: p + ${t2}$, intent(in) :: x + ${t2}$ :: res, s1, y + ${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$ + + if(x == zero) then + + res = l_gamma(p, one) + + else if(x > real(p, ${k2}$)) then + + s1 = -x + p * log(x) + res = log(gpx(p, x)) + s1 + + else if(x <= real(p, ${k2}$) .and. x > zero) then + + y = l_gamma(p, one) + s1 = -x + p * log(x) - y + res = gpx(p, x) * exp(s1) + res = log(one - res) + y + + else + + y = l_gamma(p, one) + s1 = -x + p * log(abs(x)) + log(gpx(p, x)) + res = (-1) ** p * exp(s1) + res = log(abs(exp(y) - res)) + + end if + end function l_ingamma_up_${t1[0]}$${k1}$${k2}$ + + #:endfor + #:endfor + + + + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function regamma_p_${t1[0]}$${k1}$(p, x) result(res) + ! + ! Approximation of regularized incomplete gamma function P(p,x) for real p + ! + ${t1}$, intent(in) :: p, x + ${t1}$ :: res, s1 + ${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$ + + if(x < zero) call error_stop("Error(regamma_p): Regularized gamma_p" & + //" function is not defined at x < 0") + + + if(x == zero) then + + res = zero + + else if(x > p) then + + s1 = -x + p * log(x) - log_gamma(p) + res = one - exp(s1 + log(gpx(p,x))) + + else if(x <= p) then + + s1 = -x + p * log(abs(x)) - log_gamma(p) + res = exp(log(gpx(p, x)) + s1) + + end if + end function regamma_p_${t1[0]}$${k1}$ + + #:endfor + + + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + impure elemental function regamma_p_${t1[0]}$${k1}$${k2}$(p, x) result(res) + ! + ! Approximation of regularized incomplete gamma function P(p,x) for integer p + ! + ${t1}$, intent(in) :: p + ${t2}$, intent(in) :: x + ${t2}$ :: res, s1 + ${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$ + + if(x < zero) call error_stop("Error(regamma_p): Regularized gamma_p" & + //" function is not defined at x < 0") + + + if(x == zero) then + + res = zero + + else if(x > real(p, ${k2}$)) then + + s1 = -x + p * log(x) - l_gamma(p, one) + res = one - exp(s1 + log(gpx(p,x))) + + else if(x <= real(p, ${k2}$)) then + + s1 = -x + p * log(abs(x)) - l_gamma(p, one) + res = exp(log(gpx(p, x)) + s1) + + end if + end function regamma_p_${t1[0]}$${k1}$${k2}$ + + #:endfor + #:endfor + + + + #:for k1, t1 in REAL_KINDS_TYPES + impure elemental function regamma_q_${t1[0]}$${k1}$(p, x) result(res) + ! + ! Approximation of regularized incomplete gamma function Q(p,x) for real p + ! + ${t1}$, intent(in) :: p, x + ${t1}$ :: res, s1 + ${t1}$, parameter :: zero = 0.0_${k1}$, one = 1.0_${k1}$ + + if(x < zero) call error_stop("Error(regamma_p): Regularized gamma_q" & + //" function is not defined at x < 0") + + + if(x == zero) then + + res = one + + else if(x > p) then + + s1 = -x + p * log(x) - log_gamma(p) + res = exp(s1 + log(gpx(p,x))) + + else if(x <= p) then + + s1 = -x + p * log(abs(x)) - log_gamma(p) + res = one - exp(log(gpx(p, x)) + s1) + + end if + end function regamma_q_${t1[0]}$${k1}$ + + #:endfor + + + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + impure elemental function regamma_q_${t1[0]}$${k1}$${k2}$(p, x) result(res) + ! + ! Approximation of regularized incomplet gamma function Q(p,x) for integer p + ! + ${t1}$, intent(in) :: p + ${t2}$, intent(in) :: x + ${t2}$ :: res, s1 + ${t2}$, parameter :: zero = 0.0_${k2}$, one = 1.0_${k2}$ + + if(x < zero) call error_stop("Error(regamma_q): Regularized gamma_q" & + //" function is not defined at x < 0") + + + if(x == zero) then + + res = one + + else if(x > real(p, ${k2}$)) then + + s1 = -x + p * log(x) - l_gamma(p, one) + res = exp(log(gpx(p,x)) + s1) + + elseif(x <= real(p, ${k2}$)) then + + s1 = -x + p * log(abs(x)) - l_gamma(p, one) + res = one - exp(s1 + log(gpx(p,x))) + + end if + end function regamma_q_${t1[0]}$${k1}$${k2}$ + + #:endfor + #:endfor + +end module stdlib_specialfunctions_gamma diff --git a/src/tests/CMakeLists.txt b/src/tests/CMakeLists.txt index de110ca62..a4250d7ba 100644 --- a/src/tests/CMakeLists.txt +++ b/src/tests/CMakeLists.txt @@ -26,6 +26,7 @@ add_subdirectory(logger) add_subdirectory(optval) add_subdirectory(selection) add_subdirectory(sorting) +add_subdirectory(specialfunctions) add_subdirectory(stats) add_subdirectory(string) add_subdirectory(system) diff --git a/src/tests/Makefile.manual b/src/tests/Makefile.manual deleted file mode 100644 index 370f2e3c8..000000000 --- a/src/tests/Makefile.manual +++ /dev/null @@ -1,39 +0,0 @@ -.PHONY: all clean test - -LIB = libstdlib-testing.a -SRC = testdrive.F90 -OBJS = $(SRC:.F90=.o) -MODS = $(OBJS:.o=.mod) -FETCH = curl -L - -all test:: $(LIB) - -testdrive.F90: - $(FETCH) https://github.com/fortran-lang/test-drive/raw/v0.4.0/src/testdrive.F90 > $@ - -all test clean:: - $(MAKE) -f Makefile.manual --directory=array $@ - $(MAKE) -f Makefile.manual --directory=ascii $@ - $(MAKE) -f Makefile.manual --directory=bitsets $@ - $(MAKE) -f Makefile.manual --directory=hash_functions_perf $@ - $(MAKE) -f Makefile.manual --directory=hash_functions $@ - $(MAKE) -f Makefile.manual --directory=io $@ - $(MAKE) -f Makefile.manual --directory=logger $@ - $(MAKE) -f Makefile.manual --directory=optval $@ - $(MAKE) -f Makefile.manual --directory=selection $@ - $(MAKE) -f Makefile.manual --directory=sorting $@ - $(MAKE) -f Makefile.manual --directory=quadrature $@ - $(MAKE) -f Makefile.manual --directory=stats $@ - $(MAKE) -f Makefile.manual --directory=string $@ - $(MAKE) -f Makefile.manual --directory=math $@ - $(MAKE) -f Makefile.manual --directory=stringlist $@ - $(MAKE) -f Makefile.manual --directory=linalg $@ - -$(LIB): $(OBJS) - ar rcs $@ $^ - -clean:: - $(RM) $(LIB) $(OBJS) $(MODS) $(SRCGEN) - -%.o: %.F90 - $(FC) $(FFLAGS) -I.. -c $< diff --git a/src/tests/Makefile.manual.test.mk b/src/tests/Makefile.manual.test.mk deleted file mode 100644 index 3aba355e1..000000000 --- a/src/tests/Makefile.manual.test.mk +++ /dev/null @@ -1,27 +0,0 @@ -# Common Makefile rules that are included from each test subdirectory's -# Makefile - -CPPFLAGS += -I../.. -I.. -LDFLAGS += -L../.. -L.. -lstdlib-testing -lstdlib - -OBJS = $(PROGS_SRC:.f90=.o) -PROGS = $(OBJS:.o=) -TESTPROGS = $(PROGS:=TEST) - -.PHONY: all clean test $(TESTPROGS) - -all: $(PROGS) - -test: $(TESTPROGS) - -$(TESTPROGS): - ./$(@:TEST=) - -clean: - $(RM) $(PROGS) $(OBJS) $(CLEAN_FILES) - -%.o: %.f90 - $(FC) $(FFLAGS) $(CPPFLAGS) -c $< - -$(PROGS): %: %.o - $(FC) $(FFLAGS) $(CPPFLAGS) -o $@ $^ $(LDFLAGS) diff --git a/src/tests/array/Makefile.manual b/src/tests/array/Makefile.manual deleted file mode 100644 index 2a59ac3e0..000000000 --- a/src/tests/array/Makefile.manual +++ /dev/null @@ -1,4 +0,0 @@ -PROGS_SRC = test_logicalloc.f90 - - -include ../Makefile.manual.test.mk diff --git a/src/tests/ascii/Makefile.manual b/src/tests/ascii/Makefile.manual deleted file mode 100644 index 8edb7b893..000000000 --- a/src/tests/ascii/Makefile.manual +++ /dev/null @@ -1,4 +0,0 @@ -PROGS_SRC = test_ascii.f90 - - -include ../Makefile.manual.test.mk diff --git a/src/tests/bitsets/Makefile.manual b/src/tests/bitsets/Makefile.manual deleted file mode 100644 index 0ecba442e..000000000 --- a/src/tests/bitsets/Makefile.manual +++ /dev/null @@ -1,3 +0,0 @@ -PROGS_SRC = test_stdlib_bitset_64.f90 test_stdlib_bitset_large.f90 - -include ../Makefile.manual.test.mk diff --git a/src/tests/hash_functions/CMakeLists.txt b/src/tests/hash_functions/CMakeLists.txt index db8f9b0fa..eacdd727e 100755 --- a/src/tests/hash_functions/CMakeLists.txt +++ b/src/tests/hash_functions/CMakeLists.txt @@ -1,25 +1,26 @@ #ADDTEST(hash_functions) -set(SRC -nmhash_scalar.c -pengyhash.c -SpookyV2.cpp -SpookyV2Test.cpp -waterhash.c -generate_hash_arrays.cpp -) - enable_language(CXX) enable_language(C) -add_library(libc_hash ${SRC}) - -set(CMAKE_FORTRAN_LINK_EXECUTABLE " -o ") - -add_executable(test_hash_functions test_hash_functions.f90) -target_link_libraries(test_hash_functions "${PROJECT_NAME}" "test-drive::test-drive" "libc_hash") -add_test(NAME hash_functions - COMMAND $ ${CMAKE_CURRENT_BINARY_DIR} - WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) - -set_target_properties(test_hash_functions PROPERTIES LINKER_LANGUAGE FORTRAN) +ADDTEST(hash_functions) +target_sources( + test_hash_functions + PRIVATE + nmhash_scalar.c + pengyhash.c + SpookyV2.cpp + SpookyV2Test.cpp + waterhash.c + generate_hash_arrays.cpp +) +if(CMAKE_Fortran_COMPILER_ID MATCHES "^Intel") + set_target_properties(test_hash_functions PROPERTIES LINKER_LANGUAGE Fortran) +endif() +if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU AND CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 10.0) + target_compile_options( + test_hash_functions + PRIVATE + $<$:-fno-range-check> + ) +endif() diff --git a/src/tests/hash_functions/Makefile.manual b/src/tests/hash_functions/Makefile.manual deleted file mode 100644 index c933bc700..000000000 --- a/src/tests/hash_functions/Makefile.manual +++ /dev/null @@ -1,47 +0,0 @@ -CC ?= gcc -CXX ?= g++ - -CPPFLAGS += -I. -I../.. -I.. -LDFLAGS += -L../.. -L.. -lstdlib-testing -lstdlib - -PROGS = test_hash_functions -TESTPROGS = $(PROGS:=TEST) - -all: $(PROGS) - -test: $(TESTPROGS) - -$(TESTPROGS): - ./$(@:TEST=) - -test_hash_functions: test_hash_functions.f90 generate_hash_arrays.o libc_hash.a - $(FC) $(FFLAGS) $(CPPFLAGS) -L. -o $@ $^ $(LDFLAGS) -lc_hash -lstdc++ - -generate_hash_arrays.o: generate_hash_arrays.cpp libc_hash.a - $(CXX) $(CXXFLAGS) -c generate_hash_arrays.cpp -o generate_hash_arrays.o - -libc_hash.a: SpookyV2.o SpookyV2Test.o pengyhash.o nmhash_scalar.o waterhash.o - ar rcs libc_hash.a SpookyV2.o SpookyV2Test.o pengyhash.o \ - nmhash_scalar.o waterhash.o - -pengyhash.o: pengyhash.c pengyhash.h - $(CC) $(CFLAGS) $(CPPFLAGS) -c pengyhash.c -o pengyhash.o - -waterhash.o: waterhash.c waterhash.h - $(CC) $(CFLAGS) $(CPPFLAGS) -c waterhash.c -o waterhash.o - -SpookyV2.o: SpookyV2.cpp SpookyV2.h - $(CXX) $(CXXFLAGS) $(CPPFLAGS) -c SpookyV2.cpp -o SpookyV2.o - -SpookyV2Test.o: SpookyV2Test.cpp SpookyV2.h - $(CXX) $(CXXFLAGS) $(CPPFLAGS) -c SpookyV2Test.cpp -o SpookyV2Test.o - -nmhash_scalar.o: nmhash_scalar.c nmhash_scalar.h - $(CC) $(CFLAGS) $(CPPFLAGS) -c nmhash_scalar.c -o nmhash_scalar.o - -clean: - rm nmhash_scalar.o SpookyV2Test.o SpookyV2.o waterhash.o pengyhash.o \ - libc_hash.a generate_hash_arrays.o $(PROGS) *.*mod\ - *.bin - - diff --git a/src/tests/hash_functions_perf/CMakeLists.txt b/src/tests/hash_functions_perf/CMakeLists.txt index 459719c32..1c14ccbf8 100755 --- a/src/tests/hash_functions_perf/CMakeLists.txt +++ b/src/tests/hash_functions_perf/CMakeLists.txt @@ -1,2 +1,10 @@ ADDTEST(32_bit_hash_performance) ADDTEST(64_bit_hash_performance) + +if(CMAKE_Fortran_COMPILER_ID STREQUAL GNU AND CMAKE_Fortran_COMPILER_VERSION VERSION_LESS 10.0) + target_compile_options( + test_64_bit_hash_performance + PRIVATE + $<$:-fno-range-check> + ) +endif() diff --git a/src/tests/hash_functions_perf/Makefile.manual b/src/tests/hash_functions_perf/Makefile.manual deleted file mode 100755 index d3e59bd18..000000000 --- a/src/tests/hash_functions_perf/Makefile.manual +++ /dev/null @@ -1,3 +0,0 @@ -PROGS_SRC = test_64_bit_hash_performance.f90 test_32_bit_hash_performance.f90 - -include ../Makefile.manual.test.mk diff --git a/src/tests/io/Makefile.manual b/src/tests/io/Makefile.manual deleted file mode 100644 index b6335cf82..000000000 --- a/src/tests/io/Makefile.manual +++ /dev/null @@ -1,20 +0,0 @@ -SRCFYPP = \ - test_loadtxt_qp.fypp \ - test_savetxt_qp.fypp - -SRCGEN = $(SRCFYPP:.fypp=.f90) - -PROGS_SRC = test_loadtxt.f90 \ - test_savetxt.f90 \ - test_getline.f90 \ - test_npy.f90 \ - test_parse_mode.f90 \ - test_open.f90 \ - $(SRCGEN) - -$(SRCGEN): %.f90: %.fypp ../../common.fypp - fypp -I../.. $(FYPPFLAGS) $< $@ - -CLEAN_FILES = tmp*.dat io_open.dat io_open.stream $(SRCFYPP:.fypp=.f90) $(PROGS_SRC:.f90=.mod) - -include ../Makefile.manual.test.mk diff --git a/src/tests/io/test_loadtxt.f90 b/src/tests/io/test_loadtxt.f90 index cf2029ee7..a75c63e49 100644 --- a/src/tests/io/test_loadtxt.f90 +++ b/src/tests/io/test_loadtxt.f90 @@ -19,6 +19,7 @@ subroutine collect_loadtxt(testsuite) new_unittest("loadtxt_sp_huge", test_loadtxt_sp_huge), & new_unittest("loadtxt_sp_tiny", test_loadtxt_sp_tiny), & new_unittest("loadtxt_dp", test_loadtxt_dp), & + new_unittest("loadtxt_dp_max_skip", test_loadtxt_dp_max_skip), & new_unittest("loadtxt_dp_huge", test_loadtxt_dp_huge), & new_unittest("loadtxt_dp_tiny", test_loadtxt_dp_tiny), & new_unittest("loadtxt_complex", test_loadtxt_complex) & @@ -134,6 +135,29 @@ subroutine test_loadtxt_dp(error) end subroutine test_loadtxt_dp + subroutine test_loadtxt_dp_max_skip(error) + !> Error handling + type(error_type), allocatable, intent(out) :: error + real(dp), allocatable :: input(:,:), expected(:,:) + integer :: n, m + + allocate(input(10,10)) + + do m = 0, 5 + do n = 1, 11 + call random_number(input) + input = input - 0.5 + call savetxt('test_dp_max_skip.txt', input) + call loadtxt('test_dp_max_skip.txt', expected, skiprows=m, max_rows=n) + call check(error, all(input(m+1:min(n+m,10),:) == expected)) + deallocate(expected) + if (allocated(error)) return + end do + end do + + end subroutine test_loadtxt_dp_max_skip + + subroutine test_loadtxt_dp_huge(error) !> Error handling type(error_type), allocatable, intent(out) :: error diff --git a/src/tests/linalg/Makefile.manual b/src/tests/linalg/Makefile.manual deleted file mode 100644 index db51c62d4..000000000 --- a/src/tests/linalg/Makefile.manual +++ /dev/null @@ -1,14 +0,0 @@ -SRCFYPP = \ - test_linalg.fypp \ - test_linalg_matrix_property_checks.fypp - -SRCGEN = $(SRCFYPP:.fypp=.f90) - -PROGS_SRC = \ - $(SRCGEN) - -$(SRCGEN): %.f90: %.fypp ../../common.fypp - fypp -I../.. $(FYPPFLAGS) $< $@ - - -include ../Makefile.manual.test.mk diff --git a/src/tests/logger/Makefile.manual b/src/tests/logger/Makefile.manual deleted file mode 100644 index cea74fcd7..000000000 --- a/src/tests/logger/Makefile.manual +++ /dev/null @@ -1,4 +0,0 @@ -PROGS_SRC = test_stdlib_logger.f90 - - -include ../Makefile.manual.test.mk diff --git a/src/tests/math/CMakeLists.txt b/src/tests/math/CMakeLists.txt index 9d11bf765..9f9683516 100644 --- a/src/tests/math/CMakeLists.txt +++ b/src/tests/math/CMakeLists.txt @@ -7,4 +7,3 @@ fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) ADDTEST(stdlib_math) ADDTEST(linspace) ADDTEST(logspace) -ADDTEST(math_arange) diff --git a/src/tests/math/Makefile.manual b/src/tests/math/Makefile.manual deleted file mode 100644 index 5da73c5da..000000000 --- a/src/tests/math/Makefile.manual +++ /dev/null @@ -1,12 +0,0 @@ -SRCFYPP = \ - test_stdlib_math.fypp -SRCGEN = $(SRCFYPP:.fypp=.f90) - -PROGS_SRC = test_linspace.f90 test_logspace.f90 \ - test_math_arange.f90 \ - $(SRCGEN) - -$(SRCGEN): %.f90: %.fypp ../../common.fypp - fypp -I../.. $(FYPPFLAGS) $< $@ - -include ../Makefile.manual.test.mk diff --git a/src/tests/math/test_math_arange.f90 b/src/tests/math/test_math_arange.f90 deleted file mode 100644 index 71d67b5ee..000000000 --- a/src/tests/math/test_math_arange.f90 +++ /dev/null @@ -1,86 +0,0 @@ -! SPDX-Identifier: MIT - -module test_math_arange - use testdrive, only : new_unittest, unittest_type, error_type, check - use stdlib_math, only: arange - implicit none - - public :: collect_math_arange - -contains - - !> Collect all exported unit tests - subroutine collect_math_arange(testsuite) - !> Collection of tests - type(unittest_type), allocatable, intent(out) :: testsuite(:) - - testsuite = [ & - new_unittest("arange-real", test_math_arange_real), & - new_unittest("arange-integer", test_math_arange_integer) & - ] - - end subroutine collect_math_arange - - subroutine test_math_arange_real(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - ! Normal - call check(error, all(arange(3.0) == [1.0, 2.0, 3.0]), "all(arange(3.0) == [1.0,2.0,3.0]) failed.") - call check(error, all(arange(-1.0) == [1.0, 0.0, -1.0]), "all(arange(-1.0) == [1.0,0.0,-1.0]) failed.") - call check(error, all(arange(0.0, 2.0) == [0.0, 1.0, 2.0]), "all(arange(0.0,2.0) == [0.0,1.0,2.0]) failed.") - call check(error, all(arange(1.0, -1.0) == [1.0, 0.0, -1.0]), "all(arange(1.0,-1.0) == [1.0,0.0,-1.0]) failed.") - call check(error, all(arange(1.0, 1.0) == [1.0]), "all(arange(1.0,1.0) == [1.0]) failed.") - call check(error, all(arange(0.0, 2.0, 2.0) == [0.0, 2.0]), "all(arange(0.0,2.0,2.0) == [0.0,2.0]) failed.") - call check(error, all(arange(1.0, -1.0, 2.0) == [1.0, -1.0]), "all(arange(1.0,-1.0,2.0) == [1.0,-1.0]) failed.") - ! Not recommended - call check(error, all(arange(0.0, 2.0, -2.0) == [0.0, 2.0]), "all(arange(0.0,2.0,-2.0) == [0.0,2.0]) failed.") - call check(error, all(arange(1.0, -1.0, -2.0) == [1.0, -1.0]),"all(arange(1.0,-1.0,-2.0) == [1.0,-1.0]) failed.") - call check(error, all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]),"all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]) failed.") - end subroutine test_math_arange_real - - subroutine test_math_arange_integer(error) - !> Error handling - type(error_type), allocatable, intent(out) :: error - - ! Normal - call check(error, all(arange(3) == [1, 2, 3]), "all(arange(3) == [1,2,3]) failed.") - call check(error, all(arange(-1) == [1, 0, -1]), "all(arange(-1) == [1,0,-1]) failed.") - call check(error, all(arange(0, 2) == [0, 1, 2]), "all(arange(0,2) == [0,1,2]) failed.") - call check(error, all(arange(1, -1) == [1, 0, -1]), "all(arange(1,-1) == [1,0,-1]) failed.") - call check(error, all(arange(1, 1) == [1]), "all(arange(1,1) == [1]) failed.") - call check(error, all(arange(0, 2, 2) == [0, 2]), "all(arange(0,2,2) == [0,2]) failed.") - call check(error, all(arange(1, -1, 2) == [1, -1]), "all(arange(1,-1,2) == [1,-1]) failed.") - ! Not recommended - call check(error, all(arange(0, 2, -2) == [0, 2]), "all(arange(0,2,-2) == [0,2]) failed.") - call check(error, all(arange(1, -1, -2) == [1, -1]), "all(arange(1,-1,-2) == [1,-1]) failed.") - call check(error, all(arange(0, 2, 0) == [0,1,2]), "all(arange(0, 2, 0) == [0,1,2]) failed.") - end subroutine test_math_arange_integer - -end module test_math_arange - -program tester - use, intrinsic :: iso_fortran_env, only : error_unit - use testdrive, only : run_testsuite, new_testsuite, testsuite_type - use test_math_arange, only : collect_math_arange - implicit none - integer :: stat, is - type(testsuite_type), allocatable :: testsuites(:) - character(len=*), parameter :: fmt = '("#", *(1x, a))' - - stat = 0 - - testsuites = [ & - new_testsuite("math-arange", collect_math_arange) & - ] - - 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 tester diff --git a/src/tests/math/test_stdlib_math.fypp b/src/tests/math/test_stdlib_math.fypp index 4d8bb34a5..9b02f5fbe 100644 --- a/src/tests/math/test_stdlib_math.fypp +++ b/src/tests/math/test_stdlib_math.fypp @@ -4,7 +4,8 @@ module test_stdlib_math use testdrive, only : new_unittest, unittest_type, error_type, check, skip_test - use stdlib_math, only: clip, arg, argd, argpi, arange, is_close, all_close + use stdlib_math, only: clip, arg, argd, argpi, arange, is_close, all_close, diff, & + arange use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, xdp, qp implicit none @@ -51,6 +52,22 @@ contains , new_unittest("all_close-real-${k1}$", test_all_close_real_${k1}$) & , new_unittest("all_close-cmplx-${k1}$", test_all_close_cmplx_${k1}$) & #:endfor + + !> Tests for `diff` + #:for k1 in REAL_KINDS + , new_unittest("diff-real-${k1}$", test_diff_real_${k1}$) & + #:endfor + #:for k1 in INT_KINDS + , new_unittest("diff-int-${k1}$", test_diff_int_${k1}$) & + #:endfor + + !> Tests for `arange` + #:for k1 in REAL_KINDS + , new_unittest("arange-real-${k1}$", test_arange_real_${k1}$) & + #:endfor + #:for k1 in INT_KINDS + , new_unittest("arange-int-${k1}$", test_arange_int_${k1}$) & + #:endfor ] end subroutine collect_stdlib_math @@ -235,6 +252,7 @@ contains if (allocated(error)) return call check(error, abs(arg((0.0_${k1}$, 0.0_${k1}$)) - 0.0_${k1}$) < tol, & "test_zero_scalar") + if (allocated(error)) return #! and for array (180.0° see scalar version) theta = arange(-179.0_${k1}$, 179.0_${k1}$, 3.58_${k1}$) @@ -254,6 +272,7 @@ contains if (allocated(error)) return call check(error, abs(argd((0.0_${k1}$, 0.0_${k1}$)) - 0.0_${k1}$) < tol, & "test_zero_scalar") + if (allocated(error)) return #! and for array (180.0° see scalar version) theta = arange(-179.0_${k1}$, 179.0_${k1}$, 3.58_${k1}$) @@ -273,6 +292,7 @@ contains if (allocated(error)) return call check(error, abs(argpi((0.0_${k1}$, 0.0_${k1}$)) - 0.0_${k1}$) < tol, & "test_zero_scalar") + if (allocated(error)) return #! and for array (180.0° see scalar version) theta = arange(-179.0_${k1}$, 179.0_${k1}$, 3.58_${k1}$) @@ -364,6 +384,180 @@ contains end subroutine test_all_close_cmplx_${k1}$ #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + subroutine test_diff_real_${k1}$(error) + type(error_type), allocatable, intent(out) :: error + ${t1}$ :: x(6) = [${t1}$ :: 0, 5, 15, 30, 50, 75] + ${t1}$ :: A(1, 3) = reshape([${t1}$ :: 1, 3, 5], [1, 3]) + ${t1}$ :: B(2) = [${t1}$ :: 1, 2] + + !> rank-1 diff + call check(error, all_close(diff(x), [${t1}$ :: 5, 10, 15, 20, 25]), & + "diff() in test_diff_real_${k1}$ failed") + if (allocated(error)) return + call check(error, all_close(diff(x, n=0), x), & + "diff(, n=0) in test_diff_real_${k1}$ failed") + if (allocated(error)) return + call check(error, all_close(diff(x, n=2), [${t1}$ :: 5, 5, 5, 5]), & + "diff(, n=2) in test_diff_real_${k1}$ failed") + if (allocated(error)) return + + call check(error, all_close(diff(x, prepend=[${t1}$ :: 1]), [${t1}$ :: -1, 5, 10, 15, 20, 25]), & + "diff(, prepend=[${t1}$ :: 1]) in test_diff_real_${k1}$ failed") + if (allocated(error)) return + call check(error, all_close(diff(x, append=[${t1}$ :: 1]), [${t1}$ :: 5, 10, 15, 20, 25, -74]), & + "diff(, append=[${t1}$ :: 1]) in test_diff_real_${k1}$ failed") + if (allocated(error)) return + + !> rank-2 diff + call check(error, all_close(diff(reshape(A, [3,1]), n=1, dim=1), reshape([${t1}$ :: 2, 2], [2, 1])), & + "diff(, n=1, dim=1) in test_diff_real_${k1}$ failed") + if (allocated(error)) return + call check(error, all_close(diff(A, n=1, dim=2), reshape([${t1}$ :: 2, 2], [1, 2])), & + "diff(, n=1, dim=2) in test_diff_real_${k1}$ failed") + if (allocated(error)) return + + call check(error, all_close(diff(A, n=1, dim=2, prepend=reshape([${t1}$ :: 1], [1, 1]), & + append=reshape([${t1}$ :: 2], [1, 1])), reshape([${t1}$ :: 0, 2, 2, -3], [1, 4])), & + "diff(, n=1, dim=2, prepend=reshape([${t1}$ :: 1], [1, 1]), & + &append=reshape([${t1}$ :: 2], [1, 1])) in test_diff_real_${k1}$ failed") + if (allocated(error)) return + + !> size(B, dim) <= n + call check(error, size(diff(B, 2)), 0, "size(diff(B, 2)) in test_diff_real_${k1}$ failed") + if (allocated(error)) return + call check(error, size(diff(B, 3)), 0, "size(diff(B, 3)) in test_diff_real_${k1}$ failed") + + end subroutine test_diff_real_${k1}$ + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + subroutine test_diff_int_${k1}$(error) + type(error_type), allocatable, intent(out) :: error + ${t1}$ :: x(6) = [${t1}$ :: 0, 5, 15, 30, 50, 75] + ${t1}$ :: A(1, 3) = reshape([${t1}$ :: 1, 3, 5], [1, 3]) + ${t1}$ :: B(2) = [${t1}$ :: 1, 2] + + !> rank-1 diff + call check(error, all(diff(x) == [${t1}$ :: 5, 10, 15, 20, 25]), & + "diff() in test_diff_int_${k1}$ failed") + if (allocated(error)) return + call check(error, all(diff(x, n=0) == x), & + "diff(, n=0) in test_diff_int_${k1}$ failed") + if (allocated(error)) return + call check(error, all(diff(x, n=2) == [${t1}$ :: 5, 5, 5, 5]), & + "diff(, n=2) in test_diff_int_${k1}$ failed") + if (allocated(error)) return + + call check(error, all(diff(x, prepend=[${t1}$ :: 1]) == [${t1}$ :: -1, 5, 10, 15, 20, 25]), & + "diff(, prepend=[${t1}$ :: 1]) in test_diff_int_${k1}$ failed") + if (allocated(error)) return + call check(error, all(diff(x, append=[${t1}$ :: 1]) == [${t1}$ :: 5, 10, 15, 20, 25, -74]), & + "diff(, append=[${t1}$ :: 1]) in test_diff_int_${k1}$ failed") + if (allocated(error)) return + + !> rank-2 diff + call check(error, all(diff(reshape(A, [3,1]), n=1, dim=1) == reshape([${t1}$ :: 2, 2], [2, 1])), & + "diff(, n=1, dim=1) in test_diff_int_${k1}$ failed") + if (allocated(error)) return + call check(error, all(diff(A, n=1, dim=2) == reshape([${t1}$ :: 2, 2], [1, 2])), & + "diff(, n=1, dim=2) in test_diff_int_${k1}$ failed") + if (allocated(error)) return + + call check(error, all(diff(A, n=1, dim=2, prepend=reshape([${t1}$ :: 1], [1, 1]), & + append=reshape([${t1}$ :: 2], [1, 1])) == reshape([${t1}$ :: 0, 2, 2, -3], [1, 4])), & + "diff(, n=1, dim=2, prepend=reshape([${t1}$ :: 1], [1, 1]), & + &append=reshape([${t1}$ :: 2], [1, 1])) in test_diff_int_${k1}$ failed") + if (allocated(error)) return + + !> size(B, dim) <= n + call check(error, size(diff(B, 2)), 0, "size(diff(B, 2)) in test_diff_int_${k1}$ failed") + if (allocated(error)) return + call check(error, size(diff(B, 3)), 0, "size(diff(B, 3)) in test_diff_int_${k1}$ failed") + + end subroutine test_diff_int_${k1}$ + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + subroutine test_arange_real_${k1}$(error) + type(error_type), allocatable, intent(out) :: error + + ! Normal + call check(error, all_close(arange(3.0_${k1}$), [1.0_${k1}$, 2.0_${k1}$, 3.0_${k1}$]), & + "all(arange(3.0_${k1}$), [1.0_${k1}$,2.0_${k1}$,3.0_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all_close(arange(-1.0_${k1}$), [1.0_${k1}$, 0.0_${k1}$, -1.0_${k1}$]), & + "all_close(arange(-1.0_${k1}$), [1.0_${k1}$,0.0_${k1}$,-1.0_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all_close(arange(0.0_${k1}$, 2.0_${k1}$), [0.0_${k1}$, 1.0_${k1}$, 2.0_${k1}$]), & + "all_close(arange(0.0_${k1}$,2.0_${k1}$), [0.0_${k1}$,1.0_${k1}$,2.0_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all_close(arange(1.0_${k1}$, -1.0_${k1}$), [1.0_${k1}$, 0.0_${k1}$, -1.0_${k1}$]), & + "all_close(arange(1.0_${k1}$,-1.0_${k1}$), [1.0_${k1}$,0.0_${k1}$,-1.0_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all_close(arange(1.0_${k1}$, 1.0_${k1}$), [1.0_${k1}$]), & + "all_close(arange(1.0_${k1}$,1.0_${k1}$), [1.0_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all_close(arange(0.0_${k1}$, 2.0_${k1}$, 2.0_${k1}$), [0.0_${k1}$, 2.0_${k1}$]), & + "all_close(arange(0.0_${k1}$,2.0_${k1}$,2.0_${k1}$), [0.0_${k1}$,2.0_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all_close(arange(1.0_${k1}$, -1.0_${k1}$, 2.0_${k1}$), [1.0_${k1}$, -1.0_${k1}$]), & + "all_close(arange(1.0_${k1}$,-1.0_${k1}$,2.0_${k1}$), [1.0_${k1}$,-1.0_${k1}$]) failed.") + if (allocated(error)) return + + ! Not recommended + call check(error, all_close(arange(0.0_${k1}$, 2.0_${k1}$, -2.0_${k1}$), [0.0_${k1}$, 2.0_${k1}$]), & + "all_close(arange(0.0_${k1}$,2.0_${k1}$,-2.0_${k1}$), [0.0_${k1}$,2.0_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all_close(arange(1.0_${k1}$, -1.0_${k1}$, -2.0_${k1}$), [1.0_${k1}$, -1.0_${k1}$]), & + "all_close(arange(1.0_${k1}$,-1.0_${k1}$,-2.0_${k1}$), [1.0_${k1}$,-1.0_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all_close(arange(0.0_${k1}$, 2.0_${k1}$, 0.0_${k1}$), [0.0_${k1}$,1.0_${k1}$,2.0_${k1}$]), & + "all_close(arange(0.0_${k1}$, 2.0_${k1}$, 0.0_${k1}$), [0.0_${k1}$,1.0_${k1}$,2.0_${k1}$]) failed.") + end subroutine test_arange_real_${k1}$ + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + subroutine test_arange_int_${k1}$(error) + type(error_type), allocatable, intent(out) :: error + + ! Normal + call check(error, all(arange(3_${k1}$) == [1_${k1}$, 2_${k1}$, 3_${k1}$]), & + "all(arange(3_${k1}$) == [1_${k1}$,2_${k1}$,3_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all(arange(-1_${k1}$) == [1_${k1}$, 0_${k1}$, -1_${k1}$]), & + "all(arange(-1_${k1}$) == [1_${k1}$,0_${k1}$,-1_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all(arange(0_${k1}$, 2_${k1}$) == [0_${k1}$, 1_${k1}$, 2_${k1}$]), & + "all(arange(0_${k1}$,2_${k1}$) == [0_${k1}$,1_${k1}$,2_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all(arange(1_${k1}$, -1_${k1}$) == [1_${k1}$, 0_${k1}$, -1_${k1}$]), & + "all(arange(1_${k1}$,-1_${k1}$) == [1_${k1}$,0_${k1}$,-1_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all(arange(1_${k1}$, 1_${k1}$) == [1_${k1}$]), & + "all(arange(1_${k1}$,1_${k1}$) == [1_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all(arange(0_${k1}$, 2_${k1}$, 2_${k1}$) == [0_${k1}$, 2_${k1}$]), & + "all(arange(0_${k1}$,2_${k1}$,2_${k1}$) == [0_${k1}$,2_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all(arange(1_${k1}$, -1_${k1}$, 2_${k1}$) == [1_${k1}$, -1_${k1}$]), & + "all(arange(1_${k1}$,-1_${k1}$,2_${k1}$) == [1_${k1}$,-1_${k1}$]) failed.") + if (allocated(error)) return + + ! Not recommended + call check(error, all(arange(0_${k1}$, 2_${k1}$, -2_${k1}$) == [0_${k1}$, 2_${k1}$]), & + "all(arange(0_${k1}$,2_${k1}$,2_${k1}$) == [0_${k1}$,2_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all(arange(1_${k1}$, -1_${k1}$, -2_${k1}$) == [1_${k1}$, -1_${k1}$]), & + "all(arange(1_${k1}$,-1_${k1}$,2_${k1}$) == [1_${k1}$,-1_${k1}$]) failed.") + if (allocated(error)) return + call check(error, all(arange(0_${k1}$, 2_${k1}$, 0_${k1}$) == [0_${k1}$, 1_${k1}$, 2_${k1}$]), & + "all(arange(0_${k1}$,2_${k1}$,0_${k1}$) == [0_${k1}$,1_${k1}$,2_${k1}$]) failed.") + + end subroutine test_arange_int_${k1}$ + #:endfor + end module test_stdlib_math diff --git a/src/tests/quadrature/Makefile.manual b/src/tests/quadrature/Makefile.manual deleted file mode 100644 index 1d0cb9502..000000000 --- a/src/tests/quadrature/Makefile.manual +++ /dev/null @@ -1,12 +0,0 @@ -SRCFYPP = \ - test_simps.fypp \ - test_trapz.fypp -SRCGEN = $(SRCFYPP:.fypp=.f90) -PROGS_SRC = \ - test_gauss.f90 \ - $(SRCGEN) - -$(SRCGEN): %.f90: %.fypp ../../common.fypp - fypp -I../.. $(FYPPFLAGS) $< $@ - -include ../Makefile.manual.test.mk diff --git a/src/tests/quadrature/test_gauss.f90 b/src/tests/quadrature/test_gauss.f90 index 8fce773e6..dee5c9fd2 100644 --- a/src/tests/quadrature/test_gauss.f90 +++ b/src/tests/quadrature/test_gauss.f90 @@ -21,7 +21,8 @@ subroutine collect_gauss(testsuite) new_unittest("gauss-lobatto-analytic", test_gauss_lobatto_analytic), & new_unittest("gauss-lobatto-5", test_gauss_lobatto_5), & new_unittest("gauss-lobatto-32", test_gauss_lobatto_32), & - new_unittest("gauss-lobatto-64", test_gauss_lobatto_64) & + new_unittest("gauss-lobatto-64", test_gauss_lobatto_64), & + new_unittest("gauss-github-issue-619", test_fix_github_issue619) & ] end subroutine @@ -48,6 +49,25 @@ subroutine test_gauss_analytic(error) end subroutine + subroutine test_fix_github_issue619(error) + !> See github issue https://github.com/fortran-lang/stdlib/issues/619 + type(error_type), allocatable, intent(out) :: error + integer :: i + + ! test the values of nodes and weights + i = 5 + block + real(dp), dimension(i) :: x1,w1,x2,w2 + call gauss_legendre(x1,w1) + call gauss_legendre(x2,w2,interval=[-1._dp, 1._dp]) + + call check(error, all(abs(x1-x2) < 2*epsilon(x1(1)))) + if (allocated(error)) return + call check(error, all(abs(w1-w2) < 2*epsilon(w1(1)))) + end block + + end subroutine + subroutine test_gauss_5(error) !> Error handling type(error_type), allocatable, intent(out) :: error diff --git a/src/tests/selection/Makefile.manual b/src/tests/selection/Makefile.manual deleted file mode 100644 index 94a94037c..000000000 --- a/src/tests/selection/Makefile.manual +++ /dev/null @@ -1,10 +0,0 @@ -SRCFYPP = test_selection.fypp - -SRCGEN = $(SRCFYPP:.fypp=.f90) - -$(SRCGEN): %.f90: %.fypp ../../common.fypp - fypp -I../.. $(FYPPFLAGS) $< $@ - -PROGS_SRC = $(SRCGEN) - -include ../Makefile.manual.test.mk diff --git a/src/tests/sorting/Makefile.manual b/src/tests/sorting/Makefile.manual deleted file mode 100644 index 39657c8f3..000000000 --- a/src/tests/sorting/Makefile.manual +++ /dev/null @@ -1,3 +0,0 @@ -PROGS_SRC = test_sorting.f90 - -include ../Makefile.manual.test.mk diff --git a/src/tests/specialfunctions/CMakeLists.txt b/src/tests/specialfunctions/CMakeLists.txt new file mode 100644 index 000000000..caa3a96b5 --- /dev/null +++ b/src/tests/specialfunctions/CMakeLists.txt @@ -0,0 +1,10 @@ +### Pre-process: .fpp -> .f90 via Fypp + +# Create a list of the files to be preprocessed +set(fppFiles + test_specialfunctions_gamma.fypp +) + +fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) + +ADDTEST(specialfunctions_gamma) diff --git a/src/tests/optval/Makefile.manual b/src/tests/specialfunctions/Makefile.manual similarity index 74% rename from src/tests/optval/Makefile.manual rename to src/tests/specialfunctions/Makefile.manual index 37cd5f143..790744555 100644 --- a/src/tests/optval/Makefile.manual +++ b/src/tests/specialfunctions/Makefile.manual @@ -1,9 +1,7 @@ SRCFYPP = \ - test_optval.fypp -SRCGEN = $(SRCFYPP:.fypp=.f90) + test_specialfunctions_gamma.fypp -PROGS_SRC = \ - $(SRCGEN) +SRCGEN = $(SRCFYPP:.fypp=.f90) $(SRCGEN): %.f90: %.fypp ../../common.fypp fypp -I../.. $(FYPPFLAGS) $< $@ diff --git a/src/tests/specialfunctions/test_specialfunctions_gamma.fypp b/src/tests/specialfunctions/test_specialfunctions_gamma.fypp new file mode 100644 index 000000000..26421bded --- /dev/null +++ b/src/tests/specialfunctions/test_specialfunctions_gamma.fypp @@ -0,0 +1,587 @@ +#:set WITH_QP = False +#:set WITH_XDP = False +#:include "common.fypp" +#:set CI_KINDS_TYPES = INT_KINDS_TYPES + CMPLX_KINDS_TYPES +module test_specialfunctions_gamma + use testdrive, only : new_unittest, unittest_type, error_type, check + use stdlib_kinds, only: sp, dp, int8, int16, int32, int64 + use stdlib_specialfunctions_gamma, only: gamma, log_gamma, log_factorial, & + lower_incomplete_gamma, & + upper_incomplete_gamma, & + log_lower_incomplete_gamma, & + log_upper_incomplete_gamma, & + regularized_gamma_p, & + regularized_gamma_q + + implicit none + private + + public :: collect_specialfunctions_gamma + + #:for k1, t1 in REAL_KINDS_TYPES + ${t1}$, parameter :: tol_${k1}$ = 1000 * epsilon(1.0_${k1}$) + #:endfor + + + + +contains + + subroutine collect_specialfunctions_gamma(testsuite) + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("log_factorial_iint8", test_logfact_iint8) & + + #:for k1, t1 in INT_KINDS_TYPES + , new_unittest("log_factorial_${t1[0]}$${k1}$", & + test_logfact_${t1[0]}$${k1}$) & + #:endfor + + #:for k1, t1 in CI_KINDS_TYPES + , new_unittest("gamma_${t1[0]}$${k1}$", & + test_gamma_${t1[0]}$${k1}$) & + , new_unittest("log_gamma_${t1[0]}$${k1}$", & + test_loggamma_${t1[0]}$${k1}$) & + #:endfor + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + , new_unittest("lower_incomplete_gamma_${t1[0]}$${k1}$${k2}$", & + test_lincgamma_${t1[0]}$${k1}$${k2}$) & + , new_unittest("log_lower_incomplete_gamma_${t1[0]}$${k1}$${k2}$", & + test_log_lincgamma_${t1[0]}$${k1}$${k2}$) & + , new_unittest("upper_incomplete_gamma_${t1[0]}$${k1}$${k2}$", & + test_uincgamma_${t1[0]}$${k1}$${k2}$) & + , new_unittest("log_upper_incomplete_gamma_${t1[0]}$${k1}$${k2}$", & + test_log_uincgamma_${t1[0]}$${k1}$${k2}$) & + , new_unittest("regularized_gamma_p_${t1[0]}$${k1}$${k2}$", & + test_gamma_p_${t1[0]}$${k1}$${k2}$) & + , new_unittest("regularized_gamma_q_${t1[0]}$${k1}$${k2}$", & + test_gamma_q_${t1[0]}$${k1}$${k2}$) & + #:endfor + #:endfor + + #:for k1, t1 in REAL_KINDS_TYPES + , new_unittest("lower_incomplete_gamma_${t1[0]}$${k1}$", & + test_lincgamma_${t1[0]}$${k1}$) & + , new_unittest("log_lower_incomplete_gamma_${t1[0]}$${k1}$", & + test_log_lincgamma_${t1[0]}$${k1}$) & + , new_unittest("upper_incomplete_gamma_${t1[0]}$${k1}$", & + test_uincgamma_${t1[0]}$${k1}$) & + , new_unittest("log_upper_incomplete_gamma_${t1[0]}$${k1}$", & + test_log_uincgamma_${t1[0]}$${k1}$) & + , new_unittest("regularized_gamma_p_${t1[0]}$${k1}$", & + test_gamma_p_${t1[0]}$${k1}$) & + , new_unittest("regularized_gamma_q_${t1[0]}$${k1}$", & + test_gamma_q_${t1[0]}$${k1}$) & + #:endfor + ] + end subroutine collect_specialfunctions_gamma + + + + #:for k1, t1 in INT_KINDS_TYPES + + subroutine test_logfact_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 6 + integer :: i + + #:if k1 == "int8" + + ${t1}$, parameter :: x(n) = [0_${k1}$, 1_${k1}$, 2_${k1}$, 4_${k1}$, & + 5_${k1}$, 100_${k1}$] + real(sp), parameter :: ans(n) = [0.0, 0.0, 0.693147180, 3.17805383, & + 4.78749174, 3.63739376e2] + + #:elif k1 == "int16" + + ${t1}$, parameter :: x(n) = [0_${k1}$, 1_${k1}$, 2_${k1}$, 4_${k1}$, & + 7_${k1}$, 500_${k1}$] + real(sp), parameter :: ans(n) = [0.0, 0.0, 0.693147180, 3.17805383, & + 8.52516136, 2.61133046e3] + + #:elif k1 == "int32" + + ${t1}$, parameter :: x(n) = [0_${k1}$, 1_${k1}$, 2_${k1}$, 4_${k1}$, & + 12_${k1}$, 7000_${k1}$] + real(sp), parameter :: ans(n) = [0.0, 0.0, 0.693147180, 3.17805383, & + 1.99872145e1, 5.49810038e4] + + #:elif k1 == "int64" + + ${t1}$, parameter :: x(n) = [0_${k1}$, 1_${k1}$, 2_${k1}$, 4_${k1}$, & + 20_${k1}$, 90000_${k1}$] + real(sp), parameter :: ans(n) = [0.0, 0.0, 0.693147180, 3.17805383, & + 4.23356165e1, 9.36687468e5] + + #:endif + + do i = 1, n + + call check(error, log_factorial(x(i)), ans(i), "Integer kind " & + //"${k1}$ failed", thr = tol_sp, rel = .true.) + + end do + end subroutine test_logfact_${t1[0]}$${k1}$ + + #:endfor + + + + #:for k1, t1 in CI_KINDS_TYPES + + subroutine test_gamma_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + + #:if k1 == "int8" + + ${t1}$, parameter :: x(n) = [1_${k1}$, 2_${k1}$, 4_${k1}$, 6_${k1}$] + ${t1}$, parameter :: ans(n) = [1_${k1}$, 1_${k1}$, 6_${k1}$, 120_${k1}$] + + #:elif k1 == "int16" + + ${t1}$, parameter :: x(n) = [1_${k1}$, 2_${k1}$, 4_${k1}$, 8_${k1}$] + ${t1}$, parameter :: ans(n) = [1_${k1}$, 1_${k1}$, 6_${k1}$, 5040_${k1}$] + + #:elif k1 == "int32" + + ${t1}$, parameter :: x(n) = [1_${k1}$, 2_${k1}$, 4_${k1}$, 13_${k1}$] + ${t1}$, parameter :: ans(n) = [1_${k1}$, 1_${k1}$, 6_${k1}$, & + 479001600_${k1}$] + + #:elif k1 == "int64" + + ${t1}$, parameter :: x(n) = [1_${k1}$, 2_${k1}$, 4_${k1}$, 21_${k1}$] + ${t1}$, parameter :: ans(n) = [1_${k1}$, 1_${k1}$, 6_${k1}$, & + 2432902008176640000_${k1}$] + #:elif t1[0] == "c" + + ${t1}$, parameter :: x(n) = [(0.25_${k1}$, 0.25_${k1}$), & + (0.5_${k1}$, -0.5_${k1}$), & + (1.0_${k1}$, 1.0_${k1}$), & + (-1.254e1_${k1}$, -9.87_${k1}$)] + + ${t1}$, parameter :: ans(n) = & + [(1.6511332803889208_${k1}$, -1.8378758749947890_${k1}$), & + (0.81816399954174739_${k1}$, 0.76331382871398262_${k1}$),& + (0.49801566811835604_${k1}$, -0.15494982830181069_${k1}$),& + (-2.18767396709283064e-21_${k1}$, 2.77577940846953455e-21_${k1}$)] + #:endif + + + #:if t1[0] == "i" + + do i = 1, n + + call check(error, gamma(x(i)), ans(i), "Integer kind ${k1}$ failed") + + end do + + #:elif t1[0] == "c" + + do i = 1, n + + call check(error, gamma(x(i)), ans(i), "Complex kind ${k1}$ failed",& + thr = tol_${k1}$, rel = .true.) + + end do + + #:endif + end subroutine test_gamma_${t1[0]}$${k1}$ + + + + subroutine test_loggamma_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + + #:if k1 == "int8" + + ${t1}$, parameter :: x(n) = [1_${k1}$, 2_${k1}$, 10_${k1}$, 47_${k1}$] + real(sp), parameter :: ans(n) = [0.0, 0.0, 1.28018274e1, 1.32952575e2] + + #:elif k1 == "int16" + + ${t1}$, parameter :: x(n) = [1_${k1}$, 2_${k1}$, 111_${k1}$, 541_${k1}$] + real(sp), parameter :: ans(n) = [0.0, 0.0, 4.10322777e2, 2.86151221e3] + + #:elif k1 == "int32" + + ${t1}$, parameter :: x(n) = [1_${k1}$, 2_${k1}$, 2021_${k1}$, & + 42031_${k1}$] + real(sp), parameter :: ans(n) = [0.0, 0.0, 1.33586470e4, 4.05433461e5] + + #:elif k1 == "int64" + + ${t1}$, parameter :: x(n) = [1_${k1}$, 2_${k1}$, 2021_${k1}$, & + 42031_${k1}$] + real(sp), parameter :: ans(n) = [0.0, 0.0, 1.33586470e4, 4.05433461e5] + + #:elif t1[0] == "c" + + ${t1}$, parameter :: x(n) = [(0.25_${k1}$, 0.25_${k1}$), & + (0.5_${k1}$, -0.5_${k1}$), & + (1.0_${k1}$, 1.0_${k1}$), & + (-1.254e1_${k1}$, -9.87_${k1}$)] + + ${t1}$, parameter :: ans(n) = & + [(0.90447450949333889_${k1}$, -0.83887024394321282_${k1}$),& + (0.11238724280962311_${k1}$, 0.75072920212205074_${k1}$), & + (-0.65092319930185634_${k1}$, -0.30164032046753320_${k1}$),& + (-4.7091788015763380e1_${k1}$, 1.4804627819235690e1_${k1}$)] + #:endif + + + #:if t1[0] == "i" + + do i = 1, n + + call check(error, log_gamma(x(i)), ans(i), "Integer kind ${k1}$ " & + //"failed", thr = tol_sp, rel = .true.) + + end do + + #:elif t1[0] == "c" + + do i = 1, n + + call check(error, log_gamma(x(i)), ans(i), "Complex kind ${k1}$ " & + //"failed", thr = tol_${k1}$, rel = .true.) + + end do + + #:endif + end subroutine test_loggamma_${t1[0]}$${k1}$ + + #:endfor + + + + + #:for k1, t1 in INT_KINDS_TYPES + #:for k2, t2 in REAL_KINDS_TYPES + + subroutine test_lincgamma_${t1[0]}$${k1}$${k2}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$, parameter :: p(n) = [1_${k1}$, 2_${k1}$, 3_${k1}$, 2_${k1}$] + ${t2}$, parameter :: x(n) = [0.5_${k2}$, 3.5_${k2}$, -5.0_${k2}$, -10.0_${k2}$] + + ${t2}$, parameter :: ans(n) = [0.3934693402873667_${k2}$, & + 0.86411177459956675_${k2}$, & + -2.5210237047438023e3_${k2}$, & + 1.9823919215326045e5_${k2}$] + + do i = 1, n + + call check(error, lower_incomplete_gamma(p(i), x(i)), ans(i), & + "Lower incomplete gamma function with p(kind=${k1}$) and " & + //"x(kind=${k2}$) failed", thr = tol_${k2}$, rel = .true.) + + end do + + end subroutine test_lincgamma_${t1[0]}$${k1}$${k2}$ + + + + subroutine test_log_lincgamma_${t1[0]}$${k1}$${k2}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$ :: p(n) = [1_${k1}$, 2_${k1}$, 3_${k1}$, 2_${k1}$] + ${t2}$ :: x(n) = [0.5_${k2}$, 3.5_${k2}$, -5.0_${k2}$, -10.0_${k2}$] + + ${t2}$, parameter :: ans(n) = [-0.93275212956718857_${k2}$, & + -0.14605314979599791_${k2}$, & + 7.8324203300567640_${k2}$, & + 1.2197229621760137e1_${k2}$] + + do i = 1, n + + call check(error, log_lower_incomplete_gamma(p(i), x(i)), ans(i), & + "Logarithm of lower incomplete gamma function with " & + //"p(kind=${k1}$) and x(kind=${k2}$) failed", thr = tol_${k2}$, & + rel = .true.) + + end do + + end subroutine test_log_lincgamma_${t1[0]}$${k1}$${k2}$ + + + + subroutine test_uincgamma_${t1[0]}$${k1}$${k2}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$ :: p(n) = [1_${k1}$, 2_${k1}$, 3_${k1}$, 2_${k1}$] + ${t2}$ :: x(n) = [0.5_${k2}$, 3.5_${k2}$, -5.0_${k2}$, -10.0_${k2}$] + + ${t2}$, parameter :: ans(n) = [0.60653065971263342_${k2}$, & + 0.13588822540043325_${k2}$, & + 2.5230237047438022E3_${k2}$, & + -1.9823819215326045e5_${k2}$] + + do i = 1, n + + call check(error, upper_incomplete_gamma(p(i), x(i)), ans(i), & + "Logarithm of upper incomplete gamma function with " & + //"p(kind=${k1}$) and x(kind=${k2}$) failed", thr = tol_${k2}$, & + rel = .true.) + + end do + + end subroutine test_uincgamma_${t1[0]}$${k1}$${k2}$ + + + + subroutine test_log_uincgamma_${t1[0]}$${k1}$${k2}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$ :: p(n) = [1_${k1}$, 2_${k1}$, 3_${k1}$, 2_${k1}$] + ${t2}$ :: x(n) = [0.5_${k2}$, 3.5_${k2}$, -5.0_${k2}$, -10.0_${k2}$] + + ${t2}$, parameter :: ans(n) = [-0.5_${k2}$, -1.9959226032237259_${k2}$,& + 7.8332133440562161_${k2}$, & + 1.2197224577336219e1_${k2}$] + + do i = 1, n + + call check(error, log_upper_incomplete_gamma(p(i), x(i)), ans(i), & + "Logarithm of upper incomplete gamma function with " & + //"p(kind=${k1}$) and x(kind=${k2}$) failed", thr = tol_${k2}$, & + rel = .true.) + + end do + end subroutine test_log_uincgamma_${t1[0]}$${k1}$${k2}$ + + + + + subroutine test_gamma_p_${t1[0]}$${k1}$${k2}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$ :: p(n) = [1_${k1}$, 1_${k1}$, 3_${k1}$, 3_${k1}$] + ${t2}$ :: x(n) = [0.5_${k2}$, 1.5_${k2}$, 0.5_${k2}$, 3.5_${k2}$] + + ${t2}$, parameter :: ans(n) = [0.39346934028736658_${k2}$, & + 0.77686983985157017_${k2}$, & + 1.4387677966970687e-2_${k2}$, & + 0.67915280113786593_${k2}$] + + do i = 1, n + + call check(error, regularized_gamma_p(p(i), x(i)), ans(i), & + "Regularized gamma P function with p(kind=${k1}$) and " & + //"x(kind=${k2}$) failed", thr = tol_${k2}$, rel = .true.) + + end do + end subroutine test_gamma_p_${t1[0]}$${k1}$${k2}$ + + + + subroutine test_gamma_q_${t1[0]}$${k1}$${k2}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$ :: p(n) = [1_${k1}$, 1_${k1}$, 3_${k1}$, 3_${k1}$] + ${t2}$ :: x(n) = [0.5_${k2}$, 1.5_${k2}$, 0.5_${k2}$, 3.5_${k2}$] + + ${t2}$, parameter :: ans(n) = [0.60653065971263342_${k2}$, & + 0.22313016014842983_${k2}$, & + 0.98561232203302931_${k2}$, & + 0.32084719886213407_${k2}$] + + do i = 1, n + + call check(error, regularized_gamma_q(p(i), x(i)), ans(i), & + "Regularized gamma Q function with p(kind=${k1}$) and " & + //"x(kind=${k2}$) failed", thr = tol_${k2}$, rel = .true.) + + end do + end subroutine test_gamma_q_${t1[0]}$${k1}$${k2}$ + + #:endfor + #:endfor + + + + #:for k1, t1 in REAL_KINDS_TYPES + + subroutine test_lincgamma_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$ :: p(n) = [1.0_${k1}$, 2.0_${k1}$, 3.1_${k1}$, 6.5_${k1}$] + ${t1}$ :: x(n) = [0.5_${k1}$, 3.5_${k1}$, 5.0_${k1}$, 3.2_${k1}$] + + ${t1}$, parameter :: ans(n) = [0.3934693402873667_${k1}$, & + 0.86411177459956675_${k1}$, & + 1.8980559470963281_${k1}$, & + 2.0043549563092636e1_${k1}$] + + do i = 1, n + + call check(error, lower_incomplete_gamma(p(i), x(i)), ans(i), & + "Lower incomplete gamma function with p(kind=${k1}$) and " & + //"x(kind=${k1}$) failed", thr = tol_${k1}$, rel = .true.) + + end do + + end subroutine test_lincgamma_${t1[0]}$${k1}$ + + + + subroutine test_log_lincgamma_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$ :: p(n) = [1.0_${k1}$, 2.0_${k1}$, 3.1_${k1}$, 6.5_${k1}$] + ${t1}$ :: x(n) = [0.5_${k1}$, 3.5_${k1}$, 5.0_${k1}$, 3.2_${k1}$] + + ${t1}$, parameter :: ans(n) = [-0.93275212956718857_${k1}$, & + -0.14605314979599791_${k1}$, & + 0.64083017662175706_${k1}$, & + 2.9979073844388951_${k1}$] + + do i = 1, n + + call check(error, log_lower_incomplete_gamma(p(i), x(i)), ans(i), & + "Logarithm of lower incomplete gamma function with " & + //"p(kind=${k1}$) and x(kind=${k1}$) failed", thr = tol_${k1}$, & + rel = .true.) + + end do + + end subroutine test_log_lincgamma_${t1[0]}$${k1}$ + + + + subroutine test_uincgamma_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$ :: p(n) = [1.0_${k1}$, 2.0_${k1}$, 3.1_${k1}$, 6.5_${k1}$] + ${t1}$ :: x(n) = [0.5_${k1}$, 3.5_${k1}$, 5.0_${k1}$, 3.2_${k1}$] + + ${t1}$, parameter :: ans(n) = [0.60653065971263342_${k1}$, & + 0.13588822540043325_${k1}$, & + 0.29956433129614910_${k1}$, & + 2.6784172825195172e2_${k1}$] + + do i = 1, n + + call check(error, upper_incomplete_gamma(p(i), x(i)), ans(i), & + "Logarithm of upper incomplete gamma function with " & + //"p(kind=${k1}$) and x(kind=${k1}$) failed", thr = tol_${k1}$, & + rel = .true.) + + end do + + end subroutine test_uincgamma_${t1[0]}$${k1}$ + + + + subroutine test_log_uincgamma_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$ :: p(n) = [1.0_${k1}$, 2.0_${k1}$, 3.1_${k1}$, 6.5_${k1}$] + ${t1}$ :: x(n) = [0.5_${k1}$, 3.5_${k1}$, 5.0_${k1}$, 3.2_${k1}$] + + ${t1}$, parameter :: ans(n) = [-0.5_${k1}$, -1.9959226032237259_${k1}$,& + -1.2054260888453405_${k1}$, & + 5.5903962398338761_${k1}$] + + do i = 1, n + + call check(error, log_upper_incomplete_gamma(p(i), x(i)), ans(i), & + "Logarithm of upper incomplete gamma function with " & + //"p(kind=${k1}$) and x(kind=${k1}$) failed", thr = tol_${k1}$, & + rel = .true.) + + end do + end subroutine test_log_uincgamma_${t1[0]}$${k1}$ + + + + subroutine test_gamma_p_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$ :: p(n) = [1.3_${k1}$, 1.3_${k1}$, 3.7_${k1}$, 3.7_${k1}$] + ${t1}$ :: x(n) = [0.5_${k1}$, 2.1_${k1}$, 2.6_${k1}$, 5.1_${k1}$] + + ${t1}$, parameter :: ans(n) = [0.26487356764588505_${k1}$, & + 0.81011791338807457_${k1}$, & + 0.32198359288949589_${k1}$, & + 0.79435732817518852_${k1}$] + + do i = 1, n + + call check(error, regularized_gamma_p(p(i), x(i)), ans(i), & + "Regularized gamma P function with p(kind=${k1}$) and " & + //"x(kind=${k1}$) failed", thr = tol_${k1}$, rel = .true.) + + end do + end subroutine test_gamma_p_${t1[0]}$${k1}$ + + + + subroutine test_gamma_q_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: n = 4 + integer :: i + ${t1}$ :: p(n) = [1.3_${k1}$, 1.3_${k1}$, 3.7_${k1}$, 3.7_${k1}$] + ${t1}$ :: x(n) = [0.5_${k1}$, 2.1_${k1}$, 2.6_${k1}$, 5.1_${k1}$] + + ${t1}$, parameter :: ans(n) = [0.73512643235411495_${k1}$, & + 0.18988208661192543_${k1}$, & + 0.67801640711050411_${k1}$, & + 0.20564267182481148_${k1}$] + + do i = 1, n + + call check(error, regularized_gamma_q(p(i), x(i)), ans(i), & + "Regularized gamma Q function with p(kind=${k1}$) and " & + //"x(kind=${k1}$) failed", thr = tol_${k1}$, rel = .true.) + + end do + end subroutine test_gamma_q_${t1[0]}$${k1}$ + + #:endfor +end module test_specialfunctions_gamma + + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type + use test_specialfunctions_gamma, only : collect_specialfunctions_gamma + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [new_testsuite("Gamma special function", & + collect_specialfunctions_gamma)] + + 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 tester diff --git a/src/tests/stats/CMakeLists.txt b/src/tests/stats/CMakeLists.txt new file mode 100644 index 000000000..ff9d45063 --- /dev/null +++ b/src/tests/stats/CMakeLists.txt @@ -0,0 +1,34 @@ +#### Pre-process: .fpp -> .f90 via Fypp + +# Create a list of the files to be preprocessed +set(fppFiles + test_mean.fypp + test_mean_f03.fypp + test_median.fypp + test_distribution_uniform.fypp + test_distribution_normal.fypp + test_distribution_exponential.fypp +) + +fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) + +ADDTEST(corr) +ADDTEST(cov) +ADDTEST(mean) +ADDTEST(median) +ADDTEST(moment) +ADDTEST(rawmoment) +ADDTEST(var) +ADDTEST(varn) +ADDTEST(random) +ADDTEST(distribution_uniform) +ADDTEST(distribution_normal) +ADDTEST(distribution_exponential) + +if(DEFINED CMAKE_MAXIMUM_RANK) + if(${CMAKE_MAXIMUM_RANK} GREATER 7) + ADDTEST(mean_f03) + endif() +elseif(f03rank) + ADDTEST(mean_f03) +endif() diff --git a/src/tests/string/Makefile.manual b/src/tests/string/Makefile.manual deleted file mode 100644 index 8b93f625b..000000000 --- a/src/tests/string/Makefile.manual +++ /dev/null @@ -1,11 +0,0 @@ -PROGS_SRC = test_string_assignment.f90 \ - test_string_derivedtype_io.f90 \ - test_string_functions.f90 \ - test_string_intrinsic.f90 \ - test_string_match.f90 \ - test_string_operator.f90 \ - test_string_strip_chomp.f90 \ - test_string_to_string.f90 - - -include ../Makefile.manual.test.mk diff --git a/src/tests/stringlist/Makefile.manual b/src/tests/stringlist/Makefile.manual deleted file mode 100644 index 8140e758c..000000000 --- a/src/tests/stringlist/Makefile.manual +++ /dev/null @@ -1,5 +0,0 @@ -PROGS_SRC = test_insert_at.f90 \ - test_append_prepend.f90 - - -include ../Makefile.manual.test.mk From 01e990ee8df7bbbbbc8913caf9fe172e9c11a574 Mon Sep 17 00:00:00 2001 From: jim-215-fisher Date: Sat, 18 Jun 2022 00:04:48 -0400 Subject: [PATCH 39/42] delete special.fypp --- src/stdlib_stats_distribution_special.fypp | 614 --------------------- 1 file changed, 614 deletions(-) delete mode 100644 src/stdlib_stats_distribution_special.fypp diff --git a/src/stdlib_stats_distribution_special.fypp b/src/stdlib_stats_distribution_special.fypp deleted file mode 100644 index 1c71b0106..000000000 --- a/src/stdlib_stats_distribution_special.fypp +++ /dev/null @@ -1,614 +0,0 @@ -#:include "common.fypp" -#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES -#:set IR_KINDS_TYPES = INT_KINDS_TYPES + REAL_KINDS_TYPES -Module stdlib_stats_distribution_special - use stdlib_kinds - use stdlib_error, only : error_stop - - implicit none - private - real(qp), parameter :: D(0:10) = [2.48574089138753565546e-5_qp, & - 1.05142378581721974210_qp, & - -3.45687097222016235469_qp, & - 4.51227709466894823700_qp, & - -2.98285225323576655721_qp, & - 1.05639711577126713077_qp, & - -1.95428773191645869583e-1_qp, & - 1.70970543404441224307e-2_qp, & - -5.71926117404305781283e-4_qp, & - 4.63399473359905636708e-6_qp, & - -2.71994908488607703910e-9_qp] - real(qp), parameter :: R = 10.900511_qp, HALF = 0.5_qp, & - sqep = log(2.0_qp * sqrt(exp(1.0_qp) / acos(-1.0_qp))) - real(dp), parameter :: ep_machine = 2.2e-16_dp, dm = 1.0e-300_dp - - ! for stdlib_distribution internal use - - public :: loggamma, log_factorial - public :: ingamma_low, log_ingamma_low, ingamma_up, log_ingamma_up - public :: regamma_p, regamma_q - public :: beta, log_beta, inbeta - - interface loggamma - ! Logrithm of gamma function with real variable - ! - #:for k1, t1 in REAL_KINDS_TYPES - module procedure l_gamma_${t1[0]}$${k1}$ - #:endfor - end interface loggamma - - interface log_factorial - ! Logrithm of factorial n!, integer variable - ! - #:for k1, t1 in INT_KINDS_TYPES - module procedure l_factorial_1_${t1[0]}$${k1}$ !1 dummy - #:endfor - - #: for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - module procedure l_factorial_${t1[0]}$${k1}$${k2}$ !2 dummy - #:endfor - #:endfor - end interface log_factorial - - - interface ingamma_low - ! Lower incomplete gamma function - ! - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure ingamma_low_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface ingamma_low - - interface log_ingamma_low - ! Logrithm of lower incomplete gamma function - ! - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure l_ingamma_low_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface log_ingamma_low - - interface ingamma_up - ! Upper incomplete gamma function - ! - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure ingamma_up_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface ingamma_up - - interface log_ingamma_up - ! Logrithm of upper incomplete gamma function - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure l_ingamma_up_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface log_ingamma_up - - interface regamma_p - ! Regularized (normalized) lower incomplete gamma function, P - ! - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure regamma_p_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface regamma_p - - interface regamma_q - ! Regularized (normalized) upper incomplete gamma function, Q - ! - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - module procedure regamma_q_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - end interface regamma_q - - interface gpx - ! Evaluation of incomplete gamma function - ! - #:for k1, t1 in REAL_KINDS_TYPES - module procedure gpx_${t1[0]}$${k1}$ - #:endfor - - #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - module procedure gpx_${t1[0]}$${k1}$${k2}$ - #:endfor - #:endfor - end interface gpx - - interface beta - ! Beta function - ! - #:for k1, t1 in REAL_KINDS_TYPES - module procedure beta_${t1[0]}$${k1}$ - #:endfor - end interface beta - - interface log_beta - ! Logrithm of beta function - ! - #:for k1, t1 in REAL_KINDS_TYPES - module procedure l_beta_${t1[0]}$${k1}$ - #:endfor - end interface log_beta - - interface inbeta - ! Incomplete beta function - ! - #:for k1, t1 in REAL_KINDS_TYPES - module procedure inbeta_${t1[0]}$${k1}$ - #:endfor - end interface inbeta - - - contains - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function l_gamma_${t1[0]}$${k1}$(x) result (res) - ! Log gamma function for any positive real number i,e, {R+} - ! - ${t1}$, intent(in) :: x - ${t1}$ :: res - real(qp) :: q, sum - integer :: i - - if(x <= 0._${k1}$) call error_stop("Error(l_gamma): Gamma function" & - //" augument must be greater than 0") - if(x == 1.0_${k1}$ .or. x == 2.0_${k1}$) then - res = 0.0_${k1}$ - else - q = real(x, qp) - HALF - sum = D(0) - do i=1, 10 - sum = sum + D(i) / (real(x, qp) - 1.0_qp + real(i, qp)) - end do - res = real(sqep + log(sum) - q + q * log(q + R), kind=${k1}$) - endif - return - end function l_gamma_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in INT_KINDS_TYPES - impure elemental function l_factorial_1_${t1[0]}$${k1}$(n) result(res) - ! Log(n!) with single precision result, n is integer - ! - ${t1}$, intent(in) :: n - real :: res - - if(n < 0) call error_stop("Error(l_factorial): Factorial function" & - //" augument must be no less than 0") - select case(n) - case (0) - res = 0.0 - case (1) - res = 0.0 - case (2:) - res = loggamma(real(n+1, dp)) - end select - return - end function l_factorial_1_${t1[0]}$${k1}$ - #:endfor - - #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - impure elemental function l_factorial_${t1[0]}$${k1}$${k2}$(n,x) result(res) - ! Log(n!) with required prescision for result, n is integer, x is a real & - ! for specified kind - ! - ${t1}$, intent(in) :: n - ${t2}$, intent(in) :: x - ${t2}$ :: res - - if(n < 0) call error_stop("Error(l_factorial): Factorial function" & - //" augument must be no less than 0") - select case(n) - case (0) - res = 0.0_${k2}$ - case (1) - res = 0.0_${k2}$ - case (2:) - res = loggamma(real(n + 1, kind=${k2}$)) - end select - return - end function l_factorial_${t1[0]}$${k1}$${k2}$ - #:endfor - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function gpx_${t1[0]}$${k1}$(s, x) result(res) - ! Approximation of incomplete gamma G function - ! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and - ! Accurate Evaluation of a Generalized Incomplete Gamma Function", ACM - ! Transactions on Mathematical Software, March 2020. - ! - ! Fortran 90 program by Jim-215-Fisher - ! - ${t1}$, intent(in) :: x, s - real(dp) :: res - real(dp) :: a, b, g, c, d, y - integer :: n - - if(x < 0._${k1}$) then - call error_stop("Error(gpx): Incomplete gamma function with" & - //" negative x must come with integer of s") - elseif(s >= x) then - a = real(s, dp) - g = 1.0_dp / a - c = g - do - a = a + 1.0_dp - c = c * real(x, dp) / a - g = g + c - if(abs(c) < ep_machine) exit - end do - else - a = 1.0_dp - b = real(x + 1 - s, dp) - g = a / b - c = a / dm - d = 1.0_dp / b - n = 2 - do - a = -(n - 1) * real((n - 1 - s), dp) - b = real(x - s, dp) + 2 * n - 1.0_dp - d = d * a + b - if(d == 0.0_dp) d = dm - c = b + a / c - if(c == 0.0_dp) c = dm - d = 1.0_dp / d - y = c * d - g = g * y - n = n + 1 - if(abs(y - 1.0_dp) < ep_machine) exit - end do - endif - res = g - return - end function gpx_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in INT_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - impure elemental function gpx_${t1[0]}$${k1}$${k2}$(s, x) result(res) - ! Approximation of incomplete gamma G function - ! Based on Rémy Abergel and Lionel Moisan "Algorithm 1006, Fast and - ! Accurate Evaluation of a Generalized Incomplete Gamma Function", ACM - ! Transactions on Mathematical Software, March 2020. - ! - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - real(dp) :: res - ${t2}$ :: p_lim - real(dp) :: a, b, g, c, d, y - integer :: n - - if(x < -9._${k2}$) then - p_lim = 5.0_${k2}$ * (sqrt(abs(x)) - 1.0_${k2}$) - elseif(x >= -9.0_${k2}$ .and. x <= 0.0_${k2}$) then - p_lim = 0.0_${k2}$ - else - p_lim = x - endif - if(real(s, ${k2}$) >= p_lim) then - a = real(s, dp) - g = 1.0_dp / a - c = g - do - a = a + 1.0_dp - c = c * x / a - g = g + c - if(abs(c) < ep_machine) exit - end do - elseif(x >= 0.0_${k2}$) then - a = 1.0_dp - b = real(x, dp) + (1 - s) - g = a / b - c = a / dm - d = 1.0_dp / b - n = 2 - do - a = -(n - 1) * real((n - s - 1), dp) - b = real(x - s, dp) + 2 * n - 1.0_dp - d = d * a + b - if(d == 0.0_dp) d = dm - c = b + a / c - if(c == 0.0_dp) c = dm - d = 1.0_dp / d - y = c * d - g = g * y - n = n + 1 - if(abs(y - 1.0_dp) < ep_machine) exit - end do - elseif(abs(x) > real(max(1_${k1}$, s - 1_${k1}$), ${k2}$)) then - a = real(-x, dp) - c = 1.0_dp / a - d = real(s - 1, dp) - b = c * (a - d) - n = 1 - do - c = d * (d - 1.0_dp) / (a * a) - d = d - 2.0_dp - y = c * ( a - d) - b = b + y - n = n + 1 - if(int(n, ${k1}$) > (s - 2_${k1}$) / 2_${k1}$ .or. y < b * & - ep_machine) exit - end do - if(y >= b * ep_machine .and. mod(s, 2_${k1}$) /= 0_${k1}$) & - b = b + d * c / a - g = ((-1) ** s * exp(-a + loggamma(real(s, dp)) - (s - 1) * & - log(a)) + b ) / a - endif - res = g - return - end function gpx_${t1[0]}$${k1}$${k2}$ - - #:endfor - #:endfor - - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - impure elemental function ingamma_low_${t1[0]}$${k1}$${k2}$(s, x) & - result(res) - ! Approximation of lower incomplete gamma function - ! - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res - real(dp) :: s1, y, xx, ss - - #:if t1[0] == "i" - if(s < 0_${k1}$) call error_stop("Error(ingamma_low): Lower" & - //" incomplete gamma function input s value must be greater than 0") - #:else - if(s < 0._${k1}$) call error_stop("Error(ingamma_low): Lower" & - //" incomplete gamma function input s value must be greater than 0") - #:endif - xx = real(x, dp); ss = real(s, dp) - if(x == 0.0_${k2}$) then - res = 0.0_${k2}$ - elseif(x > 0.0_${k2}$ .and. x <= real(s, ${k2}$)) then - s1 = -xx + ss * log(xx) - res = real(gpx(s,x) * exp(s1), kind=${k2}$) - elseif(x > real(s, ${k2}$)) then - s1 = loggamma(ss) - y = 1.0_dp - exp(-xx + ss * log(xx) - s1) * gpx(s,x) - res = real(y * exp(s1), kind=${k2}$) - else - s1 = -xx + ss * log(-xx) - res = real((-1)**s * gpx(s,x) * exp(s1), kind=${k2}$) - endif - return - end function ingamma_low_${t1[0]}$${k1}$${k2}$ - #:endif - #:endfor - #:endfor - - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - impure elemental function l_ingamma_low_${t1[0]}$${k1}$${k2}$(s, x) & - result(res) - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res - - res = log(ingamma_low(s,x)) - end function l_ingamma_low_${t1[0]}$${k1}$${k2}$ - - #:endif - #:endfor - #:endfor - - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - impure elemental function ingamma_up_${t1[0]}$${k1}$${k2}$(s, x) & - result(res) - ! Approximation of upper incomplete gamma function - ! - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res - - res = exp(loggamma(real(s, kind=${k2}$))) - ingamma_low(s,x) - return - end function ingamma_up_${t1[0]}$${k1}$${k2}$ - - #:endif - #:endfor - #:endfor - - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and ( k1 != k2)) - impure elemental function l_ingamma_up_${t1[0]}$${k1}$${k2}$(s, x) & - result(res) - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res - - res = log(ingamma_up(s,x)) - end function l_ingamma_up_${t1[0]}$${k1}$${k2}$ - - #:endif - #:endfor - #:endfor - - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - impure elemental function regamma_p_${t1[0]}$${k1}$${k2}$(s, x) result(res) - ! Approximation of regulated incomplet gamma function P(s,x) - ! - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res - real(dp) :: s1, xx, ss - - #:if t1[0] == "i" - if(s < 0_${k1}$) call error_stop("Error(regamma_p): Lower incomplete" & - //" gamma function input s value must be greater than 0") - #:else - if(s < 0._${k1}$) call error_stop("Error(regamma_p): Lower incomplete" & - //" gamma function input s value must be greater than 0") - #:endif - xx = real(x, dp); ss = real(s, dp) - s1 = -xx + ss * log(abs(xx)) - loggamma(ss) - if(x == 0.0_${k2}$) then - res = 0.0_${k2}$ - elseif(x > 0.0_${k2}$ .and. x <= real(s, ${k2}$)) then - res = real(gpx(s,x) * exp(s1), kind=${k2}$) - elseif(x > real(s, ${k2}$)) then - res = 1.0_dp - exp(s1) * gpx(s,x) - else - res = real((-1)**s * gpx(s,x) * exp(s1), kind=${k2}$) - endif - return - end function regamma_p_${t1[0]}$${k1}$${k2}$ - - #:endif - #:endfor - #:endfor - - #:for k1, t1 in IR_KINDS_TYPES - #:for k2, t2 in REAL_KINDS_TYPES - #:if not ((t1[0] == "r") and (k1 != k2)) - impure elemental function regamma_q_${t1[0]}$${k1}$${k2}$(s, x) & - result(res) - ! Approximation of regulated incomplet gamma function Q(s,x) - ! - ${t1}$, intent(in) :: s - ${t2}$, intent(in) :: x - ${t2}$ :: res - - res = real(1.0_dp - regamma_p(s,x), kind=${k2}$) - return - end function regamma_q_${t1[0]}$${k1}$${k2}$ - - #:endif - #:endfor - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function beta_${t1[0]}$${k1}$(a, b) result(res) - ! Evaluation of beta function through gamma function - ! - ${t1}$, intent(in) :: a, b - ${t1}$ :: res - - if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error(beta):" & - //" Beta function auguments a, b values must be greater than 0") - res = exp(loggamma(a) + loggamma(b) - loggamma(a+b)) - return - end function beta_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function l_beta_${t1[0]}$${k1}$(a, b) result(res) - ! Logrithm of beta function through log(gamma) - ! - ${t1}$, intent(in) :: a, b - ${t1}$ :: res - - if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error(l_beta):"& - //" Beta function auguments a, b values must be greater than 0") - res = loggamma(a) + loggamma(b) - loggamma(a+b) - return - end function l_beta_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function inbeta_${t1[0]}$${k1}$(x, a, b) result(res) - ! Evaluation of incomplete beta function using continued fractions - ! "Computation of Special Functions" by S. Zhang and J. Jin, 1996 - ! - ${t1}$, intent(in) :: x, a, b - ${t1}$ :: res - integer :: n, k - real(dp) :: an, bn, g, c, d, y, s0, ak, ak2 - - if(a <= 0._${k1}$ .or. b <= 0._${k1}$) call error_stop("Error(inbeta):"& - //" Incomplete beta function auguments a, b values must be greater" & - //" than 0") - s0 = (a + 1) / (a + b + 2) - an = 1.0_dp - bn = 1.0_dp - g = an / bn - c = an / dm - d = 1.0_dp / bn - n = 1 - if(x < real(s0, ${k1}$)) then - do - if(mod(n, 2) == 0) then - k = n / 2; ak = real(a + 2 * k, dp) - an = k * real(x, dp) * (b - k) / (ak * ak - ak) - else - k = (n - 1) / 2; ak = real(a + k, dp); ak2 = ak + k - an = - (ak + b) * ak * real(x, dp) / (ak2 * ak2 + ak2) - endif - d = d * an + bn - if(d == 0.0_dp) d = dm - c = bn + an / c - if(c == 0.0_dp) c = dm - d = 1.0_dp / d - y = c * d - g = g * y - n = n + 1 - if(abs(y - 1.0_dp) < ep_machine) exit - end do - g = x ** a * (1.0_${k1}$ - x) ** b * g / (a * beta(a, b)) - else - do - if(mod(n, 2) == 0) then - k = n / 2; ak = real(b + 2 * k, dp) - an = k * (1.0_dp - x) * (a - k) / (ak * ak - ak) - else - k = (n - 1) / 2; ak = b + k; ak2 = ak + k - an = - ak * (1.0_dp - x) * (a + ak) / (ak2 * ak2 + ak2) - endif - d = d * an + bn - if(d == 0.0_dp) d = dm - c = bn + an / c - if(c == 0.0_dp) c = dm - d = 1.0_dp / d - y = c * d - g = g * y - n = n + 1 - if(abs(y - 1.0_dp) < ep_machine) exit - end do - g = x ** a * (1.0_${k1}$ - x) ** b * g / (b * beta(a, b)) - g = 1.0_${k1}$ - g - endif - res = g - end function inbeta_${t1[0]}$${k1}$ - - #:endfor - -end module stdlib_stats_distribution_special From fb04c0b0c9492462f6b76da9feabac1f0e378966 Mon Sep 17 00:00:00 2001 From: jim-215-fisher Date: Mon, 20 Jun 2022 14:31:57 -0400 Subject: [PATCH 40/42] major changes in gamma files --- doc/specs/index.md | 1 + doc/specs/stdlib_stats_distribution_gamma.md | 79 ++- src/CMakeLists.txt | 1 + src/stdlib_stats_distribution_PRNG.fypp | 151 ------ src/stdlib_stats_distribution_gamma.fypp | 294 +++++----- src/stdlib_stats_distribution_normal.fypp | 292 ---------- src/stdlib_stats_distribution_uniform.fypp | 446 ---------------- src/tests/stats/CMakeLists.txt | 2 + src/tests/stats/test_distribution_gamma.f90 | 530 ------------------- src/tests/stats/test_distribution_gamma.fypp | 337 ++++++++++++ 10 files changed, 534 insertions(+), 1599 deletions(-) delete mode 100644 src/stdlib_stats_distribution_PRNG.fypp delete mode 100644 src/tests/stats/test_distribution_gamma.f90 create mode 100644 src/tests/stats/test_distribution_gamma.fypp diff --git a/doc/specs/index.md b/doc/specs/index.md index 95f08a31f..04dbd4bae 100644 --- a/doc/specs/index.md +++ b/doc/specs/index.md @@ -30,6 +30,7 @@ This is and index/directory of the specifications (specs) for each new module/fe - [stats_distributions_uniform](./stdlib_stats_distribution_uniform.html) - Uniform Probability Distribution - [stats_distributions_normal](./stdlib_stats_distribution_normal.html) - Normal Probability Distribution - [stats_distributions_exponential](./stdlib_stats_distribution_exponential.html) - Exponential Probability Distribution + - [stats_distributions_gamma](./stdlib_stats_distribution_gamma.html) - Gamma Probability Distribution - [string\_type](./stdlib_string_type.html) - Basic string support - [stringlist_type](./stdlib_stringlist_type.html) - 1-Dimensional list of strings - [strings](./stdlib_strings.html) - String handling and manipulation routines diff --git a/doc/specs/stdlib_stats_distribution_gamma.md b/doc/specs/stdlib_stats_distribution_gamma.md index 7d7bf342f..8674619f0 100644 --- a/doc/specs/stdlib_stats_distribution_gamma.md +++ b/doc/specs/stdlib_stats_distribution_gamma.md @@ -1,13 +1,13 @@ --- -title: stats_distribution +title: stats_distribution_gamma --- # Statistical Distributions -- Gamma Distribution Module [TOC] -## `gamma_distribution_rvs` - gamma distribution random variates +## `rvs_gamma` - gamma distribution random variates ### Status @@ -15,13 +15,22 @@ Experimental ### Description -With one augument for shape parameter, the function returns a standard gamma distributed random variate \(\gamma\)(shape) with `rate = 1.0`. The function is elemental. For complex auguments, the real and imaginary parts are independent of each other. +With one argument for shape parameter, the function returns a random sample from the standard gamma distribution `Gam(shape)` with `rate = 1.0`. + +With two arguments, the function returns a random sample from gamma distribution `Gam(shape, rate)`. + +With three arguments, the function returns a rank one array of gamma distributed random variates. + +For complex shape and rate parameters, the real and imaginary parts are sampled independently of each other. -With two auguments, the function return a scalar gamma distributed random variate \(\gamma\)(shape, rate). ### Syntax -`result = [[stdlib_stats_distribution_gamma(module):gamma_distribution_rvs(interface)]](shape [, rate] [[, array_size]])` +`result = [[stdlib_stats_distribution_gamma(module):rvs_gamma(interface)]](shape [, rate] [[, array_size]])` + +### Class + +Function ### Arguments @@ -29,18 +38,18 @@ With two auguments, the function return a scalar gamma distributed random variat `rate`: optional argument has `intent(in)` and is a scalar of type `real` or `complex`. -`array_size`: optional argument has `intent(in)` and is a scalar of type `integer`. +`array_size`: optional argument has `intent(in)` and is a scalar of type `integer` with default kind. ### Return value -The result is a scalar or rank one array, with a size of `array_size`, of type `real` or `complex`. +The result is a scalar or rank one array, with a size of `array_size`, and has the same type of `shape`. ### Example ```fortran program demo_gamma_rvs - use stdlib_stats_distribution_PRNG, only : random_seed - use stdlib_stats_distribution_gamma, only: rgamma => gamma_distribution_rvs + use stdlib_random, only : random_seed + use stdlib_stats_distribution_gamma, only: rgamma => rvs_gamma implicit none real :: g(2,3,4) @@ -61,7 +70,7 @@ program demo_gamma_rvs g(:,:,:) = 0.5 print *, rgamma(g) - !a rank 3 array of 60 standard gamma random variates with rate=0.5 + !a rank 3 array of 60 standard gamma random variates with shape=0.5 ! 1.03841162 1.33044529 0.912742674 0.131288037 0.638593793 ! 1.03565669E-02 0.624804378 1.12179172 4.91380468E-02 6.69969944E-03 @@ -86,7 +95,7 @@ program demo_gamma_rvs end program demo_gamma_rvs ``` -## `gamma_distribution_pdf` - gamma probability density function +## `pdf_gamma` - gamma distribution probability density function ### Status @@ -94,13 +103,22 @@ Experimental ### Description -The probability density function of the continuous gamma distribution. +The probability density function (pdf) of the single real variable gamma distribution: $$ f(x)= \frac{scale^{shape}}{\Gamma (shape)}x^{shape-1}e^{-scale \times x} , for \;\; x>0, shape, scale>0$$ +For a complex variable (x + y i) with independent real x and imaginary y parts, the joint probability density function is the product of the corresponding marginal pdf of real and imaginary pdf (for more details, see +"Probability and Random Processes with Applications to Signal Processing and Communications", 2nd ed., Scott L. Miller and Donald Childers, 2012, p.197): + +$$f(x+\mathit{i}y)=f(x)f(y)$$ + ### Syntax -`result = [[stdlib_stats_distribution_gamma(module):gamma_distribution_pdf(interface)]](x, shape, rate)` +`result = [[stdlib_stats_distribution_gamma(module):pdf_gamma(interface)]](x, shape, rate)` + +### Class + +Elemental function ### Arguments @@ -110,19 +128,19 @@ $$ f(x)= \frac{scale^{shape}}{\Gamma (shape)}x^{shape-1}e^{-scale \times x} , fo `rate`: has `intent(in)` and is a scalar of type `real` or `complex`. -The function is elemental, i.e., all auguments could be arrays conformable to each other. All arguments must have the same type. +All arguments must have the same type. ### Return value -The result is a scalar or an array, with a shape conformable to auguments, of type `real`. +The result is a scalar or an array, with a shape conformable to arguments, of type `real`. ### Example ```fortran program demo_gamma_pdf - use stdlib_stats_distribution_PRNG, onyl : random_seed - use stdlib_stats_distribution_gamma, only: rgamma => gamma_distribution_rvs,& - gamma_pdf => gamma_distribution_pdf + use stdlib_random, only : random_seed + use stdlib_stats_distribution_gamma, only: rgamma => rvs_gamma,& + gamma_pdf => pdf_gamma implicit none real :: x(2,3,4),g(2,3,4),s(2,3,4) @@ -159,7 +177,7 @@ program demo_gamma_pdf end program demo_gamma_pdf ``` -## `gamma_distribution_cdf` - gamma cumulative distribution function +## `cdf_gamma` - gamma distribution cumulative distribution function ### Status @@ -167,13 +185,22 @@ Experimental ### Description -Cumulative distribution function of the gamma continuous distribution +Cumulative distribution function (cdf) of the single real variable gamma distribution: $$ F(x)= \frac{\gamma (shape, scale \times x)}{\Gamma (shape)}, for \;\; x>0, shape, scale>0} $$ +For a complex variable (x + y i) with independent real x and imaginary y parts, the joint cumulative distribution function is the product of corresponding marginal cdf of real and imaginary cdf (for more details, see +"Probability and Random Processes with Applications to Signal Processing and Communications", 2nd ed., Scott L. Miller and Donald Childers, 2012, p.197): + +$$F(x+\mathit{i}y)=F(x)F(y)$$ + ### Syntax -`result = [[stdlib_stats_distribution_gamma(module):gamma_distribution_cdf(interface)]](x, shape, rate)` +`result = [[stdlib_stats_distribution_gamma(module):cdf_gamma(interface)]](x, shape, rate)` + +### Class + +Elemental function ### Arguments @@ -183,19 +210,19 @@ $$ F(x)= \frac{\gamma (shape, scale \times x)}{\Gamma (shape)}, for \;\; x>0, s `rate`: has `intent(in)` and is a scalar of type `real` or `complex`. -The function is elemental, i.e., all auguments could be arrays conformable to each other. All arguments must have the same type. +All arguments must have the same type. ### Return value -The result is a scalar of type `real` with a shape conformable to auguments. +The result is a scalar of type `real` with the same kind of input arguments. ### Example ```fortran program demo_gamma_cdf - use stdlib_stats_distribution_PRNG, onyl : random_seed - use stdlib_stats_distribution_gamma, only: rgamma => gamma_distribution_rvs,& - gamma_cdf => gamma_distribution_cdf + use stdlib_random, only : random_seed + use stdlib_stats_distribution_gamma, only: rgamma => rvs_gamma,& + gamma_cdf => cdf_gamma implicit none real :: x(2,3,4),g(2,3,4),s(2,3,4) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 40a5940a6..b46ba5a45 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -41,6 +41,7 @@ set(fppFiles stdlib_stats_distribution_uniform.fypp stdlib_stats_distribution_normal.fypp stdlib_stats_distribution_exponential.fypp + stdlib_stats_distribution_gamma.fypp stdlib_stats_var.fypp stdlib_quadrature.fypp stdlib_quadrature_trapz.fypp diff --git a/src/stdlib_stats_distribution_PRNG.fypp b/src/stdlib_stats_distribution_PRNG.fypp deleted file mode 100644 index 3fdbf0438..000000000 --- a/src/stdlib_stats_distribution_PRNG.fypp +++ /dev/null @@ -1,151 +0,0 @@ -#:include "common.fypp" -module stdlib_stats_distribution_PRNG - use stdlib_kinds, only: int8, int16, int32, int64 - use stdlib_error - implicit none - private - integer, parameter :: MAX_INT_BIT_SIZE = bit_size(1_int64) - integer(int64), save :: st(4) ! internal states for xoshiro256ss function - integer(int64), save :: si = 614872703977525537_int64 ! default seed value - logical, save :: seed_initialized = .false. - - public :: random_seed - public :: dist_rand - - - interface dist_rand - !! Version experimental - !! - !! Generation of random integers with different kinds - !! ([Specification](../page/specs/stdlib_stats_distribution_PRNG.html# - !! description)) - #:for k1, t1 in INT_KINDS_TYPES - module procedure dist_rand_${t1[0]}$${k1}$ - #:endfor - end interface dist_rand - - interface random_seed - !! Version experimental - !! - !! Set seed value for random number generator - !! ([Specification](../page/specs/stdlib_stats_distribution_PRNG.html# - !! description)) - !! - #:for k1, t1 in INT_KINDS_TYPES - module procedure random_distribution_seed_${t1[0]}$${k1}$ - #:endfor - end interface random_seed - - - contains - - #:for k1, t1 in INT_KINDS_TYPES - function dist_rand_${t1[0]}$${k1}$(n) result(res) - !! Random integer generation for various kinds - !! result = [-2^k, 2^k - 1], k = 7, 15, 31, 63, depending on input kind - !! Result will be operated by bitwise operators to generate desired integer - !! and real pseudorandom numbers - !! - ${t1}$, intent(in) :: n - ${t1}$ :: res - integer :: k - - k = MAX_INT_BIT_SIZE - bit_size(n) - if(k < 0) call error_stop("Error(dist_rand): Integer bit size is" & - //" greater than 64bit") - res = shiftr(xoshiro256ss( ), k) - end function dist_rand_${t1[0]}$${k1}$ - - #:endfor - - function xoshiro256ss( ) result (res) - ! Generate random 64-bit integers - ! Written in 2018 by David Blackman and Sebastiano Vigna (vigna@acm.org) - ! http://prng.di.unimi.it/xoshiro256starstar.c - ! - ! This is xoshiro256** 1.0, one of our all-purpose, rock-solid - ! generators. It has excellent (sub-ns) speed, a state (256 bits) that is - ! large enough for any parallel application, and it passes all tests we - ! are aware of. - ! - ! The state must be seeded so that it is not everywhere zero. If you have - ! a 64-bit seed, we suggest to seed a splitmix64 generator and use its - ! output to fill st. - ! - ! Fortran 90 version translated from C by Jim-215-Fisher - ! - integer(int64) :: res, t - - if(.not. seed_initialized) call random_distribution_seed_iint64(si,t) - res = rol64(st(2) * 5 , 7) * 9 - t = shiftl(st(2), 17) - st(3) = ieor(st(3), st(1)) - st(4) = ieor(st(4), st(2)) - st(2) = ieor(st(2), st(3)) - st(1) = ieor(st(1), st(4)) - st(3) = ieor(st(3), t) - st(4) = rol64(st(4), 45) - end function xoshiro256ss - - function rol64(x, k) result(res) - integer(int64), intent(in) :: x - integer, intent(in) :: k - integer(int64) :: t1, t2, res - - t1 = shiftr(x, (64 - k)) - t2 = shiftl(x, k) - res = ior(t1, t2) - end function rol64 - - - function splitmix64(s) result(res) - ! Written in 2015 by Sebastiano Vigna (vigna@acm.org) - ! This is a fixed-increment version of Java 8's SplittableRandom - ! generator. - ! See http://dx.doi.org/10.1145/2714064.2660195 and - ! http://docs.oracle.com/javase/8/docs/api/java/util/SplittableRandom.html - ! - ! It is a very fast generator passing BigCrush, and it can be useful if - ! for some reason you absolutely want 64 bits of state. - ! - ! Fortran 90 translated from C by Jim-215-Fisher - ! - integer(int64) :: res, int01, int02, int03 - integer(int64), intent(in), optional :: s - data int01, int02, int03/-7046029254386353131_int64, & - -4658895280553007687_int64, & - -7723592293110705685_int64/ - ! Values are converted from C unsigned integer of 0x9e3779b97f4a7c15, - ! 0xbf58476d1ce4e5b9, 0x94d049bb133111eb - - if(present(s)) si = s - res = si - si = res + int01 - res = ieor(res, shiftr(res, 30)) * int02 - res = ieor(res, shiftr(res, 27)) * int03 - res = ieor(res, shiftr(res, 31)) - end function splitmix64 - - #:for k1, t1 in INT_KINDS_TYPES - subroutine random_distribution_seed_${t1[0]}$${k1}$(put, get) - !! Set seed value for random number generator - !! - ${t1}$, intent(in) :: put - ${t1}$, intent(out) :: get - integer(int64) :: tmp - integer :: i - - tmp = splitmix64(int(put, kind = int64)) - do i = 1, 10 - tmp = splitmix64( ) - end do - do i = 1, 4 - tmp = splitmix64( ) - st(i) = tmp - end do - get = int(tmp, kind = ${k1}$) - seed_initialized = .true. - end subroutine random_distribution_seed_${t1[0]}$${k1}$ - - #:endfor -end module stdlib_stats_distribution_PRNG \ No newline at end of file diff --git a/src/stdlib_stats_distribution_gamma.fypp b/src/stdlib_stats_distribution_gamma.fypp index 488e37858..664eddeb5 100644 --- a/src/stdlib_stats_distribution_gamma.fypp +++ b/src/stdlib_stats_distribution_gamma.fypp @@ -1,26 +1,28 @@ +#:set WITH_QP = False +#:set WITH_XDP = False #:include "common.fypp" #:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES Module stdlib_stats_distribution_gamma - use stdlib_kinds + use stdlib_kinds, only : sp, dp use stdlib_error, only : error_stop - use stdlib_stats_distribution_uniform, only : uni=>uniform_distribution_rvs - use stdlib_stats_distribution_normal, only : rnor=>normal_distribution_rvs - use stdlib_stats_distribution_special, only : ingamma=>ingamma_low, loggamma + use stdlib_stats_distribution_uniform, only : uni=>rvs_uniform + use stdlib_stats_distribution_normal, only : rnor=>rvs_normal + use stdlib_specialfunctions_gamma, only : lincgam => lower_incomplete_gamma implicit none private - integer(int64), parameter :: INT_ONE = 1_int64 - public :: gamma_distribution_rvs - public :: gamma_distribution_pdf - public :: gamma_distribution_cdf + public :: rvs_gamma + public :: pdf_gamma + public :: cdf_gamma - interface gamma_distribution_rvs + + interface rvs_gamma !! Version experimental !! !! Gamma Distribution Random Variates !! ([Specification](../page/specs/stdlib_stats_distribution_gamma.html# - !! description)) + !! rvs_gamma-gamma-distribution-random-variates)) !! #:for k1, t1 in RC_KINDS_TYPES module procedure gamma_dist_rvs_1_${t1[0]}$${k1}$ ! 1 argument @@ -33,296 +35,280 @@ Module stdlib_stats_distribution_gamma #:for k1, t1 in RC_KINDS_TYPES module procedure gamma_dist_rvs_array_${t1[0]}$${k1}$ ! 3 arguments #:endfor - end interface gamma_distribution_rvs + end interface rvs_gamma + - interface gamma_distribution_pdf + interface pdf_gamma !! Version experimental !! !! Gamma Distribution Probability Density Function !! ([Specification](../page/specs/stdlib_stats_distribution_gamma.html# - !! description)) + !! pdf_gamma-gamma-distribution-probability-density-function)) !! #:for k1, t1 in RC_KINDS_TYPES module procedure gamma_dist_pdf_${t1[0]}$${k1}$ #:endfor - end interface gamma_distribution_pdf + end interface pdf_gamma + - interface gamma_distribution_cdf + interface cdf_gamma !! Version experimental !! !! Gamma Distribution Cumulative Distribution Function !! ([Specification](../page/specs/stdlib_stats_distribution_gamma.html# - !! description)) + !! cdf_gamma_gamma-distribution-cumulative-density-function)) !! #:for k1, t1 in RC_KINDS_TYPES module procedure gamma_dist_cdf_${t1[0]}$${k1}$ #:endfor - end interface gamma_distribution_cdf + end interface cdf_gamma - contains + + +contains #:for k1, t1 in REAL_KINDS_TYPES impure elemental function gamma_dist_rvs_1_${t1[0]}$${k1}$(shape) result(res) - ! Gamma random variate + ! Gamma distribution random variate. "A Simple Method for Generating Gamma + ! Variables", G. Marsaglia & W. W. Tsang, ACM Transactions on Mathematical + ! Software, 26(3), 2000, p. 363 ! ${t1}$, intent(in) :: shape ${t1}$ :: res - ${t1}$ :: x, v, u, zz, tol = 1000 * epsilon(1.0_${k1}$) - ${t1}$, save :: alpha = 0._${k1}$, d, c, sq = 0.0331_${k1}$ + ${t1}$ :: x, v, u, zz + ${t1}$, save :: alpha = 0._${k1}$, d, c + ${t1}$, parameter :: sq = 0.0331_${k1}$, tol = 1000 * epsilon(1.0_${k1}$) + if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs): Gamma" & - //" distribution shape parameter must be greater than zero") + //" distribution shape parameter must be greater than zero") zz = shape + if(zz < 1._${k1}$) zz = 1._${k1}$ + zz + !shift shape parameter > 1 if(abs(zz - alpha) > tol) then + !initial run alpha = zz d = alpha - 1._${k1}$ / 3._${k1}$ c = 1._${k1}$ / (3._${k1}$ * sqrt(d)) + endif + do do x = rnor(0.0_${k1}$, 1.0_${k1}$) v = 1._${k1}$ + c * x v = v * v * v + if(v > 0._${k1}$) exit + end do + x = x * x u = uni(1.0_${k1}$) + if(u < (1._${k1}$ - sq * x * x)) exit + if(log(u) < 0.5_${k1}$ * x + d * (1._${k1}$ - v + log(v))) exit + end do + res = d * v + if(shape < 1._${k1}$) then + !restore shape parameter < 1 u = uni(1.0_${k1}$) res = res * u ** (1._${k1}$ / shape) + endif - return end function gamma_dist_rvs_1_${t1[0]}$${k1}$ #:endfor + #:for k1, t1 in CMPLX_KINDS_TYPES impure elemental function gamma_dist_rvs_1_${t1[0]}$${k1}$(shape) result(res) - ! Gamma distributed complex. The real part and imaginary part are + ! Complex parameter gamma distributed. The real part and imaginary part are ! independent of each other. ! ${t1}$, intent(in) :: shape ${t1}$ :: res - real(${k1}$) :: tr, ti - tr = gamma_dist_rvs_1_r${k1}$(real(shape)) - ti = gamma_dist_rvs_1_r${k1}$(aimag(shape)) - res = cmplx(tr,ti, kind=${k1}$) - return + res = cmplx(gamma_dist_rvs_1_r${k1}$(shape%re), & + gamma_dist_rvs_1_r${k1}$(shape%im), kind=${k1}$) end function gamma_dist_rvs_1_${t1[0]}$${k1}$ #:endfor + #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function gamma_dist_rvs_${t1[0]}$${k1}$(shape, rate) & - result(res) + impure elemental function gamma_dist_rvs_${t1[0]}$${k1}$(shape, rate) & + result(res) + ! ${t1}$, intent(in) :: shape, rate ${t1}$ :: res - ${t1}$ :: x, v, u, zz, tol = 1000 * epsilon(1.0_${k1}$) - ${t1}$, save :: alpha = 0._${k1}$, d, c, sq = 0.0331_${k1}$ - if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs): Gamma" & - //" distribution shape parameter must be greater than zero") - - if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs): Gamma" & + if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs): Gamma" & //" distribution rate parameter must be greater than zero") - zz = shape - if(zz < 1._${k1}$) zz = 1._${k1}$ + zz - if(abs(zz - alpha) > tol) then - alpha = zz - d = alpha - 1._${k1}$ / 3._${k1}$ - c = 1._${k1}$ / (3._${k1}$ * sqrt(d)) - endif - do - do - x = rnor(0.0_${k1}$, 1.0_${k1}$) - v = 1._${k1}$ + c * x - v = v * v * v - if(v > 0._${k1}$) exit - end do - x = x * x - u = uni(1.0_${k1}$) - if(u < (1._${k1}$ - sq * x * x)) exit - if(log(u) < 0.5_${k1}$ * x + d * (1._${k1}$ - v + log(v))) exit - end do - res = d * v - if(shape < 1._${k1}$) then - u = uni(1.0_${k1}$) - res = res * u ** (1._${k1}$ / shape) - endif - res = res / rate - return + res = gamma_dist_rvs_1_${t1[0]}$${k1}$(shape) / rate end function gamma_dist_rvs_${t1[0]}$${k1}$ #:endfor + #:for k1, t1 in CMPLX_KINDS_TYPES - impure elemental function gamma_dist_rvs_${t1[0]}$${k1}$(shape, rate) & - result(res) - ! Gamma distributed complex. The real part and imaginary part are & + impure elemental function gamma_dist_rvs_${t1[0]}$${k1}$(shape, rate) & + result(res) + ! Complex parameter gamma distributed. The real part and imaginary part are & ! independent of each other. ! ${t1}$, intent(in) :: shape, rate ${t1}$ :: res - real(${k1}$) :: tr, ti - tr = gamma_dist_rvs_r${k1}$(real(shape), real(rate)) - ti = gamma_dist_rvs_r${k1}$(aimag(shape), aimag(rate)) - res = cmplx(tr, ti, kind=${k1}$) - return + res = cmplx(gamma_dist_rvs_r${k1}$(shape%re, rate%re), & + gamma_dist_rvs_r${k1}$(shape%im, rate%im), kind=${k1}$) end function gamma_dist_rvs_${t1[0]}$${k1}$ #:endfor + #:for k1, t1 in REAL_KINDS_TYPES - function gamma_dist_rvs_array_${t1[0]}$${k1}$(shape, rate, array_size) & - result(res) + function gamma_dist_rvs_array_${t1[0]}$${k1}$(shape, rate, array_size) & + result(res) + ! ${t1}$, intent(in) :: shape, rate - ${t1}$, allocatable :: res(:) integer, intent(in) :: array_size - ${t1}$ :: x, v, u, zz, tol = 1000 * epsilon(1.0_${k1}$), re - ${t1}$, save :: alpha = 0._${k1}$, d, c, sq = 0.0331_${k1}$ + ${t1}$ :: res(array_size) integer :: i - if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs_array):" & - //" Gamma distribution shape parameter must be greater than zero") + do i = 1, array_size - if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_rvs_array):" & - //" Gamma distribution rate parameter must be greater than zero") + res(i) = gamma_dist_rvs_${t1[0]}$${k1}$(shape, rate) - allocate(res(array_size)) - zz = shape - if(zz < 1._${k1}$) zz = 1._${k1}$ + zz - if(abs(zz - alpha) > tol) then - alpha = zz - d = alpha - 1._${k1}$ / 3._${k1}$ - c = 1._${k1}$ / (3._${k1}$ * sqrt(d)) - endif - do i = 1, array_size - do - do - x = rnor(0.0_${k1}$, 1.0_${k1}$) - v = 1._${k1}$ + c * x - v = v * v * v - if(v > 0._${k1}$) exit - end do - x = x * x - u = uni(1.0_${k1}$) - if(u < (1._${k1}$ - sq * x * x)) exit - if(log(u) < 0.5_${k1}$ * x + d * (1._${k1}$ - v + log(v))) exit - end do - re = d * v - if(shape < 1._${k1}$) then - u = uni(1.0_${k1}$) - re = re * u ** (1._${k1}$ / shape) - endif - res(i) = re / rate end do - return end function gamma_dist_rvs_array_${t1[0]}$${k1}$ #:endfor + #:for k1, t1 in CMPLX_KINDS_TYPES - function gamma_dist_rvs_array_${t1[0]}$${k1}$(shape, rate, array_size) & - result(res) + function gamma_dist_rvs_array_${t1[0]}$${k1}$(shape, rate, array_size) & + result(res) + ! Complex parameter gamma distributed. The real part and imaginary part are & + ! independent of each other. + ! ${t1}$, intent(in) :: shape, rate - ${t1}$, allocatable :: res(:) integer, intent(in) :: array_size + ${t1}$ :: res(array_size) integer :: i - real(${k1}$) :: tr, ti - allocate(res(array_size)) do i = 1, array_size - tr = gamma_dist_rvs_r${k1}$(real(shape), real(rate)) - ti = gamma_dist_rvs_r${k1}$(aimag(shape), aimag(rate)) - res(i) = cmplx(tr, ti, kind=${k1}$) + + res(i) = cmplx(gamma_dist_rvs_r${k1}$(shape%re, rate%re), & + gamma_dist_rvs_r${k1}$(shape%im, rate%im), & + kind=${k1}$) + end do - return end function gamma_dist_rvs_array_${t1[0]}$${k1}$ #:endfor + #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function gamma_dist_pdf_${t1[0]}$${k1}$(x, shape, rate) & - result(res) - ! Gamma distributed probability function + impure elemental function gamma_dist_pdf_${t1[0]}$${k1}$(x, shape, rate) & + result(res) + ! Gamma distribution probability density function ! ${t1}$, intent(in) :: x, shape, rate - real :: res - - if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & - //" distribution rate parameter must be greaeter than zero") - if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & - //" distribution shape parameter must be greater than zero") - if(x <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & - //" distribution variate x must be greater than zero") + real(${k1}$) :: res + + if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & + //" distribution rate parameter must be greaeter than zero") + + if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & + //" distribution shape parameter must be greater than zero") + + if(x <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & + //" distribution variate x must be greater than zero") + if(x == 0.0_${k1}$) then + if(shape <= 1.0_${k1}$) then + res = huge(1.0) + 1.0 + else + res = 0.0_${k1}$ + endif + else - res = exp((shape - 1._${k1}$) * log(x) - x * rate + shape * & - log(rate) - loggamma(shape)) + + res = exp((shape - 1._${k1}$) * log(x) - x * rate + shape * & + log(rate) - log_gamma(shape)) + endif - return end function gamma_dist_pdf_${t1[0]}$${k1}$ #:endfor + #:for k1, t1 in CMPLX_KINDS_TYPES impure elemental function gamma_dist_pdf_${t1[0]}$${k1}$(x, shape, rate) & - result(res) + result(res) + ! Complex parameter gamma distributed. The real part and imaginary part are & + ! independent of each other. + ! ${t1}$, intent(in) :: x, shape, rate - real :: res + real(${k1}$) :: res - res = gamma_dist_pdf_r${k1}$(real(x), real(shape), real(rate)) - res = res * gamma_dist_pdf_r${k1}$(aimag(x), aimag(shape), aimag(rate)) - return + res = gamma_dist_pdf_r${k1}$(x%re, shape%re, rate%re) + res = res * gamma_dist_pdf_r${k1}$(x%im, shape%im, rate%im) end function gamma_dist_pdf_${t1[0]}$${k1}$ #:endfor + #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function gamma_dist_cdf_${t1[0]}$${k1}$(x, shape, rate) & - result(res) - ! Gamma random cumulative distribution function + impure elemental function gamma_dist_cdf_${t1[0]}$${k1}$(x, shape, rate) & + result(res) + ! Gamma distribution cumulative distribution function ! ${t1}$, intent(in) :: x, shape, rate - real :: res - - if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & - //" distribution rate parameter must be greaeter than zero") - if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & - //" distribution shape parameter must be greater than zero") - if(x <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & - //" distribution variate x must be greater than zero") - res = ingamma(shape, rate * x) / gamma(shape) - return + real(${k1}$) :: res + + if(rate <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & + //" distribution rate parameter must be greaeter than zero") + + if(shape <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & + //" distribution shape parameter must be greater than zero") + + if(x <= 0.0_${k1}$) call error_stop("Error(gamma_dist_pdf): Gamma" & + //" distribution variate x must be greater than zero") + + res = lincgam(shape, rate * x) / gamma(shape) end function gamma_dist_cdf_${t1[0]}$${k1}$ #:endfor + #:for k1, t1 in CMPLX_KINDS_TYPES impure elemental function gamma_dist_cdf_${t1[0]}$${k1}$(x, shape, rate) & - result(res) + result(res) + ! Complex parameter gamma distributed. The real part and imaginary part are & + ! independent of each other. + ! ${t1}$, intent(in) :: x, shape, rate - real :: res + real(${k1}$) :: res - res = gamma_dist_cdf_r${k1}$(real(x), real(shape), real(rate)) - res = res * gamma_dist_cdf_r${k1}$(aimag(x), aimag(shape), aimag(rate)) + res = gamma_dist_cdf_r${k1}$(x%re, shape%re, rate%re) + res = res * gamma_dist_cdf_r${k1}$(x%im, shape%im, rate%im) end function gamma_dist_cdf_${t1[0]}$${k1}$ #:endfor -end module stdlib_stats_distribution_gamma \ No newline at end of file +end module stdlib_stats_distribution_gamma diff --git a/src/stdlib_stats_distribution_normal.fypp b/src/stdlib_stats_distribution_normal.fypp index 8ddbc59e1..e21b7af14 100644 --- a/src/stdlib_stats_distribution_normal.fypp +++ b/src/stdlib_stats_distribution_normal.fypp @@ -1,81 +1,15 @@ #:include "common.fypp" #:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES -<<<<<<< HEAD -Module stdlib_stats_distribution_normal - use stdlib_kinds - use stdlib_error, only : error_stop - use stdlib_stats_distribution_PRNG, only : dist_rand - use stdlib_stats_distribution_uniform, only : uni=>uniform_distribution_rvs -======= module stdlib_stats_distribution_normal use stdlib_kinds, only : sp, dp, xdp, qp, int32 use stdlib_error, only : error_stop use stdlib_random, only : dist_rand use stdlib_stats_distribution_uniform, only : uni=>rvs_uniform ->>>>>>> upstream/master implicit none private real(dp), parameter :: HALF = 0.5_dp, ONE = 1.0_dp, TWO = 2.0_dp -<<<<<<< HEAD - integer, save :: kn(0:127) - real(dp), save :: wn(0:127), fn(0:127) - logical, save :: zig_norm_initialized = .false. - - public :: normal_distribution_rvs - public :: normal_distribution_pdf - public :: normal_distribution_cdf - - interface normal_distribution_rvs - !! Version experimental - !! - !! Normal Distribution Random Variates - !!([Specification](../page/specs/stdlib_stats_distribution_normal.html# - !! description)) - !! - module procedure norm_dist_rvs_0_rsp !0 dummy variable - - #:for k1, t1 in RC_KINDS_TYPES - module procedure norm_dist_rvs_${t1[0]}$${k1}$ !2 dummy variables - #:endfor - - #:for k1, t1 in RC_KINDS_TYPES - module procedure norm_dist_rvs_array_${t1[0]}$${k1}$ !3 dummy variables - #:endfor - end interface normal_distribution_rvs - - interface normal_distribution_pdf - !! Version experimental - !! - !! Normal Distribution Probability Density Function - !!([Specification](../page/specs/stdlib_stats_distribution_normal.html# - !! description)) - !! - #:for k1, t1 in RC_KINDS_TYPES - module procedure norm_dist_pdf_${t1[0]}$${k1}$ - #:endfor - end interface normal_distribution_pdf - - interface normal_distribution_cdf - !! Version experimental - !! - !! Normal Distribution Cumulative Distribution Function - !!([Specification](../page/specs/stdlib_stats_distribution_normal.html# - !! description)) - !! - #:for k1, t1 in RC_KINDS_TYPES - module procedure norm_dist_cdf_${t1[0]}$${k1}$ - #:endfor - end interface normal_distribution_cdf - - - contains - - subroutine zigset - ! Marsaglia & Tsang generator for random normals & random exponentials. - ! Translated from C by Alan Miller (amiller@bigpond.net.au) -======= integer :: kn(0:127) real(dp) :: wn(0:127), fn(0:127) logical :: zig_norm_initialized = .false. @@ -142,7 +76,6 @@ contains ! Marsaglia & Tsang generator for random normals & random exponentials. ! Translated from C by Alan Miller (amiller@bigpond.net.au), released as public ! domain (https://jblevins.org/mirror/amiller/) ->>>>>>> upstream/master ! ! Marsaglia, G. & Tsang, W.W. (2000) `The ziggurat method for generating ! random variables', J. Statist. Software, v5(8). @@ -150,19 +83,6 @@ contains ! This is an electronic journal which can be downloaded from: ! http://www.jstatsoft.org/v05/i08 ! -<<<<<<< HEAD - ! N.B. It is assumed that all integers are 32-bit. - ! - ! Latest version - 1 January 2001 - ! - real(dp), parameter :: M1 = 2147483648.0_dp - real(dp) :: dn = 3.442619855899_dp, tn, & - vn = 0.00991256303526217_dp, q - integer :: i - - tn = dn - ! tables for random normals -======= ! Latest version - 1 January 2001 ! real(dp), parameter :: M1 = 2147483648.0_dp, vn = 0.00991256303526217_dp @@ -172,7 +92,6 @@ contains dn = 3.442619855899_dp tn = dn !tables for random normals ->>>>>>> upstream/master q = vn * exp(HALF * dn * dn) kn(0) = int((dn / q) * M1, kind = int32) kn(1) = 0 @@ -188,13 +107,6 @@ contains wn(i) = dn / M1 end do zig_norm_initialized = .true. -<<<<<<< HEAD - return - end subroutine zigset - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function norm_dist_rvs_0_${t1[0]}$${k1}$( ) result(res) -======= end subroutine zigset @@ -202,7 +114,6 @@ contains #:for k1, t1 in REAL_KINDS_TYPES function rvs_norm_0_${t1[0]}$${k1}$( ) result(res) ! ->>>>>>> upstream/master ! Standard normal random vairate (0,1) ! ${t1}$ :: res @@ -210,19 +121,10 @@ contains ${t1}$ :: x, y integer :: hz, iz -<<<<<<< HEAD - if( .not. zig_norm_initialized ) call zigset - iz = 0 - ! original algorithm use 32bit - hz = dist_rand(1_int32) - - iz = iand( hz, 127 ) -======= if(.not. zig_norm_initialized) call zigset iz = 0 hz = dist_rand(1_int32) !32bit random integer iz = iand( hz, 127 ) !random integer in [0, 127] ->>>>>>> upstream/master if( abs( hz ) < kn(iz) ) then res = hz * wn(iz) else @@ -243,11 +145,6 @@ contains res = x exit L1 end if -<<<<<<< HEAD - - !original algorithm use 32bit -======= ->>>>>>> upstream/master hz = dist_rand(1_int32) iz = iand( hz, 127 ) if( abs( hz ) < kn(iz) ) then @@ -256,16 +153,6 @@ contains end if end do L1 end if -<<<<<<< HEAD - return - end function norm_dist_rvs_0_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function norm_dist_rvs_${t1[0]}$${k1}$(loc, scale) & - result(res) -======= end function rvs_norm_0_${t1[0]}$${k1}$ #:endfor @@ -275,65 +162,10 @@ contains #:for k1, t1 in REAL_KINDS_TYPES function rvs_norm_${t1[0]}$${k1}$(loc, scale) result(res) ! ->>>>>>> upstream/master ! Normal random variate (loc, scale) ! ${t1}$, intent(in) :: loc, scale ${t1}$ :: res -<<<<<<< HEAD - ${t1}$, parameter :: r = 3.442619855899_${k1}$, rr = 1.0_${k1}$ / r - ${t1}$ :: x, y - integer :: hz, iz - - if(scale==0._${k1}$) call error_stop("Error(norm_dist_rvs): Normal" & - //" distribution scale parameter must be non-zero") - if( .not. zig_norm_initialized ) call zigset - iz = 0 - ! original algorithm use 32bit - hz = dist_rand(1_int32) - - iz = iand( hz, 127 ) - if( abs( hz ) < kn(iz) ) then - res = hz * wn(iz) - else - L1: do - L2: if( iz == 0 ) then - do - x = -log( uni(1.0_${k1}$) ) * rr - y = -log( uni(1.0_${k1}$) ) - if( y + y >= x * x ) exit - end do - res = r + x - if( hz <= 0 ) res = -res - exit L1 - end if L2 - x = hz * wn(iz) - if( fn(iz) + uni(1.0_${k1}$) * (fn(iz-1) - fn(iz)) < & - exp(-HALF * x * x) ) then - res = x - exit L1 - end if - - !original algorithm use 32bit - hz = dist_rand(1_int32) - iz = iand( hz, 127 ) - if( abs( hz ) < kn(iz) ) then - res = hz * wn(iz) - exit L1 - end if - end do L1 - end if - res = res * scale + loc - return - end function norm_dist_rvs_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in CMPLX_KINDS_TYPES - impure elemental function norm_dist_rvs_${t1[0]}$${k1}$(loc, scale) & - result(res) - ! Normal distributed complex. The real part and imaginary part are & -======= if(scale == 0._${k1}$) call error_stop("Error(rvs_norm): Normal" & //" distribution scale parameter must be non-zero") @@ -349,29 +181,12 @@ contains function rvs_norm_${t1[0]}$${k1}$(loc, scale) result(res) ! ! Normally distributed complex. The real part and imaginary part are & ->>>>>>> upstream/master ! independent of each other. ! ${t1}$, intent(in) :: loc, scale ${t1}$ :: res real(${k1}$) :: tr, ti -<<<<<<< HEAD - tr = norm_dist_rvs_r${k1}$(real(loc), real(scale)) - ti = norm_dist_rvs_r${k1}$(aimag(loc), aimag(scale)) - res = cmplx(tr, ti, kind=${k1}$) - return - end function norm_dist_rvs_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - function norm_dist_rvs_array_${t1[0]}$${k1}$(loc, scale, array_size) & - result(res) - ${t1}$, intent(in) :: loc, scale - integer, intent(in) :: array_size - ${t1}$, allocatable :: res(:) -======= tr = rvs_norm_r${k1}$(loc % re, scale % re) ti = rvs_norm_r${k1}$(loc % im, scale % im) res = cmplx(tr, ti, kind=${k1}$) @@ -386,29 +201,16 @@ contains ${t1}$, intent(in) :: loc, scale integer, intent(in) :: array_size ${t1}$ :: res(array_size) ->>>>>>> upstream/master ${t1}$, parameter :: r = 3.442619855899_${k1}$, rr = 1.0_${k1}$ / r ${t1}$ :: x, y, re integer :: hz, iz, i -<<<<<<< HEAD - if(scale==0._${k1}$) call error_stop("Error(norm_dist_rvs_array):" & - //" Normal distribution scale parameter must be non-zero") - if( .not. zig_norm_initialized ) call zigset - allocate(res(array_size)) - do i = 1, array_size - iz = 0 - ! original algorithm use 32bit - hz = dist_rand(1_int32) - -======= if(scale == 0._${k1}$) call error_stop("Error(rvs_norm_array): Normal" & //"distribution scale parameter must be non-zero") if(.not. zig_norm_initialized) call zigset do i = 1, array_size iz = 0 hz = dist_rand(1_int32) ->>>>>>> upstream/master iz = iand( hz, 127 ) if( abs( hz ) < kn(iz) ) then re = hz * wn(iz) @@ -431,10 +233,6 @@ contains exit L1 end if -<<<<<<< HEAD - !original algorithm use 32bit -======= ->>>>>>> upstream/master hz = dist_rand(1_int32) iz = iand( hz, 127 ) if( abs( hz ) < kn(iz) ) then @@ -445,95 +243,6 @@ contains end if res(i) = re * scale + loc end do -<<<<<<< HEAD - return - end function norm_dist_rvs_array_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in CMPLX_KINDS_TYPES - function norm_dist_rvs_array_${t1[0]}$${k1}$(loc, scale, array_size) & - result(res) - ${t1}$, intent(in) :: loc, scale - integer, intent(in) :: array_size - integer :: i - ${t1}$, allocatable :: res(:) - real(${k1}$) :: tr, ti - - allocate(res(array_size)) - do i = 1, array_size - tr = norm_dist_rvs_r${k1}$(real(loc), real(scale)) - ti = norm_dist_rvs_r${k1}$(aimag(loc), aimag(scale)) - res(i) = cmplx(tr, ti, kind=${k1}$) - end do - return - end function norm_dist_rvs_array_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function norm_dist_pdf_${t1[0]}$${k1}$(x, loc, scale) & - result(res) - ! Normal distributed probability function - ! - ${t1}$, intent(in) :: x, loc, scale - real :: res - ${t1}$, parameter :: sqrt_2_pi = sqrt(2.0_${k1}$ * acos(-1.0_${k1}$)) - - if(scale==0._${k1}$) call error_stop("Error(norm_dist_pdf):" & - //" Normal distribution scale parameter must be non-zero") - res = exp(- 0.5_${k1}$ * (x - loc) * (x - loc) / (scale * scale)) / & - (sqrt_2_Pi * scale) - return - end function norm_dist_pdf_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in CMPLX_KINDS_TYPES - impure elemental function norm_dist_pdf_${t1[0]}$${k1}$(x, loc, scale) & - result(res) - ${t1}$, intent(in) :: x, loc, scale - real :: res - - res = norm_dist_pdf_r${k1}$(real(x), real(loc), real(scale)) - res = res * norm_dist_pdf_r${k1}$(aimag(x), aimag(loc), aimag(scale)) - return - end function norm_dist_pdf_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function norm_dist_cdf_${t1[0]}$${k1}$(x, loc, scale) & - result(res) - ! Normal random cumulative distribution function - ! - ${t1}$, intent(in) :: x, loc, scale - real :: res - ${t1}$, parameter :: sqrt_2 = sqrt(2.0_${k1}$) - - if(scale==0._${k1}$) call error_stop("Error(norm_dist_cdf):" & - //" Normal distribution scale parameter must be non-zero") - res = (1.0_${k1}$ + erf((x - loc) / (scale * sqrt_2))) / 2.0_${k1}$ - return - end function norm_dist_cdf_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in CMPLX_KINDS_TYPES - impure elemental function norm_dist_cdf_${t1[0]}$${k1}$(x, loc, scale) & - result(res) - ${t1}$, intent(in) :: x, loc, scale - real :: res - - res = norm_dist_cdf_r${k1}$(real(x), real(loc), real(scale)) - res = res * norm_dist_cdf_r${k1}$(aimag(x), aimag(loc), aimag(scale)) - return - end function norm_dist_cdf_${t1[0]}$${k1}$ - - #:endfor - -end module stdlib_stats_distribution_normal -======= end function rvs_norm_array_${t1[0]}$${k1}$ #:endfor @@ -621,4 +330,3 @@ end module stdlib_stats_distribution_normal #:endfor end module stdlib_stats_distribution_normal ->>>>>>> upstream/master diff --git a/src/stdlib_stats_distribution_uniform.fypp b/src/stdlib_stats_distribution_uniform.fypp index f9c40a3bf..1bf67a698 100644 --- a/src/stdlib_stats_distribution_uniform.fypp +++ b/src/stdlib_stats_distribution_uniform.fypp @@ -1,17 +1,10 @@ #:include "common.fypp" #:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES #:set ALL_KINDS_TYPES = INT_KINDS_TYPES + RC_KINDS_TYPES -<<<<<<< HEAD -Module stdlib_stats_distribution_uniform - use stdlib_kinds - use stdlib_error, only : error_stop - use stdlib_stats_distribution_PRNG, only : dist_rand -======= module stdlib_stats_distribution_uniform use stdlib_kinds, only : sp, dp, xdp, qp, int8, int16, int32, int64 use stdlib_error, only : error_stop use stdlib_random, only : dist_rand ->>>>>>> upstream/master implicit none private @@ -19,68 +12,6 @@ module stdlib_stats_distribution_uniform real(dp), parameter :: MESENNE_NUMBER = 1.0_dp / (2.0_dp ** 53 - 1.0_dp) integer(int64), parameter :: INT_ONE = 1_int64 -<<<<<<< HEAD - public :: uniform_distribution_rvs - public :: uniform_distribution_pdf - public :: uniform_distribution_cdf - public :: shuffle - - interface uniform_distribution_rvs - !! Version experimental - !! - !! Get uniformly distributed random variate for integer, real and complex - !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# - !! description)) - - module procedure unif_dist_rvs_0_rsp ! 0 dummy variable - - #:for k1, t1 in ALL_KINDS_TYPES - module procedure unif_dist_rvs_1_${t1[0]}$${k1}$ ! 1 dummy variable - #:endfor - - #:for k1, t1 in ALL_KINDS_TYPES - module procedure unif_dist_rvs_${t1[0]}$${k1}$ ! 2 dummy variables - #:endfor - - #:for k1, t1 in ALL_KINDS_TYPES - module procedure unif_dist_rvs_array_${t1[0]}$${k1}$ ! 3 dummy variables - #:endfor - end interface uniform_distribution_rvs - - interface uniform_distribution_pdf - !! Version experiment - !! - !! Get uniform distribution probability density (pdf) for integer, real and - !! complex variables - !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# - !! description)) - - #:for k1, t1 in ALL_KINDS_TYPES - module procedure unif_dist_pdf_${t1[0]}$${k1}$ - #:endfor - end interface uniform_distribution_pdf - - interface uniform_distribution_cdf - !! Version experimental - !! - !! Get uniform distribution cumulative distribution function (cdf) for - !! integer, real and complex variables - !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# - !! description)) - !! - #:for k1, t1 in ALL_KINDS_TYPES - module procedure unif_dist_cdf_${t1[0]}$${k1}$ - #:endfor - end interface uniform_distribution_cdf - - interface shuffle - !! Version experimental - !! - !! Fisher-Yates shuffle algorithm for a rank one array of integer, real and - !! complex variables - !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# - !! description)) -======= public :: rvs_uniform public :: pdf_uniform public :: cdf_uniform @@ -146,7 +77,6 @@ module stdlib_stats_distribution_uniform !! complex variables. !! ([Specification](../page/specs/stdlib_stats_distribution_uniform.html# !! shuffle-using-fisher-yates-algorithm-to-generate-a-random-permutation-of-a-list)) ->>>>>>> upstream/master !! #:for k1, t1 in ALL_KINDS_TYPES module procedure shuffle_${t1[0]}$${k1}$ @@ -154,12 +84,6 @@ module stdlib_stats_distribution_uniform end interface shuffle -<<<<<<< HEAD - contains - - #:for k1, t1 in INT_KINDS_TYPES - impure elemental function unif_dist_rvs_1_${t1[0]}$${k1}$(scale) result(res) -======= @@ -170,7 +94,6 @@ contains #:for k1, t1 in INT_KINDS_TYPES impure elemental function rvs_unif_1_${t1[0]}$${k1}$(scale) result(res) ! ->>>>>>> upstream/master ! Uniformly distributed integer in [0, scale] ! Bitmask with rejection ! https://www.pcg-random.org/posts/bounded-rands.html @@ -178,21 +101,6 @@ contains ! Fortran 90 translated from c by Jim-215-fisher ! ${t1}$, intent(in) :: scale -<<<<<<< HEAD - ${t1}$ :: res, u, mask, n - integer :: zeros, bits_left, bits - - n = scale - if(n <= 0_${k1}$) call error_stop("Error(unif_dist_rvs_1): Uniform" & - //" distribution scale parameter must be positive") - zeros = leadz(n) - bits = bit_size(n) - zeros - mask = shiftr(not(0_${k1}$), zeros) - L1 : do - u = dist_rand(n) - res = iand(u, mask) - if(res <= n) exit L1 -======= ${t1}$ :: res, u, mask integer :: zeros, bits_left, bits @@ -205,26 +113,11 @@ contains u = dist_rand(scale) res = iand(u, mask) if(res <= scale) exit L1 ->>>>>>> upstream/master bits_left = zeros L2 : do if(bits_left < bits) exit L2 u = shiftr(u, bits) res = iand(u, mask) -<<<<<<< HEAD - if(res <= n) exit L1 - bits_left = bits_left - bits - end do L2 - end do L1 - return - end function unif_dist_rvs_1_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in INT_KINDS_TYPES - impure elemental function unif_dist_rvs_${t1[0]}$${k1}$(loc, scale) & - result( res ) -======= if(res <= scale) exit L1 bits_left = bits_left - bits end do L2 @@ -238,24 +131,11 @@ contains #:for k1, t1 in INT_KINDS_TYPES impure elemental function rvs_unif_${t1[0]}$${k1}$(loc, scale) result(res) ! ->>>>>>> upstream/master ! Uniformly distributed integer in [loc, loc + scale] ! ${t1}$, intent(in) :: loc, scale ${t1}$ :: res -<<<<<<< HEAD - if(scale <= 0_${k1}$) call error_stop("Error(unif_dist_rvs): Uniform" & - //" distribution scale parameter must be positive") - res = loc + unif_dist_rvs_1_${t1[0]}$${k1}$(scale) - return - end function unif_dist_rvs_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function unif_dist_rvs_0_${t1[0]}$${k1}$( ) result(res) -======= if(scale <= 0_${k1}$) call error_stop("Error(rvs_unif): Uniform" & //" distribution scale parameter must be positive") res = loc + rvs_unif_1_${t1[0]}$${k1}$(scale) @@ -268,7 +148,6 @@ contains #:for k1, t1 in REAL_KINDS_TYPES impure elemental function rvs_unif_0_${t1[0]}$${k1}$( ) result(res) ! ->>>>>>> upstream/master ! Uniformly distributed float in [0,1] ! Based on the paper by Frederic Goualard, "Generating Random Floating- ! Point Numbers By Dividing Integers: a Case Study", Proceedings of @@ -278,16 +157,6 @@ contains integer(int64) :: tmp tmp = shiftr(dist_rand(INT_ONE), 11) ! Get random from [0,2^53-1] -<<<<<<< HEAD - res = real(tmp * MESENNE_NUMBER, kind =${k1}$) ! convert to [0,1] - return - end function unif_dist_rvs_0_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function unif_dist_rvs_1_${t1[0]}$${k1}$(scale) result(res) -======= res = real(tmp * MESENNE_NUMBER, kind = ${k1}$) ! convert to [0,1] end function rvs_unif_0_${t1[0]}$${k1}$ @@ -298,25 +167,11 @@ contains #:for k1, t1 in REAL_KINDS_TYPES impure elemental function rvs_unif_1_${t1[0]}$${k1}$(scale) result(res) ! ->>>>>>> upstream/master ! Uniformly distributed float in [0, scale] ! ${t1}$, intent(in) :: scale ${t1}$ :: res -<<<<<<< HEAD - if(scale == 0._${k1}$) call error_stop("Error(unif_dist_rvs_1): " & - //"Uniform distribution scale parameter must be non-zero") - res = scale * unif_dist_rvs_0_${t1[0]}$${k1}$( ) - return - end function unif_dist_rvs_1_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - impure elemental function unif_dist_rvs_${t1[0]}$${k1}$(loc, scale) & - result(res) -======= if(scale == 0._${k1}$) call error_stop("Error(rvs_unif_1): " & //"Uniform distribution scale parameter must be non-zero") res = scale * rvs_unif_0_${t1[0]}$${k1}$( ) @@ -329,56 +184,11 @@ contains #:for k1, t1 in REAL_KINDS_TYPES impure elemental function rvs_unif_${t1[0]}$${k1}$(loc, scale) result(res) ! ->>>>>>> upstream/master ! Uniformly distributed float in [loc, loc + scale] ! ${t1}$, intent(in) :: loc, scale ${t1}$ :: res -<<<<<<< HEAD - if(scale == 0._${k1}$) call error_stop("Error(unif_dist_rvs): " & - //"Uniform distribution scale parameter must be non-zero") - res = loc + scale * unif_dist_rvs_0_${t1[0]}$${k1}$( ) - return - end function unif_dist_rvs_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in CMPLX_KINDS_TYPES - impure elemental function unif_dist_rvs_1_${t1[0]}$${k1}$(scale) result(res) - ! Uniformly distributed complex in [(0,0i), (scale, i(scale)] - ! The real part and imaginary part are independent of each other, so that - ! the joint distribution is on an unit square [(0,0i), scale,i(scale)] - ! - ${t1}$, intent(in) :: scale - ${t1}$ :: res - real(${k1}$) :: r1, r2, tr, ti - - if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error(uni_dist_" & - //"rvs_1): Uniform distribution scale parameter must be non-zero") - r1 = unif_dist_rvs_0_r${k1}$( ) - if(real(scale) == 0.0_${k1}$) then - ti = aimag(scale) * r1 - tr = 0.0_${k1}$ - elseif(aimag(scale) == 0.0_${k1}$) then - tr = real(scale) * r1 - ti = 0.0_${k1}$ - else - r2 = unif_dist_rvs_0_r${k1}$( ) - tr = real(scale) * r1 - ti = aimag(scale) * r2 - endif - res = cmplx(tr, ti, kind=${k1}$) - return - end function unif_dist_rvs_1_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in CMPLX_KINDS_TYPES - impure elemental function unif_dist_rvs_${t1[0]}$${k1}$(loc, scale) & - result(res) - ! Uniformly distributed complex in [(loc,iloc), (loc + scale, i(loc + scale)] -======= if(scale == 0._${k1}$) call error_stop("Error(rvs_unif): " & //"Uniform distribution scale parameter must be non-zero") res = loc + scale * rvs_unif_0_${t1[0]}$${k1}$( ) @@ -425,58 +235,12 @@ contains ! ! Uniformly distributed complex in [(loc,iloc), (loc + scale, i(loc + ! scale))]. ->>>>>>> upstream/master ! The real part and imaginary part are independent of each other, so that ! the joint distribution is on an unit square [(loc,iloc), (loc + scale, ! i(loc + scale))] ! ${t1}$, intent(in) :: loc, scale ${t1}$ :: res -<<<<<<< HEAD - real(${k1}$) :: r1, r2, tr, ti - - if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error(uni_dist_" & - //"rvs): Uniform distribution scale parameter must be non-zero") - r1 = unif_dist_rvs_0_r${k1}$( ) - if(real(scale) == 0.0_${k1}$) then - tr = real(loc) - ti = aimag(loc) + aimag(scale) * r1 - elseif(aimag(scale) == 0.0_${k1}$) then - tr = real(loc) + real(scale) * r1 - ti = aimag(loc) - else - r2 = unif_dist_rvs_0_r${k1}$( ) - tr = real(loc) + real(scale) * r1 - ti = aimag(loc) + aimag(scale) * r2 - endif - res = cmplx(tr, ti, kind=${k1}$) - return - end function unif_dist_rvs_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in INT_KINDS_TYPES - function unif_dist_rvs_array_${t1[0]}$${k1}$(loc, scale, array_size) & - result(res) - ${t1}$, intent(in) :: loc, scale - ${t1}$, allocatable :: res(:) - ${t1}$ :: u, mask, n, nn - integer, intent(in) :: array_size - integer :: i, zeros, bits_left, bits - - n = scale - if(n == 0_${k1}$) call error_stop("Error(unif_dist_rvs_array): Uniform" & - //" distribution scale parameter must be non-zero") - allocate(res(array_size)) - zeros = leadz(n) - bits = bit_size(n) - zeros - mask = shiftr(not(0_${k1}$), zeros) - do i = 1, array_size - L1 : do - u = dist_rand(n) - nn = iand(u, mask) - if(nn <= n) exit L1 -======= real(${k1}$) :: r1, tr, ti if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error(rvs_uni_" & @@ -519,36 +283,17 @@ contains u = dist_rand(scale) nn = iand(u, mask) if(nn <= scale) exit L1 ->>>>>>> upstream/master bits_left = zeros L2 : do if(bits_left < bits) exit L2 u = shiftr(u, bits) nn = iand(u, mask) -<<<<<<< HEAD - if(nn <= n) exit L1 -======= if(nn <= scale) exit L1 ->>>>>>> upstream/master bits_left = bits_left - bits end do L2 end do L1 res(i) = loc + nn end do -<<<<<<< HEAD - return - end function unif_dist_rvs_array_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - function unif_dist_rvs_array_${t1[0]}$${k1}$(loc, scale, array_size) & - result(res) - ${t1}$, intent(in) :: loc, scale - ${t1}$, allocatable :: res(:) - ${t1}$ :: t - integer, intent(in) :: array_size -======= end function rvs_unif_array_${t1[0]}$${k1}$ #:endfor @@ -562,38 +307,16 @@ contains ${t1}$, intent(in) :: loc, scale ${t1}$ :: res(array_size) ${t1}$ :: t ->>>>>>> upstream/master integer(int64) :: tmp integer :: i -<<<<<<< HEAD - if(scale == 0._${k1}$) call error_stop("Error(unif_dist_rvs_array):" & - //" Uniform distribution scale parameter must be non-zero") - allocate(res(array_size)) -======= if(scale == 0._${k1}$) call error_stop("Error(rvs_unif_array):" & //" Uniform distribution scale parameter must be non-zero") ->>>>>>> upstream/master do i = 1, array_size tmp = shiftr(dist_rand(INT_ONE), 11) t = real(tmp * MESENNE_NUMBER, kind = ${k1}$) res(i) = loc + scale * t -<<<<<<< HEAD - enddo - return - end function unif_dist_rvs_array_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in CMPLX_KINDS_TYPES - function unif_dist_rvs_array_${t1[0]}$${k1}$(loc, scale, array_size) & - result(res) - ${t1}$, intent(in) :: loc, scale - ${t1}$, allocatable :: res(:) - real(${k1}$) :: r1, r2, tr, ti - integer, intent(in) :: array_size -======= end do end function rvs_unif_array_${t1[0]}$${k1}$ @@ -608,46 +331,10 @@ contains ${t1}$, intent(in) :: loc, scale ${t1}$ :: res(array_size) real(${k1}$) :: r1, tr, ti ->>>>>>> upstream/master integer(int64) :: tmp integer :: i -<<<<<<< HEAD - if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error(unif_dist_"& - //"rvs_array): Uniform distribution scale parameter must be non-zero") - allocate(res(array_size)) - do i = 1, array_size - tmp = shiftr(dist_rand(INT_ONE), 11) - r1 = real(tmp * MESENNE_NUMBER, kind = ${k1}$) - if(real(scale) == 0.0_${k1}$) then - tr = real(loc) - ti = aimag(loc) + aimag(scale) * r1 - elseif(aimag(scale) == 0.0_${k1}$) then - tr = real(loc) + real(scale) * r1 - ti = aimag(loc) - else - tmp = shiftr(dist_rand(INT_ONE), 11) - r2 = real(tmp * MESENNE_NUMBER, kind = ${k1}$) - tr = real(loc) + real(scale) * r1 - ti = aimag(loc) + aimag(scale) * r2 - endif - res(i) = cmplx(tr, ti, kind=${k1}$) - enddo - return - end function unif_dist_rvs_array_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in INT_KINDS_TYPES - elemental function unif_dist_pdf_${t1[0]}$${k1}$(x, loc, scale) result(res) - ${t1}$, intent(in) :: x, loc, scale - real :: res - - if(scale == 0) then - res = 0.0 - elseif(x < loc .or. x > (loc + scale)) then -======= if(scale == (0.0_${k1}$, 0.0_${k1}$)) call error_stop("Error(rvs_unif" & //"_array): Uniform distribution scale parameter must be non-zero") do i = 1, array_size @@ -682,65 +369,10 @@ contains if(scale == 0_${k1}$) then res = 0.0 else if(x < loc .or. x > (loc + scale)) then ->>>>>>> upstream/master res = 0.0 else res = 1. / (scale + 1_${k1}$) end if -<<<<<<< HEAD - return - end function unif_dist_pdf_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - elemental function unif_dist_pdf_${t1[0]}$${k1}$(x, loc, scale) result(res) - ${t1}$, intent(in) :: x, loc, scale - real :: res - - if(scale == 0.0_${k1}$) then - res = 0.0 - elseif(x <= loc .or. x >= (loc + scale)) then - res = 0.0 - else - res = 1.0 / scale - end if - return - end function unif_dist_pdf_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in CMPLX_KINDS_TYPES - elemental function unif_dist_pdf_${t1[0]}$${k1}$(x, loc, scale) result(res) - ${t1}$, intent(in) :: x, loc, scale - real :: res - real(${k1}$) :: tr, ti - - tr = real(loc) + real(scale); ti = aimag(loc) + aimag(scale) - if(scale == (0.0_${k1}$,0.0_${k1}$)) then - res = 0.0 - elseif((real(x) >= real(loc) .and. real(x) <= tr) .and. & - (aimag(x) >= aimag(loc) .and. aimag(x) <= ti)) then - res = 1.0 / (real(scale) * aimag(scale)) - else - res = 0.0 - end if - return - end function unif_dist_pdf_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in INT_KINDS_TYPES - elemental function unif_dist_cdf_${t1[0]}$${k1}$(x, loc, scale) result(res) - ${t1}$, intent(in) :: x, loc, scale - real :: res - - if(scale == 0) then - res = 0.0 - elseif(x < loc) then - res = 0.0 - elseif(x >= loc .and. x <= (loc + scale)) then -======= end function pdf_unif_${t1[0]}$${k1}$ #:endfor @@ -800,73 +432,10 @@ contains else if(x < loc) then res = 0.0 else if(x >= loc .and. x <= (loc + scale)) then ->>>>>>> upstream/master res = real((x - loc + 1_${k1}$)) / real((scale + 1_${k1}$)) else res = 1.0 end if -<<<<<<< HEAD - return - end function unif_dist_cdf_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in REAL_KINDS_TYPES - elemental function unif_dist_cdf_${t1[0]}$${k1}$(x, loc, scale) result(res) - ${t1}$, intent(in) :: x, loc, scale - real :: res - - if(scale == 0.0_${k1}$) then - res = 0.0 - elseif(x < loc) then - res = 0.0 - elseif(x >= loc .and. x <= (loc + scale)) then - res = (x - loc) / scale - else - res = 1.0 - end if - return - end function unif_dist_cdf_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in CMPLX_KINDS_TYPES - elemental function unif_dist_cdf_${t1[0]}$${k1}$(x, loc, scale) result(res) - ${t1}$, intent(in) :: x, loc, scale - real :: res - logical :: r1, r2, i1, i2 - - if(scale == (0.0_${k1}$,0.0_${k1}$)) then - res = 0.0 - return - endif - r1 = real(x) < real(loc) - r2 = real(x) > (real(loc) + real(scale)) - i1 = aimag(x) < aimag(loc) - i2 = aimag(x) > (aimag(loc) + aimag(scale)) - if(r1 .or. i1) then - res = 0.0 - elseif((.not. r1) .and. (.not. r2) .and. i2) then - res = (real(x) - real(loc)) / real(scale) - elseif((.not. i1) .and. (.not. i2) .and. r2) then - res = (aimag(x) - aimag(loc)) / aimag(scale) - elseif((.not. r1) .and. (.not. r2) .and. (.not. i1) .and. (.not. i2)) & - then - res = (real(x) - real(loc)) * (aimag(x) - aimag(loc)) / & - (real(scale) * aimag(scale)) - elseif(r2 .and. i2)then - res = 1.0 - end if - return - end function unif_dist_cdf_${t1[0]}$${k1}$ - - #:endfor - - #:for k1, t1 in ALL_KINDS_TYPES - function shuffle_${t1[0]}$${k1}$( list ) result(res) - ${t1}$, intent(in) :: list(:) - ${t1}$, allocatable :: res(:) -======= end function cdf_unif_${t1[0]}$${k1}$ #:endfor @@ -935,33 +504,18 @@ contains ${t1}$, intent(in) :: list(:) ${t1}$ :: res(size(list)) ->>>>>>> upstream/master ${t1}$ :: tmp integer :: n, i, j n = size(list) -<<<<<<< HEAD - allocate(res(n), source=list) - do i = 1, n - 1 - j = uniform_distribution_rvs(n - i) + i -======= res = list do i = 1, n - 1 j = rvs_uniform(n - i) + i ->>>>>>> upstream/master tmp = res(i) res(i) = res(j) res(j) = tmp end do -<<<<<<< HEAD - return - end function shuffle_${t1[0]}$${k1}$ - - #:endfor -end module stdlib_stats_distribution_uniform -======= end function shuffle_${t1[0]}$${k1}$ #:endfor end module stdlib_stats_distribution_uniform ->>>>>>> upstream/master diff --git a/src/tests/stats/CMakeLists.txt b/src/tests/stats/CMakeLists.txt index ff9d45063..94990ccf1 100644 --- a/src/tests/stats/CMakeLists.txt +++ b/src/tests/stats/CMakeLists.txt @@ -8,6 +8,7 @@ set(fppFiles test_distribution_uniform.fypp test_distribution_normal.fypp test_distribution_exponential.fypp + test_distribution_gamma.fypp ) fypp_f90("${fyppFlags}" "${fppFiles}" outFiles) @@ -24,6 +25,7 @@ ADDTEST(random) ADDTEST(distribution_uniform) ADDTEST(distribution_normal) ADDTEST(distribution_exponential) +ADDTEST(distribution_gamma) if(DEFINED CMAKE_MAXIMUM_RANK) if(${CMAKE_MAXIMUM_RANK} GREATER 7) diff --git a/src/tests/stats/test_distribution_gamma.f90 b/src/tests/stats/test_distribution_gamma.f90 deleted file mode 100644 index 797d03d8b..000000000 --- a/src/tests/stats/test_distribution_gamma.f90 +++ /dev/null @@ -1,530 +0,0 @@ -program test_distribution_gamma - use stdlib_kinds - use stdlib_error, only : check - use stdlib_stats_distribution_PRNG, only: random_seed - use stdlib_stats_distribution_gamma, gamma_rvs => gamma_distribution_rvs, & - gamma_pdf => gamma_distribution_pdf, & - gamma_cdf => gamma_distribution_cdf - - implicit none - real(sp), parameter :: sptol = 1000 * epsilon(1.0_sp) - real(dp), parameter :: dptol = 1000 * epsilon(1.0_dp) - real(qp), parameter :: qptol = 1000 * epsilon(1.0_qp) - logical :: warn = .true. - integer :: put, get - - put = 1234567 - call random_seed(put, get) - - call test_gamma_random_generator - - call test_gamma_rvs_rsp - call test_gamma_rvs_rdp - call test_gamma_rvs_rqp - call test_gamma_rvs_csp - call test_gamma_rvs_cdp - call test_gamma_rvs_cqp - - call test_gamma_pdf_rsp - call test_gamma_pdf_rdp - call test_gamma_pdf_rqp - call test_gamma_pdf_csp - call test_gamma_pdf_cdp - call test_gamma_pdf_cqp - - call test_gamma_cdf_rsp - call test_gamma_cdf_rdp - call test_gamma_cdf_rqp - call test_gamma_cdf_csp - call test_gamma_cdf_cdp - call test_gamma_cdf_cqp - - - contains - - subroutine test_gamma_random_generator - integer :: i, j, freq(0:1000), num=10000000 - real(dp) :: chisq, expct - - print *, "" - print *, "Test gamma random generator with chi-squared" - freq = 0 - do i = 1, num - j = 1000 * gamma_cdf(gamma_rvs(2.0,1.5),2.0,1.5) - freq(j) = freq(j) + 1 - end do - chisq = 0.0_dp - expct = num / 1000 - do i = 0, 999 - chisq = chisq + (freq(i) - expct) ** 2 / expct - end do - write(*,*) "The critical values for chi-squared with 1000 d. of f. is" & - //" 1143.92" - write(*,*) "Chi-squared for gamma random generator is : ", chisq - call check((chisq < 1143.9), & - msg="gamma randomness failed chi-squared test", warn=warn) - end subroutine test_gamma_random_generator - - subroutine test_gamma_rvs_rsp - real(sp) :: res(10), gshape, scale - integer :: i, n, k = 5 - integer :: put, get - real(sp) :: ans(10) = [0.857589039350877514111471181067133115_sp, & - 1.02066235929592669341367273855793615_sp, & - 0.997539313039285858469791992057480517_sp, & - 0.976533566171099213454202419140525167_sp, & - 0.418534850809151373739671312677149231_sp, & - 2.20122874546440374485431246113130646_sp, & - 2.06395422779089208145254668611859318_sp, & - 3.17946689363011574223408637477787452_sp, & - 1.93297441375957258760155732080675223_sp, & - 1.02579597344383310585282655020137840_sp] - - print *, "Test gamma_distribution_rvs_rsp" - put = 639741825 - call random_seed(put, get) - gshape = 2.0_sp; scale = 1.0_sp - do i = 1, 5 - res(i) = gamma_rvs(gshape, scale) - end do - res(6:10) = gamma_rvs(gshape, scale, k) - call check(all(abs(res - ans) < sptol), & - msg="gamma_distribution_rvs_rsp failed", warn=warn) - end subroutine test_gamma_rvs_rsp - - subroutine test_gamma_rvs_rdp - real(dp) :: res(10), gshape, scale - integer :: i, n, k = 5 - integer :: put, get - real(dp) :: ans(10) = [0.857589039350877514111471181067133115_dp, & - 1.02066235929592669341367273855793615_dp, & - 0.997539313039285858469791992057480517_dp, & - 0.976533566171099213454202419140525167_dp, & - 0.418534850809151373739671312677149231_dp, & - 2.20122874546440374485431246113130646_dp, & - 2.06395422779089208145254668611859318_dp, & - 3.17946689363011574223408637477787452_dp, & - 1.93297441375957258760155732080675223_dp, & - 1.02579597344383310585282655020137840_dp] - - print *, "Test gamma_distribution_rvs_rdp" - put = 639741825 - call random_seed(put, get) - gshape = 2.0_dp; scale = 1.0_dp - do i = 1, 5 - res(i) = gamma_rvs(gshape, scale) - end do - res(6:10) = gamma_rvs(gshape, scale, k) - call check(all(abs(res - ans) < dptol), & - msg="gamma_distribution_rvs_rdp failed", warn=warn) - end subroutine test_gamma_rvs_rdp - - subroutine test_gamma_rvs_rqp - real(qp) :: res(10), gshape, scale - integer :: i, n, k = 5 - integer :: put, get - real(qp) :: ans(10) = [0.857589039350877514111471181067133115_qp, & - 1.02066235929592669341367273855793615_qp, & - 0.997539313039285858469791992057480517_qp, & - 0.976533566171099213454202419140525167_qp, & - 0.418534850809151373739671312677149231_qp, & - 2.20122874546440374485431246113130646_qp, & - 2.06395422779089208145254668611859318_qp, & - 3.17946689363011574223408637477787452_qp, & - 1.93297441375957258760155732080675223_qp, & - 1.02579597344383310585282655020137840_qp] - - print *, "Test gamma_distribution_rvs_rqp" - put = 639741825 - call random_seed(put, get) - gshape = 2.0_qp; scale = 1.0_qp - do i = 1, 5 - res(i) = gamma_rvs(gshape, scale) - end do - res(6:10) = gamma_rvs(gshape, scale, k) - call check(all(abs(res - ans) < qptol), & - msg="gamma_distribution_rvs_rqp failed", warn=warn) - end subroutine test_gamma_rvs_rqp - - subroutine test_gamma_rvs_csp - complex(sp) :: res(10), gshape, scale - integer :: i, n, k = 5 - integer :: put, get - complex(sp) :: ans(10) = [(1.07198631763458251953125000000000000_sp, & - 0.467755347490310668945312500000000000_sp), & - (0.423825174570083618164062500000000000_sp, & - 0.963404953479766845703125000000000000_sp), & - (2.75153589248657226562500000000000000_sp, & - 0.148371994495391845703125000000000000_sp), & - (1.45363664627075195312500000000000000_sp, & - 0.568527400493621826171875000000000000_sp), & - (0.345591425895690917968750000000000000_sp, & - 4.962176829576492309570312500000000000E-0002_sp), & - (1.96578848361968994140625000000000000_sp, & - 3.11243152618408203125000000000000000_sp), & - (3.41551613807678222656250000000000000_sp, & - 5.049489438533782958984375000000000000E-0002_sp), & - (0.945943951606750488281250000000000000_sp, & - 0.456915855407714843750000000000000000_sp), & - (1.14931583404541015625000000000000000_sp, & - 0.129447638988494873046875000000000000_sp), & - (2.96914696693420410156250000000000000_sp, & - 1.16174089908599853515625000000000000_sp)] - - print *, "Test gamma_distribution_rvs_csp" - put = 639741825 - call random_seed(put, get) - gshape = (2.0_sp, 0.7_sp); scale = (0.8_sp, 1.2_sp) - do i = 1, 5 - res(i) = gamma_rvs(gshape, scale) - end do - res(6:10) = gamma_rvs(gshape, scale, k) - call check(all(abs(res - ans) < sptol), & - msg="gamma_distribution_rvs_csp failed", warn=warn) - end subroutine test_gamma_rvs_csp - - subroutine test_gamma_rvs_cdp - complex(dp) :: res(10), gshape, scale - integer :: i, n, k = 5 - integer :: put, get - complex(dp) :: ans(10) = [(1.07198631763458251953125000000000000_dp, & - 0.467755347490310668945312500000000000_dp), & - (0.423825174570083618164062500000000000_dp, & - 0.963404953479766845703125000000000000_dp), & - (2.75153589248657226562500000000000000_dp, & - 0.148371994495391845703125000000000000_dp), & - (1.45363664627075195312500000000000000_dp, & - 0.568527400493621826171875000000000000_dp), & - (0.345591425895690917968750000000000000_dp, & - 4.962176829576492309570312500000000000E-0002_dp), & - (1.96578848361968994140625000000000000_dp, & - 3.11243152618408203125000000000000000_dp), & - (3.41551613807678222656250000000000000_dp, & - 5.049489438533782958984375000000000000E-0002_dp), & - (0.945943951606750488281250000000000000_dp, & - 0.456915855407714843750000000000000000_dp), & - (1.14931583404541015625000000000000000_dp, & - 0.129447638988494873046875000000000000_dp), & - (2.96914696693420410156250000000000000_dp, & - 1.16174089908599853515625000000000000_dp)] - - print *, "Test gamma_distribution_rvs_cdp" - put = 639741825 - call random_seed(put, get) - gshape = (2.0_dp, 0.7_dp); scale = (0.8_dp, 1.2_dp) - do i = 1, 5 - res(i) = gamma_rvs(gshape, scale) - end do - res(6:10) = gamma_rvs(gshape, scale, k) - call check(all(abs(res - ans) < dptol), & - msg="gamma_distribution_rvs_cdp failed", warn=warn) - end subroutine test_gamma_rvs_cdp - - subroutine test_gamma_rvs_cqp - complex(qp) :: res(10), gshape, scale - integer :: i, n, k = 5 - integer :: put, get - complex(qp) :: ans(10) = [(1.07198631763458251953125000000000000_qp, & - 0.467755347490310668945312500000000000_qp), & - (0.423825174570083618164062500000000000_qp, & - 0.963404953479766845703125000000000000_qp), & - (2.75153589248657226562500000000000000_qp, & - 0.148371994495391845703125000000000000_qp), & - (1.45363664627075195312500000000000000_qp, & - 0.568527400493621826171875000000000000_qp), & - (0.345591425895690917968750000000000000_qp, & - 4.962176829576492309570312500000000000E-0002_qp), & - (1.96578848361968994140625000000000000_qp, & - 3.11243152618408203125000000000000000_qp), & - (3.41551613807678222656250000000000000_qp, & - 5.049489438533782958984375000000000000E-0002_qp), & - (0.945943951606750488281250000000000000_qp, & - 0.456915855407714843750000000000000000_qp), & - (1.14931583404541015625000000000000000_qp, & - 0.129447638988494873046875000000000000_qp), & - (2.96914696693420410156250000000000000_qp, & - 1.16174089908599853515625000000000000_qp)] - - print *, "Test gamma_distribution_rvs_cqp" - put = 639741825 - call random_seed(put, get) - gshape = (2.0_qp, 0.7_qp); scale = (0.8_qp, 1.2_qp) - do i = 1, 5 - res(i) = gamma_rvs(gshape, scale) - end do - res(6:10) = gamma_rvs(gshape, scale, k) - call check(all(abs(res - ans) < qptol), & - msg="gamma_distribution_rvs_cqp failed", warn=warn) - end subroutine test_gamma_rvs_cqp - - - - subroutine test_gamma_pdf_rsp - real(sp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [3.44954208E-02, 3.44954208E-02, 3.44954208E-02, & - 0.291166335, 0.283382922, 0.279222697, 0.364406645, & - 0.243792102,6.38156384E-02,0.258446008, 0.172681183, & - 0.311812222, 0.240270957, 0.367655009, 9.90117192E-02] - - print *, "Test gamma_distribution_pdf_rsp" - put = 345987126 - call random_seed(put, get) - gshape = 2.0_sp; scale = 1.0_sp - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_pdf(x1, gshape, scale) - res(:, 2:5) = gamma_pdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans, [3,5])) < sptol), & - msg="gamma_distribution_pdf_rsp failed", warn=warn) - end subroutine test_gamma_pdf_rsp - - subroutine test_gamma_pdf_rdp - real(dp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [3.44954208E-02, 3.44954208E-02, 3.44954208E-02, & - 0.291166335, 0.283382922, 0.279222697, 0.364406645, & - 0.243792102,6.38156384E-02,0.258446008, 0.172681183, & - 0.311812222, 0.240270957, 0.367655009, 9.90117192E-02] - - print *, "Test gamma_distribution_pdf_rdp" - put = 345987126 - call random_seed(put, get) - gshape = 2.0_dp; scale = 1.0_dp - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_pdf(x1, gshape, scale) - res(:, 2:5) = gamma_pdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans, [3,5])) < dptol), & - msg="gamma_distribution_pdf_rdp failed", warn=warn) - end subroutine test_gamma_pdf_rdp - - subroutine test_gamma_pdf_rqp - real(qp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [3.44954208E-02, 3.44954208E-02, 3.44954208E-02, & - 0.291166335, 0.283382922, 0.279222697, 0.364406645, & - 0.243792102,6.38156384E-02,0.258446008, 0.172681183, & - 0.311812222, 0.240270957, 0.367655009, 9.90117192E-02] - - print *, "Test gamma_distribution_pdf_rqp" - put = 345987126 - call random_seed(put, get) - gshape = 2.0_qp; scale = 1.0_qp - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_pdf(x1, gshape, scale) - res(:, 2:5) = gamma_pdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans, [3,5])) < qptol), & - msg="gamma_distribution_pdf_rqp failed", warn=warn) - end subroutine test_gamma_pdf_rqp - - subroutine test_gamma_pdf_csp - complex(sp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [0.115542844,0.115542844,0.115542844, 9.26823243E-02, & - 0.401668519, 0.374689817, 0.147123635, 0.225616276, & - 0.127654046, 3.91825065E-02, 2.58735381E-03, & - 0.101058327, 0.240440935, 4.98853484E-03, 0.110858262] - - print *, "Test gamma_distribution_pdf_csp" - put = 345987126 - call random_seed(put, get) - gshape = (2.0_sp, 0.7_sp); scale = (0.8_sp, 1.2_sp) - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_pdf(x1, gshape, scale) - res(:, 2:5) = gamma_pdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans, [3,5])) < sptol), & - msg="gamma_distribution_pdf_csp failed", warn=warn) - end subroutine test_gamma_pdf_csp - - subroutine test_gamma_pdf_cdp - complex(dp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [0.115542844,0.115542844,0.115542844, 9.26823243E-02, & - 0.401668519, 0.374689817, 0.147123635, 0.225616276, & - 0.127654046, 3.91825065E-02, 2.58735381E-03, & - 0.101058327, 0.240440935, 4.98853484E-03, 0.110858262] - - print *, "Test gamma_distribution_pdf_cdp" - put = 345987126 - call random_seed(put, get) - gshape = (2.0_dp, 0.7_dp); scale = (0.8_dp, 1.2_dp) - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_pdf(x1, gshape, scale) - res(:, 2:5) = gamma_pdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans, [3,5])) < dptol), & - msg="gamma_distribution_pdf_cdp failed", warn=warn) - end subroutine test_gamma_pdf_cdp - - subroutine test_gamma_pdf_cqp - complex(qp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [0.115542844,0.115542844,0.115542844, 9.26823243E-02, & - 0.401668519, 0.374689817, 0.147123635, 0.225616276, & - 0.127654046, 3.91825065E-02, 2.58735381E-03, & - 0.101058327, 0.240440935, 4.98853484E-03, 0.110858262] - - print *, "Test gamma_distribution_pdf_cqp" - put = 345987126 - call random_seed(put, get) - gshape = (2.0_qp, 0.7_qp); scale = (0.8_qp, 1.2_qp) - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_pdf(x1, gshape, scale) - res(:, 2:5) = gamma_pdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans, [3,5])) < qptol), & - msg="gamma_distribution_pdf_cqp failed", warn=warn) - end subroutine test_gamma_pdf_cqp - - - subroutine test_gamma_cdf_rsp - real(sp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [5.48762567E-02, 5.48762567E-02, 5.48762567E-02, & - 0.315411955, 0.385681599, 0.232208580, 0.393366873, & - 0.805594206, 0.886319339, 0.376679629, 0.141763687, & - 0.455908805, 0.278569371, 0.181033060, 0.729863822] - - print *, "Test gamma_distribution_cdf_rsp" - put = 567985123 - call random_seed(put, get) - gshape = 2.0_sp; scale = 2.0_sp - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_cdf(x1, gshape, scale) - res(:, 2:5) = gamma_cdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans,[3,5])) < sptol), & - msg="gamma_distribution_cdf_rsp failed", warn=warn) - end subroutine test_gamma_cdf_rsp - - subroutine test_gamma_cdf_rdp - real(dp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [5.48762567E-02, 5.48762567E-02, 5.48762567E-02, & - 0.315411955, 0.385681599, 0.232208580, 0.393366873, & - 0.805594206, 0.886319339, 0.376679629, 0.141763687, & - 0.455908805, 0.278569371, 0.181033060, 0.729863822] - - print *, "Test gamma_distribution_cdf_rdp" - put = 567985123 - call random_seed(put, get) - gshape = 2.0_dp; scale = 2.0_dp - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_cdf(x1, gshape, scale) - res(:, 2:5) = gamma_cdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans,[3,5])) < dptol), & - msg="gamma_distribution_cdf_rdp failed", warn=warn) - end subroutine test_gamma_cdf_rdp - - subroutine test_gamma_cdf_rqp - real(qp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [5.48762567E-02, 5.48762567E-02, 5.48762567E-02, & - 0.315411955, 0.385681599, 0.232208580, 0.393366873, & - 0.805594206, 0.886319339, 0.376679629, 0.141763687, & - 0.455908805, 0.278569371, 0.181033060, 0.729863822] - - print *, "Test gamma_distribution_cdf_rqp" - put = 567985123 - call random_seed(put, get) - gshape = 2.0_qp; scale = 2.0_qp - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_cdf(x1, gshape, scale) - res(:, 2:5) = gamma_cdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans,[3,5])) < qptol), & - msg="gamma_distribution_cdf_rqp failed", warn=warn) - end subroutine test_gamma_cdf_rqp - - subroutine test_gamma_cdf_csp - complex(sp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [3.21221203E-02, 3.21221203E-02, 3.21221203E-02, & - 0.209311500,0.779570222, 0.170826405, 2.75949780E-02,& - 2.37940717E-02, 5.22981845E-02, 0.223270506, & - 0.273653150, 3.49688679E-02,0.580260038, 0.230904028,& - 0.250726104] - - print *, "Test gamma_distribution_cdf_csp" - put = 567985123 - call random_seed(put, get) - gshape = (2.0_sp, 0.7_sp); scale = (0.8_sp, 1.2_sp) - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_cdf(x1, gshape, scale) - res(:, 2:5) = gamma_cdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans,[3,5])) < sptol), & - msg="gamma_distribution_cdf_csp failed", warn=warn) - end subroutine test_gamma_cdf_csp - - subroutine test_gamma_cdf_cdp - complex(dp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [3.21221203E-02, 3.21221203E-02, 3.21221203E-02, & - 0.209311500,0.779570222, 0.170826405, 2.75949780E-02,& - 2.37940717E-02, 5.22981845E-02, 0.223270506, & - 0.273653150, 3.49688679E-02,0.580260038, 0.230904028,& - 0.250726104] - - print *, "Test gamma_distribution_cdf_cdp" - put = 567985123 - call random_seed(put, get) - gshape = (2.0_dp, 0.7_dp); scale = (0.8_dp, 1.2_dp) - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_cdf(x1, gshape, scale) - res(:, 2:5) = gamma_cdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans,[3,5])) < dptol), & - msg="gamma_distribution_cdf_cdp failed", warn=warn) - end subroutine test_gamma_cdf_cdp - - subroutine test_gamma_cdf_cqp - complex(qp) :: x1, x2(3,4), gshape, scale - real :: res(3,5) - integer :: i, n - integer :: put, get - real :: ans(15) = [3.21221203E-02, 3.21221203E-02, 3.21221203E-02, & - 0.209311500,0.779570222, 0.170826405, 2.75949780E-02,& - 2.37940717E-02, 5.22981845E-02, 0.223270506, & - 0.273653150, 3.49688679E-02,0.580260038, 0.230904028,& - 0.250726104] - - print *, "Test gamma_distribution_cdf_cqp" - put = 567985123 - call random_seed(put, get) - gshape = (2.0_qp, 0.7_qp); scale = (0.8_qp, 1.2_qp) - x1 = gamma_rvs(gshape, scale) - x2 = reshape(gamma_rvs(gshape, scale, 12), [3,4]) - res(:,1) = gamma_cdf(x1, gshape, scale) - res(:, 2:5) = gamma_cdf(x2, gshape, scale) - call check(all(abs(res - reshape(ans,[3,5])) < qptol), & - msg="gamma_distribution_cdf_cqp failed", warn=warn) - end subroutine test_gamma_cdf_cqp - -end program test_distribution_gamma \ No newline at end of file diff --git a/src/tests/stats/test_distribution_gamma.fypp b/src/tests/stats/test_distribution_gamma.fypp new file mode 100644 index 000000000..a49cfb7b1 --- /dev/null +++ b/src/tests/stats/test_distribution_gamma.fypp @@ -0,0 +1,337 @@ +#:set WITH_QP = False +#:set WITH_XDP = False +#:include "common.fypp" +#:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES +module test_stats_distribution_gamma + use testdrive, only : new_unittest, unittest_type, error_type, check + use stdlib_kinds, only : sp, dp + use stdlib_random, only : random_seed + use stdlib_stats_distribution_gamma, only : rgamma => rvs_gamma, & + gamma_pdf => pdf_gamma, gamma_cdf => cdf_gamma + + implicit none + private + + public :: collect_stats_distribution_gamma + + #:for k1, t1 in REAL_KINDS_TYPES + ${t1}$, parameter :: tol_${k1}$ = 1000 * epsilon(1.0_${k1}$) + #:endfor + + + + +contains + + subroutine collect_stats_distribution_gamma(testsuite) + type(unittest_type), allocatable, intent(out) :: testsuite(:) + + testsuite = [ & + new_unittest("gamma_random_generator", test_gamma_random_generator)& + + #:for k1, t1 in RC_KINDS_TYPES + , new_unittest("gamma_rvs_${t1[0]}$${k1}$", & + test_gamma_rvs_${t1[0]}$${k1}$) & + #:endfor + + #:for k1, t1 in RC_KINDS_TYPES + , new_unittest("gamma_pdf_${t1[0]}$${k1}$", & + test_gamma_pdf_${t1[0]}$${k1}$) & + #:endfor + + #:for k1, t1 in RC_KINDS_TYPES + , new_unittest("gamma_cdf_${t1[0]}$${k1}$", & + test_gamma_cdf_${t1[0]}$${k1}$) & + #:endfor + ] + end subroutine collect_stats_distribution_gamma + + + + subroutine test_gamma_random_generator(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: num = 10000000, array_size = 1000 + integer :: i, j, freq(0 : array_size), put, get + real(dp) :: chisq, expct + character(80) :: ch1 + + print *, "" + print *, "Test gamma random generator with chi-squared" + + put = 1234567 + call random_seed(put, get) + freq = 0 + + do i = 1, num + + j = 1000 * gamma_cdf(rgamma(2.0,1.5),2.0,1.5) + freq(j) = freq(j) + 1 + + end do + + chisq = 0.0_dp + expct = num / array_size + + do i = 0, array_size - 1 + + chisq = chisq + (freq(i) - expct) ** 2 / expct + + end do + + write(ch1, '(f10.1)') chisq + + call check(error, chisq < 1143.9, & + "gamma randomness failed chi-squared test.", & + "The critical values for chi-squared with 1000 dof is"// & + " 1143.92. Chi-squared for gamma random generator is :"// & + trim(ch1)) + + end subroutine test_gamma_random_generator + + + + #:for k1, t1 in RC_KINDS_TYPES + subroutine test_gamma_rvs_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + integer, parameter :: k = 5, n = 10 + ${t1}$ :: res(n), gshape, scale + integer :: i + integer :: seed, get + #:if t1[0] == "r" + #! for real type + ${t1}$ :: ans(n) = [0.85758907497718884_${k1}$, & + 1.0206623865526090_${k1}$, & + 0.99753931024198650_${k1}$, & + 0.97653359790345839_${k1}$, & + 0.41853482638322043_${k1}$, & + 2.2012288073086310_${k1}$, & + 2.0639542613306592_${k1}$, & + 3.1794669730880192_${k1}$, & + 1.9329744662223280_${k1}$, & + 1.0257959670932111_${k1}$] + #:else + #! for complex type + ${t1}$ :: ans(n) = & + [(1.0719863437214860_${k1}$, 0.46775532101393819_${k1}$), & + (0.42382516926807201_${k1}$, 0.96340496644915230_${k1}$), & + (2.7515360091357888_${k1}$, 0.14837198853150388_${k1}$), & + (1.4536367104245524_${k1}$, 0.56852736336951559_${k1}$), & + (0.34559143458416125_${k1}$, 4.96217685362488267E-002_${k1}$), & + (1.9657884897696516_${k1}$, 3.1124314799641013_${k1}$), & + (3.4155160623540453_${k1}$, 5.04948933894018709E-002_${k1}$), & + (0.94594398345216302_${k1}$, 0.45691588305890624_${k1}$), & + (1.1493158751025965_${k1}$, 0.12944763723941669_${k1}$), & + (2.9691469633592282_${k1}$, 1.1617408197125874_${k1}$)] + #:endif + + print *, "Test gamma_distribution_rvs_${t1[0]}$${k1}$" + seed = 639741825 + call random_seed(seed, get) + + #:if t1[0] == "r" + #! for real type + gshape = 2.0_${k1}$; scale = 1.0_${k1}$ + #:else + #! for complex type + gshape = (2.0_${k1}$, 0.7_${k1}$); scale = (0.8_${k1}$, 1.2_${k1}$) + #:endif + + do i = 1, k + + res(i) = rgamma(gshape, scale) + + end do + + res(k + 1 : n) = rgamma(gshape, scale, k) + + do i = 1, n + + call check(error, res(i), ans(i), "gamma_distribution_rvs_"// & + "${t1[0]}$${k1}$ failed", thr = tol_${k1}$) + + end do + end subroutine test_gamma_rvs_${t1[0]}$${k1}$ + + #:endfor + + + + + #:for k1, t1 in RC_KINDS_TYPES + subroutine test_gamma_pdf_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + ${t1}$ :: x1, x2(3,4), gshape, scale + integer :: i + integer :: seed, get + real(${k1}$) :: res(15) + #:if t1[0] == "r" + #! for real type + real(${k1}$), parameter :: ans(15) = & + [3.4495412572168718E-002_${k1}$, & + 3.4495412572168718E-002_${k1}$, & + 3.4495412572168718E-002_${k1}$, & + 0.29116634347089576_${k1}$, & + 0.28338290850731412_${k1}$, & + 0.27922270935613586_${k1}$, & + 0.36440665523348270_${k1}$, & + 0.24379209619143699_${k1}$, & + 6.3815638087140858E-002_${k1}$, & + 0.25844600948718588_${k1}$, & + 0.17268118913523497_${k1}$, & + 0.31181223194308200_${k1}$, & + 0.24027095040543087_${k1}$, & + 0.36765502365831570_${k1}$, & + 9.9011714088769673E-002_${k1}$] + #:else + #! for complex type + real(${k1}$), parameter :: ans(15) = & + [0.11554282574059289_${k1}$, & + 0.11554282574059289_${k1}$, & + 0.11554282574059289_${k1}$, & + 9.2682318951901529E-002_${k1}$, & + 0.40166849087286088_${k1}$, & + 0.37468980496232701_${k1}$, & + 0.14712363446345342_${k1}$, & + 0.22561628567985184_${k1}$, & + 0.12765403024301181_${k1}$, & + 3.9182498867847360E-002_${k1}$, & + 2.5873533461032859E-003_${k1}$, & + 0.10105832622792968_${k1}$, & + 0.24044091896609490_${k1}$, & + 4.9885356046115948E-003_${k1}$, & + 0.11085827028639164_${k1}$] + #:endif + + print *, "Test gamma_distribution_pdf_${t1[0]}$${k1}$" + seed = 345987126 + call random_seed(seed, get) + #:if t1[0] == "r" + #! for real type + gshape = 2.0_${k1}$; scale = 1.0_${k1}$ + #:else + #! for complex type + gshape = (2.0_${k1}$, 0.7_${k1}$); scale = (0.8_${k1}$, 1.2_${k1}$) + #:endif + + x1 = rgamma(gshape, scale) + x2 = reshape(rgamma(gshape, scale, 12), [3,4]) + res(1:3) = gamma_pdf(x1, gshape, scale) + res(4:15) = reshape(gamma_pdf(x2, gshape, scale), [12]) + + do i = 1, 15 + + call check(error, res(i), ans(i), "gamma_distribution"// & + "_pdf_${t1[0]}$${k1}$ failed", thr = tol_${k1}$) + + end do + end subroutine test_gamma_pdf_${t1[0]}$${k1}$ + + #:endfor + + + + + #:for k1, t1 in RC_KINDS_TYPES + subroutine test_gamma_cdf_${t1[0]}$${k1}$(error) + type(error_type), allocatable, intent(out) :: error + ${t1}$ :: x1, x2(3,4), gshape, scale + integer :: i + integer :: seed, get + real(${k1}$) :: res(15) + #:if t1[0] == "r" + #! for real type + real(${k1}$), parameter :: ans(15) = & + [5.4876256610822634E-002_${k1}$, & + 5.4876256610822634E-002_${k1}$, & + 5.4876256610822634E-002_${k1}$, & + 0.31541195839514946_${k1}$, & + 0.38568161497244058_${k1}$, & + 0.23220859761573376_${k1}$, & + 0.39336687687155714_${k1}$, & + 0.80559422971604655_${k1}$, & + 0.88631934249921673_${k1}$, & + 0.37667963185005432_${k1}$, & + 0.14176369124149241_${k1}$, & + 0.45590880930769767_${k1}$, & + 0.27856937500418372_${k1}$, & + 0.18103305981618728_${k1}$, & + 0.72986385036366463_${k1}$] + #:else + #! for complex type + real(${k1}$), parameter :: ans(15) = & + [3.2122120543510921E-002_${k1}$, & + 3.2122120543510921E-002_${k1}$, & + 3.2122120543510921E-002_${k1}$, & + 0.20931149671160035_${k1}$, & + 0.77957028981310350_${k1}$, & + 0.17082639598330887_${k1}$, & + 2.7594977080807291E-002_${k1}$, & + 2.3794072479821078E-002_${k1}$, & + 5.2298181677386930E-002_${k1}$, & + 0.22327051157236336_${k1}$, & + 0.27365315981967359_${k1}$, & + 3.4968870668437825E-002_${k1}$, & + 0.58026010546190465_${k1}$, & + 0.23090402450867176_${k1}$, & + 0.25072609802292339_${k1}$] + #:endif + + print *, "Test gamma_distribution_cdf_${t1[0]}$${k1}$" + seed = 567985123 + call random_seed(seed, get) + + #:if t1[0] == "r" + #! for real type + gshape = 2.0_${k1}$; scale = 2.0_${k1}$ + #:else + #! for complex type + gshape = (2.0_${k1}$, 0.7_${k1}$); scale = (0.8_${k1}$, 1.2_${k1}$) + #:endif + + x1 = rgamma(gshape, scale) + x2 = reshape(rgamma(gshape, scale, 12), [3,4]) + res(1:3) = gamma_cdf(x1, gshape, scale) + res(4:15) = reshape(gamma_cdf(x2, gshape, scale), [12]) + + do i = 1, 15 + + call check(error, res(i), ans(i), "gamma_distribution"// & + "_cdf_${t1[0]}$${k1}$ failed", thr = tol_${k1}$) + + end do + end subroutine test_gamma_cdf_${t1[0]}$${k1}$ + + #:endfor + +end module test_stats_distribution_gamma + + + +program tester + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : run_testsuite, new_testsuite, testsuite_type + use test_stats_distribution_gamma, only : collect_stats_distribution_gamma + implicit none + integer :: stat, is + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [new_testsuite("Stats_distribution_gamma", & + collect_stats_distribution_gamma)] + + 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 tester From f80ab4c9a43107cbef6b24297bfb0344d5e0f402 Mon Sep 17 00:00:00 2001 From: Jing <53905783+Jim-215-Fisher@users.noreply.github.com> Date: Wed, 22 Jun 2022 13:27:37 -0400 Subject: [PATCH 41/42] Update doc/specs/stdlib_stats_distribution_gamma.md Co-authored-by: Ian Giestas Pauli --- doc/specs/stdlib_stats_distribution_gamma.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/specs/stdlib_stats_distribution_gamma.md b/doc/specs/stdlib_stats_distribution_gamma.md index 8674619f0..42ca67981 100644 --- a/doc/specs/stdlib_stats_distribution_gamma.md +++ b/doc/specs/stdlib_stats_distribution_gamma.md @@ -124,7 +124,7 @@ Elemental function `x`: has `intent(in)` and is a scalar of type `real` or `complex`. -`shape` has `intent(in)` and is a scalar of type real` or `complex`. +`shape` has `intent(in)` and is a scalar of type `real` or `complex`. `rate`: has `intent(in)` and is a scalar of type `real` or `complex`. From 12e4fe93a06711c3fb53a64b7c4048aa633a055c Mon Sep 17 00:00:00 2001 From: jim-215-fisher Date: Wed, 10 Aug 2022 20:51:57 -0400 Subject: [PATCH 42/42] minor changes in doc --- doc/specs/stdlib_stats_distribution_gamma.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/specs/stdlib_stats_distribution_gamma.md b/doc/specs/stdlib_stats_distribution_gamma.md index 42ca67981..d3f5939f0 100644 --- a/doc/specs/stdlib_stats_distribution_gamma.md +++ b/doc/specs/stdlib_stats_distribution_gamma.md @@ -105,7 +105,7 @@ Experimental The probability density function (pdf) of the single real variable gamma distribution: -$$ f(x)= \frac{scale^{shape}}{\Gamma (shape)}x^{shape-1}e^{-scale \times x} , for \;\; x>0, shape, scale>0$$ +$$ f(x)= \frac{scale^{shape}}{\Gamma (shape)}x^{shape-1}e^{-scale \times x} , for \; x>0, shape, scale>0$$ For a complex variable (x + y i) with independent real x and imaginary y parts, the joint probability density function is the product of the corresponding marginal pdf of real and imaginary pdf (for more details, see "Probability and Random Processes with Applications to Signal Processing and Communications", 2nd ed., Scott L. Miller and Donald Childers, 2012, p.197): @@ -187,7 +187,7 @@ Experimental Cumulative distribution function (cdf) of the single real variable gamma distribution: -$$ F(x)= \frac{\gamma (shape, scale \times x)}{\Gamma (shape)}, for \;\; x>0, shape, scale>0} $$ +$$ F(x)= \frac{\gamma (shape, scale \times x)}{\Gamma (shape)}, for \; x>0, shape, scale>0 $$ For a complex variable (x + y i) with independent real x and imaginary y parts, the joint cumulative distribution function is the product of corresponding marginal cdf of real and imaginary cdf (for more details, see "Probability and Random Processes with Applications to Signal Processing and Communications", 2nd ed., Scott L. Miller and Donald Childers, 2012, p.197):