static void
pochhammer_small_n (gnm_float x, gnm_float n, GnmQuad *res)
{
GnmQuad qx, qn, qr, qs, f1, f2, f3, f4, f5;
gnm_float r;
gboolean debug = FALSE;
g_return_if_fail (x >= 20);
g_return_if_fail (gnm_abs (n) <= 1);
/*
* G(x) = c * x^(x-1/2) * exp(-x) * E(x)
* G(x+n) = c * (x+n)^(x+n-1/2) * exp(-(x+n)) * E(x+n)
* = c * (x+n)^(x-1/2) * (x+n)^n * exp(-x) * exp(-n) * E(x+n)
*
* G(x+n)/G(x)
* = (1+n/x)^(x-1/2) * (x+n)^n * exp(-n) * E(x+n)/E(x)
* = (1+n/x)^x / sqrt(1+n/x) * (x+n)^n * exp(-n) * E(x+n)/E(x)
* = exp(x*log(1+n/x) - n) / sqrt(1+n/x) * (x+n)^n * E(x+n)/E(x)
* = exp(x*log1p(n/x) - n) / sqrt(1+n/x) * (x+n)^n * E(x+n)/E(x)
* = exp(x*(log1pmx(n/x)+n/x) - n) / sqrt(1+n/x) * (x+n)^n * E(x+n)/E(x)
* = exp(x*log1pmx(n/x) + n - n) / sqrt(1+n/x) * (x+n)^n * E(x+n)/E(x)
* = exp(x*log1pmx(n/x)) / sqrt(1+n/x) * (x+n)^n * E(x+n)/E(x)
*/
gnm_quad_init (&qx, x);
gnm_quad_init (&qn, n);
gnm_quad_div (&qr, &qn, &qx);
r = gnm_quad_value (&qr);
gnm_quad_add (&qs, &qx, &qn);
/* exp(x*log1pmx(n/x)) */
gnm_quad_mul12 (&f1, log1pmx (r), x); /* sub-opt */
gnm_quad_exp (&f1, NULL, &f1);
if (debug) g_printerr ("f1=%.20g\n", gnm_quad_value (&f1));
/* sqrt(1+n/x) */
gnm_quad_add (&f2, &gnm_quad_one, &qr);
gnm_quad_sqrt (&f2, &f2);
if (debug) g_printerr ("f2=%.20g\n", gnm_quad_value (&f2));
/* (x+n)^n */
gnm_quad_pow (&f3, NULL, &qs, &qn);
if (debug) g_printerr ("f3=%.20g\n", gnm_quad_value (&f3));
/* E(x+n) */
gamma_error_factor (&f4, &qs);
if (debug) g_printerr ("f4=%.20g\n", gnm_quad_value (&f4));
/* E(x) */
gamma_error_factor (&f5, &qx);
if (debug) g_printerr ("f5=%.20g\n", gnm_quad_value (&f5));
gnm_quad_div (res, &f1, &f2);
gnm_quad_mul (res, res, &f3);
gnm_quad_mul (res, res, &f4);
gnm_quad_div (res, res, &f5);
}
/*
* Asymptotic expansion to calculate the probability that Poisson variate
* has value <= x.
* Various assertions about this are made (without proof) at
* http://members.aol.com/iandjmsmith/PoissonApprox.htm
*/
static double
ppois_asymp (double x, double lambda, int lower_tail, int log_p)
{
static const double coefs_a[8] = {
-1e99, /* placeholder used for 1-indexing */
2/3.,
-4/135.,
8/2835.,
16/8505.,
-8992/12629925.,
-334144/492567075.,
698752/1477701225.
};
static const double coefs_b[8] = {
-1e99, /* placeholder */
1/12.,
1/288.,
-139/51840.,
-571/2488320.,
163879/209018880.,
5246819/75246796800.,
-534703531/902961561600.
};
double elfb, elfb_term;
double res12, res1_term, res1_ig, res2_term, res2_ig;
double dfm, pt_, s2pt, f, np;
int i;
dfm = lambda - x;
/* If lambda is large, the distribution is highly concentrated
about lambda. So representation error in x or lambda can lead
to arbitrarily large values of pt_ and hence divergence of the
coefficients of this approximation.
*/
pt_ = - log1pmx (dfm / x);
s2pt = sqrt (2 * x * pt_);
if (dfm < 0) s2pt = -s2pt;
res12 = 0;
res1_ig = res1_term = sqrt (x);
res2_ig = res2_term = s2pt;
for (i = 1; i < 8; i++) {
res12 += res1_ig * coefs_a[i];
res12 += res2_ig * coefs_b[i];
res1_term *= pt_ / i ;
res2_term *= 2 * pt_ / (2 * i + 1);
res1_ig = res1_ig / x + res1_term;
res2_ig = res2_ig / x + res2_term;
}
elfb = x;
elfb_term = 1;
for (i = 1; i < 8; i++) {
elfb += elfb_term * coefs_b[i];
elfb_term /= x;
}
if (!lower_tail) elfb = -elfb;
#ifdef DEBUG_p
REprintf ("res12 = %.14g elfb=%.14g\n", elfb, res12);
#endif
f = res12 / elfb;
np = pnorm (s2pt, 0.0, 1.0, !lower_tail, log_p);
if (log_p) {
double n_d_over_p = dpnorm (s2pt, !lower_tail, np);
#ifdef DEBUG_p
REprintf ("pp*_asymp(): f=%.14g np=e^%.14g nd/np=%.14g f*nd/np=%.14g\n",
f, np, n_d_over_p, f * n_d_over_p);
#endif
return np + log1p (f * n_d_over_p);
} else {
double nd = dnorm (s2pt, 0., 1., log_p);
#ifdef DEBUG_p
REprintf ("pp*_asymp(): f=%.14g np=%.14g nd=%.14g f*nd=%.14g\n",
f, np, nd, f * nd);
#endif
return np + f * nd;
}
} /* ppois_asymp() */
/* Compute log(gamma(a+1)) accurately also for small a (0 < a < 0.5). */
double lgamma1p (double a)
{
const double eulers_const = 0.5772156649015328606065120900824024;
/* coeffs[i] holds (zeta(i+2)-1)/(i+2) , i = 0:(N-1), N = 40 : */
const int N = 40;
static const double coeffs[40] = {
0.3224670334241132182362075833230126e-0,/* = (zeta(2)-1)/2 */
0.6735230105319809513324605383715000e-1,/* = (zeta(3)-1)/3 */
0.2058080842778454787900092413529198e-1,
0.7385551028673985266273097291406834e-2,
0.2890510330741523285752988298486755e-2,
0.1192753911703260977113935692828109e-2,
0.5096695247430424223356548135815582e-3,
0.2231547584535793797614188036013401e-3,
0.9945751278180853371459589003190170e-4,
0.4492623673813314170020750240635786e-4,
0.2050721277567069155316650397830591e-4,
0.9439488275268395903987425104415055e-5,
0.4374866789907487804181793223952411e-5,
0.2039215753801366236781900709670839e-5,
0.9551412130407419832857179772951265e-6,
0.4492469198764566043294290331193655e-6,
0.2120718480555466586923135901077628e-6,
0.1004322482396809960872083050053344e-6,
0.4769810169363980565760193417246730e-7,
0.2271109460894316491031998116062124e-7,
0.1083865921489695409107491757968159e-7,
0.5183475041970046655121248647057669e-8,
0.2483674543802478317185008663991718e-8,
0.1192140140586091207442548202774640e-8,
0.5731367241678862013330194857961011e-9,
0.2759522885124233145178149692816341e-9,
0.1330476437424448948149715720858008e-9,
0.6422964563838100022082448087644648e-10,
0.3104424774732227276239215783404066e-10,
0.1502138408075414217093301048780668e-10,
0.7275974480239079662504549924814047e-11,
0.3527742476575915083615072228655483e-11,
0.1711991790559617908601084114443031e-11,
0.8315385841420284819798357793954418e-12,
0.4042200525289440065536008957032895e-12,
0.1966475631096616490411045679010286e-12,
0.9573630387838555763782200936508615e-13,
0.4664076026428374224576492565974577e-13,
0.2273736960065972320633279596737272e-13,
0.1109139947083452201658320007192334e-13/* = (zeta(40+1)-1)/(40+1) */
};
const double c = 0.2273736845824652515226821577978691e-12;/* zeta(N+2)-1 */
const double tol_logcf = 1e-14;
double lgam;
int i;
if (fabs (a) >= 0.5)
return lgammafn (a + 1);
/* Abramowitz & Stegun 6.1.33 : for |x| < 2,
* <==> log(gamma(1+x)) = -(log(1+x) - x) - gamma*x + x^2 * \sum_{n=0}^\infty c_n (-x)^n
* where c_n := (Zeta(n+2) - 1)/(n+2) = coeffs[n]
*
* Here, another convergence acceleration trick is used to compute
* lgam(x) := sum_{n=0..Inf} c_n (-x)^n
*/
lgam = c * logcf(-a / 2, N + 2, 1, tol_logcf);
for (i = N - 1; i >= 0; i--)
lgam = coeffs[i] - a * lgam;
return (a * lgam - eulers_const) * a - log1pmx (a);
} /* lgamma1p */
/* Compute gnm_log(gamma(a+1)) accurately also for small a (0 < a < 0.5). */
gnm_float lgamma1p (gnm_float a)
{
const gnm_float eulers_const = GNM_const(0.5772156649015328606065120900824024);
/* coeffs[i] holds (zeta(i+2)-1)/(i+2) , i = 1:N, N = 40 : */
const int N = 40;
static const gnm_float coeffs[40] = {
GNM_const(0.3224670334241132182362075833230126e-0),
GNM_const(0.6735230105319809513324605383715000e-1),
GNM_const(0.2058080842778454787900092413529198e-1),
GNM_const(0.7385551028673985266273097291406834e-2),
GNM_const(0.2890510330741523285752988298486755e-2),
GNM_const(0.1192753911703260977113935692828109e-2),
GNM_const(0.5096695247430424223356548135815582e-3),
GNM_const(0.2231547584535793797614188036013401e-3),
GNM_const(0.9945751278180853371459589003190170e-4),
GNM_const(0.4492623673813314170020750240635786e-4),
GNM_const(0.2050721277567069155316650397830591e-4),
GNM_const(0.9439488275268395903987425104415055e-5),
GNM_const(0.4374866789907487804181793223952411e-5),
GNM_const(0.2039215753801366236781900709670839e-5),
GNM_const(0.9551412130407419832857179772951265e-6),
GNM_const(0.4492469198764566043294290331193655e-6),
GNM_const(0.2120718480555466586923135901077628e-6),
GNM_const(0.1004322482396809960872083050053344e-6),
GNM_const(0.4769810169363980565760193417246730e-7),
GNM_const(0.2271109460894316491031998116062124e-7),
GNM_const(0.1083865921489695409107491757968159e-7),
GNM_const(0.5183475041970046655121248647057669e-8),
GNM_const(0.2483674543802478317185008663991718e-8),
GNM_const(0.1192140140586091207442548202774640e-8),
GNM_const(0.5731367241678862013330194857961011e-9),
GNM_const(0.2759522885124233145178149692816341e-9),
GNM_const(0.1330476437424448948149715720858008e-9),
GNM_const(0.6422964563838100022082448087644648e-10),
GNM_const(0.3104424774732227276239215783404066e-10),
GNM_const(0.1502138408075414217093301048780668e-10),
GNM_const(0.7275974480239079662504549924814047e-11),
GNM_const(0.3527742476575915083615072228655483e-11),
GNM_const(0.1711991790559617908601084114443031e-11),
GNM_const(0.8315385841420284819798357793954418e-12),
GNM_const(0.4042200525289440065536008957032895e-12),
GNM_const(0.1966475631096616490411045679010286e-12),
GNM_const(0.9573630387838555763782200936508615e-13),
GNM_const(0.4664076026428374224576492565974577e-13),
GNM_const(0.2273736960065972320633279596737272e-13),
GNM_const(0.1109139947083452201658320007192334e-13)
};
const gnm_float c = GNM_const(0.2273736845824652515226821577978691e-12);/* zeta(N+2)-1 */
gnm_float lgam;
int i;
if (gnm_abs (a) >= 0.5)
return gnm_lgamma (a + 1);
/* Abramowitz & Stegun 6.1.33,
* also http://functions.wolfram.com/06.11.06.0008.01 */
lgam = c * gnm_logcf (-a / 2, N + 2, 1);
for (i = N - 1; i >= 0; i--)
lgam = coeffs[i] - a * lgam;
return (a * lgam - eulers_const) * a - log1pmx (a);
} /* lgamma1p */
double F77_SUB(log1pxmx)(double *x)
{
return log1pmx(*x);
}
inline typename tools::promote_args<T>::type log1pmx(T x)
{
return log1pmx(x, policies::policy<>());
}
