subroutine angle_cdf ( x, n, cdf ) !******************************************************************************* ! !! ANGLE_CDF evaluates the Angle CDF. ! ! Modified: ! ! 03 September 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Reuven Rubinstein, ! Monte Carlo Optimization, Simulation and Sensitivity of Queueing Networks, ! Wiley, 1986. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, integer N, the spatial dimension. ! N must be at least 2. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) gamma integer n real ( kind = 8 ) n_real real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) sin_power_int real ( kind = 8 ) x real ( kind = 8 ), parameter :: zero = 0.0D+00 if ( n < 2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ANGLE_CDF - Fatal error!' write ( *, '(a)' ) ' N must be at least 2.' write ( *, '(a,i8)' ) ' The input value of N = ', n stop end if if ( x <= 0.0D+00 ) then cdf = 0.0D+00 else if ( pi <= x ) then cdf = 1.0D+00 else if ( n == 2 ) then cdf = x / pi else n_real = real ( n, kind = 8 ) cdf = sin_power_int ( zero, x, n-2 ) * gamma ( n_real / 2.0D+00 ) & / ( sqrt ( pi ) * gamma ( ( n_real - 1.0D+00 ) / 2.0D+00 ) ) end if return end subroutine angle_mean ( n, mean ) !******************************************************************************* ! !! ANGLE_MEAN returns the mean of the Angle PDF. ! ! Modified: ! ! 02 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the spatial dimension. ! N must be at least 2. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) mean integer n real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 mean = pi / 2.0D+00 return end subroutine angle_pdf ( x, n, pdf ) !******************************************************************************* ! !! ANGLE_PDF evaluates the Angle PDF. ! ! Discussion: ! ! X is an angle between 0 and PI, corresponding to the angle ! made in an N-dimensional space, between a fixed line passing ! through the origin, and an arbitrary line that also passes ! through the origin, which is specified by a choosing any point ! on the N-dimensional sphere with uniform probability. ! ! Formula: ! ! PDF(X) = ( sin ( X ) )**(N-2) * Gamma ( N / 2 ) ! / ( sqrt ( PI ) * Gamma ( ( N - 1 ) / 2 ) ) ! ! PDF(X) = 1 / PI if N = 2. ! ! Modified: ! ! 02 September 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Reuven Rubinstein, ! Monte Carlo Optimization, Simulation and Sensitivity of Queueing Networks, ! Wiley, 1986. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, integer N, the spatial dimension. ! N must be at least 2. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) gamma integer n real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( n < 2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ANGLE_PDF - Fatal error!' write ( *, '(a)' ) ' N must be at least 2.' write ( *, '(a,i8)' ) ' The input value of N = ', n stop end if if ( x < 0.0D+00 .or. pi < x ) then pdf = 0.0D+00 else if ( n == 2 ) then pdf = 1.0D+00 / pi else pdf = ( sin ( x ) )**( n - 2 ) * gamma ( real ( n, kind = 8 ) / 2.0D+00 ) & / ( sqrt ( pi ) * gamma ( real ( n - 1, kind = 8 ) / 2.0D+00 ) ) end if return end subroutine anglit_cdf ( x, cdf ) !******************************************************************************* ! !! ANGLIT_CDF evaluates the Anglit CDF. ! ! Modified: ! ! 29 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( x < - 0.25D+00 * pi ) then cdf = 0.0D+00 else if ( x < 0.25D+00 * pi ) then cdf = 0.5D+00 - 0.5D+00 * cos ( 2.0D+00 * x + pi / 2.0D+00 ) else cdf = 1.0D+00 end if return end subroutine anglit_cdf_inv ( cdf, x ) !******************************************************************************* ! !! ANGLIT_CDF_INV inverts the Anglit CDF. ! ! Modified: ! ! 29 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ANGLIT_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = 0.5D+00 * ( acos ( 1.0D+00 - 2.0D+00 * cdf ) - pi / 2.0D+00 ) return end subroutine anglit_mean ( mean ) !******************************************************************************* ! !! ANGLIT_MEAN returns the mean of the Anglit PDF. ! ! Modified: ! ! 28 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) mean mean = 0.0D+00 return end subroutine anglit_pdf ( x, pdf ) !******************************************************************************* ! !! ANGLIT_PDF evaluates the Anglit PDF. ! ! Formula: ! ! PDF(X) = sin ( 2 * X + PI / 2 ) for -PI/4 <= X <= PI/4 ! ! Modified: ! ! 28 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( x <= - 0.25D+00 * pi .or. 0.25D+00 * pi <= x ) then pdf = 0.0D+00 else pdf = sin ( 2.0D+00 * x + 0.25D+00 * pi ) end if return end subroutine anglit_sample ( seed, x ) !******************************************************************************* ! !! ANGLIT_SAMPLE samples the Anglit PDF. ! ! Modified: ! ! 28 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call anglit_cdf_inv ( cdf, x ) return end subroutine anglit_variance ( variance ) !******************************************************************************* ! !! ANGLIT_VARIANCE returns the variance of the Anglit PDF. ! ! Discussion: ! ! Variance = ! Integral ( -PI/4 <= X <= PI/4 ) X**2 * sin ( 2 * X + PI / 2 ) ! ! Antiderivative = ! 0.5D+00 * X * sin ( 2 * X + PI / 2 ) ! + ( 0.25 - 0.5D+00 * X**2 ) * cos ( 2 * X + PI / 2 ) ! ! Modified: ! ! 29 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) variance variance = 0.0625D+00 * pi * pi - 0.5D+00 return end subroutine arcsin_cdf ( x, a, cdf ) !******************************************************************************* ! !! ARCSIN_CDF evaluates the Arcsin CDF. ! ! Modified: ! ! 20 March 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, the parameter of the CDF. ! A must be positive. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( x <= -a ) then cdf = 0.0D+00 else if ( x < a ) then cdf = 0.5D+00 + asin ( x / a ) / pi else cdf = 1.0D+00 end if return end subroutine arcsin_cdf_inv ( cdf, a, x ) !******************************************************************************* ! !! ARCSIN_CDF_INV inverts the Arcsin CDF. ! ! Modified: ! ! 20 March 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, the parameter of the CDF. ! A must be positive. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ARCSIN_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = a * sin ( pi * ( cdf - 0.5D+00 ) ) return end function arcsin_check ( a ) !******************************************************************************* ! !! ARCSIN_CHECK checks the parameter of the Arcsin CDF. ! ! Modified: ! ! 27 October 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0 < A. ! ! Output, logical ARCSIN_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a logical arcsin_check if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ARCSIN_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.' arcsin_check = .false. return end if arcsin_check = .true. return end subroutine arcsin_mean ( a, mean ) !******************************************************************************* ! !! ARCSIN_MEAN returns the mean of the Arcsin PDF. ! ! Modified: ! ! 20 March 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the CDF. ! A must be positive. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) mean mean = 0.0D+00 return end subroutine arcsin_pdf ( x, a, pdf ) !******************************************************************************* ! !! ARCSIN_PDF evaluates the Arcsin PDF. ! ! Discussion: ! ! The LOGISTIC EQUATION has the form: ! ! X(N+1) = 4.0D+00 * LAMBDA * ( 1.0D+00 - X(N) ). ! ! where 0 < LAMBDA <= 1. This nonlinear difference equation maps ! the unit interval into itself, and is a simple example of a system ! exhibiting chaotic behavior. Ulam and von Neumann studied the ! logistic equation with LAMBDA = 1, and showed that iterates of the ! function generated a sequence of pseudorandom numbers with ! the Arcsin probability density function. ! ! The derived sequence ! ! Y(N) = ( 2 / PI ) * Arcsin ( SQRT ( X(N) ) ) ! ! is a pseudorandom sequence with the uniform probability density ! function on [0,1]. For certain starting values, such as X(0) = 0, 0.75, ! or 1.0D+00, the sequence degenerates into a constant sequence, and for ! values very near these, the sequence takes a while before becoming ! chaotic. ! ! Formula: ! ! PDF(X) = 1 / ( pi * sqrt ( A**2 - X**2 ) ) ! ! Modified: ! ! 20 March 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Daniel Zwillinger and Stephen Kokoska, ! CRC Standard Probability and Statistics Tables and Formulae, ! Chapman and Hall/CRC, 2000, pages 114-115. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! -A < X < A. ! ! Input, real ( kind = 8 ) A, the parameter of the CDF. ! A must be positive. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ARCSIN_PDF - Fatal error!' write ( *, '(a)' ) ' Parameter A must be positive.' stop end if if ( x <= -a .or. a <= x ) then pdf = 0.0D+00 else pdf = 1.0D+00 / ( pi * sqrt ( a * a - x * x ) ) end if return end subroutine arcsin_sample ( a, seed, x ) !******************************************************************************* ! !! ARCSIN_SAMPLE samples the Arcsin PDF. ! ! Modified: ! ! 20 March 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the CDF. ! A must be positive. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call arcsin_cdf_inv ( cdf, a, x ) return end subroutine arcsin_variance ( a, variance ) !******************************************************************************* ! !! ARCSIN_VARIANCE returns the variance of the Arcsin PDF. ! ! Modified: ! ! 20 March 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the CDF. ! A must be positive. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) variance variance = a * a / 2.0D+00 return end subroutine benford_pdf ( x, pdf ) !******************************************************************************* ! !! BENFORD_PDF returns the Benford probability of one or more significant digits. ! ! Discussion: ! ! Benford's law is an empirical formula explaining the observed ! distribution of initial digits in lists culled from newspapers, ! tax forms, stock market prices, and so on. It predicts the observed ! high frequency of the initial digit 1, for instance. ! ! Note that the probabilities of digits 1 through 9 are guaranteed ! to add up to 1, since ! LOG10 ( 2/1 ) + LOG10 ( 3/2) + LOG10 ( 4/3 ) + ... + LOG10 ( 10/9 ) ! = LOG10 ( 2/1 * 3/2 * 4/3 * ... * 10/9 ) = LOG10 ( 10 ) = 1. ! ! Formula: ! ! PDF(X) = LOG10 ( ( X + 1 ) / X ). ! ! Modified: ! ! 13 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! F Benford, ! The Law of Anomalous Numbers, ! Proceedings of the American Philosophical Society, ! Volume 78, pages 551-572, 1938. ! ! T P Hill, ! The First Digit Phenomenon, ! American Scientist, ! Volume 86, July/August 1998, pages 358 - 363. ! ! R Raimi, ! The Peculiar Distribution of First Digits, ! Scientific American, ! December 1969, pages 109-119. ! ! Parameters: ! ! Input, integer X, the string of significant digits to be checked. ! If X is 1, then we are asking for the Benford probability that ! a value will have first digit 1. If X is 123, we are asking for ! the probability that the first three digits will be 123, and so on. ! ! Output, real ( kind = 8 ) PDF, the Benford probability that an item taken ! from a real world distribution will have the initial digits X. ! implicit none real ( kind = 8 ) pdf integer x if ( x <= 0 ) then pdf = 0.0D+00 else pdf = log10 ( real ( x + 1, kind = 8 ) / real ( x, kind = 8 ) ) end if return end subroutine bernoulli_cdf ( x, a, cdf ) !******************************************************************************* ! !! BERNOULLI_CDF evaluates the Bernoulli CDF. ! ! Modified: ! ! 24 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the number of successes on a single trial. ! X = 0 or 1. ! ! Input, real ( kind = 8 ) A, the probability of success on one trial. ! 0.0D+00 <= A <= 1.0. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf integer x if ( x < 0 ) then cdf = 0.0D+00 else if ( x == 0 ) then cdf = 1.0D+00 - a else cdf = 1.0D+00 end if return end subroutine bernoulli_cdf_inv ( cdf, a, x ) !******************************************************************************* ! !! BERNOULLI_CDF_INV inverts the Bernoulli CDF. ! ! Modified: ! ! 24 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 <= A <= 1.0. ! ! Output, integer X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf integer x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BERNOULLI_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf <= 1.0D+00 - a ) then x = 0 else x = 1 end if return end function bernoulli_check ( a ) !******************************************************************************* ! !! BERNOULLI_CHECK checks the parameter of the Bernoulli CDF. ! ! Modified: ! ! 18 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0 <= A <= 1.0. ! ! Output, logical BERNOULLI_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a logical bernoulli_check if ( a < 0.0D+00 .or. 1.0D+00 < a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BERNOULLI_CHECK - Fatal error!' write ( *, '(a)' ) ' A < 0 or 1 < A.' bernoulli_check = .false. return end if bernoulli_check = .true. return end subroutine bernoulli_mean ( a, mean ) !******************************************************************************* ! !! BERNOULLI_MEAN returns the mean of the Bernoulli PDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the probability of success. ! 0.0D+00 <= A <= 1.0. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) mean mean = a return end subroutine bernoulli_pdf ( x, a, pdf ) !******************************************************************************* ! !! BERNOULLI_PDF evaluates the Bernoulli PDF. ! ! Formula: ! ! PDF(A;X) = A**X * ( 1.0D+00 - A )**( X - 1 ) ! ! X = 0 or 1. ! ! Discussion: ! ! The Bernoulli PDF describes the simple case in which a single trial ! is carried out, with two possible outcomes, called "success" and ! "failure"; the probability of success is A. ! ! Modified: ! ! 24 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the number of successes on a single trial. ! X = 0 or 1. ! ! Input, real ( kind = 8 ) A, the probability of success on one trial. ! 0.0 <= A <= 1.0. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) pdf integer x if ( x < 0 ) then pdf = 0.0D+00 else if ( x == 0 ) then pdf = 1.0D+00 - a else if ( x == 1 ) then pdf = a else pdf = 0.0D+00 end if return end subroutine bernoulli_sample ( a, seed, x ) !******************************************************************************* ! !! BERNOULLI_SAMPLE samples the Bernoulli PDF. ! ! Modified: ! ! 23 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the probability of success on one trial. ! 0.0D+00 <= A <= 1.0. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed integer x cdf = d_uniform_01 ( seed ) call bernoulli_cdf_inv ( cdf, a, x ) return end subroutine bernoulli_variance ( a, variance ) !******************************************************************************* ! !! BERNOULLI_VARIANCE returns the variance of the Bernoulli PDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the probability of success on one trial. ! 0.0D+00 <= A <= 1.0. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) variance variance = a * ( 1.0D+00 - a ) return end function bessel_i0 ( arg ) !******************************************************************************* ! !! BESSEL_I0 evaluates the modified Bessel function I0(X). ! ! Discussion: ! ! The main computation evaluates slightly modified forms of ! minimax approximations generated by Blair and Edwards, Chalk ! River (Atomic Energy of Canada Limited) Report AECL-4928, ! October, 1974. This transportable program is patterned after ! the machine dependent FUNPACK packet NATSI0, but cannot match ! that version for efficiency or accuracy. This version uses ! rational functions that theoretically approximate I-SUB-0(X) ! to at least 18 significant decimal digits. ! ! Machine dependent constants: ! ! beta = Radix for the floating-point system ! maxexp = Smallest power of beta that overflows ! XMAX = Largest argument acceptable to BESI0; Solution to ! equation: ! W(X) * (1+1/(8*X)+9/(128*X**2) = beta**maxexp ! where W(X) = EXP(X)/sqrt(2*PI*X) ! ! Approximate values for some important machines are: ! ! beta maxexp XMAX ! ! CRAY-1 (S.P.) 2 8191 5682.810 ! Cyber 180/855 ! under NOS (S.P.) 2 1070 745.893 ! IEEE (IBM/XT, ! SUN, etc.) (S.P.) 2 128 91.900 ! IEEE (IBM/XT, ! SUN, etc.) (D.P.) 2 1024 713.986 ! IBM 3033 (D.P.) 16 63 178.182 ! VAX (S.P.) 2 127 91.203 ! VAX D-Format (D.P.) 2 127 91.203 ! VAX G-Format (D.P.) 2 1023 713.293 ! ! Author: ! ! W. J. Cody and L. Stoltz, ! Mathematics and Computer Science Division, ! Argonne National Laboratory, ! Argonne, Illinois, 60439. ! ! FORTRAN90 version by John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) ARG, the argument. ! ! Output, real ( kind = 8 ) BESSEL_I0, the value of the modified ! Bessel function of the first kind. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) arg real ( kind = 8 ) b real ( kind = 8 ) bessel_i0 real ( kind = 8 ), parameter :: exp40 = 2.353852668370199854D+17 integer i real ( kind = 8 ), parameter, dimension ( 15 ) :: p = (/ & -5.2487866627945699800D-18, & -1.5982226675653184646D-14, & -2.6843448573468483278D-11, & -3.0517226450451067446D-08, & -2.5172644670688975051D-05, & -1.5453977791786851041D-02, & -7.0935347449210549190D+00, & -2.4125195876041896775D+03, & -5.9545626019847898221D+05, & -1.0313066708737980747D+08, & -1.1912746104985237192D+10, & -8.4925101247114157499D+11, & -3.2940087627407749166D+13, & -5.5050369673018427753D+14, & -2.2335582639474375249D+15 /) real ( kind = 8 ), parameter, dimension ( 8 ) :: pp = (/ & -3.9843750000000000000D-01, & 2.9205384596336793945D+00, & -2.4708469169133954315D+00, & 4.7914889422856814203D-01, & -3.7384991926068969150D-03, & -2.6801520353328635310D-03, & 9.9168777670983678974D-05, & -2.1877128189032726730D-06 /) real ( kind = 8 ), parameter, dimension ( 5 ) :: q = (/ & -3.7277560179962773046D+03, & 6.5158506418655165707D+06, & -6.5626560740833869295D+09, & 3.7604188704092954661D+12, & -9.7087946179594019126D+14 /) real ( kind = 8 ), parameter, dimension ( 7 ) :: qq = (/ & -3.1446690275135491500D+01, & 8.5539563258012929600D+01, & -6.0228002066743340583D+01, & 1.3982595353892851542D+01, & -1.1151759188741312645D+00, & 3.2547697594819615062D-02, & -5.5194330231005480228D-04 /) real ( kind = 8 ), parameter :: rec15 = 6.6666666666666666666D-02 real ( kind = 8 ) sump real ( kind = 8 ) sumq real ( kind = 8 ) value real ( kind = 8 ) x real ( kind = 8 ), parameter :: xmax = 91.9D+00 real ( kind = 8 ) xx x = abs ( arg ) if ( x < epsilon ( arg ) ) then value = 1.0D+00 else if ( x < 15.0D+00 ) then ! ! EPSILON ( ARG ) <= ABS(ARG) < 15.0D+00 ! xx = x * x sump = p(1) do i = 2, 15 sump = sump * xx + p(i) end do xx = xx - 225.0D+00 sumq = (((( & xx + q(1) ) & * xx + q(2) ) & * xx + q(3) ) & * xx + q(4) ) & * xx + q(5) value = sump / sumq else if ( 15.0D+00 <= x ) then if ( xmax < x ) then value = huge ( value ) else ! ! 15.0D+00 <= ABS(ARG) ! xx = 1.0D+00 / x - rec15 sump = (((((( & pp(1) & * xx + pp(2) ) & * xx + pp(3) ) & * xx + pp(4) ) & * xx + pp(5) ) & * xx + pp(6) ) & * xx + pp(7) ) & * xx + pp(8) sumq = (((((( & xx + qq(1) ) & * xx + qq(2) ) & * xx + qq(3) ) & * xx + qq(4) ) & * xx + qq(5) ) & * xx + qq(6) ) & * xx + qq(7) value = sump / sumq ! ! Calculation reformulated to avoid premature overflow. ! if ( x <= xmax - 15.0D+00 ) then a = exp ( x ) b = 1.0D+00 else a = exp ( x - 40.0D+00 ) b = exp40 end if value = ( ( value * a - pp(1) * a ) / sqrt ( x ) ) * b end if end if bessel_i0 = value return end subroutine bessel_i0_values ( n_data, x, fx ) !******************************************************************************* ! !! BESSEL_I0_VALUES returns some values of the I0 Bessel function. ! ! Discussion: ! ! The modified Bessel functions In(Z) and Kn(Z) are solutions of ! the differential equation ! ! Z^2 W'' + Z * W' - ( Z^2 + N^2 ) * W = 0. ! ! The modified Bessel function I0(Z) corresponds to N = 0. ! ! In Mathematica, the function can be evaluated by: ! ! BesselI[0,x] ! ! Modified: ! ! 20 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 20 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.1000000000000000D+01, & 0.1010025027795146D+01, & 0.1040401782229341D+01, & 0.1092045364317340D+01, & 0.1166514922869803D+01, & 0.1266065877752008D+01, & 0.1393725584134064D+01, & 0.1553395099731217D+01, & 0.1749980639738909D+01, & 0.1989559356618051D+01, & 0.2279585302336067D+01, & 0.3289839144050123D+01, & 0.4880792585865024D+01, & 0.7378203432225480D+01, & 0.1130192195213633D+02, & 0.1748117185560928D+02, & 0.2723987182360445D+02, & 0.6723440697647798D+02, & 0.4275641157218048D+03, & 0.2815716628466254D+04 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.00D+00, & 0.20D+00, & 0.40D+00, & 0.60D+00, & 0.80D+00, & 0.10D+01, & 0.12D+01, & 0.14D+01, & 0.16D+01, & 0.18D+01, & 0.20D+01, & 0.25D+01, & 0.30D+01, & 0.35D+01, & 0.40D+01, & 0.45D+01, & 0.50D+01, & 0.60D+01, & 0.80D+01, & 0.10D+02 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 fx = 0.0D+00 else x = x_vec(n_data) fx = fx_vec(n_data) end if return end function bessel_i1 ( arg ) !******************************************************************************* ! !! BESSEL_I1 evaluates the Bessel I function of order I. ! ! Discussion: ! ! The main computation evaluates slightly modified forms of ! minimax approximations generated by Blair and Edwards. ! This transportable program is patterned after the machine-dependent ! FUNPACK packet NATSI1, but cannot match that version for efficiency ! or accuracy. This version uses rational functions that theoretically ! approximate I-SUB-1(X) to at least 18 significant decimal digits. ! The accuracy achieved depends on the arithmetic system, the compiler, ! the intrinsic functions, and proper selection of the machine-dependent ! constants. ! ! Machine-dependent constants: ! ! beta = Radix for the floating-point system. ! maxexp = Smallest power of beta that overflows. ! XMAX = Largest argument acceptable to BESI1; Solution to ! equation: ! EXP(X) * (1-3/(8*X)) / SQRT(2*PI*X) = beta**maxexp ! ! ! Approximate values for some important machines are: ! ! beta maxexp XMAX ! ! CRAY-1 (S.P.) 2 8191 5682.810 ! Cyber 180/855 ! under NOS (S.P.) 2 1070 745.894 ! IEEE (IBM/XT, ! SUN, etc.) (S.P.) 2 128 91.906 ! IEEE (IBM/XT, ! SUN, etc.) (D.P.) 2 1024 713.987 ! IBM 3033 (D.P.) 16 63 178.185 ! VAX (S.P.) 2 127 91.209 ! VAX D-Format (D.P.) 2 127 91.209 ! VAX G-Format (D.P.) 2 1023 713.293 ! ! Modified: ! ! 27 October 2004 ! ! Author: ! ! W. J. Cody and L. Stoltz, ! Mathematics and Computer Science Division, ! Argonne National Laboratory, ! Argonne, IL 60439. ! ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Blair and Edwards, ! Chalk River Report AECL-4928, ! Atomic Energy of Canada, Limited, ! October, 1974. ! ! Parameters: ! ! Input, real (kind = 8 ) ARG, the argument. ! ! Output, real ( kind = 8 ) BESSEL_I1, the value of the Bessel ! I1 function. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) arg real ( kind = 8 ) b real ( kind = 8 ) bessel_i1 real ( kind = 8 ), parameter :: exp40 = 2.353852668370199854D+17 real ( kind = 8 ), parameter :: forty = 40.0D+00 real ( kind = 8 ), parameter :: half = 0.5D+00 integer j real ( kind = 8 ), parameter :: one = 1.0D+00 real ( kind = 8 ), parameter :: one5 = 15.0D+00 real ( kind = 8 ), dimension(15) :: p = (/ & -1.9705291802535139930D-19, & -6.5245515583151902910D-16, & -1.1928788903603238754D-12, & -1.4831904935994647675D-09, & -1.3466829827635152875D-06, & -9.1746443287817501309D-04, & -4.7207090827310162436D-01, & -1.8225946631657315931D+02, & -5.1894091982308017540D+04, & -1.0588550724769347106D+07, & -1.4828267606612366099D+09, & -1.3357437682275493024D+11, & -6.9876779648010090070D+12, & -1.7732037840791591320D+14, & -1.4577180278143463643D+15 /) real ( kind = 8 ) :: pbar = 3.98437500D-01 real ( kind = 8 ), dimension(8) :: pp = (/ & -6.0437159056137600000D-02, & 4.5748122901933459000D-01, & -4.2843766903304806403D-01, & 9.7356000150886612134D-02, & -3.2457723974465568321D-03, & -3.6395264712121795296D-04, & 1.6258661867440836395D-05, & -3.6347578404608223492D-07 /) real ( kind = 8 ), dimension(5) :: q = (/ & -4.0076864679904189921D+03, & 7.4810580356655069138D+06, & -8.0059518998619764991D+09, & 4.8544714258273622913D+12, & -1.3218168307321442305D+15 /) real ( kind = 8 ), dimension(6) :: qq = (/ & -3.8806586721556593450D+00, & 3.2593714889036996297D+00, & -8.5017476463217924408D-01, & 7.4212010813186530069D-02, & -2.2835624489492512649D-03, & 3.7510433111922824643D-05 /) real ( kind = 8 ), parameter :: rec15 = 6.6666666666666666666D-02 real ( kind = 8 ) sump real ( kind = 8 ) sumq real ( kind = 8 ), parameter :: two25 = 225.0D+00 real ( kind = 8 ) value real ( kind = 8 ) x real ( kind = 8 ), parameter :: xmax = 713.987D+00 real ( kind = 8 ) xx real ( kind = 8 ), parameter :: zero = 0.0D+00 x = abs ( arg ) ! ! ABS(ARG) < EPSILON ( ARG ) ! if ( x < epsilon ( x ) ) then value = half * x ! ! EPSILON ( ARG ) <= ABS(ARG) < 15.0 ! else if ( x < one5 ) then xx = x * x sump = p(1) do j = 2, 15 sump = sump * xx + p(j) end do xx = xx - two25 sumq = (((( & xx + q(1) & ) * xx + q(2) & ) * xx + q(3) & ) * xx + q(4) & ) * xx + q(5) value = ( sump / sumq ) * x else if ( xmax < x ) then value = huge ( x ) ! ! 15.0 <= ABS(ARG) ! else xx = one / x - rec15 sump = (((((( & pp(1) & * xx + pp(2) & ) * xx + pp(3) & ) * xx + pp(4) & ) * xx + pp(5) & ) * xx + pp(6) & ) * xx + pp(7) & ) * xx + pp(8) sumq = ((((( & xx + qq(1) & ) * xx + qq(2) & ) * xx + qq(3) & ) * xx + qq(4) & ) * xx + qq(5) & ) * xx + qq(6) value = sump / sumq if ( xmax - one5 < x ) then a = exp ( x - forty ) b = exp40 else a = exp ( x ) b = one end if value = ( ( value * a + pbar * a ) / sqrt ( x ) ) * b end if if ( arg < zero ) then value = -value end if bessel_i1 = value return end subroutine bessel_i1_values ( n_data, x, fx ) !******************************************************************************* ! !! BESSEL_I1_VALUES returns some values of the I1 Bessel function. ! ! Discussion: ! ! The modified Bessel functions In(Z) and Kn(Z) are solutions of ! the differential equation ! ! Z^2 W'' + Z * W' - ( Z^2 + N^2 ) * W = 0. ! ! In Mathematica, the function can be evaluated by: ! ! BesselI[1,x] ! ! Modified: ! ! 20 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 20 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.0000000000000000D+00, & 0.1005008340281251D+00, & 0.2040267557335706D+00, & 0.3137040256049221D+00, & 0.4328648026206398D+00, & 0.5651591039924850D+00, & 0.7146779415526431D+00, & 0.8860919814143274D+00, & 0.1084810635129880D+01, & 0.1317167230391899D+01, & 0.1590636854637329D+01, & 0.2516716245288698D+01, & 0.3953370217402609D+01, & 0.6205834922258365D+01, & 0.9759465153704450D+01, & 0.1538922275373592D+02, & 0.2433564214245053D+02, & 0.6134193677764024D+02, & 0.3998731367825601D+03, & 0.2670988303701255D+04 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.00D+00, & 0.20D+00, & 0.40D+00, & 0.60D+00, & 0.80D+00, & 0.10D+01, & 0.12D+01, & 0.14D+01, & 0.16D+01, & 0.18D+01, & 0.20D+01, & 0.25D+01, & 0.30D+01, & 0.35D+01, & 0.40D+01, & 0.45D+01, & 0.50D+01, & 0.60D+01, & 0.80D+01, & 0.10D+02 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 fx = 0.0D+00 else x = x_vec(n_data) fx = fx_vec(n_data) end if return end function beta ( a, b ) !******************************************************************************* ! !! BETA returns the value of the Beta function. ! ! Formula: ! ! BETA(A,B) = ( GAMMA ( A ) * GAMMA ( B ) ) / GAMMA ( A + B ) ! = Integral ( 0 <= T <= 1 ) T**(A-1) (1-T)**(B-1) dT. ! ! Modified: ! ! 10 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the function. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) BETA, the value of the function. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) beta real ( kind = 8 ) gamma_log if ( a <= 0.0D+00 .or. b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA - Fatal error!' write ( *, '(a)' ) ' Both A and B must be greater than 0.' stop end if beta = exp ( gamma_log ( a ) + gamma_log ( b ) - gamma_log ( a + b ) ) return end subroutine beta_binomial_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! BETA_BINOMIAL_CDF evaluates the Beta Binomial CDF. ! ! Discussion: ! ! A simple summing approach is used. ! ! Modified: ! ! 07 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Input, integer C, a parameter of the PDF. ! 0 <= C. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) beta integer c real ( kind = 8 ) cdf real ( kind = 8 ) pdf integer x integer y if ( x < 0 ) then cdf = 0.0D+00 else if ( x < c ) then cdf = 0.0D+00 do y = 0, x pdf = beta ( a + real ( y, kind = 8 ), & b + real ( c - y, kind = 8 ) ) / ( real ( c + 1, kind = 8 ) & * beta ( real ( y + 1 , kind = 8), & real ( c - y + 1, kind = 8 ) ) * beta ( a, b ) ) cdf = cdf + pdf end do else if ( c <= x ) then cdf = 1.0D+00 end if return end subroutine beta_binomial_cdf_inv ( cdf, a, b, c, x ) !******************************************************************************* ! !! BETA_BINOMIAL_CDF_INV inverts the Beta Binomial CDF. ! ! Discussion: ! ! A simple discrete approach is used. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, B, parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Input, integer C, a parameter of the PDF. ! 0 <= C. ! ! Output, integer X, the smallest X whose cumulative density function ! is greater than or equal to CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) beta integer c real ( kind = 8 ) cdf real ( kind = 8 ) cum real ( kind = 8 ) pdf integer x integer y if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_BINOMIAL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if cum = 0.0D+00 do y = 0, c pdf = beta ( a + real ( y, kind = 8 ), & b + real ( c - y, kind = 8 ) ) / ( real ( c + 1, kind = 8 ) & * beta ( real ( y + 1, kind = 8 ), & real ( c - y + 1, kind = 8 ) ) * beta ( a, b ) ) cum = cum + pdf if ( cdf <= cum ) then x = y return end if end do x = c return end function beta_binomial_check ( a, b, c ) !******************************************************************************* ! !! BETA_BINOMIAL_CHECK checks the parameters of the Beta Binomial PDF. ! ! Modified: ! ! 18 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Input, integer C, a parameter of the PDF. ! 0 <= C. ! ! Output, logical BETA_BINOMIAL_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical beta_binomial_check integer c if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_BINOMIAL_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.' beta_binomial_check = .false. return end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_BINOMIAL_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' beta_binomial_check = .false. return end if if ( c < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_BINOMIAL_CHECK - Fatal error!' write ( *, '(a)' ) ' C < 0.' beta_binomial_check = .false. return end if beta_binomial_check = .true. return end subroutine beta_binomial_mean ( a, b, c, mean ) !******************************************************************************* ! !! BETA_BINOMIAL_MEAN returns the mean of the Beta Binomial PDF. ! ! Modified: ! ! 26 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Input, integer C, a parameter of the PDF. ! 0 <= N. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer c real ( kind = 8 ) mean mean = real ( c, kind = 8 ) * a / ( a + b ) return end subroutine beta_binomial_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! BETA_BINOMIAL_PDF evaluates the Beta Binomial PDF. ! ! Formula: ! ! PDF(A,B,C;X) = Beta(A+X,B+C-X) ! / ( (C+1) * Beta(X+1,C-X+1) * Beta(A,B) ) for 0 <= X <= C. ! ! This PDF can be reformulated as: ! ! The beta binomial probability density function for X successes ! out of N trials is ! ! PDF2(X)( N, MU, THETA ) = ! C(N,X) * Product ( 0 <= R <= X - 1 ) ( MU + R * THETA ) ! * Product ( 0 <= R <= N - X - 1 ) ( 1 - MU + R * THETA ) ! / Product ( 0 <= R <= N - 1 ) ( 1 + R * THETA ) ! ! where ! ! C(N,X) is the combinatorial coefficient; ! MU is the expectation of the underlying Beta distribution; ! THETA is a shape parameter. ! ! A THETA value of 0 ( or A+B --> Infinity ) results in the binomial ! distribution: ! ! PDF2(X) ( N, MU, 0 ) = C(N,X) * MU**X * ( 1 - MU )**(N-X) ! ! Given A, B, C for PDF, then the equivalent PDF2 has: ! ! N = C ! MU = A / ( A + B ) ! THETA = 1 / ( A + B ) ! ! Given N, MU, THETA for PDF2, the equivalent PDF has: ! ! A = MU / THETA ! B = ( 1 - MU ) / THETA ! C = N ! ! Discussion: ! ! BETA_BINOMIAL_PDF(1,1,C;X) = UNIFORM_DISCRETE_PDF(0,C-1;X) ! ! Modified: ! ! 18 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Input, integer C, a parameter of the PDF. ! 0 <= C. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) beta integer c real ( kind = 8 ) pdf integer x if ( x < 0 ) then pdf = 0.0D+00 else if ( x <= c ) then pdf = beta ( a + real ( x, kind = 8 ), b + real ( c - x, kind = 8 ) ) & / ( real ( c + 1, kind = 8 ) & * beta ( real ( x + 1, kind = 8 ), & real ( c - x + 1, kind = 8 ) ) * beta ( a, b ) ) else if ( c < x ) then pdf = 0.0D+00 end if return end subroutine beta_binomial_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! BETA_BINOMIAL_SAMPLE samples the Beta Binomial CDF. ! ! Modified: ! ! 07 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Input, integer C, a parameter of the PDF. ! 0 <= C. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer c real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed integer x cdf = d_uniform_01 ( seed ) call beta_binomial_cdf_inv ( cdf, a, b, c, x ) return end subroutine beta_binomial_variance ( a, b, c, variance ) !******************************************************************************* ! !! BETA_BINOMIAL_VARIANCE returns the variance of the Beta Binomial PDF. ! ! Modified: ! ! 26 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Input, integer C, a parameter of the PDF. ! 0 <= C. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer c real ( kind = 8 ) variance variance = ( real ( c, kind = 8 ) * a * b ) & * ( a + b + real ( c, kind = 8 ) ) & / ( ( a + b )**2 * ( a + b + 1.0D+00 ) ) return end subroutine beta_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! BETA_CDF evaluates the Beta CDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) beta_inc real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x <= 0.0D+00 ) then cdf = 0.0D+00 else if ( x <= 1.0D+00 ) then cdf = beta_inc ( a, b, x ) else cdf = 1.0D+00 end if return end subroutine beta_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! BETA_CDF_INV inverts the Beta CDF. ! ! Modified: ! ! 21 April 2001 ! ! Author: ! ! Abernathy and Smith ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Abernathy and Smith, ! Algorithm 724, ! ACM Transactions on Mathematical Software, ! Volume 19, Number 4, December 1993, pages 481-483. ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the argument of the CDF. ! implicit none integer, parameter :: maxk = 20 real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) bcoeff real ( kind = 8 ) cdf real ( kind = 8 ) cdf_x real ( kind = 8 ) d(2:maxk,0:maxk-2) real ( kind = 8 ), parameter :: error = 0.0001D+00 real ( kind = 8 ), parameter :: errapp = 0.01D+00 integer i integer j integer k integer loopct real ( kind = 8 ) pdf_x real ( kind = 8 ) q real ( kind = 8 ) s1 real ( kind = 8 ) s2 real ( kind = 8 ) sum2 real ( kind = 8 ) t real ( kind = 8 ) tail real ( kind = 8 ) x real ( kind = 8 ) xold if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if ! ! Estimate the solution. ! x = a / ( a + b ) xold = 0.0D+00 loopct = 2 do while ( errapp <= abs ( ( x - xold ) / x ) .and. loopct /= 0 ) xold = x loopct = loopct - 1 ! ! CDF_X = PROB { BETA(A,B) <= X }. ! Q = ( CDF - CDF_X ) / PDF_X. ! call beta_cdf ( x, a, b, cdf_x ) call beta_pdf ( x, a, b, pdf_x ) q = ( cdf - cdf_x ) / pdf_x ! ! D(N,K) = C(N,K) * Q**(N+K-1) / (N-1)! ! t = 1.0D+00 - x s1 = q * ( b - 1.0D+00 ) / t s2 = q * ( 1.0D+00 - a ) / x d(2,0) = s1 + s2 tail = d(2,0) * q / 2.0D+00 x = x + q + tail k = 3 do while ( error < abs ( tail / x ) .and. k <= maxk ) ! ! Find D(2,K-2). ! s1 = q * ( real ( k, kind = 8 ) - 2.0D+00 ) * s1 / t s2 = q * ( 2.0D+00 - real ( k, kind = 8 ) ) * s2 / x d(2,k-2) = s1 + s2 ! ! Find D(3,K-3), D(4,K-4), D(5,K-5), ... , D(K-1,1). ! do i = 3, k-1 sum2 = d(2,0) * d(i-1,k-i) bcoeff = 1.0D+00 do j = 1, k-i bcoeff = ( bcoeff * real ( k - i - j + 1, kind = 8 ) ) & / real ( j, kind = 8 ) sum2 = sum2 + bcoeff * d(2,j) * d(i-1,k-i-j) end do d(i,k-i) = sum2 + d(i-1,k-i+1) / real ( i - 1, kind = 8 ) end do ! ! Compute D(K,0) and use it to expand the series. ! d(k,0) = d(2,0) * d(k-1,0) + d(k-1,1) / real ( k - 1, kind = 8 ) tail = d(k,0) * q / real ( k, kind = 8 ) x = x + tail ! ! Check for divergence. ! if ( x <= 0.0D+00 .or. 1.0D+00 <= x ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_CDF_INV - Fatal error!' write ( *, '(a)' ) ' The series has diverged.' write ( *, '(a,g14.6)' ) ' X = ', x x = - 1.0D+00 return end if k = k + 1 end do end do return end subroutine beta_cdf_values ( n_data, a, b, x, fx ) !******************************************************************************* ! !! BETA_CDF_VALUES returns some values of the Beta CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = BetaDistribution [ a, b ] ! CDF [ dist, x ] ! ! Modified: ! ! 02 September 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Karl Pearson, ! Tables of the Incomplete Beta Function, ! Cambridge University Press, 1968. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) A, B, the parameters of the function. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 12 real ( kind = 8 ) a real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ & 0.10D+01, & 0.10D+01, & 0.10D+01, & 0.10D+01, & 0.10D+01, & 0.10D+01, & 0.10D+01, & 0.10D+01, & 0.20D+01, & 0.30D+01, & 0.40D+01, & 0.50D+01 /) real ( kind = 8 ) b real ( kind = 8 ), save, dimension ( n_max ) :: b_vec = (/ & 0.50D+00, & 0.50D+00, & 0.50D+00, & 0.50D+00, & 0.20D+01, & 0.30D+01, & 0.40D+01, & 0.50D+01, & 0.20D+01, & 0.20D+01, & 0.20D+01, & 0.20D+01 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.5131670194948620D-01, & 0.1055728090000841D+00, & 0.1633399734659245D+00, & 0.2254033307585166D+00, & 0.3600000000000000D+00, & 0.4880000000000000D+00, & 0.5904000000000000D+00, & 0.6723200000000000D+00, & 0.2160000000000000D+00, & 0.8370000000000000D-01, & 0.3078000000000000D-01, & 0.1093500000000000D-01 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.10D+00, & 0.20D+00, & 0.30D+00, & 0.40D+00, & 0.20D+00, & 0.20D+00, & 0.20D+00, & 0.20D+00, & 0.30D+00, & 0.30D+00, & 0.30D+00, & 0.30D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 a = 0.0D+00 b = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else a = a_vec(n_data) b = b_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function beta_check ( a, b ) !******************************************************************************* ! !! BETA_CHECK checks the parameters of the Beta PDF. ! ! Modified: ! ! 08 December 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, logical BETA_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical beta_check if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.' beta_check = .false. return end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' beta_check = .false. return end if beta_check = .true. return end function beta_inc ( a, b, x ) !******************************************************************************* ! !! BETA_INC returns the value of the incomplete Beta function. ! ! Discussion: ! ! This calculation requires an iteration. In some cases, the iteration ! may not converge rapidly, or may become inaccurate. ! ! Formula: ! ! BETA_INC(A,B,X) ! ! = Integral ( 0 <= T <= X ) T**(A-1) (1-T)**(B-1) dT ! / Integral ( 0 <= T <= 1 ) T**(A-1) (1-T)**(B-1) dT ! ! = Integral ( 0 <= T <= X ) T**(A-1) (1-T)**(B-1) dT ! / BETA(A,B) ! ! Modified: ! ! 16 February 2004 ! ! Author: ! ! Majumder and Bhattacharjee ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Majumder and Bhattacharjee, ! Algorithm AS63, ! Applied Statistics, ! 1973, volume 22, number 3. ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the function. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Input, real ( kind = 8 ) X, the argument of the function. ! Normally, 0.0D+00 <= X <= 1.0. ! ! Output, real ( kind = 8 ) BETA_INC, the value of the function. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) beta real ( kind = 8 ) beta_inc real ( kind = 8 ) cx integer i integer it integer, parameter :: it_max = 1000 logical indx integer ns real ( kind = 8 ) pp real ( kind = 8 ) psq real ( kind = 8 ) qq real ( kind = 8 ) rx real ( kind = 8 ) temp real ( kind = 8 ) term real ( kind = 8 ), parameter :: tol = 1.0D-07 real ( kind = 8 ) x real ( kind = 8 ) xx if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_INC - Fatal error!' write ( *, '(a)' ) ' A <= 0.' stop end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_INC - Fatal error!' write ( *, '(a)' ) ' B <= 0.' stop end if if ( x <= 0.0D+00 ) then beta_inc = 0.0D+00 return else if ( 1.0D+00 <= x ) then beta_inc = 1.0D+00 return end if ! ! Change tail if necessary and determine S. ! psq = a + b if ( a < ( a + b ) * x ) then xx = 1.0D+00 - x cx = x pp = b qq = a indx = .true. else xx = x cx = 1.0D+00 - x pp = a qq = b indx = .false. end if term = 1.0D+00 i = 1 beta_inc = 1.0D+00 ns = int ( qq + cx * ( a + b ) ) ! ! Use Soper's reduction formulas. ! rx = xx / cx temp = qq - real ( i, kind = 8 ) if ( ns == 0 ) then rx = xx end if it = 0 do it = it + 1 if ( it_max < it ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_INC - Fatal error!' write ( *, '(a)' ) ' Maximum number of iterations exceeded!' write ( *, '(a,i8)' ) ' IT_MAX = ', it_max stop end if term = term * temp * rx / ( pp + real ( i, kind = 8 ) ) beta_inc = beta_inc + term temp = abs ( term ) if ( temp <= tol .and. temp <= tol * beta_inc ) then exit end if i = i + 1 ns = ns - 1 if ( 0 <= ns ) then temp = qq - real ( i, kind = 8 ) if ( ns == 0 ) then rx = xx end if else temp = psq psq = psq + 1.0D+00 end if end do ! ! Finish calculation. ! beta_inc = beta_inc * exp ( pp * log ( xx ) & + ( qq - 1.0D+00 ) * log ( cx ) ) / ( beta ( a, b ) * pp ) if ( indx ) then beta_inc = 1.0D+00 - beta_inc end if return end subroutine beta_inc_values ( n_data, a, b, x, fx ) !******************************************************************************* ! !! BETA_INC_VALUES returns some values of the incomplete Beta function. ! ! Discussion: ! ! The incomplete Beta function may be written ! ! BETA_INC(A,B,X) = Integral (0 to X) T**(A-1) * (1-T)**(B-1) dT ! / Integral (0 to 1) T**(A-1) * (1-T)**(B-1) dT ! ! Thus, ! ! BETA_INC(A,B,0.0) = 0.0D+00 ! BETA_INC(A,B,1.0) = 1.0 ! ! In Mathematica, the function can be evaluated by: ! ! BETA[X,A,B] / BETA[A,B] ! ! Modified: ! ! 09 June 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Karl Pearson, ! Tables of the Incomplete Beta Function, ! Cambridge University Press, 1968. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) A, B, the parameters of the function. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 30 real ( kind = 8 ) a real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ & 0.5D+00, & 0.5D+00, & 0.5D+00, & 1.0D+00, & 1.0D+00, & 1.0D+00, & 1.0D+00, & 1.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 5.5D+00, & 10.0D+00, & 10.0D+00, & 10.0D+00, & 10.0D+00, & 20.0D+00, & 20.0D+00, & 20.0D+00, & 20.0D+00, & 20.0D+00, & 30.0D+00, & 30.0D+00, & 40.0D+00 /) real ( kind = 8 ) b real ( kind = 8 ), save, dimension ( n_max ) :: b_vec = (/ & 0.5D+00, & 0.5D+00, & 0.5D+00, & 0.5D+00, & 0.5D+00, & 0.5D+00, & 0.5D+00, & 1.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 5.0D+00, & 0.5D+00, & 5.0D+00, & 5.0D+00, & 10.0D+00, & 5.0D+00, & 10.0D+00, & 10.0D+00, & 20.0D+00, & 20.0D+00, & 10.0D+00, & 10.0D+00, & 20.0D+00 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.6376856085851985D-01, & 0.2048327646991335D+00, & 0.1000000000000000D+01, & 0.0000000000000000D+00, & 0.5012562893380045D-02, & 0.5131670194948620D-01, & 0.2928932188134525D+00, & 0.5000000000000000D+00, & 0.2800000000000000D-01, & 0.1040000000000000D+00, & 0.2160000000000000D+00, & 0.3520000000000000D+00, & 0.5000000000000000D+00, & 0.6480000000000000D+00, & 0.7840000000000000D+00, & 0.8960000000000000D+00, & 0.9720000000000000D+00, & 0.4361908850559777D+00, & 0.1516409096347099D+00, & 0.8978271484375000D-01, & 0.1000000000000000D+01, & 0.5000000000000000D+00, & 0.4598773297575791D+00, & 0.2146816102371739D+00, & 0.9507364826957875D+00, & 0.5000000000000000D+00, & 0.8979413687105918D+00, & 0.2241297491808366D+00, & 0.7586405487192086D+00, & 0.7001783247477069D+00 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.01D+00, & 0.10D+00, & 1.00D+00, & 0.00D+00, & 0.01D+00, & 0.10D+00, & 0.50D+00, & 0.50D+00, & 0.10D+00, & 0.20D+00, & 0.30D+00, & 0.40D+00, & 0.50D+00, & 0.60D+00, & 0.70D+00, & 0.80D+00, & 0.90D+00, & 0.50D+00, & 0.90D+00, & 0.50D+00, & 1.00D+00, & 0.50D+00, & 0.80D+00, & 0.60D+00, & 0.80D+00, & 0.50D+00, & 0.60D+00, & 0.70D+00, & 0.80D+00, & 0.70D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 a = 0.0D+00 b = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else a = a_vec(n_data) b = b_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end subroutine beta_mean ( a, b, mean ) !******************************************************************************* ! !! BETA_MEAN returns the mean of the Beta PDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a / ( a + b ) return end subroutine beta_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! BETA_PDF evaluates the Beta PDF. ! ! Formula: ! ! PDF(A,B;X) = X**(A-1) * (1-X)**(B-1) / BETA(A,B). ! ! Discussion: ! ! A = B = 1 yields the Uniform distribution on [0,1]. ! A = B = 1/2 yields the Arcsin distribution. ! B = 1 yields the power function distribution. ! A = B -> Infinity tends to the Normal distribution. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) beta real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x < 0.0D+00 .or. 1.0D+00 < x ) then pdf = 0.0D+00 else pdf = x**( a - 1.0D+00 ) * ( 1.0D+00 - x )**( b - 1.0D+00 ) / beta ( a, b ) end if return end subroutine beta_sample ( a, b, seed, x ) !******************************************************************************* ! !! BETA_SAMPLE samples the Beta PDF. ! ! Modified: ! ! 05 February 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! William Kennedy and James Gentle, ! Algorithm BN, ! Statistical Computing, ! Dekker, 1980. ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) d_uniform_01 real ( kind = 8 ) mu integer seed real ( kind = 8 ) stdev real ( kind = 8 ) test real ( kind = 8 ) u real ( kind = 8 ) x real ( kind = 8 ) y mu = ( a - 1.0D+00 ) / ( a + b - 2.0D+00 ) stdev = 0.5D+00 / sqrt ( a + b - 2.0D+00 ) do call normal_01_sample ( seed, y ) x = mu + stdev * y if ( x < 0.0D+00 .or. 1.0D+00 < x ) then cycle end if u = d_uniform_01 ( seed ) test = ( a - 1.0D+00 ) * log ( x / ( a - 1.0D+00 ) ) & + ( b - 1.0D+00 ) * log ( ( 1.0D+00 - x ) / ( b - 1.0D+00 ) ) & + ( a + b - 2.0D+00 ) * log ( a + b - 2.0D+00 ) + 0.5D+00 * y * y if ( log ( u ) <= test ) then exit end if end do return end subroutine beta_variance ( a, b, variance ) !******************************************************************************* ! !! BETA_VARIANCE returns the variance of the Beta PDF. ! ! Modified: ! ! 27 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = ( a * b ) / ( ( a + b )**2 * ( 1.0D+00 + a + b ) ) return end subroutine binomial_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! BINOMIAL_CDF evaluates the Binomial CDF. ! ! Definition: ! ! CDF(X)(A,B) is the probability of at most X successes in A trials, ! given that the probability of success on a single trial is B. ! ! Discussion: ! ! A sequence of trials with fixed probability of success on ! any trial is known as a sequence of Bernoulli trials. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the desired number of successes. ! 0 <= X <= A. ! ! Input, integer A, the number of trials. ! 1 <= A. ! ! Input, real ( kind = 8 ) B, the probability of success on one trial. ! 0.0D+00 <= B <= 1.0. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none integer a real ( kind = 8 ) b integer cnk real ( kind = 8 ) cdf integer j real ( kind = 8 ) pr integer x if ( x < 0 ) then cdf = 0.0D+00 else if ( a <= x ) then cdf = 1.0D+00 else if ( b == 0.0D+00 ) then cdf = 1.0D+00 else if ( b == 1.0D+00 ) then cdf = 0.0D+00 else cdf = 0.0D+00 do j = 0, x call binomial_coef ( a, j, cnk ) pr = real ( cnk, kind = 8 ) * b**j * ( 1.0D+00 - b )**( a - j ) cdf = cdf + pr end do end if return end subroutine binomial_cdf_values ( n_data, a, b, x, fx ) !******************************************************************************* ! !! BINOMIAL_CDF_VALUES returns some values of the binomial CDF. ! ! Discussion: ! ! CDF(X)(A,B) is the probability of at most X successes in A trials, ! given that the probability of success on a single trial is B. ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`DiscreteDistributions`] ! dist = BinomialDistribution [ n, p ] ! CDF [ dist, x ] ! ! Modified: ! ! 15 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Daniel Zwillinger, ! CRC Standard Mathematical Tables and Formulae, ! 30th Edition, CRC Press, 1996, pages 651-652. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer A, a parameter of the function. ! ! Output, real ( kind = 8 ) B, a parameter of the function. ! ! Output, integer X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 17 integer a integer, save, dimension ( n_max ) :: a_vec = (/ & 2, 2, 2, 2, & 2, 4, 4, 4, & 4, 10, 10, 10, & 10, 10, 10, 10, & 10 /) real ( kind = 8 ) b real ( kind = 8 ), save, dimension ( n_max ) :: b_vec = (/ & 0.05D+00, & 0.05D+00, & 0.05D+00, & 0.50D+00, & 0.50D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.05D+00, & 0.10D+00, & 0.15D+00, & 0.20D+00, & 0.25D+00, & 0.30D+00, & 0.40D+00, & 0.50D+00 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.9025000000000000D+00, & 0.9975000000000000D+00, & 0.1000000000000000D+01, & 0.2500000000000000D+00, & 0.7500000000000000D+00, & 0.3164062500000000D+00, & 0.7382812500000000D+00, & 0.9492187500000000D+00, & 0.9960937500000000D+00, & 0.9999363101685547D+00, & 0.9983650626000000D+00, & 0.9901259090013672D+00, & 0.9672065024000000D+00, & 0.9218730926513672D+00, & 0.8497316674000000D+00, & 0.6331032576000000D+00, & 0.3769531250000000D+00 /) integer n_data integer x integer, save, dimension ( n_max ) :: x_vec = (/ & 0, 1, 2, 0, & 1, 0, 1, 2, & 3, 4, 4, 4, & 4, 4, 4, 4, & 4 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 a = 0 b = 0.0D+00 x = 0 fx = 0.0D+00 else a = a_vec(n_data) b = b_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end subroutine binomial_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! BINOMIAL_CDF_INV inverts the Binomial CDF. ! ! Modified: ! ! 06 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, integer A, the number of trials. ! 1 <= A. ! ! Input, real ( kind = 8 ) B, the probability of success on one trial. ! 0.0D+00 <= B <= 1.0. ! ! Output, integer X, the corresponding argument. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cdf2 real ( kind = 8 ) pdf integer x integer x2 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BINOMIAL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if cdf2 = 0.0D+00 do x2 = 0, a call binomial_pdf ( x2, a, b, pdf ) cdf2 = cdf2 + pdf if ( cdf <= cdf2 ) then x = x2 return end if end do return end function binomial_check ( a, b ) !******************************************************************************* ! !! BINOMIAL_CHECK checks the parameter of the Binomial PDF. ! ! Modified: ! ! 18 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of trials. ! 1 <= A. ! ! Input, real ( kind = 8 ) B, the probability of success on one trial. ! 0.0D+00 <= B <= 1.0. ! ! Output, logical BINOMIAL_CHECK, is true if the parameters are legal. ! implicit none integer a real ( kind = 8 ) b logical binomial_check if ( a < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BINOMIAL_CHECK - Fatal error!' write ( *, '(a)' ) ' A < 1.' binomial_check = .false. return end if if ( b < 0.0D+00 .or. 1.0D+00 < b ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BINOMIAL_CHECK - Fatal error!' write ( *, '(a)' ) ' B < 0 or 1 < B.' binomial_check = .false. return end if binomial_check = .true. return end subroutine binomial_coef ( n, k, cnk ) !******************************************************************************* ! !! BINOMIAL_COEF computes the Binomial coefficient C(N,K). ! ! Discussion: ! ! The value is calculated in such a way as to avoid overflow and ! roundoff. The calculation is done in integer arithmetic. ! ! Formula: ! ! CNK = C(N,K) = N! / ( K! * (N-K)! ) ! ! Modified: ! ! 17 January 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! M L Wolfson and H V Wright, ! Combinatorial of M Things Taken N at a Time, ! ACM Algorithm 160, ! Communications of the ACM, ! April, 1963. ! ! Parameters: ! ! Input, integer N, K, are the values of N and K. ! ! Output, integer CNK, the number of combinations of N ! things taken K at a time. ! implicit none integer cnk integer i integer k integer mn integer mx integer n mn = min ( k, n-k ) if ( mn < 0 ) then cnk = 0 else if ( mn == 0 ) then cnk = 1 else mx = max ( k, n-k ) cnk = mx + 1 do i = 2, mn cnk = ( cnk * ( mx + i ) ) / i end do end if return end subroutine binomial_coef_log ( n, k, cnk_log ) !******************************************************************************* ! !! BINOMIAL_COEF_LOG computes the logarithm of the Binomial coefficient. ! ! Formula: ! ! CNK_LOG = LOG ( C(N,K) ) = LOG ( N! / ( K! * (N-K)! ) ). ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, K, are the values of N and K. ! ! Output, real ( kind = 8 ) CNK_LOG, the logarithm of C(N,K). ! implicit none real ( kind = 8 ) cnk_log real ( kind = 8 ) factorial_log integer k integer n cnk_log = factorial_log ( n ) - factorial_log ( k ) - factorial_log ( n - k ) return end subroutine binomial_mean ( a, b, mean ) !******************************************************************************* ! !! BINOMIAL_MEAN returns the mean of the Binomial PDF. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of trials. ! 1 <= A. ! ! Input, real ( kind = 8 ) B, the probability of success on one trial. ! 0.0D+00 <= B <= 1.0. ! ! Output, real ( kind = 8 ) MEAN, the expected value of the number of ! successes in A trials. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) mean mean = real ( a, kind = 8 ) * b return end subroutine binomial_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! BINOMIAL_PDF evaluates the Binomial PDF. ! ! Definition: ! ! PDF(A,B;X) is the probability of exactly X successes in A trials, ! given that the probability of success on a single trial is B. ! ! Formula: ! ! PDF(A,B;X) = C(N,X) * B**X * ( 1.0D+00 - B )**( A - X ) ! ! Discussion: ! ! Binomial_PDF(1,B;X) = Bernoulli_PDF(B;X). ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the desired number of successes. ! 0 <= X <= A. ! ! Input, integer A, the number of trials. ! 1 <= A. ! ! Input, real ( kind = 8 ) B, the probability of success on one trial. ! 0.0D+00 <= B <= 1.0. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none integer a real ( kind = 8 ) b integer cnk real ( kind = 8 ) pdf integer x if ( a < 1 ) then pdf = 0.0D+00 else if ( x < 0 .or. a < x ) then pdf = 0.0D+00 else if ( b == 0.0D+00 ) then if ( x == 0 ) then pdf = 1.0D+00 else pdf = 0.0D+00 end if else if ( b == 1.0D+00 ) then if ( x == a ) then pdf = 1.0D+00 else pdf = 0.0D+00 end if else call binomial_coef ( a, x, cnk ) pdf = real ( cnk, kind = 8 ) * b**x * ( 1.0D+00 - b )**( a - x ) end if return end subroutine binomial_sample ( a, b, seed, x ) !******************************************************************************* ! !! BINOMIAL_SAMPLE samples the Binomial PDF. ! ! Modified: ! ! 02 February 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! William Kennedy and James Gentle, ! Algorithm BU, ! Statistical Computing, ! Dekker, 1980. ! ! Parameters: ! ! Input, integer A, the number of trials. ! 1 <= A. ! ! Input, real ( kind = 8 ) B, the probability of success on one trial. ! 0.0D+00 <= B <= 1.0. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) d_uniform_01 integer i integer seed real ( kind = 8 ) u integer x x = 0 do i = 1, a u = d_uniform_01 ( seed ) if ( u <= b ) then x = x + 1 end if end do return end subroutine binomial_variance ( a, b, variance ) !******************************************************************************* ! !! BINOMIAL_VARIANCE returns the variance of the Binomial PDF. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of trials. ! 1 <= A. ! ! Input, real ( kind = 8 ) B, the probability of success on one trial. ! 0.0D+00 <= B <= 1.0. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) variance variance = real ( a, kind = 8 ) * b * ( 1.0D+00 - b ) return end subroutine bradford_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! BRADFORD_CDF evaluates the Bradford CDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x <= a ) then cdf = 0.0D+00 else if ( x <= b ) then cdf = log ( 1.0D+00 + c * ( x - a ) / ( b - a ) ) / log ( c + 1.0D+00 ) else if ( b < x ) then cdf = 1.0D+00 end if return end subroutine bradford_cdf_inv ( cdf, a, b, c, x ) !******************************************************************************* ! !! BRADFORD_CDF_INV inverts the Bradford CDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BRADFORD_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf <= 0.0D+00 ) then x = a else if ( cdf < 1.0D+00 ) then x = a + ( b - a ) * ( ( c + 1.0D+00 )**cdf - 1.0D+00 ) / c else if ( 1.0D+00 <= cdf ) then x = b end if return end function bradford_check ( a, b, c ) !******************************************************************************* ! !! BRADFORD_CHECK checks the parameters of the Bradford PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A < B, ! 0.0D+00 < C. ! ! Output, logical BRADFORD_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical bradford_check real ( kind = 8 ) c if ( b <= a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BRADFORD_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= A.' bradford_check = .false. return end if if ( c <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BRADFORD_CHECK - Fatal error!' write ( *, '(a)' ) ' C <= 0.' bradford_check = .false. return end if bradford_check = .true. return end subroutine bradford_mean ( a, b, c, mean ) !******************************************************************************* ! !! BRADFORD_MEAN returns the mean of the Bradford PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) mean mean = ( c * ( b - a ) + log ( c + 1.0D+00 ) * ( a * ( c + 1.0D+00 ) - b ) ) & / ( c * log ( c + 1.0D+00 ) ) return end subroutine bradford_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! BRADFORD_PDF evaluates the Bradford PDF. ! ! Formula: ! ! PDF(A,B,C;X) = ! C / ( ( C * ( X - A ) + B - A ) * log ( C + 1 ) ) ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A <= X ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x <= a ) then pdf = 0.0D+00 else if ( x <= b ) then pdf = c / ( ( c * ( x - a ) + b - a ) * log ( c + 1.0D+00 ) ) else if ( b < x ) then pdf = 0.0D+00 end if return end subroutine bradford_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! BRADFORD_SAMPLE samples the Bradford PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A < B, ! 0.0D+00 < C. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) x = a + ( b - a ) * ( ( c + 1.0D+00 )**cdf - 1.0D+00 ) / c return end subroutine bradford_variance ( a, b, c, variance ) !******************************************************************************* ! !! BRADFORD_VARIANCE returns the variance of the Bradford PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) variance variance = ( b - a )**2 * & ( c * ( log ( c + 1.0D+00 ) - 2.0D+00 ) + 2.0D+00 * log ( c + 1.0D+00 ) ) & / ( 2.0D+00 * c * ( log ( c + 1.0D+00 ) )**2 ) return end subroutine burr_cdf ( x, a, b, c, d, cdf ) !******************************************************************************* ! !! BURR_CDF evaluates the Burr CDF. ! ! Modified: ! ! 01 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, C, D, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) d real ( kind = 8 ) x if ( x <= a ) then cdf = 0.0D+00 else cdf = 1.0D+00 / ( 1.0D+00 + ( b / ( x - a ) )**c )**d end if return end subroutine burr_cdf_inv ( cdf, a, b, c, d, x ) !******************************************************************************* ! !! BURR_CDF_INV inverts the Burr CDF. ! ! Modified: ! ! 01 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, C, D, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) d real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BURR_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = a + b / ( ( 1.0D+00 / cdf )**(1.0D+00 / d ) - 1.0D+00 )**( 1.0D+00 / c ) return end function burr_check ( a, b, c, d ) !******************************************************************************* ! !! BURR_CHECK checks the parameters of the Burr CDF. ! ! Modified: ! ! 01 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, D, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, logical BURR_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical burr_check real ( kind = 8 ) c real ( kind = 8 ) d if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BURR_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' burr_check = .false. return end if if ( c <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BURR_CHECK - Fatal error!' write ( *, '(a)' ) ' C <= 0.' burr_check = .false. return end if burr_check = .true. return end subroutine burr_mean ( a, b, c, d, mean ) !******************************************************************************* ! !! BURR_MEAN returns the mean of the Burr PDF. ! ! Modified: ! ! 01 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, D, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) d real ( kind = 8 ) gamma real ( kind = 8 ) mean mean = a + b * gamma ( 1.0D+00 - 1.0D+00 / c ) & * gamma ( d + 1.0D+00 / c ) / gamma ( d ) return end subroutine burr_pdf ( x, a, b, c, d, pdf ) !******************************************************************************* ! !! BURR_PDF evaluates the Burr PDF. ! ! Formula: ! ! PDF(A,B,C,D;X) = ( C * D / B ) * ( ( X - A ) / B )**( - C - 1 ) ! * ( 1 + ( ( X - A ) / B )**( - C ) )**( - D - 1 ) ! ! Modified: ! ! 01 January 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! M E Johnson, ! Multivariate Statistical Simulation, ! Wiley, New York, 1987. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A <= X ! ! Input, real ( kind = 8 ) A, B, C, D, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) d real ( kind = 8 ) pdf real ( kind = 8 ) x real ( kind = 8 ) y if ( x <= a ) then pdf = 0.0D+00 else y = ( x - a ) / b pdf = ( c * d / b ) * y**( - c - 1.0D+00 ) & * ( 1.0D+00 + y**( - c ) )**( - d - 1.0D+00 ) end if return end subroutine burr_sample ( a, b, c, d, seed, x ) !******************************************************************************* ! !! BURR_SAMPLE samples the Burr PDF. ! ! Modified: ! ! 01 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, D, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) d real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call burr_cdf_inv ( cdf, a, b, c, d, x ) return end subroutine burr_variance ( a, b, c, d, variance ) !******************************************************************************* ! !! BURR_VARIANCE returns the variance of the Burr PDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, D, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) d real ( kind = 8 ) gamma real ( kind = 8 ) k real ( kind = 8 ) variance if ( c <= 2.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BURR_VARIANCE - Warning!' write ( *, '(a)' ) ' Variance undefined for C <= 2.' variance = huge ( variance ) else k = gamma ( d ) * gamma ( 1.0D+00 - 2.0D+00 / c ) & * gamma ( d + 2.0D+00 / c ) & - ( gamma ( 1.0D+00 - 1.0D+00 / c ) * gamma ( d + 1.0D+00 / c ) )**2 variance = k * b * b / ( gamma ( d ) )**2 end if return end subroutine c_normal_01_sample ( seed, x ) !******************************************************************************* ! !! C_NORMAL_01_SAMPLE samples the complex Normal 01 PDF. ! ! Modified: ! ! 30 July 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, complex X, a sample of the PDF. ! implicit none real ( kind = 8 ) d_uniform_01 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 integer seed real ( kind = 8 ) v1 real ( kind = 8 ) v2 complex x real ( kind = 8 ) x_c real ( kind = 8 ) x_r v1 = d_uniform_01 ( seed ) v2 = d_uniform_01 ( seed ) x_r = sqrt ( - 2.0D+00 * log ( v1 ) ) * cos ( 2.0D+00 * pi * v2 ) x_c = sqrt ( - 2.0D+00 * log ( v1 ) ) * sin ( 2.0D+00 * pi * v2 ) x = cmplx ( x_r, x_c ) return end subroutine cardioid_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! CARDIOID_CDF evaluates the Cardioid CDF. ! ! Discussion: ! ! The angle X is assumed to lie between A - PI and A + PI. ! ! Modified: ! ! 30 July 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! A - PI <= X <= A + PI. ! ! Input, real ( kind = 8 ) A, B, the parameters. ! -0.5 <= B <= 0.5. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( x <= a - pi ) then cdf = 0.0D+00 else if ( x < a + pi ) then cdf = ( pi + x - a + 2.0D+00 * b * sin ( x - a ) ) / ( 2.0D+00 * pi ) else cdf = 1.0D+00 end if return end subroutine cardioid_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! CARDIOID_CDF_INV inverts the Cardioid CDF. ! ! Modified: ! ! 31 July 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0 <= CDF <= 1. ! ! Input, real ( kind = 8 ) A, B, the parameters. ! -0.5 <= B <= 0.5. ! ! Output, real ( kind = 8 ) X, the argument with the given CDF. ! A - PI <= X <= A + PI. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) fp real ( kind = 8 ) fx integer it real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ), parameter :: tol = 0.000001D+00 real ( kind = 8 ) x if ( cdf <= 0.0D+00 ) then x = a - pi else if ( cdf < 1.0D+00 ) then x = a it = 0 do fx = cdf - ( pi + x - a + 2.0D+00 * b * sin ( x - a ) ) / ( 2.0D+00 * pi ) if ( abs ( fx ) < tol ) then exit end if if ( 10 < it ) then stop end if fp = - ( 1.0D+00 + 2.0D+00 * b * cos ( x - a ) ) / ( 2.0D+00 * pi ) x = x - fx / fp x = max ( x, a - pi ) x = min ( x, a + pi ) it = it + 1 end do else x = a + pi end if return end function cardioid_check ( a, b ) !******************************************************************************* ! !! CARDIOID_CHECK checks the parameters of the Cardioid CDF. ! ! Modified: ! ! 31 July 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -0.5 <= B <= 0.5. ! ! Output, logical CARDIOID_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical cardioid_check if ( b < -0.5D+00 .or. 0.5D+00 < b ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CARDIOID_CHECK - Fatal error!' write ( *, '(a)' ) ' B < -0.5 or 0.5 < B.' cardioid_check = .false. return end if cardioid_check = .true. return end subroutine cardioid_mean ( a, b, mean ) !******************************************************************************* ! !! CARDIOID_MEAN returns the mean of the Cardioid PDF. ! ! Modified: ! ! 30 July 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -0.5 <= B <= 0.5. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a return end subroutine cardioid_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! CARDIOID_PDF evaluates the Cardioid PDF. ! ! Discussion: ! ! The cardioid PDF can be thought of as being applied to points on ! a circle. Compare this distribution with the "Cosine PDF". ! ! Formula: ! ! PDF(A,B;X) = ( 1 / ( 2 * PI ) ) * ( 1 + 2 * B * COS ( X - A ) ) ! for A - PI <= X <= A + PI, -1/2 <= B <= 1/2. ! ! Modified: ! ! 30 July 2005 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! N I Fisher, ! Statistical Analysis of Circular Data, ! Cambridge, 1993. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A - PI <= X <= A + PI. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -0.5 <= B <= 0.5. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x pdf = ( 1.0D+00 + 2.0D+00 * b * cos ( x - a ) ) / ( 2.0D+00 * pi ) return end subroutine cardioid_sample ( a, b, seed, x ) !******************************************************************************* ! !! CARDIOID_SAMPLE samples the Cardioid PDF. ! ! Modified: ! ! 30 July 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -0.5 <= B <= 0.5. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! A - PI <= X <= A + PI. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call cardioid_cdf_inv ( cdf, a, b, x ) return end subroutine cardioid_variance ( a, b, variance ) !******************************************************************************* ! !! CARDIOID_VARIANCE returns the variance of the Cardioid PDF. ! ! Modified: ! ! 31 July 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -0.5 <= B <= 0.5. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = 0.0D+00 return end subroutine cauchy_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! CAUCHY_CDF evaluates the Cauchy CDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b cdf = 0.5D+00 + atan ( y ) / PI return end subroutine cauchy_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! CAUCHY_CDF_INV inverts the Cauchy CDF. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CAUCHY_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = a + b * tan ( pi * ( cdf - 0.5D+00 ) ) return end subroutine cauchy_cdf_values ( n_data, mu, sigma, x, fx ) !******************************************************************************* ! !! CAUCHY_CDF_VALUES returns some values of the Cauchy CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = CauchyDistribution [ mu, sigma ] ! CDF [ dist, x ] ! ! Modified: ! ! 05 September 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) MU, the mean of the distribution. ! ! Output, real ( kind = 8 ) SIGMA, the variance of the distribution. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 12 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.5000000000000000D+00, & 0.8524163823495667D+00, & 0.9220208696226307D+00, & 0.9474315432887466D+00, & 0.6475836176504333D+00, & 0.6024163823495667D+00, & 0.5779791303773693D+00, & 0.5628329581890012D+00, & 0.6475836176504333D+00, & 0.5000000000000000D+00, & 0.3524163823495667D+00, & 0.2500000000000000D+00 /) real ( kind = 8 ) mu real ( kind = 8 ), save, dimension ( n_max ) :: mu_vec = (/ & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01 /) integer n_data real ( kind = 8 ) sigma real ( kind = 8 ), save, dimension ( n_max ) :: sigma_vec = (/ & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01 /) real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 mu = 0.0D+00 sigma = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else mu = mu_vec(n_data) sigma = sigma_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function cauchy_check ( a, b ) !******************************************************************************* ! !! CAUCHY_CHECK checks the parameters of the Cauchy CDF. ! ! Modified: ! ! 09 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, logical CAUCHY_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical cauchy_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CAUCHY_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' cauchy_check = .false. return end if cauchy_check = .true. return end subroutine cauchy_mean ( a, b, mean ) !******************************************************************************* ! !! CAUCHY_MEAN returns the mean of the Cauchy PDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a return end subroutine cauchy_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! CAUCHY_PDF evaluates the Cauchy PDF. ! ! Formula: ! ! PDF(A,B;X) = 1 / ( PI * B * ( 1 + ( ( X - A ) / B )**2 ) ) ! ! Discussion: ! ! The Cauchy PDF is also known as the Breit-Wigner PDF. It ! has some unusual properties. In particular, the integrals for the ! expected value and higher order moments are "singular", in the ! sense that the limiting values do not exist. A result can be ! obtained if the upper and lower limits of integration are set ! equal to +T and -T, and the limit as T=>INFINITY is taken, but ! this is a very weak and unreliable sort of limit. ! ! Modified: ! ! 09 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b pdf = 1.0D+00 / ( pi * b * ( 1.0D+00 + y * y ) ) return end subroutine cauchy_sample ( a, b, seed, x ) !******************************************************************************* ! !! CAUCHY_SAMPLE samples the Cauchy PDF. ! ! Modified: ! ! 11 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call cauchy_cdf_inv ( cdf, a, b, x ) return end subroutine cauchy_variance ( a, b, variance ) !******************************************************************************* ! !! CAUCHY_VARIANCE returns the variance of the Cauchy PDF. ! ! Discussion: ! ! The variance of the Cauchy PDF is not well defined. This routine ! is made available for completeness only, and simply returns ! a "very large" number. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = huge ( variance ) return end subroutine chi_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! CHI_CDF evaluates the Chi CDF. ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) gamma_inc real ( kind = 8 ) p2 real ( kind = 8 ) x real ( kind = 8 ) x2 real ( kind = 8 ) y if ( x <= a ) then cdf = 0.0D+00 else y = ( x - a ) / b x2 = 0.5D+00 * y * y p2 = 0.5D+00 * c cdf = gamma_inc ( p2, x2 ) end if return end subroutine chi_cdf_inv ( cdf, a, b, c, x ) !******************************************************************************* ! !! CHI_CDF_INV inverts the Chi CDF. ! ! Discussion: ! ! A simple bisection method is used. ! ! Modified: ! ! 30 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) cdf1 real ( kind = 8 ) cdf2 real ( kind = 8 ) cdf3 integer it integer, parameter :: it_max = 100 real ( kind = 8 ), parameter :: tol = 0.0001D+00 real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 real ( kind = 8 ) x3 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHI_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = a return else if ( 1.0D+00 == cdf ) then x = huge ( x ) return end if x1 = a cdf1 = 0.0D+00 x2 = a + 1.0D+00 do call chi_cdf ( x2, a, b, c, cdf2 ) if ( cdf < cdf2 ) then exit end if x2 = a + 2.0D+00 * ( x2 - a ) end do ! ! Now use bisection. ! it = 0 do it = it + 1 x3 = 0.5D+00 * ( x1 + x2 ) call chi_cdf ( x3, a, b, c, cdf3 ) if ( abs ( cdf3 - cdf ) < tol ) then x = x3 return end if if ( it_max < it ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHI_CDF_INV - Fatal error!' write ( *, '(a)' ) ' Iteration limit exceeded.' return end if if ( sign ( 1.0D+00, cdf3 - cdf ) == sign ( 1.0D+00, cdf1 - cdf ) ) then x1 = x3 cdf1 = cdf3 else x2 = x3 cdf2 = cdf3 end if end do return end function chi_check ( a, b, c ) !******************************************************************************* ! !! CHI_CHECK checks the parameters of the Chi CDF. ! ! Modified: ! ! 31 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, logical CHI_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c logical chi_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHI_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.0.' chi_check = .false. return end if if ( c <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHI_CHECK - Fatal error!' write ( *, '(a)' ) ' C <= 0.0.' chi_check = .false. return end if chi_check = .true. return end subroutine chi_mean ( a, b, c, mean ) !******************************************************************************* ! !! CHI_MEAN returns the mean of the Chi PDF. ! ! Modified: ! ! 31 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, real ( kind = 8 ) MEAN, the mean value. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) gamma real ( kind = 8 ) mean mean = a + sqrt ( 2.0D+00 ) * b * gamma ( 0.5D+00 * ( c + 1.0D+00 ) ) & / gamma ( 0.5D+00 * c ) return end subroutine chi_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! CHI_PDF evaluates the Chi PDF. ! ! Formula: ! ! PDF(A,B,C;X) = EXP ( - 0.5D+00 * ( ( X - A ) / B )**2 ) ! * ( ( X - A ) / B )**( C - 1 ) / ! ( 2**( 0.5D+00 * C - 1 ) * B * GAMMA ( 0.5D+00 * C ) ) ! ! Discussion: ! ! CHI(A,B,1) is the Half Normal PDF; ! CHI(0,B,2) is the Rayleigh PDF; ! CHI(0,B,3) is the Maxwell PDF. ! ! Modified: ! ! 31 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A <= X ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) gamma real ( kind = 8 ) pdf real ( kind = 8 ) x real ( kind = 8 ) y if ( x <= a ) then pdf = 0.0D+00 else y = ( x - a ) / b pdf = exp ( - 0.5D+00 * y * y ) * y**( c - 1.0D+00 ) / & ( 2.0D+00**( 0.5D+00 * c - 1.0D+00 ) * b * gamma ( 0.5D+00 * c ) ) end if return end subroutine chi_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! CHI_SAMPLE samples the Chi PDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c integer seed real ( kind = 8 ) x call chi_square_sample ( c, seed, x ) x = a + b * sqrt ( x ) return end subroutine chi_variance ( a, b, c, variance ) !******************************************************************************* ! !! CHI_VARIANCE returns the variance of the Chi PDF. ! ! ! Modified: ! ! 31 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0 < B, ! 0 < C. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) gamma real ( kind = 8 ) variance variance = b * b * ( c - 2.0D+00 * & ( gamma ( 0.5D+00 * ( c + 1.0D+00 ) ) / gamma ( 0.5D+00 * c ) )**2 ) return end subroutine chi_square_cdf ( x, a, cdf ) !******************************************************************************* ! !! CHI_SQUARE_CDF evaluates the Chi squared CDF. ! ! Modified: ! ! 10 October 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the value of the random deviate. ! ! Input, real ( kind = 8 ) A, the parameter of the distribution, usually ! the number of degrees of freedom. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a2 real ( kind = 8 ) b2 real ( kind = 8 ) c2 real ( kind = 8 ) cdf real ( kind = 8 ) x real ( kind = 8 ) x2 x2 = 0.5D+00 * x a2 = 0.0D+00 b2 = 1.0D+00 c2 = 0.5D+00 * a call gamma_cdf ( x2, a2, b2, c2, cdf ) return end subroutine chi_square_cdf_inv ( cdf, a, x ) !******************************************************************************* ! !! CHI_SQUARE_CDF_INV inverts the Chi squared PDF. ! ! Modified: ! ! 11 October 2004 ! ! Author: ! ! Best and Roberts ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Best and Roberts, ! The Percentage Points of the Chi-Squared Distribution, ! Algorithm AS 91, ! Applied Statistics, ! Volume 24, Number ?, pages 385-390, 1975. ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, a value of the chi-squared cumulative ! probability density function. ! 0.000002 <= CDF <= 0.999998. ! ! Input, real ( kind = 8 ) A, the parameter of the chi-squared ! probability density function. 0 < A. ! ! Output, real ( kind = 8 ) X, the value of the chi-squared random deviate ! with the property that the probability that a chi-squared random ! deviate with parameter A is less than or equal to X is CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a2 real ( kind = 8 ), parameter :: aa = 0.6931471806D+00 real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ), parameter :: c1 = 0.01D+00 real ( kind = 8 ), parameter :: c2 = 0.222222D+00 real ( kind = 8 ), parameter :: c3 = 0.32D+00 real ( kind = 8 ), parameter :: c4 = 0.4D+00 real ( kind = 8 ), parameter :: c5 = 1.24D+00 real ( kind = 8 ), parameter :: c6 = 2.2D+00 real ( kind = 8 ), parameter :: c7 = 4.67D+00 real ( kind = 8 ), parameter :: c8 = 6.66D+00 real ( kind = 8 ), parameter :: c9 = 6.73D+00 real ( kind = 8 ), parameter :: c10 = 13.32D+00 real ( kind = 8 ), parameter :: c11 = 60.0D+00 real ( kind = 8 ), parameter :: c12 = 70.0D+00 real ( kind = 8 ), parameter :: c13 = 84.0D+00 real ( kind = 8 ), parameter :: c14 = 105.0D+00 real ( kind = 8 ), parameter :: c15 = 120.0D+00 real ( kind = 8 ), parameter :: c16 = 127.0D+00 real ( kind = 8 ), parameter :: c17 = 140.0D+00 real ( kind = 8 ), parameter :: c18 = 175.0D+00 real ( kind = 8 ), parameter :: c19 = 210.0D+00 real ( kind = 8 ), parameter :: c20 = 252.0D+00 real ( kind = 8 ), parameter :: c21 = 264.0D+00 real ( kind = 8 ), parameter :: c22 = 294.0D+00 real ( kind = 8 ), parameter :: c23 = 346.0D+00 real ( kind = 8 ), parameter :: c24 = 420.0D+00 real ( kind = 8 ), parameter :: c25 = 462.0D+00 real ( kind = 8 ), parameter :: c26 = 606.0D+00 real ( kind = 8 ), parameter :: c27 = 672.0D+00 real ( kind = 8 ), parameter :: c28 = 707.0D+00 real ( kind = 8 ), parameter :: c29 = 735.0D+00 real ( kind = 8 ), parameter :: c30 = 889.0D+00 real ( kind = 8 ), parameter :: c31 = 932.0D+00 real ( kind = 8 ), parameter :: c32 = 966.0D+00 real ( kind = 8 ), parameter :: c33 = 1141.0D+00 real ( kind = 8 ), parameter :: c34 = 1182.0D+00 real ( kind = 8 ), parameter :: c35 = 1278.0D+00 real ( kind = 8 ), parameter :: c36 = 1740.0D+00 real ( kind = 8 ), parameter :: c37 = 2520.0D+00 real ( kind = 8 ), parameter :: c38 = 5040.0D+00 real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: cdf_max = 0.999998D+00 real ( kind = 8 ), parameter :: cdf_min = 0.000002D+00 real ( kind = 8 ) ch real ( kind = 8 ), parameter :: e = 0.0000005D+00 real ( kind = 8 ) g real ( kind = 8 ) gamma_inc real ( kind = 8 ) gamma_log integer i integer, parameter :: it_max = 20 real ( kind = 8 ) p1 real ( kind = 8 ) p2 real ( kind = 8 ) q real ( kind = 8 ) s1 real ( kind = 8 ) s2 real ( kind = 8 ) s3 real ( kind = 8 ) s4 real ( kind = 8 ) s5 real ( kind = 8 ) s6 real ( kind = 8 ) t real ( kind = 8 ) x real ( kind = 8 ) x2 real ( kind = 8 ) xx if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHI_SQUARE_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' write ( *, '(a,g14.6)' ) ' CDF = ', cdf stop end if if ( cdf < cdf_min ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHI_SQUARE_CDF_INV - Warning!' write ( *, '(a)' ) ' CDF < CDF_MIN.' write ( *, '(a,g14.6)' ) ' CDF = ', cdf write ( *, '(a,g14.6)' ) ' CDF_MIN = ', cdf_min end if if ( cdf_max < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHI_SQUARE_CDF_INV - Warning!' write ( *, '(a)' ) ' CDF_MAX < CDF.' write ( *, '(a,g14.6)' ) ' CDF = ', cdf write ( *, '(a,g14.6)' ) ' CDF_MAX = ', cdf_max end if xx = 0.5D+00 * a c = xx - 1.0D+00 ! ! Compute Log ( Gamma ( A/2 ) ). ! g = gamma_log ( a / 2.0D+00 ) ! ! Starting approximation for small chi-squared. ! if ( a < - c5 * log ( cdf ) ) then ch = ( cdf * xx * exp ( g + xx * aa ) )**( 1.0D+00 / xx ) if ( ch < e ) then x = ch return end if ! ! Starting approximation for A less than or equal to 0.32. ! else if ( a <= c3 ) then ch = c4 a2 = log ( 1.0D+00 - cdf ) do q = ch p1 = 1.0D+00 + ch * ( c7 + ch ) p2 = ch * ( c9 + ch * ( c8 + ch ) ) t = - 0.5D+00 + ( c7 + 2.0D+00 * ch ) / p1 & - ( c9 + ch * ( c10 + 3.0D+00 * ch ) ) / p2 ch = ch - ( 1.0D+00 - exp ( a2 + g + 0.5D+00 * ch + c * aa ) & * p2 / p1 ) / t if ( abs ( q / ch - 1.0D+00 ) <= c1 ) then exit end if end do ! ! Call to algorithm AS 111. ! Note that P has been tested above. ! AS 241 could be used as an alternative. ! else call normal_01_cdf_inv ( cdf, x2 ) ! ! Starting approximation using Wilson and Hilferty estimate. ! p1 = c2 / a ch = a * ( x2 * sqrt ( p1 ) + 1.0D+00 - p1 )**3 ! ! Starting approximation for P tending to 1. ! if ( c6 * a + 6.0D+00 < ch ) then ch = - 2.0D+00 * ( log ( 1.0D+00 - cdf ) - c * log ( 0.5D+00 * ch ) + g ) end if end if ! ! Call to algorithm AS 239 and calculation of seven term Taylor series. ! do i = 1, it_max q = ch p1 = 0.5D+00 * ch p2 = cdf - gamma_inc ( xx, p1 ) t = p2 * exp ( xx * aa + g + p1 - c * log ( ch ) ) b = t / ch a2 = 0.5D+00 * t - b * c s1 = ( c19 + a2 & * ( c17 + a2 & * ( c14 + a2 & * ( c13 + a2 & * ( c12 + a2 & * c11 ) ) ) ) ) / c24 s2 = ( c24 + a2 & * ( c29 + a2 & * ( c32 + a2 & * ( c33 + a2 & * c35 ) ) ) ) / c37 s3 = ( c19 + a2 & * ( c25 + a2 & * ( c28 + a2 & * c31 ) ) ) / c37 s4 = ( c20 + a2 & * ( c27 + a2 & * c34 ) + c & * ( c22 + a2 & * ( c30 + a2 & * c36 ) ) ) / c38 s5 = ( c13 + c21 * a2 + c * ( c18 + c26 * a2 ) ) / c37 s6 = ( c15 + c * ( c23 + c16 * c ) ) / c38 ch = ch + t * ( 1.0D+00 + 0.5D+00 * t * s1 - b * c & * ( s1 - b & * ( s2 - b & * ( s3 - b & * ( s4 - b & * ( s5 - b & * s6 ) ) ) ) ) ) if ( e < abs ( q / ch - 1.0D+00 ) ) then x = ch return end if end do x = ch write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHI_SQUARE_CDF_INV - Warning!' write ( *, '(a)' ) ' Convergence not reached.' return end subroutine chi_square_cdf_values ( n_data, a, x, fx ) !******************************************************************************* ! !! CHI_SQUARE_CDF_VALUES returns some values of the Chi-Square CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = ChiSquareDistribution [ df ] ! CDF [ dist, x ] ! ! Modified: ! ! 09 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer A, the parameter of the function. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 21 integer a integer, save, dimension ( n_max ) :: a_vec = (/ & 1, 2, 1, 2, & 1, 2, 3, 4, & 1, 2, 3, 4, & 5, 3, 3, 3, & 3, 3, 10, 10, & 10 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.7965567455405796D-01, & 0.4987520807317687D-02, & 0.1124629160182849D+00, & 0.9950166250831946D-02, & 0.4729107431344619D+00, & 0.1812692469220181D+00, & 0.5975750516063926D-01, & 0.1752309630642177D-01, & 0.6826894921370859D+00, & 0.3934693402873666D+00, & 0.1987480430987992D+00, & 0.9020401043104986D-01, & 0.3743422675270363D-01, & 0.4275932955291202D+00, & 0.6083748237289110D+00, & 0.7385358700508894D+00, & 0.8282028557032669D+00, & 0.8883897749052874D+00, & 0.1721156299558408D-03, & 0.3659846827343712D-02, & 0.1857593622214067D-01 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.01D+00, & 0.01D+00, & 0.02D+00, & 0.02D+00, & 0.40D+00, & 0.40D+00, & 0.40D+00, & 0.40D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 2.00D+00, & 3.00D+00, & 4.00D+00, & 5.00D+00, & 6.00D+00, & 1.00D+00, & 2.00D+00, & 3.00D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 a = 0 x = 0.0D+00 fx = 0.0D+00 else a = a_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function chi_square_check ( a ) !******************************************************************************* ! !! CHI_SQUARE_CHECK checks the parameter of the central Chi squared PDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the distribution. ! 1 <= A. ! ! Output, logical CHI_SQUARE_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a logical chi_square_check if ( a < 1.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHI_SQUARE_CHECK - Fatal error!' write ( *, '(a)' ) ' A < 1.0.' chi_square_check = .false. return end if chi_square_check = .true. return end subroutine chi_square_mean ( a, mean ) !******************************************************************************* ! !! CHI_SQUARE_MEAN returns the mean of the central Chi squared PDF. ! ! Modified: ! ! 30 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the distribution. ! 1 <= A. ! ! Output, real ( kind = 8 ) MEAN, the mean value. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) mean mean = a return end subroutine chi_square_pdf ( x, a, pdf ) !******************************************************************************* ! !! CHI_SQUARE_PDF evaluates the central Chi squared PDF. ! ! Formula: ! ! PDF(A;X) = ! EXP ( - X / 2 ) * X**((A-2)/2) / ( 2**(A/2) * GAMMA ( A/2 ) ) ! ! Modified: ! ! 30 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 1 <= A. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) gamma real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x < 0.0D+00 ) then pdf = 0.0D+00 else b = a / 2.0D+00 pdf = exp ( - 0.5D+00 * x ) * x**( b - 1.0D+00 ) & / ( 2.0D+00**b * gamma ( b ) ) end if return end subroutine chi_square_sample ( a, seed, x ) !******************************************************************************* ! !! CHI_SQUARE_SAMPLE samples the central Chi squared PDF. ! ! Modified: ! ! 30 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 1 <= A. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a2 real ( kind = 8 ) b2 real ( kind = 8 ) c2 integer i integer, parameter :: it_max = 100 integer n integer seed real ( kind = 8 ) x real ( kind = 8 ) x2 n = int ( a ) if ( real ( n, kind = 8 ) == a .and. n <= it_max ) then x = 0.0D+00 do i = 1, n call normal_01_sample ( seed, x2 ) x = x + x2 * x2 end do else a2 = 0.0D+00 b2 = 1.0D+00 c2 = a / 2.0D+00 call gamma_sample ( a2, b2, c2, seed, x ) x = 2.0D+00 * x end if return end subroutine chi_square_variance ( a, variance ) !******************************************************************************* ! !! CHI_SQUARE_VARIANCE returns the variance of the central Chi squared PDF. ! ! Modified: ! ! 10 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the distribution. ! 1 <= A. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) variance variance = 2.0D+00 * a return end function chi_square_noncentral_check ( a, b ) !******************************************************************************* ! !! CHI_SQUARE_NONCENTRAL_CHECK checks the parameters of the noncentral Chi Squared PDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the parameter of the PDF. ! 1.0D+00 <= A. ! ! Input, real ( kind = 8 ) B, the noncentrality parameter of the PDF. ! 0.0D+00 <= B. ! ! Output, logical CHI_SQUARE_NONCENTRAL_CHECK, is true if the parameters ! are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical chi_square_noncentral_check if ( a < 1.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHI_SQUARE_NONCENTRAL_CHECK - Fatal error!' write ( *, '(a)' ) ' A < 1.' chi_square_noncentral_check = .false. return end if if ( b < 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHI_SQUARE_NONCENTRAL_CHECK - Fatal error!' write ( *, '(a)' ) ' B < 0.' chi_square_noncentral_check = .false. return end if chi_square_noncentral_check = .true. return end subroutine chi_square_noncentral_cdf_values ( n_data, df, lambda, x, cdf ) !******************************************************************************* ! !! CHI_SQUARE_NONCENTRAL_CDF_VALUES returns values of the noncentral chi CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = NoncentralChiSquareDistribution [ df, lambda ] ! CDF [ dist, x ] ! ! Modified: ! ! 30 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer DF, the number of degrees of freedom. ! ! Output, real ( kind = 8 ) LAMBDA, the noncentrality parameter. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) CDF, the noncentral chi CDF. ! implicit none integer, parameter :: n_max = 28 real ( kind = 8 ) cdf real ( kind = 8 ), save, dimension ( n_max ) :: cdf_vec = (/ & 0.8399444269398261D+00, & 0.6959060300435139D+00, & 0.5350879697078847D+00, & 0.7647841496310313D+00, & 0.6206436532195436D+00, & 0.4691667375373180D+00, & 0.3070884345937569D+00, & 0.2203818092990903D+00, & 0.1500251895581519D+00, & 0.3071163194335791D-02, & 0.1763982670131894D-02, & 0.9816792594625022D-03, & 0.1651753140866208D-01, & 0.2023419573950451D-03, & 0.4984476352854074D-06, & 0.1513252400654827D-01, & 0.2090414910614367D-02, & 0.2465021206048452D-03, & 0.2636835050342939D-01, & 0.1857983220079215D-01, & 0.1305736595486640D-01, & 0.5838039534819351D-01, & 0.4249784402463712D-01, & 0.3082137716021596D-01, & 0.1057878223400849D+00, & 0.7940842984598509D-01, & 0.5932010895599639D-01, & 0.2110395656918684D+00 /) integer df integer, save, dimension ( n_max ) :: df_vec = (/ & 1, 2, 3, & 1, 2, 3, & 1, 2, 3, & 1, 2, 3, & 60, 80, 100, & 1, 2, 3, & 10, 10, 10, & 10, 10, 10, & 10, 10, 10, & 8 /) real ( kind = 8 ) lambda real ( kind = 8 ), save, dimension ( n_max ) :: lambda_vec = (/ & 0.5D+00, & 0.5D+00, & 0.5D+00, & 1.0D+00, & 1.0D+00, & 1.0D+00, & 5.0D+00, & 5.0D+00, & 5.0D+00, & 20.0D+00, & 20.0D+00, & 20.0D+00, & 30.0D+00, & 30.0D+00, & 30.0D+00, & 5.0D+00, & 5.0D+00, & 5.0D+00, & 2.0D+00, & 3.0D+00, & 4.0D+00, & 2.0D+00, & 3.0D+00, & 4.0D+00, & 2.0D+00, & 3.0D+00, & 4.0D+00, & 0.5D+00 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 3.000D+00, & 3.000D+00, & 3.000D+00, & 3.000D+00, & 3.000D+00, & 3.000D+00, & 3.000D+00, & 3.000D+00, & 3.000D+00, & 3.000D+00, & 3.000D+00, & 3.000D+00, & 60.000D+00, & 60.000D+00, & 60.000D+00, & 0.050D+00, & 0.050D+00, & 0.050D+00, & 4.000D+00, & 4.000D+00, & 4.000D+00, & 5.000D+00, & 5.000D+00, & 5.000D+00, & 6.000D+00, & 6.000D+00, & 6.000D+00, & 5.000D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 lambda = 0.0D+00 df = 0 cdf = 0.0D+00 else x = x_vec(n_data) lambda = lambda_vec(n_data) df = df_vec(n_data) cdf = cdf_vec(n_data) end if return end subroutine chi_square_noncentral_mean ( a, b, mean ) !******************************************************************************* ! !! CHI_SQUARE_NONCENTRAL_MEAN returns the mean of the noncentral Chi squared PDF. ! ! Modified: ! ! 30 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the parameter of the PDF. ! 1.0D+00 <= A. ! ! Input, real ( kind = 8 ) B, the noncentrality parameter of the PDF. ! 0.0D+00 <= B. ! ! Output, real ( kind = 8 ) MEAN, the mean value. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a + b return end subroutine chi_square_noncentral_sample ( a, b, seed, x ) !******************************************************************************* ! !! CHI_SQUARE_NONCENTRAL_SAMPLE samples the noncentral Chi squared PDF. ! ! Modified: ! ! 30 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the parameter of the PDF. ! 1.0D+00 <= A. ! ! Input, real ( kind = 8 ) B, the noncentrality parameter of the PDF. ! 0.0D+00 <= B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a1 real ( kind = 8 ) a2 real ( kind = 8 ) b real ( kind = 8 ) b2 integer seed real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 a1 = a - 1.0D+00 call chi_square_sample ( a1, seed, x1 ) a2 = sqrt ( b ) b2 = 1.0D+00 call normal_sample ( a2, b2, seed, x2 ) x = x1 + x2 * x2 return end subroutine chi_square_noncentral_variance ( a, b, variance ) !******************************************************************************* ! !! CHI_SQUARE_NONCENTRAL_VARIANCE returns the variance of the noncentral Chi squared PDF. ! ! Modified: ! ! 30 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 1 <= A. ! ! Input, real ( kind = 8 ) B, the noncentrality parameter of the PDF. ! 0.0D+00 <= B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance value. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = 2.0D+00 * ( a + 2.0D+00 * b ) return end subroutine circle_sample ( a, b, c, seed, x1, x2 ) !******************************************************************************* ! !! CIRCLE_SAMPLE samples points from a circle. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the circle. ! The circle is centered at (A,B) and has radius C. ! 0.0D+00 < C. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X1, X2, a sampled point of the circle. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) angle real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) d_uniform_01 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) radius_frac integer seed real ( kind = 8 ) x1 real ( kind = 8 ) x2 radius_frac = d_uniform_01 ( seed ) radius_frac = sqrt ( radius_frac ) angle = 2.0D+00 * pi * d_uniform_01 ( seed ) x1 = a + c * radius_frac * cos ( angle ) x2 = b + c * radius_frac * sin ( angle ) return end subroutine circular_normal_01_mean ( mean ) !******************************************************************************* ! !! CIRCULAR_NORMAL_01_MEAN returns the mean of the Circular Normal 01 PDF. ! ! Modified: ! ! 13 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) MEAN(2), the mean of the PDF. ! implicit none real ( kind = 8 ) mean(2) mean(1:2) = 0.0D+00 return end subroutine circular_normal_01_pdf ( x, pdf ) !******************************************************************************* ! !! CIRCULAR_NORMAL_01_PDF evaluates the Circular Normal 01 PDF. ! ! Formula: ! ! PDF(X) = EXP ( - 0.5D+00 * ( X(1)**2 + X(2)**2 ) ) / ( 2 * PI ) ! ! Modified: ! ! 13 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X(2), the argument of the PDF. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x(2) pdf = exp ( - 0.5D+00 * ( x(1)**2 + x(2)**2 ) ) / ( 2.0D+00 * pi ) return end subroutine circular_normal_01_sample ( seed, x ) !******************************************************************************* ! !! CIRCULAR_NORMAL_01_SAMPLE samples the Circular Normal 01 PDF. ! ! Modified: ! ! 13 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X(2), a sample of the PDF. ! implicit none real ( kind = 8 ) d_uniform_01 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 integer seed real ( kind = 8 ) v1 real ( kind = 8 ) v2 real ( kind = 8 ) x(2) v1 = d_uniform_01 ( seed ) v2 = d_uniform_01 ( seed ) x(1) = sqrt ( - 2.0D+00 * log ( v1 ) ) * cos ( 2.0D+00 * pi * v2 ) x(2) = sqrt ( - 2.0D+00 * log ( v1 ) ) * sin ( 2.0D+00 * pi * v2 ) return end subroutine circular_normal_01_variance ( variance ) !******************************************************************************* ! !! CIRCULAR_NORMAL_01_VARIANCE returns the variance of the Circular Normal 01 PDF. ! ! Modified: ! ! 13 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) VARIANCE(2), the variance of the PDF. ! implicit none real ( kind = 8 ) variance(2) variance(1) = 1.0D+00 variance(2) = 1.0D+00 return end subroutine cosine_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! COSINE_CDF evaluates the Cosine CDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameter of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) y if ( x <= a - pi * b ) then cdf = 0.0D+00 else if ( x <= a + pi * b ) then y = ( x - a ) / b cdf = 0.5D+00 + ( y + sin ( y ) ) / ( 2.0D+00 * pi ) else if ( a + pi * b < x ) then cdf = 1.0D+00 end if return end subroutine cosine_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! COSINE_CDF_INV inverts the Cosine CDF. ! ! Discussion: ! ! A simple bisection method is used on the interval ! [ A - PI * B, A + PI * B ]. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cdf1 real ( kind = 8 ) cdf2 real ( kind = 8 ) cdf3 integer it integer, parameter :: it_max = 100 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ), parameter :: tol = 0.0001D+00 real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 real ( kind = 8 ) x3 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COSINE_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = a - pi * b return else if ( 1.0D+00 == cdf ) then x = a + pi * b return end if x1 = a - pi * b cdf1 = 0.0D+00 x2 = a + pi * b cdf2 = 1.0D+00 ! ! Now use bisection. ! it = 0 do it = 1, it_max x3 = 0.5D+00 * ( x1 + x2 ) call cosine_cdf ( x3, a, b, cdf3 ) if ( abs ( cdf3 - cdf ) < tol ) then x = x3 return end if if ( sign ( 1.0D+00, cdf3 - cdf ) == sign ( 1.0D+00, cdf1 - cdf ) ) then x1 = x3 cdf1 = cdf3 else x2 = x3 cdf2 = cdf3 end if end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COSINE_CDF_INV - Fatal error!' write ( *, '(a)' ) ' Iteration limit exceeded.' stop end function cosine_check ( a, b ) !******************************************************************************* ! !! COSINE_CHECK checks the parameters of the Cosine CDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameter of the PDF. ! 0.0D+00 < B. ! ! Output, logical COSINE_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical cosine_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COSINE_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.0' cosine_check = .false. return end if cosine_check = .true. return end subroutine cosine_mean ( a, b, mean ) !******************************************************************************* ! !! COSINE_MEAN returns the mean of the Cosine PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a return end subroutine cosine_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! COSINE_PDF evaluates the Cosine PDF. ! ! Discussion: ! ! The cosine PDF can be thought of as being applied to points on ! a circle. ! ! Formula: ! ! PDF(A,B;X) = ( 1 / ( 2 * PI * B ) ) * COS ( ( X - A ) / B ) ! for A - PI * B <= X <= A + PI * B ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) y if ( x < a - pi * b ) then pdf = 0.0D+00 else if ( x <= a + pi * b ) then y = ( x - a ) / b pdf = 1.0D+00 / ( 2.0D+00 * pi * b ) * cos ( y ) else if ( a + pi * b < x ) then pdf = 0.0D+00 end if return end subroutine cosine_sample ( a, b, seed, x ) !******************************************************************************* ! !! COSINE_SAMPLE samples the Cosine PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call cosine_cdf_inv ( cdf, a, b, x ) return end subroutine cosine_variance ( a, b, variance ) !******************************************************************************* ! !! COSINE_VARIANCE returns the variance of the Cosine PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) variance variance = ( pi * pi / 3.0D+00 - 2.0D+00 ) * b * b return end subroutine coupon_mean ( j, n, mean ) !******************************************************************************* ! !! COUPON_MEAN returns the mean of the Coupon PDF. ! ! Modified: ! ! 14 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer J, the number of distinct coupons to be collected. ! J must be between 1 and N. ! ! Input, integer N, the number of distinct coupons. ! ! Output, real ( kind = 8 ) MEAN, the mean number of coupons that ! must be collected in order to just get J distinct kinds. ! implicit none integer i integer j integer n real ( kind = 8 ) mean if ( n < j ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COUPON_MEAN - Fatal error!' write ( *, '(a)' ) ' Number of distinct coupons desired must be no more' write ( *, '(a)' ) ' than the total number of distinct coupons.' stop end if mean = 0.0D+00 do i = 1, j mean = mean + 1.0D+00 / real ( n - i + 1, kind = 8 ) end do mean = mean * real ( n, kind = 8 ) return end subroutine coupon_simulate ( n_type, seed, coupon, n_coupon ) !******************************************************************************* ! !! COUPON_SIMULATE simulates the coupon collector's problem. ! ! Discussion: ! ! The coupon collector needs to collect one of each of N_TYPE ! coupons. The collector may draw one coupon on each trial, ! and takes as many trials as necessary to complete the task. ! On each trial, the probability of picking any particular type ! of coupon is always 1 / N_TYPE. ! ! The most interesting question is, what is the expected number ! of drawings necessary to complete the collection? ! how does this number vary as N_TYPE increases? What is the ! distribution of the numbers of each type of coupon in a typical ! collection when it is just completed? ! ! As N increases, the number of coupons necessary to be ! collected in order to get a complete set in any simulation ! strongly tends to the value N_TYPE * LOG ( N_TYPE ). ! ! If N_TYPE is 1, the simulation ends with a single drawing. ! ! If N_TYPE is 2, then we may call the coupon taken on the first drawing ! a "Head", say, and the process then is similar to the question of the ! length, plus one, of a run of Heads or Tails in coin flipping. ! ! Modified: ! ! 13 May 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N_TYPE, the number of types of coupons. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer COUPON(N_TYPE), the number of coupons of each type ! that were collected during the simulation. ! ! Output, integer N_COUPON, the total number of coupons collected. ! implicit none integer n_type integer coupon(n_type) integer i integer i_uniform integer, parameter :: max_coupon = 2000 integer n_coupon integer seed integer straight coupon(1:n_type) = 0 straight = 0 n_coupon = 0 ! ! Draw another coupon. ! do while ( n_coupon < max_coupon ) i = i_uniform ( 1, n_type, seed ) ! ! Increment the number of I coupons. ! coupon(i) = coupon(i) + 1 n_coupon = n_coupon + 1 ! ! If I is the next one we needed, increase STRAIGHT by 1. ! if ( i == straight + 1 ) then do straight = straight + 1 ! ! If STRAIGHT = N_TYPE, we have all of them. ! if ( n_type <= straight ) then return end if ! ! If the next coupon has not been collected, our straight is over. ! if ( coupon(straight+1) <= 0 ) then exit end if end do end if end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COUPON_SIMULATE - Fatal error!' write ( *, '(a)' ) ' Maximum number of coupons drawn without success.' stop end subroutine coupon_variance ( j, n, variance ) !******************************************************************************* ! !! COUPON_VARIANCE returns the variance of the Coupon PDF. ! ! Modified: ! ! 14 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer J, the number of distinct coupons to be collected. ! J must be between 1 and N. ! ! Input, integer N, the number of distinct coupons. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the number of ! coupons that must be collected in order to just get J distinct kinds. ! implicit none integer i integer j integer n real ( kind = 8 ) variance if ( n < j ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COUPON_VARIANCE - Fatal error!' write ( *, '(a)' ) ' Number of distinct coupons desired must be no more' write ( *, '(a)' ) ' than the total number of distinct coupons.' stop end if variance = 0.0D+00 do i = 1, j variance = variance + real ( i - 1, kind = 8 ) & / real ( n - i + 1, kind = 8 )**2 end do variance = variance * real ( n, kind = 8 ) return end function csc ( theta ) !******************************************************************************* ! !! CSC returns the cosecant of X. ! ! Definition: ! ! CSC ( THETA ) = 1.0D+00 / SIN ( THETA ) ! ! Discussion: ! ! CSC is not a built-in function in FORTRAN, and occasionally it ! is handier, or more concise, to be able to refer to it directly ! rather than through its definition in terms of the sine function. ! ! Modified: ! ! 01 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) THETA, the angle, in radians, whose ! cosecant is desired. It must be the case that SIN ( THETA ) is not zero. ! ! Output, real ( kind = 8 ) CSC, the cosecant of THETA. ! implicit none real ( kind = 8 ) csc real ( kind = 8 ) theta csc = sin ( theta ) if ( csc == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CSC - Fatal error!' write ( *, '(a,g14.6)' ) ' CSC undefined for THETA = ', theta stop end if csc = 1.0D+00 / csc return end function d_ceiling ( r ) !******************************************************************************* ! !! D_CEILING rounds a real value "up" to the nearest integer. ! ! Examples: ! ! R Value ! ! -1.1 -1 ! -1.0 -1 ! -0.9 0 ! 0.0 0 ! 5.0 5 ! 5.1 6 ! 5.9 6 ! 6.0 6 ! ! Modified: ! ! 07 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) R, the real value to be rounded up. ! ! Output, integer D_CEILING, the rounded value. ! implicit none integer d_ceiling real ( kind = 8 ) r integer value value = int ( r ) if ( real ( value, kind = 8 ) < r ) then value = value + 1 end if d_ceiling = value return end function d_is_int ( r ) !******************************************************************************* ! !! D_IS_INT determines if a double precision number represents an integer value. ! ! Modified: ! ! 07 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) R, the number to be checked. ! ! Output, logical D_IS_INT, is TRUE if R is an integer value. ! implicit none integer i real ( kind = 8 ) r logical d_is_int if ( real ( huge ( i ), kind = 8 ) < r ) then d_is_int = .false. else if ( r < - real ( huge ( i ) , kind = 8 ) ) then d_is_int = .false. else if ( r == real ( int ( r ), kind = 8 ) ) then d_is_int = .true. else d_is_int = .false. end if return end function d_pi ( ) !******************************************************************************* ! !! D_PI returns the value of pi to 16 decimal places. ! ! Modified: ! ! 19 December 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision D_PI, the value of pi. ! implicit none double precision d_pi d_pi = 3.141592653589793D+00 return end function d_uniform ( a, b, seed ) !******************************************************************************* ! !! D_UNIFORM returns a scaled double precision pseudorandom number. ! ! Discussion: ! ! The pseudorandom number should be uniformly distributed ! between A and B. ! ! Modified: ! ! 29 January 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the limits of the interval. ! ! Input/output, integer SEED, the "seed" value, which should NOT be 0. ! On output, SEED has been updated. ! ! Output, real ( kind = 8 ) D_UNIFORM, a number strictly between A and B. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer k integer seed real ( kind = 8 ) d_uniform k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if ! ! Although SEED can be represented exactly as a 32 bit integer, ! it generally cannot be represented exactly as a 32 bit real number! ! d_uniform = a + ( b - a ) * real ( seed, kind = 8 ) * 4.656612875D-10 return end function d_uniform_01 ( seed ) !******************************************************************************* ! !! D_UNIFORM_01 is a portable pseudorandom number generator. ! ! Discussion: ! ! This routine implements the recursion ! ! seed = 16807 * seed mod ( 2**31 - 1 ) ! unif = seed / ( 2**31 - 1 ) ! ! The integer arithmetic never requires more than 32 bits, ! including a sign bit. ! ! Modified: ! ! 11 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, L E Schrage, ! A Guide to Simulation, ! Springer Verlag, pages 201-202, 1983. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, pages 362-376, 1986. ! ! Parameters: ! ! Input/output, integer SEED, the "seed" value, which should NOT be 0. ! (Otherwise, the output values of SEED and UNIFORM will be zero.) ! On output, SEED has been updated. ! ! Output, real ( kind = 8 ) D_UNIFORM_01, a new pseudorandom variate, ! strictly between 0 and 1. ! implicit none integer k integer seed real ( kind = 8 ) d_uniform_01 k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if ! ! Although SEED can be represented exactly as a 32 bit integer, ! it generally cannot be represented exactly as a 32 bit real number! ! d_uniform_01 = real ( seed, kind = 8 ) * 4.656612875E-10 return end subroutine deranged_cdf ( x, a, cdf ) !******************************************************************************* ! !! DERANGED_CDF evaluates the Deranged CDF. ! ! Modified: ! ! 06 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the maximum number of items in their correct places. ! 0 <= X <= A. ! ! Input, integer A, the number of items. ! 1 <= A. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none integer a real ( kind = 8 ) cdf integer cnk integer deranged_enum integer dnmk real ( kind = 8 ) i_factorial integer sum2 integer x integer x2 if ( x < 0 .or. a < x ) then cdf = 0.0D+00 else sum2 = 0 do x2 = 0, x call binomial_coef ( a, x2, cnk ) dnmk = deranged_enum ( a-x2 ) sum2 = sum2 + cnk * dnmk end do cdf = real ( sum2, kind = 8 ) / i_factorial ( a ) end if return end subroutine deranged_cdf_inv ( cdf, a, x ) !******************************************************************************* ! !! DERANGED_CDF_INV inverts the Deranged CDF. ! ! Modified: ! ! 06 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, integer A, the number of items. ! 1 <= A. ! ! Output, integer X, the corresponding argument. ! implicit none integer a real ( kind = 8 ) cdf real ( kind = 8 ) cdf2 real ( kind = 8 ) pdf integer x integer x2 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DERANGED_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if cdf2 = 0.0D+00 do x2 = 0, a call deranged_pdf ( x2, a, pdf ) cdf2 = cdf2 + pdf if ( cdf <= cdf2 ) then x = x2 return end if end do x = a return end function deranged_check ( a ) !******************************************************************************* ! !! DERANGED_CHECK checks the parameter of the Deranged PDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the total number of items. ! 1 <= A. ! ! Output, logical DERANGED_CHECK, is true if the parameters are legal. ! implicit none integer a logical deranged_check if ( a < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DERANGED_CHECK - Fatal error!' write ( *, '(a)' ) ' A < 1.' deranged_check = .false. return end if deranged_check = .true. return end function deranged_enum ( n ) !******************************************************************************* ! !! DERANGED_ENUM returns the number of derangements of N objects. ! ! Definition: ! ! A derangement of N objects is a permutation with no fixed ! points. If we symbolize the permutation operation by "P", ! then for a derangment, P(I) is never equal to I. ! ! Recursion: ! ! D(0) = 1 ! D(1) = 0 ! D(2) = 1 ! D(N) = (N-1) * ( D(N-1) + D(N-2) ) ! ! or ! ! D(0) = 1 ! D(1) = 0 ! D(N) = N * D(N-1) + (-1)**N ! ! Formula: ! ! D(N) = N! * ( 1 - 1/1! + 1/2! - 1/3! ... 1/N! ) ! ! Based on the inclusion/exclusion law. ! ! Comments: ! ! D(N) is the number of ways of placing N non-attacking rooks on ! an N by N chessboard with one diagonal deleted. ! ! Limit ( N -> Infinity ) D(N)/N! = 1 / e. ! ! The number of permutations with exactly K items in the right ! place is COMB(N,K) * D(N-K). ! ! First values: ! ! N D(N) ! 0 1 ! 1 0 ! 2 1 ! 3 2 ! 4 9 ! 5 44 ! 6 265 ! 7 1854 ! 8 14833 ! 9 133496 ! 10 1334961 ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects to be permuted. ! ! Output, integer DERANGED_ENUM, the number of derangements of N objects. ! implicit none integer deranged_enum integer dn integer dnm1 integer dnm2 integer i integer n if ( n < 0 ) then dn = 0 else if ( n == 0 ) then dn = 1 else if ( n == 1 ) then dn = 0 else if ( n == 2 ) then dn = 1 else dnm1 = 0 dn = 1 do i = 3, n dnm2 = dnm1 dnm1 = dn dn = ( i - 1 ) * ( dnm1 + dnm2 ) end do end if deranged_enum = dn return end subroutine deranged_mean ( a, mean ) !******************************************************************************* ! !! DERANGED_MEAN returns the mean of the Deranged CDF. ! ! Discussion: ! ! The mean is computed by straightforward summation. ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of items. ! 1 <= A. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none integer a real ( kind = 8 ) mean real ( kind = 8 ) pdf integer x mean = 0.0D+00 do x = 1, a call deranged_pdf ( x, a, pdf ) mean = mean + pdf * x end do return end subroutine deranged_pdf ( x, a, pdf ) !******************************************************************************* ! !! DERANGED_PDF evaluates the Deranged PDF. ! ! Definition: ! ! PDF(A;X) is the probability that exactly X items will occur in ! their proper place after a random permutation of A items. ! ! Modified: ! ! 06 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the number of items in their correct places. ! 0 <= X <= A. ! ! Input, integer A, the total number of items. ! 1 <= A. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none integer a integer cnk integer deranged_enum integer dnmk real ( kind = 8 ) i_factorial real ( kind = 8 ) pdf integer x if ( x < 0 .or. a < x ) then pdf = 0.0D+00 else call binomial_coef ( a, x, cnk ) dnmk = deranged_enum ( a-x ) pdf = real ( cnk * dnmk, kind = 8 ) / i_factorial ( a ) end if return end subroutine deranged_sample ( a, seed, x ) !******************************************************************************* ! !! DERANGED_SAMPLE samples the Deranged PDF. ! ! Modified: ! ! 06 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of items. ! 1 <= A. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none integer a real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed integer x cdf = d_uniform_01 ( seed ) call deranged_cdf_inv ( cdf, a, x ) return end subroutine deranged_variance ( a, variance ) !******************************************************************************* ! !! DERANGED_VARIANCE returns the variance of the Deranged CDF. ! ! Discussion: ! ! The variance is computed by straightforward summation. ! ! Modified: ! ! 06 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of items. ! 1 <= A. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none integer a real ( kind = 8 ) mean real ( kind = 8 ) pdf integer x real ( kind = 8 ) variance call deranged_mean ( a, mean ) variance = 0.0D+00 do x = 1, a call deranged_pdf ( x, a, pdf ) variance = variance + pdf * ( x - mean )**2 end do return end function digamma ( x ) !******************************************************************************* ! !! DIGAMMA calculates the digamma or Psi function. ! ! Discussion: ! ! DiGamma ( X ) = d ( log ( Gamma ( X ) ) ) / dX ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! J Bernardo ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! J Bernardo, ! Psi ( Digamma ) Function, ! Algorithm AS 103, ! Applied Statistics, ! Volume 25, Number 3, pages 315-317, 1976. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the digamma function. ! 0 < X. ! ! Output, real ( kind = 8 ) DIGAMMA, the value of the digamma function at X. ! implicit none real ( kind = 8 ), parameter :: c = 8.5D+00 real ( kind = 8 ), parameter :: d1 = -0.5772156649D+00 real ( kind = 8 ) digamma real ( kind = 8 ) r real ( kind = 8 ), parameter :: s = 0.00001D+00 real ( kind = 8 ), parameter :: s3 = 0.08333333333D+00 real ( kind = 8 ), parameter :: s4 = 0.0083333333333D+00 real ( kind = 8 ), parameter :: s5 = 0.003968253968D+00 real ( kind = 8 ) x real ( kind = 8 ) y ! ! The argument must be positive. ! if ( x <= 0.0D+00 ) then digamma = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGAMMA - Fatal error!' write ( *, '(a)' ) ' X <= 0.' stop ! ! Use approximation if argument <= S. ! else if ( x <= s ) then digamma = d1 - 1.0D+00 / x ! ! Reduce the argument to DIGAMMA(X + N) where C <= (X + N). ! else digamma = 0.0D+00 y = x do while ( y < c ) digamma = digamma - 1.0D+00 / y y = y + 1.0D+00 end do ! ! Use Stirling's (actually de Moivre's) expansion if C < argument. ! r = 1.0D+00 / ( y * y ) digamma = digamma + log ( y ) - 0.5D+00 / y & - r * ( s3 - r * ( s4 - r * s5 ) ) end if return end subroutine dipole_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! DIPOLE_CDF evaluates the Dipole CDF. ! ! Modified: ! ! 28 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A is arbitrary, but represents an angle, so only 0 <= A <= 2 * PI ! is interesting, and -1.0D+00 <= B <= 1.0. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x cdf = 0.5D+00 + ( 1.0D+00 / pi ) * atan ( x ) & + b * b * ( x * cos ( 2.0D+00 * a ) & - sin ( 2.0D+00 * a ) ) / ( pi * ( 1.0D+00 + x * x ) ) return end subroutine dipole_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! DIPOLE_CDF_INV inverts the Dipole CDF. ! ! Discussion: ! ! A simple bisection method is used. ! ! Modified: ! ! 04 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -1.0D+00 <= B <= 1.0. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cdf1 real ( kind = 8 ) cdf2 real ( kind = 8 ) cdf3 integer it integer, parameter :: it_max = 100 real ( kind = 8 ), parameter :: tol = 0.0001D+00 real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 real ( kind = 8 ) x3 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIPOLE_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = - huge ( x ) return else if ( 1.0D+00 == cdf ) then x = huge ( x ) return end if ! ! Seek X1 < X < X2. ! x1 = - 1.0D+00 do call dipole_cdf ( x1, a, b, cdf1 ) if ( cdf1 <= cdf ) then exit end if x1 = 2.0D+00 * x1 end do x2 = 1.0D+00 do call dipole_cdf ( x2, a, b, cdf2 ) if ( cdf <= cdf2 ) then exit end if x2 = 2.0D+00 * x2 end do ! ! Now use bisection. ! it = 0 do it = it + 1 x3 = 0.5D+00 * ( x1 + x2 ) call dipole_cdf ( x3, a, b, cdf3 ) if ( abs ( cdf3 - cdf ) < tol ) then x = x3 exit end if if ( it_max < it ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIPOLE_CDF_INV - Fatal error!' write ( *, '(a)' ) ' Iteration limit exceeded.' stop end if if ( sign ( 1.0D+00, cdf3 - cdf ) == sign ( 1.0D+00, cdf1 - cdf ) ) then x1 = x3 cdf1 = cdf3 else x2 = x3 cdf2 = cdf3 end if end do return end function dipole_check ( a, b ) !******************************************************************************* ! !! DIPOLE_CHECK checks the parameters of the Dipole CDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A is arbitrary, but represents an angle, so only 0 <= A <= 2 * PI ! is interesting, and -1.0D+00 <= B <= 1.0. ! ! Output, logical DIPOLE_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical dipole_check if ( b < -1.0D+00 .or. 1.0D+00 < b ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIPOLE_CHECK - Fatal error!' write ( *, '(a)' ) ' -1.0D+00 <= B <= 1.0D+00 is required.' write ( *, '(a,g14.6)' ) ' The input B = ', b dipole_check = .false. return end if dipole_check = .true. return end subroutine dipole_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! DIPOLE_PDF evaluates the Dipole PDF. ! ! Formula: ! ! PDF(A,B;X) = ! 1 / ( PI * ( 1 + X**2 ) ) ! + B**2 * ( ( 1 - X**2 ) * cos ( 2 * A ) + 2 * X * sin ( 2 * A ) ) ! / ( PI * ( 1 + X**2 )**2 ) ! ! Discussion: ! ! Densities of this kind commonly occur in the analysis of resonant ! scattering of elementary particles. ! ! DIPOLE_PDF(A,0;X) = CAUCHY_PDF(A;X) ! ! A = 0, B = 1 yields the single channel dipole distribution. ! ! Modified: ! ! 28 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Knop, ! Algorithm 441, ! Random Deviates from the Dipole Distribution, ! ACM Transactions on Mathematical Software, ! Volume 16, Number 1, 1973, page 51. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A is arbitrary, but represents an angle, so only 0 <= A <= 2 * PI ! is interesting, ! and -1.0D+00 <= B <= 1.0. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x pdf = 1.0D+00 / ( pi * ( 1.0D+00 + x * x ) ) & + b * b * ( ( 1.0D+00 - x * x ) * cos ( 2.0D+00 * a ) & + 2.0D+00 * x * sin ( 2.0D+00 * x ) ) / ( pi * ( 1.0D+00 + x * x )**2 ) return end subroutine dipole_sample ( a, b, seed, x ) !******************************************************************************* ! !! DIPOLE_SAMPLE samples the Dipole PDF. ! ! Modified: ! ! 04 January 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Knop, ! Algorithm 441, ! ACM Transactions on Mathematical Software. ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A is arbitrary, but represents an angle, so only 0 <= A <= 2 * PI ! is interesting, ! and -1.0D+00 <= B <= 1.0D+00. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a2 real ( kind = 8 ) b real ( kind = 8 ) b2 real ( kind = 8 ) c2 integer seed real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 ! ! Find (X1,X2) at random in a circle. ! a2 = b * sin ( a ) b2 = b * cos ( a ) c2 = 1.0D+00 call circle_sample ( a2, b2, c2, seed, x1, x2 ) ! ! The dipole variate is the ratio X1 / X2. ! x = x1 / x2 return end function dirichlet_check ( n, a ) !******************************************************************************* ! !! DIRICHLET_CHECK checks the parameters of the Dirichlet PDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components. ! ! Input, real ( kind = 8 ) A(N), the probabilities for each component. ! Each A(I) should be positive. ! ! Output, logical DIRICHLET_CHECK, is true if the parameters are legal. ! implicit none integer n real ( kind = 8 ) a(n) logical dirichlet_check integer i logical positive positive = .false. do i = 1, n if ( a(i) <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIRICHLET_CHECK - Fatal error!' write ( *, '(a)' ) ' A(I) <= 0.' write ( *, '(a,i8)' ) ' For I = ', i write ( *, '(a,g14.6)' ) ' A(I) = ', a(i) dirichlet_check = .false. return else if ( 0.0D+00 < a(i) ) then positive = .true. end if end do if ( .not. positive ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIRICHLET_CHECK - Fatal error!' write ( *, '(a)' ) ' All parameters are zero!' dirichlet_check = .false. return end if dirichlet_check = .true. return end subroutine dirichlet_mean ( n, a, mean ) !******************************************************************************* ! !! DIRICHLET_MEAN returns the means of the Dirichlet PDF. ! ! Modified: ! ! 23 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components. ! ! Input, real ( kind = 8 ) A(N), the probabilities for each component. ! Each A(I) should be positive. ! ! Output, real ( kind = 8 ) MEAN(N), the means of the PDF. ! implicit none integer n real ( kind = 8 ) a(n) real ( kind = 8 ) mean(n) mean(1:n) = a(1:n) call dvec_unit_sum ( n, mean ) return end function dirichlet_mix_check ( comp_num, elem_num, a, comp_weight ) !******************************************************************************* ! !! DIRICHLET_MIX_CHECK checks the parameters of a Dirichlet mixture PDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer COMP_NUM, the number of components in the Dirichlet ! mixture density, that is, the number of distinct Dirichlet PDF's ! that are mixed together. ! ! Input, integer ELEM_NUM, the number of elements of an observation. ! ! Input, real ( kind = 8 ) A(ELEM_NUM,COMP_NUM), the probabilities ! for element ELEM_NUM in component COMP_NUM. ! Each A(I,J) should be positive. ! ! Input, real ( kind = 8 ) COMP_WEIGHT(COMP_NUM), the mixture weights of ! the densities. These do not need to be normalized. The weight of a ! given component is the relative probability that that component will ! be used to generate the sample. ! ! Output, logical DIRICHLET_MIX_CHECK, is true if the parameters are legal. ! implicit none integer comp_num integer elem_num real ( kind = 8 ) a(elem_num,comp_num) integer comp_i real ( kind = 8 ) comp_weight(comp_num) logical dirichlet_mix_check integer elem_i logical positive do comp_i = 1, comp_num do elem_i = 1, elem_num if ( a(elem_i,comp_i) <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIRICHLET_MIX_CHECK - Fatal error!' write ( *, '(a)' ) ' A(ELEM,COMP) <= 0.' write ( *, '(a,i8)' ) ' COMP = ', comp_i write ( *, '(a,i8)' ) ' ELEM = ', elem_i write ( *, '(a,g14.6)' ) ' A(COMP,ELEM) = ', a(elem_i,comp_i) dirichlet_mix_check = .false. return end if end do end do positive = .false. do comp_i = 1, comp_num if ( comp_weight(comp_i) < 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIRICHLET_MIX_CHECK - Fatal error!' write ( *, '(a)' ) ' COMP_WEIGHT(COMP) < 0.' write ( *, '(a,i8)' ) ' COMP = ', comp_i write ( *, '(a,g14.6)' ) ' COMP_WEIGHT(COMP) = ', comp_weight(comp_i) dirichlet_mix_check = .false. return else if ( 0.0D+00 < comp_weight(comp_i) ) then positive = .true. end if end do if ( .not. positive ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIRICHLET_MIX_CHECK - Fatal error!' write ( *, '(a)' ) ' All component weights are zero.' dirichlet_mix_check = .false. return end if dirichlet_mix_check = .true. return end subroutine dirichlet_mix_mean ( comp_num, elem_num, a, comp_weight, & mean ) !******************************************************************************* ! !! DIRICHLET_MIX_MEAN returns the means of a Dirichlet mixture PDF. ! ! Modified: ! ! 08 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer COMP_NUM, the number of components in the Dirichlet ! mixture density, that is, the number of distinct Dirichlet PDF's ! that are mixed together. ! ! Input, integer ELEM_NUM, the number of elements of an observation. ! ! Input, real ( kind = 8 ) A(ELEM_NUM,COMP_NUM), the probabilities for ! element ELEM_NUM in component COMP_NUM. ! Each A(I,J) should be positive. ! ! Input, real ( kind = 8 ) COMP_WEIGHT(COMP_NUM), the mixture weights of ! the densities. These do not need to be normalized. The weight of a ! given component is the relative probability that that component will ! be used to generate the sample. ! ! Output, real ( kind = 8 ) MEAN(ELEM_NUM), the means for each element. ! implicit none integer comp_num integer elem_num real ( kind = 8 ) a(elem_num,comp_num) integer comp_i real ( kind = 8 ) comp_mean(elem_num) real ( kind = 8 ) comp_weight(comp_num) real ( kind = 8 ) comp_weight_sum real ( kind = 8 ) mean(elem_num) comp_weight_sum = sum ( comp_weight ) mean(1:elem_num) = 0.0D+00 do comp_i = 1, comp_num call dirichlet_mean ( elem_num, a(1,comp_i), comp_mean ) mean(1:elem_num) = mean(1:elem_num) & + comp_weight(comp_i) * comp_mean(1:elem_num) end do mean(1:elem_num) = mean(1:elem_num) / comp_weight_sum return end subroutine dirichlet_mix_pdf ( x, comp_num, elem_num, a, & comp_weight, pdf ) !******************************************************************************* ! !! DIRICHLET_MIX_PDF evaluates a Dirichlet mixture PDF. ! ! Discussion: ! ! The PDF is a weighted sum of Dirichlet PDF's. Each PDF is a ! "component", with an associated weight. ! ! Modified: ! ! 08 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X(ELEM_NUM), the argument of the PDF. ! ! Input, integer COMP_NUM, the number of components in the Dirichlet ! mixture density, that is, the number of distinct Dirichlet PDF's ! that are mixed together. ! ! Input, integer ELEM_NUM, the number of elements of an observation. ! ! Input, real ( kind = 8 ) A(ELEM_NUM,COMP_NUM), the probabilities for ! element ELEM_NUM in component COMP_NUM. ! Each A(I,J) should be positive. ! ! Input, real ( kind = 8 ) COMP_WEIGHT(COMP_NUM), the mixture weights of ! the densities. These do not need to be normalized. The weight of a ! given component is the relative probability that that component will ! be used to generate the sample. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none integer comp_num integer elem_num real ( kind = 8 ) a(elem_num,comp_num) integer comp_i real ( kind = 8 ) comp_pdf real ( kind = 8 ) comp_weight(comp_num) real ( kind = 8 ) comp_weight_sum real ( kind = 8 ) pdf real ( kind = 8 ) x(elem_num) comp_weight_sum = sum ( comp_weight ) pdf = 0.0D+00 do comp_i = 1, comp_num call dirichlet_pdf ( x, elem_num, a(1,comp_i), comp_pdf ) pdf = pdf + comp_weight(comp_i) * comp_pdf / comp_weight_sum end do return end subroutine dirichlet_mix_sample ( comp_num, elem_num, a, & comp_weight, seed, comp, x ) !******************************************************************************* ! !! DIRICHLET_MIX_SAMPLE samples a Dirichlet mixture PDF. ! ! Modified: ! ! 08 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer COMP_NUM, the number of components in the Dirichlet ! mixture density, that is, the number of distinct Dirichlet PDF's ! that are mixed together. ! ! Input, integer ELEM_NUM, the number of elements of an observation. ! ! Input, real ( kind = 8 ) A(ELEM_NUM,COMP_NUM), the probabilities for ! element ELEM_NUM in component COMP_NUM. ! Each A(I,J) should be positive. ! ! Input, real ( kind = 8 ) COMP_WEIGHT(COMP_NUM), the mixture weights of ! the densities. These do not need to be normalized. The weight of a ! given component is the relative probability that that component will ! be used to generate the sample. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer COMP, the index of the component of the Dirichlet ! mixture that was chosen to generate the sample. ! ! Output, real ( kind = 8 ) X(ELEM_NUM), a sample of the PDF. ! implicit none integer comp_num integer elem_num real ( kind = 8 ) a(elem_num,comp_num) integer comp real ( kind = 8 ) comp_weight(comp_num) integer seed real ( kind = 8 ) x(elem_num) ! ! Choose a particular density component COMP. ! call discrete_sample ( comp_num, comp_weight, seed, comp ) ! ! Sample the density number COMP. ! call dirichlet_sample ( elem_num, a(1,comp), seed, x ) return end subroutine dirichlet_moment2 ( n, a, m2 ) !******************************************************************************* ! !! DIRICHLET_MOMENT2 returns the second moments of the Dirichlet PDF. ! ! Modified: ! ! 23 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components. ! ! Input, real ( kind = 8 ) A(N), the probabilities for each component. ! Each A(I) should be positive. ! ! Output, real ( kind = 8 ) M2(N,N), the second moments of the PDF. ! implicit none integer n real ( kind = 8 ) a(n) real ( kind = 8 ) a_sum real ( kind = 8 ) m2(n,n) integer i integer j a_sum = sum ( a(1:n) ) do i = 1, n do j = 1, n if ( i == j ) then m2(i,j) = a(i) * ( a(i) + 1.0D+00 ) / ( a_sum * ( a_sum + 1.0D+00 ) ) else m2(i,j) = a(i) * a(j) / ( a_sum * ( a_sum + 1.0D+00 ) ) end if end do end do return end subroutine dirichlet_multinomial_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! DIRICHLET_MULTINOMIAL_PDF evaluates a Dirichlet Multinomial PDF. ! ! Formula: ! ! PDF(A,B,C;X) = Comb(A,B,X) * ( Gamma(C_Sum) / Gamma(C_Sum+A) ) ! Product ( 1 <= I <= B ) Gamma(C(I)+X(I)) / Gamma(C(I)) ! ! where: ! ! Comb(A,B,X) is the multinomial coefficient C( A; X(1), X(2), ..., X(B) ), ! C_Sum = Sum ( 1 <= I <= B ) C(I) ! ! Modified: ! ! 17 December 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Kenneth Lange, ! Mathematical and Statistical Methods for Genetic Analysis, ! Springer, 1997, page 45. ! ! Parameters: ! ! Input, integer X(B); X(I) counts the number of occurrences of ! outcome I, out of the total of A trials. ! ! Input, integer A, the total number of trials. ! ! Input, integer B, the number of different possible outcomes on ! one trial. ! ! Input, real ( kind = 8 ) C(B); C(I) is the Dirichlet parameter associated ! with outcome I. ! ! Output, real ( kind = 8 ) PDF, the value of the Dirichlet multinomial PDF. ! implicit none integer b integer a real ( kind = 8 ) c(b) real ( kind = 8 ) c_sum real ( kind = 8 ) gamma_log integer i real ( kind = 8 ) pdf real ( kind = 8 ) pdf_log integer x(b) c_sum = sum ( c(1:b) ) pdf_log = - gamma_log ( c_sum + real ( a, kind = 8 ) ) + gamma_log ( c_sum ) & + gamma_log ( real ( a + 1, kind = 8 ) ) do i = 1, b pdf_log = pdf_log + gamma_log ( c(i) + real ( x(i), kind = 8 ) ) & - gamma_log ( c(i) ) - gamma_log ( real ( x(i) + 1, kind = 8 ) ) end do pdf = exp ( pdf_log ) return end subroutine dirichlet_pdf ( x, n, a, pdf ) !******************************************************************************* ! !! DIRICHLET_PDF evaluates the Dirichlet PDF. ! ! Definition: ! ! PDF(N,A;X) = Product ( 1 <= I <= N ) X(I)**( A(I) - 1 ) ! * Gamma ( A_SUM ) / A_PROD ! ! where ! ! 0 <= A(I) for all I; ! 0 <= X(I) for all I; ! Sum ( 1 <= I <= N ) X(I) = 1; ! A_SUM = Sum ( 1 <= I <= N ) A(I). ! A_PROD = Product ( 1 <= I <= N ) Gamma ( A(I) ) ! ! Modified: ! ! 06 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X(N), the argument of the PDF. Each X(I) should ! be greater than 0.0D+00, and the X(I)'s must add up to 1.0. ! ! Input, integer N, the number of components. ! ! Input, real ( kind = 8 ) A(N), the probabilities for each component. ! Each A(I) should be nonnegative, and at least one should be ! positive. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none integer n real ( kind = 8 ) a(n) real ( kind = 8 ) a_prod real ( kind = 8 ) a_sum real ( kind = 8 ) gamma integer i real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: tol = 0.0001D+00 real ( kind = 8 ) x(n) real ( kind = 8 ) x_sum do i = 1, n if ( x(i) <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIRICHLET_PDF - Fatal error!' write ( *, '(a)' ) ' X(I) <= 0.' end if end do x_sum = sum ( x(1:n) ) if ( tol < abs ( x_sum - 1.0D+00 ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIRICHLET_PDF - Fatal error!' write ( *, '(a)' ) ' SUM X(I) =/= 1.' end if a_sum = sum ( a(1:n) ) a_prod = 1.0D+00 do i = 1, n a_prod = a_prod * gamma ( a(i) ) end do pdf = gamma ( a_sum ) / a_prod do i = 1, n pdf = pdf * x(i)**( a(i) - 1.0D+00 ) end do return end subroutine dirichlet_sample ( n, a, seed, x ) !******************************************************************************* ! !! DIRICHLET_SAMPLE samples the Dirichlet PDF. ! ! Modified: ! ! 23 November 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jerry Banks, editor, ! Handbook of Simulation, ! Engineering and Management Press Books, 1998, page 169. ! ! Parameters: ! ! Input, integer N, the number of components. ! ! Input, real ( kind = 8 ) A(N), the probabilities for each component. ! Each A(I) should be nonnegative, and at least one should be ! positive. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X(N), a sample of the PDF. The entries ! of X should sum to 1. ! implicit none integer n real ( kind = 8 ) a(n) real ( kind = 8 ) a2 real ( kind = 8 ) b2 real ( kind = 8 ) c2 integer i integer seed real ( kind = 8 ) x(n) a2 = 0.0D+00 b2 = 1.0D+00 do i = 1, n c2 = a(i) call gamma_sample ( a2, b2, c2, seed, x(i) ) end do ! ! Rescale the vector to have unit sum. ! call dvec_unit_sum ( n, x ) return end subroutine dirichlet_variance ( n, a, variance ) !******************************************************************************* ! !! DIRICHLET_VARIANCE returns the variances of the Dirichlet PDF. ! ! Modified: ! ! 03 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components. ! ! Input, real ( kind = 8 ) A(N), the probabilities for each component. ! Each A(I) should be nonnegative, and at least one should be positive. ! ! Output, real ( kind = 8 ) VARIANCE(N), the variances of the PDF. ! implicit none integer n real ( kind = 8 ) a(n) real ( kind = 8 ) a_sum integer i real ( kind = 8 ) variance(n) a_sum = sum ( a(1:n) ) do i = 1, n variance(i) = a(i) * ( a_sum - a(i) ) / ( a_sum**2 * ( a_sum + 1.0D+00 ) ) end do return end subroutine discrete_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! DISCRETE_CDF evaluates the Discrete CDF. ! ! Modified: ! ! 05 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the item whose probability is desired. ! ! Input, integer A, the number of probabilities assigned. ! ! Input, real ( kind = 8 ) B(A), the relative probabilities of outcomes ! 1 through A. Each entry must be nonnegative. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) cdf integer x if ( x < 1 ) then cdf = 0.0D+00 else if ( x < a ) then cdf = sum ( b(1:x) ) / sum ( b(1:a) ) else if ( a <= x ) then cdf = 1.0D+00 end if return end subroutine discrete_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! DISCRETE_CDF_INV inverts the Discrete CDF. ! ! Modified: ! ! 05 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, integer A, the number of probabilities assigned. ! ! Input, real ( kind = 8 ) B(A), the relative probabilities of outcomes ! 1 through A. Each entry must be nonnegative. ! ! Output, integer X, the corresponding argument for which ! CDF(X-1) < CDF <= CDF(X) ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) b_sum real ( kind = 8 ) cdf real ( kind = 8 ) cum integer j integer x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DISCRETE_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if b_sum = sum ( b(1:a) ) cum = 0.0D+00 do j = 1, a cum = cum + b(j) / b_sum if ( cdf <= cum ) then x = j return end if end do x = a return end function discrete_check ( a, b ) !******************************************************************************* ! !! DISCRETE_CHECK checks the parameters of the Discrete CDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of probabilities assigned. ! ! Input, real ( kind = 8 ) B(A), the relative probabilities of ! outcomes 1 through A. Each entry must be nonnegative. ! ! Output, logical DISCRETE_CHECK, is true if the parameters are legal. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) b_sum logical discrete_check integer j do j = 1, a if ( b(j) < 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DISCRETE_CHECK - Fatal error!' write ( *, '(a)' ) ' Negative probabilities not allowed.' discrete_check = .false. return end if end do b_sum = sum ( b(1:a) ) if ( b_sum == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DISCRETE_CHECK - Fatal error!' write ( *, '(a)' ) ' Total probablity is zero.' discrete_check = .false. return end if discrete_check = .true. return end subroutine discrete_mean ( a, b, mean ) !******************************************************************************* ! !! DISCRETE_MEAN evaluates the mean of the Discrete PDF. ! ! Modified: ! ! 05 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of probabilities assigned. ! ! Input, real ( kind = 8 ) B(A), the relative probabilities of ! outcomes 1 through A. Each entry must be nonnegative. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) b_sum integer j real ( kind = 8 ) mean b_sum = sum ( b(1:a) ) mean = 0.0D+00 do j = 1, a mean = mean + real ( j, kind = 8 ) * b(j) end do mean = mean / b_sum return end subroutine discrete_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! DISCRETE_PDF evaluates the Discrete PDF. ! ! Formula: ! ! PDF(A,B;X) = B(X) if 1 <= X <= A ! = 0 otherwise ! ! Modified: ! ! 05 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the item whose probability is desired. ! ! Input, integer A, the number of probabilities assigned. ! ! Input, real ( kind = 8 ) B(A), the relative probabilities of ! outcomes 1 through A. Each entry must be nonnegative. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) b_sum real ( kind = 8 ) pdf integer x b_sum = sum ( b(1:a) ) if ( 1 <= x .and. x <= a ) then pdf = b(x) / b_sum else pdf = 0.0D+00 end if return end subroutine discrete_sample ( a, b, seed, x ) !******************************************************************************* ! !! DISCRETE_SAMPLE samples the Discrete PDF. ! ! Modified: ! ! 05 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of probabilities assigned. ! ! Input, real ( kind = 8 ) B(A), the relative probabilities of ! outcomes 1 through A. Each entry must be nonnegative. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) b_sum real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed integer x b_sum = sum ( b(1:a) ) cdf = d_uniform_01 ( seed ) call discrete_cdf_inv ( cdf, a, b, x ) return end subroutine discrete_variance ( a, b, variance ) !******************************************************************************* ! !! DISCRETE_VARIANCE evaluates the variance of the Discrete PDF. ! ! Modified: ! ! 05 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of probabilities assigned. ! ! Input, real ( kind = 8 ) B(A), the relative probabilities of ! outcomes 1 through A. Each entry must be nonnegative. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) b_sum integer j real ( kind = 8 ) mean real ( kind = 8 ) variance b_sum = sum ( b(1:a) ) mean = 0.0D+00 do j = 1, a mean = mean + real ( j, kind = 8 ) * b(j) end do mean = mean / b_sum variance = 0.0D+00 do j = 1, a variance = variance + b(j) * ( j - mean )**2 end do variance = variance / b_sum return end subroutine dmat_print ( m, n, a, title ) !******************************************************************************* ! !! DMAT_PRINT prints a double precision matrix. ! ! Modified: ! ! 12 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the number of rows in A. ! ! Input, integer N, the number of columns in A. ! ! Input, real ( kind = 8 ) A(M,N), the matrix. ! ! Input, character ( len = * ) TITLE, a title to be printed. ! implicit none integer m integer n real ( kind = 8 ) a(m,n) character ( len = * ) title call dmat_print_some ( m, n, a, 1, 1, m, n, title ) return end subroutine dmat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title ) !******************************************************************************* ! !! DMAT_PRINT_SOME prints some of a double precision matrix. ! ! Modified: ! ! 12 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns. ! ! Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed. ! ! Input, integer ILO, JLO, the first row and column to print. ! ! Input, integer IHI, JHI, the last row and column to print. ! ! Input, character ( len = * ) TITLE, an optional title. ! implicit none integer, parameter :: incx = 5 integer m integer n real ( kind = 8 ) a(m,n) character ( len = 14 ) ctemp(incx) integer i integer i2hi integer i2lo integer ihi integer ilo integer inc integer j integer j2 integer j2hi integer j2lo integer jhi integer jlo logical d_is_int character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx j2hi = j2lo + incx - 1 j2hi = min ( j2hi, n ) j2hi = min ( j2hi, jhi ) inc = j2hi + 1 - j2lo write ( *, '(a)' ) ' ' do j = j2lo, j2hi j2 = j + 1 - j2lo write ( ctemp(j2), '(i7,7x)') j end do write ( *, '('' Col '',5a14)' ) ctemp(1:inc) write ( *, '(a)' ) ' Row' write ( *, '(a)' ) ' ' i2lo = max ( ilo, 1 ) i2hi = min ( ihi, m ) do i = i2lo, i2hi do j2 = 1, inc j = j2lo - 1 + j2 if ( d_is_int ( a(i,j) ) ) then write ( ctemp(j2), '(f8.0,6x)' ) a(i,j) else write ( ctemp(j2), '(g14.6)' ) a(i,j) end if end do write ( *, '(i5,1x,5a14)' ) i, ( ctemp(j), j = 1, inc ) end do end do write ( *, '(a)' ) ' ' return end function dpoly_value ( n, a, x ) !*********************************************************************** ! !! DPOLY_VALUE evaluates a double precision polynomial. ! ! Discussion: ! ! For sanity's sake, the value of N indicates the NUMBER of ! coefficients, or more precisely, the ORDER of the polynomial, ! rather than the DEGREE of the polynomial. The two quantities ! differ by 1, but cause a great deal of confusion. ! ! Given N and A, the form of the polynomial is: ! ! p(x) = a(1) + a(2) * x + ... + a(n-1) * x^(n-2) + a(n) * x^(n-1) ! ! Modified: ! ! 13 August 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the order of the polynomial. ! ! Input, real ( kind = 8 ) A(N), the coefficients of the polynomial. ! A(1) is the constant term. ! ! Input, real ( kind = 8 ) X, the point at which the polynomial is ! to be evaluated. ! ! Output, real ( kind = 8 ) DPOLY_VALUE, the value of the polynomial at X. ! implicit none integer n real ( kind = 8 ) a(n) real ( kind = 8 ) dpoly_value integer i real ( kind = 8 ) x dpoly_value = 0.0D+00 do i = n, 1, -1 dpoly_value = dpoly_value * x + a(i) end do return end subroutine drow_max ( m, n, x, ixmax, xmax ) !******************************************************************************* ! !! DROW_MAX returns the maximums of rows of a double precision array. ! ! Modified: ! ! 01 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns in the array. ! ! Input, real ( kind = 8 ) X(M,N), the array to be examined. ! ! Output, integer IXMAX(M); IXMAX(I) is the column of X in which ! the maximum for row I occurs. ! ! Output, real ( kind = 8 ) XMAX(M), the maximums of the rows of X. ! implicit none integer m integer n integer i integer ixmax(m) integer j real ( kind = 8 ) x(m,n) real ( kind = 8 ) xmax(m) do i = 1, m ixmax(i) = 1 xmax(i) = x(i,1) do j = 2, n if ( xmax(i) < x(i,j) ) then ixmax(i) = j xmax(i) = x(i,j) end if end do end do return end subroutine drow_mean ( m, n, x, mean ) !******************************************************************************* ! !! DROW_MEAN returns the means of rows of a double precision array. ! ! Modified: ! ! 01 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns in the array. ! ! Input, real ( kind = 8 ) X(M,N), the array whose row means are desired. ! ! Output, real ( kind = 8 ) MEAN(M), the means, or averages, ! of the rows of X. ! implicit none integer m integer n integer i real ( kind = 8 ) mean(m) real ( kind = 8 ) x(m,n) do i = 1, m mean(i) = sum ( x(i,1:n) ) / real ( n ) end do return end subroutine drow_min ( m, n, x, ixmin, xmin ) !******************************************************************************* ! !! DROW_MIN returns the minimums of rows of a double precision array. ! ! Modified: ! ! 01 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns in the array. ! ! Input, real ( kind = 8 ) X(M,N), the array to be examined. ! ! Output, integer IXMIN(M); IXMIN(I) is the column of X in which ! the minimum for row I occurs. ! ! Output, real ( kind = 8 ) XMIN(M), the minimums of the rows of X. ! implicit none integer m integer n integer i integer ixmin(m) integer j real ( kind = 8 ) x(m,n) real ( kind = 8 ) xmin(m) do i = 1, m ixmin(i) = 1 xmin(i) = x(i,1) do j = 2, n if ( x(i,j) < xmin(i) ) then ixmin(i) = j xmin(i) = x(i,j) end if end do end do return end subroutine drow_variance ( m, n, x, variance ) !******************************************************************************* ! !! DROW_VARIANCE returns the variances of the rows of a double precision array. ! ! Modified: ! ! 01 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns in the array. ! ! Input, real ( kind = 8 ) X(M,N), the array whose row means are desired. ! ! Output, real ( kind = 8 ) VARIANCE(M), the variances of the rows of X. ! implicit none integer m integer n integer i real ( kind = 8 ) mean real ( kind = 8 ) variance(m) real ( kind = 8 ) x(m,n) do i = 1, m mean = sum ( x(i,1:n) ) / real ( n, kind = 8 ) variance(i) = sum ( ( x(i,1:n) - mean )**2 ) if ( 1 < n ) then variance(i) = variance(i) / real ( n - 1, kind = 8 ) else variance(i) = 0.0D+00 end if end do return end subroutine dvec_circular_variance ( n, x, circular_variance ) !******************************************************************************* ! !! DVEC_CIRCULAR_VARIANCE returns the circular variance of a double precision vector. ! ! Modified: ! ! 02 December 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real ( kind = 8 ) X(N), the vector whose variance is desired. ! ! Output, real ( kind = 8 ) CIRCULAR VARIANCE, the circular variance ! of the vector entries. ! implicit none integer n real ( kind = 8 ) circular_variance real ( kind = 8 ) mean real ( kind = 8 ) x(n) call dvec_mean ( n, x, mean ) circular_variance = & ( sum ( cos ( x(1:n) - mean ) ) )**2 & + ( sum ( sin ( x(1:n) - mean ) ) )**2 circular_variance = sqrt ( circular_variance ) / real ( n, kind = 8 ) circular_variance = 1.0D+00 - circular_variance return end subroutine dvec_max ( n, x, index, xmax ) !******************************************************************************* ! !! DVEC_MAX returns the maximum value in a real vector. ! ! Modified: ! ! 30 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input, real ( kind = 8 ) X(N), the array. ! ! Output, integer INDEX, the index of the largest entry. ! ! Output, real ( kind = 8 ) XMAX, the value of the largest entry. ! implicit none integer n integer i integer index real ( kind = 8 ) x(n) real ( kind = 8 ) xmax if ( n <= 0 ) then index = 0 xmax = 0.0D+00 else index = 1 xmax = x(1) do i = 2, n if ( xmax < x(i) ) then xmax = x(i) index = i end if end do end if return end subroutine dvec_mean ( n, x, mean ) !******************************************************************************* ! !! DVEC_MEAN returns the mean of a double precision vector. ! ! Modified: ! ! 02 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real ( kind = 8 ) X(N), the vector whose mean is desired. ! ! Output, real ( kind = 8 ) MEAN, the mean, or average, ! of the vector entries. ! implicit none integer n real ( kind = 8 ) mean real ( kind = 8 ) x(n) mean = sum ( x(1:n) ) / real ( n, kind = 8 ) return end subroutine dvec_min ( n, x, index, xmin ) !******************************************************************************* ! !! DVEC_MIN returns the minimum value of a double precision array. ! ! Modified: ! ! 30 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input, real ( kind = 8 ) X(N), the array. ! ! Output, integer INDEX, the index of the smallest entry. ! ! Output, real ( kind = 8 ) XMIN, the value of the smallest entry. ! implicit none integer n integer i integer index real ( kind = 8 ) x(n) real ( kind = 8 ) xmin if ( n <= 0 ) then index = 0 xmin = 0.0D+00 else xmin = x(1) index = 1 do i = 2, n if ( x(i) < xmin ) then xmin = x(i) index = i end if end do end if return end subroutine dvec_print ( n, a, title ) !******************************************************************************* ! !! DVEC_PRINT prints a double precision vector. ! ! Modified: ! ! 16 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, real ( kind = 8 ) A(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none integer n real ( kind = 8 ) a(n) integer i character ( len = * ) title if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(i8,g14.6)' ) i, a(i) end do return end subroutine dvec_uniform ( n, a, b, seed, r ) !******************************************************************************* ! !! DVEC_UNIFORM returns a vector of scaled pseudorandom double precision values. ! ! Modified: ! ! 29 January 2005 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, L E Schrage, ! A Guide to Simulation, ! Springer Verlag, pages 201-202, 1983. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, pages 362-376, 1986. ! ! P A Lewis, A S Goodman, J M Miller, ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, pages 136-143, 1969. ! ! Parameters: ! ! Input, integer M, the number of entries in the vector. ! ! Input, real ( kind = 8 ) A, B, the lower and upper limits. ! ! Input/output, integer SEED, the "seed" value, which should NOT be 0. ! On output, SEED has been updated. ! ! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. ! implicit none integer n real ( kind = 8 ) a real ( kind = 8 ) b integer i integer k integer seed real ( kind = 8 ) r(n) do i = 1, n k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if r(i) = a + ( b - a ) * real ( seed, kind = 8 ) * 4.656612875D-10 end do return end subroutine dvec_uniform_01 ( n, seed, r ) !******************************************************************************* ! !! DVEC_UNIFORM_01 returns a vector of unit pseudorandom double precision values. ! ! Modified: ! ! 19 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, L E Schrage, ! A Guide to Simulation, ! Springer Verlag, pages 201-202, 1983. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, pages 362-376, 1986. ! ! P A Lewis, A S Goodman, J M Miller, ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, pages 136-143, 1969. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input/output, integer SEED, the "seed" value, which should NOT be 0. ! On output, SEED has been updated. ! ! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. ! implicit none integer n integer i integer k integer seed real ( kind = 8 ) r(n) do i = 1, n k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if r(i) = real ( seed, kind = 8 ) * 4.656612875D-10 end do return end subroutine dvec_unit_sum ( n, a ) !******************************************************************************* ! !! DVEC_UNIT_SUM normalizes a double precision vector to have unit sum. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input/output, real A(N), the vector to be normalized. On output, ! the entries of A should have unit sum. However, if the input vector ! has zero sum, the routine halts. ! implicit none integer n real ( kind = 8 ) a(n) real ( kind = 8 ) a_sum a_sum = sum ( a(1:n) ) if ( a_sum == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DVEC_UNIT_SUM - Fatal error!' write ( *, '(a)' ) ' The vector entries sum to 0.' stop end if a(1:n) = a(1:n) / a_sum return end subroutine dvec_variance ( n, x, variance ) !******************************************************************************* ! !! DVEC_VARIANCE returns the variance of a double precision vector. ! ! Modified: ! ! 01 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real ( kind = 8 ) X(N), the vector whose variance is desired. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the vector entries. ! implicit none integer n real ( kind = 8 ) mean real ( kind = 8 ) variance real ( kind = 8 ) x(n) call dvec_mean ( n, x, mean ) variance = sum ( ( x(1:n) - mean )**2 ) if ( 1 < n ) then variance = variance / real ( n - 1, kind = 8 ) else variance = 0.0D+00 end if return end function e_constant ( ) !******************************************************************************* ! !! E_CONSTANT returns the value of E. ! ! Discussion: ! ! "E" was named in honor of Euler. ! ! Modified: ! ! 30 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) E_CONSTANT, the base of the natural ! logarithm system. ! implicit none real ( kind = 8 ) e_constant e_constant = 2.71828182845904523536028747135266249775724709369995D+00 return end subroutine empirical_discrete_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! EMPIRICAL_DISCRETE_CDF evaluates the Empirical Discrete CDF. ! ! Modified: ! ! 28 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, integer A, the number of values. ! 0 < A. ! ! Input, real ( kind = 8 ) B(A), the weights of each value. ! 0 <= B(1:A) and at least one value is nonzero. ! ! Input, real ( kind = 8 ) C(A), the values. ! The values must be distinct and in ascending order. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) bsum real ( kind = 8 ) c(a) real ( kind = 8 ) cdf integer i real ( kind = 8 ) x cdf = 0.0D+00 bsum = sum ( b(1:a) ) do i = 1, a if ( x < c(i) ) then return end if cdf = cdf + b(i) / bsum end do return end subroutine empirical_discrete_cdf_inv ( cdf, a, b, c, x ) !******************************************************************************* ! !! EMPIRICAL_DISCRETE_CDF_INV inverts the Empirical Discrete CDF. ! ! Modified: ! ! 28 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, integer A, the number of values. ! 0 < A. ! ! Input, real ( kind = 8 ) B(A), the weights of each value. ! 0 <= B(1:A) and at least one value is nonzero. ! ! Input, real ( kind = 8 ) C(A), the values. ! The values must be distinct and in ascending order. ! ! Output, real ( kind = 8 ) X, the smallest argument whose CDF is greater ! than or equal to CDF. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) bsum real ( kind = 8 ) c(a) real ( kind = 8 ) cdf real ( kind = 8 ) cdf2 integer i real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EMPIRICAL_DISCRETE_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if bsum = sum ( b(1:a) ) x = c(1) cdf2 = b(1) / bsum do i = 2, a if ( cdf <= cdf2 ) then return end if x = c(i) cdf2 = cdf2 + b(i) / bsum end do return end function empirical_discrete_check ( a, b, c ) !******************************************************************************* ! !! EMPIRICAL_DISCRETE_CHECK checks the parameters of the Empirical Discrete CDF. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of values. ! 0 < A. ! ! Input, real ( kind = 8 ) B(A), the weights of each value. ! 0 <= B(1:A) and at least one value is nonzero. ! ! Input, real ( kind = 8 ) C(A), the values. ! The values must be distinct and in ascending order. ! ! Output, logical EMPIRICAL_DISCRETE_CHECK, is true if the parameters ! are legal. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) c(a) logical empirical_discrete_check integer i integer j if ( a <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EMPIRICAL_DISCRETE_CHECK - Fatal error!' write ( *, '(a)' ) ' A must be positive.' write ( *, '(a,i)' ) ' Input A = ', a write ( *, '(a)' ) ' A is the number of weights.' empirical_discrete_check = .false. return end if if ( any ( b(1:a) < 0.0D+00 ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EMPIRICAL_DISCRETE_CHECK - Fatal error!' write ( *, '(a)' ) ' Some B(*) < 0.' write ( *, '(a)' ) ' But all B values must be nonnegative.' empirical_discrete_check = .false. return end if if ( all ( b(1:a) == 0.0D+00 ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EMPIRICAL_DISCRETE_CHECK - Fatal error!' write ( *, '(a)' ) ' All B(*) = 0.' write ( *, '(a)' ) ' But at least one B values must be nonzero.' empirical_discrete_check = .false. return end if do i = 1, a do j = i+1, a if ( c(i) == c(j) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EMPIRICAL_DISCRETE_CHECK - Fatal error!' write ( *, '(a)' ) ' All values C must be unique.' write ( *, '(a)' ) ' But at least two values are identical.' empirical_discrete_check = .false. return end if end do end do do i = 1, a-1 if ( c(i+1) < c(i) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EMPIRICAL_DISCRETE_CHECK - Fatal error!' write ( *, '(a)' ) ' The values in C must be in ascending order.' empirical_discrete_check = .false. return end if end do empirical_discrete_check = .true. return end subroutine empirical_discrete_mean ( a, b, c, mean ) !******************************************************************************* ! !! EMPIRICAL_DISCRETE_MEAN returns the mean of the Empirical Discrete PDF. ! ! Modified: ! ! 28 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of values. ! 0 < A. ! ! Input, real ( kind = 8 ) B(A), the weights of each value. ! 0 <= B(1:A) and at least one value is nonzero. ! ! Input, real ( kind = 8 ) C(A), the values. ! The values must be distinct and in ascending order. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) c(a) real ( kind = 8 ) mean mean = dot_product ( b(1:a), c(1:a) ) / sum ( b(1:a) ) return end subroutine empirical_discrete_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! EMPIRICAL_DISCRETE_PDF evaluates the Empirical Discrete PDF. ! ! Discussion: ! ! A set of A values C(1:A) are assigned nonnegative weights B(1:A), ! with at least one B nonzero. The probability of C(I) is the ! value of B(I) divided by the sum of the weights. ! ! The C's must be distinct, and given in ascending order. ! ! Modified: ! ! 28 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, integer A, the number of values. ! 0 < A. ! ! Input, real ( kind = 8 ) B(A), the weights of each value. ! 0 <= B(1:A) and at least one value is nonzero. ! ! Input, real ( kind = 8 ) C(A), the values. ! The values must be distinct and in ascending order. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) c(a) integer i real ( kind = 8 ) pdf real ( kind = 8 ) x do i = 1, a if ( x == c(i) ) then pdf = b(i) / sum ( b(1:a) ) return end if end do pdf = 0.0D+00 return end subroutine empirical_discrete_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! EMPIRICAL_DISCRETE_SAMPLE samples the Empirical Discrete PDF. ! ! Modified: ! ! 28 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of values. ! 0 < A. ! ! Input, real ( kind = 8 ) B(A), the weights of each value. ! 0 <= B(1:A) and at least one value is nonzero. ! ! Input, real ( kind = 8 ) C(A), the values. ! The values must be distinct and in ascending order. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) c(a) real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call empirical_discrete_cdf_inv ( cdf, a, b, c, x ) return end subroutine empirical_discrete_variance ( a, b, c, variance ) !******************************************************************************* ! !! EMPIRICAL_DISCRETE_VARIANCE returns the variance of the Empirical Discrete PDF. ! ! Modified: ! ! 28 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of values. ! 0 < A. ! ! Input, real ( kind = 8 ) B(A), the weights of each value. ! 0 <= B(1:A) and at least one value is nonzero. ! ! Input, real ( kind = 8 ) C(A), the values. ! The values must be distinct and in ascending order. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none integer a real ( kind = 8 ) b(a) real ( kind = 8 ) bsum real ( kind = 8 ) c(a) integer i real ( kind = 8 ) mean real ( kind = 8 ) variance bsum = sum ( b(1:a) ) call empirical_discrete_mean ( a, b, c, mean ) variance = 0.0D+00 do i = 1, a variance = variance + ( b(i) / bsum ) * ( c(i) - mean )**2 end do return end function erf ( x ) !******************************************************************************* ! !! ERF evaluates the error function. ! ! Definition: ! ! ERF(X) = ( 2 / sqrt ( PI ) ) * Integral ( 0 <= T <= X ) EXP ( - T**2 ) dT. ! ! Properties: ! ! Limit ( X -> -Infinity ) ERF(X) = -1.0; ! ERF(0) = 0.0; ! ERF(0.476936...) = 0.5; ! Limit ( X -> +Infinity ) ERF(X) = +1.0. ! ! 0.5D+00 * ( ERF(X/sqrt(2)) + 1 ) = Normal_01_CDF(X) ! ! Modified: ! ! 06 December 1999 ! ! Author: ! ! W J Cody, ! Mathematics and Computer Science Division, ! Argonne National Laboratory, ! Argonne, Illinois, 60439. ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! W J Cody, ! "Rational Chebyshev Approximations for the Error Function", ! Mathematics of Computation, ! 1969, pages 631-638. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the error function. ! ! Output, real ( kind = 8 ) ERF, the value of the error function. ! implicit none real ( kind = 8 ), parameter, dimension ( 5 ) :: a = (/ & 3.16112374387056560D+00, & 1.13864154151050156D+02, & 3.77485237685302021D+02, & 3.20937758913846947D+03, & 1.85777706184603153D-01 /) real ( kind = 8 ), parameter, dimension ( 4 ) :: b = (/ & 2.36012909523441209D+01, & 2.44024637934444173D+02, & 1.28261652607737228D+03, & 2.84423683343917062D+03 /) real ( kind = 8 ), parameter, dimension ( 9 ) :: c = (/ & 5.64188496988670089D-01, & 8.88314979438837594D+00, & 6.61191906371416295D+01, & 2.98635138197400131D+02, & 8.81952221241769090D+02, & 1.71204761263407058D+03, & 2.05107837782607147D+03, & 1.23033935479799725D+03, & 2.15311535474403846D-08 /) real ( kind = 8 ), parameter, dimension ( 8 ) :: d = (/ & 1.57449261107098347D+01, & 1.17693950891312499D+02, & 5.37181101862009858D+02, & 1.62138957456669019D+03, & 3.29079923573345963D+03, & 4.36261909014324716D+03, & 3.43936767414372164D+03, & 1.23033935480374942D+03 /) real ( kind = 8 ) del real ( kind = 8 ) erf integer i real ( kind = 8 ), parameter, dimension ( 6 ) :: p = (/ & 3.05326634961232344D-01, & 3.60344899949804439D-01, & 1.25781726111229246D-01, & 1.60837851487422766D-02, & 6.58749161529837803D-04, & 1.63153871373020978D-02 /) real ( kind = 8 ), parameter, dimension ( 5 ) :: q = (/ & 2.56852019228982242D+00, & 1.87295284992346047D+00, & 5.27905102951428412D-01, & 6.05183413124413191D-02, & 2.33520497626869185D-03 /) real ( kind = 8 ), parameter :: sqrpi = 0.56418958354775628695D+00 real ( kind = 8 ), parameter :: thresh = 0.46875D+00 real ( kind = 8 ) x real ( kind = 8 ) xabs real ( kind = 8 ), parameter :: xbig = 26.543D+00 real ( kind = 8 ) xden real ( kind = 8 ) xnum real ( kind = 8 ) xsq xabs = abs ( ( x ) ) ! ! Evaluate ERF(X) for |X| <= 0.46875. ! if ( xabs <= thresh ) then if ( epsilon ( xabs ) < xabs ) then xsq = xabs * xabs else xsq = 0.0D+00 end if xnum = a(5) * xsq xden = xsq do i = 1, 3 xnum = ( xnum + a(i) ) * xsq xden = ( xden + b(i) ) * xsq end do erf = x * ( xnum + a(4) ) / ( xden + b(4) ) ! ! Evaluate ERFC(X) for 0.46875 <= |X| <= 4.0. ! else if ( xabs <= 4.0D+00 ) then xnum = c(9) * xabs xden = xabs do i = 1, 7 xnum = ( xnum + c(i) ) * xabs xden = ( xden + d(i) ) * xabs end do erf = ( xnum + c(8) ) / ( xden + d(8) ) xsq = real ( int ( xabs * 16.0D+00 ), kind = 8 ) / 16.0D+00 del = ( xabs - xsq ) * ( xabs + xsq ) erf = exp ( - xsq * xsq ) * exp ( - del ) * erf erf = ( 0.5D+00 - erf ) + 0.5D+00 if ( x < 0.0D+00 ) then erf = - erf end if ! ! Evaluate ERFC(X) for 4.0D+00 < |X|. ! else if ( xbig <= xabs ) then if ( 0.0D+00 < x ) then erf = 1.0D+00 else erf = - 1.0D+00 end if else xsq = 1.0D+00 / ( xabs * xabs ) xnum = p(6) * xsq xden = xsq do i = 1, 4 xnum = ( xnum + p(i) ) * xsq xden = ( xden + q(i) ) * xsq end do erf = xsq * ( xnum + p(5) ) / ( xden + q(5) ) erf = ( sqrpi - erf ) / xabs xsq = real ( int ( xabs * 16.0D+00 ), kind = 8 ) / 16.0D+00 del = ( xabs - xsq ) * ( xabs + xsq ) erf = exp ( - xsq * xsq ) * exp ( - del ) * erf erf = ( 0.5D+00 - erf ) + 0.5D+00 if ( x < 0.0D+00 ) then erf = - erf end if end if end if return end subroutine erlang_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! ERLANG_CDF evaluates the Erlang CDF. ! ! Modified: ! ! 31 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, integer C, the parameters of the PDF. ! 0.0D+00 < B. ! 0 < C. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer c real ( kind = 8 ) cdf real ( kind = 8 ) gamma_inc real ( kind = 8 ) p2 real ( kind = 8 ) x real ( kind = 8 ) x2 if ( x < a ) then cdf = 0.0D+00 else x2 = ( x - a ) / b p2 = real ( c, kind = 8 ) cdf = gamma_inc ( p2, x2 ) end if return end subroutine erlang_cdf_inv ( cdf, a, b, c, x ) !******************************************************************************* ! !! ERLANG_CDF_INV inverts the Erlang CDF. ! ! Discussion: ! ! A simple bisection method is used. ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, B, integer C, the parameters of the PDF. ! 0.0D+00 < B. ! 0 < C. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer c real ( kind = 8 ) cdf real ( kind = 8 ) cdf1 real ( kind = 8 ) cdf2 real ( kind = 8 ) cdf3 integer it integer, parameter :: it_max = 100 real ( kind = 8 ), parameter :: tol = 0.0001D+00 real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 real ( kind = 8 ) x3 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ERLANG_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = a return else if ( 1.0D+00 == cdf ) then x = huge ( x ) return end if x1 = a cdf1 = 0.0D+00 x2 = a + 1.0D+00 do call erlang_cdf ( x2, a, b, c, cdf2 ) if ( cdf < cdf2 ) then exit end if x2 = a + 2.0D+00 * ( x2 - a ) end do ! ! Now use bisection. ! it = 0 do it = it + 1 x3 = 0.5D+00 * ( x1 + x2 ) call erlang_cdf ( x3, a, b, c, cdf3 ) if ( abs ( cdf3 - cdf ) < tol ) then x = x3 exit end if if ( it_max < it ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ERLANG_CDF_INV - Fatal error!' write ( *, '(a)' ) ' Iteration limit exceeded.' return end if if ( sign ( 1.0D+00, cdf3 - cdf ) == sign ( 1.0D+00, cdf1 - cdf ) ) then x1 = x3 cdf1 = cdf3 else x2 = x3 cdf2 = cdf3 end if end do return end function erlang_check ( a, b, c ) !******************************************************************************* ! !! ERLANG_CHECK checks the parameters of the Erlang PDF. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, integer C, the parameters of the PDF. ! 0.0D+00 < B. ! 0 < C. ! ! Output, logical ERLANG_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer c logical erlang_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ERLANG_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.0' erlang_check = .false. return end if if ( c <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ERLANG_CHECK - Fatal error!' write ( *, '(a)' ) ' C <= 0.' erlang_check = .false. return end if erlang_check = .true. return end subroutine erlang_mean ( a, b, c, mean ) !******************************************************************************* ! !! ERLANG_MEAN returns the mean of the Erlang PDF. ! ! Modified: ! ! 31 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, integer C, the parameters of the PDF. ! 0.0D+00 < B. ! 0 < C. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer c real ( kind = 8 ) mean mean = a + b * real ( c, kind = 8 ) return end subroutine erlang_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! ERLANG_PDF evaluates the Erlang PDF. ! ! Formula: ! ! PDF(A,B,C;X) = ( ( X - A ) / B )**( C - 1 ) ! / ( B * Gamma ( C ) * EXP ( ( X - A ) / B ) ) ! ! for 0 < B, 0 < C integer, A <= X. ! ! Modified: ! ! 31 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, integer C, the parameters of the PDF. ! 0.0D+00 < B. ! 0 < C. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer c real ( kind = 8 ) i_factorial real ( kind = 8 ) pdf real ( kind = 8 ) x real ( kind = 8 ) y if ( x <= a ) then pdf = 0.0D+00 else y = ( x - a ) / b pdf = y**( c - 1 ) / ( b * i_factorial ( c - 1 ) * exp ( y ) ) end if return end subroutine erlang_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! ERLANG_SAMPLE samples the Erlang PDF. ! ! Modified: ! ! 31 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, integer C, the parameters of the PDF. ! 0.0D+00 < B. ! 0 < C. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a2 real ( kind = 8 ) b real ( kind = 8 ) b2 integer c integer i integer seed real ( kind = 8 ) x real ( kind = 8 ) x2 a2 = 0.0D+00 b2 = b x = a do i = 1, c call exponential_sample ( a2, b2, seed, x2 ) x = x + x2 end do return end subroutine erlang_variance ( a, b, c, variance ) !******************************************************************************* ! !! ERLANG_VARIANCE returns the variance of the Erlang PDF. ! ! Modified: ! ! 31 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, integer C, the parameters of the PDF. ! 0.0D+00 < B. ! 0 < C. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer c real ( kind = 8 ) variance variance = b * b * real ( c ) return end function euler_constant ( ) !******************************************************************************* ! !! EULER_CONSTANT returns the value of the Euler-Mascheroni constant. ! ! Discussion: ! ! The Euler-Mascheroni constant is often denoted by a lower-case ! Gamma. Gamma is defined as ! ! Gamma = limit ( M -> Infinity ) ! ( Sum ( 1 <= N <= M ) 1 / N ) - Log ( M ) ! ! Modified: ! ! 27 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) EULER_CONSTANT, the value of the ! Euler-Mascheroni constant. ! implicit none real ( kind = 8 ) euler_constant euler_constant = 0.577215664901532860606512090082402431042D+00 return end subroutine exponential_01_cdf ( x, cdf ) !******************************************************************************* ! !! EXPONENTIAL_01_CDF evaluates the Exponential 01 CDF. ! ! Modified: ! ! 09 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x <= 0.0D+00 ) then cdf = 0.0D+00 else cdf = 1.0D+00 - exp ( - x ) end if return end subroutine exponential_01_cdf_inv ( cdf, x ) !******************************************************************************* ! !! EXPONENTIAL_01_CDF_INV inverts the Exponential 01 CDF. ! ! Modified: ! ! 09 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EXPONENTIAL_01_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = - log ( 1.0D+00 - cdf ) return end subroutine exponential_01_mean ( mean ) !******************************************************************************* ! !! EXPONENTIAL_01_MEAN returns the mean of the Exponential 01 PDF. ! ! Modified: ! ! 09 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) mean mean = 1.0D+00 return end subroutine exponential_01_pdf ( x, pdf ) !******************************************************************************* ! !! EXPONENTIAL_01_PDF evaluates the Exponential 01 PDF. ! ! Formula: ! ! PDF(X) = EXP ( - X ) ! ! Modified: ! ! 09 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x < 0.0D+00 ) then pdf = 0.0D+00 else pdf = exp ( - x ) end if return end subroutine exponential_01_sample ( seed, x ) !******************************************************************************* ! !! EXPONENTIAL_01_SAMPLE samples the Exponential PDF with parameter 1. ! ! Modified: ! ! 20 March 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) x = - log ( 1.0D+00 - cdf ) return end subroutine exponential_01_variance ( variance ) !******************************************************************************* ! !! EXPONENTIAL_01_VARIANCE returns the variance of the Exponential 01 PDF. ! ! Modified: ! ! 09 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) variance variance = 1.0D+00 return end subroutine exponential_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! EXPONENTIAL_CDF evaluates the Exponential CDF. ! ! Modified: ! ! 01 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameter of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x <= a ) then cdf = 0.0D+00 else cdf = 1.0D+00 - exp ( ( a - x ) / b ) end if return end subroutine exponential_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! EXPONENTIAL_CDF_INV inverts the Exponential CDF. ! ! Modified: ! ! 01 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EXPONENTIAL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = a - b * log ( 1.0D+00 - cdf ) return end subroutine exponential_cdf_values ( n_data, lambda, x, fx ) !******************************************************************************* ! !! EXPONENTIAL_CDF_VALUES returns some values of the Exponential CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = ExponentialDistribution [ lambda ] ! CDF [ dist, x ] ! ! Modified: ! ! 29 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) LAMBDA, the parameter of the distribution. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 9 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.3934693402873666D+00, & 0.6321205588285577D+00, & 0.7768698398515702D+00, & 0.8646647167633873D+00, & 0.8646647167633873D+00, & 0.9816843611112658D+00, & 0.9975212478233336D+00, & 0.9996645373720975D+00, & 0.9999546000702375D+00 /) real ( kind = 8 ) lambda real ( kind = 8 ), save, dimension ( n_max ) :: lambda_vec = (/ & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 lambda = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else lambda = lambda_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function exponential_check ( a, b ) !******************************************************************************* ! !! EXPONENTIAL_CHECK checks the parameters of the Exponential CDF. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameter of the PDF. ! 0.0D+00 < B. ! ! Output, logical EXPONENTIAL_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical exponential_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EXPONENTIAL_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.0' exponential_check = .false. return end if exponential_check = .true. return end subroutine exponential_mean ( a, b, mean ) !******************************************************************************* ! !! EXPONENTIAL_MEAN returns the mean of the Exponential PDF. ! ! Modified: ! ! 01 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a + b return end subroutine exponential_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! EXPONENTIAL_PDF evaluates the Exponential PDF. ! ! Formula: ! ! PDF(A,B;X) = ( 1 / B ) * EXP ( ( A - X ) / B ) ! ! Discussion: ! ! The time interval between two Poisson events is a random ! variable with the Exponential PDF. The parameter B is the ! average interval between events. ! ! In another context, the Exponential PDF is related to ! the Boltzmann distribution, which describes the relative ! probability of finding a system, which is in thermal equilibrium ! at absolute temperature T, in a given state having energy E. ! The relative probability is ! ! Boltzmann_Relative_Probability(E,T) = exp ( - E / ( k * T ) ), ! ! where k is the Boltzmann constant, ! ! k = 1.38 * 10**(-23) joules / degree Kelvin ! ! and normalization requires a determination of the possible ! energy states of the system. ! ! Modified: ! ! 01 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A <= X ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x < a ) then pdf = 0.0D+00 else pdf = ( 1.0D+00 / b ) * exp ( ( a - x ) / b ) end if return end subroutine exponential_sample ( a, b, seed, x ) !******************************************************************************* ! !! EXPONENTIAL_SAMPLE samples the Exponential PDF. ! ! Modified: ! ! 01 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call exponential_cdf_inv ( cdf, a, b, x ) return end subroutine exponential_variance ( a, b, variance ) !******************************************************************************* ! !! EXPONENTIAL_VARIANCE returns the variance of the Exponential PDF. ! ! Modified: ! ! 01 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = b * b return end subroutine extreme_values_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! EXTREME_VALUES_CDF evaluates the Extreme Values CDF. ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b cdf = exp ( - exp ( - y ) ) return end subroutine extreme_values_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! EXTREME_VALUES_CDF_INV inverts the Extreme Values CDF. ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EXTREME_VALUES_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = a - b * log ( - log ( cdf ) ) return end subroutine extreme_values_cdf_values ( n_data, alpha, beta, x, fx ) !******************************************************************************* ! !! EXTREME_VALUES_CDF_VALUES returns some values of the Extreme Values CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = ExtremeValuesDistribution [ alpha, beta ] ! CDF [ dist, x ] ! ! Modified: ! ! 05 September 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) ALPHA, the first parameter of the distribution. ! ! Output, real ( kind = 8 ) BETA, the second parameter of the distribution. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 12 real ( kind = 8 ) alpha real ( kind = 8 ), save, dimension ( n_max ) :: alpha_vec = (/ & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01 /) real ( kind = 8 ) beta real ( kind = 8 ), save, dimension ( n_max ) :: beta_vec = (/ & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.3678794411714423D+00, & 0.8734230184931166D+00, & 0.9818510730616665D+00, & 0.9975243173927525D+00, & 0.5452392118926051D+00, & 0.4884435800065159D+00, & 0.4589560693076638D+00, & 0.4409910259429826D+00, & 0.5452392118926051D+00, & 0.3678794411714423D+00, & 0.1922956455479649D+00, & 0.6598803584531254D-01 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 alpha = 0.0D+00 beta = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else alpha = alpha_vec(n_data) beta = beta_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function extreme_values_check ( a, b ) !******************************************************************************* ! !! EXTREME_VALUES_CHECK checks the parameters of the Extreme Values CDF. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, logical EXTREME_VALUES_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical extreme_values_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EXTREME_VALUES_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' extreme_values_check = .false. return end if extreme_values_check = .true. return end subroutine extreme_values_mean ( a, b, mean ) !******************************************************************************* ! !! EXTREME_VALUES_MEAN returns the mean of the Extreme Values PDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) euler_constant real ( kind = 8 ) mean mean = a + b * euler_constant ( ) return end subroutine extreme_values_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! EXTREME_VALUES_PDF evaluates the Extreme Values PDF. ! ! Formula: ! ! PDF(A,B;X) = ! ( 1 / B ) * exp ( ( A - X ) / B ) * exp ( - exp ( ( A - X ) / B ) ). ! ! Discussion: ! ! The Extreme Values PDF is also known as the Fisher-Tippet PDF ! and the Log-Weibull PDF. ! ! The special case A = 0 and B = 1 is the Gumbel PDF. ! ! The Extreme Values PDF is the limiting distribution for the ! smallest or largest value in a large sample drawn from ! any of a great variety of distributions. ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Eric Weisstein, editor, ! CRC Concise Encylopedia of Mathematics, ! CRC Press, 1998. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ) x pdf = ( 1.0D+00 / b ) * exp ( ( a - x ) / b - exp ( ( a - x ) / b ) ) return end subroutine extreme_values_sample ( a, b, seed, x ) !******************************************************************************* ! !! EXTREME_VALUES_SAMPLE samples the Extreme Values PDF. ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call extreme_values_cdf_inv ( cdf, a, b, x ) return end subroutine extreme_values_variance ( a, b, variance ) !******************************************************************************* ! !! EXTREME_VALUES_VARIANCE returns the variance of the Extreme Values PDF. ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) variance variance = pi * pi * b * b / 6.0D+00 return end subroutine f_cdf ( x, m, n, cdf ) !******************************************************************************* ! !! F_CDF evaluates the F central CDF. ! ! Modified: ! ! 31 May 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Formula 26.5.28 ! Abramowitz and Stegun, ! Handbook of Mathematical Functions. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, integer M, N, the parameters of the PDF. ! 1 <= M, ! 1 <= N. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) arg1 real ( kind = 8 ) arg2 real ( kind = 8 ) arg3 real ( kind = 8 ) beta_inc real ( kind = 8 ) cdf integer m integer n real ( kind = 8 ) x if ( x <= 0.0D+00 ) then cdf = 0.0D+00 else arg1 = 0.5D+00 * real ( n, kind = 8 ) arg2 = 0.5D+00 * real ( m, kind = 8 ) arg3 = real ( n, kind = 8 ) & / ( real ( n, kind = 8 ) + real ( m, kind = 8 ) * x ) cdf = 1.0D+00 - beta_inc ( arg1, arg2, arg3 ) end if return end subroutine f_cdf_values ( n_data, a, b, x, fx ) !******************************************************************************* ! !! F_CDF_VALUES returns some values of the F CDF test function. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = FRatioDistribution [ dfn, dfd ] ! CDF [ dist, x ] ! ! Modified: ! ! 11 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer A, integer B, the parameters of the function. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 20 integer a integer, save, dimension ( n_max ) :: a_vec = (/ & 1, & 1, & 5, & 1, & 2, & 4, & 1, & 6, & 8, & 1, & 3, & 6, & 1, & 1, & 1, & 1, & 2, & 3, & 4, & 5 /) integer b integer, save, dimension ( n_max ) :: b_vec = (/ & 1, & 5, & 1, & 5, & 10, & 20, & 5, & 6, & 16, & 5, & 10, & 12, & 5, & 5, & 5, & 5, & 5, & 5, & 5, & 5 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.5000000000000000D+00, & 0.4999714850534485D+00, & 0.4996034370170990D+00, & 0.7496993658293228D+00, & 0.7504656462757382D+00, & 0.7514156325324275D+00, & 0.8999867031372156D+00, & 0.8997127554259699D+00, & 0.9002845660853669D+00, & 0.9500248817817622D+00, & 0.9500574946122442D+00, & 0.9501926400000000D+00, & 0.9750133887312993D+00, & 0.9900022327445249D+00, & 0.9949977837872073D+00, & 0.9989999621122122D+00, & 0.5687988496283079D+00, & 0.5351452100063650D+00, & 0.5143428032407864D+00, & 0.5000000000000000D+00 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 1.00D+00, & 0.528D+00, & 1.89D+00, & 1.69D+00, & 1.60D+00, & 1.47D+00, & 4.06D+00, & 3.05D+00, & 2.09D+00, & 6.61D+00, & 3.71D+00, & 3.00D+00, & 10.01D+00, & 16.26D+00, & 22.78D+00, & 47.18D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 a = 0 b = 0 x = 0.0D+00 fx = 0.0D+00 else a = a_vec(n_data) b = b_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function f_check ( m, n ) !******************************************************************************* ! !! F_CHECK checks the parameters of the F PDF. ! ! Modified: ! ! 25 October 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the parameters of the PDF. ! 1 <= M, ! 1 <= N. ! ! Output, logical F_CHECK, is TRUE if the parameters are legal. ! implicit none logical f_check integer m integer n if ( m < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'F_CHECK - Fatal error!' write ( *, '(a)' ) ' M < 1.' f_check = .false. return end if if ( n < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'F_CHECK - Fatal error!' write ( *, '(a)' ) ' N < 1.' f_check = .false. return end if f_check = .true. return end subroutine f_mean ( m, n, mean ) !******************************************************************************* ! !! F_MEAN returns the mean of the F central PDF. ! ! Modified: ! ! 10 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the parameters of the PDF. ! 1 <= M, ! 1 <= N. ! Note, however, that the mean is not defined unless 3 <= N. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none integer m real ( kind = 8 ) mean integer n if ( n < 3 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'F_MEAN - Fatal error!' write ( *, '(a)' ) ' The mean is not defined for N < 3.' stop end if mean = real ( n, kind = 8 ) / real ( n - 2, kind = 8 ) return end subroutine f_pdf ( x, m, n, pdf ) !******************************************************************************* ! !! F_PDF evaluates the F central PDF. ! ! Formula: ! ! PDF(M,N;X) = M**(M/2) * X**((M-2)/2) ! / ( Beta(M/2,N/2) * N**(M/2) * ( 1 + (M/N) * X )**((M+N)/2) ! ! Modified: ! ! 13 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X ! ! Input, integer M, N, the parameters of the PDF. ! 1 <= M, ! 1 <= N. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) beta real ( kind = 8 ) bot1 real ( kind = 8 ) bot2 integer m integer n real ( kind = 8 ) pdf real ( kind = 8 ) top real ( kind = 8 ) x if ( x < 0.0D+00 ) then pdf = 0.0D+00 else a = real ( m, kind = 8 ) b = real ( n, kind = 8 ) top = sqrt ( a**m * b**n * x**( m - 2 ) ) bot1 = beta ( a / 2.0D+00, b / 2.0D+00 ) bot2 = sqrt ( ( b + a * x )**( m + n ) ) pdf = top / ( bot1 * bot2 ) end if return end subroutine f_sample ( m, n, seed, x ) !******************************************************************************* ! !! F_SAMPLE samples the F central PDF. ! ! Modified: ! ! 18 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the parameters of the PDF. ! 1 <= M, ! 1 <= N. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a integer m integer n integer seed real ( kind = 8 ) x real ( kind = 8 ) xm real ( kind = 8 ) xn a = real ( m, kind = 8 ) call chi_square_sample ( a, seed, xm ) a = real ( n, kind = 8 ) call chi_square_sample ( a, seed, xn ) x = real ( n, kind = 8 ) * xm / ( real ( m, kind = 8 ) * xn ) return end subroutine f_variance ( m, n, variance ) !******************************************************************************* ! !! F_VARIANCE returns the variance of the F central PDF. ! ! Modified: ! ! 10 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the parameters of the PDF. ! 1 <= M, ! 1 <= N. ! Note, however, that the variance is not defined unless 5 <= N. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none integer m integer n real ( kind = 8 ) variance if ( n < 5 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'F_VARIANCE - Fatal error!' write ( *, '(a)' ) ' The variance is not defined for N < 5.' stop end if variance = real ( 2 * n * n * ( m + n - 2 ), kind = 8 ) / & real ( m * ( n - 2 )**2 * ( n - 4 ), kind = 8 ) return end subroutine f_noncentral_cdf_values ( n_data, n1, n2, lambda, x, fx ) !******************************************************************************* ! !! F_NONCENTRAL_CDF_VALUES returns some values of the F CDF test function. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = NoncentralFRatioDistribution [ n1, n2, lambda ] ! CDF [ dist, x ] ! ! Modified: ! ! 30 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer N1, integer N2, the numerator and denominator ! degrees of freedom. ! ! Output, real ( kind = 8 ) LAMBDA, the noncentrality parameter. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 22 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.5000000000000000D+00, & 0.6367825323508774D+00, & 0.5840916116305482D+00, & 0.3234431872392788D+00, & 0.4501187879813550D+00, & 0.6078881441188312D+00, & 0.7059275551414605D+00, & 0.7721782003263727D+00, & 0.8191049017635072D+00, & 0.3170348430749965D+00, & 0.4327218008454471D+00, & 0.4502696915707327D+00, & 0.4261881186594096D+00, & 0.6753687206341544D+00, & 0.4229108778879005D+00, & 0.6927667261228938D+00, & 0.3632174676491226D+00, & 0.4210054012695865D+00, & 0.4266672258818927D+00, & 0.4464016600524644D+00, & 0.8445888579504827D+00, & 0.4339300273343604D+00 /) real ( kind = 8 ) lambda real ( kind = 8 ), save, dimension ( n_max ) :: lambda_vec = (/ & 0.00D+00, & 0.00D+00, & 0.25D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 2.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 2.00D+00, & 1.00D+00, & 1.00D+00, & 0.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00 /) integer n_data integer n1 integer, save, dimension ( n_max ) :: n1_vec = (/ & 1, 1, 1, 1, & 1, 1, 1, 1, & 1, 1, 2, 2, & 3, 3, 4, 4, & 5, 5, 6, 6, & 8, 16 /) integer n2 integer, save, dimension ( n_max ) :: n2_vec = (/ & 1, 5, 5, 5, & 5, 5, 5, 5, & 5, 5, 5, 10, & 5, 5, 5, 5, & 1, 5, 6, 12, & 16, 8 /) real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 1.00D+00, & 1.00D+00, & 1.00D+00, & 0.50D+00, & 1.00D+00, & 2.00D+00, & 3.00D+00, & 4.00D+00, & 5.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 2.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 2.00D+00, & 2.00D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 n1 = 0 n2 = 0 lambda = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else n1 = n1_vec(n_data) n2 = n2_vec(n_data) lambda = lambda_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function f_noncentral_check ( a, m, n ) !******************************************************************************* ! !! F_NONCENTRAL_CHECK checks the parameters of the F noncentral PDF. ! ! Modified: ! ! 30 October 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, a parameter of the PDF. ! ! Input, integer M, N, the parameters of the PDF. ! 1 <= M, ! 1 <= N. ! ! Output, logical F_NONCENTRAL_CHECK, is TRUE if the parameters are legal. ! implicit none real ( kind = 8 ) a logical f_noncentral_check integer m integer n if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'F_NONCENTRAL_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.' f_noncentral_check = .false. return end if if ( m < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'F_NONCENTRAL_CHECK - Fatal error!' write ( *, '(a)' ) ' M < 1.' f_noncentral_check = .false. return end if if ( n < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'F_NONCENTRAL_CHECK - Fatal error!' write ( *, '(a)' ) ' N < 1.' f_noncentral_check = .false. return end if f_noncentral_check = .true. return end subroutine f_noncentral_mean ( a, m, n, mean ) !******************************************************************************* ! !! F_NONCENTRAL_MEAN returns the mean of the F noncentral PDF. ! ! Modified: ! ! 26 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, a parameter of the PDF. ! ! Input, integer M, N, parameters of the PDF. ! 1 <= M, ! 1 <= N. ! Note, however, that the mean is not defined unless 3 <= N. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a integer m real ( kind = 8 ) mean integer n if ( n < 3 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'F_NONCENTRAL_MEAN - Fatal error!' write ( *, '(a)' ) ' The mean is not defined for N < 3.' stop end if mean = ( real ( m, kind = 8 ) + a ) * real ( n, kind = 8 ) & / ( real ( m, kind = 8 ) * real ( n - 2, kind = 8 ) ) return end subroutine f_noncentral_variance ( a, m, n, variance ) !******************************************************************************* ! !! F_NONCENTRAL_VARIANCE returns the variance of the F noncentral PDF. ! ! Modified: ! ! 26 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, a parameter of the PDF. ! ! Input, integer M, N, parameters of the PDF. ! 1 <= M, ! 1 <= N. ! Note, however, that the variance is not defined unless 5 <= N. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a integer m real ( kind = 8 ) mr integer n real ( kind = 8 ) nr real ( kind = 8 ) variance if ( n < 5 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'F_NONCENTRAL_VARIANCE - Fatal error!' write ( *, '(a)' ) ' The variance is not defined for N < 5.' stop end if mr = real ( m, kind = 8 ) nr = real ( n, kind = 8 ) variance = ( ( mr + a )**2 + 2.0D+00 * ( mr + a ) * nr**2 ) & / ( ( nr - 2.0D+00 ) * ( nr - 4.0D+00 ) * mr**2 ) - & ( mr + a )**2 * nr**2 / ( ( nr - 2.0D+00 )**2 * mr**2 ) return end function factorial_log ( n ) !******************************************************************************* ! !! FACTORIAL_LOG returns the logarithm of N!. ! ! Definition: ! ! N! = Product ( 1 <= I <= N ) I ! ! Method: ! ! N! = Gamma(N+1). ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the argument of the function. ! 0 <= N. ! ! Output, real ( kind = 8 ) FACTORIAL_LOG, the logarithm of N!. ! implicit none real ( kind = 8 ) factorial_log integer i integer n if ( n < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACTORIAL_LOG - Fatal error!' write ( *, '(a)' ) ' N < 0.' stop end if factorial_log = 0.0D+00 do i = 2, n factorial_log = factorial_log + log ( real ( i, kind = 8 ) ) end do return end function factorial_stirling ( n ) !******************************************************************************* ! !! FACTORIAL_STIRLING computes Stirling's approximation to N!. ! ! Definition: ! ! N! = Product ( 1 <= I <= N ) I ! ! Stirling ( N ) = sqrt ( 2 * PI * N ) * ( N / E )**N * E**(1/(12*N) ) ! ! Discussion: ! ! This routine returns the raw approximation for all nonnegative ! values of N. If N is less than 0, the value is returned as 0, ! and if N is 0, the value of 1 is returned. In all other cases, ! Stirling's formula is used. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the argument of the function. ! ! Output, real ( kind = 8 ) FACTORIAL_STIRLING, an approximation to N!. ! implicit none real ( kind = 8 ), parameter :: e_natural = & 2.71828182845904523536028747135266249775724709369995 real ( kind = 8 ) factorial_stirling integer n real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) value if ( n < 0 ) then value = 0.0D+00 else if ( n == 0 ) then value = 1.0D+00 else value = sqrt ( 2.0D+00 * pi * real ( n, kind = 8 ) ) & * ( real ( n, kind = 8 ) / e_natural )**n & * exp ( 1.0D+00 / real ( 12 * n, kind = 8 ) ) end if factorial_stirling = value return end subroutine fisk_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! FISK_CDF evaluates the Fisk CDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x <= a ) then cdf = 0.0D+00 else cdf = 1.0D+00 / ( 1.0D+00 + ( b / ( x - a ) )**c ) end if return end subroutine fisk_cdf_inv ( cdf, a, b, c, x ) !******************************************************************************* ! !! FISK_CDF_INV inverts the Fisk CDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FISK_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf <= 0.0D+00 ) then x = a else if ( cdf < 1.0D+00 ) then x = a + b * ( cdf / ( 1.0D+00 - cdf ) )**( 1.0D+00 / c ) else if ( 1.0D+00 <= cdf ) then x = huge ( x ) end if return end function fisk_check ( a, b, c ) !******************************************************************************* ! !! FISK_CHECK checks the parameters of the Fisk PDF. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, logical FISK_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c logical fisk_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FISK_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' fisk_check = .false. return end if if ( c <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FISK_CHECK - Fatal error!' write ( *, '(a)' ) ' C <= 0.' fisk_check = .false. return end if fisk_check = .true. return end subroutine fisk_mean ( a, b, c, mean ) !******************************************************************************* ! !! FISK_MEAN returns the mean of the Fisk PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) csc real ( kind = 8 ) mean real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 if ( c <= 1.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FISK_MEAN - Fatal error!' write ( *, '(a)' ) ' No mean defined for C <= 1.0' stop end if mean = a + pi * ( b / c ) * csc ( pi / c ) return end subroutine fisk_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! FISK_PDF evaluates the Fisk PDF. ! ! Formula: ! ! PDF(A,B,C;X) = ! ( C / B ) * ( ( X - A ) / B )**( C - 1 ) / ! ( 1 + ( ( X - A ) / B )**C )**2 ! ! Discussion: ! ! The Fisk PDF is also known as the Log Logistic PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A <= X ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) pdf real ( kind = 8 ) x real ( kind = 8 ) y if ( x <= a ) then pdf = 0.0D+00 else y = ( x - a ) / b pdf = ( c / b ) * y**( c - 1.0D+00 ) / ( 1.0D+00 + y**c )**2 end if return end subroutine fisk_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! FISK_SAMPLE samples the Fisk PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call fisk_cdf_inv ( cdf, a, b, c, x ) return end subroutine fisk_variance ( a, b, c, variance ) !******************************************************************************* ! !! FISK_VARIANCE returns the variance of the Fisk PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) csc real ( kind = 8 ) g real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) variance if ( c <= 2.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FISK_VARIANCE - Fatal error!' write ( *, '(a)' ) ' No variance defined for C <= 2.0' stop end if g = pi / c variance = b * b & * ( 2.0D+00 * g * csc ( 2.0D+00 * g ) - ( g * csc ( g ) )**2 ) return end subroutine folded_normal_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! FOLDED_NORMAL_CDF evaluates the Folded Normal CDF. ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! 0.0D+00 <= X. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 <= A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cdf1 real ( kind = 8 ) cdf2 real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 if ( x < 0.0D+00 ) then cdf = 0.0D+00 else x1 = ( x - a ) / b call normal_01_cdf ( x1, cdf1 ) x2 = ( - x - a ) / b call normal_01_cdf ( x2, cdf2 ) cdf = cdf1 - cdf2 end if return end subroutine folded_normal_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! FOLDED_NORMAL_CDF_INV inverts the Folded Normal CDF. ! ! Modified: ! ! 01 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 <= A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the argument of the CDF. ! 0.0D+00 <= X. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cdf1 real ( kind = 8 ) cdf2 real ( kind = 8 ) cdf3 integer it integer, parameter :: it_max = 100 real ( kind = 8 ), parameter :: tol = 0.0001D+00 real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 real ( kind = 8 ) x3 real ( kind = 8 ) xa real ( kind = 8 ) xb if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FOLDED_NORMAL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = 0.0D+00 return else if ( 1.0D+00 == cdf ) then x = huge ( x ) return end if ! ! Find X1, for which the value of CDF will be too small. ! if ( 0.0D+00 <= a ) then call normal_cdf_inv ( cdf, a, b, x1 ) else call normal_cdf_inv ( cdf, -a, b, x1 ) end if x1 = max ( x1, 0.0D+00 ) call folded_normal_cdf ( x1, a, b, cdf1 ) ! ! Find X2, for which the value of CDF will be too big. ! cdf2 = ( 1.0D+00 - cdf ) / 2.0D+00 call normal_cdf_inv ( cdf2, a, b, xa ) call normal_cdf_inv ( cdf2, -a, b, xb ) x2 = max ( abs ( xa ), abs ( xb ) ) call folded_normal_cdf ( x2, a, b, cdf2 ) ! ! Now use bisection. ! it = 0 do it = it + 1 x3 = 0.5D+00 * ( x1 + x2 ) call folded_normal_cdf ( x3, a, b, cdf3 ) if ( abs ( cdf3 - cdf ) < tol ) then x = x3 exit end if if ( it_max < it ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FOLDED_NORMAL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' Iteration limit exceeded.' stop end if if ( sign ( 1.0D+00, cdf3 - cdf ) == sign ( 1.0D+00, cdf1 - cdf ) ) then x1 = x3 cdf1 = cdf3 else x2 = x3 cdf2 = cdf3 end if end do return end function folded_normal_check ( a, b ) !******************************************************************************* ! !! FOLDED_NORMAL_CHECK checks the parameters of the Folded Normal CDF. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 <= A, ! 0.0D+00 < B. ! ! Output, logical FOLDED_NORMAL_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical folded_normal_check if ( a < 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FOLDED_NORMAL_CHECK - Fatal error!' write ( *, '(a)' ) ' A < 0.' folded_normal_check = .false. return end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FOLDED_NORMAL_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' folded_normal_check = .false. return end if folded_normal_check = .true. return end subroutine folded_normal_mean ( a, b, mean ) !******************************************************************************* ! !! FOLDED_NORMAL_MEAN returns the mean of the Folded Normal PDF. ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 <= A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a2 real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) mean real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 a2 = a / b call normal_01_cdf ( a2, cdf ) mean = b * sqrt ( 2.0D+00 / PI ) * exp ( - 0.5D+00 * a2 * a2 ) & - a * ( 1.0D+00 - 2.0D+00 * cdf ) return end subroutine folded_normal_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! FOLDED_NORMAL_PDF evaluates the Folded Normal PDF. ! ! Formula: ! ! PDF(A;X) = sqrt ( 2 / PI ) * ( 1 / B ) * cosh ( A * X / B**2 ) ! * exp ( - 0.5D+00 * ( X**2 + A**2 ) / B**2 ) ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 <= A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( x < 0.0D+00 ) then pdf = 0.0D+00 else pdf = sqrt ( 2.0D+00 / PI ) * ( 1.0D+00 / b ) * cosh ( a * x / b**2 ) & * exp ( - 0.5D+00 * ( x * x + a * a ) / b**2 ) end if return end subroutine folded_normal_sample ( a, b, seed, x ) !******************************************************************************* ! !! FOLDED_NORMAL_SAMPLE samples the Folded Normal PDF. ! ! Modified: ! ! 13 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 <= A, ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call folded_normal_cdf_inv ( cdf, a, b, x ) return end subroutine folded_normal_variance ( a, b, variance ) !******************************************************************************* ! !! FOLDED_NORMAL_VARIANCE returns the variance of the Folded Normal PDF. ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 <= A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean real ( kind = 8 ) variance call folded_normal_mean ( a, b, mean ) variance = a * a + b * b - mean * mean return end function gamma ( x ) !******************************************************************************* ! !! GAMMA calculates the Gamma function for a real argument X. ! ! ! Definition: ! ! GAMMA(X) = Integral ( 0 <= T <= Infinity ) T**(X-1) EXP(-T) DT ! ! Recursion: ! ! GAMMA(X+1) = X * GAMMA(X) ! ! Special values: ! ! GAMMA(0.5) = sqrt(PI) ! If N is a positive integer, GAMMA(N+1) = N!, the standard factorial. ! ! Discussion: ! ! Computation is based on an algorithm outlined in reference 1. ! The program uses rational functions that approximate the GAMMA ! function to at least 20 significant decimal digits. Coefficients ! for the approximation over the interval (1,2) are unpublished. ! Those for the approximation for X .GE. 12 are from reference 2. ! The accuracy achieved depends on the arithmetic system, the ! compiler, the intrinsic functions, and proper selection of the ! machine dependent constants. ! ! Machine dependent constants: ! ! BETA: radix for the floating-point representation. ! MAXEXP: the smallest positive power of BETA that overflows. ! XBIG: the largest argument for which GAMMA(X) is representable ! in the machine, i.e., the solution to the equation ! GAMMA(XBIG) = BETA**MAXEXP. ! XMININ: the smallest positive floating-point number such that ! 1/XMININ is machine representable. ! ! Approximate values for some important machines are: ! ! BETA MAXEXP XBIG ! ! CRAY-1 (S.P.) 2 8191 966.961 ! Cyber 180/855 ! under NOS (S.P.) 2 1070 177.803 ! IEEE (IBM/XT, ! SUN, etc.) (S.P.) 2 128 35.040 ! IEEE (IBM/XT, ! SUN, etc.) (D.P.) 2 1024 171.624 ! IBM 3033 (D.P.) 16 63 57.574 ! VAX D-Format (D.P.) 2 127 34.844 ! VAX G-Format (D.P.) 2 1023 171.489 ! ! XMININ ! ! CRAY-1 (S.P.) 1.84D-2466 ! Cyber 180/855 ! under NOS (S.P.) 3.14D-294 ! IEEE (IBM/XT, ! SUN, etc.) (S.P.) 1.18D-38 ! IEEE (IBM/XT, ! SUN, etc.) (D.P.) 2.23D-308 ! IBM 3033 (D.P.) 1.39D-76 ! VAX D-Format (D.P.) 5.88D-39 ! VAX G-Format (D.P.) 1.12D-308 ! ! Author: ! ! W. J. Cody and L. Stoltz, ! Applied Mathematics Division, ! Argonne National Laboratory, ! Argonne, Illinois, 60439. ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! W J Cody, ! "An Overview of Software Development for Special Functions", ! Lecture Notes in Mathematics, 506, ! Numerical Analysis Dundee, 1975, ! G. A. Watson (ed.), ! Springer Verlag, Berlin, 1976. ! ! Hart, Cheney, Lawson, Maehly, Mesztenyi, Rice, Thacher, Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) GAMMA, the value of the function. ! The computation is believed to be free of underflow and overflow. ! implicit none real ( kind = 8 ), parameter, dimension ( 7 ) :: c = (/ & -1.910444077728D-03, & 8.4171387781295D-04, & -5.952379913043012D-04, & 7.93650793500350248D-04, & -2.777777777777681622553D-03, & 8.333333333333333331554247D-02, & 5.7083835261D-03 /) real ( kind = 8 ) fact real ( kind = 8 ) gamma integer i integer n real ( kind = 8 ), parameter, dimension ( 8 ) :: p = (/ & -1.71618513886549492533811D+00, & 2.47656508055759199108314D+01, & -3.79804256470945635097577D+02, & 6.29331155312818442661052D+02, & 8.66966202790413211295064D+02, & -3.14512729688483675254357D+04, & -3.61444134186911729807069D+04, & 6.64561438202405440627855D+04 /) logical parity real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ), parameter, dimension ( 8 ) :: q = (/ & -3.08402300119738975254353D+01, & 3.15350626979604161529144D+02, & -1.01515636749021914166146D+03, & -3.10777167157231109440444D+03, & 2.25381184209801510330112D+04, & 4.75584627752788110767815D+03, & -1.34659959864969306392456D+05, & -1.15132259675553483497211D+05 /) real ( kind = 8 ), parameter :: sqrtpi = 0.9189385332046727417803297D+00 real ( kind = 8 ) sum2 real ( kind = 8 ) x real ( kind = 8 ), parameter :: xbig = 35.040D+00 real ( kind = 8 ) xden real ( kind = 8 ), parameter :: xminin = 1.18D-38 real ( kind = 8 ) xnum real ( kind = 8 ) y real ( kind = 8 ) y1 real ( kind = 8 ) ysq real ( kind = 8 ) z parity = .false. fact = 1.0D+00 n = 0 y = x ! ! Argument is negative. ! if ( y <= 0.0D+00 ) then y = - x y1 = real ( int ( y ), kind = 8 ) gamma = y - y1 if ( gamma /= 0.0D+00 ) then if ( y1 /= 2.0D+00 * real ( int ( y1 * 0.5D+00 ), kind = 8 ) ) then parity = .true. end if fact = - pi / sin ( pi * gamma ) y = y + 1.0D+00 else gamma = huge ( gamma ) return end if end if ! ! Argument < EPS ! if ( y < epsilon ( y ) ) then if ( xminin <= y ) then gamma = 1.0D+00 / y else gamma = huge ( gamma ) return end if else if ( y < 12.0D+00 ) then y1 = y ! ! 0.0D+00 < argument < 1.0D+00 ! if ( y < 1.0D+00 ) then z = y y = y + 1.0D+00 ! ! 1.0D+00 < argument < 12.0D+00, reduce argument if necessary. ! else n = int ( y ) - 1 y = y - real ( n, kind = 8 ) z = y - 1.0D+00 end if ! ! Evaluate approximation for 1.0D+00 < argument < 2.0. ! xnum = 0.0D+00 xden = 1.0D+00 do i = 1, 8 xnum = ( xnum + p(i) ) * z xden = xden * z + q(i) end do gamma = xnum / xden + 1.0D+00 ! ! Adjust result for case 0.0D+00 < argument < 1.0. ! if ( y1 < y ) then gamma = gamma / y1 ! ! Adjust result for case 2.0D+00 < argument < 12.0. ! else if ( y < y1 ) then do i = 1, n gamma = gamma * y y = y + 1.0D+00 end do end if ! ! Evaluate for 12 <= argument. ! else if ( y <= xbig ) then ysq = y * y sum2 = c(7) do i = 1, 6 sum2 = sum2 / ysq + c(i) end do sum2 = sum2 / y - y + sqrtpi sum2 = sum2 + ( y - 0.5D+00 ) * log ( y ) gamma = exp ( sum2 ) else gamma = huge ( gamma ) return end if end if ! ! Final adjustments and return. ! if ( parity ) then gamma = - gamma end if if ( fact /= 1.0D+00 ) then gamma = fact / gamma end if return end subroutine gamma_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! GAMMA_CDF evaluates the Gamma CDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A <= X ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) gamma_inc real ( kind = 8 ) p2 real ( kind = 8 ) x real ( kind = 8 ) x2 x2 = ( x - a ) / b p2 = c cdf = gamma_inc ( p2, x2 ) return end subroutine gamma_cdf_values ( n_data, mu, sigma, x, fx ) !******************************************************************************* ! !! GAMMA_CDF_VALUES returns some values of the Gamma CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = GammaDistribution [ mu, sigma ] ! CDF [ dist, x ] ! ! Modified: ! ! 05 September 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) MU, the mean of the distribution. ! ! Output, real ( kind = 8 ) SIGMA, the variance of the distribution. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 12 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.8646647167633873D+00, & 0.9816843611112658D+00, & 0.9975212478233336D+00, & 0.9996645373720975D+00, & 0.6321205588285577D+00, & 0.4865828809674080D+00, & 0.3934693402873666D+00, & 0.3296799539643607D+00, & 0.4421745996289254D+00, & 0.1911531694619419D+00, & 0.6564245437845009D-01, & 0.1857593622214067D-01 /) real ( kind = 8 ) mu real ( kind = 8 ), save, dimension ( n_max ) :: mu_vec = (/ & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01 /) integer n_data real ( kind = 8 ) sigma real ( kind = 8 ), save, dimension ( n_max ) :: sigma_vec = (/ & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01 /) real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 mu = 0.0D+00 sigma = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else mu = mu_vec(n_data) sigma = sigma_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function gamma_check ( a, b, c ) !******************************************************************************* ! !! GAMMA_CHECK checks the parameters of the Gamma PDF. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, logical GAMMA_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c logical gamma_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GAMMA_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' write ( *, '(a,g14.6)' ) ' B = ', b gamma_check = .false. return end if if ( c <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GAMMA_CHECK - Fatal error!' write ( *, '(a)' ) ' C <= 0.' write ( *, '(a,g14.6)' ) ' C = ', c gamma_check = .false. return end if gamma_check = .true. return end function gamma_inc ( p, x ) !******************************************************************************* ! !! GAMMA_INC computes the incomplete Gamma function. ! ! Definition: ! ! GAMMA_INC(P,X) = Integral ( 0 <= T <= X ) T**(P-1) EXP(-T) DT / GAMMA(P). ! ! Discussion: ! ! GAMMA_INC(P, 0) = 0, ! GAMMA_INC(P,Infinity) = 1. ! ! Modified: ! ! 01 May 2001 ! ! Author: ! ! B L Shea ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! B L Shea, ! Chi-squared and Incomplete Gamma Integral, ! Algorithm AS239, ! Applied Statistics, ! Volume 37, Number 3, 1988, pages 466-473. ! ! Parameters: ! ! Input, real ( kind = 8 ) P, the exponent parameter. ! 0.0D+00 < P. ! ! Input, real ( kind = 8 ) X, the integral limit parameter. ! If X is less than or equal to 0, GAMMA_INC is returned as 0. ! ! Output, real ( kind = 8 ) GAMMA_INC, the value of the function. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) arg real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: exp_arg_min = -88.0D+00 real ( kind = 8 ) gamma_inc real ( kind = 8 ) gamma_log real ( kind = 8 ), parameter :: overflow = 1.0D+37 real ( kind = 8 ) p real ( kind = 8 ), parameter :: plimit = 1000.0D+00 real ( kind = 8 ) pn1 real ( kind = 8 ) pn2 real ( kind = 8 ) pn3 real ( kind = 8 ) pn4 real ( kind = 8 ) pn5 real ( kind = 8 ) pn6 real ( kind = 8 ) rn real ( kind = 8 ), parameter :: tol = 1.0D-07 real ( kind = 8 ) x real ( kind = 8 ), parameter :: xbig = 1.0D+08 gamma_inc = 0.0D+00 if ( p <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GAMMA_INC - Fatal error!' write ( *, '(a)' ) ' Parameter P <= 0.' stop end if if ( x <= 0.0D+00 ) then gamma_inc = 0.0D+00 return end if ! ! Use a normal approximation if PLIMIT < P. ! if ( plimit < p ) then pn1 = 3.0D+00 * sqrt ( p ) * ( ( x / p ) ** ( 1.0D+00 / 3.0D+00 ) & + 1.0D+00 / ( 9.0D+00 * p ) - 1.0D+00 ) call normal_01_cdf ( pn1, cdf ) gamma_inc = cdf return end if ! ! Is X extremely large compared to P? ! if ( xbig < x ) then gamma_inc = 1.0D+00 return end if ! ! Use Pearson's series expansion. ! (P is not large enough to force overflow in the log of Gamma. ! if ( x <= 1.0D+00 .or. x < p ) then arg = p * log ( x ) - x - gamma_log ( p + 1.0D+00 ) c = 1.0D+00 gamma_inc = 1.0D+00 a = p do a = a + 1.0D+00 c = c * x / a gamma_inc = gamma_inc + c if ( c <= tol ) then exit end if end do arg = arg + log ( gamma_inc ) if ( exp_arg_min <= arg ) then gamma_inc = exp ( arg ) else gamma_inc = 0.0D+00 end if else ! ! Use a continued fraction expansion. ! arg = p * log ( x ) - x - gamma_log ( p ) a = 1.0D+00 - p b = a + x + 1.0D+00 c = 0.0D+00 pn1 = 1.0D+00 pn2 = x pn3 = x + 1.0D+00 pn4 = x * b gamma_inc = pn3 / pn4 do a = a + 1.0D+00 b = b + 2.0D+00 c = c + 1.0D+00 pn5 = b * pn3 - a * c * pn1 pn6 = b * pn4 - a * c * pn2 if ( 0.0D+00 < abs ( pn6 ) ) then rn = pn5 / pn6 if ( abs ( gamma_inc - rn ) <= min ( tol, tol * rn ) ) then arg = arg + log ( gamma_inc ) if ( exp_arg_min <= arg ) then gamma_inc = 1.0D+00 - exp ( arg ) else gamma_inc = 1.0D+00 end if return end if gamma_inc = rn end if pn1 = pn3 pn2 = pn4 pn3 = pn5 pn4 = pn6 ! ! Rescale terms in continued fraction if terms are large. ! if ( overflow <= abs ( pn5 ) ) then pn1 = pn1 / overflow pn2 = pn2 / overflow pn3 = pn3 / overflow pn4 = pn4 / overflow end if end do end if return end subroutine gamma_inc_values ( n_data, a, x, fx ) !******************************************************************************* ! !! GAMMA_INC_VALUES returns some values of the incomplete Gamma function. ! ! Discussion: ! ! The (normalized) incomplete Gamma function P(A,X) is defined as: ! ! PN(A,X) = 1/Gamma(A) * Integral ( 0 <= T <= X ) T**(A-1) * exp(-T) dT. ! ! With this definition, for all A and X, ! ! 0 <= PN(A,X) <= 1 ! ! and ! ! PN(A,INFINITY) = 1.0 ! ! In Mathematica, the function can be evaluated by: ! ! 1 - GammaRegularized[A,X] ! ! Modified: ! ! 20 November 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) A, the parameter of the function. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 20 real ( kind = 8 ) a real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ & 0.10D+00, & 0.10D+00, & 0.10D+00, & 0.50D+00, & 0.50D+00, & 0.50D+00, & 0.10D+01, & 0.10D+01, & 0.10D+01, & 0.11D+01, & 0.11D+01, & 0.11D+01, & 0.20D+01, & 0.20D+01, & 0.20D+01, & 0.60D+01, & 0.60D+01, & 0.11D+02, & 0.26D+02, & 0.41D+02 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.7382350532339351D+00, & 0.9083579897300343D+00, & 0.9886559833621947D+00, & 0.3014646416966613D+00, & 0.7793286380801532D+00, & 0.9918490284064973D+00, & 0.9516258196404043D-01, & 0.6321205588285577D+00, & 0.9932620530009145D+00, & 0.7205974576054322D-01, & 0.5891809618706485D+00, & 0.9915368159845525D+00, & 0.1018582711118352D-01, & 0.4421745996289254D+00, & 0.9927049442755639D+00, & 0.4202103819530612D-01, & 0.9796589705830716D+00, & 0.9226039842296429D+00, & 0.4470785799755852D+00, & 0.7444549220718699D+00 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.30D-01, & 0.30D+00, & 0.15D+01, & 0.75D-01, & 0.75D+00, & 0.35D+01, & 0.10D+00, & 0.10D+01, & 0.50D+01, & 0.10D+00, & 0.10D+01, & 0.50D+01, & 0.15D+00, & 0.15D+01, & 0.70D+01, & 0.25D+01, & 0.12D+02, & 0.16D+02, & 0.25D+02, & 0.45D+02 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 a = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else a = a_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function gamma_log ( x ) !******************************************************************************* ! !! GAMMA_LOG calculates the natural logarithm of GAMMA ( X ). ! ! Discussion: ! ! Computation is based on an algorithm outlined in references 1 and 2. ! The program uses rational functions that theoretically approximate ! LOG(GAMMA(X)) to at least 18 significant decimal digits. The ! approximation for 12 < X is from Hart et al, while approximations ! for X < 12.0D+00 are similar to those in Cody and Hillstrom, ! but are unpublished. ! ! The accuracy achieved depends on the arithmetic system, the compiler, ! intrinsic functions, and proper selection of the machine dependent ! constants. ! ! Modified: ! ! 16 June 1999 ! ! Author: ! ! W. J. Cody and L. Stoltz ! Argonne National Laboratory ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! W. J. Cody and Kenneth Hillstrom, ! Chebyshev Approximations for the Natural Logarithm of the Gamma Function, ! Mathematics of Computation, ! Volume 21, 1967, pages 198-203. ! ! Kenneth Hillstrom, ! ANL/AMD Program ANLC366S, DGAMMA/DLGAMA, ! May 1969. ! ! Hart, Cheney, Lawson, Maehly, Mesztenyi, Rice, Thacher, Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the Gamma function. ! X must be positive. ! ! Output, real ( kind = 8 ) GAMMA_LOG, the logarithm of the Gamma ! function of X. ! ! Local Parameters: ! ! Local, real ( kind = 8 ) BETA, the radix for the floating-point ! representation. ! ! Local, integer MAXEXP, the smallest positive power of BETA that overflows. ! ! Local, real ( kind = 8 ) XBIG, the largest argument for which ! LN(GAMMA(X)) is representable in the machine, the solution to the equation ! LN(GAMMA(XBIG)) = BETA**MAXEXP. ! ! Local, real ( kind = 8 ) FRTBIG, a rough estimate of the fourth root ! of XBIG. ! ! Approximate values for some important machines are: ! ! BETA MAXEXP XBIG FRTBIG ! ! CRAY-1 (S.P.) 2 8191 9.62D+2461 3.13D+615 ! Cyber 180/855 (S.P.) 2 1070 1.72D+319 6.44D+79 ! IEEE (IBM/XT) (S.P.) 2 128 4.08D+36 1.42D+9 ! IEEE (IBM/XT) (D.P.) 2 1024 2.55D+305 2.25D+76 ! IBM 3033 (D.P.) 16 63 4.29D+73 2.56D+18 ! VAX D-Format (D.P.) 2 127 2.05D+36 1.20D+9 ! VAX G-Format (D.P.) 2 1023 1.28D+305 1.89D+76 ! implicit none real ( kind = 8 ), parameter, dimension ( 7 ) :: c = (/ & -1.910444077728D-03, & 8.4171387781295D-04, & -5.952379913043012D-04, & 7.93650793500350248D-04, & -2.777777777777681622553D-03, & 8.333333333333333331554247D-02, & 5.7083835261D-03 /) real ( kind = 8 ) corr real ( kind = 8 ), parameter :: d1 = -5.772156649015328605195174D-01 real ( kind = 8 ), parameter :: d2 = 4.227843350984671393993777D-01 real ( kind = 8 ), parameter :: d4 = 1.791759469228055000094023D+00 integer i real ( kind = 8 ), parameter :: frtbig = 1.42D+09 real ( kind = 8 ) gamma_log real ( kind = 8 ), parameter, dimension ( 8 ) :: p1 = (/ & 4.945235359296727046734888D+00, & 2.018112620856775083915565D+02, & 2.290838373831346393026739D+03, & 1.131967205903380828685045D+04, & 2.855724635671635335736389D+04, & 3.848496228443793359990269D+04, & 2.637748787624195437963534D+04, & 7.225813979700288197698961D+03 /) real ( kind = 8 ), parameter, dimension ( 8 ) :: p2 = (/ & 4.974607845568932035012064D+00, & 5.424138599891070494101986D+02, & 1.550693864978364947665077D+04, & 1.847932904445632425417223D+05, & 1.088204769468828767498470D+06, & 3.338152967987029735917223D+06, & 5.106661678927352456275255D+06, & 3.074109054850539556250927D+06 /) real ( kind = 8 ), parameter, dimension ( 8 ) :: p4 = (/ & 1.474502166059939948905062D+04, & 2.426813369486704502836312D+06, & 1.214755574045093227939592D+08, & 2.663432449630976949898078D+09, & 2.940378956634553899906876D+10, & 1.702665737765398868392998D+11, & 4.926125793377430887588120D+11, & 5.606251856223951465078242D+11 /) real ( kind = 8 ), parameter :: pnt68 = 0.6796875D+00 real ( kind = 8 ), parameter, dimension ( 8 ) :: q1 = (/ & 6.748212550303777196073036D+01, & 1.113332393857199323513008D+03, & 7.738757056935398733233834D+03, & 2.763987074403340708898585D+04, & 5.499310206226157329794414D+04, & 6.161122180066002127833352D+04, & 3.635127591501940507276287D+04, & 8.785536302431013170870835D+03 /) real ( kind = 8 ), parameter, dimension ( 8 ) :: q2 = (/ & 1.830328399370592604055942D+02, & 7.765049321445005871323047D+03, & 1.331903827966074194402448D+05, & 1.136705821321969608938755D+06, & 5.267964117437946917577538D+06, & 1.346701454311101692290052D+07, & 1.782736530353274213975932D+07, & 9.533095591844353613395747D+06 /) real ( kind = 8 ), parameter, dimension ( 8 ) :: q4 = (/ & 2.690530175870899333379843D+03, & 6.393885654300092398984238D+05, & 4.135599930241388052042842D+07, & 1.120872109616147941376570D+09, & 1.488613728678813811542398D+10, & 1.016803586272438228077304D+11, & 3.417476345507377132798597D+11, & 4.463158187419713286462081D+11 /) real ( kind = 8 ) res real ( kind = 8 ), parameter :: sqrtpi = 0.9189385332046727417803297D+00 real ( kind = 8 ) x real ( kind = 8 ), parameter :: xbig = 4.08D+36 real ( kind = 8 ) xden real ( kind = 8 ) xm1 real ( kind = 8 ) xm2 real ( kind = 8 ) xm4 real ( kind = 8 ) xnum real ( kind = 8 ) xsq ! ! Return immediately if the argument is out of range. ! if ( x <= 0.0D+00 .or. xbig < x ) then gamma_log = huge ( gamma_log ) return end if if ( x <= epsilon ( x ) ) then res = -log ( x ) else if ( x <= 1.5D+00 ) then if ( x < pnt68 ) then corr = - log ( x ) xm1 = x else corr = 0.0D+00 xm1 = ( x - 0.5D+00 ) - 0.5D+00 end if if ( x <= 0.5D+00 .or. pnt68 <= x ) then xden = 1.0D+00 xnum = 0.0D+00 do i = 1, 8 xnum = xnum * xm1 + p1(i) xden = xden * xm1 + q1(i) end do res = corr + ( xm1 * ( d1 + xm1 * ( xnum / xden ) ) ) else xm2 = ( x - 0.5D+00 ) - 0.5D+00 xden = 1.0D+00 xnum = 0.0D+00 do i = 1, 8 xnum = xnum * xm2 + p2(i) xden = xden * xm2 + q2(i) end do res = corr + xm2 * ( d2 + xm2 * ( xnum / xden ) ) end if else if ( x <= 4.0D+00 ) then xm2 = x - 2.0D+00 xden = 1.0D+00 xnum = 0.0D+00 do i = 1, 8 xnum = xnum * xm2 + p2(i) xden = xden * xm2 + q2(i) end do res = xm2 * ( d2 + xm2 * ( xnum / xden ) ) else if ( x <= 12.0D+00 ) then xm4 = x - 4.0D+00 xden = - 1.0D+00 xnum = 0.0D+00 do i = 1, 8 xnum = xnum * xm4 + p4(i) xden = xden * xm4 + q4(i) end do res = d4 + xm4 * ( xnum / xden ) else res = 0.0D+00 if ( x <= frtbig ) then res = c(7) xsq = x * x do i = 1, 6 res = res / xsq + c(i) end do end if res = res / x corr = log ( x ) res = res + sqrtpi - 0.5D+00 * corr res = res + x * ( corr - 1.0D+00 ) end if gamma_log = res return end function gamma_log_int ( n ) !******************************************************************************* ! !! GAMMA_LOG_INT computes the logarithm of Gamma of an integer N. ! ! Modified: ! ! 08 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the argument of the logarithm of the Gamma function. ! 0 < N. ! ! Output, real ( kind = 8 ) GAMMA_LOG_INT, the logarithm of ! the Gamma function of N. ! implicit none real ( kind = 8 ) gamma_log real ( kind = 8 ) gamma_log_int integer n if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GAMMA_LOG_INT - Fatal error!' write ( *, '(a,i)' ) ' Illegal input value of N = ', n write ( *, '(a)' ) ' But N must be strictly positive.' stop end if gamma_log_int = gamma_log ( real ( n, kind = 8 ) ) return end subroutine gamma_mean ( a, b, c, mean ) !******************************************************************************* ! !! GAMMA_MEAN returns the mean of the Gamma PDF. ! ! Modified: ! ! 12 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) mean mean = a + b * c return end subroutine gamma_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! GAMMA_PDF evaluates the Gamma PDF. ! ! Formula: ! ! PDF(A,B,C;X) = exp ( - ( X - A ) / B ) * ( ( X - A ) / B )**(C-1) ! / ( B * GAMMA ( C ) ) ! ! Discussion: ! ! GAMMA_PDF(A,B,C;X), where C is an integer, is the Erlang PDF. ! GAMMA_PDF(A,B,1;X) is the Exponential PDF. ! GAMMA_PDF(0,2,C/2;X) is the Chi Squared PDF with C degrees of freedom. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A <= X ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) gamma real ( kind = 8 ) pdf real ( kind = 8 ) x real ( kind = 8 ) y if ( x <= a ) then pdf = 0.0D+00 else y = ( x - a ) / b pdf = y**( c - 1.0D+00 ) / ( b * gamma ( c ) * exp ( y ) ) end if return end subroutine gamma_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! GAMMA_SAMPLE samples the Gamma PDF. ! ! Modified: ! ! 15 September 2000 ! ! Author: ! ! J H Ahrens and U Dieter ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! J H Ahrens and U Dieter, ! Generating Gamma Variates by a Modified Rejection Technique, ! Communications of the ACM, ! Volume 25, Number 1, January 1982, pages 47 - 54. ! ! J H Ahrens and U Dieter, ! Computer Methods for Sampling from Gamma, Beta, Poisson and ! Binomial Distributions. ! Computing, Volume 12, 1974, pages 223 - 246. ! ! J H Ahrens, K D Kohrt, and U Dieter, ! Algorithm 599, ! ACM Transactions on Mathematical Software, ! Volume 9, Number 2, June 1983, pages 255-257. ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ), parameter :: a1 = 0.3333333D+00 real ( kind = 8 ), parameter :: a2 = - 0.2500030D+00 real ( kind = 8 ), parameter :: a3 = 0.2000062D+00 real ( kind = 8 ), parameter :: a4 = - 0.1662921D+00 real ( kind = 8 ), parameter :: a5 = 0.1423657D+00 real ( kind = 8 ), parameter :: a6 = - 0.1367177D+00 real ( kind = 8 ), parameter :: a7 = 0.1233795D+00 real ( kind = 8 ) b real ( kind = 8 ) bcoef real ( kind = 8 ) c real ( kind = 8 ) co real ( kind = 8 ) d real ( kind = 8 ) d_uniform_01 real ( kind = 8 ) e real ( kind = 8 ), parameter :: e1 = 1.0D+00 real ( kind = 8 ), parameter :: e2 = 0.4999897D+00 real ( kind = 8 ), parameter :: e3 = 0.1668290D+00 real ( kind = 8 ), parameter :: e4 = 0.0407753D+00 real ( kind = 8 ), parameter :: e5 = 0.0102930D+00 real ( kind = 8 ), parameter :: euler = 2.71828182845904D+00 real ( kind = 8 ) p real ( kind = 8 ) q real ( kind = 8 ) q0 real ( kind = 8 ), parameter :: q1 = 0.04166669D+00 real ( kind = 8 ), parameter :: q2 = 0.02083148D+00 real ( kind = 8 ), parameter :: q3 = 0.00801191D+00 real ( kind = 8 ), parameter :: q4 = 0.00144121D+00 real ( kind = 8 ), parameter :: q5 = - 0.00007388D+00 real ( kind = 8 ), parameter :: q6 = 0.00024511D+00 real ( kind = 8 ), parameter :: q7 = 0.00024240D+00 real ( kind = 8 ) r real ( kind = 8 ) s integer seed real ( kind = 8 ) si real ( kind = 8 ) s2 real ( kind = 8 ) t real ( kind = 8 ) u real ( kind = 8 ) v real ( kind = 8 ) w real ( kind = 8 ) x ! ! Allow C = 0. ! if ( c == 0.0D+00 ) then x = a return end if ! ! C < 1. ! if ( c < 1.0D+00 ) then do u = d_uniform_01 ( seed ) t = 1.0D+00 + c / euler p = u * t call exponential_01_sample ( seed, s ) if ( p < 1.0D+00 ) then x = exp ( log ( p ) / c ) if ( x <= s ) then exit end if else x = - log ( ( t - p ) / c ) if ( ( 1.0D+00 - c ) * log ( x ) <= s ) then exit end if end if end do x = a + b * x return ! ! 1 <= C. ! else s2 = c - 0.5D+00 s = sqrt ( c - 0.5D+00 ) d = sqrt ( 32.0D+00 ) - 12.0D+00 * sqrt ( c - 0.5D+00 ) call normal_01_sample ( seed, t ) x = ( sqrt ( c - 0.5D+00 ) + 0.5D+00 * t )**2 if ( 0.0D+00 <= t ) then x = a + b * x return end if u = d_uniform_01 ( seed ) if ( d * u <= t**3 ) then x = a + b * x return end if r = 1.0D+00 / c q0 = ( ( ( ( ( ( & q7 * r & + q6 ) * r & + q5 ) * r & + q4 ) * r & + q3 ) * r & + q2 ) * r & + q1 ) * r if ( c <= 3.686D+00 ) then bcoef = 0.463D+00 + s - 0.178D+00 * s2 si = 1.235D+00 co = 0.195D+00 / s - 0.079D+00 + 0.016D+00 * s else if ( c <= 13.022D+00 ) then bcoef = 1.654D+00 + 0.0076D+00 * s2 si = 1.68D+00 / s + 0.275D+00 co = 0.062D+00 / s + 0.024D+00 else bcoef = 1.77D+00 si = 0.75D+00 co = 0.1515D+00 / s end if if ( 0.0D+00 < sqrt ( c - 0.5D+00 ) + 0.5D+00 * t ) then v = 0.5D+00 * t / s if ( 0.25D+00 < abs ( v ) ) then q = q0 - s * t + 0.25D+00 * t * t + 2.0D+00 * s2 * log ( 1.0D+00 + v ) else q = q0 + 0.5D+00 * t**2 * ( ( ( ( ( ( & a7 * v & + a6 ) * v & + a5 ) * v & + a4 ) * v & + a3 ) * v & + a2 ) * v & + a1 ) * v end if if ( log ( 1.0D+00 - u ) <= q ) then x = a + b * x return end if end if do call exponential_01_sample ( seed, e ) u = d_uniform_01 ( seed ) u = 2.0D+00 * u - 1.0D+00 t = bcoef + sign ( si * e, u ) if ( -0.7187449D+00 <= t ) then v = 0.5D+00 * t / s if ( 0.25D+00 < abs ( v ) ) then q = q0 - s * t + 0.25D+00 * t**2 + 2.0D+00 * s2 * log ( 1.0D+00 + v ) else q = q0 + 0.5D+00 * t**2 * ( ( ( ( ( ( & a7 * v & + a6 ) * v & + a5 ) * v & + a4 ) * v & + a3 ) * v & + a2 ) * v & + a1 ) * v end if if ( 0.0D+00 < q ) then if ( 0.5D+00 < q ) then w = exp ( q ) - 1.0D+00 else w = ( ( ( ( & e5 * q & + e4 ) * q & + e3 ) * q & + e2 ) * q & + e1 ) * q end if if ( co * abs ( u ) <= w * exp ( e - 0.5D+00 * t**2 ) ) then x = a + b * ( s + 0.5D+00 * t )**2 return end if end if end if end do end if return end subroutine gamma_variance ( a, b, c, variance ) !******************************************************************************* ! !! GAMMA_VARIANCE returns the variance of the Gamma PDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) variance variance = b * b * c return end subroutine genlogistic_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! GENLOGISTIC_CDF evaluates the Generalized Logistic CDF. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b cdf = 1.0D+00 / ( 1.0D+00 + exp ( - y ) )**c return end subroutine genlogistic_cdf_inv ( cdf, a, b, c, x ) !******************************************************************************* ! !! GENLOGISTIC_CDF_INV inverts the Generalized Logistic CDF. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GENLOGISTIC_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = - huge ( x ) else if ( cdf < 1.0D+00 ) then x = a - b * log ( cdf**( - 1.0D+00 / c ) - 1.0D+00 ) else if ( 1.0D+00 == cdf ) then x = huge ( x ) end if return end function genlogistic_check ( a, b, c ) !******************************************************************************* ! !! GENLOGISTIC_CHECK checks the parameters of the Generalized Logistic CDF. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, logical GENLOGISTIC_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c logical genlogistic_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GENLOGISTIC_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' genlogistic_check = .false. return end if if ( c <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GENLOGISTIC_CHECK - Fatal error!' write ( *, '(a)' ) ' C <= 0.' genlogistic_check = .false. return end if genlogistic_check = .true. return end subroutine genlogistic_mean ( a, b, c, mean ) !******************************************************************************* ! !! GENLOGISTIC_MEAN returns the mean of the Generalized Logistic PDF. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) digamma real ( kind = 8 ) euler_constant real ( kind = 8 ) mean mean = a + b * ( euler_constant ( ) + digamma ( c ) ) return end subroutine genlogistic_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! GENLOGISTIC_PDF evaluates the Generalized Logistic PDF. ! ! Formula: ! ! PDF(A,B,C;X) = ( C / B ) * exp ( ( A - X ) / B ) / ! ( ( 1 + exp ( ( A - X ) / B ) )**(C+1) ) ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) pdf real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b pdf = ( c / b ) * exp ( - y ) / ( 1.0D+00 + exp ( - y ) )**( c + 1.0D+00 ) return end subroutine genlogistic_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! GENLOGISTIC_SAMPLE samples the Generalized Logistic PDF. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call genlogistic_cdf_inv ( cdf, a, b, c, x ) return end subroutine genlogistic_variance ( a, b, c, variance ) !******************************************************************************* ! !! GENLOGISTIC_VARIANCE returns the variance of the Generalized Logistic PDF. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) trigamma real ( kind = 8 ) variance variance = b * b * ( pi * pi / 6.0D+00 + trigamma ( c ) ) return end subroutine geometric_cdf ( x, a, cdf ) !******************************************************************************* ! !! GEOMETRIC_CDF evaluates the Geometric CDF. ! ! Definition: ! ! CDF(X,P) is the probability that there will be at least one ! successful trial in the first X Bernoulli trials, given that ! the probability of success in a single trial is P. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the maximum number of trials. ! ! Input, real ( kind = 8 ) A, the probability of success on one trial. ! 0.0D+00 <= A <= 1.0. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf integer x if ( x <= 0 ) then cdf = 0.0D+00 else if ( a == 0.0D+00 ) then cdf = 0.0D+00 else if ( a == 1.0D+00 ) then cdf = 1.0D+00 else cdf = 1.0D+00 - ( 1.0D+00 - a )**x end if return end subroutine geometric_cdf_inv ( cdf, a, x ) !******************************************************************************* ! !! GEOMETRIC_CDF_INV inverts the Geometric CDF. ! ! Modified: ! ! 26 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0D+00 ! ! Input, real ( kind = 8 ) A, the probability of success on one trial. ! 0.0D+00 <= A <= 1.0. ! ! Output, integer X, the corresponding value of X. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf integer x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GEOMETRIC_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( a == 1.0D+00 ) then x = 1 else if ( a == 0.0D+00 ) then x = huge ( x ) else x = 1 + int ( log ( 1.0D+00 - cdf ) / log ( 1.0D+00 - a ) ) end if return end subroutine geometric_cdf_values ( n_data, x, p, cdf ) !******************************************************************************* ! !! GEOMETRIC_CDF_VALUES returns values of the geometric CDF. ! ! Discussion: ! ! The geometric or Pascal probability density function gives the ! probability that the first success will happen on the X-th Bernoulli ! trial, given that the probability of a success on a single trial is P. ! ! The value of CDF ( X, P ) is the probability that the first success ! will happen on or before the X-th trial. ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`DiscreteDistributions`] ! dist = GeometricDistribution [ p ] ! CDF [ dist, x ] ! ! Modified: ! ! 21 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Daniel Zwillinger and Stephen Kokoska, ! CRC Standard Probability and Statistics Tables and Formulae, ! Chapman and Hall / CRC Press, 2000. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer X, the number of trials. ! ! Output, real ( kind = 8 ) P, the probability of success ! on one trial. ! ! Output, real ( kind = 8 ) CDF, the cumulative density function. ! implicit none integer, parameter :: n_max = 14 real ( kind = 8 ) cdf real ( kind = 8 ), save, dimension ( n_max ) :: cdf_vec = (/ & 0.1900000000000000D+00, & 0.2710000000000000D+00, & 0.3439000000000000D+00, & 0.6861894039100000D+00, & 0.3600000000000000D+00, & 0.4880000000000000D+00, & 0.5904000000000000D+00, & 0.9141006540800000D+00, & 0.7599000000000000D+00, & 0.8704000000000000D+00, & 0.9375000000000000D+00, & 0.9843750000000000D+00, & 0.9995117187500000D+00, & 0.9999000000000000D+00 /) integer n_data real ( kind = 8 ) p real ( kind = 8 ), save, dimension ( n_max ) :: p_vec = (/ & 0.1D+00, & 0.1D+00, & 0.1D+00, & 0.1D+00, & 0.2D+00, & 0.2D+00, & 0.2D+00, & 0.2D+00, & 0.3D+00, & 0.4D+00, & 0.5D+00, & 0.5D+00, & 0.5D+00, & 0.9D+00 /) integer x integer, save, dimension ( n_max ) :: x_vec = (/ & 1, 2, 3, 10, 1, & 2, 3, 10, 3, 3, & 3, 5, 10, 3 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0 p = 0.0D+00 cdf = 0.0D+00 else x = x_vec(n_data) p = p_vec(n_data) cdf = cdf_vec(n_data) end if return end function geometric_check ( a ) !******************************************************************************* ! !! GEOMETRIC_CHECK checks the parameter of the Geometric CDF. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the probability of success on one trial. ! 0.0D+00 <= A <= 1.0. ! ! Output, logical GEOMETRIC_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a logical geometric_check if ( a < 0.0D+00 .or. 1.0D+00 < a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GEOMETRIC_CHECK - Fatal error!' write ( *, '(a)' ) ' A < 0 or 1 < A.' geometric_check = .false. return end if geometric_check = .true. return end subroutine geometric_mean ( a, mean ) !******************************************************************************* ! !! GEOMETRIC_MEAN returns the mean of the Geometric PDF. ! ! Discussion: ! ! MEAN is the expected value of the number of trials required ! to obtain a single success. ! ! Modified: ! ! 06 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the probability of success on one trial. ! 0.0D+00 <= A <= 1.0. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) mean mean = 1.0D+00 / a return end subroutine geometric_pdf ( x, a, pdf ) !******************************************************************************* ! !! GEOMETRIC_PDF evaluates the Geometric PDF. ! ! Formula: ! ! PDF(A;X) = A * ( 1 - A )**(X-1) ! ! Definition: ! ! PDF(A;X) is the probability that exactly X Bernoulli trials, each ! with probability of success A, will be required to achieve ! a single success. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the number of trials. ! 0 < X ! ! Input, real ( kind = 8 ) A, the probability of success on one trial. ! 0.0D+00 <= A <= 1.0. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) pdf integer x ! ! Special cases. ! if ( x < 1 ) then pdf = 0.0D+00 else if ( a == 0.0D+00 ) then pdf = 0.0D+00 else if ( a == 1.0D+00 ) then if ( x == 1 ) then pdf = 1.0D+00 else pdf = 0.0D+00 end if else pdf = a * ( 1.0D+00 - a )**( x - 1 ) end if return end subroutine geometric_sample ( a, seed, x ) !******************************************************************************* ! !! GEOMETRIC_SAMPLE samples the Geometric PDF. ! ! Modified: ! ! 06 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the probability of success on one trial. ! 0.0D+00 <= A <= 1.0. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed integer x cdf = d_uniform_01 ( seed ) call geometric_cdf_inv ( cdf, a, x ) return end subroutine geometric_variance ( a, variance ) !******************************************************************************* ! !! GEOMETRIC_VARIANCE returns the variance of the Geometric PDF. ! ! Modified: ! ! 06 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the probability of success on one trial. ! 0.0D+00 <= A <= 1.0. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) variance variance = ( 1.0D+00 - a ) / ( a * a ) return end subroutine gompertz_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! GOMPERTZ_CDF evaluates the Gompertz CDF. ! ! Modified: ! ! 19 December 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Johnson, Kotz, and Balakrishnan, ! Continuous Univariate Distributions, Volume 2, second edition, ! Wiley, 1994, pages 25-26. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 1 < A, 0 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x <= 0.0D+00 ) then cdf = 0.0D+00 else cdf = 1.0D+00 - exp ( - b * ( a**x - 1.0D+00 ) / log ( a ) ) end if return end subroutine gompertz_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! GOMPERTZ_CDF_INV inverts the Gompertz CDF. ! ! Modified: ! ! 19 December 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Johnson, Kotz, and Balakrishnan, ! Continuous Univariate Distributions, Volume 2, second edition, ! Wiley, 1994, pages 25-26. ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 1 < A, 0 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GOMPERTZ_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf < 1.0D+00 ) then x = log ( 1.0D+00 - log ( 1.0D+00 - cdf ) * log ( a ) / b ) / log ( a ) else x = huge ( x ) end if return end function gompertz_check ( a, b ) !******************************************************************************* ! !! GOMPERTZ_CHECK checks the parameters of the Gompertz PDF. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Johnson, Kotz, and Balakrishnan, ! Continuous Univariate Distributions, Volume 2, second edition, ! Wiley, 1994, pages 25-26. ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 1 < A, 0 < B. ! ! Output, logical GOMPERTZ_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical gompertz_check if ( a <= 1.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GOMPERTZ_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 1.0!' gompertz_check = .false. return end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GOMPERTZ_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.0!' gompertz_check = .false. return end if gompertz_check = .true. return end subroutine gompertz_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! GOMPERTZ_PDF evaluates the Gompertz PDF. ! ! Formula: ! ! PDF(A,B;X) = B * A**X / exp ( B * ( A**X - 1 ) / log ( A ) ) ! ! for ! ! 0.0 <= X ! 1.0 < A ! 0.0 < B ! ! Modified: ! ! 19 December 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Johnson, Kotz, and Balakrishnan, ! Continuous Univariate Distributions, Volume 2, second edition, ! Wiley, 1994, pages 25-26. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 1 < A, 0 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x < 0.0D+00 ) then pdf = 0.0D+00 else if ( 1.0D+00 < a ) then pdf = exp ( log ( b ) + x * log ( a ) & - ( b / log ( a ) ) * ( a**x - 1.0D+00 ) ) end if return end subroutine gompertz_sample ( a, b, seed, x ) !******************************************************************************* ! !! GOMPERTZ_SAMPLE samples the Gompertz PDF. ! ! Modified: ! ! 19 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 1 < A, 0 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call gompertz_cdf_inv ( cdf, a, b, x ) return end subroutine gumbel_cdf ( x, cdf ) !******************************************************************************* ! !! GUMBEL_CDF evaluates the Gumbel CDF. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) x cdf = exp ( - exp ( - x ) ) return end subroutine gumbel_cdf_inv ( cdf, x ) !******************************************************************************* ! !! GUMBEL_CDF_INV inverts the Gumbel CDF. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GUMBEL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = - log ( - log ( cdf ) ) return end subroutine gumbel_mean ( mean ) !******************************************************************************* ! !! GUMBEL_MEAN returns the mean of the Gumbel PDF. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) euler_constant real ( kind = 8 ) mean mean = euler_constant ( ) return end subroutine gumbel_pdf ( x, pdf ) !******************************************************************************* ! !! GUMBEL_PDF evaluates the Gumbel PDF. ! ! Formula: ! ! PDF(X) = exp ( -X ) * exp ( - exp ( -X ) ). ! ! Discussion: ! ! GUMBEL_PDF(X) = EXTREME_PDF(0,1;X) ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Eric Weisstein, editor, ! CRC Concise Encylopedia of Mathematics, ! CRC Press, 1998. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) pdf real ( kind = 8 ) x pdf = exp ( - x - exp ( - x ) ) return end subroutine gumbel_sample ( seed, x ) !******************************************************************************* ! !! GUMBEL_SAMPLE samples the Gumbel PDF. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call gumbel_cdf_inv ( cdf, x ) return end subroutine gumbel_variance ( variance ) !******************************************************************************* ! !! GUMBEL_VARIANCE returns the variance of the Gumbel PDF. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) variance variance = pi * pi / 6.0D+00 return end subroutine half_normal_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! HALF_NORMAL_CDF evaluates the Half Normal CDF. ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cdf2 real ( kind = 8 ) x if ( x <= a ) then cdf = 0.0D+00 else call normal_cdf ( x, a, b, cdf2 ) cdf = 2.0D+00 * cdf2 - 1.0D+00 end if return end subroutine half_normal_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! HALF_NORMAL_CDF_INV inverts the Half Normal CDF. ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cdf2 real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HALF_NORMAL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if cdf2 = 0.5D+00 * ( cdf + 1.0D+00 ) call normal_cdf_inv ( cdf2, a, b, x ) return end function half_normal_check ( a, b ) !******************************************************************************* ! !! HALF_NORMAL_CHECK checks the parameters of the Half Normal PDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, logical HALF_NORMAL_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical half_normal_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HALF_NORMAL_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' half_normal_check = .false. return end if half_normal_check = .true. return end subroutine half_normal_mean ( a, b, mean ) !******************************************************************************* ! !! HALF_NORMAL_MEAN returns the mean of the Half Normal PDF. ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 mean = a + b * sqrt ( 2.0D+00 / pi ) return end subroutine half_normal_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! HALF_NORMAL_PDF evaluates the Half Normal PDF. ! ! Formula: ! ! PDF(A,B;X) = ! sqrt ( 2 / PI ) * ( 1 / B ) * exp ( - 0.5D+00 * ( ( X - A ) / B )**2 ) ! ! for A <= X ! ! Discussion: ! ! The Half Normal PDF is a special case of both the Chi PDF and the ! Folded Normal PDF. ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A <= X ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) y if ( x <= a ) then pdf = 0.0D+00 else y = ( x - a ) / b pdf = sqrt ( 2.0D+00 / pi ) * ( 1.0D+00 / b ) * exp ( - 0.5D+00 * y * y ) end if return end subroutine half_normal_sample ( a, b, seed, x ) !******************************************************************************* ! !! HALF_NORMAL_SAMPLE samples the Half Normal PDF. ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call half_normal_cdf_inv ( cdf, a, b, x ) return end subroutine half_normal_variance ( a, b, variance ) !******************************************************************************* ! !! HALF_NORMAL_VARIANCE returns the variance of the Half Normal PDF. ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) variance variance = b * b * ( 1.0D+00 - 2.0D+00 / pi ) return end subroutine hypergeometric_cdf ( x, n, m, l, cdf ) !******************************************************************************* ! !! HYPERGEOMETRIC_CDF evaluates the Hypergeometric CDF. ! ! Modified: ! ! 13 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the CDF. ! ! Input, integer N, the number of balls selected. ! 0 <= N <= L. ! ! Input, integer M, the number of white balls in the population. ! 0 <= M <= L. ! ! Input, integer L, the number of balls to select from. ! 0 <= L. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) c1_log real ( kind = 8 ) c2_log integer l integer m integer n real ( kind = 8 ) pdf integer x integer x2 call binomial_coef_log ( l - m, n, c1_log ) call binomial_coef_log ( l, n, c2_log ) pdf = exp ( c1_log - c2_log ) cdf = pdf do x2 = 0, x - 1 pdf = pdf * real ( ( m - x2 ) * ( n - x2 ), kind = 8 ) & / real ( ( x2 + 1 ) * ( l - m - n + x2 + 1 ), kind = 8 ) cdf = cdf + pdf end do return end subroutine hypergeometric_cdf_values ( n_data, sam, suc, pop, n, fx ) !******************************************************************************* ! !! HYPERGEOMETRIC_CDF_VALUES returns some values of the hypergeometric CDF. ! ! Discussion: ! ! CDF(X)(A,B) is the probability of at most X successes in A trials, ! given that the probability of success on a single trial is B. ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`DiscreteDistributions`] ! dist = HypergeometricDistribution [ sam, suc, pop ] ! CDF [ dist, n ] ! ! Modified: ! ! 05 September 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Daniel Zwillinger, ! CRC Standard Mathematical Tables and Formulae, ! 30th Edition, CRC Press, 1996, pages 651-652. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer SAM, integer SUC, integer POP, the sample size, ! success size, and population parameters of the function. ! ! Output, integer N, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 16 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.6001858177500578D-01, & 0.2615284665839845D+00, & 0.6695237889132748D+00, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.5332595856827856D+00, & 0.1819495964117640D+00, & 0.4448047017527730D-01, & 0.9999991751316731D+00, & 0.9926860896560750D+00, & 0.8410799901444538D+00, & 0.3459800113391901D+00, & 0.0000000000000000D+00, & 0.2088888139634505D-02, & 0.3876752992448843D+00, & 0.9135215248834896D+00 /) integer n integer n_data integer, save, dimension ( n_max ) :: n_vec = (/ & 7, 8, 9, 10, & 6, 6, 6, 6, & 6, 6, 6, 6, & 0, 0, 0, 0 /) integer pop integer, save, dimension ( n_max ) :: pop_vec = (/ & 100, 100, 100, 100, & 100, 100, 100, 100, & 100, 100, 100, 100, & 90, 200, 1000, 10000 /) integer sam integer, save, dimension ( n_max ) :: sam_vec = (/ & 10, 10, 10, 10, & 6, 7, 8, 9, & 10, 10, 10, 10, & 10, 10, 10, 10 /) integer suc integer, save, dimension ( n_max ) :: suc_vec = (/ & 90, 90, 90, 90, & 90, 90, 90, 90, & 10, 30, 50, 70, & 90, 90, 90, 90 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 sam = 0 suc = 0 pop = 0 n = 0 fx = 0.0D+00 else sam = sam_vec(n_data) suc = suc_vec(n_data) pop = pop_vec(n_data) n = n_vec(n_data) fx = fx_vec(n_data) end if return end function hypergeometric_check ( n, m, l ) !******************************************************************************* ! !! HYPERGEOMETRIC_CHECK checks the parameters of the Hypergeometric CDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of balls selected. ! 0 <= N <= L. ! ! Input, integer M, the number of white balls in the population. ! 0 <= M <= L. ! ! Input, integer L, the number of balls to select from. ! 0 <= L. ! ! Output, logical HYPERGEOMETRIC_CHECK, is true if the parameters are legal. ! implicit none logical hypergeometric_check integer l integer m integer n if ( n < 0 .or. l < n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HYPERGEOMETRIC_CHECK - Fatal error!' write ( *, '(a)' ) ' Input N is out of range.' hypergeometric_check = .false. return end if if ( m < 0 .or. l < m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HYPERGEOMETRIC_CHECK - Fatal error!' write ( *, '(a)' ) ' Input M is out of range.' hypergeometric_check = .false. return end if if ( l < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HYPERGEOMETRIC_CHECK - Fatal error!' write ( *, '(a)' ) ' Input L is out of range.' hypergeometric_check = .false. return end if hypergeometric_check = .true. return end subroutine hypergeometric_mean ( n, m, l, mean ) !******************************************************************************* ! !! HYPERGEOMETRIC_MEAN returns the mean of the Hypergeometric PDF. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of balls selected. ! 0 <= N <= L. ! ! Input, integer M, the number of white balls in the population. ! 0 <= M <= L. ! ! Input, integer L, the number of balls to select from. ! 0 <= L. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none integer l integer m real ( kind = 8 ) mean integer n mean = real ( n * m, kind = 8 ) / real ( l, kind = 8 ) return end subroutine hypergeometric_pdf ( x, n, m, l, pdf ) !******************************************************************************* ! !! HYPERGEOMETRIC_PDF evaluates the Hypergeometric PDF. ! ! Formula: ! ! PDF(N,M,L;X) = C(M,X) * C(L-M,N-X) / C(L,N). ! ! Definition: ! ! PDF(N,M,L;X) is the probability of drawing X white balls in a ! single random sample of size N from a population containing ! M white balls and a total of L balls. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the desired number of white balls. ! 0 <= X <= N, usually, although any value of X can be given. ! ! Input, integer N, the number of balls selected. ! 0 <= N <= L. ! ! Input, integer M, the number of white balls in the population. ! 0 <= M <= L. ! ! Input, integer L, the number of balls to select from. ! 0 <= L. ! ! Output, real ( kind = 8 ) PDF, the probability of exactly K white balls. ! implicit none real ( kind = 8 ) c1 real ( kind = 8 ) c2 real ( kind = 8 ) c3 integer l integer m integer n real ( kind = 8 ) pdf real ( kind = 8 ) pdf_log integer x ! ! Special cases. ! if ( x < 0 ) then pdf = 1.0D+00 else if ( n < x ) then pdf = 0.0D+00 else if ( m < x ) then pdf = 0.0D+00 else if ( l < x ) then pdf = 0.0D+00 else if ( n == 0 ) then if ( x == 0 ) then pdf = 1.0D+00 else pdf = 0.0D+00 end if else call binomial_coef_log ( m, x, c1 ) call binomial_coef_log ( l-m, n-x, c2 ) call binomial_coef_log ( l, n, c3 ) pdf_log = c1 + c2 - c3 pdf = exp ( pdf_log ) end if return end subroutine hypergeometric_sample ( n, m, l, seed, x ) !******************************************************************************* ! !! HYPERGEOMETRIC_SAMPLE samples the Hypergeometric PDF. ! ! Modified: ! ! 23 February 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jerry Banks, editor, ! Handbook of Simulation, ! Engineering and Management Press Books, 1998, page 165. ! ! Parameters: ! ! Input, integer N, the number of balls selected. ! 0 <= N <= L. ! ! Input, integer M, the number of white balls in the population. ! 0 <= M <= L. ! ! Input, integer L, the number of balls to select from. ! 0 <= L. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c1_log real ( kind = 8 ) c2_log real ( kind = 8 ) d_uniform_01 integer l integer m integer n integer seed real ( kind = 8 ) u integer x call binomial_coef_log ( l - m, n, c1_log ) call binomial_coef_log ( l, n, c2_log ) a = exp ( c1_log - c2_log ) b = a u = d_uniform_01 ( seed ) x = 0 do while ( a < u ) b = b * real ( ( m - x ) * ( n - x ), kind = 8 ) & / real ( ( x + 1 ) * ( l - m - n + x + 1 ), kind = 8 ) a = a + b x = x + 1 end do return end subroutine hypergeometric_variance ( n, m, l, variance ) !******************************************************************************* ! !! HYPERGEOMETRIC_VARIANCE returns the variance of the Hypergeometric PDF. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of balls selected. ! 0 <= N <= L. ! ! Input, integer M, the number of white balls in the population. ! 0 <= M <= L. ! ! Input, integer L, the number of balls to select from. ! 0 <= L. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none integer l integer m integer n real ( kind = 8 ) variance variance = real ( n * m * ( l - m ) * ( l - n ), kind = 8 ) & / real ( l * l * ( l - 1 ), kind = 8 ) return end function i_factorial ( n ) !******************************************************************************* ! !! I_FACTORIAL returns N!. ! ! Definition: ! ! N! = Product ( 1 <= I <= N ) I ! ! Modified: ! ! 22 November 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the argument of the function. ! 0 <= N. ! ! Output, real ( kind = 8 ) I_FACTORIAL, the factorial of N. ! implicit none real ( kind = 8 ) i_factorial integer i integer n if ( n < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_FACTORIAL - Fatal error!' write ( *, '(a)' ) ' N < 0.' stop end if i_factorial = 1.0D+00 do i = 2, n i_factorial = i_factorial * real ( i, kind = 8 ) end do return end function i_uniform ( a, b, seed ) !******************************************************************************* ! !! I_UNIFORM returns a integer pseudorandom number. ! ! Discussion: ! ! The pseudorandom number should be uniformly distributed ! between A and B. ! ! Modified: ! ! 21 November 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, B, the limits of the interval. ! ! Input/output, integer SEED, the "seed" value, which should NOT be 0. ! On output, SEED has been updated. ! ! Output, integer I_UNIFORM, a number between A and B. ! implicit none integer a integer b real ( kind = 8 ) d real ( kind = 8 ) d_uniform_01 integer i_uniform integer seed d = real ( a, kind = 8 ) - 0.5D+00 & + real ( 1 + b - a, kind = 8 ) * d_uniform_01 ( seed ) i_uniform = nint ( d ) i_uniform = max ( i_uniform, a ) i_uniform = min ( i_uniform, b ) return end subroutine inverse_gaussian_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! INVERSE_GAUSSIAN_CDF evaluates the Inverse Gaussian CDF. ! ! Modified: ! ! 23 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! 0.0D+00 < X. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cdf1 real ( kind = 8 ) cdf2 real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 if ( x <= 0.0D+00 ) then cdf = 0.0D+00 else x1 = sqrt ( b / x ) * ( x - a ) / a call normal_01_cdf ( x1, cdf1 ) x2 = - sqrt ( b / x ) * ( x + a ) / a call normal_01_cdf ( x2, cdf2 ) cdf = cdf1 + exp ( 2.0D+00 * b / a ) * cdf2 end if return end function inverse_gaussian_check ( a, b ) !******************************************************************************* ! !! INVERSE_GAUSSIAN_CHECK checks the parameters of the Inverse Gaussian CDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, logical INVERSE_GAUSSIAN_CHECK, is true if the parameters ! are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical inverse_gaussian_check if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INVERSE_GAUSSIAN_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.' inverse_gaussian_check = .false. return end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INVERSE_GAUSSIAN_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' inverse_gaussian_check = .false. return end if inverse_gaussian_check = .true. return end subroutine inverse_gaussian_mean ( a, b, mean ) !******************************************************************************* ! !! INVERSE_GAUSSIAN_MEAN returns the mean of the Inverse Gaussian PDF. ! ! Modified: ! ! 25 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a return end subroutine inverse_gaussian_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! INVERSE_GAUSSIAN_PDF evaluates the Inverse Gaussian PDF. ! ! Discussion: ! ! The Inverse Gaussian PDF is also known as the Wald PDF ! and the Inverse Normal PDF. ! ! Formula: ! ! PDF(A,B;X) ! = sqrt ( B / ( 2 * PI * X**3 ) ) ! * exp ( - B * ( X - A )**2 / ( 2.0D+00 * A**2 * X ) ) ! ! Modified: ! ! 23 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 < X ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( x <= 0.0D+00 ) then pdf = 0.0D+00 else pdf = sqrt ( b / ( 2.0D+00 * pi * x**3 ) ) * & exp ( - b * ( x - a )**2 / ( 2.0D+00 * a * a * x ) ) end if return end subroutine inverse_gaussian_sample ( a, b, seed, x ) !******************************************************************************* ! !! INVERSE_GAUSSIAN_SAMPLE samples the Inverse Gaussian PDF. ! ! Modified: ! ! 23 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) d_uniform_01 real ( kind = 8 ) phi integer seed real ( kind = 8 ) t real ( kind = 8 ) u real ( kind = 8 ) x real ( kind = 8 ) y real ( kind = 8 ) z phi = b / a call normal_01_sample ( seed, z ) y = z * z t = 1.0D+00 + 0.5D+00 * ( y - sqrt ( 4.0D+00 * phi * y + y * y ) ) / phi u = d_uniform_01 ( seed ) if ( u * ( 1.0D+00 + t ) <= 1.0D+00 ) then x = a * t else x = a / t end if return end subroutine inverse_gaussian_variance ( a, b, variance ) !******************************************************************************* ! !! INVERSE_GAUSSIAN_VARIANCE returns the variance of the Inverse Gaussian PDF. ! ! Modified: ! ! 25 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = a**3 / b return end subroutine irow_max ( m, n, x, ixmax, xmax ) !******************************************************************************* ! !! IROW_MAX returns the maximums of rows of an integer array. ! ! Modified: ! ! 26 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns in the array. ! ! Input, integer X(M,N), the array to be examined. ! ! Output, integer IXMAX(M); IXMAX(I) is the column of X in which ! the maximum for row I occurs. ! ! Output, integer XMAX(M), the maximums of the rows of X. ! implicit none integer m integer n integer i integer ixmax(m) integer j integer x(m,n) integer xmax(m) do i = 1, m ixmax(i) = 1 xmax(i) = x(i,1) do j = 2, n if ( xmax(i) < x(i,j) ) then ixmax(i) = j xmax(i) = x(i,j) end if end do end do return end subroutine irow_mean ( m, n, a, mean ) !******************************************************************************* ! !! IROW_MEAN returns the means of the rows of a table. ! ! Modified: ! ! 14 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns of data. ! ! Input, integer A(M,N), the array. ! ! Output, real ( kind = 8 ) MEAN(M), the mean of each row. ! implicit none integer m integer n integer a(m,n) integer i real ( kind = 8 ) mean(m) do i = 1, m mean(i) = sum ( a(i,1:n) ) / real ( n, kind = 8 ) end do return end subroutine irow_min ( m, n, x, ixmin, xmin ) !******************************************************************************* ! !! IROW_MIN returns the minimums of rows of an integer array. ! ! Modified: ! ! 26 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns in the array. ! ! Input, integer X(M,N), the array to be examined. ! ! Output, integer IXMIN(M); IXMIN(I) is the column of X in which ! the minimum for row I occurs. ! ! Output, integer XMIN(M), the minimums of the rows of X. ! implicit none integer m integer n integer i integer ixmin(m) integer j integer x(m,n) integer xmin(m) do i = 1, m ixmin(i) = 1 xmin(i) = x(i,1) do j = 2, n if ( x(i,j) < xmin(i) ) then ixmin(i) = j xmin(i) = x(i,j) end if end do end do return end subroutine irow_variance ( m, n, a, variance ) !******************************************************************************* ! !! IROW_VARIANCE returns the variances of the rows of a table. ! ! Modified: ! ! 14 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns of data. ! ! Input, integer A(M,N), the array. ! ! Output, real ( kind = 8 ) VARIANCE(M), the variance of each row. ! implicit none integer m integer n integer a(m,n) integer i integer j real ( kind = 8 ) mean real ( kind = 8 ) variance(m) do i = 1, m mean = real ( sum ( a(i,1:n) ), kind = 8 ) / real ( n, kind = 8 ) variance(i) = 0.0D+00 do j = 1, n variance(i) = variance(i) + ( real ( a(i,j), kind = 8 ) - mean )**2 end do if ( 1 < n ) then variance(i) = variance(i) / real ( n - 1, kind = 8 ) else variance(i) = 0.0D+00 end if end do return end subroutine ivec_max ( n, iarray, index, imax ) !******************************************************************************* ! !! IVEC_MAX computes the maximum element of an integer array. ! ! Modified: ! ! 30 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input, integer IARRAY(N), the array. ! ! Output, integer INDEX, the index of the largest entry. ! ! Output, integer IMAX, the value of the largest entry. ! implicit none integer n integer i integer iarray(n) integer index integer imax if ( n <= 0 ) then imax = 0 index = 0 else imax = iarray(1) index = 1 do i = 2, n if ( imax < iarray(i) ) then imax = iarray(i) index = i end if end do end if return end subroutine ivec_mean ( n, x, mean ) !******************************************************************************* ! !! IVEC_MEAN returns the mean of an integer vector. ! ! Modified: ! ! 02 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, integer X(N), the vector whose mean is desired. ! ! Output, real ( kind = 8 ) MEAN, the mean, or average, of ! the vector entries. ! implicit none integer n real ( kind = 8 ) mean integer x(n) mean = real ( sum ( x(1:n) ), kind = 8 ) / real ( n, kind = 8 ) return end subroutine ivec_min ( n, iarray, index, imin ) !******************************************************************************* ! !! IVEC_MIN computes the minimum element of an integer array. ! ! Modified: ! ! 09 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input, integer IARRAY(N), the array. ! ! Output, integer INDEX, the index of the smallest entry. ! ! Output, integer IMIN, the value of the smallest entry. ! implicit none integer n integer i integer iarray(n) integer imin integer index if ( n <= 0 ) then imin = 0 index = 0 else imin = iarray(1) index = 1 do i = 2, n if ( iarray(i) < imin ) then imin = iarray(i) index = i end if end do end if return end subroutine ivec_print ( n, a, title ) !******************************************************************************* ! !! IVEC_PRINT prints an integer vector. ! ! Modified: ! ! 28 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, integer A(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none integer n integer a(n) integer big integer i character ( len = * ) title if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if big = maxval ( abs ( a(1:n) ) ) write ( *, '(a)' ) ' ' if ( big < 1000 ) then do i = 1, n write ( *, '(i8,1x,i4)' ) i, a(i) end do else if ( big < 1000000 ) then do i = 1, n write ( *, '(i8,1x,i7)' ) i, a(i) end do else do i = 1, n write ( *, '(i8,i11)' ) i, a(i) end do end if return end subroutine ivec_variance ( n, x, variance ) !******************************************************************************* ! !! IVEC_VARIANCE returns the variance of an integer vector. ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, integer X(N), the vector whose variance is desired. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the vector entries. ! implicit none integer n real ( kind = 8 ) mean real ( kind = 8 ) variance integer x(n) call ivec_mean ( n, x, mean ) variance = sum ( ( real ( x(1:n), kind = 8 ) - mean )**2 ) if ( 1 < n ) then variance = variance / real ( n - 1, kind = 8 ) else variance = 0.0D+00 end if return end subroutine laplace_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! LAPLACE_CDF evaluates the Laplace CDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b if ( x <= a ) then cdf = 0.5D+00 * exp ( y ) else cdf = 1.0D+00 - 0.5D+00 * exp ( - y ) end if return end subroutine laplace_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! LAPLACE_CDF_INV inverts the Laplace CDF. ! ! Modified: ! ! 17 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LAPLACE_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf <= 0.5D+00 ) then x = a + b * log ( 2.0D+00 * cdf ) else x = a - b * log ( 2.0D+00 * ( 1.0D+00 - cdf ) ) end if return end subroutine laplace_cdf_values ( n_data, mu, beta, x, fx ) !******************************************************************************* ! !! LAPLACE_CDF_VALUES returns some values of the Laplace CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = LaplaceDistribution [ mu, beta ] ! CDF [ dist, x ] ! ! Modified: ! ! 28 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) MU, the mean of the distribution. ! ! Output, real ( kind = 8 ) BETA, the shape parameter. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 12 real ( kind = 8 ) beta real ( kind = 8 ), save, dimension ( n_max ) :: beta_vec = (/ & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.5000000000000000D+00, & 0.8160602794142788D+00, & 0.9323323583816937D+00, & 0.9751064658160680D+00, & 0.6967346701436833D+00, & 0.6417343447131054D+00, & 0.6105996084642976D+00, & 0.5906346234610091D+00, & 0.5000000000000000D+00, & 0.3032653298563167D+00, & 0.1839397205857212D+00, & 0.1115650800742149D+00 /) real ( kind = 8 ) mu real ( kind = 8 ), save, dimension ( n_max ) :: mu_vec = (/ & 0.0000000000000000D+01, & 0.0000000000000000D+01, & 0.0000000000000000D+01, & 0.0000000000000000D+01, & 0.0000000000000000D+01, & 0.0000000000000000D+01, & 0.0000000000000000D+01, & 0.0000000000000000D+01, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.0000000000000000D+01, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 mu = 0.0D+00 beta = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else mu = mu_vec(n_data) beta = beta_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function laplace_check ( a, b ) !******************************************************************************* ! !! LAPLACE_CHECK checks the parameters of the Laplace PDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, logical LAPLACE_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical laplace_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LAPLACE_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' laplace_check = .false. return end if laplace_check = .true. return end subroutine laplace_mean ( a, b, mean ) !******************************************************************************* ! !! LAPLACE_MEAN returns the mean of the Laplace PDF. ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a return end subroutine laplace_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! LAPLACE_PDF evaluates the Laplace PDF. ! ! Formula: ! ! PDF(A,B;X) = exp ( - abs ( X - A ) / B ) / ( 2 * B ) ! ! Discussion: ! ! The Laplace PDF is also known as the Double Exponential PDF. ! ! Modified: ! ! 09 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ) x pdf = exp ( - abs ( x - a ) / b ) / ( 2.0D+00 * b ) return end subroutine laplace_sample ( a, b, seed, x ) !******************************************************************************* ! !! LAPLACE_SAMPLE samples the Laplace PDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call laplace_cdf_inv ( cdf, a, b, x ) return end subroutine laplace_variance ( a, b, variance ) !******************************************************************************* ! !! LAPLACE_VARIANCE returns the variance of the Laplace PDF. ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = 2.0D+00 * b * b return end function lerch ( a, b, c ) !******************************************************************************* ! !! LERCH estimates the Lerch transcendent function. ! ! Definition: ! ! The Lerch transcendent function is defined as: ! ! LERCH ( A, B, C ) = Sum ( 0 <= K < Infinity ) A**K / ( C + K )**B ! ! excluding any term with ( C + K ) = 0. ! ! Modified: ! ! 17 December 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Eric Weisstein, editor, ! CRC Concise Encylopedia of Mathematics, ! CRC Press, 1998. ! ! Thanks: ! ! Oscar van Vlijmen ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the function. ! ! Output, real ( kind = 8 ) LERCH, an approximation to the Lerch ! transcendent function. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a_k real ( kind = 8 ) b real ( kind = 8 ) c integer k real ( kind = 8 ) lerch real ( kind = 8 ) sum2 real ( kind = 8 ) sum2_old sum2 = 0.0D+00 k = 0 a_k = 1.0D+00 do sum2_old = sum2 if ( c + real ( k, kind = 8 ) == 0.0D+00 ) then k = k + 1 a_k = a_k * a cycle end if sum2 = sum2 + a_k / ( c + real ( k, kind = 8 ) )**b if ( sum2 <= sum2_old ) then exit end if k = k + 1 a_k = a_k * a end do lerch = sum2 return end subroutine logistic_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! LOGISTIC_CDF evaluates the Logistic CDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x cdf = 1.0D+00 / ( 1.0D+00 + exp ( ( a - x ) / b ) ) return end subroutine logistic_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! LOGISTIC_CDF_INV inverts the Logistic CDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LOGISTIC_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = a - b * log ( ( 1.0D+00 - cdf ) / cdf ) return end subroutine logistic_cdf_values ( n_data, mu, beta, x, fx ) !******************************************************************************* ! !! LOGISTIC_CDF_VALUES returns some values of the Logistic CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = LogisticDistribution [ mu, beta ] ! CDF [ dist, x ] ! ! Modified: ! ! 30 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) MU, the mean of the distribution. ! ! Output, real ( kind = 8 ) BETA, the shape parameter of the distribution. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 12 real ( kind = 8 ) beta real ( kind = 8 ), save, dimension ( n_max ) :: beta_vec = (/ & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.5000000000000000D+00, & 0.8807970779778824D+00, & 0.9820137900379084D+00, & 0.9975273768433652D+00, & 0.6224593312018546D+00, & 0.5825702064623147D+00, & 0.5621765008857981D+00, & 0.5498339973124779D+00, & 0.6224593312018546D+00, & 0.5000000000000000D+00, & 0.3775406687981454D+00, & 0.2689414213699951D+00 /) real ( kind = 8 ) mu real ( kind = 8 ), save, dimension ( n_max ) :: mu_vec = (/ & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 mu = 0.0D+00 beta = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else mu = mu_vec(n_data) beta = beta_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function logistic_check ( a, b ) !******************************************************************************* ! !! LOGISTIC_CHECK checks the parameters of the Logistic CDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, logical LOGISTIC_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical logistic_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LOGISTIC_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' logistic_check = .false. return end if logistic_check = .true. return end subroutine logistic_mean ( a, b, mean ) !******************************************************************************* ! !! LOGISTIC_MEAN returns the mean of the Logistic PDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a return end subroutine logistic_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! LOGISTIC_PDF evaluates the Logistic PDF. ! ! Formula: ! ! PDF(A,B;X) = exp ( ( A - X ) / B ) / ! ( B * ( 1 + exp ( ( A - X ) / B ) )**2 ) ! ! Discussion: ! ! The Logistic PDF is also known as the Sech-Squared PDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ) temp real ( kind = 8 ) x temp = exp ( ( a - x ) / b ) pdf = temp / ( b * ( 1.0D+00 + temp )**2 ) return end subroutine logistic_sample ( a, b, seed, x ) !******************************************************************************* ! !! LOGISTIC_SAMPLE samples the Logistic PDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call logistic_cdf_inv ( cdf, a, b, x ) return end subroutine logistic_variance ( a, b, variance ) !******************************************************************************* ! !! LOGISTIC_VARIANCE returns the variance of the Logistic PDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) variance variance = pi * pi * b * b / 3.0D+00 return end subroutine log_normal_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! LOG_NORMAL_CDF evaluates the Lognormal CDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 < X. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) logx real ( kind = 8 ) x if ( x <= 0.0D+00 ) then cdf = 0.0D+00 else logx = log ( x ) call normal_cdf ( logx, a, b, cdf ) end if return end subroutine log_normal_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! LOG_NORMAL_CDF_INV inverts the Lognormal CDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) logx real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LOG_NORMAL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if call normal_cdf_inv ( cdf, a, b, logx ) x = exp ( logx ) return end subroutine log_normal_cdf_values ( n_data, mu, sigma, x, fx ) !******************************************************************************* ! !! LOG_NORMAL_CDF_VALUES returns some values of the Log Normal CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = LogNormalDistribution [ mu, sigma ] ! CDF [ dist, x ] ! ! Modified: ! ! 28 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) MU, the mean of the distribution. ! ! Output, real ( kind = 8 ) SIGMA, the shape parameter of the distribution. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 12 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.2275013194817921D-01, & 0.2697049307349095D+00, & 0.5781741008028732D+00, & 0.7801170895122241D+00, & 0.4390310097476894D+00, & 0.4592655190218048D+00, & 0.4694258497695908D+00, & 0.4755320473858733D+00, & 0.3261051056816658D+00, & 0.1708799040927608D+00, & 0.7343256357952060D-01, & 0.2554673736161761D-01 /) real ( kind = 8 ) mu real ( kind = 8 ), save, dimension ( n_max ) :: mu_vec = (/ & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01 /) integer n_data real ( kind = 8 ) sigma real ( kind = 8 ), save, dimension ( n_max ) :: sigma_vec = (/ & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01 /) real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 mu = 0.0D+00 sigma = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else mu = mu_vec(n_data) sigma = sigma_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function log_normal_check ( a, b ) !******************************************************************************* ! !! LOG_NORMAL_CHECK checks the parameters of the Lognormal PDF. ! ! Modified: ! ! 08 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, logical LOG_NORMAL_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical log_normal_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LOG_NORMAL_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' log_normal_check = .false. return end if log_normal_check = .true. return end subroutine log_normal_mean ( a, b, mean ) !******************************************************************************* ! !! LOG_NORMAL_MEAN returns the mean of the Lognormal PDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = exp ( a + 0.5D+00 * b * b ) return end subroutine log_normal_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! LOG_NORMAL_PDF evaluates the Lognormal PDF. ! ! Formula: ! ! PDF(A,B;X) ! = exp ( - 0.5 * ( ( log ( X ) - A ) / B )**2 ) ! / ( B * X * sqrt ( 2 * PI ) ) ! ! Discussion: ! ! The Lognormal PDF is also known as the Cobb-Douglas PDF, ! and as the Antilog_normal PDF. ! ! The Lognormal PDF describes a variable X whose logarithm ! is normally distributed. ! ! The special case A = 0, B = 1 is known as Gilbrat's PDF. ! ! Modified: ! ! 10 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 < X ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( x <= 0.0D+00 ) then pdf = 0.0D+00 else pdf = exp ( - 0.5D+00 * ( ( log ( x ) - a ) / b )**2 ) & / ( b * x * sqrt ( 2.0D+00 * pi ) ) end if return end subroutine log_normal_sample ( a, b, seed, x ) !******************************************************************************* ! !! LOG_NORMAL_SAMPLE samples the Lognormal PDF. ! ! Modified: ! ! 10 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call log_normal_cdf_inv ( cdf, a, b, x ) return end subroutine log_normal_variance ( a, b, variance ) !******************************************************************************* ! !! LOG_NORMAL_VARIANCE returns the variance of the Lognormal PDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = exp ( 2.0D+00 * a + b * b ) * ( exp ( b * b ) - 1.0D+00 ) return end subroutine log_series_cdf ( x, a, cdf ) !******************************************************************************* ! !! LOG_SERIES_CDF evaluates the Logarithmic Series CDF. ! ! Discussion: ! ! Simple summation is used, with a recursion to generate successive ! values of the PDF. ! ! Modified: ! ! 18 December 1999 ! ! Author: ! ! John Burkardt ! ! Thanks: ! ! Oscar van Vlijmen ! ! Parameters: ! ! Input, integer X, the argument of the PDF. ! 0 < X ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A < 1.0. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ) pdf integer x integer x2 cdf = 0.0D+00 do x2 = 1, x if ( x2 == 1 ) then pdf = - a / log ( 1.0D+00 - a ) else pdf = real ( x2 - 1, kind = 8 ) * a * pdf / real ( x2, kind = 8 ) end if cdf = cdf + pdf end do return end subroutine log_series_cdf_inv ( cdf, a, x ) !******************************************************************************* ! !! LOG_SERIES_CDF_INV inverts the Logarithmic Series CDF. ! ! Discussion: ! ! Simple summation is used. The only protection against an ! infinite loop caused by roundoff is that X cannot be larger ! than 1000. ! ! Modified: ! ! 18 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A < 1.0. ! ! Output, real ( kind = 8 ) X, the argument of the CDF for which ! CDF(X-1) <= CDF <= CDF(X). ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ) cdf2 real ( kind = 8 ) pdf integer x integer, parameter :: xmax = 1000 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LOG_SERIES_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if cdf2 = 0.0D+00 x = 1 do while ( cdf2 < cdf .and. x < xmax ) if ( x == 1 ) then pdf = - a / log ( 1.0D+00 - a ) else pdf = real ( x - 1, kind = 8 ) * a * pdf / real ( x, kind = 8 ) end if cdf2 = cdf2 + pdf x = x + 1 end do return end subroutine log_series_cdf_values ( n_data, t, n, fx ) !******************************************************************************* ! !! LOG_SERIES_CDF_VALUES returns some values of the log series CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`DiscreteDistributions`] ! dist = LogSeriesDistribution [ t ] ! CDF [ dist, n ] ! ! Modified: ! ! 27 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) T, the parameter of the function. ! ! Output, integer N, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 29 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.9491221581029903D+00, & 0.9433541128559735D+00, & 0.9361094611773272D+00, & 0.9267370278044118D+00, & 0.9141358246245129D+00, & 0.8962840235449100D+00, & 0.8690148741955517D+00, & 0.8221011541254772D+00, & 0.7213475204444817D+00, & 0.6068261510845583D+00, & 0.5410106403333613D+00, & 0.4970679476476894D+00, & 0.4650921887927060D+00, & 0.4404842934597863D+00, & 0.4207860535926143D+00, & 0.4045507673897055D+00, & 0.3908650337129266D+00, & 0.2149757685421097D+00, & 0.0000000000000000D+00, & 0.2149757685421097D+00, & 0.3213887739704539D+00, & 0.3916213575531612D+00, & 0.4437690508633213D+00, & 0.4850700239649681D+00, & 0.5191433267738267D+00, & 0.5480569580144867D+00, & 0.5731033910767085D+00, & 0.5951442521714636D+00, & 0.6147826594068904D+00 /) integer n integer n_data integer, save, dimension ( n_max ) :: n_vec = (/ & 1, 1, 1, 1, 1, & 1, 1, 1, 1, 1, & 1, 1, 1, 1, 1, & 1, 1, 1, 0, 1, & 2, 3, 4, 5, 6, & 7, 8, 9, 10 /) real ( kind = 8 ) t real ( kind = 8 ), save, dimension ( n_max ) :: t_vec = (/ & 0.1000000000000000D+00, & 0.1111111111111111D+00, & 0.1250000000000000D+00, & 0.1428571428571429D+00, & 0.1666666666666667D+00, & 0.2000000000000000D+00, & 0.2500000000000000D+00, & 0.3333333333333333D+00, & 0.5000000000000000D+00, & 0.6666666666666667D+00, & 0.7500000000000000D+00, & 0.8000000000000000D+00, & 0.8333333333333333D+00, & 0.8571485714857149D+00, & 0.8750000000000000D+00, & 0.8888888888888889D+00, & 0.9000000000000000D+00, & 0.9900000000000000D+00, & 0.9900000000000000D+00, & 0.9900000000000000D+00, & 0.9900000000000000D+00, & 0.9900000000000000D+00, & 0.9900000000000000D+00, & 0.9900000000000000D+00, & 0.9900000000000000D+00, & 0.9900000000000000D+00, & 0.9900000000000000D+00, & 0.9900000000000000D+00, & 0.9900000000000000D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 t = 0.0D+00 n = 0 fx = 0.0D+00 else t = t_vec(n_data) n = n_vec(n_data) fx = fx_vec(n_data) end if return end function log_series_check ( a ) !******************************************************************************* ! !! LOG_SERIES_CHECK checks the parameter of the Logarithmic Series PDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A < 1.0. ! ! Output, logical LOG_SERIES_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a logical log_series_check if ( a <= 0.0D+00 .or. 1.0D+00 <= a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LOG_SERIES_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.0D+00 or 1.0D+00 <= A' log_series_check = .false. return end if log_series_check = .true. return end subroutine log_series_mean ( a, mean ) !******************************************************************************* ! !! LOG_SERIES_MEAN returns the mean of the Logarithmic Series PDF. ! ! Modified: ! ! 20 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A < 1.0. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) mean mean = - a / ( ( 1.0D+00 - a ) * log ( 1.0D+00 - a ) ) return end subroutine log_series_pdf ( x, a, pdf ) !******************************************************************************* ! !! LOG_SERIES_PDF evaluates the Logarithmic Series PDF. ! ! Formula: ! ! PDF(A;X) = - A**X / ( X * log ( 1 - A ) ) ! ! Modified: ! ! 20 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the PDF. ! 0 < X ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A < 1.0. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) pdf integer x if ( x <= 0 ) then pdf = 0.0D+00 else pdf = - a**x / ( real ( x, kind = 8 ) * log ( 1.0D+00 - a ) ) end if return end subroutine log_series_sample ( a, seed, x ) !******************************************************************************* ! !! LOG_SERIES_SAMPLE samples the Logarithmic Series PDF. ! ! Modified: ! ! 06 March 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Luc Devroye, ! Non-Uniform Random Variate Generation, ! Springer-Verlag, New York, 1986, page 547. ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A < 1.0. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) u real ( kind = 8 ) v integer x u = d_uniform_01 ( seed ) v = d_uniform_01 ( seed ) x = int ( 1.0D+00 + log ( v ) / ( log ( 1.0D+00 - ( 1.0D+00 - a )**u ) ) ) return end subroutine log_series_variance ( a, variance ) !******************************************************************************* ! !! LOG_SERIES_VARIANCE returns the variance of the Logarithmic Series PDF. ! ! Modified: ! ! 20 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A < 1.0. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) alpha real ( kind = 8 ) variance alpha = - 1.0D+00 / log ( 1.0D+00 - a ) variance = a * alpha * ( 1.0D+00 - alpha * a ) / ( 1.0D+00 - a )**2 return end subroutine log_uniform_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! LOG_UNIFORM_CDF evaluates the Log Uniform CDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x <= a ) then cdf = 0.0D+00 else if ( x < b ) then cdf = ( log ( x ) - log ( a ) ) / ( log ( b ) - log ( a ) ) else cdf = 1.0D+00 end if return end subroutine log_uniform_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! LOG_UNIFORM_CDF_INV inverts the Log Uniform CDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LOG_UNIFORM_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = a * exp ( ( log ( b ) - log ( a ) ) * cdf ) return end function log_uniform_check ( a, b ) !******************************************************************************* ! !! LOG_UNIFORM_CHECK checks the parameters of the Log Uniform CDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 1.0 < A < B. ! ! Output, logical LOG_UNIFORM_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical log_uniform_check if ( a <= 1.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LOG_UNIFORM_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 1.' log_uniform_check = .false. return end if if ( b <= a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LOG_UNIFORM_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= A.' log_uniform_check = .false. return end if log_uniform_check = .true. return end subroutine log_uniform_mean ( a, b, mean ) !******************************************************************************* ! !! LOG_UNIFORM_MEAN returns the mean of the Log Uniform PDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 1.0 < A < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = ( b - a ) / ( log ( b ) - log ( a ) ) return end subroutine log_uniform_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! LOG_UNIFORM_PDF evaluates the Log Uniform PDF. ! ! Discussion: ! ! PDF(A,B;X) = 1 / ( X * ( log ( B ) - log ( A ) ) ) for A <= X <= B ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 1.0 < A < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x < a ) then pdf = 0.0D+00 else if ( x <= b ) then pdf = 1.0D+00 / ( x * ( log ( b ) - log ( a ) ) ) else pdf = 0.0D+00 end if return end subroutine log_uniform_sample ( a, b, seed, x ) !******************************************************************************* ! !! LOG_UNIFORM_SAMPLE samples the Log Uniform PDF. ! ! Modified: ! ! 20 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 1.0 < A < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call log_uniform_cdf_inv ( cdf, a, b, x ) return end subroutine lorentz_cdf ( x, cdf ) !******************************************************************************* ! !! LORENTZ_CDF evaluates the Lorentz CDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x cdf = 0.5D+00 + atan ( x ) / pi return end subroutine lorentz_cdf_inv ( cdf, x ) !******************************************************************************* ! !! LORENTZ_CDF_INV inverts the Lorentz CDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LORENTZ_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = tan ( pi * ( cdf - 0.5D+00 ) ) return end subroutine lorentz_mean ( mean ) !******************************************************************************* ! !! LORENTZ_MEAN returns the mean of the Lorentz PDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) mean mean = 0.0D+00 return end subroutine lorentz_pdf ( x, pdf ) !******************************************************************************* ! !! LORENTZ_PDF evaluates the Lorentz PDF. ! ! Formula: ! ! PDF(X) = 1 / ( PI * ( 1 + X**2 ) ) ! ! Discussion: ! ! The chief interest of the Lorentz PDF is that it is easily ! inverted, and can be used to dominate other PDF's in an ! acceptance/rejection method. ! ! LORENTZ_PDF(X) = CAUCHY_PDF(0,1;X) ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x pdf = 1.0D+00 / ( pi * ( 1.0D+00 + x * x ) ) return end subroutine lorentz_sample ( seed, x ) !******************************************************************************* ! !! LORENTZ_SAMPLE samples the Lorentz PDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call lorentz_cdf_inv ( cdf, x ) return end subroutine lorentz_variance ( variance ) !******************************************************************************* ! !! LORENTZ_VARIANCE returns the variance of the Lorentz PDF. ! ! Discussion: ! ! The variance of the Lorentz PDF is not well defined. This routine ! is made available for completeness only, and simply returns ! a "very large" number. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) VARIANCE, the mean of the PDF. ! implicit none real ( kind = 8 ) variance variance = huge ( variance ) return end subroutine maxwell_cdf ( x, a, cdf ) !******************************************************************************* ! !! MAXWELL_CDF evaluates the Maxwell CDF. ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0 < A. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ) gamma_inc real ( kind = 8 ) p2 real ( kind = 8 ) x real ( kind = 8 ) x2 if ( x <= 0.0D+00 ) then cdf = 0.0D+00 else x2 = x / a p2 = 1.5D+00 cdf = gamma_inc ( p2, x2 ) end if return end subroutine maxwell_cdf_inv ( cdf, a, x ) !******************************************************************************* ! !! MAXWELL_CDF_INV inverts the Maxwell CDF. ! ! Discussion: ! ! A simple bisection method is used. ! ! Modified: ! ! 01 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0 < A. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ) cdf1 real ( kind = 8 ) cdf2 real ( kind = 8 ) cdf3 integer it integer, parameter :: it_max = 100 real ( kind = 8 ), parameter :: tol = 0.0001D+00 real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 real ( kind = 8 ) x3 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAXWELL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = 0.0D+00 return else if ( 1.0D+00 == cdf ) then x = huge ( x ) return end if x1 = 0.0D+00 cdf1 = 0.0D+00 x2 = 1.0D+00 do call maxwell_cdf ( x2, a, cdf2 ) if ( cdf < cdf2 ) then exit end if x2 = 2.0D+00 * x2 if ( 1000000.0D+00 < x2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAXWELL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' Initial bracketing effort fails.' stop end if end do ! ! Now use bisection. ! it = 0 do it = it + 1 x3 = 0.5D+00 * ( x1 + x2 ) call maxwell_cdf ( x3, a, cdf3 ) if ( abs ( cdf3 - cdf ) < tol ) then x = x3 exit end if if ( it_max < it ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAXWELL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' Iteration limit exceeded.' stop end if if ( sign ( 1.0D+00, cdf3 - cdf ) == sign ( 1.0D+00, cdf1 - cdf ) ) then x1 = x3 cdf1 = cdf3 else x2 = x3 cdf2 = cdf3 end if end do return end function maxwell_check ( a ) !******************************************************************************* ! !! MAXWELL_CHECK checks the parameters of the Maxwell CDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0 < A. ! ! Output, logical MAXWELL_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a logical maxwell_check if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAXWELL_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.0.' maxwell_check = .false. return end if maxwell_check = .true. return end subroutine maxwell_mean ( a, mean ) !******************************************************************************* ! !! MAXWELL_MEAN returns the mean of the Maxwell PDF. ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0 < A. ! ! Output, real ( kind = 8 ) MEAN, the mean value. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) gamma real ( kind = 8 ) mean mean = sqrt ( 2.0D+00 ) * a * gamma ( 2.0D+00 ) / gamma ( 1.5D+00 ) return end subroutine maxwell_pdf ( x, a, pdf ) !******************************************************************************* ! !! MAXWELL_PDF evaluates the Maxwell PDF. ! ! Formula: ! ! PDF(A;X) = exp ( - 0.5D+00 * ( X / A )**2 ) * ( X / A )**2 / ! ( sqrt ( 2 ) * A * GAMMA ( 1.5D+00 ) ) ! ! Discussion: ! ! MAXWELL_PDF(A;X) = CHI_PDF(0,A,3;X) ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0 < X ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0 < A. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) gamma real ( kind = 8 ) pdf real ( kind = 8 ) x real ( kind = 8 ) y if ( x <= 0.0D+00 ) then pdf = 0.0D+00 else y = x / a pdf = exp ( - 0.5D+00 * y * y ) * y * y & / ( sqrt ( 2.0D+00 ) * a * gamma ( 1.5D+00 ) ) end if return end subroutine maxwell_sample ( a, seed, x ) !******************************************************************************* ! !! MAXWELL_SAMPLE samples the Maxwell PDF. ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0 < A. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a2 integer seed real ( kind = 8 ) x a2 = 3.0D+00 call chi_square_sample ( a2, seed, x ) x = a * sqrt ( x ) return end subroutine maxwell_variance ( a, variance ) !******************************************************************************* ! !! MAXWELL_VARIANCE returns the variance of the Maxwell PDF. ! ! Modified: ! ! 05 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0 < A. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) gamma real ( kind = 8 ) variance variance = a * a * ( 3.0D+00 - 2.0D+00 & * ( gamma ( 2.0D+00 ) / gamma ( 1.5D+00 ) )**2 ) return end function multicoef_check ( nfactor, factor ) !******************************************************************************* ! !! MULTICOEF_CHECK checks the parameters of the multinomial coefficient. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NFACTOR, the number of factors. ! 1 <= NFACTOR. ! ! Input, integer FACTOR(NFACTOR), contains the factors. ! 0.0D+00 <= FACTOR(I). ! ! Output, logical MULTICOEF_CHECK, is true if the parameters are legal. ! implicit none integer nfactor integer factor(nfactor) integer i logical multicoef_check if ( nfactor < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MULTICOEF_CHECK - Fatal error!' write ( *, '(a)' ) ' NFACTOR < 1.' multicoef_check = .false. return end if do i = 1, nfactor if ( factor(i) < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MULTICOEF_CHECK - Fatal error' write ( *, '(a,i8)' ) ' Factor ', I write ( *, '(a,i8)' ) ' = ', factor(i) write ( *, '(a)' ) ' But this value must be nonnegative.' multicoef_check = .false. return end if end do multicoef_check = .true. return end subroutine multinomial_coef1 ( nfactor, factor, ncomb ) !******************************************************************************* ! !! MULTINOMIAL_COEF1 computes a Multinomial coefficient. ! ! Definition: ! ! The multinomial coefficient is a generalization of the binomial ! coefficient. It may be interpreted as the number of combinations of ! N objects, where FACTOR(1) objects are indistinguishable of type 1, ! ... and FACTOR(NFACTOR) are indistinguishable of type NFACTOR, ! and N is the sum of FACTOR(1) through FACTOR(NFACTOR). ! ! Formula: ! ! NCOMB = N! / ( FACTOR(1)! FACTOR(2)! ... FACTOR(NFACTOR)! ) ! ! Method: ! ! The log of the gamma function is used, to avoid overflow. ! ! Modified: ! ! 02 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NFACTOR, the number of factors. ! 1 <= NFACTOR. ! ! Input, integer FACTOR(NFACTOR), contains the factors. ! 0.0D+00 <= FACTOR(I). ! ! Output, integer NCOMB, the value of the multinomial coefficient. ! implicit none integer nfactor logical check real ( kind = 8 ) facn integer factor(nfactor) real ( kind = 8 ) factorial_log integer i logical multicoef_check integer n integer ncomb check = multicoef_check ( nfactor, factor ) if ( .not. check ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MULTINOMIAL_COEF1 - Fatal error!' write ( *, '(a)' ) ' MULTICOEF_CHECK failed.' ncomb = -huge ( 1 ) return end if ! ! The factors sum to N. ! n = sum ( factor(1:nfactor) ) facn = factorial_log ( n ) do i = 1, nfactor facn = facn - factorial_log ( factor(i) ) end do ncomb = nint ( exp ( facn ) ) return end subroutine multinomial_coef2 ( nfactor, factor, ncomb ) !******************************************************************************* ! !! MULTINOMIAL_COEF2 computes a Multinomial coefficient. ! ! Definition: ! ! The multinomial coefficient is a generalization of the binomial ! coefficient. It may be interpreted as the number of combinations of ! N objects, where FACTOR(1) objects are indistinguishable of type 1, ! ... and FACTOR(NFACTOR) are indistinguishable of type NFACTOR, ! and N is the sum of FACTOR(1) through FACTOR(NFACTOR). ! ! Formula: ! ! NCOMB = N! / ( FACTOR(1)! FACTOR(2)! ... FACTOR(NFACTOR)! ) ! ! Method: ! ! A direct method is used, which should be exact. However, there ! is a possibility of intermediate overflow of the result. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NFACTOR, the number of factors. ! 1 <= NFACTOR. ! ! Input, integer FACTOR(NFACTOR), contains the factors. ! 0.0D+00 <= FACTOR(I). ! ! Output, integer NCOMB, the value of the multinomial coefficient. ! implicit none integer nfactor logical check integer factor(nfactor) integer i integer j integer k logical multicoef_check integer ncomb check = multicoef_check ( nfactor, factor ) if ( .not. check ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MULTINOMIAL_COEF2 - Fatal error!' write ( *, '(a)' ) ' MULTICOEF_CHECK failed.' ncomb = -huge ( 1 ) return end if ncomb = 1 k = 0 do i = 1, nfactor do j = 1, factor(i) k = k + 1 ncomb = ( ncomb * k ) / j end do end do return end function multinomial_check ( a, b, c ) !******************************************************************************* ! !! MULTINOMIAL_CHECK checks the parameters of the Multinomial PDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of trials. ! ! Input, integer B, the number of outcomes possible on one trial. ! 1 <= B. ! ! Input, real ( kind = 8 ) C(B). C(I) is the probability of outcome I on ! any trial. ! 0.0D+00 <= C(I) <= 1.0D+00, ! Sum ( 1 <= I <= B ) C(I) = 1.0. ! ! Output, logical MULTINOMIAL_CHECK, is true if the parameters are legal. ! implicit none integer b integer a real ( kind = 8 ) c(b) real ( kind = 8 ) c_sum integer i logical multinomial_check if ( b < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MULTINOMIAL_CHECK - Fatal error!' write ( *, '(a)' ) ' B < 1.' multinomial_check = .false. return end if do i = 1, b if ( c(i) < 0.0D+00 .or. 1.0D+00 < c(i) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MULTINOMIAL_CHECK - Fatal error!' write ( *, '(a)' ) ' Input C(I) is out of range.' multinomial_check = .false. return end if end do c_sum = sum ( c ) if ( 0.0001D+00 < abs ( 1.0D+00 - c_sum ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MULTINOMIAL_CHECK - Fatal error!' write ( *, '(a)' ) ' The probabilities do not sum to 1.' multinomial_check = .false. return end if multinomial_check = .true. return end subroutine multinomial_covariance ( a, b, c, covariance ) !******************************************************************************* ! !! MULTINOMIAL_COVARIANCE returns the covariances of the Multinomial PDF. ! ! Modified: ! ! 14 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of trials. ! ! Input, integer B, the number of outcomes possible on one trial. ! 1 <= B. ! ! Input, real ( kind = 8 ) C(B). C(I) is the probability of outcome I on ! any trial. ! 0.0D+00 <= C(I) <= 1.0D+00, ! SUM ( 1 <= I <= B) C(I) = 1.0. ! ! Output, real ( kind = 8 ) COVARIANCE(B,B), the covariance matrix. ! implicit none integer b integer a real ( kind = 8 ) c(b) real ( kind = 8 ) covariance(b,b) integer i integer j do i = 1, b do j = 1, b if ( i == j ) then covariance(i,j) = real ( a, kind = 8 ) * c(i) * ( 1.0D+00 - c(i) ) else covariance(i,j) = - real ( a, kind = 8 ) * c(i) * c(j) end if end do end do return end subroutine multinomial_mean ( a, b, c, mean ) !******************************************************************************* ! !! MULTINOMIAL_MEAN returns the means of the Multinomial PDF. ! ! Modified: ! ! 31 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of trials. ! ! Input, integer B, the number of outcomes possible on one trial. ! 1 <= B. ! ! Input, real ( kind = 8 ) C(B). C(I) is the probability of outcome I on ! any trial. ! 0.0D+00 <= C(I) <= 1.0D+00, ! SUM ( 1 <= I <= B) C(I) = 1.0. ! ! Output, real ( kind = 8 ) MEAN(B), MEAN(I) is the expected value of the ! number of outcome I in N trials. ! implicit none integer b integer a real ( kind = 8 ) c(b) real ( kind = 8 ) mean(b) mean(1:b) = real ( a, kind = 8 ) * c(1:b) return end subroutine multinomial_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! MULTINOMIAL_PDF computes a Multinomial PDF. ! ! Formula: ! ! PDF(A,B,C;X) = Comb(A,B,X) * Product ( 1 <= I <= B ) C(I)**X(I) ! ! where Comb(A,B,X) is the multinomial coefficient ! C( A; X(1), X(2), ..., X(B) ) ! ! Discussion: ! ! PDF(A,B,C;X) is the probability that in A trials there ! will be exactly X(I) occurrences of event I, whose probability ! on one trial is C(I), for I from 1 to B. ! ! As soon as A or B gets large, the number of possible X's explodes, ! and the probability of any particular X can become extremely small. ! ! Modified: ! ! 14 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X(B); X(I) counts the number of occurrences of ! outcome I, out of the total of A trials. ! ! Input, integer A, the total number of trials. ! ! Input, integer B, the number of different possible outcomes on ! one trial. ! ! Input, real ( kind = 8 ) C(B); C(I) is the probability of outcome I on ! any one trial. ! ! Output, real ( kind = 8 ) PDF, the value of the multinomial PDF. ! implicit none integer b integer a real ( kind = 8 ) c(b) real ( kind = 8 ) gamma_log integer i real ( kind = 8 ) pdf real ( kind = 8 ) pdf_log integer x(b) ! ! To try to avoid overflow, do the calculation in terms of logarithms. ! Note that Gamma(A+1) = A factorial. ! pdf_log = gamma_log ( real ( a + 1, kind = 8 ) ) do i = 1, b pdf_log = pdf_log + x(i) * log ( c(i) ) & - gamma_log ( real ( x(i) + 1, kind = 8 ) ) end do pdf = exp ( pdf_log ) return end subroutine multinomial_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! MULTINOMIAL_SAMPLE samples the Multinomial PDF. ! ! Modified: ! ! 14 February 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Luc Devroye, ! Non-Uniform Random Variate Generation, ! Springer-Verlag, New York, 1986, page 559. ! ! Parameters: ! ! Input, integer A, the total number of trials. ! 0 <= A. ! ! Input, integer B, the number of outcomes possible on one trial. ! 1 <= B. ! ! Input, real ( kind = 8 ) C(B). C(I) is the probability of outcome I on ! any trial. ! 0.0D+00 <= C(I) <= 1.0D+00, ! SUM ( 1 <= I <= B) C(I) = 1.0. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X(B); X(I) is the number of ! occurrences of event I during the N trials. ! implicit none integer b integer a real ( kind = 8 ) c(b) integer ifactor integer ntot real ( kind = 8 ) prob integer seed real ( kind = 8 ) sum2 integer x(b) ntot = a sum2 = 1.0D+00 x(1:b) = 0 do ifactor = 1, b - 1 prob = c(ifactor) / sum2 ! ! Generate a binomial random deviate for NTOT trials with ! single trial success probability PROB. ! call binomial_sample ( ntot, prob, seed, x(ifactor) ) ntot = ntot - x(ifactor) if ( ntot <= 0 ) then return end if sum2 = sum2 - c(ifactor) end do ! ! The last factor gets what's left. ! x(b) = ntot return end subroutine multinomial_variance ( a, b, c, variance ) !******************************************************************************* ! !! MULTINOMIAL_VARIANCE returns the variances of the Multinomial PDF. ! ! Modified: ! ! 31 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the number of trials. ! ! Input, integer B, the number of outcomes possible on one trial. ! 1 <= B. ! ! Input, real ( kind = 8 ) C(B). C(I) is the probability of outcome I on ! any trial. ! 0.0D+00 <= C(I) <= 1.0D+00, ! SUM ( 1 <= I <= B ) C(I) = 1.0. ! ! Output, real ( kind = 8 ) VARIANCE(B), VARIANCE(I) is the variance of the ! total number of events of type I. ! implicit none integer b integer a real ( kind = 8 ) c(b) integer i real ( kind = 8 ) variance(b) do i = 1, b variance(i) = real ( a, kind = 8 ) * c(i) * ( 1.0D+00 - c(i) ) end do return end subroutine multivariate_normal_sample ( n, mean, covar_factor, seed, x ) !******************************************************************************* ! !! MULTIVARIATE_NORMAL_SAMPLE samples the Multivariate Normal PDF. ! ! Discussion: ! ! PDF ( Mean(1:N), S(1:N,1:N); X(1:N) ) = 1 / ( 2 * pi * det ( S ) )^(N/2) ! * exp ( - ( X - Mean )' * inverse ( S ) * ( X - Mean ) / 2 ) ! ! Here, ! ! X is the argument vector of length N, ! Mean is the mean vector of length N, ! S is an N by N positive definite symmetric covariance matrix. ! ! The properties of S guarantee that it has a lower triangular ! matrix L, the Cholesky factor, such that S = L * L'. It is the ! matrix L, rather than S, that is required by this routine. ! ! Modified: ! ! 21 September 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jerry Banks, editor, ! Handbook of Simulation, ! Engineering and Management Press Books, 1998, page 167. ! ! Parameters: ! ! Input, integer N, the spatial dimension. ! ! Input, real ( kind = 8 ) MEAN(N), the mean vector. ! ! Input, real ( kind = 8 ) COVAR_FACTOR(N,N), the lower triangular Cholesky ! factor L of the covariance matrix S. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X(N), a sample point of the distribution. ! implicit none integer n real ( kind = 8 ) covar_factor(n,n) integer i integer j real ( kind = 8 ) mean(n) integer seed real ( kind = 8 ) x(n) real ( kind = 8 ) z do i = 1, n call normal_01_sample ( seed, z ) x(i) = mean(i) do j = 1, i x(i) = x(i) + covar_factor(i,j) * z end do end do return end subroutine nakagami_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! NAKAGAMI_CDF evaluates the Nakagami CDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) gamma_inc real ( kind = 8 ) p2 real ( kind = 8 ) x real ( kind = 8 ) x2 real ( kind = 8 ) y if ( x <= 0.0D+00 ) then cdf = 0.0D+00 else if ( 0.0D+00 < x ) then y = ( x - a ) / b x2 = c * y * y p2 = c cdf = gamma_inc ( p2, x2 ) end if return end function nakagami_check ( a, b, c ) !******************************************************************************* ! !! NAKAGAMI_CHECK checks the parameters of the Nakagami PDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, logical NAKAGAMI_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c logical nakagami_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NAKAGAMI_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' nakagami_check = .false. return end if if ( c <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NAKAGAMI_CHECK - Fatal error!' write ( *, '(a)' ) ' C <= 0.' nakagami_check = .false. return end if nakagami_check = .true. return end subroutine nakagami_mean ( a, b, c, mean ) !******************************************************************************* ! !! NAKAGAMI_MEAN returns the mean of the Nakagami PDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B ! 0.0D+00 < C ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) gamma real ( kind = 8 ) mean mean = a + b * gamma ( c + 0.5D+00 ) / ( sqrt ( c ) * gamma ( c ) ) return end subroutine nakagami_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! NAKAGAMI_PDF evaluates the Nakagami PDF. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) gamma real ( kind = 8 ) pdf real ( kind = 8 ) x real ( kind = 8 ) y if ( x <= 0.0D+00 ) then pdf = 0.0D+00 else if ( 0.0D+00 < x ) then y = ( x - a ) / b pdf = 2.0D+00 * c**c / ( b * gamma ( c ) ) * y**( 2.0D+00 * c - 1.0D+00 ) & * exp ( - c * y * y ) end if return end subroutine nakagami_variance ( a, b, c, variance ) !******************************************************************************* ! !! NAKAGAMI_VARIANCE returns the variance of the Nakagami PDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B ! 0.0D+00 < C ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) gamma real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) variance t1 = gamma ( c + 0.5D+00 ) t2 = gamma ( c ) variance = b * b * ( 1.0D+00 - t1 * t1 / ( c * t2 * t2 ) ) return end subroutine negative_binomial_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! NEGATIVE_BINOMIAL_CDF evaluates the Negative Binomial CDF. ! ! Discussion: ! ! A simple summing approach is used. ! ! Modified: ! ! 19 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the CDF. ! ! Input, integer A, a parameter of the PDF. ! 0 <= A. ! ! Input, real ( kind = 8 ) B, a parameter of the PDF. ! 0 < B <= 1. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) cdf integer cnk real ( kind = 8 ) pdf integer x integer y cdf = 0.0D+00 do y = a, x call binomial_coef ( y-1, a-1, cnk ) pdf = real ( cnk, kind = 8 ) * b**a * ( 1.0D+00 - b )**( y - a ) cdf = cdf + pdf end do return end subroutine negative_binomial_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! NEGATIVE_BINOMIAL_CDF_INV inverts the Negative Binomial CDF. ! ! Discussion: ! ! A simple discrete approach is used. ! ! Modified: ! ! 06 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, integer A, a parameter of the PDF. ! 0 <= A. ! ! Input, real ( kind = 8 ) B, a parameter of the PDF. ! 0 < B <= 1. ! ! Output, integer X, the smallest X whose cumulative density function ! is greater than or equal to CDF. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cum real ( kind = 8 ) pdf integer x integer, parameter :: x_max = 1000 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NEGATIVE_BINOMIAL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if cum = 0.0D+00 x = a do call negative_binomial_pdf ( x, a, b, pdf ) cum = cum + pdf if ( cdf <= cum .or. x_max <= x ) then exit end if x = x + 1 end do return end subroutine negative_binomial_cdf_values ( n_data, f, s, p, cdf ) !******************************************************************************* ! !! NEGATIVE_BINOMIAL_CDF_VALUES returns values of the negative binomial CDF. ! ! Discussion: ! ! Assume that a coin has a probability P of coming up heads on ! any one trial. Suppose that we plan to flip the coin until we ! achieve a total of S heads. If we let F represent the number of ! tails that occur in this process, then the value of F satisfies ! a negative binomial PDF: ! ! PDF(F,S,P) = Choose ( F from F+S-1 ) * P**S * (1-P)**F ! ! The negative binomial CDF is the probability that there are F or ! fewer failures upon the attainment of the S-th success. Thus, ! ! CDF(F,S,P) = sum ( 0 <= G <= F ) PDF(G,S,P) ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`DiscreteDistributions`] ! dist = NegativeBinomialDistribution [ s, p ] ! CDF [ dist, f ] ! ! Modified: ! ! 24 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! F C Powell, ! Statistical Tables for Sociology, Biology and Physical Sciences, ! Cambridge University Press, 1982. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer F, the maximum number of failures. ! ! Output, integer S, the number of successes. ! ! Output, real ( kind = 8 ) P, the probability of a success on one trial. ! ! Output, real ( kind = 8 ) CDF, the probability of at most F failures ! before the S-th success. ! implicit none integer, parameter :: n_max = 27 real ( kind = 8 ) cdf real ( kind = 8 ), save, dimension ( n_max ) :: cdf_vec = (/ & 0.6367187500000000D+00, & 0.3632812500000000D+00, & 0.1445312500000000D+00, & 0.5000000000000000D+00, & 0.2265625000000000D+00, & 0.6250000000000000D-01, & 0.3437500000000000D+00, & 0.1093750000000000D+00, & 0.1562500000000000D-01, & 0.1792000000000000D+00, & 0.4096000000000000D-01, & 0.4096000000000000D-02, & 0.7047000000000000D-01, & 0.1093500000000000D-01, & 0.7290000000000000D-03, & 0.9861587127990000D+00, & 0.9149749500510000D+00, & 0.7471846521450000D+00, & 0.8499053647030009D+00, & 0.5497160941090026D+00, & 0.2662040052146710D+00, & 0.6513215599000000D+00, & 0.2639010709000000D+00, & 0.7019082640000000D-01, & 0.1000000000000000D+01, & 0.1990000000000000D-01, & 0.1000000000000000D-03 /) integer f integer, save, dimension ( n_max ) :: f_vec = (/ & 4, 3, 2, & 3, 2, 1, & 2, 1, 0, & 2, 1, 0, & 2, 1, 0, & 11, 10, 9, & 17, 16, 15, & 9, 8, 7, & 2, 1, 0 /) integer n_data real ( kind = 8 ) p real ( kind = 8 ), save, dimension ( n_max ) :: p_vec = (/ & 0.50D+00, & 0.50D+00, & 0.50D+00, & 0.50D+00, & 0.50D+00, & 0.50D+00, & 0.50D+00, & 0.50D+00, & 0.50D+00, & 0.40D+00, & 0.40D+00, & 0.40D+00, & 0.30D+00, & 0.30D+00, & 0.30D+00, & 0.30D+00, & 0.30D+00, & 0.30D+00, & 0.10D+00, & 0.10D+00, & 0.10D+00, & 0.10D+00, & 0.10D+00, & 0.10D+00, & 0.10D-01, & 0.10D-01, & 0.10D-01 /) integer s integer, save, dimension ( n_max ) :: s_vec = (/ & 4, 5, 6, & 4, 5, 6, & 4, 5, 6, & 4, 5, 6, & 4, 5, 6, & 1, 2, 3, & 1, 2, 3, & 1, 2, 3, & 0, 1, 2 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 f = 0 s = 0 p = 0.0D+00 cdf = 0.0D+00 else f = f_vec(n_data) s = s_vec(n_data) p = p_vec(n_data) cdf = cdf_vec(n_data) end if return end function negative_binomial_check ( a, b ) !******************************************************************************* ! !! NEGATIVE_BINOMIAL_CHECK checks the parameters of the Negative Binomial PDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, a parameter of the PDF. ! 0 <= A. ! ! Input, real ( kind = 8 ) B, a parameter of the PDF. ! 0 < B <= 1. ! ! Output, logical NEGATIVE_BINOMIAL_CHECK, is true if the ! parameters are legal. ! implicit none integer a real ( kind = 8 ) b logical negative_binomial_check if ( a < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NEGATIVE_BINOMIAL_CHECK - Fatal error!' write ( *, '(a)' ) ' A < 0.' negative_binomial_check = .false. return end if if ( b <= 0.0D+00 .or. 1.0D+00 < b ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NEGATIVE_BINOMIAL_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0 or 1 < B.' negative_binomial_check = .false. return end if negative_binomial_check = .true. return end subroutine negative_binomial_mean ( a, b, mean ) !******************************************************************************* ! !! NEGATIVE_BINOMIAL_MEAN returns the mean of the Negative Binomial PDF. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, a parameter of the PDF. ! 0 <= A. ! ! Input, real ( kind = 8 ) B, a parameter of the PDF. ! 0 < B <= 1. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) mean mean = real ( a, kind = 8 ) / b return end subroutine negative_binomial_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! NEGATIVE_BINOMIAL_PDF evaluates the Negative Binomial PDF. ! ! Formula: ! ! PDF(A,B;X) = C(X-1,A-1) * B**A * ( 1 - B )**(X-A) ! ! Discussion: ! ! PDF(A,B;X) is the probability that the A-th success will ! occur on the X-th trial, given that the probability ! of a success on a single trial is B. ! ! The Negative Binomial PDF is also known as the Pascal PDF or ! the "Polya" PDF. ! ! NEGATIVE_BINOMIAL_PDF(1,B;X) = GEOMETRIC_PDF(B;X) ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the number of trials. ! A <= X. ! ! Input, integer A, the number of successes required. ! 0 <= A <= X, normally. ! ! Input, real ( kind = 8 ) B, the probability of a success on a single trial. ! 0.0D+00 < B <= 1.0. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none integer a real ( kind = 8 ) b integer cnk real ( kind = 8 ) pdf integer x if ( x < a ) then pdf = 0.0D+00 else call binomial_coef ( x-1, a-1, cnk ) pdf = real ( cnk, kind = 8 ) * b**a * ( 1.0D+00 - b )**( x - a ) end if return end subroutine negative_binomial_sample ( a, b, seed, x ) !******************************************************************************* ! !! NEGATIVE_BINOMIAL_SAMPLE samples the Negative Binomial PDF. ! ! Modified: ! ! 28 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, a parameter of the PDF. ! 0 <= A. ! ! Input, real ( kind = 8 ) B, a parameter of the PDF. ! 0 < B <= 1. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) d_uniform_01 integer num_success real ( kind = 8 ) r integer seed integer x if ( b == 1.0D+00 ) then x = a return else if ( b == 0.0D+00 ) then x = huge ( 1 ) return end if x = 0 num_success = 0 do while ( num_success < a ) x = x + 1 r = d_uniform_01 ( seed ) if ( r <= b ) then num_success = num_success + 1 end if end do return end subroutine negative_binomial_variance ( a, b, variance ) !******************************************************************************* ! !! NEGATIVE_BINOMIAL_VARIANCE returns the variance of the Negative Binomial PDF. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, a parameter of the PDF. ! 0 <= A. ! ! Input, real ( kind = 8 ) B, a parameter of the PDF. ! 0 < B <= 1. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) variance variance = real ( a, kind = 8 ) * ( 1.0D+00 - b ) / ( b * b ) return end subroutine normal_01_cdf ( x, cdf ) !******************************************************************************* ! !! NORMAL_01_CDF evaluates the Normal 01 CDF. ! ! Modified: ! ! 10 February 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! A G Adams, ! Areas Under the Normal Curve, ! Algorithm 39, ! Computer Journal, ! Volume 12, pages 197-198, 1969. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ), parameter :: a1 = 0.398942280444D+00 real ( kind = 8 ), parameter :: a2 = 0.399903438504D+00 real ( kind = 8 ), parameter :: a3 = 5.75885480458D+00 real ( kind = 8 ), parameter :: a4 = 29.8213557808D+00 real ( kind = 8 ), parameter :: a5 = 2.62433121679D+00 real ( kind = 8 ), parameter :: a6 = 48.6959930692D+00 real ( kind = 8 ), parameter :: a7 = 5.92885724438D+00 real ( kind = 8 ), parameter :: b0 = 0.398942280385D+00 real ( kind = 8 ), parameter :: b1 = 3.8052D-08 real ( kind = 8 ), parameter :: b2 = 1.00000615302D+00 real ( kind = 8 ), parameter :: b3 = 3.98064794D-04 real ( kind = 8 ), parameter :: b4 = 1.98615381364D+00 real ( kind = 8 ), parameter :: b5 = 0.151679116635D+00 real ( kind = 8 ), parameter :: b6 = 5.29330324926D+00 real ( kind = 8 ), parameter :: b7 = 4.8385912808D+00 real ( kind = 8 ), parameter :: b8 = 15.1508972451D+00 real ( kind = 8 ), parameter :: b9 = 0.742380924027D+00 real ( kind = 8 ), parameter :: b10 = 30.789933034D+00 real ( kind = 8 ), parameter :: b11 = 3.99019417011D+00 real ( kind = 8 ) cdf real ( kind = 8 ) q real ( kind = 8 ) x real ( kind = 8 ) y ! ! |X| <= 1.28. ! if ( abs ( x ) <= 1.28D+00 ) then y = 0.5D+00 * x * x q = 0.5D+00 - abs ( x ) * ( a1 - a2 * y / ( y + a3 - a4 / ( y + a5 & + a6 / ( y + a7 ) ) ) ) ! ! 1.28 < |X| <= 12.7 ! else if ( abs ( x ) <= 12.7D+00 ) then y = 0.5D+00 * x * x q = exp ( - y ) * b0 / ( abs ( x ) - b1 & + b2 / ( abs ( x ) + b3 & + b4 / ( abs ( x ) - b5 & + b6 / ( abs ( x ) + b7 & - b8 / ( abs ( x ) + b9 & + b10 / ( abs ( x ) + b11 ) ) ) ) ) ) ! ! 12.7 < |X| ! else q = 0.0D+00 end if ! ! Take account of negative X. ! if ( x < 0.0D+00 ) then cdf = q else cdf = 1.0D+00 - q end if return end subroutine normal_01_cdf_inv ( p, x ) !*********************************************************************** ! !! NORMAL_01_CDF_INV inverts the standard normal CDF. ! ! Discussion: ! ! The result is accurate to about 1 part in 10**16. ! ! Modified: ! ! 27 December 2004 ! ! Author: ! ! Michael Wichura ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Michael Wichura, ! The Percentage Points of the Normal Distribution, ! Algorithm AS 241, ! Applied Statistics, ! Volume 37, Number 3, pages 477-484, 1988. ! ! Parameters: ! ! Input, real ( kind = 8 ) P, the value of the cumulative probability ! densitity function. 0 < P < 1. If P is outside this range, an ! "infinite" value will be returned. ! ! Output, real ( kind = 8 ) X, the normal deviate value ! with the property that the probability of a standard normal deviate being ! less than or equal to the value is P. ! implicit none real ( kind = 8 ), parameter, dimension ( 8 ) :: a = (/ & 3.3871328727963666080D+00, & 1.3314166789178437745D+02, & 1.9715909503065514427D+03, & 1.3731693765509461125D+04, & 4.5921953931549871457D+04, & 6.7265770927008700853D+04, & 3.3430575583588128105D+04, & 2.5090809287301226727D+03 /) real ( kind = 8 ), parameter, dimension ( 8 ) :: b = (/ & 1.0D+00, & 4.2313330701600911252D+01, & 6.8718700749205790830D+02, & 5.3941960214247511077D+03, & 2.1213794301586595867D+04, & 3.9307895800092710610D+04, & 2.8729085735721942674D+04, & 5.2264952788528545610D+03 /) real ( kind = 8 ), parameter, dimension ( 8 ) :: c = (/ & 1.42343711074968357734D+00, & 4.63033784615654529590D+00, & 5.76949722146069140550D+00, & 3.64784832476320460504D+00, & 1.27045825245236838258D+00, & 2.41780725177450611770D-01, & 2.27238449892691845833D-02, & 7.74545014278341407640D-04 /) real ( kind = 8 ), parameter :: const1 = 0.180625D+00 real ( kind = 8 ), parameter :: const2 = 1.6D+00 real ( kind = 8 ) dpoly_value real ( kind = 8 ), parameter, dimension ( 8 ) :: d = (/ & 1.0D+00, & 2.05319162663775882187D+00, & 1.67638483018380384940D+00, & 6.89767334985100004550D-01, & 1.48103976427480074590D-01, & 1.51986665636164571966D-02, & 5.47593808499534494600D-04, & 1.05075007164441684324D-09 /) real ( kind = 8 ), parameter, dimension ( 8 ) :: e = (/ & 6.65790464350110377720D+00, & 5.46378491116411436990D+00, & 1.78482653991729133580D+00, & 2.96560571828504891230D-01, & 2.65321895265761230930D-02, & 1.24266094738807843860D-03, & 2.71155556874348757815D-05, & 2.01033439929228813265D-07 /) real ( kind = 8 ), parameter, dimension ( 8 ) :: f = (/ & 1.0D+00, & 5.99832206555887937690D-01, & 1.36929880922735805310D-01, & 1.48753612908506148525D-02, & 7.86869131145613259100D-04, & 1.84631831751005468180D-05, & 1.42151175831644588870D-07, & 2.04426310338993978564D-15 /) real ( kind = 8 ) p real ( kind = 8 ) q real ( kind = 8 ) r real ( kind = 8 ), parameter :: split1 = 0.425D+00 real ( kind = 8 ), parameter :: split2 = 5.0D+00 real ( kind = 8 ) x if ( p <= 0.0D+00 ) then x = -huge ( p ) return end if if ( 1.0D+00 <= p ) then x = huge ( p ) return end if q = p - 0.5D+00 if ( abs ( q ) <= split1 ) then r = const1 - q * q x = q * dpoly_value ( 8, a, r ) / dpoly_value ( 8, b, r ) else if ( q < 0.0D+00 ) then r = p else r = 1.0D+00 - p end if if ( r <= 0.0D+00 ) then x = -1.0D+00 stop end if r = sqrt ( -log ( r ) ) if ( r <= split2 ) then r = r - const2 x = dpoly_value ( 8, c, r ) / dpoly_value ( 8, d, r ) else r = r - split2 x = dpoly_value ( 8, e, r ) / dpoly_value ( 8, f, r ) end if if ( q < 0.0D+00 ) then x = -x end if end if return end subroutine normal_01_cdf_values ( n_data, x, fx ) !******************************************************************************* ! !! NORMAL_01_CDF_VALUES returns some values of the Normal 01 CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = NormalDistribution [ 0, 1 ] ! CDF [ dist, x ] ! ! Modified: ! ! 28 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 17 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.5000000000000000D+00, & 0.5398278372770290D+00, & 0.5792597094391030D+00, & 0.6179114221889526D+00, & 0.6554217416103242D+00, & 0.6914624612740131D+00, & 0.7257468822499270D+00, & 0.7580363477769270D+00, & 0.7881446014166033D+00, & 0.8159398746532405D+00, & 0.8413447460685429D+00, & 0.9331927987311419D+00, & 0.9772498680518208D+00, & 0.9937903346742239D+00, & 0.9986501019683699D+00, & 0.9997673709209645D+00, & 0.9999683287581669D+00 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.0000000000000000D+00, & 0.1000000000000000D+00, & 0.2000000000000000D+00, & 0.3000000000000000D+00, & 0.4000000000000000D+00, & 0.5000000000000000D+00, & 0.6000000000000000D+00, & 0.7000000000000000D+00, & 0.8000000000000000D+00, & 0.9000000000000000D+00, & 0.1000000000000000D+01, & 0.1500000000000000D+01, & 0.2000000000000000D+01, & 0.2500000000000000D+01, & 0.3000000000000000D+01, & 0.3500000000000000D+01, & 0.4000000000000000D+01 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 fx = 0.0D+00 else x = x_vec(n_data) fx = fx_vec(n_data) end if return end subroutine normal_01_mean ( mean ) !******************************************************************************* ! !! NORMAL_01_MEAN returns the mean of the Normal 01 PDF. ! ! Modified: ! ! 04 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) mean mean = 0.0D+00 return end subroutine normal_01_pdf ( x, pdf ) !******************************************************************************* ! !! NORMAL_01_PDF evaluates the Normal 01 PDF. ! ! Discussion: ! ! The Normal 01 PDF is also called the "Standard Normal" PDF, or ! the Normal PDF with 0 mean and variance 1. ! ! Formula: ! ! PDF(X) = exp ( - 0.5 * X**2 ) / sqrt ( 2 * PI ) ! ! Modified: ! ! 04 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x pdf = exp ( -0.5D+00 * x * x ) / sqrt ( 2.0D+00 * pi ) return end subroutine normal_01_sample ( seed, x ) !******************************************************************************* ! !! NORMAL_01_SAMPLE samples the standard normal probability distribution. ! ! Discussion: ! ! The standard normal probability distribution function (PDF) has ! mean 0 and standard deviation 1. ! ! Method: ! ! The Box-Muller method is used, which is efficient, but ! generates two values at a time. ! ! Modified: ! ! 02 February 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the standard normal PDF. ! implicit none real ( kind = 8 ) d_uniform_01 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r1 real ( kind = 8 ) r2 integer seed integer, save :: used = -1 real ( kind = 8 ) x real ( kind = 8 ), save :: y = 0.0D+00 if ( used == -1 ) then used = 0 end if ! ! If we've used an even number of values so far, generate two more, ! return one and save one. ! if ( mod ( used, 2 ) == 0 ) then do r1 = d_uniform_01 ( seed ) if ( r1 /= 0.0D+00 ) then exit end if end do r2 = d_uniform_01 ( seed ) x = sqrt ( -2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * pi * r2 ) y = sqrt ( -2.0D+00 * log ( r1 ) ) * sin ( 2.0D+00 * pi * r2 ) ! ! Otherwise, return the second, saved, value. ! else x = y end if used = used + 1 return end subroutine normal_01_variance ( variance ) !******************************************************************************* ! !! NORMAL_01_VARIANCE returns the variance of the Normal 01 PDF. ! ! Modified: ! ! 05 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) variance variance = 1.0D+00 return end subroutine normal_01_vector ( n, seed, x ) !******************************************************************************* ! !! NORMAL_01_VECTOR samples the standard normal probability distribution. ! ! Discussion: ! ! The standard normal probability distribution function (PDF) has ! mean 0 and standard deviation 1. ! ! This routine can generate a vector of values on one call. It ! has the feature that it should provide the same results ! in the same order no matter how we break up the task. ! ! Before calling this routine, the user may call RANDOM_SEED ! in order to set the seed of the random number generator. ! ! Method: ! ! The Box-Muller method is used, which is efficient, but ! generates an even number of values each time. On any call ! to this routine, an even number of new values are generated. ! Depending on the situation, one value may be left over. ! In that case, it is saved for the next call. ! ! Modified: ! ! 19 October 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of values desired. If N is negative, ! then the code will flush its internal memory; in particular, ! if there is a saved value to be used on the next call, it is ! instead discarded. This is useful if the user has reset the ! random number seed, for instance. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF. ! ! Local parameters: ! ! Local, integer MADE, records the number of values that have ! been computed. On input with negative N, this value overwrites ! the return value of N, so the user can get an accounting of ! how much work has been done. ! ! Local, real R(N+1), is used to store some uniform random values. ! Its dimension is N+1, but really it is only needed to be the ! smallest even number greater than or equal to N. ! ! Local, integer SAVED, is 0 or 1 depending on whether there is a ! single saved value left over from the previous call. ! ! Local, integer X_LO_INDEX, X_HI_INDEX, records the range of entries of ! X that we need to compute. This starts off as 1:N, but is adjusted ! if we have a saved value that can be immediately stored in X(1), ! and so on. ! ! Local, real Y, the value saved from the previous call, if ! SAVED is 1. ! implicit none integer n real ( kind = 8 ) d_uniform_01 integer m integer, save :: made = 0 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r(n+1) integer, save :: saved = 0 integer seed real ( kind = 8 ) x(n) integer x_hi_index integer x_lo_index real ( kind = 8 ), save :: y = 0.0D+00 ! ! I'd like to allow the user to reset the internal data. ! But this won't work properly if we have a saved value Y. ! I'm making a crock option that allows the user to signal ! explicitly that any internal memory should be flushed, ! by passing in a negative value for N. ! if ( n < 0 ) then made = 0 saved = 0 y = 0.0D+00 return else if ( n == 0 ) then return end if ! ! Record the range of X we need to fill in. ! x_lo_index = 1 x_hi_index = n ! ! Use up the old value, if we have it. ! if ( saved == 1 ) then x(1) = y saved = 0 x_lo_index = 2 end if ! ! Maybe we don't need any more values. ! if ( x_hi_index - x_lo_index + 1 == 0 ) then ! ! If we need just one new value, do that here to avoid null arrays. ! else if ( x_hi_index - x_lo_index + 1 == 1 ) then r(1) = d_uniform_01 ( seed ) r(2) = d_uniform_01 ( seed ) x(x_hi_index) = & sqrt ( -2.0D+00 * log ( r(1) ) ) * cos ( 2.0D+00 * pi * r(2) ) y = sqrt ( -2.0D+00 * log ( r(1) ) ) * sin ( 2.0D+00 * pi * r(2) ) saved = 1 made = made + 2 ! ! If we require an even number of values, that's easy. ! else if ( mod ( x_hi_index - x_lo_index + 1, 2 ) == 0 ) then m = ( x_hi_index - x_lo_index + 1 ) / 2 call dvec_uniform_01 ( 2*m, seed, r ) x(x_lo_index:x_hi_index-1:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-1:2) ) ) & * cos ( 2.0D+00 * pi * r(2:2*m:2) ) x(x_lo_index+1:x_hi_index:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-1:2) ) ) & * sin ( 2.0D+00 * pi * r(2:2*m:2) ) made = made + x_hi_index - x_lo_index + 1 ! ! If we require an odd number of values, we generate an even number, ! and handle the last pair specially, storing one in X(N), and ! saving the other for later. ! else x_hi_index = x_hi_index - 1 m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1 call dvec_uniform_01 ( 2*m, seed, r ) x(x_lo_index:x_hi_index-1:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-3:2) ) ) & * cos ( 2.0D+00 * pi * r(2:2*m-2:2) ) x(x_lo_index+1:x_hi_index:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-3:2) ) ) & * sin ( 2.0D+00 * pi * r(2:2*m-2:2) ) x(n) = sqrt ( -2.0D+00 * log ( r(2*m-1) ) ) & * cos ( 2.0D+00 * pi * r(2*m) ) y = sqrt ( -2.0D+00 * log ( r(2*m-1) ) ) & * sin ( 2.0D+00 * pi * r(2*m) ) saved = 1 made = made + x_hi_index - x_lo_index + 2 end if return end subroutine normal_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! NORMAL_CDF evaluates the Normal CDF. ! ! Modified: ! ! 23 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b call normal_01_cdf ( y, cdf ) return end subroutine normal_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! NORMAL_CDF_INV inverts the Normal CDF. ! ! Modified: ! ! 23 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x real ( kind = 8 ) x2 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NORMAL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if call normal_01_cdf_inv ( cdf, x2 ) x = a + b * x2 return end subroutine normal_cdf_values ( n_data, mu, sigma, x, fx ) !******************************************************************************* ! !! NORMAL_CDF_VALUES returns some values of the Normal CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = NormalDistribution [ mu, sigma ] ! CDF [ dist, x ] ! ! Modified: ! ! 05 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) MU, the mean of the distribution. ! ! Output, real ( kind = 8 ) SIGMA, the variance of the distribution. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 12 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.5000000000000000D+00, & 0.9772498680518208D+00, & 0.9999683287581669D+00, & 0.9999999990134124D+00, & 0.6914624612740131D+00, & 0.6305586598182364D+00, & 0.5987063256829237D+00, & 0.5792597094391030D+00, & 0.6914624612740131D+00, & 0.5000000000000000D+00, & 0.3085375387259869D+00, & 0.1586552539314571D+00 /) real ( kind = 8 ) mu real ( kind = 8 ), save, dimension ( n_max ) :: mu_vec = (/ & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01 /) integer n_data real ( kind = 8 ) sigma real ( kind = 8 ), save, dimension ( n_max ) :: sigma_vec = (/ & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01 /) real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 mu = 0.0D+00 sigma = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else mu = mu_vec(n_data) sigma = sigma_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function normal_check ( a, b ) !******************************************************************************* ! !! NORMAL_CHECK checks the parameters of the Normal PDF. ! ! ! Modified: ! ! 18 September 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, logical NORMAL_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical normal_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NORMAL_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' normal_check = .false. return end if normal_check = .true. return end subroutine normal_mean ( a, b, mean ) !******************************************************************************* ! !! NORMAL_MEAN returns the mean of the Normal PDF. ! ! Modified: ! ! 10 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a return end subroutine normal_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! NORMAL_PDF evaluates the Normal PDF. ! ! Formula: ! ! PDF(A,B;X) ! = exp ( - 0.5D+00 * ( ( X - A ) / B )**2 ) / ( B * sqrt ( 2 * PI ) ) ! ! Discussion: ! ! The normal PDF is also known as the Gaussian PDF. ! ! Modified: ! ! 10 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b pdf = exp ( - 0.5D+00 * y * y ) / ( b * sqrt ( 2.0D+00 * pi ) ) return end subroutine normal_sample ( a, b, seed, x ) !******************************************************************************* ! !! NORMAL_SAMPLE samples the Normal PDF. ! ! Discussion: ! ! The Box-Muller method is used. ! ! Modified: ! ! 10 October 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer seed real ( kind = 8 ) x call normal_01_sample ( seed, x ) x = a + b * x return end subroutine normal_variance ( a, b, variance ) !******************************************************************************* ! !! NORMAL_VARIANCE returns the variance of the Normal PDF. ! ! Modified: ! ! 10 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = b * b return end subroutine normal_vector ( n, mean, dev, seed, x ) !******************************************************************************* ! !! NORMAL_VECTOR samples the normal probability distribution. ! ! Discussion: ! ! The normal probability distribution function (PDF) has ! a user-specified mean and standard deviation. ! ! This routine can generate a vector of values on one call. It ! has the feature that it should provide the same results ! in the same order no matter how we break up the task. ! ! Before calling this routine, the user may call RANDOM_SEED ! in order to set the seed of the random number generator. ! ! Method: ! ! The Box-Muller method is used, which is efficient, but ! generates an even number of values each time. On any call ! to this routine, an even number of new values are generated. ! Depending on the situation, one value may be left over. ! In that case, it is saved for the next call. ! ! Modified: ! ! 19 October 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of values desired. If N is negative, ! then the code will flush its internal memory; in particular, ! if there is a saved value to be used on the next call, it is ! instead discarded. This is useful if the user has reset the ! random number seed, for instance. ! ! Input, real ( kind = 8 ) MEAN, the desired mean value. ! ! Input, real ( kind = 8 ) DEV, the desired standard deviation. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF. ! implicit none integer n integer seed real ( kind = 8 ) x(n) real ( kind = 8 ) dev real ( kind = 8 ) mean call normal_01_vector ( n, seed, x ) x(1:n) = mean + dev * x(1:n) return end subroutine owen_values ( n_data, h, a, t ) !******************************************************************************* ! !! OWEN_VALUES returns some values of Owen's T function. ! ! Discussion: ! ! Owen's T function is useful for computation of the bivariate normal ! distribution and the distribution of a skewed normal distribution. ! ! Although it was originally formulated in terms of the bivariate ! normal function, the function can be defined more directly as ! ! T(H,A) = 1 / ( 2 * pi ) * ! Integral ( 0 <= X <= A ) e^(-H^2*(1+X^2)/2) / (1+X^2) dX ! ! In Mathematica, the function can be evaluated by: ! ! fx = 1/(2*Pi) * Integrate [ E^(-h^2*(1+x^2)/2)/(1+x^2), {x,0,a} ] ! ! Modified: ! ! 10 December 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) H, a parameter. ! ! Output, real ( kind = 8 ) A, the upper limit of the integral. ! ! Output, real ( kind = 8 ) T, the value of the function. ! implicit none integer, parameter :: n_max = 22 real ( kind = 8 ) a real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ & 0.5000000000000000D+00, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.5000000000000000D+00, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.5000000000000000D+00, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.5000000000000000D+00, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.5000000000000000D+00, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.1000000000000000D+02, & 0.1000000000000000D+03 /) real ( kind = 8 ) h real ( kind = 8 ), save, dimension ( n_max ) :: h_vec = (/ & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.2500000000000000D+00, & 0.2500000000000000D+00, & 0.2500000000000000D+00, & 0.2500000000000000D+00, & 0.1250000000000000D+00, & 0.1250000000000000D+00, & 0.1250000000000000D+00, & 0.1250000000000000D+00, & 0.7812500000000000D-02, & 0.7812500000000000D-02, & 0.7812500000000000D-02, & 0.7812500000000000D-02, & 0.7812500000000000D-02, & 0.7812500000000000D-02 /) integer n_data real ( kind = 8 ) t real ( kind = 8 ), save, dimension ( n_max ) :: t_vec = (/ & 0.4306469112078537D-01, & 0.6674188216570097D-01, & 0.7846818699308410D-01, & 0.7929950474887259D-01, & 0.6448860284750376D-01, & 0.1066710629614485D+00, & 0.1415806036539784D+00, & 0.1510840430760184D+00, & 0.7134663382271778D-01, & 0.1201285306350883D+00, & 0.1666128410939293D+00, & 0.1847501847929859D+00, & 0.7317273327500385D-01, & 0.1237630544953746D+00, & 0.1737438887583106D+00, & 0.1951190307092811D+00, & 0.7378938035365546D-01, & 0.1249951430754052D+00, & 0.1761984774738108D+00, & 0.1987772386442824D+00, & 0.2340886964802671D+00, & 0.2479460829231492D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 h = 0.0D+00 a = 0.0D+00 t = 0.0D+00 else h = h_vec(n_data) a = a_vec(n_data) t = t_vec(n_data) end if return end subroutine pareto_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! PARETO_CDF evaluates the Pareto CDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x < a ) then cdf = 0.0D+00 else cdf = 1.0D+00 - ( a / x )**b end if return end subroutine pareto_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! PARETO_CDF_INV inverts the Pareto CDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PARETO_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = a / ( 1.0D+00 - cdf )**( 1.0D+00 / b ) return end function pareto_check ( a, b ) !******************************************************************************* ! !! PARETO_CHECK checks the parameters of the Pareto CDF. ! ! Modified: ! ! 18 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, logical PARETO_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical pareto_check if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PARETO_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.' pareto_check = .false. return end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PARETO_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' pareto_check = .false. return end if pareto_check = .true. return end subroutine pareto_mean ( a, b, mean ) !******************************************************************************* ! !! PARETO_MEAN returns the mean of the Pareto PDF. ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean if ( b <= 1.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PARETO_MEAN - Fatal error!' write ( *, '(a)' ) ' For B <= 1, the mean does not exist.' mean = 0.0D+00 return end if mean = b * a / ( b - 1.0D+00 ) return end subroutine pareto_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! PARETO_PDF evaluates the Pareto PDF. ! ! Formula: ! ! PDF(A,B;X) = B * A**B / X**(B+1). ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A <= X ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x < a ) then pdf = 0.0D+00 else pdf = b * a**b / x**( b + 1.0D+00 ) end if return end subroutine pareto_sample ( a, b, seed, x ) !******************************************************************************* ! !! PARETO_SAMPLE samples the Pareto PDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call pareto_cdf_inv ( cdf, a, b, x ) return end subroutine pareto_variance ( a, b, variance ) !******************************************************************************* ! !! PARETO_VARIANCE returns the variance of the Pareto PDF. ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance if ( b <= 2.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PARETO_VARIANCE - Warning!' write ( *, '(a)' ) ' For B <= 2, the variance does not exist.' variance = 0.0D+00 return end if variance = a * a * b / ( ( b - 1.0D+00 )**2 * ( b - 2.0D+00 ) ) return end function pearson_05_check ( a, b, c ) !******************************************************************************* ! !! PEARSON_05_CHECK checks the parameters of the Pearson 5 PDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < A, 0.0D+00 < B. ! ! Output, logical PEARSON_05_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c logical pearson_05_check if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PEARSON_05_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.' pearson_05_check = .false. return end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PEARSON_05_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' pearson_05_check = .false. return end if pearson_05_check = .true. return end subroutine pearson_05_mean ( a, b, c, mean ) !******************************************************************************* ! !! PEARSON_05_MEAN evaluates the mean of the Pearson 5 PDF. ! ! Discussion: ! ! The mean is undefined for B <= 1. ! ! Modified: ! ! 05 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < A, 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) mean if ( b <= 1.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PEARSON_05_MEAN - Warning!' write ( *, '(a)' ) ' MEAN undefined for B <= 1.' mean = c return end if mean = c + a / ( b - 1.0D+00 ) return end subroutine pearson_05_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! PEARSON_05_PDF evaluates the Pearson 5 PDF. ! ! Formula: ! ! PDF(A,B;X) = A**B * ( X - C )**(-B-1) ! * exp ( - A / ( X - C ) ) / Gamma ( B ) ! ! Modified: ! ! 04 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! C < X ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < A, 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) gamma real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x <= c ) then pdf = 0.0D+00 else pdf = a**b * ( x - c )**( - b - 1.0D+00 ) & * exp ( - a / ( x - c ) ) / gamma ( b ) end if return end subroutine pearson_05_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! PEARSON_05_SAMPLE samples the Pearson 5 PDF. ! ! Modified: ! ! 05 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < A, 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a2 real ( kind = 8 ) b real ( kind = 8 ) b2 real ( kind = 8 ) c real ( kind = 8 ) c2 integer seed real ( kind = 8 ) x real ( kind = 8 ) x2 a2 = 0.0D+00 b2 = b c2 = 1.0D+00 / a call gamma_sample ( a2, b2, c2, seed, x2 ) x = c + 1.0D+00 / x2 return end function planck_check ( a, b ) !******************************************************************************* ! !! PLANCK_CHECK checks the parameters of the Planck PDF. ! ! Modified: ! ! 26 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, ! 0.0D+00 < B. ! ! Output, logical PLANCK_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical planck_check if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PLANCK_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.' planck_check = .false. return end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PLANCK_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' planck_check = .false. return end if planck_check = .true. return end subroutine planck_mean ( a, b, mean ) !******************************************************************************* ! !! PLANCK_MEAN returns the mean of the Planck PDF. ! ! Modified: ! ! 25 October 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0 < A, 0.0 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean real ( kind = 8 ) zeta mean = ( b + 1.0D+00 ) * zeta ( b + 2.0D+00 ) / zeta ( b + 1.0D+00 ) return end subroutine planck_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! PLANCK_PDF evaluates the Planck PDF. ! ! Discussion: ! ! The Planck PDF has the form ! ! PDF(A,B;X) = A**(B+1) * X**B / ( exp ( A * X ) - 1 ) / K ! ! where K is the normalization constant, and has the value ! ! K = Gamma ( B + 1 ) * Zeta ( B + 1 ). ! ! The original Planck distribution governed the frequencies in ! blackbody radiation at a given temperature T, and has the form ! ! PDF(A;X) = K * X**3 / ( exp ( A * X ) - 1 ) ! ! with ! ! K = 15 / PI**4. ! ! Thus, in terms of the Planck PDF, the original Planck distribution ! has A = 1, B = 3. ! ! Modified: ! ! 25 October 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Johnson and Kotz, ! Continuous Univariate Distributions, ! Volume 2, Chapter 33, ! Wiley. ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0 < A, 0.0 < B. ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0 <= X ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) gamma real ( kind = 8 ) k real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) zeta if ( x < 0.0D+00 ) then pdf = 0.0D+00 else k = gamma ( b + 1.0D+00 ) * zeta ( b + 1.0D+00 ) pdf = a**( b + 1.0D+00 ) * x**b / ( exp ( a * x ) - 1.0D+00 ) / k end if return end subroutine planck_sample ( a, b, seed, x ) !******************************************************************************* ! !! PLANCK_SAMPLE samples the Planck PDF. ! ! Discussion: ! ! The Planck sampling seems to be giving incorrect results. ! I suspect this has to do with a possible problem in the ! ZIPF_SAMPLE routine. ! ! Modified: ! ! 25 October 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Luc Devroye, ! Non-Uniform Random Variate Generation, ! Springer Verlag, 1986, pages 552. ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0 < A, 0.0 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a2 real ( kind = 8 ) b real ( kind = 8 ) b2 real ( kind = 8 ) c2 real ( kind = 8 ) g integer seed real ( kind = 8 ) x integer z a2 = 0.0D+00 b2 = 1.0D+00 c2 = b + 1.0D+00 call gamma_sample ( a2, b2, c2, seed, g ) call zipf_sample ( c2, seed, z ) x = g / ( a * real ( z, kind = 8 ) ) return end subroutine planck_variance ( a, b, variance ) !******************************************************************************* ! !! PLANCK_VARIANCE returns the variance of the Planck PDF. ! ! Modified: ! ! 13 December 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0 < A, 0.0 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean real ( kind = 8 ) variance real ( kind = 8 ) zeta call planck_mean ( a, b, mean ) variance = ( b + 1.0D+00 ) * ( b + 2.0D+00 ) & * zeta ( b + 3.0D+00 ) / zeta ( b + 1.0D+00 ) - mean * mean return end subroutine point_distance_1d_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! POINT_DISTANCE_1D_PDF evaluates the point distance PDF in 1D. ! ! Discussion: ! ! It is assumed that a set of points has been generated in 1D ! according to a Poisson process. The number of points in a region ! of size LENGTH is a Poisson variate with mean value B * LENGTH. ! ! For a point chosen at random, we may now find the nearest ! Poisson point, the second nearest and so on. We are interested ! in the PDF that governs the expected behavior of the distances ! of rank A = 1, 2, 3, ... with Poisson density B. ! ! Note that this PDF is a form of the Gamma PDF.??? ! ! Formula: ! ! PDF(A,B;X) = B**A * X**( A - 1 ) * exp ( - B * X ) / ( A - 1 )! ! ! Modified: ! ! 22 September 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X. ! ! Input, integer A, indicates the degree of nearness of the point. ! A = 1 means the nearest point, A = 2 the second nearest, and so on. ! 0 < A. ! ! Input, real ( kind = 8 ) B, the point density. 0.0 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) i_factorial real ( kind = 8 ) pdf real ( kind = 8 ) x if ( a < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POINT_DISTANCE_1D_PDF - Fatal error!' write ( *, '(a)' ) ' Input parameter A < 1.' stop end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POINT_DISTANCE_1D_PDF - Fatal error!' write ( *, '(a)' ) ' Input parameter B <= 0.0.' stop end if if ( x < 0.0D+00 ) then pdf = 0.0D+00 else pdf = b**a * x**( a - 1 ) * exp ( - b * x ) / i_factorial ( a - 1 ) end if return end subroutine point_distance_2d_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! POINT_DISTANCE_2D_PDF evaluates the point distance PDF in 2D. ! ! Discussion: ! ! It is assumed that a set of points has been generated in 2D ! according to a Poisson process. The number of points in a region ! of size AREA is a Poisson variate with mean value B * AREA. ! ! For a point chosen at random, we may now find the nearest ! Poisson point, the second nearest and so on. We are interested ! in the PDF that governs the expected behavior of the distances ! of rank A = 1, 2, 3, ... with Poisson density B. ! ! Formula: ! ! PDF(A,B;X) = 2 * ( B * PI )**A * X**( 2 * A - 1 ) ! * EXP ( - B * PI * X * X ) / ( A - 1 )! ! ! Modified: ! ! 22 September 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Daniel Zwillinger, editor, ! CRC Standard Mathematical Tables and Formulae, ! 30th Edition, ! CRC Press, 1996, pages 579. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X. ! ! Input, integer A, indicates the degree of nearness of the point. ! A = 1 means the nearest point, A = 2 the second nearest, and so on. ! 0 < A. ! ! Input, real ( kind = 8 ) B, the point density. 0.0 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) i_factorial real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( a < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POINT_DISTANCE_2D_PDF - Fatal error!' write ( *, '(a)' ) ' Input parameter A < 1.' stop end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POINT_DISTANCE_2D_PDF - Fatal error!' write ( *, '(a)' ) ' Input parameter B <= 0.0.' stop end if if ( x < 0.0D+00 ) then pdf = 0.0D+00 else pdf = 2.0D+00 * ( b * pi )**a * x**( 2 * a - 1 ) & * exp ( - b * pi * x * x ) / i_factorial ( a - 1 ) end if return end subroutine point_distance_3d_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! POINT_DISTANCE_3D_PDF evaluates the point distance PDF in the 3D. ! ! Discussion: ! ! It is assumed that a set of points has been generated in 3D ! according to a Poisson process. The number of points in a region ! of size VOLUME is a Poisson variate with mean value B * VOLUME. ! ! For a point chosen at random, we may now find the nearest ! Poisson point, the second nearest and so on. We are interested ! in the PDF that governs the expected behavior of the distances ! of rank A = 1, 2, 3, ... with Poisson density B. ! ! Formula: ! ! PDF(A,B;X) = 3 * ( (4/3) * B * PI )**A * X**( 3 * A - 1 ) ! * EXP ( - (4/3) * B * PI * X * X * X ) / ( A - 1 )! ! ! Modified: ! ! 22 September 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Daniel Zwillinger, editor, ! CRC Standard Mathematical Tables and Formulae, ! 30th Edition, ! CRC Press, 1996, pages 580. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X. ! ! Input, integer A, indicates the degree of nearness of the point. ! A = 1 means the nearest point, A = 2 the second nearest, and so on. ! 0 < A. ! ! Input, real ( kind = 8 ) B, the Poisson point density. 0.0 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none integer a real ( kind = 8 ) b real ( kind = 8 ) i_factorial real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( a < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POINT_DISTANCE_3D_PDF - Fatal error!' write ( *, '(a)' ) ' Input parameter A < 1.' stop end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POINT_DISTANCE_3D_PDF - Fatal error!' write ( *, '(a)' ) ' Input parameter B <= 0.0.' stop end if if ( x < 0.0D+00 ) then pdf = 0.0D+00 else pdf = 3.0D+00 * ( ( 4.0D+00 / 3.0D+00 ) * b * pi )**a & * x**( 3 * a - 1 ) * exp ( - ( 4.0D+00 / 3.0D+00 ) * b * pi * x**3 ) & / i_factorial ( a - 1 ) end if return end subroutine poisson_cdf ( x, a, cdf ) !******************************************************************************* ! !! POISSON_CDF evaluates the Poisson CDF. ! ! Definition: ! ! CDF(X,A) is the probability that the number of events observed ! in a unit time period will be no greater than X, given that the ! expected number of events in a unit time period is A. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the CDF. ! 0 <= X. ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf integer i real ( kind = 8 ) last real ( kind = 8 ) new real ( kind = 8 ) sum2 integer x if ( x < 0 ) then cdf = 0.0D+00 else new = exp ( - a ) sum2 = new do i = 1, x last = new new = last * a / real ( i, kind = 8 ) sum2 = sum2 + new end do cdf = sum2 end if return end subroutine poisson_cdf_values ( n_data, a, x, fx ) !******************************************************************************* ! !! POISSON_CDF_VALUES returns some values of the Poisson CDF. ! ! Discussion: ! ! CDF(X)(A) is the probability of at most X successes in unit time, ! given that the expected mean number of successes is A. ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`DiscreteDistributions`] ! dist = PoissonDistribution [ a ] ! CDF [ dist, x ] ! ! Modified: ! ! 20 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Daniel Zwillinger, ! CRC Standard Mathematical Tables and Formulae, ! 30th Edition, CRC Press, 1996, pages 653-658. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) A, the parameter of the function. ! ! Output, integer X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 21 real ( kind = 8 ) a real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ & 0.02D+00, & 0.10D+00, & 0.10D+00, & 0.50D+00, & 0.50D+00, & 0.50D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 1.00D+00, & 2.00D+00, & 2.00D+00, & 2.00D+00, & 2.00D+00, & 5.00D+00, & 5.00D+00, & 5.00D+00, & 5.00D+00, & 5.00D+00, & 5.00D+00, & 5.00D+00 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.9801986733067553D+00, & 0.9048374180359596D+00, & 0.9953211598395555D+00, & 0.6065306597126334D+00, & 0.9097959895689501D+00, & 0.9856123220330293D+00, & 0.3678794411714423D+00, & 0.7357588823428846D+00, & 0.9196986029286058D+00, & 0.9810118431238462D+00, & 0.1353352832366127D+00, & 0.4060058497098381D+00, & 0.6766764161830635D+00, & 0.8571234604985470D+00, & 0.6737946999085467D-02, & 0.4042768199451280D-01, & 0.1246520194830811D+00, & 0.2650259152973617D+00, & 0.4404932850652124D+00, & 0.6159606548330631D+00, & 0.7621834629729387D+00 /) integer n_data integer x integer, save, dimension ( n_max ) :: x_vec = (/ & 0, 0, 1, 0, & 1, 2, 0, 1, & 2, 3, 0, 1, & 2, 3, 0, 1, & 2, 3, 4, 5, & 6 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 a = 0.0D+00 x = 0 fx = 0.0D+00 else a = a_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end subroutine poisson_cdf_inv ( cdf, a, x ) !******************************************************************************* ! !! POISSON_CDF_INV inverts the Poisson CDF. ! ! Modified: ! ! 16 September 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, a value of the CDF. ! 0 <= CDF < 1. ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Output, integer X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf integer i real ( kind = 8 ) last real ( kind = 8 ) new real ( kind = 8 ) sum2 real ( kind = 8 ) sumold integer x integer, parameter :: xmax = 100 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POISSON_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if ! ! Now simply start at X = 0, and find the first value for which ! CDF(X-1) <= CDF <= CDF(X). ! sum2 = 0.0D+00 do i = 0, xmax sumold = sum2 if ( i == 0 ) then new = exp ( - a ) sum2 = new else last = new new = last * a / real ( i, kind = 8 ) sum2 = sum2 + new end if if ( sumold <= cdf .and. cdf <= sum2 ) then x = i return end if end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POISSON_CDF_INV - Warning!' write ( *, '(a,i8)' ) ' Exceeded XMAX = ', xmax x = xmax return end function poisson_check ( a ) !******************************************************************************* ! !! POISSON_CHECK checks the parameter of the Poisson PDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Output, logical POISSON_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a logical poisson_check if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POISSON_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.' poisson_check = .false. return end if poisson_check = .true. return end subroutine poisson_mean ( a, mean ) !******************************************************************************* ! !! POISSON_MEAN returns the mean of the Poisson PDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) mean mean = a return end subroutine poisson_pdf ( x, a, pdf ) !******************************************************************************* ! !! POISSON_PDF evaluates the Poisson PDF. ! ! Formula: ! ! PDF(A;X) = EXP ( - A ) * A**X / X! ! ! Discussion: ! ! PDF(A;X) is the probability that the number of events observed ! in a unit time period will be X, given the expected number ! of events in a unit time. ! ! The parameter A is the expected number of events per unit time. ! ! The Poisson PDF is a discrete version of the Exponential PDF. ! ! The time interval between two Poisson events is a random ! variable with the Exponential PDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the PDF. ! 0 <= X ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) i_factorial real ( kind = 8 ) pdf integer x if ( x < 0 ) then pdf = 0.0D+00 else pdf = exp ( - a ) * a**x / i_factorial ( x ) end if return end subroutine poisson_sample ( a, seed, x ) !******************************************************************************* ! !! POISSON_SAMPLE samples the Poisson PDF. ! ! Modified: ! ! 02 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed integer x cdf = d_uniform_01 ( seed ) call poisson_cdf_inv ( cdf, a, x ) return end subroutine poisson_variance ( a, variance ) !******************************************************************************* ! !! POISSON_VARIANCE returns the variance of the Poisson PDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) variance variance = a return end subroutine power_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! POWER_CDF evaluates the Power CDF. ! ! Modified: ! ! 11 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, 0.0D+00 < B, ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x <= 0.0D+00 ) then cdf = 0.0D+00 else if ( x <= b ) then cdf = ( x / b )**a else cdf = 1.0D+00 end if return end subroutine power_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! POWER_CDF_INV inverts the Power CDF. ! ! Modified: ! ! 11 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POWER_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = 0.0D+00 else if ( cdf < 1.0D+00 ) then x = b * exp ( log ( cdf ) / a ) else x = b end if return end function power_check ( a, b ) !******************************************************************************* ! !! POWER_CHECK checks the parameter of the Power PDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, 0.0D+00 < B. ! ! Output, logical POWER_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical power_check if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POWER_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.' power_check = .false. return end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POWER_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' power_check = .false. return end if power_check = .true. return end subroutine power_mean ( a, b, mean ) !******************************************************************************* ! !! POWER_MEAN returns the mean of the Power PDF. ! ! Modified: ! ! 11 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a * b / ( a + 1.0D+00 ) return end subroutine power_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! POWER_PDF evaluates the Power PDF. ! ! Formula: ! ! PDF(A;X) = (A/B) * (X/B)**(A-1) ! ! Modified: ! ! 11 July 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Daniel Zwillinger and Stephen Kokoska, ! CRC Standard Probability and Statistics Tables and Formulae, ! Chapman and Hall/CRC, 2000, pages 152-153. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X <= B. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x < 0.0D+00 .or. b < x ) then pdf = 0.0D+00 else pdf = ( a / b ) * ( x / b )**( a - 1.0D+00 ) end if return end subroutine power_sample ( a, b, seed, x ) !******************************************************************************* ! !! POWER_SAMPLE samples the Power PDF. ! ! Modified: ! ! 11 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call power_cdf_inv ( cdf, a, b, x ) return end subroutine power_variance ( a, b, variance ) !******************************************************************************* ! !! POWER_VARIANCE returns the variance of the Power PDF. ! ! Modified: ! ! 11 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A, 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = b * b * a / ( ( a + 1.0D+00 )**2 * ( a + 2.0D+00 ) ) return end subroutine psi_values ( n_data, x, fx ) !******************************************************************************* ! !! PSI_VALUES returns some values of the Psi or Digamma function. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! PolyGamma[x] ! ! or ! ! PolyGamma[0,x] ! ! PSI(X) = d ln ( Gamma ( X ) ) / d X = Gamma'(X) / Gamma(X) ! ! PSI(1) = -Euler's constant. ! ! PSI(X+1) = PSI(X) + 1 / X. ! ! Modified: ! ! 17 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 11 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & -0.5772156649015329D+00, & -0.4237549404110768D+00, & -0.2890398965921883D+00, & -0.1691908888667997D+00, & -0.6138454458511615D-01, & 0.3648997397857652D-01, & 0.1260474527734763D+00, & 0.2085478748734940D+00, & 0.2849914332938615D+00, & 0.3561841611640597D+00, & 0.4227843350984671D+00 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 1.0D+00, & 1.1D+00, & 1.2D+00, & 1.3D+00, & 1.4D+00, & 1.5D+00, & 1.6D+00, & 1.7D+00, & 1.8D+00, & 1.9D+00, & 2.0D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 fx = 0.0D+00 else x = x_vec(n_data) fx = fx_vec(n_data) end if return end subroutine rayleigh_cdf ( x, a, cdf ) !******************************************************************************* ! !! RAYLEIGH_CDF evaluates the Rayleigh CDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! 0.0D+00 <= X. ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x < 0.0D+00 ) then cdf = 0.0D+00 else cdf = 1.0D+00 - exp ( - x**2 / ( 2.0D+00 * a**2 ) ) end if return end subroutine rayleigh_cdf_inv ( cdf, a, x ) !******************************************************************************* ! !! RAYLEIGH_CDF_INV inverts the Rayleigh CDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RAYLEIGH_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = sqrt ( - 2.0D+00 * a * a * log ( 1.0D+00 - cdf ) ) return end subroutine rayleigh_cdf_values ( n_data, sigma, x, fx ) !******************************************************************************* ! !! RAYLEIGH_CDF_VALUES returns some values of the Rayleigh CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = RayleighDistribution [ sigma ] ! CDF [ dist, x ] ! ! Modified: ! ! 01 September 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) SIGMA, the shape parameter of the distribution. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 9 real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.8646647167633873D+00, & 0.9996645373720975D+00, & 0.9999999847700203D+00, & 0.999999999999987D+00, & 0.8646647167633873D+00, & 0.3934693402873666D+00, & 0.1992625970831920D+00, & 0.1175030974154046D+00, & 0.7688365361336422D-01 /) integer n_data real ( kind = 8 ) sigma real ( kind = 8 ), save, dimension ( n_max ) :: sigma_vec = (/ & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01 /) real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 sigma = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else sigma = sigma_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function rayleigh_check ( a ) !******************************************************************************* ! !! RAYLEIGH_CHECK checks the parameter of the Rayleigh PDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Output, logical RAYLEIGH_CHECK, is true if the parameter is legal. ! implicit none real ( kind = 8 ) a logical rayleigh_check if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RAYLEIGH_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.' rayleigh_check = .false. return end if rayleigh_check = .true. return end subroutine rayleigh_mean ( a, mean ) !******************************************************************************* ! !! RAYLEIGH_MEAN returns the mean of the Rayleigh PDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) mean real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 mean = a * sqrt ( 0.5D+00 * pi ) return end subroutine rayleigh_pdf ( x, a, pdf ) !******************************************************************************* ! !! RAYLEIGH_PDF evaluates the Rayleigh PDF. ! ! Formula: ! ! PDF(A;X) = ( X / A**2 ) * EXP ( - X**2 / ( 2 * A**2 ) ) ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0 < A. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x < 0.0D+00 ) then pdf = 0.0D+00 else pdf = ( x / a**2 ) * exp ( - x**2 / ( 2.0D+00 * a**2 ) ) end if return end subroutine rayleigh_sample ( a, seed, x ) !******************************************************************************* ! !! RAYLEIGH_SAMPLE samples the Rayleigh PDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 0.0D+00 < A. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call rayleigh_cdf_inv ( cdf, a, x ) return end subroutine rayleigh_variance ( a, variance ) !******************************************************************************* ! !! RAYLEIGH_VARIANCE returns the variance of the Rayleigh PDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameters of the PDF. ! 0.0D+00 < A. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) variance variance = 2.0D+00 * a**2 * ( 1.0D+00 - 0.25D+00 * pi ) return end subroutine reciprocal_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! RECIPROCAL_CDF evaluates the Reciprocal CDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A <= B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x <= 0.0D+00 ) then cdf = 0.0D+00 else if ( 0.0D+00 < x ) then cdf = log ( a / x ) / log ( a / b ) end if return end subroutine reciprocal_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! RECIPROCAL_CDF_INV inverts the Reciprocal CDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A <= B. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RECIPROCAL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = 0.0D+00 else if ( 0.0D+00 < cdf ) then x = b**cdf / a**( cdf - 1.0D+00 ) end if return end function reciprocal_check ( a, b ) !******************************************************************************* ! !! RECIPROCAL_CHECK checks the parameters of the Reciprocal CDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A <= B. ! ! Output, logical RECIPROCAL_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical reciprocal_check if ( a <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RECIPROCAL_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 0.0' reciprocal_check = .false. return end if if ( b < a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RECIPROCAL_CHECK - Fatal error!' write ( *, '(a)' ) ' B < A' reciprocal_check = .false. return end if reciprocal_check = .true. return end subroutine reciprocal_mean ( a, b, mean ) !******************************************************************************* ! !! RECIPROCAL_MEAN returns the mean of the Reciprocal PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A <= B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = ( a - b ) / log ( a / b ) return end subroutine reciprocal_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! RECIPROCAL_PDF evaluates the Reciprocal PDF. ! ! Formula: ! ! PDF(A,B;X) = 1.0D+00 / ( X * LOG ( B / A ) ) ! for 0.0D+00 <= X ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A <= B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x <= 0.0D+00 ) then pdf = 0.0D+00 else if ( 0.0D+00 < x ) then pdf = 1.0D+00 / ( x * log ( b / a ) ) end if return end subroutine reciprocal_sample ( a, b, seed, x ) !******************************************************************************* ! !! RECIPROCAL_SAMPLE samples the Reciprocal PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A <= B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) x = b**cdf / a**( cdf - 1.0D+00 ) return end subroutine reciprocal_variance ( a, b, variance ) !******************************************************************************* ! !! RECIPROCAL_VARIANCE returns the variance of the Reciprocal PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < A <= B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) d real ( kind = 8 ) variance d = log ( a / b ) variance = ( a - b )* ( a * ( d - 2.0D+00 ) & + b * ( d + 2.0D+00 ) ) / ( 2.0D+00 * d**2 ) return end function sech ( X ) !******************************************************************************* ! !! SECH returns the hyperbolic secant. ! ! Definition: ! ! SECH ( X ) = 1.0D+00 / COSH ( X ) = 2.0D+00 / ( EXP ( X ) + EXP ( - X ) ) ! ! Discussion: ! ! SECH is not a built-in function in FORTRAN, and occasionally it ! is handier, or more concise, to be able to refer to it directly ! rather than through its definition in terms of the sine function. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument. ! ! Output, real ( kind = 8 ) SECH, the hyperbolic secant of X. ! implicit none real ( kind = 8 ) sech real ( kind = 8 ) x sech = 1.0D+00 / cosh ( x ) return end subroutine sech_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! SECH_CDF evaluates the Hyperbolic Secant CDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameter of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b cdf = 2.0D+00 * atan ( exp ( y ) ) / pi return end subroutine sech_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! SECH_CDF_INV inverts the Hyperbolic Secant CDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SECH_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = - huge ( x ) else if ( cdf < 1.0D+00 ) then x = a + b * log ( tan ( 0.5D+00 * pi * cdf ) ) else if ( 1.0D+00 == cdf ) then x = huge ( x ) end if return end function sech_check ( a, b ) !******************************************************************************* ! !! SECH_CHECK checks the parameters of the Hyperbolic Secant CDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameter of the PDF. ! 0.0D+00 < B. ! ! Output, logical SECH_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical sech_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SECH_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.0' sech_check = .false. return end if sech_check = .true. return end subroutine sech_mean ( a, b, mean ) !******************************************************************************* ! !! SECH_MEAN returns the mean of the Hyperbolic Secant PDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a return end subroutine sech_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! SECH_PDF evaluates the Hypebolic Secant PDF. ! ! Formula: ! ! PDF(A,B;X) = sech ( ( X - A ) / B ) / ( PI * B ) ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) sech real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b pdf = sech ( y ) / ( pi * b ) return end subroutine sech_sample ( a, b, seed, x ) !******************************************************************************* ! !! SECH_SAMPLE samples the Hyperbolic Secant PDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) x = a + b * log ( tan ( 0.5D+00 * pi * cdf ) ) return end subroutine sech_variance ( a, b, variance ) !******************************************************************************* ! !! SECH_VARIANCE returns the variance of the Hyperbolic Secant PDF. ! ! Modified: ! ! 02 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) variance variance = 0.25D+00 * ( pi * b )**2 return end subroutine semicircular_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! SEMICIRCULAR_CDF evaluates the Semicircular CDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameter of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) y if ( x <= a - b ) then cdf = 0.0D+00 else if ( x <= a + b ) then y = ( x - a ) / b cdf = 0.5D+00 + ( y * sqrt ( 1.0D+00 - y**2 ) + asin ( y ) ) / pi else if ( a + b < x ) then cdf = 1.0D+00 end if return end subroutine semicircular_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! SEMICIRCULAR_CDF_INV inverts the Semicircular CDF. ! ! Discussion: ! ! A simple bisection method is used on the interval [ A - B, A + B ]. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cdf1 real ( kind = 8 ) cdf2 real ( kind = 8 ) cdf3 integer it integer, parameter :: it_max = 100 real ( kind = 8 ), parameter :: tol = 0.0001D+00 real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 real ( kind = 8 ) x3 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SEMICIRCULAR_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = a - b return else if ( 1.0D+00 == cdf ) then x = a + b return end if x1 = a - b cdf1 = 0.0D+00 x2 = a + b cdf2 = 1.0D+00 ! ! Now use bisection. ! it = 0 do it = it + 1 x3 = 0.5D+00 * ( x1 + x2 ) call semicircular_cdf ( x3, a, b, cdf3 ) if ( abs ( cdf3 - cdf ) < tol ) then x = x3 exit end if if ( it_max < it ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SEMICIRCULAR_CDF_INV - Fatal error!' write ( *, '(a)' ) ' Iteration limit exceeded.' stop end if if ( sign ( 1.0D+00, cdf3 - cdf ) == sign ( 1.0D+00, cdf1 - cdf ) ) then x1 = x3 cdf1 = cdf3 else x2 = x3 cdf2 = cdf3 end if end do return end function semicircular_check ( a, b ) !******************************************************************************* ! !! SEMICIRCULAR_CHECK checks the parameters of the Semicircular CDF. ! ! Modified: ! ! 22 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameter of the PDF. ! 0.0D+00 < B. ! ! Output, logical SEMICIRCULAR_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical semicircular_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SEMICIRCULAR_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.0' semicircular_check = .false. return end if semicircular_check = .true. return end subroutine semicircular_mean ( a, b, mean ) !******************************************************************************* ! !! SEMICIRCULAR_MEAN returns the mean of the Semicircular PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a return end subroutine semicircular_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! SEMICIRCULAR_PDF evaluates the Semicircular PDF. ! ! Formula: ! ! PDF(A,B;X) = ( 2 / ( B * PI ) ) * SQRT ( 1 - ( ( X - A ) / B )**2 ) ! for A - B <= X <= A + B ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) y if ( x < a - b ) then pdf = 0.0D+00 else if ( x <= a + b ) then y = ( x - a ) / b pdf = 2.0D+00 / ( b * pi ) * sqrt ( 1.0D+00 - y**2 ) else if ( a + b < x ) then pdf = 0.0D+00 end if return end subroutine semicircular_sample ( a, b, seed, x ) !******************************************************************************* ! !! SEMICIRCULAR_SAMPLE samples the Semicircular PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) angle real ( kind = 8 ) b real ( kind = 8 ) d_uniform_01 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) radius integer seed real ( kind = 8 ) x radius = d_uniform_01 ( seed ) radius = b * sqrt ( radius ) angle = pi * d_uniform_01 ( seed ) x = a + radius * cos ( angle ) return end subroutine semicircular_variance ( a, b, variance ) !******************************************************************************* ! !! SEMICIRCULAR_VARIANCE returns the variance of the Semicircular PDF. ! ! Modified: ! ! 30 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = b * b / 4.0D+00 return end function sin_power_int ( a, b, n ) !******************************************************************************* ! !! SIN_POWER_INT evaluates the sine power integral. ! ! Discussion: ! ! The function is defined by ! ! SIN_POWER_INT(A,B,N) = Integral ( A <= T <= B ) ( sin ( t ))^n dt ! ! The algorithm uses the following fact: ! ! Integral sin^n ( t ) = (1/n) * ( ! sin^(n-1)(t) * cos(t) + ( n-1 ) * Integral sin^(n-2) ( t ) dt ) ! ! Modified: ! ! 02 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters ! ! Input, real ( kind = 8 ) A, B, the limits of integration. ! ! Input, integer N, the power of the sine function. ! ! Output, real ( kind = 8 ) SIN_POWER_INT, the value of the integral. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) ca real ( kind = 8 ) cb integer m integer mlo integer n real ( kind = 8 ) sa real ( kind = 8 ) sb real ( kind = 8 ) sin_power_int real ( kind = 8 ) value if ( n < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SIN_POWER_INT - Fatal error!' write ( *, '(a)' ) ' Power N < 0.' value = 0.0D+00 stop end if sa = sin ( a ) sb = sin ( b ) ca = cos ( a ) cb = cos ( b ) if ( mod ( n, 2 ) == 0 ) then value = b - a mlo = 2 else value = ca - cb mlo = 3 end if do m = mlo, n, 2 value = ( real ( m - 1, kind = 8 ) * value & + sa**(m-1) * ca - sb**(m-1) * cb ) & / real ( m, kind = 8 ) end do sin_power_int = value return end subroutine student_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! STUDENT_CDF evaluates the central Student T CDF. ! ! Modified: ! ! 02 November 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, shape parameters of the PDF, ! used to transform the argument X to a shifted and scaled ! value Y = ( X - A ) / B. It is required that B be nonzero. ! For the standard distribution, A = 0 and B = 1. ! ! Input, real ( kind = 8 ) C, is usually called the number of ! degrees of freedom of the distribution. C is typically an ! integer, but that is not essential. It is required that ! C be strictly positive. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a2 real ( kind = 8 ) b real ( kind = 8 ) b2 real ( kind = 8 ) beta_inc real ( kind = 8 ) c real ( kind = 8 ) c2 real ( kind = 8 ) cdf real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b a2 = 0.5D+00 * c b2 = 0.5D+00 c2 = c / ( c + y * y ) if ( y <= 0.0D+00 ) then cdf = 0.5D+00 * beta_inc ( a2, b2, c2 ) else cdf = 1.0D+00 - 0.5D+00 * beta_inc ( a2, b2, c2 ) end if return end subroutine student_cdf_values ( n_data, c, x, fx ) !******************************************************************************* ! !! STUDENT_CDF_VALUES returns some values of the Student CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = StudentTDistribution [ c ] ! CDF [ dist, x ] ! ! Modified: ! ! 02 November 2005 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) C, is usually called the number of ! degrees of freedom of the distribution. C is typically an ! integer, but that is not essential. It is required that ! C be strictly positive. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 13 real ( kind = 8 ) c real ( kind = 8 ), save, dimension ( n_max ) :: c_vec = (/ & 1.0D+00, 2.0D+00, 3.0D+00, 4.0D+00, & 5.0D+00, 2.0D+00, 5.0D+00, 2.0D+00, & 5.0D+00, 2.0D+00, 3.0D+00, 4.0D+00, & 5.0D+00 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.6000231200328521D+00, & 0.6001080279134390D+00, & 0.6001150934648930D+00, & 0.6000995134721354D+00, & 0.5999341989834830D+00, & 0.7498859393137811D+00, & 0.7500879487671045D+00, & 0.9500004222186464D+00, & 0.9499969138365968D+00, & 0.9900012348724744D+00, & 0.9900017619355059D+00, & 0.9900004567580596D+00, & 0.9900007637471291D+00 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.325D+00, & 0.289D+00, & 0.277D+00, & 0.271D+00, & 0.267D+00, & 0.816D+00, & 0.727D+00, & 2.920D+00, & 2.015D+00, & 6.965D+00, & 4.541D+00, & 3.747D+00, & 3.365D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 c = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else c = c_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function student_check ( a, b, c ) !******************************************************************************* ! !! STUDENT_CHECK checks the parameter of the central Student T CDF. ! ! Modified: ! ! 02 November 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, shape parameters of the PDF, ! used to transform the argument X to a shifted and scaled ! value Y = ( X - A ) / B. It is required that B be nonzero. ! For the standard distribution, A = 0 and B = 1. ! ! Input, real ( kind = 8 ) C, is usually called the number of ! degrees of freedom of the distribution. C is typically an ! integer, but that is not essential. It is required that ! C be strictly positive. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c logical student_check if ( b == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STUDENT_CHECK - Fatal error!' write ( *, '(a)' ) ' B must be nonzero.' student_check = .false. return end if if ( c <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STUDENT_CHECK - Fatal error!' write ( *, '(a)' ) ' C must be greater than 0.' student_check = .false. return end if student_check = .true. return end subroutine student_mean ( a, b, c, mean ) !******************************************************************************* ! !! STUDENT_MEAN returns the mean of the central Student T PDF. ! ! Modified: ! ! 02 November 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, shape parameters of the PDF, ! used to transform the argument X to a shifted and scaled ! value Y = ( X - A ) / B. It is required that B be nonzero. ! For the standard distribution, A = 0 and B = 1. ! ! Input, real ( kind = 8 ) C, is usually called the number of ! degrees of freedom of the distribution. C is typically an ! integer, but that is not essential. It is required that ! C be strictly positive. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) mean mean = a return end subroutine student_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! STUDENT_PDF evaluates the central Student T PDF. ! ! Formula: ! ! PDF(A,B,C;X) = Gamma ( (C+1)/2 ) / ! ( Gamma ( C / 2 ) * Sqrt ( PI * C ) ! * ( 1 + ((X-A)/B)**2/C )**(C + 1/2 ) ) ! ! Modified: ! ! 02 November 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, shape parameters of the PDF, ! used to transform the argument X to a shifted and scaled ! value Y = ( X - A ) / B. It is required that B be nonzero. ! For the standard distribution, A = 0 and B = 1. ! ! Input, real ( kind = 8 ) C, is usually called the number of ! degrees of freedom of the distribution. C is typically an ! integer, but that is not essential. It is required that ! C be strictly positive. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) gamma real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x real ( kind = 8 ) y y = ( x - a ) / b pdf = gamma ( 0.5D+00 * ( c + 1.0D+00 ) ) / ( sqrt ( pi * c ) & * gamma ( 0.5D+00 * c ) & * sqrt ( ( 1.0D+00 + y * y / c )**( 2 * c + 1.0D+00 ) ) ) return end subroutine student_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! STUDENT_SAMPLE samples the central Student T PDF. ! ! Discussion: ! ! For the sampling algorithm, it is necessary that 2 < C. ! ! Modified: ! ! 02 November 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, shape parameters of the PDF, ! used to transform the argument X to a shifted and scaled ! value Y = ( X - A ) / B. It is required that B be nonzero. ! For the standard distribution, A = 0 and B = 1. ! ! Input, real ( kind = 8 ) C, is usually called the number of ! degrees of freedom of the distribution. C is typically an ! integer, but that is not essential. It is required that ! C be strictly positive. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) a2 real ( kind = 8 ) b real ( kind = 8 ) b2 real ( kind = 8 ) c integer seed real ( kind = 8 ) x real ( kind = 8 ) x2 real ( kind = 8 ) x3 if ( c < 3.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STUDENT_SAMPLE - Fatal error!' write ( *, '(a)' ) ' Sampling fails for C <= 2.' return end if a2 = 0.0D+00 b2 = c / ( c - 2 ) call normal_sample ( a2, b2, seed, x2 ) call chi_square_sample ( c, seed, x3 ) x3 = x3 * c / ( c - 2.0D+00 ) x = a + b * x2 * sqrt ( c ) / x3 return end subroutine student_variance ( a, b, c, variance ) !******************************************************************************* ! !! STUDENT_VARIANCE returns the variance of the central Student T PDF. ! ! Discussion: ! ! The variance is not defined unless 2 < C. ! ! Modified: ! ! 02 November 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, shape parameters of the PDF, ! used to transform the argument X to a shifted and scaled ! value Y = ( X - A ) / B. It is required that B be nonzero. ! For the standard distribution, A = 0 and B = 1. ! ! Input, real ( kind = 8 ) C, is usually called the number of ! degrees of freedom of the distribution. C is typically an ! integer, but that is not essential. It is required that ! C be strictly positive. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) variance if ( c <= 2.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STUDENT_VARIANCE - Fatal error!' write ( *, '(a)' ) ' Variance not defined for C <= 2.' stop end if variance = b * b * c / ( c - 2.0D+00 ) return end subroutine student_noncentral_cdf ( x, idf, d, cdf ) !******************************************************************************* ! !! STUDENT_NONCENTRAL_CDF evaluates the noncentral Student T CDF. ! ! Modified: ! ! 07 March 1999 ! ! Author: ! ! B E Cooper ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! B E Cooper, ! The Integral of the Non-Central T-Distribution, ! Algorithm AS 5, ! Applied Statistics, ! Volume 17, 1968, page 193. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, integer IDF, the number of degrees of freedom. ! ! Input, real ( kind = 8 ) D, the noncentrality parameter. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a integer, parameter :: a_max = 100 real ( kind = 8 ) ak real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cdf2 real ( kind = 8 ) d real ( kind = 8 ) drb real ( kind = 8 ), parameter :: emin = 12.5D+00 real ( kind = 8 ) f real ( kind = 8 ) fk real ( kind = 8 ) fmkm1 real ( kind = 8 ) fmkm2 real ( kind = 8 ) gamma_log integer idf integer k real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) sum2 real ( kind = 8 ) temp real ( kind = 8 ) tfn real ( kind = 8 ) x f = real ( idf, kind = 8 ) if ( idf == 1 ) then a = x / sqrt ( f ) b = f / ( f + x**2 ) drb = d * sqrt ( b ) call normal_01_cdf ( drb, cdf2 ) cdf = 1.0D+00 - cdf2 + 2.0D+00 * tfn ( drb, a ) else if ( idf <= a_max ) then a = x / sqrt ( f ) b = f / ( f + x * x ) drb = d * sqrt ( b ) sum2 = 0.0D+00 fmkm2 = 0.0D+00 if ( abs ( drb ) < emin ) then call normal_01_cdf ( a * drb, cdf2 ) fmkm2 = a * sqrt ( b ) * exp ( - 0.5D+00 * drb**2 ) * cdf2 & / sqrt ( 2.0D+00 * pi ) end if fmkm1 = b * d * a * fmkm2 if ( abs ( d ) < emin ) then fmkm1 = fmkm1 + 0.5D+00 * b * a * exp ( - 0.5D+00 * d**2 ) / pi end if if ( mod ( idf, 2 ) == 0 ) then sum2 = fmkm2 else sum2 = fmkm1 end if ak = 1.0D+00 do k = 2, idf - 2, 2 fk = real ( k, kind = 8 ) fmkm2 = b * ( d * a * ak * fmkm1 + fmkm2 ) * ( fk - 1.0D+00 ) / fk ak = 1.0D+00 / ( ak * ( fk - 1.0D+00 ) ) fmkm1 = b * ( d * a * ak * fmkm2 + fmkm1 ) * fk / ( fk + 1.0D+00 ) if ( mod ( idf, 2 ) == 0 ) then sum2 = sum2 + fmkm2 else sum2 = sum2 + fmkm1 end if ak = 1.0D+00 / ( ak * fk ) end do if ( mod ( idf, 2 ) == 0 ) then call normal_01_cdf ( d, cdf2 ) cdf = 1.0D+00 - cdf2 + sum2 * sqrt ( 2.0D+00 * pi ) else call normal_01_cdf ( drb, cdf2 ) cdf = 1.0D+00 - cdf2 + 2.0D+00 * ( sum2 + tfn ( drb, a ) ) end if ! ! Normal approximation. ! else a = sqrt ( 0.5D+00 * f ) * exp ( gamma_log ( 0.5D+00 * ( f - 1.0D+00 ) ) & - gamma_log ( 0.5D+00 * f ) ) * d temp = ( x - a ) / sqrt ( f * ( 1.0D+00 + d**2 ) / ( f - 2.0D+00 ) - a**2 ) call normal_01_cdf ( temp, cdf2 ) cdf = cdf2 end if return end subroutine student_noncentral_cdf_values ( n_data, df, lambda, x, fx ) !******************************************************************************* ! !! STUDENT_NONCENTRAL_CDF_VALUES returns values of the noncentral Student CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = NoncentralStudentTDistribution [ df, lambda ] ! CDF [ dist, x ] ! ! Mathematica seems to have some difficulty computing this function ! to the desired number of digits. ! ! Modified: ! ! 01 September 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer DF, real ( kind = 8 ) LAMBDA, the parameters of the ! function. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 30 integer df integer, save, dimension ( n_max ) :: df_vec = (/ & 1, 2, 3, & 1, 2, 3, & 1, 2, 3, & 1, 2, 3, & 1, 2, 3, & 15, 20, 25, & 1, 2, 3, & 10, 10, 10, & 10, 10, 10, & 10, 10, 10 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.8975836176504333D+00, & 0.9522670169D+00, & 0.9711655571887813D+00, & 0.8231218864D+00, & 0.9049021510D+00, & 0.9363471834D+00, & 0.7301025986D+00, & 0.8335594263D+00, & 0.8774010255D+00, & 0.5248571617D+00, & 0.6293856597D+00, & 0.6800271741D+00, & 0.20590131975D+00, & 0.2112148916D+00, & 0.2074730718D+00, & 0.9981130072D+00, & 0.9994873850D+00, & 0.9998391562D+00, & 0.168610566972D+00, & 0.16967950985D+00, & 0.1701041003D+00, & 0.9247683363D+00, & 0.7483139269D+00, & 0.4659802096D+00, & 0.9761872541D+00, & 0.8979689357D+00, & 0.7181904627D+00, & 0.9923658945D+00, & 0.9610341649D+00, & 0.8688007350D+00 /) real ( kind = 8 ) lambda real ( kind = 8 ), save, dimension ( n_max ) :: lambda_vec = (/ & 0.0D+00, & 0.0D+00, & 0.0D+00, & 0.5D+00, & 0.5D+00, & 0.5D+00, & 1.0D+00, & 1.0D+00, & 1.0D+00, & 2.0D+00, & 2.0D+00, & 2.0D+00, & 4.0D+00, & 4.0D+00, & 4.0D+00, & 7.0D+00, & 7.0D+00, & 7.0D+00, & 1.0D+00, & 1.0D+00, & 1.0D+00, & 2.0D+00, & 3.0D+00, & 4.0D+00, & 2.0D+00, & 3.0D+00, & 4.0D+00, & 2.0D+00, & 3.0D+00, & 4.0D+00 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 3.00D+00, & 15.00D+00, & 15.00D+00, & 15.00D+00, & 0.05D+00, & 0.05D+00, & 0.05D+00, & 4.00D+00, & 4.00D+00, & 4.00D+00, & 5.00D+00, & 5.00D+00, & 5.00D+00, & 6.00D+00, & 6.00D+00, & 6.00D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 df = 0 lambda = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else df = df_vec(n_data) lambda = lambda_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function tfn ( h, a ) !******************************************************************************* ! !! TFN calculates the T function of Owen. ! ! Discussion: ! ! Owen's T function is useful for computation of the bivariate normal ! distribution and the distribution of a skewed normal distribution. ! ! Although it was originally formulated in terms of the bivariate ! normal function, the function can be defined more directly as ! ! T(H,A) = 1 / ( 2 * pi ) * ! Integral ( 0 <= X <= A ) e^( -H^2 * (1+X^2) / 2 ) / (1+X^2) dX ! ! Modified: ! ! 10 December 2004 ! ! Author: ! ! J C Young and C E Minder ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! D B Owen, ! Tables for computing the bivariate normal distribution, ! Annals of Mathematical Statistics, ! Volume 27, pages 1075-1090, 1956. ! ! J C Young and C E Minder, ! Algorithm AS 76, ! An Algorithm Useful in Calculating Non-Central T and ! Bivariate Normal Distributions, ! Applied Statistics, ! Volume 23, Number 3, 1974, pages 455-457. ! ! Parameters: ! ! Input, real ( kind = 8 ) H, A, the arguments of the T function. ! ! Output, real ( kind = 8 ) TFN, the value of the T function. ! implicit none integer, parameter :: ngauss = 10 real ( kind = 8 ) a real ( kind = 8 ) as real ( kind = 8 ) h real ( kind = 8 ) h1 real ( kind = 8 ) h2 real ( kind = 8 ) hs integer i real ( kind = 8 ) rt real ( kind = 8 ) tfn real ( kind = 8 ), parameter :: two_pi_inverse = 0.1591549430918953D+00 real ( kind = 8 ), parameter :: tv1 = 1.0D-35 real ( kind = 8 ), parameter :: tv2 = 15.0D+00 real ( kind = 8 ), parameter :: tv3 = 15.0D+00 real ( kind = 8 ), parameter :: tv4 = 1.0D-05 real ( kind = 8 ), parameter, dimension ( ngauss ) :: weight = (/ & 0.666713443086881375935688098933D-01, & 0.149451349150580593145776339658D+00, & 0.219086362515982043995534934228D+00, & 0.269266719309996355091226921569D+00, & 0.295524224714752870173892994651D+00, & 0.295524224714752870173892994651D+00, & 0.269266719309996355091226921569D+00, & 0.219086362515982043995534934228D+00, & 0.149451349150580593145776339658D+00, & 0.666713443086881375935688098933D-01 /) real ( kind = 8 ) x real ( kind = 8 ), parameter, dimension ( ngauss ) :: xtab = (/ & -0.973906528517171720077964012084D+00, & -0.865063366688984510732096688423D+00, & -0.679409568299024406234327365115D+00, & -0.433395394129247190799265943166D+00, & -0.148874338981631210884826001130D+00, & 0.148874338981631210884826001130D+00, & 0.433395394129247190799265943166D+00, & 0.679409568299024406234327365115D+00, & 0.865063366688984510732096688423D+00, & 0.973906528517171720077964012084D+00 /) ! ! Test for H near zero. ! if ( abs ( h ) < tv1 ) then tfn = atan ( a ) * two_pi_inverse ! ! Test for large values of abs(H). ! else if ( tv2 < abs ( h ) ) then tfn = 0.0D+00 ! ! Test for A near zero. ! else if ( abs ( a ) < tv1 ) then tfn = 0.0D+00 ! ! Test whether abs(A) is so large that it must be truncated. ! If so, the truncated value of A is H2. ! else hs = - 0.5D+00 * h * h h2 = a as = a * a ! ! Computation of truncation point by Newton iteration. ! if ( tv3 <= log ( 1.0D+00 + as ) - hs * as ) then h1 = 0.5D+00 * a as = 0.25D+00 * as do rt = as + 1.0D+00 h2 = h1 + ( hs * as + tv3 - log ( rt ) ) & / ( 2.0D+00 * h1 * ( 1.0D+00 / rt - hs ) ) as = h2 * h2 if ( abs ( h2 - h1 ) < tv4 ) then exit end if h1 = h2 end do end if ! ! Gaussian quadrature on the interval [0,H2]. ! rt = 0.0D+00 do i = 1, ngauss x = 0.5D+00 * h2 * ( xtab(i) + 1.0D+00 ) rt = rt + weight(i) * exp ( hs * ( 1.0D+00 + x * x ) ) & / ( 1.0D+00 + x * x ) end do tfn = rt * ( 0.5D+00 * h2 ) * two_pi_inverse end if return end subroutine timestamp ( ) !******************************************************************************* ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! Example: ! ! May 31 2001 9:45:54.872 AM ! ! Modified: ! ! 15 March 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none character ( len = 40 ) string call timestring ( string ) write ( *, '(a)' ) trim ( string ) return end subroutine timestring ( string ) !******************************************************************************* ! !! TIMESTRING writes the current YMDHMS date into a string. ! ! Example: ! ! STRING = 'May 31 2001 9:45:54.872 AM' ! ! Modified: ! ! 15 March 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) STRING, contains the date information. ! A character length of 40 should always be sufficient. ! implicit none character ( len = 8 ) ampm integer d character ( len = 8 ) date integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s character ( len = * ) string character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( string, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine triangle_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! TRIANGLE_CDF evaluates the Triangle CDF. ! ! Modified: ! ! 18 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A <= B <= C and A < C. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x <= a ) then cdf = 0.0D+00 else if ( x <= b ) then if ( a == b ) then cdf = 0.0D+00 else cdf = ( x - a ) * ( x - a ) / ( b - a ) / ( c - a ) end if else if ( x <= c ) then cdf = ( b - a ) / ( c - a ) & + ( 2.0D+00 * c - b - x ) * ( x - b ) / ( c - b ) / ( c - a ) else cdf = 1.0D+00 end if return end subroutine triangle_cdf_inv ( cdf, a, b, c, x ) !******************************************************************************* ! !! TRIANGLE_CDF_INV inverts the Triangle CDF. ! ! Modified: ! ! 17 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A <= B <= C and A < C. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) cdf_mid real ( kind = 8 ) d real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TRIANGLE_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if d = 2.0D+00 / ( c - a ) cdf_mid = 0.5D+00 * d * ( b - a ) if ( cdf <= cdf_mid ) then x = a + sqrt ( cdf * ( b - a ) * ( c - a ) ) else x = c - sqrt ( ( c - b ) * ( ( c - b ) - ( cdf - cdf_mid ) * ( c - a ) ) ) end if return end function triangle_check ( a, b, c ) !******************************************************************************* ! !! TRIANGLE_CHECK checks the parameters of the Triangle CDF. ! ! Modified: ! ! 17 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A <= B <= C and A < C. ! ! Output, logical TRIANGLE_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c logical triangle_check if ( b < a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TRIANGLE_CHECK - Fatal error!' write ( *, '(a)' ) ' B < A.' triangle_check = .false. return end if if ( c < b ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TRIANGLE_CHECK - Fatal error!' write ( *, '(a)' ) ' C < B.' triangle_check = .false. return end if if ( a == c ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TRIANGLE_CHECK - Fatal error!' write ( *, '(a)' ) ' A == C.' triangle_check = .false. return end if triangle_check = .true. return end subroutine triangle_mean ( a, b, c, mean ) !******************************************************************************* ! !! TRIANGLE_MEAN returns the mean of the Triangle PDF. ! ! Modified: ! ! 18 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A <= B <= C and A < C. ! ! Output, real ( kind = 8 ) MEAN, the mean of the discrete uniform PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) mean mean = a + ( c + b - 2.0D+00 * a ) / 3.0D+00 return end subroutine triangle_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! TRIANGLE_PDF evaluates the Triangle PDF. ! ! Discussion: ! ! Given points A <= B <= C, the probability is 0 to the left of A, ! rises linearly to a maximum of 2/(C-A) at B, drops linearly to zero ! at C, and is zero for all values greater than C. ! ! Formula: ! ! PDF(A,B,C;X) ! = 2 * ( X - A ) / ( B - A ) / ( C - A ) for A <= X <= B ! = 2 * ( C - X ) / ( C - B ) / ( C - A ) for B <= X <= C. ! ! Modified: ! ! 18 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A <= B <= C and A < C. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x <= a ) then pdf = 0.0D+00 else if ( x <= b ) then if ( a == b ) then pdf = 0.0D+00 else pdf = 2.0D+00 * ( x - a ) / ( b - a ) / ( c - a ) end if else if ( x <= c ) then if ( b == c ) then pdf = 0.0D+00 else pdf = 2.0D+00 * ( c - x ) / ( c - b ) / ( c - a ) end if else pdf = 0.0D+00 end if return end subroutine triangle_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! TRIANGLE_SAMPLE samples the Triangle PDF. ! ! Modified: ! ! 17 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A <= B <= C and A < C. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call triangle_cdf_inv ( cdf, a, b, c, x ) return end subroutine triangle_variance ( a, b, c, variance ) !******************************************************************************* ! !! TRIANGLE_VARIANCE returns the variance of the Triangle PDF. ! ! Modified: ! ! 18 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! A <= B <= C and A < C. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) variance variance = ( ( c - a ) * ( c - a ) & - ( c - a ) * ( b - a ) & + ( b - a ) * ( b - a ) ) / 18.0D+00 return end subroutine triangular_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! TRIANGULAR_CDF evaluates the Triangular CDF. ! ! Modified: ! ! 21 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x <= a ) then cdf = 0.0D+00 else if ( x <= 0.5D+00 * ( a + b ) ) then cdf = 2.0D+00 * ( x**2 - 2.0D+00 * a * x + a**2 ) / ( b - a )**2 else if ( x <= b ) then cdf = 0.5D+00 + ( - 2.0D+00 * x**2 + 4.0D+00 * b * x + 0.5D+00 * a**2 & - a * b - 1.5D+00 * b**2 ) / ( b - a )**2 else cdf = 1.0D+00 end if return end subroutine triangular_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! TRIANGULAR_CDF_INV inverts the Triangular CDF. ! ! Modified: ! ! 21 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TRIANGULAR_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf <= 0.5D+00 ) then x = a + 0.5D+00 * ( b - a ) * sqrt ( 2.0D+00 * cdf ) else x = b - 0.5D+00 * ( b - a ) * sqrt ( 2.0D+00 * ( 1.0D+00 - cdf ) ) end if return end function triangular_check ( a, b ) !******************************************************************************* ! !! TRIANGULAR_CHECK checks the parameters of the Triangular CDF. ! ! Modified: ! ! 18 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, logical TRIANGULAR_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical triangular_check if ( b <= a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TRIANGULAR_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= A.' triangular_check = .false. return end if triangular_check = .true. return end subroutine triangular_mean ( a, b, mean ) !******************************************************************************* ! !! TRIANGULAR_MEAN returns the mean of the Triangular PDF. ! ! Modified: ! ! 21 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = 0.5D+00 * ( a + b ) return end subroutine triangular_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! TRIANGULAR_PDF evaluates the Triangular PDF. ! ! Formula: ! ! PDF(A,B;X) = 4 * ( X - A ) / ( B - A )**2 for A <= X <= (A+B)/2 ! = 4 * ( B - X ) / ( B - A )**2 for (A+B)/2 <= X <= B. ! ! Modified: ! ! 21 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x <= a ) then pdf = 0.0D+00 else if ( x <= 0.5D+00 * ( a + b ) ) then pdf = 4.0D+00 * ( x - a ) / ( b - a )**2 else if ( x <= b ) then pdf = 4.0D+00 * ( b - x ) / ( b - a )**2 else pdf = 0.0D+00 end if return end subroutine triangular_sample ( a, b, seed, x ) !******************************************************************************* ! !! TRIANGULAR_SAMPLE samples the Triangular PDF. ! ! Modified: ! ! 21 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call triangular_cdf_inv ( cdf, a, b, x ) return end subroutine triangular_variance ( a, b, variance ) !******************************************************************************* ! !! TRIANGULAR_VARIANCE returns the variance of the Triangular PDF. ! ! Modified: ! ! 21 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = ( b - a )**2 / 24.0D+00 return end function trigamma ( x ) !******************************************************************************* ! !! TRIGAMMA calculates the TriGamma function. ! ! Discussion: ! ! TriGamma(x) = d**2 log ( Gamma ( x ) ) / dx**2. ! ! Modified: ! ! 03 January 2000 ! ! Author: ! ! B Schneider ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! B Schneider, ! Trigamma Function, ! Algorithm AS 121, ! Applied Statistics, ! Volume 27, Number 1, page 97-99, 1978. ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the trigamma function. ! 0 < X. ! ! Output, real ( kind = 8 ) TRIGAMMA, the value of the ! trigamma function at X. ! implicit none real ( kind = 8 ), parameter :: a = 0.0001D+00 real ( kind = 8 ), parameter :: b = 5.0D+00 real ( kind = 8 ), parameter :: b2 = 1.0D+00 / 6.0D+00 real ( kind = 8 ), parameter :: b4 = - 1.0D+00 / 30.0D+00 real ( kind = 8 ), parameter :: b6 = 1.0D+00 / 42.0D+00 real ( kind = 8 ), parameter :: b8 = - 1.0D+00 / 30.0D+00 real ( kind = 8 ) trigamma real ( kind = 8 ) x real ( kind = 8 ) y real ( kind = 8 ) z ! ! 1): If X is not positive, fail. ! if ( x <= 0.0D+00 ) then trigamma = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TRIGAMMA - Fatal error!' write ( *, '(a)' ) ' X <= 0.' stop ! ! 2): If X is smaller than A, use a small value approximation. ! else if ( x <= a ) then trigamma = 1.0D+00 / x**2 ! ! 3): Otherwise, increase the argument to B <= ( X + I ). ! else z = x trigamma = 0.0D+00 do while ( z < b ) trigamma = trigamma + 1.0D+00 / z**2 z = z + 1.0D+00 end do ! ! ...and then apply an asymptotic formula. ! y = 1.0D+00 / z**2 trigamma = trigamma + 0.5D+00 * & y + ( 1.0D+00 & + y * ( b2 & + y * ( b4 & + y * ( b6 & + y * b8 )))) / z end if return end subroutine uniform_01_cdf ( x, cdf ) !******************************************************************************* ! !! UNIFORM_01_CDF evaluates the Uniform 01 CDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x < 0.0D+00 ) then cdf = 0.0D+00 else if ( 1.0D+00 < x ) then cdf = 1.0D+00 else cdf = x end if return end subroutine uniform_01_cdf_inv ( cdf, x ) !******************************************************************************* ! !! UNIFORM_01_CDF_INV inverts the Uniform 01 CDF. ! ! Modified: ! ! 08 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'UNIFORM_01_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = cdf return end subroutine uniform_01_mean ( mean ) !******************************************************************************* ! !! UNIFORM_01_MEAN returns the mean of the Uniform 01 PDF. ! ! Modified: ! ! 08 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) mean mean = 0.5D+00 return end subroutine uniform_01_order_sample ( n, seed, x ) !******************************************************************************* ! !! UNIFORM_01_ORDER_SAMPLE samples the Uniform 01 Order PDF. ! ! Discussion: ! ! In effect, this routine simply generates N samples of the ! Uniform 01 PDF; but it generates them in order. (Actually, ! it generates them in descending order, but stores them in ! the array in ascending order). This saves the work of ! sorting the results. Moreover, if the order statistics ! for another PDF are desired, and the inverse CDF is available, ! then the desired values may be generated, presorted, by ! calling this routine and using the results as input to the ! inverse CDF routine. ! ! Modified: ! ! 03 March 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jerry Banks, editor, ! Handbook of Simulation, ! Engineering and Management Press Books, 1998, page 168. ! ! Parameters: ! ! Input, integer N, the number of elements in the sample. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X(N), N samples of the Uniform 01 PDF, in ! ascending order. ! implicit none integer n real ( kind = 8 ) d_uniform_01 integer i integer seed real ( kind = 8 ) u real ( kind = 8 ) v real ( kind = 8 ) x(n) v = 1.0D+00 do i = n, 1, -1 u = d_uniform_01 ( seed ) v = v * u**( 1.0D+00 / real ( i, kind = 8 ) ) x(i) = v end do return end subroutine uniform_01_pdf ( x, pdf ) !******************************************************************************* ! !! UNIFORM_01_PDF evaluates the Uniform 01 PDF. ! ! Formula: ! ! PDF(X) = 1 for 0 <= X <= 1 ! = 0 otherwise ! ! Modified: ! ! 08 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! 0.0D+00 <= X <= 1.0. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x < 0.0D+00 .or. 1.0D+00 < x ) then pdf = 0.0D+00 else pdf = 1.0D+00 end if return end function uniform_01_sample ( seed ) !******************************************************************************* ! !! UNIFORM_01_SAMPLE is a portable random number generator. ! ! Formula: ! ! SEED = SEED * (7**5) mod ( 2**31 - 1 ) ! UNIFORM_01_SAMPLE = SEED * / ( 2**31 - 1 ) ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer SEED, the integer "seed" used to generate ! the output random number, and updated in preparation for the ! next one. SEED should not be zero. ! ! Output, real ( kind = 8 ) UNIFORM_01_SAMPLE, a random value between 0 and 1. ! ! Local parameters: ! ! IA = 7**5 ! IB = 2**15 ! IB16 = 2**16 ! IP = 2**31-1 ! implicit none integer, parameter :: ia = 16807 integer, parameter :: ib15 = 32768 integer, parameter :: ib16 = 65536 integer, parameter :: ip = 2147483647 integer iprhi integer ixhi integer k integer leftlo integer loxa integer seed real ( kind = 8 ) uniform_01_sample ! ! Don't let SEED be 0 or IP ! if ( seed == 0 .or. seed == ip ) then seed = ip / 2 end if ! ! Get the 15 high order bits of SEED. ! ixhi = seed / ib16 ! ! Get the 16 low bits of SEED and form the low product. ! loxa = ( seed - ixhi * ib16 ) * ia ! ! Get the 15 high order bits of the low product. ! leftlo = loxa / ib16 ! ! Form the 31 highest bits of the full product. ! iprhi = ixhi * ia + leftlo ! ! Get overflow past the 31st bit of full product. ! k = iprhi / ib15 ! ! Assemble all the parts and presubtract IP. The parentheses are essential. ! seed = ( ( ( loxa - leftlo * ib16 ) - ip ) + ( iprhi - k * ib15 ) * ib16 ) & + k ! ! Add IP back in if necessary. ! if ( seed < 0 ) then seed = seed + ip end if ! ! Multiply by 1 / (2**31-1). ! uniform_01_sample = real ( seed, kind = 8 ) * 4.656612875D-10 return end subroutine uniform_01_variance ( variance ) !******************************************************************************* ! !! UNIFORM_01_VARIANCE returns the variance of the Uniform 01 PDF. ! ! Modified: ! ! 08 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) variance variance = 1.0D+00 / 12.0D+00 return end subroutine uniform_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! UNIFORM_CDF evaluates the Uniform CDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( x < a ) then cdf = 0.0D+00 else if ( b < x ) then cdf = 1.0D+00 else cdf = ( x - a ) / ( b - a ) end if return end subroutine uniform_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! UNIFORM_CDF_INV inverts the Uniform CDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'UNIFORM_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = a + ( b - a ) * cdf return end function uniform_check ( a, b ) !******************************************************************************* ! !! UNIFORM_CHECK checks the parameters of the Uniform CDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, logical UNIFORM_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical uniform_check if ( b <= a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'UNIFORM_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= A.' uniform_check = .false. return end if uniform_check = .true. return end subroutine uniform_mean ( a, b, mean ) !******************************************************************************* ! !! UNIFORM_MEAN returns the mean of the Uniform PDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = 0.5D+00 * ( a + b ) return end subroutine uniform_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! UNIFORM_PDF evaluates the Uniform PDF. ! ! Discussion: ! ! The Uniform PDF is also known as the "Rectangular" or "de Moivre" PDF. ! ! Formula: ! ! PDF(A,B;X) = 1 / ( B - A ) for A <= X <= B ! = 0 otherwise ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf real ( kind = 8 ) x if ( x < a .or. b < x ) then pdf = 0.0D+00 else pdf = 1.0D+00 / ( b - a ) end if return end subroutine uniform_sample ( a, b, seed, x ) !******************************************************************************* ! !! UNIFORM_SAMPLE samples the Uniform PDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call uniform_cdf_inv ( cdf, a, b, x ) return end subroutine uniform_variance ( a, b, variance ) !******************************************************************************* ! !! UNIFORM_VARIANCE returns the variance of the Uniform PDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! A < B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) variance variance = ( b - a )**2 / 12.0D+00 return end subroutine uniform_discrete_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! UNIFORM_DISCRETE_CDF evaluates the Uniform Discrete CDF. ! ! Modified: ! ! 29 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the CDF. ! ! Input, integer A, B, the parameters of the PDF. ! A <= B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none integer a integer b real ( kind = 8 ) cdf integer x if ( x < a ) then cdf = 0.0D+00 else if ( b < x ) then cdf = 1.0D+00 else cdf = real ( x + 1 - a, kind = 8 ) / real ( b + 1 - a, kind = 8 ) end if return end subroutine uniform_discrete_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! UNIFORM_DISCRETE_CDF_INV inverts the Uniform Discrete CDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, integer A, B, the parameters of the PDF. ! A <= B. ! ! Output, integer X, the smallest argument whose CDF is greater ! than or equal to CDF. ! implicit none integer a real ( kind = 8 ) a2 integer b real ( kind = 8 ) b2 real ( kind = 8 ) cdf integer x real ( kind = 8 ) x2 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'UNIFORM_DISCRETE_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if a2 = real ( a, kind = 8 ) - 0.5D+00 b2 = real ( b, kind = 8 ) + 0.5D+00 x2 = a + cdf * ( b2 - a2 ) x = nint ( x2 ) x = max ( x, a ) x = min ( x, b ) return end function uniform_discrete_check ( a, b ) !******************************************************************************* ! !! UNIFORM_DISCRETE_CHECK checks the parameters of the Uniform discrete CDF. ! ! Modified: ! ! 13 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, B, the parameters of the PDF. ! A <= B. ! ! Output, logical UNIFORM_DISCRETE_CHECK, is true if the parameters ! are legal. ! implicit none integer a integer b logical uniform_discrete_check if ( b < a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'UNIFORM_DISCRETE_CHECK - Fatal error!' write ( *, '(a)' ) ' B < A.' uniform_discrete_check = .false. return end if uniform_discrete_check = .true. return end subroutine uniform_discrete_mean ( a, b, mean ) !******************************************************************************* ! !! UNIFORM_DISCRETE_MEAN returns the mean of the Uniform discrete PDF. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, B, the parameters of the PDF. ! A <= B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none integer a integer b real ( kind = 8 ) mean mean = 0.5D+00 * real ( a + b, kind = 8 ) return end subroutine uniform_discrete_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! UNIFORM_DISCRETE_PDF evaluates the Uniform discrete PDF. ! ! Discussion: ! ! The Uniform Discrete PDF is also known as the "Rectangular" ! Discrete PDF. ! ! Formula: ! ! PDF(A,B;X) = 1 / ( B + 1 - A ) for A <= X <= B. ! ! The parameters define the interval of integers ! for which the PDF is nonzero. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the PDF. ! ! Input, integer A, B, the parameters of the PDF. ! A <= B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none integer a integer b real ( kind = 8 ) pdf integer x if ( x < a .or. b < x ) then pdf = 0.0D+00 else pdf = 1.0D+00 / real ( b + 1 - a, kind = 8 ) end if return end subroutine uniform_discrete_sample ( a, b, seed, x ) !******************************************************************************* ! !! UNIFORM_DISCRETE_SAMPLE samples the Uniform discrete PDF. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, B, the parameters of the PDF. ! A <= B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none integer a integer b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed integer x cdf = d_uniform_01 ( seed ) call uniform_discrete_cdf_inv ( cdf, a, b, x ) return end subroutine uniform_discrete_variance ( a, b, variance ) !******************************************************************************* ! !! UNIFORM_DISCRETE_VARIANCE returns the variance of the Uniform discrete PDF. ! ! Modified: ! ! 28 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, B, the parameters of the PDF. ! A <= B. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none integer a integer b real ( kind = 8 ) variance variance = real ( ( b + 1 - a )**2 - 1, kind = 8 ) / 12.0D+00 return end subroutine uniform_nsphere_sample ( n, seed, x ) !******************************************************************************* ! !! UNIFORM_NSPHERE_SAMPLE samples the Uniform Unit Sphere PDF. ! ! Modified: ! ! 15 December 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jerry Banks, editor, ! Handbook of Simulation, ! Engineering and Management Press Books, 1998, page 168. ! ! Parameters: ! ! Input, integer N, the dimension of the sphere. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X(N), a point on the unit N sphere, chosen ! with a uniform probability. ! implicit none integer n integer i integer seed real ( kind = 8 ) x(n) do i = 1, n call normal_01_sample ( seed, x(i) ) end do x(1:n) = x(1:n) / sqrt ( sum ( x(1:n)**2 ) ) return end subroutine von_mises_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! VON_MISES_CDF evaluates the von Mises CDF. ! ! Modified: ! ! 22 September 2005 ! ! Author: ! ! Geoffrey Hill ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Geoffrey Hill, ! ACM TOMS Algorithm 518, ! Incomplete Bessel Function I0: The von Mises Distribution, ! ACM Transactions on Mathematical Software, ! Volume 3, Number 3, September 1977, pages 279-284. ! ! Kanti Mardia and Peter Jupp, ! Directional Statistics, ! Wiley, 2000, QA276.M335 ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! A - PI <= X <= A + PI. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -PI <= A <= PI, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ), parameter :: a1 = 12.0D+00 real ( kind = 8 ), parameter :: a2 = 0.8D+00 real ( kind = 8 ), parameter :: a3 = 8.0D+00 real ( kind = 8 ), parameter :: a4 = 1.0D+00 real ( kind = 8 ) arg real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ), parameter :: c1 = 56.0D+00 real ( kind = 8 ) cdf real ( kind = 8 ), parameter :: ck = 10.5D+00 real ( kind = 8 ) cn real ( kind = 8 ) erf real ( kind = 8 ) erfx integer ip integer n real ( kind = 8 ) p real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r real ( kind = 8 ) s real ( kind = 8 ) sn real ( kind = 8 ) u real ( kind = 8 ) v real ( kind = 8 ) x real ( kind = 8 ) y real ( kind = 8 ) z ! ! We expect -PI <= X - A <= PI. ! if ( x - a <= -pi ) then cdf = 0.0D+00 return end if if ( pi <= x - a ) then cdf = 1.0D+00 return end if ! ! Convert the angle (X - A) modulo 2 PI to the range ( 0, 2 * PI ). ! z = b u = mod ( x - a + pi, 2.0D+00 * pi ) if ( u < 0.0D+00 ) then u = u + 2.0D+00 * pi end if y = u - pi ! ! For small B, sum IP terms by backwards recursion. ! if ( z <= ck ) then v = 0.0D+00 if ( 0.0D+00 < z ) then ip = int ( z * a2 - a3 / ( z + a4 ) + a1 ) p = real ( ip, kind = 8 ) s = sin ( y ) c = cos ( y ) y = p * y sn = sin ( y ) cn = cos ( y ) r = 0.0D+00 z = 2.0D+00 / z do n = 2, ip p = p - 1.0D+00 y = sn sn = sn * c - cn * s cn = cn * c + y * s r = 1.0D+00 / ( p * z + r ) v = ( sn / p + v ) * r end do end if cdf = ( u * 0.5D+00 + v ) / pi ! ! For large B, compute the normal approximation and left tail. ! else c = 24.0D+00 * z v = c - c1 r = sqrt ( ( 54.0D+00 / ( 347.0D+00 / v + 26.0D+00 - c ) - 6.0D+00 + c ) & / 12.0D+00 ) z = sin ( 0.5D+00 * y ) * r s = 2.0D+00 * z**2 v = v - s + 3.0D+00 y = ( c - s - s - 16.0D+00 ) / 3.0D+00 y = ( ( s + 1.75D+00 ) * s + 83.5D+00 ) / v - y arg = z * ( 1.0D+00 - s / y**2 ) erfx = erf ( arg ) cdf = 0.5D+00 * erfx + 0.5D+00 end if cdf = max ( cdf, 0.0D+00 ) cdf = min ( cdf, 1.0D+00 ) return end subroutine von_mises_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! VON_MISES_CDF_INV inverts the von Mises CDF. ! ! Discussion: ! ! A simple bisection method is used on the interval [ A - PI, A + PI ]. ! ! Modified: ! ! 19 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -PI <= A <= PI, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! A - PI <= X <= A + PI. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) cdf1 real ( kind = 8 ) cdf2 real ( kind = 8 ) cdf3 integer it integer, parameter :: it_max = 100 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ), parameter :: tol = 0.000001D+00 real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 real ( kind = 8 ) x3 if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'VON_MISES_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if if ( cdf == 0.0D+00 ) then x = a - pi return else if ( 1.0D+00 == cdf ) then x = a + pi return end if x1 = a - pi cdf1 = 0.0D+00 x2 = a + pi cdf2 = 1.0D+00 ! ! Now use bisection. ! it = 0 do it = it + 1 x3 = 0.5D+00 * ( x1 + x2 ) call von_mises_cdf ( x3, a, b, cdf3 ) if ( abs ( cdf3 - cdf ) < tol ) then x = x3 exit end if if ( it_max < it ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'VON_MISES_CDF_INV - Fatal error!' write ( *, '(a)' ) ' Iteration limit exceeded.' stop end if if ( sign ( 1.0D+00, cdf3 - cdf ) == sign ( 1.0D+00, cdf1 - cdf ) ) then x1 = x3 cdf1 = cdf3 else x2 = x3 cdf2 = cdf3 end if end do return end subroutine von_mises_cdf_values ( n_data, a, b, x, fx ) !******************************************************************************* ! !! VON_MISES_CDF_VALUES returns some values of the von Mises CDF. ! ! Modified: ! ! 08 December 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Kanti Mardia and Peter Jupp, ! Directional Statistics, ! Wiley, 2000, QA276.M335 ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) A, B, the parameters of the function. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 23 real ( kind = 8 ) a real ( kind = 8 ), save, dimension ( n_max ) :: a_vec = (/ & 0.0D+00, & 0.0D+00, & 0.0D+00, & 0.0D+00, & 0.0D+00, & 0.1D+01, & 0.1D+01, & 0.1D+01, & 0.1D+01, & 0.1D+01, & 0.1D+01, & -0.2D+01, & -0.1D+01, & 0.0D+01, & 0.1D+01, & 0.2D+01, & 0.3D+01, & 0.0D+00, & 0.0D+00, & 0.0D+00, & 0.0D+00, & 0.0D+00, & 0.0D+00 /) real ( kind = 8 ) b real ( kind = 8 ), save, dimension ( n_max ) :: b_vec = (/ & 0.1D+01, & 0.1D+01, & 0.1D+01, & 0.1D+01, & 0.1D+01, & 0.2D+01, & 0.2D+01, & 0.2D+01, & 0.2D+01, & 0.2D+01, & 0.2D+01, & 0.3D+01, & 0.3D+01, & 0.3D+01, & 0.3D+01, & 0.3D+01, & 0.3D+01, & 0.0D+00, & 0.1D+01, & 0.2D+01, & 0.3D+01, & 0.4D+01, & 0.5D+01 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.2535089956281180D-01, & 0.1097539041177346D+00, & 0.5000000000000000D+00, & 0.8043381312498558D+00, & 0.9417460124555197D+00, & 0.5000000000000000D+00, & 0.6018204118446155D+00, & 0.6959356933122230D+00, & 0.7765935901304593D+00, & 0.8410725934916615D+00, & 0.8895777369550366D+00, & 0.9960322705517925D+00, & 0.9404336090170247D+00, & 0.5000000000000000D+00, & 0.5956639098297530D-01, & 0.3967729448207649D-02, & 0.2321953958111930D-03, & 0.6250000000000000D+00, & 0.7438406999109122D+00, & 0.8369224904294019D+00, & 0.8941711407897124D+00, & 0.9291058600568743D+00, & 0.9514289900655436D+00 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & -0.2617993977991494D+01, & -0.1570796326794897D+01, & 0.0000000000000000D+00, & 0.1047197551196598D+01, & 0.2094395102393195D+01, & 0.1000000000000000D+01, & 0.1200000000000000D+01, & 0.1400000000000000D+01, & 0.1600000000000000D+01, & 0.1800000000000000D+01, & 0.2000000000000000D+01, & 0.0000000000000000D+00, & 0.0000000000000000D+00, & 0.0000000000000000D+00, & 0.0000000000000000D+00, & 0.0000000000000000D+00, & 0.0000000000000000D+00, & 0.7853981633974483D+00, & 0.7853981633974483D+00, & 0.7853981633974483D+00, & 0.7853981633974483D+00, & 0.7853981633974483D+00, & 0.7853981633974483D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 a = 0.0D+00 b = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else a = a_vec(n_data) b = b_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function von_mises_check ( a, b ) !******************************************************************************* ! !! VON_MISES_CHECK checks the parameters of the von Mises PDF. ! ! Modified: ! ! 09 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -PI <= A <= PI, ! 0.0D+00 < B. ! ! Output, logical VON_MISES_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 logical von_mises_check if ( a < -pi .or. pi < a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'VON_MISES_CHECK - Fatal error!' write ( *, '(a)' ) ' A < -PI or PI < A.' von_mises_check = .false. return end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'VON_MISES_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.0' von_mises_check = .false. return end if von_mises_check = .true. return end subroutine von_mises_circular_variance ( a, b, circular_variance ) !******************************************************************************* ! !! VON_MISES_CIRCULAR_VARIANCE returns the circular variance of the von Mises PDF. ! ! Modified: ! ! 02 December 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -PI <= A <= PI, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CIRCULAR_VARIANCE, the circular variance ! of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) bessel_i0 real ( kind = 8 ) bessel_i1 real ( kind = 8 ) circular_variance circular_variance = 1.0D+00 - bessel_i1 ( b ) / bessel_i0 ( b ) return end subroutine von_mises_mean ( a, b, mean ) !******************************************************************************* ! !! VON_MISES_MEAN returns the mean of the von Mises PDF. ! ! Modified: ! ! 07 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -PI <= A <= PI, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) mean mean = a return end subroutine von_mises_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! VON_MISES_PDF evaluates the von Mises PDF. ! ! Formula: ! ! PDF(A,B;X) = EXP ( B * COS ( X - A ) ) / ( 2 * PI * I0(B) ) ! ! where: ! ! I0(*) is the modified Bessel function of the first ! kind of order 0. ! ! The von Mises distribution for points on the unit circle is ! analogous to the normal distribution of points on a line. ! The variable X is interpreted as a deviation from the angle A, ! with B controlling the amount of dispersion. ! ! Modified: ! ! 27 October 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jerry Banks, editor, ! Handbook of Simulation, ! Engineering and Management Press Books, 1998, page 160. ! ! D J Best and N I Fisher, ! Efficient Simulation of the von Mises Distribution, ! Applied Statistics, ! Volume 28, Number 2, pages 152-157. ! ! Merran Evans, Nicholas Hastings, Brian Peacock, ! Statistical Distributions, ! Wiley, 2000, QA273.6.E92, pages 189-191. ! ! Kanti Mardia and Peter Jupp, ! Directional Statistics, ! Wiley, 2000, QA276.M335 ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A - PI <= X <= A + PI. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -PI <= A <= PI, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) bessel_i0 real ( kind = 8 ) pdf real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) x if ( x < a - pi ) then pdf = 0.0D+00 else if ( x <= a + pi ) then pdf = exp ( b * cos ( x - a ) ) / ( 2.0D+00 * pi * bessel_i0 ( b ) ) else pdf = 0.0D+00 end if return end subroutine von_mises_sample ( a, b, seed, x ) !******************************************************************************* ! !! VON_MISES_SAMPLE samples the von Mises PDF. ! ! Modified: ! ! 07 March 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! D J Best and N I Fisher, ! Efficient Simulation of the von Mises Distribution, ! Applied Statistics, ! Volume 28, Number 2, pages 152-157. ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! -PI <= A <= PI, ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) d_uniform_01 real ( kind = 8 ) f real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r real ( kind = 8 ) rho integer seed real ( kind = 8 ) tau real ( kind = 8 ) u1 real ( kind = 8 ) u2 real ( kind = 8 ) u3 real ( kind = 8 ) x real ( kind = 8 ) z tau = 1.0D+00 + sqrt ( 1.0D+00 + 4.0D+00 * b * b ) rho = ( tau - sqrt ( 2.0D+00 * tau ) ) / ( 2.0D+00 * b ) r = ( 1.0D+00 + rho**2 ) / ( 2.0D+00 * rho ) do u1 = d_uniform_01 ( seed ) z = cos ( pi * u1 ) f = ( 1.0D+00 + r * z ) / ( r + z ) c = b * ( r - f ) u2 = d_uniform_01 ( seed ) if ( u2 < c * ( 2.0D+00 - c ) ) then exit end if if ( c <= log ( c / u2 ) + 1.0D+00 ) then exit end if end do u3 = d_uniform_01 ( seed ) x = a + sign ( 1.0D+00, u3 - 0.5D+00 ) * acos ( f ) return end subroutine weibull_cdf ( x, a, b, c, cdf ) !******************************************************************************* ! !! WEIBULL_CDF evaluates the Weibull CDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the CDF. ! A <= X. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) x real ( kind = 8 ) y if ( x < a ) then cdf = 0.0D+00 else y = ( x - a ) / b cdf = 1.0D+00 - 1.0D+00 / exp ( y**c ) end if return end subroutine weibull_cdf_inv ( cdf, a, b, c, x ) !******************************************************************************* ! !! WEIBULL_CDF_INV inverts the Weibull CDF. ! ! Modified: ! ! 13 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 < CDF < 1.0. ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) X, the corresponding argument of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'WEIBULL_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = a + b * ( - log ( 1.0D+00 - cdf ) )**( 1.0D+00 / c ) return end subroutine weibull_cdf_values ( n_data, alpha, beta, x, fx ) !******************************************************************************* ! !! WEIBULL_CDF_VALUES returns some values of the Weibull CDF. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! Needs["Statistics`ContinuousDistributions`"] ! dist = WeibullDistribution [ alpha, beta ] ! CDF [ dist, x ] ! ! Modified: ! ! 31 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 before the ! first call. On each call, the routine increments N_DATA by 1, and ! returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = 8 ) ALPHA, the first parameter of the distribution. ! ! Output, real ( kind = 8 ) BETA, the second parameter of the distribution. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer, parameter :: n_max = 12 real ( kind = 8 ) alpha real ( kind = 8 ), save, dimension ( n_max ) :: alpha_vec = (/ & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01 /) real ( kind = 8 ) beta real ( kind = 8 ), save, dimension ( n_max ) :: beta_vec = (/ & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.5000000000000000D+00, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.5000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01 /) real ( kind = 8 ) fx real ( kind = 8 ), save, dimension ( n_max ) :: fx_vec = (/ & 0.8646647167633873D+00, & 0.9816843611112658D+00, & 0.9975212478233336D+00, & 0.9996645373720975D+00, & 0.6321205588285577D+00, & 0.4865828809674080D+00, & 0.3934693402873666D+00, & 0.3296799539643607D+00, & 0.8946007754381357D+00, & 0.9657818816883340D+00, & 0.9936702845725143D+00, & 0.9994964109502630D+00 /) integer n_data real ( kind = 8 ) x real ( kind = 8 ), save, dimension ( n_max ) :: x_vec = (/ & 0.1000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.4000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.2000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01, & 0.3000000000000000D+01 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 alpha = 0.0D+00 beta = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else alpha = alpha_vec(n_data) beta = beta_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function weibull_check ( a, b, c ) !******************************************************************************* ! !! WEIBULL_CHECK checks the parameters of the Weibull CDF. ! ! Modified: ! ! 18 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, logical WEIBULL_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c logical weibull_check if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'WEIBULL_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' weibull_check = .false. return end if if ( c <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'WEIBULL_CHECK - Fatal error!' write ( *, '(a)' ) ' C <= 0.' weibull_check = .false. return end if weibull_check = .true. return end subroutine weibull_mean ( a, b, c, mean ) !******************************************************************************* ! !! WEIBULL_MEAN returns the mean of the Weibull PDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) gamma real ( kind = 8 ) mean mean = b * gamma ( ( c + 1.0D+00 ) / c ) + a return end subroutine weibull_pdf ( x, a, b, c, pdf ) !******************************************************************************* ! !! WEIBULL_PDF evaluates the Weibull PDF. ! ! Formula: ! ! PDF(A,B,C;X) = ( C / B ) * ( ( X - A ) / B )**( C - 1 ) ! * EXP ( - ( ( X - A ) / B )**C ). ! ! Discussion: ! ! The Weibull PDF is also known as the Frechet PDF. ! ! WEIBULL_PDF(A,B,1;X) is the Exponential PDF. ! ! WEIBULL_PDF(0,1,2;X) is the Rayleigh PDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the PDF. ! A <= X ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) pdf real ( kind = 8 ) x real ( kind = 8 ) y if ( x < a ) then pdf = 0.0D+00 else y = ( x - a ) / b pdf = ( c / b ) * y**( c - 1.0D+00 ) / exp ( y**c ) end if return end subroutine weibull_sample ( a, b, c, seed, x ) !******************************************************************************* ! !! WEIBULL_SAMPLE samples the Weibull PDF. ! ! Modified: ! ! 12 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, real ( kind = 8 ) X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) x cdf = d_uniform_01 ( seed ) call weibull_cdf_inv ( cdf, a, b, c, x ) return end subroutine weibull_variance ( a, b, c, variance ) !******************************************************************************* ! !! WEIBULL_VARIANCE returns the variance of the Weibull PDF. ! ! Modified: ! ! 16 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, C, the parameters of the PDF. ! 0.0D+00 < B, ! 0.0D+00 < C. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) gamma real ( kind = 8 ) g1 real ( kind = 8 ) g2 real ( kind = 8 ) variance g1 = gamma ( ( c + 2.0D+00 ) / c ) g2 = gamma ( ( c + 1.0D+00 ) / c ) variance = b * b * ( g1 - g2 * g2 ) return end subroutine weibull_discrete_cdf ( x, a, b, cdf ) !******************************************************************************* ! !! WEIBULL_DISCRETE_CDF evaluates the Discrete Weibull CDF. ! ! Modified: ! ! 17 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the CDF. ! 0 <= X. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 <= A <= 1.0D+00, ! 0.0D+00 < B. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf integer x if ( x < 0 ) then cdf = 0.0D+00 else cdf = 1.0D+00 - ( 1.0D+00 - a )**((x+1)**b) end if return end subroutine weibull_discrete_cdf_inv ( cdf, a, b, x ) !******************************************************************************* ! !! WEIBULL_DISCRETE_CDF_INV inverts the Discrete Weibull CDF. ! ! Modified: ! ! 19 October 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) CDF, the value of the CDF. ! 0.0D+00 <= CDF <= 1.0. ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 <= A <= 1.0D+00, ! 0.0D+00 < B. ! ! Output, integer X, the corresponding argument. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf integer d_ceiling integer x if ( cdf < 0.0D+00 .or. 1.0D+00 < cdf ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'WEIBULL_DISCRETE_CDF_INV - Fatal error!' write ( *, '(a)' ) ' CDF < 0 or 1 < CDF.' stop end if x = d_ceiling ( & ( log ( 1.0D+00 - cdf ) / log ( 1.0D+00 - a ) )**( 1.0D+00 / b ) - 1.0D+00 ) return end function weibull_discrete_check ( a, b ) !******************************************************************************* ! !! WEIBULL_DISCRETE_CHECK checks the parameters of the discrete Weibull CDF. ! ! Modified: ! ! 08 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 <= A <= 1.0D+00, ! 0.0D+00 < B. ! ! Output, logical WEIBULL_DISCRETE_CHECK, is true if the parameters ! are legal. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b logical weibull_discrete_check if ( a < 0.0D+00 .or. 1.0D+00 < a ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'WEIBULL_DISCRETE_CHECK - Fatal error!' write ( *, '(a)' ) ' A < 0 or 1 < A.' weibull_discrete_check = .false. return end if if ( b <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'WEIBULL_DISCRETE_CHECK - Fatal error!' write ( *, '(a)' ) ' B <= 0.' weibull_discrete_check = .false. return end if weibull_discrete_check = .true. return end subroutine weibull_discrete_pdf ( x, a, b, pdf ) !******************************************************************************* ! !! WEIBULL_DISCRETE_PDF evaluates the discrete Weibull PDF. ! ! Formula: ! ! PDF(A,B;X) = ( 1 - A )**X**B - ( 1 - A )**(X+1)**B. ! ! Discussion: ! ! WEIBULL_DISCRETE_PDF(A,1;X) = GEOMETRIC_PDF(A;X) ! ! Modified: ! ! 15 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the PDF. ! 0 <= X ! ! Input, real ( kind = 8 ) A, B, the parameters that define the PDF. ! 0 <= A <= 1, ! 0 < B. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) pdf integer x if ( x < 0 ) then pdf = 0.0D+00 else pdf = ( 1.0D+00 - a )**(x**b) - ( 1.0D+00 - a )**((x+1)**b) end if return end subroutine weibull_discrete_sample ( a, b, seed, x ) !******************************************************************************* ! !! WEIBULL_DISCRETE_SAMPLE samples the discrete Weibull PDF. ! ! Modified: ! ! 07 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, B, the parameters of the PDF. ! 0.0D+00 <= A <= 1.0D+00, ! 0.0D+00 < B. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) cdf real ( kind = 8 ) d_uniform_01 integer seed integer x cdf = d_uniform_01 ( seed ) call weibull_discrete_cdf_inv ( cdf, a, b, x ) return end function zeta ( p ) !******************************************************************************* ! !! ZETA estimates the Riemann Zeta function. ! ! Definition: ! ! For 1 < P, the Riemann Zeta function is defined as: ! ! ZETA ( P ) = Sum ( 1 <= N < Infinity ) 1 / N**P ! ! Modified: ! ! 07 March 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Daniel Zwillinger, editor, ! CRC Standard Mathematical Tables and Formulae, ! 30th Edition, ! CRC Press, 1996. ! ! Parameters: ! ! Input, real ( kind = 8 ) P, the power to which the integers are raised. ! P must be greater than 1. For integral P up to 20, a ! precomputed value of ZETA is returned; otherwise the infinite ! sum is approximated. ! ! Output, real ( kind = 8 ) ZETA, an approximation to the Riemann ! Zeta function. ! implicit none integer n real ( kind = 8 ) p real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) zsum real ( kind = 8 ) zsum_old real ( kind = 8 ) zeta if ( p <= 1.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ZETA - Fatal error!' write ( *, '(a)' ) ' Exponent P <= 1.0.' stop else if ( p == 2.0D+00 ) then zeta = pi**2 / 6.0D+00 else if ( p == 3.0D+00 ) then zeta = 1.2020569032D+00 else if ( p == 4.0D+00 ) then zeta = pi**4 / 90.0D+00 else if ( p == 5.0D+00 ) then zeta = 1.0369277551D+00 else if ( p == 6.0D+00 ) then zeta = pi**6 / 945.0D+00 else if ( p == 7.0D+00 ) then zeta = 1.0083492774D+00 else if ( p == 8.0D+00 ) then zeta = pi**8 / 9450.0D+00 else if ( p == 9.0D+00 ) then zeta = 1.0020083928D+00 else if ( p == 10.0D+00 ) then zeta = pi**10 / 93555.0D+00 else if ( p == 11.0D+00 ) then zeta = 1.0004941886D+00 else if ( p == 12.0D+00 ) then zeta = 1.0002460866D+00 else if ( p == 13.0D+00 ) then zeta = 1.0001227133D+00 else if ( p == 14.0D+00 ) then zeta = 1.0000612482D+00 else if ( p == 15.0D+00 ) then zeta = 1.0000305882D+00 else if ( p == 16.0D+00 ) then zeta = 1.0000152823D+00 else if ( p == 17.0D+00 ) then zeta = 1.0000076372D+00 else if ( p == 18.0D+00 ) then zeta = 1.0000038173D+00 else if ( p == 19.0D+00 ) then zeta = 1.0000019082D+00 else if ( p == 20.0D+00 ) then zeta = 1.0000009540D+00 else zsum = 0.0D+00 n = 0 do n = n + 1 zsum_old = zsum zsum = zsum + 1.0D+00 / ( real ( n, kind = 8 ) )**p if ( zsum <= zsum_old ) then exit end if end do zeta = zsum end if return end subroutine zipf_cdf ( x, a, cdf ) !******************************************************************************* ! !! ZIPF_CDF evaluates the Zipf CDF. ! ! Discussion: ! ! Simple summation is used. ! ! Modified: ! ! 19 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the PDF. ! 1 <= N ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 1.0D+00 < A. ! ! Output, real ( kind = 8 ) CDF, the value of the CDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ), save :: asave = 0.0D+00 real ( kind = 8 ), save :: c = 0.0D+00 real ( kind = 8 ) cdf real ( kind = 8 ) pdf integer x integer y real ( kind = 8 ) zeta if ( x < 1 ) then cdf = 0.0D+00 else if ( a /= asave ) then c = zeta ( a ) asave = a end if cdf = 0.0D+00 do y = 1, x pdf = ( 1.0D+00 / real ( y, kind = 8 )**a ) / c cdf = cdf + pdf end do end if return end function zipf_check ( a ) !******************************************************************************* ! !! ZIPF_CHECK checks the parameter of the Zipf PDF. ! ! Modified: ! ! 18 September 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 1.0D+00 < A. ! ! Output, logical ZIPF_CHECK, is true if the parameters are legal. ! implicit none real ( kind = 8 ) a logical zipf_check if ( a <= 1.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ZIPF_CHECK - Fatal error!' write ( *, '(a)' ) ' A <= 1.' zipf_check = .false. return end if zipf_check = .true. return end subroutine zipf_mean ( a, mean ) !******************************************************************************* ! !! ZIPF_MEAN returns the mean of the Zipf PDF. ! ! Modified: ! ! 01 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 1.0D+00 < A. ! ! Output, real ( kind = 8 ) MEAN, the mean of the PDF. ! The mean is only defined for 2 < A. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) mean real ( kind = 8 ) zeta if ( a <= 2.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ZIPF_MEAN - Fatal error!' write ( *, '(a)' ) ' No mean defined for A <= 2.' stop end if mean = zeta ( a - 1.0D+00 ) / zeta ( a ) return end subroutine zipf_pdf ( x, a, pdf ) !******************************************************************************* ! !! ZIPF_PDF evaluates the Zipf PDF. ! ! Formula: ! ! PDF(A;X) = ( 1 / X**A ) / C ! ! where the normalizing constant is chosen so that ! ! C = Sum ( 1 <= I < Infinity ) 1 / I**A. ! ! Discussion: ! ! From observation, the frequency of different words in long ! sequences of text seems to follow the Zipf PDF, with ! parameter A slightly greater than 1. The Zipf PDF is sometimes ! known as the "discrete Pareto" PDF. ! ! Modified: ! ! 07 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X, the argument of the PDF. ! 1 <= N ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 1.0D+00 < A. ! ! Output, real ( kind = 8 ) PDF, the value of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ), save :: asave = 0.0D+00 real ( kind = 8 ), save :: c = 0.0D+00 real ( kind = 8 ) pdf integer x real ( kind = 8 ) zeta if ( x < 1 ) then pdf = 0.0D+00 else if ( a /= asave ) then c = zeta ( a ) asave = a end if pdf = ( 1.0D+00 / real ( x, kind = 8 )**a ) / c end if return end subroutine zipf_sample ( a, seed, x ) !******************************************************************************* ! !! ZIPF_SAMPLE samples the Zipf PDF. ! ! Discussion: ! ! I am concerned that there may be a discrepancy in the results ! of this routine, which do not seem to have the predicted variances. ! ! Modified: ! ! 06 March 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Luc Devroye, ! Non-Uniform Random Variate Generation, ! Springer Verlag, 1986, pages 550-551. ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 1.0D+00 < A. ! ! Input/output, integer SEED, a seed for the random number generator. ! ! Output, integer X, a sample of the PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) d_uniform_01 integer seed real ( kind = 8 ) t real ( kind = 8 ) test real ( kind = 8 ) u real ( kind = 8 ) v real ( kind = 8 ) w integer x test = real ( huge ( 1 ) ) b = 2.0D+00**( a - 1.0D+00 ) do u = d_uniform_01 ( seed ) v = d_uniform_01 ( seed ) w = aint ( 1.0D+00 / u**( 1.0D+00 / ( a - 1.0D+00 ) ) ) ! ! Very small values of U can cause W to be very large, ! bigger than the largest integer... ! if ( test < w ) then cycle end if t = ( ( w + 1.0D+00 ) / w )**( a - 1.0D+00 ) if ( v * w * ( t - 1.0D+00 ) * b <= t * ( b - 1.0D+00 ) ) then exit end if end do x = int ( w ) return end subroutine zipf_variance ( a, variance ) !******************************************************************************* ! !! ZIPF_VARIANCE returns the variance of the Zipf PDF. ! ! Modified: ! ! 01 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the parameter of the PDF. ! 1.0D+00 < A. ! ! Output, real ( kind = 8 ) VARIANCE, the variance of the PDF. ! The variance is only defined for 3 < A. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) mean real ( kind = 8 ) variance real ( kind = 8 ) zeta if ( a <= 3.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ZIPF_VARIANCE - Fatal error!' write ( *, '(a)' ) ' No variance defined for A <= 3.0.' stop end if call zipf_mean ( a, mean ) variance = zeta ( a - 2.0D+00 ) / zeta ( a ) - mean * mean return end