/*
This file is part of liberferfc.
Copyright 2009-2010 by
Laboratoire de l'Informatique du Parallélisme, UMR CNRS - ENS Lyon -
UCB Lyon 1 - INRIA 5668,
and by LORIA (CNRS, INPL, INRIA, UHP, U-Nancy 2).
It has been written by S. Chevillard.
Liberferfc is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.
Liberferfc is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public License
along with liberferfc. If not, see .
*/
#include
#include "erferfc_utils.h"
#include "erferfc.h"
#include "tune/tune.h"
#include "math.h"
/* Chooses the method that should be used for evaluating erf */
/* on |x| with precision prec. */
/* It uses paramters defined in tune/tune.h */
/* They can be adapted for each architecture: */
/* see boundaryExample.dat for more details. */
int choose_method(mpfr_t x, mpfr_prec_t prec) {
mpfr_t tmp;
double logx, logprec;
/* Just shortcuts */
const double ax = log(POINT_Ax);
const double ay = log(POINT_Ay);
const double bx = log(POINT_Bx);
const double by = log(POINT_By);
const double cx = log(POINT_Cx);
const double cy = log(POINT_Cy);
const double dx = log(POINT_Dx);
const double dy = log(POINT_Dy);
mpfr_init2(tmp, SMALL_PRECISION);
mpfr_set(tmp, x, MPFR_RNDD);
mpfr_sqr(tmp, tmp, MPFR_RNDD);
mpfr_my_mul_d(tmp, tmp, LOG2EINF, MPFR_RNDD);
mpfr_mul_2ui(tmp, tmp, 1, MPFR_RNDD);
mpfr_add_si(tmp, tmp, mpfr_get_exp(x), MPFR_RNDD);
if (mpfr_cmp_ui(tmp, ADD_UI_SAFE(prec,6)) >=0) {
mpfr_clear(tmp);
return 3;
}
if ((double)prec <= POINT_Ay) {
mpfr_clear(tmp);
return 1;
}
/* else... */
mpfr_abs(tmp, x, MPFR_RNDN);
logx = log(mpfr_get_d(tmp, MPFR_RNDN));
mpfr_clear(tmp);
logprec = log(prec);
if ( (double)prec < POINT_By ) {
if ( (by-ay)*(logx-ax)+(ax-bx)*(logprec-ay) >= 0 ) return 2;
else return 1;
}
else if ( (double)prec < POINT_Cy ) {
if ( (cy-by)*(logx-bx)+(bx-cx)*(logprec-by) >= 0 ) return 2;
else return 1;
}
else {
if ( (dy-cy)*(logx-cx)+(cx-dx)*(logprec-cy) >= 0 ) return 2;
else return 1;
}
}
/* Wrapper for computing erf(x) when x > 0 */
/* method \in {1,2,3} indicates which method must be used. */
/* NULL is returned when the accuracy cannot be achieved. */
mpfr_t *mp_erf_xpos(mpfr_t x, mpfr_prec_t tprime, int method) {
mpfr_t tmp;
mpfr_t *R, *res;
mpfr_prec_t s;
mpfr_exp_t E;
unsigned long guard_bits;
if (method==3) {
E = mpfr_get_exp(x);
if (E <= 0) return NULL;
/* else... */
mpfr_init2(tmp, SMALL_PRECISION);
mpfr_set(tmp, x, MPFR_RNDD);
mpfr_sqr(tmp, tmp, MPFR_RNDD);
mpfr_my_mul_d(tmp, tmp, LOG2EINF, MPFR_RNDD);
ASSERT(mpfr_fits_ulong_p(tmp, MPFR_RNDD));
guard_bits = mpfr_get_ui(tmp, MPFR_RNDD);
guard_bits = ADD_UI_SAFE(guard_bits, (unsigned)E);
mpfr_clear(tmp);
if ( ADD_UI_SAFE(tprime, 2) <= guard_bits ) {
res = malloc(sizeof(mpfr_t)); ASSERT(res != 0);
mpfr_init2(*res, tprime); mpfr_set_ui(*res, 1, MPFR_RNDN);
return res;
}
/* else... */
s = ADD_UI_SAFE(tprime, 3) - guard_bits;
R = mp_erfc3(x, s);
if (R == 0) return NULL;
res = malloc(sizeof(mpfr_t)); ASSERT(res != 0);
mpfr_init2(*res, ADD_UI_SAFE(tprime, 3));
mpfr_ui_sub(*res, 1, *R, MPFR_RNDN);
mpfr_clear(*R);
free(R);
return res;
}
if (method==1) return mp_erf1(x, tprime);
else return mp_erf2(x, tprime);
}
/* Wrapper for computing erf(x) when x < 0 */
/* Same semantic as mp_erf_xpos. */
mpfr_t *mp_erf_xneg(mpfr_t x, mpfr_prec_t tprime, int method) {
mpfr_t absx;
mpfr_t *r;
mpfr_init2(absx, mpfr_get_prec(x));
ASSERT(mpfr_abs(absx, x, MPFR_RNDU)==0);
r = mp_erf_xpos(absx, tprime, method);
mpfr_clear(absx);
if (r==NULL) return NULL;
/* else... */
ASSERT(mpfr_neg(*r, *r, MPFR_RNDN)==0);
return r;
}
/* Wrapper for computing erfc(x) when x > 0 */
/* Same semantic as mp_erf_xpos. */
mpfr_t *mp_erfc_xpos(mpfr_t x, mpfr_prec_t tprime, int method) {
mpfr_exp_t E;
mpfr_t tmp;
mpfr_t *R, *res;
mpfr_prec_t s;
if (method == 3) return mp_erfc3(x, tprime);
/* else method == 1 or method == 2 */
E = mpfr_get_exp(x);
if (E<=0) {
if (ADD_UI_SAFE(tprime, 4) <= (unsigned)(-E)) {
res = malloc(sizeof(mpfr_t)); ASSERT(res != 0);
mpfr_init2(*res, tprime); mpfr_set_ui(*res, 1, MPFR_RNDN);
return res;
}
/* else... */
s = ADD_UI_SAFE(tprime, 5) + E;
}
else {
s = ADD_UI_SAFE((unsigned)E, ADD_UI_SAFE(tprime, 3));
mpfr_init2(tmp, SMALL_PRECISION);
mpfr_set(tmp, x, MPFR_RNDU);
mpfr_sqr(tmp, tmp, MPFR_RNDU);
mpfr_my_mul_d(tmp, tmp, LOG2ESUP, MPFR_RNDU);
ASSERT(mpfr_fits_ulong_p(tmp, MPFR_RNDU));
s = ADD_UI_SAFE(s, mpfr_get_ui(tmp, MPFR_RNDU));
mpfr_clear(tmp);
}
if (method==1) R = mp_erf1(x, s);
else R = mp_erf2(x, s);
res = malloc(sizeof(mpfr_t)); ASSERT(res != NULL);
mpfr_init2(*res, ADD_UI_SAFE(tprime, 3));
mpfr_ui_sub(*res, 1, *R, MPFR_RNDN);
mpfr_clear(*R);
free(R);
return res;
}
/* Wrapper for computing erfc(x) when x < 0 */
/* Same semantic as mp_erf_xpos. */
mpfr_t *mp_erfc_xneg(mpfr_t x, mpfr_prec_t tprime, int method) {
mpfr_exp_t E;
mpfr_prec_t s;
mpfr_t absx, tmp;
mpfr_t *R, *res;
unsigned long guard_bits;
E = mpfr_get_exp(x);
if (method == 3) {
if (E <= 0) return NULL;
/* else... */
mpfr_init2(tmp, SMALL_PRECISION);
mpfr_set(tmp, x, MPFR_RNDD);
mpfr_sqr(tmp, tmp, MPFR_RNDD);
mpfr_my_mul_d(tmp, tmp, LOG2EINF, MPFR_RNDD);
ASSERT(mpfr_fits_ulong_p(tmp, MPFR_RNDD));
guard_bits = mpfr_get_ui(tmp, MPFR_RNDD);
mpfr_clear(tmp);
guard_bits = ADD_UI_SAFE(guard_bits, (unsigned)E);
if (ADD_UI_SAFE(tprime, 1) <= guard_bits) {
res = malloc(sizeof(mpfr_t)); ASSERT(res != NULL);
mpfr_init2(*res, tprime);
mpfr_set_ui(*res, 2, MPFR_RNDN);
return res;
}
/* else... */
s = ADD_UI_SAFE(tprime, 2) - guard_bits;
mpfr_init2(absx, mpfr_get_prec(x));
ASSERT(mpfr_abs(absx, x, MPFR_RNDN)==0);
R = mp_erfc3(absx, s);
mpfr_clear(absx);
res = malloc(sizeof(mpfr_t)); ASSERT(res != NULL);
mpfr_init2(*res, ADD_UI_SAFE(tprime, 3));
mpfr_ui_sub(*res, 2, *R, MPFR_RNDN);
mpfr_clear(*R);
free(R);
return res;
}
/* else method==1 or method==2 */
if (E<=0) {
if (tprime + 1 <= (unsigned)(-E)) {
res = malloc(sizeof(mpfr_t)); ASSERT(res != NULL);
mpfr_init2(*res, tprime);
mpfr_set_ui(*res, 1, MPFR_RNDN);
return res;
}
/* else... */
s = ADD_UI_SAFE(tprime, 2)+E;
}
else s = ADD_UI_SAFE(tprime, 1);
mpfr_init2(absx, mpfr_get_prec(x));
ASSERT(mpfr_abs(absx, x, MPFR_RNDN)==0);
if (method == 1) R = mp_erf1(absx, s);
else R = mp_erf2(absx, s);
mpfr_clear(absx);
res = malloc(sizeof(mpfr_t)); ASSERT(res != NULL);
mpfr_init2(*res, ADD_UI_SAFE(tprime, 3));
mpfr_add_ui(*res, *R, 1, MPFR_RNDN);
mpfr_clear(*R);
free(R);
return res;
}
/* Wrapper for computing erf(x) for any value x */
mpfr_t *mp_erf(mpfr_t x, mpfr_prec_t tprime) {
mpfr_t *res;
int method;
if(mpfr_nan_p(x)) {
res = malloc(sizeof(mpfr_t)); ASSERT(res != NULL);
mpfr_init2(*res, tprime);
mpfr_set_nan(*res);
return res;
}
if(mpfr_zero_p(x)) {
res = malloc(sizeof(mpfr_t)); ASSERT(res != NULL);
mpfr_init2(*res, tprime);
mpfr_set(*res, x, MPFR_RNDN);
return res;
}
if(mpfr_inf_p(x)) {
res = malloc(sizeof(mpfr_t)); ASSERT(res != NULL);
mpfr_init2(*res, tprime);
if (mpfr_sgn(x)>0) mpfr_set_si(*res, 1, MPFR_RNDN);
else mpfr_set_si(*res, -1, MPFR_RNDN);
return res;
}
method = choose_method(x, tprime);
if (mpfr_sgn(x)>0) {
res = mp_erf_xpos(x, tprime, method);
if (res == NULL) res = mp_erf_xpos(x, tprime, 2);
}
else {
res = mp_erf_xneg(x, tprime, method);
if (res == NULL) res = mp_erf_xneg(x, tprime, 2);
}
return res;
}
/* Wrapper for computing erf(x) for any value x */
mpfr_t *mp_erfc(mpfr_t x, mpfr_prec_t tprime) {
mpfr_t *res;
int method;
mpfr_t tmp;
mpfr_prec_t s;
if(mpfr_nan_p(x)) {
res = malloc(sizeof(mpfr_t)); ASSERT(res != NULL);
mpfr_init2(*res, tprime);
mpfr_set_nan(*res);
return res;
}
if(mpfr_zero_p(x)) {
res = malloc(sizeof(mpfr_t)); ASSERT(res != NULL);
mpfr_init2(*res, tprime);
mpfr_set_ui(*res, 1, MPFR_RNDN);
return res;
}
if(mpfr_inf_p(x)) {
res = malloc(sizeof(mpfr_t)); ASSERT(res != NULL);
mpfr_init2(*res, tprime);
if (mpfr_sgn(x)>0) mpfr_set_ui(*res, 0, MPFR_RNDN);
else mpfr_set_ui(*res, 2, MPFR_RNDN);
return res;
}
if (mpfr_sgn(x)<= 0) method = choose_method(x, tprime);
else {
mpfr_init2(tmp, SMALL_PRECISION);
mpfr_set(tmp, x, MPFR_RNDU);
mpfr_sqr(tmp, tmp, MPFR_RNDU);
mpfr_my_mul_d(tmp, tmp, LOG2ESUP, MPFR_RNDU);
if (!mpfr_fits_ulong_p(tmp, MPFR_RNDU)) method = 3;
else {
s = mpfr_get_ui(tmp, MPFR_RNDU);
if (mpfr_get_exp(x)>=0) {
s = ADD_UI_SAFE(s, (unsigned)mpfr_get_exp(x));
s = ADD_UI_SAFE(s, tprime);
method = choose_method(x, s);
}
else if (s <= 1 + (unsigned)(-mpfr_get_exp(x))) method = 1;
else {
s = ADD_UI_SAFE(s+mpfr_get_exp(x), tprime);
method = choose_method(x, s);
}
}
mpfr_clear(tmp);
}
if (mpfr_sgn(x)>0) {
res = mp_erfc_xpos(x, tprime, method);
if (res == NULL) res = mp_erfc_xpos(x, tprime, 2);
}
else {
res = mp_erfc_xneg(x, tprime, method);
if (res == NULL) res = mp_erfc_xneg(x, tprime, 2);
}
return res;
}
/* Given y such that |y-erf(x)| < 2^(-prec)*|erf(x)|, determine if it is */
/* possible to round it to precision target_prec=mpfr_get_prec(res) in */
/* the direction rnd. If rounding is possible, set the correctly rounded */
/* value in res, the corresponding ternary MPFR-like value in r and */
/* returns 1. Returns 0, leaving res and r unchanged otherwise. */
/* */
/* Method used: */
/* First, if y<0, we remark that RU(y) = -RD(|y|), RD(y) = -RU(|y|) and */
/* for other roundings R, R(y) = -R(|y|). So we can consider |y| and */
/* deduce if y rounds correctly. */
/* */
/* |y-erf(x)| < 2^(-prec)*|erf(x)| (1) */
/* => | |y| - |erf(x)| | < 2^(-prec)*|erf(x)| */
/* */
/* Moreover (1) implies that */
/* |erf(x)| < (1 - 2^(-prec))^(-1) * |y| (2) */
/* So in particular, |erf(x)| < 2|y| < 2^(EXP(y)+1) */
/* */
/* In conclusion, */
/* |erf(x)| in [|y|-2^(EXP(y)-prec+1), |y|+2^(EXP(y)-prec+1)] */
/* Moreover, we know that |erf(x)|<1. */
int can_round_erf(mpfr_t y, mpfr_prec_t prec,
mpfr_t res, int *r, mpfr_rnd_t rnd) {
mpfr_t yabs;
mpfr_t inf, sup;
mpfr_rnd_t rnd2;
int ternary_inf, ternary_sup;
int test;
mpfr_init2(yabs, mpfr_get_prec(y));
ASSERT (mpfr_abs(yabs, y, MPFR_RNDN) == 0);
if (mpfr_cmp_ui(y, 0)<=0) {
if (rnd==MPFR_RNDU) rnd2 = MPFR_RNDD;
else if (rnd==MPFR_RNDD) rnd2 = MPFR_RNDU;
else rnd2 = rnd;
}
else rnd2 = rnd;
mpfr_init2(inf, mpfr_get_prec(res));
mpfr_init2(sup, mpfr_get_prec(res));
mpfr_set_ui(inf, 1, MPFR_RNDU);
mpfr_mul_2si(inf, inf, mpfr_get_exp(y)+1-(signed)prec, MPFR_RNDU);
ternary_inf = mpfr_sub(inf, yabs, inf, rnd2);
mpfr_set_ui(sup, 1, MPFR_RNDU);
mpfr_mul_2si(sup, sup, mpfr_get_exp(y)+1-(signed)prec, MPFR_RNDU);
ternary_sup = mpfr_add(sup, yabs, sup, rnd2);
/* We take into account the fact that |erf(x)| < 1 */
if (mpfr_cmp_ui(sup, 1) >= 0) {
if ( (rnd2==MPFR_RNDD) || (rnd2==MPFR_RNDZ) ) {
mpfr_set_ui(sup, 1, MPFR_RNDN); mpfr_nextbelow(sup);
ternary_sup = -1;
}
else {
mpfr_set_ui(sup, 1, MPFR_RNDN); ternary_sup = 1;
}
}
if (mpfr_equal_p(inf, sup) && (ternary_inf == ternary_sup)) {
test = 1;
ASSERT (mpfr_set(res, inf, MPFR_RNDN) == 0);
if (mpfr_cmp_ui(y,0)<=0) {
mpfr_neg(res, res, MPFR_RNDN);
*r = -ternary_inf;
}
else *r = ternary_inf;
}
else test = 0;
mpfr_clear(inf);
mpfr_clear(sup);
mpfr_clear(yabs);
return test;
}
/* Same semantic and strategy as for can_round_erf */
int can_round_erfc(mpfr_t y, mpfr_prec_t prec,
mpfr_t res, int *r, mpfr_rnd_t rnd) {
mpfr_t inf, sup;
int ternary_inf, ternary_sup;
int test;
mpfr_init2(inf, mpfr_get_prec(res));
mpfr_init2(sup, mpfr_get_prec(res));
mpfr_set_ui(inf, 1, MPFR_RNDU);
mpfr_mul_2si(inf, inf, mpfr_get_exp(y)+1-(signed)prec, MPFR_RNDU);
ternary_inf = mpfr_sub(inf, y, inf, rnd);
mpfr_set_ui(sup, 1, MPFR_RNDU);
mpfr_mul_2si(sup, sup, mpfr_get_exp(y)+1-(signed)prec, MPFR_RNDU);
ternary_sup = mpfr_add(sup, y, sup, rnd);
/* We take into account the fact that erfc(x) < 2 */
if (mpfr_cmp_ui(sup, 2) >= 0) {
if ( (rnd==MPFR_RNDD) || (rnd==MPFR_RNDZ) ) {
mpfr_set_ui(sup, 2, MPFR_RNDN); mpfr_nextbelow(sup);
ternary_sup = -1;
}
else {
mpfr_set_ui(sup, 2, MPFR_RNDN); ternary_sup = 1;
}
}
if (mpfr_equal_p(inf, sup) && (ternary_inf == ternary_sup)) {
ASSERT (mpfr_set(res, inf, MPFR_RNDN) == 0);
*r = ternary_inf;
test = 1;
}
else test = 0;
mpfr_clear(inf);
mpfr_clear(sup);
return test;
}
/* A wrapper computing the value of erf(x), correctly rounded, in the */
/* direction rnd. */
int cr_erf(mpfr_t res, mpfr_t x, mpfr_rnd_t rnd) {
mpfr_t *tmp;
mpfr_prec_t prec;
int i = 0;
int method;
int ternary = 2;
if(mpfr_nan_p(x)) { mpfr_set_nan(res); return 0;}
if(mpfr_zero_p(x)) return mpfr_set(res, x, MPFR_RNDN);
if(mpfr_inf_p(x)) return mpfr_set_si(res, (mpfr_sgn(x)>0)?1:-1, MPFR_RNDN);
/* We begin with 12 guard bits */
prec = mpfr_get_prec(res) + 12;
/* ZIV loop */
for (;;) {
i++;
method = choose_method(x, prec);
if (mpfr_sgn(x)>0) {
tmp = mp_erf_xpos(x, prec, method);
if (tmp == NULL) tmp = mp_erf_xpos(x, prec, 2);
}
else {
tmp = mp_erf_xneg(x, prec, method);
if (tmp == NULL) tmp = mp_erf_xneg(x, prec, 2);
}
if (can_round_erf(*tmp, prec, res, &ternary, rnd)) break;
if (i==1) prec += 64; else prec *= 2;
} /* End of ZIV loop */
mpfr_clear(*tmp);
free(tmp);
return ternary;
}
/* A wrapper computing the value of erfc(x), correctly rounded, in the */
/* direction rnd. */
int cr_erfc(mpfr_t res, mpfr_t x, mpfr_rnd_t rnd) {
mpfr_t *tmp;
mpfr_prec_t prec;
int i = 0;
int method;
int ternary = 2;
if(mpfr_nan_p(x)) { mpfr_set_nan(res); return 0; }
if(mpfr_zero_p(x)) return mpfr_set_ui(res, 1, MPFR_RNDN);
if(mpfr_inf_p(x)) {
if (mpfr_sgn(x)>0) return mpfr_set_ui(res, 0, MPFR_RNDU);
else return mpfr_set_ui(res, 2, MPFR_RNDN);
}
/* We begin with 12 guard bits */
prec = mpfr_get_prec(res) + 12;
/* ZIV loop */
for (;;) {
i++;
method = choose_method(x, prec);
if (mpfr_sgn(x)>0) {
tmp = mp_erfc_xpos(x, prec, method);
if (tmp == NULL) tmp = mp_erfc_xpos(x, prec, 2);
}
else {
tmp = mp_erfc_xneg(x, prec, method);
if (tmp == NULL) tmp = mp_erfc_xneg(x, prec, 2);
}
if (can_round_erfc(*tmp, prec, res, &ternary, rnd)) break;
if (i==1) prec += 64; else prec *= 2;
} /* End of ZIV loop */
mpfr_clear(*tmp);
free(tmp);
return ternary;
}