static void
round_str (FILE *fout, const char *s, int prec, int emin, int emax,
bool ibm_ld)
{
mpfr_t f;
mpfr_set_default_prec (prec);
mpfr_set_emin (emin);
mpfr_set_emax (emax);
mpfr_init (f);
int r = string_to_fp (f, s, MPFR_RNDD);
if (ibm_ld)
{
assert (prec == 106 && emin == -1073 && emax == 1024);
/* The maximum value in IBM long double has discontiguous
mantissa bits. */
mpfr_t max_value;
mpfr_init2 (max_value, 107);
mpfr_set_str (max_value, "0x1.fffffffffffff7ffffffffffffcp+1023", 0,
MPFR_RNDN);
if (mpfr_cmpabs (f, max_value) > 0)
r = 1;
mpfr_clear (max_value);
}
mpfr_fprintf (fout, "\t%s,\n", r ? "false" : "true");
print_fp (fout, f, ",\n");
string_to_fp (f, s, MPFR_RNDN);
print_fp (fout, f, ",\n");
string_to_fp (f, s, MPFR_RNDZ);
print_fp (fout, f, ",\n");
string_to_fp (f, s, MPFR_RNDU);
print_fp (fout, f, "");
mpfr_clear (f);
}
SeedValue seed_mpfr_cmpabs (SeedContext ctx,
SeedObject function,
SeedObject this_object,
gsize argument_count,
const SeedValue args[],
SeedException *exception)
{
mpfr_ptr rop, op;
gint ret;
CHECK_ARG_COUNT("mpfr.cmpabs", 1);
rop = seed_object_get_private(this_object);
if ( seed_value_is_object_of_class(ctx, args[0], mpfr_class) )
{
op = seed_object_get_private(args[0]);
}
else
{
TYPE_EXCEPTION("mpfr.cmpabs", "mpfr_t");
}
ret = mpfr_cmpabs(rop, op);
return seed_value_from_int(ctx, ret, exception);
}
int
mpfi_abs (mpfi_ptr a, mpfi_srcptr b)
{
/* the result a contains the absolute values of every element of b */
int inexact_right, inexact = 0;
if (MPFI_NAN_P (b)) {
mpfr_set_nan (&(a->left));
mpfr_set_nan (&(a->right));
MPFR_RET_NAN;
}
if (MPFI_IS_NONNEG (b))
inexact = mpfi_set (a, b);
else if (MPFI_IS_NONPOS (b))
inexact = mpfi_neg (a, b);
else { /* b contains 0 */
if (mpfr_cmpabs (&(b->left), &(b->right)) < 0) {
inexact_right = mpfr_set (&(a->right), &(b->right), MPFI_RNDU);
}
else {
inexact_right = mpfr_neg (&(a->right), &(b->left), MPFI_RNDU);
}
mpfr_set_si (&(a->left), 0, MPFI_RNDD);
if (inexact_right)
inexact += 2;
}
return inexact;
}
void increase_norm(gmp_RR& norm, const ElementType& a) const
{
if (mpfr_cmpabs(&a, norm) > 0)
{
set(*norm, a);
abs(*norm,*norm);
}
}
/* if u = o(x-y), v = o(u-x), w = o(v+y), then x-y = u-w */
static void
check_two_sum (mpfr_prec_t p)
{
mpfr_t x, y, u, v, w;
mpfr_rnd_t rnd;
int inexact;
mpfr_init2 (x, p);
mpfr_init2 (y, p);
mpfr_init2 (u, p);
mpfr_init2 (v, p);
mpfr_init2 (w, p);
mpfr_urandomb (x, RANDS);
mpfr_urandomb (y, RANDS);
if (mpfr_cmpabs (x, y) < 0)
mpfr_swap (x, y);
rnd = MPFR_RNDN;
inexact = test_sub (u, x, y, rnd);
test_sub (v, u, x, rnd);
mpfr_add (w, v, y, rnd);
/* as u = (x-y) - w, we should have inexact and w of opposite signs */
if (((inexact == 0) && mpfr_cmp_ui (w, 0)) ||
((inexact > 0) && (mpfr_cmp_ui (w, 0) <= 0)) ||
((inexact < 0) && (mpfr_cmp_ui (w, 0) >= 0)))
{
printf ("Wrong inexact flag for prec=%u, rnd=%s\n", (unsigned)p,
mpfr_print_rnd_mode (rnd));
printf ("x=");
mpfr_print_binary(x);
puts ("");
printf ("y=");
mpfr_print_binary(y);
puts ("");
printf ("u=");
mpfr_print_binary(u);
puts ("");
printf ("v=");
mpfr_print_binary(v);
puts ("");
printf ("w=");
mpfr_print_binary(w);
puts ("");
printf ("inexact = %d\n", inexact);
exit (1);
}
mpfr_clear (x);
mpfr_clear (y);
mpfr_clear (u);
mpfr_clear (v);
mpfr_clear (w);
}
bool almostEqual(const M2::ARingRRR& R, int nbits, const M2::ARingRRR::ElementType& a, const M2::ARingRRR::ElementType& b)
{
mpfr_t epsilon;
mpfr_init2(epsilon, R.get_precision());
mpfr_set_ui_2exp(epsilon, 1, -nbits, GMP_RNDN);
M2::ARingRRR::ElementType c;
R.init(c);
R.subtract(c,a,b);
bool ret = mpfr_cmpabs(&c,epsilon) < 0;
R.clear(c);
mpfr_clear(epsilon);
return ret;
}
int mpfr_mat_R_reduced(__mpfr_struct ** R, long d, double delta, double eta, mp_prec_t prec)
{
if (d == 1)
return 1;
mpfr_t tmp1;
mpfr_t tmp2;
mpfr_init2(tmp1, prec);
mpfr_init2(tmp2, prec);
int reduced = 1;
long i;
for (i = 0; (i < d - 1) && (reduced == 1); i++)
{
mpfr_pow_ui(tmp1, R[i+1] + i, 2L, GMP_RNDN);
mpfr_pow_ui(tmp2, R[i+1] + i + 1, 2L, GMP_RNDN);
mpfr_add(tmp1, tmp1, tmp2, GMP_RNDN);
mpfr_pow_ui(tmp2, R[i] + i, 2L, GMP_RNDN);
mpfr_mul_d(tmp2, tmp2, (double) delta, GMP_RNDN);
mpfr_sub(tmp1, tmp1, tmp2, GMP_RNDN);
// mpfr_add_d(tmp1, tmp1, .001, GMP_RNDN);
if (mpfr_sgn(tmp1) < 0)
{
reduced = 0;
printf(" happened at index i = %ld\n", i);
break;
}
long j;
for (j = 0; (j < i) && (reduced == 1); j++)
{
mpfr_mul_d(tmp2, R[i + 1] + i + 1, (double) eta, GMP_RNDN);
if (mpfr_cmpabs(R[j] + i, tmp2) > 0)
{
reduced = 0;
printf(" size red problem at index i = %ld, j = %ld\n", i, j);
break;
}
}
}
mpfr_clear(tmp1);
mpfr_clear(tmp2);
return reduced;
}
/*
Parameters:
s - the input floating-point number
n, p - parameters from the algorithm
tc - an array of p floating-point numbers tc[1]..tc[p]
Output:
b is the result, i.e.
sum(tc[i]*product((s+2j)*(s+2j-1)/n^2,j=1..i-1), i=1..p)*s*n^(-s-1)
*/
static void
mpfr_zeta_part_b (mpfr_t b, mpfr_srcptr s, int n, int p, mpfr_t *tc)
{
mpfr_t s1, d, u;
unsigned long n2;
int l, t;
MPFR_GROUP_DECL (group);
if (p == 0)
{
MPFR_SET_ZERO (b);
MPFR_SET_POS (b);
return;
}
n2 = n * n;
MPFR_GROUP_INIT_3 (group, MPFR_PREC (b), s1, d, u);
/* t equals 2p-2, 2p-3, ... ; s1 equals s+t */
t = 2 * p - 2;
mpfr_set (d, tc[p], GMP_RNDN);
for (l = 1; l < p; l++)
{
mpfr_add_ui (s1, s, t, GMP_RNDN); /* s + (2p-2l) */
mpfr_mul (d, d, s1, GMP_RNDN);
t = t - 1;
mpfr_add_ui (s1, s, t, GMP_RNDN); /* s + (2p-2l-1) */
mpfr_mul (d, d, s1, GMP_RNDN);
t = t - 1;
mpfr_div_ui (d, d, n2, GMP_RNDN);
mpfr_add (d, d, tc[p-l], GMP_RNDN);
/* since s is positive and the tc[i] have alternate signs,
the following is unlikely */
if (MPFR_UNLIKELY (mpfr_cmpabs (d, tc[p-l]) > 0))
mpfr_set (d, tc[p-l], GMP_RNDN);
}
mpfr_mul (d, d, s, GMP_RNDN);
mpfr_add (s1, s, __gmpfr_one, GMP_RNDN);
mpfr_neg (s1, s1, GMP_RNDN);
mpfr_ui_pow (u, n, s1, GMP_RNDN);
mpfr_mul (b, d, u, GMP_RNDN);
MPFR_GROUP_CLEAR (group);
}
static void
special (void)
{
mpfr_t x, y, res;
int inexact;
mpfr_init (x);
mpfr_init (y);
mpfr_init (res);
mpfr_set_prec (x, 24);
mpfr_set_prec (y, 24);
mpfr_set_str_binary (y, "0.111100110001011010111");
inexact = mpfr_ui_sub (x, 1, y, GMP_RNDN);
if (inexact)
{
printf ("Wrong inexact flag: got %d, expected 0\n", inexact);
exit (1);
}
mpfr_set_prec (x, 24);
mpfr_set_prec (y, 24);
mpfr_set_str_binary (y, "0.111100110001011010111");
if ((inexact = mpfr_ui_sub (x, 38181761, y, GMP_RNDN)) >= 0)
{
printf ("Wrong inexact flag: got %d, expected -1\n", inexact);
exit (1);
}
mpfr_set_prec (x, 63);
mpfr_set_prec (y, 63);
mpfr_set_str_binary (y, "0.111110010010100100110101101010001001100101110001000101110111111E-1");
if ((inexact = mpfr_ui_sub (x, 1541116494, y, GMP_RNDN)) <= 0)
{
printf ("Wrong inexact flag: got %d, expected +1\n", inexact);
exit (1);
}
mpfr_set_prec (x, 32);
mpfr_set_prec (y, 32);
mpfr_set_str_binary (y, "0.11011000110111010001011100011100E-1");
if ((inexact = mpfr_ui_sub (x, 2000375416, y, GMP_RNDN)) >= 0)
{
printf ("Wrong inexact flag: got %d, expected -1\n", inexact);
exit (1);
}
mpfr_set_prec (x, 24);
mpfr_set_prec (y, 24);
mpfr_set_str_binary (y, "0.110011011001010011110111E-2");
if ((inexact = mpfr_ui_sub (x, 927694848, y, GMP_RNDN)) <= 0)
{
printf ("Wrong inexact flag: got %d, expected +1\n", inexact);
exit (1);
}
/* bug found by Mathieu Dutour, 12 Apr 2001 */
mpfr_set_prec (x, 5);
mpfr_set_prec (y, 5);
mpfr_set_prec (res, 5);
mpfr_set_str_binary (x, "1e-12");
mpfr_ui_sub (y, 1, x, GMP_RNDD);
mpfr_set_str_binary (res, "0.11111");
if (mpfr_cmp (y, res))
{
printf ("Error in mpfr_ui_sub (y, 1, x, GMP_RNDD) for x=2^(-12)\nexpected 1.1111e-1, got ");
mpfr_out_str (stdout, 2, 0, y, GMP_RNDN);
printf ("\n");
exit (1);
}
mpfr_ui_sub (y, 1, x, GMP_RNDU);
mpfr_set_str_binary (res, "1.0");
if (mpfr_cmp (y, res))
{
printf ("Error in mpfr_ui_sub (y, 1, x, GMP_RNDU) for x=2^(-12)\n"
"expected 1.0, got ");
mpfr_out_str (stdout, 2, 0, y, GMP_RNDN);
printf ("\n");
exit (1);
}
mpfr_ui_sub (y, 1, x, GMP_RNDN);
mpfr_set_str_binary (res, "1.0");
if (mpfr_cmp (y, res))
{
printf ("Error in mpfr_ui_sub (y, 1, x, GMP_RNDN) for x=2^(-12)\n"
"expected 1.0, got ");
mpfr_out_str (stdout, 2, 0, y, GMP_RNDN);
printf ("\n");
exit (1);
}
mpfr_set_prec (x, 10);
mpfr_set_prec (y, 10);
mpfr_random (x);
mpfr_ui_sub (y, 0, x, GMP_RNDN);
if (MPFR_IS_ZERO(x))
MPFR_ASSERTN(MPFR_IS_ZERO(y));
else
MPFR_ASSERTN(mpfr_cmpabs (x, y) == 0 && mpfr_sgn (x) != mpfr_sgn (y));
mpfr_set_prec (x, 73);
mpfr_set_str_binary (x, "0.1101111010101011011011100011010000000101110001011111001011011000101111101E-99");
mpfr_ui_sub (x, 1, x, GMP_RNDZ);
mpfr_nextabove (x);
MPFR_ASSERTN(mpfr_cmp_ui (x, 1) == 0);
mpfr_clear (x);
mpfr_clear (y);
mpfr_clear (res);
}
void mpfr_poly_gaussian_proposal_param_max(mpfr_ptr mean_par, mpfr_ptr stdev_par, size_t nterms, mpfr_t* coef, mpfr_ptr c1, mpfr_ptr c2, mpfr_ptr mean, mpfr_ptr stdev) {
#undef NPASS
#define NPASS NTEMP(mpfr_poly_gaussian_pdf_pass_temp)
size_t ntemp = NTEMP(mpfr_poly_gaussian_proposal_param_max);
mpfr_t *temp = mpfr_array_alloc_init(ntemp);
mpfr_ptr tmp = GET_NEXT_TEMP_PTR(temp);
mpfr_ptr xmax = GET_NEXT_TEMP_PTR(temp);
mpfr_ptr init = GET_NEXT_TEMP_PTR(temp);
if (mpfr_inf_p(c1)) {
MPFR_FUN(sub_ui, init, c2, 1); // can not use c2 because the function can be zero here
} else if (mpfr_inf_p(c2)) {
MPFR_FUN(add_ui, init, c1, 1); // can not use c1 because the function can be zero here
} else {
MPFR_FUN(add, init, c1, c2);
MPFR_FUN(div_ui, init, init, 2);
}
mpfr_optimization_newton(xmax, init, c1, c2, mpfr_poly_gaussian_gradient_log_v, mpfr_poly_gaussian_hessian_log_v, nterms, coef, mean, stdev);
//mpfr_ptr xc1 = GET_NEXT_TEMP_PTR(temp);
//mpfr_ptr xc2 = GET_NEXT_TEMP_PTR(temp);
mpfr_ptr xcmp = GET_NEXT_TEMP_PTR(temp);
/* set xc1 to almost c1 (99%) */
//MPFR_FUN(mul_ui, xc1, c1, 99);
//MPFR_FUN(add, xc1, xmax, xc1);
//MPFR_FUN(div_ui, xc1, xc1, 100);
/* set xc2 to almost c2 (99%) */
//MPFR_FUN(mul_ui, xc2, c2, 99);
//MPFR_FUN(add, xc2, xmax, xc2);
//MPFR_FUN(div_ui, xc2, xc2, 100);
//mpfr_ptr fc1 = GET_NEXT_TEMP_PTR(temp);
//mpfr_ptr fc2 = GET_NEXT_TEMP_PTR(temp);
//mpfr_ptr fxc1 = GET_NEXT_TEMP_PTR(temp);
//mpfr_ptr fxc2 = GET_NEXT_TEMP_PTR(temp);
mpfr_ptr fcmp = GET_NEXT_TEMP_PTR(temp);
mpfr_ptr fmax = GET_NEXT_TEMP_PTR(temp);
//mpfr_ptr finit = GET_NEXT_TEMP_PTR(temp);
mpfr_t *pass_temp = GET_NEXT_TEMP(temp);
//mpfr_poly_gaussian_pdf_pass_temp(fc1, c1, nterms, coef, c1, c2, mean, stdev, pass_temp);
//mpfr_poly_gaussian_pdf_pass_temp(fc2, c2, nterms, coef, c1, c2, mean, stdev, pass_temp);
//mpfr_poly_gaussian_pdf_pass_temp(fxc1, xc1, nterms, coef, c1, c2, mean, stdev, pass_temp);
//mpfr_poly_gaussian_pdf_pass_temp(fxc2, xc2, nterms, coef, c1, c2, mean, stdev, pass_temp);
mpfr_poly_gaussian_pdf_pass_temp(fmax, xmax, nterms, coef, c1, c2, mean, stdev, pass_temp);
//mpfr_poly_gaussian_pdf_pass_temp(finit, init, nterms, coef, c1, c2, mean, stdev, pass_temp);
/*
TEST_IN_FUNCTION_START
mpfr_printf("xc1: %Rg xc2: %Rg xinit: %Rg xmax: %Rg\n", xc1, xc2, init, xmax);
mpfr_printf("f(xc1): %Rg f(xc2): %Rg f_init: %Rg f_max: %Rg\n", fxc1, fxc2, finit, fmax);
TEST_IN_FUNCTION_END
*/
/* checking for correct maximization */
/*if (mpfr_cmpabs(fc1,fmax)>=0) {
MPFR_FUN(set, fmax, fc1);
MPFR_FUN(set, xmax, c1);
} else if (mpfr_cmpabs(fc2,fmax)>=0) {
MPFR_FUN(set, fmax, fc2);
MPFR_FUN(set, xmax, c2);
}*/
/*
mpfr_ptr xcmp;
mpfr_ptr fcmp;
if (mpfr_cmpabs(fxc1,fxc2)>=0 && mpfr_sgn(fxc1)!=0 && !mpfr_equal_p(xmax,xc1) && !mpfr_inf_p(xc1) && !mpfr_equal_p(fmax, fxc1)) {
fcmp = fxc1;
xcmp = xc1;
} else if (mpfr_cmpabs(fxc2,fxc1)>=0 && mpfr_sgn(fxc2)!=0 && !mpfr_equal_p(xmax,xc2) && !mpfr_inf_p(xc2) && !mpfr_equal_p(fmax, fxc2)) {
fcmp = fxc2;
xcmp = xc2;
} else if (mpfr_sgn(fxc1)!=0 && !mpfr_equal_p(xmax,xc1) && !mpfr_inf_p(xc1) && !mpfr_equal_p(fmax, fxc1)){
fcmp = fxc1;
xcmp = xc1;
} else if (mpfr_sgn(fxc2)!=0 && !mpfr_equal_p(xmax,xc2) && !mpfr_inf_p(xc2) && !mpfr_equal_p(fmax, fxc2)) {
fcmp = fxc2;
xcmp = xc2;
} else {
fcmp = finit;
xcmp = init;
}
*/
if (mpfr_cmpabs(xmax, c1)>0) {
MPFR_FUN(abs, xcmp, xmax);
} else {
MPFR_FUN(abs, xcmp, c1);
}
if (mpfr_sgn(xcmp)==0) { // shouldn't be so but just in case
MPFR_FUN(set_ui, xcmp, 1);
}
MPFR_FUN(add, xcmp, xcmp, xmax);
mpfr_poly_gaussian_pdf_pass_temp(fcmp, xcmp, nterms, coef, c1, c2, mean, stdev, pass_temp);
MPFR_FUN(set, mean_par, xmax);
MPFR_FUN(div, tmp, fmax, fcmp);
MPFR_FUN(log, tmp, tmp);
MPFR_FUN(mul_ui, tmp, tmp, 2);
MPFR_FUN(sqrt, tmp, tmp);
MPFR_FUN(sub, stdev_par, xcmp, xmax);
MPFR_FUN(abs, stdev_par, stdev_par);
MPFR_FUN(div, stdev_par, stdev_par, tmp);
/*
TEST_IN_FUNCTION_START
mpfr_printf("mean: %Rg stdev: %Rg\n", mean_par, stdev_par);
TEST_IN_FUNCTION_END
*/
mpfr_array_clear_free(temp, ntemp);
return;
}
static void
check_inexact (void)
{
mpfr_t x, y, z, u;
mpfr_prec_t px, py, pu, pz;
int inexact, cmp;
mpfr_rnd_t rnd;
mpfr_init (x);
mpfr_init (y);
mpfr_init (z);
mpfr_init (u);
mpfr_set_prec (x, 2);
mpfr_set_str_binary (x, "0.1E-4");
mpfr_set_prec (u, 33);
mpfr_set_str_binary (u, "0.101110100101101100000000111100000E-1");
mpfr_set_prec (y, 31);
if ((inexact = test_add (y, x, u, MPFR_RNDN)))
{
printf ("Wrong inexact flag (2): expected 0, got %d\n", inexact);
exit (1);
}
mpfr_set_prec (x, 2);
mpfr_set_str_binary (x, "0.1E-4");
mpfr_set_prec (u, 33);
mpfr_set_str_binary (u, "0.101110100101101100000000111100000E-1");
mpfr_set_prec (y, 28);
if ((inexact = test_add (y, x, u, MPFR_RNDN)))
{
printf ("Wrong inexact flag (1): expected 0, got %d\n", inexact);
exit (1);
}
for (px=2; px<MAX_PREC; px++)
{
mpfr_set_prec (x, px);
do
{
mpfr_urandomb (x, RANDS);
}
while (mpfr_cmp_ui (x, 0) == 0);
for (pu=2; pu<MAX_PREC; pu++)
{
mpfr_set_prec (u, pu);
do
{
mpfr_urandomb (u, RANDS);
}
while (mpfr_cmp_ui (u, 0) == 0);
{
py = MPFR_PREC_MIN + (randlimb () % (MAX_PREC - 1));
mpfr_set_prec (y, py);
pz = (mpfr_cmpabs (x, u) >= 0) ? MPFR_EXP(x) - MPFR_EXP(u)
: MPFR_EXP(u) - MPFR_EXP(x);
/* x + u is exactly representable with precision
abs(EXP(x)-EXP(u)) + max(prec(x), prec(u)) + 1 */
pz = pz + MAX(MPFR_PREC(x), MPFR_PREC(u)) + 1;
mpfr_set_prec (z, pz);
rnd = RND_RAND ();
if (test_add (z, x, u, rnd))
{
printf ("z <- x + u should be exact\n");
printf ("x=");
mpfr_print_binary (x);
puts ("");
printf ("u=");
mpfr_print_binary (u);
puts ("");
printf ("z=");
mpfr_print_binary (z);
puts ("");
exit (1);
}
{
rnd = RND_RAND ();
inexact = test_add (y, x, u, rnd);
cmp = mpfr_cmp (y, z);
if (((inexact == 0) && (cmp != 0)) ||
((inexact > 0) && (cmp <= 0)) ||
((inexact < 0) && (cmp >= 0)))
{
printf ("Wrong inexact flag for rnd=%s\n",
mpfr_print_rnd_mode(rnd));
printf ("expected %d, got %d\n", cmp, inexact);
printf ("x=");
mpfr_print_binary (x);
puts ("");
printf ("u=");
mpfr_print_binary (u);
puts ("");
printf ("y= ");
mpfr_print_binary (y);
puts ("");
printf ("x+u=");
mpfr_print_binary (z);
puts ("");
exit (1);
}
}
}
}
}
mpfr_clear (x);
mpfr_clear (y);
mpfr_clear (z);
mpfr_clear (u);
}
static void
check_inexact (void)
{
mpfr_t x, y, z, u;
mpfr_prec_t px, py, pu, pz;
int inexact, cmp;
mpfr_rnd_t rnd;
mpfr_init (x);
mpfr_init (y);
mpfr_init (z);
mpfr_init (u);
mpfr_set_prec (x, 2);
mpfr_set_ui (x, 6, MPFR_RNDN);
mpfr_div_2exp (x, x, 4, MPFR_RNDN); /* x = 6/16 */
mpfr_set_prec (y, 2);
mpfr_set_si (y, -1, MPFR_RNDN);
mpfr_div_2exp (y, y, 4, MPFR_RNDN); /* y = -1/16 */
inexact = test_sub (y, y, x, MPFR_RNDN); /* y = round(-7/16) = -1/2 */
if (inexact >= 0)
{
printf ("Error: wrong inexact flag for -1/16 - (6/16)\n");
exit (1);
}
for (px=2; px<MAX_PREC; px++)
{
mpfr_set_prec (x, px);
do
{
mpfr_urandomb (x, RANDS);
}
while (mpfr_cmp_ui (x, 0) == 0);
for (pu=2; pu<MAX_PREC; pu++)
{
mpfr_set_prec (u, pu);
do
{
mpfr_urandomb (u, RANDS);
}
while (mpfr_cmp_ui (u, 0) == 0);
{
py = 2 + (randlimb () % (MAX_PREC - 2));
mpfr_set_prec (y, py);
/* warning: MPFR_EXP is undefined for 0 */
pz = (mpfr_cmpabs (x, u) >= 0) ? MPFR_EXP(x) - MPFR_EXP(u)
: MPFR_EXP(u) - MPFR_EXP(x);
pz = pz + MAX(MPFR_PREC(x), MPFR_PREC(u));
mpfr_set_prec (z, pz);
rnd = RND_RAND ();
if (test_sub (z, x, u, rnd))
{
printf ("z <- x - u should be exact\n");
exit (1);
}
{
rnd = RND_RAND ();
inexact = test_sub (y, x, u, rnd);
cmp = mpfr_cmp (y, z);
if (((inexact == 0) && (cmp != 0)) ||
((inexact > 0) && (cmp <= 0)) ||
((inexact < 0) && (cmp >= 0)))
{
printf ("Wrong inexact flag for rnd=%s\n",
mpfr_print_rnd_mode(rnd));
printf ("expected %d, got %d\n", cmp, inexact);
printf ("x="); mpfr_print_binary (x); puts ("");
printf ("u="); mpfr_print_binary (u); puts ("");
printf ("y= "); mpfr_print_binary (y); puts ("");
printf ("x-u="); mpfr_print_binary (z); puts ("");
exit (1);
}
}
}
}
}
mpfr_clear (x);
mpfr_clear (y);
mpfr_clear (z);
mpfr_clear (u);
}
/* Put in z the value of x^y, rounded according to 'rnd'.
Return the inexact flag in [0, 10]. */
int
mpc_pow (mpc_ptr z, mpc_srcptr x, mpc_srcptr y, mpc_rnd_t rnd)
{
int ret = -2, loop, x_real, x_imag, y_real, z_real = 0, z_imag = 0;
mpc_t t, u;
mpfr_prec_t p, pr, pi, maxprec;
int saved_underflow, saved_overflow;
/* save the underflow or overflow flags from MPFR */
saved_underflow = mpfr_underflow_p ();
saved_overflow = mpfr_overflow_p ();
x_real = mpfr_zero_p (mpc_imagref(x));
y_real = mpfr_zero_p (mpc_imagref(y));
if (y_real && mpfr_zero_p (mpc_realref(y))) /* case y zero */
{
if (x_real && mpfr_zero_p (mpc_realref(x)))
{
/* we define 0^0 to be (1, +0) since the real part is
coherent with MPFR where 0^0 gives 1, and the sign of the
imaginary part cannot be determined */
mpc_set_ui_ui (z, 1, 0, MPC_RNDNN);
return 0;
}
else /* x^0 = 1 +/- i*0 even for x=NaN see algorithms.tex for the
sign of zero */
{
mpfr_t n;
int inex, cx1;
int sign_zi;
/* cx1 < 0 if |x| < 1
cx1 = 0 if |x| = 1
cx1 > 0 if |x| > 1
*/
mpfr_init (n);
inex = mpc_norm (n, x, MPFR_RNDN);
cx1 = mpfr_cmp_ui (n, 1);
if (cx1 == 0 && inex != 0)
cx1 = -inex;
sign_zi = (cx1 < 0 && mpfr_signbit (mpc_imagref (y)) == 0)
|| (cx1 == 0
&& mpfr_signbit (mpc_imagref (x)) != mpfr_signbit (mpc_realref (y)))
|| (cx1 > 0 && mpfr_signbit (mpc_imagref (y)));
/* warning: mpc_set_ui_ui does not set Im(z) to -0 if Im(rnd)=RNDD */
ret = mpc_set_ui_ui (z, 1, 0, rnd);
if (MPC_RND_IM (rnd) == MPFR_RNDD || sign_zi)
mpc_conj (z, z, MPC_RNDNN);
mpfr_clear (n);
return ret;
}
}
if (!mpc_fin_p (x) || !mpc_fin_p (y))
{
/* special values: exp(y*log(x)) */
mpc_init2 (u, 2);
mpc_log (u, x, MPC_RNDNN);
mpc_mul (u, u, y, MPC_RNDNN);
ret = mpc_exp (z, u, rnd);
mpc_clear (u);
goto end;
}
if (x_real) /* case x real */
{
if (mpfr_zero_p (mpc_realref(x))) /* x is zero */
{
/* special values: exp(y*log(x)) */
mpc_init2 (u, 2);
mpc_log (u, x, MPC_RNDNN);
mpc_mul (u, u, y, MPC_RNDNN);
ret = mpc_exp (z, u, rnd);
mpc_clear (u);
goto end;
}
/* Special case 1^y = 1 */
if (mpfr_cmp_ui (mpc_realref(x), 1) == 0)
{
int s1, s2;
s1 = mpfr_signbit (mpc_realref (y));
s2 = mpfr_signbit (mpc_imagref (x));
ret = mpc_set_ui (z, +1, rnd);
/* the sign of the zero imaginary part is known in some cases (see
algorithm.tex). In such cases we have
(x +s*0i)^(y+/-0i) = x^y + s*sign(y)*0i
where s = +/-1. We extend here this rule to fix the sign of the
zero part.
Note that the sign must also be set explicitly when rnd=RNDD
because mpfr_set_ui(z_i, 0, rnd) always sets z_i to +0.
*/
if (MPC_RND_IM (rnd) == MPFR_RNDD || s1 != s2)
mpc_conj (z, z, MPC_RNDNN);
goto end;
}
/* x^y is real when:
(a) x is real and y is integer
(b) x is real non-negative and y is real */
if (y_real && (mpfr_integer_p (mpc_realref(y)) ||
mpfr_cmp_ui (mpc_realref(x), 0) >= 0))
{
int s1, s2;
s1 = mpfr_signbit (mpc_realref (y));
s2 = mpfr_signbit (mpc_imagref (x));
ret = mpfr_pow (mpc_realref(z), mpc_realref(x), mpc_realref(y), MPC_RND_RE(rnd));
ret = MPC_INEX(ret, mpfr_set_ui (mpc_imagref(z), 0, MPC_RND_IM(rnd)));
/* the sign of the zero imaginary part is known in some cases
(see algorithm.tex). In such cases we have (x +s*0i)^(y+/-0i)
= x^y + s*sign(y)*0i where s = +/-1.
We extend here this rule to fix the sign of the zero part.
Note that the sign must also be set explicitly when rnd=RNDD
because mpfr_set_ui(z_i, 0, rnd) always sets z_i to +0.
*/
if (MPC_RND_IM(rnd) == MPFR_RNDD || s1 != s2)
mpfr_neg (mpc_imagref(z), mpc_imagref(z), MPC_RND_IM(rnd));
goto end;
}
/* (-1)^(n+I*t) is real for n integer and t real */
if (mpfr_cmp_si (mpc_realref(x), -1) == 0 && mpfr_integer_p (mpc_realref(y)))
z_real = 1;
/* for x real, x^y is imaginary when:
(a) x is negative and y is half-an-integer
(b) x = -1 and Re(y) is half-an-integer
*/
if ((mpfr_cmp_ui (mpc_realref(x), 0) < 0) && is_odd (mpc_realref(y), 1)
&& (y_real || mpfr_cmp_si (mpc_realref(x), -1) == 0))
z_imag = 1;
}
else /* x non real */
/* I^(t*I) and (-I)^(t*I) are real for t real,
I^(n+t*I) and (-I)^(n+t*I) are real for n even and t real, and
I^(n+t*I) and (-I)^(n+t*I) are imaginary for n odd and t real
(s*I)^n is real for n even and imaginary for n odd */
if ((mpc_cmp_si_si (x, 0, 1) == 0 || mpc_cmp_si_si (x, 0, -1) == 0 ||
(mpfr_cmp_ui (mpc_realref(x), 0) == 0 && y_real)) &&
mpfr_integer_p (mpc_realref(y)))
{ /* x is I or -I, and Re(y) is an integer */
if (is_odd (mpc_realref(y), 0))
z_imag = 1; /* Re(y) odd: z is imaginary */
else
z_real = 1; /* Re(y) even: z is real */
}
else /* (t+/-t*I)^(2n) is imaginary for n odd and real for n even */
if (mpfr_cmpabs (mpc_realref(x), mpc_imagref(x)) == 0 && y_real &&
mpfr_integer_p (mpc_realref(y)) && is_odd (mpc_realref(y), 0) == 0)
{
if (is_odd (mpc_realref(y), -1)) /* y/2 is odd */
z_imag = 1;
else
z_real = 1;
}
pr = mpfr_get_prec (mpc_realref(z));
pi = mpfr_get_prec (mpc_imagref(z));
p = (pr > pi) ? pr : pi;
p += 12; /* experimentally, seems to give less than 10% of failures in
Ziv's strategy; probably wrong now since q is not computed */
if (p < 64)
p = 64;
mpc_init2 (u, p);
mpc_init2 (t, p);
pr += MPC_RND_RE(rnd) == MPFR_RNDN;
pi += MPC_RND_IM(rnd) == MPFR_RNDN;
maxprec = MPC_MAX_PREC (z);
x_imag = mpfr_zero_p (mpc_realref(x));
for (loop = 0;; loop++)
{
int ret_exp;
mpfr_exp_t dr, di;
mpfr_prec_t q;
mpc_log (t, x, MPC_RNDNN);
mpc_mul (t, t, y, MPC_RNDNN);
/* Compute q such that |Re (y log x)|, |Im (y log x)| < 2^q.
We recompute it at each loop since we might get different
bounds if the precision is not enough. */
q = mpfr_get_exp (mpc_realref(t)) > 0 ? mpfr_get_exp (mpc_realref(t)) : 0;
if (mpfr_get_exp (mpc_imagref(t)) > (mpfr_exp_t) q)
q = mpfr_get_exp (mpc_imagref(t));
mpfr_clear_overflow ();
mpfr_clear_underflow ();
ret_exp = mpc_exp (u, t, MPC_RNDNN);
if (mpfr_underflow_p () || mpfr_overflow_p ()) {
/* under- and overflow flags are set by mpc_exp */
mpc_set (z, u, MPC_RNDNN);
ret = ret_exp;
goto exact;
}
/* Since the error bound is global, we have to take into account the
exponent difference between the real and imaginary parts. We assume
either the real or the imaginary part of u is not zero.
*/
dr = mpfr_zero_p (mpc_realref(u)) ? mpfr_get_exp (mpc_imagref(u))
: mpfr_get_exp (mpc_realref(u));
di = mpfr_zero_p (mpc_imagref(u)) ? dr : mpfr_get_exp (mpc_imagref(u));
if (dr > di)
{
di = dr - di;
dr = 0;
}
else
{
dr = di - dr;
di = 0;
}
/* the term -3 takes into account the factor 4 in the complex error
(see algorithms.tex) plus one due to the exponent difference: if
z = a + I*b, where the relative error on z is at most 2^(-p), and
EXP(a) = EXP(b) + k, the relative error on b is at most 2^(k-p) */
if ((z_imag || (p > q + 3 + dr && mpfr_can_round (mpc_realref(u), p - q - 3 - dr, MPFR_RNDN, MPFR_RNDZ, pr))) &&
(z_real || (p > q + 3 + di && mpfr_can_round (mpc_imagref(u), p - q - 3 - di, MPFR_RNDN, MPFR_RNDZ, pi))))
break;
/* if Re(u) is not known to be zero, assume it is a normal number, i.e.,
neither zero, Inf or NaN, otherwise we might enter an infinite loop */
MPC_ASSERT (z_imag || mpfr_number_p (mpc_realref(u)));
/* idem for Im(u) */
MPC_ASSERT (z_real || mpfr_number_p (mpc_imagref(u)));
if (ret == -2) /* we did not yet call mpc_pow_exact, or it aborted
because intermediate computations had > maxprec bits */
{
/* check exact cases (see algorithms.tex) */
if (y_real)
{
maxprec *= 2;
ret = mpc_pow_exact (z, x, mpc_realref(y), rnd, maxprec);
if (ret != -1 && ret != -2)
goto exact;
}
p += dr + di + 64;
}
else
p += p / 2;
mpc_set_prec (t, p);
mpc_set_prec (u, p);
}
if (z_real)
{
/* When the result is real (see algorithm.tex for details),
Im(x^y) =
+ sign(imag(y))*0i, if |x| > 1
+ sign(imag(x))*sign(real(y))*0i, if |x| = 1
- sign(imag(y))*0i, if |x| < 1
*/
mpfr_t n;
int inex, cx1;
int sign_zi, sign_rex, sign_imx;
/* cx1 < 0 if |x| < 1
cx1 = 0 if |x| = 1
cx1 > 0 if |x| > 1
*/
sign_rex = mpfr_signbit (mpc_realref (x));
sign_imx = mpfr_signbit (mpc_imagref (x));
mpfr_init (n);
inex = mpc_norm (n, x, MPFR_RNDN);
cx1 = mpfr_cmp_ui (n, 1);
if (cx1 == 0 && inex != 0)
cx1 = -inex;
sign_zi = (cx1 < 0 && mpfr_signbit (mpc_imagref (y)) == 0)
|| (cx1 == 0 && sign_imx != mpfr_signbit (mpc_realref (y)))
|| (cx1 > 0 && mpfr_signbit (mpc_imagref (y)));
/* copy RE(y) to n since if z==y we will destroy Re(y) below */
mpfr_set_prec (n, mpfr_get_prec (mpc_realref (y)));
mpfr_set (n, mpc_realref (y), MPFR_RNDN);
ret = mpfr_set (mpc_realref(z), mpc_realref(u), MPC_RND_RE(rnd));
if (y_real && (x_real || x_imag))
{
/* FIXME: with y_real we assume Im(y) is really 0, which is the case
for example when y comes from pow_fr, but in case Im(y) is +0 or
-0, we might get different results */
mpfr_set_ui (mpc_imagref (z), 0, MPC_RND_IM (rnd));
fix_sign (z, sign_rex, sign_imx, n);
ret = MPC_INEX(ret, 0); /* imaginary part is exact */
}
else
{
ret = MPC_INEX (ret, mpfr_set_ui (mpc_imagref (z), 0, MPC_RND_IM (rnd)));
/* warning: mpfr_set_ui does not set Im(z) to -0 if Im(rnd) = RNDD */
if (MPC_RND_IM (rnd) == MPFR_RNDD || sign_zi)
mpc_conj (z, z, MPC_RNDNN);
}
mpfr_clear (n);
}
else if (z_imag)
{
ret = mpfr_set (mpc_imagref(z), mpc_imagref(u), MPC_RND_IM(rnd));
/* if z is imaginary and y real, then x cannot be real */
if (y_real && x_imag)
{
int sign_rex = mpfr_signbit (mpc_realref (x));
/* If z overlaps with y we set Re(z) before checking Re(y) below,
but in that case y=0, which was dealt with above. */
mpfr_set_ui (mpc_realref (z), 0, MPC_RND_RE (rnd));
/* Note: fix_sign only does something when y is an integer,
then necessarily y = 1 or 3 (mod 4), and in that case the
sign of Im(x) is irrelevant. */
fix_sign (z, sign_rex, 0, mpc_realref (y));
ret = MPC_INEX(0, ret);
}
else
ret = MPC_INEX(mpfr_set_ui (mpc_realref(z), 0, MPC_RND_RE(rnd)), ret);
}
else
ret = mpc_set (z, u, rnd);
exact:
mpc_clear (t);
mpc_clear (u);
/* restore underflow and overflow flags from MPFR */
if (saved_underflow)
mpfr_set_underflow ();
if (saved_overflow)
mpfr_set_overflow ();
end:
return ret;
}
/* The computation of z = pow(x,y) is done by
z = exp(y * log(x)) = x^y
For the special cases, see Section F.9.4.4 of the C standard:
_ pow(±0, y) = ±inf for y an odd integer < 0.
_ pow(±0, y) = +inf for y < 0 and not an odd integer.
_ pow(±0, y) = ±0 for y an odd integer > 0.
_ pow(±0, y) = +0 for y > 0 and not an odd integer.
_ pow(-1, ±inf) = 1.
_ pow(+1, y) = 1 for any y, even a NaN.
_ pow(x, ±0) = 1 for any x, even a NaN.
_ pow(x, y) = NaN for finite x < 0 and finite non-integer y.
_ pow(x, -inf) = +inf for |x| < 1.
_ pow(x, -inf) = +0 for |x| > 1.
_ pow(x, +inf) = +0 for |x| < 1.
_ pow(x, +inf) = +inf for |x| > 1.
_ pow(-inf, y) = -0 for y an odd integer < 0.
_ pow(-inf, y) = +0 for y < 0 and not an odd integer.
_ pow(-inf, y) = -inf for y an odd integer > 0.
_ pow(-inf, y) = +inf for y > 0 and not an odd integer.
_ pow(+inf, y) = +0 for y < 0.
_ pow(+inf, y) = +inf for y > 0. */
int
mpfr_pow (mpfr_ptr z, mpfr_srcptr x, mpfr_srcptr y, mpfr_rnd_t rnd_mode)
{
int inexact;
int cmp_x_1;
int y_is_integer;
MPFR_SAVE_EXPO_DECL (expo);
MPFR_LOG_FUNC
(("x[%Pu]=%.*Rg y[%Pu]=%.*Rg rnd=%d",
mpfr_get_prec (x), mpfr_log_prec, x,
mpfr_get_prec (y), mpfr_log_prec, y, rnd_mode),
("z[%Pu]=%.*Rg inexact=%d",
mpfr_get_prec (z), mpfr_log_prec, z, inexact));
if (MPFR_ARE_SINGULAR (x, y))
{
/* pow(x, 0) returns 1 for any x, even a NaN. */
if (MPFR_UNLIKELY (MPFR_IS_ZERO (y)))
return mpfr_set_ui (z, 1, rnd_mode);
else if (MPFR_IS_NAN (x))
{
MPFR_SET_NAN (z);
MPFR_RET_NAN;
}
else if (MPFR_IS_NAN (y))
{
/* pow(+1, NaN) returns 1. */
if (mpfr_cmp_ui (x, 1) == 0)
return mpfr_set_ui (z, 1, rnd_mode);
MPFR_SET_NAN (z);
MPFR_RET_NAN;
}
else if (MPFR_IS_INF (y))
{
if (MPFR_IS_INF (x))
{
if (MPFR_IS_POS (y))
MPFR_SET_INF (z);
else
MPFR_SET_ZERO (z);
MPFR_SET_POS (z);
MPFR_RET (0);
}
else
{
int cmp;
cmp = mpfr_cmpabs (x, __gmpfr_one) * MPFR_INT_SIGN (y);
MPFR_SET_POS (z);
if (cmp > 0)
{
/* Return +inf. */
MPFR_SET_INF (z);
MPFR_RET (0);
}
else if (cmp < 0)
{
/* Return +0. */
MPFR_SET_ZERO (z);
MPFR_RET (0);
}
else
{
/* Return 1. */
return mpfr_set_ui (z, 1, rnd_mode);
}
}
}
else if (MPFR_IS_INF (x))
{
int negative;
/* Determine the sign now, in case y and z are the same object */
negative = MPFR_IS_NEG (x) && is_odd (y);
if (MPFR_IS_POS (y))
MPFR_SET_INF (z);
else
MPFR_SET_ZERO (z);
if (negative)
MPFR_SET_NEG (z);
else
MPFR_SET_POS (z);
MPFR_RET (0);
}
else
{
int negative;
MPFR_ASSERTD (MPFR_IS_ZERO (x));
/* Determine the sign now, in case y and z are the same object */
negative = MPFR_IS_NEG(x) && is_odd (y);
if (MPFR_IS_NEG (y))
{
MPFR_ASSERTD (! MPFR_IS_INF (y));
MPFR_SET_INF (z);
mpfr_set_divby0 ();
}
else
MPFR_SET_ZERO (z);
if (negative)
MPFR_SET_NEG (z);
else
MPFR_SET_POS (z);
MPFR_RET (0);
}
}
/* x^y for x < 0 and y not an integer is not defined */
y_is_integer = mpfr_integer_p (y);
if (MPFR_IS_NEG (x) && ! y_is_integer)
{
MPFR_SET_NAN (z);
MPFR_RET_NAN;
}
/* now the result cannot be NaN:
(1) either x > 0
(2) or x < 0 and y is an integer */
cmp_x_1 = mpfr_cmpabs (x, __gmpfr_one);
if (cmp_x_1 == 0)
return mpfr_set_si (z, MPFR_IS_NEG (x) && is_odd (y) ? -1 : 1, rnd_mode);
/* now we have:
(1) either x > 0
(2) or x < 0 and y is an integer
and in addition |x| <> 1.
*/
/* detect overflow: an overflow is possible if
(a) |x| > 1 and y > 0
(b) |x| < 1 and y < 0.
FIXME: this assumes 1 is always representable.
FIXME2: maybe we can test overflow and underflow simultaneously.
The idea is the following: first compute an approximation to
y * log2|x|, using rounding to nearest. If |x| is not too near from 1,
this approximation should be accurate enough, and in most cases enable
one to prove that there is no underflow nor overflow.
Otherwise, it should enable one to check only underflow or overflow,
instead of both cases as in the present case.
*/
if (cmp_x_1 * MPFR_SIGN (y) > 0)
{
mpfr_t t;
int negative, overflow;
MPFR_SAVE_EXPO_MARK (expo);
mpfr_init2 (t, 53);
/* we want a lower bound on y*log2|x|:
(i) if x > 0, it suffices to round log2(x) toward zero, and
to round y*o(log2(x)) toward zero too;
(ii) if x < 0, we first compute t = o(-x), with rounding toward 1,
and then follow as in case (1). */
if (MPFR_SIGN (x) > 0)
mpfr_log2 (t, x, MPFR_RNDZ);
else
{
mpfr_neg (t, x, (cmp_x_1 > 0) ? MPFR_RNDZ : MPFR_RNDU);
mpfr_log2 (t, t, MPFR_RNDZ);
}
mpfr_mul (t, t, y, MPFR_RNDZ);
overflow = mpfr_cmp_si (t, __gmpfr_emax) > 0;
mpfr_clear (t);
MPFR_SAVE_EXPO_FREE (expo);
if (overflow)
{
MPFR_LOG_MSG (("early overflow detection\n", 0));
negative = MPFR_SIGN(x) < 0 && is_odd (y);
return mpfr_overflow (z, rnd_mode, negative ? -1 : 1);
}
}
/* Basic underflow checking. One has:
* - if y > 0, |x^y| < 2^(EXP(x) * y);
* - if y < 0, |x^y| <= 2^((EXP(x) - 1) * y);
* so that one can compute a value ebound such that |x^y| < 2^ebound.
* If we have ebound <= emin - 2 (emin - 1 in directed rounding modes),
* then there is an underflow and we can decide the return value.
*/
if (MPFR_IS_NEG (y) ? (MPFR_GET_EXP (x) > 1) : (MPFR_GET_EXP (x) < 0))
{
mpfr_t tmp;
mpfr_eexp_t ebound;
int inex2;
/* We must restore the flags. */
MPFR_SAVE_EXPO_MARK (expo);
mpfr_init2 (tmp, sizeof (mpfr_exp_t) * CHAR_BIT);
inex2 = mpfr_set_exp_t (tmp, MPFR_GET_EXP (x), MPFR_RNDN);
MPFR_ASSERTN (inex2 == 0);
if (MPFR_IS_NEG (y))
{
inex2 = mpfr_sub_ui (tmp, tmp, 1, MPFR_RNDN);
MPFR_ASSERTN (inex2 == 0);
}
mpfr_mul (tmp, tmp, y, MPFR_RNDU);
if (MPFR_IS_NEG (y))
mpfr_nextabove (tmp);
/* tmp doesn't necessarily fit in ebound, but that doesn't matter
since we get the minimum value in such a case. */
ebound = mpfr_get_exp_t (tmp, MPFR_RNDU);
mpfr_clear (tmp);
MPFR_SAVE_EXPO_FREE (expo);
if (MPFR_UNLIKELY (ebound <=
__gmpfr_emin - (rnd_mode == MPFR_RNDN ? 2 : 1)))
{
/* warning: mpfr_underflow rounds away from 0 for MPFR_RNDN */
MPFR_LOG_MSG (("early underflow detection\n", 0));
return mpfr_underflow (z,
rnd_mode == MPFR_RNDN ? MPFR_RNDZ : rnd_mode,
MPFR_SIGN (x) < 0 && is_odd (y) ? -1 : 1);
}
}
/* If y is an integer, we can use mpfr_pow_z (based on multiplications),
but if y is very large (I'm not sure about the best threshold -- VL),
we shouldn't use it, as it can be very slow and take a lot of memory
(and even crash or make other programs crash, as several hundred of
MBs may be necessary). Note that in such a case, either x = +/-2^b
(this case is handled below) or x^y cannot be represented exactly in
any precision supported by MPFR (the general case uses this property).
*/
if (y_is_integer && (MPFR_GET_EXP (y) <= 256))
{
mpz_t zi;
MPFR_LOG_MSG (("special code for y not too large integer\n", 0));
mpz_init (zi);
mpfr_get_z (zi, y, MPFR_RNDN);
inexact = mpfr_pow_z (z, x, zi, rnd_mode);
mpz_clear (zi);
return inexact;
}
/* Special case (+/-2^b)^Y which could be exact. If x is negative, then
necessarily y is a large integer. */
{
mpfr_exp_t b = MPFR_GET_EXP (x) - 1;
MPFR_ASSERTN (b >= LONG_MIN && b <= LONG_MAX); /* FIXME... */
if (mpfr_cmp_si_2exp (x, MPFR_SIGN(x), b) == 0)
{
mpfr_t tmp;
int sgnx = MPFR_SIGN (x);
MPFR_LOG_MSG (("special case (+/-2^b)^Y\n", 0));
/* now x = +/-2^b, so x^y = (+/-1)^y*2^(b*y) is exact whenever b*y is
an integer */
MPFR_SAVE_EXPO_MARK (expo);
mpfr_init2 (tmp, MPFR_PREC (y) + sizeof (long) * CHAR_BIT);
inexact = mpfr_mul_si (tmp, y, b, MPFR_RNDN); /* exact */
MPFR_ASSERTN (inexact == 0);
/* Note: as the exponent range has been extended, an overflow is not
possible (due to basic overflow and underflow checking above, as
the result is ~ 2^tmp), and an underflow is not possible either
because b is an integer (thus either 0 or >= 1). */
MPFR_CLEAR_FLAGS ();
inexact = mpfr_exp2 (z, tmp, rnd_mode);
mpfr_clear (tmp);
if (sgnx < 0 && is_odd (y))
{
mpfr_neg (z, z, rnd_mode);
inexact = -inexact;
}
/* Without the following, the overflows3 test in tpow.c fails. */
MPFR_SAVE_EXPO_UPDATE_FLAGS (expo, __gmpfr_flags);
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (z, inexact, rnd_mode);
}
}
MPFR_SAVE_EXPO_MARK (expo);
/* Case where |y * log(x)| is very small. Warning: x can be negative, in
that case y is a large integer. */
{
mpfr_t t;
mpfr_exp_t err;
/* We need an upper bound on the exponent of y * log(x). */
mpfr_init2 (t, 16);
if (MPFR_IS_POS(x))
mpfr_log (t, x, cmp_x_1 < 0 ? MPFR_RNDD : MPFR_RNDU); /* away from 0 */
else
{
/* if x < -1, round to +Inf, else round to zero */
mpfr_neg (t, x, (mpfr_cmp_si (x, -1) < 0) ? MPFR_RNDU : MPFR_RNDD);
mpfr_log (t, t, (mpfr_cmp_ui (t, 1) < 0) ? MPFR_RNDD : MPFR_RNDU);
}
MPFR_ASSERTN (MPFR_IS_PURE_FP (t));
err = MPFR_GET_EXP (y) + MPFR_GET_EXP (t);
mpfr_clear (t);
MPFR_CLEAR_FLAGS ();
MPFR_SMALL_INPUT_AFTER_SAVE_EXPO (z, __gmpfr_one, - err, 0,
(MPFR_SIGN (y) > 0) ^ (cmp_x_1 < 0),
rnd_mode, expo, {});
}
/* General case */
inexact = mpfr_pow_general (z, x, y, rnd_mode, y_is_integer, &expo);
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (z, inexact, rnd_mode);
}
/* Put in z the value of x^y, rounded according to 'rnd'.
Return the inexact flag in [0, 10]. */
int
mpc_pow (mpc_ptr z, mpc_srcptr x, mpc_srcptr y, mpc_rnd_t rnd)
{
int ret = -2, loop, x_real, y_real, z_real = 0, z_imag = 0;
mpc_t t, u;
mp_prec_t p, q, pr, pi, maxprec;
long Q;
x_real = mpfr_zero_p (MPC_IM(x));
y_real = mpfr_zero_p (MPC_IM(y));
if (y_real && mpfr_zero_p (MPC_RE(y))) /* case y zero */
{
if (x_real && mpfr_zero_p (MPC_RE(x))) /* 0^0 = NaN +i*NaN */
{
mpfr_set_nan (MPC_RE(z));
mpfr_set_nan (MPC_IM(z));
return 0;
}
else /* x^0 = 1 +/- i*0 even for x=NaN see algorithms.tex for the
sign of zero */
{
mpfr_t n;
int inex, cx1;
int sign_zi;
/* cx1 < 0 if |x| < 1
cx1 = 0 if |x| = 1
cx1 > 0 if |x| > 1
*/
mpfr_init (n);
inex = mpc_norm (n, x, GMP_RNDN);
cx1 = mpfr_cmp_ui (n, 1);
if (cx1 == 0 && inex != 0)
cx1 = -inex;
sign_zi = (cx1 < 0 && mpfr_signbit (MPC_IM (y)) == 0)
|| (cx1 == 0
&& mpfr_signbit (MPC_IM (x)) != mpfr_signbit (MPC_RE (y)))
|| (cx1 > 0 && mpfr_signbit (MPC_IM (y)));
/* warning: mpc_set_ui_ui does not set Im(z) to -0 if Im(rnd)=RNDD */
ret = mpc_set_ui_ui (z, 1, 0, rnd);
if (MPC_RND_IM (rnd) == GMP_RNDD || sign_zi)
mpc_conj (z, z, MPC_RNDNN);
mpfr_clear (n);
return ret;
}
}
if (mpfr_nan_p (MPC_RE(x)) || mpfr_nan_p (MPC_IM(x)) ||
mpfr_nan_p (MPC_RE(y)) || mpfr_nan_p (MPC_IM(y)) ||
mpfr_inf_p (MPC_RE(x)) || mpfr_inf_p (MPC_IM(x)) ||
mpfr_inf_p (MPC_RE(y)) || mpfr_inf_p (MPC_IM(y)))
{
/* special values: exp(y*log(x)) */
mpc_init2 (u, 2);
mpc_log (u, x, MPC_RNDNN);
mpc_mul (u, u, y, MPC_RNDNN);
ret = mpc_exp (z, u, rnd);
mpc_clear (u);
goto end;
}
if (x_real) /* case x real */
{
if (mpfr_zero_p (MPC_RE(x))) /* x is zero */
{
/* special values: exp(y*log(x)) */
mpc_init2 (u, 2);
mpc_log (u, x, MPC_RNDNN);
mpc_mul (u, u, y, MPC_RNDNN);
ret = mpc_exp (z, u, rnd);
mpc_clear (u);
goto end;
}
/* Special case 1^y = 1 */
if (mpfr_cmp_ui (MPC_RE(x), 1) == 0)
{
int s1, s2;
s1 = mpfr_signbit (MPC_RE (y));
s2 = mpfr_signbit (MPC_IM (x));
ret = mpc_set_ui (z, +1, rnd);
/* the sign of the zero imaginary part is known in some cases (see
algorithm.tex). In such cases we have
(x +s*0i)^(y+/-0i) = x^y + s*sign(y)*0i
where s = +/-1. We extend here this rule to fix the sign of the
zero part.
Note that the sign must also be set explicitly when rnd=RNDD
because mpfr_set_ui(z_i, 0, rnd) always sets z_i to +0.
*/
if (MPC_RND_IM (rnd) == GMP_RNDD || s1 != s2)
mpc_conj (z, z, MPC_RNDNN);
goto end;
}
/* x^y is real when:
(a) x is real and y is integer
(b) x is real non-negative and y is real */
if (y_real && (mpfr_integer_p (MPC_RE(y)) ||
mpfr_cmp_ui (MPC_RE(x), 0) >= 0))
{
int s1, s2;
s1 = mpfr_signbit (MPC_RE (y));
s2 = mpfr_signbit (MPC_IM (x));
ret = mpfr_pow (MPC_RE(z), MPC_RE(x), MPC_RE(y), MPC_RND_RE(rnd));
ret = MPC_INEX(ret, mpfr_set_ui (MPC_IM(z), 0, MPC_RND_IM(rnd)));
/* the sign of the zero imaginary part is known in some cases
(see algorithm.tex). In such cases we have (x +s*0i)^(y+/-0i)
= x^y + s*sign(y)*0i where s = +/-1.
We extend here this rule to fix the sign of the zero part.
Note that the sign must also be set explicitly when rnd=RNDD
because mpfr_set_ui(z_i, 0, rnd) always sets z_i to +0.
*/
if (MPC_RND_IM(rnd) == GMP_RNDD || s1 != s2)
mpfr_neg (MPC_IM(z), MPC_IM(z), MPC_RND_IM(rnd));
goto end;
}
/* (-1)^(n+I*t) is real for n integer and t real */
if (mpfr_cmp_si (MPC_RE(x), -1) == 0 && mpfr_integer_p (MPC_RE(y)))
z_real = 1;
/* for x real, x^y is imaginary when:
(a) x is negative and y is half-an-integer
(b) x = -1 and Re(y) is half-an-integer
*/
if (mpfr_cmp_ui (MPC_RE(x), 0) < 0 && is_odd (MPC_RE(y), 1) &&
(y_real || mpfr_cmp_si (MPC_RE(x), -1) == 0))
z_imag = 1;
}
else /* x non real */
/* I^(t*I) and (-I)^(t*I) are real for t real,
I^(n+t*I) and (-I)^(n+t*I) are real for n even and t real, and
I^(n+t*I) and (-I)^(n+t*I) are imaginary for n odd and t real
(s*I)^n is real for n even and imaginary for n odd */
if ((mpc_cmp_si_si (x, 0, 1) == 0 || mpc_cmp_si_si (x, 0, -1) == 0 ||
(mpfr_cmp_ui (MPC_RE(x), 0) == 0 && y_real)) &&
mpfr_integer_p (MPC_RE(y)))
{ /* x is I or -I, and Re(y) is an integer */
if (is_odd (MPC_RE(y), 0))
z_imag = 1; /* Re(y) odd: z is imaginary */
else
z_real = 1; /* Re(y) even: z is real */
}
else /* (t+/-t*I)^(2n) is imaginary for n odd and real for n even */
if (mpfr_cmpabs (MPC_RE(x), MPC_IM(x)) == 0 && y_real &&
mpfr_integer_p (MPC_RE(y)) && is_odd (MPC_RE(y), 0) == 0)
{
if (is_odd (MPC_RE(y), -1)) /* y/2 is odd */
z_imag = 1;
else
z_real = 1;
}
/* first bound |Re(y log(x))|, |Im(y log(x)| < 2^q */
mpc_init2 (t, 64);
mpc_log (t, x, MPC_RNDNN);
mpc_mul (t, t, y, MPC_RNDNN);
/* the default maximum exponent for MPFR is emax=2^30-1, thus if
t > log(2^emax) = emax*log(2), then exp(t) will overflow */
if (mpfr_cmp_ui_2exp (MPC_RE(t), 372130558, 1) > 0)
goto overflow;
/* the default minimum exponent for MPFR is emin=-2^30+1, thus the
smallest representable value is 2^(emin-1), and if
t < log(2^(emin-1)) = (emin-1)*log(2), then exp(t) will underflow */
if (mpfr_cmp_si_2exp (MPC_RE(t), -372130558, 1) < 0)
goto underflow;
q = mpfr_get_exp (MPC_RE(t)) > 0 ? mpfr_get_exp (MPC_RE(t)) : 0;
if (mpfr_get_exp (MPC_IM(t)) > (mp_exp_t) q)
q = mpfr_get_exp (MPC_IM(t));
pr = mpfr_get_prec (MPC_RE(z));
pi = mpfr_get_prec (MPC_IM(z));
p = (pr > pi) ? pr : pi;
p += 11; /* experimentally, seems to give less than 10% of failures in
Ziv's strategy */
mpc_init2 (u, p);
pr += MPC_RND_RE(rnd) == GMP_RNDN;
pi += MPC_RND_IM(rnd) == GMP_RNDN;
maxprec = MPFR_PREC(MPC_RE(z));
if (MPFR_PREC(MPC_IM(z)) > maxprec)
maxprec = MPFR_PREC(MPC_IM(z));
for (loop = 0;; loop++)
{
mp_exp_t dr, di;
if (p + q > 64) /* otherwise we reuse the initial approximation
t of y*log(x), avoiding two computations */
{
mpc_set_prec (t, p + q);
mpc_log (t, x, MPC_RNDNN);
mpc_mul (t, t, y, MPC_RNDNN);
}
mpc_exp (u, t, MPC_RNDNN);
/* Since the error bound is global, we have to take into account the
exponent difference between the real and imaginary parts. We assume
either the real or the imaginary part of u is not zero.
*/
dr = mpfr_zero_p (MPC_RE(u)) ? mpfr_get_exp (MPC_IM(u))
: mpfr_get_exp (MPC_RE(u));
di = mpfr_zero_p (MPC_IM(u)) ? dr : mpfr_get_exp (MPC_IM(u));
if (dr > di)
{
di = dr - di;
dr = 0;
}
else
{
dr = di - dr;
di = 0;
}
/* the term -3 takes into account the factor 4 in the complex error
(see algorithms.tex) plus one due to the exponent difference: if
z = a + I*b, where the relative error on z is at most 2^(-p), and
EXP(a) = EXP(b) + k, the relative error on b is at most 2^(k-p) */
if ((z_imag || mpfr_can_round (MPC_RE(u), p - 3 - dr, GMP_RNDN, GMP_RNDZ, pr)) &&
(z_real || mpfr_can_round (MPC_IM(u), p - 3 - di, GMP_RNDN, GMP_RNDZ, pi)))
break;
/* if Re(u) is not known to be zero, assume it is a normal number, i.e.,
neither zero, Inf or NaN, otherwise we might enter an infinite loop */
MPC_ASSERT (z_imag || mpfr_number_p (MPC_RE(u)));
/* idem for Im(u) */
MPC_ASSERT (z_real || mpfr_number_p (MPC_IM(u)));
if (ret == -2) /* we did not yet call mpc_pow_exact, or it aborted
because intermediate computations had > maxprec bits */
{
/* check exact cases (see algorithms.tex) */
if (y_real)
{
maxprec *= 2;
ret = mpc_pow_exact (z, x, MPC_RE(y), rnd, maxprec);
if (ret != -1 && ret != -2)
goto exact;
}
p += dr + di + 64;
}
else
p += p / 2;
mpc_set_prec (t, p + q);
mpc_set_prec (u, p);
}
if (z_real)
{
/* When the result is real (see algorithm.tex for details),
Im(x^y) =
+ sign(imag(y))*0i, if |x| > 1
+ sign(imag(x))*sign(real(y))*0i, if |x| = 1
- sign(imag(y))*0i, if |x| < 1
*/
mpfr_t n;
int inex, cx1;
int sign_zi;
/* cx1 < 0 if |x| < 1
cx1 = 0 if |x| = 1
cx1 > 0 if |x| > 1
*/
mpfr_init (n);
inex = mpc_norm (n, x, GMP_RNDN);
cx1 = mpfr_cmp_ui (n, 1);
if (cx1 == 0 && inex != 0)
cx1 = -inex;
sign_zi = (cx1 < 0 && mpfr_signbit (MPC_IM (y)) == 0)
|| (cx1 == 0
&& mpfr_signbit (MPC_IM (x)) != mpfr_signbit (MPC_RE (y)))
|| (cx1 > 0 && mpfr_signbit (MPC_IM (y)));
ret = mpfr_set (MPC_RE(z), MPC_RE(u), MPC_RND_RE(rnd));
/* warning: mpfr_set_ui does not set Im(z) to -0 if Im(rnd) = RNDD */
ret = MPC_INEX (ret, mpfr_set_ui (MPC_IM (z), 0, MPC_RND_IM (rnd)));
if (MPC_RND_IM (rnd) == GMP_RNDD || sign_zi)
mpc_conj (z, z, MPC_RNDNN);
mpfr_clear (n);
}
else if (z_imag)
{
ret = mpfr_set (MPC_IM(z), MPC_IM(u), MPC_RND_IM(rnd));
ret = MPC_INEX(mpfr_set_ui (MPC_RE(z), 0, MPC_RND_RE(rnd)), ret);
}
else
ret = mpc_set (z, u, rnd);
exact:
mpc_clear (t);
mpc_clear (u);
end:
return ret;
underflow:
/* If we have an underflow, we know that |z| is too small to be
represented, but depending on arg(z), we should return +/-0 +/- I*0.
We assume t is the approximation of y*log(x), thus we want
exp(t) = exp(Re(t))+exp(I*Im(t)).
FIXME: this part of code is not 100% rigorous, since we don't consider
rounding errors.
*/
mpc_init2 (u, 64);
mpfr_const_pi (MPC_RE(u), GMP_RNDN);
mpfr_div_2exp (MPC_RE(u), MPC_RE(u), 1, GMP_RNDN); /* Pi/2 */
mpfr_remquo (MPC_RE(u), &Q, MPC_IM(t), MPC_RE(u), GMP_RNDN);
if (mpfr_sgn (MPC_RE(u)) < 0)
Q--; /* corresponds to positive remainder */
mpfr_set_ui (MPC_RE(z), 0, GMP_RNDN);
mpfr_set_ui (MPC_IM(z), 0, GMP_RNDN);
switch (Q & 3)
{
case 0: /* first quadrant: round to (+0 +0) */
ret = MPC_INEX(-1, -1);
break;
case 1: /* second quadrant: round to (-0 +0) */
mpfr_neg (MPC_RE(z), MPC_RE(z), GMP_RNDN);
ret = MPC_INEX(1, -1);
break;
case 2: /* third quadrant: round to (-0 -0) */
mpfr_neg (MPC_RE(z), MPC_RE(z), GMP_RNDN);
mpfr_neg (MPC_IM(z), MPC_IM(z), GMP_RNDN);
ret = MPC_INEX(1, 1);
break;
case 3: /* fourth quadrant: round to (+0 -0) */
mpfr_neg (MPC_IM(z), MPC_IM(z), GMP_RNDN);
ret = MPC_INEX(-1, 1);
break;
}
goto clear_t_and_u;
overflow:
/* If we have an overflow, we know that |z| is too large to be
represented, but depending on arg(z), we should return +/-Inf +/- I*Inf.
We assume t is the approximation of y*log(x), thus we want
exp(t) = exp(Re(t))+exp(I*Im(t)).
FIXME: this part of code is not 100% rigorous, since we don't consider
rounding errors.
*/
mpc_init2 (u, 64);
mpfr_const_pi (MPC_RE(u), GMP_RNDN);
mpfr_div_2exp (MPC_RE(u), MPC_RE(u), 1, GMP_RNDN); /* Pi/2 */
/* the quotient is rounded to the nearest integer in mpfr_remquo */
mpfr_remquo (MPC_RE(u), &Q, MPC_IM(t), MPC_RE(u), GMP_RNDN);
if (mpfr_sgn (MPC_RE(u)) < 0)
Q--; /* corresponds to positive remainder */
switch (Q & 3)
{
case 0: /* first quadrant */
mpfr_set_inf (MPC_RE(z), 1);
mpfr_set_inf (MPC_IM(z), 1);
ret = MPC_INEX(1, 1);
break;
case 1: /* second quadrant */
mpfr_set_inf (MPC_RE(z), -1);
mpfr_set_inf (MPC_IM(z), 1);
ret = MPC_INEX(-1, 1);
break;
case 2: /* third quadrant */
mpfr_set_inf (MPC_RE(z), -1);
mpfr_set_inf (MPC_IM(z), -1);
ret = MPC_INEX(-1, -1);
break;
case 3: /* fourth quadrant */
mpfr_set_inf (MPC_RE(z), 1);
mpfr_set_inf (MPC_IM(z), -1);
ret = MPC_INEX(1, -1);
break;
}
clear_t_and_u:
mpc_clear (t);
mpc_clear (u);
return ret;
}
int
mpc_log (mpc_ptr rop, mpc_srcptr op, mpc_rnd_t rnd){
int ok, underflow = 0;
mpfr_srcptr x, y;
mpfr_t v, w;
mpfr_prec_t prec;
int loops;
int re_cmp, im_cmp;
int inex_re, inex_im;
int err;
mpfr_exp_t expw;
int sgnw;
/* special values: NaN and infinities */
if (!mpc_fin_p (op)) {
if (mpfr_nan_p (mpc_realref (op))) {
if (mpfr_inf_p (mpc_imagref (op)))
mpfr_set_inf (mpc_realref (rop), +1);
else
mpfr_set_nan (mpc_realref (rop));
mpfr_set_nan (mpc_imagref (rop));
inex_im = 0; /* Inf/NaN is exact */
}
else if (mpfr_nan_p (mpc_imagref (op))) {
if (mpfr_inf_p (mpc_realref (op)))
mpfr_set_inf (mpc_realref (rop), +1);
else
mpfr_set_nan (mpc_realref (rop));
mpfr_set_nan (mpc_imagref (rop));
inex_im = 0; /* Inf/NaN is exact */
}
else /* We have an infinity in at least one part. */ {
inex_im = mpfr_atan2 (mpc_imagref (rop), mpc_imagref (op), mpc_realref (op),
MPC_RND_IM (rnd));
mpfr_set_inf (mpc_realref (rop), +1);
}
return MPC_INEX(0, inex_im);
}
/* special cases: real and purely imaginary numbers */
re_cmp = mpfr_cmp_ui (mpc_realref (op), 0);
im_cmp = mpfr_cmp_ui (mpc_imagref (op), 0);
if (im_cmp == 0) {
if (re_cmp == 0) {
inex_im = mpfr_atan2 (mpc_imagref (rop), mpc_imagref (op), mpc_realref (op),
MPC_RND_IM (rnd));
mpfr_set_inf (mpc_realref (rop), -1);
inex_re = 0; /* -Inf is exact */
}
else if (re_cmp > 0) {
inex_re = mpfr_log (mpc_realref (rop), mpc_realref (op), MPC_RND_RE (rnd));
inex_im = mpfr_set (mpc_imagref (rop), mpc_imagref (op), MPC_RND_IM (rnd));
}
else {
/* op = x + 0*y; let w = -x = |x| */
int negative_zero;
mpfr_rnd_t rnd_im;
negative_zero = mpfr_signbit (mpc_imagref (op));
if (negative_zero)
rnd_im = INV_RND (MPC_RND_IM (rnd));
else
rnd_im = MPC_RND_IM (rnd);
w [0] = *mpc_realref (op);
MPFR_CHANGE_SIGN (w);
inex_re = mpfr_log (mpc_realref (rop), w, MPC_RND_RE (rnd));
inex_im = mpfr_const_pi (mpc_imagref (rop), rnd_im);
if (negative_zero) {
mpc_conj (rop, rop, MPC_RNDNN);
inex_im = -inex_im;
}
}
return MPC_INEX(inex_re, inex_im);
}
else if (re_cmp == 0) {
if (im_cmp > 0) {
inex_re = mpfr_log (mpc_realref (rop), mpc_imagref (op), MPC_RND_RE (rnd));
inex_im = mpfr_const_pi (mpc_imagref (rop), MPC_RND_IM (rnd));
/* division by 2 does not change the ternary flag */
mpfr_div_2ui (mpc_imagref (rop), mpc_imagref (rop), 1, GMP_RNDN);
}
else {
w [0] = *mpc_imagref (op);
MPFR_CHANGE_SIGN (w);
inex_re = mpfr_log (mpc_realref (rop), w, MPC_RND_RE (rnd));
inex_im = mpfr_const_pi (mpc_imagref (rop), INV_RND (MPC_RND_IM (rnd)));
/* division by 2 does not change the ternary flag */
mpfr_div_2ui (mpc_imagref (rop), mpc_imagref (rop), 1, GMP_RNDN);
mpfr_neg (mpc_imagref (rop), mpc_imagref (rop), GMP_RNDN);
inex_im = -inex_im; /* negate the ternary flag */
}
return MPC_INEX(inex_re, inex_im);
}
prec = MPC_PREC_RE(rop);
mpfr_init2 (w, 2);
/* let op = x + iy; log = 1/2 log (x^2 + y^2) + i atan2 (y, x) */
/* loop for the real part: 1/2 log (x^2 + y^2), fast, but unsafe */
/* implementation */
ok = 0;
for (loops = 1; !ok && loops <= 2; loops++) {
prec += mpc_ceil_log2 (prec) + 4;
mpfr_set_prec (w, prec);
mpc_abs (w, op, GMP_RNDN);
/* error 0.5 ulp */
if (mpfr_inf_p (w))
/* intermediate overflow; the logarithm may be representable.
Intermediate underflow is impossible. */
break;
mpfr_log (w, w, GMP_RNDN);
/* generic error of log: (2^(- exp(w)) + 0.5) ulp */
if (mpfr_zero_p (w))
/* impossible to round, switch to second algorithm */
break;
err = MPC_MAX (-mpfr_get_exp (w), 0) + 1;
/* number of lost digits */
ok = mpfr_can_round (w, prec - err, GMP_RNDN, GMP_RNDZ,
mpfr_get_prec (mpc_realref (rop)) + (MPC_RND_RE (rnd) == GMP_RNDN));
}
if (!ok) {
prec = MPC_PREC_RE(rop);
mpfr_init2 (v, 2);
/* compute 1/2 log (x^2 + y^2) = log |x| + 1/2 * log (1 + (y/x)^2)
if |x| >= |y|; otherwise, exchange x and y */
if (mpfr_cmpabs (mpc_realref (op), mpc_imagref (op)) >= 0) {
x = mpc_realref (op);
y = mpc_imagref (op);
}
else {
x = mpc_imagref (op);
y = mpc_realref (op);
}
do {
prec += mpc_ceil_log2 (prec) + 4;
mpfr_set_prec (v, prec);
mpfr_set_prec (w, prec);
mpfr_div (v, y, x, GMP_RNDD); /* error 1 ulp */
mpfr_sqr (v, v, GMP_RNDD);
/* generic error of multiplication:
1 + 2*1*(2+1*2^(1-prec)) <= 5.0625 since prec >= 6 */
mpfr_log1p (v, v, GMP_RNDD);
/* error 1 + 4*5.0625 = 21.25 , see algorithms.tex */
mpfr_div_2ui (v, v, 1, GMP_RNDD);
/* If the result is 0, then there has been an underflow somewhere. */
mpfr_abs (w, x, GMP_RNDN); /* exact */
mpfr_log (w, w, GMP_RNDN); /* error 0.5 ulp */
expw = mpfr_get_exp (w);
sgnw = mpfr_signbit (w);
mpfr_add (w, w, v, GMP_RNDN);
if (!sgnw) /* v is positive, so no cancellation;
error 22.25 ulp; error counts lost bits */
err = 5;
else
err = MPC_MAX (5 + mpfr_get_exp (v),
/* 21.25 ulp (v) rewritten in ulp (result, now in w) */
-1 + expw - mpfr_get_exp (w)
/* 0.5 ulp (previous w), rewritten in ulp (result) */
) + 2;
/* handle one special case: |x|=1, and (y/x)^2 underflows;
then 1/2*log(x^2+y^2) \approx 1/2*y^2 also underflows. */
if ( (mpfr_cmp_si (x, -1) == 0 || mpfr_cmp_ui (x, 1) == 0)
&& mpfr_zero_p (w))
underflow = 1;
} while (!underflow &&
!mpfr_can_round (w, prec - err, GMP_RNDN, GMP_RNDZ,
mpfr_get_prec (mpc_realref (rop)) + (MPC_RND_RE (rnd) == GMP_RNDN)));
mpfr_clear (v);
}
/* imaginary part */
inex_im = mpfr_atan2 (mpc_imagref (rop), mpc_imagref (op), mpc_realref (op),
MPC_RND_IM (rnd));
/* set the real part; cannot be done before if rop==op */
if (underflow)
/* create underflow in result */
inex_re = mpfr_set_ui_2exp (mpc_realref (rop), 1,
mpfr_get_emin_min () - 2, MPC_RND_RE (rnd));
else
inex_re = mpfr_set (mpc_realref (rop), w, MPC_RND_RE (rnd));
mpfr_clear (w);
return MPC_INEX(inex_re, inex_im);
}
/* Generic random tests with cancellations.
*
* In summary, we do 4000 tests of the following form:
* 1. We set the first MPFR_NCANCEL members of an array to random values,
* with a random exponent taken in 4 ranges, depending on the value of
* i % 4 (see code below).
* 2. For each of the next MPFR_NCANCEL iterations:
* A. we randomly permute some terms of the array (to make sure that a
* particular order doesn't have an influence on the result);
* B. we compute the sum in a random rounding mode;
* C. if this sum is zero, we end the current test (there is no longer
* anything interesting to test);
* D. we check that this sum is below some bound (chosen as infinite
* for the first iteration of (2), i.e. this test will be useful
* only for the next iterations, after cancellations);
* E. we put the opposite of this sum in the array, the goal being to
* introduce a chain of cancellations;
* F. we compute the bound for the next iteration, derived from (E).
* 3. We do another iteration like (2), but with reusing a random element
* of the array. This last test allows one to check the support of
* reused arguments. Before this support (r10467), it triggers an
* assertion failure with (almost?) all seeds, and if assertions are
* not checked, tsum fails in most cases but not all.
*/
static void
cancel (void)
{
mpfr_t x[2 * MPFR_NCANCEL], bound;
mpfr_ptr px[2 * MPFR_NCANCEL];
int i, j, k, n;
mpfr_init2 (bound, 2);
/* With 4000 tests, tsum will fail in most cases without support of
reused arguments (before r10467). */
for (i = 0; i < 4000; i++)
{
mpfr_set_inf (bound, 1);
for (n = 0; n <= numberof (x); n++)
{
mpfr_prec_t p;
mpfr_rnd_t rnd;
if (n < numberof (x))
{
px[n] = x[n];
p = MPFR_PREC_MIN + (randlimb () % 256);
mpfr_init2 (x[n], p);
k = n;
}
else
{
/* Reuse of a random member of the array. */
k = randlimb () % n;
}
if (n < MPFR_NCANCEL)
{
mpfr_exp_t e;
MPFR_ASSERTN (n < numberof (x));
e = (i & 1) ? 0 : mpfr_get_emin ();
tests_default_random (x[n], 256, e,
((i & 2) ? e + 2000 : mpfr_get_emax ()),
0);
}
else
{
/* random permutation with n random transpositions */
for (j = 0; j < n; j++)
{
int k1, k2;
k1 = randlimb () % (n-1);
k2 = randlimb () % (n-1);
mpfr_swap (x[k1], x[k2]);
}
rnd = RND_RAND ();
#if DEBUG
printf ("mpfr_sum cancellation test\n");
for (j = 0; j < n; j++)
{
printf (" x%d[%3ld] = ", j, mpfr_get_prec(x[j]));
mpfr_out_str (stdout, 16, 0, x[j], MPFR_RNDN);
printf ("\n");
}
printf (" rnd = %s, output prec = %ld\n",
mpfr_print_rnd_mode (rnd), mpfr_get_prec (x[n]));
#endif
mpfr_sum (x[k], px, n, rnd);
if (mpfr_zero_p (x[k]))
{
if (k == n)
n++;
break;
}
if (mpfr_cmpabs (x[k], bound) > 0)
{
printf ("Error in cancel on i = %d, n = %d\n", i, n);
printf ("Expected bound: ");
mpfr_dump (bound);
printf ("x[%d]: ", k);
mpfr_dump (x[k]);
exit (1);
}
if (k != n)
break;
/* For the bound, use MPFR_RNDU due to possible underflow.
It would be nice to add some specific underflow checks,
though there are already ones in check_underflow(). */
mpfr_set_ui_2exp (bound, 1,
mpfr_get_exp (x[n]) - p - (rnd == MPFR_RNDN),
MPFR_RNDU);
/* The next sum will be <= bound in absolute value
(the equality can be obtained in all rounding modes
since the sum will be rounded). */
mpfr_neg (x[n], x[n], MPFR_RNDN);
}
}
while (--n >= 0)
mpfr_clear (x[n]);
}
mpfr_clear (bound);
}
static void
tst (void)
{
int sv = sizeof (val) / sizeof (*val);
int i, j;
int rnd;
mpfr_t x, y, z, tmp;
mpfr_inits2 (53, x, y, z, tmp, (mpfr_ptr) 0);
for (i = 0; i < sv; i++)
for (j = 0; j < sv; j++)
RND_LOOP (rnd)
{
int exact, inex;
unsigned int flags;
if (my_setstr (x, val[i]) || my_setstr (y, val[j]))
{
printf ("internal error for (%d,%d,%d)\n", i, j, rnd);
exit (1);
}
mpfr_clear_flags ();
inex = mpfr_pow (z, x, y, (mpfr_rnd_t) rnd);
flags = __gmpfr_flags;
if (! MPFR_IS_NAN (z) && mpfr_nanflag_p ())
err ("got NaN flag without NaN value", i, j, rnd, z, inex);
if (MPFR_IS_NAN (z) && ! mpfr_nanflag_p ())
err ("got NaN value without NaN flag", i, j, rnd, z, inex);
if (inex != 0 && ! mpfr_inexflag_p ())
err ("got non-zero ternary value without inexact flag",
i, j, rnd, z, inex);
if (inex == 0 && mpfr_inexflag_p ())
err ("got null ternary value with inexact flag",
i, j, rnd, z, inex);
if (i >= 3 && j >= 3)
{
if (mpfr_underflow_p ())
err ("got underflow", i, j, rnd, z, inex);
if (mpfr_overflow_p ())
err ("got overflow", i, j, rnd, z, inex);
exact = MPFR_IS_SINGULAR (z) ||
(mpfr_mul_2ui (tmp, z, 16, MPFR_RNDN), mpfr_integer_p (tmp));
if (exact && inex != 0)
err ("got exact value with ternary flag different from 0",
i, j, rnd, z, inex);
if (! exact && inex == 0)
err ("got inexact value with ternary flag equal to 0",
i, j, rnd, z, inex);
}
if (MPFR_IS_ZERO (x) && ! MPFR_IS_NAN (y) && MPFR_NOTZERO (y))
{
if (MPFR_IS_NEG (y) && ! MPFR_IS_INF (z))
err ("expected an infinity", i, j, rnd, z, inex);
if (MPFR_IS_POS (y) && ! MPFR_IS_ZERO (z))
err ("expected a zero", i, j, rnd, z, inex);
if ((MPFR_IS_NEG (x) && is_odd (y)) ^ MPFR_IS_NEG (z))
err ("wrong sign", i, j, rnd, z, inex);
}
if (! MPFR_IS_NAN (x) && mpfr_cmp_si (x, -1) == 0)
{
/* x = -1 */
if (! (MPFR_IS_INF (y) || mpfr_integer_p (y)) &&
! MPFR_IS_NAN (z))
err ("expected NaN", i, j, rnd, z, inex);
if ((MPFR_IS_INF (y) || (mpfr_integer_p (y) && ! is_odd (y)))
&& ! mpfr_equal_p (z, __gmpfr_one))
err ("expected 1", i, j, rnd, z, inex);
if (is_odd (y) &&
(MPFR_IS_NAN (z) || mpfr_cmp_si (z, -1) != 0))
err ("expected -1", i, j, rnd, z, inex);
}
if ((mpfr_equal_p (x, __gmpfr_one) || MPFR_IS_ZERO (y)) &&
! mpfr_equal_p (z, __gmpfr_one))
err ("expected 1", i, j, rnd, z, inex);
if (MPFR_IS_PURE_FP (x) && MPFR_IS_NEG (x) &&
MPFR_IS_FP (y) && ! mpfr_integer_p (y) &&
! MPFR_IS_NAN (z))
err ("expected NaN", i, j, rnd, z, inex);
if (MPFR_IS_INF (y) && MPFR_NOTZERO (x))
{
int cmpabs1 = mpfr_cmpabs (x, __gmpfr_one);
if ((MPFR_IS_NEG (y) ? (cmpabs1 < 0) : (cmpabs1 > 0)) &&
! (MPFR_IS_POS (z) && MPFR_IS_INF (z)))
err ("expected +Inf", i, j, rnd, z, inex);
if ((MPFR_IS_NEG (y) ? (cmpabs1 > 0) : (cmpabs1 < 0)) &&
! (MPFR_IS_POS (z) && MPFR_IS_ZERO (z)))
err ("expected +0", i, j, rnd, z, inex);
}
if (MPFR_IS_INF (x) && ! MPFR_IS_NAN (y) && MPFR_NOTZERO (y))
{
if (MPFR_IS_POS (y) && ! MPFR_IS_INF (z))
err ("expected an infinity", i, j, rnd, z, inex);
if (MPFR_IS_NEG (y) && ! MPFR_IS_ZERO (z))
err ("expected a zero", i, j, rnd, z, inex);
if ((MPFR_IS_NEG (x) && is_odd (y)) ^ MPFR_IS_NEG (z))
err ("wrong sign", i, j, rnd, z, inex);
}
test_others (val[i], val[j], (mpfr_rnd_t) rnd, x, y, z, inex, flags,
"tst");
}
mpfr_clears (x, y, z, tmp, (mpfr_ptr) 0);
}
void externalPlot(char *library, mpfr_t a, mpfr_t b, mp_prec_t samplingPrecision, int random, node *func, int mode, mp_prec_t prec, char *name, int type) {
void *descr;
void (*myFunction)(mpfr_t, mpfr_t);
char *error;
mpfr_t x_h,x,y,temp,perturb,ulp,min_value;
double xd, yd;
FILE *file;
gmp_randstate_t state;
char *gplotname;
char *dataname;
char *outputname;
gmp_randinit_default (state);
if(samplingPrecision > prec) {
sollyaFprintf(stderr, "Error: you must use a sampling precision lower than the current precision\n");
return;
}
descr = dlopen(library, RTLD_NOW);
if (descr==NULL) {
sollyaFprintf(stderr, "Error: the given library (%s) is not available (%s)!\n",library,dlerror());
return;
}
dlerror(); /* Clear any existing error */
myFunction = (void (*)(mpfr_t, mpfr_t)) dlsym(descr, "f");
if ((error = dlerror()) != NULL) {
sollyaFprintf(stderr, "Error: the function f cannot be found in library %s (%s)\n",library,error);
return;
}
if(name==NULL) {
gplotname = (char *)safeCalloc(13 + strlen(PACKAGE_NAME), sizeof(char));
sprintf(gplotname,"/tmp/%s-%04d.p",PACKAGE_NAME,fileNumber);
dataname = (char *)safeCalloc(15 + strlen(PACKAGE_NAME), sizeof(char));
sprintf(dataname,"/tmp/%s-%04d.dat",PACKAGE_NAME,fileNumber);
outputname = (char *)safeCalloc(1, sizeof(char));
fileNumber++;
if (fileNumber >= NUMBEROFFILES) fileNumber=0;
}
else {
gplotname = (char *)safeCalloc(strlen(name)+3,sizeof(char));
sprintf(gplotname,"%s.p",name);
dataname = (char *)safeCalloc(strlen(name)+5,sizeof(char));
sprintf(dataname,"%s.dat",name);
outputname = (char *)safeCalloc(strlen(name)+5,sizeof(char));
if ((type==PLOTPOSTSCRIPT) || (type==PLOTPOSTSCRIPTFILE)) sprintf(outputname,"%s.eps",name);
}
/* Beginning of the interesting part of the code */
file = fopen(gplotname, "w");
if (file == NULL) {
sollyaFprintf(stderr,"Error: the file %s requested by plot could not be opened for writing: ",gplotname);
sollyaFprintf(stderr,"\"%s\".\n",strerror(errno));
return;
}
sollyaFprintf(file, "# Gnuplot script generated by %s\n",PACKAGE_NAME);
if ((type==PLOTPOSTSCRIPT) || (type==PLOTPOSTSCRIPTFILE)) sollyaFprintf(file,"set terminal postscript eps color\nset out \"%s\"\n",outputname);
sollyaFprintf(file, "set xrange [%1.50e:%1.50e]\n", mpfr_get_d(a, GMP_RNDD),mpfr_get_d(b, GMP_RNDU));
sollyaFprintf(file, "plot \"%s\" using 1:2 with dots t \"\"\n",dataname);
fclose(file);
file = fopen(dataname, "w");
if (file == NULL) {
sollyaFprintf(stderr,"Error: the file %s requested by plot could not be opened for writing: ",dataname);
sollyaFprintf(stderr,"\"%s\".\n",strerror(errno));
return;
}
mpfr_init2(x_h,samplingPrecision);
mpfr_init2(perturb, prec);
mpfr_init2(x,prec);
mpfr_init2(y,prec);
mpfr_init2(temp,prec);
mpfr_init2(ulp,prec);
mpfr_init2(min_value,53);
mpfr_sub(min_value, b, a, GMP_RNDN);
mpfr_div_2ui(min_value, min_value, 12, GMP_RNDN);
mpfr_set(x_h,a,GMP_RNDD);
while(mpfr_less_p(x_h,b)) {
mpfr_set(x, x_h, GMP_RNDN); // exact
if (mpfr_zero_p(x_h)) {
mpfr_set(x_h, min_value, GMP_RNDU);
}
else {
if (mpfr_cmpabs(x_h, min_value) < 0) mpfr_set_d(x_h, 0., GMP_RNDN);
else mpfr_nextabove(x_h);
}
if(random) {
mpfr_sub(ulp, x_h, x, GMP_RNDN);
mpfr_urandomb(perturb, state);
mpfr_mul(perturb, perturb, ulp, GMP_RNDN);
mpfr_add(x, x, perturb, GMP_RNDN);
}
(*myFunction)(temp,x);
evaluateFaithful(y, func, x,prec);
mpfr_sub(temp, temp, y, GMP_RNDN);
if(mode==RELATIVE) mpfr_div(temp, temp, y, GMP_RNDN);
xd = mpfr_get_d(x, GMP_RNDN);
if (xd >= MAX_VALUE_GNUPLOT) xd = MAX_VALUE_GNUPLOT;
if (xd <= -MAX_VALUE_GNUPLOT) xd = -MAX_VALUE_GNUPLOT;
sollyaFprintf(file, "%1.50e",xd);
if (!mpfr_number_p(temp)) {
if (verbosity >= 2) {
changeToWarningMode();
sollyaPrintf("Information: function undefined or not evaluable in point %s = ",variablename);
printValue(&x);
sollyaPrintf("\nThis point will not be plotted.\n");
restoreMode();
}
}
yd = mpfr_get_d(temp, GMP_RNDN);
if (yd >= MAX_VALUE_GNUPLOT) yd = MAX_VALUE_GNUPLOT;
if (yd <= -MAX_VALUE_GNUPLOT) yd = -MAX_VALUE_GNUPLOT;
sollyaFprintf(file, "\t%1.50e\n", yd);
}
fclose(file);
/* End of the interesting part.... */
dlclose(descr);
mpfr_clear(x);
mpfr_clear(y);
mpfr_clear(x_h);
mpfr_clear(temp);
mpfr_clear(perturb);
mpfr_clear(ulp);
mpfr_clear(min_value);
if ((name==NULL) || (type==PLOTFILE)) {
if (fork()==0) {
daemon(1,1);
execlp("gnuplot", "gnuplot", "-persist", gplotname, NULL);
perror("An error occurred when calling gnuplot ");
exit(1);
}
else wait(NULL);
}
else { /* Case we have an output: no daemon */
if (fork()==0) {
execlp("gnuplot", "gnuplot", "-persist", gplotname, NULL);
perror("An error occurred when calling gnuplot ");
exit(1);
}
else {
wait(NULL);
if((type==PLOTPOSTSCRIPT)) {
remove(gplotname);
remove(dataname);
}
}
}
free(gplotname);
free(dataname);
free(outputname);
return;
}
void zeroize_tiny(gmp_RR epsilon, ElementType &a) const
{
if (mpfr_cmpabs(&a,epsilon) < 0)
set_zero(a);
}
int
main (void)
{
mpfr_t xx, yy;
int c;
tests_start_mpfr ();
mpfr_init2 (xx, 2);
mpfr_init2 (yy, 2);
mpfr_clear_erangeflag ();
MPFR_SET_NAN (xx);
MPFR_SET_NAN (yy);
if (mpfr_cmpabs (xx, yy) != 0)
ERROR ("mpfr_cmpabs (NAN,NAN) returns non-zero\n");
if (!mpfr_erangeflag_p ())
ERROR ("mpfr_cmpabs (NAN,NAN) doesn't set erange flag\n");
mpfr_set_str_binary (xx, "0.10E0");
mpfr_set_str_binary (yy, "-0.10E0");
if (mpfr_cmpabs (xx, yy) != 0)
ERROR ("mpfr_cmpabs (xx, yy) returns non-zero for prec=2\n");
mpfr_set_prec (xx, 65);
mpfr_set_prec (yy, 65);
mpfr_set_str_binary (xx, "-0.10011010101000110101010000000011001001001110001011101011111011101E623");
mpfr_set_str_binary (yy, "0.10011010101000110101010000000011001001001110001011101011111011100E623");
if (mpfr_cmpabs (xx, yy) <= 0)
ERROR ("Error (1) in mpfr_cmpabs\n");
mpfr_set_str_binary (xx, "-0.10100010001110110111000010001000010011111101000100011101000011100");
mpfr_set_str_binary (yy, "-0.10100010001110110111000010001000010011111101000100011101000011011");
if (mpfr_cmpabs (xx, yy) <= 0)
ERROR ("Error (2) in mpfr_cmpabs\n");
mpfr_set_prec (xx, 160);
mpfr_set_prec (yy, 160);
mpfr_set_str_binary (xx, "0.1E1");
mpfr_set_str_binary (yy, "-0.1111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111100000110001110100");
if (mpfr_cmpabs (xx, yy) <= 0)
ERROR ("Error (3) in mpfr_cmpabs\n");
mpfr_set_prec(xx, 53);
mpfr_set_prec(yy, 200);
mpfr_set_ui (xx, 1, (mpfr_rnd_t) 0);
mpfr_set_ui (yy, 1, (mpfr_rnd_t) 0);
if (mpfr_cmpabs(xx, yy) != 0)
ERROR ("Error in mpfr_cmpabs: 1.0 != 1.0\n");
mpfr_set_prec (yy, 31);
mpfr_set_str (xx, "-1.0000000002", 10, (mpfr_rnd_t) 0);
mpfr_set_ui (yy, 1, (mpfr_rnd_t) 0);
if (!(mpfr_cmpabs(xx,yy)>0))
ERROR ("Error in mpfr_cmpabs: not 1.0000000002 > 1.0\n");
mpfr_set_prec(yy, 53);
mpfr_set_ui(xx, 0, MPFR_RNDN);
mpfr_set_str (yy, "-0.1", 10, MPFR_RNDN);
if (mpfr_cmpabs(xx, yy) >= 0)
ERROR ("Error in mpfr_cmpabs(0.0, 0.1)\n");
mpfr_set_inf (xx, -1);
mpfr_set_str (yy, "23489745.0329", 10, MPFR_RNDN);
if (mpfr_cmpabs(xx, yy) <= 0)
ERROR ("Error in mpfr_cmp(-Inf, 23489745.0329)\n");
mpfr_set_inf (xx, 1);
mpfr_set_inf (yy, -1);
if (mpfr_cmpabs(xx, yy) != 0)
ERROR ("Error in mpfr_cmpabs(Inf, -Inf)\n");
mpfr_set_inf (yy, -1);
mpfr_set_str (xx, "2346.09234", 10, MPFR_RNDN);
if (mpfr_cmpabs (xx, yy) >= 0)
ERROR ("Error in mpfr_cmpabs(-Inf, 2346.09234)\n");
mpfr_set_prec (xx, 2);
mpfr_set_prec (yy, 128);
mpfr_set_str_binary (xx, "0.1E10");
mpfr_set_str_binary (yy,
"0.100000000000000000000000000000000000000000000000"
"00000000000000000000000000000000000000000000001E10");
if (mpfr_cmpabs (xx, yy) >= 0)
ERROR ("Error in mpfr_cmpabs(10.235, 2346.09234)\n");
mpfr_swap (xx, yy);
if (mpfr_cmpabs(xx, yy) <= 0)
ERROR ("Error in mpfr_cmpabs(2346.09234, 10.235)\n");
mpfr_swap (xx, yy);
/* Check for NAN */
mpfr_set_nan (xx);
mpfr_clear_erangeflag ();
c = (mpfr_cmp) (xx, yy);
if (c != 0 || !mpfr_erangeflag_p () )
{
printf ("NAN error (1)\n");
exit (1);
}
mpfr_clear_erangeflag ();
c = (mpfr_cmp) (yy, xx);
if (c != 0 || !mpfr_erangeflag_p () )
{
printf ("NAN error (2)\n");
exit (1);
}
mpfr_clear_erangeflag ();
c = (mpfr_cmp) (xx, xx);
if (c != 0 || !mpfr_erangeflag_p () )
{
printf ("NAN error (3)\n");
exit (1);
}
mpfr_clear (xx);
mpfr_clear (yy);
tests_end_mpfr ();
return 0;
}