static double hy1f1a (double a, double b, double x, double *err)
{
double h1, h2, t, u, temp, acanc, asum, err1, err2;
if (x == 0) {
acanc = 1.0;
asum = MAXNUM;
goto adone;
}
temp = log(fabs(x));
t = x + temp * (a-b);
u = -temp * a;
if (b > 0) {
temp = lgam(b);
t += temp;
u += temp;
}
h1 = hyp2f0(a, a-b+1, -1.0/x, 1, &err1);
temp = exp(u) / cephes_gamma(b-a);
h1 *= temp;
err1 *= temp;
h2 = hyp2f0(b-a, 1.0-a, 1.0/x, 2, &err2);
if (a < 0)
temp = exp(t) / cephes_gamma(a);
else
temp = exp(t - lgam(a));
h2 *= temp;
err2 *= temp;
if (x < 0.0)
asum = h1;
else
asum = h2;
acanc = fabs(err1) + fabs(err2);
if (b < 0) {
temp = cephes_gamma(b);
asum *= temp;
acanc *= fabs(temp);
}
if (asum != 0.0)
acanc /= fabs(asum);
/* fudge factor, since error of asymptotic formula
often seems this much larger than advertised
*/
acanc *= 30.0;
adone:
*err = acanc;
return asum;
}
static double jvs(double n, double x)
{
double t, u, y, z, k;
int ex;
z = -x * x / 4.0;
u = 1.0;
y = u;
k = 1.0;
t = 1.0;
while (t > MACHEP) {
u *= z / (k * (n + k));
y += u;
k += 1.0;
if (y != 0)
t = fabs(u / y);
}
#if CEPHES_DEBUG
printf("power series=%.5e ", y);
#endif
t = frexp(0.5 * x, &ex);
ex = ex * n;
if ((ex > -1023)
&& (ex < 1023)
&& (n > 0.0)
&& (n < (MAXGAM - 1.0))) {
t = pow(0.5 * x, n) / gamma(n + 1.0);
#if CEPHES_DEBUG
printf("pow(.5*x, %.4e)/gamma(n+1)=%.5e\n", n, t);
#endif
y *= t;
} else {
#if CEPHES_DEBUG
z = n * log(0.5 * x);
k = lgam(n + 1.0);
t = z - k;
printf("log pow=%.5e, lgam(%.4e)=%.5e\n", z, n + 1.0, k);
#else
t = n * log(0.5 * x) - lgam(n + 1.0);
#endif
if (y < 0) {
sgngam = -sgngam;
y = -y;
}
t += log(y);
#if CEPHES_DEBUG
printf("log y=%.5e\n", log(y));
#endif
if (t < -MAXLOG) {
return (0.0);
}
if (t > MAXLOG) {
mtherr("Jv", OVERFLOW);
return (MAXNUM);
}
y = sgngam * exp(t);
}
return (y);
}
double igam( double a, double x )
{
double ans, ax, c, r;
if( (x <= 0) || ( a <= 0) )
return( 0.0 );
if( (x > 1.0) && (x > a ) )
return( 1.0 - igamc(a,x) );
/* Compute x**a * exp(-x) / gamma(a) */
ax = a * log(x) - x - lgam(a);
if( ax < -MAXLOG )
{
mtherr( "igam", UNDERFLOW );
return( 0.0 );
}
ax = exp(ax);
/* power series */
r = a;
c = 1.0;
ans = 1.0;
do
{
r += 1.0;
c *= x/r;
ans += c;
}
while( c/ans > MACHEP );
return( ans * ax/a );
}
inline long double lgamma(long double x)
{
#ifdef BOOST_MSVC
return lgam((double)x);
#else
return lgaml(x);
#endif
}
/* Compute lgam(x + 1). */
double lgam1p(double x)
{
if (fabs(x) <= 0.5) {
return lgam1p_taylor(x);
} else if (fabs(x - 1) < 0.5) {
return log(x) + lgam1p_taylor(x - 1);
} else {
return lgam(x + 1);
}
}
/* Exact Smirnov statistic, for one-sided test. */
double smirnov(int n, double e)
{
int v, nn;
double evn, omevn, p, t, c, lgamnp1;
/* This comparison should assure returning NaN whenever
* e is NaN itself. In original || form it would proceed */
if (!(n > 0 && e >= 0.0 && e <= 1.0))
return (NPY_NAN);
if (e == 0.0)
return 1.0;
nn = (int) (floor((double) n * (1.0 - e)));
p = 0.0;
if (n < 1013) {
c = 1.0;
for (v = 0; v <= nn; v++) {
evn = e + ((double) v) / n;
p += c * pow(evn, (double) (v - 1))
* pow(1.0 - evn, (double) (n - v));
/* Next combinatorial term; worst case error = 4e-15. */
c *= ((double) (n - v)) / (v + 1);
}
}
else {
lgamnp1 = lgam((double) (n + 1));
for (v = 0; v <= nn; v++) {
evn = e + ((double) v) / n;
omevn = 1.0 - evn;
if (fabs(omevn) > 0.0) {
t = lgamnp1 - lgam((double) (v + 1))
- lgam((double) (n - v + 1))
+ (v - 1) * log(evn)
+ (n - v) * log(omevn);
if (t > -MAXLOG)
p += exp(t);
}
}
}
return (p * e);
}
static double pseries( double a, double b, double x )
{
double s, t, u, v, n, t1, z, ai;
ai = 1.0 / a;
u = (1.0 - b) * x;
v = u / (a + 1.0);
t1 = v;
t = u;
n = 2.0;
s = 0.0;
z = MACHEP * ai;
while( fabs(v) > z )
{
u = (n - b) * x / n;
t *= u;
v = t / (a + n);
s += v;
n += 1.0;
}
s += t1;
s += ai;
u = a * log(x);
if( (a+b) < MAXGAM && fabs(u) < MAXLOG )
{
t = gammafn(a+b)/(gammafn(a)*gammafn(b));
s = s * t * pow(x,a);
}
else
{
t = lgam(a+b) - lgam(a) - lgam(b) + u + log(s);
if( t < MINLOG )
s = 0.0;
else
s = exp(t);
}
return(s);
}
static DBL igam(DBL a, DBL x)
{
DBL ans, ax, c, r;
int sgngam = 0;
if ((x <= 0) || (a <= 0))
{
return (0.0);
}
if ((x > 1.0) && (x > a))
{
return (1.0 - igamc(a, x));
}
/* Compute x**a * exp(-x) / gamma(a) */
ax = a * log(x) - x - lgam(a, &sgngam);
if (ax < -MAXLOG)
{
/*
mtherr("igam", UNDERFLOW);
*/
return (0.0);
}
ax = exp(ax);
/* power series */
r = a;
c = 1.0;
ans = 1.0;
do
{
r += 1.0;
c *= x / r;
ans += c;
}
while (c / ans > MACHEP);
return (ans * ax / a);
}
/*
* Large-z expansion for Struve H and L
* http://dlmf.nist.gov/11.6.1
*/
double struve_asymp_large_z(double v, double z, int is_h, double *err)
{
int n, sgn, maxiter;
double term, sum, maxterm;
double m;
if (is_h) {
sgn = -1;
}
else {
sgn = 1;
}
/* Asymptotic expansion divergenge point */
m = z/2;
if (m <= 0) {
maxiter = 0;
}
else if (m > MAXITER) {
maxiter = MAXITER;
}
else {
maxiter = (int)m;
}
if (maxiter == 0) {
*err = NPY_INFINITY;
return NPY_NAN;
}
if (z < v) {
/* Exclude regions where our error estimation fails */
*err = NPY_INFINITY;
return NPY_NAN;
}
/* Evaluate sum */
term = -sgn / sqrt(M_PI) * exp(-lgam(v + 0.5) + (v - 1) * log(z/2)) * gammasgn(v + 0.5);
sum = term;
maxterm = 0;
for (n = 0; n < maxiter; ++n) {
term *= sgn * (1 + 2*n) * (1 + 2*n - 2*v) / (z*z);
sum += term;
if (fabs(term) > maxterm) {
maxterm = fabs(term);
}
if (fabs(term) < SUM_EPS * fabs(sum) || term == 0 || !npy_isfinite(sum)) {
break;
}
}
if (is_h) {
sum += bessel_y(v, z);
}
else {
sum += bessel_i(v, z);
}
/*
* This error estimate is strictly speaking valid only for
* n > v - 0.5, but numerical results indicate that it works
* reasonably.
*/
*err = fabs(term) + fabs(maxterm) * 1e-16;
return sum;
}
double incbet( double aa, double bb, double xx )
{
double a, b, t, x, xc, w, y;
int flag;
if( aa <= 0.0 || bb <= 0.0 )
goto domerr;
if( (xx <= 0.0) || ( xx >= 1.0) )
{
if( xx == 0.0 )
return(0.0);
if( xx == 1.0 )
return( 1.0 );
domerr:
mtherr( "incbet", DOMAIN );
return( 0.0 );
}
flag = 0;
if( (bb * xx) <= 1.0 && xx <= 0.95)
{
t = pseries(aa, bb, xx);
goto done;
}
w = 1.0 - xx;
/* Reverse a and b if x is greater than the mean. */
if( xx > (aa/(aa+bb)) )
{
flag = 1;
a = bb;
b = aa;
xc = xx;
x = w;
}
else
{
a = aa;
b = bb;
xc = w;
x = xx;
}
if( flag == 1 && (b * x) <= 1.0 && x <= 0.95)
{
t = pseries(a, b, x);
goto done;
}
/* Choose expansion for better convergence. */
y = x * (a+b-2.0) - (a-1.0);
if( y < 0.0 )
w = incbcf( a, b, x );
else
w = incbd( a, b, x ) / xc;
/* Multiply w by the factor
a b _ _ _
x (1-x) | (a+b) / ( a | (a) | (b) ) . */
y = a * log(x);
t = b * log(xc);
if( (a+b) < MAXGAM && fabs(y) < MAXLOG && fabs(t) < MAXLOG )
{
t = pow(xc,b);
t *= pow(x,a);
t /= a;
t *= w;
t *= gammafn(a+b) / (gammafn(a) * gammafn(b));
goto done;
}
/* Resort to logarithms. */
y += t + lgam(a+b) - lgam(a) - lgam(b);
y += log(w/a);
if( y < MINLOG )
t = 0.0;
else
t = exp(y);
done:
if( flag == 1 )
{
if( t <= MACHEP )
t = 1.0 - MACHEP;
else
t = 1.0 - t;
}
return( t );
}
static DBL igami(DBL a, DBL y0)
{
DBL d, y, x0, lgm;
int i;
int sgngam = 0;
/* approximation to inverse function */
d = 1.0 / (9.0 * a);
y = (1.0 - d - ndtri(y0) * sqrt(d));
x0 = a * y * y * y;
lgm = lgam(a, &sgngam);
for (i = 0; i < 10; i++)
{
if (x0 <= 0.0)
{
/*
mtherr("igami", UNDERFLOW);
*/
return (0.0);
}
y = igamc(a, x0);
/* compute the derivative of the function at this point */
d = (a - 1.0) * log(x0) - x0 - lgm;
if (d < -MAXLOG)
{
/*
mtherr("igami", UNDERFLOW);
*/
goto done;
}
d = -exp(d);
/* compute the step to the next approximation of x */
if (d == 0.0)
{
goto done;
}
d = (y - y0) / d;
x0 = x0 - d;
if (i < 3)
{
continue;
}
if (fabs(d / x0) < 2.0 * MACHEP)
{
goto done;
}
}
done:
return (x0);
}
static DBL igamc(DBL a, DBL x)
{
DBL ans, c, yc, ax, y, z;
DBL pk, pkm1, pkm2, qk, qkm1, qkm2;
DBL r, t;
int sgngam = 0;
if ((x <= 0) || (a <= 0))
{
return (1.0);
}
if ((x < 1.0) || (x < a))
{
return (1.0 - igam(a, x));
}
ax = a * log(x) - x - lgam(a, &sgngam);
if (ax < -MAXLOG)
{
/*
mtherr("igamc", UNDERFLOW);
*/
return (0.0);
}
ax = exp(ax);
/* continued fraction */
y = 1.0 - a;
z = x + y + 1.0;
c = 0.0;
pkm2 = 1.0;
qkm2 = x;
pkm1 = x + 1.0;
qkm1 = z * x;
ans = pkm1 / qkm1;
do
{
c += 1.0;
y += 1.0;
z += 2.0;
yc = y * c;
pk = pkm1 * z - pkm2 * yc;
qk = qkm1 * z - qkm2 * yc;
if (qk != 0)
{
r = pk / qk;
t = fabs((ans - r) / r);
ans = r;
}
else
{
t = 1.0;
}
pkm2 = pkm1;
pkm1 = pk;
qkm2 = qkm1;
qkm1 = qk;
if (fabs(pk) > BIG)
{
pkm2 /= BIG;
pkm1 /= BIG;
qkm2 /= BIG;
qkm1 /= BIG;
}
}
while (t > MACHEP);
return (ans * ax);
}
double igamc( double a, double x )
{
double ans, ax, c, yc, r, t, y, z;
double pk, pkm1, pkm2, qk, qkm1, qkm2;
if( (x <= 0) || ( a <= 0) )
return( 1.0 );
if( (x < 1.0) || (x < a) )
return( 1.0 - igam(a,x) );
ax = a * log(x) - x - lgam(a);
if( ax < -MAXLOG )
{
mtherr( "igamc", UNDERFLOW );
return( 0.0 );
}
ax = exp(ax);
/* continued fraction */
y = 1.0 - a;
z = x + y + 1.0;
c = 0.0;
pkm2 = 1.0;
qkm2 = x;
pkm1 = x + 1.0;
qkm1 = z * x;
ans = pkm1/qkm1;
do
{
c += 1.0;
y += 1.0;
z += 2.0;
yc = y * c;
pk = pkm1 * z - pkm2 * yc;
qk = qkm1 * z - qkm2 * yc;
if( qk != 0 )
{
r = pk/qk;
t = fabs( (ans - r)/r );
ans = r;
}
else
t = 1.0;
pkm2 = pkm1;
pkm1 = pk;
qkm2 = qkm1;
qkm1 = qk;
if( fabs(pk) > big )
{
pkm2 *= biginv;
pkm1 *= biginv;
qkm2 *= biginv;
qkm1 *= biginv;
}
}
while( t > MACHEP );
return( ans * ax );
}
double lgam(double x)
{
double p, q, u, w, z;
int i;
sgngam = 1;
if (!npy_isfinite(x))
return x;
if (x < -34.0) {
q = -x;
w = lgam(q); /* note this modifies sgngam! */
p = floor(q);
if (p == q) {
lgsing:
mtherr("lgam", SING);
return (NPY_INFINITY);
}
i = p;
if ((i & 1) == 0)
sgngam = -1;
else
sgngam = 1;
z = q - p;
if (z > 0.5) {
p += 1.0;
z = p - q;
}
z = q * sin(NPY_PI * z);
if (z == 0.0)
goto lgsing;
/* z = log(NPY_PI) - log( z ) - w; */
z = LOGPI - log(z) - w;
return (z);
}
if (x < 13.0) {
z = 1.0;
p = 0.0;
u = x;
while (u >= 3.0) {
p -= 1.0;
u = x + p;
z *= u;
}
while (u < 2.0) {
if (u == 0.0)
goto lgsing;
z /= u;
p += 1.0;
u = x + p;
}
if (z < 0.0) {
sgngam = -1;
z = -z;
}
else
sgngam = 1;
if (u == 2.0)
return (log(z));
p -= 2.0;
x = x + p;
p = x * polevl(x, B, 5) / p1evl(x, C, 6);
return (log(z) + p);
}
if (x > MAXLGM) {
return (sgngam * NPY_INFINITY);
}
q = (x - 0.5) * log(x) - x + LS2PI;
if (x > 1.0e8)
return (q);
p = 1.0 / (x * x);
if (x >= 1000.0)
q += ((7.9365079365079365079365e-4 * p
- 2.7777777777777777777778e-3) * p
+ 0.0833333333333333333333) / x;
else
q += polevl(p, A, 4) / x;
return (q);
}
int main()
{
printf("%f \n", lgam(5.2));
}
/*
* Power series for Struve H and L
* http://dlmf.nist.gov/11.2.1
*
* Starts to converge roughly at |n| > |z|
*/
double struve_power_series(double v, double z, int is_h, double *err)
{
int n, sgn;
double term, sum, maxterm, scaleexp, tmp;
double2_t cterm, csum, cdiv, z2, c2v, ctmp, ctmp2;
if (is_h) {
sgn = -1;
}
else {
sgn = 1;
}
tmp = -lgam(v + 1.5) + (v + 1)*log(z/2);
if (tmp < -600 || tmp > 600) {
/* Scale exponent to postpone underflow/overflow */
scaleexp = tmp/2;
tmp -= scaleexp;
}
else {
scaleexp = 0;
}
term = 2 / sqrt(M_PI) * exp(tmp) * gammasgn(v + 1.5);
sum = term;
maxterm = 0;
double2_init(&cterm, term);
double2_init(&csum, sum);
double2_init(&z2, sgn*z*z);
double2_init(&c2v, 2*v);
for (n = 0; n < MAXITER; ++n) {
/* cdiv = (3 + 2*n) * (3 + 2*n + 2*v)) */
double2_init(&cdiv, 3 + 2*n);
double2_init(&ctmp, 3 + 2*n);
double2_add(&ctmp, &c2v, &ctmp);
double2_mul(&cdiv, &ctmp, &cdiv);
/* cterm *= z2 / cdiv */
double2_mul(&cterm, &z2, &cterm);
double2_div(&cterm, &cdiv, &cterm);
double2_add(&csum, &cterm, &csum);
term = double2_double(&cterm);
sum = double2_double(&csum);
if (fabs(term) > maxterm) {
maxterm = fabs(term);
}
if (fabs(term) < SUM_TINY * fabs(sum) || term == 0 || !npy_isfinite(sum)) {
break;
}
}
*err = fabs(term) + fabs(maxterm) * 1e-22;
if (scaleexp != 0) {
sum *= exp(scaleexp);
*err *= exp(scaleexp);
}
if (sum == 0 && term == 0 && v < 0 && !is_h) {
/* Spurious underflow */
*err = NPY_INFINITY;
return NPY_NAN;
}
return sum;
}
static double struve_hl(double v, double z, int is_h)
{
double value[4], err[4], tmp;
int n;
if (z < 0) {
n = v;
if (v == n) {
tmp = (n % 2 == 0) ? -1 : 1;
return tmp * struve_hl(v, -z, is_h);
}
else {
return NPY_NAN;
}
}
else if (z == 0) {
if (v < -1) {
return gammasgn(v + 1.5) * NPY_INFINITY;
}
else if (v == -1) {
return 2 / sqrt(M_PI) / Gamma(0.5);
}
else {
return 0;
}
}
n = -v - 0.5;
if (n == -v - 0.5 && n > 0) {
if (is_h) {
return (n % 2 == 0 ? 1 : -1) * bessel_j(n + 0.5, z);
}
else {
return bessel_i(n + 0.5, z);
}
}
/* Try the asymptotic expansion */
if (z >= 0.7*v + 12) {
value[0] = struve_asymp_large_z(v, z, is_h, &err[0]);
if (err[0] < GOOD_EPS * fabs(value[0])) {
return value[0];
}
}
else {
err[0] = NPY_INFINITY;
}
/* Try power series */
value[1] = struve_power_series(v, z, is_h, &err[1]);
if (err[1] < GOOD_EPS * fabs(value[1])) {
return value[1];
}
/* Try bessel series */
if (fabs(z) < fabs(v) + 20) {
value[2] = struve_bessel_series(v, z, is_h, &err[2]);
if (err[2] < GOOD_EPS * fabs(value[2])) {
return value[2];
}
}
else {
err[2] = NPY_INFINITY;
}
/* Return the best of the three, if it is acceptable */
n = 0;
if (err[1] < err[n]) n = 1;
if (err[2] < err[n]) n = 2;
if (err[n] < ACCEPTABLE_EPS * fabs(value[n]) || err[n] < ACCEPTABLE_ATOL) {
return value[n];
}
/* Maybe it really is an overflow? */
tmp = -lgam(v + 1.5) + (v + 1)*log(z/2);
if (!is_h) {
tmp = fabs(tmp);
}
if (tmp > 700) {
sf_error("struve", SF_ERROR_OVERFLOW, "overflow in series");
return NPY_INFINITY * gammasgn(v + 1.5);
}
/* Failure */
sf_error("struve", SF_ERROR_NO_RESULT, "total loss of precision");
return NPY_NAN;
}
inline double lgamma(double x)
{ return lgam(x); }
static DBL lgam(DBL x, int *sgngam)
{
DBL p, q, w, z;
int i;
*sgngam = 1;
if (x < -34.0)
{
q = -x;
w = lgam(q, sgngam); /* note this modifies sgngam! */
p = floor(q);
if (p == q)
{
goto loverf;
}
i = p;
if ((i & 1) == 0)
{
*sgngam = -1;
}
else
{
*sgngam = 1;
}
z = q - p;
if (z > 0.5)
{
p += 1.0;
z = p - q;
}
z = q * sin(M_PI * z);
if (z == 0.0)
{
goto loverf;
}
/* z = log(M_PI) - log( z ) - w;*/
z = LOGPI - log(z) - w;
return (z);
}
if (x < 13.0)
{
z = 1.0;
while (x >= 3.0)
{
x -= 1.0;
z *= x;
}
while (x < 2.0)
{
if (x == 0.0)
{
goto loverf;
}
z /= x;
x += 1.0;
}
if (z < 0.0)
{
*sgngam = -1;
z = -z;
}
else
{
*sgngam = 1;
}
if (x == 2.0)
{
return (log(z));
}
x -= 2.0;
p = x * polevl(x, B, 5) / p1evl(x, C, 6);
return (log(z) + p);
}
if (x > MAXLGM)
{
loverf:
/*
mtherr("lgam", OVERFLOW);
*/
return (*sgngam * MAXNUM);
}
q = (x - 0.5) * log(x) - x + LS2PI;
if (x > 1.0e8)
{
return (q);
}
p = 1.0 / (x * x);
if (x >= 1000.0)
{
q += ((7.9365079365079365079365e-4 * p -
2.7777777777777777777778e-3) * p +
0.0833333333333333333333) / x;
}
else
{
q += polevl(p, A, 4) / x;
}
return (q);
}
double igami( double a, double y0 )
{
double x0, x1, x, yl, yh, y, d, lgm, dithresh;
int i, dir;
/* bound the solution */
x0 = MAXNUM;
yl = 0;
x1 = 0;
yh = 1.0;
dithresh = 5.0 * MACHEP;
/* approximation to inverse function */
d = 1.0/(9.0*a);
y = ( 1.0 - d - ndtri(y0) * sqrt(d) );
x = a * y * y * y;
lgm = lgam(a);
for( i=0; i<10; i++ )
{
if( x > x0 || x < x1 )
goto ihalve;
y = igamc(a,x);
if( y < yl || y > yh )
goto ihalve;
if( y < y0 )
{
x0 = x;
yl = y;
}
else
{
x1 = x;
yh = y;
}
/* compute the derivative of the function at this point */
d = (a - 1.0) * log(x) - x - lgm;
if( d < -MAXLOG )
goto ihalve;
d = -exp(d);
/* compute the step to the next approximation of x */
d = (y - y0)/d;
if( fabs(d/x) < MACHEP )
goto done;
x = x - d;
}
/* Resort to interval halving if Newton iteration did not converge. */
ihalve:
d = 0.0625;
if( x0 == MAXNUM )
{
if( x <= 0.0 )
x = 1.0;
while( x0 == MAXNUM )
{
x = (1.0 + d) * x;
y = igamc( a, x );
if( y < y0 )
{
x0 = x;
yl = y;
break;
}
d = d + d;
}
}
d = 0.5;
dir = 0;
for( i=0; i<400; i++ )
{
x = x1 + d * (x0 - x1);
y = igamc( a, x );
lgm = (x0 - x1)/(x1 + x0);
if( fabs(lgm) < dithresh )
break;
lgm = (y - y0)/y0;
if( fabs(lgm) < dithresh )
break;
if( x <= 0.0 )
break;
if( y >= y0 )
{
x1 = x;
yh = y;
if( dir < 0 )
{
dir = 0;
d = 0.5;
}
else if( dir > 1 )
d = 0.5 * d + 0.5;
else
d = (y0 - yl)/(yh - yl);
dir += 1;
}
else
{
x0 = x;
yl = y;
if( dir > 0 )
{
dir = 0;
d = 0.5;
}
else if( dir < -1 )
d = 0.5 * d;
else
d = (y0 - yl)/(yh - yl);
dir -= 1;
}
}
if( x == 0.0 )
mtherr( "igami", UNDERFLOW );
done:
return( x );
}
static double find_inverse_gamma(double a, double p, double q)
{
/*
* In order to understand what's going on here, you will
* need to refer to:
*
* Computation of the Incomplete Gamma Function Ratios and their Inverse
* ARMIDO R. DIDONATO and ALFRED H. MORRIS, JR.
* ACM Transactions on Mathematical Software, Vol. 12, No. 4,
* December 1986, Pages 377-393.
*/
double result;
if (a == 1) {
if (q > 0.9) {
result = -log1p(-p);
}
else {
result = -log(q);
}
}
else if (a < 1) {
double g = Gamma(a);
double b = q * g;
if ((b > 0.6) || ((b >= 0.45) && (a >= 0.3))) {
/* DiDonato & Morris Eq 21:
*
* There is a slight variation from DiDonato and Morris here:
* the first form given here is unstable when p is close to 1,
* making it impossible to compute the inverse of Q(a,x) for small
* q. Fortunately the second form works perfectly well in this case.
*/
double u;
if((b * q > 1e-8) && (q > 1e-5)) {
u = pow(p * g * a, 1 / a);
}
else {
u = exp((-q / a) - NPY_EULER);
}
result = u / (1 - (u / (a + 1)));
}
else if ((a < 0.3) && (b >= 0.35)) {
/* DiDonato & Morris Eq 22: */
double t = exp(-NPY_EULER - b);
double u = t * exp(t);
result = t * exp(u);
}
else if ((b > 0.15) || (a >= 0.3)) {
/* DiDonato & Morris Eq 23: */
double y = -log(b);
double u = y - (1 - a) * log(y);
result = y - (1 - a) * log(u) - log(1 + (1 - a) / (1 + u));
}
else if (b > 0.1) {
/* DiDonato & Morris Eq 24: */
double y = -log(b);
double u = y - (1 - a) * log(y);
result = y - (1 - a) * log(u)
- log((u * u + 2 * (3 - a) * u + (2 - a) * (3 - a))
/ (u * u + (5 - a) * u + 2));
}
else {
/* DiDonato & Morris Eq 25: */
double y = -log(b);
double c1 = (a - 1) * log(y);
double c1_2 = c1 * c1;
double c1_3 = c1_2 * c1;
double c1_4 = c1_2 * c1_2;
double a_2 = a * a;
double a_3 = a_2 * a;
double c2 = (a - 1) * (1 + c1);
double c3 = (a - 1) * (-(c1_2 / 2)
+ (a - 2) * c1
+ (3 * a - 5) / 2);
double c4 = (a - 1) * ((c1_3 / 3) - (3 * a - 5) * c1_2 / 2
+ (a_2 - 6 * a + 7) * c1
+ (11 * a_2 - 46 * a + 47) / 6);
double c5 = (a - 1) * (-(c1_4 / 4)
+ (11 * a - 17) * c1_3 / 6
+ (-3 * a_2 + 13 * a -13) * c1_2
+ (2 * a_3 - 25 * a_2 + 72 * a - 61) * c1 / 2
+ (25 * a_3 - 195 * a_2 + 477 * a - 379) / 12);
double y_2 = y * y;
double y_3 = y_2 * y;
double y_4 = y_2 * y_2;
result = y + c1 + (c2 / y) + (c3 / y_2) + (c4 / y_3) + (c5 / y_4);
}
}
else {
/* DiDonato and Morris Eq 31: */
double s = find_inverse_s(p, q);
double s_2 = s * s;
double s_3 = s_2 * s;
double s_4 = s_2 * s_2;
double s_5 = s_4 * s;
double ra = sqrt(a);
double w = a + s * ra + (s_2 - 1) / 3;
w += (s_3 - 7 * s) / (36 * ra);
w -= (3 * s_4 + 7 * s_2 - 16) / (810 * a);
w += (9 * s_5 + 256 * s_3 - 433 * s) / (38880 * a * ra);
if ((a >= 500) && (fabs(1 - w / a) < 1e-6)) {
result = w;
}
else if (p > 0.5) {
if (w < 3 * a) {
result = w;
}
else {
double D = fmax(2, a * (a - 1));
double lg = lgam(a);
double lb = log(q) + lg;
if (lb < -D * 2.3) {
/* DiDonato and Morris Eq 25: */
double y = -lb;
double c1 = (a - 1) * log(y);
double c1_2 = c1 * c1;
double c1_3 = c1_2 * c1;
double c1_4 = c1_2 * c1_2;
double a_2 = a * a;
double a_3 = a_2 * a;
double c2 = (a - 1) * (1 + c1);
double c3 = (a - 1) * (-(c1_2 / 2)
+ (a - 2) * c1
+ (3 * a - 5) / 2);
double c4 = (a - 1) * ((c1_3 / 3)
- (3 * a - 5) * c1_2 / 2
+ (a_2 - 6 * a + 7) * c1
+ (11 * a_2 - 46 * a + 47) / 6);
double c5 = (a - 1) * (-(c1_4 / 4)
+ (11 * a - 17) * c1_3 / 6
+ (-3 * a_2 + 13 * a -13) * c1_2
+ (2 * a_3 - 25 * a_2 + 72 * a - 61) * c1 / 2
+ (25 * a_3 - 195 * a_2 + 477 * a - 379) / 12);
double y_2 = y * y;
double y_3 = y_2 * y;
double y_4 = y_2 * y_2;
result = y + c1 + (c2 / y) + (c3 / y_2) + (c4 / y_3) + (c5 / y_4);
}
else {
/* DiDonato and Morris Eq 33: */
double u = -lb + (a - 1) * log(w) - log(1 + (1 - a) / (1 + w));
result = -lb + (a - 1) * log(u) - log(1 + (1 - a) / (1 + u));
}
}
}
else {
double z = w;
double ap1 = a + 1;
double ap2 = a + 2;
if (w < 0.15 * ap1) {
/* DiDonato and Morris Eq 35: */
double v = log(p) + lgam(ap1);
z = exp((v + w) / a);
s = log1p(z / ap1 * (1 + z / ap2));
z = exp((v + z - s) / a);
s = log1p(z / ap1 * (1 + z / ap2));
z = exp((v + z - s) / a);
s = log1p(z / ap1 * (1 + z / ap2 * (1 + z / (a + 3))));
z = exp((v + z - s) / a);
}
if ((z <= 0.01 * ap1) || (z > 0.7 * ap1)) {
result = z;
}
else {
/* DiDonato and Morris Eq 36: */
double ls = log(didonato_SN(a, z, 100, 1e-4));
double v = log(p) + lgam(ap1);
z = exp((v + z - ls) / a);
result = z * (1 - (a * log(z) - z - v + ls) / (a - z));
}
}
}
return result;
}
