static double find_inverse_s(double p, double q)
{
/*
* 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.
*
* See equation 32.
*/
double s, t;
double a[4] = {0.213623493715853, 4.28342155967104,
11.6616720288968, 3.31125922108741};
double b[5] = {0.3611708101884203e-1, 1.27364489782223,
6.40691597760039, 6.61053765625462, 1};
if (p < 0.5) {
t = sqrt(-2 * log(p));
}
else {
t = sqrt(-2 * log(q));
}
s = t - polevl(t, a, 3) / polevl(t, b, 4);
if(p < 0.5)
s = -s;
return s;
}
double ndtri(double y0)
{
double x, y, z, y2, x0, x1;
int code = 1;
y = y0;
if (y > (1.0 - 0.13533528323661269189)) { /* 0.135... = exp(-2) */
y = 1.0 - y;
code = 0;
}
if (y > 0.13533528323661269189) {
y = y - 0.5;
y2 = y * y;
x = y + y * (y2 * polevl(y2, P0, 4) / p1evl(y2, Q0, 8));
x = x * s2pi;
return (x);
}
x = sqrt(-2.0 * log(y));
x0 = x - log(x) / x;
z = 1.0 / x;
if (x < 8.0) /* y > exp(-32) = 1.2664165549e-14 */
x1 = z * polevl(z, P1, 8) / p1evl(z, Q1, 8);
else
x1 = z * polevl(z, P2, 8) / p1evl(z, Q2, 8);
x = x0 - x1;
if (code != 0)
x = -x;
return (x);
}
double erfc(double a)
{
double p,q,x,y,z;
if (isnan(a)) {
mtherr("erfc", DOMAIN);
return (NAN);
}
if( a < 0.0 )
x = -a;
else
x = a;
if( x < 1.0 )
return( 1.0 - erf(a) );
z = -a * a;
if( z < -MAXLOG )
{
under:
mtherr( "erfc", UNDERFLOW );
if( a < 0 )
return( 2.0 );
else
return( 0.0 );
}
z = exp(z);
if( x < 8.0 )
{
p = polevl( x, P, 8 );
q = p1evl( x, Q, 8 );
}
else
{
p = polevl( x, R, 5 );
q = p1evl( x, S, 6 );
}
y = (z * p)/q;
if( a < 0 )
y = 2.0 - y;
if( y == 0.0 )
goto under;
return(y);
}
void fresnl( double xxa, double *ssa, double *cca )
{
double f, g, cc, ss, c, s, t, u, x, x2;
/*debug double t1;*/
x = xxa;
x = fabs(x);
x2 = x * x;
if( x2 < 2.5625 )
{
t = x2 * x2;
ss = x * x2 * polevl( t, sn, 6);
cc = x * polevl( t, cn, 6);
goto done;
}
if( x > 36974.0 )
{
cc = 0.5;
ss = 0.5;
goto done;
}
/* Asymptotic power series auxiliary functions
* for large argument
*/
x2 = x * x;
t = PIF * x2;
u = 1.0/(t * t);
t = 1.0/t;
f = 1.0 - u * polevl( u, fn, 7);
g = t * polevl( u, gn, 7);
t = PIO2F * x2;
c = cos(t);
s = sin(t);
t = PIF * x;
cc = 0.5 + (f * s - g * c)/t;
ss = 0.5 - (f * c + g * s)/t;
done:
if( xxa < 0.0 )
{
cc = -cc;
ss = -ss;
}
*cca = cc;
*ssa = ss;
}
double exp2(double x)
{
double px, xx;
short n;
if (cephes_isnan(x))
return (x);
if (x > MAXL2) {
return (NPY_INFINITY);
}
if (x < MINL2) {
return (0.0);
}
xx = x; /* save x */
/* separate into integer and fractional parts */
px = floor(x + 0.5);
n = px;
x = x - px;
/* rational approximation
* exp2(x) = 1 + 2xP(xx)/(Q(xx) - P(xx))
* where xx = x**2
*/
xx = x * x;
px = x * polevl(xx, P, 2);
x = px / (p1evl(xx, Q, 2) - px);
x = 1.0 + ldexp(x, 1);
/* scale by power of 2 */
x = ldexp(x, n);
return (x);
}
double asinh(double xx)
{
double a, z, x;
int sign;
if(ISNAN(xx)) return xx;
if( xx == 0.0 ) return xx;
if( xx < 0.0 ) {
sign = -1;
x = -xx;
} else {
sign = 1;
x = xx;
}
if( x > 1.0e8 ) {
if( x == R_PosInf ) return xx;
return( sign * (log(x) + LOGE2) );
}
z = x * x;
if( x < 0.5 ) {
a = ( polevl(z, P, 4)/p1evl(z, Q, 4) ) * z;
a = a * x + x;
if( sign < 0 ) a = -a;
return a;
}
a = sqrt( z + 1.0 );
return sign * log(x + a);
}
/* Asymptotic expansion for large n, DLMF 8.20(ii) */
double expn_large_n(int n, double x)
{
int k;
double p = n;
double lambda = x/p;
double multiplier = 1/p/(lambda + 1)/(lambda + 1);
double fac = 1;
double res = 1; /* A[0] = 1 */
double expfac, term;
expfac = exp(-lambda*p)/(lambda + 1)/p;
if (expfac == 0) {
mtherr("expn", UNDERFLOW);
return 0;
}
/* Do the k = 1 term outside the loop since A[1] = 1 */
fac *= multiplier;
res += fac;
for (k = 2; k < nA; k++) {
fac *= multiplier;
term = fac*polevl(lambda, A[k], Adegs[k]);
res += term;
if (fabs(term) < MACHEP*fabs(res)) {
break;
}
}
return expfac*res;
}
double atanh(double x)
#ifdef __cplusplus
throw ()
#endif
{
double s, z;
if(ISNAN(x)) return x;
if( x == 0.0 ) return x;
z = fabs(x);
if( z >= 1.0 ) {
if( x == 1.0 ) return R_PosInf;
if( x == -1.0 ) return R_NegInf;
return NA_REAL;
}
if( z < 1.0e-7 ) return x;
if( z < 0.5 ) {
z = x * x;
s = x + x * z * (polevl(z, P, 4) / p1evl(z, Q, 5));
return s;
}
return 0.5 * log((1.0+x)/(1.0-x));
}
double cosm1(double x)
{
double xx;
if ((x < -CEPHES_PI_4) || (x > CEPHES_PI_4))
return (cos(x) - 1.0);
xx = x * x;
xx = -0.5 * xx + xx * xx * polevl(xx, coscof, 6);
return xx;
}
int fresnl(double xxa, double *ssa, double *cca)
{
double f, g, cc, ss, c, s, t, u;
double x, x2;
x = fabs(xxa);
x2 = x * x;
if (x2 < 2.5625) {
t = x2 * x2;
ss = x * x2 * polevl(t, sn, 5) / p1evl(t, sd, 6);
cc = x * polevl(t, cn, 5) / polevl(t, cd, 6);
goto done;
}
if (x > 36974.0) {
cc = 0.5;
ss = 0.5;
goto done;
}
/* Auxiliary functions for large argument */
x2 = x * x;
t = PI * x2;
u = 1.0 / (t * t);
t = 1.0 / t;
f = 1.0 - u * polevl(u, fn, 9) / p1evl(u, fd, 10);
g = t * polevl(u, gn, 10) / p1evl(u, gd, 11);
t = PIBYTWO * x2;
c = cos(t);
s = sin(t);
t = PI * x;
cc = 0.5 + (f * s - g * c) / t;
ss = 0.5 - (f * c + g * s) / t;
done:
if (xxa < 0.0) {
cc = -cc;
ss = -ss;
}
*cca = cc;
*ssa = ss;
return (0);
}
double log1p(double x)
{
double z;
z = 1.0 + x;
if ((z < CEPHES_SQRT1_2) || (z > CEPHES_SQRT2))
return (log(z));
z = x * x;
z = -0.5 * z + x * (z * polevl(x, LP, 6) / p1evl(x, LQ, 6));
return (x + z);
}
Real GaussianInv<Real>::calc(Real y0)
{
if (y0 <= 0)
return -Real_::max;
if (y0 >= 1)
return Real_::max;
int code = 1;
Real y = y0;
if (y > 1 - 0.13533528323661269189) /* 0.135... = exp(-2) */
{
y = 1 - y;
code = 0;
}
if (y > 0.13533528323661269189)
{
y = y - 0.5;
Real y2 = y * y;
Real x = y + y * (y2 * polevl(y2, P0, 4) / p1evl(y2, Q0, 8));
static const Real sqrtTwoPi = Alge::sqrt(Real_::piTwo);
x = x * sqrtTwoPi;
return x;
}
Real x = Alge::sqrt( -2 * Alge::log(y) );
Real x0 = x - Alge::log(x)/x;
Real z = 1/x;
Real x1;
if(x < 8) /* y > exp(-32) = 1.2664165549e-14 */
x1 = z * polevl(z, P1, 8) / p1evl(z, Q1, 8);
else
x1 = z * polevl(z, P2, 8) / p1evl(z, Q2, 8);
x = x0 - x1;
if(code != 0)
x = -x;
return x;
}
double expm1(double x)
{
double r, xx;
if (!cephes_isfinite(x)) {
if (cephes_isnan(x)) {
return x;
}
else if (x > 0) {
return x;
}
else {
return -1.0;
}
}
if ((x < -0.5) || (x > 0.5))
return (exp(x) - 1.0);
xx = x * x;
r = x * polevl(xx, EP, 2);
r = r / (polevl(xx, EQ, 3) - r);
return (r + r);
}
static double jnt(double n, double x)
{
double z, zz, z3;
double cbn, n23, cbtwo;
double ai, aip, bi, bip; /* Airy functions */
double nk, fk, gk, pp, qq;
double F[5], G[4];
int k;
cbn = cbrt(n);
z = (x - n) / cbn;
cbtwo = cbrt(2.0);
/* Airy function */
zz = -cbtwo * z;
airy(zz, &ai, &aip, &bi, &bip);
/* polynomials in expansion */
zz = z * z;
z3 = zz * z;
F[0] = 1.0;
F[1] = -z / 5.0;
F[2] = polevl(z3, PF2, 1) * zz;
F[3] = polevl(z3, PF3, 2);
F[4] = polevl(z3, PF4, 3) * z;
G[0] = 0.3 * zz;
G[1] = polevl(z3, PG1, 1);
G[2] = polevl(z3, PG2, 2) * z;
G[3] = polevl(z3, PG3, 2) * zz;
#if CEPHES_DEBUG
for (k = 0; k <= 4; k++)
printf("F[%d] = %.5E\n", k, F[k]);
for (k = 0; k <= 3; k++)
printf("G[%d] = %.5E\n", k, G[k]);
#endif
pp = 0.0;
qq = 0.0;
nk = 1.0;
n23 = cbrt(n * n);
for (k = 0; k <= 4; k++) {
fk = F[k] * nk;
pp += fk;
if (k != 4) {
gk = G[k] * nk;
qq += gk;
}
#if CEPHES_DEBUG
printf("fk[%d] %.5E, gk[%d] %.5E\n", k, fk, k, gk);
#endif
nk /= n23;
}
fk = cbtwo * ai * pp / cbn + cbrt(4.0) * aip * qq / n;
return (fk);
}
double exp10(double x)
{
double px, xx;
short n;
#ifdef NANS
if( isnan(x) )
return(x);
#endif
if( x > MAXL10 )
{
#ifdef INFINITIES
return( INFINITY );
#else
mtherr( "exp10", OVERFLOW );
return( MAXNUM );
#endif
}
if( x < -MAXL10 ) /* Would like to use MINLOG but can't */
{
mtherr( "exp10", UNDERFLOW );
return(0.0);
}
/* Express 10**x = 10**g 2**n
* = 10**g 10**( n log10(2) )
* = 10**( g + n log10(2) )
*/
px = floor( LOG210 * x + 0.5 );
n = px;
x -= px * LG102A;
x -= px * LG102B;
/* rational approximation for exponential
* of the fractional part:
* 10**x = 1 + 2x P(x**2)/( Q(x**2) - P(x**2) )
*/
xx = x * x;
px = x * polevl( xx, P, 3 );
x = px/( p1evl( xx, Q, 3 ) - px );
x = 1.0 + ldexp( x, 1 );
/* multiply by power of 2 */
x = ldexp( x, n );
return(x);
}
/* Gamma function computed by Stirling's formula.
* The polynomial STIR is valid for 33 <= x <= 172.
*/
double stirf (double x)
{ double y, w, v;
w = 1.0/x;
w = 1.0 + w * polevl( w, STIR, 4 );
y = exp(x);
if( x > MAXSTIR )
{ v = pow( x, 0.5 * x - 0.25 );
y = v * (v / y);
}
else
{ y = pow( x, x - 0.5 ) / y;
}
y = SQTPI * y * w;
return( y );
}
double erf(double x)
{
double y, z;
if (isnan(x)) {
mtherr("erf", DOMAIN);
return (NAN);
}
if( fabs(x) > 1.0 )
return( 1.0 - erfc(x) );
z = x * x;
y = x * polevl( z, T, 4 ) / p1evl( z, U, 5 );
return( y );
}
double GaussianEstimator::errorFunction(double x) {
double y, z;
static double T[] = { 9.60497373987051638749E0, 9.00260197203842689217E1,
2.23200534594684319226E3, 7.00332514112805075473E3,
5.55923013010394962768E4 };
static double U[] = {
// 1.00000000000000000000E0,
3.35617141647503099647E1, 5.21357949780152679795E2,
4.59432382970980127987E3, 2.26290000613890934246E4,
4.92673942608635921086E4 };
if (fabs(x) > 1.0) {
return (1.0 - errorFunctionComplemented(x));
}
z = x * x;
y = x * polevl(z, T, 4) / p1evl(z, U, 5);
return y;
}
/* Gamma function computed by Stirling's formula.
* The polynomial STIR is valid for 33 <= x <= 172.
*/
static double stirf(double x)
{
double y, w, v;
if (x >= MAXGAM) {
return (NPY_INFINITY);
}
w = 1.0 / x;
w = 1.0 + w * polevl(w, STIR, 4);
y = exp(x);
if (x > MAXSTIR) { /* Avoid overflow in pow() */
v = pow(x, 0.5 * x - 0.25);
y = v * (v / y);
}
else {
y = pow(x, x - 0.5) / y;
}
y = SQTPI * y * w;
return (y);
}
static double jnx(double n, double x)
{
double zeta, sqz, zz, zp, np;
double cbn, n23, t, z, sz;
double pp, qq, z32i, zzi;
double ak, bk, akl, bkl;
int sign, doa, dob, nflg, k, s, tk, tkp1, m;
static double u[8];
static double ai, aip, bi, bip;
/* Test for x very close to n. Use expansion for transition region if so. */
cbn = cbrt(n);
z = (x - n) / cbn;
if (fabs(z) <= 0.7)
return (jnt(n, x));
z = x / n;
zz = 1.0 - z * z;
if (zz == 0.0)
return (0.0);
if (zz > 0.0) {
sz = sqrt(zz);
t = 1.5 * (log((1.0 + sz) / z) - sz); /* zeta ** 3/2 */
zeta = cbrt(t * t);
nflg = 1;
}
else {
sz = sqrt(-zz);
t = 1.5 * (sz - acos(1.0 / z));
zeta = -cbrt(t * t);
nflg = -1;
}
z32i = fabs(1.0 / t);
sqz = cbrt(t);
/* Airy function */
n23 = cbrt(n * n);
t = n23 * zeta;
#if CEPHES_DEBUG
printf("zeta %.5E, Airy(%.5E)\n", zeta, t);
#endif
airy(t, &ai, &aip, &bi, &bip);
/* polynomials in expansion */
u[0] = 1.0;
zzi = 1.0 / zz;
u[1] = polevl(zzi, P1, 1) / sz;
u[2] = polevl(zzi, P2, 2) / zz;
u[3] = polevl(zzi, P3, 3) / (sz * zz);
pp = zz * zz;
u[4] = polevl(zzi, P4, 4) / pp;
u[5] = polevl(zzi, P5, 5) / (pp * sz);
pp *= zz;
u[6] = polevl(zzi, P6, 6) / pp;
u[7] = polevl(zzi, P7, 7) / (pp * sz);
#if CEPHES_DEBUG
for (k = 0; k <= 7; k++)
printf("u[%d] = %.5E\n", k, u[k]);
#endif
pp = 0.0;
qq = 0.0;
np = 1.0;
/* flags to stop when terms get larger */
doa = 1;
dob = 1;
akl = NPY_INFINITY;
bkl = NPY_INFINITY;
for (k = 0; k <= 3; k++) {
tk = 2 * k;
tkp1 = tk + 1;
zp = 1.0;
ak = 0.0;
bk = 0.0;
for (s = 0; s <= tk; s++) {
if (doa) {
if ((s & 3) > 1)
sign = nflg;
else
sign = 1;
ak += sign * mu[s] * zp * u[tk - s];
}
if (dob) {
m = tkp1 - s;
if (((m + 1) & 3) > 1)
sign = nflg;
else
sign = 1;
bk += sign * lambda[s] * zp * u[m];
}
zp *= z32i;
}
if (doa) {
ak *= np;
t = fabs(ak);
if (t < akl) {
akl = t;
pp += ak;
}
else
doa = 0;
}
if (dob) {
bk += lambda[tkp1] * zp * u[0];
bk *= -np / sqz;
t = fabs(bk);
if (t < bkl) {
bkl = t;
qq += bk;
}
else
dob = 0;
}
#if CEPHES_DEBUG
printf("a[%d] %.5E, b[%d] %.5E\n", k, ak, k, bk);
#endif
if (np < MACHEP)
break;
np /= n * n;
}
/* normalizing factor ( 4*zeta/(1 - z**2) )**1/4 */
t = 4.0 * zeta / zz;
t = sqrt(sqrt(t));
t *= ai * pp / cbrt(n) + aip * qq / (n23 * n);
return (t);
}
double Gamma(double x)
{
double p, q, z;
int i;
sgngam = 1;
#ifdef NANS
if( isnan(x) )
return(x);
#endif
#ifdef INFINITIES
#ifdef NANS
if( x == INFINITY )
return(x);
if( x == -INFINITY )
return(x);
#else
if( !isfinite(x) )
return(x);
#endif
#endif
q = fabs(x);
if( q > 33.0 )
{
if( x < 0.0 )
{
p = floor(q);
if( p == q )
{
#ifdef NANS
gamnan:
mtherr( "Gamma", OVERFLOW );
return (MAXNUM);
#else
goto goverf;
#endif
}
i = p;
if( (i & 1) == 0 )
sgngam = -1;
z = q - p;
if( z > 0.5 )
{
p += 1.0;
z = q - p;
}
z = q * sin( PI * z );
if( z == 0.0 )
{
#ifdef INFINITIES
return( sgngam * INFINITY);
#else
goverf:
mtherr( "Gamma", OVERFLOW );
return( sgngam * MAXNUM);
#endif
}
z = fabs(z);
z = PI/(z * stirf(q) );
}
else
{
z = stirf(x);
}
return( sgngam * z );
}
z = 1.0;
while( x >= 3.0 )
{
x -= 1.0;
z *= x;
}
while( x < 0.0 )
{
if( x > -1.E-9 )
goto small;
z /= x;
x += 1.0;
}
while( x < 2.0 )
{
if( x < 1.e-9 )
goto small;
z /= x;
x += 1.0;
}
if( x == 2.0 )
return(z);
x -= 2.0;
p = polevl( x, P, 6 );
q = polevl( x, Q, 7 );
return( z * p / q );
small:
if( x == 0.0 )
{
#ifdef INFINITIES
#ifdef NANS
goto gamnan;
#else
return( INFINITY );
#endif
#else
mtherr( "Gamma", SING );
return( MAXNUM );
#endif
}
else
return( z/((1.0 + 0.5772156649015329 * x) * x) );
}
static double _bessel_j1(double x)
{
double w, z, p, q, xn;
const double RP[4] = {
-8.99971225705559398224E8,
4.52228297998194034323E11,
-7.27494245221818276015E13,
3.68295732863852883286E15,
};
const double RQ[8] = {
6.20836478118054335476E2,
2.56987256757748830383E5,
8.35146791431949253037E7,
2.21511595479792499675E10,
4.74914122079991414898E12,
7.84369607876235854894E14,
8.95222336184627338078E16,
5.32278620332680085395E18,
};
const double PP[7] = {
7.62125616208173112003E-4,
7.31397056940917570436E-2,
1.12719608129684925192E0,
5.11207951146807644818E0,
8.42404590141772420927E0,
5.21451598682361504063E0,
1.00000000000000000254E0,
};
const double PQ[7] = {
5.71323128072548699714E-4,
6.88455908754495404082E-2,
1.10514232634061696926E0,
5.07386386128601488557E0,
8.39985554327604159757E0,
5.20982848682361821619E0,
9.99999999999999997461E-1,
};
const double QP[8] = {
5.10862594750176621635E-2,
4.98213872951233449420E0,
7.58238284132545283818E1,
3.66779609360150777800E2,
7.10856304998926107277E2,
5.97489612400613639965E2,
2.11688757100572135698E2,
2.52070205858023719784E1,
};
const double QQ[7] = {
7.42373277035675149943E1,
1.05644886038262816351E3,
4.98641058337653607651E3,
9.56231892404756170795E3,
7.99704160447350683650E3,
2.82619278517639096600E3,
3.36093607810698293419E2,
};
w = x;
if (x < 0)
w = -x;
if (w <= 5.0) {
z = x * x;
w = polevl(z, RP, 3) / p1evl(z, RQ, 8);
w = w * x * (z - Z1) * (z - Z2);
return w ;
}
w = 5.0 / x;
z = w * w;
p = polevl(z, PP, 6) / polevl(z, PQ, 6);
q = polevl(z, QP, 7) / p1evl(z, QQ, 7);
xn = x - THPIO4;
p = p * cos(xn) - w * q * sin(xn);
return p * SQ2OPI / sqrt(x);
}
double psi(double x)
{
double p, q, nz, s, w, y, z;
int i, n, negative;
negative = 0;
nz = 0.0;
if( x <= 0.0 ) {
negative = 1;
q = x;
p = floor(q);
if( p == q ) {
mtherr( "psi", SING );
return( MAXNUM );
}
/* Remove the zeros of tan(PI x)
* by subtracting the nearest integer from x
*/
nz = q - p;
if( nz != 0.5 ) {
if( nz > 0.5 ) {
p += 1.0;
nz = q - p;
}
nz = M_PI/tan(M_PI*nz);
} else {
nz = 0.0;
}
x = 1.0 - x;
}
/* check for positive integer up to 10 */
if( (x <= 10.0) && (x == floor(x)) ) {
y = 0.0;
n = x;
for( i=1; i<n; i++ ) {
w = i;
y += 1.0/w;
}
y -= EUL;
goto done;
}
s = x;
w = 0.0;
while( s < 10.0 ) {
w += 1.0/s;
s += 1.0;
}
if( s < 1.0e17 ) {
z = 1.0/(s * s);
y = z * polevl( z, A, 6 );
} else
y = 0.0;
y = log(s) - (0.5/s) - y - w;
done:
if( negative ) {
y -= nz;
}
return(y);
}
double sas_J1(double x)
{
//Cephes double pression function
#if FLOAT_SIZE>4
double w, z, p, q, xn;
const double Z1 = 1.46819706421238932572E1;
const double Z2 = 4.92184563216946036703E1;
const double THPIO4 = 2.35619449019234492885;
const double SQ2OPI = 0.79788456080286535588;
w = x;
if( x < 0 )
w = -x;
if( w <= 5.0 )
{
z = x * x;
w = polevl( z, RPJ1, 3 ) / p1evl( z, RQJ1, 8 );
w = w * x * (z - Z1) * (z - Z2);
return( w );
}
w = 5.0/x;
z = w * w;
p = polevl( z, PPJ1, 6)/polevl( z, PQJ1, 6 );
q = polevl( z, QPJ1, 7)/p1evl( z, QQJ1, 7 );
xn = x - THPIO4;
double sn, cn;
SINCOS(xn, sn, cn);
p = p * cn - w * q * sn;
return( p * SQ2OPI / sqrt(x) );
//Single precission version of cephes
#else
double xx, w, z, p, q, xn;
const double Z1 = 1.46819706421238932572E1;
const double THPIO4F = 2.35619449019234492885; /* 3*pi/4 */
xx = x;
if( xx < 0 )
xx = -x;
if( xx <= 2.0 )
{
z = xx * xx;
p = (z-Z1) * xx * polevl( z, JPJ1, 4 );
return( p );
}
q = 1.0/x;
w = sqrt(q);
p = w * polevl( q, MO1J1, 7);
w = q*q;
xn = q * polevl( w, PH1J1, 7) - THPIO4F;
p = p * cos(xn + xx);
return(p);
#endif
}
static DBL ndtri(DBL y0)
{
DBL x, y, z, y2, x0, x1;
int code;
if (y0 <= 0.0)
{
/*
mtherr("ndtri", DOMAIN);
*/
return (-MAXNUM);
}
if (y0 >= 1.0)
{
/*
mtherr("ndtri", DOMAIN);
*/
return (MAXNUM);
}
code = 1;
y = y0;
if (y > (1.0 - 0.13533528323661269189)) /* 0.135... = exp(-2) */
{
y = 1.0 - y;
code = 0;
}
if (y > 0.13533528323661269189)
{
y = y - 0.5;
y2 = y * y;
x = y + y * (y2 * polevl(y2, P0, 4) / p1evl(y2, Q0, 8));
x = x * s2pi;
return (x);
}
x = sqrt(-2.0 * log(y));
x0 = x - log(x) / x;
z = 1.0 / x;
if (x < 8.0) /* y > exp(-32) = 1.2664165549e-14 */
{
x1 = z * polevl(z, P1, 8) / p1evl(z, Q1, 8);
}
else
{
x1 = z * polevl(z, P2, 8) / p1evl(z, Q2, 8);
}
x = x0 - x1;
if (code != 0)
{
x = -x;
}
return (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 Gamma(double x)
{
double p, q, z;
int i;
sgngam = 1;
if (!npy_isfinite(x)) {
return x;
}
q = fabs(x);
if (q > 33.0) {
if (x < 0.0) {
p = floor(q);
if (p == q) {
gamnan:
mtherr("Gamma", OVERFLOW);
return (NPY_INFINITY);
}
i = p;
if ((i & 1) == 0)
sgngam = -1;
z = q - p;
if (z > 0.5) {
p += 1.0;
z = q - p;
}
z = q * sin(NPY_PI * z);
if (z == 0.0) {
return (sgngam * NPY_INFINITY);
}
z = fabs(z);
z = NPY_PI / (z * stirf(q));
}
else {
z = stirf(x);
}
return (sgngam * z);
}
z = 1.0;
while (x >= 3.0) {
x -= 1.0;
z *= x;
}
while (x < 0.0) {
if (x > -1.E-9)
goto small;
z /= x;
x += 1.0;
}
while (x < 2.0) {
if (x < 1.e-9)
goto small;
z /= x;
x += 1.0;
}
if (x == 2.0)
return (z);
x -= 2.0;
p = polevl(x, P, 6);
q = polevl(x, Q, 7);
return (z * p / q);
small:
if (x == 0.0) {
goto gamnan;
}
else
return (z / ((1.0 + 0.5772156649015329 * x) * x));
}
double gammln (double x)
{
double p, q, w, z;
int i;
sgngam = 1;
if( x < -34.0 )
{
q = -x;
w = gammln(q); /* note this modifies sgngam! */
p = floor(q);
if( p == q )
goto loverf;
i = (int)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( PI * z );
if( z == 0.0 )
goto loverf;
/* z = log(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:
output("Overflow in loggamma\n");
error=1; return 0;
}
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 gamm (double x)
{
double p, q, z;
int i;
sgngam = 1;
q = fabs(x);
if( q > 33.0 )
{ if( x < 0.0 )
{ p = floor(q);
if( p == q )
goto goverf;
i = (int)p;
if( (i & 1) == 0 )
sgngam = -1;
z = q - p;
if( z > 0.5 )
{
p += 1.0;
z = q - p;
}
z = q * sin( PI * z );
if( z == 0.0 )
{
goverf:
output("Overflow in gamma\n");
error=1; return 0;
}
z = fabs(z);
z = PI/(z * stirf(q) );
}
else
{
z = stirf(x);
}
return( sgngam * z );
}
z = 1.0;
while( x >= 3.0 )
{
x -= 1.0;
z *= x;
}
while( x < 0.0 )
{
if( x > -1.E-9 )
goto small;
z /= x;
x += 1.0;
}
while( x < 2.0 )
{
if( x < 1.e-9 )
goto small;
z /= x;
x += 1.0;
}
if( (x == 2.0) || (x == 3.0) )
return(z);
x -= 2.0;
p = polevl( x, P, 6 );
q = polevl( x, Q, 7 );
return( z * p / q );
small:
if( x == 0.0 )
{
output("Wrong argument for gamma.\n");
error=1; return 0;
}
else
return( z/((1.0 + 0.5772156649015329 * x) * x) );
}
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);
}