SeedValue seed_mpfr_frac (SeedContext ctx,
SeedObject function,
SeedObject this_object,
gsize argument_count,
const SeedValue args[],
SeedException *exception)
{
mpfr_rnd_t rnd;
mpfr_ptr rop, op;
gint ret;
CHECK_ARG_COUNT("mpfr.frac", 2);
rop = seed_object_get_private(this_object);
rnd = seed_value_to_mpfr_rnd_t(ctx, args[1], exception);
if ( seed_value_is_object_of_class(ctx, args[0], mpfr_class) )
{
op = seed_object_get_private(args[0]);
}
else
{
TYPE_EXCEPTION("mpfr.frac", "mpfr_t");
}
ret = mpfr_frac(rop, op, rnd);
return seed_value_from_int(ctx, ret, exception);
}
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);
}
/* Set iop to the integral part of op and fop to its fractional part */
int
mpfr_modf (mpfr_ptr iop, mpfr_ptr fop, mpfr_srcptr op, mpfr_rnd_t rnd_mode)
{
mpfr_exp_t ope;
mpfr_prec_t opq;
int inexi, inexf;
MPFR_LOG_FUNC
(("op[%Pu]=%.*Rg rnd=%d",
mpfr_get_prec (op), mpfr_log_prec, op, rnd_mode),
("iop[%Pu]=%.*Rg fop[%Pu]=%.*Rg",
mpfr_get_prec (iop), mpfr_log_prec, iop,
mpfr_get_prec (fop), mpfr_log_prec, fop));
MPFR_ASSERTN (iop != fop);
if ( MPFR_UNLIKELY (MPFR_IS_SINGULAR (op)) )
{
if (MPFR_IS_NAN (op))
{
MPFR_SET_NAN (iop);
MPFR_SET_NAN (fop);
MPFR_RET_NAN;
}
MPFR_SET_SAME_SIGN (iop, op);
MPFR_SET_SAME_SIGN (fop, op);
if (MPFR_IS_INF (op))
{
MPFR_SET_INF (iop);
MPFR_SET_ZERO (fop);
MPFR_RET (0);
}
else /* op is zero */
{
MPFR_ASSERTD (MPFR_IS_ZERO (op));
MPFR_SET_ZERO (iop);
MPFR_SET_ZERO (fop);
MPFR_RET (0);
}
}
ope = MPFR_GET_EXP (op);
opq = MPFR_PREC (op);
if (ope <= 0) /* 0 < |op| < 1 */
{
inexf = (fop != op) ? mpfr_set (fop, op, rnd_mode) : 0;
MPFR_SET_SAME_SIGN (iop, op);
MPFR_SET_ZERO (iop);
MPFR_RET (INEX(0, inexf));
}
else if (ope >= opq) /* op has no fractional part */
{
inexi = (iop != op) ? mpfr_set (iop, op, rnd_mode) : 0;
MPFR_SET_SAME_SIGN (fop, op);
MPFR_SET_ZERO (fop);
MPFR_RET (INEX(inexi, 0));
}
else /* op has both integral and fractional parts */
{
if (iop != op)
{
inexi = mpfr_rint_trunc (iop, op, rnd_mode);
inexf = mpfr_frac (fop, op, rnd_mode);
}
else
{
MPFR_ASSERTN (fop != op);
inexf = mpfr_frac (fop, op, rnd_mode);
inexi = mpfr_rint_trunc (iop, op, rnd_mode);
}
MPFR_RET (INEX(inexi, inexf));
}
}
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);
}
