/* Functional inverse of Smirnov distribution
* finds e such that smirnov(n,e) = p. */
double smirnovi(int n, double p)
{
double e, t, dpde;
int iterations;
if (!(p > 0.0 && p <= 1.0)) {
mtherr("smirnovi", DOMAIN);
return (NPY_NAN);
}
/* Start with approximation p = exp(-2 n e^2). */
e = sqrt(-log(p) / (2.0 * n));
iterations = 0;
do {
/* Use approximate derivative in Newton iteration. */
t = -2.0 * n * e;
dpde = 2.0 * t * exp(t * e);
if (fabs(dpde) > 0.0)
t = (p - smirnov(n, e)) / dpde;
else {
mtherr("smirnovi", UNDERFLOW);
return 0.0;
}
e = e + t;
if (e >= 1.0 || e <= 0.0) {
mtherr("smirnovi", OVERFLOW);
return 0.0;
}
if (++iterations > MAXITER) {
mtherr("smirnovi", TOOMANY);
return (e);
}
}
while (fabs(t / e) > 1e-10);
return (e);
}
/* Functional inverse of Kolmogorov statistic for two-sided test.
* Finds y such that kolmogorov(y) = p.
* If e = smirnovi (n,p), then kolmogi(2 * p) / sqrt(n) should
* be close to e. */
double kolmogi(double p)
{
double y, t, dpdy;
int iterations;
if (!(p > 0.0 && p <= 1.0)) {
mtherr("kolmogi", DOMAIN);
return (NPY_NAN);
}
if ((1.0 - p) < 1e-16)
return 0.0;
/* Start with approximation p = 2 exp(-2 y^2). */
y = sqrt(-0.5 * log(0.5 * p));
iterations = 0;
do {
/* Use approximate derivative in Newton iteration. */
t = -2.0 * y;
dpdy = 4.0 * t * exp(t * y);
if (fabs(dpdy) > 0.0)
t = (p - kolmogorov(y)) / dpdy;
else {
mtherr("kolmogi", UNDERFLOW);
return 0.0;
}
y = y + t;
if (++iterations > MAXITER) {
mtherr("kolmogi", TOOMANY);
return (y);
}
}
while (fabs(t / y) > 1.0e-10);
return (y);
}
double iv(double v, double x)
{
int sign;
double t, ax, res;
/* If v is a negative integer, invoke symmetry */
t = floor(v);
if (v < 0.0) {
if (t == v) {
v = -v; /* symmetry */
t = -t;
}
}
/* If x is negative, require v to be an integer */
sign = 1;
if (x < 0.0) {
if (t != v) {
mtherr("iv", DOMAIN);
return (CEPHES_NAN);
}
if (v != 2.0 * floor(v / 2.0)) {
sign = -1;
}
}
/* Avoid logarithm singularity */
if (x == 0.0) {
if (v == 0.0) {
return 1.0;
}
if (v < 0.0) {
mtherr("iv", OVERFLOW);
return CEPHES_INFINITY;
}
else
return 0.0;
}
ax = fabs(x);
if (fabs(v) > 50) {
/*
* Uniform asymptotic expansion for large orders.
*
* This appears to overflow slightly later than the Boost
* implementation of Temme's method.
*/
ikv_asymptotic_uniform(v, ax, &res, NULL);
}
else {
/* Otherwise: Temme's method */
ikv_temme(v, ax, &res, NULL);
}
res *= sign;
return res;
}
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);
}
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);
}
double ndtr(double a)
{
double x, y, z;
if (isnan(a)) {
mtherr("ndtr", DOMAIN);
return (NAN);
}
x = a * SQRTH;
z = fabs(x);
if( z < SQRTH )
y = 0.5 + 0.5 * erf(x);
else
{
y = 0.5 * erfc(z);
if( x > 0 )
y = 1.0 - y;
}
return(y);
}
double hyperg (double a, double b, double x)
{
double asum, psum, acanc, temp, pcanc = 0;
/* See if a Kummer transformation will help */
temp = b - a;
if (fabs(temp) < 0.001 * fabs(a))
return exp(x) * hyperg(temp, b, -x);
psum = hy1f1p(a, b, x, &pcanc);
if (pcanc < 1.0e-15)
goto done;
/* try asymptotic series */
asum = hy1f1a(a, b, x, &acanc);
/* Pick the result with less estimated error */
if (acanc < pcanc) {
pcanc = acanc;
psum = asum;
}
done:
if (pcanc > 1.0e-12)
mtherr("hyperg", CEPHES_PLOSS);
return psum;
}
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 );
}
/* 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;
}
/*
* Compute Iv from (AMS5 9.7.1), asymptotic expansion for large |z|
* Iv ~ exp(x)/sqrt(2 pi x) ( 1 + (4*v*v-1)/8x + (4*v*v-1)(4*v*v-9)/8x/2! + ...)
*/
static double iv_asymptotic(double v, double x)
{
double mu;
double sum, term, prefactor, factor;
int k;
prefactor = exp(x) / sqrt(2 * CEPHES_PI * x);
if (prefactor == CEPHES_INFINITY) {
return prefactor;
}
mu = 4 * v * v;
sum = 1.0;
term = 1.0;
k = 1;
do {
factor = (mu - (2 * k - 1) * (2 * k - 1)) / (8 * x) / k;
if (k > 100) {
/* didn't converge */
mtherr("iv(iv_asymptotic)", TLOSS);
break;
}
term *= -factor;
sum += term;
++k;
} while (fabs(term) > MACHEP * fabs(sum));
return sum * prefactor;
}
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);
}
/*
* Modified Bessel functions of the first and second kind of fractional order
*
* Calculate K(v, x) and K(v+1, x) by method analogous to
* Temme, Journal of Computational Physics, vol 21, 343 (1976)
*/
static int temme_ik_series(double v, double x, double *K, double *K1)
{
double f, h, p, q, coef, sum, sum1, tolerance;
double a, b, c, d, sigma, gamma1, gamma2;
unsigned long k;
double gp;
double gm;
/*
* |x| <= 2, Temme series converge rapidly
* |x| > 2, the larger the |x|, the slower the convergence
*/
BOOST_ASSERT(fabs(x) <= 2);
BOOST_ASSERT(fabs(v) <= 0.5f);
gp = gamma(v + 1) - 1;
gm = gamma(-v + 1) - 1;
a = log(x / 2);
b = exp(v * a);
sigma = -a * v;
c = fabs(v) < MACHEP ? 1 : sin(CEPHES_PI * v) / (v * CEPHES_PI);
d = fabs(sigma) < MACHEP ? 1 : sinh(sigma) / sigma;
gamma1 = fabs(v) < MACHEP ? -CEPHES_EULER : (0.5f / v) * (gp - gm) * c;
gamma2 = (2 + gp + gm) * c / 2;
/* initial values */
p = (gp + 1) / (2 * b);
q = (1 + gm) * b / 2;
f = (cosh(sigma) * gamma1 + d * (-a) * gamma2) / c;
h = p;
coef = 1;
sum = coef * f;
sum1 = coef * h;
/* series summation */
tolerance = MACHEP;
for (k = 1; k < MAXITER; k++) {
f = (k * f + p + q) / (k * k - v * v);
p /= k - v;
q /= k + v;
h = p - k * f;
coef *= x * x / (4 * k);
sum += coef * f;
sum1 += coef * h;
if (fabs(coef * f) < fabs(sum) * tolerance) {
break;
}
}
if (k == MAXITER) {
mtherr("ikv_temme(temme_ik_series)", TLOSS);
}
*K = sum;
*K1 = 2 * sum1 / x;
return 0;
}
static double
tancot(double xx, int cotflg)
{
double x;
int sign;
/* make argument positive but save the sign */
if( xx < 0 ) {
x = -xx;
sign = -1;
} else {
x = xx;
sign = 1;
}
if( x > lossth ) {
mtherr("tandg", TLOSS);
return 0.0;
}
/* modulo 180 */
x = x - 180.0*floor(x/180.0);
if (cotflg) {
if (x <= 90.0) {
x = 90.0 - x;
} else {
x = x - 90.0;
sign *= -1;
}
} else {
if (x > 90.0) {
x = 180.0 - x;
sign *= -1;
}
}
if (x == 0.0) {
return 0.0;
} else if (x == 45.0) {
return sign*1.0;
} else if (x == 90.0) {
mtherr( (cotflg ? "cotdg" : "tandg"), SING );
return MAXNUM;
}
/* x is now transformed into [0, 90) */
return sign * tan(x*PI180);
}
static double hy1f1p (double a, double b, double x, double *err)
{
double n, a0, sum, t, u, temp;
double an, bn, maxt, pcanc;
/* set up for power series summation */
an = a;
bn = b;
a0 = 1.0;
sum = 1.0;
n = 1.0;
t = 1.0;
maxt = 0.0;
while (t > MACHEP) {
/* check bn first since if both an and bn are zero it is
a singularity
*/
if (bn == 0) {
mtherr("hyperg", CEPHES_SING);
return MAXNUM;
}
if (an == 0)
return sum;
if (n > 200)
goto pdone;
u = x * (an / (bn * n));
/* check for blowup */
temp = fabs(u);
if (temp > 1.0 && maxt > (MAXNUM/temp)) {
pcanc = 1.0; /* estimate 100% error */
goto blowup;
}
a0 *= u;
sum += a0;
t = fabs(a0);
if (t > maxt)
maxt = t;
an += 1.0;
bn += 1.0;
n += 1.0;
}
pdone:
/* estimate error due to roundoff and cancellation */
if (sum != 0.0)
maxt /= fabs(sum);
maxt *= MACHEP; /* this way avoids multiply overflow */
pcanc = fabs(MACHEP * n + maxt);
blowup:
*err = pcanc;
return sum;
}
double chdtr (double df, double x)
{
if (x < 0.0 || df < 1.0) {
mtherr("chdtr", CEPHES_DOMAIN);
return 0.0;
}
return igam(df/2.0, x/2.0);
}
/*
* Calculate K(v, x) and K(v+1, x) by evaluating continued fraction
* z1 / z0 = U(v+1.5, 2v+1, 2x) / U(v+0.5, 2v+1, 2x), see
* Thompson and Barnett, Computer Physics Communications, vol 47, 245 (1987)
*/
static int CF2_ik(double v, double x, double *Kv, double *Kv1)
{
double S, C, Q, D, f, a, b, q, delta, tolerance, current, prev;
unsigned long k;
/*
* |x| >= |v|, CF2_ik converges rapidly
* |x| -> 0, CF2_ik fails to converge
*/
BOOST_ASSERT(fabs(x) > 1);
/*
* Steed's algorithm, see Thompson and Barnett,
* Journal of Computational Physics, vol 64, 490 (1986)
*/
tolerance = MACHEP;
a = v * v - 0.25f;
b = 2 * (x + 1); /* b1 */
D = 1 / b; /* D1 = 1 / b1 */
f = delta = D; /* f1 = delta1 = D1, coincidence */
prev = 0; /* q0 */
current = 1; /* q1 */
Q = C = -a; /* Q1 = C1 because q1 = 1 */
S = 1 + Q * delta; /* S1 */
for (k = 2; k < MAXITER; k++) { /* starting from 2 */
/* continued fraction f = z1 / z0 */
a -= 2 * (k - 1);
b += 2;
D = 1 / (b + a * D);
delta *= b * D - 1;
f += delta;
/* series summation S = 1 + \sum_{n=1}^{\infty} C_n * z_n / z_0 */
q = (prev - (b - 2) * current) / a;
prev = current;
current = q; /* forward recurrence for q */
C *= -a / k;
Q += C * q;
S += Q * delta;
/* S converges slower than f */
if (fabs(Q * delta) < fabs(S) * tolerance) {
break;
}
}
if (k == MAXITER) {
mtherr("ikv_temme(CF2_ik)", TLOSS);
}
*Kv = sqrt(CEPHES_PI / (2 * x)) * exp(-x) / S;
*Kv1 = *Kv * (0.5f + v + x + (v * v - 0.25f) * f) / x;
return 0;
}
double fdtrc(double a, double b, double x)
{
double w;
if ((a <= 0.0) || (b <= 0.0) || (x < 0.0)) {
mtherr("fdtrc", DOMAIN);
return CEPHES_NAN;
}
w = b / (b + a * x);
return incbet(0.5 * b, 0.5 * a, w);
}
double pdtr( int k, double m )
{
double v;
if( (k < 0) || (m <= 0.0) )
{
mtherr( "pdtr", DOMAIN );
return( 0.0 );
}
v = k+1;
return( igamc( v, m ) );
}
static double lbeta_negint(int a, double b)
{
double r;
if (b == (int)b && 1 - a - b > 0) {
r = lbeta(1 - a - b, b);
return r;
}
else {
mtherr("lbeta", OVERFLOW);
return CEPHES_INFINITY;
}
}
static double beta_negint(int a, double b)
{
int sgn;
if (b == (int)b && 1 - a - b > 0) {
sgn = ((int)b % 2 == 0) ? 1 : -1;
return sgn * beta(1 - a - b, b);
}
else {
mtherr("lbeta", OVERFLOW);
return CEPHES_INFINITY;
}
}
double fdtr(double a, double b, double x)
{
double w;
if ((a <= 0.0) || (b <= 0.0) || (x < 0.0)) {
mtherr("fdtr", DOMAIN);
return CEPHES_NAN;
}
w = a * x;
w = w / (b + w);
return incbet(0.5 * a, 0.5 * b, w);
}
double chdtri (double df, double y)
{
double x;
if (y < 0.0 || y > 1.0 || df < 1.0) {
mtherr("chdtri", CEPHES_DOMAIN);
return 0.0;
}
x = igami(0.5 * df, y);
return 2.0 * x;
}
double cephes_bessel_Iv (double v, double x)
{
double ax, t = floor(v);
int sign;
/* If v is a negative integer, invoke symmetry */
if (v < 0.0 && t == v) {
t = v = -v;
}
/* If x is negative, require v to be an integer */
sign = 1;
if (x < 0.0) {
if (t != v) {
mtherr("iv", DOMAIN);
return 0.0;
}
if (v != 2.0 * floor(v/2.0))
sign = -1;
}
/* Avoid logarithm singularity */
if (x == 0.0) {
if (v == 0.0)
return 1.0;
if (v < 0.0) {
mtherr("iv", CEPHES_OVERFLOW);
return MAXNUM;
} else
return 0.0;
}
ax = fabs(x);
t = v * log(0.5 * ax) - x;
t = sign * exp(t) / cephes_gamma(v + 1.0);
ax = v + 0.5;
return t * hyperg(ax, 2*ax, 2*x);
}
double pdtri( int k, double y )
{
double v;
if( (k < 0) || (y < 0.0) || (y >= 1.0) )
{
mtherr( "pdtri", DOMAIN );
return( 0.0 );
}
v = k+1;
v = igami( v, y );
return( v );
}
long double erfcl(long double a)
{
long double p, q, x, y, z;
if (isinf (a))
return (signbit(a) ? 2.0 : 0.0);
x = fabsl (a);
if (x < 1.0L)
return (1.0L - erfl(a));
z = a * a;
if (z > MAXLOGL)
{
under:
mtherr("erfcl", UNDERFLOW);
errno = ERANGE;
return (signbit(a) ? 2.0 : 0.0);
}
/* Compute z = expl(a * a). */
z = expx2l(a);
y = 1.0L/x;
if (x < 8.0L)
{
p = polevll(y, P, 9);
q = p1evll(y, Q, 10);
}
else
{
q = y * y;
p = y * polevll(q, R, 4);
q = p1evll(q, S, 5);
}
y = p/(q * z);
if (a < 0.0L)
y = 2.0L - y;
if (y == 0.0L)
goto under;
return (y);
}
double k1e (double x)
{
double y;
if (x <= 0.0) {
mtherr("k1e", CEPHES_DOMAIN);
return MAXNUM;
}
if (x <= 2.0) {
y = x * x - 2.0;
y = log(0.5 * x) * cephes_bessel_I1(x) + chbevl(y, A, 11) / x;
return y * exp(x);
}
return chbevl(8.0/x - 2.0, B, 25) / sqrt(x);
}
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 );
}
/* Evaluate continued fraction fv = I_(v+1) / I_v, derived from
* Abramowitz and Stegun, Handbook of Mathematical Functions, 1972, 9.1.73 */
static int CF1_ik(double v, double x, double *fv)
{
double C, D, f, a, b, delta, tiny, tolerance;
unsigned long k;
/*
* |x| <= |v|, CF1_ik converges rapidly
* |x| > |v|, CF1_ik needs O(|x|) iterations to converge
*/
/*
* modified Lentz's method, see
* Lentz, Applied Optics, vol 15, 668 (1976)
*/
tolerance = 2 * MACHEP;
tiny = 1 / sqrt(DBL_MAX);
C = f = tiny; /* b0 = 0, replace with tiny */
D = 0;
for (k = 1; k < MAXITER; k++) {
a = 1;
b = 2 * (v + k) / x;
C = b + a / C;
D = b + a * D;
if (C == 0) {
C = tiny;
}
if (D == 0) {
D = tiny;
}
D = 1 / D;
delta = C * D;
f *= delta;
if (fabs(delta - 1) <= tolerance) {
break;
}
}
if (k == MAXITER) {
mtherr("ikv_temme(CF1_ik)", TLOSS);
}
*fv = f;
return 0;
}
double cephes_bessel_K1 (double x)
{
double y, z;
z = 0.5 * x;
if (z <= 0.0) {
mtherr("k1", CEPHES_DOMAIN);
return MAXNUM;
}
if (x <= 2.0) {
y = x * x - 2.0;
y = log(z) * cephes_bessel_I1(x) + chbevl(y, A, 11) / x;
return y;
}
return exp(-x) * chbevl(8.0/x - 2.0, B, 25) / sqrt(x);
}
double igami(double a, double p)
{
int i;
double x, fac, f_fp, fpp_fp;
if (npy_isnan(a) || npy_isnan(p)) {
return NPY_NAN;
}
else if ((a < 0) || (p < 0) || (p > 1)) {
mtherr("gammaincinv", DOMAIN);
}
else if (p == 0.0) {
return 0.0;
}
else if (p == 1.0) {
return NPY_INFINITY;
}
else if (p > 0.9) {
return igamci(a, 1 - p);
}
x = find_inverse_gamma(a, p, 1 - p);
/* Halley's method */
for (i = 0; i < 3; i++) {
fac = igam_fac(a, x);
if (fac == 0.0) {
return x;
}
f_fp = (igam(a, x) - p) * x / fac;
/* The ratio of the first and second derivatives simplifies */
fpp_fp = -1.0 + (a - 1) / x;
if (npy_isinf(fpp_fp)) {
/* Resort to Newton's method in the case of overflow */
x = x - f_fp;
}
else {
x = x - f_fp / (1.0 - 0.5 * f_fp * fpp_fp);
}
}
return x;
}
