/* 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; }