void
ovm_dd_div(oregister_t *l, oregister_t *r)
{
switch (r->t) {
case t_void:
l->v.dd /= 0.0;
check_cdd(l);
break;
case t_word:
l->v.dd /= r->v.w;
check_cdd(l);
break;
case t_float:
l->v.dd /= r->v.d;
check_cdd(l);
break;
case t_mpz:
l->v.dd /= mpz_get_d(ozr(r));
check_cdd(l);
break;
case t_rat:
l->v.dd /= rat_get_d(r->v.r);
check_cdd(l);
break;
case t_mpq:
l->v.dd /= mpq_get_d(oqr(r));
check_cdd(l);
break;
case t_mpr:
l->t = t_mpc;
mpc_set_d_d(occ(l), real(l->v.dd), imag(l->v.dd), thr_rndc);
mpc_set_fr(occ(r), orr(r), thr_rndc);
mpc_div(occ(l), occ(l), occ(r), thr_rndc);
check_mpc(l);
break;
case t_cdd:
l->v.dd /= r->v.dd;
check_cdd(l);
break;
case t_cqq:
real(r->v.dd) = mpq_get_d(oqr(r));
imag(r->v.dd) = mpq_get_d(oqi(r));
l->v.dd /= r->v.dd;
check_cdd(l);
break;
case t_mpc:
l->t = t_mpc;
mpc_set_d_d(occ(l), real(l->v.dd), imag(l->v.dd), thr_rndc);
mpc_div(occ(l), occ(l), occ(r), thr_rndc);
check_mpc(l);
break;
default:
ovm_raise(except_not_a_number);
}
}
void
ovm_dd_atan2(oregister_t *l, oregister_t *r)
{
switch (r->t) {
case t_void:
goto flt;
case t_word:
if (r->v.w) {
real(r->v.dd) = r->v.w;
imag(r->v.dd) = 0.0;
goto cdd;
}
flt:
l->t = t_float;
l->v.d = real(l->v.dd) >= 0.0 ? M_PI_2 : -M_PI_2;
break;
case t_float:
if (r->v.d) {
real(r->v.dd) = r->v.d;
imag(r->v.dd) = 0.0;
goto cdd;
}
goto flt;
case t_mpz:
real(r->v.dd) = mpz_get_d(ozr(r));
imag(r->v.dd) = 0.0;
goto cdd;
case t_rat:
real(r->v.dd) = rat_get_d(r->v.r);
imag(r->v.dd) = 0.0;
goto cdd;
case t_mpq:
real(r->v.dd) = mpq_get_d(oqr(r));
imag(r->v.dd) = 0.0;
goto cdd;
case t_mpr:
mpc_set_fr(occ(r), orr(r), thr_rndc);
goto mpc;
case t_cdd:
cdd:
l->v.dd = catan(l->v.dd / r->v.dd);
check_cdd(l);
break;
case t_cqq:
real(r->v.dd) = mpq_get_d(oqr(r));
imag(r->v.dd) = mpq_get_d(oqi(r));
goto cdd;
case t_mpc:
mpc:
l->t = t_mpc;
mpc_set_d_d(occ(l), real(l->v.dd), imag(l->v.dd), thr_rndc);
mpc_div(occ(l), occ(l), occ(r), thr_rndc);
mpc_atan(occ(l), occ(l), thr_rndc);
check_mpc(l);
break;
default:
ovm_raise(except_not_a_number);
}
}
SEXP R_mpc_div(SEXP e1, SEXP e2) {
/* N.B. We always use signed integers for e2 given R's type system. */
mpc_t *z = (mpc_t *)malloc(sizeof(mpc_t));
if (Rf_inherits(e1, "mpc")) {
mpc_t *z1 = (mpc_t *)R_ExternalPtrAddr(e1);
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, max(mpc_get_prec(*z1),
mpc_get_prec(*z2)));
mpc_div(*z, *z1, *z2, Rmpc_get_rounding());
} else if (Rf_isInteger(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpc_div_ui(*z, *z1, INTEGER(e2)[0],
Rmpc_get_rounding());
} else if (Rf_isNumeric(e2)) {
mpc_init2(*z, mpc_get_prec(*z1));
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
mpc_div_fr(*z, *z1, x, Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc division.");
}
} else if (Rf_isInteger(e1)) {
if (Rf_inherits(e2, "mpc")) {
/* TODO: sign issue here. mpc_ui_div is
* unsigned, mult -1 if needed by asnwer? */
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpc_init2(*z, mpc_get_prec(*z2));
mpc_ui_div(*z, INTEGER(e1)[0], *z2,
Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc division.");
}
} else if (Rf_isNumeric(e1)) {
if (Rf_inherits(e2, "mpc")) {
mpc_t *z2 = (mpc_t *)R_ExternalPtrAddr(e2);
mpfr_t x;
mpfr_init2(x, 53);
mpfr_set_d(x, REAL(e2)[0], GMP_RNDN);
mpc_fr_div(*z, x, *z2, Rmpc_get_rounding());
} else {
Rf_error("Invalid second operand for mpc division.");
}
} else {
Rf_error("Invalid operands for mpc division.");
}
SEXP retVal = PROTECT(R_MakeExternalPtr((void *)z,
Rf_install("mpc ptr"), R_NilValue));
Rf_setAttrib(retVal, R_ClassSymbol, Rf_mkString("mpc"));
R_RegisterCFinalizerEx(retVal, mpcFinalizer, TRUE);
UNPROTECT(1);
return retVal;
}
void
ovm_q_div(oregister_t *l, oregister_t *r)
{
switch (r->t) {
case t_void:
ovm_raise(except_floating_point_error);
case t_word:
mpq_set_si(oqr(r), r->v.w, 1);
mpq_div(oqr(l), oqr(l), oqr(r));
check_mpq(l);
break;
case t_float:
l->t = t_float;
l->v.d = mpq_get_d(oqr(l)) / r->v.d;
break;
case t_mpz:
mpz_set_ui(ozs(r), 1);
mpq_div(oqr(l), oqr(l), oqr(r));
check_mpq(l);
break;
case t_rat:
mpq_set_si(oqr(r), rat_num(r->v.r), rat_den(r->v.r));
mpq_div(oqr(l), oqr(l), oqr(r));
check_mpq(l);
break;
case t_mpq:
mpq_div(oqr(l), oqr(l), oqr(r));
check_mpq(l);
break;
case t_mpr:
l->t = t_mpr;
mpfr_set_q(orr(l), oqr(l), thr_rnd);
mpfr_div(orr(l), orr(l), orr(r), thr_rnd);
break;
case t_cdd:
l->t = t_cdd;
l->v.dd = mpq_get_d(oqr(l)) * r->v.dd;
check_cdd(l);
break;
case t_cqq:
l->t = t_cqq;
mpq_set_ui(oqi(l), 0, 1);
cqq_div(oqq(l), oqq(l), oqq(r));
check_cqq(l);
break;
case t_mpc:
l->t = t_mpc;
mpc_set_q(occ(l), oqr(l), thr_rndc);
mpc_div(occ(l), occ(l), occ(r), thr_rndc);
check_mpc(l);
break;
default:
ovm_raise(except_not_a_number);
}
}
int
mpc_ui_div (mpc_ptr a, unsigned long int b, mpc_srcptr c, mpc_rnd_t rnd)
{
int inex;
mpc_t bb;
mpc_init2 (bb, sizeof(unsigned long int) * CHAR_BIT);
mpc_set_ui (bb, b, rnd); /* exact */
inex = mpc_div (a, bb, c, rnd);
mpc_clear (bb);
return inex;
}
// Computes j = j(tau).
static void compute_j(mpc_t j, mpc_t tau) {
mpc_t h;
mpc_t z0;
mpc_init(h);
mpc_init(z0);
compute_h(h, tau);
//mpc_mul_ui(z0, h, 256);
mpc_mul_2exp(z0, h, 8);
mpc_add_ui(z0, z0, 1);
mpc_pow_ui(z0, z0, 3);
mpc_div(j, z0, h);
mpc_clear(z0);
mpc_clear(h);
}
// Computes z = h(tau)
// (called h() by Blake et al, f() by Cohen.)
static void compute_h(mpc_t z, mpc_t tau) {
mpc_t z0, z1, q;
mpc_init(q);
mpc_init(z0);
mpc_init(z1);
compute_q(q, tau);
mpc_mul(z0, q, q);
compute_Delta(z0, z0);
compute_Delta(z1, q);
mpc_div(z, z0, z1);
mpc_clear(q);
mpc_clear(z0);
mpc_clear(z1);
}
int
mpc_fr_div (mpc_ptr a, mpfr_srcptr b, mpc_srcptr c, mpc_rnd_t rnd)
{
mpc_t bc;
int inexact;
MPC_RE (bc)[0] = b [0];
mpfr_init (MPC_IM (bc));
/* we consider the operand b to have imaginary part +0 */
mpfr_set_ui (MPC_IM (bc), 0, GMP_RNDN);
inexact = mpc_div (a, bc, c, rnd);
mpfr_clear (MPC_IM (bc));
return inexact;
}
/******************************************************
* SUBROUTINE MNEWTON_USR *
*******************************************************
multiprecision computation
******************************************************/
void
mnewton_usr (mpc_t x, rdpe_t rad, mpc_t corr, mps_boolean * again)
{
int i, m;
rdpe_t ap, ax, eps, temp, apeps, atmp;
cdpe_t ctmp;
tmpc_t p, pp, pt, tmp;
tmpc_init2 (p, mpwp);
tmpc_init2 (pp, mpwp);
tmpc_init2 (pt, mpwp);
tmpc_init2 (tmp, mpwp);
m = (int) (log (n + 1.0) / LOG2);
if ((1 << m) <= n)
m++;
rdpe_set (eps, mp_epsilon);
rdpe_mul_eq_d (eps, (double) 4 * n);
mpc_get_cdpe (ctmp, x);
cdpe_mod (ax, ctmp);
mpc_set_ui (p, 1, 0);
mpc_set_ui (pp, 0, 0);
rdpe_set (ap, rdpe_one);
for (i = 1; i <= m; i++)
{
mpc_sqr (tmp, p);
mpc_mul (pt, x, tmp);
mpc_add_eq_ui (pt, 1, 0);
mpc_mul_eq (pp, x);
mpc_mul_eq (pp, p);
mpc_mul_eq_ui (pp, 2);
mpc_add_eq (pp, tmp);
mpc_set (p, pt);
rdpe_mul_eq (ap, ax);
mpc_get_cdpe (ctmp, p);
cdpe_mod (atmp, ctmp);
rdpe_add_eq (ap, atmp);
}
rdpe_mul_eq (ap, ax);
mpc_div (corr, p, pp);
mpc_get_cdpe (ctmp, p);
cdpe_mod (temp, ctmp);
rdpe_mul (apeps, ap, eps);
rdpe_mul_eq_d (apeps, 3.0);
*again = rdpe_gt (temp, apeps);
rdpe_add (rad, temp, apeps);
rdpe_mul_eq_d (rad, (double) n);
mpc_get_cdpe (ctmp, pp);
cdpe_mod (temp, ctmp);
rdpe_div_eq (rad, temp);
if (rdpe_eq (rad, rdpe_zero))
rdpe_mul (rad, ax, eps);
tmpc_clear (tmp);
tmpc_clear (pt);
tmpc_clear (pp);
tmpc_clear (p);
}
void
ovm_q_atan2(oregister_t *l, oregister_t *r)
{
switch (r->t) {
case t_void:
if (!cfg_float_format) {
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), 0.0);
}
else {
mpfr_set_ui(orr(r), 0, thr_rnd);
goto mpr;
}
break;
case t_word:
if (!cfg_float_format) {
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), r->v.w);
}
else {
mpfr_set_si(orr(r), r->v.w, thr_rnd);
goto mpr;
}
break;
case t_float:
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), r->v.d);
break;
case t_mpz:
if (!cfg_float_format) {
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), mpz_get_d(ozr(r)));
}
else {
mpfr_set_z(orr(r), ozr(r), thr_rnd);
goto mpr;
}
break;
case t_rat:
if (!cfg_float_format) {
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), rat_get_d(r->v.r));
}
else {
mpq_set_si(oqr(r), rat_num(r->v.r), rat_den(r->v.r));
mpfr_set_q(orr(r), oqr(r), thr_rnd);
goto mpr;
}
break;
case t_mpq:
if (!cfg_float_format) {
l->t = t_float;
l->v.d = atan2(mpq_get_d(oqr(l)), mpq_get_d(oqr(r)));
}
else {
mpfr_set_q(orr(r), oqr(r), thr_rnd);
goto mpr;
}
break;
case t_mpr:
mpr:
mpfr_set_q(orr(l), oqr(l), thr_rnd);
l->t = t_mpr;
mpfr_atan2(orr(l), orr(l), orr(r), thr_rnd);
break;
case t_cdd:
cdd:
l->t = t_cdd;
real(l->v.dd) = mpq_get_d(oqr(l));
imag(l->v.dd) = 0.0;
l->v.dd = catan(l->v.dd / r->v.dd);
check_cdd(l);
break;
case t_cqq:
if (!cfg_float_format) {
real(r->v.dd) = mpq_get_d(oqr(r));
imag(r->v.dd) = mpq_get_d(oqi(r));
goto cdd;
}
mpc_set_q_q(occ(r), oqr(r), oqi(r), thr_rndc);
case t_mpc:
l->t = t_mpc;
mpc_set_q(occ(l), oqr(l), thr_rndc);
mpc_div(occ(l), occ(l), occ(r), thr_rndc);
mpc_atan(occ(l), occ(l), thr_rndc);
check_mpc(l);
break;
default:
ovm_raise(except_not_a_number);
}
}
int
mpc_tan (mpc_ptr rop, mpc_srcptr op, mpc_rnd_t rnd)
{
mpc_t x, y;
mpfr_prec_t prec;
mpfr_exp_t err;
int ok = 0;
int inex;
/* special values */
if (!mpc_fin_p (op))
{
if (mpfr_nan_p (mpc_realref (op)))
{
if (mpfr_inf_p (mpc_imagref (op)))
/* tan(NaN -i*Inf) = +/-0 -i */
/* tan(NaN +i*Inf) = +/-0 +i */
{
/* exact unless 1 is not in exponent range */
inex = mpc_set_si_si (rop, 0,
(MPFR_SIGN (mpc_imagref (op)) < 0) ? -1 : +1,
rnd);
}
else
/* tan(NaN +i*y) = NaN +i*NaN, when y is finite */
/* tan(NaN +i*NaN) = NaN +i*NaN */
{
mpfr_set_nan (mpc_realref (rop));
mpfr_set_nan (mpc_imagref (rop));
inex = MPC_INEX (0, 0); /* always exact */
}
}
else if (mpfr_nan_p (mpc_imagref (op)))
{
if (mpfr_cmp_ui (mpc_realref (op), 0) == 0)
/* tan(-0 +i*NaN) = -0 +i*NaN */
/* tan(+0 +i*NaN) = +0 +i*NaN */
{
mpc_set (rop, op, rnd);
inex = MPC_INEX (0, 0); /* always exact */
}
else
/* tan(x +i*NaN) = NaN +i*NaN, when x != 0 */
{
mpfr_set_nan (mpc_realref (rop));
mpfr_set_nan (mpc_imagref (rop));
inex = MPC_INEX (0, 0); /* always exact */
}
}
else if (mpfr_inf_p (mpc_realref (op)))
{
if (mpfr_inf_p (mpc_imagref (op)))
/* tan(-Inf -i*Inf) = -/+0 -i */
/* tan(-Inf +i*Inf) = -/+0 +i */
/* tan(+Inf -i*Inf) = +/-0 -i */
/* tan(+Inf +i*Inf) = +/-0 +i */
{
const int sign_re = mpfr_signbit (mpc_realref (op));
int inex_im;
mpfr_set_ui (mpc_realref (rop), 0, MPC_RND_RE (rnd));
mpfr_setsign (mpc_realref (rop), mpc_realref (rop), sign_re, MPFR_RNDN);
/* exact, unless 1 is not in exponent range */
inex_im = mpfr_set_si (mpc_imagref (rop),
mpfr_signbit (mpc_imagref (op)) ? -1 : +1,
MPC_RND_IM (rnd));
inex = MPC_INEX (0, inex_im);
}
else
/* tan(-Inf +i*y) = tan(+Inf +i*y) = NaN +i*NaN, when y is
finite */
{
mpfr_set_nan (mpc_realref (rop));
mpfr_set_nan (mpc_imagref (rop));
inex = MPC_INEX (0, 0); /* always exact */
}
}
else
/* tan(x -i*Inf) = +0*sin(x)*cos(x) -i, when x is finite */
/* tan(x +i*Inf) = +0*sin(x)*cos(x) +i, when x is finite */
{
mpfr_t c;
mpfr_t s;
int inex_im;
mpfr_init (c);
mpfr_init (s);
mpfr_sin_cos (s, c, mpc_realref (op), MPFR_RNDN);
mpfr_set_ui (mpc_realref (rop), 0, MPC_RND_RE (rnd));
mpfr_setsign (mpc_realref (rop), mpc_realref (rop),
mpfr_signbit (c) != mpfr_signbit (s), MPFR_RNDN);
/* exact, unless 1 is not in exponent range */
inex_im = mpfr_set_si (mpc_imagref (rop),
(mpfr_signbit (mpc_imagref (op)) ? -1 : +1),
MPC_RND_IM (rnd));
inex = MPC_INEX (0, inex_im);
mpfr_clear (s);
mpfr_clear (c);
}
return inex;
}
if (mpfr_zero_p (mpc_realref (op)))
/* tan(-0 -i*y) = -0 +i*tanh(y), when y is finite. */
/* tan(+0 +i*y) = +0 +i*tanh(y), when y is finite. */
{
int inex_im;
mpfr_set (mpc_realref (rop), mpc_realref (op), MPC_RND_RE (rnd));
inex_im = mpfr_tanh (mpc_imagref (rop), mpc_imagref (op), MPC_RND_IM (rnd));
return MPC_INEX (0, inex_im);
}
if (mpfr_zero_p (mpc_imagref (op)))
/* tan(x -i*0) = tan(x) -i*0, when x is finite. */
/* tan(x +i*0) = tan(x) +i*0, when x is finite. */
{
int inex_re;
inex_re = mpfr_tan (mpc_realref (rop), mpc_realref (op), MPC_RND_RE (rnd));
mpfr_set (mpc_imagref (rop), mpc_imagref (op), MPC_RND_IM (rnd));
return MPC_INEX (inex_re, 0);
}
/* ordinary (non-zero) numbers */
/* tan(op) = sin(op) / cos(op).
We use the following algorithm with rounding away from 0 for all
operations, and working precision w:
(1) x = A(sin(op))
(2) y = A(cos(op))
(3) z = A(x/y)
the error on Im(z) is at most 81 ulp,
the error on Re(z) is at most
7 ulp if k < 2,
8 ulp if k = 2,
else 5+k ulp, where
k = Exp(Re(x))+Exp(Re(y))-2min{Exp(Re(y)), Exp(Im(y))}-Exp(Re(x/y))
see proof in algorithms.tex.
*/
prec = MPC_MAX_PREC(rop);
mpc_init2 (x, 2);
mpc_init2 (y, 2);
err = 7;
do
{
mpfr_exp_t k, exr, eyr, eyi, ezr;
ok = 0;
/* FIXME: prevent addition overflow */
prec += mpc_ceil_log2 (prec) + err;
mpc_set_prec (x, prec);
mpc_set_prec (y, prec);
/* rounding away from zero: except in the cases x=0 or y=0 (processed
above), sin x and cos y are never exact, so rounding away from 0 is
rounding towards 0 and adding one ulp to the absolute value */
mpc_sin_cos (x, y, op, MPC_RNDZZ, MPC_RNDZZ);
MPFR_ADD_ONE_ULP (mpc_realref (x));
MPFR_ADD_ONE_ULP (mpc_imagref (x));
MPFR_ADD_ONE_ULP (mpc_realref (y));
MPFR_ADD_ONE_ULP (mpc_imagref (y));
MPC_ASSERT (mpfr_zero_p (mpc_realref (x)) == 0);
if ( mpfr_inf_p (mpc_realref (x)) || mpfr_inf_p (mpc_imagref (x))
|| mpfr_inf_p (mpc_realref (y)) || mpfr_inf_p (mpc_imagref (y))) {
/* If the real or imaginary part of x is infinite, it means that
Im(op) was large, in which case the result is
sign(tan(Re(op)))*0 + sign(Im(op))*I,
where sign(tan(Re(op))) = sign(Re(x))*sign(Re(y)). */
int inex_re, inex_im;
mpfr_set_ui (mpc_realref (rop), 0, MPFR_RNDN);
if (mpfr_sgn (mpc_realref (x)) * mpfr_sgn (mpc_realref (y)) < 0)
{
mpfr_neg (mpc_realref (rop), mpc_realref (rop), MPFR_RNDN);
inex_re = 1;
}
else
inex_re = -1; /* +0 is rounded down */
if (mpfr_sgn (mpc_imagref (op)) > 0)
{
mpfr_set_ui (mpc_imagref (rop), 1, MPFR_RNDN);
inex_im = 1;
}
else
{
mpfr_set_si (mpc_imagref (rop), -1, MPFR_RNDN);
inex_im = -1;
}
inex = MPC_INEX(inex_re, inex_im);
goto end;
}
exr = mpfr_get_exp (mpc_realref (x));
eyr = mpfr_get_exp (mpc_realref (y));
eyi = mpfr_get_exp (mpc_imagref (y));
/* some parts of the quotient may be exact */
inex = mpc_div (x, x, y, MPC_RNDZZ);
/* OP is no pure real nor pure imaginary, so in theory the real and
imaginary parts of its tangent cannot be null. However due to
rouding errors this might happen. Consider for example
tan(1+14*I) = 1.26e-10 + 1.00*I. For small precision sin(op) and
cos(op) differ only by a factor I, thus after mpc_div x = I and
its real part is zero. */
if (mpfr_zero_p (mpc_realref (x)) || mpfr_zero_p (mpc_imagref (x)))
{
err = prec; /* double precision */
continue;
}
if (MPC_INEX_RE (inex))
MPFR_ADD_ONE_ULP (mpc_realref (x));
if (MPC_INEX_IM (inex))
MPFR_ADD_ONE_ULP (mpc_imagref (x));
MPC_ASSERT (mpfr_zero_p (mpc_realref (x)) == 0);
ezr = mpfr_get_exp (mpc_realref (x));
/* FIXME: compute
k = Exp(Re(x))+Exp(Re(y))-2min{Exp(Re(y)), Exp(Im(y))}-Exp(Re(x/y))
avoiding overflow */
k = exr - ezr + MPC_MAX(-eyr, eyr - 2 * eyi);
err = k < 2 ? 7 : (k == 2 ? 8 : (5 + k));
/* Can the real part be rounded? */
ok = (!mpfr_number_p (mpc_realref (x)))
|| mpfr_can_round (mpc_realref(x), prec - err, MPFR_RNDN, MPFR_RNDZ,
MPC_PREC_RE(rop) + (MPC_RND_RE(rnd) == MPFR_RNDN));
if (ok)
{
/* Can the imaginary part be rounded? */
ok = (!mpfr_number_p (mpc_imagref (x)))
|| mpfr_can_round (mpc_imagref(x), prec - 6, MPFR_RNDN, MPFR_RNDZ,
MPC_PREC_IM(rop) + (MPC_RND_IM(rnd) == MPFR_RNDN));
}
}
while (ok == 0);
inex = mpc_set (rop, x, rnd);
end:
mpc_clear (x);
mpc_clear (y);
return inex;
}
/**
* @brief Worker for the mpolzer routine.
*/
static void *
mps_thread_mpolzer_worker (void *data_ptr)
{
mps_thread_worker_data *data = (mps_thread_worker_data*)data_ptr;
mps_context *s = data->s;
mps_polynomial *p = s->active_poly;
mps_thread_job job;
int iter, l;
mpc_t corr, abcorr, mroot, diff;
rdpe_t eps, rad1, rtmp;
cdpe_t ctmp;
mpc_init2 (abcorr, s->mpwp);
mpc_init2 (corr, s->mpwp);
mpc_init2 (mroot, s->mpwp);
mpc_init2 (diff, s->mpwp);
rdpe_mul_d (eps, s->mp_epsilon, (double)4 * s->n);
/* Continue to iterate while exception condition has not
* been reached and there more roots to approximate */
while ((*data->nzeros) < data->required_zeros)
{
/* Get next job for this thread */
job = mps_thread_job_queue_next (s, data->queue);
/* Set variables to be used in the rest of the code */
iter = job.iter;
/* Check if we exceeded the maximum number of iterations */
if (job.iter == MPS_THREAD_JOB_EXCEP)
{
(*data->excep) = true;
goto endfun;
}
l = job.i;
/* Lock roots_mutex to assure that we are the only thread
* working on this root. Parallel computation on the same
* root is not useful, since we would be performing the
* same computations. */
if (s->pool->n > 1)
pthread_mutex_lock (&data->roots_mutex[l]);
/* MPS_DEBUG (s, "Iterating on root %d, iter %d", l, job.iter); */
if (s->root[l]->again)
{
/* Check if, while we were waiting, excep condition has been reached,
* or all the zeros has been approximated. */
if (*data->excep || (*data->nzeros) >= data->required_zeros)
{
if (s->pool->n > 1)
pthread_mutex_unlock (&data->roots_mutex[l]);
goto endfun;
}
/* Increment total iteration counter */
(*data->it)++;
/* Copy locally the root to work on */
if (s->pool->n > 1)
pthread_mutex_lock (&data->aberth_mutex[l]);
mpc_set (mroot, s->root[l]->mvalue);
if (s->pool->n > 1)
pthread_mutex_unlock (&data->aberth_mutex[l]);
/* sparse/dense polynomial */
rdpe_set (rad1, s->root[l]->drad);
mps_polynomial_mnewton (s, p, s->root[l], corr, s->mpwp);
if (iter == 0 && !s->root[l]->again && rdpe_gt (s->root[l]->drad, rad1)
&& rdpe_ne (rad1, rdpe_zero))
rdpe_set (s->root[l]->drad, rad1);
/************************************************
The above condition is needed to cope with the case
where at the first iteration the starting point is
already in the root neighbourhood and the actually
computed radius is too big since the value of the
first derivative is too small.
In this case the previous radius bound, obtained by
means of Rouche' is more reliable and strict
***********************************************/
if (s->root[l]->again
/* the correction is performed only if iter!=1 or rad[l]!=rad1 */
|| iter != 0
|| rdpe_ne (s->root[l]->drad, rad1))
{
/* Global lock to aberth step to reach a real Gauss-Seidel iteration */
if (s->pool->n > 1)
pthread_mutex_lock (data->global_aberth_mutex);
/* Compute Aberth correction with locks so we can lock the
* roots while reading them. */
mps_maberth_s_wl (s, l, job.cluster_item->cluster, abcorr,
data->aberth_mutex);
/* Apply aberth correction that has been computed */
mpc_mul_eq (abcorr, corr);
mpc_neg_eq (abcorr);
mpc_add_eq_ui (abcorr, 1, 0);
mpc_div (abcorr, corr, abcorr);
mpc_sub_eq (mroot, abcorr);
mpc_get_cdpe (ctmp, abcorr);
cdpe_mod (rtmp, ctmp);
rdpe_add_eq (s->root[l]->drad, rtmp);
/* Lock aberth_mutex and copy the computed root back
* to its place */
if (s->pool->n > 1)
pthread_mutex_lock (&data->aberth_mutex[l]);
mpc_set (s->root[l]->mvalue, mroot);
if (s->pool->n > 1)
pthread_mutex_unlock (&data->aberth_mutex[l]);
/* Go with others aberth iterations */
if (s->pool->n > 1)
pthread_mutex_unlock (data->global_aberth_mutex);
}
/* check for new approximated roots */
if (!s->root[l]->again)
{
(*data->nzeros)++;
if ((*data->nzeros) >= data->required_zeros)
{
if (s->pool->n > 1)
pthread_mutex_unlock (&data->roots_mutex[l]);
goto endfun;
}
}
}
if (s->pool->n > 1)
pthread_mutex_unlock (&data->roots_mutex[l]);
/* MPS_DEBUG_MPC (s, 15, s->root[l]->mvalue, "s->mroot[%d]", l); */
/* MPS_DEBUG_RDPE (s, s->root[l]->drad, "s->drad[%d]", l); */
if ((*data->nzeros) == s->n)
{
goto endfun;
}
}
endfun: /* free local MP variables */
mpc_clear (corr);
mpc_clear (abcorr);
mpc_clear (mroot);
mpc_clear (diff);
return NULL;
}
/**
* @brief User-defined program for the computation of \f$p\f$, \f$p'\f$.
*
* @param s The current mps_context
* @param poly The mps_polynomial being solved.
* @param root The approximation whose Newton correction shall be computed.
* @param corr The output value where the newton correction will be stored.
*
* This sample computes the 'Quadratic polynomial by
* means of the relation: p=1+x*p**2, starting with p=1
*/
void
mps_quadratic_poly_mnewton (mps_context * ctx, mps_polynomial * poly,
mps_approximation * root, mpc_t corr, long int wp)
{
int i, m, n = poly->degree;
rdpe_t ap, ax, eps, temp, apeps, atmp, epsilon, drad;
cdpe_t ctmp;
mpc_t p, pp, pt, tmp, x;
mps_boolean again;
mpc_init2 (p, wp);
mpc_init2 (pp, wp);
mpc_init2 (pt, wp);
mpc_init2 (tmp, wp);
mpc_init2 (x, wp);
mps_approximation_get_mvalue (ctx, root, x);
mps_approximation_get_drad (ctx, root, drad);
again = mps_approximation_get_again (ctx, root);
rdpe_set_2dl (epsilon, 1.0, 2 - wp);
m = (int) (log (n + 1.0) / LOG2);
if ((1 << m) <= n)
m++;
rdpe_set (eps, epsilon);
rdpe_mul_eq_d (eps, (double) 4 * n);
mpc_get_cdpe (ctmp, x);
cdpe_mod (ax, ctmp);
mpc_set_ui (p, 1, 0);
mpc_set_ui (pp, 0, 0);
rdpe_set (ap, rdpe_one);
for (i = 1; i <= m; i++)
{
mpc_sqr (tmp, p);
mpc_mul (pt, x, tmp);
mpc_add_eq_ui (pt, 1, 0);
mpc_mul_eq (pp, x);
mpc_mul_eq (pp, p);
mpc_mul_eq_ui (pp, 2);
mpc_add_eq (pp, tmp);
mpc_set (p, pt);
rdpe_mul_eq (ap, ax);
mpc_get_cdpe (ctmp, p);
cdpe_mod (atmp, ctmp);
rdpe_add_eq (ap, atmp);
}
rdpe_mul_eq (ap, ax);
mpc_div (corr, p, pp);
mpc_get_cdpe (ctmp, p);
cdpe_mod (temp, ctmp);
rdpe_mul (apeps, ap, eps);
rdpe_mul_eq_d (apeps, 3.0);
mps_approximation_set_again (ctx, root, rdpe_gt (temp, apeps));
rdpe_add (drad, temp, apeps);
rdpe_mul_eq_d (drad, (double) n);
mpc_get_cdpe (ctmp, pp);
cdpe_mod (temp, ctmp);
rdpe_div_eq (drad, temp);
if (rdpe_eq (drad, rdpe_zero))
rdpe_mul (drad, ax, eps);
mps_approximation_set_drad (ctx, root, drad);
mps_approximation_set_again (ctx, root, again);
mpc_clear (tmp);
mpc_clear (pt);
mpc_clear (pp);
mpc_clear (p);
mpc_clear (x);
}
mpcomplex operator/(const mpcomplex& a, const mpcomplex& b) {
mpc_t value;
mpc_init3( value , a.mpc_prec, a.mpc_prec );
mpc_div(value, a.mpc_val, b.mpc_val, a.default_rnd);
return mpcomplex(value);
}
mpcomplex& mpcomplex::operator/=( const mpcomplex& a) {
mpc_div(mpc_val, mpc_val, a.mpc_val, default_rnd);
return *this;
}
void Lib_Mpcr_Div(MpcrPtr x, MpcrPtr y, MpcrPtr z, long rnd)
{
mpc_div( (mpc_ptr) x, (mpc_ptr) y, (mpc_ptr) z, (mpc_rnd_t) rnd);
}
