static void
check_cache (void)
{
mpfr_t x;
int i;
mpfr_init2 (x, 195);
mpfr_free_cache ();
i = mpfr_const_log2 (x, MPFR_RNDN);
if (i == 0)
{
printf("Error for log2. Invalid ternary value (1).\n");
exit (1);
}
mpfr_set_prec (x, 194);
i = mpfr_const_log2 (x, MPFR_RNDN);
if (i == 0)
{
printf("Error for log2. Invalid ternary value (2).\n");
exit (1);
}
mpfr_free_cache ();
mpfr_set_prec (x, 9);
mpfr_const_log2 (x, MPFR_RNDN);
mpfr_set_prec (x, 8);
mpfr_const_log2 (x, MPFR_RNDN);
if (mpfr_cmp_str (x, "0.10110001E0", 2, MPFR_RNDN))
{
printf("Error for log2. Wrong rounding.\n");
exit (1);
}
mpfr_clear (x);
}
static void
bug20091030 (void)
{
mpfr_t x, x_ref;
int inex, inex_ref;
mpfr_prec_t p;
int r;
mpfr_free_cache ();
mpfr_init2 (x, MPFR_PREC_MIN);
for (p = MPFR_PREC_MIN; p <= 100; p++)
{
mpfr_set_prec (x, p);
inex = mpfr_const_pi (x, MPFR_RNDU);
if (inex < 0)
{
printf ("Error, inex < 0 for RNDU (prec=%lu)\n",
(unsigned long) p);
exit (1);
}
inex = mpfr_const_pi (x, MPFR_RNDD);
if (inex > 0)
{
printf ("Error, inex > 0 for RNDD (prec=%lu)\n",
(unsigned long) p);
exit (1);
}
}
mpfr_free_cache ();
mpfr_init2 (x_ref, MPFR_PREC_MIN);
for (p = MPFR_PREC_MIN; p <= 100; p++)
{
mpfr_set_prec (x, p + 10);
mpfr_const_pi (x, MPFR_RNDN);
mpfr_set_prec (x, p);
mpfr_set_prec (x_ref, p);
for (r = 0; r < MPFR_RND_MAX; r++)
{
inex = mpfr_const_pi (x, (mpfr_rnd_t) r);
inex_ref = mpfr_const_pi_internal (x_ref, (mpfr_rnd_t) r);
if (inex != inex_ref || mpfr_cmp (x, x_ref) != 0)
{
printf ("mpfr_const_pi and mpfr_const_pi_internal disagree\n");
printf ("mpfr_const_pi gives ");
mpfr_dump (x);
printf ("mpfr_const_pi_internal gives ");
mpfr_dump (x_ref);
printf ("inex=%d inex_ref=%d\n", inex, inex_ref);
exit (1);
}
}
}
mpfr_clear (x);
mpfr_clear (x_ref);
}
int main(int argc, char *argv[]) {
const double sigma2 = sqrt(1.0/(2.0*log(2.0)));
unsigned long long t;
cmdline_params_gauss_z_t params;
params.sigma = 2 * sigma2;
params.tau = 6;
params.c = 0;
params.ntrials = 10000000;
params.algorithm = DGS_DISC_GAUSS_UNIFORM_TABLE;
params.precision = MP;
parse_gauss_z_cmdline(¶ms, argc, argv);
if (params.algorithm == DGS_DISC_GAUSS_SIGMA2_LOGTABLE) {
int k = round(params.sigma/sigma2);
params.sigma = k*sigma2;
}
printf("%s :: σ: %.2f, c: %.2f. τ: %ld, precision: %d, algorithm: %d -- ", argv[0],
params.sigma, params.c, params.tau, params.precision, params.algorithm);
run(params.sigma, params.c, params.tau, params.precision, params.algorithm, params.ntrials, &t);
double walltime = t/100000.0/params.ntrials*(1000.0*1000.0); // μs
printf("wall time: %8.3f μs per call (rate: %8.3f per second)\n", walltime, 1000.0*1000.0/walltime);
mpfr_free_cache();
return 0;
}
int main(int argc, char *argv[]) {
cmdline_params_t params;
parse_cmdline(params, argc, argv, "GGHLite Instance Generator", NULL);
print_header("GGHLite Instance Generator", params);
aes_randstate_t randstate;
aes_randinit_seed(randstate, params->shaseed, NULL);
gghlite_sk_t self;
gghlite_params_init(self->params, params->lambda, params->kappa, params->rerand, params->flags);
gghlite_params_print(self->params);
printf("\n---\n");
gghlite_sk_init(self, randstate);
printf("\n---\n");
gghlite_sk_print_norms(self);
printf("\n---\n");
gghlite_sk_print_times(self);
gghlite_sk_clear(self, 1);
aes_randclear(randstate);
flint_cleanup();
mpfr_free_cache();
}
void ThreadCleanup(void *arg)
{
(void)arg;
#ifdef LIBHVL_USE_MPFR
mpfr_free_cache();
#endif // LIBHVL_USE_MPFR
}
SEXP print_mpfr(SEXP x, SEXP digits)
{
SEXP D = GET_SLOT(x, Rmpfr_Data_Sym);/* an R list() of length n */
int n = length(D), i;
mpfr_t r;
Rboolean use_x_digits = INTEGER(digits)[0] == NA_INTEGER;
/* #if MPFR_VERSION >= MPFR_VERSION_NUM(2,4,0) */
/* char buf[R_BUFSIZE], *p = buf; */
/* #endif */
mpfr_init(r); /* with default precision */
for(i=0; i < n; i++) {
R_asMPFR(VECTOR_ELT(D, i), r);
/* #if MPFR_VERSION >= MPFR_VERSION_NUM(2,4,0) */
/* Rprintf */
/* #else /\* requires R_Outputfile from R's Interfaces.h ___Unix-alike only__ *\/ */
mpfr_out_str (R_Outputfile, 10, use_x_digits ? 0 : asInteger(digits),
r, MPFR_RNDD);
/* #endif */
Rprintf("\n");
}
mpfr_clear (r);
mpfr_free_cache(); /* <- Manual 4.8 "Memory Handling" strongly advises ...*/
return x;
}
SEXP R_mpfr_fac (SEXP n_, SEXP prec, SEXP rnd_mode)
{
int n = length(n_), i, *nn;
SEXP n_t, val = PROTECT(allocVector(VECSXP, n)); int nprot = 1;
mpfr_rnd_t rnd = R_rnd2MP(rnd_mode);
mpfr_t r_i;
if(TYPEOF(n_) != INTSXP) {
PROTECT(n_t = coerceVector(n_, INTSXP)); nprot++;/* or bail out*/
nn = INTEGER(n_t);
} else {
nn = INTEGER(n_);
}
int i_p = asInteger(prec);
R_mpfr_check_prec(i_p);
mpfr_init2(r_i, i_p);
for(i=0; i < n; i++) {
// never happens when called from R:
if(nn[i] < 0) error("R_mpfr_fac(%d): negative n.", nn[i]);
mpfr_fac_ui(r_i, nn[i], rnd);
SET_VECTOR_ELT(val, i, MPFR_as_R(r_i));
}
mpfr_clear(r_i);
mpfr_free_cache();
UNPROTECT(nprot);
return val;
}
int coords_calculate_precision(coords* c)
{
int l, p;
mpfr_t tmp;
mpfr_t bail;
mpfr_t px_size;
mpfr_t precision;
mpfr_init2(tmp, c->precision);
mpfr_init2(bail, c->precision);
mpfr_init2(px_size, c->precision);
mpfr_init2(precision, c->precision);
mpfr_set_d( bail, 4.0, GMP_RNDN);
mpfr_div_si(px_size, c->width, c->img_width, GMP_RNDN);
mpfr_div( tmp, bail, px_size, GMP_RNDN);
l = mpfr_log2( precision, tmp, GMP_RNDN);
p = (int)mpfr_get_si( precision, GMP_RNDN);
if (l < 0) /* precision was rounded down */
++p;
c->recommend = p;
mpfr_clear(tmp);
mpfr_clear(bail);
mpfr_clear(px_size);
mpfr_clear(precision);
mpfr_free_cache(); /* <-- keep valgrind happy over mpfr_log2 */
return c->recommend;
}
void *WorkerFunc(void *arg)
#endif // LIBHVL_THREADING_
{
const ThreadParams *tp = static_cast<const ThreadParams *>(arg);
double x = tp->from;
HVL_Pair *buf = tp->buffer;
CheckPrecision(tp->ctx);
#ifdef LIBHVL_THREADING_PTHREAD
pthread_cleanup_push(ThreadCleanup, nullptr);
#endif // LIBHVL_THREADING_PTHREAD
for (size_t iter = 0; iter < tp->iters; iter++) {
double r = tp->calcfun(tp->ctx, x, tp->a0, tp->a1, tp->a2, tp->a3);
buf->x = x;
buf->y = r;
buf++;
x += tp->step;
#ifdef LIBHVL_THREADING_PTHREAD
pthread_testcancel();
#endif // LIBHVL_THREADING_PTHREAD
}
#ifdef LIBHVL_USE_MPFR
mpfr_free_cache();
#endif // LIBHVL_USE_MPFR
#ifdef LIBHVL_THREADING_PTHREAD
pthread_cleanup_pop(0);
#endif // LIBHVL_THREADING_PTHREAD
return 0;
}
int main(void)
{
flint_rand_t state;
fmpz_t p;
fmpz * v;
long i;
printf("number_of_partitions....");
fflush(stdout);
flint_randinit(state);
fmpz_init(p);
v = _fmpz_vec_init(3000);
number_of_partitions_vec(v, 3000);
for (i = 0; i < 3000; i++)
{
number_of_partitions(p, i);
if (!fmpz_equal(p, v + i))
{
printf("FAIL:\n");
printf("p(%ld) does not agree with power series\n", i);
printf("Computed p(%ld): ", i); fmpz_print(p); printf("\n");
printf("Expected: "); fmpz_print(v + i); printf("\n");
abort();
}
}
_fmpz_vec_clear(v, 3000);
for (i = 0; testdata[i][0] != 0; i++)
{
number_of_partitions(p, testdata[i][0]);
if (fmpz_fdiv_ui(p, 1000000000) != testdata[i][1])
{
printf("FAIL:\n");
printf("p(%ld) does not agree with known value mod 10^9\n",
testdata[i][0]);
printf("Computed: %lu\n", fmpz_fdiv_ui(p, 1000000000));
printf("Expected: %lu\n", testdata[i][1]);
abort();
}
}
fmpz_clear(p);
flint_randclear(state);
mpfr_free_cache();
_fmpz_cleanup();
printf("PASS\n");
return 0;
}
int
main(void)
{
int i, result;
flint_rand_t state;
printf("dlog....");
fflush(stdout);
flint_randinit(state);
for (i = 0; i < 10000; i++)
{
fmpz_t x;
mpz_t z;
mpfr_t r;
double y, w;
fmpz_init(x);
mpz_init(z);
mpfr_init2(r, 53);
fmpz_randtest_not_zero(x, state, 10000);
fmpz_abs(x, x);
y = fmpz_dlog(x);
fmpz_get_mpz(z, x);
mpfr_set_z(r, z, MPFR_RNDN);
mpfr_log(r, r, MPFR_RNDN);
w = mpfr_get_d(r, MPFR_RNDN);
result = (FLINT_ABS(y - w) <= w * 1e-13);
if (!result)
{
printf("FAIL:\n");
printf("x = "), fmpz_print(x), printf("\n");
printf("y = %.20g\n", y);
printf("w = %.20g\n", w);
abort();
}
fmpz_clear(x);
mpz_clear(z);
mpfr_clear(r);
}
mpfr_free_cache();
flint_randclear(state);
_fmpz_cleanup();
printf("PASS\n");
return EXIT_SUCCESS;
}
static int compute_min_prec(double &rho, int d, double delta, double eta, double epsilon,
MinPrecAlgo algo)
{
int old_prec = Float::set_prec(53);
Float f_minprec, f_rho, f_d, f_eta, f_delta, f_epsilon, tmp1, tmp2;
// These four conversions are exact
f_d = static_cast<double>(d);
f_eta = eta;
f_delta = delta;
f_epsilon = epsilon;
if (algo == MINPREC_L2)
{
// eta - 0.5 is an exact fp operation
if (f_epsilon > eta - 0.5)
f_epsilon = eta - 0.5;
tmp1 = 1.0;
tmp1.sub(tmp1, f_delta, GMP_RNDD);
if (f_epsilon > tmp1)
f_epsilon = tmp1;
// now fEpsilon <= min(epsilon, eta - 0.5, 1 - delta);
}
// Computes tmp1 >= (1 + eta) ^ 2 + epsilon
tmp1 = 1.0; // exact
tmp1.add(f_eta, tmp1, GMP_RNDU); // >= 1 + eta
tmp1.mul(tmp1, tmp1, GMP_RNDU); // >= (1 + eta) ^ 2
tmp1.add(tmp1, f_epsilon, GMP_RNDU);
// Computes tmp2 <= delta - eta ^ 2
tmp2.mul(f_eta, f_eta, GMP_RNDU);
tmp2.sub(f_delta, tmp2, GMP_RNDD);
FPLLL_CHECK(tmp2 > 0, "invalid LLL parameters, eta must be < sqrt(delta)");
// Computes rho >= ((1 + eta) ^ 2 + epsilon) / (delta - eta ^ 2)
f_rho.div(tmp1, tmp2, GMP_RNDU);
rho = f_rho.get_d(GMP_RNDU);
/* Computes minprec >= constant + 2 * log2(d) - log2(epsilon) + d * log2(rho)
(constant = 5 for GSO, 10 for LLL) */
tmp1.log(f_d, GMP_RNDU); // >= log(d)
tmp1.mul_2si(tmp1, 1); // >= 2 * log(d)
tmp2.log(f_epsilon, GMP_RNDD); // <= log(epsilon) (<= 0)
tmp1.sub(tmp1, tmp2, GMP_RNDU); // >= 2 * log(d) - log(epsilon)
tmp2.log(f_rho, GMP_RNDU); // >= log(rho)
tmp2.mul(f_d, tmp2, GMP_RNDU); // >= d * log(rho)
tmp1.add(tmp1, tmp2, GMP_RNDU); // >= 2*log(d)-log(epsilon)+d*log(rho)
tmp2 = 2.0; // exact
tmp2.log(tmp2, GMP_RNDD); // <= log(2)
tmp1.div(tmp1, tmp2, GMP_RNDU); // >= 2*log2(d)-log2(epsilon)+d*log2(rho)
tmp2 = (algo == MINPREC_L2) ? 10.0 : 5.0;
f_minprec.add(tmp1, tmp2, GMP_RNDU);
int minprec = static_cast<int>(ceil(f_minprec.get_d(GMP_RNDU)));
mpfr_free_cache();
Float::set_prec(old_prec);
return minprec;
}
int main()
{
fmpz * num1;
fmpz * den1;
fmpz_t num2;
fmpz_t den2;
long n, N;
printf("bernoulli_number....");
fflush(stdout);
N = 4000;
num1 = _fmpz_vec_init(N);
den1 = _fmpz_vec_init(N);
fmpz_init(num2);
fmpz_init(den2);
_bernoulli_number_vec_multi_mod(num1, den1, N);
for (n = 0; n < N; n++)
{
bernoulli_number(num2, den2, n);
if (!fmpz_equal(num1 + n, num2))
{
printf("FAIL: n = %ld, numerator\n", n);
printf("vec: "); fmpz_print(num1 + n); printf("\n");
printf("single: "); fmpz_print(num2); printf("\n");
abort();
}
if (!fmpz_equal(den1 + n, den2))
{
printf("FAIL: n = %ld, denominator\n", n);
printf("vec: "); fmpz_print(den1 + n); printf("\n");
printf("single: "); fmpz_print(den2); printf("\n");
abort();
}
}
_fmpz_vec_clear(num1, N);
_fmpz_vec_clear(den1, N);
fmpz_clear(num2);
fmpz_clear(den2);
mpfr_free_cache();
_fmpz_cleanup();
printf("PASS\n");
return 0;
}
int main(int argc, char* const argv[])
{
int result = Catch::Session().run( argc, argv );
#if defined(HAVE_SYMENGINE_MPFR)
mpfr_free_cache();
#endif // HAVE_SYMENGINE_MPFR
#if defined(HAVE_SYMENGINE_ARB)
flint_cleanup();
#endif // HAVE_SYMENGINE_ARB
return result;
}
int main(int argc, char *argv[]) {
cmdline_params_t params;
const char *name = "GGHLite Parameters";
parse_cmdline(params, argc, argv, name, NULL);
print_header(name, params);
gghlite_sk_t self;
gghlite_params_init(self->params, params->lambda, params->kappa, params->rerand, params->flags);
gghlite_params_print(self->params);
gghlite_sk_clear(self, 1);
flint_cleanup();
mpfr_free_cache();
}
int main()
{
unsigned long long base_counts[] = { 5, 5, 5, 5 };
unsigned long long window = 20;
double val = 0.0;
val = cwf(base_counts, window);
printf("%f\n", val);
val = ce(base_counts, window);
printf("%f\n", val);
mpfr_free_cache();
return 0;
}
APLVFP PrimFnMonQuoteDotVisV
(APLVFP aplVfpRht,
LPPRIMSPEC lpPrimSpec)
{
APLMPI mpzRes = {0};
APLVFP mpfRes = {0};
// Check for indeterminates: !N for integer N < 0
if (mpfr_integer_p (&aplVfpRht)
&& mpfr_cmp_ui (&aplVfpRht, 0) < 0)
return *mpfr_QuadICValue (&aplVfpRht, // No left arg
ICNDX_QDOTn,
&aplVfpRht,
&mpfRes,
FALSE);
// Check for PosInfinity
if (IsMpfPosInfinity (&aplVfpRht))
return mpfPosInfinity;
// If the arg is an integer,
// and it fits in a ULONG, ...
if (mpfr_integer_p (&aplVfpRht)
&& mpfr_fits_uint_p (&aplVfpRht, MPFR_RNDN))
{
mpz_init (&mpzRes);
mpfr_init0 (&mpfRes);
mpz_fac_ui (&mpzRes, mpfr_get_ui (&aplVfpRht, MPFR_RNDN));
mpfr_set_z (&mpfRes, &mpzRes, MPFR_RNDN);
Myz_clear (&mpzRes);
} else
{
// Initialize the result
mpfr_init_set (&mpfRes, &aplVfpRht, MPFR_RNDN);
mpfr_add_ui (&mpfRes, &mpfRes, 1, MPFR_RNDN);
// Let MPFR handle it
mpfr_gamma (&mpfRes, &mpfRes, MPFR_RNDN);
#ifdef DEBUG
mpfr_free_cache ();
#endif
} // End IF/ELSE
return mpfRes;
} // End PrimFnMonQuoteDotVisV
int main(void)
{
long k;
flint_rand_t state;
printf("zeta_ui_bsplit....");
fflush(stdout);
flint_randinit(state);
for (k = 0; k < 100; k++)
{
long prec, n;
mpfr_t x, y;
n = 2 + n_randint(state, 20);
prec = 2 + n_randint(state, 10000);
mpfr_init2(x, prec);
mpfr_init2(y, prec);
mpfr_zeta_ui(x, n, MPFR_RNDN);
mpfr_zeta_ui_bsplit(y, n, MPFR_RNDN);
if (!mpfr_equal_p(x, y))
{
printf("FAIL:\n");
printf("Wrong value at n = %ld, prec = %ld\n", n, prec);
printf("x:\n");
mpfr_out_str(stdout, 10, 0, x, MPFR_RNDN);
printf("\n");
printf("x:\n");
mpfr_out_str(stdout, 10, 0, y, MPFR_RNDN);
printf("\n");
abort();
}
mpfr_clear(x);
mpfr_clear(y);
}
flint_randclear(state);
mpfr_free_cache();
_fmpz_cleanup();
printf("PASS\n");
return 0;
}
/* Convert R "mpfr" object (list of "mpfr1") to R "double" vector : */
SEXP mpfr2d(SEXP x, SEXP rnd_mode) {
int n = length(x), i;
SEXP val = PROTECT(allocVector(REALSXP, n));
double *r = REAL(val);
mpfr_t R_i;
mpfr_init(R_i); /* with default precision */
for(i=0; i < n; i++) {
R_asMPFR(VECTOR_ELT(x, i), R_i);
r[i] = mpfr_get_d(R_i, R_rnd2MP(rnd_mode));
}
mpfr_clear (R_i);
mpfr_free_cache();
UNPROTECT(1);
return val;
}
int main(void)
{
struct number n;
char *input, buffer[256];
rl_bind_key('\t', rl_complete);
while (1) {
snprintf(buffer, sizeof(buffer), "> ");
input = readline(buffer);
if (!input || !strcmp(input, "exit"))
break;
add_history(input);
calculate(input, &n);
// snprintf(buffer, sizeof(buffer), "%%.%ldRf\n", mpfr_get_prec(n.num));
mpfr_printf("%RNf\n", n.num);
mpfr_clear(n.num);
mpfr_free_cache();
free(input);
}
return 0;
}
SEXP print_mpfr1(SEXP x, SEXP digits)
{
mpfr_t r;
Rboolean use_x_digits = INTEGER(digits)[0] == NA_INTEGER;
mpfr_init2(r, R_mpfr_prec(x));
R_asMPFR(x, r);
/* Rprintf(" * [dbg] after R_asMPFR() ..\n"); */
mpfr_out_str (R_Outputfile, 10,
use_x_digits ? 0 : asInteger(digits),
r, MPFR_RNDD);
/* prints the value of s in base 10, rounded towards -Inf, where the third
argument 0 means that the number of printed digits is automatically
chosen from the precision of s; */
Rprintf("\n");
mpfr_clear (r);
mpfr_free_cache(); /* <- Manual 4.8 "Memory Handling" strongly advises ...*/
return x;
}
void
tests_end_mpfr (void)
{
int err = 0;
if (mpfr_get_emin () != default_emin)
{
printf ("Default emin value has not been restored!\n");
err = 1;
}
if (mpfr_get_emax () != default_emax)
{
printf ("Default emax value has not been restored!\n");
err = 1;
}
mpfr_free_cache ();
mpfr_free_cache2 (MPFR_FREE_GLOBAL_CACHE);
tests_rand_end ();
#ifndef MPFR_USE_MINI_GMP
tests_memory_end ();
#endif
#ifdef MPFR_TESTS_DIVBYZERO
/* Define to test the use of MPFR_ERRDIVZERO */
if (fetestexcept (FE_DIVBYZERO|FE_INVALID))
{
printf ("A floating-point division by 0 or an invalid operation"
" occurred!\n");
#ifdef MPFR_ERRDIVZERO
/* This should never occur because the purpose of defining
MPFR_ERRDIVZERO is to avoid all the FP divisions by 0. */
err = 1;
#endif
}
#endif
if (err)
exit (err);
}
/**
* Debug statements will be used if the -d option is used.
*/
int main(int argc, char** argv) {
if (argc > 1 && strcmp(argv[1], "-d") == 0) {
aks_debug = 1;
}
mpz_t n;
mpz_init(n);
while (!feof(stdin)) {
gmp_scanf("%Zd", &n);
if(feof(stdin)) {
break;
}
int prime = aks_is_prime(n);
gmp_printf("%d\n", prime);
}
mpz_clear(n);
mpfr_free_cache();
return 0;
}
SEXP d2mpfr1_(double x, int i_prec, mpfr_rnd_t rnd)
{
mpfr_t r;
int nr_limbs = N_LIMBS(i_prec), i;
R_mpfr_check_prec(i_prec);
R_mpfr_MPFR_2R_init(val);
mpfr_init2 (r, (mpfr_prec_t)i_prec);
mpfr_set_d (r, x, rnd);
R_mpfr_MPFR_2R_fill;
/* free space used by the MPFR variables */
mpfr_clear (r);
mpfr_free_cache(); /* <- Manual 4.8 "Memory Handling" strongly advises ...*/
UNPROTECT(1);
return val;
}/* d2mpfr1_ */
int
main (void)
{
FILE *output;
struct speed_params2D param;
double (*speed_funcs[3]) (struct speed_params *s);
/* char filename[256] = "virtual_timing_ai.dat"; */
/* speed_funcs[0] = virtual_timing_ai1; */
/* speed_funcs[1] = virtual_timing_ai2; */
char filename[256] = "airy.dat";
speed_funcs[0] = timing_ai1;
speed_funcs[1] = timing_ai2;
speed_funcs[2] = NULL;
output = fopen (filename, "w");
if (output == NULL)
{
fprintf (stderr, "Can't open file '%s' for writing.\n", filename);
abort ();
}
param.min_x = -80;
param.max_x = 60;
param.min_prec = 50;
param.max_prec = 1500;
param.nb_points_x = 200;
param.nb_points_prec = 200;
param.logarithmic_scale_x = 0;
param.logarithmic_scale_prec = 0;
param.speed_funcs = speed_funcs;
generate_2D_sample (output, param);
fclose (output);
mpfr_free_cache ();
return 0;
}
/* Convert R "mpfr" object (list of "mpfr1") to R "integer" vector : */
SEXP mpfr2i(SEXP x, SEXP rnd_mode) {
int n = length(x), i;
SEXP val = PROTECT(allocVector(INTSXP, n));
int *r = INTEGER(val);
mpfr_t R_i;
mpfr_init(R_i); /* with default precision */
for(i=0; i < n; i++) {
R_asMPFR(VECTOR_ELT(x, i), R_i);
if(!mpfr_fits_sint_p(R_i, R_rnd2MP(rnd_mode))) {
warning("NAs introduced by coercion from \"mpfr\" [%d]", i+1);
r[i] = NA_INTEGER;
}
else {
long lr = mpfr_get_si(R_i, R_rnd2MP(rnd_mode));
r[i] = (int) lr;
}
}
mpfr_clear (R_i);
mpfr_free_cache();
UNPROTECT(1);
return val;
}
/* From the MPFR (2.3.2, 2008) doc :
-- Function:
int mpfr_set_str (mpfr_t ROP, const char *S, int BASE, mpfr_rnd_t RND)
Set ROP to the value of the whole string S in base BASE, rounded
in the direction RND. See the documentation of `mpfr_strtofr' for
a detailed description of the valid string formats. This function
returns 0 if the entire string up to the final null character is a
valid number in base BASE; otherwise it returns -1, and ROP may
have changed.
*/
SEXP str2mpfr1_list(SEXP x, SEXP prec, SEXP base, SEXP rnd_mode)
{
/* NB: Both x and prec are "recycled" to the longer one if needed */
int ibase = asInteger(base), *iprec,
nx = LENGTH(x), np = LENGTH(prec),
n = (nx == 0 || np == 0) ? 0 : imax2(nx, np),
nprot = 1;
SEXP val = PROTECT(allocVector(VECSXP, n));
mpfr_rnd_t rnd = R_rnd2MP(rnd_mode);
mpfr_t r_i;
mpfr_init(r_i);
if(!isString(x)) { PROTECT(x = coerceVector(x, STRSXP)); nprot++; }
if(!isInteger(prec)) { PROTECT(prec = coerceVector(prec, INTSXP)); nprot++; }
iprec = INTEGER(prec);
for(int i = 0; i < n; i++) {
int prec_i = iprec[i % np];
R_mpfr_check_prec(prec_i);
mpfr_set_prec(r_i, (mpfr_prec_t) prec_i);
int ierr = mpfr_set_str(r_i, CHAR(STRING_ELT(x, i % nx)), ibase, rnd);
if(ierr) {
if (!strcmp("NA", CHAR(STRING_ELT(x, i % nx))))
mpfr_set_nan(r_i); // "NA" <=> "NaN" (which *are* treated well, by mpfr_set_str)
else
error("str2mpfr1_list(x, *): x[%d] cannot be made into MPFR",
i+1);
}
/* FIXME: become more efficient by doing R_..._2R_init() only once*/
SET_VECTOR_ELT(val, i, MPFR_as_R(r_i));
}
mpfr_clear (r_i);
mpfr_free_cache();
UNPROTECT(nprot);
return val;
}
void sample(void * arg, ulong count)
{
fmpz * num;
fmpz * den;
bernoulli_vec_t * params = (bernoulli_vec_t *) arg;
ulong n = params->n;
long i;
int algorithm = params->algorithm;
num = _fmpz_vec_init(n);
den = _fmpz_vec_init(n);
prof_start();
for (i = 0; i < count; i++)
{
if (algorithm == 0)
{
_bernoulli_number_vec_recursive(num, den, n);
}
else if (algorithm == 1)
{
_bernoulli_number_vec_multi_mod(num, den, n);
}
else if (algorithm == 2)
{
_bernoulli_number_vec_zeta(num, den, n);
mpfr_free_cache();
}
}
prof_stop();
_fmpz_vec_clear(num, n);
_fmpz_vec_clear(den, n);
}
int main(int argc, char *argv[]) {
aes_randstate_t randstate;
aes_randinit(randstate);
int status = 0;
status += test_jigsaw(20, 2, 1, randstate);
status += test_jigsaw(20, 3, 1, randstate);
status += test_jigsaw(20, 4, 1, randstate);
status += test_jigsaw(20, 2, 0, randstate);
status += test_jigsaw(20, 3, 0, randstate);
status += test_jigsaw(20, 4, 0, randstate);
status += test_jigsaw_indices(20, 4, 90, randstate);
status += test_jigsaw_indices(20, 20, 60, randstate);
aes_randclear(randstate);
flint_cleanup();
mpfr_free_cache();
return status;
}
/* Convert R "mpfr" object (list of "mpfr1") to R "character" vector,
* using precision 'prec' which can be NA/NULL in which case
* "full precision" (as long as necessary) is used : */
SEXP mpfr2str(SEXP x, SEXP digits, SEXP base) {
int n = length(x), i;
int n_dig = isNull(digits) ? 0 : asInteger(digits);
int dig_n_max = -1;
SEXP val = PROTECT(allocVector(VECSXP, 4)),
nms, str, exp, fini, zero;
int *i_exp, *is_fin, *is_0;
int B = asInteger(base); // = base for output
double p_fact = (B == 2) ? 1. : log(B) / M_LN2;
char *ch = NULL;
mpfr_t R_i;
if(n_dig < 0)
error("'digits' must be NULL or integer >= 0");
/* be "overprotective" for now ... */
SET_VECTOR_ELT(val, 0, str = PROTECT(allocVector(STRSXP, n)));
SET_VECTOR_ELT(val, 1, exp = PROTECT(allocVector(INTSXP, n)));
SET_VECTOR_ELT(val, 2, fini= PROTECT(allocVector(LGLSXP, n)));
SET_VECTOR_ELT(val, 3, zero= PROTECT(allocVector(LGLSXP, n)));
nms = PROTECT(allocVector(STRSXP, 4));
SET_STRING_ELT(nms, 0, mkChar("str"));
SET_STRING_ELT(nms, 1, mkChar("exp"));
SET_STRING_ELT(nms, 2, mkChar("finite"));
SET_STRING_ELT(nms, 3, mkChar("is.0"));
setAttrib(val, R_NamesSymbol, nms);
i_exp = INTEGER(exp);
is_fin= LOGICAL(fini);
is_0 = LOGICAL(zero);
mpfr_init(R_i); /* with default precision */
for(i=0; i < n; i++) {
mpfr_exp_t exp = (mpfr_exp_t) 0;
mpfr_exp_t *exp_ptr = &exp;
int dig_needed;
R_asMPFR(VECTOR_ELT(x, i), R_i);
#ifdef __Rmpfr_FIRST_TRY_FAILS__
/* Observing memory problems, e.g., see ../tests/00-bug.R.~3~
* Originally hoped it was solvable via R_alloc() etc, but it seems the problem is
* deeper and I currently suspect a problem/bug in MPFR library's mpfr_get_str(..) */
ch = mpfr_get_str(NULL, exp_ptr, B,
(size_t) n_dig, R_i, MPFR_RNDN);
#else
if(n_dig) {/* use it as desired precision */
dig_needed = n_dig;
} else { /* n_dig = 0 --> string will use "enough" digits */
dig_needed = p_fact * (int)R_i->_mpfr_prec;
}
if (i == 0) { /* first time */
dig_n_max = dig_needed;
ch = (char *) R_alloc(dig_needed + 2, sizeof(char));
}
else if(!n_dig && dig_needed > dig_n_max) {
ch = (char *) S_realloc(ch, dig_needed + 2, dig_n_max + 2,
sizeof(char));
dig_n_max = dig_needed;
}
/* char * mpfr_get_str (char *STR, mpfr_exp_t *EXPPTR, int B,
* size_t N, mpfr_t OP, mpfr_rnd_t RND) */
mpfr_get_str(ch, exp_ptr, B,
(size_t) n_dig, R_i, MPFR_RNDN);
#endif
SET_STRING_ELT(str, i, mkChar(ch));
i_exp[i] = (int) exp_ptr[0];
is_fin[i]= mpfr_number_p(R_i);
is_0 [i] = mpfr_zero_p(R_i);
#ifdef __Rmpfr_FIRST_TRY_FAILS__
mpfr_free_str(ch);
#endif
}
mpfr_clear (R_i);
mpfr_free_cache();
UNPROTECT(6);
return val;
}
