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