int my_mpfr_lbeta(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);
/* "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 = ln(finite / +-Inf) = ln(0) = -Inf :
mpfr_set_inf (R, -1);
mpfr_clear (s);
return ans;
}// else: sum is integer; at least one 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 ------------------
* ================
* --> see my_mpfr_beta() above */
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) {
//----------------- 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 = log(|1 / S|) = - log(|S|)
mpz_abs(S, S);
mpfr_set_z(s, S, RND); // <mpfr> s := |S|
mpfr_log(R, s, RND); // R := log(s) = log(|S|)
mpfr_neg(R, R, RND); // R = -R = -log(|S|)
mpz_clear(S);
}
else { // b is "large", use direct B(.,.) formula
// a := (-1)^b -- not needed here, neither 'neg': want log( |.| )
// s' := 1-s = 1-a-b
mpfr_ui_sub(s, 1, s, RND);
// R := log(|B(1-a-b, b)|) = log(|B(s', b)|)
my_mpfr_lbeta (R, s, b, RND);
}
mpfr_clear(s);
return ans;
}
}
ans = mpfr_lngamma(s, s, RND); // s = lngamma(a + b)
ans = mpfr_lngamma(a, a, RND);
ans = mpfr_lngamma(b, b, RND);
ans = mpfr_add (b, b, a, RND); // b' = lngamma(a) + lngamma(b)
ans = mpfr_sub (R, b, s, RND);
mpfr_clear (s);
return ans;
}
static void
special (void)
{
mpfr_t x, y;
int inex;
mpfr_init (x);
mpfr_init (y);
mpfr_set_nan (x);
mpfr_lngamma (y, x, MPFR_RNDN);
if (!mpfr_nan_p (y))
{
printf ("Error for lngamma(NaN)\n");
exit (1);
}
mpfr_set_inf (x, -1);
mpfr_lngamma (y, x, MPFR_RNDN);
if (!mpfr_nan_p (y))
{
printf ("Error for lngamma(-Inf)\n");
exit (1);
}
mpfr_set_inf (x, 1);
mpfr_lngamma (y, x, MPFR_RNDN);
if (!mpfr_inf_p (y) || mpfr_sgn (y) < 0)
{
printf ("Error for lngamma(+Inf)\n");
exit (1);
}
mpfr_set_ui (x, 0, MPFR_RNDN);
mpfr_lngamma (y, x, MPFR_RNDN);
if (!mpfr_inf_p (y) || mpfr_sgn (y) < 0)
{
printf ("Error for lngamma(+0)\n");
exit (1);
}
mpfr_set_ui (x, 0, MPFR_RNDN);
mpfr_neg (x, x, MPFR_RNDN);
mpfr_lngamma (y, x, MPFR_RNDN);
if (!mpfr_nan_p (y))
{
printf ("Error for lngamma(-0)\n");
exit (1);
}
mpfr_set_ui (x, 1, MPFR_RNDN);
mpfr_lngamma (y, x, MPFR_RNDN);
if (MPFR_IS_NAN (y) || mpfr_cmp_ui (y, 0) || MPFR_IS_NEG (y))
{
printf ("Error for lngamma(1)\n");
exit (1);
}
mpfr_set_si (x, -1, MPFR_RNDN);
mpfr_lngamma (y, x, MPFR_RNDN);
if (!mpfr_nan_p (y))
{
printf ("Error for lngamma(-1)\n");
exit (1);
}
mpfr_set_ui (x, 2, MPFR_RNDN);
mpfr_lngamma (y, x, MPFR_RNDN);
if (MPFR_IS_NAN (y) || mpfr_cmp_ui (y, 0) || MPFR_IS_NEG (y))
{
printf ("Error for lngamma(2)\n");
exit (1);
}
mpfr_set_prec (x, 53);
mpfr_set_prec (y, 53);
#define CHECK_X1 "1.0762904832837976166"
#define CHECK_Y1 "-0.039418362817587634939"
mpfr_set_str (x, CHECK_X1, 10, MPFR_RNDN);
mpfr_lngamma (y, x, MPFR_RNDN);
mpfr_set_str (x, CHECK_Y1, 10, MPFR_RNDN);
if (MPFR_IS_NAN (y) || 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 "0.049010669407893718563"
mpfr_set_str (x, CHECK_X2, 10, MPFR_RNDN);
mpfr_lngamma (y, x, MPFR_RNDN);
mpfr_set_str (x, CHECK_Y2, 10, MPFR_RNDN);
if (MPFR_IS_NAN (y) || 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, MPFR_RNDN);
mpfr_lngamma (y, x, MPFR_RNDU);
mpfr_set_prec (x, 175);
mpfr_set_str_binary (x, "0.1010001100011101101011001101110010100001000001000001110011000001101100001111001001000101011011100100010101011110100111110101010100010011010010000101010111001100011000101111E7");
if (MPFR_IS_NAN (y) || mpfr_cmp (x, y))
{
printf ("Error in mpfr_lngamma (1)\n");
exit (1);
}
mpfr_set_prec (x, 21);
mpfr_set_prec (y, 8);
mpfr_set_ui (y, 120, MPFR_RNDN);
mpfr_lngamma (x, y, MPFR_RNDZ);
mpfr_set_prec (y, 21);
mpfr_set_str_binary (y, "0.111000101000001100101E9");
if (MPFR_IS_NAN (x) || mpfr_cmp (x, y))
{
printf ("Error in mpfr_lngamma (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_lngamma (y, x, MPFR_RNDN);
mpfr_set_prec (x, 206);
mpfr_set_str_binary (x, "0.10000111011000000011100010101001100110001110000111100011000100100110110010001011011110101001111011110110000001010100111011010000000011100110110101100111000111010011110010000100010111101010001101000110101001E13");
if (MPFR_IS_NAN (y) || mpfr_cmp (x, y))
{
printf ("Error in mpfr_lngamma (768)\n");
exit (1);
}
if (inex >= 0)
{
printf ("Wrong flag for mpfr_lngamma (768)\n");
exit (1);
}
mpfr_set_prec (x, 4);
mpfr_set_prec (y, 4);
mpfr_set_str_binary (x, "0.1100E-66");
mpfr_lngamma (y, x, MPFR_RNDN);
mpfr_set_str_binary (x, "0.1100E6");
if (MPFR_IS_NAN (y) || mpfr_cmp (x, y))
{
printf ("Error for lngamma(0.1100E-66)\n");
exit (1);
}
mpfr_set_prec (x, 256);
mpfr_set_prec (y, 32);
mpfr_set_si_2exp (x, -1, 200, MPFR_RNDN);
mpfr_add_ui (x, x, 1, MPFR_RNDN);
mpfr_div_2ui (x, x, 1, MPFR_RNDN);
mpfr_lngamma (y, x, MPFR_RNDN);
mpfr_set_prec (x, 32);
mpfr_set_str_binary (x, "-0.10001000111011111011000010100010E207");
if (MPFR_IS_NAN (y) || mpfr_cmp (x, y))
{
printf ("Error for lngamma(-2^199+0.5)\n");
printf ("Got ");
mpfr_dump (y);
printf ("instead of ");
mpfr_dump (x);
exit (1);
}
mpfr_set_prec (x, 256);
mpfr_set_prec (y, 32);
mpfr_set_si_2exp (x, -1, 200, MPFR_RNDN);
mpfr_sub_ui (x, x, 1, MPFR_RNDN);
mpfr_div_2ui (x, x, 1, MPFR_RNDN);
mpfr_lngamma (y, x, MPFR_RNDN);
if (!mpfr_nan_p (y))
{
printf ("Error for lngamma(-2^199-0.5)\n");
exit (1);
}
mpfr_clear (x);
mpfr_clear (y);
}
/* return in z a lower bound (for rnd = RNDD) or upper bound (for rnd = RNDU)
of |zeta(s)|/2, using:
log(|zeta(s)|/2) = (s-1)*log(2*Pi) + lngamma(1-s)
+ log(|sin(Pi*s/2)| * zeta(1-s)).
Assumes s < 1/2 and s1 = 1-s exactly, thus s1 > 1/2.
y and p are temporary variables.
At input, p is Pi rounded down.
The comments in the code are for rnd = RNDD. */
static void
mpfr_reflection_overflow (mpfr_t z, mpfr_t s1, const mpfr_t s, mpfr_t y,
mpfr_t p, mpfr_rnd_t rnd)
{
mpz_t sint;
MPFR_ASSERTD (rnd == MPFR_RNDD || rnd == MPFR_RNDU);
/* Since log is increasing, we want lower bounds on |sin(Pi*s/2)| and
zeta(1-s). */
mpz_init (sint);
mpfr_get_z (sint, s, MPFR_RNDD); /* sint = floor(s) */
/* We first compute a lower bound of |sin(Pi*s/2)|, which is a periodic
function of period 2. Thus:
if 2k < s < 2k+1, then |sin(Pi*s/2)| is increasing;
if 2k-1 < s < 2k, then |sin(Pi*s/2)| is decreasing.
These cases are distinguished by testing bit 0 of floor(s) as if
represented in two's complement (or equivalently, as an unsigned
integer mod 2):
0: sint = 0 mod 2, thus 2k < s < 2k+1 and |sin(Pi*s/2)| is increasing;
1: sint = 1 mod 2, thus 2k-1 < s < 2k and |sin(Pi*s/2)| is decreasing.
Let's recall that the comments are for rnd = RNDD. */
if (mpz_tstbit (sint, 0) == 0) /* |sin(Pi*s/2)| is increasing: round down
Pi*s to get a lower bound. */
{
mpfr_mul (y, p, s, rnd);
if (rnd == MPFR_RNDD)
mpfr_nextabove (p); /* we will need p rounded above afterwards */
}
else /* |sin(Pi*s/2)| is decreasing: round up Pi*s to get a lower bound. */
{
if (rnd == MPFR_RNDD)
mpfr_nextabove (p);
mpfr_mul (y, p, s, MPFR_INVERT_RND(rnd));
}
mpfr_div_2ui (y, y, 1, MPFR_RNDN); /* exact, rounding mode doesn't matter */
/* The rounding direction of sin depends on its sign. We have:
if -4k-2 < s < -4k, then -2k-1 < s/2 < -2k, thus sin(Pi*s/2) < 0;
if -4k < s < -4k+2, then -2k < s/2 < -2k+1, thus sin(Pi*s/2) > 0.
These cases are distinguished by testing bit 1 of floor(s) as if
represented in two's complement (or equivalently, as an unsigned
integer mod 4):
0: sint = {0,1} mod 4, thus -2k < s/2 < -2k+1 and sin(Pi*s/2) > 0;
1: sint = {2,3} mod 4, thus -2k-1 < s/2 < -2k and sin(Pi*s/2) < 0.
Let's recall that the comments are for rnd = RNDD. */
if (mpz_tstbit (sint, 1) == 0) /* -2k < s/2 < -2k+1; sin(Pi*s/2) > 0 */
{
/* Round sin down to get a lower bound of |sin(Pi*s/2)|. */
mpfr_sin (y, y, rnd);
}
else /* -2k-1 < s/2 < -2k; sin(Pi*s/2) < 0 */
{
/* Round sin up to get a lower bound of |sin(Pi*s/2)|. */
mpfr_sin (y, y, MPFR_INVERT_RND(rnd));
mpfr_abs (y, y, MPFR_RNDN); /* exact, rounding mode doesn't matter */
}
mpz_clear (sint);
/* now y <= |sin(Pi*s/2)| when rnd=RNDD, y >= |sin(Pi*s/2)| when rnd=RNDU */
mpfr_zeta_pos (z, s1, rnd); /* zeta(1-s) */
mpfr_mul (z, z, y, rnd);
/* now z <= |sin(Pi*s/2)|*zeta(1-s) */
mpfr_log (z, z, rnd);
/* now z <= log(|sin(Pi*s/2)|*zeta(1-s)) */
mpfr_lngamma (y, s1, rnd);
mpfr_add (z, z, y, rnd);
/* z <= lngamma(1-s) + log(|sin(Pi*s/2)|*zeta(1-s)) */
/* since s-1 < 0, we want to round log(2*pi) upwards */
mpfr_mul_2ui (y, p, 1, MPFR_INVERT_RND(rnd));
mpfr_log (y, y, MPFR_INVERT_RND(rnd));
mpfr_mul (y, y, s1, MPFR_INVERT_RND(rnd));
mpfr_sub (z, z, y, rnd);
mpfr_exp (z, z, rnd);
if (rnd == MPFR_RNDD)
mpfr_nextbelow (p); /* restore original p */
}
