real factorial(const real & a)
{
real x;
mpfr_fac_ui(x.r, mpfr_get_ui(a.r, MPFR_RNDZ), MPFR_RNDN);
return x;
}
static PyObject *
GMPy_Context_Factorial(PyObject *self, PyObject *other)
{
MPFR_Object *result;
long n;
CTXT_Object *context = NULL;
if (self && CTXT_Check(self)) {
context = (CTXT_Object*)self;
}
else {
CHECK_CONTEXT(context);
}
n = PyLong_AsLong(other);
if ((n == -1) && PyErr_Occurred()) {
TYPE_ERROR("factorial() requires 'int' argument");
return NULL;
}
if (n < 0) {
VALUE_ERROR("factorial() of negative number");
return NULL;
}
if (!(result = GMPy_MPFR_New(0, context))) {
return NULL;
}
mpfr_clear_flags();
mpfr_fac_ui(result->f, n, GET_MPFR_ROUND(context));
_GMPy_MPFR_Cleanup(&result, context);
return (PyObject*)result;
}
SEXP R_mpfr_fac (SEXP n_, SEXP prec, SEXP rnd_mode)
{
int n = length(n_), i, *nn;
SEXP n_t, val = PROTECT(allocVector(VECSXP, n)); int nprot = 1;
mpfr_rnd_t rnd = R_rnd2MP(rnd_mode);
mpfr_t r_i;
if(TYPEOF(n_) != INTSXP) {
PROTECT(n_t = coerceVector(n_, INTSXP)); nprot++;/* or bail out*/
nn = INTEGER(n_t);
} else {
nn = INTEGER(n_);
}
int i_p = asInteger(prec);
R_mpfr_check_prec(i_p);
mpfr_init2(r_i, i_p);
for(i=0; i < n; i++) {
// never happens when called from R:
if(nn[i] < 0) error("R_mpfr_fac(%d): negative n.", nn[i]);
mpfr_fac_ui(r_i, nn[i], rnd);
SET_VECTOR_ELT(val, i, MPFR_as_R(r_i));
}
mpfr_clear(r_i);
mpfr_free_cache();
UNPROTECT(nprot);
return val;
}
static void
special (void)
{
mpfr_t x, y;
int inex;
mpfr_init (x);
mpfr_init (y);
mpfr_set_prec (x, 21);
mpfr_set_prec (y, 21);
mpfr_fac_ui (x, 119, GMP_RNDZ);
mpfr_set_str_binary (y, "0.101111101110100110110E654");
if (mpfr_cmp (x, y))
{
printf ("Error in mpfr_fac_ui (119)\n");
exit (1);
}
mpfr_set_prec (y, 206);
inex = mpfr_fac_ui (y, 767, GMP_RNDN);
mpfr_set_prec (x, 206);
mpfr_set_str_binary (x, "0.110111100001000001101010010001000111000100000100111000010011100011011111001100011110101000111101101100110001001100110100001001111110000101010000100100011100010011101110000001000010001100010000101001111E6250");
if (mpfr_cmp (x, y))
{
printf ("Error in mpfr_fac_ui (767)\n");
exit (1);
}
if (inex <= 0)
{
printf ("Wrong flag for mpfr_fac_ui (767)\n");
exit (1);
}
mpfr_set_prec (y, 202);
mpfr_fac_ui (y, 69, GMP_RNDU);
mpfr_clear (x);
mpfr_clear (y);
}
static void
test_int (void)
{
unsigned long n0 = 1, n1 = 80, n;
mpz_t f;
mpfr_t x, y;
mp_prec_t prec_f, p;
int r;
int inex1, inex2;
mpz_init (f);
mpfr_init (x);
mpfr_init (y);
mpz_fac_ui (f, n0 - 1);
for (n = n0; n <= n1; n++)
{
mpz_mul_ui (f, f, n); /* f = n! */
prec_f = mpz_sizeinbase (f, 2) - mpz_scan1 (f, 0);
for (p = MPFR_PREC_MIN; p <= prec_f; p++)
{
mpfr_set_prec (x, p);
mpfr_set_prec (y, p);
for (r = 0; r < GMP_RND_MAX; r++)
{
inex1 = mpfr_fac_ui (x, n, (mp_rnd_t) r);
inex2 = mpfr_set_z (y, f, (mp_rnd_t) r);
if (mpfr_cmp (x, y))
{
printf ("Error for n=%lu prec=%lu rnd=%s\n",
n, (unsigned long) p, mpfr_print_rnd_mode ((mp_rnd_t) r));
exit (1);
}
if ((inex1 < 0 && inex2 >= 0) || (inex1 == 0 && inex2 != 0)
|| (inex1 > 0 && inex2 <= 0))
{
printf ("Wrong inexact flag for n=%lu prec=%lu rnd=%s\n",
n, (unsigned long) p, mpfr_print_rnd_mode ((mp_rnd_t) r));
exit (1);
}
}
}
}
mpz_clear (f);
mpfr_clear (x);
mpfr_clear (y);
}
/* 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);
}
int
main (int argc, char *argv[])
{
unsigned int prec, err, yprec, n, k, zeros;
int rnd;
mpfr_t x, y, z, t;
int inexact;
tests_start_mpfr ();
special ();
test_int ();
mpfr_init (x);
mpfr_init (y);
mpfr_init (z);
mpfr_init (t);
mpfr_fac_ui (y, 0, GMP_RNDN);
if (mpfr_cmp_ui (y, 1))
{
printf ("mpfr_fac_ui(0) does not give 1\n");
exit (1);
}
for (prec = 2; prec <= 100; prec++)
{
mpfr_set_prec (x, prec);
mpfr_set_prec (z, prec);
mpfr_set_prec (t, prec);
yprec = prec + 10;
mpfr_set_prec (y, yprec);
for (n = 0; n < 50; n++)
for (rnd = 0; rnd < GMP_RND_MAX; rnd++)
{
inexact = mpfr_fac_ui (y, n, (mp_rnd_t) rnd);
err = (rnd == GMP_RNDN) ? yprec + 1 : yprec;
if (mpfr_can_round (y, err, (mp_rnd_t) rnd, (mp_rnd_t) rnd, prec))
{
mpfr_set (t, y, (mp_rnd_t) rnd);
inexact = mpfr_fac_ui (z, n, (mp_rnd_t) rnd);
/* fact(n) ends with floor(n/2)+floor(n/4)+... zeros */
for (k=n/2, zeros=0; k; k >>= 1)
zeros += k;
if (MPFR_EXP(y) <= (mp_exp_t) (prec + zeros))
/* result should be exact */
{
if (inexact)
{
printf ("Wrong inexact flag: expected exact\n");
exit (1);
}
}
else /* result is inexact */
{
if (!inexact)
{
printf ("Wrong inexact flag: expected inexact\n");
printf ("n=%u prec=%u\n", n, prec);
mpfr_print_binary(z); puts ("");
exit (1);
}
}
if (mpfr_cmp (t, z))
{
printf ("results differ for x=");
mpfr_out_str (stdout, 2, prec, x, GMP_RNDN);
printf (" prec=%u rnd_mode=%s\n", prec,
mpfr_print_rnd_mode ((mp_rnd_t) rnd));
printf (" got ");
mpfr_out_str (stdout, 2, prec, z, GMP_RNDN);
puts ("");
printf (" expected ");
mpfr_out_str (stdout, 2, prec, t, GMP_RNDN);
puts ("");
printf (" approximation was ");
mpfr_print_binary (y);
puts ("");
exit (1);
}
}
}
}
static void
overflowed_fac0 (void)
{
mpfr_t x, y;
int inex, rnd, err = 0;
mp_exp_t old_emax;
old_emax = mpfr_get_emax ();
mpfr_init2 (x, 8);
mpfr_init2 (y, 8);
mpfr_set_ui (y, 1, GMP_RNDN);
mpfr_nextbelow (y);
set_emax (0); /* 1 is not representable. */
RND_LOOP (rnd)
{
mpfr_clear_flags ();
inex = mpfr_fac_ui (x, 0, rnd);
if (! mpfr_overflow_p ())
{
printf ("Error in overflowed_fac0 (rnd = %s):\n"
" The overflow flag is not set.\n",
mpfr_print_rnd_mode (rnd));
err = 1;
}
if (rnd == GMP_RNDZ || rnd == GMP_RNDD)
{
if (inex >= 0)
{
printf ("Error in overflowed_fac0 (rnd = %s):\n"
" The inexact value must be negative.\n",
mpfr_print_rnd_mode (rnd));
err = 1;
}
if (! mpfr_equal_p (x, y))
{
printf ("Error in overflowed_fac0 (rnd = %s):\n"
" Got ", mpfr_print_rnd_mode (rnd));
mpfr_print_binary (x);
printf (" instead of 0.11111111E0.\n");
err = 1;
}
}
else
{
if (inex <= 0)
{
printf ("Error in overflowed_fac0 (rnd = %s):\n"
" The inexact value must be positive.\n",
mpfr_print_rnd_mode (rnd));
err = 1;
}
if (! (mpfr_inf_p (x) && MPFR_SIGN (x) > 0))
{
printf ("Error in overflowed_fac0 (rnd = %s):\n"
" Got ", mpfr_print_rnd_mode (rnd));
mpfr_print_binary (x);
printf (" instead of +Inf.\n");
err = 1;
}
}
}
set_emax (old_emax);
if (err)
exit (1);
mpfr_clear (x);
mpfr_clear (y);
}
void func_factorial(fp_t* v, fp_t f) {
mpfr_fac_ui(*v, fp_t_to_long(f), MPFR_RNDN);
}
/* compute in s an approximation of
S3 = c*sum((h(k)+h(n+k))*y^k/k!/(n+k)!,k=0..infinity)
where h(k) = 1 + 1/2 + ... + 1/k
k=0: h(n)
k=1: 1+h(n+1)
k=2: 3/2+h(n+2)
Returns e such that the error is bounded by 2^e ulp(s).
*/
static mpfr_exp_t
mpfr_yn_s3 (mpfr_ptr s, mpfr_srcptr y, mpfr_srcptr c, unsigned long n)
{
unsigned long k, zz;
mpfr_t t, u;
mpz_t p, q; /* p/q will store h(k)+h(n+k) */
mpfr_exp_t exps, expU;
zz = mpfr_get_ui (y, MPFR_RNDU); /* y = z^2/4 */
MPFR_ASSERTN (zz < ULONG_MAX - 2);
zz += 2; /* z^2 <= 2^zz */
mpz_init_set_ui (p, 0);
mpz_init_set_ui (q, 1);
/* initialize p/q to h(n) */
for (k = 1; k <= n; k++)
{
/* p/q + 1/k = (k*p+q)/(q*k) */
mpz_mul_ui (p, p, k);
mpz_add (p, p, q);
mpz_mul_ui (q, q, k);
}
mpfr_init2 (t, MPFR_PREC(s));
mpfr_init2 (u, MPFR_PREC(s));
mpfr_fac_ui (t, n, MPFR_RNDN);
mpfr_div (t, c, t, MPFR_RNDN); /* c/n! */
mpfr_mul_z (u, t, p, MPFR_RNDN);
mpfr_div_z (s, u, q, MPFR_RNDN);
exps = MPFR_EXP (s);
expU = exps;
for (k = 1; ;k ++)
{
/* update t */
mpfr_mul (t, t, y, MPFR_RNDN);
mpfr_div_ui (t, t, k, MPFR_RNDN);
mpfr_div_ui (t, t, n + k, MPFR_RNDN);
/* update p/q:
p/q + 1/k + 1/(n+k) = [p*k*(n+k) + q*(n+k) + q*k]/(q*k*(n+k)) */
mpz_mul_ui (p, p, k);
mpz_mul_ui (p, p, n + k);
mpz_addmul_ui (p, q, n + 2 * k);
mpz_mul_ui (q, q, k);
mpz_mul_ui (q, q, n + k);
mpfr_mul_z (u, t, p, MPFR_RNDN);
mpfr_div_z (u, u, q, MPFR_RNDN);
exps = MPFR_EXP (u);
if (exps > expU)
expU = exps;
mpfr_add (s, s, u, MPFR_RNDN);
exps = MPFR_EXP (s);
if (exps > expU)
expU = exps;
if (MPFR_EXP (u) + (mpfr_exp_t) MPFR_PREC (u) < MPFR_EXP (s) &&
zz / (2 * k) < k + n)
break;
}
mpfr_clear (t);
mpfr_clear (u);
mpz_clear (p);
mpz_clear (q);
exps = expU - MPFR_EXP (s);
/* the error is bounded by (6k^2+33/2k+11) 2^exps ulps
<= 8*(k+2)^2 2^exps ulps */
return 3 + 2 * MPFR_INT_CEIL_LOG2(k + 2) + exps;
}
