int
main (int argc, char *argv[])
{
mpfr_t x, y, z, s;
MPFR_SAVE_EXPO_DECL (expo);
tests_start_mpfr ();
bug20101018 ();
mpfr_init (x);
mpfr_init (s);
mpfr_init (y);
mpfr_init (z);
/* check special cases */
mpfr_set_prec (x, 2);
mpfr_set_prec (y, 2);
mpfr_set_prec (z, 2);
mpfr_set_prec (s, 2);
mpfr_set_str (x, "-0.75", 10, MPFR_RNDN);
mpfr_set_str (y, "0.5", 10, MPFR_RNDN);
mpfr_set_str (z, "0.375", 10, MPFR_RNDN);
mpfr_fma (s, x, y, z, MPFR_RNDU); /* result is 0 */
if (mpfr_cmp_ui(s, 0))
{
printf("Error: -0.75 * 0.5 + 0.375 should be equal to 0 for prec=2\n");
exit(1);
}
mpfr_set_prec (x, 27);
mpfr_set_prec (y, 27);
mpfr_set_prec (z, 27);
mpfr_set_prec (s, 27);
mpfr_set_str_binary (x, "1.11111111111111111111111111e-1");
mpfr_set (y, x, MPFR_RNDN);
mpfr_set_str_binary (z, "-1.00011110100011001011001001e-1");
if (mpfr_fma (s, x, y, z, MPFR_RNDN) >= 0)
{
printf ("Wrong inexact flag for x=y=1-2^(-27)\n");
exit (1);
}
mpfr_set_nan (x);
mpfr_urandomb (y, RANDS);
mpfr_urandomb (z, RANDS);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_nan_p (s))
{
printf ("evaluation of function in x=NAN does not return NAN");
exit (1);
}
mpfr_set_nan (y);
mpfr_urandomb (x, RANDS);
mpfr_urandomb (z, RANDS);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_nan_p(s))
{
printf ("evaluation of function in y=NAN does not return NAN");
exit (1);
}
mpfr_set_nan (z);
mpfr_urandomb (y, RANDS);
mpfr_urandomb (x, RANDS);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_nan_p (s))
{
printf ("evaluation of function in z=NAN does not return NAN");
exit (1);
}
mpfr_set_inf (x, 1);
mpfr_set_inf (y, 1);
mpfr_set_inf (z, 1);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_inf_p (s) || mpfr_sgn (s) < 0)
{
printf ("Error for (+inf) * (+inf) + (+inf)\n");
exit (1);
}
mpfr_set_inf (x, -1);
mpfr_set_inf (y, -1);
mpfr_set_inf (z, 1);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_inf_p (s) || mpfr_sgn (s) < 0)
{
printf ("Error for (-inf) * (-inf) + (+inf)\n");
exit (1);
}
mpfr_set_inf (x, 1);
mpfr_set_inf (y, -1);
mpfr_set_inf (z, -1);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_inf_p (s) || mpfr_sgn (s) > 0)
{
printf ("Error for (+inf) * (-inf) + (-inf)\n");
exit (1);
}
mpfr_set_inf (x, -1);
mpfr_set_inf (y, 1);
mpfr_set_inf (z, -1);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_inf_p (s) || mpfr_sgn (s) > 0)
{
printf ("Error for (-inf) * (+inf) + (-inf)\n");
exit (1);
}
mpfr_set_inf (x, 1);
mpfr_set_ui (y, 0, MPFR_RNDN);
mpfr_urandomb (z, RANDS);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_nan_p (s))
{
printf ("evaluation of function in x=INF y=0 does not return NAN");
exit (1);
}
mpfr_set_inf (y, 1);
mpfr_set_ui (x, 0, MPFR_RNDN);
mpfr_urandomb (z, RANDS);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_nan_p (s))
{
printf ("evaluation of function in x=0 y=INF does not return NAN");
exit (1);
}
mpfr_set_inf (x, 1);
mpfr_urandomb (y, RANDS); /* always positive */
mpfr_set_inf (z, -1);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_nan_p (s))
{
printf ("evaluation of function in x=INF y>0 z=-INF does not return NAN");
exit (1);
}
mpfr_set_inf (y, 1);
mpfr_urandomb (x, RANDS);
mpfr_set_inf (z, -1);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_nan_p (s))
{
printf ("evaluation of function in x>0 y=INF z=-INF does not return NAN");
exit (1);
}
mpfr_set_inf (x, 1);
mpfr_urandomb (y, RANDS);
mpfr_urandomb (z, RANDS);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_inf_p (s) || mpfr_sgn (s) < 0)
{
printf ("evaluation of function in x=INF does not return INF");
exit (1);
}
mpfr_set_inf (y, 1);
mpfr_urandomb (x, RANDS);
mpfr_urandomb (z, RANDS);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_inf_p (s) || mpfr_sgn (s) < 0)
{
printf ("evaluation of function in y=INF does not return INF");
exit (1);
}
mpfr_set_inf (z, 1);
mpfr_urandomb (x, RANDS);
mpfr_urandomb (y, RANDS);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (!mpfr_inf_p (s) || mpfr_sgn (s) < 0)
{
printf ("evaluation of function in z=INF does not return INF");
exit (1);
}
mpfr_set_ui (x, 0, MPFR_RNDN);
mpfr_urandomb (y, RANDS);
mpfr_urandomb (z, RANDS);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (mpfr_cmp (s, z))
{
printf ("evaluation of function in x=0 does not return z\n");
exit (1);
}
mpfr_set_ui (y, 0, MPFR_RNDN);
mpfr_urandomb (x, RANDS);
mpfr_urandomb (z, RANDS);
mpfr_fma (s, x, y, z, MPFR_RNDN);
if (mpfr_cmp (s, z))
{
printf ("evaluation of function in y=0 does not return z\n");
exit (1);
}
{
mpfr_prec_t prec;
mpfr_t t, slong;
mpfr_rnd_t rnd;
int inexact, compare;
unsigned int n;
mpfr_prec_t p0=2, p1=200;
unsigned int N=200;
mpfr_init (t);
mpfr_init (slong);
/* generic test */
for (prec = p0; prec <= p1; prec++)
{
mpfr_set_prec (x, prec);
mpfr_set_prec (y, prec);
mpfr_set_prec (z, prec);
mpfr_set_prec (s, prec);
mpfr_set_prec (t, prec);
for (n=0; n<N; n++)
{
mpfr_urandomb (x, RANDS);
mpfr_urandomb (y, RANDS);
mpfr_urandomb (z, RANDS);
if (randlimb () % 2)
mpfr_neg (x, x, MPFR_RNDN);
if (randlimb () % 2)
mpfr_neg (y, y, MPFR_RNDN);
if (randlimb () % 2)
mpfr_neg (z, z, MPFR_RNDN);
rnd = RND_RAND ();
mpfr_set_prec (slong, 2 * prec);
if (mpfr_mul (slong, x, y, rnd))
{
printf ("x*y should be exact\n");
exit (1);
}
compare = mpfr_add (t, slong, z, rnd);
inexact = mpfr_fma (s, x, y, z, rnd);
if (mpfr_cmp (s, t))
{
printf ("results differ for x=");
mpfr_out_str (stdout, 2, prec, x, MPFR_RNDN);
printf (" y=");
mpfr_out_str (stdout, 2, prec, y, MPFR_RNDN);
printf (" z=");
mpfr_out_str (stdout, 2, prec, z, MPFR_RNDN);
printf (" prec=%u rnd_mode=%s\n", (unsigned int) prec,
mpfr_print_rnd_mode (rnd));
printf ("got ");
mpfr_out_str (stdout, 2, prec, s, MPFR_RNDN);
puts ("");
printf ("expected ");
mpfr_out_str (stdout, 2, prec, t, MPFR_RNDN);
puts ("");
printf ("approx ");
mpfr_print_binary (slong);
puts ("");
exit (1);
}
if (((inexact == 0) && (compare != 0)) ||
((inexact < 0) && (compare >= 0)) ||
((inexact > 0) && (compare <= 0)))
{
printf ("Wrong inexact flag for rnd=%s: expected %d, got %d\n",
mpfr_print_rnd_mode (rnd), compare, inexact);
printf (" x="); mpfr_out_str (stdout, 2, 0, x, MPFR_RNDN);
printf (" y="); mpfr_out_str (stdout, 2, 0, y, MPFR_RNDN);
printf (" z="); mpfr_out_str (stdout, 2, 0, z, MPFR_RNDN);
printf (" s="); mpfr_out_str (stdout, 2, 0, s, MPFR_RNDN);
printf ("\n");
exit (1);
}
}
}
mpfr_clear (t);
mpfr_clear (slong);
}
mpfr_clear (x);
mpfr_clear (y);
mpfr_clear (z);
mpfr_clear (s);
test_exact ();
MPFR_SAVE_EXPO_MARK (expo);
test_overflow1 ();
test_overflow2 ();
test_underflow1 ();
test_underflow2 ();
MPFR_SAVE_EXPO_FREE (expo);
tests_end_mpfr ();
return 0;
}
int
mpfr_yn (mpfr_ptr res, long n, mpfr_srcptr z, mp_rnd_t r)
{
int inex;
unsigned long absn;
mp_prec_t prec;
mp_exp_t err1, err2, err3;
mpfr_t y, s1, s2, s3;
MPFR_ZIV_DECL (loop);
MPFR_LOG_FUNC (("x[%#R]=%R n=%d rnd=%d", z, z, n, r),
("y[%#R]=%R", res, res));
absn = SAFE_ABS (unsigned long, n);
if (MPFR_UNLIKELY (MPFR_IS_SINGULAR (z)))
{
if (MPFR_IS_NAN (z))
{
MPFR_SET_NAN (res); /* y(n,NaN) = NaN */
MPFR_RET_NAN;
}
/* y(n,z) tends to zero when z goes to +Inf, oscillating around
0. We choose to return +0 in that case. */
else if (MPFR_IS_INF (z))
{
if (MPFR_SIGN(z) > 0)
return mpfr_set_ui (res, 0, r);
else /* y(n,-Inf) = NaN */
{
MPFR_SET_NAN (res);
MPFR_RET_NAN;
}
}
else /* y(n,z) tends to -Inf for n >= 0 or n even, to +Inf otherwise,
when z goes to zero */
{
MPFR_SET_INF(res);
if (n >= 0 || (n & 1) == 0)
MPFR_SET_NEG(res);
else
MPFR_SET_POS(res);
MPFR_RET(0);
}
}
/* for z < 0, y(n,z) is imaginary except when j(n,|z|) = 0, which we
assume does not happen for a rational z. */
if (MPFR_SIGN(z) < 0)
{
MPFR_SET_NAN (res);
MPFR_RET_NAN;
}
/* now z is not singular, and z > 0 */
/* Deal with tiny arguments. We have:
y0(z) = 2 log(z)/Pi + 2 (euler - log(2))/Pi + O(log(z)*z^2), more
precisely for 0 <= z <= 1/2, with g(z) = 2/Pi + 2(euler-log(2))/Pi/log(z),
g(z) - 0.41*z^2 < y0(z)/log(z) < g(z)
thus since log(z) is negative:
g(z)*log(z) < y0(z) < (g(z) - z^2/2)*log(z)
and since |g(z)| >= 0.63 for 0 <= z <= 1/2, the relative error on
y0(z)/log(z) is bounded by 0.41*z^2/0.63 <= 0.66*z^2.
Note: we use both the main term in log(z) and the constant term, because
otherwise the relative error would be only in 1/log(|log(z)|).
*/
if (n == 0 && MPFR_EXP(z) < - (mp_exp_t) (MPFR_PREC(res) / 2))
{
mpfr_t l, h, t, logz;
int ok, inex2;
prec = MPFR_PREC(res) + 10;
mpfr_init2 (l, prec);
mpfr_init2 (h, prec);
mpfr_init2 (t, prec);
mpfr_init2 (logz, prec);
/* first enclose log(z) + euler - log(2) = log(z/2) + euler */
mpfr_log (logz, z, GMP_RNDD); /* lower bound of log(z) */
mpfr_set (h, logz, GMP_RNDU); /* exact */
mpfr_nextabove (h); /* upper bound of log(z) */
mpfr_const_euler (t, GMP_RNDD); /* lower bound of euler */
mpfr_add (l, logz, t, GMP_RNDD); /* lower bound of log(z) + euler */
mpfr_nextabove (t); /* upper bound of euler */
mpfr_add (h, h, t, GMP_RNDU); /* upper bound of log(z) + euler */
mpfr_const_log2 (t, GMP_RNDU); /* upper bound of log(2) */
mpfr_sub (l, l, t, GMP_RNDD); /* lower bound of log(z/2) + euler */
mpfr_nextbelow (t); /* lower bound of log(2) */
mpfr_sub (h, h, t, GMP_RNDU); /* upper bound of log(z/2) + euler */
mpfr_const_pi (t, GMP_RNDU); /* upper bound of Pi */
mpfr_div (l, l, t, GMP_RNDD); /* lower bound of (log(z/2)+euler)/Pi */
mpfr_nextbelow (t); /* lower bound of Pi */
mpfr_div (h, h, t, GMP_RNDD); /* upper bound of (log(z/2)+euler)/Pi */
mpfr_mul_2ui (l, l, 1, GMP_RNDD); /* lower bound on g(z)*log(z) */
mpfr_mul_2ui (h, h, 1, GMP_RNDU); /* upper bound on g(z)*log(z) */
/* we now have l <= g(z)*log(z) <= h, and we need to add -z^2/2*log(z)
to h */
mpfr_mul (t, z, z, GMP_RNDU); /* upper bound on z^2 */
/* since logz is negative, a lower bound corresponds to an upper bound
for its absolute value */
mpfr_neg (t, t, GMP_RNDD);
mpfr_div_2ui (t, t, 1, GMP_RNDD);
mpfr_mul (t, t, logz, GMP_RNDU); /* upper bound on z^2/2*log(z) */
/* an underflow may happen in the above instructions, clear flag */
mpfr_clear_underflow ();
mpfr_add (h, h, t, GMP_RNDU);
inex = mpfr_prec_round (l, MPFR_PREC(res), r);
inex2 = mpfr_prec_round (h, MPFR_PREC(res), r);
/* we need h=l and inex=inex2 */
ok = (inex == inex2) && (mpfr_cmp (l, h) == 0);
if (ok)
mpfr_set (res, h, r); /* exact */
mpfr_clear (l);
mpfr_clear (h);
mpfr_clear (t);
mpfr_clear (logz);
if (ok)
return inex;
}
/* small argument check for y1(z) = -2/Pi/z + O(log(z)):
for 0 <= z <= 1, |y1(z) + 2/Pi/z| <= 0.25 */
if (n == 1 && MPFR_EXP(z) + 1 < - (mp_exp_t) MPFR_PREC(res))
{
mpfr_t y;
int ok;
/* since 2/Pi > 0.5, and |y1(z)| >= |2/Pi/z|, if z <= 2^(-emax-1),
then |y1(z)| > 2^emax */
prec = MPFR_PREC(res) + 10;
mpfr_init2 (y, prec);
mpfr_const_pi (y, GMP_RNDU); /* Pi*(1+u)^2, where here and below u
represents a quantity <= 1/2^prec */
mpfr_mul (y, y, z, GMP_RNDU); /* Pi*z * (1+u)^4, upper bound */
mpfr_ui_div (y, 2, y, GMP_RNDZ); /* 2/Pi/z * (1+u)^6, lower bound */
mpfr_neg (y, y, GMP_RNDN);
if (mpfr_overflow_p ())
{
mpfr_clear (y);
return mpfr_overflow (res, r, -1);
}
/* (1+u)^6 can be written 1+7u [for another value of u], thus the
error on 2/Pi/z is less than 7ulp(y). The truncation error is less
than 1/4, thus if ulp(y)>=1/4, the total error is less than 8ulp(y),
otherwise it is less than 1/4+7/8 <= 2. */
if (MPFR_EXP(y) + 2 >= MPFR_PREC(y)) /* ulp(y) >= 1/4 */
err1 = 3;
else /* ulp(y) <= 1/8 */
err1 = (mp_exp_t) MPFR_PREC(y) - MPFR_EXP(y) + 1;
ok = MPFR_CAN_ROUND (y, prec - err1, MPFR_PREC(res), r);
if (ok)
inex = mpfr_set (res, y, r);
mpfr_clear (y);
if (ok)
return inex;
}
/* we can use the asymptotic expansion as soon as z > p log(2)/2,
but to get some margin we use it for z > p/2 */
if (mpfr_cmp_ui (z, MPFR_PREC(res) / 2 + 3) > 0)
{
inex = mpfr_yn_asympt (res, n, z, r);
if (inex != 0)
return inex;
}
mpfr_init (y);
mpfr_init (s1);
mpfr_init (s2);
mpfr_init (s3);
prec = MPFR_PREC(res) + 2 * MPFR_INT_CEIL_LOG2 (MPFR_PREC (res)) + 13;
MPFR_ZIV_INIT (loop, prec);
for (;;)
{
mpfr_set_prec (y, prec);
mpfr_set_prec (s1, prec);
mpfr_set_prec (s2, prec);
mpfr_set_prec (s3, prec);
mpfr_mul (y, z, z, GMP_RNDN);
mpfr_div_2ui (y, y, 2, GMP_RNDN); /* z^2/4 */
/* store (z/2)^n temporarily in s2 */
mpfr_pow_ui (s2, z, absn, GMP_RNDN);
mpfr_div_2si (s2, s2, absn, GMP_RNDN);
/* compute S1 * (z/2)^(-n) */
if (n == 0)
{
mpfr_set_ui (s1, 0, GMP_RNDN);
err1 = 0;
}
else
err1 = mpfr_yn_s1 (s1, y, absn - 1);
mpfr_div (s1, s1, s2, GMP_RNDN); /* (z/2)^(-n) * S1 */
/* See algorithms.tex: the relative error on s1 is bounded by
(3n+3)*2^(e+1-prec). */
err1 = MPFR_INT_CEIL_LOG2 (3 * absn + 3) + err1 + 1;
/* rel_err(s1) <= 2^(err1-prec), thus err(s1) <= 2^err1 ulps */
/* compute (z/2)^n * S3 */
mpfr_neg (y, y, GMP_RNDN); /* -z^2/4 */
err3 = mpfr_yn_s3 (s3, y, s2, absn); /* (z/2)^n * S3 */
/* the error on s3 is bounded by 2^err3 ulps */
/* add s1+s3 */
err1 += MPFR_EXP(s1);
mpfr_add (s1, s1, s3, GMP_RNDN);
/* the error is bounded by 1/2 + 2^err1*2^(- EXP(s1))
+ 2^err3*2^(EXP(s3) - EXP(s1)) */
err3 += MPFR_EXP(s3);
err1 = (err3 > err1) ? err3 + 1 : err1 + 1;
err1 -= MPFR_EXP(s1);
err1 = (err1 >= 0) ? err1 + 1 : 1;
/* now the error on s1 is bounded by 2^err1*ulp(s1) */
/* compute S2 */
mpfr_div_2ui (s2, z, 1, GMP_RNDN); /* z/2 */
mpfr_log (s2, s2, GMP_RNDN); /* log(z/2) */
mpfr_const_euler (s3, GMP_RNDN);
err2 = MPFR_EXP(s2) > MPFR_EXP(s3) ? MPFR_EXP(s2) : MPFR_EXP(s3);
mpfr_add (s2, s2, s3, GMP_RNDN); /* log(z/2) + gamma */
err2 -= MPFR_EXP(s2);
mpfr_mul_2ui (s2, s2, 1, GMP_RNDN); /* 2*(log(z/2) + gamma) */
mpfr_jn (s3, absn, z, GMP_RNDN); /* Jn(z) */
mpfr_mul (s2, s2, s3, GMP_RNDN); /* 2*(log(z/2) + gamma)*Jn(z) */
err2 += 4; /* the error on s2 is bounded by 2^err2 ulps, see
algorithms.tex */
/* add all three sums */
err1 += MPFR_EXP(s1); /* the error on s1 is bounded by 2^err1 */
err2 += MPFR_EXP(s2); /* the error on s2 is bounded by 2^err2 */
mpfr_sub (s2, s2, s1, GMP_RNDN); /* s2 - (s1+s3) */
err2 = (err1 > err2) ? err1 + 1 : err2 + 1;
err2 -= MPFR_EXP(s2);
err2 = (err2 >= 0) ? err2 + 1 : 1;
/* now the error on s2 is bounded by 2^err2*ulp(s2) */
mpfr_const_pi (y, GMP_RNDN); /* error bounded by 1 ulp */
mpfr_div (s2, s2, y, GMP_RNDN); /* error bounded by 2^(err2+1)*ulp(s2) */
err2 ++;
if (MPFR_LIKELY (MPFR_CAN_ROUND (s2, prec - err2, MPFR_PREC(res), r)))
break;
MPFR_ZIV_NEXT (loop, prec);
}
MPFR_ZIV_FREE (loop);
inex = (n >= 0 || (n & 1) == 0)
? mpfr_set (res, s2, r)
: mpfr_neg (res, s2, r);
mpfr_clear (y);
mpfr_clear (s1);
mpfr_clear (s2);
mpfr_clear (s3);
return inex;
}
/* evaluates erf(x) using the expansion at x=0:
erf(x) = 2/sqrt(Pi) * sum((-1)^k*x^(2k+1)/k!/(2k+1), k=0..infinity)
Assumes x is neither NaN nor infinite nor zero.
Assumes also that e*x^2 <= n (target precision).
*/
static int
mpfr_erf_0 (mpfr_ptr res, mpfr_srcptr x, double xf2, mpfr_rnd_t rnd_mode)
{
mpfr_prec_t n, m;
mpfr_exp_t nuk, sigmak;
double tauk;
mpfr_t y, s, t, u;
unsigned int k;
int log2tauk;
int inex;
MPFR_ZIV_DECL (loop);
n = MPFR_PREC (res); /* target precision */
/* initial working precision */
m = n + (mpfr_prec_t) (xf2 / LOG2) + 8 + MPFR_INT_CEIL_LOG2 (n);
mpfr_init2 (y, m);
mpfr_init2 (s, m);
mpfr_init2 (t, m);
mpfr_init2 (u, m);
MPFR_ZIV_INIT (loop, m);
for (;;)
{
mpfr_mul (y, x, x, MPFR_RNDU); /* err <= 1 ulp */
mpfr_set_ui (s, 1, MPFR_RNDN);
mpfr_set_ui (t, 1, MPFR_RNDN);
tauk = 0.0;
for (k = 1; ; k++)
{
mpfr_mul (t, y, t, MPFR_RNDU);
mpfr_div_ui (t, t, k, MPFR_RNDU);
mpfr_div_ui (u, t, 2 * k + 1, MPFR_RNDU);
sigmak = MPFR_GET_EXP (s);
if (k % 2)
mpfr_sub (s, s, u, MPFR_RNDN);
else
mpfr_add (s, s, u, MPFR_RNDN);
sigmak -= MPFR_GET_EXP(s);
nuk = MPFR_GET_EXP(u) - MPFR_GET_EXP(s);
if ((nuk < - (mpfr_exp_t) m) && ((double) k >= xf2))
break;
/* tauk <- 1/2 + tauk * 2^sigmak + (1+8k)*2^nuk */
tauk = 0.5 + mul_2exp (tauk, sigmak)
+ mul_2exp (1.0 + 8.0 * (double) k, nuk);
}
mpfr_mul (s, x, s, MPFR_RNDU);
MPFR_SET_EXP (s, MPFR_GET_EXP (s) + 1);
mpfr_const_pi (t, MPFR_RNDZ);
mpfr_sqrt (t, t, MPFR_RNDZ);
mpfr_div (s, s, t, MPFR_RNDN);
tauk = 4.0 * tauk + 11.0; /* final ulp-error on s */
log2tauk = __gmpfr_ceil_log2 (tauk);
if (MPFR_LIKELY (MPFR_CAN_ROUND (s, m - log2tauk, n, rnd_mode)))
break;
/* Actualisation of the precision */
MPFR_ZIV_NEXT (loop, m);
mpfr_set_prec (y, m);
mpfr_set_prec (s, m);
mpfr_set_prec (t, m);
mpfr_set_prec (u, m);
}
MPFR_ZIV_FREE (loop);
inex = mpfr_set (res, s, rnd_mode);
mpfr_clear (y);
mpfr_clear (t);
mpfr_clear (u);
mpfr_clear (s);
return inex;
}
/* Put in y an approximation of erfc(x) for large x, using formulae 7.1.23 and
7.1.24 from Abramowitz and Stegun.
Returns e such that the error is bounded by 2^e ulp(y),
or returns 0 in case of underflow.
*/
static mpfr_exp_t
mpfr_erfc_asympt (mpfr_ptr y, mpfr_srcptr x)
{
mpfr_t t, xx, err;
unsigned long k;
mpfr_prec_t prec = MPFR_PREC(y);
mpfr_exp_t exp_err;
mpfr_init2 (t, prec);
mpfr_init2 (xx, prec);
mpfr_init2 (err, 31);
/* let u = 2^(1-p), and let us represent the error as (1+u)^err
with a bound for err */
mpfr_mul (xx, x, x, MPFR_RNDD); /* err <= 1 */
mpfr_ui_div (xx, 1, xx, MPFR_RNDU); /* upper bound for 1/(2x^2), err <= 2 */
mpfr_div_2ui (xx, xx, 1, MPFR_RNDU); /* exact */
mpfr_set_ui (t, 1, MPFR_RNDN); /* current term, exact */
mpfr_set (y, t, MPFR_RNDN); /* current sum */
mpfr_set_ui (err, 0, MPFR_RNDN);
for (k = 1; ; k++)
{
mpfr_mul_ui (t, t, 2 * k - 1, MPFR_RNDU); /* err <= 4k-3 */
mpfr_mul (t, t, xx, MPFR_RNDU); /* err <= 4k */
/* for -1 < x < 1, and |nx| < 1, we have |(1+x)^n| <= 1+7/4|nx|.
Indeed, for x>=0: log((1+x)^n) = n*log(1+x) <= n*x. Let y=n*x < 1,
then exp(y) <= 1+7/4*y.
For x<=0, let x=-x, we can prove by induction that (1-x)^n >= 1-n*x.*/
mpfr_mul_2si (err, err, MPFR_GET_EXP (y) - MPFR_GET_EXP (t), MPFR_RNDU);
mpfr_add_ui (err, err, 14 * k, MPFR_RNDU); /* 2^(1-p) * t <= 2 ulp(t) */
mpfr_div_2si (err, err, MPFR_GET_EXP (y) - MPFR_GET_EXP (t), MPFR_RNDU);
if (MPFR_GET_EXP (t) + (mpfr_exp_t) prec <= MPFR_GET_EXP (y))
{
/* the truncation error is bounded by |t| < ulp(y) */
mpfr_add_ui (err, err, 1, MPFR_RNDU);
break;
}
if (k & 1)
mpfr_sub (y, y, t, MPFR_RNDN);
else
mpfr_add (y, y, t, MPFR_RNDN);
}
/* the error on y is bounded by err*ulp(y) */
mpfr_mul (t, x, x, MPFR_RNDU); /* rel. err <= 2^(1-p) */
mpfr_div_2ui (err, err, 3, MPFR_RNDU); /* err/8 */
mpfr_add (err, err, t, MPFR_RNDU); /* err/8 + xx */
mpfr_mul_2ui (err, err, 3, MPFR_RNDU); /* err + 8*xx */
mpfr_exp (t, t, MPFR_RNDU); /* err <= 1/2*ulp(t) + err(x*x)*t
<= 1/2*ulp(t)+2*|x*x|*ulp(t)
<= (2*|x*x|+1/2)*ulp(t) */
mpfr_mul (t, t, x, MPFR_RNDN); /* err <= 1/2*ulp(t) + (4*|x*x|+1)*ulp(t)
<= (4*|x*x|+3/2)*ulp(t) */
mpfr_const_pi (xx, MPFR_RNDZ); /* err <= ulp(Pi) */
mpfr_sqrt (xx, xx, MPFR_RNDN); /* err <= 1/2*ulp(xx) + ulp(Pi)/2/sqrt(Pi)
<= 3/2*ulp(xx) */
mpfr_mul (t, t, xx, MPFR_RNDN); /* err <= (8 |xx| + 13/2) * ulp(t) */
mpfr_div (y, y, t, MPFR_RNDN); /* the relative error on input y is bounded
by (1+u)^err with u = 2^(1-p), that on
t is bounded by (1+u)^(8 |xx| + 13/2),
thus that on output y is bounded by
8 |xx| + 7 + err. */
if (MPFR_IS_ZERO(y))
{
/* If y is zero, most probably we have underflow. We check it directly
using the fact that erfc(x) <= exp(-x^2)/sqrt(Pi)/x for x >= 0.
We compute an upper approximation of exp(-x^2)/sqrt(Pi)/x.
*/
mpfr_mul (t, x, x, MPFR_RNDD); /* t <= x^2 */
mpfr_neg (t, t, MPFR_RNDU); /* -x^2 <= t */
mpfr_exp (t, t, MPFR_RNDU); /* exp(-x^2) <= t */
mpfr_const_pi (xx, MPFR_RNDD); /* xx <= sqrt(Pi), cached */
mpfr_mul (xx, xx, x, MPFR_RNDD); /* xx <= sqrt(Pi)*x */
mpfr_div (y, t, xx, MPFR_RNDN); /* if y is zero, this means that the upper
approximation of exp(-x^2)/sqrt(Pi)/x
is nearer from 0 than from 2^(-emin-1),
thus we have underflow. */
exp_err = 0;
}
else
{
mpfr_add_ui (err, err, 7, MPFR_RNDU);
exp_err = MPFR_GET_EXP (err);
}
mpfr_clear (t);
mpfr_clear (xx);
mpfr_clear (err);
return exp_err;
}
/*------------------------------------------------------------------------*/
int my_mpfr_beta (mpfr_t R, mpfr_t a, mpfr_t b, mpfr_rnd_t RND)
{
mpfr_prec_t p_a = mpfr_get_prec(a), p_b = mpfr_get_prec(b);
if(p_a < p_b) p_a = p_b;// p_a := max(p_a, p_b)
if(mpfr_get_prec(R) < p_a)
mpfr_prec_round(R, p_a, RND);// so prec(R) = max( prec(a), prec(b) )
int ans;
mpfr_t s; mpfr_init2(s, p_a);
#ifdef DEBUG_Rmpfr
R_CheckUserInterrupt();
int cc = 0;
#endif
/* "FIXME": check each 'ans' below, and return when not ok ... */
ans = mpfr_add(s, a, b, RND);
if(mpfr_integer_p(s) && mpfr_sgn(s) <= 0) { // (a + b) is integer <= 0
if(!mpfr_integer_p(a) && !mpfr_integer_p(b)) {
// but a,b not integer ==> R = finite / +-Inf = 0 :
mpfr_set_zero (R, +1);
mpfr_clear (s);
return ans;
}// else: sum is integer; at least one {a,b} integer ==> both integer
int sX = mpfr_sgn(a), sY = mpfr_sgn(b);
if(sX * sY < 0) { // one negative, one positive integer
// ==> special treatment here :
if(sY < 0) // ==> sX > 0; swap the two
mpfr_swap(a, b);
// now have --- a < 0 < b <= |a| integer ------------------
/* ================ and in this case:
B(a,b) = (-1)^b B(1-a-b, b) = (-1)^b B(1-s, b)
= (1*2*..*b) / (-s-1)*(-s-2)*...*(-s-b)
*/
/* where in the 2nd form, both numerator and denominator have exactly
* b integer factors. This is attractive {numerically & speed wise}
* for 'small' b */
#define b_large 100
#ifdef DEBUG_Rmpfr
Rprintf(" my_mpfr_beta(<neg int>): s = a+b= "); R_PRT(s);
Rprintf("\n a = "); R_PRT(a);
Rprintf("\n b = "); R_PRT(b); Rprintf("\n");
if(cc++ > 999) { mpfr_set_zero (R, +1); mpfr_clear (s); return ans; }
#endif
unsigned long b_ = 0;// -Wall
Rboolean
b_fits_ulong = mpfr_fits_ulong_p(b, RND),
small_b = b_fits_ulong && (b_ = mpfr_get_ui(b, RND)) < b_large;
if(small_b) {
#ifdef DEBUG_Rmpfr
Rprintf(" b <= b_large = %d...\n", b_large);
#endif
//----------------- small b ------------------
// use GMP big integer arithmetic:
mpz_t S; mpz_init(S); mpfr_get_z(S, s, RND); // S := s
mpz_sub_ui (S, S, (unsigned long) 1); // S = s - 1 = (a+b-1)
/* binomial coefficient choose(N, k) requires k a 'long int';
* here, b must fit into a long: */
mpz_bin_ui (S, S, b_); // S = choose(S, b) = choose(a+b-1, b)
mpz_mul_ui (S, S, b_); // S = S*b = b * choose(a+b-1, b)
// back to mpfr: R = 1 / S = 1 / (b * choose(a+b-1, b))
mpfr_set_ui(s, (unsigned long) 1, RND);
mpfr_div_z(R, s, S, RND);
mpz_clear(S);
}
else { // b is "large", use direct B(.,.) formula
#ifdef DEBUG_Rmpfr
Rprintf(" b > b_large = %d...\n", b_large);
#endif
// a := (-1)^b :
// there is no mpfr_si_pow(a, -1, b, RND);
int neg; // := 1 ("TRUE") if (-1)^b = -1, i.e. iff b is odd
if(b_fits_ulong) { // (i.e. not very large)
neg = (b_ % 2); // 1 iff b_ is odd, 0 otherwise
} else { // really large b; as we know it is integer, can still..
// b2 := b / 2
mpfr_t b2; mpfr_init2(b2, p_a);
mpfr_div_2ui(b2, b, 1, RND);
neg = !mpfr_integer_p(b2); // b is odd, if b/2 is *not* integer
#ifdef DEBUG_Rmpfr
Rprintf(" really large b; neg = ('b is odd') = %d\n", neg);
#endif
}
// s' := 1-s = 1-a-b
mpfr_ui_sub(s, 1, s, RND);
#ifdef DEBUG_Rmpfr
Rprintf(" neg = %d\n", neg);
Rprintf(" s' = 1-a-b = "); R_PRT(s);
Rprintf("\n -> calling B(s',b)\n");
#endif
// R := B(1-a-b, b) = B(s', b)
if(small_b) {
my_mpfr_beta (R, s, b, RND);
} else {
my_mpfr_lbeta (R, s, b, RND);
mpfr_exp(R, R, RND); // correct *if* beta() >= 0
}
#ifdef DEBUG_Rmpfr
Rprintf(" R' = beta(s',b) = "); R_PRT(R); Rprintf("\n");
#endif
// Result = (-1)^b B(1-a-b, b) = +/- s'
if(neg) mpfr_neg(R, R, RND);
}
mpfr_clear(s);
return ans;
}
}
ans = mpfr_gamma(s, s, RND); /* s = gamma(a + b) */
#ifdef DEBUG_Rmpfr
Rprintf("my_mpfr_beta(): s = gamma(a+b)= "); R_PRT(s);
Rprintf("\n a = "); R_PRT(a);
Rprintf("\n b = "); R_PRT(b);
#endif
ans = mpfr_gamma(a, a, RND);
ans = mpfr_gamma(b, b, RND);
ans = mpfr_mul(b, b, a, RND); /* b' = gamma(a) * gamma(b) */
#ifdef DEBUG_Rmpfr
Rprintf("\n G(a) * G(b) = "); R_PRT(b); Rprintf("\n");
#endif
ans = mpfr_div(R, b, s, RND);
mpfr_clear (s);
/* mpfr_free_cache() must be called in the caller !*/
return ans;
}
/* Input: s - a floating-point number >= 1/2.
rnd_mode - a rounding mode.
Assumes s is neither NaN nor Infinite.
Output: z - Zeta(s) rounded to the precision of z with direction rnd_mode
*/
static int
mpfr_zeta_pos (mpfr_t z, mpfr_srcptr s, mpfr_rnd_t rnd_mode)
{
mpfr_t b, c, z_pre, f, s1;
double beta, sd, dnep;
mpfr_t *tc1;
mpfr_prec_t precz, precs, d, dint;
int p, n, l, add;
int inex;
MPFR_GROUP_DECL (group);
MPFR_ZIV_DECL (loop);
MPFR_ASSERTD (MPFR_IS_POS (s) && MPFR_GET_EXP (s) >= 0);
precz = MPFR_PREC (z);
precs = MPFR_PREC (s);
/* Zeta(x) = 1+1/2^x+1/3^x+1/4^x+1/5^x+O(1/6^x)
so with 2^(EXP(x)-1) <= x < 2^EXP(x)
So for x > 2^3, k^x > k^8, so 2/k^x < 2/k^8
Zeta(x) = 1 + 1/2^x*(1+(2/3)^x+(2/4)^x+...)
= 1 + 1/2^x*(1+sum((2/k)^x,k=3..infinity))
<= 1 + 1/2^x*(1+sum((2/k)^8,k=3..infinity))
And sum((2/k)^8,k=3..infinity) = -257+128*Pi^8/4725 ~= 0.0438035
So Zeta(x) <= 1 + 1/2^x*2 for x >= 8
The error is < 2^(-x+1) <= 2^(-2^(EXP(x)-1)+1) */
if (MPFR_GET_EXP (s) > 3)
{
mpfr_exp_t err;
err = MPFR_GET_EXP (s) - 1;
if (err > (mpfr_exp_t) (sizeof (mpfr_exp_t)*CHAR_BIT-2))
err = MPFR_EMAX_MAX;
else
err = ((mpfr_exp_t)1) << err;
err = 1 - (-err+1); /* GET_EXP(one) - (-err+1) = err :) */
MPFR_FAST_COMPUTE_IF_SMALL_INPUT (z, __gmpfr_one, err, 0, 1,
rnd_mode, {});
}
d = precz + MPFR_INT_CEIL_LOG2(precz) + 10;
/* we want that s1 = s-1 is exact, i.e. we should have PREC(s1) >= EXP(s) */
dint = (mpfr_uexp_t) MPFR_GET_EXP (s);
mpfr_init2 (s1, MAX (precs, dint));
inex = mpfr_sub (s1, s, __gmpfr_one, MPFR_RNDN);
MPFR_ASSERTD (inex == 0);
/* case s=1 should have already been handled */
MPFR_ASSERTD (!MPFR_IS_ZERO (s1));
MPFR_GROUP_INIT_4 (group, MPFR_PREC_MIN, b, c, z_pre, f);
MPFR_ZIV_INIT (loop, d);
for (;;)
{
/* Principal loop: we compute, in z_pre,
an approximation of Zeta(s), that we send to can_round */
if (MPFR_GET_EXP (s1) <= -(mpfr_exp_t) ((mpfr_prec_t) (d-3)/2))
/* Branch 1: when s-1 is very small, one
uses the approximation Zeta(s)=1/(s-1)+gamma,
where gamma is Euler's constant */
{
dint = MAX (d + 3, precs);
/* branch 1, with internal precision dint */
MPFR_GROUP_REPREC_4 (group, dint, b, c, z_pre, f);
mpfr_div (z_pre, __gmpfr_one, s1, MPFR_RNDN);
mpfr_const_euler (f, MPFR_RNDN);
mpfr_add (z_pre, z_pre, f, MPFR_RNDN);
}
else /* Branch 2 */
{
size_t size;
/* branch 2 */
/* Computation of parameters n, p and working precision */
dnep = (double) d * LOG2;
sd = mpfr_get_d (s, MPFR_RNDN);
/* beta = dnep + 0.61 + sd * log (6.2832 / sd);
but a larger value is OK */
#define LOG6dot2832 1.83787940484160805532
beta = dnep + 0.61 + sd * (LOG6dot2832 - LOG2 *
__gmpfr_floor_log2 (sd));
if (beta <= 0.0)
{
p = 0;
/* n = 1 + (int) (exp ((dnep - LOG2) / sd)); */
n = 1 + (int) __gmpfr_ceil_exp2 ((d - 1.0) / sd);
}
else
{
p = 1 + (int) beta / 2;
n = 1 + (int) ((sd + 2.0 * (double) p - 1.0) / 6.2832);
}
/* add = 4 + floor(1.5 * log(d) / log (2)).
We should have add >= 10, which is always fulfilled since
d = precz + 11 >= 12, thus ceil(log2(d)) >= 4 */
add = 4 + (3 * MPFR_INT_CEIL_LOG2 (d)) / 2;
MPFR_ASSERTD(add >= 10);
dint = d + add;
if (dint < precs)
dint = precs;
/* internal precision is dint */
size = (p + 1) * sizeof(mpfr_t);
tc1 = (mpfr_t*) mpfr_allocate_func (size);
for (l=1; l<=p; l++)
mpfr_init2 (tc1[l], dint);
MPFR_GROUP_REPREC_4 (group, dint, b, c, z_pre, f);
/* precision of z is precz */
/* Computation of the coefficients c_k */
mpfr_zeta_c (p, tc1);
/* Computation of the 3 parts of the function Zeta. */
mpfr_zeta_part_a (z_pre, s, n);
mpfr_zeta_part_b (b, s, n, p, tc1);
/* s1 = s-1 is already computed above */
mpfr_div (c, __gmpfr_one, s1, MPFR_RNDN);
mpfr_ui_pow (f, n, s1, MPFR_RNDN);
mpfr_div (c, c, f, MPFR_RNDN);
mpfr_add (z_pre, z_pre, c, MPFR_RNDN);
mpfr_add (z_pre, z_pre, b, MPFR_RNDN);
for (l=1; l<=p; l++)
mpfr_clear (tc1[l]);
mpfr_free_func (tc1, size);
/* End branch 2 */
}
if (MPFR_LIKELY (MPFR_CAN_ROUND (z_pre, d-3, precz, rnd_mode)))
break;
MPFR_ZIV_NEXT (loop, d);
}
MPFR_ZIV_FREE (loop);
inex = mpfr_set (z, z_pre, rnd_mode);
MPFR_GROUP_CLEAR (group);
mpfr_clear (s1);
return inex;
}
/* Don't need to save/restore exponent range: the cache does it.
Catalan's constant is G = sum((-1)^k/(2*k+1)^2, k=0..infinity).
We compute it using formula (31) of Victor Adamchik's page
"33 representations for Catalan's constant"
http://www-2.cs.cmu.edu/~adamchik/articles/catalan/catalan.htm
G = Pi/8*log(2+sqrt(3)) + 3/8*sum(k!^2/(2k)!/(2k+1)^2,k=0..infinity)
*/
int
mpfr_const_catalan_internal (mpfr_ptr g, mp_rnd_t rnd_mode)
{
mpfr_t x, y, z;
mpz_t T, P, Q;
mp_prec_t pg, p;
int inex;
MPFR_ZIV_DECL (loop);
MPFR_GROUP_DECL (group);
MPFR_LOG_FUNC (("rnd_mode=%d", rnd_mode), ("g[%#R]=%R inex=%d", g, g, inex));
/* Here are the WC (max prec = 100.000.000)
Once we have found a chain of 11, we only look for bigger chain.
Found 3 '1' at 0
Found 5 '1' at 9
Found 6 '0' at 34
Found 9 '1' at 176
Found 11 '1' at 705
Found 12 '0' at 913
Found 14 '1' at 12762
Found 15 '1' at 152561
Found 16 '0' at 171725
Found 18 '0' at 525355
Found 20 '0' at 529245
Found 21 '1' at 6390133
Found 22 '0' at 7806417
Found 25 '1' at 11936239
Found 27 '1' at 51752950
*/
pg = MPFR_PREC (g);
p = pg + 9;
p += MPFR_INT_CEIL_LOG2 (p);
MPFR_GROUP_INIT_3 (group, p, x, y, z);
mpz_init (T);
mpz_init (P);
mpz_init (Q);
MPFR_ZIV_INIT (loop, p);
for (;;) {
mpfr_sqrt_ui (x, 3, GMP_RNDU);
mpfr_add_ui (x, x, 2, GMP_RNDU);
mpfr_log (x, x, GMP_RNDU);
mpfr_const_pi (y, GMP_RNDU);
mpfr_mul (x, x, y, GMP_RNDN);
S (T, P, Q, 0, (p - 1) / 2);
mpz_mul_ui (T, T, 3);
mpfr_set_z (y, T, GMP_RNDU);
mpfr_set_z (z, Q, GMP_RNDD);
mpfr_div (y, y, z, GMP_RNDN);
mpfr_add (x, x, y, GMP_RNDN);
mpfr_div_2ui (x, x, 3, GMP_RNDN);
if (MPFR_LIKELY (MPFR_CAN_ROUND (x, p - 5, pg, rnd_mode)))
break;
/* Fixme: Is it possible? */
MPFR_ZIV_NEXT (loop, p);
MPFR_GROUP_REPREC_3 (group, p, x, y, z);
}
MPFR_ZIV_FREE (loop);
inex = mpfr_set (g, x, rnd_mode);
MPFR_GROUP_CLEAR (group);
mpz_clear (T);
mpz_clear (P);
mpz_clear (Q);
return inex;
}
static void
check_large (void)
{
__float128 f, e;
int i;
mpfr_t x, y;
int r;
mpfr_init2 (x, 113);
mpfr_init2 (y, 113);
/* check with the largest float128 number 2^16384*(1-2^(-113)) */
for (f = 1.0, i = 0; i < 113; i++)
f = f + f;
f = f - (__float128) 1.0;
mpfr_set_ui (y, 1, MPFR_RNDN);
mpfr_mul_2exp (y, y, 113, MPFR_RNDN);
mpfr_sub_ui (y, y, 1, MPFR_RNDN);
for (i = 113; i < 16384; i++)
{
RND_LOOP (r)
{
mpfr_set_float128 (x, f, (mpfr_rnd_t) r);
if (! mpfr_equal_p (x, y))
{
printf ("mpfr_set_float128 failed for 2^%d*(1-2^(-113)) rnd=%s\n",
i, mpfr_print_rnd_mode ((mpfr_rnd_t) r));
printf ("got ");
mpfr_dump (x);
exit (1);
}
e = mpfr_get_float128 (x, (mpfr_rnd_t) r);
if (e != f)
{
printf ("mpfr_get_float128 failed for 2^%d*(1-2^(-113)) rnd=%s\n",
i, mpfr_print_rnd_mode ((mpfr_rnd_t) r));
exit (1);
}
}
/* check with opposite number */
f = -f;
mpfr_neg (y, y, MPFR_RNDN);
RND_LOOP (r)
{
mpfr_set_float128 (x, f, (mpfr_rnd_t) r);
if (! mpfr_equal_p (x, y))
{
printf ("mpfr_set_float128 failed for -2^%d*(1-2^(-113)) rnd=%s\n",
i, mpfr_print_rnd_mode ((mpfr_rnd_t) r));
printf ("got ");
mpfr_dump (x);
exit (1);
}
e = mpfr_get_float128 (x, (mpfr_rnd_t) r);
if (e != f)
{
printf ("mpfr_get_float128 failed for -2^%d*(1-2^(-113)) rnd=%s\n",
i, mpfr_print_rnd_mode ((mpfr_rnd_t) r));
exit (1);
}
}
f = -f;
mpfr_neg (y, y, MPFR_RNDN);
f = f + f;
mpfr_add (y, y, y, MPFR_RNDN);
}
mpfr_clear (x);
mpfr_clear (y);
}
void mpfr_bisect_sqrt(mpfr_t R, mpfr_t N, mpfr_t T)
{
if(mpfr_cmp_ui(N, 0) < 0)
{
fprintf(stderr, "The value to square root must be non-negative\n");
exit(-1);
}
if(mpfr_cmp_ui(T, 0) < 0)
{
fprintf(stderr, "The tolerance must be non-negative\n");
exit(-1);
}
mpfr_exp_t e;
mpfr_t a, b, x, f, d, fab, n;
mpfr_init(n);
mpfr_frexp(&e, n, N, MPFR_RNDN);
if(e%2)
{
mpfr_div_ui(n, n, 2, MPFR_RNDN);
e += 1;
}
//Set a == 0
mpfr_init_set_ui(a, 0, MPFR_RNDN);
//Set b == 1
mpfr_init_set_ui(b, 1, MPFR_RNDN);
//Set x = (a + b)/2
mpfr_init(x);
mpfr_add(x, a, b, MPFR_RNDN);
mpfr_mul(x, x, MPFR_HALF, MPFR_RNDN);
//Set f = x^2 - N and fab = |f|
mpfr_init(f);
mpfr_init(fab);
mpfr_mul(f, x, x, MPFR_RNDN);
mpfr_sub(f, f, N, MPFR_RNDN);
mpfr_abs(fab, f, MPFR_RNDN);
//Set d = b - a
mpfr_init(d);
mpfr_sub(d, b, a, MPFR_RNDN);
while(mpfr_cmp(fab, T) > 0 && mpfr_cmp(d, T) > 0)
{
//Update the bounds, a and b
if(mpfr_cmp_ui(f, 0) < 0)
mpfr_set(a, x, MPFR_RNDN);
else
mpfr_set(b, x, MPFR_RNDN);
//Update x
mpfr_add(x, a, b, MPFR_RNDN);
mpfr_mul(x, x, MPFR_HALF, MPFR_RNDN);
//Update f and fab
mpfr_mul(f, x, x, MPFR_RNDN);
mpfr_sub(f, f, n, MPFR_RNDN);
mpfr_abs(fab, f, MPFR_RNDN);
}
printf("beep");
mpfr_mul_2si(R, x, e/2, MPFR_RNDN);
}
/* Compute the real part of the dilogarithm defined by
Li2(x) = -\Int_{t=0}^x log(1-t)/t dt */
int
mpfr_li2 (mpfr_ptr y, mpfr_srcptr x, mpfr_rnd_t rnd_mode)
{
int inexact;
mp_exp_t err;
mpfr_prec_t yp, m;
MPFR_ZIV_DECL (loop);
MPFR_SAVE_EXPO_DECL (expo);
MPFR_LOG_FUNC (("x[%#R]=%R rnd=%d", x, x, rnd_mode), ("y[%#R]=%R", y));
if (MPFR_UNLIKELY (MPFR_IS_SINGULAR (x)))
{
if (MPFR_IS_NAN (x))
{
MPFR_SET_NAN (y);
MPFR_RET_NAN;
}
else if (MPFR_IS_INF (x))
{
MPFR_SET_NEG (y);
MPFR_SET_INF (y);
MPFR_RET (0);
}
else /* x is zero */
{
MPFR_ASSERTD (MPFR_IS_ZERO (x));
MPFR_SET_SAME_SIGN (y, x);
MPFR_SET_ZERO (y);
MPFR_RET (0);
}
}
/* Li2(x) = x + x^2/4 + x^3/9 + ..., more precisely for 0 < x <= 1/2
we have |Li2(x) - x| < x^2/2 <= 2^(2EXP(x)-1) and for -1/2 <= x < 0
we have |Li2(x) - x| < x^2/4 <= 2^(2EXP(x)-2) */
if (MPFR_IS_POS (x))
MPFR_FAST_COMPUTE_IF_SMALL_INPUT (y, x, -MPFR_GET_EXP (x), 1, 1, rnd_mode,
{});
else
MPFR_FAST_COMPUTE_IF_SMALL_INPUT (y, x, -MPFR_GET_EXP (x), 2, 0, rnd_mode,
{});
MPFR_SAVE_EXPO_MARK (expo);
yp = MPFR_PREC (y);
m = yp + MPFR_INT_CEIL_LOG2 (yp) + 13;
if (MPFR_LIKELY ((mpfr_cmp_ui (x, 0) > 0) && (mpfr_cmp_d (x, 0.5) <= 0)))
/* 0 < x <= 1/2: Li2(x) = S(-log(1-x))-log^2(1-x)/4 */
{
mpfr_t s, u;
mp_exp_t expo_l;
int k;
mpfr_init2 (u, m);
mpfr_init2 (s, m);
MPFR_ZIV_INIT (loop, m);
for (;;)
{
mpfr_ui_sub (u, 1, x, GMP_RNDN);
mpfr_log (u, u, GMP_RNDU);
if (MPFR_IS_ZERO(u))
goto next_m;
mpfr_neg (u, u, GMP_RNDN); /* u = -log(1-x) */
expo_l = MPFR_GET_EXP (u);
k = li2_series (s, u, GMP_RNDU);
err = 1 + MPFR_INT_CEIL_LOG2 (k + 1);
mpfr_sqr (u, u, GMP_RNDU);
mpfr_div_2ui (u, u, 2, GMP_RNDU); /* u = log^2(1-x) / 4 */
mpfr_sub (s, s, u, GMP_RNDN);
/* error(s) <= (0.5 + 2^(d-EXP(s))
+ 2^(3 + MAX(1, - expo_l) - EXP(s))) ulp(s) */
err = MAX (err, MAX (1, - expo_l) - 1) - MPFR_GET_EXP (s);
err = 2 + MAX (-1, err);
if (MPFR_CAN_ROUND (s, (mp_exp_t) m - err, yp, rnd_mode))
break;
next_m:
MPFR_ZIV_NEXT (loop, m);
mpfr_set_prec (u, m);
mpfr_set_prec (s, m);
}
MPFR_ZIV_FREE (loop);
inexact = mpfr_set (y, s, rnd_mode);
mpfr_clear (u);
mpfr_clear (s);
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (y, inexact, rnd_mode);
}
else if (!mpfr_cmp_ui (x, 1))
/* Li2(1)= pi^2 / 6 */
{
mpfr_t u;
mpfr_init2 (u, m);
MPFR_ZIV_INIT (loop, m);
for (;;)
{
mpfr_const_pi (u, GMP_RNDU);
mpfr_sqr (u, u, GMP_RNDN);
mpfr_div_ui (u, u, 6, GMP_RNDN);
err = m - 4; /* error(u) <= 19/2 ulp(u) */
if (MPFR_CAN_ROUND (u, err, yp, rnd_mode))
break;
MPFR_ZIV_NEXT (loop, m);
mpfr_set_prec (u, m);
}
MPFR_ZIV_FREE (loop);
inexact = mpfr_set (y, u, rnd_mode);
mpfr_clear (u);
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (y, inexact, rnd_mode);
}
else if (mpfr_cmp_ui (x, 2) >= 0)
/* x >= 2: Li2(x) = -S(-log(1-1/x))-log^2(x)/2+log^2(1-1/x)/4+pi^2/3 */
{
int k;
mp_exp_t expo_l;
mpfr_t s, u, xx;
if (mpfr_cmp_ui (x, 38) >= 0)
{
inexact = mpfr_li2_asympt_pos (y, x, rnd_mode);
if (inexact != 0)
goto end_of_case_gt2;
}
mpfr_init2 (u, m);
mpfr_init2 (s, m);
mpfr_init2 (xx, m);
MPFR_ZIV_INIT (loop, m);
for (;;)
{
mpfr_ui_div (xx, 1, x, GMP_RNDN);
mpfr_neg (xx, xx, GMP_RNDN);
mpfr_log1p (u, xx, GMP_RNDD);
mpfr_neg (u, u, GMP_RNDU); /* u = -log(1-1/x) */
expo_l = MPFR_GET_EXP (u);
k = li2_series (s, u, GMP_RNDN);
mpfr_neg (s, s, GMP_RNDN);
err = MPFR_INT_CEIL_LOG2 (k + 1) + 1; /* error(s) <= 2^err ulp(s) */
mpfr_sqr (u, u, GMP_RNDN);
mpfr_div_2ui (u, u, 2, GMP_RNDN); /* u= log^2(1-1/x)/4 */
mpfr_add (s, s, u, GMP_RNDN);
err =
MAX (err,
3 + MAX (1, -expo_l) + MPFR_GET_EXP (u)) - MPFR_GET_EXP (s);
err = 2 + MAX (-1, err); /* error(s) <= 2^err ulp(s) */
err += MPFR_GET_EXP (s);
mpfr_log (u, x, GMP_RNDU);
mpfr_sqr (u, u, GMP_RNDN);
mpfr_div_2ui (u, u, 1, GMP_RNDN); /* u = log^2(x)/2 */
mpfr_sub (s, s, u, GMP_RNDN);
err = MAX (err, 3 + MPFR_GET_EXP (u)) - MPFR_GET_EXP (s);
err = 2 + MAX (-1, err); /* error(s) <= 2^err ulp(s) */
err += MPFR_GET_EXP (s);
mpfr_const_pi (u, GMP_RNDU);
mpfr_sqr (u, u, GMP_RNDN);
mpfr_div_ui (u, u, 3, GMP_RNDN); /* u = pi^2/3 */
mpfr_add (s, s, u, GMP_RNDN);
err = MAX (err, 2) - MPFR_GET_EXP (s);
err = 2 + MAX (-1, err); /* error(s) <= 2^err ulp(s) */
if (MPFR_CAN_ROUND (s, (mp_exp_t) m - err, yp, rnd_mode))
break;
MPFR_ZIV_NEXT (loop, m);
mpfr_set_prec (u, m);
mpfr_set_prec (s, m);
mpfr_set_prec (xx, m);
}
MPFR_ZIV_FREE (loop);
inexact = mpfr_set (y, s, rnd_mode);
mpfr_clears (s, u, xx, (mpfr_ptr) 0);
end_of_case_gt2:
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (y, inexact, rnd_mode);
}
else if (mpfr_cmp_ui (x, 1) > 0)
/* 2 > x > 1: Li2(x) = S(log(x))+log^2(x)/4-log(x)log(x-1)+pi^2/6 */
{
int k;
mp_exp_t e1, e2;
mpfr_t s, u, v, xx;
mpfr_init2 (s, m);
mpfr_init2 (u, m);
mpfr_init2 (v, m);
mpfr_init2 (xx, m);
MPFR_ZIV_INIT (loop, m);
for (;;)
{
mpfr_log (v, x, GMP_RNDU);
k = li2_series (s, v, GMP_RNDN);
e1 = MPFR_GET_EXP (s);
mpfr_sqr (u, v, GMP_RNDN);
mpfr_div_2ui (u, u, 2, GMP_RNDN); /* u = log^2(x)/4 */
mpfr_add (s, s, u, GMP_RNDN);
mpfr_sub_ui (xx, x, 1, GMP_RNDN);
mpfr_log (u, xx, GMP_RNDU);
e2 = MPFR_GET_EXP (u);
mpfr_mul (u, v, u, GMP_RNDN); /* u = log(x) * log(x-1) */
mpfr_sub (s, s, u, GMP_RNDN);
mpfr_const_pi (u, GMP_RNDU);
mpfr_sqr (u, u, GMP_RNDN);
mpfr_div_ui (u, u, 6, GMP_RNDN); /* u = pi^2/6 */
mpfr_add (s, s, u, GMP_RNDN);
/* error(s) <= (31 + (k+1) * 2^(1-e1) + 2^(1-e2)) ulp(s)
see algorithms.tex */
err = MAX (MPFR_INT_CEIL_LOG2 (k + 1) + 1 - e1, 1 - e2);
err = 2 + MAX (5, err);
if (MPFR_CAN_ROUND (s, (mp_exp_t) m - err, yp, rnd_mode))
break;
MPFR_ZIV_NEXT (loop, m);
mpfr_set_prec (s, m);
mpfr_set_prec (u, m);
mpfr_set_prec (v, m);
mpfr_set_prec (xx, m);
}
MPFR_ZIV_FREE (loop);
inexact = mpfr_set (y, s, rnd_mode);
mpfr_clears (s, u, v, xx, (mpfr_ptr) 0);
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (y, inexact, rnd_mode);
}
else if (mpfr_cmp_ui_2exp (x, 1, -1) > 0) /* 1/2 < x < 1 */
/* 1 > x > 1/2: Li2(x) = -S(-log(x))+log^2(x)/4-log(x)log(1-x)+pi^2/6 */
{
int k;
mpfr_t s, u, v, xx;
mpfr_init2 (s, m);
mpfr_init2 (u, m);
mpfr_init2 (v, m);
mpfr_init2 (xx, m);
MPFR_ZIV_INIT (loop, m);
for (;;)
{
mpfr_log (u, x, GMP_RNDD);
mpfr_neg (u, u, GMP_RNDN);
k = li2_series (s, u, GMP_RNDN);
mpfr_neg (s, s, GMP_RNDN);
err = 1 + MPFR_INT_CEIL_LOG2 (k + 1) - MPFR_GET_EXP (s);
mpfr_ui_sub (xx, 1, x, GMP_RNDN);
mpfr_log (v, xx, GMP_RNDU);
mpfr_mul (v, v, u, GMP_RNDN); /* v = - log(x) * log(1-x) */
mpfr_add (s, s, v, GMP_RNDN);
err = MAX (err, 1 - MPFR_GET_EXP (v));
err = 2 + MAX (3, err) - MPFR_GET_EXP (s);
mpfr_sqr (u, u, GMP_RNDN);
mpfr_div_2ui (u, u, 2, GMP_RNDN); /* u = log^2(x)/4 */
mpfr_add (s, s, u, GMP_RNDN);
err = MAX (err, 2 + MPFR_GET_EXP (u)) - MPFR_GET_EXP (s);
err = 2 + MAX (-1, err) + MPFR_GET_EXP (s);
mpfr_const_pi (u, GMP_RNDU);
mpfr_sqr (u, u, GMP_RNDN);
mpfr_div_ui (u, u, 6, GMP_RNDN); /* u = pi^2/6 */
mpfr_add (s, s, u, GMP_RNDN);
err = MAX (err, 3) - MPFR_GET_EXP (s);
err = 2 + MAX (-1, err);
if (MPFR_CAN_ROUND (s, (mp_exp_t) m - err, yp, rnd_mode))
break;
MPFR_ZIV_NEXT (loop, m);
mpfr_set_prec (s, m);
mpfr_set_prec (u, m);
mpfr_set_prec (v, m);
mpfr_set_prec (xx, m);
}
MPFR_ZIV_FREE (loop);
inexact = mpfr_set (y, s, rnd_mode);
mpfr_clears (s, u, v, xx, (mpfr_ptr) 0);
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (y, inexact, rnd_mode);
}
else if (mpfr_cmp_si (x, -1) >= 0)
/* 0 > x >= -1: Li2(x) = -S(log(1-x))-log^2(1-x)/4 */
{
int k;
mp_exp_t expo_l;
mpfr_t s, u, xx;
mpfr_init2 (s, m);
mpfr_init2 (u, m);
mpfr_init2 (xx, m);
MPFR_ZIV_INIT (loop, m);
for (;;)
{
mpfr_neg (xx, x, GMP_RNDN);
mpfr_log1p (u, xx, GMP_RNDN);
k = li2_series (s, u, GMP_RNDN);
mpfr_neg (s, s, GMP_RNDN);
expo_l = MPFR_GET_EXP (u);
err = 1 + MPFR_INT_CEIL_LOG2 (k + 1) - MPFR_GET_EXP (s);
mpfr_sqr (u, u, GMP_RNDN);
mpfr_div_2ui (u, u, 2, GMP_RNDN); /* u = log^2(1-x)/4 */
mpfr_sub (s, s, u, GMP_RNDN);
err = MAX (err, - expo_l);
err = 2 + MAX (err, 3);
if (MPFR_CAN_ROUND (s, (mp_exp_t) m - err, yp, rnd_mode))
break;
MPFR_ZIV_NEXT (loop, m);
mpfr_set_prec (s, m);
mpfr_set_prec (u, m);
mpfr_set_prec (xx, m);
}
MPFR_ZIV_FREE (loop);
inexact = mpfr_set (y, s, rnd_mode);
mpfr_clears (s, u, xx, (mpfr_ptr) 0);
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (y, inexact, rnd_mode);
}
else
/* x < -1: Li2(x)
= S(log(1-1/x))-log^2(-x)/4-log(1-x)log(-x)/2+log^2(1-x)/4-pi^2/6 */
{
int k;
mpfr_t s, u, v, w, xx;
if (mpfr_cmp_si (x, -7) <= 0)
{
inexact = mpfr_li2_asympt_neg (y, x, rnd_mode);
if (inexact != 0)
goto end_of_case_ltm1;
}
mpfr_init2 (s, m);
mpfr_init2 (u, m);
mpfr_init2 (v, m);
mpfr_init2 (w, m);
mpfr_init2 (xx, m);
MPFR_ZIV_INIT (loop, m);
for (;;)
{
mpfr_ui_div (xx, 1, x, GMP_RNDN);
mpfr_neg (xx, xx, GMP_RNDN);
mpfr_log1p (u, xx, GMP_RNDN);
k = li2_series (s, u, GMP_RNDN);
mpfr_ui_sub (xx, 1, x, GMP_RNDN);
mpfr_log (u, xx, GMP_RNDU);
mpfr_neg (xx, x, GMP_RNDN);
mpfr_log (v, xx, GMP_RNDU);
mpfr_mul (w, v, u, GMP_RNDN);
mpfr_div_2ui (w, w, 1, GMP_RNDN); /* w = log(-x) * log(1-x) / 2 */
mpfr_sub (s, s, w, GMP_RNDN);
err = 1 + MAX (3, MPFR_INT_CEIL_LOG2 (k+1) + 1 - MPFR_GET_EXP (s))
+ MPFR_GET_EXP (s);
mpfr_sqr (w, v, GMP_RNDN);
mpfr_div_2ui (w, w, 2, GMP_RNDN); /* w = log^2(-x) / 4 */
mpfr_sub (s, s, w, GMP_RNDN);
err = MAX (err, 3 + MPFR_GET_EXP(w)) - MPFR_GET_EXP (s);
err = 2 + MAX (-1, err) + MPFR_GET_EXP (s);
mpfr_sqr (w, u, GMP_RNDN);
mpfr_div_2ui (w, w, 2, GMP_RNDN); /* w = log^2(1-x) / 4 */
mpfr_add (s, s, w, GMP_RNDN);
err = MAX (err, 3 + MPFR_GET_EXP (w)) - MPFR_GET_EXP (s);
err = 2 + MAX (-1, err) + MPFR_GET_EXP (s);
mpfr_const_pi (w, GMP_RNDU);
mpfr_sqr (w, w, GMP_RNDN);
mpfr_div_ui (w, w, 6, GMP_RNDN); /* w = pi^2 / 6 */
mpfr_sub (s, s, w, GMP_RNDN);
err = MAX (err, 3) - MPFR_GET_EXP (s);
err = 2 + MAX (-1, err) + MPFR_GET_EXP (s);
if (MPFR_CAN_ROUND (s, (mp_exp_t) m - err, yp, rnd_mode))
break;
MPFR_ZIV_NEXT (loop, m);
mpfr_set_prec (s, m);
mpfr_set_prec (u, m);
mpfr_set_prec (v, m);
mpfr_set_prec (w, m);
mpfr_set_prec (xx, m);
}
MPFR_ZIV_FREE (loop);
inexact = mpfr_set (y, s, rnd_mode);
mpfr_clears (s, u, v, w, xx, (mpfr_ptr) 0);
end_of_case_ltm1:
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (y, inexact, rnd_mode);
}
MPFR_ASSERTN (0); /* should never reach this point */
}
/* Compute the alternating series
s = S(z) = \sum_{k=0}^infty B_{2k} (z))^{2k+1} / (2k+1)!
with 0 < z <= log(2) to the precision of s rounded in the direction
rnd_mode.
Return the maximum index of the truncature which is useful
for determinating the relative error.
*/
static int
li2_series (mpfr_t sum, mpfr_srcptr z, mpfr_rnd_t rnd_mode)
{
int i, Bm, Bmax;
mpfr_t s, u, v, w;
mpfr_prec_t sump, p;
mp_exp_t se, err;
mpz_t *B;
MPFR_ZIV_DECL (loop);
/* The series converges for |z| < 2 pi, but in mpfr_li2 the argument is
reduced so that 0 < z <= log(2). Here is additionnal check that z is
(nearly) correct */
MPFR_ASSERTD (MPFR_IS_STRICTPOS (z));
MPFR_ASSERTD (mpfr_cmp_d (z, 0.6953125) <= 0);
sump = MPFR_PREC (sum); /* target precision */
p = sump + MPFR_INT_CEIL_LOG2 (sump) + 4; /* the working precision */
mpfr_init2 (s, p);
mpfr_init2 (u, p);
mpfr_init2 (v, p);
mpfr_init2 (w, p);
B = bernoulli ((mpz_t *) 0, 0);
Bm = Bmax = 1;
MPFR_ZIV_INIT (loop, p);
for (;;)
{
mpfr_sqr (u, z, GMP_RNDU);
mpfr_set (v, z, GMP_RNDU);
mpfr_set (s, z, GMP_RNDU);
se = MPFR_GET_EXP (s);
err = 0;
for (i = 1;; i++)
{
if (i >= Bmax)
B = bernoulli (B, Bmax++); /* B_2i * (2i+1)!, exact */
mpfr_mul (v, u, v, GMP_RNDU);
mpfr_div_ui (v, v, 2 * i, GMP_RNDU);
mpfr_div_ui (v, v, 2 * i, GMP_RNDU);
mpfr_div_ui (v, v, 2 * i + 1, GMP_RNDU);
mpfr_div_ui (v, v, 2 * i + 1, GMP_RNDU);
/* here, v_2i = v_{2i-2} / (2i * (2i+1))^2 */
mpfr_mul_z (w, v, B[i], GMP_RNDN);
/* here, w_2i = v_2i * B_2i * (2i+1)! with
error(w_2i) < 2^(5 * i + 8) ulp(w_2i) (see algorithms.tex) */
mpfr_add (s, s, w, GMP_RNDN);
err = MAX (err + se, 5 * i + 8 + MPFR_GET_EXP (w))
- MPFR_GET_EXP (s);
err = 2 + MAX (-1, err);
se = MPFR_GET_EXP (s);
if (MPFR_GET_EXP (w) <= se - (mp_exp_t) p)
break;
}
/* the previous value of err is the rounding error,
the truncation error is less than EXP(z) - 6 * i - 5
(see algorithms.tex) */
err = MAX (err, MPFR_GET_EXP (z) - 6 * i - 5) + 1;
if (MPFR_CAN_ROUND (s, (mp_exp_t) p - err, sump, rnd_mode))
break;
MPFR_ZIV_NEXT (loop, p);
mpfr_set_prec (s, p);
mpfr_set_prec (u, p);
mpfr_set_prec (v, p);
mpfr_set_prec (w, p);
}
MPFR_ZIV_FREE (loop);
mpfr_set (sum, s, rnd_mode);
Bm = Bmax;
while (Bm--)
mpz_clear (B[Bm]);
(*__gmp_free_func) (B, Bmax * sizeof (mpz_t));
mpfr_clears (s, u, v, w, (mpfr_ptr) 0);
/* Let K be the returned value.
1. As we compute an alternating series, the truncation error has the same
sign as the next term w_{K+2} which is positive iff K%4 == 0.
2. Assume that error(z) <= (1+t) z', where z' is the actual value, then
error(s) <= 2 * (K+1) * t (see algorithms.tex).
*/
return 2 * i;
}
void mexFunction( int nlhs, mxArray *plhs[],
int nrhs, const mxArray *prhs[] )
{
double *prec,*eoutr,*eouti;
int mrows,ncols;
char *input_buf;
char *w1,*w2;
int buflen,status;
mpfr_t xr,xi,yr,yi,zr,zi,temp,temp1,temp2,temp3,temp4;
mp_exp_t expptr;
/* Check for proper number of arguments. */
if(nrhs!=5) {
mexErrMsgTxt("5 inputs required.");
} else if(nlhs>4) {
mexErrMsgTxt("Too many output arguments");
}
/* The input must be a noncomplex scalar double.*/
mrows = mxGetM(prhs[0]);
ncols = mxGetN(prhs[0]);
if( !mxIsDouble(prhs[0]) || mxIsComplex(prhs[0]) ||
!(mrows==1 && ncols==1) ) {
mexErrMsgTxt("Input must be a noncomplex scalar double.");
}
/* Set precision and initialize mpfr variables */
prec = mxGetPr(prhs[0]);
mpfr_set_default_prec(*prec);
mpfr_init(xr); mpfr_init(xi);
mpfr_init(yr); mpfr_init(yi);
mpfr_init(zr); mpfr_init(zi);
mpfr_init(temp); mpfr_init(temp1);
mpfr_init(temp2); mpfr_init(temp3);
mpfr_init(temp4);
/* Read the input strings into mpfr x real */
buflen = (mxGetM(prhs[1]) * mxGetN(prhs[1])) + 1;
input_buf=mxCalloc(buflen, sizeof(char));
status = mxGetString(prhs[1], input_buf, buflen);
mpfr_set_str(xr,input_buf,10,GMP_RNDN);
/* Read the input strings into mpfr x imag */
buflen = (mxGetM(prhs[2]) * mxGetN(prhs[2])) + 1;
input_buf=mxCalloc(buflen, sizeof(char));
status = mxGetString(prhs[2], input_buf, buflen);
mpfr_set_str(xi,input_buf,10,GMP_RNDN);
/* Read the input strings into mpfr y real */
buflen = (mxGetM(prhs[3]) * mxGetN(prhs[3])) + 1;
input_buf=mxCalloc(buflen, sizeof(char));
status = mxGetString(prhs[3], input_buf, buflen);
mpfr_set_str(yr,input_buf,10,GMP_RNDN);
/* Read the input strings into mpfr y imag */
buflen = (mxGetM(prhs[4]) * mxGetN(prhs[4])) + 1;
input_buf=mxCalloc(buflen, sizeof(char));
status = mxGetString(prhs[4], input_buf, buflen);
mpfr_set_str(yi,input_buf,10,GMP_RNDN);
/* Mathematical operation */
/* ln(magnitude) */
mpfr_mul(temp,xr,xr,GMP_RNDN);
mpfr_mul(temp1,xi,xi,GMP_RNDN);
mpfr_add(temp,temp,temp1,GMP_RNDN);
mpfr_sqrt(temp,temp,GMP_RNDN);
mpfr_log(temp,temp,GMP_RNDN);
/* angle */
mpfr_atan2(temp1,xi,xr,GMP_RNDN);
/* real exp */
mpfr_mul(temp3,temp,yr,GMP_RNDN);
mpfr_mul(temp2,temp1,yi,GMP_RNDN);
mpfr_sub(temp3,temp3,temp2,GMP_RNDN);
mpfr_exp(temp3,temp3,GMP_RNDN);
/* cos sin argument */
mpfr_mul(temp2,temp1,yr,GMP_RNDN);
mpfr_mul(temp4,temp,yi,GMP_RNDN);
mpfr_add(temp2,temp2,temp4,GMP_RNDN);
mpfr_cos(zr,temp2,GMP_RNDN);
mpfr_mul(zr,zr,temp3,GMP_RNDN);
mpfr_sin(zi,temp2,GMP_RNDN);
mpfr_mul(zi,zi,temp3,GMP_RNDN);
/* Retrieve results */
mxFree(input_buf);
input_buf=mpfr_get_str (NULL, &expptr, 10, 0, zr, GMP_RNDN);
w1=malloc(strlen(input_buf)+20);
w2=malloc(strlen(input_buf)+20);
if (strncmp(input_buf, "-", 1)==0){
strcpy(w2,&input_buf[1]);
sprintf(w1,"-.%se%i",w2,expptr);
} else {
strcpy(w2,&input_buf[0]);
sprintf(w1,"+.%se%i",w2,expptr);
}
plhs[0] = mxCreateString(w1);
/* plhs[1] = mxCreateDoubleMatrix(mrows,ncols, mxREAL); */
/* eoutr=mxGetPr(plhs[1]); */
/* *eoutr=expptr; */
mpfr_free_str(input_buf);
input_buf=mpfr_get_str (NULL, &expptr, 10, 0, zi, GMP_RNDN);
free(w1);
free(w2);
w1=malloc(strlen(input_buf)+20);
w2=malloc(strlen(input_buf)+20);
if (strncmp(input_buf, "-", 1)==0){
strcpy(w2,&input_buf[1]);
sprintf(w1,"-.%se%i",w2,expptr);
} else {
strcpy(w2,&input_buf[0]);
sprintf(w1,"+.%se%i",w2,expptr);
}
plhs[1] = mxCreateString(w1);
/* plhs[3] = mxCreateDoubleMatrix(mrows,ncols, mxREAL); */
/* eouti=mxGetPr(plhs[3]); */
/* *eouti=expptr; */
mpfr_clear(xr); mpfr_clear(xi);
mpfr_clear(yr); mpfr_clear(yi);
mpfr_clear(zr); mpfr_clear(zi);
mpfr_clear(temp); mpfr_clear(temp1);
mpfr_clear(temp2); mpfr_clear(temp3);
mpfr_clear(temp4);
mpfr_free_str(input_buf);
free(w1);
free(w2);
}
static void
_assympt_mpfr (gulong l, mpq_t q, mpfr_ptr res, mp_rnd_t rnd)
{
NcmBinSplit **bs_ptr = _ncm_mpsf_sbessel_get_bs ();
NcmBinSplit *bs = *bs_ptr;
_binsplit_spherical_bessel *data = (_binsplit_spherical_bessel *) bs->userdata;
gulong prec = mpfr_get_prec (res);
#define sin_x data->sin
#define cos_x data->cos
mpfr_set_prec (sin_x, prec);
mpfr_set_prec (cos_x, prec);
mpfr_set_q (res, q, rnd);
mpfr_sin_cos (sin_x, cos_x, res, rnd);
switch (l % 4)
{
case 0:
break;
case 1:
mpfr_swap (sin_x, cos_x);
mpfr_neg (sin_x, sin_x, rnd);
break;
case 2:
mpfr_neg (sin_x, sin_x, rnd);
mpfr_neg (cos_x, cos_x, rnd);
break;
case 3:
mpfr_swap (sin_x, cos_x);
mpfr_neg (cos_x, cos_x, rnd);
break;
}
if (l > 0)
{
mpfr_mul_ui (cos_x, cos_x, l * (l + 1), rnd);
mpfr_div (cos_x, cos_x, res, rnd);
mpfr_div (cos_x, cos_x, res, rnd);
mpfr_div_2ui (cos_x, cos_x, 1, rnd);
}
mpfr_div (sin_x, sin_x, res, rnd);
data->l = l;
mpq_inv (data->mq2_2, q);
mpq_mul (data->mq2_2, data->mq2_2, data->mq2_2);
mpq_neg (data->mq2_2, data->mq2_2);
mpq_div_2exp (data->mq2_2, data->mq2_2, 2);
data->sincos = 0;
binsplit_spherical_bessel_assympt (bs, 0, (l + 1) / 2 + (l + 1) % 2);
mpfr_mul_z (sin_x, sin_x, bs->T, rnd);
mpfr_div_z (sin_x, sin_x, bs->Q, rnd);
data->sincos = 1;
if (l > 0)
{
binsplit_spherical_bessel_assympt (bs, 0, l / 2 + l % 2);
mpfr_mul_z (cos_x, cos_x, bs->T, rnd);
mpfr_div_z (cos_x, cos_x, bs->Q, rnd);
mpfr_add (res, sin_x, cos_x, rnd);
}
else
mpfr_set (res, sin_x, rnd);
ncm_memory_pool_return (bs_ptr);
return;
}
static PyObject *
GMPy_Real_Add(PyObject *x, PyObject *y, CTXT_Object *context)
{
MPFR_Object *result = NULL;
CHECK_CONTEXT(context);
if (!(result = GMPy_MPFR_New(0, context))) {
/* LCOV_EXCL_START */
return NULL;
/* LCOV_EXCL_STOP */
}
if (MPFR_Check(x) && MPFR_Check(y)) {
mpfr_clear_flags();
SET_MPFR_MPFR_WAS_NAN(context, x, y);
result->rc = mpfr_add(result->f, MPFR(x), MPFR(y), GET_MPFR_ROUND(context));
goto done;
}
if (MPFR_Check(x)) {
if (PyIntOrLong_Check(y)) {
int error;
long temp = GMPy_Integer_AsLongAndError(y, &error);
if (!error) {
mpfr_clear_flags();
SET_MPFR_WAS_NAN(context, x);
result->rc = mpfr_add_si(result->f, MPFR(x), temp, GET_MPFR_ROUND(context));
goto done;
}
else {
mpz_set_PyIntOrLong(global.tempz, y);
mpfr_clear_flags();
SET_MPFR_WAS_NAN(context, x);
result->rc = mpfr_add_z(result->f, MPFR(x), global.tempz, GET_MPFR_ROUND(context));
goto done;
}
}
if (CHECK_MPZANY(y)) {
mpfr_clear_flags();
SET_MPFR_WAS_NAN(context, x);
result->rc = mpfr_add_z(result->f, MPFR(x), MPZ(y), GET_MPFR_ROUND(context));
goto done;
}
if (IS_RATIONAL(y)) {
MPQ_Object *tempy = NULL;
if (!(tempy = GMPy_MPQ_From_Number(y, context))) {
/* LCOV_EXCL_START */
Py_DECREF((PyObject*)result);
return NULL;
/* LCOV_EXCL_STOP */
}
mpfr_clear_flags();
SET_MPFR_WAS_NAN(context, x);
result->rc = mpfr_add_q(result->f, MPFR(x), tempy->q, GET_MPFR_ROUND(context));
Py_DECREF((PyObject*)tempy);
goto done;
}
if (PyFloat_Check(y)) {
mpfr_clear_flags();
SET_MPFR_FLOAT_WAS_NAN(context, x, y);
result->rc = mpfr_add_d(result->f, MPFR(x), PyFloat_AS_DOUBLE(y), GET_MPFR_ROUND(context));
goto done;
}
}
if (MPFR_Check(y)) {
if (PyIntOrLong_Check(x)) {
int error;
long temp = GMPy_Integer_AsLongAndError(x, &error);
if (!error) {
mpfr_clear_flags();
SET_MPFR_WAS_NAN(context, y);
result->rc = mpfr_add_si(result->f, MPFR(y), temp, GET_MPFR_ROUND(context));
goto done;
}
else {
mpz_set_PyIntOrLong(global.tempz, x);
mpfr_clear_flags();
SET_MPFR_WAS_NAN(context, y);
result->rc = mpfr_add_z(result->f, MPFR(y), global.tempz, GET_MPFR_ROUND(context));
goto done;
}
}
if (CHECK_MPZANY(x)) {
mpfr_clear_flags();
SET_MPFR_WAS_NAN(context, y);
result->rc = mpfr_add_z(result->f, MPFR(y), MPZ(x), GET_MPFR_ROUND(context));
goto done;
}
if (IS_RATIONAL(x)) {
MPQ_Object *tempx = NULL;
if (!(tempx = GMPy_MPQ_From_Number(x, context))) {
/* LCOV_EXCL_START */
Py_DECREF((PyObject*)result);
return NULL;
/* LCOV_EXCL_STOP */
}
mpfr_clear_flags();
SET_MPFR_WAS_NAN(context, y);
result->rc = mpfr_add_q(result->f, MPFR(y), tempx->q, GET_MPFR_ROUND(context));
Py_DECREF((PyObject*)tempx);
goto done;
}
if (PyFloat_Check(x)) {
mpfr_clear_flags();
SET_MPFR_FLOAT_WAS_NAN(context, y, x);
result->rc = mpfr_add_d(result->f, MPFR(y), PyFloat_AS_DOUBLE(x), GET_MPFR_ROUND(context));
goto done;
}
}
if (IS_REAL(x) && IS_REAL(y)) {
MPFR_Object *tempx = NULL, *tempy = NULL;
if (!(tempx = GMPy_MPFR_From_Real(x, 1, context)) ||
!(tempy = GMPy_MPFR_From_Real(y, 1, context))) {
/* LCOV_EXCL_START */
Py_XDECREF((PyObject*)tempx);
Py_XDECREF((PyObject*)tempy);
Py_DECREF((PyObject*)result);
return NULL;
/* LCOV_EXCL_STOP */
}
mpfr_clear_flags();
SET_MPFR_MPFR_WAS_NAN(context, tempx, tempy);
result->rc = mpfr_add(result->f, MPFR(tempx), MPFR(tempy), GET_MPFR_ROUND(context));
Py_DECREF((PyObject*)tempx);
Py_DECREF((PyObject*)tempy);
goto done;
}
/* LCOV_EXCL_START */
Py_DECREF((PyObject*)result);
SYSTEM_ERROR("Internal error in GMPy_Real_Add().");
return NULL;
/* LCOV_EXCL_STOP */
done:
_GMPy_MPFR_Cleanup(&result, context);
return (PyObject*)result;
}
int
main (int argc, char *argv[])
{
mpfr_t x, y;
mp_exp_t emin, emax;
tests_start_mpfr ();
test_set_underflow ();
test_set_overflow ();
check_default_rnd();
mpfr_init (x);
mpfr_init (y);
emin = mpfr_get_emin ();
emax = mpfr_get_emax ();
if (emin >= emax)
{
printf ("Error: emin >= emax\n");
exit (1);
}
mpfr_set_ui (x, 1, GMP_RNDN);
mpfr_mul_2exp (x, x, 1024, GMP_RNDN);
mpfr_set_double_range ();
mpfr_check_range (x, 0, GMP_RNDN);
if (!mpfr_inf_p (x) || (mpfr_sgn(x) <= 0))
{
printf ("Error: 2^1024 rounded to nearest should give +Inf\n");
exit (1);
}
set_emax (1025);
mpfr_set_ui (x, 1, GMP_RNDN);
mpfr_mul_2exp (x, x, 1024, GMP_RNDN);
mpfr_set_double_range ();
mpfr_check_range (x, 0, GMP_RNDD);
if (!mpfr_number_p (x))
{
printf ("Error: 2^1024 rounded down should give a normal number\n");
exit (1);
}
mpfr_set_ui (x, 1, GMP_RNDN);
mpfr_mul_2exp (x, x, 1023, GMP_RNDN);
mpfr_add (x, x, x, GMP_RNDN);
if (!mpfr_inf_p (x) || (mpfr_sgn(x) <= 0))
{
printf ("Error: x+x rounded to nearest for x=2^1023 should give +Inf\n");
printf ("emax = %ld\n", mpfr_get_emax ());
printf ("got "); mpfr_print_binary (x); puts ("");
exit (1);
}
mpfr_set_ui (x, 1, GMP_RNDN);
mpfr_mul_2exp (x, x, 1023, GMP_RNDN);
mpfr_add (x, x, x, GMP_RNDD);
if (!mpfr_number_p (x))
{
printf ("Error: x+x rounded down for x=2^1023 should give"
" a normal number\n");
exit (1);
}
mpfr_set_ui (x, 1, GMP_RNDN);
mpfr_div_2exp (x, x, 1022, GMP_RNDN);
mpfr_set_str_binary (y, "1.1e-1022"); /* y = 3/2*x */
mpfr_sub (y, y, x, GMP_RNDZ);
if (mpfr_cmp_ui (y, 0))
{
printf ("Error: y-x rounded to zero should give 0"
" for y=3/2*2^(-1022), x=2^(-1022)\n");
printf ("y="); mpfr_print_binary (y); puts ("");
exit (1);
}
set_emin (-1026);
mpfr_set_ui (x, 1, GMP_RNDN);
mpfr_div_2exp (x, x, 1025, GMP_RNDN);
mpfr_set_double_range ();
mpfr_check_range (x, 0, GMP_RNDN);
if (!MPFR_IS_ZERO (x) )
{
printf ("Error: x rounded to nearest for x=2^-1024 should give Zero\n");
printf ("emin = %ld\n", mpfr_get_emin ());
printf ("got "); mpfr_dump (x);
exit (1);
}
mpfr_clear (x);
mpfr_clear (y);
check_emin_emax();
check_flags();
tests_end_mpfr ();
return 0;
}
int
mpfr_acosh (mpfr_ptr y, mpfr_srcptr x , mpfr_rnd_t rnd_mode)
{
MPFR_SAVE_EXPO_DECL (expo);
int inexact;
int comp;
MPFR_LOG_FUNC (
("x[%Pu]=%.*Rg rnd=%d", mpfr_get_prec (x), mpfr_log_prec, x, rnd_mode),
("y[%Pu]=%.*Rg inexact=%d", mpfr_get_prec (y), mpfr_log_prec, y,
inexact));
/* Deal with special cases */
if (MPFR_UNLIKELY (MPFR_IS_SINGULAR (x)))
{
/* Nan, or zero or -Inf */
if (MPFR_IS_INF (x) && MPFR_IS_POS (x))
{
MPFR_SET_INF (y);
MPFR_SET_POS (y);
MPFR_RET (0);
}
else /* Nan, or zero or -Inf */
{
MPFR_SET_NAN (y);
MPFR_RET_NAN;
}
}
comp = mpfr_cmp_ui (x, 1);
if (MPFR_UNLIKELY (comp < 0))
{
MPFR_SET_NAN (y);
MPFR_RET_NAN;
}
else if (MPFR_UNLIKELY (comp == 0))
{
MPFR_SET_ZERO (y); /* acosh(1) = 0 */
MPFR_SET_POS (y);
MPFR_RET (0);
}
MPFR_SAVE_EXPO_MARK (expo);
/* General case */
{
/* Declaration of the intermediary variables */
mpfr_t t;
/* Declaration of the size variables */
mpfr_prec_t Ny = MPFR_PREC(y); /* Precision of output variable */
mpfr_prec_t Nt; /* Precision of the intermediary variable */
mpfr_exp_t err, exp_te, d; /* Precision of error */
MPFR_ZIV_DECL (loop);
/* compute the precision of intermediary variable */
/* the optimal number of bits : see algorithms.tex */
Nt = Ny + 4 + MPFR_INT_CEIL_LOG2 (Ny);
/* initialization of intermediary variables */
mpfr_init2 (t, Nt);
/* First computation of acosh */
MPFR_ZIV_INIT (loop, Nt);
for (;;)
{
MPFR_BLOCK_DECL (flags);
/* compute acosh */
MPFR_BLOCK (flags, mpfr_mul (t, x, x, MPFR_RNDD)); /* x^2 */
if (MPFR_OVERFLOW (flags))
{
mpfr_t ln2;
mpfr_prec_t pln2;
/* As x is very large and the precision is not too large, we
assume that we obtain the same result by evaluating ln(2x).
We need to compute ln(x) + ln(2) as 2x can overflow. TODO:
write a proof and add an MPFR_ASSERTN. */
mpfr_log (t, x, MPFR_RNDN); /* err(log) < 1/2 ulp(t) */
pln2 = Nt - MPFR_PREC_MIN < MPFR_GET_EXP (t) ?
MPFR_PREC_MIN : Nt - MPFR_GET_EXP (t);
mpfr_init2 (ln2, pln2);
mpfr_const_log2 (ln2, MPFR_RNDN); /* err(ln2) < 1/2 ulp(t) */
mpfr_add (t, t, ln2, MPFR_RNDN); /* err <= 3/2 ulp(t) */
mpfr_clear (ln2);
err = 1;
}
else
{
exp_te = MPFR_GET_EXP (t);
mpfr_sub_ui (t, t, 1, MPFR_RNDD); /* x^2-1 */
if (MPFR_UNLIKELY (MPFR_IS_ZERO (t)))
{
/* This means that x is very close to 1: x = 1 + t with
t < 2^(-Nt). We have: acosh(x) = sqrt(2t) (1 - eps(t))
with 0 < eps(t) < t / 12. */
mpfr_sub_ui (t, x, 1, MPFR_RNDD); /* t = x - 1 */
mpfr_mul_2ui (t, t, 1, MPFR_RNDN); /* 2t */
mpfr_sqrt (t, t, MPFR_RNDN); /* sqrt(2t) */
err = 1;
}
else
{
d = exp_te - MPFR_GET_EXP (t);
mpfr_sqrt (t, t, MPFR_RNDN); /* sqrt(x^2-1) */
mpfr_add (t, t, x, MPFR_RNDN); /* sqrt(x^2-1)+x */
mpfr_log (t, t, MPFR_RNDN); /* ln(sqrt(x^2-1)+x) */
/* error estimate -- see algorithms.tex */
err = 3 + MAX (1, d) - MPFR_GET_EXP (t);
/* error is bounded by 1/2 + 2^err <= 2^(max(0,1+err)) */
err = MAX (0, 1 + err);
}
}
if (MPFR_LIKELY (MPFR_CAN_ROUND (t, Nt - err, Ny, rnd_mode)))
break;
/* reactualisation of the precision */
MPFR_ZIV_NEXT (loop, Nt);
mpfr_set_prec (t, Nt);
}
MPFR_ZIV_FREE (loop);
inexact = mpfr_set (y, t, rnd_mode);
mpfr_clear (t);
}
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (y, inexact, rnd_mode);
}
/* we have x >= 1/2 here */
static int
mpfr_digamma_positive (mpfr_ptr y, mpfr_srcptr x, mpfr_rnd_t rnd_mode)
{
mpfr_prec_t p = MPFR_PREC(y) + 10, q;
mpfr_t t, u, x_plus_j;
int inex;
mpfr_exp_t errt, erru, expt;
unsigned long j = 0, min;
MPFR_ZIV_DECL (loop);
MPFR_LOG_FUNC
(("x[%Pu]=%.*Rg rnd=%d", mpfr_get_prec(x), mpfr_log_prec, x, rnd_mode),
("y[%Pu]=%.*Rg inexact=%d", mpfr_get_prec(y), mpfr_log_prec, y, inex));
/* compute a precision q such that x+1 is exact */
if (MPFR_PREC(x) < MPFR_EXP(x))
q = MPFR_EXP(x);
else
q = MPFR_PREC(x) + 1;
/* for very large x, use |digamma(x) - log(x)| < 1/x < 2^(1-EXP(x)) */
if (MPFR_PREC(y) + 10 < MPFR_EXP(x))
{
/* this ensures EXP(x) >= 3, thus x >= 4, thus log(x) > 1 */
mpfr_init2 (t, MPFR_PREC(y) + 10);
mpfr_log (t, x, MPFR_RNDZ);
if (MPFR_CAN_ROUND (t, MPFR_PREC(y) + 10, MPFR_PREC(y), rnd_mode))
{
inex = mpfr_set (y, t, rnd_mode);
mpfr_clear (t);
return inex;
}
mpfr_clear (t);
}
mpfr_init2 (x_plus_j, q);
mpfr_init2 (t, p);
mpfr_init2 (u, p);
MPFR_ZIV_INIT (loop, p);
for(;;)
{
/* Lower bound for x+j in mpfr_digamma_approx call: since the smallest
term of the divergent series for Digamma(x) is about exp(-2*Pi*x), and
we want it to be less than 2^(-p), this gives x > p*log(2)/(2*Pi)
i.e., x >= 0.1103 p.
To be safe, we ensure x >= 0.25 * p.
*/
min = (p + 3) / 4;
if (min < 2)
min = 2;
mpfr_set (x_plus_j, x, MPFR_RNDN);
mpfr_set_ui (u, 0, MPFR_RNDN);
j = 0;
while (mpfr_cmp_ui (x_plus_j, min) < 0)
{
j ++;
mpfr_ui_div (t, 1, x_plus_j, MPFR_RNDN); /* err <= 1/2 ulp */
mpfr_add (u, u, t, MPFR_RNDN);
inex = mpfr_add_ui (x_plus_j, x_plus_j, 1, MPFR_RNDZ);
if (inex != 0) /* we lost one bit */
{
q ++;
mpfr_prec_round (x_plus_j, q, MPFR_RNDZ);
mpfr_nextabove (x_plus_j);
}
/* since all terms are positive, the error is bounded by j ulps */
}
for (erru = 0; j > 1; erru++, j = (j + 1) / 2);
errt = mpfr_digamma_approx (t, x_plus_j);
expt = MPFR_EXP(t);
mpfr_sub (t, t, u, MPFR_RNDN);
if (MPFR_EXP(t) < expt)
errt += expt - MPFR_EXP(t);
if (MPFR_EXP(t) < MPFR_EXP(u))
erru += MPFR_EXP(u) - MPFR_EXP(t);
if (errt > erru)
errt = errt + 1;
else if (errt == erru)
errt = errt + 2;
else
errt = erru + 1;
if (MPFR_CAN_ROUND (t, p - errt, MPFR_PREC(y), rnd_mode))
break;
MPFR_ZIV_NEXT (loop, p);
mpfr_set_prec (t, p);
mpfr_set_prec (u, p);
}
MPFR_ZIV_FREE (loop);
inex = mpfr_set (y, t, rnd_mode);
mpfr_clear (t);
mpfr_clear (u);
mpfr_clear (x_plus_j);
return inex;
}
int fractal_mpfr_calculate_line(image_info* img, int line)
{
int ret = 1;
int ix = 0;
int mx = 0;
int chk_px = ((rthdata*)img->rth_ptr)->check_stop_px;
int img_width = img->real_width;
int* raw_data = &img->raw_data[line * img_width];
depth_t depth = img->depth;
mpfr_t x, y;
mpfr_t x2, y2;
mpfr_t c_re, c_im;
/* working variables: */
mpfr_t wre, wim;
mpfr_t wre2, wim2;
mpfr_t frs_bail;
mpfr_t width, img_rw, img_xmin;
mpfr_t t1;
mpfr_init2(x, img->precision);
mpfr_init2(y, img->precision);
mpfr_init2(x2, img->precision);
mpfr_init2(y2, img->precision);
mpfr_init2(c_re, img->precision);
mpfr_init2(c_im, img->precision);
mpfr_init2(wre, img->precision);
mpfr_init2(wim, img->precision);
mpfr_init2(wre2, img->precision);
mpfr_init2(wim2, img->precision);
mpfr_init2(frs_bail,img->precision);
mpfr_init2(width, img->precision);
mpfr_init2(img_rw, img->precision);
mpfr_init2(img_xmin,img->precision);
mpfr_init2(t1, img->precision);
mpfr_set_si(frs_bail, 4, GMP_RNDN);
mpfr_set_si(img_rw, img_width, GMP_RNDN);
mpfr_set( img_xmin, img->xmin, GMP_RNDN);
mpfr_set( width, img->width, GMP_RNDN);
/* y = img->ymax - ((img->xmax - img->xmin)
/ (long double)img->real_width)
* (long double)img->lines_done; */
mpfr_div( t1, width, img_rw, GMP_RNDN);
mpfr_mul_si( t1, t1, line, GMP_RNDN);
mpfr_sub( y, img->ymax, t1, GMP_RNDN);
mpfr_mul( y2, y, y, GMP_RNDN);
while (ix < img_width)
{
mx += chk_px;
if (mx > img_width)
mx = img_width;
for (; ix < mx; ++ix, ++raw_data)
{
/* x = ((long double)ix / (long double)img->real_width)
* (img->xmax - img->xmin) + img->xmin; */
mpfr_si_div(t1, ix, img_rw, GMP_RNDN);
mpfr_mul(x, t1, width, GMP_RNDN);
mpfr_add(x, x, img_xmin, GMP_RNDN);
mpfr_mul( x2, x, x, GMP_RNDN);
mpfr_set( wre, x, GMP_RNDN);
mpfr_set( wim, y, GMP_RNDN);
mpfr_set( wre2, x2, GMP_RNDN);
mpfr_set( wim2, y2, GMP_RNDN);
switch (img->family)
{
case FAMILY_MANDEL:
mpfr_set(c_re, x, GMP_RNDN);
mpfr_set(c_im, y, GMP_RNDN);
break;
case FAMILY_JULIA:
mpfr_set(c_re, img->u.julia.c_re, GMP_RNDN);
mpfr_set(c_im, img->u.julia.c_im, GMP_RNDN);
break;
}
switch(img->fractal)
{
case BURNING_SHIP:
*raw_data = frac_burning_ship_mpfr(
depth, frs_bail,
wim, wre,
c_im, c_re,
wim2, wre2, t1);
break;
case GENERALIZED_CELTIC:
*raw_data = frac_generalized_celtic_mpfr(
depth, frs_bail,
wim, wre,
c_im, c_re,
wim2, wre2, t1);
break;
case VARIANT:
*raw_data = frac_variant_mpfr(
depth, frs_bail,
wim, wre,
c_im, c_re,
wim2, wre2, t1);
break;
case MANDELBROT:
default:
*raw_data = frac_mandel_mpfr(depth, frs_bail,
wim, wre,
c_im, c_re,
wim2, wre2, t1);
}
}
if (rth_render_should_stop((rthdata*)img->rth_ptr))
{
ret = 0;
break;
}
}
mpfr_clear(x);
mpfr_clear(y);
mpfr_clear(x2);
mpfr_clear(y2);
mpfr_clear(c_re);
mpfr_clear(c_im);
mpfr_clear(wre);
mpfr_clear(wim);
mpfr_clear(wre2);
mpfr_clear(wim2);
mpfr_clear(frs_bail);
mpfr_clear(width);
mpfr_clear(img_rw);
mpfr_clear(t1);
return ret;
}
/* 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 */
}
void generate_2D_sample (FILE *output, struct speed_params2D param)
{
mpfr_t temp;
double incr_prec;
mpfr_t incr_x;
mpfr_t x, x2;
double prec;
struct speed_params s;
int i;
int test;
int nb_functions;
double *t; /* store the timing of each implementation */
/* We first determine how many implementations we have */
nb_functions = 0;
while (param.speed_funcs[nb_functions] != NULL)
nb_functions++;
t = malloc (nb_functions * sizeof (double));
if (t == NULL)
{
fprintf (stderr, "Can't allocate memory.\n");
abort ();
}
mpfr_init2 (temp, MPFR_SMALL_PRECISION);
/* The precision is sampled from min_prec to max_prec with */
/* approximately nb_points_prec points. If logarithmic_scale_prec */
/* is true, the precision is multiplied by incr_prec at each */
/* step. Otherwise, incr_prec is added at each step. */
if (param.logarithmic_scale_prec)
{
mpfr_set_ui (temp, (unsigned long int)param.max_prec, MPFR_RNDU);
mpfr_div_ui (temp, temp, (unsigned long int)param.min_prec, MPFR_RNDU);
mpfr_root (temp, temp,
(unsigned long int)param.nb_points_prec, MPFR_RNDU);
incr_prec = mpfr_get_d (temp, MPFR_RNDU);
}
else
{
incr_prec = (double)param.max_prec - (double)param.min_prec;
incr_prec = incr_prec/((double)param.nb_points_prec);
}
/* The points x are sampled according to the following rule: */
/* If logarithmic_scale_x = 0: */
/* nb_points_x points are equally distributed between min_x and max_x */
/* If logarithmic_scale_x = 1: */
/* nb_points_x points are sampled from 2^(min_x) to 2^(max_x). At */
/* each step, the current point is multiplied by incr_x. */
/* If logarithmic_scale_x = -1: */
/* nb_points_x/2 points are sampled from -2^(max_x) to -2^(min_x) */
/* (at each step, the current point is divided by incr_x); and */
/* nb_points_x/2 points are sampled from 2^(min_x) to 2^(max_x) */
/* (at each step, the current point is multiplied by incr_x). */
mpfr_init2 (incr_x, param.max_prec);
if (param.logarithmic_scale_x == 0)
{
mpfr_set_d (incr_x,
(param.max_x - param.min_x)/(double)param.nb_points_x,
MPFR_RNDU);
}
else if (param.logarithmic_scale_x == -1)
{
mpfr_set_d (incr_x,
2.*(param.max_x - param.min_x)/(double)param.nb_points_x,
MPFR_RNDU);
mpfr_exp2 (incr_x, incr_x, MPFR_RNDU);
}
else
{ /* other values of param.logarithmic_scale_x are considered as 1 */
mpfr_set_d (incr_x,
(param.max_x - param.min_x)/(double)param.nb_points_x,
MPFR_RNDU);
mpfr_exp2 (incr_x, incr_x, MPFR_RNDU);
}
/* Main loop */
mpfr_init2 (x, param.max_prec);
mpfr_init2 (x2, param.max_prec);
prec = (double)param.min_prec;
while (prec <= param.max_prec)
{
printf ("prec = %d\n", (int)prec);
if (param.logarithmic_scale_x == 0)
mpfr_set_d (temp, param.min_x, MPFR_RNDU);
else if (param.logarithmic_scale_x == -1)
{
mpfr_set_d (temp, param.max_x, MPFR_RNDD);
mpfr_exp2 (temp, temp, MPFR_RNDD);
mpfr_neg (temp, temp, MPFR_RNDU);
}
else
{
mpfr_set_d (temp, param.min_x, MPFR_RNDD);
mpfr_exp2 (temp, temp, MPFR_RNDD);
}
/* We perturb x a little bit, in order to avoid trailing zeros that */
/* might change the behavior of algorithms. */
mpfr_const_pi (x, MPFR_RNDN);
mpfr_div_2ui (x, x, 7, MPFR_RNDN);
mpfr_add_ui (x, x, 1, MPFR_RNDN);
mpfr_mul (x, x, temp, MPFR_RNDN);
test = 1;
while (test)
{
mpfr_fprintf (output, "%e\t", mpfr_get_d (x, MPFR_RNDN));
mpfr_fprintf (output, "%Pu\t", (mpfr_prec_t)prec);
s.r = (mp_limb_t)mpfr_get_exp (x);
s.size = (mpfr_prec_t)prec;
s.align_xp = (mpfr_sgn (x) > 0)?1:2;
mpfr_set_prec (x2, (mpfr_prec_t)prec);
mpfr_set (x2, x, MPFR_RNDU);
s.xp = x2->_mpfr_d;
for (i=0; i<nb_functions; i++)
{
t[i] = speed_measure (param.speed_funcs[i], &s);
mpfr_fprintf (output, "%e\t", t[i]);
}
fprintf (output, "%d\n", 1 + find_best (t, nb_functions));
if (param.logarithmic_scale_x == 0)
{
mpfr_add (x, x, incr_x, MPFR_RNDU);
if (mpfr_cmp_d (x, param.max_x) > 0)
test=0;
}
else
{
if (mpfr_sgn (x) < 0 )
{ /* if x<0, it means that logarithmic_scale_x=-1 */
mpfr_div (x, x, incr_x, MPFR_RNDU);
mpfr_abs (temp, x, MPFR_RNDD);
mpfr_log2 (temp, temp, MPFR_RNDD);
if (mpfr_cmp_d (temp, param.min_x) < 0)
mpfr_neg (x, x, MPFR_RNDN);
}
else
{
mpfr_mul (x, x, incr_x, MPFR_RNDU);
mpfr_set (temp, x, MPFR_RNDD);
mpfr_log2 (temp, temp, MPFR_RNDD);
if (mpfr_cmp_d (temp, param.max_x) > 0)
test=0;
}
}
}
prec = ( (param.logarithmic_scale_prec) ? (prec * incr_prec)
: (prec + incr_prec) );
fprintf (output, "\n");
}
free (t);
mpfr_clear (incr_x);
mpfr_clear (x);
mpfr_clear (x2);
mpfr_clear (temp);
return;
}
int
mpfr_fma (mpfr_ptr s, mpfr_srcptr x, mpfr_srcptr y, mpfr_srcptr z,
mp_rnd_t rnd_mode)
{
int inexact;
mpfr_t u;
/* particular cases */
if (MPFR_IS_NAN(x) || MPFR_IS_NAN(y) || MPFR_IS_NAN(z))
{
MPFR_SET_NAN(s);
MPFR_RET_NAN;
}
if (MPFR_IS_INF(x) || MPFR_IS_INF(y))
{
/* cases Inf*0+z, 0*Inf+z, Inf-Inf */
if ((MPFR_IS_FP(y) && MPFR_IS_ZERO(y)) ||
(MPFR_IS_FP(x) && MPFR_IS_ZERO(x)) ||
(MPFR_IS_INF(z) && ((MPFR_SIGN(x) * MPFR_SIGN(y)) != MPFR_SIGN(z))))
{
MPFR_SET_NAN(s);
MPFR_RET_NAN;
}
MPFR_CLEAR_NAN(s);
if (MPFR_IS_INF(z)) /* case Inf-Inf already checked above */
{
MPFR_SET_INF(s);
MPFR_SET_SAME_SIGN(s, z);
MPFR_RET(0);
}
else /* z is finite */
{
MPFR_SET_INF(s);
if (MPFR_SIGN(s) != (MPFR_SIGN(x) * MPFR_SIGN(y)))
MPFR_CHANGE_SIGN(s);
MPFR_RET(0);
}
}
MPFR_CLEAR_NAN(s);
/* now x and y are finite */
if (MPFR_IS_INF(z))
{
MPFR_SET_INF(s);
MPFR_SET_SAME_SIGN(s, z);
MPFR_RET(0);
}
MPFR_CLEAR_INF(s);
if (MPFR_IS_ZERO(x) || MPFR_IS_ZERO(y))
{
if (MPFR_IS_ZERO(z))
{
int sign_p, sign_z;
sign_p = MPFR_SIGN(x) * MPFR_SIGN(y);
sign_z = MPFR_SIGN(z);
if (MPFR_SIGN(s) !=
(rnd_mode != GMP_RNDD ?
((sign_p < 0 && sign_z < 0) ? -1 : 1) :
((sign_p > 0 && sign_z > 0) ? 1 : -1)))
{
MPFR_CHANGE_SIGN(s);
}
MPFR_SET_ZERO(s);
MPFR_RET(0);
}
else
return mpfr_set (s, z, rnd_mode);
}
if (MPFR_IS_ZERO(z))
return mpfr_mul (s, x, y, rnd_mode);
/* if we take prec(u) >= prec(x) + prec(y), the product
u <- x*y is always exact */
mpfr_init2 (u, MPFR_PREC(x) + MPFR_PREC(y));
mpfr_mul (u, x, y, GMP_RNDN); /* always exact */
inexact = mpfr_add (s, z, u, rnd_mode);
mpfr_clear(u);
return inexact;
}
void mp_Iadd (mp_interval_t *rop, mp_interval_t op1, mp_interval_t op2) {
// LEFT BOUNDARIES ADD, ROUNDING DOWNWARDS
mpfr_add (rop->a, op1.a, op2.a, MPFR_RNDD);
// RIGHT BOUNDARIES ADD, ROUNDING UPWARDS
mpfr_add (rop->b, op1.b, op2.b, MPFR_RNDU);
}
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;
}
int
lunar_longitude( mpfr_t *result, mpfr_t *moment ) {
mpfr_t C, mean_moon, elongation, solar_anomaly, lunar_anomaly, moon_node, E, correction, venus, jupiter, flat_earth, N, fullangle;
mpfr_init(C);
julian_centuries( &C, moment );
{
mpfr_t a, b, c, d, e;
mpfr_init(mean_moon);
mpfr_init_set_d(a, 218.316591, GMP_RNDN);
mpfr_init_set_d(b, 481267.88134236, GMP_RNDN);
mpfr_init_set_d(c, -0.0013268, GMP_RNDN);
mpfr_init_set_ui(d, 1, GMP_RNDN);
mpfr_div_ui(d, d, 538841, GMP_RNDN);
mpfr_init_set_si(e, -1, GMP_RNDN);
mpfr_div_ui(e, e, 65194000, GMP_RNDN);
polynomial( &mean_moon, &C, 5, &a, &b, &c, &d, &e );
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
mpfr_clear(d);
mpfr_clear(e);
}
{
mpfr_t a, b, c, d, e;
mpfr_init(elongation);
mpfr_init_set_d(a, 297.8502042, GMP_RNDN);
mpfr_init_set_d(b, 445267.1115168, GMP_RNDN);
mpfr_init_set_d(c, -0.00163, GMP_RNDN);
mpfr_init_set_ui(d, 1, GMP_RNDN);
mpfr_div_ui(d, d, 545868, GMP_RNDN);
mpfr_init_set_si(e, -1, GMP_RNDN);
mpfr_div_ui(e, e, 113065000, GMP_RNDN);
polynomial( &elongation, &C, 5, &a, &b, &c, &d, &e );
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
mpfr_clear(d);
mpfr_clear(e);
}
{
mpfr_t a, b, c, d;
mpfr_init(solar_anomaly);
mpfr_init_set_d(a, 357.5291092, GMP_RNDN);
mpfr_init_set_d(b, 35999.0502909, GMP_RNDN);
mpfr_init_set_d(c, -0.0001536, GMP_RNDN);
mpfr_init_set_ui(d, 1, GMP_RNDN);
mpfr_div_ui(d, d, 24490000, GMP_RNDN);
polynomial( &solar_anomaly, &C, 4, &a, &b, &c, &d );
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
mpfr_clear(d);
}
{
mpfr_t a, b, c, d, e;
mpfr_init(lunar_anomaly);
mpfr_init_set_d(a, 134.9634114, GMP_RNDN);
mpfr_init_set_d(b, 477198.8676313, GMP_RNDN);
mpfr_init_set_d(c, 0.0008997, GMP_RNDN);
mpfr_init_set_ui(d, 1, GMP_RNDN);
mpfr_div_ui(d, d, 69699, GMP_RNDN);
mpfr_init_set_si(e, -1, GMP_RNDN);
mpfr_div_ui(e, e, 14712000, GMP_RNDN);
polynomial( &lunar_anomaly, &C, 5, &a, &b, &c, &d, &e);
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
mpfr_clear(d);
mpfr_clear(e);
}
{
mpfr_t a, b, c, d, e;
mpfr_init(moon_node);
mpfr_init_set_d(a, 93.2720993, GMP_RNDN);
mpfr_init_set_d(b, 483202.0175273, GMP_RNDN);
mpfr_init_set_d(c, -0.0034029, GMP_RNDN);
mpfr_init_set_si(d, -1, GMP_RNDN);
mpfr_div_ui(d, d, 3526000, GMP_RNDN);
mpfr_init_set_ui(e, 1, GMP_RNDN);
mpfr_div_ui(e, e, 863310000, GMP_RNDN);
polynomial(&moon_node, &C, 5, &a, &b, &c, &d, &e);
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
mpfr_clear(d);
mpfr_clear(e);
}
{
mpfr_t a, b, c;
mpfr_init(E);
mpfr_init_set_ui(a, 1, GMP_RNDN);
mpfr_init_set_d(b, -0.002516, GMP_RNDN);
mpfr_init_set_d(c, -0.0000074, GMP_RNDN);
polynomial( &E, &C, 3, &a, &b, &c );
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
}
{
int i;
mpfr_t fugly;
mpfr_init_set_ui(fugly, 0, GMP_RNDN);
for(i = 0; i < LUNAR_LONGITUDE_ARGS_SIZE; i++) {
mpfr_t a, b, v, w, x, y, z;
mpfr_init_set_d( v, LUNAR_LONGITUDE_ARGS[i][0], GMP_RNDN );
mpfr_init_set_d( w, LUNAR_LONGITUDE_ARGS[i][1], GMP_RNDN );
mpfr_init_set_d( x, LUNAR_LONGITUDE_ARGS[i][2], GMP_RNDN );
mpfr_init_set_d( y, LUNAR_LONGITUDE_ARGS[i][3], GMP_RNDN );
mpfr_init_set_d( z, LUNAR_LONGITUDE_ARGS[i][4], GMP_RNDN );
mpfr_init(b);
mpfr_pow(b, E, x, GMP_RNDN);
mpfr_mul(w, w, elongation, GMP_RNDN);
mpfr_mul(x, x, solar_anomaly, GMP_RNDN);
mpfr_mul(y, y, lunar_anomaly, GMP_RNDN);
mpfr_mul(z, z, moon_node, GMP_RNDN);
mpfr_init_set(a, w, GMP_RNDN);
mpfr_add(a, a, x, GMP_RNDN);
mpfr_add(a, a, y, GMP_RNDN);
mpfr_add(a, a, z, GMP_RNDN);
dt_astro_sin(&a, &a);
mpfr_mul(a, a, v, GMP_RNDN);
mpfr_mul(a, a, b, GMP_RNDN);
mpfr_add(fugly, fugly, a, GMP_RNDN);
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(v);
mpfr_clear(w);
mpfr_clear(x);
mpfr_clear(y);
mpfr_clear(z);
}
mpfr_init_set_d( correction, 0.000001, GMP_RNDN );
mpfr_mul( correction, correction, fugly, GMP_RNDN);
mpfr_clear(fugly);
}
{
mpfr_t a, b;
mpfr_init(venus);
mpfr_init_set_d(a, 119.75, GMP_RNDN);
mpfr_init_set(b, C, GMP_RNDN);
mpfr_mul_d(b, b, 131.849, GMP_RNDN);
mpfr_add(a, a, b, GMP_RNDN);
dt_astro_sin(&a, &a);
mpfr_mul_d(venus, a, 0.003957, GMP_RNDN );
mpfr_clear(a);
mpfr_clear(b);
}
{
mpfr_t a, b;
mpfr_init(jupiter);
mpfr_init_set_d(a, 53.09, GMP_RNDN);
mpfr_init_set(b, C, GMP_RNDN);
mpfr_mul_d(b, b, 479264.29, GMP_RNDN);
mpfr_add(a, a, b, GMP_RNDN);
dt_astro_sin(&a, &a);
mpfr_mul_d(jupiter, a, 0.000318, GMP_RNDN );
mpfr_clear(a);
mpfr_clear(b);
}
{
mpfr_t a;
mpfr_init(flat_earth);
mpfr_init_set(a, mean_moon, GMP_RNDN);
mpfr_sub(a, a, moon_node, GMP_RNDN);
dt_astro_sin(&a, &a);
mpfr_mul_d(flat_earth, a, 0.001962, GMP_RNDN);
mpfr_clear(a);
}
mpfr_set(*result, mean_moon, GMP_RNDN);
mpfr_add(*result, *result, correction, GMP_RNDN);
mpfr_add(*result, *result, venus, GMP_RNDN);
mpfr_add(*result, *result, jupiter, GMP_RNDN);
mpfr_add(*result, *result, flat_earth, GMP_RNDN);
#ifdef ANNOYING_DEBUG
#if (ANNOYING_DEBUG)
mpfr_fprintf(stderr,
"mean_moon = %.10RNf\ncorrection = %.10RNf\nvenus = %.10RNf\njupiter = %.10RNf\nflat_earth = %.10RNf\n",
mean_moon,
correction,
venus,
jupiter,
flat_earth);
#endif
#endif
mpfr_init(N);
nutation(&N, moment);
mpfr_add(*result, *result, N, GMP_RNDN);
mpfr_init_set_ui(fullangle, 360, GMP_RNDN);
#ifdef ANNOYING_DEBUG
#if (ANNOYING_DEBUG)
mpfr_fprintf(stderr, "lunar = mod(%.10RNf) = ", *result );
#endif
#endif
dt_astro_mod(result, result, &fullangle);
#ifdef ANNOYING_DEBUG
#if (ANNOYING_DEBUG)
mpfr_fprintf(stderr, "%.10RNf\n", *result );
#endif
#endif
mpfr_clear(C);
mpfr_clear(mean_moon);
mpfr_clear(elongation);
mpfr_clear(solar_anomaly);
mpfr_clear(lunar_anomaly);
mpfr_clear(moon_node);
mpfr_clear(E);
mpfr_clear(correction);
mpfr_clear(venus);
mpfr_clear(jupiter);
mpfr_clear(flat_earth);
mpfr_clear(N);
mpfr_clear(fullangle);
return 1;
}
void add(ElementType &result, const ElementType& a, const ElementType& b) const
{
mpfr_add(&result, &a, &b, GMP_RNDN);
}
static inline void
adjust_lunar_phase_to_zero(mpfr_t *result) {
mpfr_t ll, delta;
int mode = -1;
int loop = 1;
int count = 0;
/* Adjust values so that it's as close as possible to 0 degrees.
* if we have a delta of 1 degree, then we're about
* 1 / ( 360 / MEAN_SYNODIC_MONTH )
* days apart
*/
mpfr_init(ll);
mpfr_init_set_d(delta, 0.0001, GMP_RNDN);
while (loop) {
int flipped = mode;
mpfr_t new_moment;
count++;
mpfr_init(new_moment);
lunar_phase(&ll, result);
#if (TRACE)
mpfr_fprintf(stderr,
"Adjusting ll from (%.30RNf) moment is %.5RNf delta is %.30RNf\n", ll, *result, delta);
#endif
/* longitude was greater than 180, so we're looking to add a few
* degrees to make it close to 360 ( 0 )
*/
if (mpfr_cmp_ui( ll, 180 ) > 0) {
mode = 1;
mpfr_sub_ui(delta, ll, 360, GMP_RNDN);
mpfr_div_d(delta, delta, 360 / MEAN_SYNODIC_MONTH, GMP_RNDN);
mpfr_add( new_moment, *result, delta, GMP_RNDN );
#if (TRACE)
mpfr_fprintf(stderr, "add %.30RNf -> %.30RNf\n", *result, new_moment);
#endif
mpfr_set(*result, new_moment, GMP_RNDN);
if (mpfr_cmp(new_moment, *result) == 0) {
loop = 0;
}
} else if (mpfr_cmp_ui( ll, 180 ) < 0 ) {
if ( mpfr_cmp_d( ll, 0.000000000000000000001 ) < 0) {
loop = 0;
} else {
mode = 0;
mpfr_sub_ui(delta, ll, 0, GMP_RNDN);
mpfr_div_d(delta, delta, 360 / MEAN_SYNODIC_MONTH, GMP_RNDN);
mpfr_sub( new_moment, *result, delta, GMP_RNDN );
#if (TRACE)
mpfr_fprintf(stderr, "sub %.120RNf -> %.120RNf\n", *result, new_moment);
#endif
if (mpfr_cmp(new_moment, *result) == 0) {
loop = 0;
}
mpfr_set(*result, new_moment, GMP_RNDN);
}
} else {
loop = 0;
}
if (flipped != -1 && flipped != mode) {
mpfr_div_d(delta, delta, 1.1, GMP_RNDN);
}
mpfr_clear(new_moment);
}
mpfr_clear(delta);
mpfr_clear(ll);
}
/* 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 mp_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) */
mp_exp_t exps, expU;
zz = mpfr_get_ui (y, GMP_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, GMP_RNDN);
mpfr_div (t, c, t, GMP_RNDN); /* c/n! */
mpfr_mul_z (u, t, p, GMP_RNDN);
mpfr_div_z (s, u, q, GMP_RNDN);
exps = MPFR_EXP (s);
expU = exps;
for (k = 1; ;k ++)
{
/* update t */
mpfr_mul (t, t, y, GMP_RNDN);
mpfr_div_ui (t, t, k, GMP_RNDN);
mpfr_div_ui (t, t, n + k, GMP_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, GMP_RNDN);
mpfr_div_z (u, u, q, GMP_RNDN);
exps = MPFR_EXP (u);
if (exps > expU)
expU = exps;
mpfr_add (s, s, u, GMP_RNDN);
exps = MPFR_EXP (s);
if (exps > expU)
expU = exps;
if (MPFR_EXP (u) + (mp_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;
}
int
nth_new_moon( mpfr_t *result, int n_int ) {
mpfr_t n, k, C, approx, E, solar_anomaly, lunar_anomaly, moon_argument, omega, extra, correction, additional;
#if(0)
PerlIO_printf(PerlIO_stderr(), "nth_new_moon = %d\n", n_int );
#endif
if ( dt_astro_global_cache.cache_size > n_int ) {
mpfr_t *cached = dt_astro_global_cache.cache[n_int];
if (cached != NULL) {
#if(0)
PerlIO_printf(PerlIO_stderr(), "Cache HIT for %d\n", n_int);
#endif
mpfr_set( *result, *cached, GMP_RNDN );
return 1;
}
}
mpfr_init_set_ui( n, n_int, GMP_RNDN );
/* k = n - 24724 */
mpfr_init_set(k, n, GMP_RNDN);
mpfr_sub_ui(k, k, 24724, GMP_RNDN );
/* c = k / 1236.85 */
mpfr_init_set(C, k, GMP_RNDN );
mpfr_div_d(C, C, 1236.85, GMP_RNDN);
{
mpfr_t a, b, c, d, e;
mpfr_init(approx);
mpfr_init_set_d(a, 730125.59765, GMP_RNDN );
mpfr_init_set_d(b, MEAN_SYNODIC_MONTH * 1236.85, GMP_RNDN );
mpfr_init_set_d(c, 0.0001337, GMP_RNDN );
mpfr_init_set_d(d, -0.000000150, GMP_RNDN );
mpfr_init_set_d(e, 0.00000000073, GMP_RNDN );
polynomial( &approx, &C, 5, &a, &b, &c, &d, &e );
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
mpfr_clear(d);
mpfr_clear(e);
#ifdef ANNOYING_DEBUG
#if (ANNOYING_DEBUG)
mpfr_fprintf(stderr,
"approx = %.10RNf\n", approx);
#endif
#endif
}
{
mpfr_t a, b, c;
mpfr_init(E);
mpfr_init_set_ui(a, 1, GMP_RNDN);
mpfr_init_set_d(b, -0.002516, GMP_RNDN );
mpfr_init_set_d(c, -0.0000074, GMP_RNDN );
polynomial( &E, &C, 3, &a, &b, &c );
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
}
{
mpfr_t a, b, c, d;
mpfr_init(solar_anomaly);
mpfr_init_set_d(a, 2.5534, GMP_RNDN);
mpfr_init_set_d(b, 1236.85, GMP_RNDN);
mpfr_mul_d(b, b, 29.10535669, GMP_RNDN);
mpfr_init_set_d(c, -0.0000218, GMP_RNDN );
mpfr_init_set_d(d, -0.00000011, GMP_RNDN );
polynomial( &solar_anomaly, &C, 4, &a, &b, &c, &d);
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
mpfr_clear(d);
}
{
mpfr_t a, b, c, d, e;
mpfr_init(lunar_anomaly);
mpfr_init_set_d(a, 201.5643, GMP_RNDN);
mpfr_init_set_d(b, 385.81693528 * 1236.85, GMP_RNDN);
mpfr_init_set_d(c, 0.0107438, GMP_RNDN);
mpfr_init_set_d(d, 0.00001239, GMP_RNDN);
mpfr_init_set_d(e, -0.000000058, GMP_RNDN);
polynomial( &lunar_anomaly, &C, 5, &a, &b, &c, &d, &e);
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
mpfr_clear(d);
mpfr_clear(e);
}
{
mpfr_t a, b, c, d, e;
mpfr_init(moon_argument);
mpfr_init_set_d(a, 160.7108, GMP_RNDN);
mpfr_init_set_d(b, 390.67050274 * 1236.85, GMP_RNDN);
mpfr_init_set_d(c, -0.0016431, GMP_RNDN);
mpfr_init_set_d(d, -0.00000227, GMP_RNDN);
mpfr_init_set_d(e, 0.000000011, GMP_RNDN);
polynomial( &moon_argument, &C, 5, &a, &b, &c, &d, &e);
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
mpfr_clear(d);
mpfr_clear(e);
}
{
mpfr_t a, b, c, d;
mpfr_init(omega);
mpfr_init_set_d(a, 124.7746, GMP_RNDN);
mpfr_init_set_d(b, -1.56375580 * 1236.85, GMP_RNDN);
mpfr_init_set_d(c, 0.0020691, GMP_RNDN);
mpfr_init_set_d(d, 0.00000215, GMP_RNDN);
polynomial( &omega, &C, 4, &a, &b, &c, &d);
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
mpfr_clear(d);
}
{
mpfr_t a, b, c;
mpfr_init(extra);
mpfr_init_set_d(a, 299.77, GMP_RNDN);
mpfr_init_set_d(b, 132.8475848, GMP_RNDN);
mpfr_init_set_d(c, -0.009173, GMP_RNDN);
polynomial(&extra, &c, 3, &a, &b, &c);
dt_astro_sin(&extra, &extra);
mpfr_mul_d(extra, extra, 0.000325, GMP_RNDN);
mpfr_clear(a);
mpfr_clear(b);
mpfr_clear(c);
}
mpfr_init(correction);
dt_astro_sin(&correction, &omega);
mpfr_mul_d(correction, correction, -0.00017, GMP_RNDN);
{
int i;
for( i = 0; i < NTH_NEW_MOON_CORRECTION_ARGS_SIZE; i++ ) {
mpfr_t a, v, w, x, y, z;
mpfr_init_set_d(v, NTH_NEW_MOON_CORRECTION_ARGS[i][0], GMP_RNDN);
mpfr_init_set_d(w, NTH_NEW_MOON_CORRECTION_ARGS[i][1], GMP_RNDN);
mpfr_init_set_d(x, NTH_NEW_MOON_CORRECTION_ARGS[i][2], GMP_RNDN);
mpfr_init_set_d(y, NTH_NEW_MOON_CORRECTION_ARGS[i][3], GMP_RNDN);
mpfr_init_set_d(z, NTH_NEW_MOON_CORRECTION_ARGS[i][4], GMP_RNDN);
mpfr_mul(x, x, solar_anomaly, GMP_RNDN);
mpfr_mul(y, y, lunar_anomaly, GMP_RNDN);
mpfr_mul(z, z, moon_argument, GMP_RNDN);
mpfr_add(x, x, y, GMP_RNDN);
mpfr_add(x, x, z, GMP_RNDN);
dt_astro_sin(&x, &x);
mpfr_init(a);
mpfr_pow(a, E, w, GMP_RNDN);
mpfr_mul(a, a, v, GMP_RNDN);
mpfr_mul(a, a, x, GMP_RNDN);
mpfr_add( correction, correction, a, GMP_RNDN );
mpfr_clear(a);
mpfr_clear(v);
mpfr_clear(w);
mpfr_clear(x);
mpfr_clear(y);
mpfr_clear(z);
}
}
{
int z;
mpfr_init_set_ui(additional, 0, GMP_RNDN);
for (z = 0; z < NTH_NEW_MOON_ADDITIONAL_ARGS_SIZE; z++) {
mpfr_t i, j, l;
mpfr_init_set_d(i, NTH_NEW_MOON_ADDITIONAL_ARGS[z][0], GMP_RNDN);
mpfr_init_set_d(j, NTH_NEW_MOON_ADDITIONAL_ARGS[z][1], GMP_RNDN);
mpfr_init_set_d(l, NTH_NEW_MOON_ADDITIONAL_ARGS[z][2], GMP_RNDN);
mpfr_mul(j, j, k, GMP_RNDN);
mpfr_add(j, j, i, GMP_RNDN);
dt_astro_sin(&j, &j);
mpfr_mul(l, l, j, GMP_RNDN);
mpfr_add(additional, additional, l, GMP_RNDN);
mpfr_clear(i);
mpfr_clear(j);
mpfr_clear(l);
}
}
#ifdef ANNOYING_DEBUG
#if (ANNOYING_DEBUG)
mpfr_fprintf(stderr,
"correction = %.10RNf\nextra = %.10RNf\nadditional = %.10RNf\n", correction, extra, additional );
#endif
#endif
mpfr_set(*result, approx, GMP_RNDN);
mpfr_add(*result, *result, correction, GMP_RNDN);
mpfr_add(*result, *result, extra, GMP_RNDN);
mpfr_add(*result, *result, additional, GMP_RNDN);
adjust_lunar_phase_to_zero( result );
mpfr_clear(n);
mpfr_clear(k);
mpfr_clear(C);
mpfr_clear(approx);
mpfr_clear(E);
mpfr_clear(solar_anomaly);
mpfr_clear(lunar_anomaly);
mpfr_clear(moon_argument);
mpfr_clear(omega);
mpfr_clear(extra);
mpfr_clear(correction);
mpfr_clear(additional);
if (dt_astro_global_cache.cache_size == 0) {
dt_astro_global_cache.cache_size = 200000;
Newxz( dt_astro_global_cache.cache, dt_astro_global_cache.cache_size, mpfr_t * );
}
int
mpfr_sinh_cosh (mpfr_ptr sh, mpfr_ptr ch, mpfr_srcptr xt, mpfr_rnd_t rnd_mode)
{
mpfr_t x;
int inexact_sh, inexact_ch;
MPFR_ASSERTN (sh != ch);
MPFR_LOG_FUNC
(("x[%Pu]=%.*Rg rnd=%d",
mpfr_get_prec (xt), mpfr_log_prec, xt, rnd_mode),
("sh[%Pu]=%.*Rg ch[%Pu]=%.*Rg",
mpfr_get_prec (sh), mpfr_log_prec, sh,
mpfr_get_prec (ch), mpfr_log_prec, ch));
if (MPFR_UNLIKELY (MPFR_IS_SINGULAR (xt)))
{
if (MPFR_IS_NAN (xt))
{
MPFR_SET_NAN (ch);
MPFR_SET_NAN (sh);
MPFR_RET_NAN;
}
else if (MPFR_IS_INF (xt))
{
MPFR_SET_INF (sh);
MPFR_SET_SAME_SIGN (sh, xt);
MPFR_SET_INF (ch);
MPFR_SET_POS (ch);
MPFR_RET (0);
}
else /* xt is zero */
{
MPFR_ASSERTD (MPFR_IS_ZERO (xt));
MPFR_SET_ZERO (sh); /* sinh(0) = 0 */
MPFR_SET_SAME_SIGN (sh, xt);
inexact_sh = 0;
inexact_ch = mpfr_set_ui (ch, 1, rnd_mode); /* cosh(0) = 1 */
return INEX(inexact_sh,inexact_ch);
}
}
/* Warning: if we use MPFR_FAST_COMPUTE_IF_SMALL_INPUT here, make sure
that the code also works in case of overlap (see sin_cos.c) */
MPFR_TMP_INIT_ABS (x, xt);
{
mpfr_t s, c, ti;
mpfr_exp_t d;
mpfr_prec_t N; /* Precision of the intermediary variables */
long int err; /* Precision of error */
MPFR_ZIV_DECL (loop);
MPFR_SAVE_EXPO_DECL (expo);
MPFR_GROUP_DECL (group);
MPFR_SAVE_EXPO_MARK (expo);
/* compute the precision of intermediary variable */
N = MPFR_PREC (ch);
N = MAX (N, MPFR_PREC (sh));
/* the optimal number of bits : see algorithms.ps */
N = N + MPFR_INT_CEIL_LOG2 (N) + 4;
/* initialise of intermediary variables */
MPFR_GROUP_INIT_3 (group, N, s, c, ti);
/* First computation of sinh_cosh */
MPFR_ZIV_INIT (loop, N);
for (;;)
{
MPFR_BLOCK_DECL (flags);
/* compute sinh_cosh */
MPFR_BLOCK (flags, mpfr_exp (s, x, MPFR_RNDD));
if (MPFR_OVERFLOW (flags))
/* exp(x) does overflow */
{
/* since cosh(x) >= exp(x), cosh(x) overflows too */
inexact_ch = mpfr_overflow (ch, rnd_mode, MPFR_SIGN_POS);
/* sinh(x) may be representable */
inexact_sh = mpfr_sinh (sh, xt, rnd_mode);
MPFR_SAVE_EXPO_UPDATE_FLAGS (expo, MPFR_FLAGS_OVERFLOW);
break;
}
d = MPFR_GET_EXP (s);
mpfr_ui_div (ti, 1, s, MPFR_RNDU); /* 1/exp(x) */
mpfr_add (c, s, ti, MPFR_RNDU); /* exp(x) + 1/exp(x) */
mpfr_sub (s, s, ti, MPFR_RNDN); /* exp(x) - 1/exp(x) */
mpfr_div_2ui (c, c, 1, MPFR_RNDN); /* 1/2(exp(x) + 1/exp(x)) */
mpfr_div_2ui (s, s, 1, MPFR_RNDN); /* 1/2(exp(x) - 1/exp(x)) */
/* it may be that s is zero (in fact, it can only occur when exp(x)=1,
and thus ti=1 too) */
if (MPFR_IS_ZERO (s))
err = N; /* double the precision */
else
{
/* calculation of the error */
d = d - MPFR_GET_EXP (s) + 2;
/* error estimate: err = N-(__gmpfr_ceil_log2(1+pow(2,d)));*/
err = N - (MAX (d, 0) + 1);
if (MPFR_LIKELY (MPFR_CAN_ROUND (s, err, MPFR_PREC (sh),
rnd_mode) && \
MPFR_CAN_ROUND (c, err, MPFR_PREC (ch),
rnd_mode)))
{
inexact_sh = mpfr_set4 (sh, s, rnd_mode, MPFR_SIGN (xt));
inexact_ch = mpfr_set (ch, c, rnd_mode);
break;
}
}
/* actualisation of the precision */
N += err;
MPFR_ZIV_NEXT (loop, N);
MPFR_GROUP_REPREC_3 (group, N, s, c, ti);
}
MPFR_ZIV_FREE (loop);
MPFR_GROUP_CLEAR (group);
MPFR_SAVE_EXPO_FREE (expo);
}
/* now, let's raise the flags if needed */
inexact_sh = mpfr_check_range (sh, inexact_sh, rnd_mode);
inexact_ch = mpfr_check_range (ch, inexact_ch, rnd_mode);
return INEX(inexact_sh,inexact_ch);
}
int
mpfr_sin (mpfr_ptr y, mpfr_srcptr x, mpfr_rnd_t rnd_mode)
{
mpfr_t c, xr;
mpfr_srcptr xx;
mpfr_exp_t expx, err;
mpfr_prec_t precy, m;
int inexact, sign, reduce;
MPFR_ZIV_DECL (loop);
MPFR_SAVE_EXPO_DECL (expo);
MPFR_LOG_FUNC
(("x[%Pu]=%.*Rg rnd=%d", mpfr_get_prec (x), mpfr_log_prec, x, rnd_mode),
("y[%Pu]=%.*Rg inexact=%d", mpfr_get_prec (y), mpfr_log_prec, y,
inexact));
if (MPFR_UNLIKELY (MPFR_IS_SINGULAR (x)))
{
if (MPFR_IS_NAN (x) || MPFR_IS_INF (x))
{
MPFR_SET_NAN (y);
MPFR_RET_NAN;
}
else /* x is zero */
{
MPFR_ASSERTD (MPFR_IS_ZERO (x));
MPFR_SET_ZERO (y);
MPFR_SET_SAME_SIGN (y, x);
MPFR_RET (0);
}
}
/* sin(x) = x - x^3/6 + ... so the error is < 2^(3*EXP(x)-2) */
MPFR_FAST_COMPUTE_IF_SMALL_INPUT (y, x, -2 * MPFR_GET_EXP (x), 2, 0,
rnd_mode, {});
MPFR_SAVE_EXPO_MARK (expo);
/* Compute initial precision */
precy = MPFR_PREC (y);
if (precy >= MPFR_SINCOS_THRESHOLD)
return mpfr_sin_fast (y, x, rnd_mode);
m = precy + MPFR_INT_CEIL_LOG2 (precy) + 13;
expx = MPFR_GET_EXP (x);
mpfr_init (c);
mpfr_init (xr);
MPFR_ZIV_INIT (loop, m);
for (;;)
{
/* first perform argument reduction modulo 2*Pi (if needed),
also helps to determine the sign of sin(x) */
if (expx >= 2) /* If Pi < x < 4, we need to reduce too, to determine
the sign of sin(x). For 2 <= |x| < Pi, we could avoid
the reduction. */
{
reduce = 1;
/* As expx + m - 1 will silently be converted into mpfr_prec_t
in the mpfr_set_prec call, the assert below may be useful to
avoid undefined behavior. */
MPFR_ASSERTN (expx + m - 1 <= MPFR_PREC_MAX);
mpfr_set_prec (c, expx + m - 1);
mpfr_set_prec (xr, m);
mpfr_const_pi (c, MPFR_RNDN);
mpfr_mul_2ui (c, c, 1, MPFR_RNDN);
mpfr_remainder (xr, x, c, MPFR_RNDN);
/* The analysis is similar to that of cos.c:
|xr - x - 2kPi| <= 2^(2-m). Thus we can decide the sign
of sin(x) if xr is at distance at least 2^(2-m) of both
0 and +/-Pi. */
mpfr_div_2ui (c, c, 1, MPFR_RNDN);
/* Since c approximates Pi with an error <= 2^(2-expx-m) <= 2^(-m),
it suffices to check that c - |xr| >= 2^(2-m). */
if (MPFR_SIGN (xr) > 0)
mpfr_sub (c, c, xr, MPFR_RNDZ);
else
mpfr_add (c, c, xr, MPFR_RNDZ);
if (MPFR_IS_ZERO(xr)
|| MPFR_GET_EXP(xr) < (mpfr_exp_t) 3 - (mpfr_exp_t) m
|| MPFR_IS_ZERO(c)
|| MPFR_GET_EXP(c) < (mpfr_exp_t) 3 - (mpfr_exp_t) m)
goto ziv_next;
/* |xr - x - 2kPi| <= 2^(2-m), thus |sin(xr) - sin(x)| <= 2^(2-m) */
xx = xr;
}
else /* the input argument is already reduced */
{
reduce = 0;
xx = x;
}
sign = MPFR_SIGN(xx);
/* now that the argument is reduced, precision m is enough */
mpfr_set_prec (c, m);
mpfr_cos (c, xx, MPFR_RNDZ); /* can't be exact */
mpfr_nexttoinf (c); /* now c = cos(x) rounded away */
mpfr_mul (c, c, c, MPFR_RNDU); /* away */
mpfr_ui_sub (c, 1, c, MPFR_RNDZ);
mpfr_sqrt (c, c, MPFR_RNDZ);
if (MPFR_IS_NEG_SIGN(sign))
MPFR_CHANGE_SIGN(c);
/* Warning: c may be 0! */
if (MPFR_UNLIKELY (MPFR_IS_ZERO (c)))
{
/* Huge cancellation: increase prec a lot! */
m = MAX (m, MPFR_PREC (x));
m = 2 * m;
}
else
{
/* the absolute error on c is at most 2^(3-m-EXP(c)),
plus 2^(2-m) if there was an argument reduction.
Since EXP(c) <= 1, 3-m-EXP(c) >= 2-m, thus the error
is at most 2^(3-m-EXP(c)) in case of argument reduction. */
err = 2 * MPFR_GET_EXP (c) + (mpfr_exp_t) m - 3 - (reduce != 0);
if (MPFR_CAN_ROUND (c, err, precy, rnd_mode))
break;
/* check for huge cancellation (Near 0) */
if (err < (mpfr_exp_t) MPFR_PREC (y))
m += MPFR_PREC (y) - err;
/* Check if near 1 */
if (MPFR_GET_EXP (c) == 1)
m += m;
}
ziv_next:
/* Else generic increase */
MPFR_ZIV_NEXT (loop, m);
}
MPFR_ZIV_FREE (loop);
inexact = mpfr_set (y, c, rnd_mode);
/* inexact cannot be 0, since this would mean that c was representable
within the target precision, but in that case mpfr_can_round will fail */
mpfr_clear (c);
mpfr_clear (xr);
MPFR_SAVE_EXPO_FREE (expo);
return mpfr_check_range (y, inexact, rnd_mode);
}
