double gammad ( double x, double p, int *ifault )
/******************************************************************************/
/*
Purpose:
GAMMAD computes the Incomplete Gamma Integral
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
03 November 2010
Author:
Original FORTRAN77 version by B Shea.
C version by John Burkardt.
Reference:
B Shea,
Algorithm AS 239:
Chi-squared and Incomplete Gamma Integral,
Applied Statistics,
Volume 37, Number 3, 1988, pages 466-473.
Parameters:
Input, double X, P, the parameters of the incomplete
gamma ratio. 0 <= X, and 0 < P.
Output, int IFAULT, error flag.
0, no error.
1, X < 0 or P <= 0.
Output, double GAMMAD, the value of the incomplete
Gamma integral.
*/
{
double a;
double an;
double arg;
double b;
double c;
double elimit = - 88.0;
double oflo = 1.0E+37;
double plimit = 1000.0;
double pn1;
double pn2;
double pn3;
double pn4;
double pn5;
double pn6;
double rn;
double tol = 1.0E-14;
int upper;
double value;
double xbig = 1.0E+08;
value = 0.0;
/*
Check the input.
*/
if ( x < 0.0 )
{
*ifault = 1;
return value;
}
if ( p <= 0.0 )
{
*ifault = 1;
return value;
}
*ifault = 0;
if ( x == 0.0 )
{
value = 0.0;
return value;
}
/*
If P is large, use a normal approximation.
*/
if ( plimit < p )
{
pn1 = 3.0 * sqrt ( p ) * ( pow ( x / p, 1.0 / 3.0 )
+ 1.0 / ( 9.0 * p ) - 1.0 );
upper = 0;
value = alnorm ( pn1, upper );
return value;
}
/*
If X is large set value = 1.
*/
if ( xbig < x )
{
value = 1.0;
return value;
}
/*
Use Pearson's series expansion.
(Note that P is not large enough to force overflow in ALOGAM).
No need to test IFAULT on exit since P > 0.
*/
if ( x <= 1.0 || x < p )
{
arg = p * log ( x ) - x - alngam ( p + 1.0, ifault );
c = 1.0;
value = 1.0;
a = p;
for ( ; ; )
{
a = a + 1.0;
c = c * x / a;
value = value + c;
if ( c <= tol )
{
break;
}
}
arg = arg + log ( value );
if ( elimit <= arg )
{
value = exp ( arg );
}
else
{
value = 0.0;
}
}
/*
Use a continued fraction expansion.
*/
else
{
arg = p * log ( x ) - x - alngam ( p, ifault );
a = 1.0 - p;
b = a + x + 1.0;
c = 0.0;
pn1 = 1.0;
pn2 = x;
pn3 = x + 1.0;
pn4 = x * b;
value = pn3 / pn4;
for ( ; ; )
{
a = a + 1.0;
b = b + 2.0;
c = c + 1.0;
an = a * c;
pn5 = b * pn3 - an * pn1;
pn6 = b * pn4 - an * pn2;
if ( pn6 != 0.0 )
{
rn = pn5 / pn6;
if ( r8_abs ( value - rn ) <= r8_min ( tol, tol * rn ) )
{
break;
}
value = rn;
}
pn1 = pn3;
pn2 = pn4;
pn3 = pn5;
pn4 = pn6;
/*
Re-scale terms in continued fraction if terms are large.
*/
if ( oflo <= abs ( pn5 ) )
{
pn1 = pn1 / oflo;
pn2 = pn2 / oflo;
pn3 = pn3 / oflo;
pn4 = pn4 / oflo;
}
}
arg = arg + log ( value );
if ( elimit <= arg )
{
value = 1.0 - exp ( arg );
}
else
{
value = 1.0;
}
}
return value;
}
double chyper ( int point, int kk, int ll, int mm, int nn, int *ifault )
/******************************************************************************/
/*
Purpose:
CHYPER computes point or cumulative hypergeometric probabilities.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
11 November 2010
Author:
Original FORTRAN77 version by Richard Lund.
C version by John Burkardt.
Reference:
PR Freeman,
Algorithm AS 59:
Hypergeometric Probabilities,
Applied Statistics,
Volume 22, Number 1, 1973, pages 130-133.
Richard Lund,
Algorithm AS 152:
Cumulative hypergeometric probabilities,
Applied Statistics,
Volume 29, Number 2, 1980, pages 221-223.
BL Shea,
Remark AS R77:
A Remark on Algorithm AS 152: Cumulative hypergeometric probabilities,
Applied Statistics,
Volume 38, Number 1, 1989, pages 199-204.
Parameters:
Input, int POINT, is TRUE if the point probability is desired,
and FALSE if the cumulative probability is desired.
Input, int KK, the sample size.
0 <= KK <= MM.
Input, int LL, the number of successes in the sample.
0 <= LL <= KK.
Input, int MM, the population size that was sampled.
0 <= MM.
Input, int NN, the number of "successes" in the population.
0 <= NN <= MM.
Output, int *IFAULT, error flag.
0, no error occurred.
nonzero, an error occurred.
Output, double CHYPER, the PDF (point probability) of
exactly LL successes out of KK samples, or the CDF (cumulative
probability) of up to LL successes out of KK samples.
*/
{
double arg;
int dir;
double elimit = - 88.0;
int i;
int j;
int k;
int kl;
int l;
int m;
int mbig = 600;
double mean;
int mnkl;
int mvbig = 1000;
int n;
int nl;
double p;
double pt;
double rootpi = 2.506628274631001;
double scale = 1.0E+35;
double sig;
double value;
*ifault = 0;
k = kk + 1;
l = ll + 1;
m = mm + 1;
n = nn + 1;
dir = 1;
/*
Check arguments are within permitted limits.
*/
value = 0.0;
if ( n < 1 || m < n || k < 1 || m < k )
{
*ifault = 1;
return value;
}
if ( l < 1 || m - n < k - l )
{
*ifault = 2;
return value;
}
if ( !point )
{
value = 1.0;
}
if ( n < l || k < l )
{
*ifault = 2;
return value;
}
*ifault = 0;
value = 1.0;
if ( k == 1 || k == m || n == 1 || n == m )
{
return value;
}
if ( !point && ll == i4_min ( kk, nn ) )
{
return value;
}
p = ( double ) ( nn ) / ( double ) ( mm - nn );
if ( 16.0 * r8_max ( p, 1.0 / p )
< ( double ) ( i4_min ( kk, mm - kk ) ) &&
mvbig < mm && - 100.0 < elimit )
{
/*
Use a normal approximation.
*/
mean = ( double ) ( kk * nn ) / ( double ) ( mm );
sig = sqrt ( mean * ( ( double ) ( mm - nn ) / ( double ) ( mm ) )
* ( ( double ) ( mm - kk ) / ( ( double ) ( mm - 1 ) ) ) );
if ( point )
{
arg = - 0.5 * ( pow ( ( ( double ) ( ll ) - mean ) / sig, 2 ) );
if ( elimit <= arg )
{
value = exp ( arg ) / ( sig * rootpi );
}
else
{
value = 0.0;
}
}
else
{
value = alnorm ( ( ( double ) ( ll ) + 0.5 - mean ) / sig, 0 );
}
}
else
{
/*
Calculate exact hypergeometric probabilities.
Interchange K and N if this saves calculations.
*/
if ( i4_min ( n - 1, m - n ) < i4_min ( k - 1, m - k ) )
{
i = k;
k = n;
n = i;
}
if ( m - k < k - 1 )
{
dir = !dir;
l = n - l + 1;
k = m - k + 1;
}
if ( mbig < mm )
{
/*
Take logarithms of factorials.
*/
p = alnfac ( nn )
- alnfac ( mm )
+ alnfac ( mm - kk )
+ alnfac ( kk )
+ alnfac ( mm - nn )
- alnfac ( ll )
- alnfac ( nn - ll )
- alnfac ( kk - ll )
- alnfac ( mm - nn - kk + ll );
if ( elimit <= p )
{
value = exp ( p );
}
else
{
value = 0.0;
}
}
else
{
/*
Use Freeman/Lund algorithm.
*/
for ( i = 1; i <= l - 1; i++ )
{
value = value * ( double ) ( ( k - i ) * ( n - i ) )
/ ( double ) ( ( l - i ) * ( m - i ) );
}
if ( l != k )
{
j = m - n + l;
for ( i = l; i <= k - 1; i++ )
{
value = value * ( double ) ( j - i ) / ( double ) ( m - i );
}
}
}
if ( point )
{
return value;
}
if ( value == 0.0 )
{
/*
We must recompute the point probability since it has underflowed.
*/
if ( mm <= mbig )
{
p = alnfac ( nn )
- alnfac ( mm )
+ alnfac ( kk )
+ alnfac ( mm - nn )
- alnfac ( ll )
- alnfac ( nn - ll )
- alnfac ( kk - ll )
- alnfac ( mm - nn - kk + ll )
+ alnfac ( mm - kk );
}
p = p + log ( scale );
if ( p < elimit )
{
*ifault = 3;
if ( ( double ) ( nn * kk + nn + kk + 1 )
/ ( double ) ( mm + 2 ) < ( double ) ( ll ) )
{
value = 1.0;
}
return value;
}
else
{
p = exp ( p );
}
}
else
/*
Scale up at this point.
*/
{
p = value * scale;
}
pt = 0.0;
nl = n - l;
kl = k - l;
mnkl = m - n - kl + 1;
if ( l <= kl )
{
for ( i = 1; i <= l - 1; i++ )
{
p = p * ( double ) ( ( l - i ) * ( mnkl - i ) ) /
( double ) ( ( nl + i ) * ( kl + i ) );
pt = pt + p;
}
}
else
{
dir = !dir;
for ( j = 0; j <= kl - 1; j++ )
{
p = p * ( double ) ( ( nl - j ) * ( kl - j ) )
/ ( double ) ( ( l + j ) * ( mnkl + j ) );
pt = pt + p;
}
}
if ( p == 0.0 )
{
*ifault = 3;
}
if ( dir )
{
value = value + ( pt / scale );
}
else
{
value = 1.0 - ( pt / scale );
}
}
return value;
}
double prncst ( double st, int idf, double d, int *ifault )
/******************************************************************************/
/*
Purpose:
PRNCST computes the lower tail of noncentral T distribution.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
23 October 2010
Author:
Original FORTRAN77 version by BE Cooper.
C version by John Burkardt.
Reference:
BE Cooper,
Algorithm AS 5:
The Integral of the Non-Central T-Distribution,
Applied Statistics,
Volume 17, Number 2, 1968, page 193.
Parameters:
Input, double ST, the argument.
Input, int IDF, the number of degrees of freedom.
Input, double D, the noncentrality parameter.
Output, int *IFAULT, error flag.
0, no error occurred.
nonzero, an error occurred.
Output, double PRNCST, the value of the lower tail of
the noncentral T distribution.
Local Parameters:
Local, double G1, 1.0 / sqrt(2.0 * pi)
Local, double G2, 1.0 / (2.0 * pi)
Local, double G3, sqrt(2.0 * pi)
*/
{
double a;
double ak;
double b;
double da;
double drb;
double emin = 12.5;
double f;
double fk;
double fkm1;
double fmkm1;
double fmkm2;
double g1 = 0.3989422804;
double g2 = 0.1591549431;
double g3 = 2.5066282746;
int ioe;
int k;
double rb;
double sum;
double value;
f = ( double ) ( idf );
/*
For very large IDF, use the normal approximation.
*/
if ( 100 < idf )
{
*ifault = 1;
a = sqrt ( 0.5 * f )
* exp ( alngam ( 0.5 * ( f - 1.0 ), &k )
- alngam ( 0.5 * f, &k ) ) * d;
value = alnorm ( ( st - a ) / sqrt ( f * ( 1.0 + d * d )
/ ( f - 2.0 ) - a * a ), 0 );
return value;
}
*ifault = 0;
ioe = ( idf % 2 );
a = st / sqrt ( f );
b = f / ( f + st * st );
rb = sqrt ( b );
da = d * a;
drb = d * rb;
if ( idf == 1 )
{
value = alnorm ( drb, 1 ) + 2.0 * tfn ( drb, a );
return value;
}
sum = 0.0;
if ( r8_abs ( drb ) < emin )
{
fmkm2 = a * rb * exp ( - 0.5 * drb * drb )
* alnorm ( a * drb, 0 ) * g1;
}
else
{
fmkm2 = 0.0;
}
fmkm1 = b * da * fmkm2;
if ( r8_abs ( d ) < emin )
{
fmkm1 = fmkm1 + b * a * g2 * exp ( - 0.5 * d * d );
}
if ( ioe == 0 )
{
sum = fmkm2;
}
else
{
sum = fmkm1;
}
ak = 1.0;
fk = 2.0;
for ( k = 2; k <= idf - 2; k = k + 2 )
{
fkm1 = fk - 1.0;
fmkm2 = b * ( da * ak * fmkm1 + fmkm2 ) * fkm1 / fk;
ak = 1.0 / ( ak * fkm1 );
fmkm1 = b * ( da * ak * fmkm2 + fmkm1 ) * fk / ( fk + 1.0 );
if ( ioe == 0 )
{
sum = sum + fmkm2;
}
else
{
sum = sum + fmkm1;
}
ak = 1.0 / ( ak * fk );
fk = fk + 2.0;
}
if ( ioe == 0 )
{
value = alnorm ( d, 1 ) + sum * g3;
}
else
{
value = alnorm ( drb, 1 ) + 2.0 * ( sum + tfn ( drb, a ) );
}
return value;
}
double gammad(double x, double p) {
//! ALGORITHM AS239 APPL. STATIST. (1988) VOL. 37, NO. 3
//! Computation of the Incomplete Gamma Integral
//! Auxiliary functions required: ALNORM = algorithm AS66 (included) & LNGAMMA
//! Converted to be compatible with ELF90 by Alan Miller
//! N.B. The return parameter IFAULT has been removed as ELF90 allows only
//! one output parameter from functions. An error message is issued instead.
double gamma_prob;
double pn1, pn2, pn3, pn4, pn5, pn6, tol = 1.e-14, oflo = 1.e+37;
double xbig = 1.e+8, arg, c, rn, a, b, one = 1.0, zero = 0.0, an;
double two = 2.0, elimit = -88.0, plimit = 1000.0, three = 3.0;
double nine = 9;
gamma_prob = zero;
if (p <= zero || x < EPSILON) {
return 0.0;
}
// Use a normal approximation if P > PLIMIT
if (p > plimit) {
pn1 = three * sqrt(p) * (pow(x/p,one/three) + one / (nine * p) - one);
return alnorm(pn1, false);
}
// If X is extremely large compared to P then set gamma_prob = 1
if (x > xbig) {
return one;
}
if (x <= one || x < p) {
//! Use Pearson's series expansion.
//! (Note that P is not large enough to force overflow in LNGAMMA)
arg = p * log(x) - x - lngamma(p + one);
c = one;
gamma_prob = one;
a = p;
do {
a = a + one;
c = c * x / a;
gamma_prob = gamma_prob + c;
} while (c >= tol);
arg = arg + log(gamma_prob);
gamma_prob = zero;
if (arg >= elimit) {
gamma_prob = exp(arg);
}
} else {
//! Use a continued fraction expansion
arg = p * log(x) - x - lngamma(p);
a = one - p;
b = a + x + one;
c = zero;
pn1 = one;
pn2 = x;
pn3 = x + one;
pn4 = x * b;
gamma_prob = pn3 / pn4;
do {
a = a + one;
b = b + two;
c = c + one;
an = a * c;
pn5 = b * pn3 - an * pn1;
pn6 = b * pn4 - an * pn2;
if (fabs(pn6) > zero) {
rn = pn5 / pn6;
if(fabs(gamma_prob - rn) <= MIN(tol, tol * rn))
break;
gamma_prob = rn;
}
pn1 = pn3;
pn2 = pn4;
pn3 = pn5;
pn4 = pn6;
if (fabs(pn5) >= oflo) {
// ! Re-scale terms in continued fraction if terms are large
pn1 = pn1 / oflo;
pn2 = pn2 / oflo;
pn3 = pn3 / oflo;
pn4 = pn4 / oflo;
}
} while (true);
arg = arg + log(gamma_prob);
gamma_prob = one;
if (arg >= elimit) {
gamma_prob = one - exp(arg);
}
}
return gamma_prob;
}
