function algdiv ( a, b ) !*****************************************************************************80 ! !! ALGDIV computes ln ( Gamma ( B ) / Gamma ( A + B ) ) when 8 <= B. ! ! Discussion: ! ! In this algorithm, DEL(X) is the function defined by ! ! ln ( Gamma(X) ) = ( X - 0.5 ) * ln ( X ) - X + 0.5 * ln ( 2 * PI ) ! + DEL(X). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! real ( kind = rk ) A, B, define the arguments. ! ! Output: ! ! real ( kind = rk ) ALGDIV, the value of ln(Gamma(B)/Gamma(A+B)). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) algdiv real ( kind = rk ) alnrel real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ), parameter :: c0 = 0.833333333333333D-01 real ( kind = rk ), parameter :: c1 = -0.277777777760991D-02 real ( kind = rk ), parameter :: c2 = 0.793650666825390D-03 real ( kind = rk ), parameter :: c3 = -0.595202931351870D-03 real ( kind = rk ), parameter :: c4 = 0.837308034031215D-03 real ( kind = rk ), parameter :: c5 = -0.165322962780713D-02 real ( kind = rk ) d real ( kind = rk ) h real ( kind = rk ) s11 real ( kind = rk ) s3 real ( kind = rk ) s5 real ( kind = rk ) s7 real ( kind = rk ) s9 real ( kind = rk ) t real ( kind = rk ) u real ( kind = rk ) v real ( kind = rk ) w real ( kind = rk ) x real ( kind = rk ) x2 if ( b < a ) then h = b / a c = 1.0D+00 / ( 1.0D+00 + h ) x = h / ( 1.0D+00 + h ) d = a + ( b - 0.5D+00 ) else h = a / b c = h / ( 1.0D+00 + h ) x = 1.0D+00 / ( 1.0D+00 + h ) d = b + ( a - 0.5D+00 ) end if ! ! Set SN = (1 - X^N)/(1 - X). ! x2 = x * x s3 = 1.0D+00 + ( x + x2 ) s5 = 1.0D+00 + ( x + x2 * s3 ) s7 = 1.0D+00 + ( x + x2 * s5 ) s9 = 1.0D+00 + ( x + x2 * s7 ) s11 = 1.0D+00 + ( x + x2 * s9 ) ! ! Set W = DEL(B) - DEL(A + B). ! t = ( 1.0D+00 / b )**2 w = (((( & c5 * s11 * t & + c4 * s9 ) * t & + c3 * s7 ) * t & + c2 * s5 ) * t & + c1 * s3 ) * t & + c0 w = w * ( c / b ) ! ! Combine the results. ! u = d * alnrel ( a / b ) v = a * ( log ( b ) - 1.0D+00 ) if ( v < u ) then algdiv = ( w - v ) - u else algdiv = ( w - u ) - v end if return end function alnrel ( a ) !*****************************************************************************80 ! !! ALNREL evaluates the function ln ( 1 + A ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! real ( kind = rk ) A, the argument. ! ! Output: ! ! real ( kind = rk ) ALNREL, the value of ln ( 1 + A ). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) alnrel real ( kind = rk ), parameter :: p1 = -0.129418923021993D+01 real ( kind = rk ), parameter :: p2 = 0.405303492862024D+00 real ( kind = rk ), parameter :: p3 = -0.178874546012214D-01 real ( kind = rk ), parameter :: q1 = -0.162752256355323D+01 real ( kind = rk ), parameter :: q2 = 0.747811014037616D+00 real ( kind = rk ), parameter :: q3 = -0.845104217945565D-01 real ( kind = rk ) t real ( kind = rk ) t2 real ( kind = rk ) w real ( kind = rk ) x if ( abs ( a ) <= 0.375D+00 ) then t = a / ( a + 2.0D+00 ) t2 = t * t w = ((( p3 * t2 + p2 ) * t2 + p1 ) * t2 + 1.0D+00 ) & / ((( q3 * t2 + q2 ) * t2 + q1 ) * t2 + 1.0D+00 ) alnrel = 2.0D+00 * t * w else x = 1.0D+00 + real ( a, kind = rk ) alnrel = log ( x ) end if return end function apser ( a, b, x, eps ) !*****************************************************************************80 ! !! APSER computes the incomplete beta ratio I(SUB(1-X))(B,A). ! ! Discussion: ! ! APSER is used only for cases where ! ! A <= min ( EPS, EPS * B ), ! B * X <= 1, and ! X <= 0.5. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! real ( kind = rk ) A, B, X, the parameters of the ! incomplete beta ratio. ! ! real ( kind = rk ) EPS, a tolerance. ! ! Output: ! ! real ( kind = rk ) APSER, the incomplete beta ratio. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) aj real ( kind = rk ) apser real ( kind = rk ) b real ( kind = rk ) bx real ( kind = rk ) c real ( kind = rk ) eps real ( kind = rk ), parameter :: g = 0.577215664901533D+00 real ( kind = rk ) j real ( kind = rk ) psi real ( kind = rk ) s real ( kind = rk ) t real ( kind = rk ) tol real ( kind = rk ) x bx = b * x t = x - bx if ( b * eps <= 0.02D+00 ) then c = log ( x ) + psi ( b ) + g + t else c = log ( bx ) + g + t end if tol = 5.0D+00 * eps * abs ( c ) j = 1.0D+00 s = 0.0D+00 do j = j + 1.0D+00 t = t * ( x - bx / j ) aj = t / j s = s + aj if ( abs ( aj ) <= tol ) then exit end if end do apser = -a * ( c + s ) return end function bcorr ( a0, b0 ) !*****************************************************************************80 ! !! BCORR evaluates DEL(A0) + DEL(B0) - DEL(A0 + B0). ! ! Discussion: ! ! The function DEL(A) is a remainder term that is used in the expression: ! ! ln ( Gamma ( A ) ) = ( A - 0.5 ) * ln ( A ) ! - A + 0.5 * ln ( 2 * PI ) + DEL ( A ), ! ! or, in other words, DEL ( A ) is defined as: ! ! DEL ( A ) = ln ( Gamma ( A ) ) - ( A - 0.5 ) * ln ( A ) ! + A + 0.5 * ln ( 2 * PI ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! real ( kind = rk ) A0, B0, the arguments. ! It is assumed that 8 <= A0 and 8 <= B0. ! ! Output: ! ! real ( kind = rk ) BCORR, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) a0 real ( kind = rk ) b real ( kind = rk ) b0 real ( kind = rk ) bcorr real ( kind = rk ) c real ( kind = rk ), parameter :: c0 = 0.833333333333333D-01 real ( kind = rk ), parameter :: c1 = -0.277777777760991D-02 real ( kind = rk ), parameter :: c2 = 0.793650666825390D-03 real ( kind = rk ), parameter :: c3 = -0.595202931351870D-03 real ( kind = rk ), parameter :: c4 = 0.837308034031215D-03 real ( kind = rk ), parameter :: c5 = -0.165322962780713D-02 real ( kind = rk ) h real ( kind = rk ) s11 real ( kind = rk ) s3 real ( kind = rk ) s5 real ( kind = rk ) s7 real ( kind = rk ) s9 real ( kind = rk ) t real ( kind = rk ) w real ( kind = rk ) x real ( kind = rk ) x2 a = min ( a0, b0 ) b = max ( a0, b0 ) h = a / b c = h / ( 1.0D+00 + h ) x = 1.0D+00 / ( 1.0D+00 + h ) x2 = x * x ! ! Set SN = (1 - X^N)/(1 - X) ! s3 = 1.0D+00 + ( x + x2 ) s5 = 1.0D+00 + ( x + x2 * s3 ) s7 = 1.0D+00 + ( x + x2 * s5 ) s9 = 1.0D+00 + ( x + x2 * s7 ) s11 = 1.0D+00 + ( x + x2 * s9 ) ! ! Set W = DEL(B) - DEL(A + B) ! t = ( 1.0D+00 / b )**2 w = (((( & c5 * s11 * t & + c4 * s9 ) * t & + c3 * s7 ) * t & + c2 * s5 ) * t & + c1 * s3 ) * t & + c0 w = w * ( c / b ) ! ! Compute DEL(A) + W. ! t = ( 1.0D+00 / a )**2 bcorr = ((((( & c5 * t & + c4 ) * t & + c3 ) * t & + c2 ) * t & + c1 ) * t & + c0 ) / a + w return end function beta ( a, b ) !*****************************************************************************80 ! !! BETA evaluates the beta function. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) A, B, the arguments of the beta function. ! ! Output: ! ! real ( kind = rk ) BETA, the value of the beta function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) beta real ( kind = rk ) beta_log beta = exp ( beta_log ( a, b ) ) return end function beta_asym ( a, b, lambda, eps ) !*****************************************************************************80 ! !! BETA_ASYM computes an asymptotic expansion for IX(A,B), for large A and B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! real ( kind = rk ) A, B, the parameters of the function. ! A and B should be nonnegative. It is assumed that both A and B ! are greater than or equal to 15. ! ! real ( kind = rk ) LAMBDA, the value of ( A + B ) * Y - B. ! It is assumed that 0 <= LAMBDA. ! ! real ( kind = rk ) EPS, the tolerance. ! ! Output: ! ! real ( kind = rk ) BETA_ASYM, the estimate for IX(A,B). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: num = 20 real ( kind = rk ) a real ( kind = rk ) a0(num+1) real ( kind = rk ) b real ( kind = rk ) b0(num+1) real ( kind = rk ) bcorr real ( kind = rk ) beta_asym real ( kind = rk ) bsum real ( kind = rk ) c(num+1) real ( kind = rk ) d(num+1) real ( kind = rk ) dsum real ( kind = rk ), parameter :: e0 = 1.12837916709551D+00 real ( kind = rk ), parameter :: e1 = 0.353553390593274D+00 real ( kind = rk ) eps real ( kind = rk ) error_fc real ( kind = rk ) f real ( kind = rk ) h real ( kind = rk ) h2 real ( kind = rk ) hn integer i integer j real ( kind = rk ) j0 real ( kind = rk ) j1 real ( kind = rk ) lambda integer m integer mm1 integer mmj integer n integer np1 real ( kind = rk ) r real ( kind = rk ) r0 real ( kind = rk ) r1 real ( kind = rk ) rlog1 real ( kind = rk ) s real ( kind = rk ) sum1 real ( kind = rk ) t real ( kind = rk ) t0 real ( kind = rk ) t1 real ( kind = rk ) u real ( kind = rk ) w real ( kind = rk ) w0 real ( kind = rk ) z real ( kind = rk ) z0 real ( kind = rk ) z2 real ( kind = rk ) zn real ( kind = rk ) znm1 beta_asym = 0.0D+00 if ( a < b ) then h = a / b r0 = 1.0D+00 / ( 1.0D+00 + h ) r1 = ( b - a ) / b w0 = 1.0D+00 / sqrt ( a * ( 1.0D+00 + h )) else h = b / a r0 = 1.0D+00 / ( 1.0D+00 + h ) r1 = ( b - a ) / a w0 = 1.0D+00 / sqrt ( b * ( 1.0D+00 + h )) end if f = a * rlog1 ( - lambda / a ) + b * rlog1 ( lambda / b ) t = exp ( - f ) if ( t == 0.0D+00 ) then return end if z0 = sqrt ( f ) z = 0.5D+00 * ( z0 / e1 ) z2 = f + f a0(1) = ( 2.0D+00 / 3.0D+00 ) * r1 c(1) = -0.5D+00 * a0(1) d(1) = -c(1) j0 = ( 0.5D+00 / e0 ) * error_fc ( 1, z0 ) j1 = e1 sum1 = j0 + d(1) * w0 * j1 s = 1.0D+00 h2 = h * h hn = 1.0D+00 w = w0 znm1 = z zn = z2 do n = 2, num, 2 hn = h2 * hn a0(n) = 2.0D+00 * r0 * ( 1.0D+00 + h * hn ) & / ( n + 2.0D+00 ) np1 = n + 1 s = s + hn a0(np1) = 2.0D+00 * r1 * s / ( n + 3.0D+00 ) do i = n, np1 r = -0.5D+00 * ( i + 1.0D+00 ) b0(1) = r * a0(1) do m = 2, i bsum = 0.0D+00 mm1 = m - 1 do j = 1, mm1 mmj = m - j bsum = bsum + ( j * r - mmj ) * a0(j) * b0(mmj) end do b0(m) = r * a0(m) + bsum / m end do c(i) = b0(i) / ( i + 1.0D+00 ) dsum = 0.0 do j = 1, i-1 dsum = dsum + d(i-j) * c(j) end do d(i) = - ( dsum + c(i) ) end do j0 = e1 * znm1 + ( n - 1.0D+00 ) * j0 j1 = e1 * zn + n * j1 znm1 = z2 * znm1 zn = z2 * zn w = w0 * w t0 = d(n) * w * j0 w = w0 * w t1 = d(np1) * w * j1 sum1 = sum1 + ( t0 + t1 ) if ( ( abs ( t0 ) + abs ( t1 )) <= eps * sum1 ) then u = exp ( - bcorr ( a, b ) ) beta_asym = e0 * t * u * sum1 return end if end do u = exp ( - bcorr ( a, b ) ) beta_asym = e0 * t * u * sum1 return end function beta_frac ( a, b, x, y, lambda, eps ) !*****************************************************************************80 ! !! BETA_FRAC evaluates a continued fraction expansion for IX(A,B). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! real ( kind = rk ) A, B, the parameters of the function. ! A and B should be nonnegative. It is assumed that both A and ! B are greater than 1. ! ! real ( kind = rk ) X, Y. X is the argument of the ! function, and should satisy 0 <= X <= 1. Y should equal 1 - X. ! ! real ( kind = rk ) LAMBDA, the value of ( A + B ) * Y - B. ! ! real ( kind = rk ) EPS, a tolerance. ! ! Output: ! ! real ( kind = rk ) BETA_FRAC, the value of the continued ! fraction approximation for IX(A,B). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) alpha real ( kind = rk ) an real ( kind = rk ) anp1 real ( kind = rk ) b real ( kind = rk ) beta real ( kind = rk ) beta_frac real ( kind = rk ) beta_rcomp real ( kind = rk ) bn real ( kind = rk ) bnp1 real ( kind = rk ) c real ( kind = rk ) c0 real ( kind = rk ) c1 real ( kind = rk ) e real ( kind = rk ) eps real ( kind = rk ) lambda real ( kind = rk ) n real ( kind = rk ) p real ( kind = rk ) r real ( kind = rk ) r0 real ( kind = rk ) s real ( kind = rk ) t real ( kind = rk ) w real ( kind = rk ) x real ( kind = rk ) y real ( kind = rk ) yp1 beta_frac = beta_rcomp ( a, b, x, y ) if ( beta_frac == 0.0D+00 ) then return end if c = 1.0D+00 + lambda c0 = b / a c1 = 1.0D+00 + 1.0D+00 / a yp1 = y + 1.0D+00 n = 0.0D+00 p = 1.0D+00 s = a + 1.0D+00 an = 0.0D+00 bn = 1.0D+00 anp1 = 1.0D+00 bnp1 = c / c1 r = c1 / c ! ! Continued fraction calculation. ! do n = n + 1.0D+00 t = n / a w = n * ( b - n ) * x e = a / s alpha = ( p * ( p + c0 ) * e * e ) * ( w * x ) e = ( 1.0D+00 + t ) / ( c1 + t + t ) beta = n + w / s + e * ( c + n * yp1 ) p = 1.0D+00 + t s = s + 2.0D+00 ! ! Update AN, BN, ANP1, and BNP1. ! t = alpha * an + beta * anp1 an = anp1 anp1 = t t = alpha * bn + beta * bnp1 bn = bnp1 bnp1 = t r0 = r r = anp1 / bnp1 if ( abs ( r - r0 ) <= eps * r ) then beta_frac = beta_frac * r exit end if ! ! Rescale AN, BN, ANP1, and BNP1. ! an = an / bnp1 bn = bn / bnp1 anp1 = r bnp1 = 1.0D+00 end do return end subroutine beta_grat ( a, b, x, y, w, eps, ierr ) !*****************************************************************************80 ! !! BETA_GRAT evaluates an asymptotic expansion for IX(A,B). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) A, B, the parameters of the function. ! A and B should be nonnegative. It is assumed that 15 <= A ! and B <= 1, and that B is less than A. ! ! Input, real ( kind = rk ) X, Y. X is the argument of the ! function, and should satisy 0 <= X <= 1. Y should equal 1 - X. ! ! Input/output, real ( kind = rk ) W, a quantity to which the ! result of the computation is to be added on output. ! ! Input, real ( kind = rk ) EPS, a tolerance. ! ! Output, integer IERR, an error flag, which is 0 if no error ! was detected. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) algdiv real ( kind = rk ) alnrel real ( kind = rk ) b real ( kind = rk ) bm1 real ( kind = rk ) bp2n real ( kind = rk ) c(30) real ( kind = rk ) cn real ( kind = rk ) coef real ( kind = rk ) d(30) real ( kind = rk ) dj real ( kind = rk ) eps real ( kind = rk ) gam1 integer i integer ierr real ( kind = rk ) j real ( kind = rk ) l real ( kind = rk ) lnx integer n real ( kind = rk ) n2 real ( kind = rk ) nu real ( kind = rk ) p real ( kind = rk ) q real ( kind = rk ) r real ( kind = rk ) s real ( kind = rk ) sum1 real ( kind = rk ) t real ( kind = rk ) t2 real ( kind = rk ) u real ( kind = rk ) v real ( kind = rk ) w real ( kind = rk ) x real ( kind = rk ) y real ( kind = rk ) z bm1 = ( b - 0.5D+00 ) - 0.5D+00 nu = a + 0.5D+00 * bm1 if ( y <= 0.375D+00 ) then lnx = alnrel ( - y ) else lnx = log ( x ) end if z = -nu * lnx if ( b * z == 0.0D+00 ) then ierr = 1 return end if ! ! Computation of the expansion. ! ! Set R = EXP(-Z)*Z^B/GAMMA(B) ! r = b * ( 1.0D+00 + gam1 ( b ) ) * exp ( b * log ( z )) r = r * exp ( a * lnx ) * exp ( 0.5D+00 * bm1 * lnx ) u = algdiv ( b, a ) + b * log ( nu ) u = r * exp ( - u ) if ( u == 0.0D+00 ) then ierr = 1 return end if call gamma_rat1 ( b, z, r, p, q, eps ) v = 0.25D+00 * ( 1.0D+00 / nu )**2 t2 = 0.25D+00 * lnx * lnx l = w / u j = q / r sum1 = j t = 1.0D+00 cn = 1.0D+00 n2 = 0.0D+00 do n = 1, 30 bp2n = b + n2 j = ( bp2n * ( bp2n + 1.0D+00 ) * j & + ( z + bp2n + 1.0D+00 ) * t ) * v n2 = n2 + 2.0D+00 t = t * t2 cn = cn / ( n2 * ( n2 + 1.0D+00 )) c(n) = cn s = 0.0D+00 coef = b - n do i = 1, n-1 s = s + coef * c(i) * d(n-i) coef = coef + b end do d(n) = bm1 * cn + s / n dj = d(n) * j sum1 = sum1 + dj if ( sum1 <= 0.0D+00 ) then ierr = 1 return end if if ( abs ( dj ) <= eps * ( sum1 + l ) ) then ierr = 0 w = w + u * sum1 return end if end do ierr = 0 w = w + u * sum1 return end subroutine beta_inc ( a, b, x, y, w, w1, ierr ) !*****************************************************************************80 ! !! BETA_INC evaluates the incomplete beta function IX(A,B). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! real ( kind = rk ) A, B, the parameters of the function. ! A and B should be nonnegative. ! ! real ( kind = rk ) X, Y. X is the argument of the ! function, and should satisy 0 <= X <= 1. Y should equal 1 - X. ! ! Output: ! ! real ( kind = rk ) W, W1, the values of IX(A,B) and 1-IX(A,B). ! ! integer IERR, the error flag. ! 0, no error was detected. ! 1, A or B is negative; ! 2, A = B = 0; ! 3, X < 0 or 1 < X; ! 4, Y < 0 or 1 < Y; ! 5, X + Y /= 1; ! 6, X = A = 0; ! 7, Y = B = 0. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) a0 real ( kind = rk ) apser real ( kind = rk ) b real ( kind = rk ) b0 real ( kind = rk ) beta_asym real ( kind = rk ) beta_frac real ( kind = rk ) beta_pser real ( kind = rk ) beta_up real ( kind = rk ) eps real ( kind = rk ) fpser integer ierr integer ierr1 integer ind real ( kind = rk ) lambda integer n real ( kind = rk ) t real ( kind = rk ) w real ( kind = rk ) w1 real ( kind = rk ) x real ( kind = rk ) x0 real ( kind = rk ) y real ( kind = rk ) y0 real ( kind = rk ) z eps = epsilon ( eps ) w = 0.0D+00 w1 = 0.0D+00 if ( a < 0.0D+00 .or. b < 0.0D+00 ) then ierr = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_INC - Fatal error!' write ( *, '(a,i8)' ) ' IERR = ', ierr return end if if ( a == 0.0D+00 .and. b == 0.0D+00 ) then ierr = 2 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_INC - Fatal error!' write ( *, '(a,i8)' ) ' IERR = ', ierr return end if if ( x < 0.0D+00 .or. 1.0D+00 < x ) then ierr = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_INC - Fatal error!' write ( *, '(a,i8)' ) ' IERR = ', ierr return end if if ( y < 0.0D+00 .or. 1.0D+00 < y ) then ierr = 4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_INC - Fatal error!' write ( *, '(a,i8)' ) ' IERR = ', ierr return end if z = ( ( x + y ) - 0.5D+00 ) - 0.5D+00 if ( 3.0D+00 * eps < abs ( z ) ) then ierr = 5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_INC - Fatal error!' write ( *, '(a,i8)' ) ' IERR = ', ierr return end if ierr = 0 if ( x == 0.0D+00 ) then w = 0.0D+00 w1 = 1.0D+00 if ( a == 0.0D+00 ) then ierr = 6 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_INC - Fatal error!' write ( *, '(a,i8)' ) ' IERR = ', ierr end if return end if if ( y == 0.0D+00 ) then if ( b == 0.0D+00 ) then ierr = 7 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BETA_INC - Fatal error!' write ( *, '(a,i8)' ) ' IERR = ', ierr return end if w = 1.0D+00 w1 = 0.0D+00 return end if if ( a == 0.0D+00 ) then w = 1.0D+00 w1 = 0.0D+00 return end if if ( b == 0.0D+00 ) then w = 0.0D+00 w1 = 1.0D+00 return end if eps = max ( eps, 1.0D-15 ) if ( max ( a, b ) < 0.001D+00 * eps ) then go to 260 end if ind = 0 a0 = a b0 = b x0 = x y0 = y if ( 1.0D+00 < min ( a0, b0 ) ) then go to 40 end if ! ! Procedure for A0 <= 1 or B0 <= 1 ! if ( 0.5D+00 < x ) then ind = 1 a0 = b b0 = a x0 = y y0 = x end if if ( b0 < min ( eps, eps * a0 ) ) then go to 90 end if if ( a0 < min ( eps, eps * b0 ) .and. b0 * x0 <= 1.0D+00 ) then go to 100 end if if ( 1.0D+00 < max ( a0, b0 ) ) then go to 20 end if if ( min ( 0.2D+00, b0 ) <= a0 ) then go to 110 end if if ( x0**a0 <= 0.9D+00 ) then go to 110 end if if ( 0.3D+00 <= x0 ) then go to 120 end if n = 20 go to 140 20 continue if ( b0 <= 1.0D+00 ) then go to 110 end if if ( 0.3D+00 <= x0 ) then go to 120 end if if ( 0.1D+00 <= x0 ) then go to 30 end if if ( ( x0 * b0 )**a0 <= 0.7D+00 ) then go to 110 end if 30 continue if ( 15.0D+00 < b0 ) then go to 150 end if n = 20 go to 140 ! ! PROCEDURE for 1 < A0 and 1 < B0. ! 40 continue if ( a <= b ) then lambda = a - ( a + b ) * x else lambda = ( a + b ) * y - b end if if ( lambda < 0.0D+00 ) then ind = 1 a0 = b b0 = a x0 = y y0 = x lambda = abs ( lambda ) end if !70 continue if ( b0 < 40.0D+00 .and. b0 * x0 <= 0.7D+00 ) then go to 110 end if if ( b0 < 40.0D+00 ) then go to 160 end if if ( b0 < a0 ) then go to 80 end if if ( a0 <= 100.0D+00 ) then go to 130 end if if ( 0.03D+00 * a0 < lambda ) then go to 130 end if go to 200 80 continue if ( b0 <= 100.0D+00 ) then go to 130 end if if ( 0.03D+00 * b0 < lambda ) then go to 130 end if go to 200 ! ! Evaluation of the appropriate algorithm. ! 90 continue w = fpser ( a0, b0, x0, eps ) w1 = 0.5D+00 + ( 0.5D+00 - w ) go to 250 100 continue w1 = apser ( a0, b0, x0, eps ) w = 0.5D+00 + ( 0.5D+00 - w1 ) go to 250 110 continue w = beta_pser ( a0, b0, x0, eps ) w1 = 0.5D+00 + ( 0.5D+00 - w ) go to 250 120 continue w1 = beta_pser ( b0, a0, y0, eps ) w = 0.5D+00 + ( 0.5D+00 - w1 ) go to 250 130 continue w = beta_frac ( a0, b0, x0, y0, lambda, 15.0D+00 * eps ) w1 = 0.5D+00 + ( 0.5D+00 - w ) go to 250 140 continue w1 = beta_up ( b0, a0, y0, x0, n, eps ) b0 = b0 + n 150 continue call beta_grat ( b0, a0, y0, x0, w1, 15.0D+00 * eps, ierr1 ) w = 0.5D+00 + ( 0.5D+00 - w1 ) go to 250 160 continue n = int ( b0 ) b0 = b0 - n if ( b0 == 0.0D+00 ) then n = n - 1 b0 = 1.0D+00 end if !170 continue w = beta_up ( b0, a0, y0, x0, n, eps ) if ( x0 <= 0.7D+00 ) then w = w + beta_pser ( a0, b0, x0, eps ) w1 = 0.5D+00 + ( 0.5D+00 - w ) go to 250 end if if ( a0 <= 15.0D+00 ) then n = 20 w = w + beta_up ( a0, b0, x0, y0, n, eps ) a0 = a0 + n end if !190 continue call beta_grat ( a0, b0, x0, y0, w, 15.0D+00 * eps, ierr1 ) w1 = 0.5D+00 + ( 0.5D+00 - w ) go to 250 200 continue w = beta_asym ( a0, b0, lambda, 100.0D+00 * eps ) w1 = 0.5D+00 + ( 0.5D+00 - w ) go to 250 ! ! Termination of the procedure. ! 250 continue if ( ind /= 0 ) then t = w w = w1 w1 = t end if return ! ! Procedure for A and B < 0.001 * EPS ! 260 continue w = b / ( a + b ) w1 = a / ( a + b ) return end subroutine beta_inc_values ( n_data, a, b, x, fx ) !*****************************************************************************80 ! !! 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.0 ! BETA_INC(A,B,1.0) = 1.0 ! ! Note that in Mathematica, the expressions: ! ! BETA[A,B] = Integral (0 to 1) T^(A-1) * (1-T)^(B-1) dT ! BETA[X,A,B] = Integral (0 to X) T^(A-1) * (1-T)^(B-1) dT ! ! and thus, to evaluate the incomplete Beta function requires: ! ! BETA_INC(A,B,X) = BETA[X,A,B] / BETA[A,B] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Karl Pearson, ! Tables of the Incomplete Beta Function, ! Cambridge University Press, 1968. ! ! 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 = rk ) A, B, X, the arguments of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 30 real ( kind = rk ) a real ( kind = rk ), 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 = rk ) b real ( kind = rk ), 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 = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.0637686D+00, 0.2048328D+00, 1.0000000D+00, 0.0D+00, & 0.0050126D+00, 0.0513167D+00, 0.2928932D+00, 0.5000000D+00, & 0.028D+00, 0.104D+00, 0.216D+00, 0.352D+00, & 0.500D+00, 0.648D+00, 0.784D+00, 0.896D+00, & 0.972D+00, 0.4361909D+00, 0.1516409D+00, 0.0897827D+00, & 1.0000000D+00, 0.5000000D+00, 0.4598773D+00, 0.2146816D+00, & 0.9507365D+00, 0.5000000D+00, 0.8979414D+00, 0.2241297D+00, & 0.7586405D+00, 0.7001783D+00 /) integer n_data real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 0.01D+00, 0.10D+00, 1.00D+00, 0.0D+00, & 0.01D+00, 0.10D+00, 0.50D+00, 0.50D+00, & 0.1D+00, 0.2D+00, 0.3D+00, 0.4D+00, & 0.5D+00, 0.6D+00, 0.7D+00, 0.8D+00, & 0.9D+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 function beta_log ( a0, b0 ) !*****************************************************************************80 ! !! BETA_LOG evaluates the logarithm of the beta function. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! real ( kind = rk ) A0, B0, the parameters of the function. ! A0 and B0 should be nonnegative. ! ! Output: ! ! real ( kind = rk ) BETA_LOG, the value of the logarithm ! of the Beta function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) a0 real ( kind = rk ) algdiv real ( kind = rk ) alnrel real ( kind = rk ) b real ( kind = rk ) b0 real ( kind = rk ) bcorr real ( kind = rk ) beta_log real ( kind = rk ) c real ( kind = rk ), parameter :: e = 0.918938533204673D+00 real ( kind = rk ) gamma_log real ( kind = rk ) gsumln real ( kind = rk ) h integer i integer n real ( kind = rk ) u real ( kind = rk ) v real ( kind = rk ) w real ( kind = rk ) z a = min ( a0, b0 ) b = max ( a0, b0 ) ! ! 8 < A. ! if ( 8.0D+00 <= a ) then w = bcorr ( a, b ) h = a / b c = h / ( 1.0D+00 + h ) u = - ( a - 0.5D+00 ) * log ( c ) v = b * alnrel ( h ) if ( v < u ) then beta_log = ((( -0.5D+00 * log ( b ) + e ) + w ) - v ) - u else beta_log = ((( -0.5D+00 * log ( b ) + e ) + w ) - u ) - v end if return end if ! ! Procedure when A < 1 ! if ( a < 1.0D+00 ) then if ( b < 8.0D+00 ) then beta_log = gamma_log ( a ) + ( gamma_log ( b ) - gamma_log ( a + b ) ) else beta_log = gamma_log ( a ) + algdiv ( a, b ) end if return end if ! ! Procedure when 1 <= A < 8 ! if ( 2.0D+00 < a ) then go to 40 end if if ( b <= 2.0D+00 ) then beta_log = gamma_log ( a ) + gamma_log ( b ) - gsumln ( a, b ) return end if w = 0.0D+00 if ( b < 8.0D+00 ) then go to 60 end if beta_log = gamma_log ( a ) + algdiv ( a, b ) return 40 continue ! ! Reduction of A when 1000 < B. ! if ( 1000.0D+00 < b ) then n = int ( a - 1.0D+00 ) w = 1.0D+00 do i = 1, n a = a - 1.0D+00 w = w * ( a / ( 1.0D+00 + a / b )) end do beta_log = ( log ( w ) - n * log ( b ) ) & + ( gamma_log ( a ) + algdiv ( a, b ) ) return end if n = int ( a - 1.0D+00 ) w = 1.0D+00 do i = 1, n a = a - 1.0D+00 h = a / b w = w * ( h / ( 1.0D+00 + h ) ) end do w = log ( w ) if ( 8.0D+00 <= b ) then beta_log = w + gamma_log ( a ) + algdiv ( a, b ) return end if ! ! Reduction of B when B < 8. ! 60 continue n = int ( b - 1.0D+00 ) z = 1.0D+00 do i = 1, n b = b - 1.0D+00 z = z * ( b / ( a + b )) end do beta_log = w + log ( z ) + ( gamma_log ( a ) + ( gamma_log ( b ) & - gsumln ( a, b ) ) ) return end function beta_pser ( a, b, x, eps ) !*****************************************************************************80 ! !! BETA_PSER uses a power series expansion to evaluate IX(A,B)(X). ! ! Discussion: ! ! BETA_PSER is used when B <= 1 or B*X <= 0.7. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! real ( kind = rk ) A, B, the parameters. ! ! real ( kind = rk ) X, the point where the function ! is to be evaluated. ! ! real ( kind = rk ) EPS, the tolerance. ! ! Output: ! ! real ( kind = rk ) BETA_PSER, the approximate value of IX(A,B)(X). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) a0 real ( kind = rk ) algdiv real ( kind = rk ) apb real ( kind = rk ) b real ( kind = rk ) b0 real ( kind = rk ) beta_log real ( kind = rk ) beta_pser real ( kind = rk ) c real ( kind = rk ) eps real ( kind = rk ) gam1 real ( kind = rk ) gamma_ln1 integer i integer m real ( kind = rk ) n real ( kind = rk ) sum1 real ( kind = rk ) t real ( kind = rk ) tol real ( kind = rk ) u real ( kind = rk ) w real ( kind = rk ) x real ( kind = rk ) z beta_pser = 0.0D+00 if ( x == 0.0D+00 ) then return end if ! ! Compute the factor X^A/(A*BETA(A,B)) ! a0 = min ( a, b ) if ( 1.0D+00 <= a0 ) then z = a * log ( x ) - beta_log ( a, b ) beta_pser = exp ( z ) / a else b0 = max ( a, b ) if ( b0 <= 1.0D+00 ) then beta_pser = x ** a if ( beta_pser == 0.0D+00 ) then return end if apb = a + b if ( apb <= 1.0D+00 ) then z = 1.0D+00 + gam1 ( apb ) else u = a + b - 1.0D+00 z = ( 1.0D+00 + gam1 ( u ) ) / apb end if c = ( 1.0D+00 + gam1 ( a ) ) & * ( 1.0D+00 + gam1 ( b ) ) / z beta_pser = beta_pser * c * ( b / apb ) else if ( b0 < 8.0D+00 ) then u = gamma_ln1 ( a0 ) m = int ( b0 - 1.0D+00 ) c = 1.0D+00 do i = 1, m b0 = b0 - 1.0D+00 c = c * ( b0 / ( a0 + b0 )) end do u = log ( c ) + u z = a * log ( x ) - u b0 = b0 - 1.0D+00 apb = a0 + b0 if ( apb <= 1.0D+00 ) then t = 1.0D+00 + gam1 ( apb ) else u = a0 + b0 - 1.0D+00 t = ( 1.0D+00 + gam1 ( u ) ) / apb end if beta_pser = exp ( z ) * ( a0 / a ) & * ( 1.0D+00 + gam1 ( b0 )) / t else if ( 8.0D+00 <= b0 ) then u = gamma_ln1 ( a0 ) + algdiv ( a0, b0 ) z = a * log ( x ) - u beta_pser = ( a0 / a ) * exp ( z ) end if end if if ( beta_pser == 0.0D+00 .or. a <= 0.1D+00 * eps ) then return end if ! ! Compute the series. ! sum1 = 0.0D+00 n = 0.0D+00 c = 1.0D+00 tol = eps / a do n = n + 1.0D+00 c = c * ( 0.5D+00 + ( 0.5D+00 - b / n ) ) * x w = c / ( a + n ) sum1 = sum1 + w if ( abs ( w ) <= tol ) then exit end if end do beta_pser = beta_pser * ( 1.0D+00 + a * sum1 ) return end function beta_rcomp ( a, b, x, y ) !*****************************************************************************80 ! !! BETA_RCOMP evaluates X^A * Y^B / Beta(A,B). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! real ( kind = rk ) A, B, the parameters of the Beta function. ! A and B should be nonnegative. ! ! real ( kind = rk ) X, Y, define the numerator of the fraction. ! ! Output: ! ! real ( kind = rk ) BETA_RCOMP, the value of X^A * Y^B / Beta(A,B). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) a0 real ( kind = rk ) algdiv real ( kind = rk ) alnrel real ( kind = rk ) apb real ( kind = rk ) b real ( kind = rk ) b0 real ( kind = rk ) bcorr real ( kind = rk ) beta_log real ( kind = rk ) beta_rcomp real ( kind = rk ) c real ( kind = rk ), parameter :: const = 0.398942280401433D+00 real ( kind = rk ) e real ( kind = rk ) gam1 real ( kind = rk ) gamma_ln1 real ( kind = rk ) h integer i real ( kind = rk ) lambda real ( kind = rk ) lnx real ( kind = rk ) lny integer n real ( kind = rk ) rlog1 real ( kind = rk ) t real ( kind = rk ) u real ( kind = rk ) v real ( kind = rk ) x real ( kind = rk ) x0 real ( kind = rk ) y real ( kind = rk ) y0 real ( kind = rk ) z beta_rcomp = 0.0D+00 if ( x == 0.0D+00 .or. y == 0.0D+00 ) then return end if a0 = min ( a, b ) if ( a0 < 8.0D+00 ) then if ( x <= 0.375D+00 ) then lnx = log ( x ) lny = alnrel ( - x ) else if ( y <= 0.375D+00 ) then lnx = alnrel ( - y ) lny = log ( y ) else lnx = log ( x ) lny = log ( y ) end if z = a * lnx + b * lny if ( 1.0D+00 <= a0 ) then z = z - beta_log ( a, b ) beta_rcomp = exp ( z ) return end if ! ! Procedure for A < 1 or B < 1 ! b0 = max ( a, b ) if ( b0 <= 1.0D+00 ) then beta_rcomp = exp ( z ) if ( beta_rcomp == 0.0D+00 ) then return end if apb = a + b if ( apb <= 1.0D+00 ) then z = 1.0D+00 + gam1 ( apb ) else u = a + b - 1.0D+00 z = ( 1.0D+00 + gam1 ( u ) ) / apb end if c = ( 1.0D+00 + gam1 ( a ) ) & * ( 1.0D+00 + gam1 ( b ) ) / z beta_rcomp = beta_rcomp * ( a0 * c ) & / ( 1.0D+00 + a0 / b0 ) else if ( b0 < 8.0D+00 ) then u = gamma_ln1 ( a0 ) n = int ( b0 - 1.0D+00 ) c = 1.0D+00 do i = 1, n b0 = b0 - 1.0D+00 c = c * ( b0 / ( a0 + b0 )) end do u = log ( c ) + u z = z - u b0 = b0 - 1.0D+00 apb = a0 + b0 if ( apb <= 1.0D+00 ) then t = 1.0D+00 + gam1 ( apb ) else u = a0 + b0 - 1.0D+00 t = ( 1.0D+00 + gam1 ( u ) ) / apb end if beta_rcomp = a0 * exp ( z ) * ( 1.0D+00 + gam1 ( b0 ) ) / t else if ( 8.0D+00 <= b0 ) then u = gamma_ln1 ( a0 ) + algdiv ( a0, b0 ) beta_rcomp = a0 * exp ( z - u ) end if else if ( a <= b ) then h = a / b x0 = h / ( 1.0D+00 + h ) y0 = 1.0D+00 / ( 1.0D+00 + h ) lambda = a - ( a + b ) * x else h = b / a x0 = 1.0D+00 / ( 1.0D+00 + h ) y0 = h / ( 1.0D+00 + h ) lambda = ( a + b ) * y - b end if e = -lambda / a if ( abs ( e ) <= 0.6D+00 ) then u = rlog1 ( e ) else u = e - log ( x / x0 ) end if e = lambda / b if ( abs ( e ) <= 0.6D+00 ) then v = rlog1 ( e ) else v = e - log ( y / y0 ) end if z = exp ( - ( a * u + b * v ) ) beta_rcomp = const * sqrt ( b * x0 ) * z * exp ( - bcorr ( a, b )) end if return end function beta_rcomp1 ( mu, a, b, x, y ) !*****************************************************************************80 ! !! BETA_RCOMP1 evaluates exp(MU) * X^A * Y^B / Beta(A,B). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! integer MU, ? ! ! real ( kind = rk ) A, B, the parameters of the Beta function. ! A and B should be nonnegative. ! ! real ( kind = rk ) X, Y, quantities whose powers form part of ! the expression. ! ! Output: ! ! real ( kind = rk ) BETA_RCOMP1, the value of ! exp(MU) * X^A * Y^B / Beta(A,B). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) a0 real ( kind = rk ) algdiv real ( kind = rk ) alnrel real ( kind = rk ) apb real ( kind = rk ) b real ( kind = rk ) b0 real ( kind = rk ) bcorr real ( kind = rk ) beta_log real ( kind = rk ) beta_rcomp1 real ( kind = rk ) c real ( kind = rk ), parameter :: const = 0.398942280401433D+00 real ( kind = rk ) e real ( kind = rk ) esum real ( kind = rk ) gam1 real ( kind = rk ) gamma_ln1 real ( kind = rk ) h integer i real ( kind = rk ) lambda real ( kind = rk ) lnx real ( kind = rk ) lny integer mu integer n real ( kind = rk ) rlog1 real ( kind = rk ) t real ( kind = rk ) u real ( kind = rk ) v real ( kind = rk ) x real ( kind = rk ) x0 real ( kind = rk ) y real ( kind = rk ) y0 real ( kind = rk ) z a0 = min ( a, b ) ! ! Procedure for 8 <= A and 8 <= B. ! if ( 8.0D+00 <= a0 ) then if ( a <= b ) then h = a / b x0 = h / ( 1.0D+00 + h ) y0 = 1.0D+00 / ( 1.0D+00 + h ) lambda = a - ( a + b ) * x else h = b / a x0 = 1.0D+00 / ( 1.0D+00 + h ) y0 = h / ( 1.0D+00 + h ) lambda = ( a + b ) * y - b end if e = -lambda / a if ( abs ( e ) <= 0.6D+00 ) then u = rlog1 ( e ) else u = e - log ( x / x0 ) end if e = lambda / b if ( abs ( e ) <= 0.6D+00 ) then v = rlog1 ( e ) else v = e - log ( y / y0 ) end if z = esum ( mu, - ( a * u + b * v )) beta_rcomp1 = const * sqrt ( b * x0 ) * z * exp ( - bcorr ( a, b ) ) ! ! Procedure for A < 8 or B < 8. ! else if ( x <= 0.375D+00 ) then lnx = log ( x ) lny = alnrel ( - x ) else if ( y <= 0.375D+00 ) then lnx = alnrel ( - y ) lny = log ( y ) else lnx = log ( x ) lny = log ( y ) end if z = a * lnx + b * lny if ( 1.0D+00 <= a0 ) then z = z - beta_log ( a, b ) beta_rcomp1 = esum ( mu, z ) return end if ! ! Procedure for A < 1 or B < 1. ! b0 = max ( a, b ) if ( 8.0D+00 <= b0 ) then u = gamma_ln1 ( a0 ) + algdiv ( a0, b0 ) beta_rcomp1 = a0 * esum ( mu, z-u ) return end if if ( 1.0D+00 < b0 ) then ! ! Algorithm for 1 < B0 < 8 ! u = gamma_ln1 ( a0 ) n = int ( b0 - 1.0D+00 ) c = 1.0D+00 do i = 1, n b0 = b0 - 1.0D+00 c = c * ( b0 / ( a0 + b0 ) ) end do u = log ( c ) + u z = z - u b0 = b0 - 1.0D+00 apb = a0 + b0 if ( apb <= 1.0D+00 ) then t = 1.0D+00 + gam1 ( apb ) else u = a0 + b0 - 1.0D+00 t = ( 1.0D+00 + gam1 ( u ) ) / apb end if beta_rcomp1 = a0 * esum ( mu, z ) & * ( 1.0D+00 + gam1 ( b0 ) ) / t ! ! Algorithm for B0 <= 1 ! else beta_rcomp1 = esum ( mu, z ) if ( beta_rcomp1 == 0.0D+00 ) then return end if apb = a + b if ( apb <= 1.0D+00 ) then z = 1.0D+00 + gam1 ( apb ) else u = real ( a, kind = rk ) + real ( b, kind = rk ) - 1.0D+00 z = ( 1.0D+00 + gam1 ( u )) / apb end if c = ( 1.0D+00 + gam1 ( a ) ) & * ( 1.0D+00 + gam1 ( b ) ) / z beta_rcomp1 = beta_rcomp1 * ( a0 * c ) / ( 1.0D+00 + a0 / b0 ) end if end if return end function beta_up ( a, b, x, y, n, eps ) !*****************************************************************************80 ! !! BETA_UP evaluates IX(A,B) - IX(A+N,B) where N is a positive integer. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! real ( kind = rk ) A, B, the parameters of the function. ! A and B should be nonnegative. ! ! real ( kind = rk ) X, Y, ? ! ! integer N, the increment to the first argument of IX. ! ! real ( kind = rk ) EPS, the tolerance. ! ! Output: ! ! real ( kind = rk ) BETA_UP, the value of IX(A,B) - IX(A+N,B). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) ap1 real ( kind = rk ) apb real ( kind = rk ) b real ( kind = rk ) beta_rcomp1 real ( kind = rk ) beta_up real ( kind = rk ) d real ( kind = rk ) eps real ( kind = rk ) exparg integer i integer k real ( kind = rk ) l integer mu integer n real ( kind = rk ) r real ( kind = rk ) t real ( kind = rk ) w real ( kind = rk ) x real ( kind = rk ) y ! ! Obtain the scaling factor EXP(-MU) AND ! EXP(MU) * ( X^A * Y^B / BETA(A,B) ) / A ! apb = a + b ap1 = a + 1.0D+00 mu = 0 d = 1.0D+00 if ( n /= 1 ) then if ( 1.0D+00 <= a ) then if ( 1.1D+00 * ap1 <= apb ) then mu = int ( abs ( exparg ( 1 ) ) ) k = int ( exparg ( 0 ) ) if ( k < mu ) then mu = k end if t = mu d = exp ( - t ) end if end if end if beta_up = beta_rcomp1 ( mu, a, b, x, y ) / a if ( n == 1 .or. beta_up == 0.0D+00 ) then return end if w = d ! ! Let K be the index of the maximum term. ! k = 0 if ( 1.0D+00 < b ) then if ( y <= 0.0001D+00 ) then k = n - 1 else r = ( b - 1.0D+00 ) * x / y - a if ( 1.0D+00 <= r ) then k = n - 1 t = n - 1 if ( r < t ) then k = int ( r ) end if end if end if ! ! Add the increasing terms of the series. ! do i = 1, k l = i - 1 d = ( ( apb + l ) / ( ap1 + l ) ) * x * d w = w + d end do end if ! ! Add the remaining terms of the series. ! do i = k+1, n-1 l = i - 1 d = ( ( apb + l ) / ( ap1 + l ) ) * x * d w = w + d if ( d <= eps * w ) then beta_up = beta_up * w return end if end do beta_up = beta_up * w return end subroutine binomial_cdf_values ( n_data, a, b, x, fx ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! 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, real ( kind = rk ) B, integer X, the ! arguments of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 = rk ) b real ( kind = rk ), 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 = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.9025D+00, 0.9975D+00, 1.0000D+00, 0.2500D+00, & 0.7500D+00, 0.3164D+00, 0.7383D+00, 0.9492D+00, & 0.9961D+00, 0.9999D+00, 0.9984D+00, 0.9901D+00, & 0.9672D+00, 0.9219D+00, 0.8497D+00, 0.6331D+00, & 0.3770D+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 cdfbet ( which, p, q, x, y, a, b, status, bound ) !*****************************************************************************80 ! !! CDFBET evaluates the CDF of the Beta Distribution. ! ! Discussion: ! ! This routine calculates any one parameter of the beta distribution ! given the others. ! ! The value P of the cumulative distribution function is calculated ! directly by code associated with the reference. ! ! Computation of the other parameters involves a seach for a value that ! produces the desired value of P. The search relies on the ! monotonicity of P with respect to the other parameters. ! ! The beta density is proportional to t^(A-1) * (1-t)^(B-1). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, integer WHICH, indicates which of the next four ! argument values is to be calculated from the others. ! 1: Calculate P and Q from X, Y, A and B; ! 2: Calculate X and Y from P, Q, A and B; ! 3: Calculate A from P, Q, X, Y and B; ! 4: Calculate B from P, Q, X, Y and A. ! ! Input/output, real ( kind = rk ) P, the integral from 0 to X of the ! chi-square distribution. Input range: [0, 1]. ! ! Input/output, real ( kind = rk ) Q, equals 1-P. Input range: [0, 1]. ! ! Input/output, real ( kind = rk ) X, the upper limit of integration ! of the beta density. If it is an input value, it should lie in ! the range [0,1]. If it is an output value, it will be searched for ! in the range [0,1]. ! ! Input/output, real ( kind = rk ) Y, equal to 1-X. If it is an input ! value, it should lie in the range [0,1]. If it is an output value, ! it will be searched for in the range [0,1]. ! ! Input/output, real ( kind = rk ) A, the first parameter of the beta ! density. If it is an input value, it should lie in the range ! (0, +infinity). If it is an output value, it will be searched ! for in the range [1D-300,1D300]. ! ! Input/output, real ( kind = rk ) B, the second parameter of the beta ! density. If it is an input value, it should lie in the range ! (0, +infinity). If it is an output value, it will be searched ! for in the range [1D-300,1D300]. ! ! Output, integer STATUS, reports the status of the computation. ! 0, if the calculation completed correctly; ! -I, if the input parameter number I is out of range; ! +1, if the answer appears to be lower than lowest search bound; ! +2, if the answer appears to be higher than greatest search bound; ! +3, if P + Q /= 1; ! +4, if X + Y /= 1. ! ! Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero. ! If STATUS is negative, then this is the value exceeded by parameter I. ! if STATUS is 1 or 2, this is the search bound that was exceeded. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ), parameter :: atol = 1.0D-10 real ( kind = rk ) b real ( kind = rk ) bound real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) fx real ( kind = rk ), parameter :: inf = 1.0D+300 real ( kind = rk ) p real ( kind = rk ) q logical qhi logical qleft integer status real ( kind = rk ), parameter :: tol = 1.0D-08 integer which real ( kind = rk ) x real ( kind = rk ) xhi real ( kind = rk ) xlo real ( kind = rk ) y status = 0 bound = 0.0D+00 if ( which < 1 ) then bound = 1.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if if ( 4 < which ) then bound = 4.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if ! ! Unless P is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( p < 0.0D+00 ) then bound = 0.0D+00 status = -2 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return else if ( 1.0D+00 < p ) then bound = 1.0D+00 status = -2 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return end if end if ! ! Unless Q is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( q < 0.0D+00 ) then bound = 0.0D+00 status = -3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return else if ( 1.0D+00 < q ) then bound = 1.0D+00 status = -3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return end if end if ! ! Unless X is to be computed, make sure it is legal. ! if ( which /= 2 ) then if ( x < 0.0D+00 ) then bound = 0.0D+00 status = -4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter X is out of range.' return else if ( 1.0D+00 < x ) then bound = 1.0D+00 status = -4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter X is out of range.' return end if end if ! ! Unless Y is to be computed, make sure it is legal. ! if ( which /= 2 ) then if ( y < 0.0D+00 ) then bound = 0.0D+00 status = -5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter Y is out of range.' return else if ( 1.0D+00 < y ) then bound = 1.0D+00 status = -5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter Y is out of range.' return end if end if ! ! Unless A is to be computed, make sure it is legal. ! if ( which /= 3 ) then if ( a <= 0.0D+00 ) then bound = 0.0D+00 status = -6 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter A is out of range.' return end if end if ! ! Unless B is to be computed, make sure it is legal. ! if ( which /= 4 ) then if ( b <= 0.0D+00 ) then bound = 0.0D+00 status = -7 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter B is out of range.' return end if end if ! ! Check that P + Q = 1. ! if ( which /= 1 ) then if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then status = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' P + Q /= 1.' return end if end if ! ! Check that X + Y = 1. ! if ( which /= 2 ) then if ( 3.0D+00 * epsilon ( x ) < abs ( ( x + y ) - 1.0D+00 ) ) then status = 4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' X + Y /= 1.' return end if end if ! ! Compute P and Q. ! if ( which == 1 ) then call cumbet ( x, y, a, b, p, q ) status = 0 ! ! Compute X and Y. ! else if ( which == 2 ) then call dstzr ( 0.0D+00, 1.0D+00, atol, tol ) if ( p <= q ) then status = 0 fx = 0.0D+00 call dzror ( status, x, fx, xlo, xhi, qleft, qhi ) y = 1.0D+00 - x do while ( status == 1 ) call cumbet ( x, y, a, b, cum, ccum ) fx = cum - p call dzror ( status, x, fx, xlo, xhi, qleft, qhi ) y = 1.0D+00 - x end do else status = 0 fx = 0.0D+00 call dzror ( status, y, fx, xlo, xhi, qleft, qhi ) x = 1.0D+00 - y do while ( status == 1 ) call cumbet ( x, y, a, b, cum, ccum ) fx = ccum - q call dzror ( status, y, fx, xlo, xhi, qleft, qhi ) x = 1.0D+00 - y end do end if if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Compute A. ! else if ( which == 3 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 a = 5.0D+00 fx = 0.0D+00 call dinvr ( status, a, fx, qleft, qhi ) do while ( status == 1 ) call cumbet ( x, y, a, b, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, a, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Compute B. ! else if ( which == 4 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 b = 5.0D+00 fx = 0.0D+00 call dinvr ( status, b, fx, qleft, qhi ) do while ( status == 1 ) call cumbet ( x, y, a, b, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, b, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if end if return end subroutine cdfbin ( which, p, q, s, xn, pr, ompr, status, bound ) !*****************************************************************************80 ! !! CDFBIN evaluates the CDF of the Binomial distribution. ! ! Discussion: ! ! This routine calculates any one parameter of the binomial distribution ! given the others. ! ! The value P of the cumulative distribution function is calculated ! directly. ! ! Computation of the other parameters involves a seach for a value that ! produces the desired value of P. The search relies on the ! monotonicity of P with respect to the other parameters. ! ! P is the probablility of S or fewer successes in XN binomial trials, ! each trial having an individual probability of success of PR. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.5.24. ! ! Parameters: ! ! Input, integer WHICH, indicates which of argument values is to ! be calculated from the others. ! 1: Calculate P and Q from S, XN, PR and OMPR; ! 2: Calculate S from P, Q, XN, PR and OMPR; ! 3: Calculate XN from P, Q, S, PR and OMPR; ! 4: Calculate PR and OMPR from P, Q, S and XN. ! ! Input/output, real ( kind = rk ) P, the cumulation, from 0 to S, ! of the binomial distribution. If P is an input value, it should ! lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) Q, equal to 1-P. If Q is an input ! value, it should lie in the range [0,1]. If Q is an output value, ! it will lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) S, the number of successes observed. ! Whether this is an input or output value, it should lie in the ! range [0,XN]. ! ! Input/output, real ( kind = rk ) XN, the number of binomial trials. ! If this is an input value it should lie in the range: (0, +infinity). ! If it is an output value it will be searched for in the ! range [1.0D-300, 1.0D+300]. ! ! Input/output, real ( kind = rk ) PR, the probability of success in each ! binomial trial. Whether this is an input or output value, it should ! lie in the range: [0,1]. ! ! Input/output, real ( kind = rk ) OMPR, equal to 1-PR. Whether this is an ! input or output value, it should lie in the range [0,1]. Also, it should ! be the case that PR + OMPR = 1. ! ! Output, integer STATUS, reports the status of the computation. ! 0, if the calculation completed correctly; ! -I, if the input parameter number I is out of range; ! +1, if the answer appears to be lower than lowest search bound; ! +2, if the answer appears to be higher than greatest search bound; ! +3, if P + Q /= 1; ! +4, if PR + OMPR /= 1. ! ! Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero. ! If STATUS is negative, then this is the value exceeded by parameter I. ! if STATUS is 1 or 2, this is the search bound that was exceeded. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: atol = 1.0D-10 real ( kind = rk ) bound real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) fx real ( kind = rk ), parameter :: inf = 1.0D+300 real ( kind = rk ) ompr real ( kind = rk ) p real ( kind = rk ) pr real ( kind = rk ) q logical qhi logical qleft real ( kind = rk ) s integer status real ( kind = rk ), parameter :: tol = 1.0D-08 integer which real ( kind = rk ) xhi real ( kind = rk ) xlo real ( kind = rk ) xn status = 0 bound = 0.0D+00 ! ! Check the arguments. ! if ( which < 1 ) then bound = 1.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if if ( 4 < which ) then bound = 4.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if ! ! Unless P is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( p < 0.0D+00 ) then status = -2 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return else if ( 1.0D+00 < p ) then status = -2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return end if end if ! ! Unless Q is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( q < 0.0D+00 ) then status = -3 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return else if ( 1.0D+00 < q ) then status = -3 bound = 1.0 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return end if end if ! ! Unless XN is to be computed, make sure it is legal. ! if ( which /= 3 ) then if ( xn <= 0.0D+00 ) then bound = 0.0D+00 status = -5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter XN is out of range.' return end if end if ! ! Unless S is to be computed, make sure it is legal. ! if ( which /= 2 ) then if ( s < 0.0D+00 ) then bound = 0.0D+00 status = -4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter S is out of range.' return else if ( which /= 3 .and. xn < s ) then bound = xn status = -4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter S is out of range.' return end if end if ! ! Unless PR is to be computed, make sure it is legal. ! if ( which /= 4 ) then if ( pr < 0.0D+00 ) then bound = 0.0D+00 status = -6 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter PR is out of range.' return else if ( 1.0D+00 < pr ) then bound = 1.0D+00 status = -6 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter PR is out of range.' return end if end if ! ! Unless OMPR is to be computed, make sure it is legal. ! if ( which /= 4 ) then if ( ompr < 0.0D+00 ) then bound = 0.0D+00 status = -7 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter OMPR is out of range.' return else if ( 1.0D+00 < ompr ) then bound = 1.0D+00 status = -7 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' Input parameter OMPR is out of range.' return end if end if ! ! Check that P + Q = 1. ! if ( which /= 1 ) then if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then status = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' P + Q /= 1.' return end if end if ! ! Check that PR + OMPR = 1. ! if ( which /= 4 ) then if ( 3.0D+00 * epsilon ( 1.0D+00 ) & < abs ( ( pr + ompr ) - 1.0D+00 ) ) then status = 4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBET - Fatal error!' write ( *, '(a)' ) ' PR + OMPR /= 1.' return end if end if ! ! Calculate P and Q. ! if ( which == 1 ) then call cumbin ( s, xn, pr, ompr, p, q ) status = 0 ! ! Calculate S. ! else if ( which == 2 ) then call dstinv ( 0.0D+00, xn, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 s = 5.0D+00 fx = 0.0D+00 call dinvr ( status, s, fx, qleft, qhi ) do while ( status == 1 ) call cumbin ( s, xn, pr, ompr, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, s, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBIN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = xn write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBIN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate XN. ! else if ( which == 3 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 xn = 5.0D+00 fx = 0.0D+00 call dinvr ( status, xn, fx, qleft, qhi ) do while ( status == 1 ) call cumbin ( s, xn, pr, ompr, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, xn, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBIN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound return else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBIN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound return end if end if ! ! Calculate PR and OMPR. ! else if ( which == 4 ) then call dstzr ( 0.0D+00, 1.0D+00, atol, tol ) if ( p <= q ) then status = 0 call dzror ( status, pr, fx, xlo, xhi, qleft, qhi ) ompr = 1.0D+00 - pr do while ( status == 1 ) call cumbin ( s, xn, pr, ompr, cum, ccum ) fx = cum - p call dzror ( status, pr, fx, xlo, xhi, qleft, qhi ) ompr = 1.0D+00 - pr end do else status = 0 call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi ) pr = 1.0D+00 - ompr do while ( status == 1 ) call cumbin ( s, xn, pr, ompr, cum, ccum ) fx = ccum - q call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi ) pr = 1.0D+00 - ompr end do end if if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBIN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFBIN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if end if return end subroutine cdfchi ( which, p, q, x, df, status, bound ) !*****************************************************************************80 ! !! CDFCHI evaluates the CDF of the chi square distribution. ! ! Discussion: ! ! This routine calculates any one parameter of the chi square distribution ! given the others. ! ! The value P of the cumulative distribution function is calculated ! directly. ! ! Computation of the other parameters involves a seach for a value that ! produces the desired value of P. The search relies on the ! monotonicity of P with respect to the other parameters. ! ! The CDF of the chi square distribution can be evaluated ! within Mathematica by commands such as: ! ! Needs["Statistics`ContinuousDistributions`"] ! CDF [ ChiSquareDistribution [ DF ], X ] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.4.19. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input, integer WHICH, indicates which argument is to be ! calculated from the others. ! 1: Calculate P and Q from X and DF; ! 2: Calculate X from P, Q and DF; ! 3: Calculate DF from P, Q and X. ! ! Input/output, real ( kind = rk ) P, the integral from 0 to X of ! the chi-square distribution. If this is an input value, it should ! lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) Q, equal to 1-P. If Q is an input ! value, it should lie in the range [0,1]. If Q is an output value, ! it will lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) X, the upper limit of integration ! of the chi-square distribution. If this is an input ! value, it should lie in the range: [0, +infinity). If it is an output ! value, it will be searched for in the range: [0,1.0D+300]. ! ! Input/output, real ( kind = rk ) DF, the degrees of freedom of the ! chi-square distribution. If this is an input value, it should lie ! in the range: (0, +infinity). If it is an output value, it will be ! searched for in the range: [ 1.0D-300, 1.0D+300]. ! ! Output, integer STATUS, reports the status of the computation. ! 0, if the calculation completed correctly; ! -I, if the input parameter number I is out of range; ! +1, if the answer appears to be lower than lowest search bound; ! +2, if the answer appears to be higher than greatest search bound; ! +3, if P + Q /= 1; ! +10, an error was returned from CUMGAM. ! ! Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero. ! If STATUS is negative, then this is the value exceeded by parameter I. ! if STATUS is 1 or 2, this is the search bound that was exceeded. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: atol = 1.0D-10 real ( kind = rk ) bound real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) df real ( kind = rk ) fx real ( kind = rk ), parameter :: inf = 1.0D+300 real ( kind = rk ) p real ( kind = rk ) porq real ( kind = rk ) q logical qhi logical qleft integer status real ( kind = rk ), parameter :: tol = 1.0D-08 integer which real ( kind = rk ) x status = 0 bound = 0.0D+00 ! ! Check the arguments. ! if ( which < 1 ) then bound = 1.0 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 3.' return end if if ( 3 < which ) then bound = 3.0 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 3.' return end if ! ! Unless P is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( p < 0.0D+00 ) then status = -2 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return else if ( 1.0D+00 < p ) then status = -2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return end if end if ! ! Unless Q is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( q < 0.0D+00 ) then status = -3 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return else if ( 1.0D+00 < q ) then status = -3 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return end if end if ! ! Unless X is to be computed, make sure it is legal. ! if ( which /= 2 ) then if ( x < 0.0D+00 ) then bound = 0.0D+00 status = -4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Fatal error!' write ( *, '(a)' ) ' Input parameter X is out of range.' return end if end if ! ! Unless DF is to be computed, make sure it is legal. ! if ( which /= 3 ) then if ( df <= 0.0D+00 ) then bound = 0.0D+00 status = -5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Fatal error!' write ( *, '(a)' ) ' Input parameter DF is out of range.' return end if end if ! ! Check that P + Q = 1. ! if ( which /= 1 ) then if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then status = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Fatal error!' write ( *, '(a)' ) ' P + Q /= 1.' return end if end if ! ! Select the minimum of P and Q. ! if ( which /= 1 ) then porq = min ( p, q ) end if ! ! Calculate P and Q. ! if ( which == 1 ) then status = 0 call cumchi ( x, df, p, q ) if ( 1.5D+00 < porq ) then status = 10 return end if ! ! Calculate X. ! else if ( which == 2 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 x = 5.0D+00 fx = 0.0D+00 call dinvr ( status, x, fx, qleft, qhi ) do while ( status == 1 ) call cumchi ( x, df, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if if ( 1.5D+00 < fx + porq ) then status = 10 return end if call dinvr ( status, x, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate DF. ! else if ( which == 3 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 df = 5.0D+00 fx = 0.0D+00 call dinvr ( status, df, fx, qleft, qhi ) do while ( status == 1 ) call cumchi ( x, df, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if if ( 1.5D+00 < fx + porq ) then status = 10 return end if call dinvr ( status, df, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHI - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if end if return end subroutine cdfchn ( which, p, q, x, df, pnonc, status, bound ) !*****************************************************************************80 ! !! CDFCHN evaluates the CDF of the Noncentral Chi-Square. ! ! Discussion: ! ! This routine calculates any one parameter of the noncentral chi-square ! distribution given values for the others. ! ! The value P of the cumulative distribution function is calculated ! directly. ! ! Computation of the other parameters involves a seach for a value that ! produces the desired value of P. The search relies on the ! monotonicity of P with respect to the other parameters. ! ! The computation time required for this routine is proportional ! to the noncentrality parameter (PNONC). Very large values of ! this parameter can consume immense computer resources. This is ! why the search range is bounded by 10,000. ! ! The CDF of the noncentral chi square distribution can be evaluated ! within Mathematica by commands such as: ! ! Needs["Statistics`ContinuousDistributions`"] ! CDF[ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.5.25. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input, integer WHICH, indicates which argument is to be ! calculated from the others. ! 1: Calculate P and Q from X, DF and PNONC; ! 2: Calculate X from P, DF and PNONC; ! 3: Calculate DF from P, X and PNONC; ! 4: Calculate PNONC from P, X and DF. ! ! Input/output, real ( kind = rk ) P, the integral from 0 to X of ! the noncentral chi-square distribution. If this is an input ! value, it should lie in the range: [0, 1.0-1.0D-16). ! ! Input/output, real ( kind = rk ) Q, is generally not used by this ! subroutine and is only included for similarity with other routines. ! However, if P is to be computed, then a value will also be computed ! for Q. ! ! Input, real ( kind = rk ) X, the upper limit of integration of the ! noncentral chi-square distribution. If this is an input value, it ! should lie in the range: [0, +infinity). If it is an output value, ! it will be sought in the range: [0,1.0D+300]. ! ! Input/output, real ( kind = rk ) DF, the number of degrees of freedom ! of the noncentral chi-square distribution. If this is an input value, ! it should lie in the range: (0, +infinity). If it is an output value, ! it will be searched for in the range: [ 1.0D-300, 1.0D+300]. ! ! Input/output, real ( kind = rk ) PNONC, the noncentrality parameter of ! the noncentral chi-square distribution. If this is an input value, it ! should lie in the range: [0, +infinity). If it is an output value, ! it will be searched for in the range: [0,1.0D+4] ! ! Output, integer STATUS, reports on the calculation. ! 0, if calculation completed correctly; ! -I, if input parameter number I is out of range; ! 1, if the answer appears to be lower than the lowest search bound; ! 2, if the answer appears to be higher than the greatest search bound. ! ! Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero. ! If STATUS is negative, then this is the value exceeded by parameter I. ! if STATUS is 1 or 2, this is the search bound that was exceeded. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: atol=1.0D-50 real ( kind = rk ) bound real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) df real ( kind = rk ) fx real ( kind = rk ), parameter :: inf=1.0D+300 real ( kind = rk ) p real ( kind = rk ) pnonc real ( kind = rk ) q logical qhi logical qleft integer status real ( kind = rk ), parameter :: tent4=1.0D+04 real ( kind = rk ), parameter :: tol=1.0D-08 integer which real ( kind = rk ) x status = 0 bound = 0.0D+00 ! ! Check the arguments. ! if ( which < 1 ) then bound = 1.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if if ( 4 < which ) then bound = 4.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if ! ! Unless P is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( p < 0.0D+00 ) then status = -2 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return else if ( 1.0D+00 < p ) then status = -2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return end if end if ! ! Unless X is to be computed, make sure it is legal. ! if ( which /= 2 ) then if ( x < 0.0D+00 ) then bound = 0.0D+00 status = -4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Fatal error!' write ( *, '(a)' ) ' Input parameter X is out of range.' return end if end if ! ! Unless DF is to be computed, make sure it is legal. ! if ( which /= 3 ) then if ( df <= 0.0D+00 ) then bound = 0.0D+00 status = -5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Fatal error!' write ( *, '(a)' ) ' Input parameter DF is out of range.' return end if end if ! ! Unless PNONC is to be computed, make sure it is legal. ! if ( which /= 4 ) then if ( pnonc < 0.0D+00 ) then bound = 0.0D+00 status = -6 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Fatal error!' write ( *, '(a)' ) ' Input parameter PNONC is out of range.' return end if end if ! ! Calculate P and Q. ! if ( which == 1 ) then call cumchn ( x, df, pnonc, p, q ) status = 0 ! ! Calculate X. ! else if ( which == 2 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 x = 5.0D+00 fx = 0.0D+00 call dinvr ( status, x, fx, qleft, qhi ) do while ( status == 1 ) call cumchn ( x, df, pnonc, cum, ccum ) fx = cum - p call dinvr ( status, x, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate DF. ! else if ( which == 3 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 df = 5.0D+00 fx = 0.0D+00 call dinvr ( status, df, fx, qleft, qhi ) do while ( status == 1 ) call cumchn ( x, df, pnonc, cum, ccum ) fx = cum - p call dinvr ( status, df, fx, qleft, qhi ) end do if ( status == -1 )then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate PNONC. ! else if ( which == 4 ) then call dstinv ( 0.0D+00, tent4, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 pnonc = 5.0D+00 fx = 0.0D+00 call dinvr ( status, pnonc, fx, qleft, qhi ) do while ( status == 1 ) call cumchn ( x, df, pnonc, cum, ccum ) fx = cum - p call dinvr ( status, pnonc, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = tent4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFCHN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if end if return end subroutine cdff ( which, p, q, f, dfn, dfd, status, bound ) !*****************************************************************************80 ! !! CDFF evaluates the CDF of the F distribution. ! ! Discussion: ! ! This routine calculates any one parameter of the F distribution ! given the others. ! ! The value P of the cumulative distribution function is calculated ! directly. ! ! Computation of the other parameters involves a seach for a value that ! produces the desired value of P. The search relies on the ! monotonicity of P with respect to the other parameters. ! ! The value of the cumulative F distribution is not necessarily ! monotone in either degrees of freedom. There thus may be two ! values that provide a given CDF value. This routine assumes ! monotonicity and will find an arbitrary one of the two values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.6.2. ! ! Parameters: ! ! Input, integer WHICH, indicates which argument is to be ! calculated from the others. ! 1: Calculate P and Q from F, DFN and DFD; ! 2: Calculate F from P, Q, DFN and DFD; ! 3: Calculate DFN from P, Q, F and DFD; ! 4: Calculate DFD from P, Q, F and DFN. ! ! Input/output, real ( kind = rk ) P, the integral from 0 to F of ! the F-density. If it is an input value, it should lie in the ! range [0,1]. ! ! Input/output, real ( kind = rk ) Q, equal to 1-P. If Q is an input ! value, it should lie in the range [0,1]. If Q is an output value, ! it will lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) F, the upper limit of integration ! of the F-density. If this is an input value, it should lie in the ! range [0, +infinity). If it is an output value, it will be searched ! for in the range [0,1.0D+300]. ! ! Input/output, real ( kind = rk ) DFN, the number of degrees of ! freedom of the numerator sum of squares. If this is an input value, ! it should lie in the range: (0, +infinity). If it is an output value, ! it will be searched for in the range: [ 1.0D-300, 1.0D+300]. ! ! Input/output, real ( kind = rk ) DFD, the number of degrees of freedom ! of the denominator sum of squares. If this is an input value, it should ! lie in the range: (0, +infinity). If it is an output value, it will ! be searched for in the range: [ 1.0D-300, 1.0D+300]. ! ! Output, integer STATUS, reports the status of the computation. ! 0, if the calculation completed correctly; ! -I, if the input parameter number I is out of range; ! +1, if the answer appears to be lower than lowest search bound; ! +2, if the answer appears to be higher than greatest search bound; ! +3, if P + Q /= 1. ! ! Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero. ! If STATUS is negative, then this is the value exceeded by parameter I. ! if STATUS is 1 or 2, this is the search bound that was exceeded. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: atol = 1.0D-10 real ( kind = rk ) bound real ( kind = rk ) bound_hi real ( kind = rk ) bound_lo real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) dfd real ( kind = rk ) dfn real ( kind = rk ) f real ( kind = rk ) fx real ( kind = rk ), parameter :: inf = 1.0D+300 real ( kind = rk ) p real ( kind = rk ) q logical qhi logical qleft integer status real ( kind = rk ), parameter :: tol = 1.0D-08 integer which status = 0 bound = 0.0D+00 ! ! Check the arguments. ! if ( which < 1 ) then bound = 1.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if if ( 4 < which ) then bound = 4.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if ! ! Unless P is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( p < 0.0D+00 ) then status = -2 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return else if ( 1.0D+00 < p ) then status = -2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return end if end if ! ! Unless Q is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( q < 0.0D+00 ) then status = -3 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return else if ( 1.0D+00 < q ) then status = -3 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return end if end if ! ! Unless F is to be computed, make sure it is legal. ! if ( which /= 2 ) then if ( f < 0.0D+00 ) then bound = 0.0D+00 status = -4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Fatal error!' write ( *, '(a)' ) ' Input parameter F is out of range.' return end if end if ! ! Unless DFN is to be computed, make sure it is legal. ! if ( which /= 3 ) then if ( dfn <= 0.0D+00 ) then bound = 0.0D+00 status = -5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Fatal error!' write ( *, '(a)' ) ' Input parameter DFN is out of range.' return end if end if ! ! Unless DFD is to be computed, make sure it is legal. ! if ( which /= 4 ) then if ( dfd <= 0.0D+00 ) then bound = 0.0D+00 status = -6 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Fatal error!' write ( *, '(a)' ) ' Input parameter DFD is out of range.' return end if end if ! ! Check that P + Q = 1. ! if ( which /= 1 ) then if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then status = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Fatal error!' write ( *, '(a)' ) ' P + Q /= 1.' return end if end if ! ! Calculate P and Q. ! if ( which == 1 ) then call cumf ( f, dfn, dfd, p, q ) status = 0 ! ! Calculate F. ! else if ( which == 2 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 f = 5.0D+00 fx = 0.0D+00 call dinvr ( status, f, fx, qleft, qhi ) do while ( status == 1 ) call cumf ( f, dfn, dfd, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, f, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate DFN. ! ! Note that, in the original calculation, the lower bound for DFN was 0. ! Using DFN = 0 causes an error in CUMF when it calls BETA_INC. ! The lower bound was set to the more reasonable value of 1. ! JVB, 14 April 2007. ! else if ( which == 3 ) then bound_lo = 1.0D+00 bound_hi = inf call dstinv ( bound_lo, bound_hi, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 dfn = 5.0D+00 fx = 0.0D+00 call dinvr ( status, dfn, fx, qleft, qhi ) do while ( status == 1 ) call cumf ( f, dfn, dfd, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, dfn, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = bound_lo write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound_lo return else status = 2 bound = bound_hi write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound_hi return end if end if ! ! Calculate DFD. ! ! Note that, in the original calculation, the lower bound for DFD was 0. ! Using DFD = 0 causes an error in CUMF when it calls BETA_INC. ! The lower bound was set to the more reasonable value of 1. ! JVB, 14 April 2007. ! else if ( which == 4 ) then bound_lo = 1.0D+00 bound_hi = inf call dstinv ( bound_lo, bound_hi, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 dfd = 5.0D+00 fx = 0.0D+00 call dinvr ( status, dfd, fx, qleft, qhi ) do while ( status == 1 ) call cumf ( f, dfn, dfd, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, dfd, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = bound_lo write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound_lo else status = 2 bound = bound_hi write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFF - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound_hi end if end if end if return end subroutine cdffnc ( which, p, q, f, dfn, dfd, pnonc, status, bound ) !*****************************************************************************80 ! !! CDFFNC evaluates the CDF of the Noncentral F distribution. ! ! Discussion: ! ! This routine originally used 1.0D+300 as the upper bound for the ! interval in which many of the missing parameters are to be sought. ! Since the underlying rootfinder routine needs to evaluate the ! function at this point, it is no surprise that the program was ! experiencing overflows. A less extravagant upper bound ! is being tried for now! ! ! This routine calculates any one parameter of the Noncentral F distribution ! given the others. ! ! The value P of the cumulative distribution function is calculated ! directly. ! ! Computation of the other parameters involves a seach for a value that ! produces the desired value of P. The search relies on the ! monotonicity of P with respect to the other parameters. ! ! The computation time required for this routine is proportional ! to the noncentrality parameter PNONC. Very large values of ! this parameter can consume immense computer resources. This is ! why the search range is bounded by 10,000. ! ! The value of the cumulative noncentral F distribution is not ! necessarily monotone in either degree of freedom. There thus ! may be two values that provide a given CDF value. This routine ! assumes monotonicity and will find an arbitrary one of the two ! values. ! ! The CDF of the noncentral F distribution can be evaluated ! within Mathematica by commands such as: ! ! Needs["Statistics`ContinuousDistributions`"] ! CDF [ NoncentralFRatioDistribution [ DFN, DFD, PNONC ], X ] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.6.20. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input, integer WHICH, indicates which argument is to be ! calculated from the others. ! 1: Calculate P and Q from F, DFN, DFD and PNONC; ! 2: Calculate F from P, Q, DFN, DFD and PNONC; ! 3: Calculate DFN from P, Q, F, DFD and PNONC; ! 4: Calculate DFD from P, Q, F, DFN and PNONC; ! 5: Calculate PNONC from P, Q, F, DFN and DFD. ! ! Input/output, real ( kind = rk ) P, the integral from 0 to F of ! the noncentral F-density. If P is an input value it should ! lie in the range [0,1) (Not including 1!). ! ! Dummy, real ( kind = rk ) Q, is not used by this subroutine, ! and is only included for similarity with the other routines. ! Its input value is not checked. If P is to be computed, the ! Q is set to 1 - P. ! ! Input/output, real ( kind = rk ) F, the upper limit of integration ! of the noncentral F-density. If this is an input value, it should ! lie in the range: [0, +infinity). If it is an output value, it ! will be searched for in the range: [0,1.0D+30]. ! ! Input/output, real ( kind = rk ) DFN, the number of degrees of freedom ! of the numerator sum of squares. If this is an input value, it should ! lie in the range: (0, +infinity). If it is an output value, it will ! be searched for in the range: [ 1.0, 1.0D+30]. ! ! Input/output, real ( kind = rk ) DFD, the number of degrees of freedom ! of the denominator sum of squares. If this is an input value, it should ! be in range: (0, +infinity). If it is an output value, it will be ! searched for in the range [1.0, 1.0D+30]. ! ! Input/output, real ( kind = rk ) PNONC, the noncentrality parameter ! If this is an input value, it should be nonnegative. ! If it is an output value, it will be searched for in the range: [0,1.0D+4]. ! ! Output, integer STATUS, reports the status of the computation. ! 0, if the calculation completed correctly; ! -I, if the input parameter number I is out of range; ! +1, if the answer appears to be lower than lowest search bound; ! +2, if the answer appears to be higher than greatest search bound; ! +3, if P + Q /= 1. ! ! Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero. ! If STATUS is negative, then this is the value exceeded by parameter I. ! if STATUS is 1 or 2, this is the search bound that was exceeded. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: atol = 1.0D-10 real ( kind = rk ) bound real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) dfd real ( kind = rk ) dfn real ( kind = rk ) f real ( kind = rk ) fx real ( kind = rk ), parameter :: inf = 1.0D+30 real ( kind = rk ) p real ( kind = rk ) pnonc real ( kind = rk ) q logical qhi logical qleft integer status real ( kind = rk ), parameter :: tent4 = 1.0D+04 real ( kind = rk ), parameter :: tol = 1.0D-08 integer which status = 0 bound = 0.0D+00 ! ! Check the arguments. ! if ( which < 1 ) then bound = 1.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 5.' return end if if ( 5 < which ) then bound = 5.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 5.' return end if ! ! Unless P is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( p < 0.0D+00 ) then status = -2 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return else if ( 1.0D+00 < p ) then status = -2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return end if end if ! ! Unless F is to be computed, make sure it is legal. ! if ( which /= 2 ) then if ( f < 0.0D+00 ) then bound = 0.0D+00 status = -4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Fatal error!' write ( *, '(a)' ) ' Input parameter F is out of range.' return end if end if ! ! Unless DFN is to be computed, make sure it is legal. ! if ( which /= 3 ) then if ( dfn <= 0.0D+00 ) then bound = 0.0D+00 status = -5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Fatal error!' write ( *, '(a)' ) ' Input parameter DFN is out of range.' return end if end if ! ! Unless DFD is to be computed, make sure it is legal. ! if ( which /= 4 ) then if ( dfd <= 0.0D+00 ) then bound = 0.0D+00 status = -6 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Fatal error!' write ( *, '(a)' ) ' Input parameter DFD is out of range.' return end if end if ! ! Unless PNONC is to be computed, make sure it is legal. ! if ( which /= 5 ) then if ( pnonc < 0.0D+00 ) then bound = 0.0D+00 status = -7 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Fatal error!' write ( *, '(a)' ) ' Input parameter PNONC is out of range.' return end if end if ! ! Calculate P and Q. ! if ( which == 1 ) then call cumfnc ( f, dfn, dfd, pnonc, p, q ) status = 0 ! ! Calculate F. ! else if ( which == 2 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 f = 5.0D+00 fx = 0.0D+00 call dinvr ( status, f, fx, qleft, qhi ) do while ( status == 1 ) call cumfnc ( f, dfn, dfd, pnonc, cum, ccum ) fx = cum - p call dinvr ( status, f, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound return else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound return end if end if ! ! Calculate DFN. ! else if ( which == 3 ) then call dstinv ( 1.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 dfn = 5.0D+00 fx = 0.0D+00 call dinvr ( status, dfn, fx, qleft, qhi ) do while ( status == 1 ) call cumfnc ( f, dfn, dfd, pnonc, cum, ccum ) fx = cum - p call dinvr ( status, dfn, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate DFD. ! else if ( which == 4 ) then call dstinv ( 1.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 dfd = 5.0D+00 fx = 0.0D+00 call dinvr ( status, dfd, fx, qleft, qhi ) do while ( status == 1 ) call cumfnc ( f, dfn, dfd, pnonc, cum, ccum ) fx = cum - p call dinvr ( status, dfd, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate PNONC. ! else if ( which == 5 ) then call dstinv ( 0.0D+00, tent4, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 pnonc = 5.0D+00 fx = 0.0D+00 call dinvr ( status, pnonc, fx, qleft, qhi ) do while ( status == 1 ) call cumfnc ( f, dfn, dfd, pnonc, cum, ccum ) fx = cum - p call dinvr ( status, pnonc, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = tent4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFFNC - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if end if return end subroutine cdfgam ( which, p, q, x, shape, scale, status, bound ) !*****************************************************************************80 ! !! CDFGAM evaluates the CDF of the Gamma Distribution. ! ! Discussion: ! ! This routine calculates any one parameter of the Gamma distribution ! given the others. ! ! The cumulative distribution function P is calculated directly. ! ! Computation of the other parameters involves a seach for a value that ! produces the desired value of P. The search relies on the ! monotonicity of P with respect to the other parameters. ! ! The gamma density is proportional to T^(SHAPE - 1) * EXP(- SCALE * T) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 654: ! Computation of the incomplete gamma function ratios and their inverse, ! ACM Transactions on Mathematical Software, ! Volume 12, 1986, pages 377-393. ! ! Parameters: ! ! Input, integer WHICH, indicates which argument is to be ! calculated from the others. ! 1: Calculate P and Q from X, SHAPE and SCALE; ! 2: Calculate X from P, Q, SHAPE and SCALE; ! 3: Calculate SHAPE from P, Q, X and SCALE; ! 4: Calculate SCALE from P, Q, X and SHAPE. ! ! Input/output, real ( kind = rk ) P, the integral from 0 to X of the ! Gamma density. If this is an input value, it should lie in the ! range: [0,1]. ! ! Input/output, real ( kind = rk ) Q, equal to 1-P. If Q is an input ! value, it should lie in the range [0,1]. If Q is an output value, ! it will lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) X, the upper limit of integration of ! the Gamma density. If this is an input value, it should lie in the ! range: [0, +infinity). If it is an output value, it will lie in ! the range: [0,1E300]. ! ! Input/output, real ( kind = rk ) SHAPE, the shape parameter of the ! Gamma density. If this is an input value, it should lie in the range: ! (0, +infinity). If it is an output value, it will be searched for ! in the range: [1.0D-300,1.0D+300]. ! ! Input/output, real ( kind = rk ) SCALE, the scale parameter of the ! Gamma density. If this is an input value, it should lie in the range ! (0, +infinity). If it is an output value, it will be searched for ! in the range: (1.0D-300,1.0D+300]. ! ! Output, integer STATUS, reports the status of the computation. ! 0, if the calculation completed correctly; ! -I, if the input parameter number I is out of range; ! +1, if the answer appears to be lower than lowest search bound; ! +2, if the answer appears to be higher than greatest search bound; ! +3, if P + Q /= 1; ! +10, if the Gamma or inverse Gamma routine cannot compute the answer. ! This usually happens only for X and SHAPE very large (more than 1.0D+10. ! ! Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero. ! If STATUS is negative, then this is the value exceeded by parameter I. ! if STATUS is 1 or 2, this is the search bound that was exceeded. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: atol = 1.0D-10 real ( kind = rk ) bound real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) fx integer ierr real ( kind = rk ), parameter :: inf=1.0D+300 real ( kind = rk ) p real ( kind = rk ) porq real ( kind = rk ) q logical qhi logical qleft real ( kind = rk ) scale real ( kind = rk ) shape real ( kind = rk ), parameter :: tol = 1.0D-08 integer status,which real ( kind = rk ) x real ( kind = rk ) xscale real ( kind = rk ) xx status = 0 bound = 0.0D+00 ! ! Check the arguments. ! if ( which < 1 ) then bound = 1.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if if ( 4 < which ) then bound = 4.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if ! ! Unless P is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( p < 0.0D+00 ) then status = -2 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return else if ( 1.0D+00 < p ) then status = -2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return end if end if ! ! Unless Q is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( q < 0.0D+00 ) then status = -3 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return else if ( 1.0D+00 < q ) then status = -3 bound = 1.0 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return end if end if ! ! Unless X is to be computed, make sure it is legal. ! if ( which /= 2 ) then if ( x < 0.0D+00 ) then bound = 0.0D+00 status = -4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Fatal error!' write ( *, '(a)' ) ' Input parameter X is out of range.' return end if end if ! ! Unless SHAPE is to be computed, make sure it is legal. ! if ( which /= 3 ) then if ( shape <= 0.0D+00 ) then bound = 0.0D+00 status = -5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Fatal error!' write ( *, '(a)' ) ' Input parameter SHAPE is out of range.' return end if end if ! ! Unless SCALE is to be computed, make sure it is legal. ! if ( which /= 4 ) then if ( scale <= 0.0D+00 ) then bound = 0.0D+00 status = -6 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Fatal error!' write ( *, '(a)' ) ' Input parameter SCALE is out of range.' return end if end if ! ! Check that P + Q = 1. ! if ( which /= 1 ) then if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+0 ) ) then status = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Fatal error!' write ( *, '(a)' ) ' P + Q /= 1.' return end if end if ! ! Select the minimum of P or Q. ! if ( which /= 1 ) then porq = min ( p, q ) end if ! ! Calculate P and Q. ! if ( which == 1 ) then status = 0 xscale = x * scale call cumgam ( xscale, shape, p, q ) if ( 1.5D+00 < porq ) then status = 10 end if ! ! Calculate X. ! else if ( which == 2 ) then call gamma_inc_inv ( shape, xx, -1.0D+00, p, q, ierr ) if ( ierr < 0.0D+00 ) then status = 10 return end if x = xx / scale status = 0 ! ! Calculate SHAPE. ! else if ( which == 3 ) then xscale = x * scale call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 shape = 5.0D+00 fx = 0.0D+00 call dinvr ( status, shape, fx, qleft, qhi ) do while ( status == 1 ) call cumgam ( xscale, shape, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if if ( p <= q .and. 1.5D+00 < cum ) then status = 10 return else if ( q < p .and. 1.5D+00 < ccum ) then status = 10 return end if call dinvr ( status, shape, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFGAM - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate SCALE. ! else if ( which == 4 ) then call gamma_inc_inv ( shape, xx, -1.0D+00, p, q, ierr ) if ( ierr < 0.0D+00 ) then status = 10 else scale = xx / x status = 0 end if end if return end subroutine cdfnbn ( which, p, q, f, s, pr, ompr, status, bound ) !*****************************************************************************80 ! !! CDFNBN evaluates the CDF of the Negative Binomial distribution ! ! Discussion: ! ! This routine calculates any one parameter of the negative binomial ! distribution given values for the others. ! ! The cumulative negative binomial distribution returns the ! probability that there will be F or fewer failures before the ! S-th success in binomial trials each of which has probability of ! success PR. ! ! The individual term of the negative binomial is the probability of ! F failures before S successes and is ! Choose( F, S+F-1 ) * PR^(S) * (1-PR)^F ! ! Computation of other parameters involve a seach for a value that ! produces the desired value of P. The search relies on the ! monotonicity of P with respect to the other parameters. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.5.26. ! ! Parameters: ! ! Input, integer WHICH, indicates which argument is to be ! calculated from the others. ! 1: Calculate P and Q from F, S, PR and OMPR; ! 2: Calculate F from P, Q, S, PR and OMPR; ! 3: Calculate S from P, Q, F, PR and OMPR; ! 4: Calculate PR and OMPR from P, Q, F and S. ! ! Input/output, real ( kind = rk ) P, the cumulation from 0 to F of ! the negative binomial distribution. If P is an input value, it ! should lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) Q, equal to 1-P. If Q is an input ! value, it should lie in the range [0,1]. If Q is an output value, ! it will lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) F, the upper limit of cumulation of ! the binomial distribution. There are F or fewer failures before ! the S-th success. If this is an input value, it may lie in the ! range [0,+infinity), and if it is an output value, it will be searched ! for in the range [0,1.0D+300]. ! ! Input/output, real ( kind = rk ) S, the number of successes. ! If this is an input value, it should lie in the range: [0, +infinity). ! If it is an output value, it will be searched for in the range: ! [0, 1.0D+300]. ! ! Input/output, real ( kind = rk ) PR, the probability of success in each ! binomial trial. Whether an input or output value, it should lie in the ! range [0,1]. ! ! Input/output, real ( kind = rk ) OMPR, the value of (1-PR). Whether an ! input or output value, it should lie in the range [0,1]. ! ! Output, integer STATUS, reports the status of the computation. ! 0, if the calculation completed correctly; ! -I, if the input parameter number I is out of range; ! +1, if the answer appears to be lower than lowest search bound; ! +2, if the answer appears to be higher than greatest search bound; ! +3, if P + Q /= 1; ! +4, if PR + OMPR /= 1. ! ! Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero. ! If STATUS is negative, then this is the value exceeded by parameter I. ! if STATUS is 1 or 2, this is the search bound that was exceeded. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: atol = 1.0D-10 real ( kind = rk ) bound real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) f real ( kind = rk ) fx real ( kind = rk ), parameter :: inf = 1.0D+300 real ( kind = rk ) ompr real ( kind = rk ) p real ( kind = rk ) pr real ( kind = rk ) q logical qhi logical qleft real ( kind = rk ) s integer status real ( kind = rk ), parameter :: tol = 1.0D-08 integer which real ( kind = rk ) xhi real ( kind = rk ) xlo status = 0 bound = 0.0D+00 ! ! Check the arguments. ! if ( which < 1 ) then bound = 1.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if if ( 4 < which ) then bound = 4.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if ! ! Unless P is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( p < 0.0D+00 ) then status = -2 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return else if ( 1.0D+00 < p ) then status = -2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return end if end if ! ! Unless Q is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( q < 0.0D+00 ) then status = -3 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return else if ( 1.0D+00 < q ) then status = -3 bound = 1.0 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return end if end if ! ! Unless F is to be computed, make sure it is legal. ! if ( which /= 2 ) then if ( f < 0.0D+00 ) then bound = 0.0D+00 status = -4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' Input parameter F is out of range.' return end if end if ! ! Unless S is to be computed, make sure it is legal. ! if ( which /= 3 ) then if ( s < 0.0D+00 ) then bound = 0.0D+00 status = -5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' Input parameter S is out of range.' return end if end if ! ! Unless PR is to be computed, make sure it is legal. ! if ( which /= 4 ) then if ( pr < 0.0D+00 ) then bound = 0.0D+00 status = -6 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' Input parameter PR is out of range.' return else if ( 1.0D+00 < pr ) then bound = 1.0D+00 status = -6 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' Input parameter PR is out of range.' return end if end if ! ! Unless OMPR is to be computed, make sure it is legal. ! if ( which /= 4 ) then if ( ompr < 0.0D+00 ) then bound = 0.0D+00 status = -7 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' Input parameter OMPR is out of range.' return else if ( 1.0D+00 < ompr ) then bound = 1.0D+00 status = -7 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' Input parameter OMPR is out of range.' return end if end if ! ! Check that P + Q = 1. ! if ( which /= 1 ) then if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then status = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' P + Q /= 1.' return end if end if ! ! Check that PR + OMPR = 1. ! if ( which /= 4 ) then if ( 3.0D+00 * epsilon ( pr ) < abs ( ( pr + ompr ) - 1.0D+00 ) ) then status = 4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Fatal error!' write ( *, '(a)' ) ' PR + OMPR /= 1.' return end if end if ! ! Calculate P and Q. ! if ( which == 1 ) then call cumnbn ( f, s, pr, ompr, p, q ) status = 0 ! ! Calculate F. ! else if ( which == 2 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 f = 5.0D+00 fx = 0.0D+00 call dinvr ( status, f, fx, qleft, qhi ) do while ( status == 1 ) call cumnbn ( f, s, pr, ompr, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, f, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate S. ! else if ( which == 3 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 s = 5.0D+00 fx = 0.0D+00 call dinvr ( status, s, fx, qleft, qhi ) do while ( status == 1 ) call cumnbn ( f, s, pr, ompr, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, s, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBn - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate PR and OMPR. ! else if ( which == 4 ) then call dstzr ( 0.0D+00, 1.0D+00, atol, tol ) if ( p <= q ) then status = 0 call dzror ( status, pr, fx, xlo, xhi, qleft, qhi ) ompr = 1.0D+00 - pr do while ( status == 1 ) call cumnbn ( f, s, pr, ompr, cum, ccum ) fx = cum - p call dzror ( status, pr, fx, xlo, xhi, qleft, qhi ) ompr = 1.0D+00 - pr end do else status = 0 call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi ) pr = 1.0D+00 - ompr do while ( status == 1 ) call cumnbn ( f, s, pr, ompr, cum, ccum ) fx = ccum - q call dzror ( status, ompr, fx, xlo, xhi, qleft, qhi ) pr = 1.0D+00 - ompr end do end if if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNBN - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if end if return end subroutine cdfnor ( which, p, q, x, mean, sd, status, bound ) !*****************************************************************************80 ! !! CDFNOR evaluates the CDF of the Normal distribution. ! ! Discussion: ! ! A slightly modified version of ANORM from SPECFUN ! is used to calculate the cumulative standard normal distribution. ! ! The rational functions from pages 90-95 of Kennedy and Gentle ! are used as starting values to a Newton iteration which ! compute the inverse standard normal. Therefore no searches are ! necessary for any parameter. ! ! For X < -15, the asymptotic expansion for the normal is used as ! the starting value in finding the inverse standard normal. ! ! The normal density is proportional to ! exp ( - 0.5 * (( X - MEAN)/SD)^2) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.2.12. ! ! William Cody, ! Algorithm 715: ! SPECFUN - A Portable FORTRAN Package of ! Special Function Routines and Test Drivers, ! ACM Transactions on Mathematical Software, ! Volume 19, Number 1, pages 22-32, 1993. ! ! William Kennedy, James Gentle, ! Statistical Computing, ! Marcel Dekker, NY, 1980, ! QA276.4 K46 ! ! Parameters: ! ! Input, integer WHICH, indicates which argument is to be ! calculated from the others. ! 1: Calculate P and Q from X, MEAN and SD; ! 2: Calculate X from P, Q, MEAN and SD; ! 3: Calculate MEAN from P, Q, X and SD; ! 4: Calculate SD from P, Q, X and MEAN. ! ! Input/output, real ( kind = rk ) P, the integral from -infinity to X ! of the Normal density. If this is an input or output value, it will ! lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) Q, equal to 1-P. If Q is an input ! value, it should lie in the range [0,1]. If Q is an output value, ! it will lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) X, the upper limit of integration of ! the Normal density. ! ! Input/output, real ( kind = rk ) MEAN, the mean of the Normal density. ! ! Input/output, real ( kind = rk ) SD, the standard deviation of the ! Normal density. If this is an input value, it should lie in the ! range (0,+infinity). ! ! Output, integer STATUS, the status of the calculation. ! 0, if calculation completed correctly; ! -I, if input parameter number I is out of range; ! 1, if answer appears to be lower than lowest search bound; ! 2, if answer appears to be higher than greatest search bound; ! 3, if P + Q /= 1. ! ! Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero. ! If STATUS is negative, then this is the value exceeded by parameter I. ! if STATUS is 1 or 2, this is the search bound that was exceeded. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) bound real ( kind = rk ) dinvnr real ( kind = rk ) mean real ( kind = rk ) p real ( kind = rk ) q real ( kind = rk ) sd integer status integer which real ( kind = rk ) x real ( kind = rk ) z status = 0 bound = 0.0D+00 ! ! Check the arguments. ! status = 0 if ( which < 1 ) then status = -1 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNOR - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return else if ( 4 < which ) then status = -1 bound = 4.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNOR - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 4.' return end if ! ! Unless P is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( p < 0.0D+00 ) then status = -2 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNOR - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return else if ( 1.0D+00 < p ) then status = -2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNOR - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return end if end if ! ! Unless Q is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( q < 0.0D+00 ) then status = -3 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNOR - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return else if ( 1.0D+00 < q ) then status = -3 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNOR - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return end if end if ! ! Check that P + Q = 1. ! if ( which /= 1 ) then if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then status = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNOR - Fatal error!' write ( *, '(a)' ) ' P + Q /= 1.' return end if end if if ( which /= 4 ) then if ( sd <= 0.0D+00 ) then bound = 0.0D+00 status = -6 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFNOR - Fatal error!' write ( *, '(a)' ) ' Input parameter SD is out of range.' return end if end if ! ! Calculate P and Q. ! if ( which == 1 ) then z = ( x - mean ) / sd call cumnor ( z, p, q ) ! ! Calculate X. ! else if ( which == 2 ) then z = dinvnr ( p, q ) x = sd * z + mean ! ! Calculate MEAN. ! else if ( which == 3 ) then z = dinvnr ( p, q ) mean = x - sd * z ! ! Calculate SD. ! else if ( which == 4 ) then z = dinvnr ( p, q ) sd = ( x - mean ) / z end if return end subroutine cdfpoi ( which, p, q, s, xlam, status, bound ) !*****************************************************************************80 ! !! CDFPOI evaluates the CDF of the Poisson distribution. ! ! Discussion: ! ! This routine calculates any one parameter of the Poisson distribution ! given the others. ! ! The value P of the cumulative distribution function is calculated ! directly. ! ! Computation of other parameters involve a seach for a value that ! produces the desired value of P. The search relies on the ! monotonicity of P with respect to the other parameters. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.4.21. ! ! Parameters: ! ! Input, integer WHICH, indicates which argument is to be ! calculated from the others. ! 1: Calculate P and Q from S and XLAM; ! 2: Calculate A from P, Q and XLAM; ! 3: Calculate XLAM from P, Q and S. ! ! Input/output, real ( kind = rk ) P, the cumulation from 0 to S of the ! Poisson density. Whether this is an input or output value, it will ! lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) Q, equal to 1-P. If Q is an input ! value, it should lie in the range [0,1]. If Q is an output value, ! it will lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) S, the upper limit of cumulation of ! the Poisson CDF. If this is an input value, it should lie in ! the range: [0, +infinity). If it is an output value, it will be ! searched for in the range: [0,1.0D+300]. ! ! Input/output, real ( kind = rk ) XLAM, the mean of the Poisson ! distribution. If this is an input value, it should lie in the range ! [0, +infinity). If it is an output value, it will be searched for ! in the range: [0,1E300]. ! ! Output, integer STATUS, reports the status of the computation. ! 0, if the calculation completed correctly; ! -I, if the input parameter number I is out of range; ! +1, if the answer appears to be lower than lowest search bound; ! +2, if the answer appears to be higher than greatest search bound; ! +3, if P + Q /= 1. ! ! Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero. ! If STATUS is negative, then this is the value exceeded by parameter I. ! if STATUS is 1 or 2, this is the search bound that was exceeded. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: atol = 1.0D-10 real ( kind = rk ) bound real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) fx real ( kind = rk ), parameter :: inf = 1.0D+300 real ( kind = rk ) p real ( kind = rk ) q logical qhi logical qleft real ( kind = rk ) s integer status real ( kind = rk ), parameter :: tol = 1.0D-08 integer which real ( kind = rk ) xlam status = 0 bound = 0.0D+00 ! ! Check the arguments. ! if ( which < 1 ) then bound = 1.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 3.' return end if if ( 3 < which ) then bound = 3.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 3.' return end if ! ! Unless P is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( p < 0.0D+00 ) then status = -2 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return else if ( 1.0D+00 < p ) then status = -2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return end if end if ! ! Unless Q is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( q < 0.0D+00 ) then status = -3 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return else if ( 1.0D+00 < q ) then status = -3 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return end if end if ! ! Unless S is to be computed, make sure it is legal. ! if ( which /= 2 ) then if ( s < 0.0D+00 ) then bound = 0.0D+00 status = -4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Fatal error!' write ( *, '(a)' ) ' Input parameter S is out of range.' return end if end if ! ! Unless XLAM is to be computed, make sure it is legal. ! if ( which /= 3 ) then if ( xlam < 0.0D+00 ) then bound = 0.0D+00 status = -5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Fatal error!' write ( *, '(a)' ) ' Input parameter XLAM is out of range.' return end if end if ! ! Check that P + Q = 1. ! if ( which /= 1 ) then if ( 3.0D+00 * epsilon ( p ) < abs ( ( p + q ) - 1.0D+00 ) ) then status = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Fatal error!' write ( *, '(a)' ) ' P + Q /= 1.' return end if end if ! ! Calculate P and Q. ! if ( which == 1 ) then call cumpoi ( s, xlam, p, q ) status = 0 ! ! Calculate S. ! else if ( which == 2 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 s = 5.0D+00 fx = 0.0D+00 call dinvr ( status, s, fx, qleft, qhi ) do while ( status == 1 ) call cumpoi ( s, xlam, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, s, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate XLAM. ! else if ( which == 3 ) then call dstinv ( 0.0D+00, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 xlam = 5.0D+00 fx = 0.0D+00 call dinvr ( status, xlam, fx, qleft, qhi ) do while ( status == 1 ) call cumpoi ( s, xlam, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, xlam, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFPOI - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if end if return end subroutine cdft ( which, p, q, t, df, status, bound ) !*****************************************************************************80 ! !! CDFT evaluates the CDF of the T distribution. ! ! Discussion: ! ! This routine calculates any one parameter of the T distribution ! given the others. ! ! The value P of the cumulative distribution function is calculated ! directly. ! ! Computation of other parameters involve a seach for a value that ! produces the desired value of P. The search relies on the ! monotonicity of P with respect to the other parameters. ! ! The original version of this routine allowed the search interval ! to extend from -1.0D+300 to +1.0D+300, which is fine until you ! try to evaluate a function at such a point! ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.5.27. ! ! Parameters: ! ! Input, integer WHICH, indicates which argument is to be ! calculated from the others. ! 1 : Calculate P and Q from T and DF; ! 2 : Calculate T from P, Q and DF; ! 3 : Calculate DF from P, Q and T. ! ! Input/output, real ( kind = rk ) P, the integral from -infinity to T of ! the T-density. Whether an input or output value, this will lie in the ! range [0,1]. ! ! Input/output, real ( kind = rk ) Q, equal to 1-P. If Q is an input ! value, it should lie in the range [0,1]. If Q is an output value, ! it will lie in the range [0,1]. ! ! Input/output, real ( kind = rk ) T, the upper limit of integration of ! the T-density. If this is an input value, it may have any value. ! It it is an output value, it will be searched for in the range ! [ -1.0D+30, 1.0D+30 ]. ! ! Input/output, real ( kind = rk ) DF, the number of degrees of freedom ! of the T distribution. If this is an input value, it should lie ! in the range: (0 , +infinity). If it is an output value, it will be ! searched for in the range: [1, 1.0D+10]. ! ! Output, integer STATUS, reports the status of the computation. ! 0, if the calculation completed correctly; ! -I, if the input parameter number I is out of range; ! +1, if the answer appears to be lower than lowest search bound; ! +2, if the answer appears to be higher than greatest search bound; ! +3, if P + Q /= 1. ! ! Output, real ( kind = rk ) BOUND, is only defined if STATUS is nonzero. ! If STATUS is negative, then this is the value exceeded by parameter I. ! if STATUS is 1 or 2, this is the search bound that was exceeded. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: atol = 1.0D-10 real ( kind = rk ) bound real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) df real ( kind = rk ) dt1 real ( kind = rk ) fx real ( kind = rk ), parameter :: inf = 1.0D+30 real ( kind = rk ), parameter :: maxdf = 1.0D+10 real ( kind = rk ) p real ( kind = rk ) q logical qhi logical qleft integer status real ( kind = rk ) t real ( kind = rk ), parameter :: tol = 1.0D-08 integer which status = 0 bound = 0.0D+00 ! ! Check the arguments. ! if ( which < 1 ) then bound = 1.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 3.' return end if if ( 3 < which ) then bound = 3.0D+00 status = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Fatal error!' write ( *, '(a)' ) ' The input parameter WHICH is out of range.' write ( *, '(a)' ) ' Legal values are between 1 and 3.' return end if ! ! Unless P is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( p < 0.0D+00 ) then status = -2 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return else if ( 1.0D+00 < p ) then status = -2 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Fatal error!' write ( *, '(a)' ) ' Input parameter P is out of range.' return end if end if ! ! Unless Q is to be computed, make sure it is legal. ! if ( which /= 1 ) then if ( q < 0.0D+00 ) then status = -3 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return else if ( 1.0D+00 < q ) then status = -3 bound = 1.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Fatal error!' write ( *, '(a)' ) ' Input parameter Q is out of range.' return end if end if ! ! Unless DF is to be computed, make sure it is legal. ! if ( which /= 3 ) then if ( df <= 0.0D+00 ) then bound = 0.0D+00 status = -5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Fatal error!' write ( *, '(a)' ) ' Input parameter DF is out of range.' return end if end if ! ! Check that P + Q = 1. ! if ( which /= 1 ) then if ( 3.0D+00 * epsilon ( 1.0D+00 ) & < abs ( ( p + q ) - 1.0D+00 ) ) then status = 3 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Fatal error!' write ( *, '(a)' ) ' P + Q /= 1.' return end if end if ! ! Calculate P and Q. ! if ( which == 1 ) then call cumt ( t, df, p, q ) status = 0 ! ! Calculate T. ! else if ( which == 2 ) then call dstinv ( -inf, inf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 t = dt1 ( p, q, df ) fx = 0.0D+00 call dinvr ( status, t, fx, qleft, qhi ) do while ( status == 1 ) call cumt ( t, df, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, t, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft )then status = 1 bound = -inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = inf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if ! ! Calculate DF. ! else if ( which == 3 ) then call dstinv ( 1.0D+00, maxdf, 0.5D+00, 0.5D+00, 5.0D+00, atol, tol ) status = 0 df = 5.0D+00 fx = 0.0D+00 call dinvr ( status, df, fx, qleft, qhi ) do while ( status == 1 ) call cumt ( t, df, cum, ccum ) if ( p <= q ) then fx = cum - p else fx = ccum - q end if call dinvr ( status, df, fx, qleft, qhi ) end do if ( status == -1 ) then if ( qleft ) then status = 1 bound = 0.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Warning!' write ( *, '(a)' ) ' The desired answer appears to be lower than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound else status = 2 bound = maxdf write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDFT - Warning!' write ( *, '(a)' ) ' The desired answer appears to be higher than' write ( *, '(a,g14.6)' ) ' the search bound of ', bound end if end if end if return end subroutine chi_noncentral_cdf_values ( n_data, x, lambda, df, cdf ) !*****************************************************************************80 ! !! CHI_NONCENTRAL_CDF_VALUES returns values of the noncentral chi CDF. ! ! Discussion: ! ! The CDF of the noncentral chi square distribution can be evaluated ! within Mathematica by commands such as: ! ! Needs["Statistics`ContinuousDistributions`"] ! CDF [ NoncentralChiSquareDistribution [ DF, LAMBDA ], X ] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 June 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 = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) LAMBDA, the noncentrality parameter. ! ! Output, integer DF, the number of degrees of freedom. ! ! Output, real ( kind = rk ) CDF, the noncentral chi CDF. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 27 real ( kind = rk ) cdf real ( kind = rk ), save, dimension ( n_max ) :: cdf_vec = (/ & 0.839944D+00, 0.695906D+00, 0.535088D+00, & 0.764784D+00, 0.620644D+00, 0.469167D+00, & 0.307088D+00, 0.220382D+00, 0.150025D+00, & 0.307116D-02, 0.176398D-02, 0.981679D-03, & 0.165175D-01, 0.202342D-03, 0.498448D-06, & 0.151325D-01, 0.209041D-02, 0.246502D-03, & 0.263684D-01, 0.185798D-01, 0.130574D-01, & 0.583804D-01, 0.424978D-01, 0.308214D-01, & 0.105788D+00, 0.794084D-01, 0.593201D-01 /) 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 /) real ( kind = rk ) lambda real ( kind = rk ), 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 /) integer n_data real ( kind = rk ) x real ( kind = rk ), 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 /) 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_cdf_values ( n_data, a, x, fx ) !*****************************************************************************80 ! !! CHI_SQUARE_CDF_VALUES returns some values of the Chi-Square CDF. ! ! Discussion: ! ! The value of CHI_CDF ( DF, X ) can be evaluated in Mathematica by ! commands like: ! ! Needs["Statistics`ContinuousDistributions`"] ! CDF[ChiSquareDistribution[DF], X ] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 June 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, 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, real ( kind = rk ) X, the arguments of ! the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.0796557D+00, 0.00498752D+00, 0.112463D+00, 0.00995017D+00, & 0.472911D+00, 0.181269D+00, 0.0597575D+00, 0.0175231D+00, & 0.682689D+00, 0.393469D+00, 0.198748D+00, 0.090204D+00, & 0.0374342D+00, 0.427593D+00, 0.608375D+00, 0.738536D+00, & 0.828203D+00, 0.88839D+00, 0.000172116D+00, 0.00365985D+00, & 0.0185759D+00 /) integer n_data real ( kind = rk ) x real ( kind = rk ), 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 subroutine cumbet ( x, y, a, b, cum, ccum ) !*****************************************************************************80 ! !! CUMBET evaluates the cumulative incomplete beta distribution. ! ! Discussion: ! ! This routine calculates the CDF to X of the incomplete beta distribution ! with parameters A and B. This is the integral from 0 to x ! of (1/B(a,b))*f(t)) where f(t) = t^(a-1) * (1-t)^(b-1) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Parameters: ! ! Input, real ( kind = rk ) X, the upper limit of integration. ! ! Input, real ( kind = rk ) Y, the value of 1-X. ! ! Input, real ( kind = rk ) A, B, the parameters of the distribution. ! ! Output, real ( kind = rk ) CUM, CCUM, the values of the cumulative ! density function and complementary cumulative density function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) ccum real ( kind = rk ) cum integer ierr real ( kind = rk ) x real ( kind = rk ) y if ( x <= 0.0D+00 ) then cum = 0.0 ccum = 1.0D+00 else if ( y <= 0.0D+00 ) then cum = 1.0D+00 ccum = 0.0 else call beta_inc ( a, b, x, y, cum, ccum, ierr ) end if return end subroutine cumbin ( s, xn, pr, ompr, cum, ccum ) !*****************************************************************************80 ! !! CUMBIN evaluates the cumulative binomial distribution. ! ! Discussion: ! ! This routine returns the probability of 0 to S successes in XN binomial ! trials, each of which has a probability of success, PR. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.5.24. ! ! Parameters: ! ! Input, real ( kind = rk ) S, the upper limit of summation. ! ! Input, real ( kind = rk ) XN, the number of trials. ! ! Input, real ( kind = rk ) PR, the probability of success in one trial. ! ! Input, real ( kind = rk ) OMPR, equals ( 1 - PR ). ! ! Output, real ( kind = rk ) CUM, the cumulative binomial distribution. ! ! Output, real ( kind = rk ) CCUM, the complement of the cumulative ! binomial distribution. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) ompr real ( kind = rk ) pr real ( kind = rk ) s real ( kind = rk ) xn if ( s < xn ) then call cumbet ( pr, ompr, s + 1.0D+00, xn - s, ccum, cum ) else cum = 1.0D+00 ccum = 0.0D+00 end if return end subroutine cumchi ( x, df, cum, ccum ) !*****************************************************************************80 ! !! CUMCHI evaluates the cumulative chi-square distribution. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Parameters: ! ! Input, real ( kind = rk ) X, the upper limit of integration. ! ! Input, real ( kind = rk ) DF, the degrees of freedom of the ! chi-square distribution. ! ! Output, real ( kind = rk ) CUM, the cumulative chi-square distribution. ! ! Output, real ( kind = rk ) CCUM, the complement of the cumulative ! chi-square distribution. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) df real ( kind = rk ) x real ( kind = rk ) xx a = df * 0.5D+00 xx = x * 0.5D+00 call cumgam ( xx, a, cum, ccum ) return end subroutine cumchn ( x, df, pnonc, cum, ccum ) !*****************************************************************************80 ! !! CUMCHN evaluates the cumulative noncentral chi-square distribution. ! ! Discussion: ! ! This routine calculates the cumulative noncentral chi-square ! distribution, i.e., the probability that a random variable ! which follows the noncentral chi-square distribution, with ! noncentrality parameter PNONC and continuous degrees of ! freedom DF, is less than or equal to X. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.4.25. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the upper limit of integration. ! ! Input, real ( kind = rk ) DF, the number of degrees of freedom. ! ! Input, real ( kind = rk ) PNONC, the noncentrality parameter of ! the noncentral chi-square distribution. ! ! Output, real ( kind = rk ) CUM, CCUM, the CDF and complementary ! CDF of the noncentral chi-square distribution. ! ! Local: ! ! Local, real ( kind = rk ) EPS, the convergence criterion. The sum ! stops when a term is less than EPS * SUM. ! ! Local, integer NTIRED, the maximum number of terms to be evaluated ! in each sum. ! ! Local, logical QCONV, is TRUE if convergence was achieved, that is, ! the program did not stop on NTIRED criterion. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) adj real ( kind = rk ) ccum real ( kind = rk ) centaj real ( kind = rk ) centwt real ( kind = rk ) chid2 real ( kind = rk ) cum real ( kind = rk ) df real ( kind = rk ) dfd2 real ( kind = rk ) dg real ( kind = rk ), parameter :: eps = 0.00001D+00 real ( kind = rk ) gamma_log integer i integer icent integer iterb integer iterf real ( kind = rk ) lcntaj real ( kind = rk ) lcntwt real ( kind = rk ) lfact integer, parameter :: ntired = 1000 real ( kind = rk ) pcent real ( kind = rk ) pnonc real ( kind = rk ) pterm logical qsmall real ( kind = rk ) sum1 real ( kind = rk ) sumadj real ( kind = rk ) term real ( kind = rk ) wt real ( kind = rk ) x real ( kind = rk ) xnonc real ( kind = rk ) xx qsmall ( xx ) = sum1 < 1.0D-20 .or. xx < eps * sum1 dg(i) = df + 2.0D+00 * real ( i, kind = rk ) if ( x <= 0.0D+00 ) then cum = 0.0D+00 ccum = 1.0D+00 return end if ! ! When the noncentrality parameter is (essentially) zero, ! use cumulative chi-square distribution ! if ( pnonc <= 1.0D-10 ) then call cumchi ( x, df, cum, ccum ) return end if xnonc = pnonc / 2.0D+00 ! ! The following code calculates the weight, chi-square, and ! adjustment term for the central term in the infinite series. ! The central term is the one in which the poisson weight is ! greatest. The adjustment term is the amount that must ! be subtracted from the chi-square to move up two degrees ! of freedom. ! icent = int ( xnonc ) if ( icent == 0 ) then icent = 1 end if chid2 = x / 2.0D+00 ! ! Calculate central weight term. ! lfact = gamma_log ( real ( icent + 1, kind = rk ) ) lcntwt = - xnonc + icent * log ( xnonc ) - lfact centwt = exp ( lcntwt ) ! ! Calculate central chi-square. ! call cumchi ( x, dg(icent), pcent, ccum ) ! ! Calculate central adjustment term. ! dfd2 = dg(icent) / 2.0D+00 lfact = gamma_log ( 1.0D+00 + dfd2 ) lcntaj = dfd2 * log ( chid2 ) - chid2 - lfact centaj = exp ( lcntaj ) sum1 = centwt * pcent ! ! Sum backwards from the central term towards zero. ! Quit whenever either ! (1) the zero term is reached, or ! (2) the term gets small relative to the sum, or ! (3) More than NTIRED terms are totaled. ! iterb = 0 sumadj = 0.0D+00 adj = centaj wt = centwt i = icent term = 0.0D+00 do dfd2 = dg(i) / 2.0D+00 ! ! Adjust chi-square for two fewer degrees of freedom. ! The adjusted value ends up in PTERM. ! adj = adj * dfd2 / chid2 sumadj = sumadj + adj pterm = pcent + sumadj ! ! Adjust Poisson weight for J decreased by one. ! wt = wt * ( i / xnonc ) term = wt * pterm sum1 = sum1 + term i = i - 1 iterb = iterb + 1 if ( ntired < iterb .or. qsmall ( term ) .or. i == 0 ) then exit end if end do iterf = 0 ! ! Now sum forward from the central term towards infinity. ! Quit when either ! (1) the term gets small relative to the sum, or ! (2) More than NTIRED terms are totaled. ! sumadj = centaj adj = centaj wt = centwt i = icent ! ! Update weights for next higher J. ! do wt = wt * ( xnonc / ( i + 1 ) ) ! ! Calculate PTERM and add term to sum. ! pterm = pcent - sumadj term = wt * pterm sum1 = sum1 + term ! ! Update adjustment term for DF for next iteration. ! i = i + 1 dfd2 = dg(i) / 2.0D+00 adj = adj * chid2 / dfd2 sumadj = sumadj + adj iterf = iterf + 1 if ( ntired < iterf .or. qsmall ( term ) ) then exit end if end do cum = sum1 ccum = 0.5D+00 + ( 0.5D+00 - cum ) return end subroutine cumf ( f, dfn, dfd, cum, ccum ) !*****************************************************************************80 ! !! CUMF evaluates the cumulative F distribution. ! ! Discussion: ! ! This routine computes the integral from 0 to F of the F density with DFN ! numerator and DFD denominator degrees of freedom. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.5.28. ! ! Parameters: ! ! Input, real ( kind = rk ) F, the upper limit of integration. ! ! Input, real ( kind = rk ) DFN, DFD, the number of degrees of ! freedom for the numerator and denominator. ! ! Output, real ( kind = rk ) CUM, CCUM, the value of the F CDF and ! the complementary F CDF. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) dfd real ( kind = rk ) dfn real ( kind = rk ) dsum real ( kind = rk ) f integer ierr real ( kind = rk ) prod real ( kind = rk ) xx real ( kind = rk ) yy if ( f <= 0.0D+00 ) then cum = 0.0D+00 ccum = 1.0D+00 return end if prod = dfn * f ! ! XX is such that the incomplete beta with parameters ! DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM ! ! YY is 1 - XX ! ! Calculate the smaller of XX and YY accurately. ! dsum = dfd + prod xx = dfd / dsum if ( 0.5D+00 < xx ) then yy = prod / dsum xx = 1.0D+00 - yy else yy = 1.0D+00 - xx end if call beta_inc ( 0.5D+00 * dfd, 0.5D+00 * dfn, xx, yy, ccum, cum, ierr ) return end subroutine cumfnc ( f, dfn, dfd, pnonc, cum, ccum ) !*****************************************************************************80 ! !! CUMFNC evaluates the cumulative noncentral F distribution. ! ! Discussion: ! ! This routine computes the noncentral F distribution with DFN and DFD ! degrees of freedom and noncentrality parameter PNONC. ! ! The series is calculated backward and forward from J = LAMBDA/2 ! (this is the term with the largest Poisson weight) until ! the convergence criterion is met. ! ! The sum continues until a succeeding term is less than EPS ! times the sum or the sum is very small. EPS is ! set to 1.0D-4 in a data statement which can be changed. ! ! The original version of this routine allowed the input values ! of DFN and DFD to be negative (nonsensical) or zero (which ! caused numerical overflow.) I have forced both these values ! to be at least 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.5.16, 26.6.17, 26.6.18, 26.6.20. ! ! Parameters: ! ! Input, real ( kind = rk ) F, the upper limit of integration. ! ! Input, real ( kind = rk ) DFN, DFD, the number of degrees of freedom ! in the numerator and denominator. Both DFN and DFD must be positive, ! and normally would be integers. This routine requires that they ! be no less than 1. ! ! Input, real ( kind = rk ) PNONC, the noncentrality parameter. ! ! Output, real ( kind = rk ) CUM, CCUM, the noncentral F CDF and ! complementary CDF. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) adn real ( kind = rk ) arg1 real ( kind = rk ) aup real ( kind = rk ) b real ( kind = rk ) betdn real ( kind = rk ) betup real ( kind = rk ) centwt real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) dfd real ( kind = rk ) dfn real ( kind = rk ) dnterm real ( kind = rk ) dsum real ( kind = rk ) dummy real ( kind = rk ), parameter :: eps = 0.0001D+00 real ( kind = rk ) expon real ( kind = rk ) f real ( kind = rk ) gamma_log integer i integer icent integer ierr real ( kind = rk ) pnonc real ( kind = rk ) prod real ( kind = rk ) sum1 real ( kind = rk ) upterm real ( kind = rk ) xmult real ( kind = rk ) xnonc real ( kind = rk ) xx real ( kind = rk ) yy if ( f <= 0.0D+00 ) then cum = 0.0D+00 ccum = 1.0D+00 return end if if ( dfn < 1.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CUMFNC - Fatal error!' write ( *, '(a)' ) ' DFN < 1.' stop end if if ( dfd < 1.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CUMFNC - Fatal error!' write ( *, '(a)' ) ' DFD < 1.' stop end if ! ! Handle case in which the noncentrality parameter is essentially zero. ! if ( pnonc < 1.0D-10 ) then call cumf ( f, dfn, dfd, cum, ccum ) return end if xnonc = pnonc / 2.0D+00 ! ! Calculate the central term of the Poisson weighting factor. ! icent = int ( xnonc ) if ( icent == 0 ) then icent = 1 end if ! ! Compute central weight term. ! centwt = exp ( -xnonc + icent * log ( xnonc ) & - gamma_log ( real ( icent + 1, kind = rk ) ) ) ! ! Compute central incomplete beta term. ! Ensure that minimum of arg to beta and 1 - arg is computed accurately. ! prod = dfn * f dsum = dfd + prod yy = dfd / dsum if ( 0.5D+00 < yy ) then xx = prod / dsum yy = 1.0D+00 - xx else xx = 1.0D+00 - yy end if arg1 = 0.5D+00 * dfn + real ( icent, kind = rk ) call beta_inc ( arg1, 0.5D+00*dfd, xx, yy, betdn, dummy, ierr ) adn = dfn / 2.0D+00 + real ( icent, kind = rk ) aup = adn b = dfd / 2.0D+00 betup = betdn sum1 = centwt * betdn ! ! Now sum terms backward from ICENT until convergence or all done. ! xmult = centwt i = icent dnterm = exp ( gamma_log ( adn + b ) & - gamma_log ( adn + 1.0D+00 ) & - gamma_log ( b ) + adn * log ( xx ) + b * log ( yy ) ) do if ( i <= 0 ) then exit end if if ( sum1 < epsilon ( xmult * betdn ) .or. & xmult * betdn < eps * sum1 ) then exit end if xmult = xmult * ( real ( i, kind = rk ) / xnonc ) i = i - 1 adn = adn - 1.0D+00 dnterm = ( adn + 1.0D+00 ) / ( ( adn + b ) * xx ) * dnterm betdn = betdn + dnterm sum1 = sum1 + xmult * betdn end do i = icent + 1 ! ! Now sum forward until convergence. ! xmult = centwt if ( ( aup - 1.0D+00 + b ) == 0 ) then expon = - gamma_log ( aup ) - gamma_log ( b ) & + ( aup - 1.0D+00 ) * log ( xx ) + b * log ( yy ) else expon = gamma_log ( aup - 1.0D+00 + b ) - gamma_log ( aup ) & - gamma_log ( b ) + ( aup - 1.0D+00 ) * log ( xx ) + b * log ( yy ) end if ! ! The fact that DCDFLIB assumes that 1.0E+30 is a reasonable ! value to plug into any function, and that G95 computes corresponding ! function values of, say 1.0E-303, and then chokes with a floating point ! error when asked to combine such a value with a reasonable floating ! point quantity, has driven me to the following sort of check that ! was last fashionable in the 1960's! ! if ( expon <= log ( epsilon ( expon ) ) ) then upterm = 0.0D+00 else upterm = exp ( expon ) end if do xmult = xmult * ( xnonc / real ( i, kind = rk ) ) i = i + 1 aup = aup + 1.0D+00 upterm = ( aup + b - 2.0D+00 ) * xx / ( aup - 1.0D+00 ) * upterm betup = betup - upterm sum1 = sum1 + xmult * betup if ( sum1 < epsilon ( xmult * betup ) .or. xmult * betup < eps * sum1 ) then exit end if end do cum = sum1 ccum = 0.5D+00 + ( 0.5D+00 - cum ) return end subroutine cumgam ( x, a, cum, ccum ) !*****************************************************************************80 ! !! CUMGAM evaluates the cumulative incomplete gamma distribution. ! ! Discussion: ! ! This routine computes the cumulative distribution function of the ! incomplete gamma distribution, i.e., the integral from 0 to X of ! ! (1/GAM(A))*EXP(-T)*T^(A-1) DT ! ! where GAM(A) is the complete gamma function of A: ! ! GAM(A) = integral from 0 to infinity of EXP(-T)*T^(A-1) DT ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Parameters: ! ! Input, real ( kind = rk ) X, the upper limit of integration. ! ! Input, real ( kind = rk ) A, the shape parameter of the incomplete ! Gamma distribution. ! ! Output, real ( kind = rk ) CUM, CCUM, the incomplete Gamma CDF and ! complementary CDF. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) x if ( x <= 0.0D+00 ) then cum = 0.0D+00 ccum = 1.0D+00 else call gamma_inc ( a, x, cum, ccum, 0 ) end if return end subroutine cumnbn ( f, s, pr, ompr, cum, ccum ) !*****************************************************************************80 ! !! CUMNBN evaluates the cumulative negative binomial distribution. ! ! Discussion: ! ! This routine returns the probability that there will be F or ! fewer failures before there are S successes, with each binomial ! trial having a probability of success PR. ! ! Prob(# failures = F | S successes, PR) = ! ( S + F - 1 ) ! ( ) * PR^S * (1-PR)^F ! ( F ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.5.26. ! ! Parameters: ! ! Input, real ( kind = rk ) F, the number of failures. ! ! Input, real ( kind = rk ) S, the number of successes. ! ! Input, real ( kind = rk ) PR, OMPR, the probability of success on ! each binomial trial, and the value of (1-PR). ! ! Output, real ( kind = rk ) CUM, CCUM, the negative binomial CDF, ! and the complementary CDF. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) f real ( kind = rk ) ompr real ( kind = rk ) pr real ( kind = rk ) s call cumbet ( pr, ompr, s, f+1.D+00, cum, ccum ) return end subroutine cumnor ( arg, cum, ccum ) !*****************************************************************************80 ! !! CUMNOR computes the cumulative normal distribution. ! ! Discussion: ! ! This function evaluates the normal distribution function: ! ! / x ! 1 | -t*t/2 ! P(x) = ----------- | e dt ! sqrt(2 pi) | ! /-oo ! ! This transportable program uses rational functions that ! theoretically approximate the normal distribution function 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! William Cody ! ! Reference: ! ! William Cody, ! Rational Chebyshev approximations for the error function, ! Mathematics of Computation, ! 1969, pages 631-637. ! ! William Cody, ! Algorithm 715: ! SPECFUN - A Portable FORTRAN Package of Special Function Routines ! and Test Drivers, ! ACM Transactions on Mathematical Software, ! Volume 19, Number 1, 1993, pages 22-32. ! ! Parameters: ! ! Input, real ( kind = rk ) ARG, the upper limit of integration. ! ! Output, real ( kind = rk ) CUM, CCUM, the Normal density CDF and ! complementary CDF. ! ! Local: ! ! Local, real ( kind = rk ) EPS, the argument below which anorm(x) ! may be represented by 0.5 and above which x*x will not underflow. ! A conservative value is the largest machine number X ! such that 1.0D+00 + X = 1.0D+00 to machine precision. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter, dimension ( 5 ) :: a = (/ & 2.2352520354606839287D+00, & 1.6102823106855587881D+02, & 1.0676894854603709582D+03, & 1.8154981253343561249D+04, & 6.5682337918207449113D-02 /) real ( kind = rk ) arg real ( kind = rk ), parameter, dimension ( 4 ) :: b = (/ & 4.7202581904688241870D+01, & 9.7609855173777669322D+02, & 1.0260932208618978205D+04, & 4.5507789335026729956D+04 /) real ( kind = rk ), parameter, dimension ( 9 ) :: c = (/ & 3.9894151208813466764D-01, & 8.8831497943883759412D+00, & 9.3506656132177855979D+01, & 5.9727027639480026226D+02, & 2.4945375852903726711D+03, & 6.8481904505362823326D+03, & 1.1602651437647350124D+04, & 9.8427148383839780218D+03, & 1.0765576773720192317D-08 /) real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ), parameter, dimension ( 8 ) :: d = (/ & 2.2266688044328115691D+01, & 2.3538790178262499861D+02, & 1.5193775994075548050D+03, & 6.4855582982667607550D+03, & 1.8615571640885098091D+04, & 3.4900952721145977266D+04, & 3.8912003286093271411D+04, & 1.9685429676859990727D+04 /) real ( kind = rk ) del real ( kind = rk ) eps integer i real ( kind = rk ), parameter, dimension ( 6 ) :: p = (/ & 2.1589853405795699D-01, & 1.274011611602473639D-01, & 2.2235277870649807D-02, & 1.421619193227893466D-03, & 2.9112874951168792D-05, & 2.307344176494017303D-02 /) real ( kind = rk ), parameter, dimension ( 5 ) :: q = (/ & 1.28426009614491121D+00, & 4.68238212480865118D-01, & 6.59881378689285515D-02, & 3.78239633202758244D-03, & 7.29751555083966205D-05 /) real ( kind = rk ), parameter :: root32 = 5.656854248D+00 real ( kind = rk ), parameter :: sixten = 16.0D+00 real ( kind = rk ) temp real ( kind = rk ), parameter :: sqrpi = 3.9894228040143267794D-01 real ( kind = rk ), parameter :: thrsh = 0.66291D+00 real ( kind = rk ) x real ( kind = rk ) xden real ( kind = rk ) xnum real ( kind = rk ) y real ( kind = rk ) xsq ! ! Machine dependent constants ! eps = epsilon ( 1.0D+00 ) * 0.5D+00 x = arg y = abs ( x ) if ( y <= thrsh ) then ! ! Evaluate anorm for |X| <= 0.66291 ! if ( eps < y ) then xsq = x * x 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 cum = x * ( xnum + a(4) ) / ( xden + b(4) ) temp = cum cum = 0.5D+00 + temp ccum = 0.5D+00 - temp ! ! Evaluate ANORM for 0.66291 <= |X| <= sqrt(32) ! else if ( y <= root32 ) then xnum = c(9) * y xden = y do i = 1, 7 xnum = ( xnum + c(i) ) * y xden = ( xden + d(i) ) * y end do cum = ( xnum + c(8) ) / ( xden + d(8) ) xsq = aint ( y * sixten ) / sixten del = ( y - xsq ) * ( y + xsq ) cum = exp ( - xsq * xsq * 0.5D+00 ) * exp ( -del * 0.5D+00 ) * cum ccum = 1.0D+00 - cum if ( 0.0D+00 < x ) then call r8_swap ( cum, ccum ) end if ! ! Evaluate ANORM for sqrt(32) < |X|. ! else cum = 0.0D+00 xsq = 1.0D+00 / ( x * x ) xnum = p(6) * xsq xden = xsq do i = 1, 4 xnum = ( xnum + p(i) ) * xsq xden = ( xden + q(i) ) * xsq end do cum = xsq * ( xnum + p(5) ) / ( xden + q(5) ) cum = ( sqrpi - cum ) / y xsq = aint ( x * sixten ) / sixten del = ( x - xsq ) * ( x + xsq ) cum = exp ( - xsq * xsq * 0.5D+00 ) & * exp ( - del * 0.5D+00 ) * cum ccum = 1.0D+00 - cum if ( 0.0D+00 < x ) then call r8_swap ( cum, ccum ) end if end if if ( cum < tiny ( cum ) ) then cum = 0.0D+00 end if if ( ccum < tiny ( ccum ) ) then ccum = 0.0D+00 end if return end subroutine cumpoi ( s, xlam, cum, ccum ) !*****************************************************************************80 ! !! CUMPOI evaluates the cumulative Poisson distribution. ! ! Discussion: ! ! This routine returns the probability of S or fewer events in a Poisson ! distribution with mean XLAM. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! Formula 26.4.21. ! ! Parameters: ! ! Input, real ( kind = rk ) S, the upper limit of cumulation of the ! Poisson density function. ! ! Input, real ( kind = rk ) XLAM, the mean of the Poisson distribution. ! ! Output, real ( kind = rk ) CUM, CCUM, the Poisson density CDF and ! complementary CDF. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) ccum real ( kind = rk ) chi real ( kind = rk ) cum real ( kind = rk ) df real ( kind = rk ) s real ( kind = rk ) xlam df = 2.0D+00 * ( s + 1.0D+00 ) chi = 2.0D+00 * xlam call cumchi ( chi, df, ccum, cum ) return end subroutine cumt ( t, df, cum, ccum ) !*****************************************************************************80 ! !! CUMT evaluates the cumulative T distribution. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Barry Brown, James Lovato, Kathy Russell ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! Formula 26.5.27. ! ! Parameters: ! ! Input, real ( kind = rk ) T, the upper limit of integration. ! ! Input, real ( kind = rk ) DF, the number of degrees of freedom of ! the T distribution. ! ! Output, real ( kind = rk ) CUM, CCUM, the T distribution CDF and ! complementary CDF. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) df real ( kind = rk ) oma real ( kind = rk ) t real ( kind = rk ) xx real ( kind = rk ) yy xx = df / ( df + t**2 ) yy = t**2 / ( df + t**2 ) call cumbet ( xx, yy, 0.5D+00*df, 0.5D+00, a, oma ) if ( t <= 0.0D+00 ) then cum = 0.5D+00 * a ccum = oma + cum else ccum = 0.5D+00 * a cum = oma + ccum end if return end function dbetrm ( a, b ) !*****************************************************************************80 ! !! DBETRM computes the Sterling remainder for the complete beta function. ! ! Discussion: ! ! Log(Beta(A,B)) = Lgamma(A) + Lgamma(B) - Lgamma(A+B) ! where Lgamma is the log of the (complete) gamma function ! ! Let ZZ be approximation obtained if each log gamma is approximated ! by Sterling's formula, i.e., ! ! Sterling(Z) = log ( sqrt ( 2 * PI ) ) + ( Z - 0.5 ) * log ( Z ) - Z ! ! The Sterling remainder is Log(Beta(A,B)) - ZZ. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Parameters: ! ! Input, real ( kind = rk ) A, B, the parameters of the Beta function. ! ! Output, real ( kind = rk ) DBETRM, the Sterling remainder. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) dbetrm real ( kind = rk ) dstrem ! ! Try to sum from smallest to largest. ! dbetrm = -dstrem ( a + b ) dbetrm = dbetrm + dstrem ( max ( a, b ) ) dbetrm = dbetrm + dstrem ( min ( a, b ) ) return end function dexpm1 ( x ) !*****************************************************************************80 ! !! DEXPM1 evaluates the function EXP(X) - 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the value at which exp(X)-1 is desired. ! ! Output, real ( kind = rk ) DEXPM1, the value of exp(X)-1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) bot real ( kind = rk ) dexpm1 real ( kind = rk ), parameter :: p1 = 0.914041914819518D-09 real ( kind = rk ), parameter :: p2 = 0.238082361044469D-01 real ( kind = rk ), parameter :: q1 = -0.499999999085958D+00 real ( kind = rk ), parameter :: q2 = 0.107141568980644D+00 real ( kind = rk ), parameter :: q3 = -0.119041179760821D-01 real ( kind = rk ), parameter :: q4 = 0.595130811860248D-03 real ( kind = rk ) top real ( kind = rk ) w real ( kind = rk ) x if ( abs ( x ) <= 0.15D+00 ) then top = ( p2 * x + p1 ) * x + 1.0D+00 bot = ((( q4 * x + q3 ) * x + q2 ) * x + q1 ) * x + 1.0D+00 dexpm1 = x * ( top / bot ) else w = exp ( x ) if ( x <= 0.0D+00 ) then dexpm1 = ( w - 0.5D+00 ) - 0.5D+00 else dexpm1 = w * ( 0.5D+00 & + ( 0.5D+00 - 1.0D+00 / w )) end if end if return end function dinvnr ( p, q ) !*****************************************************************************80 ! !! DINVNR computes the inverse of the normal distribution. ! ! Discussion: ! ! This routine returns X such that ! ! CUMNOR(X) = P, ! ! that is, so that ! ! P = integral ( -oo <= T <= X ) exp(-U*U/2)/sqrt(2*PI) dU ! ! The rational function on page 95 of Kennedy and Gentle is used as a ! starting value for the Newton method of finding roots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Reference: ! ! William Kennedy, James Gentle, ! Statistical Computing, ! Marcel Dekker, NY, 1980, ! QA276.4 K46 ! ! Parameters: ! ! Input, real ( kind = rk ) P, Q, the probability, and the complementary ! probability. ! ! Output, real ( kind = rk ) DINVNR, the argument X for which the ! Normal CDF has the value P. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) ccum real ( kind = rk ) cum real ( kind = rk ) dinvnr real ( kind = rk ) dx real ( kind = rk ), parameter :: eps = 1.0D-13 integer i integer, parameter :: maxit = 100 real ( kind = rk ) p real ( kind = rk ) pp real ( kind = rk ) q real ( kind = rk ), parameter :: r2pi = 0.3989422804014326D+00 real ( kind = rk ) strtx real ( kind = rk ) stvaln real ( kind = rk ) xcur pp = min ( p, q ) strtx = stvaln ( pp ) xcur = strtx ! ! Newton iterations. ! do i = 1, maxit call cumnor ( xcur, cum, ccum ) dx = ( cum - pp ) / ( r2pi * exp ( -0.5D+00 * xcur * xcur ) ) xcur = xcur - dx if ( abs ( dx / xcur ) < eps ) then if ( p <= q ) then dinvnr = xcur else dinvnr = -xcur end if return end if end do if ( p <= q ) then dinvnr = strtx else dinvnr = -strtx end if return end subroutine dinvr ( status, x, fx, qleft, qhi ) !*****************************************************************************80 ! !! DINVR bounds the zero of the function and invokes DZROR. ! ! Discussion: ! ! This routine seeks to find bounds on a root of the function and ! invokes DZROR to perform the zero finding. DSTINV must have been ! called before this routine in order to set its parameters. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Reference: ! ! JCP Bus, TJ Dekker, ! Two Efficient Algorithms with Guaranteed Convergence for ! Finding a Zero of a Function, ! ACM Transactions on Mathematical Software, ! Volume 1, Number 4, pages 330-345, 1975. ! ! Parameters: ! ! Input/output, integer STATUS. At the beginning of a zero ! finding problem, STATUS should be set to 0 and this routine invoked. ! The value of parameters other than X will be ignored on this call. ! If this routine needs the function to be evaluated, it will set STATUS ! to 1 and return. The value of the function should be set in FX and ! this routine again called without changing any of its other parameters. ! If this routine finishes without error, it returns with STATUS 0, ! and X an approximate root of F(X). ! If this routine cannot bound the function, it returns a negative STATUS and ! sets QLEFT and QHI. ! ! Output, real ( kind = rk ) X, the value at which F(X) is to be evaluated. ! ! Input, real ( kind = rk ) FX, the value of F(X) calculated by the user ! on the previous call, when this routine returned with STATUS = 1. ! ! Output, logical QLEFT, is defined only if QMFINV returns FALSE. In that ! case, QLEFT is TRUE if the stepping search terminated unsucessfully ! at SMALL, and FALSE if the search terminated unsucessfully at BIG. ! ! Output, logical QHI, is defined only if QMFINV returns FALSE. In that ! case, it is TRUE if Y < F(X) at the termination of the search and FALSE ! if F(X) < Y. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) :: absstp real ( kind = rk ) :: abstol real ( kind = rk ) :: big real ( kind = rk ) fbig real ( kind = rk ) fsmall real ( kind = rk ) fx integer i99999 logical qbdd logical qcond logical qdum1 logical qdum2 logical qhi logical qincr logical qleft logical qlim logical qup real ( kind = rk ) :: relstp real ( kind = rk ) :: reltol real ( kind = rk ) :: small integer status real ( kind = rk ) step real ( kind = rk ) :: stpmul real ( kind = rk ) x real ( kind = rk ) xhi real ( kind = rk ) xlb real ( kind = rk ) xlo real ( kind = rk ) xsave real ( kind = rk ) xub real ( kind = rk ) yy real ( kind = rk ) zabsst real ( kind = rk ) zabsto real ( kind = rk ) zbig real ( kind = rk ) zrelst real ( kind = rk ) zrelto real ( kind = rk ) zsmall real ( kind = rk ) zstpmu save if ( 0 < status ) then if ( i99999 == 10 ) then go to 10 else if ( i99999 == 20 ) then go to 20 else if ( i99999 == 90 ) then go to 90 else if ( i99999 == 130 ) then go to 130 else if ( i99999 == 200 ) then go to 200 else if ( i99999 == 270 ) then go to 270 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DINVR - Fatal error!' write ( *, '(a)' ) ' Illegal value of I99999.' stop 1 end if end if qcond = .not. ( small <= x .and. x <= big ) if ( .not. ( small <= x .and. x <= big ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DINVR - Fatal error!' write ( *, '(a)' ) ' The values SMALL, X, BIG are not monotone.' stop 1 end if xsave = x ! ! See that SMALL and BIG bound the zero and set QINCR. ! x = small ! ! GET-function-VALUE ! i99999 = 10 status = 1 return 10 continue fsmall = fx x = big ! ! GET-function-VALUE ! i99999 = 20 status = 1 return 20 continue fbig = fx qincr = ( fsmall < fbig ) if ( fsmall <= fbig ) then if ( 0.0D+00 < fsmall ) then status = -1 qleft = .true. qhi = .true. return end if if ( fbig < 0.0D+00 ) then status = -1 qleft = .false. qhi = .false. return end if else if ( fbig < fsmall ) then if ( fsmall < 0.0D+00 ) then status = -1 qleft = .true. qhi = .false. return end if if ( 0.0D+00 < fbig ) then status = -1 qleft = .false. qhi = .true. return end if end if x = xsave step = max ( absstp, relstp * abs ( x ) ) ! ! YY = F(X) - Y ! GET-function-VALUE ! i99999 = 90 status = 1 return 90 continue yy = fx if ( yy == 0.0D+00 ) then status = 0 return end if ! 100 continue qup = ( qincr .and. ( yy < 0.0D+00 ) ) .or. & ( .not. qincr .and. ( 0.0D+00 < yy ) ) ! ! Handle case in which we must step higher. ! if (.not. qup ) then go to 170 end if xlb = xsave xub = min ( xlb + step, big ) go to 120 110 continue if ( qcond ) then go to 150 end if ! ! YY = F(XUB) - Y ! 120 continue x = xub ! ! GET-function-VALUE ! i99999 = 130 status = 1 return 130 continue yy = fx qbdd = ( qincr .and. ( 0.0D+00 <= yy ) ) .or. & ( .not. qincr .and. ( yy <= 0.0D+00 ) ) qlim = ( big <= xub ) qcond = qbdd .or. qlim if ( .not. qcond ) then step = stpmul * step xlb = xub xub = min ( xlb + step, big ) end if go to 110 150 continue if ( qlim .and. .not. qbdd ) then status = -1 qleft = .false. qhi = .not. qincr x = big return end if go to 240 ! ! Handle the case in which we must step lower. ! 170 continue xub = xsave xlb = max ( xub - step, small ) go to 190 180 continue if ( qcond ) then go to 220 end if ! ! YY = F(XLB) - Y ! 190 continue x = xlb ! ! GET-function-VALUE ! i99999 = 200 status = 1 return 200 continue yy = fx qbdd = ( qincr .and. ( yy <= 0.0D+00 ) ) .or. & ( .not. qincr .and. ( 0.0D+00 <= yy ) ) qlim = xlb <= small qcond = qbdd .or. qlim if ( .not. qcond ) then step = stpmul * step xub = xlb xlb = max ( xub - step, small ) end if go to 180 220 continue if ( qlim .and. ( .not. qbdd ) ) then status = -1 qleft = .true. qhi = qincr x = small return end if 240 continue call dstzr ( xlb, xub, abstol, reltol ) ! ! If we reach here, XLB and XUB bound the zero of F. ! status = 0 go to 260 250 continue if ( status /= 1 ) then x = xlo status = 0 return end if 260 continue call dzror ( status, x, fx, xlo, xhi, qdum1, qdum2 ) if ( status /= 1 ) then go to 250 end if ! ! GET-function-VALUE ! i99999 = 270 status = 1 return 270 continue go to 250 entry dstinv ( zsmall, zbig, zabsst, zrelst, zstpmu, zabsto, zrelto ) !*****************************************************************************80 ! !! DSTINV SeT INverse finder - Reverse Communication ! ! Discussion: ! ! This routine is given a monotone function F, and a value Y, ! and seeks an argument value X such that F(X) = Y. ! ! This routine uses reverse communication -- see DINVR. ! This routine sets quantities needed by DINVR. ! ! F must be a monotone function, the results of QMFINV are ! otherwise undefined. QINCR must be TRUE if F is nondecreasing ! and FALSE if F is nonincreasing. ! ! QMFINV will return TRUE if and only if F(SMALL) and ! F(BIG) bracket Y, i. e., ! QINCR is TRUE and F(SMALL) <= Y <= F(BIG) or ! QINCR is FALSE and F(BIG) <= Y <= F(SMALL) ! ! If QMFINV returns TRUE, then the X returned satisfies ! the following condition. Let ! TOL(X) = MAX ( ABSTOL, RELTOL * ABS ( X ) ) ! then if QINCR is TRUE, ! F(X-TOL(X)) <= Y <= F(X+TOL(X)) ! and if QINCR is FALSE ! F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X)) ! ! Compares F(X) with Y for the input value of X then uses QINCR ! to determine whether to step left or right to bound the ! desired X. The initial step size is ! ! max ( ABSSTP, RELSTP * ABS ( S ) ) ! ! for the input value of X. ! ! Iteratively steps right or left until it bounds X. ! At each step which doesn't bound X, the step size is doubled. ! The routine is careful never to step beyond SMALL or BIG. If ! it hasn't bounded X at SMALL or BIG, QMFINV returns FALSE ! after setting QLEFT and QHI. ! ! If X is successfully bounded then Algorithm R of the paper ! Bus and Dekker is employed to find the zero of the function F(X)-Y. ! This is routine QRZERO. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Reference: ! ! JCP Bus, TJ Dekker, ! Two Efficient Algorithms with Guaranteed Convergence for ! Finding a Zero of a Function, ! ACM Transactions on Mathematical Software, ! Volume 1, Number 4, pages 330-345, 1975. ! ! Parameters: ! ! Input, real ( kind = rk ) ZSMALL, ZBIG, the left and right endpoints ! of the interval to be searched for a solution. ! ! Input, real ( kind = rk ) ZABSST, ZRELSTP, the initial step size in ! the search is max ( ZABSST, ZRELST * abs ( X ) ). ! ! Input, real ( kind = rk ) STPMUL. When a step doesn't bound the zero, ! the stepsize is multiplied by STPMUL and another step taken. A ! popular value is 2.0. ! ! Input, real ( kind = rk ) ABSTOL, RELTOL, two numbers that determine ! the accuracy of the solution ! small = zsmall big = zbig absstp = zabsst relstp = zrelst stpmul = zstpmu abstol = zabsto reltol = zrelto return end function dlanor ( x ) !*****************************************************************************80 ! !! DLANOR evaluates the logarithm of the asymptotic Normal CDF. ! ! Discussion: ! ! This routine computes the logarithm of the cumulative normal distribution ! from abs ( x ) to infinity for 5 <= abs ( X ). ! ! The relative error at X = 5 is about 0.5D-5. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions ! 1966, Formula 26.2.12. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the value at which the Normal CDF is to be ! evaluated. It is assumed that 5 <= abs ( X ). ! ! Output, real ( kind = rk ) DLANOR, the logarithm of the asymptotic ! Normal CDF. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alnrel real ( kind = rk ) approx real ( kind = rk ), save, dimension ( 0:11 ) :: coef = (/ & -1.0D+00, 3.0D+00, -15.0D+00, 105.0D+00, -945.0D+00, & 10395.0D+00, -135135.0D+00, 2027025.0D+00, -34459425.0D+00, & 654729075.0D+00, -13749310575D+00, 316234143225.0D+00 /) real ( kind = rk ) correc real ( kind = rk ), parameter :: dlsqpi = 0.91893853320467274177D+00 real ( kind = rk ) eval_pol real ( kind = rk ) dlanor real ( kind = rk ) x real ( kind = rk ) xx real ( kind = rk ) xx2 xx = abs ( x ) if ( abs ( x ) < 5.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DLANOR - Fatal error!' write ( *, '(a)' ) ' The argument X is too small.' end if approx = - dlsqpi - 0.5D+00 * x * x - log ( abs ( x ) ) xx2 = xx * xx correc = eval_pol ( coef, 11, 1.0D+00 / xx2 ) / xx2 correc = alnrel ( correc ) dlanor = approx + correc return end function dstrem ( z ) !*****************************************************************************80 ! !! DSTREM computes the Sterling remainder ln ( Gamma ( Z ) ) - Sterling ( Z ). ! ! Discussion: ! ! This routine returns ! ! ln ( Gamma ( Z ) ) - Sterling ( Z ) ! ! where Sterling(Z) is Sterling's approximation to ln ( Gamma ( Z ) ). ! ! Sterling(Z) = ln ( sqrt ( 2 * PI ) ) + ( Z - 0.5 ) * ln ( Z ) - Z ! ! If 6 <= Z, the routine uses 9 terms of a series in Bernoulli numbers, ! with values calculated using Maple. ! ! Otherwise, the difference is computed explicitly. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Parameters: ! ! Input, real ( kind = rk ) Z, the value at which the Sterling ! remainder is to be calculated. Z must be positive. ! ! Output, real ( kind = rk ) DSTREM, the Sterling remainder. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ncoef = 9 real ( kind = rk ), parameter, dimension ( 0:ncoef ) :: coef = (/ & 0.0D+00, & 0.0833333333333333333333333333333D+00, & -0.00277777777777777777777777777778D+00, & 0.000793650793650793650793650793651D+00, & -0.000595238095238095238095238095238D+00, & 0.000841750841750841750841750841751D+00, & -0.00191752691752691752691752691753D+00, & 0.00641025641025641025641025641026D+00, & -0.0295506535947712418300653594771D+00, & 0.179644372368830573164938490016D+00 /) real ( kind = rk ) dstrem real ( kind = rk ) eval_pol real ( kind = rk ) gamma_log real ( kind = rk ), parameter :: hln2pi = 0.91893853320467274178D+00 real ( kind = rk ) sterl real ( kind = rk ) z if ( z <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DSTREM - Fatal error!' write ( *, '(a)' ) ' Zero or negative argument Z.' stop end if if ( 6.0D+00 < z ) then dstrem = eval_pol ( coef, ncoef, 1.0D+00 / z**2 ) * z else sterl = hln2pi + ( z - 0.5D+00 ) * log ( z ) - z dstrem = gamma_log ( z ) - sterl end if return end function dt1 ( p, q, df ) !*****************************************************************************80 ! !! DT1 computes an approximate inverse of the cumulative T distribution. ! ! Discussion: ! ! This routine returns the inverse of the T distribution function, that is, ! the integral from 0 to INVT of the T density is P. This is an ! initial approximation. ! ! Thanks to Charles Katholi for pointing out that the RESHAPE ! function should not use a range in the "SHAPE" field (0:4,4), ! but simply the number of rows and columns (5,4), JVB, 04 May 2006. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Parameters: ! ! Input, real ( kind = rk ) P, Q, the value whose inverse from the ! T distribution CDF is desired, and the value (1-P). ! ! Input, real ( kind = rk ) DF, the number of degrees of freedom of the ! T distribution. ! ! Output, real ( kind = rk ) DT1, the approximate value of X for which ! the T density CDF with DF degrees of freedom has value P. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), dimension(0:4,4) :: coef = reshape ( (/ & 1.0D+00, 1.0D+00, 0.0D+00, 0.0D+00, 0.0D+00, & 3.0D+00, 16.0D+00, 5.0D+00, 0.0D+00, 0.0D+00, & -15.0D+00, 17.0D+00, 19.0D+00, 3.0D+00, 0.0D+00, & -945.0D+00, -1920.0D+00, 1482.0D+00, 776.0D+00, 79.0D+00/), (/ 5, 4 /) ) real ( kind = rk ), parameter, dimension ( 4 ) :: denom = (/ & 4.0D+00, 96.0D+00, 384.0D+00, 92160.0D+00 /) real ( kind = rk ) denpow real ( kind = rk ) eval_pol real ( kind = rk ) df real ( kind = rk ) dinvnr real ( kind = rk ) dt1 integer i integer, parameter, dimension ( 4 ) :: ideg = (/ 1, 2, 3, 4 /) real ( kind = rk ) p real ( kind = rk ) q real ( kind = rk ) sum1 real ( kind = rk ) term real ( kind = rk ) x real ( kind = rk ) xp real ( kind = rk ) xx x = abs ( dinvnr ( p, q ) ) xx = x * x sum1 = x denpow = 1.0D+00 do i = 1, 4 term = eval_pol ( coef(0,i), ideg(i), xx ) * x denpow = denpow * df sum1 = sum1 + term / ( denpow * denom(i) ) end do if ( 0.5D+00 <= p ) then xp = sum1 else xp = -sum1 end if dt1 = xp return end subroutine dzror ( status, x, fx, xlo, xhi, qleft, qhi ) !*****************************************************************************80 ! !! DZROR seeks a zero of a function, using reverse communication. ! ! Discussion: ! ! This routine performs the zero finding. STZROR must have been called ! before this routine in order to set its parameters. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Reference: ! ! JCP Bus, TJ Dekker, ! Two Efficient Algorithms with Guaranteed Convergence for ! Finding a Zero of a Function, ! ACM Transactions on Mathematical Software, ! Volume 1, Number 4, pages 330-345, 1975. ! ! Parameters: ! ! Input/output, integer STATUS. At the beginning of a zero ! finding problem, STATUS should be set to 0 and ZROR invoked. The value ! of other parameters will be ignored on this call. ! When ZROR needs the function evaluated, it will set ! STATUS to 1 and return. The value of the function ! should be set in FX and ZROR again called without ! changing any of its other parameters. ! When ZROR has finished without error, it will return ! with STATUS 0. In that case (XLO,XHI) bound the answe ! If ZROR finds an error (which implies that F(XLO)-Y an ! F(XHI)-Y have the same sign, it returns STATUS -1. In ! this case, XLO and XHI are undefined. ! ! Output, real ( kind = rk ) X, the value of X at which F(X) is to ! be evaluated. ! ! Input, real ( kind = rk ) FX, the value of F(X), which must be calculated ! by the user when ZROR has returned on the previous call with STATUS = 1. ! ! Output, real ( kind = rk ) XLO, XHI, are lower and upper bounds for the ! solution when ZROR returns with STATUS = 0. ! ! Output, logical QLEFT,is TRUE if the stepping search terminated ! unsucessfully at XLO. If it is FALSE, the search terminated ! unsucessfully at XHI. ! ! Output, logical QHI, is TRUE if Y < F(X) at the termination of the ! search and FALSE if F(X) < Y at the termination of the search. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) abstol real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) d integer ext real ( kind = rk ) fa real ( kind = rk ) fb real ( kind = rk ) fc real ( kind = rk ) fd real ( kind = rk ) fda real ( kind = rk ) fdb logical first real ( kind = rk ) ftol real ( kind = rk ) fx integer i99999 real ( kind = rk ) m real ( kind = rk ) mb real ( kind = rk ) p real ( kind = rk ) q logical qhi logical qleft logical qrzero real ( kind = rk ) reltol integer status real ( kind = rk ) tol real ( kind = rk ) w real ( kind = rk ) x real ( kind = rk ) xhi real ( kind = rk ) xlo real ( kind = rk ) :: xxhi = 0.0D+00 real ( kind = rk ) :: xxlo = 0.0D+00 real ( kind = rk ) zabstl real ( kind = rk ) zreltl real ( kind = rk ) zx real ( kind = rk ) zxhi real ( kind = rk ) zxlo save ftol(zx) = 0.5D+00 * max ( abstol, reltol * abs ( zx ) ) if ( 0 < status ) then go to 280 end if xlo = xxlo xhi = xxhi b = xlo x = xlo ! ! GET-function-VALUE ! i99999 = 10 go to 270 10 continue fb = fx xlo = xhi a = xlo x = xlo ! ! GET-function-VALUE ! i99999 = 20 go to 270 ! ! Check that F(ZXLO) < 0 < F(ZXHI) or F(ZXLO) > 0 > F(ZXHI) ! 20 continue if ( fb < 0.0D+00 ) then if ( fx < 0.0D+00 ) then status = -1 qleft = ( fx < fb ) qhi = .false. return end if end if if ( 0.0D+00 < fb ) then if ( 0.0D+00 < fx ) then status = -1 qleft = ( fb < fx ) qhi = .true. return end if end if fa = fx first = .true. 70 continue c = a fc = fa ext = 0 80 continue if ( abs ( fc ) < abs ( fb ) ) then if ( c == a ) then d = a fd = fa end if a = b fa = fb xlo = c b = xlo fb = fc c = a fc = fa end if tol = ftol ( xlo ) m = ( c + b ) * 0.5D+00 mb = m - b if ( .not. ( tol < abs ( mb ) ) ) then go to 240 end if if ( 3 < ext ) then w = mb go to 190 end if ! 110 continue tol = sign ( tol, mb ) p = ( b - a ) * fb ! ! I had to insert a rudimentary check on the divisions here ! to avoid ninny errors, JVB, 09 June 2004. ! if ( first ) then q = fa - fb first = .false. else if ( d == b ) then fdb = 1.0D+00 else fdb = ( fd - fb ) / ( d - b ) end if if ( d == a ) then fda = 1.0D+00 else fda = ( fd - fa ) / ( d - a ) end if p = fda * p q = fdb * fa - fda * fb end if ! 130 continue if ( p < 0.0D+00 ) then p = -p q = -q end if ! 140 continue if ( ext == 3 ) then p = p * 2.0D+00 end if if (.not. ( ( p * 1.0D+00 ) == 0.0D+00 .or. p <= ( q * tol ) ) ) then go to 150 end if w = tol go to 180 150 continue if ( p < mb * q ) then w = p / q else w = mb end if 180 continue 190 continue d = a fd = fa a = b fa = fb b = b + w xlo = b x = xlo ! ! GET-function-VALUE ! i99999 = 200 go to 270 200 continue fb = fx if ( 0.0D+00 <= fc * fb ) then go to 70 else if ( w == mb ) then ext = 0 else ext = ext + 1 end if go to 80 end if 240 continue xhi = c qrzero = ( 0.0D+00 <= fc .and. fb <= 0.0D+00 ) .or. & ( fc < 0.0D+00 .and. fb >= 0.0D+00 ) if ( qrzero ) then status = 0 else status = -1 end if return entry dstzr ( zxlo, zxhi, zabstl, zreltl ) !*****************************************************************************80 ! !! DSTZR - SeT ZeRo finder - Reverse communication version ! ! Discussion: ! ! This routine sets quantities needed by ZROR. The function of ZROR ! and the quantities set is given here. ! ! Given a function F, find XLO such that F(XLO) = 0. ! ! Input condition. F is a real ( kind = rk ) function of a single ! real ( kind = rk ) argument and XLO and XHI are such that ! F(XLO)*F(XHI) <= 0.0 ! ! If the input condition is met, QRZERO returns .TRUE. ! and output values of XLO and XHI satisfy the following ! F(XLO)*F(XHI) <= 0. ! ABS ( F(XLO) ) <= ABS ( F(XHI) ) ! ABS ( XLO - XHI ) <= TOL(X) ! where ! TOL(X) = MAX ( ABSTOL, RELTOL * ABS ( X ) ) ! ! If this algorithm does not find XLO and XHI satisfying ! these conditions then QRZERO returns .FALSE. This ! implies that the input condition was not met. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Reference: ! ! JCP Bus, TJ Dekker, ! Two Efficient Algorithms with Guaranteed Convergence for ! Finding a Zero of a Function, ! ACM Transactions on Mathematical Software, ! Volume 1, Number 4, pages 330-345, 1975. ! ! Parameters: ! ! Input, real ( kind = rk ) XLO, XHI, the left and right endpoints of the ! interval to be searched for a solution. ! ! Input, real ( kind = rk ) ABSTOL, RELTOL, two numbers that determine ! the accuracy of the solution. ! xxlo = zxlo xxhi = zxhi abstol = zabstl reltol = zreltl return ! ! TO GET-function-VALUE ! 270 status = 1 return 280 continue if ( i99999 == 10 ) then go to 10 else if ( i99999 == 20 ) then go to 20 else if ( i99999 == 200 ) then go to 200 else write ( *, '(a)' ) '' write ( *, '(a)' ) 'DSTZR - Fatal error!' write ( *, '(a)' ) ' Illegal value of I99999.' stop 1 end if end subroutine erf_values ( n_data, x, fx ) !*****************************************************************************80 ! !! ERF_VALUES returns some values of the ERF or "error" function. ! ! Discussion: ! ! ERF(X) = ( 2 / sqrt ( PI ) * integral ( 0 <= T <= X ) exp ( - T^2 ) dT ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 April 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! 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 = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 21 real ( kind = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.0000000000D+00, 0.1124629160D+00, 0.2227025892D+00, 0.3286267595D+00, & 0.4283923550D+00, 0.5204998778D+00, 0.6038560908D+00, 0.6778011938D+00, & 0.7421009647D+00, 0.7969082124D+00, 0.8427007929D+00, 0.8802050696D+00, & 0.9103139782D+00, 0.9340079449D+00, 0.9522851198D+00, 0.9661051465D+00, & 0.9763483833D+00, 0.9837904586D+00, 0.9890905016D+00, 0.9927904292D+00, & 0.9953222650D+00 /) integer n_data real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 0.0D+00, 0.1D+00, 0.2D+00, 0.3D+00, & 0.4D+00, 0.5D+00, 0.6D+00, 0.7D+00, & 0.8D+00, 0.9D+00, 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 function error_f ( x ) !*****************************************************************************80 ! !! ERROR_F evaluates the error function. ! ! Discussion: ! ! Since some compilers already supply a routine named ERF which evaluates ! the error function, this routine has been given a distinct, if ! somewhat unnatural, name. ! ! The function is defined by: ! ! ERF(X) = ( 2 / sqrt ( PI ) ) ! * Integral ( 0 <= T <= X ) EXP ( - T^2 ) dT. ! ! Properties of the function include: ! ! Limit ( X -> -Infinity ) ERF(X) = -1.0; ! ERF(0) = 0.0; ! ERF(0.476936...) = 0.5; ! Limit ( X -> +Infinity ) ERF(X) = +1.0. ! ! 0.5 * ( ERF(X/sqrt(2)) + 1 ) = Normal_01_CDF(X) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the argument. ! ! Output, real ( kind = rk ) ERF, the value of the error function at X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter, dimension ( 5 ) :: a = (/ & 0.771058495001320D-04, & -0.133733772997339D-02, & 0.323076579225834D-01, & 0.479137145607681D-01, & 0.128379167095513D+00 /) real ( kind = rk ) ax real ( kind = rk ), parameter, dimension ( 3 ) :: b = (/ & 0.301048631703895D-02, & 0.538971687740286D-01, & 0.375795757275549D+00 /) real ( kind = rk ) bot real ( kind = rk ), parameter :: c = 0.564189583547756D+00 real ( kind = rk ) error_f real ( kind = rk ), dimension ( 8 ) :: p = (/ & -1.36864857382717D-07, 5.64195517478974D-01, & 7.21175825088309D+00, 4.31622272220567D+01, & 1.52989285046940D+02, 3.39320816734344D+02, & 4.51918953711873D+02, 3.00459261020162D+02 /) real ( kind = rk ), dimension ( 8 ) :: q = (/ & 1.00000000000000D+00, 1.27827273196294D+01, & 7.70001529352295D+01, 2.77585444743988D+02, & 6.38980264465631D+02, 9.31354094850610D+02, & 7.90950925327898D+02, 3.00459260956983D+02 /) real ( kind = rk ), dimension ( 5 ) :: r = (/ & 2.10144126479064D+00, 2.62370141675169D+01, & 2.13688200555087D+01, 4.65807828718470D+00, & 2.82094791773523D-01 /) real ( kind = rk ), parameter, dimension ( 4 ) :: s = (/ & 9.41537750555460D+01, 1.87114811799590D+02, & 9.90191814623914D+01, 1.80124575948747D+02 /) real ( kind = rk ) t real ( kind = rk ) top real ( kind = rk ) x real ( kind = rk ) x2 ax = abs ( x ) if ( ax <= 0.5D+00 ) then t = x * x top = (((( a(1) * t & + a(2) ) * t & + a(3) ) * t & + a(4) ) * t & + a(5) ) + 1.0D+00 bot = (( b(1) * t + b(2) ) * t + b(3) ) * t + 1.0D+00 error_f = ax * ( top / bot ) else if ( ax <= 4.0D+00 ) then top = (((((( p(1) * ax & + p(2) ) * ax & + p(3) ) * ax & + p(4) ) * ax & + p(5) ) * ax & + p(6) ) * ax & + p(7) ) * ax & + p(8) bot = (((((( q(1) * ax + q(2) ) * ax + q(3) ) * ax + q(4) ) * ax & + q(5) ) * ax + q(6) ) * ax + q(7) ) * ax + q(8) error_f = 0.5D+00 & + ( 0.5D+00 - exp ( - x * x ) * top / bot ) else if ( ax < 5.8D+00 ) then x2 = x * x t = 1.0D+00 / x2 top = ((( r(1) * t + r(2) ) * t + r(3) ) * t + r(4) ) * t + r(5) bot = ((( s(1) * t + s(2) ) * t + s(3) ) * t + s(4) ) * t & + 1.0D+00 error_f = ( c - top / ( x2 * bot )) / ax error_f = 0.5D+00 & + ( 0.5D+00 - exp ( - x2 ) * error_f ) else error_f = 1.0D+00 end if if ( x < 0.0D+00 ) then error_f = -error_f end if return end function error_fc ( ind, x ) !*****************************************************************************80 ! !! ERROR_FC evaluates the complementary error function. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, integer IND, chooses the scaling. ! If IND is nonzero, then the value returned has been multiplied by ! EXP(X*X). ! ! Input, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) ERROR_FC, the value of the complementary ! error function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), dimension ( 5 ) :: a = (/ & 0.771058495001320D-04, -0.133733772997339D-02, & 0.323076579225834D-01, 0.479137145607681D-01, & 0.128379167095513D+00 /) real ( kind = rk ) ax real ( kind = rk ), dimension(3) :: b = (/ & 0.301048631703895D-02, & 0.538971687740286D-01, & 0.375795757275549D+00 /) real ( kind = rk ) bot real ( kind = rk ), parameter :: c = 0.564189583547756D+00 real ( kind = rk ) e real ( kind = rk ) error_fc real ( kind = rk ) exparg integer ind real ( kind = rk ), dimension ( 8 ) :: p = (/ & -1.36864857382717D-07, 5.64195517478974D-01, & 7.21175825088309D+00, 4.31622272220567D+01, & 1.52989285046940D+02, 3.39320816734344D+02, & 4.51918953711873D+02, 3.00459261020162D+02 /) real ( kind = rk ), dimension ( 8 ) :: q = (/ & 1.00000000000000D+00, 1.27827273196294D+01, & 7.70001529352295D+01, 2.77585444743988D+02, & 6.38980264465631D+02, 9.31354094850610D+02, & 7.90950925327898D+02, 3.00459260956983D+02 /) real ( kind = rk ), dimension ( 5 ) :: r = (/ & 2.10144126479064D+00, 2.62370141675169D+01, & 2.13688200555087D+01, 4.65807828718470D+00, & 2.82094791773523D-01 /) real ( kind = rk ), dimension ( 4 ) :: s = (/ & 9.41537750555460D+01, 1.87114811799590D+02, & 9.90191814623914D+01, 1.80124575948747D+02 /) real ( kind = rk ) t real ( kind = rk ) top real ( kind = rk ) w real ( kind = rk ) x ! ! ABS ( X ) <= 0.5 ! ax = abs ( x ) if ( ax <= 0.5D+00 ) then t = x * x top = (((( a(1) * t + a(2) ) * t + a(3) ) * t + a(4) ) * t + a(5) ) & + 1.0D+00 bot = (( b(1) * t + b(2) ) * t + b(3) ) * t + 1.0D+00 error_fc = 0.5D+00 + ( 0.5D+00 & - x * ( top / bot ) ) if ( ind /= 0 ) then error_fc = exp ( t ) * error_fc end if return end if ! ! 0.5 < abs ( X ) <= 4 ! if ( ax <= 4.0D+00 ) then top = (((((( p(1) * ax + p(2)) * ax + p(3)) * ax + p(4)) * ax & + p(5)) * ax + p(6)) * ax + p(7)) * ax + p(8) bot = (((((( q(1) * ax + q(2)) * ax + q(3)) * ax + q(4)) * ax & + q(5)) * ax + q(6)) * ax + q(7)) * ax + q(8) error_fc = top / bot ! ! 4 < ABS ( X ) ! else if ( x <= -5.6D+00 ) then if ( ind == 0 ) then error_fc = 2.0D+00 else error_fc = 2.0D+00 * exp ( x * x ) end if return end if if ( ind == 0 ) then if ( 100.0D+00 < x ) then error_fc = 0.0D+00 return end if if ( -exparg ( 1 ) < x * x ) then error_fc = 0.0D+00 return end if end if t = ( 1.0D+00 / x )**2 top = ((( r(1) * t + r(2) ) * t + r(3) ) * t + r(4) ) * t + r(5) bot = ((( s(1) * t + s(2) ) * t + s(3) ) * t + s(4) ) * t & + 1.0D+00 error_fc = ( c - t * top / bot ) / ax end if ! ! Final assembly. ! if ( ind /= 0 ) then if ( x < 0.0D+00 ) then error_fc = 2.0D+00 * exp ( x * x ) - error_fc end if else w = x * x t = w e = w - t error_fc = (( 0.5D+00 & + ( 0.5D+00 - e ) ) * exp ( - t ) ) * error_fc if ( x < 0.0D+00 ) then error_fc = 2.0D+00 - error_fc end if end if return end function esum ( mu, x ) !*****************************************************************************80 ! !! ESUM evaluates exp ( MU + X ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Input: ! ! integer MU, part of the argument. ! ! real ( kind = rk ) X, part of the argument. ! ! Output: ! ! real ( kind = rk ) ESUM, the value of exp ( MU + X ). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) esum integer mu real ( kind = rk ) w real ( kind = rk ) x if ( x <= 0.0D+00 ) then if ( 0 <= mu ) then w = mu + x if ( w <= 0.0D+00 ) then esum = exp ( w ) return end if end if else if ( 0.0D+00 < x ) then if ( mu <= 0 ) then w = mu + x if ( 0.0D+00 <= w ) then esum = exp ( w ) return end if end if end if w = mu esum = exp ( w ) * exp ( x ) return end function eval_pol ( a, n, x ) !*****************************************************************************80 ! !! EVAL_POL evaluates a polynomial at X. ! ! Discussion: ! ! EVAL_POL = A(0) + A(1)*X + ... + A(N)*X^N ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Input: ! ! real ( kind = rk ) A(0:N), coefficients of the polynomial. ! ! integer N, length of A. ! ! real ( kind = rk ) X, the point at which the polynomial ! is to be evaluated. ! ! Output: ! ! real ( kind = rk ) EVAL_POL, the value of the polynomial at X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(0:n) real ( kind = rk ) eval_pol integer i real ( kind = rk ) term real ( kind = rk ) x term = a(n) do i = n - 1, 0, -1 term = term * x + a(i) end do eval_pol = term return end function exparg ( l ) !*****************************************************************************80 ! !! EXPARG returns the largest or smallest legal argument for EXP. ! ! Discussion: ! ! Only an approximate limit for the argument of EXP is desired. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, integer L, indicates which limit is desired. ! If L = 0, then the largest positive argument for EXP is desired. ! Otherwise, the largest negative argument for EXP for which the ! result is nonzero is desired. ! ! Output, real ( kind = rk ) EXPARG, the desired value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer b real ( kind = rk ) exparg integer ipmpar integer l real ( kind = rk ) lnb integer m ! ! Get the arithmetic base. ! b = ipmpar(4) ! ! Compute the logarithm of the arithmetic base. ! if ( b == 2 ) then lnb = 0.69314718055995D+00 else if ( b == 8 ) then lnb = 2.0794415416798D+00 else if ( b == 16 ) then lnb = 2.7725887222398D+00 else lnb = log ( real ( b, kind = rk ) ) end if if ( l /= 0 ) then m = ipmpar(9) - 1 exparg = 0.99999D+00 * ( m * lnb ) else m = ipmpar(10) exparg = 0.99999D+00 * ( m * lnb ) end if return end subroutine f_cdf_values ( n_data, a, b, x, fx ) !*****************************************************************************80 ! !! F_CDF_VALUES returns some values of the F CDF test function. ! ! Discussion: ! ! The value of F_CDF ( DFN, DFD, X ) can be evaluated in Mathematica by ! commands like: ! ! Needs["Statistics`ContinuousDistributions`"] ! CDF[FRatioDistribution[ DFN, DFD ], X ] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 June 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, 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, real ( kind = rk ) X, the ! arguments of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.500000D+00, 0.499971D+00, 0.499603D+00, 0.749699D+00, & 0.750466D+00, 0.751416D+00, 0.899987D+00, 0.899713D+00, & 0.900285D+00, 0.950025D+00, 0.950057D+00, 0.950193D+00, & 0.975013D+00, 0.990002D+00, 0.994998D+00, 0.999000D+00, & 0.568799D+00, 0.535145D+00, 0.514343D+00, 0.500000D+00 /) integer n_data real ( kind = rk ) x real ( kind = rk ), 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 subroutine f_noncentral_cdf_values ( n_data, a, b, lambda, x, fx ) !*****************************************************************************80 ! !! F_NONCENTRAL_CDF_VALUES returns some values of the F CDF test function. ! ! Discussion: ! ! The value of NONCENTRAL_F_CDF ( DFN, DFD, LAMDA, X ) can be evaluated ! in Mathematica by commands like: ! ! Needs["Statistics`ContinuousDistributions`"] ! CDF[NoncentralFRatioDistribution[ DFN, DFD, LAMBDA ], X ] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 June 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, 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, B, real ( kind = rk ) LAMBDA, the ! parameters of the function. ! ! Output, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 22 integer a integer, save, dimension ( n_max ) :: a_vec = (/ & 1, 1, 1, 1, & 1, 1, 1, 1, & 1, 1, 2, 2, & 3, 3, 4, 4, & 5, 5, 6, 6, & 8, 16 /) integer b integer, save, dimension ( n_max ) :: b_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 = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.500000D+00, 0.636783D+00, 0.584092D+00, 0.323443D+00, & 0.450119D+00, 0.607888D+00, 0.705928D+00, 0.772178D+00, & 0.819105D+00, 0.317035D+00, 0.432722D+00, 0.450270D+00, & 0.426188D+00, 0.337744D+00, 0.422911D+00, 0.692767D+00, & 0.363217D+00, 0.421005D+00, 0.426667D+00, 0.446402D+00, & 0.844589D+00, 0.816368D+00 /) real ( kind = rk ) lambda real ( kind = rk ), save, dimension ( n_max ) :: lambda_vec = (/ & 0.00D+00, 0.000D+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 real ( kind = rk ) x real ( kind = rk ), 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 a = 0 b = 0 lambda = 0.0D+00 x = 0.0D+00 fx = 0.0D+00 else a = a_vec(n_data) b = b_vec(n_data) lambda = lambda_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end function fpser ( a, b, x, eps ) !*****************************************************************************80 ! !! FPSER evaluates IX(A,B)(X) for very small B. ! ! Discussion: ! ! This routine is appropriate for use when ! ! B < min ( EPS, EPS * A ) ! ! and ! ! X <= 0.5. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) A, B, parameters of the function. ! ! Input, real ( kind = rk ) X, the point at which the function is to ! be evaluated. ! ! Input, real ( kind = rk ) EPS, a tolerance. ! ! Output, real ( kind = rk ) FPSER, the value of IX(A,B)(X). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) an real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) eps real ( kind = rk ) exparg real ( kind = rk ) fpser real ( kind = rk ) s real ( kind = rk ) t real ( kind = rk ) tol real ( kind = rk ) x fpser = 1.0D+00 if ( 1.0D-03 * eps < a ) then fpser = 0.0D+00 t = a * log ( x ) if ( t < exparg ( 1 ) ) then return end if fpser = exp ( t ) end if ! ! 1/B(A,B) = B ! fpser = ( b / a ) * fpser tol = eps / a an = a + 1.0D+00 t = x s = t / an do an = an + 1.0D+00 t = x * t c = t / an s = s + c if ( abs ( c ) <= tol ) then exit end if end do fpser = fpser * ( 1.0D+00 + a * s ) return end function gam1 ( a ) !*****************************************************************************80 ! !! GAM1 computes 1 / GAMMA(A+1) - 1 for -0.5 <= A <= 1.5 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) A, forms the argument of the Gamma function. ! ! Output, real ( kind = rk ) GAM1, the value of 1 / GAMMA ( A + 1 ) - 1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) bot real ( kind = rk ) d real ( kind = rk ) gam1 real ( kind = rk ), parameter, dimension ( 7 ) :: p = (/ & 0.577215664901533D+00, -0.409078193005776D+00, & -0.230975380857675D+00, 0.597275330452234D-01, & 0.766968181649490D-02, -0.514889771323592D-02, & 0.589597428611429D-03 /) real ( kind = rk ), dimension ( 5 ) :: q = (/ & 0.100000000000000D+01, 0.427569613095214D+00, & 0.158451672430138D+00, 0.261132021441447D-01, & 0.423244297896961D-02 /) real ( kind = rk ), dimension ( 9 ) :: r = (/ & -0.422784335098468D+00, -0.771330383816272D+00, & -0.244757765222226D+00, 0.118378989872749D+00, & 0.930357293360349D-03, -0.118290993445146D-01, & 0.223047661158249D-02, 0.266505979058923D-03, & -0.132674909766242D-03 /) real ( kind = rk ), parameter :: s1 = 0.273076135303957D+00 real ( kind = rk ), parameter :: s2 = 0.559398236957378D-01 real ( kind = rk ) t real ( kind = rk ) top real ( kind = rk ) w d = a - 0.5D+00 if ( 0.0D+00 < d ) then t = d - 0.5D+00 else t = a end if if ( t == 0.0D+00 ) then gam1 = 0.0D+00 else if ( 0.0D+00 < t ) then top = ((((( & p(7) & * t + p(6) ) & * t + p(5) ) & * t + p(4) ) & * t + p(3) ) & * t + p(2) ) & * t + p(1) bot = ((( q(5) * t + q(4) ) * t + q(3) ) * t + q(2) ) * t & + 1.0D+00 w = top / bot if ( d <= 0.0D+00 ) then gam1 = a * w else gam1 = ( t / a ) * ( ( w - 0.5D+00 ) & - 0.5D+00 ) end if else if ( t < 0.0D+00 ) then top = ((((((( & r(9) & * t + r(8) ) & * t + r(7) ) & * t + r(6) ) & * t + r(5) ) & * t + r(4) ) & * t + r(3) ) & * t + r(2) ) & * t + r(1) bot = ( s2 * t + s1 ) * t + 1.0D+00 w = top / bot if ( d <= 0.0D+00 ) then gam1 = a * ( ( w + 0.5D+00 ) + 0.5D+00 ) else gam1 = t * w / a end if end if return end function gamma_user ( a ) !*****************************************************************************80 ! !! gamma_user evaluates the gamma function. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Alfred Morris, ! Naval Surface Weapons Center, ! Dahlgren, Virginia. ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) A, the argument of the Gamma function. ! ! Output, real ( kind = rk ) gamma_user, the value of the Gamma function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) bot real ( kind = rk ), parameter :: d = 0.41893853320467274178D+00 real ( kind = rk ) exparg real ( kind = rk ) g real ( kind = rk ) gamma_user integer i integer j real ( kind = rk ) lnx integer m integer n real ( kind = rk ), dimension ( 7 ) :: p = (/ & 0.539637273585445D-03, 0.261939260042690D-02, & 0.204493667594920D-01, 0.730981088720487D-01, & 0.279648642639792D+00, 0.553413866010467D+00, & 1.0D+00 /) real ( kind = rk ), parameter :: pi = 3.1415926535898D+00 real ( kind = rk ), dimension ( 7 ) :: q = (/ & -0.832979206704073D-03, 0.470059485860584D-02, & 0.225211131035340D-01, -0.170458969313360D+00, & -0.567902761974940D-01, 0.113062953091122D+01, & 1.0D+00 /) real ( kind = rk ), parameter :: r1 = 0.820756370353826D-03 real ( kind = rk ), parameter :: r2 = -0.595156336428591D-03 real ( kind = rk ), parameter :: r3 = 0.793650663183693D-03 real ( kind = rk ), parameter :: r4 = -0.277777777770481D-02 real ( kind = rk ), parameter :: r5 = 0.833333333333333D-01 real ( kind = rk ) s real ( kind = rk ) t real ( kind = rk ) top real ( kind = rk ) w real ( kind = rk ) x real ( kind = rk ) z gamma_user = 0.0D+00 x = a if ( abs ( a ) < 15.0D+00 ) then ! ! Evaluation of GAMMA(A) for |A| < 15 ! t = 1.0D+00 m = int ( a ) - 1 ! ! Let T be the product of A-J when 2 <= A. ! if ( 0 <= m ) then do j = 1, m x = x - 1.0D+00 t = x * t end do x = x - 1.0D+00 ! ! Let T be the product of A+J WHEN A < 1 ! else t = a if ( a <= 0.0D+00 ) then m = - m - 1 do j = 1, m x = x + 1.0D+00 t = x * t end do x = ( x + 0.5D+00 ) + 0.5D+00 t = x * t if ( t == 0.0D+00 ) then return end if end if ! ! Check if 1/T can overflow. ! if ( abs ( t ) < 1.0D-30 ) then if ( 1.0001D+00 < abs ( t ) * huge ( t ) ) then gamma_user = 1.0D+00 / t end if return end if end if ! ! Compute Gamma(1 + X) for 0 <= X < 1. ! top = p(1) bot = q(1) do i = 2, 7 top = top * x + p(i) bot = bot * x + q(i) end do gamma_user = top / bot ! ! Termination. ! if ( 1.0D+00 <= a ) then gamma_user = gamma_user * t else gamma_user = gamma_user / t end if ! ! Evaluation of Gamma(A) FOR 15 <= ABS ( A ). ! else if ( 1000.0D+00 <= abs ( a ) ) then return end if if ( a <= 0.0D+00 ) then x = -a n = int ( x ) t = x - n if ( 0.9D+00 < t ) then t = 1.0D+00 - t end if s = sin ( pi * t ) / pi if ( mod ( n, 2 ) == 0 ) then s = -s end if if ( s == 0.0D+00 ) then return end if end if ! ! Compute the modified asymptotic sum. ! t = 1.0D+00 / ( x * x ) g = (((( r1 * t + r2 ) * t + r3 ) * t + r4 ) * t + r5 ) / x lnx = log ( x ) ! ! Final assembly. ! z = x g = ( d + g ) + ( z - 0.5D+00 ) & * ( lnx - 1.0D+00 ) w = g t = g - real ( w, kind = rk ) if ( 0.99999D+00 * exparg ( 0 ) < w ) then return end if gamma_user = exp ( w )* ( 1.0D+00 + t ) if ( a < 0.0D+00 ) then gamma_user = ( 1.0D+00 / ( gamma_user * s ) ) / x end if end if return end subroutine gamma_inc ( a, x, ans, qans, ind ) !*****************************************************************************80 ! !! GAMMA_INC evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Alfred Morris ! ! Parameters: ! ! Input, real ( kind = rk ) A, X, the arguments of the incomplete ! gamma ratio. A and X must be nonnegative. A and X cannot ! both be zero. ! ! Output, real ( kind = rk ) ANS, QANS. On normal output, ! ANS = P(A,X) and QANS = Q(A,X). However, ANS is set to 2 if ! A or X is negative, or both are 0, or when the answer is ! computationally indeterminate because A is extremely large ! and X is very close to A. ! ! Input, integer IND, indicates the accuracy request: ! 0, as much accuracy as possible. ! 1, to within 1 unit of the 6-th significant digit, ! otherwise, to within 1 unit of the 3rd significant digit. ! ! Local: ! ! ALOG10 = LN(10) ! RT2PIN = 1/SQRT(2*PI) ! RTPI = SQRT(PI) ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) a2n real ( kind = rk ) a2nm1 real ( kind = rk ) acc real ( kind = rk ), dimension ( 3 ) :: acc0 = (/ & 5.0D-15, 5.0D-07, 5.0D-04 /) real ( kind = rk ), parameter :: alog10 = 2.30258509299405D+00 real ( kind = rk ) am0 real ( kind = rk ) amn real ( kind = rk ) an real ( kind = rk ) an0 real ( kind = rk ) ans real ( kind = rk ) apn real ( kind = rk ) b2n real ( kind = rk ) b2nm1 real ( kind = rk ) big(3) real ( kind = rk ) c real ( kind = rk ) c0 real ( kind = rk ) c1 real ( kind = rk ) c2 real ( kind = rk ) c3 real ( kind = rk ) c4 real ( kind = rk ) c5 real ( kind = rk ) c6 real ( kind = rk ) cma real ( kind = rk ) d0(13) real ( kind = rk ) d1(12) real ( kind = rk ) d2(10) real ( kind = rk ) d3(8) real ( kind = rk ) d4(6) real ( kind = rk ) d5(4) real ( kind = rk ) d6(2) real ( kind = rk ) d10 real ( kind = rk ) d20 real ( kind = rk ) d30 real ( kind = rk ) d40 real ( kind = rk ) d50 real ( kind = rk ) d60 real ( kind = rk ) d70 real ( kind = rk ) e real ( kind = rk ) e0 real ( kind = rk ) e00(3) real ( kind = rk ) error_f real ( kind = rk ) error_fc real ( kind = rk ) g real ( kind = rk ) gam1 real ( kind = rk ) gamma real ( kind = rk ) h integer i integer ind integer iop real ( kind = rk ) j real ( kind = rk ) l integer m integer n integer n_max real ( kind = rk ) qans real ( kind = rk ) r real ( kind = rk ) rexp real ( kind = rk ) rlog real ( kind = rk ), parameter :: rt2pin = 0.398942280401433D+00 real ( kind = rk ) rta real ( kind = rk ), parameter :: rtpi = 1.77245385090552D+00 real ( kind = rk ) rtx real ( kind = rk ) s real ( kind = rk ) sum1 real ( kind = rk ) t real ( kind = rk ) t1 real ( kind = rk ) tol real ( kind = rk ) twoa real ( kind = rk ) u real ( kind = rk ) w real ( kind = rk ) wk(20) real ( kind = rk ) x real ( kind = rk ) x0 real ( kind = rk ) x00(3) real ( kind = rk ) y real ( kind = rk ) z data big(1)/20.0D+00/,big(2)/14.0D+00/,big(3)/10.0D+00/ data e00(1)/0.25D-03/,e00(2)/0.25D-01/,e00(3)/0.14D+00/ data x00(1)/31.0D+00/,x00(2)/17.0D+00/,x00(3)/9.7D+00/ data d0(1)/0.833333333333333D-01/ data d0(2)/-0.148148148148148D-01/ data d0(3)/0.115740740740741D-02/,d0(4)/0.352733686067019D-03/ data d0(5)/-0.178755144032922D-03/,d0(6)/0.391926317852244D-04/ data d0(7)/-0.218544851067999D-05/,d0(8)/-0.185406221071516D-05/ data d0(9)/0.829671134095309D-06/,d0(10)/-0.176659527368261D-06/ data d0(11)/0.670785354340150D-08/,d0(12)/0.102618097842403D-07/ data d0(13)/-0.438203601845335D-08/ data d10/-0.185185185185185D-02/,d1(1)/-0.347222222222222D-02/ data d1(2)/0.264550264550265D-02/,d1(3)/-0.990226337448560D-03/ data d1(4)/0.205761316872428D-03/,d1(5)/-0.401877572016461D-06/ data d1(6)/-0.180985503344900D-04/,d1(7)/0.764916091608111D-05/ data d1(8)/-0.161209008945634D-05/,d1(9)/0.464712780280743D-08/ data d1(10)/0.137863344691572D-06/,d1(11)/-0.575254560351770D-07/ data d1(12)/0.119516285997781D-07/ data d20/0.413359788359788D-02/,d2(1)/-0.268132716049383D-02/ data d2(2)/0.771604938271605D-03/,d2(3)/0.200938786008230D-05/ data d2(4)/-0.107366532263652D-03/,d2(5)/0.529234488291201D-04/ data d2(6)/-0.127606351886187D-04/,d2(7)/0.342357873409614D-07/ data d2(8)/0.137219573090629D-05/,d2(9)/-0.629899213838006D-06/ data d2(10)/0.142806142060642D-06/ data d30/0.649434156378601D-03/,d3(1)/0.229472093621399D-03/ data d3(2)/-0.469189494395256D-03/,d3(3)/0.267720632062839D-03/ data d3(4)/-0.756180167188398D-04/,d3(5)/-0.239650511386730D-06/ data d3(6)/0.110826541153473D-04/,d3(7)/-0.567495282699160D-05/ data d3(8)/0.142309007324359D-05/ data d40/-0.861888290916712D-03/,d4(1)/0.784039221720067D-03/ data d4(2)/-0.299072480303190D-03/,d4(3)/-0.146384525788434D-05/ data d4(4)/0.664149821546512D-04/,d4(5)/-0.396836504717943D-04/ data d4(6)/0.113757269706784D-04/ data d50/-0.336798553366358D-03/,d5(1)/-0.697281375836586D-04/ data d5(2)/0.277275324495939D-03/,d5(3)/-0.199325705161888D-03/ data d5(4)/0.679778047793721D-04/ data d60/0.531307936463992D-03/,d6(1)/-0.592166437353694D-03/ data d6(2)/0.270878209671804D-03/ data d70 / 0.344367606892378D-03/ e = epsilon ( 1.0D+00 ) if ( a < 0.0D+00 .or. x < 0.0D+00 ) then ans = 2.0D+00 return end if if ( a == 0.0D+00 .and. x == 0.0D+00 ) then ans = 2.0D+00 return end if if ( a * x == 0.0D+00 ) then if ( x <= a ) then ans = 0.0D+00 qans = 1.0D+00 else ans = 1.0D+00 qans = 0.0D+00 end if return end if iop = ind + 1 if ( iop /= 1 .and. iop /= 2 ) iop = 3 acc = max ( acc0(iop), e ) e0 = e00(iop) x0 = x00(iop) ! ! Select the appropriate algorithm. ! if ( 1.0D+00 <= a ) then go to 10 end if if ( a == 0.5D+00 ) then go to 390 end if if ( x < 1.1D+00 ) then go to 160 end if t1 = a * log ( x ) - x u = a * exp ( t1 ) if ( u == 0.0D+00 ) then ans = 1.0D+00 qans = 0.0D+00 return end if r = u * ( 1.0D+00 + gam1 ( a ) ) go to 250 10 continue if ( big(iop) <= a ) then go to 30 end if if ( x < a .or. x0 <= x ) then go to 20 end if twoa = a + a m = int ( twoa ) if ( twoa == real ( m, kind = rk ) ) then i = m / 2 if ( a == real ( i, kind = rk ) ) then go to 210 end if go to 220 end if 20 continue t1 = a * log ( x ) - x r = exp ( t1 ) / gamma ( a ) go to 40 30 continue l = x / a if ( l == 0.0D+00 ) then ans = 0.0D+00 qans = 1.0D+00 return end if s = 0.5D+00 + ( 0.5D+00 - l ) z = rlog ( l ) if ( 700.0D+00 / a <= z ) then go to 410 end if y = a * z rta = sqrt ( a ) if ( abs ( s ) <= e0 / rta ) then go to 330 end if if ( abs ( s ) <= 0.4D+00 ) then go to 270 end if t = ( 1.0D+00 / a )**2 t1 = ((( 0.75D+00 * t - 1.0D+00 ) * t + 3.5D+00 ) & * t - 105.0D+00 ) / ( a * 1260.0D+00 ) t1 = t1 - y r = rt2pin * rta * exp ( t1 ) 40 continue if ( r == 0.0D+00 ) then if ( x <= a ) then ans = 0.0D+00 qans = 1.0D+00 else ans = 1.0D+00 qans = 0.0D+00 end if return end if if ( x <= max ( a, alog10 ) ) then go to 50 end if if ( x < x0 ) then go to 250 end if go to 100 ! ! Taylor series for P/R. ! 50 continue apn = a + 1.0D+00 t = x / apn wk(1) = t n = 20 do i = 2, 20 apn = apn + 1.0D+00 t = t * ( x / apn ) if ( t <= 1.0D-03 ) then n = i exit end if wk(i) = t end do sum1 = t tol = 0.5D+00 * acc do apn = apn + 1.0D+00 t = t * ( x / apn ) sum1 = sum1 + t if ( t <= tol ) then exit end if end do n_max = n - 1 do m = 1, n_max n = n - 1 sum1 = sum1 + wk(n) end do ans = ( r / a ) * ( 1.0D+00 + sum1 ) qans = 0.5D+00 + ( 0.5D+00 - ans ) return ! ! Asymptotic expansion. ! 100 continue amn = a - 1.0D+00 t = amn / x wk(1) = t n = 20 do i = 2, 20 amn = amn - 1.0D+00 t = t * ( amn / x ) if ( abs ( t ) <= 1.0D-03 ) then n = i exit end if wk(i) = t end do sum1 = t do if ( abs ( t ) <= acc ) then exit end if amn = amn - 1.0D+00 t = t * ( amn / x ) sum1 = sum1 + t end do n_max = n - 1 do m = 1, n_max n = n - 1 sum1 = sum1 + wk(n) end do qans = ( r / x ) * ( 1.0D+00 + sum1 ) ans = 0.5D+00 + ( 0.5D+00 - qans ) return ! ! Taylor series for P(A,X)/X^A ! 160 continue an = 3.0D+00 c = x sum1 = x / ( a + 3.0D+00 ) tol = 3.0D+00 * acc / ( a + 1.0D+00 ) do an = an + 1.0D+00 c = -c * ( x / an ) t = c / ( a + an ) sum1 = sum1 + t if ( abs ( t ) <= tol ) then exit end if end do j = a * x * ( ( sum1 / 6.0D+00 - 0.5D+00 / & ( a + 2.0D+00 ) ) * x + 1.0D+00 & / ( a + 1.0D+00 ) ) z = a * log ( x ) h = gam1 ( a ) g = 1.0D+00 + h if ( x < 0.25D+00 ) then go to 180 end if if ( a < x / 2.59D+00 ) then go to 200 end if go to 190 180 continue if ( -0.13394D+00 < z ) then go to 200 end if 190 continue w = exp ( z ) ans = w * g * ( 0.5D+00 + ( 0.5D+00 - j )) qans = 0.5D+00 + ( 0.5D+00 - ans ) return 200 continue l = rexp ( z ) w = 0.5D+00 + ( 0.5D+00 + l ) qans = ( w * j - l ) * g - h if ( qans < 0.0D+00 ) then ans = 1.0D+00 qans = 0.0D+00 return end if ans = 0.5D+00 + ( 0.5D+00 - qans ) return ! ! Finite sums for Q when 1 <= A and 2*A is an integer. ! 210 continue sum1 = exp ( - x ) t = sum1 n = 1 c = 0.0D+00 go to 230 220 continue rtx = sqrt ( x ) sum1 = error_fc ( 0, rtx ) t = exp ( -x ) / ( rtpi * rtx ) n = 0 c = -0.5D+00 230 continue do while ( n /= i ) n = n + 1 c = c + 1.0D+00 t = ( x * t ) / c sum1 = sum1 + t end do qans = sum1 ans = 0.5D+00 + ( 0.5D+00 - qans ) return ! ! Continued fraction expansion. ! 250 continue tol = max ( 5.0D+00 * e, acc ) a2nm1 = 1.0D+00 a2n = 1.0D+00 b2nm1 = x b2n = x + ( 1.0D+00 - a ) c = 1.0D+00 do a2nm1 = x * a2n + c * a2nm1 b2nm1 = x * b2n + c * b2nm1 am0 = a2nm1 / b2nm1 c = c + 1.0D+00 cma = c - a a2n = a2nm1 + cma * a2n b2n = b2nm1 + cma * b2n an0 = a2n / b2n if ( abs ( an0 - am0 ) < tol * an0 ) then exit end if end do qans = r * an0 ans = 0.5D+00 + ( 0.5D+00 - qans ) return ! ! General Temme expansion. ! 270 continue if ( abs ( s ) <= 2.0D+00 * e .and. 3.28D-03 < a * e * e ) then ans = 2.0D+00 return end if c = exp ( - y ) w = 0.5D+00 * error_fc ( 1, sqrt ( y ) ) u = 1.0D+00 / a z = sqrt ( z + z ) if ( l < 1.0D+00 ) then z = -z end if if ( iop < 2 ) then if ( abs ( s ) <= 1.0D-03 ) then c0 = (((((( & d0(7) & * z + d0(6) ) & * z + d0(5) ) & * z + d0(4) ) & * z + d0(3) ) & * z + d0(2) ) & * z + d0(1) ) & * z - 1.0D+00 / 3.0D+00 c1 = ((((( & d1(6) & * z + d1(5) ) & * z + d1(4) ) & * z + d1(3) ) & * z + d1(2) ) & * z + d1(1) ) & * z + d10 c2 = ((((d2(5)*z+d2(4))*z+d2(3))*z+d2(2))*z+d2(1))*z + d20 c3 = (((d3(4)*z+d3(3))*z+d3(2))*z+d3(1))*z + d30 c4 = ( d4(2) * z + d4(1) ) * z + d40 c5 = ( d5(2) * z + d5(1) ) * z + d50 c6 = d6(1) * z + d60 t = (((((( d70 & * u + c6 ) & * u + c5 ) & * u + c4 ) & * u + c3 ) & * u + c2 ) & * u + c1 ) & * u + c0 else c0 = (((((((((((( & d0(13) & * z + d0(12) ) & * z + d0(11) ) & * z + d0(10) ) & * z + d0(9) ) & * z + d0(8) ) & * z + d0(7) ) & * z + d0(6) ) & * z + d0(5) ) & * z + d0(4) ) & * z + d0(3) ) & * z + d0(2) ) & * z + d0(1) ) & * z - 1.0D+00 / 3.0D+00 c1 = ((((((((((( & d1(12) & * z + d1(11) & ) * z + d1(10) & ) * z + d1(9) & ) * z + d1(8) & ) * z + d1(7) & ) * z + d1(6) & ) * z + d1(5) & ) * z + d1(4) & ) * z + d1(3) & ) * z + d1(2) & ) * z + d1(1) & ) * z + d10 c2 = ((((((((( & d2(10) & * z + d2(9) & ) * z + d2(8) & ) * z + d2(7) & ) * z + d2(6) & ) * z + d2(5) & ) * z + d2(4) & ) * z + d2(3) & ) * z + d2(2) & ) * z + d2(1) & ) * z + d20 c3 = ((((((( & d3(8) & * z + d3(7) & ) * z + d3(6) & ) * z + d3(5) & ) * z + d3(4) & ) * z + d3(3) & ) * z + d3(2) & ) * z + d3(1) & ) * z + d30 c4 = ((((( d4(6)*z+d4(5))*z+d4(4))*z+d4(3))*z+d4(2))*z+d4(1))*z + d40 c5 = (((d5(4)*z+d5(3))*z+d5(2))*z+d5(1))*z + d50 c6 = ( d6(2) * z + d6(1) ) * z + d60 t = (((((( & d70 & * u + c6 ) & * u + c5 ) & * u + c4 ) & * u + c3 ) & * u + c2 ) & * u + c1 ) & * u + c0 end if else if ( iop == 2 ) then c0 = ((((( & d0(6) & * z + d0(5) ) & * z + d0(4) ) & * z + d0(3) ) & * z + d0(2) ) & * z + d0(1) ) & * z - 1.0D+00 / 3.0D+00 c1 = ((( d1(4) * z + d1(3) ) * z + d1(2) ) * z + d1(1) ) * z + d10 c2 = d2(1) * z + d20 t = ( c2 * u + c1 ) * u + c0 else if ( 2 < iop ) then t = (( d0(3) * z + d0(2) ) * z + d0(1) ) * z - 1.0D+00 / 3.0D+00 end if 310 continue if ( 1.0D+00 <= l ) then qans = c * ( w + rt2pin * t / rta ) ans = 0.5D+00 + ( 0.5D+00 - qans ) else ans = c * ( w - rt2pin * t / rta ) qans = 0.5D+00 + ( 0.5D+00 - ans ) end if return ! ! Temme expansion for L = 1 ! 330 continue if ( 3.28D-03 < a * e * e ) then ans = 2.0D+00 return end if c = 0.5D+00 + ( 0.5D+00 - y ) w = ( 0.5D+00 - sqrt ( y ) & * ( 0.5D+00 & + ( 0.5D+00 - y / 3.0D+00 ) ) / rtpi ) / c u = 1.0D+00 / a z = sqrt ( z + z ) if ( l < 1.0D+00 ) then z = -z end if if ( iop < 2 ) then c0 = (((((( & d0(7) & * z + d0(6) ) & * z + d0(5) ) & * z + d0(4) ) & * z + d0(3) ) & * z + d0(2) ) & * z + d0(1) ) & * z - 1.0D+00 / 3.0D+00 c1 = ((((( & d1(6) & * z + d1(5) ) & * z + d1(4) ) & * z + d1(3) ) & * z + d1(2) ) & * z + d1(1) ) & * z + d10 c2 = ((((d2(5)*z+d2(4))*z+d2(3))*z+d2(2))*z+d2(1))*z + d20 c3 = (((d3(4)*z+d3(3))*z+d3(2))*z+d3(1))*z + d30 c4 = ( d4(2) * z + d4(1) ) * z + d40 c5 = ( d5(2) * z + d5(1) ) * z + d50 c6 = d6(1) * z + d60 t = (((((( d70 & * u + c6 ) & * u + c5 ) & * u + c4 ) & * u + c3 ) & * u + c2 ) & * u + c1 ) & * u + c0 else if ( iop == 2 ) then c0 = ( d0(2) * z + d0(1) ) * z - 1.0D+00 / 3.0D+00 c1 = d1(1) * z + d10 t = ( d20 * u + c1 ) * u + c0 else if ( 2 < iop ) then t = d0(1) * z - 1.0D+00 / 3.0D+00 end if go to 310 ! ! Special cases ! 390 continue if ( x < 0.25D+00 ) then ans = error_f ( sqrt ( x ) ) qans = 0.5D+00 + ( 0.5D+00 - ans ) else qans = error_fc ( 0, sqrt ( x ) ) ans = 0.5D+00 + ( 0.5D+00 - qans ) end if return 410 continue if ( abs ( s ) <= 2.0D+00 * e ) then ans = 2.0D+00 return end if if ( x <= a ) then ans = 0.0D+00 qans = 1.0D+00 else ans = 1.0D+00 qans = 0.0D+00 end if return end subroutine gamma_inc_inv ( a, x, x0, p, q, ierr ) !*****************************************************************************80 ! !! GAMMA_INC_INV computes the inverse incomplete gamma ratio function. ! ! Discussion: ! ! The routine is given positive A, and nonnegative P and Q where P + Q = 1. ! The value X is computed with the property that P(A,X) = P and Q(A,X) = Q. ! Schroder iteration is employed. The routine attempts to compute X ! to 10 significant digits if this is possible for the particular computer ! arithmetic being used. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Alfred Morris ! ! Parameters: ! ! Input, real ( kind = rk ) A, the parameter in the incomplete gamma ! ratio. A must be positive. ! ! Output, real ( kind = rk ) X, the computed point for which the ! incomplete gamma functions have the values P and Q. ! ! Input, real ( kind = rk ) X0, an optional initial approximation ! for the solution X. If the user does not want to supply an ! initial approximation, then X0 should be set to 0, or a negative ! value. ! ! Input, real ( kind = rk ) P, Q, the values of the incomplete gamma ! functions, for which the corresponding argument is desired. ! ! Output, integer IERR, error flag. ! 0, the solution was obtained. Iteration was not used. ! 0 < K, The solution was obtained. IERR iterations were performed. ! -2, A <= 0 ! -3, No solution was obtained. The ratio Q/A is too large. ! -4, P + Q /= 1 ! -6, 20 iterations were performed. The most recent value obtained ! for X is given. This cannot occur if X0 <= 0. ! -7, Iteration failed. No value is given for X. ! This may occur when X is approximately 0. ! -8, A value for X has been obtained, but the routine is not certain ! of its accuracy. Iteration cannot be performed in this ! case. If X0 <= 0, this can occur only when P or Q is ! approximately 0. If X0 is positive then this can occur when A is ! exceedingly close to X and A is extremely large (say A .GE. 1.E20). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ), parameter :: a0 = 3.31125922108741D+00 real ( kind = rk ), parameter :: a1 = 11.6616720288968D+00 real ( kind = rk ), parameter :: a2 = 4.28342155967104D+00 real ( kind = rk ), parameter :: a3 = 0.213623493715853D+00 real ( kind = rk ) alnrel real ( kind = rk ) am1 real ( kind = rk ) amax real ( kind = rk ), dimension(2) :: amin = (/ & 500.0D+00, 100.0D+00 /) real ( kind = rk ) ap1 real ( kind = rk ) ap2 real ( kind = rk ) ap3 real ( kind = rk ) apn real ( kind = rk ) b real ( kind = rk ), parameter :: b1 = 6.61053765625462D+00 real ( kind = rk ), parameter :: b2 = 6.40691597760039D+00 real ( kind = rk ), parameter :: b3 = 1.27364489782223D+00 real ( kind = rk ), parameter :: b4 = .036117081018842D+00 real ( kind = rk ), dimension ( 2 ) :: bmin = (/ & 1.0D-28, 1.0D-13 /) real ( kind = rk ), parameter :: c = 0.577215664901533D+00 real ( kind = rk ) c1 real ( kind = rk ) c2 real ( kind = rk ) c3 real ( kind = rk ) c4 real ( kind = rk ) c5 real ( kind = rk ) d real ( kind = rk ), dimension ( 2 ) :: dmin = (/ & 1.0D-06, 1.0D-04 /) real ( kind = rk ) e real ( kind = rk ) e2 real ( kind = rk ), dimension ( 2 ) :: emin = (/ & 2.0D-03, 6.0D-03 /) real ( kind = rk ) eps real ( kind = rk ), dimension ( 2 ) :: eps0 = (/ & 1.0D-10, 1.0D-08 /) real ( kind = rk ) g real ( kind = rk ) gamma_log real ( kind = rk ) gamma_ln1 real ( kind = rk ) gamma real ( kind = rk ) h real ( kind = rk ), parameter :: half = 0.5D+00 integer ierr integer iop real ( kind = rk ), parameter :: ln10 = 2.302585D+00 real ( kind = rk ) p real ( kind = rk ) pn real ( kind = rk ) q real ( kind = rk ) qg real ( kind = rk ) qn real ( kind = rk ) r real ( kind = rk ) rcomp real ( kind = rk ) rta real ( kind = rk ) s real ( kind = rk ) s2 real ( kind = rk ) sum1 real ( kind = rk ) t real ( kind = rk ), parameter :: tol = 1.0D-05 real ( kind = rk ), parameter :: two = 2.0D+00 real ( kind = rk ) u real ( kind = rk ) w real ( kind = rk ) x real ( kind = rk ) x0 real ( kind = rk ) xn real ( kind = rk ) y real ( kind = rk ) z e = epsilon ( e ) x = 0.0D+00 if ( a <= 0.0D+00 ) then ierr = -2 return end if t = p + q - 1.0D+00 if ( e < abs ( t ) ) then ierr = -4 return end if ierr = 0 if ( p == 0.0D+00 ) then return end if if ( q == 0.0D+00 ) then x = huge ( x ) return end if if ( a == 1.0D+00 ) then if ( 0.9D+00 <= q ) then x = -alnrel ( - p ) else x = -log ( q ) end if return end if e2 = two * e amax = 0.4D-10 / ( e * e ) if ( 1.0D-10 < e ) then iop = 2 else iop = 1 end if eps = eps0(iop) xn = x0 if ( 0.0D+00 < x0 ) then go to 160 end if ! ! Selection of the initial approximation XN of X when A < 1. ! if ( 1.0D+00 < a ) then go to 80 end if g = gamma ( a + 1.0D+00 ) qg = q * g if ( qg == 0.0D+00 ) then x = huge ( x ) ierr = -8 return end if b = qg / a if ( 0.6D+00 * a < qg ) then go to 40 end if if ( a < 0.30D+00 .and. 0.35D+00 <= b ) then t = exp ( - ( b + c ) ) u = t * exp ( t ) xn = t * exp ( u ) go to 160 end if if ( 0.45D+00 <= b ) then go to 40 end if if ( b == 0.0D+00 ) then x = huge ( x ) ierr = -8 return end if y = -log ( b ) s = half + ( half - a ) z = log ( y ) t = y - s * z if ( 0.15D+00 <= b ) then xn = y - s * log ( t ) - log ( 1.0D+00 + s / ( t + 1.0D+00 ) ) go to 220 end if if ( 0.01D+00 < b ) then u = ( ( t + two * ( 3.0D+00 - a ) ) * t & + ( two - a ) * ( 3.0D+00 - a )) / & ( ( t + ( 5.0D+00 - a ) ) * t + two ) xn = y - s * log ( t ) - log ( u ) go to 220 end if 30 continue c1 = -s * z c2 = -s * ( 1.0D+00 + c1 ) c3 = s * (( half * c1 & + ( two - a ) ) * c1 + ( 2.5D+00 - 1.5D+00 * a ) ) c4 = -s * ((( c1 / 3.0D+00 + ( 2.5D+00 - 1.5D+00 * a ) ) * c1 & + ( ( a - 6.0D+00 ) * a + 7.0D+00 ) ) & * c1 + ( ( 11.0D+00 * a - 46.0D+00 ) * a + 47.0D+00 ) / 6.0D+00 ) c5 = -s * (((( - c1 / 4.0D+00 + ( 11.0D+00 * a - 17.0D+00 ) / 6.0D+00 ) * c1 & + ( ( -3.0D+00 * a + 13.0D+00 ) * a - 13.0D+00 ) ) * c1 & + half & * ( ( ( two * a - 25.0D+00 ) * a + 72.0D+00 ) & * a - 61.0D+00 ) ) * c1 & + ( ( ( 25.0D+00 * a - 195.0D+00 ) * a & + 477.0D+00 ) * a - 379.0D+00 ) / 12.0D+00 ) xn = (((( c5 / y + c4 ) / y + c3 ) / y + c2 ) / y + c1 ) + y if ( 1.0D+00 < a ) then go to 220 end if if ( bmin(iop) < b ) then go to 220 end if x = xn return 40 continue if ( b * q <= 1.0D-08 ) then xn = exp ( - ( q / a + c )) else if ( 0.9D+00 < p ) then xn = exp ( ( alnrel ( - q ) + gamma_ln1 ( a )) / a ) else xn = exp ( log ( p * g ) / a ) end if if ( xn == 0.0D+00 ) then ierr = -3 return end if t = half + ( half - xn / ( a + 1.0D+00 )) xn = xn / t go to 160 ! ! Selection of the initial approximation XN of X when 1 < A. ! 80 continue if ( 0.5D+00 < q ) then w = log ( p ) else w = log ( q ) end if t = sqrt ( - two * w ) s = t - ((( a3 * t + a2 ) * t + a1 ) * t + a0 ) / (((( & b4 * t + b3 ) * t + b2 ) * t + b1 ) * t + 1.0D+00 ) if ( 0.5D+00 < q ) then s = -s end if rta = sqrt ( a ) s2 = s * s xn = a + s * rta + ( s2 - 1.0D+00 ) / 3.0D+00 + s * ( s2 - 7.0D+00 ) & / ( 36.0D+00 * rta ) - ( ( 3.0D+00 * s2 + 7.0D+00 ) * s2 - 16.0D+00 ) & / ( 810.0D+00 * a ) + s * (( 9.0D+00 * s2 + 256.0D+00 ) * s2 - 433.0D+00 ) & / ( 38880.0D+00 * a * rta ) xn = max ( xn, 0.0D+00 ) if ( amin(iop) <= a ) then x = xn d = half + ( half - x / a ) if ( abs ( d ) <= dmin(iop) ) then return end if end if if ( p <= 0.5D+00 ) then go to 130 end if if ( xn < 3.0D+00 * a ) then go to 220 end if y = - ( w + gamma_log ( a ) ) d = max ( two, a * ( a - 1.0D+00 ) ) if ( ln10 * d <= y ) then s = 1.0D+00 - a z = log ( y ) go to 30 end if t = a - 1.0D+00 xn = y + t * log ( xn ) - alnrel ( -t / ( xn + 1.0D+00 ) ) xn = y + t * log ( xn ) - alnrel ( -t / ( xn + 1.0D+00 ) ) go to 220 130 continue ap1 = a + 1.0D+00 if ( 0.70D+00 * ap1 < xn ) then go to 170 end if w = w + gamma_log ( ap1 ) if ( xn <= 0.15 * ap1 ) then ap2 = a + two ap3 = a + 3.0D+00 x = exp ( ( w + x ) / a ) x = exp ( ( w + x - log ( 1.0D+00 + ( x / ap1 ) & * ( 1.0D+00 + x / ap2 ) ) ) / a ) x = exp ( ( w + x - log ( 1.0D+00 + ( x / ap1 ) & * ( 1.0D+00 + x / ap2 ) ) ) / a ) x = exp ( ( w + x - log ( 1.0D+00 + ( x / ap1 ) & * ( 1.0D+00 + ( x / ap2 ) & * ( 1.0D+00 + x / ap3 ) ) ) ) / a ) xn = x if ( xn <= 1.0D-02 * ap1 ) then if ( xn <= emin(iop) * ap1 ) then return end if go to 170 end if end if apn = ap1 t = xn / apn sum1 = 1.0D+00 + t do apn = apn + 1.0D+00 t = t * ( xn / apn ) sum1 = sum1 + t if ( t <= 1.0D-04 ) then exit end if end do t = w - log ( sum1 ) xn = exp ( ( xn + t ) / a ) xn = xn * ( 1.0D+00 - ( a * log ( xn ) - xn - t ) / ( a - xn ) ) go to 170 ! ! Schroder iteration using P. ! 160 continue if ( 0.5D+00 < p ) then go to 220 end if 170 continue if ( p <= 1.0D+10 * tiny ( p ) ) then x = xn ierr = -8 return end if am1 = ( a - half ) - half 180 continue if ( amax < a ) then d = half + ( half - xn / a ) if ( abs ( d ) <= e2 ) then x = xn ierr = -8 return end if end if if ( 20 <= ierr ) then ierr = -6 return end if ierr = ierr + 1 call gamma_inc ( a, xn, pn, qn, 0 ) if ( pn == 0.0D+00 .or. qn == 0.0D+00 ) then x = xn ierr = -8 return end if r = rcomp ( a, xn ) if ( r == 0.0D+00 ) then x = xn ierr = -8 return end if t = ( pn - p ) / r w = half * ( am1 - xn ) if ( abs ( t ) <= 0.1D+00 .and. abs ( w * t ) <= 0.1D+00 ) then go to 200 end if x = xn * ( 1.0D+00 - t ) if ( x <= 0.0D+00 ) then ierr = -7 return end if d = abs ( t ) go to 210 200 continue h = t * ( 1.0D+00 + w * t ) x = xn * ( 1.0D+00 - h ) if ( x <= 0.0D+00 ) then ierr = -7 return end if if ( 1.0D+00 <= abs ( w ) .and. abs ( w ) * t * t <= eps ) then return end if d = abs ( h ) 210 continue xn = x if ( d <= tol ) then if ( d <= eps ) then return end if if ( abs ( p - pn ) <= tol * p ) then return end if end if go to 180 ! ! Schroder iteration using Q. ! 220 continue if ( q <= 1.0D+10 * tiny ( q ) ) then x = xn ierr = -8 return end if am1 = ( a - half ) - half 230 continue if ( amax < a ) then d = half + ( half - xn / a ) if ( abs ( d ) <= e2 ) then x = xn ierr = -8 return end if end if if ( 20 <= ierr ) then ierr = -6 return end if ierr = ierr + 1 call gamma_inc ( a, xn, pn, qn, 0 ) if ( pn == 0.0D+00 .or. qn == 0.0D+00 ) then x = xn ierr = -8 return end if r = rcomp ( a, xn ) if ( r == 0.0D+00 ) then x = xn ierr = -8 return end if t = ( q - qn ) / r w = half * ( am1 - xn ) if ( abs ( t ) <= 0.1 .and. abs ( w * t ) <= 0.1 ) then go to 250 end if x = xn * ( 1.0D+00 - t ) if ( x <= 0.0D+00 ) then ierr = -7 return end if d = abs ( t ) go to 260 250 continue h = t * ( 1.0D+00 + w * t ) x = xn * ( 1.0D+00 - h ) if ( x <= 0.0D+00 ) then ierr = -7 return end if if ( 1.0D+00 <= abs ( w ) .and. abs ( w ) * t * t <= eps ) then return end if d = abs ( h ) 260 continue xn = x if ( tol < d ) then go to 230 end if if ( d <= eps ) then return end if if ( abs ( q - qn ) <= tol * q ) then return end if go to 230 end subroutine gamma_inc_values ( n_data, a, x, fx ) !*****************************************************************************80 ! !! 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 ! ! Mathematica can compute this value as ! ! 1 - GammaRegularized[A,X] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! 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 = rk ) A, X, the arguments of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 20 real ( kind = rk ) a real ( kind = rk ), save, dimension ( n_max ) :: a_vec = (/ & 0.1D+00, 0.1D+00, 0.1D+00, 0.5D+00, & 0.5D+00, 0.5D+00, 1.0D+00, 1.0D+00, & 1.0D+00, 1.1D+00, 1.1D+00, 1.1D+00, & 2.0D+00, 2.0D+00, 2.0D+00, 6.0D+00, & 6.0D+00, 11.0D+00, 26.0D+00, 41.0D+00 /) real ( kind = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.7420263D+00, 0.9119753D+00, 0.9898955D+00, 0.2931279D+00, & 0.7656418D+00, 0.9921661D+00, 0.0951626D+00, 0.6321206D+00, & 0.9932621D+00, 0.0757471D+00, 0.6076457D+00, 0.9933425D+00, & 0.0091054D+00, 0.4130643D+00, 0.9931450D+00, 0.0387318D+00, & 0.9825937D+00, 0.9404267D+00, 0.4863866D+00, 0.7359709D+00 /) integer n_data real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 3.1622777D-02, 3.1622777D-01, 1.5811388D+00, 7.0710678D-02, & 7.0710678D-01, 3.5355339D+00, 0.1000000D+00, 1.0000000D+00, & 5.0000000D+00, 1.0488088D-01, 1.0488088D+00, 5.2440442D+00, & 1.4142136D-01, 1.4142136D+00, 7.0710678D+00, 2.4494897D+00, & 1.2247449D+01, 1.6583124D+01, 2.5495098D+01, 4.4821870D+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 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_ln1 ( a ) !*****************************************************************************80 ! !! GAMMA_LN1 evaluates ln ( Gamma ( 1 + A ) ), for -0.2 <= A <= 1.25. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) A, defines the argument of the function. ! ! Output, real ( kind = rk ) GAMMA_LN1, the value of ln ( Gamma ( 1 + A ) ). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) bot real ( kind = rk ) gamma_ln1 real ( kind = rk ), parameter :: p0 = 0.577215664901533D+00 real ( kind = rk ), parameter :: p1 = 0.844203922187225D+00 real ( kind = rk ), parameter :: p2 = -0.168860593646662D+00 real ( kind = rk ), parameter :: p3 = -0.780427615533591D+00 real ( kind = rk ), parameter :: p4 = -0.402055799310489D+00 real ( kind = rk ), parameter :: p5 = -0.673562214325671D-01 real ( kind = rk ), parameter :: p6 = -0.271935708322958D-02 real ( kind = rk ), parameter :: q1 = 0.288743195473681D+01 real ( kind = rk ), parameter :: q2 = 0.312755088914843D+01 real ( kind = rk ), parameter :: q3 = 0.156875193295039D+01 real ( kind = rk ), parameter :: q4 = 0.361951990101499D+00 real ( kind = rk ), parameter :: q5 = 0.325038868253937D-01 real ( kind = rk ), parameter :: q6 = 0.667465618796164D-03 real ( kind = rk ), parameter :: r0 = 0.422784335098467D+00 real ( kind = rk ), parameter :: r1 = 0.848044614534529D+00 real ( kind = rk ), parameter :: r2 = 0.565221050691933D+00 real ( kind = rk ), parameter :: r3 = 0.156513060486551D+00 real ( kind = rk ), parameter :: r4 = 0.170502484022650D-01 real ( kind = rk ), parameter :: r5 = 0.497958207639485D-03 real ( kind = rk ), parameter :: s1 = 0.124313399877507D+01 real ( kind = rk ), parameter :: s2 = 0.548042109832463D+00 real ( kind = rk ), parameter :: s3 = 0.101552187439830D+00 real ( kind = rk ), parameter :: s4 = 0.713309612391000D-02 real ( kind = rk ), parameter :: s5 = 0.116165475989616D-03 real ( kind = rk ) top real ( kind = rk ) x if ( a < 0.6D+00 ) then top = ((((( & p6 & * a + p5 ) & * a + p4 ) & * a + p3 ) & * a + p2 ) & * a + p1 ) & * a + p0 bot = ((((( & q6 & * a + q5 ) & * a + q4 ) & * a + q3 ) & * a + q2 ) & * a + q1 ) & * a + 1.0D+00 gamma_ln1 = -a * ( top / bot ) else x = ( a - 0.5D+00 ) - 0.5D+00 top = ((((( r5 * x + r4 ) * x + r3 ) * x + r2 ) * x + r1 ) * x + r0 ) bot = ((((( s5 * x + s4 ) * x + s3 ) * x + s2 ) * x + s1 ) * x + 1.0D+00 ) gamma_ln1 = x * ( top / bot ) end if return end function gamma_log ( a ) !*****************************************************************************80 ! !! GAMMA_LOG evaluates ln ( Gamma ( A ) ) for positive A. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) A, the argument of the function. ! A should be positive. ! ! Output, real ( kind = rk ), GAMMA_LOG, the value of ln ( Gamma ( A ) ). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ), parameter :: c0 = 0.833333333333333D-01 real ( kind = rk ), parameter :: c1 = -0.277777777760991D-02 real ( kind = rk ), parameter :: c2 = 0.793650666825390D-03 real ( kind = rk ), parameter :: c3 = -0.595202931351870D-03 real ( kind = rk ), parameter :: c4 = 0.837308034031215D-03 real ( kind = rk ), parameter :: c5 = -0.165322962780713D-02 real ( kind = rk ), parameter :: d = 0.418938533204673D+00 real ( kind = rk ) gamma_log real ( kind = rk ) gamma_ln1 integer i integer n real ( kind = rk ) t real ( kind = rk ) w if ( a <= 0.8D+00 ) then gamma_log = gamma_ln1 ( a ) - log ( a ) else if ( a <= 2.25D+00 ) then t = ( a - 0.5D+00 ) - 0.5D+00 gamma_log = gamma_ln1 ( t ) else if ( a < 10.0D+00 ) then n = int ( a - 1.25D+00 ) t = a w = 1.0D+00 do i = 1, n t = t - 1.0D+00 w = t * w end do gamma_log = gamma_ln1 ( t - 1.0D+00 ) + log ( w ) else t = ( 1.0D+00 / a )**2 w = ((((( c5 * t + c4 ) * t + c3 ) * t + c2 ) * t + c1 ) * t + c0 ) / a gamma_log = ( d + w ) + ( a - 0.5D+00 ) & * ( log ( a ) - 1.0D+00 ) end if return end subroutine gamma_rat1 ( a, x, r, p, q, eps ) !*****************************************************************************80 ! !! GAMMA_RAT1 evaluates the incomplete gamma ratio functions P(A,X) and Q(A,X). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) A, X, the parameters of the functions. ! It is assumed that A <= 1. ! ! Input, real ( kind = rk ) R, the value exp(-X) * X^A / Gamma(A). ! ! Output, real ( kind = rk ) P, Q, the values of P(A,X) and Q(A,X). ! ! Input, real ( kind = rk ) EPS, the tolerance. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) a2n real ( kind = rk ) a2nm1 real ( kind = rk ) am0 real ( kind = rk ) an real ( kind = rk ) an0 real ( kind = rk ) b2n real ( kind = rk ) b2nm1 real ( kind = rk ) c real ( kind = rk ) cma real ( kind = rk ) eps real ( kind = rk ) error_f real ( kind = rk ) error_fc real ( kind = rk ) g real ( kind = rk ) gam1 real ( kind = rk ) h real ( kind = rk ) j real ( kind = rk ) l real ( kind = rk ) p real ( kind = rk ) q real ( kind = rk ) r real ( kind = rk ) rexp real ( kind = rk ) sum1 real ( kind = rk ) t real ( kind = rk ) tol real ( kind = rk ) w real ( kind = rk ) x real ( kind = rk ) z if ( a * x == 0.0D+00 ) then if ( x <= a ) then p = 0.0D+00 q = 1.0D+00 else p = 1.0D+00 q = 0.0D+00 end if return end if if ( a == 0.5D+00 ) then if ( x < 0.25D+00 ) then p = error_f ( sqrt ( x ) ) q = 0.5D+00 + ( 0.5D+00 - p ) else q = error_fc ( 0, sqrt ( x ) ) p = 0.5D+00 + ( 0.5D+00 - q ) end if return end if ! ! Taylor series for P(A,X)/X^A ! if ( x < 1.1D+00 ) then an = 3.0 c = x sum1 = x / ( a + 3.0D+00 ) tol = 0.1D+00 * eps / ( a + 1.0D+00 ) do an = an + 1.0D+00 c = -c * ( x / an ) t = c / ( a + an ) sum1 = sum1 + t if ( abs ( t ) <= tol ) then exit end if end do j = a * x * ( ( sum1 / 6.0D+00 - 0.5D+00 & / ( a + 2.0D+00 ) ) & * x + 1.0D+00 / ( a + 1.0D+00 ) ) z = a * log ( x ) h = gam1 ( a ) g = 1.0D+00 + h if ( x < 0.25D+00 ) then go to 30 end if if ( a < x / 2.59D+00 ) then go to 50 else go to 40 end if 30 continue if ( -0.13394D+00 < z ) then go to 50 end if 40 continue w = exp ( z ) p = w * g * ( 0.5D+00 + ( 0.5D+00 - j )) q = 0.5D+00 + ( 0.5D+00 - p ) return 50 continue l = rexp ( z ) w = 0.5D+00 + ( 0.5D+00 + l ) q = ( w * j - l ) * g - h if ( q < 0.0D+00 ) then p = 1.0D+00 q = 0.0D+00 else p = 0.5D+00 + ( 0.5D+00 - q ) end if ! ! Continued fraction expansion. ! else a2nm1 = 1.0D+00 a2n = 1.0D+00 b2nm1 = x b2n = x + ( 1.0D+00 - a ) c = 1.0D+00 do a2nm1 = x * a2n + c * a2nm1 b2nm1 = x * b2n + c * b2nm1 am0 = a2nm1 / b2nm1 c = c + 1.0D+00 cma = c - a a2n = a2nm1 + cma * a2n b2n = b2nm1 + cma * b2n an0 = a2n / b2n if ( abs ( an0 - am0 ) < eps * an0 ) then exit end if end do q = r * an0 p = 0.5D+00 + ( 0.5D+00 - q ) end if return end subroutine gamma_values ( n_data, x, fx ) !*****************************************************************************80 ! !! GAMMA_VALUES returns some values of the Gamma function. ! ! Definition: ! ! Gamma(Z) = Integral ( 0 <= T < Infinity) T^(Z-1) exp(-T) dT ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 April 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! 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 = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 18 real ( kind = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 4.590845D+00, 2.218160D+00, 1.489192D+00, 1.164230D+00, & 1.0000000000D+00, 0.9513507699D+00, 0.9181687424D+00, 0.8974706963D+00, & 0.8872638175D+00, 0.8862269255D+00, 0.8935153493D+00, 0.9086387329D+00, & 0.9313837710D+00, 0.9617658319D+00, 1.0000000000D+00, 3.6288000D+05, & 1.2164510D+17, 8.8417620D+30 /) integer n_data real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 0.2D+00, 0.4D+00, 0.6D+00, 0.8D+00, & 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, 10.0D+00, & 20.0D+00, 30.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 function gsumln ( a, b ) !*****************************************************************************80 ! !! GSUMLN evaluates the function ln(Gamma(A + B)). ! ! Discussion: ! ! GSUMLN is used for 1 <= A <= 2 and 1 <= B <= 2 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) A, B, values whose sum is the argument of ! the Gamma function. ! ! Output, real ( kind = rk ) GSUMLN, the value of ln(Gamma(A+B)). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) alnrel real ( kind = rk ) b real ( kind = rk ) gamma_ln1 real ( kind = rk ) gsumln real ( kind = rk ) x x = a + b - 2.0D+00 if ( x <= 0.25D+00 ) then gsumln = gamma_ln1 ( 1.0D+00 + x ) else if ( x <= 1.25D+00 ) then gsumln = gamma_ln1 ( x ) + alnrel ( x ) else gsumln = gamma_ln1 ( x - 1.0D+00 ) + log ( x * ( 1.0D+00 + x ) ) end if return end function ipmpar ( i ) !*****************************************************************************80 ! !! IPMPAR returns integer machine constants. ! ! Discussion: ! ! Input arguments 1 through 3 are queries about integer arithmetic. ! We assume integers are represented in the N-digit, base A form ! ! sign * ( X(N-1)*A^(N-1) + ... + X(1)*A + X(0) ) ! ! where 0 <= X(0:N-1) < A. ! ! Then: ! ! IPMPAR(1) = A, the base of integer arithmetic; ! IPMPAR(2) = N, the number of base A digits; ! IPMPAR(3) = A^N - 1, the largest magnitude. ! ! It is assumed that the single and real ( kind = rk ) floating ! point arithmetics have the same base, say B, and that the ! nonzero numbers are represented in the form ! ! sign * (B^E) * (X(1)/B + ... + X(M)/B^M) ! ! where X(1:M) is one of { 0, 1,..., B-1 }, and 1 <= X(1) and ! EMIN <= E <= EMAX. ! ! Input argument 4 is a query about the base of real arithmetic: ! ! IPMPAR(4) = B, the base of single and real ( kind = rk ) arithmetic. ! ! Input arguments 5 through 7 are queries about single precision ! floating point arithmetic: ! ! IPMPAR(5) = M, the number of base B digits for single precision. ! IPMPAR(6) = EMIN, the smallest exponent E for single precision. ! IPMPAR(7) = EMAX, the largest exponent E for single precision. ! ! Input arguments 8 through 10 are queries about real ( kind = rk ) ! floating point arithmetic: ! ! IPMPAR(8) = M, the number of base B digits for real ( kind = rk ). ! IPMPAR(9) = EMIN, the smallest exponent E for real ( kind = rk ). ! IPMPAR(10) = EMAX, the largest exponent E for real ( kind = rk ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Reference: ! ! Phyllis Fox, Andrew Hall, Norman Schryer, ! Algorithm 528: ! Framework for a Portable FORTRAN Subroutine Library, ! ACM Transactions on Mathematical Software, ! Volume 4, 1978, pages 176-188. ! ! Parameters: ! ! Input, integer I, the index of the desired constant. ! ! Output, integer IPMPAR, the value of the desired constant. ! implicit none integer i integer imach(10) integer ipmpar ! ! MACHINE CONSTANTS FOR AMDAHL MACHINES. ! ! data imach( 1) / 2 / ! data imach( 2) / 31 / ! data imach( 3) / 2147483647 / ! data imach( 4) / 16 / ! data imach( 5) / 6 / ! data imach( 6) / -64 / ! data imach( 7) / 63 / ! data imach( 8) / 14 / ! data imach( 9) / -64 / ! data imach(10) / 63 / ! ! Machine constants for the AT&T 3B SERIES, AT&T ! PC 7300, AND AT&T 6300. ! ! data imach( 1) / 2 / ! data imach( 2) / 31 / ! data imach( 3) / 2147483647 / ! data imach( 4) / 2 / ! data imach( 5) / 24 / ! data imach( 6) / -125 / ! data imach( 7) / 128 / ! data imach( 8) / 53 / ! data imach( 9) / -1021 / ! data imach(10) / 1024 / ! ! Machine constants for the BURROUGHS 1700 SYSTEM. ! ! data imach( 1) / 2 / ! data imach( 2) / 33 / ! data imach( 3) / 8589934591 / ! data imach( 4) / 2 / ! data imach( 5) / 24 / ! data imach( 6) / -256 / ! data imach( 7) / 255 / ! data imach( 8) / 60 / ! data imach( 9) / -256 / ! data imach(10) / 255 / ! ! Machine constants for the BURROUGHS 5700 SYSTEM. ! ! data imach( 1) / 2 / ! data imach( 2) / 39 / ! data imach( 3) / 549755813887 / ! data imach( 4) / 8 / ! data imach( 5) / 13 / ! data imach( 6) / -50 / ! data imach( 7) / 76 / ! data imach( 8) / 26 / ! data imach( 9) / -50 / ! data imach(10) / 76 / ! ! Machine constants for the BURROUGHS 6700/7700 SYSTEMS. ! ! data imach( 1) / 2 / ! data imach( 2) / 39 / ! data imach( 3) / 549755813887 / ! data imach( 4) / 8 / ! data imach( 5) / 13 / ! data imach( 6) / -50 / ! data imach( 7) / 76 / ! data imach( 8) / 26 / ! data imach( 9) / -32754 / ! data imach(10) / 32780 / ! ! Machine constants for the CDC 6000/7000 SERIES ! 60 BIT ARITHMETIC, AND THE CDC CYBER 995 64 BIT ! ARITHMETIC (NOS OPERATING SYSTEM). ! ! data imach( 1) / 2 / ! data imach( 2) / 48 / ! data imach( 3) / 281474976710655 / ! data imach( 4) / 2 / ! data imach( 5) / 48 / ! data imach( 6) / -974 / ! data imach( 7) / 1070 / ! data imach( 8) / 95 / ! data imach( 9) / -926 / ! data imach(10) / 1070 / ! ! Machine constants for the CDC CYBER 995 64 BIT ! ARITHMETIC (NOS/VE OPERATING SYSTEM). ! ! data imach( 1) / 2 / ! data imach( 2) / 63 / ! data imach( 3) / 9223372036854775807 / ! data imach( 4) / 2 / ! data imach( 5) / 48 / ! data imach( 6) / -4096 / ! data imach( 7) / 4095 / ! data imach( 8) / 96 / ! data imach( 9) / -4096 / ! data imach(10) / 4095 / ! ! Machine constants for the CRAY 1, XMP, 2, AND 3. ! ! data imach( 1) / 2 / ! data imach( 2) / 63 / ! data imach( 3) / 9223372036854775807 / ! data imach( 4) / 2 / ! data imach( 5) / 47 / ! data imach( 6) / -8189 / ! data imach( 7) / 8190 / ! data imach( 8) / 94 / ! data imach( 9) / -8099 / ! data imach(10) / 8190 / ! ! Machine constants for the data GENERAL ECLIPSE S/200. ! ! data imach( 1) / 2 / ! data imach( 2) / 15 / ! data imach( 3) / 32767 / ! data imach( 4) / 16 / ! data imach( 5) / 6 / ! data imach( 6) / -64 / ! data imach( 7) / 63 / ! data imach( 8) / 14 / ! data imach( 9) / -64 / ! data imach(10) / 63 / ! ! Machine constants for the HARRIS 220. ! ! data imach( 1) / 2 / ! data imach( 2) / 23 / ! data imach( 3) / 8388607 / ! data imach( 4) / 2 / ! data imach( 5) / 23 / ! data imach( 6) / -127 / ! data imach( 7) / 127 / ! data imach( 8) / 38 / ! data imach( 9) / -127 / ! data imach(10) / 127 / ! ! Machine constants for the HONEYWELL 600/6000 ! AND DPS 8/70 SERIES. ! ! data imach( 1) / 2 / ! data imach( 2) / 35 / ! data imach( 3) / 34359738367 / ! data imach( 4) / 2 / ! data imach( 5) / 27 / ! data imach( 6) / -127 / ! data imach( 7) / 127 / ! data imach( 8) / 63 / ! data imach( 9) / -127 / ! data imach(10) / 127 / ! ! Machine constants for the HP 2100 ! 3 WORD real ( kind = rk ) OPTION WITH FTN4 ! ! data imach( 1) / 2 / ! data imach( 2) / 15 / ! data imach( 3) / 32767 / ! data imach( 4) / 2 / ! data imach( 5) / 23 / ! data imach( 6) / -128 / ! data imach( 7) / 127 / ! data imach( 8) / 39 / ! data imach( 9) / -128 / ! data imach(10) / 127 / ! ! Machine constants for the HP 2100 ! 4 WORD real ( kind = rk ) OPTION WITH FTN4 ! ! data imach( 1) / 2 / ! data imach( 2) / 15 / ! data imach( 3) / 32767 / ! data imach( 4) / 2 / ! data imach( 5) / 23 / ! data imach( 6) / -128 / ! data imach( 7) / 127 / ! data imach( 8) / 55 / ! data imach( 9) / -128 / ! data imach(10) / 127 / ! ! Machine constants for the HP 9000. ! ! data imach( 1) / 2 / ! data imach( 2) / 31 / ! data imach( 3) / 2147483647 / ! data imach( 4) / 2 / ! data imach( 5) / 24 / ! data imach( 6) / -126 / ! data imach( 7) / 128 / ! data imach( 8) / 53 / ! data imach( 9) / -1021 / ! data imach(10) / 1024 / ! ! Machine constants for the IBM 360/370 SERIES, ! THE ICL 2900, THE ITEL AS/6, THE XEROX SIGMA ! 5/7/9 AND THE SEL SYSTEMS 85/86. ! ! data imach( 1) / 2 / ! data imach( 2) / 31 / ! data imach( 3) / 2147483647 / ! data imach( 4) / 16 / ! data imach( 5) / 6 / ! data imach( 6) / -64 / ! data imach( 7) / 63 / ! data imach( 8) / 14 / ! data imach( 9) / -64 / ! data imach(10) / 63 / ! ! Machine constants for the IBM PC. ! ! data imach(1)/2/ ! data imach(2)/31/ ! data imach(3)/2147483647/ ! data imach(4)/2/ ! data imach(5)/24/ ! data imach(6)/-125/ ! data imach(7)/128/ ! data imach(8)/53/ ! data imach(9)/-1021/ ! data imach(10)/1024/ ! ! Machine constants for the MACINTOSH II - ABSOFT ! MACFORTRAN II. ! ! data imach( 1) / 2 / ! data imach( 2) / 31 / ! data imach( 3) / 2147483647 / ! data imach( 4) / 2 / ! data imach( 5) / 24 / ! data imach( 6) / -125 / ! data imach( 7) / 128 / ! data imach( 8) / 53 / ! data imach( 9) / -1021 / ! data imach(10) / 1024 / ! ! Machine constants for the MICROVAX - VMS FORTRAN. ! ! data imach( 1) / 2 / ! data imach( 2) / 31 / ! data imach( 3) / 2147483647 / ! data imach( 4) / 2 / ! data imach( 5) / 24 / ! data imach( 6) / -127 / ! data imach( 7) / 127 / ! data imach( 8) / 56 / ! data imach( 9) / -127 / ! data imach(10) / 127 / ! ! Machine constants for the PDP-11 FORTRAN SUPPORTING ! 32-BIT integer ARITHMETIC. ! ! data imach( 1) / 2 / ! data imach( 2) / 31 / ! data imach( 3) / 2147483647 / ! data imach( 4) / 2 / ! data imach( 5) / 24 / ! data imach( 6) / -127 / ! data imach( 7) / 127 / ! data imach( 8) / 56 / ! data imach( 9) / -127 / ! data imach(10) / 127 / ! ! Machine constants for the SEQUENT BALANCE 8000. ! ! data imach( 1) / 2 / ! data imach( 2) / 31 / ! data imach( 3) / 2147483647 / ! data imach( 4) / 2 / ! data imach( 5) / 24 / ! data imach( 6) / -125 / ! data imach( 7) / 128 / ! data imach( 8) / 53 / ! data imach( 9) / -1021 / ! data imach(10) / 1024 / ! ! Machine constants for the SILICON GRAPHICS IRIS-4D ! SERIES (MIPS R3000 PROCESSOR). ! ! data imach( 1) / 2 / ! data imach( 2) / 31 / ! data imach( 3) / 2147483647 / ! data imach( 4) / 2 / ! data imach( 5) / 24 / ! data imach( 6) / -125 / ! data imach( 7) / 128 / ! data imach( 8) / 53 / ! data imach( 9) / -1021 / ! data imach(10) / 1024 / ! ! MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T ! 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T ! PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). ! data imach( 1) / 2 / data imach( 2) / 31 / data imach( 3) / 2147483647 / data imach( 4) / 2 / data imach( 5) / 24 / data imach( 6) / -125 / data imach( 7) / 128 / data imach( 8) / 53 / data imach( 9) / -1021 / data imach(10) / 1024 / ! ! Machine constants for the UNIVAC 1100 SERIES. ! ! data imach( 1) / 2 / ! data imach( 2) / 35 / ! data imach( 3) / 34359738367 / ! data imach( 4) / 2 / ! data imach( 5) / 27 / ! data imach( 6) / -128 / ! data imach( 7) / 127 / ! data imach( 8) / 60 / ! data imach( 9) /-1024 / ! data imach(10) / 1023 / ! ! Machine constants for the VAX 11/780. ! ! data imach( 1) / 2 / ! data imach( 2) / 31 / ! data imach( 3) / 2147483647 / ! data imach( 4) / 2 / ! data imach( 5) / 24 / ! data imach( 6) / -127 / ! data imach( 7) / 127 / ! data imach( 8) / 56 / ! data imach( 9) / -127 / ! data imach(10) / 127 / ! ipmpar = imach(i) return end subroutine negative_binomial_cdf_values ( n_data, f, s, p, cdf ) !*****************************************************************************80 ! !! 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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 June 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! FC Powell, ! Statistical Tables for Sociology, Biology and Physical Sciences, ! Cambridge University Press, 1982. ! ! 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 = rk ) P, the probability of a success on one trial. ! ! Output, real ( kind = rk ) CDF, the probability of at most F failures ! before the S-th success. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 27 real ( kind = rk ) cdf real ( kind = rk ), save, dimension ( n_max ) :: cdf_vec = (/ & 0.6367D+00, 0.3633D+00, 0.1445D+00, & 0.5000D+00, 0.2266D+00, 0.0625D+00, & 0.3438D+00, 0.1094D+00, 0.0156D+00, & 0.1792D+00, 0.0410D+00, 0.0041D+00, & 0.0705D+00, 0.0109D+00, 0.0007D+00, & 0.9862D+00, 0.9150D+00, 0.7472D+00, & 0.8499D+00, 0.5497D+00, 0.2662D+00, & 0.6513D+00, 0.2639D+00, 0.0702D+00, & 1.0000D+00, 0.0199D+00, 0.0001D+00 /) 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 = rk ) p real ( kind = rk ), 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.01D+00, 0.01D+00, 0.01D+00 /) 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 subroutine normal_01_cdf_values ( n_data, x, fx ) !*****************************************************************************80 ! !! 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 ] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, 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 = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 17 real ( kind = rk ) fx real ( kind = rk ), 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 = rk ) x real ( kind = rk ), 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_cdf_values ( n_data, mu, sigma, x, fx ) !*****************************************************************************80 ! !! 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 ] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, 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 = rk ) MU, the mean of the distribution. ! ! Output, real ( kind = rk ) SIGMA, the variance of the distribution. ! ! Output, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 12 real ( kind = rk ) fx real ( kind = rk ), 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 = rk ) mu real ( kind = rk ), 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 = rk ) sigma real ( kind = rk ), 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 = rk ) x real ( kind = rk ), 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 subroutine poisson_cdf_values ( n_data, a, x, fx ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 May 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! 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 = rk ) A, integer X, the arguments of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 21 real ( kind = rk ) a real ( kind = rk ), 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 = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.980D+00, 0.905D+00, 0.995D+00, 0.607D+00, & 0.910D+00, 0.986D+00, 0.368D+00, 0.736D+00, & 0.920D+00, 0.981D+00, 0.135D+00, 0.406D+00, & 0.677D+00, 0.857D+00, 0.007D+00, 0.040D+00, & 0.125D+00, 0.265D+00, 0.441D+00, 0.616D+00, & 0.762D+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 function psi ( xx ) !*****************************************************************************80 ! !! PSI evaluates the psi or digamma function, d/dx ln(gamma(x)). ! ! Discussion: ! ! The main computation involves evaluation of rational Chebyshev ! approximations. PSI was written at Argonne National Laboratory ! for FUNPACK, and subsequently modified by A. H. Morris of NSWC. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Reference: ! ! William Cody, Anthony Strecok, Henry Thacher, ! Chebyshev Approximations for the Psi Function, ! Mathematics of Computation, ! Volume 27, 1973, pages 123-127. ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) XX, the argument of the psi function. ! ! Output, real ( kind = rk ) PSI, the value of the psi function. PSI ! is assigned the value 0 when the psi function is undefined. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) aug real ( kind = rk ) den real ( kind = rk ), parameter :: dx0 = & 1.461632144968362341262659542325721325D+00 integer i integer ipmpar integer m integer n integer nq real ( kind = rk ), parameter, dimension ( 7 ) :: p1 = (/ & 0.895385022981970D-02, & 0.477762828042627D+01, & 0.142441585084029D+03, & 0.118645200713425D+04, & 0.363351846806499D+04, & 0.413810161269013D+04, & 0.130560269827897D+04/) real ( kind = rk ), dimension ( 4 ) :: p2 = (/ & -0.212940445131011D+01, & -0.701677227766759D+01, & -0.448616543918019D+01, & -0.648157123766197D+00 /) real ( kind = rk ), parameter :: piov4 = 0.785398163397448D+00 real ( kind = rk ) psi ! ! Coefficients for rational approximation of ! PSI(X) / (X - X0), 0.5D+00 <= X <= 3.0D+00 ! real ( kind = rk ), dimension ( 6 ) :: q1 = (/ & 0.448452573429826D+02, & 0.520752771467162D+03, & 0.221000799247830D+04, & 0.364127349079381D+04, & 0.190831076596300D+04, & 0.691091682714533D-05 /) real ( kind = rk ), dimension ( 4 ) :: q2 = (/ & 0.322703493791143D+02, & 0.892920700481861D+02, & 0.546117738103215D+02, & 0.777788548522962D+01 /) real ( kind = rk ) sgn real ( kind = rk ) upper real ( kind = rk ) w real ( kind = rk ) x real ( kind = rk ) xmax1 real ( kind = rk ) xmx0 real ( kind = rk ) xsmall real ( kind = rk ) xx real ( kind = rk ) z ! ! XMAX1 is the largest positive floating point constant with entirely ! integer representation. It is also used as negative of lower bound ! on acceptable negative arguments and as the positive argument beyond which ! psi may be represented as LOG(X). ! xmax1 = real ( ipmpar(3), kind = rk ) xmax1 = min ( xmax1, 1.0D+00 / epsilon ( xmax1 ) ) ! ! XSMALL is the absolute argument below which PI*COTAN(PI*X) ! may be represented by 1/X. ! xsmall = 1.0D-09 x = xx aug = 0.0D+00 if ( x == 0.0D+00 ) then psi = 0.0D+00 return end if ! ! X < 0.5, Use reflection formula PSI(1-X) = PSI(X) + PI * COTAN(PI*X) ! if ( x < 0.5D+00 ) then ! ! 0 < ABS ( X ) <= XSMALL. Use 1/X as a substitute for PI * COTAN(PI*X) ! if ( abs ( x ) <= xsmall ) then aug = -1.0D+00 / x go to 40 end if ! ! Reduction of argument for cotangent. ! w = -x sgn = piov4 if ( w <= 0.0D+00 ) then w = -w sgn = -sgn end if ! ! Make an error exit if X <= -XMAX1 ! if ( xmax1 <= w ) then psi = 0.0D+00 return end if nq = int ( w ) w = w - real ( nq, kind = rk ) nq = int ( w * 4.0D+00 ) w = 4.0D+00 * ( w - real ( nq, kind = rk ) * 0.25D+00 ) ! ! W is now related to the fractional part of 4.0 * X. ! Adjust argument to correspond to values in first ! quadrant and determine sign. ! n = nq / 2 if ( n + n /= nq ) then w = 1.0D+00 - w end if z = piov4 * w m = n / 2 if ( m + m /= n ) then sgn = -sgn end if ! ! Determine final value for -PI * COTAN(PI*X). ! n = ( nq + 1 ) / 2 m = n / 2 m = m + m if ( m == n ) then if ( z == 0.0D+00 ) then psi = 0.0D+00 return end if aug = 4.0D+00 * sgn * ( cos(z) / sin(z) ) else aug = 4.0D+00 * sgn * ( sin(z) / cos(z) ) end if 40 continue x = 1.0D+00 - x end if ! ! 0.5 <= X <= 3 ! if ( x <= 3.0D+00 ) then den = x upper = p1(1) * x do i = 1, 5 den = ( den + q1(i) ) * x upper = ( upper + p1(i+1) ) * x end do den = ( upper + p1(7) ) / ( den + q1(6) ) xmx0 = real ( x, kind = rk ) - dx0 psi = den * xmx0 + aug ! ! 3 < X < XMAX1 ! else if ( x < xmax1 ) then w = ( 1.0D+00 / x ) / x den = w upper = p2(1) * w do i = 1, 3 den = ( den + q2(i) ) * w upper = ( upper + p2(i+1) ) * w end do aug = upper / ( den + q2(4) ) - 0.5D+00 / x + aug psi = aug + log ( x ) ! ! XMAX1 <= X ! else psi = aug + log ( x ) end if return end subroutine psi_values ( n_data, x, fx ) !*****************************************************************************80 ! !! PSI_VALUES returns some values of the Psi or Digamma function. ! ! Discussion: ! ! PSI(X) = d LN ( GAMMA ( X ) ) / d X = GAMMA'(X) / GAMMA(X) ! ! PSI(1) = - Euler's constant. ! ! PSI(X+1) = PSI(X) + 1 / X. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 May 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! 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 = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 11 real ( kind = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & -0.5772156649D+00, -0.4237549404D+00, -0.2890398966D+00, & -0.1691908889D+00, -0.0613845446D+00, -0.0364899740D+00, & 0.1260474528D+00, 0.2085478749D+00, 0.2849914333D+00, & 0.3561841612D+00, 0.4227843351D+00 /) integer n_data real ( kind = rk ) x real ( kind = rk ), 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 r8_swap ( x, y ) !*****************************************************************************80 ! !! R8_SWAP swaps two R8 values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real ( kind = rk ) X, Y. On output, the values of X and ! Y have been interchanged. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x real ( kind = rk ) y real ( kind = rk ) z z = x x = y y = z return end function rcomp ( a, x ) !*****************************************************************************80 ! !! RCOMP evaluates exp(-X) * X^A / Gamma(A). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) A, X, arguments of the quantity to be computed. ! ! Output, real ( kind = rk ) RCOMP, the value of exp(-X) * X^A / Gamma(A). ! ! Local: ! ! RT2PIN = 1/SQRT(2*PI) ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) gam1 real ( kind = rk ) gamma real ( kind = rk ) rcomp real ( kind = rk ) rlog real ( kind = rk ), parameter :: rt2pin = 0.398942280401433D+00 real ( kind = rk ) t real ( kind = rk ) t1 real ( kind = rk ) u real ( kind = rk ) x if ( a < 20.0D+00 ) then t = a * log ( x ) - x if ( a < 1.0D+00 ) then rcomp = ( a * exp ( t ) ) * ( 1.0D+00 + gam1 ( a ) ) else rcomp = exp ( t ) / gamma ( a ) end if else u = x / a if ( u == 0.0D+00 ) then rcomp = 0.0D+00 else t = ( 1.0D+00 / a )**2 t1 = ((( 0.75D+00 * t - 1.0D+00 ) * t + 3.5D+00 ) * t - 105.0D+00 ) & / ( a * 1260.0D+00 ) t1 = t1 - a * rlog ( u ) rcomp = rt2pin * sqrt ( a ) * exp ( t1 ) end if end if return end function rexp ( x ) !*****************************************************************************80 ! !! REXP evaluates the function EXP(X) - 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) REXP, the value of EXP(X)-1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: p1 = 0.914041914819518D-09 real ( kind = rk ), parameter :: p2 = 0.238082361044469D-01 real ( kind = rk ), parameter :: q1 = -0.499999999085958D+00 real ( kind = rk ), parameter :: q2 = 0.107141568980644D+00 real ( kind = rk ), parameter :: q3 = -0.119041179760821D-01 real ( kind = rk ), parameter :: q4 = 0.595130811860248D-03 real ( kind = rk ) rexp real ( kind = rk ) w real ( kind = rk ) x if ( abs ( x ) <= 0.15D+00 ) then rexp = x * ( ( ( p2 * x + p1 ) * x + 1.0D+00 ) & / ( ( ( ( q4 * x + q3 ) * x + q2 ) * x + q1 ) * x + 1.0D+00 ) ) else w = exp ( x ) if ( x <= 0.0D+00 ) then rexp = ( w - 0.5D+00 ) - 0.5D+00 else rexp = w * ( 0.5D+00 + ( 0.5D+00 - 1.0D+00 / w ) ) end if end if return end function rlog ( x ) !*****************************************************************************80 ! !! RLOG computes X - 1 - LN(X). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) RLOG, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: a = 0.566749439387324D-01 real ( kind = rk ), parameter :: b = 0.456512608815524D-01 real ( kind = rk ), parameter :: half = 0.5D+00 real ( kind = rk ), parameter :: p0 = 0.333333333333333D+00 real ( kind = rk ), parameter :: p1 = -0.224696413112536D+00 real ( kind = rk ), parameter :: p2 = 0.620886815375787D-02 real ( kind = rk ), parameter :: q1 = -0.127408923933623D+01 real ( kind = rk ), parameter :: q2 = 0.354508718369557D+00 real ( kind = rk ) r real ( kind = rk ) rlog real ( kind = rk ) t real ( kind = rk ), parameter :: two = 2.0D+00 real ( kind = rk ) u real ( kind = rk ) w real ( kind = rk ) w1 real ( kind = rk ) x if ( x < 0.61D+00 ) then r = ( x - 0.5D+00 ) - 0.5D+00 rlog = r - log ( x ) else if ( x < 1.57D+00 ) then if ( x < 0.82D+00 ) then u = x - 0.7D+00 u = u / 0.7D+00 w1 = a - u * 0.3D+00 else if ( x < 1.18D+00 ) then u = ( x - half ) - half w1 = 0.0D+00 else if ( x < 1.57D+00 ) then u = 0.75D+00 * x - 1.0D+00 w1 = b + u / 3.0D+00 end if r = u / ( u + two ) t = r * r w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 ) rlog = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1 else if ( 1.57D+00 <= x ) then r = ( x - half ) - half rlog = r - log ( x ) end if return end function rlog1 ( x ) !*****************************************************************************80 ! !! RLOG1 evaluates the function X - ln ( 1 + X ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Author: ! ! Armido DiDinato, Alfred Morris ! ! Reference: ! ! Armido DiDinato, Alfred Morris, ! Algorithm 708: ! Significant Digit Computation of the Incomplete Beta Function Ratios, ! ACM Transactions on Mathematical Software, ! Volume 18, 1993, pages 360-373. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the argument. ! ! Output, real ( kind = rk ) RLOG1, the value of X - ln ( 1 + X ). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: a = 0.566749439387324D-01 real ( kind = rk ), parameter :: b = 0.456512608815524D-01 real ( kind = rk ) h real ( kind = rk ), parameter :: half = 0.5D+00 real ( kind = rk ), parameter :: p0 = 0.333333333333333D+00 real ( kind = rk ), parameter :: p1 = -0.224696413112536D+00 real ( kind = rk ), parameter :: p2 = 0.620886815375787D-02 real ( kind = rk ), parameter :: q1 = -0.127408923933623D+01 real ( kind = rk ), parameter :: q2 = 0.354508718369557D+00 real ( kind = rk ) r real ( kind = rk ) rlog1 real ( kind = rk ) t real ( kind = rk ), parameter :: two = 2.0D+00 real ( kind = rk ) w real ( kind = rk ) w1 real ( kind = rk ) x if ( x < -0.39D+00 ) then w = ( x + half ) + half rlog1 = x - log ( w ) else if ( x < -0.18D+00 ) then h = x + 0.3D+00 h = h / 0.7D+00 w1 = a - h * 0.3D+00 r = h / ( h + 2.0D+00 ) t = r * r w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 ) rlog1 = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1 else if ( x <= 0.18D+00 ) then h = x w1 = 0.0D+00 r = h / ( h + two ) t = r * r w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 ) rlog1 = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1 else if ( x <= 0.57D+00 ) then h = 0.75D+00 * x - 0.25D+00 w1 = b + h / 3.0D+00 r = h / ( h + 2.0D+00 ) t = r * r w = ( ( p2 * t + p1 ) * t + p0 ) / ( ( q2 * t + q1 ) * t + 1.0D+00 ) rlog1 = two * t * ( 1.0D+00 / ( 1.0D+00 - r ) - r * w ) + w1 else w = ( x + half ) + half rlog1 = x - log ( w ) end if return end subroutine student_cdf_values ( n_data, a, x, fx ) !*****************************************************************************80 ! !! STUDENT_CDF_VALUES returns some values of the Student CDF. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! 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, real ( kind = rk ) X, the arguments of ! the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 13 integer a integer, save, dimension ( n_max ) :: a_vec = (/ & 1, 2, 3, 4, & 5, 2, 5, 2, & 5, 2, 3, 4, & 5 /) real ( kind = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.60D+00, 0.60D+00, 0.60D+00, 0.60D+00, & 0.60D+00, 0.75D+00, 0.75D+00, 0.95D+00, & 0.95D+00, 0.99D+00, 0.99D+00, 0.99D+00, & 0.99D+00 /) integer n_data real ( kind = rk ) x real ( kind = rk ), 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 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 stvaln ( p ) !*****************************************************************************80 ! !! STVALN provides starting values for the inverse of the normal distribution. ! ! Discussion: ! ! The routine returns an X for which it is approximately true that ! P = CUMNOR(X), ! that is, ! P = Integral ( -infinity < U <= X ) exp(-U*U/2)/sqrt(2*PI) dU. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2021 ! ! Reference: ! ! William Kennedy, James Gentle, ! Statistical Computing, ! Marcel Dekker, NY, 1980, page 95, ! QA276.4 K46 ! ! Parameters: ! ! Input, real ( kind = rk ) P, the probability whose normal deviate ! is sought. ! ! Output, real ( kind = rk ) STVALN, the normal deviate whose probability ! is approximately P. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) eval_pol real ( kind = rk ) p real ( kind = rk ) sgn real ( kind = rk ) stvaln real ( kind = rk ), parameter, dimension(0:4) :: xden = (/ & 0.993484626060D-01, & 0.588581570495D+00, & 0.531103462366D+00, & 0.103537752850D+00, & 0.38560700634D-02 /) real ( kind = rk ), parameter, dimension(0:4) :: xnum = (/ & -0.322232431088D+00, & -1.000000000000D+00, & -0.342242088547D+00, & -0.204231210245D-01, & -0.453642210148D-04 /) real ( kind = rk ) y real ( kind = rk ) z if ( p <= 0.5D+00 ) then sgn = -1.0D+00 z = p else sgn = 1.0D+00 z = 1.0D+00 - p end if y = sqrt ( -2.0D+00 * log ( z ) ) stvaln = y + eval_pol ( xnum, 4, y ) / eval_pol ( xden, 4, y ) stvaln = sgn * stvaln return end subroutine timestamp ( ) !*****************************************************************************80 ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! Example: ! ! 31 May 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 August 2005 ! ! Author: ! ! John Burkardt ! implicit none character ( len = 8 ) ampm integer d 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 integer values(8) integer y call date_and_time ( values = 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 ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end