/* test gamma on some integral values (from Christopher Creutzig). */
static void
gamma_integer (void)
{
mpz_t n;
mpfr_t x, y;
unsigned int i;
mpz_init (n);
mpfr_init2 (x, 149);
mpfr_init2 (y, 149);
for (i = 0; i < 100; i++)
{
mpz_fac_ui (n, i);
mpfr_set_ui (x, i+1, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_z (x, n, GMP_RNDN);
if (!mpfr_equal_p (x, y))
{
printf ("Error for gamma(%d)\n", i+1);
printf ("expected "); mpfr_dump (x);
printf ("got "); mpfr_dump (y);
exit (1);
}
}
mpfr_clear (y);
mpfr_clear (x);
mpz_clear (n);
}
/* bug found by Stathis, only occurs on 32-bit machines */
static void
test20100709 (void)
{
mpfr_t x;
int inex;
mpfr_init2 (x, 100);
mpfr_set_str (x, "-4.6308260837372266e+07", 10, MPFR_RNDN);
inex = mpfr_gamma (x, x, MPFR_RNDN);
MPFR_ASSERTN(MPFR_IS_ZERO(x) && MPFR_IS_NEG(x) && inex > 0);
mpfr_clear (x);
}
/* bug found by Kevin Rauch */
static void
test20071231 (void)
{
mpfr_t x;
int inex;
mpfr_exp_t emin;
emin = mpfr_get_emin ();
mpfr_set_emin (-1000000);
mpfr_init2 (x, 21);
mpfr_set_str (x, "-1000001.5", 10, MPFR_RNDN);
inex = mpfr_gamma (x, x, MPFR_RNDN);
MPFR_ASSERTN(MPFR_IS_ZERO(x) && MPFR_IS_POS(x) && inex < 0);
mpfr_clear (x);
mpfr_set_emin (emin);
mpfr_init2 (x, 53);
mpfr_set_str (x, "-1000000001.5", 10, MPFR_RNDN);
inex = mpfr_gamma (x, x, MPFR_RNDN);
MPFR_ASSERTN(MPFR_IS_ZERO(x) && MPFR_IS_POS(x) && inex < 0);
mpfr_clear (x);
}
APLVFP PrimFnMonQuoteDotVisV
(APLVFP aplVfpRht,
LPPRIMSPEC lpPrimSpec)
{
APLMPI mpzRes = {0};
APLVFP mpfRes = {0};
// Check for indeterminates: !N for integer N < 0
if (mpfr_integer_p (&aplVfpRht)
&& mpfr_cmp_ui (&aplVfpRht, 0) < 0)
return *mpfr_QuadICValue (&aplVfpRht, // No left arg
ICNDX_QDOTn,
&aplVfpRht,
&mpfRes,
FALSE);
// Check for PosInfinity
if (IsMpfPosInfinity (&aplVfpRht))
return mpfPosInfinity;
// If the arg is an integer,
// and it fits in a ULONG, ...
if (mpfr_integer_p (&aplVfpRht)
&& mpfr_fits_uint_p (&aplVfpRht, MPFR_RNDN))
{
mpz_init (&mpzRes);
mpfr_init0 (&mpfRes);
mpz_fac_ui (&mpzRes, mpfr_get_ui (&aplVfpRht, MPFR_RNDN));
mpfr_set_z (&mpfRes, &mpzRes, MPFR_RNDN);
Myz_clear (&mpzRes);
} else
{
// Initialize the result
mpfr_init_set (&mpfRes, &aplVfpRht, MPFR_RNDN);
mpfr_add_ui (&mpfRes, &mpfRes, 1, MPFR_RNDN);
// Let MPFR handle it
mpfr_gamma (&mpfRes, &mpfRes, MPFR_RNDN);
#ifdef DEBUG
mpfr_free_cache ();
#endif
} // End IF/ELSE
return mpfRes;
} // End PrimFnMonQuoteDotVisV
//------------------------------------------------------------------------------
// Name:
//------------------------------------------------------------------------------
knumber_base *knumber_float::tgamma() {
#ifdef KNUMBER_USE_MPFR
mpfr_t mpfr;
mpfr_init_set_f(mpfr, mpf_, rounding_mode);
mpfr_gamma(mpfr, mpfr, rounding_mode);
mpfr_get_f(mpf_, mpfr, rounding_mode);
mpfr_clear(mpfr);
return this;
#else
const double x = mpf_get_d(mpf_);
if(isinf(x)) {
delete this;
return new knumber_error(knumber_error::ERROR_POS_INFINITY);
} else {
return execute_libc_func< ::tgamma>(x);
}
#endif
}
/* We use the reflection formula
Gamma(1+t) Gamma(1-t) = - Pi t / sin(Pi (1 + t))
in order to treat the case x <= 1,
i.e. with x = 1-t, then Gamma(x) = -Pi*(1-x)/sin(Pi*(2-x))/GAMMA(2-x)
*/
int
mpfr_gamma (mpfr_ptr gamma, mpfr_srcptr x, mpfr_rnd_t rnd_mode)
{
mpfr_t xp, GammaTrial, tmp, tmp2;
mpz_t fact;
mpfr_prec_t realprec;
int compared, is_integer;
int inex = 0; /* 0 means: result gamma not set yet */
MPFR_GROUP_DECL (group);
MPFR_SAVE_EXPO_DECL (expo);
MPFR_ZIV_DECL (loop);
MPFR_LOG_FUNC
(("x[%Pu]=%.*Rg rnd=%d", mpfr_get_prec (x), mpfr_log_prec, x, rnd_mode),
("gamma[%Pu]=%.*Rg inexact=%d",
mpfr_get_prec (gamma), mpfr_log_prec, gamma, inex));
/* Trivial cases */
if (MPFR_UNLIKELY (MPFR_IS_SINGULAR (x)))
{
if (MPFR_IS_NAN (x))
{
MPFR_SET_NAN (gamma);
MPFR_RET_NAN;
}
else if (MPFR_IS_INF (x))
{
if (MPFR_IS_NEG (x))
{
MPFR_SET_NAN (gamma);
MPFR_RET_NAN;
}
else
{
MPFR_SET_INF (gamma);
MPFR_SET_POS (gamma);
MPFR_RET (0); /* exact */
}
}
else /* x is zero */
{
MPFR_ASSERTD(MPFR_IS_ZERO(x));
MPFR_SET_INF(gamma);
MPFR_SET_SAME_SIGN(gamma, x);
MPFR_SET_DIVBY0 ();
MPFR_RET (0); /* exact */
}
}
/* Check for tiny arguments, where gamma(x) ~ 1/x - euler + ....
We know from "Bound on Runs of Zeros and Ones for Algebraic Functions",
Proceedings of Arith15, T. Lang and J.-M. Muller, 2001, that the maximal
number of consecutive zeroes or ones after the round bit is n-1 for an
input of n bits. But we need a more precise lower bound. Assume x has
n bits, and 1/x is near a floating-point number y of n+1 bits. We can
write x = X*2^e, y = Y/2^f with X, Y integers of n and n+1 bits.
Thus X*Y^2^(e-f) is near from 1, i.e., X*Y is near from 2^(f-e).
Two cases can happen:
(i) either X*Y is exactly 2^(f-e), but this can happen only if X and Y
are themselves powers of two, i.e., x is a power of two;
(ii) or X*Y is at distance at least one from 2^(f-e), thus
|xy-1| >= 2^(e-f), or |y-1/x| >= 2^(e-f)/x = 2^(-f)/X >= 2^(-f-n).
Since ufp(y) = 2^(n-f) [ufp = unit in first place], this means
that the distance |y-1/x| >= 2^(-2n) ufp(y).
Now assuming |gamma(x)-1/x| <= 1, which is true for x <= 1,
if 2^(-2n) ufp(y) >= 2, the error is at most 2^(-2n-1) ufp(y),
and round(1/x) with precision >= 2n+2 gives the correct result.
If x < 2^E, then y > 2^(-E), thus ufp(y) > 2^(-E-1).
A sufficient condition is thus EXP(x) + 2 <= -2 MAX(PREC(x),PREC(Y)).
*/
if (MPFR_GET_EXP (x) + 2
<= -2 * (mpfr_exp_t) MAX(MPFR_PREC(x), MPFR_PREC(gamma)))
{
int sign = MPFR_SIGN (x); /* retrieve sign before possible override */
int special;
MPFR_BLOCK_DECL (flags);
MPFR_SAVE_EXPO_MARK (expo);
/* for overflow cases, see below; this needs to be done
before x possibly gets overridden. */
special =
MPFR_GET_EXP (x) == 1 - MPFR_EMAX_MAX &&
MPFR_IS_POS_SIGN (sign) &&
MPFR_IS_LIKE_RNDD (rnd_mode, sign) &&
mpfr_powerof2_raw (x);
MPFR_BLOCK (flags, inex = mpfr_ui_div (gamma, 1, x, rnd_mode));
if (inex == 0) /* x is a power of two */
{
/* return RND(1/x - euler) = RND(+/- 2^k - eps) with eps > 0 */
if (rnd_mode == MPFR_RNDN || MPFR_IS_LIKE_RNDU (rnd_mode, sign))
inex = 1;
else
{
mpfr_nextbelow (gamma);
inex = -1;
}
}
else if (MPFR_UNLIKELY (MPFR_OVERFLOW (flags)))
{
/* Overflow in the division 1/x. This is a real overflow, except
in RNDZ or RNDD when 1/x = 2^emax, i.e. x = 2^(-emax): due to
the "- euler", the rounded value in unbounded exponent range
is 0.111...11 * 2^emax (not an overflow). */
if (!special)
MPFR_SAVE_EXPO_UPDATE_FLAGS (expo, flags);
}
MPFR_SAVE_EXPO_FREE (expo);
/* Note: an overflow is possible with an infinite result;
in this case, the overflow flag will automatically be
restored by mpfr_check_range. */
return mpfr_check_range (gamma, inex, rnd_mode);
}
is_integer = mpfr_integer_p (x);
/* gamma(x) for x a negative integer gives NaN */
if (is_integer && MPFR_IS_NEG(x))
{
MPFR_SET_NAN (gamma);
MPFR_RET_NAN;
}
compared = mpfr_cmp_ui (x, 1);
if (compared == 0)
return mpfr_set_ui (gamma, 1, rnd_mode);
/* if x is an integer that fits into an unsigned long, use mpfr_fac_ui
if argument is not too large.
If precision is p, fac_ui costs O(u*p), whereas gamma costs O(p*M(p)),
so for u <= M(p), fac_ui should be faster.
We approximate here M(p) by p*log(p)^2, which is not a bad guess.
Warning: since the generic code does not handle exact cases,
we want all cases where gamma(x) is exact to be treated here.
*/
if (is_integer && mpfr_fits_ulong_p (x, MPFR_RNDN))
{
unsigned long int u;
mpfr_prec_t p = MPFR_PREC(gamma);
u = mpfr_get_ui (x, MPFR_RNDN);
if (u < 44787929UL && bits_fac (u - 1) <= p + (rnd_mode == MPFR_RNDN))
/* bits_fac: lower bound on the number of bits of m,
where gamma(x) = (u-1)! = m*2^e with m odd. */
return mpfr_fac_ui (gamma, u - 1, rnd_mode);
/* if bits_fac(...) > p (resp. p+1 for rounding to nearest),
then gamma(x) cannot be exact in precision p (resp. p+1).
FIXME: remove the test u < 44787929UL after changing bits_fac
to return a mpz_t or mpfr_t. */
}
MPFR_SAVE_EXPO_MARK (expo);
/* check for overflow: according to (6.1.37) in Abramowitz & Stegun,
gamma(x) >= exp(-x) * x^(x-1/2) * sqrt(2*Pi)
>= 2 * (x/e)^x / x for x >= 1 */
if (compared > 0)
{
mpfr_t yp;
mpfr_exp_t expxp;
MPFR_BLOCK_DECL (flags);
/* quick test for the default exponent range */
if (mpfr_get_emax () >= 1073741823UL && MPFR_GET_EXP(x) <= 25)
{
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_gamma_aux (gamma, x, rnd_mode);
}
/* 1/e rounded down to 53 bits */
#define EXPM1_STR "0.010111100010110101011000110110001011001110111100111"
mpfr_init2 (xp, 53);
mpfr_init2 (yp, 53);
mpfr_set_str_binary (xp, EXPM1_STR);
mpfr_mul (xp, x, xp, MPFR_RNDZ);
mpfr_sub_ui (yp, x, 2, MPFR_RNDZ);
mpfr_pow (xp, xp, yp, MPFR_RNDZ); /* (x/e)^(x-2) */
mpfr_set_str_binary (yp, EXPM1_STR);
mpfr_mul (xp, xp, yp, MPFR_RNDZ); /* x^(x-2) / e^(x-1) */
mpfr_mul (xp, xp, yp, MPFR_RNDZ); /* x^(x-2) / e^x */
mpfr_mul (xp, xp, x, MPFR_RNDZ); /* lower bound on x^(x-1) / e^x */
MPFR_BLOCK (flags, mpfr_mul_2ui (xp, xp, 1, MPFR_RNDZ));
expxp = MPFR_GET_EXP (xp);
mpfr_clear (xp);
mpfr_clear (yp);
MPFR_SAVE_EXPO_FREE (expo);
return MPFR_OVERFLOW (flags) || expxp > __gmpfr_emax ?
mpfr_overflow (gamma, rnd_mode, 1) :
mpfr_gamma_aux (gamma, x, rnd_mode);
}
/* now compared < 0 */
/* check for underflow: for x < 1,
gamma(x) = Pi*(x-1)/sin(Pi*(2-x))/gamma(2-x).
Since gamma(2-x) >= 2 * ((2-x)/e)^(2-x) / (2-x), we have
|gamma(x)| <= Pi*(1-x)*(2-x)/2/((2-x)/e)^(2-x) / |sin(Pi*(2-x))|
<= 12 * ((2-x)/e)^x / |sin(Pi*(2-x))|.
To avoid an underflow in ((2-x)/e)^x, we compute the logarithm.
*/
if (MPFR_IS_NEG(x))
{
int underflow = 0, sgn, ck;
mpfr_prec_t w;
mpfr_init2 (xp, 53);
mpfr_init2 (tmp, 53);
mpfr_init2 (tmp2, 53);
/* we want an upper bound for x * [log(2-x)-1].
since x < 0, we need a lower bound on log(2-x) */
mpfr_ui_sub (xp, 2, x, MPFR_RNDD);
mpfr_log (xp, xp, MPFR_RNDD);
mpfr_sub_ui (xp, xp, 1, MPFR_RNDD);
mpfr_mul (xp, xp, x, MPFR_RNDU);
/* we need an upper bound on 1/|sin(Pi*(2-x))|,
thus a lower bound on |sin(Pi*(2-x))|.
If 2-x is exact, then the error of Pi*(2-x) is (1+u)^2 with u = 2^(-p)
thus the error on sin(Pi*(2-x)) is less than 1/2ulp + 3Pi(2-x)u,
assuming u <= 1, thus <= u + 3Pi(2-x)u */
w = mpfr_gamma_2_minus_x_exact (x); /* 2-x is exact for prec >= w */
w += 17; /* to get tmp2 small enough */
mpfr_set_prec (tmp, w);
mpfr_set_prec (tmp2, w);
MPFR_DBGRES (ck = mpfr_ui_sub (tmp, 2, x, MPFR_RNDN));
MPFR_ASSERTD (ck == 0); /* tmp = 2-x exactly */
mpfr_const_pi (tmp2, MPFR_RNDN);
mpfr_mul (tmp2, tmp2, tmp, MPFR_RNDN); /* Pi*(2-x) */
mpfr_sin (tmp, tmp2, MPFR_RNDN); /* sin(Pi*(2-x)) */
sgn = mpfr_sgn (tmp);
mpfr_abs (tmp, tmp, MPFR_RNDN);
mpfr_mul_ui (tmp2, tmp2, 3, MPFR_RNDU); /* 3Pi(2-x) */
mpfr_add_ui (tmp2, tmp2, 1, MPFR_RNDU); /* 3Pi(2-x)+1 */
mpfr_div_2ui (tmp2, tmp2, mpfr_get_prec (tmp), MPFR_RNDU);
/* if tmp2<|tmp|, we get a lower bound */
if (mpfr_cmp (tmp2, tmp) < 0)
{
mpfr_sub (tmp, tmp, tmp2, MPFR_RNDZ); /* low bnd on |sin(Pi*(2-x))| */
mpfr_ui_div (tmp, 12, tmp, MPFR_RNDU); /* upper bound */
mpfr_log2 (tmp, tmp, MPFR_RNDU);
mpfr_add (xp, tmp, xp, MPFR_RNDU);
/* The assert below checks that expo.saved_emin - 2 always
fits in a long. FIXME if we want to allow mpfr_exp_t to
be a long long, for instance. */
MPFR_ASSERTN (MPFR_EMIN_MIN - 2 >= LONG_MIN);
underflow = mpfr_cmp_si (xp, expo.saved_emin - 2) <= 0;
}
mpfr_clear (xp);
mpfr_clear (tmp);
mpfr_clear (tmp2);
if (underflow) /* the sign is the opposite of that of sin(Pi*(2-x)) */
{
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_underflow (gamma, (rnd_mode == MPFR_RNDN) ? MPFR_RNDZ : rnd_mode, -sgn);
}
}
realprec = MPFR_PREC (gamma);
/* we want both 1-x and 2-x to be exact */
{
mpfr_prec_t w;
w = mpfr_gamma_1_minus_x_exact (x);
if (realprec < w)
realprec = w;
w = mpfr_gamma_2_minus_x_exact (x);
if (realprec < w)
realprec = w;
}
realprec = realprec + MPFR_INT_CEIL_LOG2 (realprec) + 20;
MPFR_ASSERTD(realprec >= 5);
MPFR_GROUP_INIT_4 (group, realprec + MPFR_INT_CEIL_LOG2 (realprec) + 20,
xp, tmp, tmp2, GammaTrial);
mpz_init (fact);
MPFR_ZIV_INIT (loop, realprec);
for (;;)
{
mpfr_exp_t err_g;
int ck;
MPFR_GROUP_REPREC_4 (group, realprec, xp, tmp, tmp2, GammaTrial);
/* reflection formula: gamma(x) = Pi*(x-1)/sin(Pi*(2-x))/gamma(2-x) */
ck = mpfr_ui_sub (xp, 2, x, MPFR_RNDN); /* 2-x, exact */
MPFR_ASSERTD(ck == 0); (void) ck; /* use ck to avoid a warning */
mpfr_gamma (tmp, xp, MPFR_RNDN); /* gamma(2-x), error (1+u) */
mpfr_const_pi (tmp2, MPFR_RNDN); /* Pi, error (1+u) */
mpfr_mul (GammaTrial, tmp2, xp, MPFR_RNDN); /* Pi*(2-x), error (1+u)^2 */
err_g = MPFR_GET_EXP(GammaTrial);
mpfr_sin (GammaTrial, GammaTrial, MPFR_RNDN); /* sin(Pi*(2-x)) */
/* If tmp is +Inf, we compute exp(lngamma(x)). */
if (mpfr_inf_p (tmp))
{
inex = mpfr_explgamma (gamma, x, &expo, tmp, tmp2, rnd_mode);
if (inex)
goto end;
else
goto ziv_next;
}
err_g = err_g + 1 - MPFR_GET_EXP(GammaTrial);
/* let g0 the true value of Pi*(2-x), g the computed value.
We have g = g0 + h with |h| <= |(1+u^2)-1|*g.
Thus sin(g) = sin(g0) + h' with |h'| <= |(1+u^2)-1|*g.
The relative error is thus bounded by |(1+u^2)-1|*g/sin(g)
<= |(1+u^2)-1|*2^err_g. <= 2.25*u*2^err_g for |u|<=1/4.
With the rounding error, this gives (0.5 + 2.25*2^err_g)*u. */
ck = mpfr_sub_ui (xp, x, 1, MPFR_RNDN); /* x-1, exact */
MPFR_ASSERTD(ck == 0); (void) ck; /* use ck to avoid a warning */
mpfr_mul (xp, tmp2, xp, MPFR_RNDN); /* Pi*(x-1), error (1+u)^2 */
mpfr_mul (GammaTrial, GammaTrial, tmp, MPFR_RNDN);
/* [1 + (0.5 + 2.25*2^err_g)*u]*(1+u)^2 = 1 + (2.5 + 2.25*2^err_g)*u
+ (0.5 + 2.25*2^err_g)*u*(2u+u^2) + u^2.
For err_g <= realprec-2, we have (0.5 + 2.25*2^err_g)*u <=
0.5*u + 2.25/4 <= 0.6875 and u^2 <= u/4, thus
(0.5 + 2.25*2^err_g)*u*(2u+u^2) + u^2 <= 0.6875*(2u+u/4) + u/4
<= 1.8*u, thus the rel. error is bounded by (4.5 + 2.25*2^err_g)*u. */
mpfr_div (GammaTrial, xp, GammaTrial, MPFR_RNDN);
/* the error is of the form (1+u)^3/[1 + (4.5 + 2.25*2^err_g)*u].
For realprec >= 5 and err_g <= realprec-2, [(4.5 + 2.25*2^err_g)*u]^2
<= 0.71, and for |y|<=0.71, 1/(1-y) can be written 1+a*y with a<=4.
(1+u)^3 * (1+4*(4.5 + 2.25*2^err_g)*u)
= 1 + (21 + 9*2^err_g)*u + (57+27*2^err_g)*u^2 + (55+27*2^err_g)*u^3
+ (18+9*2^err_g)*u^4
<= 1 + (21 + 9*2^err_g)*u + (57+27*2^err_g)*u^2 + (56+28*2^err_g)*u^3
<= 1 + (21 + 9*2^err_g)*u + (59+28*2^err_g)*u^2
<= 1 + (23 + 10*2^err_g)*u.
The final error is thus bounded by (23 + 10*2^err_g) ulps,
which is <= 2^6 for err_g<=2, and <= 2^(err_g+4) for err_g >= 2. */
err_g = (err_g <= 2) ? 6 : err_g + 4;
if (MPFR_LIKELY (MPFR_CAN_ROUND (GammaTrial, realprec - err_g,
MPFR_PREC(gamma), rnd_mode)))
break;
ziv_next:
MPFR_ZIV_NEXT (loop, realprec);
}
end:
MPFR_ZIV_FREE (loop);
if (inex == 0)
inex = mpfr_set (gamma, GammaTrial, rnd_mode);
MPFR_GROUP_CLEAR (group);
mpz_clear (fact);
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (gamma, inex, rnd_mode);
}
static void
special (void)
{
mpfr_t x, y;
int inex;
mpfr_init (x);
mpfr_init (y);
mpfr_set_nan (x);
mpfr_gamma (y, x, GMP_RNDN);
if (!mpfr_nan_p (y))
{
printf ("Error for gamma(NaN)\n");
exit (1);
}
mpfr_set_inf (x, -1);
mpfr_gamma (y, x, GMP_RNDN);
if (!mpfr_nan_p (y))
{
printf ("Error for gamma(-Inf)\n");
exit (1);
}
mpfr_set_inf (x, 1);
mpfr_gamma (y, x, GMP_RNDN);
if (!mpfr_inf_p (y) || mpfr_sgn (y) < 0)
{
printf ("Error for gamma(+Inf)\n");
exit (1);
}
mpfr_set_ui (x, 0, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
if (!mpfr_inf_p (y) || mpfr_sgn (y) < 0)
{
printf ("Error for gamma(+0)\n");
exit (1);
}
mpfr_set_ui (x, 0, GMP_RNDN);
mpfr_neg (x, x, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
if (!mpfr_inf_p (y) || mpfr_sgn (y) > 0)
{
printf ("Error for gamma(-0)\n");
exit (1);
}
mpfr_set_ui (x, 1, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
if (mpfr_cmp_ui (y, 1))
{
printf ("Error for gamma(1)\n");
exit (1);
}
mpfr_set_si (x, -1, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
if (!mpfr_nan_p (y))
{
printf ("Error for gamma(-1)\n");
exit (1);
}
mpfr_set_prec (x, 53);
mpfr_set_prec (y, 53);
#define CHECK_X1 "1.0762904832837976166"
#define CHECK_Y1 "0.96134843256452096050"
mpfr_set_str (x, CHECK_X1, 10, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_str (x, CHECK_Y1, 10, GMP_RNDN);
if (mpfr_cmp (y, x))
{
printf ("mpfr_lngamma("CHECK_X1") is wrong:\n"
"expected ");
mpfr_print_binary (x); putchar ('\n');
printf ("got ");
mpfr_print_binary (y); putchar ('\n');
exit (1);
}
#define CHECK_X2 "9.23709516716202383435e-01"
#define CHECK_Y2 "1.0502315560291053398"
mpfr_set_str (x, CHECK_X2, 10, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_str (x, CHECK_Y2, 10, GMP_RNDN);
if (mpfr_cmp (y, x))
{
printf ("mpfr_lngamma("CHECK_X2") is wrong:\n"
"expected ");
mpfr_print_binary (x); putchar ('\n');
printf ("got ");
mpfr_print_binary (y); putchar ('\n');
exit (1);
}
mpfr_set_prec (x, 8);
mpfr_set_prec (y, 175);
mpfr_set_ui (x, 33, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDU);
mpfr_set_prec (x, 175);
mpfr_set_str_binary (x, "0.110010101011010101101000010101010111000110011101001000101011000001100010111001101001011E118");
if (mpfr_cmp (x, y))
{
printf ("Error in mpfr_gamma (1)\n");
exit (1);
}
mpfr_set_prec (x, 21);
mpfr_set_prec (y, 8);
mpfr_set_ui (y, 120, GMP_RNDN);
mpfr_gamma (x, y, GMP_RNDZ);
mpfr_set_prec (y, 21);
mpfr_set_str_binary (y, "0.101111101110100110110E654");
if (mpfr_cmp (x, y))
{
printf ("Error in mpfr_gamma (120)\n");
printf ("Expected "); mpfr_print_binary (y); puts ("");
printf ("Got "); mpfr_print_binary (x); puts ("");
exit (1);
}
mpfr_set_prec (x, 3);
mpfr_set_prec (y, 206);
mpfr_set_str_binary (x, "0.110e10");
inex = mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_prec (x, 206);
mpfr_set_str_binary (x, "0.110111100001000001101010010001000111000100000100111000010011100011011111001100011110101000111101101100110001001100110100001001111110000101010000100100011100010011101110000001000010001100010000101001111E6250");
if (mpfr_cmp (x, y))
{
printf ("Error in mpfr_gamma (768)\n");
exit (1);
}
if (inex <= 0)
{
printf ("Wrong flag for mpfr_gamma (768)\n");
exit (1);
}
/* worst case to exercise retry */
mpfr_set_prec (x, 1000);
mpfr_set_prec (y, 869);
mpfr_const_pi (x, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_prec (x, 4);
mpfr_set_prec (y, 4);
mpfr_set_str_binary (x, "-0.1100E-66");
mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_str_binary (x, "-0.1011E67");
if (mpfr_cmp (x, y))
{
printf ("Error for gamma(-0.1100E-66)\n");
exit (1);
}
mpfr_clear (x);
mpfr_clear (y);
}
static void
special_overflow (void)
{
mpfr_t x, y;
mp_exp_t emin, emax;
int inex;
emin = mpfr_get_emin ();
emax = mpfr_get_emax ();
set_emin (-125);
set_emax (128);
mpfr_init2 (x, 24);
mpfr_init2 (y, 24);
mpfr_set_str_binary (x, "0.101100100000000000110100E7");
mpfr_gamma (y, x, GMP_RNDN);
if (!mpfr_inf_p (y))
{
printf ("Overflow error.\n");
mpfr_dump (y);
exit (1);
}
/* problem mentioned by Kenneth Wilder, 18 Aug 2005 */
mpfr_set_prec (x, 29);
mpfr_set_prec (y, 29);
mpfr_set_str (x, "-200000000.5", 10, GMP_RNDN); /* exact */
mpfr_gamma (y, x, GMP_RNDN);
if (!(mpfr_zero_p (y) && MPFR_SIGN (y) < 0))
{
printf ("Error for gamma(-200000000.5)\n");
printf ("expected -0");
printf ("got ");
mpfr_dump (y);
exit (1);
}
mpfr_set_prec (x, 53);
mpfr_set_prec (y, 53);
mpfr_set_str (x, "-200000000.1", 10, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
if (!(mpfr_zero_p (y) && MPFR_SIGN (y) < 0))
{
printf ("Error for gamma(-200000000.1), prec=53\n");
printf ("expected -0");
printf ("got ");
mpfr_dump (y);
exit (1);
}
/* another problem mentioned by Kenneth Wilder, 29 Aug 2005 */
mpfr_set_prec (x, 333);
mpfr_set_prec (y, 14);
mpfr_set_str (x, "-2.0000000000000000000000005", 10, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_prec (x, 14);
mpfr_set_str_binary (x, "-11010011110001E66");
if (mpfr_cmp (x, y))
{
printf ("Error for gamma(-2.0000000000000000000000005)\n");
printf ("expected "); mpfr_dump (x);
printf ("got "); mpfr_dump (y);
exit (1);
}
/* another tests from Kenneth Wilder, 31 Aug 2005 */
set_emax (200);
set_emin (-200);
mpfr_set_prec (x, 38);
mpfr_set_prec (y, 54);
mpfr_set_str_binary (x, "0.11101111011100111101001001010110101001E-166");
mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_prec (x, 54);
mpfr_set_str_binary (x, "0.100010001101100001110110001010111111010000100101011E167");
if (mpfr_cmp (x, y))
{
printf ("Error for gamma (test 1)\n");
printf ("expected "); mpfr_dump (x);
printf ("got "); mpfr_dump (y);
exit (1);
}
set_emax (1000);
set_emin (-2000);
mpfr_set_prec (x, 38);
mpfr_set_prec (y, 71);
mpfr_set_str_binary (x, "10101011011100001111111000010111110010E-1034");
/* 184083777010*2^(-1034) */
mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_prec (x, 71);
mpfr_set_str_binary (x, "10111111001000011110010001000000000000110011110000000011101011111111100E926");
/* 1762885132679550982140*2^926 */
if (mpfr_cmp (x, y))
{
printf ("Error for gamma (test 2)\n");
printf ("expected "); mpfr_dump (x);
printf ("got "); mpfr_dump (y);
exit (1);
}
mpfr_set_prec (x, 38);
mpfr_set_prec (y, 88);
mpfr_set_str_binary (x, "10111100111001010000100001100100100101E-104");
/* 202824096037*2^(-104) */
mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_prec (x, 88);
mpfr_set_str_binary (x, "1010110101111000111010111100010110101010100110111000001011000111000011101100001101110010E-21");
/* 209715199999500283894743922*2^(-21) */
if (mpfr_cmp (x, y))
{
printf ("Error for gamma (test 3)\n");
printf ("expected "); mpfr_dump (x);
printf ("got "); mpfr_dump (y);
exit (1);
}
mpfr_set_prec (x, 171);
mpfr_set_prec (y, 38);
mpfr_set_str (x, "-2993155353253689176481146537402947624254601559176535", 10,
GMP_RNDN);
mpfr_div_2exp (x, x, 170, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_prec (x, 38);
mpfr_set_str (x, "201948391737", 10, GMP_RNDN);
mpfr_mul_2exp (x, x, 92, GMP_RNDN);
if (mpfr_cmp (x, y))
{
printf ("Error for gamma (test 5)\n");
printf ("expected "); mpfr_dump (x);
printf ("got "); mpfr_dump (y);
exit (1);
}
set_emin (-500000);
mpfr_set_prec (x, 337);
mpfr_set_prec (y, 38);
mpfr_set_str (x, "-30000.000000000000000000000000000000000000000000001", 10,
GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
mpfr_set_prec (x, 38);
mpfr_set_str (x, "-3.623795987425E-121243", 10, GMP_RNDN);
if (mpfr_cmp (x, y))
{
printf ("Error for gamma (test 7)\n");
printf ("expected "); mpfr_dump (x);
printf ("got "); mpfr_dump (y);
exit (1);
}
/* was producing infinite loop */
set_emin (emin);
mpfr_set_prec (x, 71);
mpfr_set_prec (y, 71);
mpfr_set_str (x, "-200000000.1", 10, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
if (!(mpfr_zero_p (y) && MPFR_SIGN (y) < 0))
{
printf ("Error for gamma (test 8)\n");
printf ("expected "); mpfr_dump (x);
printf ("got "); mpfr_dump (y);
exit (1);
}
set_emax (1073741823);
mpfr_set_prec (x, 29);
mpfr_set_prec (y, 29);
mpfr_set_str (x, "423786866", 10, GMP_RNDN);
mpfr_gamma (y, x, GMP_RNDN);
if (!mpfr_inf_p (y) || mpfr_sgn (y) < 0)
{
printf ("Error for gamma(423786866)\n");
exit (1);
}
/* check exact result */
mpfr_set_prec (x, 2);
mpfr_set_ui (x, 3, GMP_RNDN);
inex = mpfr_gamma (x, x, GMP_RNDN);
if (inex != 0 || mpfr_cmp_ui (x, 2) != 0)
{
printf ("Error for gamma(3)\n");
exit (1);
}
mpfr_set_emax (1024);
mpfr_set_prec (x, 53);
mpfr_set_prec (y, 53);
mpfr_set_str_binary (x, "101010110100110011111010000110001000111100000110101E-43");
mpfr_gamma (x, x, GMP_RNDU);
mpfr_set_str_binary (y, "110000011110001000111110110101011110000100001111111E971");
if (mpfr_cmp (x, y) != 0)
{
printf ("Error for gamma(4)\n");
printf ("expected "); mpfr_dump (y);
printf ("got "); mpfr_dump (x);
exit (1);
}
mpfr_clear (y);
mpfr_clear (x);
set_emin (emin);
set_emax (emax);
}
static int
tiny_aux (int stop, mpfr_exp_t e)
{
mpfr_t x, y, z;
int r, s, spm, inex, err = 0;
int expected_dir[2][5] = { { 1, -1, 1, -1, 1 }, { 1, 1, 1, -1, -1 } };
mpfr_exp_t saved_emax;
saved_emax = mpfr_get_emax ();
mpfr_init2 (x, 32);
mpfr_inits2 (8, y, z, (mpfr_ptr) 0);
mpfr_set_ui_2exp (x, 1, e, MPFR_RNDN);
spm = 1;
for (s = 0; s < 2; s++)
{
RND_LOOP(r)
{
mpfr_rnd_t rr = (mpfr_rnd_t) r;
mpfr_exp_t exponent, emax;
/* Exponent of the rounded value in unbounded exponent range. */
exponent = expected_dir[s][r] < 0 && s == 0 ? - e : 1 - e;
for (emax = exponent - 1; emax <= exponent; emax++)
{
unsigned int flags, expected_flags = MPFR_FLAGS_INEXACT;
int overflow, expected_inex = expected_dir[s][r];
if (emax > MPFR_EMAX_MAX)
break;
mpfr_set_emax (emax);
mpfr_clear_flags ();
inex = mpfr_gamma (y, x, rr);
flags = __gmpfr_flags;
mpfr_clear_flags ();
mpfr_set_si_2exp (z, spm, - e, MPFR_RNDU);
overflow = mpfr_overflow_p ();
/* z is 1/x - euler rounded toward +inf */
if (overflow && rr == MPFR_RNDN && s == 1)
expected_inex = -1;
if (expected_inex < 0)
mpfr_nextbelow (z); /* 1/x - euler rounded toward -inf */
if (exponent > emax)
expected_flags |= MPFR_FLAGS_OVERFLOW;
if (!(mpfr_equal_p (y, z) && flags == expected_flags
&& SAME_SIGN (inex, expected_inex)))
{
printf ("Error in tiny for s = %d, r = %s, emax = %"
MPFR_EXP_FSPEC "d%s\n on ",
s, mpfr_print_rnd_mode (rr), emax,
exponent > emax ? " (overflow)" : "");
mpfr_dump (x);
printf (" expected inex = %2d, ", expected_inex);
mpfr_dump (z);
printf (" got inex = %2d, ", SIGN (inex));
mpfr_dump (y);
printf (" expected flags = %u, got %u\n",
expected_flags, flags);
if (stop)
exit (1);
err = 1;
}
}
}
mpfr_neg (x, x, MPFR_RNDN);
spm = - spm;
}
mpfr_clears (x, y, z, (mpfr_ptr) 0);
mpfr_set_emax (saved_emax);
return err;
}
static void
exprange (void)
{
mpfr_exp_t emin, emax;
mpfr_t x, y, z;
int inex1, inex2;
unsigned int flags1, flags2;
emin = mpfr_get_emin ();
emax = mpfr_get_emax ();
mpfr_init2 (x, 16);
mpfr_inits2 (8, y, z, (mpfr_ptr) 0);
mpfr_set_ui_2exp (x, 5, -1, MPFR_RNDN);
mpfr_clear_flags ();
inex1 = mpfr_gamma (y, x, MPFR_RNDN);
flags1 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
mpfr_set_emin (0);
mpfr_clear_flags ();
inex2 = mpfr_gamma (z, x, MPFR_RNDN);
flags2 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
mpfr_set_emin (emin);
if (inex1 != inex2 || flags1 != flags2 || ! mpfr_equal_p (y, z))
{
printf ("Error in exprange (test1)\n");
printf ("x = ");
mpfr_dump (x);
printf ("Expected inex1 = %d, flags1 = %u, ", SIGN (inex1), flags1);
mpfr_dump (y);
printf ("Got inex2 = %d, flags2 = %u, ", SIGN (inex2), flags2);
mpfr_dump (z);
exit (1);
}
mpfr_set_ui_2exp (x, 32769, -60, MPFR_RNDN);
mpfr_clear_flags ();
inex1 = mpfr_gamma (y, x, MPFR_RNDD);
flags1 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
mpfr_set_emax (45);
mpfr_clear_flags ();
inex2 = mpfr_gamma (z, x, MPFR_RNDD);
flags2 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
mpfr_set_emax (emax);
if (inex1 != inex2 || flags1 != flags2 || ! mpfr_equal_p (y, z))
{
printf ("Error in exprange (test2)\n");
printf ("x = ");
mpfr_dump (x);
printf ("Expected inex1 = %d, flags1 = %u, ", SIGN (inex1), flags1);
mpfr_dump (y);
printf ("Got inex2 = %d, flags2 = %u, ", SIGN (inex2), flags2);
mpfr_dump (z);
exit (1);
}
mpfr_set_emax (44);
mpfr_clear_flags ();
inex1 = mpfr_check_range (y, inex1, MPFR_RNDD);
flags1 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
mpfr_clear_flags ();
inex2 = mpfr_gamma (z, x, MPFR_RNDD);
flags2 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
mpfr_set_emax (emax);
if (inex1 != inex2 || flags1 != flags2 || ! mpfr_equal_p (y, z))
{
printf ("Error in exprange (test3)\n");
printf ("x = ");
mpfr_dump (x);
printf ("Expected inex1 = %d, flags1 = %u, ", SIGN (inex1), flags1);
mpfr_dump (y);
printf ("Got inex2 = %d, flags2 = %u, ", SIGN (inex2), flags2);
mpfr_dump (z);
exit (1);
}
mpfr_set_ui_2exp (x, 1, -60, MPFR_RNDN);
mpfr_clear_flags ();
inex1 = mpfr_gamma (y, x, MPFR_RNDD);
flags1 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
mpfr_set_emax (60);
mpfr_clear_flags ();
inex2 = mpfr_gamma (z, x, MPFR_RNDD);
flags2 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
mpfr_set_emax (emax);
if (inex1 != inex2 || flags1 != flags2 || ! mpfr_equal_p (y, z))
{
printf ("Error in exprange (test4)\n");
printf ("x = ");
mpfr_dump (x);
printf ("Expected inex1 = %d, flags1 = %u, ", SIGN (inex1), flags1);
mpfr_dump (y);
printf ("Got inex2 = %d, flags2 = %u, ", SIGN (inex2), flags2);
mpfr_dump (z);
exit (1);
}
MPFR_ASSERTN (MPFR_EMIN_MIN == - MPFR_EMAX_MAX);
mpfr_set_emin (MPFR_EMIN_MIN);
mpfr_set_emax (MPFR_EMAX_MAX);
mpfr_set_ui (x, 0, MPFR_RNDN);
mpfr_nextabove (x); /* x = 2^(emin - 1) */
mpfr_set_inf (y, 1);
inex1 = 1;
flags1 = MPFR_FLAGS_INEXACT | MPFR_FLAGS_OVERFLOW;
mpfr_clear_flags ();
/* MPFR_RNDU: overflow, infinity since 1/x = 2^(emax + 1) */
inex2 = mpfr_gamma (z, x, MPFR_RNDU);
flags2 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
if (inex1 != inex2 || flags1 != flags2 || ! mpfr_equal_p (y, z))
{
printf ("Error in exprange (test5)\n");
printf ("x = ");
mpfr_dump (x);
printf ("Expected inex1 = %d, flags1 = %u, ", SIGN (inex1), flags1);
mpfr_dump (y);
printf ("Got inex2 = %d, flags2 = %u, ", SIGN (inex2), flags2);
mpfr_dump (z);
exit (1);
}
mpfr_clear_flags ();
/* MPFR_RNDN: overflow, infinity since 1/x = 2^(emax + 1) */
inex2 = mpfr_gamma (z, x, MPFR_RNDN);
flags2 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
if (inex1 != inex2 || flags1 != flags2 || ! mpfr_equal_p (y, z))
{
printf ("Error in exprange (test6)\n");
printf ("x = ");
mpfr_dump (x);
printf ("Expected inex1 = %d, flags1 = %u, ", SIGN (inex1), flags1);
mpfr_dump (y);
printf ("Got inex2 = %d, flags2 = %u, ", SIGN (inex2), flags2);
mpfr_dump (z);
exit (1);
}
mpfr_nextbelow (y);
inex1 = -1;
mpfr_clear_flags ();
/* MPFR_RNDD: overflow, maxnum since 1/x = 2^(emax + 1) */
inex2 = mpfr_gamma (z, x, MPFR_RNDD);
flags2 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
if (inex1 != inex2 || flags1 != flags2 || ! mpfr_equal_p (y, z))
{
printf ("Error in exprange (test7)\n");
printf ("x = ");
mpfr_dump (x);
printf ("Expected inex1 = %d, flags1 = %u, ", SIGN (inex1), flags1);
mpfr_dump (y);
printf ("Got inex2 = %d, flags2 = %u, ", SIGN (inex2), flags2);
mpfr_dump (z);
exit (1);
}
mpfr_mul_2ui (x, x, 1, MPFR_RNDN); /* x = 2^emin */
mpfr_set_inf (y, 1);
inex1 = 1;
flags1 = MPFR_FLAGS_INEXACT | MPFR_FLAGS_OVERFLOW;
mpfr_clear_flags ();
/* MPFR_RNDU: overflow, infinity since 1/x = 2^emax */
inex2 = mpfr_gamma (z, x, MPFR_RNDU);
flags2 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
if (inex1 != inex2 || flags1 != flags2 || ! mpfr_equal_p (y, z))
{
printf ("Error in exprange (test8)\n");
printf ("x = ");
mpfr_dump (x);
printf ("Expected inex1 = %d, flags1 = %u, ", SIGN (inex1), flags1);
mpfr_dump (y);
printf ("Got inex2 = %d, flags2 = %u, ", SIGN (inex2), flags2);
mpfr_dump (z);
exit (1);
}
mpfr_clear_flags ();
/* MPFR_RNDN: overflow, infinity since 1/x = 2^emax */
inex2 = mpfr_gamma (z, x, MPFR_RNDN);
flags2 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
if (inex1 != inex2 || flags1 != flags2 || ! mpfr_equal_p (y, z))
{
printf ("Error in exprange (test9)\n");
printf ("x = ");
mpfr_dump (x);
printf ("Expected inex1 = %d, flags1 = %u, ", SIGN (inex1), flags1);
mpfr_dump (y);
printf ("Got inex2 = %d, flags2 = %u, ", SIGN (inex2), flags2);
mpfr_dump (z);
exit (1);
}
mpfr_nextbelow (y);
inex1 = -1;
flags1 = MPFR_FLAGS_INEXACT;
mpfr_clear_flags ();
/* MPFR_RNDD: no overflow, maxnum since 1/x = 2^emax and euler > 0 */
inex2 = mpfr_gamma (z, x, MPFR_RNDD);
flags2 = __gmpfr_flags;
MPFR_ASSERTN (mpfr_inexflag_p ());
if (inex1 != inex2 || flags1 != flags2 || ! mpfr_equal_p (y, z))
{
printf ("Error in exprange (test10)\n");
printf ("x = ");
mpfr_dump (x);
printf ("Expected inex1 = %d, flags1 = %u, ", SIGN (inex1), flags1);
mpfr_dump (y);
printf ("Got inex2 = %d, flags2 = %u, ", SIGN (inex2), flags2);
mpfr_dump (z);
exit (1);
}
mpfr_set_emin (emin);
mpfr_set_emax (emax);
mpfr_clears (x, y, z, (mpfr_ptr) 0);
}
int
mpfr_zeta (mpfr_t z, mpfr_srcptr s, mp_rnd_t rnd_mode)
{
mpfr_t z_pre, s1, y, p;
double sd, eps, m1, c;
long add;
mp_prec_t precz, prec1, precs, precs1;
int inex;
MPFR_GROUP_DECL (group);
MPFR_ZIV_DECL (loop);
MPFR_SAVE_EXPO_DECL (expo);
MPFR_LOG_FUNC (("s[%#R]=%R rnd=%d", s, s, rnd_mode),
("z[%#R]=%R inexact=%d", z, z, inex));
/* Zero, Nan or Inf ? */
if (MPFR_UNLIKELY (MPFR_IS_SINGULAR (s)))
{
if (MPFR_IS_NAN (s))
{
MPFR_SET_NAN (z);
MPFR_RET_NAN;
}
else if (MPFR_IS_INF (s))
{
if (MPFR_IS_POS (s))
return mpfr_set_ui (z, 1, GMP_RNDN); /* Zeta(+Inf) = 1 */
MPFR_SET_NAN (z); /* Zeta(-Inf) = NaN */
MPFR_RET_NAN;
}
else /* s iz zero */
{
MPFR_ASSERTD (MPFR_IS_ZERO (s));
mpfr_set_ui (z, 1, rnd_mode);
mpfr_div_2ui (z, z, 1, rnd_mode);
MPFR_CHANGE_SIGN (z);
MPFR_RET (0);
}
}
/* s is neither Nan, nor Inf, nor Zero */
/* check tiny s: we have zeta(s) = -1/2 - 1/2 log(2 Pi) s + ... around s=0,
and for |s| <= 0.074, we have |zeta(s) + 1/2| <= |s|.
Thus if |s| <= 1/4*ulp(1/2), we can deduce the correct rounding
(the 1/4 covers the case where |zeta(s)| < 1/2 and rounding to nearest).
A sufficient condition is that EXP(s) + 1 < -PREC(z). */
if (MPFR_EXP(s) + 1 < - (mp_exp_t) MPFR_PREC(z))
{
int signs = MPFR_SIGN(s);
mpfr_set_si_2exp (z, -1, -1, rnd_mode); /* -1/2 */
if ((rnd_mode == GMP_RNDU || rnd_mode == GMP_RNDZ) && signs < 0)
{
mpfr_nextabove (z); /* z = -1/2 + epsilon */
inex = 1;
}
else if (rnd_mode == GMP_RNDD && signs > 0)
{
mpfr_nextbelow (z); /* z = -1/2 - epsilon */
inex = -1;
}
else
{
if (rnd_mode == GMP_RNDU) /* s > 0: z = -1/2 */
inex = 1;
else if (rnd_mode == GMP_RNDD)
inex = -1; /* s < 0: z = -1/2 */
else /* (GMP_RNDZ and s > 0) or GMP_RNDN: z = -1/2 */
inex = (signs > 0) ? 1 : -1;
}
return mpfr_check_range (z, inex, rnd_mode);
}
/* Check for case s= -2n */
if (MPFR_IS_NEG (s))
{
mpfr_t tmp;
tmp[0] = *s;
MPFR_EXP (tmp) = MPFR_EXP (s) - 1;
if (mpfr_integer_p (tmp))
{
MPFR_SET_ZERO (z);
MPFR_SET_POS (z);
MPFR_RET (0);
}
}
MPFR_SAVE_EXPO_MARK (expo);
/* Compute Zeta */
if (MPFR_IS_POS (s) && MPFR_GET_EXP (s) >= 0) /* Case s >= 1/2 */
inex = mpfr_zeta_pos (z, s, rnd_mode);
else /* use reflection formula
zeta(s) = 2^s*Pi^(s-1)*sin(Pi*s/2)*gamma(1-s)*zeta(1-s) */
{
precz = MPFR_PREC (z);
precs = MPFR_PREC (s);
/* Precision precs1 needed to represent 1 - s, and s + 2,
without any truncation */
precs1 = precs + 2 + MAX (0, - MPFR_GET_EXP (s));
sd = mpfr_get_d (s, GMP_RNDN) - 1.0;
if (sd < 0.0)
sd = -sd; /* now sd = abs(s-1.0) */
/* Precision prec1 is the precision on elementary computations;
it ensures a final precision prec1 - add for zeta(s) */
/* eps = pow (2.0, - (double) precz - 14.0); */
eps = __gmpfr_ceil_exp2 (- (double) precz - 14.0);
m1 = 1.0 + MAX(1.0 / eps, 2.0 * sd) * (1.0 + eps);
c = (1.0 + eps) * (1.0 + eps * MAX(8.0, m1));
/* add = 1 + floor(log(c*c*c*(13 + m1))/log(2)); */
add = __gmpfr_ceil_log2 (c * c * c * (13.0 + m1));
prec1 = precz + add;
prec1 = MAX (prec1, precs1) + 10;
MPFR_GROUP_INIT_4 (group, prec1, z_pre, s1, y, p);
MPFR_ZIV_INIT (loop, prec1);
for (;;)
{
mpfr_sub (s1, __gmpfr_one, s, GMP_RNDN);/* s1 = 1-s */
mpfr_zeta_pos (z_pre, s1, GMP_RNDN); /* zeta(1-s) */
mpfr_gamma (y, s1, GMP_RNDN); /* gamma(1-s) */
if (MPFR_IS_INF (y)) /* Zeta(s) < 0 for -4k-2 < s < -4k,
Zeta(s) > 0 for -4k < s < -4k+2 */
{
MPFR_SET_INF (z_pre);
mpfr_div_2ui (s1, s, 2, GMP_RNDN); /* s/4, exact */
mpfr_frac (s1, s1, GMP_RNDN); /* exact, -1 < s1 < 0 */
if (mpfr_cmp_si_2exp (s1, -1, -1) > 0)
MPFR_SET_NEG (z_pre);
else
MPFR_SET_POS (z_pre);
break;
}
mpfr_mul (z_pre, z_pre, y, GMP_RNDN); /* gamma(1-s)*zeta(1-s) */
mpfr_const_pi (p, GMP_RNDD);
mpfr_mul (y, s, p, GMP_RNDN);
mpfr_div_2ui (y, y, 1, GMP_RNDN); /* s*Pi/2 */
mpfr_sin (y, y, GMP_RNDN); /* sin(Pi*s/2) */
mpfr_mul (z_pre, z_pre, y, GMP_RNDN);
mpfr_mul_2ui (y, p, 1, GMP_RNDN); /* 2*Pi */
mpfr_neg (s1, s1, GMP_RNDN); /* s-1 */
mpfr_pow (y, y, s1, GMP_RNDN); /* (2*Pi)^(s-1) */
mpfr_mul (z_pre, z_pre, y, GMP_RNDN);
mpfr_mul_2ui (z_pre, z_pre, 1, GMP_RNDN);
if (MPFR_LIKELY (MPFR_CAN_ROUND (z_pre, prec1 - add, precz,
rnd_mode)))
break;
MPFR_ZIV_NEXT (loop, prec1);
MPFR_GROUP_REPREC_4 (group, prec1, z_pre, s1, y, p);
}
MPFR_ZIV_FREE (loop);
inex = mpfr_set (z, z_pre, rnd_mode);
MPFR_GROUP_CLEAR (group);
}
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (z, inex, rnd_mode);
}
void bvisit(const Gamma &x) {
apply(result_, *(x.get_args()[0]));
mpfr_gamma(result_, result_, rnd_);
};
/*------------------------------------------------------------------------*/
int my_mpfr_beta (mpfr_t R, mpfr_t a, mpfr_t b, mpfr_rnd_t RND)
{
mpfr_prec_t p_a = mpfr_get_prec(a), p_b = mpfr_get_prec(b);
if(p_a < p_b) p_a = p_b;// p_a := max(p_a, p_b)
if(mpfr_get_prec(R) < p_a)
mpfr_prec_round(R, p_a, RND);// so prec(R) = max( prec(a), prec(b) )
int ans;
mpfr_t s; mpfr_init2(s, p_a);
#ifdef DEBUG_Rmpfr
R_CheckUserInterrupt();
int cc = 0;
#endif
/* "FIXME": check each 'ans' below, and return when not ok ... */
ans = mpfr_add(s, a, b, RND);
if(mpfr_integer_p(s) && mpfr_sgn(s) <= 0) { // (a + b) is integer <= 0
if(!mpfr_integer_p(a) && !mpfr_integer_p(b)) {
// but a,b not integer ==> R = finite / +-Inf = 0 :
mpfr_set_zero (R, +1);
mpfr_clear (s);
return ans;
}// else: sum is integer; at least one {a,b} integer ==> both integer
int sX = mpfr_sgn(a), sY = mpfr_sgn(b);
if(sX * sY < 0) { // one negative, one positive integer
// ==> special treatment here :
if(sY < 0) // ==> sX > 0; swap the two
mpfr_swap(a, b);
// now have --- a < 0 < b <= |a| integer ------------------
/* ================ and in this case:
B(a,b) = (-1)^b B(1-a-b, b) = (-1)^b B(1-s, b)
= (1*2*..*b) / (-s-1)*(-s-2)*...*(-s-b)
*/
/* where in the 2nd form, both numerator and denominator have exactly
* b integer factors. This is attractive {numerically & speed wise}
* for 'small' b */
#define b_large 100
#ifdef DEBUG_Rmpfr
Rprintf(" my_mpfr_beta(<neg int>): s = a+b= "); R_PRT(s);
Rprintf("\n a = "); R_PRT(a);
Rprintf("\n b = "); R_PRT(b); Rprintf("\n");
if(cc++ > 999) { mpfr_set_zero (R, +1); mpfr_clear (s); return ans; }
#endif
unsigned long b_ = 0;// -Wall
Rboolean
b_fits_ulong = mpfr_fits_ulong_p(b, RND),
small_b = b_fits_ulong && (b_ = mpfr_get_ui(b, RND)) < b_large;
if(small_b) {
#ifdef DEBUG_Rmpfr
Rprintf(" b <= b_large = %d...\n", b_large);
#endif
//----------------- small b ------------------
// use GMP big integer arithmetic:
mpz_t S; mpz_init(S); mpfr_get_z(S, s, RND); // S := s
mpz_sub_ui (S, S, (unsigned long) 1); // S = s - 1 = (a+b-1)
/* binomial coefficient choose(N, k) requires k a 'long int';
* here, b must fit into a long: */
mpz_bin_ui (S, S, b_); // S = choose(S, b) = choose(a+b-1, b)
mpz_mul_ui (S, S, b_); // S = S*b = b * choose(a+b-1, b)
// back to mpfr: R = 1 / S = 1 / (b * choose(a+b-1, b))
mpfr_set_ui(s, (unsigned long) 1, RND);
mpfr_div_z(R, s, S, RND);
mpz_clear(S);
}
else { // b is "large", use direct B(.,.) formula
#ifdef DEBUG_Rmpfr
Rprintf(" b > b_large = %d...\n", b_large);
#endif
// a := (-1)^b :
// there is no mpfr_si_pow(a, -1, b, RND);
int neg; // := 1 ("TRUE") if (-1)^b = -1, i.e. iff b is odd
if(b_fits_ulong) { // (i.e. not very large)
neg = (b_ % 2); // 1 iff b_ is odd, 0 otherwise
} else { // really large b; as we know it is integer, can still..
// b2 := b / 2
mpfr_t b2; mpfr_init2(b2, p_a);
mpfr_div_2ui(b2, b, 1, RND);
neg = !mpfr_integer_p(b2); // b is odd, if b/2 is *not* integer
#ifdef DEBUG_Rmpfr
Rprintf(" really large b; neg = ('b is odd') = %d\n", neg);
#endif
}
// s' := 1-s = 1-a-b
mpfr_ui_sub(s, 1, s, RND);
#ifdef DEBUG_Rmpfr
Rprintf(" neg = %d\n", neg);
Rprintf(" s' = 1-a-b = "); R_PRT(s);
Rprintf("\n -> calling B(s',b)\n");
#endif
// R := B(1-a-b, b) = B(s', b)
if(small_b) {
my_mpfr_beta (R, s, b, RND);
} else {
my_mpfr_lbeta (R, s, b, RND);
mpfr_exp(R, R, RND); // correct *if* beta() >= 0
}
#ifdef DEBUG_Rmpfr
Rprintf(" R' = beta(s',b) = "); R_PRT(R); Rprintf("\n");
#endif
// Result = (-1)^b B(1-a-b, b) = +/- s'
if(neg) mpfr_neg(R, R, RND);
}
mpfr_clear(s);
return ans;
}
}
ans = mpfr_gamma(s, s, RND); /* s = gamma(a + b) */
#ifdef DEBUG_Rmpfr
Rprintf("my_mpfr_beta(): s = gamma(a+b)= "); R_PRT(s);
Rprintf("\n a = "); R_PRT(a);
Rprintf("\n b = "); R_PRT(b);
#endif
ans = mpfr_gamma(a, a, RND);
ans = mpfr_gamma(b, b, RND);
ans = mpfr_mul(b, b, a, RND); /* b' = gamma(a) * gamma(b) */
#ifdef DEBUG_Rmpfr
Rprintf("\n G(a) * G(b) = "); R_PRT(b); Rprintf("\n");
#endif
ans = mpfr_div(R, b, s, RND);
mpfr_clear (s);
/* mpfr_free_cache() must be called in the caller !*/
return ans;
}
int
mpfr_zeta (mpfr_t z, mpfr_srcptr s, mpfr_rnd_t rnd_mode)
{
mpfr_t z_pre, s1, y, p;
long add;
mpfr_prec_t precz, prec1, precs, precs1;
int inex;
MPFR_GROUP_DECL (group);
MPFR_ZIV_DECL (loop);
MPFR_SAVE_EXPO_DECL (expo);
MPFR_LOG_FUNC (
("s[%Pu]=%.*Rg rnd=%d", mpfr_get_prec (s), mpfr_log_prec, s, rnd_mode),
("z[%Pu]=%.*Rg inexact=%d", mpfr_get_prec (z), mpfr_log_prec, z, inex));
/* Zero, Nan or Inf ? */
if (MPFR_UNLIKELY (MPFR_IS_SINGULAR (s)))
{
if (MPFR_IS_NAN (s))
{
MPFR_SET_NAN (z);
MPFR_RET_NAN;
}
else if (MPFR_IS_INF (s))
{
if (MPFR_IS_POS (s))
return mpfr_set_ui (z, 1, MPFR_RNDN); /* Zeta(+Inf) = 1 */
MPFR_SET_NAN (z); /* Zeta(-Inf) = NaN */
MPFR_RET_NAN;
}
else /* s iz zero */
{
MPFR_ASSERTD (MPFR_IS_ZERO (s));
return mpfr_set_si_2exp (z, -1, -1, rnd_mode);
}
}
/* s is neither Nan, nor Inf, nor Zero */
/* check tiny s: we have zeta(s) = -1/2 - 1/2 log(2 Pi) s + ... around s=0,
and for |s| <= 2^(-4), we have |zeta(s) + 1/2| <= |s|.
EXP(s) + 1 < -PREC(z) is a sufficient condition to be able to round
correctly, for any PREC(z) >= 1 (see algorithms.tex for details). */
if (MPFR_GET_EXP (s) + 1 < - (mpfr_exp_t) MPFR_PREC(z))
{
int signs = MPFR_SIGN(s);
MPFR_SAVE_EXPO_MARK (expo);
mpfr_set_si_2exp (z, -1, -1, rnd_mode); /* -1/2 */
if (rnd_mode == MPFR_RNDA)
rnd_mode = MPFR_RNDD; /* the result is around -1/2, thus negative */
if ((rnd_mode == MPFR_RNDU || rnd_mode == MPFR_RNDZ) && signs < 0)
{
mpfr_nextabove (z); /* z = -1/2 + epsilon */
inex = 1;
}
else if (rnd_mode == MPFR_RNDD && signs > 0)
{
mpfr_nextbelow (z); /* z = -1/2 - epsilon */
inex = -1;
}
else
{
if (rnd_mode == MPFR_RNDU) /* s > 0: z = -1/2 */
inex = 1;
else if (rnd_mode == MPFR_RNDD)
inex = -1; /* s < 0: z = -1/2 */
else /* (MPFR_RNDZ and s > 0) or MPFR_RNDN: z = -1/2 */
inex = (signs > 0) ? 1 : -1;
}
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (z, inex, rnd_mode);
}
/* Check for case s= -2n */
if (MPFR_IS_NEG (s))
{
mpfr_t tmp;
tmp[0] = *s;
MPFR_EXP (tmp) = MPFR_GET_EXP (s) - 1;
if (mpfr_integer_p (tmp))
{
MPFR_SET_ZERO (z);
MPFR_SET_POS (z);
MPFR_RET (0);
}
}
/* Check for case s=1 before changing the exponent range */
if (mpfr_cmp (s, __gmpfr_one) == 0)
{
MPFR_SET_INF (z);
MPFR_SET_POS (z);
MPFR_SET_DIVBY0 ();
MPFR_RET (0);
}
MPFR_SAVE_EXPO_MARK (expo);
/* Compute Zeta */
if (MPFR_IS_POS (s) && MPFR_GET_EXP (s) >= 0) /* Case s >= 1/2 */
inex = mpfr_zeta_pos (z, s, rnd_mode);
else /* use reflection formula
zeta(s) = 2^s*Pi^(s-1)*sin(Pi*s/2)*gamma(1-s)*zeta(1-s) */
{
int overflow = 0;
precz = MPFR_PREC (z);
precs = MPFR_PREC (s);
/* Precision precs1 needed to represent 1 - s, and s + 2,
without any truncation */
precs1 = precs + 2 + MAX (0, - MPFR_GET_EXP (s));
/* Precision prec1 is the precision on elementary computations;
it ensures a final precision prec1 - add for zeta(s) */
add = compute_add (s, precz);
prec1 = precz + add;
/* FIXME: To avoid that the working precision (prec1) depends on the
input precision, one would need to take into account the error made
when s1 is not exactly 1-s when computing zeta(s1) and gamma(s1)
below, and also in the case y=Inf (i.e. when gamma(s1) overflows).
Make sure that underflows do not occur in intermediate computations.
Due to the limited precision, they are probably not possible
in practice; add some MPFR_ASSERTN's to be sure that problems
do not remain undetected? */
prec1 = MAX (prec1, precs1) + 10;
MPFR_GROUP_INIT_4 (group, prec1, z_pre, s1, y, p);
MPFR_ZIV_INIT (loop, prec1);
for (;;)
{
mpfr_exp_t ey;
mpfr_t z_up;
mpfr_const_pi (p, MPFR_RNDD); /* p is Pi */
mpfr_sub (s1, __gmpfr_one, s, MPFR_RNDN); /* s1 = 1-s */
mpfr_gamma (y, s1, MPFR_RNDN); /* gamma(1-s) */
if (MPFR_IS_INF (y)) /* zeta(s) < 0 for -4k-2 < s < -4k,
zeta(s) > 0 for -4k < s < -4k+2 */
{
/* FIXME: An overflow in gamma(s1) does not imply that
zeta(s) will overflow. A solution:
1. Compute
log(|zeta(s)|/2) = (s-1)*log(2*pi) + lngamma(1-s)
+ log(abs(sin(Pi*s/2)) * zeta(1-s))
(possibly sharing computations with the normal case)
with a rather good accuracy (see (2)).
Memorize the sign of sin(...) for the final sign.
2. Take the exponential, ~= |zeta(s)|/2. If there is an
overflow, then this means an overflow on the final result
(due to the multiplication by 2, which has not been done
yet).
3. Ziv test.
4. Correct the sign from the sign of sin(...).
5. Round then multiply by 2. Here, an overflow in either
operation means a real overflow. */
mpfr_reflection_overflow (z_pre, s1, s, y, p, MPFR_RNDD);
/* z_pre is a lower bound of |zeta(s)|/2, thus if it overflows,
or has exponent emax, then |zeta(s)| overflows too. */
if (MPFR_IS_INF (z_pre) || MPFR_GET_EXP(z_pre) == __gmpfr_emax)
{ /* determine the sign of overflow */
mpfr_div_2ui (s1, s, 2, MPFR_RNDN); /* s/4, exact */
mpfr_frac (s1, s1, MPFR_RNDN); /* exact, -1 < s1 < 0 */
overflow = (mpfr_cmp_si_2exp (s1, -1, -1) > 0) ? -1 : 1;
break;
}
else /* EXP(z_pre) < __gmpfr_emax */
{
int ok = 0;
mpfr_t z_down;
mpfr_init2 (z_up, mpfr_get_prec (z_pre));
mpfr_reflection_overflow (z_up, s1, s, y, p, MPFR_RNDU);
/* if the lower approximation z_pre does not overflow, but
z_up does, we need more precision */
if (MPFR_IS_INF (z_up) || MPFR_GET_EXP(z_up) == __gmpfr_emax)
goto next_loop;
/* check if z_pre and z_up round to the same number */
mpfr_init2 (z_down, precz);
mpfr_set (z_down, z_pre, rnd_mode);
/* Note: it might be that EXP(z_down) = emax here, in that
case we will have overflow below when we multiply by 2 */
mpfr_prec_round (z_up, precz, rnd_mode);
ok = mpfr_cmp (z_down, z_up) == 0;
mpfr_clear (z_up);
mpfr_clear (z_down);
if (ok)
{
/* get correct sign and multiply by 2 */
mpfr_div_2ui (s1, s, 2, MPFR_RNDN); /* s/4, exact */
mpfr_frac (s1, s1, MPFR_RNDN); /* exact, -1 < s1 < 0 */
if (mpfr_cmp_si_2exp (s1, -1, -1) > 0)
mpfr_neg (z_pre, z_pre, rnd_mode);
mpfr_mul_2ui (z_pre, z_pre, 1, rnd_mode);
break;
}
else
goto next_loop;
}
}
mpfr_zeta_pos (z_pre, s1, MPFR_RNDN); /* zeta(1-s) */
mpfr_mul (z_pre, z_pre, y, MPFR_RNDN); /* gamma(1-s)*zeta(1-s) */
/* multiply z_pre by 2^s*Pi^(s-1) where p=Pi, s1=1-s */
mpfr_mul_2ui (y, p, 1, MPFR_RNDN); /* 2*Pi */
mpfr_neg (s1, s1, MPFR_RNDN); /* s-1 */
mpfr_pow (y, y, s1, MPFR_RNDN); /* (2*Pi)^(s-1) */
mpfr_mul (z_pre, z_pre, y, MPFR_RNDN);
mpfr_mul_2ui (z_pre, z_pre, 1, MPFR_RNDN);
/* multiply z_pre by sin(Pi*s/2) */
mpfr_mul (y, s, p, MPFR_RNDN);
mpfr_div_2ui (p, y, 1, MPFR_RNDN); /* p = s*Pi/2 */
/* FIXME: sinpi will be available, we should replace the mpfr_sin
call below by mpfr_sinpi(s/2), where s/2 will be exact.
Can mpfr_sin underflow? Moreover, the code below should be
improved so that the "if" condition becomes unlikely, e.g.
by taking a slightly larger working precision. */
mpfr_sin (y, p, MPFR_RNDN); /* y = sin(Pi*s/2) */
ey = MPFR_GET_EXP (y);
if (ey < 0) /* take account of cancellation in sin(p) */
{
mpfr_t t;
MPFR_ASSERTN (- ey < MPFR_PREC_MAX - prec1);
mpfr_init2 (t, prec1 - ey);
mpfr_const_pi (t, MPFR_RNDD);
mpfr_mul (t, s, t, MPFR_RNDN);
mpfr_div_2ui (t, t, 1, MPFR_RNDN);
mpfr_sin (y, t, MPFR_RNDN);
mpfr_clear (t);
}
mpfr_mul (z_pre, z_pre, y, MPFR_RNDN);
if (MPFR_LIKELY (MPFR_CAN_ROUND (z_pre, prec1 - add, precz,
rnd_mode)))
break;
next_loop:
MPFR_ZIV_NEXT (loop, prec1);
MPFR_GROUP_REPREC_4 (group, prec1, z_pre, s1, y, p);
}
MPFR_ZIV_FREE (loop);
if (overflow != 0)
{
inex = mpfr_overflow (z, rnd_mode, overflow);
MPFR_SAVE_EXPO_UPDATE_FLAGS (expo, MPFR_FLAGS_OVERFLOW);
}
else
inex = mpfr_set (z, z_pre, rnd_mode);
MPFR_GROUP_CLEAR (group);
}
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (z, inex, rnd_mode);
}