double lgamma_r (double x, int *signp) { *signp = +1; if (gnm_isnan (x)) return gnm_nan; if (x > 0) { gnm_float f = 1; while (x < 10) { f *= x; x++; } return (M_LN_SQRT_2PI + (x - 0.5) * gnm_log(x) - x + lgammacor(x)) - gnm_log (f); } else { gnm_float axm2 = gnm_fmod (-x, 2.0); gnm_float y = gnm_sinpi (axm2) / M_PIgnum; *signp = axm2 > 1.0 ? +1 : -1; return y == 0 ? gnm_nan : - gnm_log (gnm_abs (y)) - lgamma1p (-x); } }
double lbeta(double a, double b) { double corr, p, q; #ifdef IEEE_754 if(ISNAN(a) || ISNAN(b)) return a + b; #endif p = q = a; if(b < p) p = b;/* := min(a,b) */ if(b > q) q = b;/* := max(a,b) */ /* both arguments must be >= 0 */ if (p < 0) ML_ERR_return_NAN else if (p == 0) { return ML_POSINF; } else if (!R_FINITE(q)) { /* q == +Inf */ return ML_NEGINF; } if (p >= 10) { /* p and q are big. */ corr = lgammacor(p) + lgammacor(q) - lgammacor(p + q); return log(q) * -0.5 + M_LN_SQRT_2PI + corr + (p - 0.5) * log(p / (p + q)) + q * log1p(-p / (p + q)); } else if (q >= 10) { /* p is small, but q is big. */ corr = lgammacor(q) - lgammacor(p + q); return lgammafn(p) + corr + p - p * log(p + q) + (q - 0.5) * log1p(-p / (p + q)); } else { /* p and q are small: p <= q < 10. */ /* R change for very small args */ if (p < 1e-306) return lgamma(p) + (lgamma(q) - lgamma(p+q)); else return log(gammafn(p) * (gammafn(q) / gammafn(p + q))); } }
gnm_float gnm_lbeta(gnm_float a, gnm_float b) { gnm_float corr, p, q; p = q = a; if(b < p) p = b;/* := min(a,b) */ if(b > q) q = b;/* := max(a,b) */ #ifdef IEEE_754 if(gnm_isnan(a) || gnm_isnan(b)) return a + b; #endif /* both arguments must be >= 0 */ if (p < 0) ML_ERR_return_NAN else if (p == 0) { return gnm_pinf; } else if (!gnm_finite(q)) { return gnm_ninf; } if (p >= 10) { /* p and q are big. */ corr = lgammacor(p) + lgammacor(q) - lgammacor(p + q); return gnm_log(q) * -0.5 + M_LN_SQRT_2PI + corr + (p - 0.5) * gnm_log(p / (p + q)) + q * gnm_log1p(-p / (p + q)); } else if (q >= 10) { /* p is small, but q is big. */ corr = lgammacor(q) - lgammacor(p + q); return gnm_lgamma(p) + corr + p - p * gnm_log(p + q) + (q - 0.5) * gnm_log1p(-p / (p + q)); } else /* p and q are small: p <= q < 10. */ return gnm_lgamma (p) + gnm_lgamma (q) - gnm_lgamma (p + q); }
double lbeta(NMATH_STATE *state, double a, double b) { double corr, p, q; p = q = a; if(b < p) p = b;/* := min(a,b) */ if(b > q) q = b;/* := max(a,b) */ #ifdef IEEE_754 if(ISNAN(a) || ISNAN(b)) return a + b; #endif /* both arguments must be >= 0 */ if (p < 0) return NAN; else if (p == 0) { return POSINF; } else if (!isfinite(q)) { return NEGINF; } if (p >= 10) { /* p and q are big. */ corr = lgammacor(p) + lgammacor(q) - lgammacor(p + q); return log(q) * -0.5 + M_LN_SQRT_2PI + corr + (p - 0.5) * log(p / (p + q)) + q * log1p(-p / (p + q)); } else if (q >= 10) { /* p is small, but q is big. */ corr = lgammacor(q) - lgammacor(p + q); return lgammafn(state, p) + corr + p - p * log(p + q) + (q - 0.5) * log1p(-p / (p + q)); } else /* p and q are small: p <= q < 10. */ return log(gammafn(state, p) * (gammafn(state, q) / gammafn(state, p + q))); }
double gammafn(double x) { const static double gamcs[42] = { +.8571195590989331421920062399942e-2, +.4415381324841006757191315771652e-2, +.5685043681599363378632664588789e-1, -.4219835396418560501012500186624e-2, +.1326808181212460220584006796352e-2, -.1893024529798880432523947023886e-3, +.3606925327441245256578082217225e-4, -.6056761904460864218485548290365e-5, +.1055829546302283344731823509093e-5, -.1811967365542384048291855891166e-6, +.3117724964715322277790254593169e-7, -.5354219639019687140874081024347e-8, +.9193275519859588946887786825940e-9, -.1577941280288339761767423273953e-9, +.2707980622934954543266540433089e-10, -.4646818653825730144081661058933e-11, +.7973350192007419656460767175359e-12, -.1368078209830916025799499172309e-12, +.2347319486563800657233471771688e-13, -.4027432614949066932766570534699e-14, +.6910051747372100912138336975257e-15, -.1185584500221992907052387126192e-15, +.2034148542496373955201026051932e-16, -.3490054341717405849274012949108e-17, +.5987993856485305567135051066026e-18, -.1027378057872228074490069778431e-18, +.1762702816060529824942759660748e-19, -.3024320653735306260958772112042e-20, +.5188914660218397839717833550506e-21, -.8902770842456576692449251601066e-22, +.1527474068493342602274596891306e-22, -.2620731256187362900257328332799e-23, +.4496464047830538670331046570666e-24, -.7714712731336877911703901525333e-25, +.1323635453126044036486572714666e-25, -.2270999412942928816702313813333e-26, +.3896418998003991449320816639999e-27, -.6685198115125953327792127999999e-28, +.1146998663140024384347613866666e-28, -.1967938586345134677295103999999e-29, +.3376448816585338090334890666666e-30, -.5793070335782135784625493333333e-31 }; int i, n; double y; double sinpiy, value; #ifdef NOMORE_FOR_THREADS static int ngam = 0; static double xmin = 0, xmax = 0., xsml = 0., dxrel = 0.; /* Initialize machine dependent constants, the first time gamma() is called. FIXME for threads ! */ if (ngam == 0) { ngam = chebyshev_init(gamcs, 42, DBL_EPSILON/20);/*was .1*d1mach(3)*/ gammalims(&xmin, &xmax);/*-> ./gammalims.c */ xsml = exp(fmax2(log(DBL_MIN), -log(DBL_MAX)) + 0.01); /* = exp(.01)*DBL_MIN = 2.247e-308 for IEEE */ dxrel = sqrt(DBL_EPSILON);/*was sqrt(d1mach(4)) */ } #else /* For IEEE double precision DBL_EPSILON = 2^-52 = 2.220446049250313e-16 : * (xmin, xmax) are non-trivial, see ./gammalims.c * xsml = exp(.01)*DBL_MIN * dxrel = sqrt(DBL_EPSILON) = 2 ^ -26 */ # define ngam 22 # define xmin -170.5674972726612 # define xmax 171.61447887182298 # define xsml 2.2474362225598545e-308 # define dxrel 1.490116119384765696e-8 #endif if(ISNAN(x)) return x; /* If the argument is exactly zero or a negative integer * then return NaN. */ if (x == 0 || (x < 0 && x == (long)x)) { ML_ERROR(ME_DOMAIN, "gammafn"); return ML_NAN; } y = fabs(x); if (y <= 10) { /* Compute gamma(x) for -10 <= x <= 10 * Reduce the interval and find gamma(1 + y) for 0 <= y < 1 * first of all. */ n = (int) x; if(x < 0) --n; y = x - n;/* n = floor(x) ==> y in [ 0, 1 ) */ --n; value = chebyshev_eval(y * 2 - 1, gamcs, ngam) + .9375; if (n == 0) return value;/* x = 1.dddd = 1+y */ if (n < 0) { /* compute gamma(x) for -10 <= x < 1 */ /* exact 0 or "-n" checked already above */ /* The answer is less than half precision */ /* because x too near a negative integer. */ if (x < -0.5 && fabs(x - (int)(x - 0.5) / x) < dxrel) { ML_ERROR(ME_PRECISION, "gammafn"); } /* The argument is so close to 0 that the result would overflow. */ if (y < xsml) { ML_ERROR(ME_RANGE, "gammafn"); if(x > 0) return ML_POSINF; else return ML_NEGINF; } n = -n; for (i = 0; i < n; i++) { value /= (x + i); } return value; } else { /* gamma(x) for 2 <= x <= 10 */ for (i = 1; i <= n; i++) { value *= (y + i); } return value; } } else { /* gamma(x) for y = |x| > 10. */ if (x > xmax) { /* Overflow */ ML_ERROR(ME_RANGE, "gammafn"); return ML_POSINF; } if (x < xmin) { /* Underflow */ ML_ERROR(ME_UNDERFLOW, "gammafn"); return 0.; } if(y <= 50 && y == (int)y) { /* compute (n - 1)! */ value = 1.; for (i = 2; i < y; i++) value *= i; } else { /* normal case */ value = exp((y - 0.5) * log(y) - y + M_LN_SQRT_2PI + ((2*y == (int)2*y)? stirlerr(y) : lgammacor(y))); } if (x > 0) return value; if (fabs((x - (int)(x - 0.5))/x) < dxrel){ /* The answer is less than half precision because */ /* the argument is too near a negative integer. */ ML_ERROR(ME_PRECISION, "gammafn"); } sinpiy = sin(M_PI * y); if (sinpiy == 0) { /* Negative integer arg - overflow */ ML_ERROR(ME_RANGE, "gammafn"); return ML_POSINF; } return -M_PI / (y * sinpiy * value); } }
double lgammafn_sign(double x, int *sgn) { double ans, y, sinpiy; #ifdef NOMORE_FOR_THREADS static double xmax = 0.; static double dxrel = 0.; if (xmax == 0) {/* initialize machine dependent constants _ONCE_ */ xmax = d1mach(2)/log(d1mach(2));/* = 2.533 e305 for IEEE double */ dxrel = sqrt (d1mach(4));/* sqrt(Eps) ~ 1.49 e-8 for IEEE double */ } #else /* For IEEE double precision DBL_EPSILON = 2^-52 = 2.220446049250313e-16 : xmax = DBL_MAX / log(DBL_MAX) = 2^1024 / (1024 * log(2)) = 2^1014 / log(2) dxrel = sqrt(DBL_EPSILON) = 2^-26 = 5^26 * 1e-26 (is *exact* below !) */ #define xmax 2.5327372760800758e+305 #define dxrel 1.490116119384765625e-8 #endif if (sgn != NULL) *sgn = 1; #ifdef IEEE_754 if(ISNAN(x)) return x; #endif if (sgn != NULL && x < 0 && fmod(floor(-x), 2.) == 0) *sgn = -1; if (x <= 0 && x == trunc(x)) { /* Negative integer argument */ ML_ERROR(ME_RANGE, "lgamma"); return ML_POSINF;/* +Inf, since lgamma(x) = log|gamma(x)| */ } y = fabs(x); if (y < 1e-306) return -log(y); // denormalized range, R change if (y <= 10) return log(fabs(gammafn(x))); /* ELSE y = |x| > 10 ---------------------- */ if (y > xmax) { ML_ERROR(ME_RANGE, "lgamma"); return ML_POSINF; } if (x > 0) { /* i.e. y = x > 10 */ #ifdef IEEE_754 if(x > 1e17) return(x*(log(x) - 1.)); else if(x > 4934720.) return(M_LN_SQRT_2PI + (x - 0.5) * log(x) - x); else #endif return M_LN_SQRT_2PI + (x - 0.5) * log(x) - x + lgammacor(x); } /* else: x < -10; y = -x */ sinpiy = fabs(sinpi(y)); if (sinpiy == 0) { /* Negative integer argument === Now UNNECESSARY: caught above */ MATHLIB_WARNING(" ** should NEVER happen! *** [lgamma.c: Neg.int, y=%g]\n",y); ML_ERR_return_NAN; } ans = M_LN_SQRT_PId2 + (x - 0.5) * log(y) - x - log(sinpiy) - lgammacor(y); if(fabs((x - trunc(x - 0.5)) * ans / x) < dxrel) { /* The answer is less than half precision because * the argument is too near a negative integer. */ ML_ERROR(ME_PRECISION, "lgamma"); } return ans; }
gnm_float pochhammer (gnm_float x, gnm_float n) { gnm_float rn, rx, lr; GnmQuad m1, m2; int e1, e2; if (gnm_isnan (x) || gnm_isnan (n)) return gnm_nan; if (n == 0) return 1; rx = gnm_floor (x); rn = gnm_floor (n); /* * Use naive multiplication when n is a small integer. * We don't want to use this if x is also an integer * (but we might do so below if x is insanely large). */ if (n == rn && x != rx && n >= 0 && n < 40) return pochhammer_naive (x, (int)n); if (!qfactf (x + n - 1, &m1, &e1) && !qfactf (x - 1, &m2, &e2)) { void *state = gnm_quad_start (); int de = e1 - e2; GnmQuad qr; gnm_float r; gnm_quad_div (&qr, &m1, &m2); r = gnm_quad_value (&qr); gnm_quad_end (state); return gnm_ldexp (r, de); } if (x == rx && x <= 0) { if (n != rn) return 0; if (x == 0) return (n > 0) ? 0 : ((gnm_fmod (-n, 2) == 0 ? +1 : -1) / gnm_fact (-n)); if (n > -x) return gnm_nan; } /* * We have left the common cases. One of x+n and x is * insanely big, possibly both. */ if (gnm_abs (x) < 1) return gnm_pinf; if (n < 0) return 1 / pochhammer (x + n, -n); if (n == rn && n >= 0 && n < 100) return pochhammer_naive (x, (int)n); if (gnm_abs (n) < 1) { /* x is big. */ void *state = gnm_quad_start (); GnmQuad qr; gnm_float r; pochhammer_small_n (x, n, &qr); r = gnm_quad_value (&qr); gnm_quad_end (state); return r; } /* Panic mode. */ g_printerr ("x=%.20g n=%.20g\n", x, n); lr = ((x - 0.5) * gnm_log1p (n / x) + n * gnm_log (x + n) - n + (lgammacor (x + n) - lgammacor (x))); return gnm_exp (lr); }
double lgammafn(NMATH_STATE *state, double x) { double ans, y, sinpiy; /* For IEEE double precision DBL_EPSILON = 2^-52 = 2.220446049250313e-16 : xmax = DBL_MAX / log(DBL_MAX) = 2^1024 / (1024 * log(2)) = 2^1014 / log(2) dxrel = sqrt(DBL_EPSILON) = 2^-26 = 5^26 * 1e-26 (is *exact* below !) */ #define xmax 2.5327372760800758e+305 #define dxrel 1.490116119384765696e-8 // R_signgam = 1; #ifdef IEEE_754 if(ISNAN(x)) return x; #endif if (x < 0 && fmod(floor(-x), 2.) == 0) // R_signgam = -1; if (x <= 0 && x == trunc(x)) { /* Negative integer argument */ printf("lgammafn: range error"); return INFINITY;/* +Inf, since lgamma(x) = log|gamma(x)| */ } y = fabs(x); if (y <= 10) return log(fabs(gammafn(state,x))); /* ELSE y = |x| > 10 ---------------------- */ if (y > xmax) { printf("lgammafn: range error"); return INFINITY; } if (x > 0) { /* i.e. y = x > 10 */ #ifdef IEEE_754 if(x > 1e17) return(x*(log(x) - 1.)); else if(x > 4934720.) return(M_LN_SQRT_2PI + (x - 0.5) * log(x) - x); else #endif return M_LN_SQRT_2PI + (x - 0.5) * log(x) - x + lgammacor(x); } /* else: x < -10; y = -x */ sinpiy = fabs(sin(M_PI * y)); if (sinpiy == 0) { /* Negative integer argument === Now UNNECESSARY: caught above */ printf(" ** should NEVER happen! *** [lgamma.c: Neg.int, y=%g]\n",y); return NAN; } ans = M_LN_SQRT_PId2 + (x - 0.5) * log(y) - x - log(sinpiy) - lgammacor(y); if(fabs((x - trunc(x - 0.5)) * ans / x) < dxrel) { /* The answer is less than half precision because * the argument is too near a negative integer. */ printf("lgammafn: precision error"); } return ans; }