// Refine the random square
mpfr_prec_t Refine(gmp_randstate_t r, mpfr_prec_t prec, long num = 1)
const {
if (num <= 0) return prec;
// Use _vx as scratch
prec += num * chunk_;
mpfr_div_2ui(_eps, _eps, num * chunk_, MPFR_RNDN);
mpz_urandomb(_ui, r, num * chunk_);
mpfr_set_prec(_up, prec);
mpfr_set_z_2exp(_up, _ui, -prec, MPFR_RNDN);
mpfr_set_prec(_vx, prec);
mpfr_add(_vx, _u, _up, MPFR_RNDN);
mpfr_swap(_u, _vx); // u = vx
mpfr_add(_up, _u, _eps, MPFR_RNDN);
mpz_urandomb(_vi, r, num * chunk_);
mpfr_set_prec(_vp, prec);
mpfr_set_z_2exp(_vp, _vi, -prec, MPFR_RNDN);
mpfr_set_prec(_vx, prec);
mpfr_add(_vx, _v, _vp, MPFR_RNDN);
mpfr_swap(_v, _vx); // v = vx
mpfr_add(_vp, _v, _eps, MPFR_RNDN);
return prec;
}
void
mpc_swap (mpc_ptr a, mpc_ptr b)
{
/* assumes real and imaginary parts do not overlap */
mpfr_swap (MPC_RE(a), MPC_RE(b));
mpfr_swap (MPC_IM(a), MPC_IM(b));
}
static void
check_random (mpfr_prec_t p)
{
mpfr_t a1,b,c,a2;
int r;
int i, inexact1, inexact2;
mpfr_inits2 (p, a1, b, c, a2, (mpfr_ptr) 0);
for (i = 0 ; i < 500 ; i++)
{
mpfr_urandomb (b, RANDS);
mpfr_urandomb (c, RANDS);
if (MPFR_IS_PURE_FP(b) && MPFR_IS_PURE_FP(c))
{
if (MPFR_GET_EXP(b) < MPFR_GET_EXP(c))
mpfr_swap(b, c);
if (MPFR_IS_PURE_FP(b) && MPFR_IS_PURE_FP(c))
for (r = 0 ; r < MPFR_RND_MAX ; r++)
{
inexact1 = mpfr_add1(a1, b, c, (mpfr_rnd_t) r);
inexact2 = mpfr_add1sp(a2, b, c, (mpfr_rnd_t) r);
if (mpfr_cmp(a1, a2))
STD_ERROR;
if (inexact1 != inexact2)
STD_ERROR2;
}
}
}
mpfr_clears (a1, a2, b, c, (mpfr_ptr) 0);
}
mpfr_t* compute_rho_to_z_matrix(unsigned long Lambda_arg, long prec){
/* To avoid writing lambda + 1 so many times...*/
unsigned long Lambda=Lambda_arg+1;
mpfr_t* temps=malloc(sizeof(mpfr_t)*(Lambda));
mpfr_init2(temps[0],prec);
mpfr_set_ui(temps[0],8,MPFR_RNDN);
mpfr_sqrt(temps[0],temps[0],MPFR_RNDN);
mpfr_neg(temps[0],temps[0],MPFR_RNDN);
for(unsigned long j=1;j<Lambda;j++){
mpfr_init2(temps[j],prec);
mpfr_mul_si(temps[j],temps[j-1],2*j-3,MPFR_RNDN);
mpfr_div_ui(temps[j],temps[j],j,MPFR_RNDN);
}
mpfr_sub_ui(temps[1],temps[1],2,MPFR_RNDN);
mpfr_add_ui(temps[0],temps[0],3,MPFR_RNDN);
mpfr_t temp;
mpfr_init2(temp,prec);
mpfr_t temp2;
mpfr_init2(temp2,prec);
mpfr_t* result=malloc(sizeof(mpfr_t)*(Lambda)*(Lambda));
mpfr_init2(result[0],prec);
mpfr_set_ui(result[0],1,MPFR_RNDN);
for(unsigned long j=1; j<(Lambda*Lambda); j++){
mpfr_init2(result[j],prec);
mpfr_set_zero(result[j],1);
}
for(unsigned long j=1;j<Lambda;j++){
mpfr_set_ui(temp,1,MPFR_RNDN);
for(unsigned long k=0;k<=j;k++){
mpfr_mul(temp2,temps[j-k],temp,MPFR_RNDN);
mpfr_add(result[j+Lambda],result[j+Lambda],temp2,MPFR_RNDN);
mpfr_mul_si(temp,temp,-2,MPFR_RNDN);
}
}
for(unsigned long i=2;i<Lambda;i++){
for(unsigned long j=1;j<Lambda;j++){
for(unsigned long k=i-1;k<Lambda-j;k++){
mpfr_mul(temp,result[Lambda*(i-1)+k],result[j+Lambda],MPFR_RNDN);
mpfr_add(result[Lambda*i+k+j],result[Lambda*i+k+j],temp,MPFR_RNDN);
}
}
}
/* transposition */
for(unsigned long i=0;i<Lambda;i++){
for(unsigned long j=0;j<i;j++){
mpfr_swap(result[i+Lambda*j],result[j+Lambda*i]);
}
}
for(unsigned long j=0;j<Lambda;j++){
mpfr_clear(temps[j]);
}
free(temps);
mpfr_clear(temp);
mpfr_clear(temp2);
return result;
}
int
mpc_mul_i (mpc_ptr a, mpc_srcptr b, int sign, mpc_rnd_t rnd)
/* if sign is >= 0, multiply by i, otherwise by -i */
{
int inex_re, inex_im;
mpfr_t tmp;
/* Treat the most probable case of compatible precisions first */
if ( MPFR_PREC (MPC_RE (b)) == MPFR_PREC (MPC_IM (a))
&& MPFR_PREC (MPC_IM (b)) == MPFR_PREC (MPC_RE (a)))
{
if (a == b)
mpfr_swap (MPC_RE (a), MPC_IM (a));
else
{
mpfr_set (MPC_RE (a), MPC_IM (b), GMP_RNDN);
mpfr_set (MPC_IM (a), MPC_RE (b), GMP_RNDN);
}
if (sign >= 0)
MPFR_CHANGE_SIGN (MPC_RE (a));
else
MPFR_CHANGE_SIGN (MPC_IM (a));
inex_re = 0;
inex_im = 0;
}
else
{
if (a == b)
{
mpfr_init2 (tmp, MPFR_PREC (MPC_RE (a)));
if (sign >= 0)
{
inex_re = mpfr_neg (tmp, MPC_IM (b), MPC_RND_RE (rnd));
inex_im = mpfr_set (MPC_IM (a), MPC_RE (b), MPC_RND_IM (rnd));
}
else
{
inex_re = mpfr_set (tmp, MPC_IM (b), MPC_RND_RE (rnd));
inex_im = mpfr_neg (MPC_IM (a), MPC_RE (b), MPC_RND_IM (rnd));
}
mpfr_clear (MPC_RE (a));
MPC_RE (a)[0] = tmp [0];
}
else
if (sign >= 0)
{
inex_re = mpfr_neg (MPC_RE (a), MPC_IM (b), MPC_RND_RE (rnd));
inex_im = mpfr_set (MPC_IM (a), MPC_RE (b), MPC_RND_IM (rnd));
}
else
{
inex_re = mpfr_set (MPC_RE (a), MPC_IM (b), MPC_RND_RE (rnd));
inex_im = mpfr_neg (MPC_IM (a), MPC_RE (b), MPC_RND_IM (rnd));
}
}
return MPC_INEX(inex_re, inex_im);
}
int
mpfi_revert_if_needed (mpfi_ptr a)
{
if ( MPFI_NAN_P (a) )
return 0;
if ( mpfr_cmp (&(a->right), &(a->left)) < 0 ) {
mpfr_swap (&(a->left), &(a->right));
return 1;
}
else
return 0;
}
/* if u = o(x-y), v = o(u-x), w = o(v+y), then x-y = u-w */
static void
check_two_sum (mpfr_prec_t p)
{
mpfr_t x, y, u, v, w;
mpfr_rnd_t rnd;
int inexact;
mpfr_init2 (x, p);
mpfr_init2 (y, p);
mpfr_init2 (u, p);
mpfr_init2 (v, p);
mpfr_init2 (w, p);
mpfr_urandomb (x, RANDS);
mpfr_urandomb (y, RANDS);
if (mpfr_cmpabs (x, y) < 0)
mpfr_swap (x, y);
rnd = MPFR_RNDN;
inexact = test_sub (u, x, y, rnd);
test_sub (v, u, x, rnd);
mpfr_add (w, v, y, rnd);
/* as u = (x-y) - w, we should have inexact and w of opposite signs */
if (((inexact == 0) && mpfr_cmp_ui (w, 0)) ||
((inexact > 0) && (mpfr_cmp_ui (w, 0) <= 0)) ||
((inexact < 0) && (mpfr_cmp_ui (w, 0) >= 0)))
{
printf ("Wrong inexact flag for prec=%u, rnd=%s\n", (unsigned)p,
mpfr_print_rnd_mode (rnd));
printf ("x=");
mpfr_print_binary(x);
puts ("");
printf ("y=");
mpfr_print_binary(y);
puts ("");
printf ("u=");
mpfr_print_binary(u);
puts ("");
printf ("v=");
mpfr_print_binary(v);
puts ("");
printf ("w=");
mpfr_print_binary(w);
puts ("");
printf ("inexact = %d\n", inexact);
exit (1);
}
mpfr_clear (x);
mpfr_clear (y);
mpfr_clear (u);
mpfr_clear (v);
mpfr_clear (w);
}
static __inline__ void
mpfr_add_bound(mpfr_t r,const mpfr_t s)
{
mpfr_prec_t s_prec=mpfr_get_prec(s);
if(s_prec > mpfr_get_prec(r) )
{
mpfr_t n; mpfr_init2(n,s_prec);
mpfr_swap(n,r);
mpfr_add(r,n,s,MPFR_RNDU);
mpfr_clear(n);
}
else
mpfr_add(r,r,s,MPFR_RNDU);
}
/**
* ncm_mpsf_sbessel_recur_next: (skip)
* @jlrec: a #NcmMpsfSBesselRecur
* @rnd: FIXME
*
* FIXME
*
*/
void
ncm_mpsf_sbessel_recur_next (NcmMpsfSBesselRecur *jlrec, mp_rnd_t rnd)
{
if (mpfr_sgn (jlrec->x) != 0)
{
mpfr_mul_ui (jlrec->temp, jlrec->jl[1], 2 * jlrec->l + 3, rnd);
mpfr_div (jlrec->temp, jlrec->temp, jlrec->x, rnd);
mpfr_sub (jlrec->temp, jlrec->temp, jlrec->jl[0], rnd);
mpfr_swap (jlrec->jl[0], jlrec->jl[1]);
mpfr_set (jlrec->jl[1], jlrec->temp, rnd);
}
jlrec->l++;
}
int
main (void)
{
mpfr_t u, v;
tests_start_mpfr ();
mpfr_init2 (u, 24);
mpfr_init2 (v, 53);
mpfr_set_ui (u, 16777215, MPFR_RNDN); /* 2^24 - 1 */
mpfr_set_str1 (v, "9007199254740991.0"); /* 2^53 - 1 */
mpfr_swap (u, v);
mpfr_swap (u, v);
if (mpfr_cmp_ui (u, 16777215) || mpfr_cmp_str1 (v, "9007199254740991.0"))
{
printf ("Error in mpfr_swap\n");
exit (1);
}
mpfr_clear (u);
mpfr_clear (v);
tests_end_mpfr ();
return 0;
}
slong
hadamard_2arg(mpfr_t b,const fmpz_mat_t m)
/*
upper bound on log2( 2*abs(m det) )
returns -1 if zero row found, smallest row index otherwise
b on entry is uninitialized
b on exit is initialized iff no zero row found
*/
{
const slong n=m->r;
slong smallest=0,j;
// gcc warning: initialization from incompatible pointer type --- don't know
// how to fix
const fmpz** const rows=m->rows;
mpfr_t v,u;
if(log2_L2_fmpz_3arg( v, rows[0], n ))
return -1;
mpfr_copy_bound(b, v);
// v and b must be freed
for(j=1;j<n;j++)
{
if(log2_L2_fmpz_3arg( u, rows[j], n ))
{
mpfr_clear(b); mpfr_clear(v);
return -1;
}
mpfr_add_bound(b, u);
if( mpfr_cmp(u, v)<0 )
{
smallest=j;
mpfr_swap(v, u);
}
mpfr_clear(u);
// v and b must be freed
}
mpfr_clear(v);
mpfr_div_ui( b, b, 2, MPFR_RNDU ); // instead of taking root
mpfr_add_ui( b, b, 1, MPFR_RNDU ); // instead of multiplying by 2
return smallest;
}
static MPC_Object *
GMPy_MPC_From_Decimal(PyObject *obj, mpfr_prec_t rprec, mpfr_prec_t iprec,
CTXT_Object *context)
{
MPC_Object *result = NULL;
MPFR_Object *tempf;
mpfr_prec_t oldmpfr, oldreal;
int oldmpfr_round, oldreal_round;
assert(IS_DECIMAL(obj));
CHECK_CONTEXT(context);
oldmpfr = GET_MPFR_PREC(context);
oldreal = GET_REAL_PREC(context);
oldmpfr_round = GET_MPFR_ROUND(context);
oldreal_round = GET_REAL_ROUND(context);
context->ctx.mpfr_prec = oldreal;
context->ctx.mpfr_round = oldreal_round;
tempf = GMPy_MPFR_From_Decimal(obj, rprec, context);
context->ctx.mpfr_prec = oldmpfr;
context->ctx.mpfr_round = oldmpfr_round;
result = GMPy_MPC_New(0, 0, context);
if (!tempf || !result) {
Py_XDECREF((PyObject*)tempf);
Py_XDECREF((PyObject*)result);
return NULL;
}
result->rc = MPC_INEX(tempf->rc, 0);
mpfr_swap(mpc_realref(result->c), tempf->f);
Py_DECREF(tempf);
return result;
}
/* return mpfr_cmp (mpc_abs (a), mpc_abs (b)) */
int
mpc_cmp_abs (mpc_srcptr a, mpc_srcptr b)
{
mpc_t z1, z2;
mpfr_t n1, n2;
mpfr_prec_t prec;
int inex1, inex2, ret;
/* Handle numbers containing one NaN as mpfr_cmp. */
if ( mpfr_nan_p (mpc_realref (a)) || mpfr_nan_p (mpc_imagref (a))
|| mpfr_nan_p (mpc_realref (b)) || mpfr_nan_p (mpc_imagref (b)))
{
mpfr_t nan;
mpfr_init (nan);
mpfr_set_nan (nan);
ret = mpfr_cmp (nan, nan);
mpfr_clear (nan);
return ret;
}
/* Handle infinities. */
if (mpc_inf_p (a))
if (mpc_inf_p (b))
return 0;
else
return 1;
else if (mpc_inf_p (b))
return -1;
/* Replace all parts of a and b by their absolute values, then order
them by size. */
z1 [0] = a [0];
z2 [0] = b [0];
if (mpfr_signbit (mpc_realref (a)))
MPFR_CHANGE_SIGN (mpc_realref (z1));
if (mpfr_signbit (mpc_imagref (a)))
MPFR_CHANGE_SIGN (mpc_imagref (z1));
if (mpfr_signbit (mpc_realref (b)))
MPFR_CHANGE_SIGN (mpc_realref (z2));
if (mpfr_signbit (mpc_imagref (b)))
MPFR_CHANGE_SIGN (mpc_imagref (z2));
if (mpfr_cmp (mpc_realref (z1), mpc_imagref (z1)) > 0)
mpfr_swap (mpc_realref (z1), mpc_imagref (z1));
if (mpfr_cmp (mpc_realref (z2), mpc_imagref (z2)) > 0)
mpfr_swap (mpc_realref (z2), mpc_imagref (z2));
/* Handle cases in which only one part differs. */
if (mpfr_cmp (mpc_realref (z1), mpc_realref (z2)) == 0)
return mpfr_cmp (mpc_imagref (z1), mpc_imagref (z2));
if (mpfr_cmp (mpc_imagref (z1), mpc_imagref (z2)) == 0)
return mpfr_cmp (mpc_realref (z1), mpc_realref (z2));
/* Implement the algorithm in algorithms.tex. */
mpfr_init (n1);
mpfr_init (n2);
prec = MPC_MAX (50, MPC_MAX (MPC_MAX_PREC (z1), MPC_MAX_PREC (z2)) / 100);
do {
mpfr_set_prec (n1, prec);
mpfr_set_prec (n2, prec);
inex1 = mpc_norm (n1, z1, MPFR_RNDD);
inex2 = mpc_norm (n2, z2, MPFR_RNDD);
ret = mpfr_cmp (n1, n2);
if (ret != 0)
goto end;
else
if (inex1 == 0) /* n1 = norm(z1) */
if (inex2) /* n2 < norm(z2) */
{
ret = -1;
goto end;
}
else /* n2 = norm(z2) */
{
ret = 0;
goto end;
}
else /* n1 < norm(z1) */
if (inex2 == 0)
{
ret = 1;
goto end;
}
prec *= 2;
} while (1);
end:
mpfr_clear (n1);
mpfr_clear (n2);
return ret;
}
/* agm(x,y) is between x and y, so we don't need to save exponent range */
int
mpfr_agm (mpfr_ptr r, mpfr_srcptr op2, mpfr_srcptr op1, mp_rnd_t rnd_mode)
{
int compare, inexact;
mp_size_t s;
mp_prec_t p, q;
mp_limb_t *up, *vp, *tmpp;
mpfr_t u, v, tmp;
unsigned long n; /* number of iterations */
unsigned long err = 0;
MPFR_ZIV_DECL (loop);
MPFR_TMP_DECL(marker);
MPFR_LOG_FUNC (("op2[%#R]=%R op1[%#R]=%R rnd=%d", op2,op2,op1,op1,rnd_mode),
("r[%#R]=%R inexact=%d", r, r, inexact));
/* Deal with special values */
if (MPFR_ARE_SINGULAR (op1, op2))
{
/* If a or b is NaN, the result is NaN */
if (MPFR_IS_NAN(op1) || MPFR_IS_NAN(op2))
{
MPFR_SET_NAN(r);
MPFR_RET_NAN;
}
/* now one of a or b is Inf or 0 */
/* If a and b is +Inf, the result is +Inf.
Otherwise if a or b is -Inf or 0, the result is NaN */
else if (MPFR_IS_INF(op1) || MPFR_IS_INF(op2))
{
if (MPFR_IS_STRICTPOS(op1) && MPFR_IS_STRICTPOS(op2))
{
MPFR_SET_INF(r);
MPFR_SET_SAME_SIGN(r, op1);
MPFR_RET(0); /* exact */
}
else
{
MPFR_SET_NAN(r);
MPFR_RET_NAN;
}
}
else /* a and b are neither NaN nor Inf, and one is zero */
{ /* If a or b is 0, the result is +0 since a sqrt is positive */
MPFR_ASSERTD (MPFR_IS_ZERO (op1) || MPFR_IS_ZERO (op2));
MPFR_SET_POS (r);
MPFR_SET_ZERO (r);
MPFR_RET (0); /* exact */
}
}
MPFR_CLEAR_FLAGS (r);
/* If a or b is negative (excluding -Infinity), the result is NaN */
if (MPFR_UNLIKELY(MPFR_IS_NEG(op1) || MPFR_IS_NEG(op2)))
{
MPFR_SET_NAN(r);
MPFR_RET_NAN;
}
/* Precision of the following calculus */
q = MPFR_PREC(r);
p = q + MPFR_INT_CEIL_LOG2(q) + 15;
MPFR_ASSERTD (p >= 7); /* see algorithms.tex */
s = (p - 1) / BITS_PER_MP_LIMB + 1;
/* b (op2) and a (op1) are the 2 operands but we want b >= a */
compare = mpfr_cmp (op1, op2);
if (MPFR_UNLIKELY( compare == 0 ))
{
mpfr_set (r, op1, rnd_mode);
MPFR_RET (0); /* exact */
}
else if (compare > 0)
{
mpfr_srcptr t = op1;
op1 = op2;
op2 = t;
}
/* Now b(=op2) >= a (=op1) */
MPFR_TMP_MARK(marker);
/* Main loop */
MPFR_ZIV_INIT (loop, p);
for (;;)
{
mp_prec_t eq;
/* Init temporary vars */
MPFR_TMP_INIT (up, u, p, s);
MPFR_TMP_INIT (vp, v, p, s);
MPFR_TMP_INIT (tmpp, tmp, p, s);
/* Calculus of un and vn */
mpfr_mul (u, op1, op2, GMP_RNDN); /* Faster since PREC(op) < PREC(u) */
mpfr_sqrt (u, u, GMP_RNDN);
mpfr_add (v, op1, op2, GMP_RNDN); /* add with !=prec is still good*/
mpfr_div_2ui (v, v, 1, GMP_RNDN);
n = 1;
while (mpfr_cmp2 (u, v, &eq) != 0 && eq <= p - 2)
{
mpfr_add (tmp, u, v, GMP_RNDN);
mpfr_div_2ui (tmp, tmp, 1, GMP_RNDN);
/* See proof in algorithms.tex */
if (4*eq > p)
{
mpfr_t w;
/* tmp = U(k) */
mpfr_init2 (w, (p + 1) / 2);
mpfr_sub (w, v, u, GMP_RNDN); /* e = V(k-1)-U(k-1) */
mpfr_sqr (w, w, GMP_RNDN); /* e = e^2 */
mpfr_div_2ui (w, w, 4, GMP_RNDN); /* e*= (1/2)^2*1/4 */
mpfr_div (w, w, tmp, GMP_RNDN); /* 1/4*e^2/U(k) */
mpfr_sub (v, tmp, w, GMP_RNDN);
err = MPFR_GET_EXP (tmp) - MPFR_GET_EXP (v); /* 0 or 1 */
mpfr_clear (w);
break;
}
mpfr_mul (u, u, v, GMP_RNDN);
mpfr_sqrt (u, u, GMP_RNDN);
mpfr_swap (v, tmp);
n ++;
}
/* the error on v is bounded by (18n+51) ulps, or twice if there
was an exponent loss in the final subtraction */
err += MPFR_INT_CEIL_LOG2(18 * n + 51); /* 18n+51 should not overflow
since n is about log(p) */
/* we should have n+2 <= 2^(p/4) [see algorithms.tex] */
if (MPFR_LIKELY (MPFR_INT_CEIL_LOG2(n + 2) <= p / 4 &&
MPFR_CAN_ROUND (v, p - err, q, rnd_mode)))
break; /* Stop the loop */
/* Next iteration */
MPFR_ZIV_NEXT (loop, p);
s = (p - 1) / BITS_PER_MP_LIMB + 1;
}
MPFR_ZIV_FREE (loop);
/* Setting of the result */
inexact = mpfr_set (r, v, rnd_mode);
/* Let's clean */
MPFR_TMP_FREE(marker);
return inexact; /* agm(u,v) can be exact for u, v rational only for u=v.
Proof (due to Nicolas Brisebarre): it suffices to consider
u=1 and v<1. Then 1/AGM(1,v) = 2F1(1/2,1/2,1;1-v^2),
and a theorem due to G.V. Chudnovsky states that for x a
non-zero algebraic number with |x|<1, then
2F1(1/2,1/2,1;x) and 2F1(-1/2,1/2,1;x) are algebraically
independent over Q. */
}
int
mpc_asin (mpc_ptr rop, mpc_srcptr op, mpc_rnd_t rnd)
{
mpfr_prec_t p, p_re, p_im, incr_p = 0;
mpfr_rnd_t rnd_re, rnd_im;
mpc_t z1;
int inex;
/* special values */
if (mpfr_nan_p (mpc_realref (op)) || mpfr_nan_p (mpc_imagref (op)))
{
if (mpfr_inf_p (mpc_realref (op)) || mpfr_inf_p (mpc_imagref (op)))
{
mpfr_set_nan (mpc_realref (rop));
mpfr_set_inf (mpc_imagref (rop), mpfr_signbit (mpc_imagref (op)) ? -1 : +1);
}
else if (mpfr_zero_p (mpc_realref (op)))
{
mpfr_set (mpc_realref (rop), mpc_realref (op), GMP_RNDN);
mpfr_set_nan (mpc_imagref (rop));
}
else
{
mpfr_set_nan (mpc_realref (rop));
mpfr_set_nan (mpc_imagref (rop));
}
return 0;
}
if (mpfr_inf_p (mpc_realref (op)) || mpfr_inf_p (mpc_imagref (op)))
{
int inex_re;
if (mpfr_inf_p (mpc_realref (op)))
{
int inf_im = mpfr_inf_p (mpc_imagref (op));
inex_re = set_pi_over_2 (mpc_realref (rop),
(mpfr_signbit (mpc_realref (op)) ? -1 : 1), MPC_RND_RE (rnd));
mpfr_set_inf (mpc_imagref (rop), (mpfr_signbit (mpc_imagref (op)) ? -1 : 1));
if (inf_im)
mpfr_div_2ui (mpc_realref (rop), mpc_realref (rop), 1, GMP_RNDN);
}
else
{
mpfr_set_zero (mpc_realref (rop), (mpfr_signbit (mpc_realref (op)) ? -1 : 1));
inex_re = 0;
mpfr_set_inf (mpc_imagref (rop), (mpfr_signbit (mpc_imagref (op)) ? -1 : 1));
}
return MPC_INEX (inex_re, 0);
}
/* pure real argument */
if (mpfr_zero_p (mpc_imagref (op)))
{
int inex_re;
int inex_im;
int s_im;
s_im = mpfr_signbit (mpc_imagref (op));
if (mpfr_cmp_ui (mpc_realref (op), 1) > 0)
{
if (s_im)
inex_im = -mpfr_acosh (mpc_imagref (rop), mpc_realref (op),
INV_RND (MPC_RND_IM (rnd)));
else
inex_im = mpfr_acosh (mpc_imagref (rop), mpc_realref (op),
MPC_RND_IM (rnd));
inex_re = set_pi_over_2 (mpc_realref (rop),
(mpfr_signbit (mpc_realref (op)) ? -1 : 1), MPC_RND_RE (rnd));
if (s_im)
mpc_conj (rop, rop, MPC_RNDNN);
}
else if (mpfr_cmp_si (mpc_realref (op), -1) < 0)
{
mpfr_t minus_op_re;
minus_op_re[0] = mpc_realref (op)[0];
MPFR_CHANGE_SIGN (minus_op_re);
if (s_im)
inex_im = -mpfr_acosh (mpc_imagref (rop), minus_op_re,
INV_RND (MPC_RND_IM (rnd)));
else
inex_im = mpfr_acosh (mpc_imagref (rop), minus_op_re,
MPC_RND_IM (rnd));
inex_re = set_pi_over_2 (mpc_realref (rop),
(mpfr_signbit (mpc_realref (op)) ? -1 : 1), MPC_RND_RE (rnd));
if (s_im)
mpc_conj (rop, rop, MPC_RNDNN);
}
else
{
inex_im = mpfr_set_ui (mpc_imagref (rop), 0, MPC_RND_IM (rnd));
if (s_im)
mpfr_neg (mpc_imagref (rop), mpc_imagref (rop), GMP_RNDN);
inex_re = mpfr_asin (mpc_realref (rop), mpc_realref (op), MPC_RND_RE (rnd));
}
return MPC_INEX (inex_re, inex_im);
}
/* pure imaginary argument */
if (mpfr_zero_p (mpc_realref (op)))
{
int inex_im;
int s;
s = mpfr_signbit (mpc_realref (op));
mpfr_set_ui (mpc_realref (rop), 0, GMP_RNDN);
if (s)
mpfr_neg (mpc_realref (rop), mpc_realref (rop), GMP_RNDN);
inex_im = mpfr_asinh (mpc_imagref (rop), mpc_imagref (op), MPC_RND_IM (rnd));
return MPC_INEX (0, inex_im);
}
/* regular complex: asin(z) = -i*log(i*z+sqrt(1-z^2)) */
p_re = mpfr_get_prec (mpc_realref(rop));
p_im = mpfr_get_prec (mpc_imagref(rop));
rnd_re = MPC_RND_RE(rnd);
rnd_im = MPC_RND_IM(rnd);
p = p_re >= p_im ? p_re : p_im;
mpc_init2 (z1, p);
while (1)
{
mpfr_exp_t ex, ey, err;
p += mpc_ceil_log2 (p) + 3 + incr_p; /* incr_p is zero initially */
incr_p = p / 2;
mpfr_set_prec (mpc_realref(z1), p);
mpfr_set_prec (mpc_imagref(z1), p);
/* z1 <- z^2 */
mpc_sqr (z1, op, MPC_RNDNN);
/* err(x) <= 1/2 ulp(x), err(y) <= 1/2 ulp(y) */
/* z1 <- 1-z1 */
ex = mpfr_get_exp (mpc_realref(z1));
mpfr_ui_sub (mpc_realref(z1), 1, mpc_realref(z1), GMP_RNDN);
mpfr_neg (mpc_imagref(z1), mpc_imagref(z1), GMP_RNDN);
ex = ex - mpfr_get_exp (mpc_realref(z1));
ex = (ex <= 0) ? 0 : ex;
/* err(x) <= 2^ex * ulp(x) */
ex = ex + mpfr_get_exp (mpc_realref(z1)) - p;
/* err(x) <= 2^ex */
ey = mpfr_get_exp (mpc_imagref(z1)) - p - 1;
/* err(y) <= 2^ey */
ex = (ex >= ey) ? ex : ey; /* err(x), err(y) <= 2^ex, i.e., the norm
of the error is bounded by |h|<=2^(ex+1/2) */
/* z1 <- sqrt(z1): if z1 = z + h, then sqrt(z1) = sqrt(z) + h/2/sqrt(t) */
ey = mpfr_get_exp (mpc_realref(z1)) >= mpfr_get_exp (mpc_imagref(z1))
? mpfr_get_exp (mpc_realref(z1)) : mpfr_get_exp (mpc_imagref(z1));
/* we have |z1| >= 2^(ey-1) thus 1/|z1| <= 2^(1-ey) */
mpc_sqrt (z1, z1, MPC_RNDNN);
ex = (2 * ex + 1) - 2 - (ey - 1); /* |h^2/4/|t| <= 2^ex */
ex = (ex + 1) / 2; /* ceil(ex/2) */
/* express ex in terms of ulp(z1) */
ey = mpfr_get_exp (mpc_realref(z1)) <= mpfr_get_exp (mpc_imagref(z1))
? mpfr_get_exp (mpc_realref(z1)) : mpfr_get_exp (mpc_imagref(z1));
ex = ex - ey + p;
/* take into account the rounding error in the mpc_sqrt call */
err = (ex <= 0) ? 1 : ex + 1;
/* err(x) <= 2^err * ulp(x), err(y) <= 2^err * ulp(y) */
/* z1 <- i*z + z1 */
ex = mpfr_get_exp (mpc_realref(z1));
ey = mpfr_get_exp (mpc_imagref(z1));
mpfr_sub (mpc_realref(z1), mpc_realref(z1), mpc_imagref(op), GMP_RNDN);
mpfr_add (mpc_imagref(z1), mpc_imagref(z1), mpc_realref(op), GMP_RNDN);
if (mpfr_cmp_ui (mpc_realref(z1), 0) == 0 || mpfr_cmp_ui (mpc_imagref(z1), 0) == 0)
continue;
ex -= mpfr_get_exp (mpc_realref(z1)); /* cancellation in x */
ey -= mpfr_get_exp (mpc_imagref(z1)); /* cancellation in y */
ex = (ex >= ey) ? ex : ey; /* maximum cancellation */
err += ex;
err = (err <= 0) ? 1 : err + 1; /* rounding error in sub/add */
/* z1 <- log(z1): if z1 = z + h, then log(z1) = log(z) + h/t with
|t| >= min(|z1|,|z|) */
ex = mpfr_get_exp (mpc_realref(z1));
ey = mpfr_get_exp (mpc_imagref(z1));
ex = (ex >= ey) ? ex : ey;
err += ex - p; /* revert to absolute error <= 2^err */
mpc_log (z1, z1, GMP_RNDN);
err -= ex - 1; /* 1/|t| <= 1/|z| <= 2^(1-ex) */
/* express err in terms of ulp(z1) */
ey = mpfr_get_exp (mpc_realref(z1)) <= mpfr_get_exp (mpc_imagref(z1))
? mpfr_get_exp (mpc_realref(z1)) : mpfr_get_exp (mpc_imagref(z1));
err = err - ey + p;
/* take into account the rounding error in the mpc_log call */
err = (err <= 0) ? 1 : err + 1;
/* z1 <- -i*z1 */
mpfr_swap (mpc_realref(z1), mpc_imagref(z1));
mpfr_neg (mpc_imagref(z1), mpc_imagref(z1), GMP_RNDN);
if (mpfr_can_round (mpc_realref(z1), p - err, GMP_RNDN, GMP_RNDZ,
p_re + (rnd_re == GMP_RNDN)) &&
mpfr_can_round (mpc_imagref(z1), p - err, GMP_RNDN, GMP_RNDZ,
p_im + (rnd_im == GMP_RNDN)))
break;
}
inex = mpc_set (rop, z1, rnd);
mpc_clear (z1);
return inex;
}
/* Implements asymptotic expansion for jn or yn (formulae 9.2.5 and 9.2.6
from Abramowitz & Stegun).
Assumes |z| > p log(2)/2, where p is the target precision
(z can be negative only for jn).
Return 0 if the expansion does not converge enough (the value 0 as inexact
flag should not happen for normal input).
*/
static int
FUNCTION (mpfr_ptr res, long n, mpfr_srcptr z, mpfr_rnd_t r)
{
mpfr_t s, c, P, Q, t, iz, err_t, err_s, err_u;
mpfr_prec_t w;
long k;
int inex, stop, diverge = 0;
mpfr_exp_t err2, err;
MPFR_ZIV_DECL (loop);
mpfr_init (c);
w = MPFR_PREC(res) + MPFR_INT_CEIL_LOG2(MPFR_PREC(res)) + 4;
MPFR_ZIV_INIT (loop, w);
for (;;)
{
mpfr_set_prec (c, w);
mpfr_init2 (s, w);
mpfr_init2 (P, w);
mpfr_init2 (Q, w);
mpfr_init2 (t, w);
mpfr_init2 (iz, w);
mpfr_init2 (err_t, 31);
mpfr_init2 (err_s, 31);
mpfr_init2 (err_u, 31);
/* Approximate sin(z) and cos(z). In the following, err <= k means that
the approximate value y and the true value x are related by
y = x * (1 + u)^k with |u| <= 2^(-w), following Higham's method. */
mpfr_sin_cos (s, c, z, MPFR_RNDN);
if (MPFR_IS_NEG(z))
mpfr_neg (s, s, MPFR_RNDN); /* compute jn/yn(|z|), fix sign later */
/* The absolute error on s/c is bounded by 1/2 ulp(1/2) <= 2^(-w-1). */
mpfr_add (t, s, c, MPFR_RNDN);
mpfr_sub (c, s, c, MPFR_RNDN);
mpfr_swap (s, t);
/* now s approximates sin(z)+cos(z), and c approximates sin(z)-cos(z),
with total absolute error bounded by 2^(1-w). */
/* precompute 1/(8|z|) */
mpfr_si_div (iz, MPFR_IS_POS(z) ? 1 : -1, z, MPFR_RNDN); /* err <= 1 */
mpfr_div_2ui (iz, iz, 3, MPFR_RNDN);
/* compute P and Q */
mpfr_set_ui (P, 1, MPFR_RNDN);
mpfr_set_ui (Q, 0, MPFR_RNDN);
mpfr_set_ui (t, 1, MPFR_RNDN); /* current term */
mpfr_set_ui (err_t, 0, MPFR_RNDN); /* error on t */
mpfr_set_ui (err_s, 0, MPFR_RNDN); /* error on P and Q (sum of errors) */
for (k = 1, stop = 0; stop < 4; k++)
{
/* compute next term: t(k)/t(k-1) = (2n+2k-1)(2n-2k+1)/(8kz) */
mpfr_mul_si (t, t, 2 * (n + k) - 1, MPFR_RNDN); /* err <= err_k + 1 */
mpfr_mul_si (t, t, 2 * (n - k) + 1, MPFR_RNDN); /* err <= err_k + 2 */
mpfr_div_ui (t, t, k, MPFR_RNDN); /* err <= err_k + 3 */
mpfr_mul (t, t, iz, MPFR_RNDN); /* err <= err_k + 5 */
/* the relative error on t is bounded by (1+u)^(5k)-1, which is
bounded by 6ku for 6ku <= 0.02: first |5 log(1+u)| <= |5.5u|
for |u| <= 0.15, then |exp(5.5u)-1| <= 6u for |u| <= 0.02. */
mpfr_mul_ui (err_t, t, 6 * k, MPFR_IS_POS(t) ? MPFR_RNDU : MPFR_RNDD);
mpfr_abs (err_t, err_t, MPFR_RNDN); /* exact */
/* the absolute error on t is bounded by err_t * 2^(-w) */
mpfr_abs (err_u, t, MPFR_RNDU);
mpfr_mul_2ui (err_u, err_u, w, MPFR_RNDU); /* t * 2^w */
mpfr_add (err_u, err_u, err_t, MPFR_RNDU); /* max|t| * 2^w */
if (stop >= 2)
{
/* take into account the neglected terms: t * 2^w */
mpfr_div_2ui (err_s, err_s, w, MPFR_RNDU);
if (MPFR_IS_POS(t))
mpfr_add (err_s, err_s, t, MPFR_RNDU);
else
mpfr_sub (err_s, err_s, t, MPFR_RNDU);
mpfr_mul_2ui (err_s, err_s, w, MPFR_RNDU);
stop ++;
}
/* if k is odd, add to Q, otherwise to P */
else if (k & 1)
{
/* if k = 1 mod 4, add, otherwise subtract */
if ((k & 2) == 0)
mpfr_add (Q, Q, t, MPFR_RNDN);
else
mpfr_sub (Q, Q, t, MPFR_RNDN);
/* check if the next term is smaller than ulp(Q): if EXP(err_u)
<= EXP(Q), since the current term is bounded by
err_u * 2^(-w), it is bounded by ulp(Q) */
if (MPFR_EXP(err_u) <= MPFR_EXP(Q))
stop ++;
else
stop = 0;
}
else
{
/* if k = 0 mod 4, add, otherwise subtract */
if ((k & 2) == 0)
mpfr_add (P, P, t, MPFR_RNDN);
else
mpfr_sub (P, P, t, MPFR_RNDN);
/* check if the next term is smaller than ulp(P) */
if (MPFR_EXP(err_u) <= MPFR_EXP(P))
stop ++;
else
stop = 0;
}
mpfr_add (err_s, err_s, err_t, MPFR_RNDU);
/* the sum of the rounding errors on P and Q is bounded by
err_s * 2^(-w) */
/* stop when start to diverge */
if (stop < 2 &&
((MPFR_IS_POS(z) && mpfr_cmp_ui (z, (k + 1) / 2) < 0) ||
(MPFR_IS_NEG(z) && mpfr_cmp_si (z, - ((k + 1) / 2)) > 0)))
{
/* if we have to stop the series because it diverges, then
increasing the precision will most probably fail, since
we will stop to the same point, and thus compute a very
similar approximation */
diverge = 1;
stop = 2; /* force stop */
}
}
/* the sum of the total errors on P and Q is bounded by err_s * 2^(-w) */
/* Now combine: the sum of the rounding errors on P and Q is bounded by
err_s * 2^(-w), and the absolute error on s/c is bounded by 2^(1-w) */
if ((n & 1) == 0) /* n even: P * (sin + cos) + Q (cos - sin) for jn
Q * (sin + cos) + P (sin - cos) for yn */
{
#ifdef MPFR_JN
mpfr_mul (c, c, Q, MPFR_RNDN); /* Q * (sin - cos) */
mpfr_mul (s, s, P, MPFR_RNDN); /* P * (sin + cos) */
#else
mpfr_mul (c, c, P, MPFR_RNDN); /* P * (sin - cos) */
mpfr_mul (s, s, Q, MPFR_RNDN); /* Q * (sin + cos) */
#endif
err = MPFR_EXP(c);
if (MPFR_EXP(s) > err)
err = MPFR_EXP(s);
#ifdef MPFR_JN
mpfr_sub (s, s, c, MPFR_RNDN);
#else
mpfr_add (s, s, c, MPFR_RNDN);
#endif
}
else /* n odd: P * (sin - cos) + Q (cos + sin) for jn,
Q * (sin - cos) - P (cos + sin) for yn */
{
#ifdef MPFR_JN
mpfr_mul (c, c, P, MPFR_RNDN); /* P * (sin - cos) */
mpfr_mul (s, s, Q, MPFR_RNDN); /* Q * (sin + cos) */
#else
mpfr_mul (c, c, Q, MPFR_RNDN); /* Q * (sin - cos) */
mpfr_mul (s, s, P, MPFR_RNDN); /* P * (sin + cos) */
#endif
err = MPFR_EXP(c);
if (MPFR_EXP(s) > err)
err = MPFR_EXP(s);
#ifdef MPFR_JN
mpfr_add (s, s, c, MPFR_RNDN);
#else
mpfr_sub (s, c, s, MPFR_RNDN);
#endif
}
if ((n & 2) != 0)
mpfr_neg (s, s, MPFR_RNDN);
if (MPFR_EXP(s) > err)
err = MPFR_EXP(s);
/* the absolute error on s is bounded by P*err(s/c) + Q*err(s/c)
+ err(P)*(s/c) + err(Q)*(s/c) + 3 * 2^(err - w - 1)
<= (|P|+|Q|) * 2^(1-w) + err_s * 2^(1-w) + 2^err * 2^(1-w),
since |c|, |old_s| <= 2. */
err2 = (MPFR_EXP(P) >= MPFR_EXP(Q)) ? MPFR_EXP(P) + 2 : MPFR_EXP(Q) + 2;
/* (|P| + |Q|) * 2^(1 - w) <= 2^(err2 - w) */
err = MPFR_EXP(err_s) >= err ? MPFR_EXP(err_s) + 2 : err + 2;
/* err_s * 2^(1-w) + 2^old_err * 2^(1-w) <= 2^err * 2^(-w) */
err2 = (err >= err2) ? err + 1 : err2 + 1;
/* now the absolute error on s is bounded by 2^(err2 - w) */
/* multiply by sqrt(1/(Pi*z)) */
mpfr_const_pi (c, MPFR_RNDN); /* Pi, err <= 1 */
mpfr_mul (c, c, z, MPFR_RNDN); /* err <= 2 */
mpfr_si_div (c, MPFR_IS_POS(z) ? 1 : -1, c, MPFR_RNDN); /* err <= 3 */
mpfr_sqrt (c, c, MPFR_RNDN); /* err<=5/2, thus the absolute error is
bounded by 3*u*|c| for |u| <= 0.25 */
mpfr_mul (err_t, c, s, MPFR_SIGN(c)==MPFR_SIGN(s) ? MPFR_RNDU : MPFR_RNDD);
mpfr_abs (err_t, err_t, MPFR_RNDU);
mpfr_mul_ui (err_t, err_t, 3, MPFR_RNDU);
/* 3*2^(-w)*|old_c|*|s| [see below] is bounded by err_t * 2^(-w) */
err2 += MPFR_EXP(c);
/* |old_c| * 2^(err2 - w) [see below] is bounded by 2^(err2-w) */
mpfr_mul (c, c, s, MPFR_RNDN); /* the absolute error on c is bounded by
1/2 ulp(c) + 3*2^(-w)*|old_c|*|s|
+ |old_c| * 2^(err2 - w) */
/* compute err_t * 2^(-w) + 1/2 ulp(c) = (err_t + 2^EXP(c)) * 2^(-w) */
err = (MPFR_EXP(err_t) > MPFR_EXP(c)) ? MPFR_EXP(err_t) + 1 : MPFR_EXP(c) + 1;
/* err_t * 2^(-w) + 1/2 ulp(c) <= 2^(err - w) */
/* now err_t * 2^(-w) bounds 1/2 ulp(c) + 3*2^(-w)*|old_c|*|s| */
err = (err >= err2) ? err + 1 : err2 + 1;
/* the absolute error on c is bounded by 2^(err - w) */
mpfr_clear (s);
mpfr_clear (P);
mpfr_clear (Q);
mpfr_clear (t);
mpfr_clear (iz);
mpfr_clear (err_t);
mpfr_clear (err_s);
mpfr_clear (err_u);
err -= MPFR_EXP(c);
if (MPFR_LIKELY (MPFR_CAN_ROUND (c, w - err, MPFR_PREC(res), r)))
break;
if (diverge != 0)
{
mpfr_set (c, z, r); /* will force inex=0 below, which means the
asymptotic expansion failed */
break;
}
MPFR_ZIV_NEXT (loop, w);
}
MPFR_ZIV_FREE (loop);
inex = (MPFR_IS_POS(z) || ((n & 1) == 0)) ? mpfr_set (res, c, r)
: mpfr_neg (res, c, r);
mpfr_clear (c);
return inex;
}
static void
special_atan2 (void)
{
mpfr_t x, y, z;
mpfr_inits2 (4, x, y, z, (mpfr_ptr) 0);
/* Anything with NAN should be set to NAN */
mpfr_set_ui (y, 0, MPFR_RNDN);
mpfr_set_nan (x);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (MPFR_IS_NAN (z));
mpfr_swap (x, y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (MPFR_IS_NAN (z));
/* 0+ 0+ --> 0+ */
mpfr_set_ui (y, 0, MPFR_RNDN);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (MPFR_IS_ZERO (z) && MPFR_IS_POS (z));
/* 0- 0+ --> 0- */
MPFR_CHANGE_SIGN (y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (MPFR_IS_ZERO (z) && MPFR_IS_NEG (z));
/* 0- 0- --> -PI */
MPFR_CHANGE_SIGN (x);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "-3.1415", 10, MPFR_RNDN) == 0);
/* 0+ 0- --> +PI */
MPFR_CHANGE_SIGN (y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "3.1415", 10, MPFR_RNDN) == 0);
/* 0+ -1 --> PI */
mpfr_set_si (x, -1, MPFR_RNDN);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "3.1415", 10, MPFR_RNDN) == 0);
/* 0- -1 --> -PI */
MPFR_CHANGE_SIGN (y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "-3.1415", 10, MPFR_RNDN) == 0);
/* 0- +1 --> 0- */
mpfr_set_ui (x, 1, MPFR_RNDN);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (MPFR_IS_ZERO (z) && MPFR_IS_NEG (z));
/* 0+ +1 --> 0+ */
MPFR_CHANGE_SIGN (y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (MPFR_IS_ZERO (z) && MPFR_IS_POS (z));
/* +1 0+ --> PI/2 */
mpfr_swap (x, y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "1.57075", 10, MPFR_RNDN) == 0);
/* +1 0- --> PI/2 */
MPFR_CHANGE_SIGN (x);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "1.57075", 10, MPFR_RNDN) == 0);
/* -1 0- --> -PI/2 */
MPFR_CHANGE_SIGN (y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "-1.57075", 10, MPFR_RNDN) == 0);
/* -1 0+ --> -PI/2 */
MPFR_CHANGE_SIGN (x);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "-1.57075", 10, MPFR_RNDN) == 0);
/* -1 +INF --> -0 */
MPFR_SET_INF (x);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (MPFR_IS_ZERO (z) && MPFR_IS_NEG (z));
/* +1 +INF --> +0 */
MPFR_CHANGE_SIGN (y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (MPFR_IS_ZERO (z) && MPFR_IS_POS (z));
/* +1 -INF --> +PI */
MPFR_CHANGE_SIGN (x);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "3.1415", 10, MPFR_RNDN) == 0);
/* -1 -INF --> -PI */
MPFR_CHANGE_SIGN (y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "-3.1415", 10, MPFR_RNDN) == 0);
/* -INF -1 --> -PI/2 */
mpfr_swap (x, y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "-1.57075", 10, MPFR_RNDN) == 0);
/* +INF -1 --> PI/2 */
MPFR_CHANGE_SIGN (y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "1.57075", 10, MPFR_RNDN) == 0);
/* +INF -INF --> 3*PI/4 */
MPFR_SET_INF (x);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "2.356194490192344928", 10, MPFR_RNDN) == 0);
/* +INF +INF --> PI/4 */
MPFR_CHANGE_SIGN (x);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "0.785375", 10, MPFR_RNDN) == 0);
/* -INF +INF --> -PI/4 */
MPFR_CHANGE_SIGN (y);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "-0.785375", 10, MPFR_RNDN) == 0);
/* -INF -INF --> -3*PI/4 */
MPFR_CHANGE_SIGN (x);
mpfr_atan2 (z, y, x, MPFR_RNDN);
MPFR_ASSERTN (mpfr_cmp_str (z, "-2.356194490192344928", 10, MPFR_RNDN) == 0);
mpfr_set_prec (z, 905); /* exercises Ziv's loop */
mpfr_atan2 (z, y, x, MPFR_RNDZ);
MPFR_ASSERTN (mpfr_cmp_str (z, "-2.35619449019234492884698253745962716314787704953132936573120844423086230471465674897102611900658780098661106488496172998532038345716293667379401955609636083808771307702645389082916973346721171619778647332160823174945008459635673617534008737395340143185923642519259526145784", 10, MPFR_RNDN) == 0);
mpfr_clears (x, y, z, (mpfr_ptr) 0);
}
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;
}
/* Swapping the two arguments */
void
mpfi_swap (mpfi_ptr a, mpfi_ptr b)
{
mpfr_swap (&(a->left), &(b->left));
mpfr_swap (&(a->right), &(b->right));
}
/*------------------------------------------------------------------------*/
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;
}
/* Generic random tests with cancellations.
*
* In summary, we do 4000 tests of the following form:
* 1. We set the first MPFR_NCANCEL members of an array to random values,
* with a random exponent taken in 4 ranges, depending on the value of
* i % 4 (see code below).
* 2. For each of the next MPFR_NCANCEL iterations:
* A. we randomly permute some terms of the array (to make sure that a
* particular order doesn't have an influence on the result);
* B. we compute the sum in a random rounding mode;
* C. if this sum is zero, we end the current test (there is no longer
* anything interesting to test);
* D. we check that this sum is below some bound (chosen as infinite
* for the first iteration of (2), i.e. this test will be useful
* only for the next iterations, after cancellations);
* E. we put the opposite of this sum in the array, the goal being to
* introduce a chain of cancellations;
* F. we compute the bound for the next iteration, derived from (E).
* 3. We do another iteration like (2), but with reusing a random element
* of the array. This last test allows one to check the support of
* reused arguments. Before this support (r10467), it triggers an
* assertion failure with (almost?) all seeds, and if assertions are
* not checked, tsum fails in most cases but not all.
*/
static void
cancel (void)
{
mpfr_t x[2 * MPFR_NCANCEL], bound;
mpfr_ptr px[2 * MPFR_NCANCEL];
int i, j, k, n;
mpfr_init2 (bound, 2);
/* With 4000 tests, tsum will fail in most cases without support of
reused arguments (before r10467). */
for (i = 0; i < 4000; i++)
{
mpfr_set_inf (bound, 1);
for (n = 0; n <= numberof (x); n++)
{
mpfr_prec_t p;
mpfr_rnd_t rnd;
if (n < numberof (x))
{
px[n] = x[n];
p = MPFR_PREC_MIN + (randlimb () % 256);
mpfr_init2 (x[n], p);
k = n;
}
else
{
/* Reuse of a random member of the array. */
k = randlimb () % n;
}
if (n < MPFR_NCANCEL)
{
mpfr_exp_t e;
MPFR_ASSERTN (n < numberof (x));
e = (i & 1) ? 0 : mpfr_get_emin ();
tests_default_random (x[n], 256, e,
((i & 2) ? e + 2000 : mpfr_get_emax ()),
0);
}
else
{
/* random permutation with n random transpositions */
for (j = 0; j < n; j++)
{
int k1, k2;
k1 = randlimb () % (n-1);
k2 = randlimb () % (n-1);
mpfr_swap (x[k1], x[k2]);
}
rnd = RND_RAND ();
#if DEBUG
printf ("mpfr_sum cancellation test\n");
for (j = 0; j < n; j++)
{
printf (" x%d[%3ld] = ", j, mpfr_get_prec(x[j]));
mpfr_out_str (stdout, 16, 0, x[j], MPFR_RNDN);
printf ("\n");
}
printf (" rnd = %s, output prec = %ld\n",
mpfr_print_rnd_mode (rnd), mpfr_get_prec (x[n]));
#endif
mpfr_sum (x[k], px, n, rnd);
if (mpfr_zero_p (x[k]))
{
if (k == n)
n++;
break;
}
if (mpfr_cmpabs (x[k], bound) > 0)
{
printf ("Error in cancel on i = %d, n = %d\n", i, n);
printf ("Expected bound: ");
mpfr_dump (bound);
printf ("x[%d]: ", k);
mpfr_dump (x[k]);
exit (1);
}
if (k != n)
break;
/* For the bound, use MPFR_RNDU due to possible underflow.
It would be nice to add some specific underflow checks,
though there are already ones in check_underflow(). */
mpfr_set_ui_2exp (bound, 1,
mpfr_get_exp (x[n]) - p - (rnd == MPFR_RNDN),
MPFR_RNDU);
/* The next sum will be <= bound in absolute value
(the equality can be obtained in all rounding modes
since the sum will be rounded). */
mpfr_neg (x[n], x[n], MPFR_RNDN);
}
}
while (--n >= 0)
mpfr_clear (x[n]);
}
mpfr_clear (bound);
}
void swap(ElementType &a, ElementType &b) const
{
mpfr_swap(&a, &b);
}
int
main (void)
{
mpfr_t xx, yy;
int c;
tests_start_mpfr ();
mpfr_init2 (xx, 2);
mpfr_init2 (yy, 2);
mpfr_clear_erangeflag ();
MPFR_SET_NAN (xx);
MPFR_SET_NAN (yy);
if (mpfr_cmpabs (xx, yy) != 0)
ERROR ("mpfr_cmpabs (NAN,NAN) returns non-zero\n");
if (!mpfr_erangeflag_p ())
ERROR ("mpfr_cmpabs (NAN,NAN) doesn't set erange flag\n");
mpfr_set_str_binary (xx, "0.10E0");
mpfr_set_str_binary (yy, "-0.10E0");
if (mpfr_cmpabs (xx, yy) != 0)
ERROR ("mpfr_cmpabs (xx, yy) returns non-zero for prec=2\n");
mpfr_set_prec (xx, 65);
mpfr_set_prec (yy, 65);
mpfr_set_str_binary (xx, "-0.10011010101000110101010000000011001001001110001011101011111011101E623");
mpfr_set_str_binary (yy, "0.10011010101000110101010000000011001001001110001011101011111011100E623");
if (mpfr_cmpabs (xx, yy) <= 0)
ERROR ("Error (1) in mpfr_cmpabs\n");
mpfr_set_str_binary (xx, "-0.10100010001110110111000010001000010011111101000100011101000011100");
mpfr_set_str_binary (yy, "-0.10100010001110110111000010001000010011111101000100011101000011011");
if (mpfr_cmpabs (xx, yy) <= 0)
ERROR ("Error (2) in mpfr_cmpabs\n");
mpfr_set_prec (xx, 160);
mpfr_set_prec (yy, 160);
mpfr_set_str_binary (xx, "0.1E1");
mpfr_set_str_binary (yy, "-0.1111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111100000110001110100");
if (mpfr_cmpabs (xx, yy) <= 0)
ERROR ("Error (3) in mpfr_cmpabs\n");
mpfr_set_prec(xx, 53);
mpfr_set_prec(yy, 200);
mpfr_set_ui (xx, 1, (mpfr_rnd_t) 0);
mpfr_set_ui (yy, 1, (mpfr_rnd_t) 0);
if (mpfr_cmpabs(xx, yy) != 0)
ERROR ("Error in mpfr_cmpabs: 1.0 != 1.0\n");
mpfr_set_prec (yy, 31);
mpfr_set_str (xx, "-1.0000000002", 10, (mpfr_rnd_t) 0);
mpfr_set_ui (yy, 1, (mpfr_rnd_t) 0);
if (!(mpfr_cmpabs(xx,yy)>0))
ERROR ("Error in mpfr_cmpabs: not 1.0000000002 > 1.0\n");
mpfr_set_prec(yy, 53);
mpfr_set_ui(xx, 0, MPFR_RNDN);
mpfr_set_str (yy, "-0.1", 10, MPFR_RNDN);
if (mpfr_cmpabs(xx, yy) >= 0)
ERROR ("Error in mpfr_cmpabs(0.0, 0.1)\n");
mpfr_set_inf (xx, -1);
mpfr_set_str (yy, "23489745.0329", 10, MPFR_RNDN);
if (mpfr_cmpabs(xx, yy) <= 0)
ERROR ("Error in mpfr_cmp(-Inf, 23489745.0329)\n");
mpfr_set_inf (xx, 1);
mpfr_set_inf (yy, -1);
if (mpfr_cmpabs(xx, yy) != 0)
ERROR ("Error in mpfr_cmpabs(Inf, -Inf)\n");
mpfr_set_inf (yy, -1);
mpfr_set_str (xx, "2346.09234", 10, MPFR_RNDN);
if (mpfr_cmpabs (xx, yy) >= 0)
ERROR ("Error in mpfr_cmpabs(-Inf, 2346.09234)\n");
mpfr_set_prec (xx, 2);
mpfr_set_prec (yy, 128);
mpfr_set_str_binary (xx, "0.1E10");
mpfr_set_str_binary (yy,
"0.100000000000000000000000000000000000000000000000"
"00000000000000000000000000000000000000000000001E10");
if (mpfr_cmpabs (xx, yy) >= 0)
ERROR ("Error in mpfr_cmpabs(10.235, 2346.09234)\n");
mpfr_swap (xx, yy);
if (mpfr_cmpabs(xx, yy) <= 0)
ERROR ("Error in mpfr_cmpabs(2346.09234, 10.235)\n");
mpfr_swap (xx, yy);
/* Check for NAN */
mpfr_set_nan (xx);
mpfr_clear_erangeflag ();
c = (mpfr_cmp) (xx, yy);
if (c != 0 || !mpfr_erangeflag_p () )
{
printf ("NAN error (1)\n");
exit (1);
}
mpfr_clear_erangeflag ();
c = (mpfr_cmp) (yy, xx);
if (c != 0 || !mpfr_erangeflag_p () )
{
printf ("NAN error (2)\n");
exit (1);
}
mpfr_clear_erangeflag ();
c = (mpfr_cmp) (xx, xx);
if (c != 0 || !mpfr_erangeflag_p () )
{
printf ("NAN error (3)\n");
exit (1);
}
mpfr_clear (xx);
mpfr_clear (yy);
tests_end_mpfr ();
return 0;
}
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;
}