int main (void) { mpc_t z; test_start (); test_end (); mpc_init2 (z, 6); mpc_set_ui_ui (z, 17, 42, MPC_RNDNN); mpfr_set_ui (mpc_realref (z), 18, GMP_RNDN); if (mpfr_get_ui (mpc_realref (z), GMP_RNDN) != 18) { fprintf (stderr, "Error in mpfr_set_ui/mpc_realref\n"); exit (1); } mpfr_set_ui (mpc_imagref (z), 43, GMP_RNDN); if (mpfr_get_ui (mpc_imagref (z), GMP_RNDN) != 43) { fprintf (stderr, "Error in mpfr_set_ui/mpc_imagref\n"); exit (1); } mpc_clear (z); return 0; }
real factorial(const real & a) { real x; mpfr_fac_ui(x.r, mpfr_get_ui(a.r, MPFR_RNDZ), MPFR_RNDN); return x; }
static unsigned long eval (mpfr_t x, mpfr_t y, mpfr_t z, mpfr_t t, mpfr_rnd_t rnd) { mpfr_div (t, x, y, rnd); /* the division x/y in precision p */ mpfr_set (z, t, rnd); /* the rounding to the precision n */ mpfr_rint_floor (z, z, rnd); return mpfr_get_ui (z, rnd); }
int main (int argc, char *argv[]) { unsigned long N = atoi (argv[1]), M; mp_prec_t p; mpfr_t i, j; char *lo; mp_exp_t exp_lo; int st, st0; fprintf (stderr, "Using GMP %s and MPFR %s\n", gmp_version, mpfr_version); st = cputime (); mpfr_init (i); mpfr_init (j); M = N; do { M += 10; mpfr_set_prec (i, 32); mpfr_set_d (i, LOG2_10, GMP_RNDU); mpfr_mul_ui (i, i, M, GMP_RNDU); mpfr_add_ui (i, i, 3, GMP_RNDU); p = mpfr_get_ui (i, GMP_RNDU); fprintf (stderr, "Setting precision to %lu\n", p); mpfr_set_prec (j, 2); mpfr_set_prec (i, p); mpfr_set_ui (j, 1, GMP_RNDN); mpfr_exp (i, j, GMP_RNDN); /* i = exp(1) */ mpfr_set_prec (j, p); mpfr_const_pi (j, GMP_RNDN); mpfr_div (i, i, j, GMP_RNDN); mpfr_sqrt (i, i, GMP_RNDN); st0 = cputime (); lo = mpfr_get_str (NULL, &exp_lo, 10, M, i, GMP_RNDN); st0 = cputime () - st0; } while (can_round (lo, N, M) == 0); lo[N] = '\0'; printf ("%s\n", lo); mpfr_clear (i); mpfr_clear (j); fprintf (stderr, "Cputime: %dms (output %dms)\n", cputime () - st, st0); return 0; }
static void check_flags (void) { mpfr_t x; mpfr_exp_t old_emin, old_emax; old_emin = mpfr_get_emin (); old_emax = mpfr_get_emax (); mpfr_init (x); /* Check the functions not the macros ! */ (mpfr_clear_flags)(); mpfr_set_double_range (); mpfr_set_ui (x, 1, MPFR_RNDN); (mpfr_clear_overflow)(); mpfr_mul_2exp (x, x, 1024, MPFR_RNDN); if (!(mpfr_overflow_p)()) ERROR("ERROR: No overflow detected!\n"); (mpfr_clear_underflow)(); mpfr_set_ui (x, 1, MPFR_RNDN); mpfr_div_2exp (x, x, 1025, MPFR_RNDN); if (!(mpfr_underflow_p)()) ERROR("ERROR: No underflow detected!\n"); (mpfr_clear_nanflag)(); MPFR_SET_NAN(x); mpfr_add (x, x, x, MPFR_RNDN); if (!(mpfr_nanflag_p)()) ERROR("ERROR: No NaN flag!\n"); (mpfr_clear_inexflag)(); mpfr_set_ui(x, 2, MPFR_RNDN); mpfr_cos(x, x, MPFR_RNDN); if (!(mpfr_inexflag_p)()) ERROR("ERROR: No inexact flag!\n"); (mpfr_clear_erangeflag) (); mpfr_set_ui (x, 1, MPFR_RNDN); mpfr_mul_2exp (x, x, 1024, MPFR_RNDN); mpfr_get_ui (x, MPFR_RNDN); if (!(mpfr_erangeflag_p)()) ERROR ("ERROR: No erange flag!\n"); mpfr_clear (x); set_emin (old_emin); set_emax (old_emax); }
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
static void test_macros_keyword (void) { mpfr_t x; unsigned long i; mpfr_init2 (x, 64); #define MKN 0x1000000 #define long short mpfr_set_ui (x, MKN, MPFR_RNDN); #undef long i = mpfr_get_ui (x, MPFR_RNDN); if (i != MKN) { printf ("Error in test_macros_keyword: expected 0x%lx, got 0x%lx.\n", (unsigned long) MKN, i); exit (1); } mpfr_clear (x); }
/* returns a lower bound of the number of significant bits of n! (not counting the low zero bits). We know n! >= (n/e)^n*sqrt(2*Pi*n) for n >= 1, and the number of zero bits is floor(n/2) + floor(n/4) + floor(n/8) + ... This approximation is exact for n <= 500000, except for n = 219536, 235928, 298981, 355854, 464848, 493725, 498992 where it returns a value 1 too small. */ static unsigned long bits_fac (unsigned long n) { mpfr_t x, y; unsigned long r, k; mpfr_init2 (x, 38); mpfr_init2 (y, 38); mpfr_set_ui (x, n, MPFR_RNDZ); mpfr_set_str_binary (y, "10.101101111110000101010001011000101001"); /* upper bound of e */ mpfr_div (x, x, y, MPFR_RNDZ); mpfr_pow_ui (x, x, n, MPFR_RNDZ); mpfr_const_pi (y, MPFR_RNDZ); mpfr_mul_ui (y, y, 2 * n, MPFR_RNDZ); mpfr_sqrt (y, y, MPFR_RNDZ); mpfr_mul (x, x, y, MPFR_RNDZ); mpfr_log2 (x, x, MPFR_RNDZ); r = mpfr_get_ui (x, MPFR_RNDU); for (k = 2; k <= n; k *= 2) r -= n / k; mpfr_clear (x); mpfr_clear (y); return r; }
int main (void) { mpfr_t a, b, c; long large_prec; tests_start_mpfr (); mpfr_inits (a, b, c, (mpfr_ptr) 0); mpfr_clears (a, b, c, (mpfr_ptr) 0); mpfr_inits2 (200, a, b, c, (mpfr_ptr) 0); mpfr_clears (a, b, c, (mpfr_ptr) 0); /* test for precision 2^31-1, see https://gforge.inria.fr/tracker/index.php?func=detail&aid=13918 */ large_prec = 2147483647; if (getenv ("MPFR_CHECK_LARGEMEM") != NULL) { /* We assume that the precision won't be increased internally. */ if (large_prec > MPFR_PREC_MAX) large_prec = MPFR_PREC_MAX; mpfr_inits2 (large_prec, a, b, (mpfr_ptr) 0); mpfr_set_ui (a, 17, MPFR_RNDN); mpfr_set (b, a, MPFR_RNDN); if (mpfr_get_ui (a, MPFR_RNDN) != 17) { printf ("Error in mpfr_init2 with precision 2^31-1\n"); exit (1); } mpfr_clears (a, b, (mpfr_ptr) 0); } tests_end_mpfr (); return 0; }
int main (int argc, char *argv[]) { mpfr_t x; long k, z, d, N; unsigned long zl, dl; int inex; int r; mpfr_exp_t emin, emax; int flag; tests_start_mpfr (); mpfr_init2 (x, 100); N = (argc==1) ? 100000 : atol (argv[1]); for (k = 1; k <= N; k++) { z = (long) (randlimb () & LONG_MAX) + LONG_MIN / 2; inex = mpfr_set_si (x, z, MPFR_RNDZ); d = mpfr_get_si (x, MPFR_RNDZ); if (d != z) { printf ("Error in mpfr_set_si: expected %ld got %ld\n", z, d); exit (1); } if (inex) { printf ("Error in mpfr_set_si: inex value incorrect for %ld: %d\n", z, inex); exit (1); } } for (k = 1; k <= N; k++) { zl = randlimb (); inex = mpfr_set_ui (x, zl, MPFR_RNDZ); dl = mpfr_get_ui (x, MPFR_RNDZ); if (dl != zl) { printf ("Error in mpfr_set_ui: expected %lu got %lu\n", zl, dl); exit (1); } if (inex) { printf ("Error in mpfr_set_ui: inex value incorrect for %lu: %d\n", zl, inex); exit (1); } } mpfr_set_prec (x, 2); if (mpfr_set_si (x, 5, MPFR_RNDZ) >= 0) { printf ("Wrong inexact flag for x=5, rnd=MPFR_RNDZ\n"); exit (1); } mpfr_set_prec (x, 2); if (mpfr_set_si (x, -5, MPFR_RNDZ) <= 0) { printf ("Wrong inexact flag for x=-5, rnd=MPFR_RNDZ\n"); exit (1); } mpfr_set_prec (x, 3); inex = mpfr_set_si (x, 77617, MPFR_RNDD); /* should be 65536 */ if (MPFR_MANT(x)[0] != ((mp_limb_t)1 << (mp_bits_per_limb-1)) || inex >= 0) { printf ("Error in mpfr_set_si(x:3, 77617, MPFR_RNDD)\n"); mpfr_print_binary (x); puts (""); exit (1); } inex = mpfr_set_ui (x, 77617, MPFR_RNDD); /* should be 65536 */ if (MPFR_MANT(x)[0] != ((mp_limb_t)1 << (mp_bits_per_limb-1)) || inex >= 0) { printf ("Error in mpfr_set_ui(x:3, 77617, MPFR_RNDD)\n"); mpfr_print_binary (x); puts (""); exit (1); } mpfr_set_prec (x, 2); inex = mpfr_set_si (x, 33096, MPFR_RNDU); if (mpfr_get_si (x, MPFR_RNDZ) != 49152 || inex <= 0) { printf ("Error in mpfr_set_si, exp. 49152, got %ld, inex %d\n", mpfr_get_si (x, MPFR_RNDZ), inex); exit (1); } inex = mpfr_set_ui (x, 33096, MPFR_RNDU); if (mpfr_get_si (x, MPFR_RNDZ) != 49152) { printf ("Error in mpfr_set_ui, exp. 49152, got %ld, inex %d\n", mpfr_get_si (x, MPFR_RNDZ), inex); exit (1); } /* Also test the mpfr_set_ui function (instead of macro). */ inex = (mpfr_set_ui) (x, 33096, MPFR_RNDU); if (mpfr_get_si (x, MPFR_RNDZ) != 49152) { printf ("Error in mpfr_set_ui function, exp. 49152, got %ld, inex %d\n", mpfr_get_si (x, MPFR_RNDZ), inex); exit (1); } for (r = 0 ; r < MPFR_RND_MAX ; r++) { mpfr_set_si (x, -1, (mpfr_rnd_t) r); mpfr_set_ui (x, 0, (mpfr_rnd_t) r); if (MPFR_IS_NEG (x) || mpfr_get_ui (x, (mpfr_rnd_t) r) != 0) { printf ("mpfr_set_ui (x, 0) gives -0 for %s\n", mpfr_print_rnd_mode ((mpfr_rnd_t) r)); exit (1); } mpfr_set_si (x, -1, (mpfr_rnd_t) r); mpfr_set_si (x, 0, (mpfr_rnd_t) r); if (MPFR_IS_NEG (x) || mpfr_get_si (x, (mpfr_rnd_t) r) != 0) { printf ("mpfr_set_si (x, 0) gives -0 for %s\n", mpfr_print_rnd_mode ((mpfr_rnd_t) r)); exit (1); } } /* check potential bug in case mp_limb_t is unsigned */ emax = mpfr_get_emax (); set_emax (0); mpfr_set_si (x, -1, MPFR_RNDN); if (mpfr_sgn (x) >= 0) { printf ("mpfr_set_si (x, -1) fails\n"); exit (1); } set_emax (emax); emax = mpfr_get_emax (); set_emax (5); mpfr_set_prec (x, 2); mpfr_set_si (x, -31, MPFR_RNDN); if (mpfr_sgn (x) >= 0) { printf ("mpfr_set_si (x, -31) fails\n"); exit (1); } set_emax (emax); /* test for get_ui */ mpfr_set_ui (x, 0, MPFR_RNDN); MPFR_ASSERTN(mpfr_get_ui (x, MPFR_RNDN) == 0); mpfr_set_ui (x, ULONG_MAX, MPFR_RNDU); mpfr_nextabove (x); mpfr_get_ui (x, MPFR_RNDU); /* another test for get_ui */ mpfr_set_prec (x, 10); mpfr_set_str_binary (x, "10.101"); dl = mpfr_get_ui (x, MPFR_RNDN); MPFR_ASSERTN (dl == 3); mpfr_set_str_binary (x, "-1.0"); mpfr_get_ui (x, MPFR_RNDN); mpfr_set_str_binary (x, "0.1"); dl = mpfr_get_ui (x, MPFR_RNDN); MPFR_ASSERTN (dl == 0); dl = mpfr_get_ui (x, MPFR_RNDZ); MPFR_ASSERTN (dl == 0); dl = mpfr_get_ui (x, MPFR_RNDD); MPFR_ASSERTN (dl == 0); dl = mpfr_get_ui (x, MPFR_RNDU); MPFR_ASSERTN (dl == 1); /* coverage tests */ mpfr_set_prec (x, 2); mpfr_set_si (x, -7, MPFR_RNDD); MPFR_ASSERTN(mpfr_cmp_si (x, -8) == 0); mpfr_set_prec (x, 2); mpfr_set_ui (x, 7, MPFR_RNDU); MPFR_ASSERTN(mpfr_cmp_ui (x, 8) == 0); emax = mpfr_get_emax (); set_emax (3); mpfr_set_ui (x, 7, MPFR_RNDU); MPFR_ASSERTN(mpfr_inf_p (x) && mpfr_sgn (x) > 0); set_emax (1); MPFR_ASSERTN( mpfr_set_ui (x, 7, MPFR_RNDU) ); MPFR_ASSERTN(mpfr_inf_p (x) && mpfr_sgn (x) > 0); set_emax (emax); mpfr_set_ui_2exp (x, 17, -50, MPFR_RNDN); MPFR_ASSERTN (mpfr_get_ui (x, MPFR_RNDD) == 0); MPFR_ASSERTN (mpfr_get_si (x, MPFR_RNDD) == 0); /* Test for ERANGE flag + correct behaviour if overflow */ mpfr_set_prec (x, 256); mpfr_set_ui (x, ULONG_MAX, MPFR_RNDN); mpfr_clear_erangeflag (); dl = mpfr_get_ui (x, MPFR_RNDN); if (dl != ULONG_MAX || mpfr_erangeflag_p ()) { printf ("ERROR for get_ui + ERANGE + ULONG_MAX (1)\n"); exit (1); } mpfr_add_ui (x, x, 1, MPFR_RNDN); dl = mpfr_get_ui (x, MPFR_RNDN); if (dl != ULONG_MAX || !mpfr_erangeflag_p ()) { printf ("ERROR for get_ui + ERANGE + ULONG_MAX (2)\n"); exit (1); } mpfr_set_si (x, -1, MPFR_RNDN); mpfr_clear_erangeflag (); dl = mpfr_get_ui (x, MPFR_RNDN); if (dl != 0 || !mpfr_erangeflag_p ()) { printf ("ERROR for get_ui + ERANGE + -1 \n"); exit (1); } mpfr_set_si (x, LONG_MAX, MPFR_RNDN); mpfr_clear_erangeflag (); d = mpfr_get_si (x, MPFR_RNDN); if (d != LONG_MAX || mpfr_erangeflag_p ()) { printf ("ERROR for get_si + ERANGE + LONG_MAX (1): %ld\n", d); exit (1); } mpfr_add_ui (x, x, 1, MPFR_RNDN); d = mpfr_get_si (x, MPFR_RNDN); if (d != LONG_MAX || !mpfr_erangeflag_p ()) { printf ("ERROR for get_si + ERANGE + LONG_MAX (2)\n"); exit (1); } mpfr_set_si (x, LONG_MIN, MPFR_RNDN); mpfr_clear_erangeflag (); d = mpfr_get_si (x, MPFR_RNDN); if (d != LONG_MIN || mpfr_erangeflag_p ()) { printf ("ERROR for get_si + ERANGE + LONG_MIN (1)\n"); exit (1); } mpfr_sub_ui (x, x, 1, MPFR_RNDN); d = mpfr_get_si (x, MPFR_RNDN); if (d != LONG_MIN || !mpfr_erangeflag_p ()) { printf ("ERROR for get_si + ERANGE + LONG_MIN (2)\n"); exit (1); } mpfr_set_nan (x); mpfr_clear_erangeflag (); d = mpfr_get_ui (x, MPFR_RNDN); if (d != 0 || !mpfr_erangeflag_p ()) { printf ("ERROR for get_ui + NaN\n"); exit (1); } mpfr_clear_erangeflag (); d = mpfr_get_si (x, MPFR_RNDN); if (d != 0 || !mpfr_erangeflag_p ()) { printf ("ERROR for get_si + NaN\n"); exit (1); } emin = mpfr_get_emin (); mpfr_set_prec (x, 2); mpfr_set_emin (4); mpfr_clear_flags (); mpfr_set_ui (x, 7, MPFR_RNDU); flag = mpfr_underflow_p (); mpfr_set_emin (emin); if (mpfr_cmp_ui (x, 8) != 0) { printf ("Error for mpfr_set_ui (x, 7, MPFR_RNDU), prec = 2, emin = 4\n"); exit (1); } if (flag) { printf ("mpfr_set_ui (x, 7, MPFR_RNDU) should not underflow " "with prec = 2, emin = 4\n"); exit (1); } mpfr_set_emin (4); mpfr_clear_flags (); mpfr_set_si (x, -7, MPFR_RNDD); flag = mpfr_underflow_p (); mpfr_set_emin (emin); if (mpfr_cmp_si (x, -8) != 0) { printf ("Error for mpfr_set_si (x, -7, MPFR_RNDD), prec = 2, emin = 4\n"); exit (1); } if (flag) { printf ("mpfr_set_si (x, -7, MPFR_RNDD) should not underflow " "with prec = 2, emin = 4\n"); exit (1); } mpfr_clear (x); test_2exp (); test_macros (); test_macros_keyword (); tests_end_mpfr (); return 0; }
static int mpfr_all_div (mpfr_ptr a, mpfr_srcptr b, mpfr_srcptr c, mpfr_rnd_t r) { mpfr_t a2; unsigned int oldflags, newflags; int inex, inex2; oldflags = __gmpfr_flags; inex = mpfr_div (a, b, c, r); if (a == b || a == c) return inex; newflags = __gmpfr_flags; mpfr_init2 (a2, MPFR_PREC (a)); if (mpfr_integer_p (b) && ! (MPFR_IS_ZERO (b) && MPFR_IS_NEG (b))) { /* b is an integer, but not -0 (-0 is rejected as it becomes +0 when converted to an integer). */ if (mpfr_fits_ulong_p (b, MPFR_RNDA)) { __gmpfr_flags = oldflags; inex2 = mpfr_ui_div (a2, mpfr_get_ui (b, MPFR_RNDN), c, r); MPFR_ASSERTN (SAME_SIGN (inex2, inex)); MPFR_ASSERTN (__gmpfr_flags == newflags); check_equal (a, a2, "mpfr_ui_div", b, c, r); } if (mpfr_fits_slong_p (b, MPFR_RNDA)) { __gmpfr_flags = oldflags; inex2 = mpfr_si_div (a2, mpfr_get_si (b, MPFR_RNDN), c, r); MPFR_ASSERTN (SAME_SIGN (inex2, inex)); MPFR_ASSERTN (__gmpfr_flags == newflags); check_equal (a, a2, "mpfr_si_div", b, c, r); } } if (mpfr_integer_p (c) && ! (MPFR_IS_ZERO (c) && MPFR_IS_NEG (c))) { /* c is an integer, but not -0 (-0 is rejected as it becomes +0 when converted to an integer). */ if (mpfr_fits_ulong_p (c, MPFR_RNDA)) { __gmpfr_flags = oldflags; inex2 = mpfr_div_ui (a2, b, mpfr_get_ui (c, MPFR_RNDN), r); MPFR_ASSERTN (SAME_SIGN (inex2, inex)); MPFR_ASSERTN (__gmpfr_flags == newflags); check_equal (a, a2, "mpfr_div_ui", b, c, r); } if (mpfr_fits_slong_p (c, MPFR_RNDA)) { __gmpfr_flags = oldflags; inex2 = mpfr_div_si (a2, b, mpfr_get_si (c, MPFR_RNDN), r); MPFR_ASSERTN (SAME_SIGN (inex2, inex)); MPFR_ASSERTN (__gmpfr_flags == newflags); check_equal (a, a2, "mpfr_div_si", b, c, r); } } mpfr_clear (a2); return inex; }
/*------------------------------------------------------------------------*/ 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; }
int mpfr_log10 (mpfr_ptr r, mpfr_srcptr a, mpfr_rnd_t rnd_mode) { int inexact; MPFR_SAVE_EXPO_DECL (expo); /* If a is NaN, the result is NaN */ if (MPFR_UNLIKELY (MPFR_IS_SINGULAR (a))) { if (MPFR_IS_NAN (a)) { MPFR_SET_NAN (r); MPFR_RET_NAN; } /* check for infinity before zero */ else if (MPFR_IS_INF (a)) { if (MPFR_IS_NEG (a)) /* log10(-Inf) = NaN */ { MPFR_SET_NAN (r); MPFR_RET_NAN; } else /* log10(+Inf) = +Inf */ { MPFR_SET_INF (r); MPFR_SET_POS (r); MPFR_RET (0); /* exact */ } } else /* a = 0 */ { MPFR_ASSERTD (MPFR_IS_ZERO (a)); MPFR_SET_INF (r); MPFR_SET_NEG (r); MPFR_RET (0); /* log10(0) is an exact -infinity */ } } /* If a is negative, the result is NaN */ if (MPFR_UNLIKELY (MPFR_IS_NEG (a))) { MPFR_SET_NAN (r); MPFR_RET_NAN; } /* If a is 1, the result is 0 */ if (mpfr_cmp_ui (a, 1) == 0) { MPFR_SET_ZERO (r); MPFR_SET_POS (r); MPFR_RET (0); /* result is exact */ } MPFR_SAVE_EXPO_MARK (expo); /* General case */ { /* Declaration of the intermediary variable */ mpfr_t t, tt; MPFR_ZIV_DECL (loop); /* Declaration of the size variable */ mpfr_prec_t Ny = MPFR_PREC(r); /* Precision of output variable */ mpfr_prec_t Nt; /* Precision of the intermediary variable */ mpfr_exp_t err; /* Precision of error */ /* compute the precision of intermediary variable */ /* the optimal number of bits : see algorithms.tex */ Nt = Ny + 4 + MPFR_INT_CEIL_LOG2 (Ny); /* initialise of intermediary variables */ mpfr_init2 (t, Nt); mpfr_init2 (tt, Nt); /* First computation of log10 */ MPFR_ZIV_INIT (loop, Nt); for (;;) { /* compute log10 */ mpfr_set_ui (t, 10, MPFR_RNDN); /* 10 */ mpfr_log (t, t, MPFR_RNDD); /* log(10) */ mpfr_log (tt, a, MPFR_RNDN); /* log(a) */ mpfr_div (t, tt, t, MPFR_RNDN); /* log(a)/log(10) */ /* estimation of the error */ err = Nt - 4; if (MPFR_LIKELY (MPFR_CAN_ROUND (t, err, Ny, rnd_mode))) break; /* log10(10^n) is exact: FIXME: Can we have 10^n exactly representable as a mpfr_t but n can't fit an unsigned long? */ if (MPFR_IS_POS (t) && mpfr_integer_p (t) && mpfr_fits_ulong_p (t, MPFR_RNDN) && !mpfr_ui_pow_ui (tt, 10, mpfr_get_ui (t, MPFR_RNDN), MPFR_RNDN) && mpfr_cmp (a, tt) == 0) break; /* actualisation of the precision */ MPFR_ZIV_NEXT (loop, Nt); mpfr_set_prec (t, Nt); mpfr_set_prec (tt, Nt); } MPFR_ZIV_FREE (loop); inexact = mpfr_set (r, t, rnd_mode); mpfr_clear (t); mpfr_clear (tt); } MPFR_SAVE_EXPO_FREE (expo); return mpfr_check_range (r, inexact, rnd_mode); }
/* compute in s an approximation of S3 = c*sum((h(k)+h(n+k))*y^k/k!/(n+k)!,k=0..infinity) where h(k) = 1 + 1/2 + ... + 1/k k=0: h(n) k=1: 1+h(n+1) k=2: 3/2+h(n+2) Returns e such that the error is bounded by 2^e ulp(s). */ static mpfr_exp_t mpfr_yn_s3 (mpfr_ptr s, mpfr_srcptr y, mpfr_srcptr c, unsigned long n) { unsigned long k, zz; mpfr_t t, u; mpz_t p, q; /* p/q will store h(k)+h(n+k) */ mpfr_exp_t exps, expU; zz = mpfr_get_ui (y, MPFR_RNDU); /* y = z^2/4 */ MPFR_ASSERTN (zz < ULONG_MAX - 2); zz += 2; /* z^2 <= 2^zz */ mpz_init_set_ui (p, 0); mpz_init_set_ui (q, 1); /* initialize p/q to h(n) */ for (k = 1; k <= n; k++) { /* p/q + 1/k = (k*p+q)/(q*k) */ mpz_mul_ui (p, p, k); mpz_add (p, p, q); mpz_mul_ui (q, q, k); } mpfr_init2 (t, MPFR_PREC(s)); mpfr_init2 (u, MPFR_PREC(s)); mpfr_fac_ui (t, n, MPFR_RNDN); mpfr_div (t, c, t, MPFR_RNDN); /* c/n! */ mpfr_mul_z (u, t, p, MPFR_RNDN); mpfr_div_z (s, u, q, MPFR_RNDN); exps = MPFR_EXP (s); expU = exps; for (k = 1; ;k ++) { /* update t */ mpfr_mul (t, t, y, MPFR_RNDN); mpfr_div_ui (t, t, k, MPFR_RNDN); mpfr_div_ui (t, t, n + k, MPFR_RNDN); /* update p/q: p/q + 1/k + 1/(n+k) = [p*k*(n+k) + q*(n+k) + q*k]/(q*k*(n+k)) */ mpz_mul_ui (p, p, k); mpz_mul_ui (p, p, n + k); mpz_addmul_ui (p, q, n + 2 * k); mpz_mul_ui (q, q, k); mpz_mul_ui (q, q, n + k); mpfr_mul_z (u, t, p, MPFR_RNDN); mpfr_div_z (u, u, q, MPFR_RNDN); exps = MPFR_EXP (u); if (exps > expU) expU = exps; mpfr_add (s, s, u, MPFR_RNDN); exps = MPFR_EXP (s); if (exps > expU) expU = exps; if (MPFR_EXP (u) + (mpfr_exp_t) MPFR_PREC (u) < MPFR_EXP (s) && zz / (2 * k) < k + n) break; } mpfr_clear (t); mpfr_clear (u); mpz_clear (p); mpz_clear (q); exps = expU - MPFR_EXP (s); /* the error is bounded by (6k^2+33/2k+11) 2^exps ulps <= 8*(k+2)^2 2^exps ulps */ return 3 + 2 * MPFR_INT_CEIL_LOG2(k + 2) + exps; }
/* tgeneric(prec_min, prec_max, step, exp_max) checks rounding with random numbers: - with precision ranging from prec_min to prec_max with an increment of step, - with exponent between -exp_max and exp_max. It also checks parameter reuse (it is assumed here that either two mpc_t variables are equal or they are different, in the sense that the real part of one of them cannot be the imaginary part of the other). */ void tgeneric (mpc_function function, mpfr_prec_t prec_min, mpfr_prec_t prec_max, mpfr_prec_t step, mpfr_exp_t exp_max) { unsigned long ul1 = 0, ul2 = 0; long lo = 0; int i = 0; mpfr_t x1, x2, xxxx; mpc_t z1, z2, z3, z4, z5, zzzz, zzzz2; mpfr_rnd_t rnd_re, rnd_im, rnd2_re, rnd2_im; mpfr_prec_t prec; mpfr_exp_t exp_min; int special, special_cases; mpc_init2 (z1, prec_max); switch (function.type) { case C_CC: mpc_init2 (z2, prec_max); mpc_init2 (z3, prec_max); mpc_init2 (z4, prec_max); mpc_init2 (zzzz, 4*prec_max); special_cases = 8; break; case CCCC: mpc_init2 (z2, prec_max); mpc_init2 (z3, prec_max); mpc_init2 (z4, prec_max); mpc_init2 (z5, prec_max); mpc_init2 (zzzz, 4*prec_max); special_cases = 8; break; case FC: mpfr_init2 (x1, prec_max); mpfr_init2 (x2, prec_max); mpfr_init2 (xxxx, 4*prec_max); mpc_init2 (z2, prec_max); special_cases = 4; break; case CCF: case CFC: mpfr_init2 (x1, prec_max); mpc_init2 (z2, prec_max); mpc_init2 (z3, prec_max); mpc_init2 (zzzz, 4*prec_max); special_cases = 6; break; case CCI: case CCS: case CCU: case CUC: mpc_init2 (z2, prec_max); mpc_init2 (z3, prec_max); mpc_init2 (zzzz, 4*prec_max); special_cases = 5; break; case CUUC: mpc_init2 (z2, prec_max); mpc_init2 (z3, prec_max); mpc_init2 (zzzz, 4*prec_max); special_cases = 6; break; case CC_C: mpc_init2 (z2, prec_max); mpc_init2 (z3, prec_max); mpc_init2 (z4, prec_max); mpc_init2 (z5, prec_max); mpc_init2 (zzzz, 4*prec_max); mpc_init2 (zzzz2, 4*prec_max); special_cases = 4; break; case CC: default: mpc_init2 (z2, prec_max); mpc_init2 (z3, prec_max); mpc_init2 (zzzz, 4*prec_max); special_cases = 4; } exp_min = mpfr_get_emin (); if (exp_max <= 0 || exp_max > mpfr_get_emax ()) exp_max = mpfr_get_emax(); if (-exp_max > exp_min) exp_min = - exp_max; if (step < 1) step = 1; for (prec = prec_min, special = 0; prec <= prec_max || special <= special_cases; prec+=step, special += (prec > prec_max ? 1 : 0)) { /* In the end, test functions in special cases of purely real, purely imaginary or infinite arguments. */ /* probability of one zero part in 256th (25 is almost 10%) */ const unsigned int zero_probability = special != 0 ? 0 : 25; mpc_set_prec (z1, prec); test_default_random (z1, exp_min, exp_max, 128, zero_probability); switch (function.type) { case C_CC: mpc_set_prec (z2, prec); test_default_random (z2, exp_min, exp_max, 128, zero_probability); mpc_set_prec (z3, prec); mpc_set_prec (z4, prec); mpc_set_prec (zzzz, 4*prec); switch (special) { case 1: mpfr_set_ui (mpc_realref (z1), 0, MPFR_RNDN); break; case 2: mpfr_set_inf (mpc_realref (z1), +1); break; case 3: mpfr_set_ui (mpc_imagref (z1), 0, MPFR_RNDN); break; case 4: mpfr_set_inf (mpc_imagref (z1), -1); break; case 5: mpfr_set_ui (mpc_realref (z2), 0, MPFR_RNDN); break; case 6: mpfr_set_inf (mpc_realref (z2), -1); break; case 7: mpfr_set_ui (mpc_imagref (z2), 0, MPFR_RNDN); break; case 8: mpfr_set_inf (mpc_imagref (z2), +1); break; } break; case CCCC: mpc_set_prec (z2, prec); test_default_random (z2, exp_min, exp_max, 128, zero_probability); mpc_set_prec (z3, prec); mpc_set_prec (z4, prec); mpc_set_prec (z5, prec); mpc_set_prec (zzzz, 4*prec); switch (special) { case 1: mpfr_set_ui (mpc_realref (z1), 0, MPFR_RNDN); break; case 2: mpfr_set_inf (mpc_realref (z1), +1); break; case 3: mpfr_set_ui (mpc_imagref (z1), 0, MPFR_RNDN); break; case 4: mpfr_set_inf (mpc_imagref (z1), -1); break; case 5: mpfr_set_ui (mpc_realref (z2), 0, MPFR_RNDN); break; case 6: mpfr_set_inf (mpc_realref (z2), -1); break; case 7: mpfr_set_ui (mpc_imagref (z2), 0, MPFR_RNDN); break; case 8: mpfr_set_inf (mpc_imagref (z2), +1); break; } break; case FC: mpc_set_prec (z2, prec); mpfr_set_prec (x1, prec); mpfr_set_prec (x2, prec); mpfr_set_prec (xxxx, 4*prec); switch (special) { case 1: mpfr_set_ui (mpc_realref (z1), 0, MPFR_RNDN); break; case 2: mpfr_set_inf (mpc_realref (z1), +1); break; case 3: mpfr_set_ui (mpc_imagref (z1), 0, MPFR_RNDN); break; case 4: mpfr_set_inf (mpc_imagref (z1), -1); break; } break; case CCU: case CUC: mpc_set_prec (z2, 128); do { test_default_random (z2, 0, 64, 128, zero_probability); } while (!mpfr_fits_ulong_p (mpc_realref (z2), MPFR_RNDN)); ul1 = mpfr_get_ui (mpc_realref(z2), MPFR_RNDN); mpc_set_prec (z2, prec); mpc_set_prec (z3, prec); mpc_set_prec (zzzz, 4*prec); switch (special) { case 1: mpfr_set_ui (mpc_realref (z1), 0, MPFR_RNDN); break; case 2: mpfr_set_inf (mpc_realref (z1), +1); break; case 3: mpfr_set_ui (mpc_imagref (z1), 0, MPFR_RNDN); break; case 4: mpfr_set_inf (mpc_imagref (z1), -1); break; case 5: ul1 = 0; break; } break; case CUUC: mpc_set_prec (z2, 128); do { test_default_random (z2, 0, 64, 128, zero_probability); } while (!mpfr_fits_ulong_p (mpc_realref (z2), MPFR_RNDN) ||!mpfr_fits_ulong_p (mpc_imagref (z2), MPFR_RNDN)); ul1 = mpfr_get_ui (mpc_realref(z2), MPFR_RNDN); ul2 = mpfr_get_ui (mpc_imagref(z2), MPFR_RNDN); mpc_set_prec (z2, prec); mpc_set_prec (z3, prec); mpc_set_prec (zzzz, 4*prec); switch (special) { case 1: mpfr_set_ui (mpc_realref (z1), 0, MPFR_RNDN); break; case 2: mpfr_set_inf (mpc_realref (z1), +1); break; case 3: mpfr_set_ui (mpc_imagref (z1), 0, MPFR_RNDN); break; case 4: mpfr_set_inf (mpc_imagref (z1), -1); break; case 5: ul1 = 0; break; case 6: ul2 = 0; break; } break; case CCS: mpc_set_prec (z2, 128); do { test_default_random (z2, 0, 64, 128, zero_probability); } while (!mpfr_fits_slong_p (mpc_realref (z2), MPFR_RNDN)); lo = mpfr_get_si (mpc_realref(z2), MPFR_RNDN); mpc_set_prec (z2, prec); mpc_set_prec (z3, prec); mpc_set_prec (zzzz, 4*prec); switch (special) { case 1: mpfr_set_ui (mpc_realref (z1), 0, MPFR_RNDN); break; case 2: mpfr_set_inf (mpc_realref (z1), +1); break; case 3: mpfr_set_ui (mpc_imagref (z1), 0, MPFR_RNDN); break; case 4: mpfr_set_inf (mpc_imagref (z1), -1); break; case 5: lo = 0; break; } break; case CCI: mpc_set_prec (z2, 128); do { test_default_random (z2, 0, 64, 128, zero_probability); } while (!mpfr_fits_slong_p (mpc_realref (z2), MPFR_RNDN)); i = (int)mpfr_get_si (mpc_realref(z2), MPFR_RNDN); mpc_set_prec (z2, prec); mpc_set_prec (z3, prec); mpc_set_prec (zzzz, 4*prec); switch (special) { case 1: mpfr_set_ui (mpc_realref (z1), 0, MPFR_RNDN); break; case 2: mpfr_set_inf (mpc_realref (z1), +1); break; case 3: mpfr_set_ui (mpc_imagref (z1), 0, MPFR_RNDN); break; case 4: mpfr_set_inf (mpc_imagref (z1), -1); break; case 5: i = 0; break; } break; case CCF: case CFC: mpfr_set_prec (x1, prec); mpfr_set (x1, mpc_realref (z1), MPFR_RNDN); test_default_random (z1, exp_min, exp_max, 128, zero_probability); mpc_set_prec (z2, prec); mpc_set_prec (z3, prec); mpc_set_prec (zzzz, 4*prec); switch (special) { case 1: mpfr_set_ui (mpc_realref (z1), 0, MPFR_RNDN); break; case 2: mpfr_set_inf (mpc_realref (z1), +1); break; case 3: mpfr_set_ui (mpc_imagref (z1), 0, MPFR_RNDN); break; case 4: mpfr_set_inf (mpc_imagref (z1), -1); break; case 5: mpfr_set_ui (x1, 0, MPFR_RNDN); break; case 6: mpfr_set_inf (x1, +1); break; } break; case CC_C: mpc_set_prec (z2, prec); mpc_set_prec (z3, prec); mpc_set_prec (z4, prec); mpc_set_prec (z5, prec); mpc_set_prec (zzzz, 4*prec); mpc_set_prec (zzzz2, 4*prec); switch (special) { case 1: mpfr_set_ui (mpc_realref (z1), 0, MPFR_RNDN); break; case 2: mpfr_set_inf (mpc_realref (z1), +1); break; case 3: mpfr_set_ui (mpc_imagref (z1), 0, MPFR_RNDN); break; case 4: mpfr_set_inf (mpc_imagref (z1), -1); break; } break; case CC: default: mpc_set_prec (z2, prec); mpc_set_prec (z3, prec); mpc_set_prec (zzzz, 4*prec); switch (special) { case 1: mpfr_set_ui (mpc_realref (z1), 0, MPFR_RNDN); break; case 2: mpfr_set_inf (mpc_realref (z1), +1); break; case 3: mpfr_set_ui (mpc_imagref (z1), 0, MPFR_RNDN); break; case 4: mpfr_set_inf (mpc_imagref (z1), -1); break; } } for (rnd_re = first_rnd_mode (); is_valid_rnd_mode (rnd_re); rnd_re = next_rnd_mode (rnd_re)) switch (function.type) { case C_CC: for (rnd_im = first_rnd_mode (); is_valid_rnd_mode (rnd_im); rnd_im = next_rnd_mode (rnd_im)) tgeneric_c_cc (&function, z1, z2, z3, zzzz, z4, MPC_RND (rnd_re, rnd_im)); reuse_c_cc (&function, z1, z2, z3, z4); break; case CCCC: for (rnd_im = first_rnd_mode (); is_valid_rnd_mode (rnd_im); rnd_im = next_rnd_mode (rnd_im)) tgeneric_cccc (&function, z1, z2, z3, z4, zzzz, z5, MPC_RND (rnd_re, rnd_im)); reuse_cccc (&function, z1, z2, z3, z4, z5); break; case FC: tgeneric_fc (&function, z1, x1, xxxx, x2, rnd_re); reuse_fc (&function, z1, z2, x1); break; case CC: for (rnd_im = first_rnd_mode (); is_valid_rnd_mode (rnd_im); rnd_im = next_rnd_mode (rnd_im)) tgeneric_cc (&function, z1, z2, zzzz, z3, MPC_RND (rnd_re, rnd_im)); reuse_cc (&function, z1, z2, z3); break; case CC_C: for (rnd_im = first_rnd_mode (); is_valid_rnd_mode (rnd_im); rnd_im = next_rnd_mode (rnd_im)) for (rnd2_re = first_rnd_mode (); is_valid_rnd_mode (rnd2_re); rnd2_re = next_rnd_mode (rnd2_re)) for (rnd2_im = first_rnd_mode (); is_valid_rnd_mode (rnd2_im); rnd2_im = next_rnd_mode (rnd2_im)) tgeneric_cc_c (&function, z1, z2, z3, zzzz, zzzz2, z4, z5, MPC_RND (rnd_re, rnd_im), MPC_RND (rnd2_re, rnd2_im)); reuse_cc_c (&function, z1, z2, z3, z4, z5); break; case CFC: for (rnd_im = first_rnd_mode (); is_valid_rnd_mode (rnd_im); rnd_im = next_rnd_mode (rnd_im)) tgeneric_cfc (&function, x1, z1, z2, zzzz, z3, MPC_RND (rnd_re, rnd_im)); reuse_cfc (&function, z1, x1, z2, z3); break; case CCF: for (rnd_im = first_rnd_mode (); is_valid_rnd_mode (rnd_im); rnd_im = next_rnd_mode (rnd_im)) tgeneric_ccf (&function, z1, x1, z2, zzzz, z3, MPC_RND (rnd_re, rnd_im)); reuse_ccf (&function, z1, x1, z2, z3); break; case CCU: for (rnd_im = first_rnd_mode (); is_valid_rnd_mode (rnd_im); rnd_im = next_rnd_mode (rnd_im)) tgeneric_ccu (&function, z1, ul1, z2, zzzz, z3, MPC_RND (rnd_re, rnd_im)); reuse_ccu (&function, z1, ul1, z2, z3); break; case CUC: for (rnd_im = first_rnd_mode (); is_valid_rnd_mode (rnd_im); rnd_im = next_rnd_mode (rnd_im)) tgeneric_cuc (&function, ul1, z1, z2, zzzz, z3, MPC_RND (rnd_re, rnd_im)); reuse_cuc (&function, ul1, z1, z2, z3); break; case CCS: for (rnd_im = first_rnd_mode (); is_valid_rnd_mode (rnd_im); rnd_im = next_rnd_mode (rnd_im)) tgeneric_ccs (&function, z1, lo, z2, zzzz, z3, MPC_RND (rnd_re, rnd_im)); reuse_ccs (&function, z1, lo, z2, z3); break; case CCI: for (rnd_im = first_rnd_mode (); is_valid_rnd_mode (rnd_im); rnd_im = next_rnd_mode (rnd_im)) tgeneric_cci (&function, z1, i, z2, zzzz, z3, MPC_RND (rnd_re, rnd_im)); reuse_cci (&function, z1, i, z2, z3); break; case CUUC: for (rnd_im = first_rnd_mode (); is_valid_rnd_mode (rnd_im); rnd_im = next_rnd_mode (rnd_im)) tgeneric_cuuc (&function, ul1, ul2, z1, z2, zzzz, z3, MPC_RND (rnd_re, rnd_im)); reuse_cuuc (&function, ul1, ul2, z1, z2, z3); break; default: printf ("tgeneric not yet implemented for this kind of" "function\n"); exit (1); } } mpc_clear (z1); switch (function.type) { case C_CC: mpc_clear (z2); mpc_clear (z3); mpc_clear (z4); mpc_clear (zzzz); break; case CCCC: mpc_clear (z2); mpc_clear (z3); mpc_clear (z4); mpc_clear (z5); mpc_clear (zzzz); break; case FC: mpc_clear (z2); mpfr_clear (x1); mpfr_clear (x2); mpfr_clear (xxxx); break; case CCF: case CFC: mpfr_clear (x1); mpc_clear (z2); mpc_clear (z3); mpc_clear (zzzz); break; case CC_C: mpc_clear (z2); mpc_clear (z3); mpc_clear (z4); mpc_clear (z5); mpc_clear (zzzz); mpc_clear (zzzz2); break; case CUUC: case CCI: case CCS: case CCU: case CUC: case CC: default: mpc_clear (z2); mpc_clear (z3); mpc_clear (zzzz); } }
/* Compare the result (z1,inex1) of mpfr_pow with all flags cleared with those of mpfr_pow with all flags set and of the other power functions. Arguments x and y are the input values; sx and sy are their string representations (sx may be null); rnd contains the rounding mode; s is a string containing the function that called test_others. */ static void test_others (const void *sx, const char *sy, mpfr_rnd_t rnd, mpfr_srcptr x, mpfr_srcptr y, mpfr_srcptr z1, int inex1, unsigned int flags, const char *s) { mpfr_t z2; int inex2; int spx = sx != NULL; if (!spx) sx = x; mpfr_init2 (z2, mpfr_get_prec (z1)); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_pow (z2, x, y, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_pow, flags set"); /* If y is an integer that fits in an unsigned long and is not -0, we can test mpfr_pow_ui. */ if (MPFR_IS_POS (y) && mpfr_integer_p (y) && mpfr_fits_ulong_p (y, MPFR_RNDN)) { unsigned long yy = mpfr_get_ui (y, MPFR_RNDN); mpfr_clear_flags (); inex2 = mpfr_pow_ui (z2, x, yy, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, flags, s, "mpfr_pow_ui, flags cleared"); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_pow_ui (z2, x, yy, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_pow_ui, flags set"); /* If x is an integer that fits in an unsigned long and is not -0, we can also test mpfr_ui_pow_ui. */ if (MPFR_IS_POS (x) && mpfr_integer_p (x) && mpfr_fits_ulong_p (x, MPFR_RNDN)) { unsigned long xx = mpfr_get_ui (x, MPFR_RNDN); mpfr_clear_flags (); inex2 = mpfr_ui_pow_ui (z2, xx, yy, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, flags, s, "mpfr_ui_pow_ui, flags cleared"); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_ui_pow_ui (z2, xx, yy, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_ui_pow_ui, flags set"); } } /* If y is an integer but not -0 and not huge, we can test mpfr_pow_z, and possibly mpfr_pow_si (and possibly mpfr_ui_div). */ if (MPFR_IS_ZERO (y) ? MPFR_IS_POS (y) : (mpfr_integer_p (y) && MPFR_GET_EXP (y) < 256)) { mpz_t yyy; /* If y fits in a long, we can test mpfr_pow_si. */ if (mpfr_fits_slong_p (y, MPFR_RNDN)) { long yy = mpfr_get_si (y, MPFR_RNDN); mpfr_clear_flags (); inex2 = mpfr_pow_si (z2, x, yy, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, flags, s, "mpfr_pow_si, flags cleared"); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_pow_si (z2, x, yy, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_pow_si, flags set"); /* If y = -1, we can test mpfr_ui_div. */ if (yy == -1) { mpfr_clear_flags (); inex2 = mpfr_ui_div (z2, 1, x, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, flags, s, "mpfr_ui_div, flags cleared"); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_ui_div (z2, 1, x, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_ui_div, flags set"); } /* If y = 2, we can test mpfr_sqr. */ if (yy == 2) { mpfr_clear_flags (); inex2 = mpfr_sqr (z2, x, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, flags, s, "mpfr_sqr, flags cleared"); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_sqr (z2, x, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_sqr, flags set"); } } /* Test mpfr_pow_z. */ mpz_init (yyy); mpfr_get_z (yyy, y, MPFR_RNDN); mpfr_clear_flags (); inex2 = mpfr_pow_z (z2, x, yyy, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, flags, s, "mpfr_pow_z, flags cleared"); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_pow_z (z2, x, yyy, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_pow_z, flags set"); mpz_clear (yyy); } /* If y = 0.5, we can test mpfr_sqrt, except if x is -0 or -Inf (because the rule for mpfr_pow on these special values is different). */ if (MPFR_IS_PURE_FP (y) && mpfr_cmp_str1 (y, "0.5") == 0 && ! ((MPFR_IS_ZERO (x) || MPFR_IS_INF (x)) && MPFR_IS_NEG (x))) { mpfr_clear_flags (); inex2 = mpfr_sqrt (z2, x, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, flags, s, "mpfr_sqrt, flags cleared"); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_sqrt (z2, x, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_sqrt, flags set"); } #if MPFR_VERSION >= MPFR_VERSION_NUM(2,4,0) /* If y = -0.5, we can test mpfr_rec_sqrt, except if x = -Inf (because the rule for mpfr_pow on -Inf is different). */ if (MPFR_IS_PURE_FP (y) && mpfr_cmp_str1 (y, "-0.5") == 0 && ! (MPFR_IS_INF (x) && MPFR_IS_NEG (x))) { mpfr_clear_flags (); inex2 = mpfr_rec_sqrt (z2, x, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, flags, s, "mpfr_rec_sqrt, flags cleared"); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_rec_sqrt (z2, x, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_rec_sqrt, flags set"); } #endif /* If x is an integer that fits in an unsigned long and is not -0, we can test mpfr_ui_pow. */ if (MPFR_IS_POS (x) && mpfr_integer_p (x) && mpfr_fits_ulong_p (x, MPFR_RNDN)) { unsigned long xx = mpfr_get_ui (x, MPFR_RNDN); mpfr_clear_flags (); inex2 = mpfr_ui_pow (z2, xx, y, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, flags, s, "mpfr_ui_pow, flags cleared"); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_ui_pow (z2, xx, y, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_ui_pow, flags set"); /* If x = 2, we can test mpfr_exp2. */ if (xx == 2) { mpfr_clear_flags (); inex2 = mpfr_exp2 (z2, y, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, flags, s, "mpfr_exp2, flags cleared"); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_exp2 (z2, y, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_exp2, flags set"); } /* If x = 10, we can test mpfr_exp10. */ if (xx == 10) { mpfr_clear_flags (); inex2 = mpfr_exp10 (z2, y, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, flags, s, "mpfr_exp10, flags cleared"); __gmpfr_flags = MPFR_FLAGS_ALL; inex2 = mpfr_exp10 (z2, y, rnd); cmpres (spx, sx, sy, rnd, z1, inex1, z2, inex2, MPFR_FLAGS_ALL, s, "mpfr_exp10, flags set"); } } mpfr_clear (z2); }
/* We use the reflection formula Gamma(1+t) Gamma(1-t) = - Pi t / sin(Pi (1 + t)) in order to treat the case x <= 1, i.e. with x = 1-t, then Gamma(x) = -Pi*(1-x)/sin(Pi*(2-x))/GAMMA(2-x) */ int mpfr_gamma (mpfr_ptr gamma, mpfr_srcptr x, mpfr_rnd_t rnd_mode) { mpfr_t xp, GammaTrial, tmp, tmp2; mpz_t fact; mpfr_prec_t realprec; int compared, is_integer; int inex = 0; /* 0 means: result gamma not set yet */ MPFR_GROUP_DECL (group); MPFR_SAVE_EXPO_DECL (expo); MPFR_ZIV_DECL (loop); MPFR_LOG_FUNC (("x[%Pu]=%.*Rg rnd=%d", mpfr_get_prec (x), mpfr_log_prec, x, rnd_mode), ("gamma[%Pu]=%.*Rg inexact=%d", mpfr_get_prec (gamma), mpfr_log_prec, gamma, inex)); /* Trivial cases */ if (MPFR_UNLIKELY (MPFR_IS_SINGULAR (x))) { if (MPFR_IS_NAN (x)) { MPFR_SET_NAN (gamma); MPFR_RET_NAN; } else if (MPFR_IS_INF (x)) { if (MPFR_IS_NEG (x)) { MPFR_SET_NAN (gamma); MPFR_RET_NAN; } else { MPFR_SET_INF (gamma); MPFR_SET_POS (gamma); MPFR_RET (0); /* exact */ } } else /* x is zero */ { MPFR_ASSERTD(MPFR_IS_ZERO(x)); MPFR_SET_INF(gamma); MPFR_SET_SAME_SIGN(gamma, x); MPFR_SET_DIVBY0 (); MPFR_RET (0); /* exact */ } } /* Check for tiny arguments, where gamma(x) ~ 1/x - euler + .... We know from "Bound on Runs of Zeros and Ones for Algebraic Functions", Proceedings of Arith15, T. Lang and J.-M. Muller, 2001, that the maximal number of consecutive zeroes or ones after the round bit is n-1 for an input of n bits. But we need a more precise lower bound. Assume x has n bits, and 1/x is near a floating-point number y of n+1 bits. We can write x = X*2^e, y = Y/2^f with X, Y integers of n and n+1 bits. Thus X*Y^2^(e-f) is near from 1, i.e., X*Y is near from 2^(f-e). Two cases can happen: (i) either X*Y is exactly 2^(f-e), but this can happen only if X and Y are themselves powers of two, i.e., x is a power of two; (ii) or X*Y is at distance at least one from 2^(f-e), thus |xy-1| >= 2^(e-f), or |y-1/x| >= 2^(e-f)/x = 2^(-f)/X >= 2^(-f-n). Since ufp(y) = 2^(n-f) [ufp = unit in first place], this means that the distance |y-1/x| >= 2^(-2n) ufp(y). Now assuming |gamma(x)-1/x| <= 1, which is true for x <= 1, if 2^(-2n) ufp(y) >= 2, the error is at most 2^(-2n-1) ufp(y), and round(1/x) with precision >= 2n+2 gives the correct result. If x < 2^E, then y > 2^(-E), thus ufp(y) > 2^(-E-1). A sufficient condition is thus EXP(x) + 2 <= -2 MAX(PREC(x),PREC(Y)). */ if (MPFR_GET_EXP (x) + 2 <= -2 * (mpfr_exp_t) MAX(MPFR_PREC(x), MPFR_PREC(gamma))) { int sign = MPFR_SIGN (x); /* retrieve sign before possible override */ int special; MPFR_BLOCK_DECL (flags); MPFR_SAVE_EXPO_MARK (expo); /* for overflow cases, see below; this needs to be done before x possibly gets overridden. */ special = MPFR_GET_EXP (x) == 1 - MPFR_EMAX_MAX && MPFR_IS_POS_SIGN (sign) && MPFR_IS_LIKE_RNDD (rnd_mode, sign) && mpfr_powerof2_raw (x); MPFR_BLOCK (flags, inex = mpfr_ui_div (gamma, 1, x, rnd_mode)); if (inex == 0) /* x is a power of two */ { /* return RND(1/x - euler) = RND(+/- 2^k - eps) with eps > 0 */ if (rnd_mode == MPFR_RNDN || MPFR_IS_LIKE_RNDU (rnd_mode, sign)) inex = 1; else { mpfr_nextbelow (gamma); inex = -1; } } else if (MPFR_UNLIKELY (MPFR_OVERFLOW (flags))) { /* Overflow in the division 1/x. This is a real overflow, except in RNDZ or RNDD when 1/x = 2^emax, i.e. x = 2^(-emax): due to the "- euler", the rounded value in unbounded exponent range is 0.111...11 * 2^emax (not an overflow). */ if (!special) MPFR_SAVE_EXPO_UPDATE_FLAGS (expo, flags); } MPFR_SAVE_EXPO_FREE (expo); /* Note: an overflow is possible with an infinite result; in this case, the overflow flag will automatically be restored by mpfr_check_range. */ return mpfr_check_range (gamma, inex, rnd_mode); } is_integer = mpfr_integer_p (x); /* gamma(x) for x a negative integer gives NaN */ if (is_integer && MPFR_IS_NEG(x)) { MPFR_SET_NAN (gamma); MPFR_RET_NAN; } compared = mpfr_cmp_ui (x, 1); if (compared == 0) return mpfr_set_ui (gamma, 1, rnd_mode); /* if x is an integer that fits into an unsigned long, use mpfr_fac_ui if argument is not too large. If precision is p, fac_ui costs O(u*p), whereas gamma costs O(p*M(p)), so for u <= M(p), fac_ui should be faster. We approximate here M(p) by p*log(p)^2, which is not a bad guess. Warning: since the generic code does not handle exact cases, we want all cases where gamma(x) is exact to be treated here. */ if (is_integer && mpfr_fits_ulong_p (x, MPFR_RNDN)) { unsigned long int u; mpfr_prec_t p = MPFR_PREC(gamma); u = mpfr_get_ui (x, MPFR_RNDN); if (u < 44787929UL && bits_fac (u - 1) <= p + (rnd_mode == MPFR_RNDN)) /* bits_fac: lower bound on the number of bits of m, where gamma(x) = (u-1)! = m*2^e with m odd. */ return mpfr_fac_ui (gamma, u - 1, rnd_mode); /* if bits_fac(...) > p (resp. p+1 for rounding to nearest), then gamma(x) cannot be exact in precision p (resp. p+1). FIXME: remove the test u < 44787929UL after changing bits_fac to return a mpz_t or mpfr_t. */ } MPFR_SAVE_EXPO_MARK (expo); /* check for overflow: according to (6.1.37) in Abramowitz & Stegun, gamma(x) >= exp(-x) * x^(x-1/2) * sqrt(2*Pi) >= 2 * (x/e)^x / x for x >= 1 */ if (compared > 0) { mpfr_t yp; mpfr_exp_t expxp; MPFR_BLOCK_DECL (flags); /* quick test for the default exponent range */ if (mpfr_get_emax () >= 1073741823UL && MPFR_GET_EXP(x) <= 25) { MPFR_SAVE_EXPO_FREE (expo); return mpfr_gamma_aux (gamma, x, rnd_mode); } /* 1/e rounded down to 53 bits */ #define EXPM1_STR "0.010111100010110101011000110110001011001110111100111" mpfr_init2 (xp, 53); mpfr_init2 (yp, 53); mpfr_set_str_binary (xp, EXPM1_STR); mpfr_mul (xp, x, xp, MPFR_RNDZ); mpfr_sub_ui (yp, x, 2, MPFR_RNDZ); mpfr_pow (xp, xp, yp, MPFR_RNDZ); /* (x/e)^(x-2) */ mpfr_set_str_binary (yp, EXPM1_STR); mpfr_mul (xp, xp, yp, MPFR_RNDZ); /* x^(x-2) / e^(x-1) */ mpfr_mul (xp, xp, yp, MPFR_RNDZ); /* x^(x-2) / e^x */ mpfr_mul (xp, xp, x, MPFR_RNDZ); /* lower bound on x^(x-1) / e^x */ MPFR_BLOCK (flags, mpfr_mul_2ui (xp, xp, 1, MPFR_RNDZ)); expxp = MPFR_GET_EXP (xp); mpfr_clear (xp); mpfr_clear (yp); MPFR_SAVE_EXPO_FREE (expo); return MPFR_OVERFLOW (flags) || expxp > __gmpfr_emax ? mpfr_overflow (gamma, rnd_mode, 1) : mpfr_gamma_aux (gamma, x, rnd_mode); } /* now compared < 0 */ /* check for underflow: for x < 1, gamma(x) = Pi*(x-1)/sin(Pi*(2-x))/gamma(2-x). Since gamma(2-x) >= 2 * ((2-x)/e)^(2-x) / (2-x), we have |gamma(x)| <= Pi*(1-x)*(2-x)/2/((2-x)/e)^(2-x) / |sin(Pi*(2-x))| <= 12 * ((2-x)/e)^x / |sin(Pi*(2-x))|. To avoid an underflow in ((2-x)/e)^x, we compute the logarithm. */ if (MPFR_IS_NEG(x)) { int underflow = 0, sgn, ck; mpfr_prec_t w; mpfr_init2 (xp, 53); mpfr_init2 (tmp, 53); mpfr_init2 (tmp2, 53); /* we want an upper bound for x * [log(2-x)-1]. since x < 0, we need a lower bound on log(2-x) */ mpfr_ui_sub (xp, 2, x, MPFR_RNDD); mpfr_log (xp, xp, MPFR_RNDD); mpfr_sub_ui (xp, xp, 1, MPFR_RNDD); mpfr_mul (xp, xp, x, MPFR_RNDU); /* we need an upper bound on 1/|sin(Pi*(2-x))|, thus a lower bound on |sin(Pi*(2-x))|. If 2-x is exact, then the error of Pi*(2-x) is (1+u)^2 with u = 2^(-p) thus the error on sin(Pi*(2-x)) is less than 1/2ulp + 3Pi(2-x)u, assuming u <= 1, thus <= u + 3Pi(2-x)u */ w = mpfr_gamma_2_minus_x_exact (x); /* 2-x is exact for prec >= w */ w += 17; /* to get tmp2 small enough */ mpfr_set_prec (tmp, w); mpfr_set_prec (tmp2, w); MPFR_DBGRES (ck = mpfr_ui_sub (tmp, 2, x, MPFR_RNDN)); MPFR_ASSERTD (ck == 0); /* tmp = 2-x exactly */ mpfr_const_pi (tmp2, MPFR_RNDN); mpfr_mul (tmp2, tmp2, tmp, MPFR_RNDN); /* Pi*(2-x) */ mpfr_sin (tmp, tmp2, MPFR_RNDN); /* sin(Pi*(2-x)) */ sgn = mpfr_sgn (tmp); mpfr_abs (tmp, tmp, MPFR_RNDN); mpfr_mul_ui (tmp2, tmp2, 3, MPFR_RNDU); /* 3Pi(2-x) */ mpfr_add_ui (tmp2, tmp2, 1, MPFR_RNDU); /* 3Pi(2-x)+1 */ mpfr_div_2ui (tmp2, tmp2, mpfr_get_prec (tmp), MPFR_RNDU); /* if tmp2<|tmp|, we get a lower bound */ if (mpfr_cmp (tmp2, tmp) < 0) { mpfr_sub (tmp, tmp, tmp2, MPFR_RNDZ); /* low bnd on |sin(Pi*(2-x))| */ mpfr_ui_div (tmp, 12, tmp, MPFR_RNDU); /* upper bound */ mpfr_log2 (tmp, tmp, MPFR_RNDU); mpfr_add (xp, tmp, xp, MPFR_RNDU); /* The assert below checks that expo.saved_emin - 2 always fits in a long. FIXME if we want to allow mpfr_exp_t to be a long long, for instance. */ MPFR_ASSERTN (MPFR_EMIN_MIN - 2 >= LONG_MIN); underflow = mpfr_cmp_si (xp, expo.saved_emin - 2) <= 0; } mpfr_clear (xp); mpfr_clear (tmp); mpfr_clear (tmp2); if (underflow) /* the sign is the opposite of that of sin(Pi*(2-x)) */ { MPFR_SAVE_EXPO_FREE (expo); return mpfr_underflow (gamma, (rnd_mode == MPFR_RNDN) ? MPFR_RNDZ : rnd_mode, -sgn); } } realprec = MPFR_PREC (gamma); /* we want both 1-x and 2-x to be exact */ { mpfr_prec_t w; w = mpfr_gamma_1_minus_x_exact (x); if (realprec < w) realprec = w; w = mpfr_gamma_2_minus_x_exact (x); if (realprec < w) realprec = w; } realprec = realprec + MPFR_INT_CEIL_LOG2 (realprec) + 20; MPFR_ASSERTD(realprec >= 5); MPFR_GROUP_INIT_4 (group, realprec + MPFR_INT_CEIL_LOG2 (realprec) + 20, xp, tmp, tmp2, GammaTrial); mpz_init (fact); MPFR_ZIV_INIT (loop, realprec); for (;;) { mpfr_exp_t err_g; int ck; MPFR_GROUP_REPREC_4 (group, realprec, xp, tmp, tmp2, GammaTrial); /* reflection formula: gamma(x) = Pi*(x-1)/sin(Pi*(2-x))/gamma(2-x) */ ck = mpfr_ui_sub (xp, 2, x, MPFR_RNDN); /* 2-x, exact */ MPFR_ASSERTD(ck == 0); (void) ck; /* use ck to avoid a warning */ mpfr_gamma (tmp, xp, MPFR_RNDN); /* gamma(2-x), error (1+u) */ mpfr_const_pi (tmp2, MPFR_RNDN); /* Pi, error (1+u) */ mpfr_mul (GammaTrial, tmp2, xp, MPFR_RNDN); /* Pi*(2-x), error (1+u)^2 */ err_g = MPFR_GET_EXP(GammaTrial); mpfr_sin (GammaTrial, GammaTrial, MPFR_RNDN); /* sin(Pi*(2-x)) */ /* If tmp is +Inf, we compute exp(lngamma(x)). */ if (mpfr_inf_p (tmp)) { inex = mpfr_explgamma (gamma, x, &expo, tmp, tmp2, rnd_mode); if (inex) goto end; else goto ziv_next; } err_g = err_g + 1 - MPFR_GET_EXP(GammaTrial); /* let g0 the true value of Pi*(2-x), g the computed value. We have g = g0 + h with |h| <= |(1+u^2)-1|*g. Thus sin(g) = sin(g0) + h' with |h'| <= |(1+u^2)-1|*g. The relative error is thus bounded by |(1+u^2)-1|*g/sin(g) <= |(1+u^2)-1|*2^err_g. <= 2.25*u*2^err_g for |u|<=1/4. With the rounding error, this gives (0.5 + 2.25*2^err_g)*u. */ ck = mpfr_sub_ui (xp, x, 1, MPFR_RNDN); /* x-1, exact */ MPFR_ASSERTD(ck == 0); (void) ck; /* use ck to avoid a warning */ mpfr_mul (xp, tmp2, xp, MPFR_RNDN); /* Pi*(x-1), error (1+u)^2 */ mpfr_mul (GammaTrial, GammaTrial, tmp, MPFR_RNDN); /* [1 + (0.5 + 2.25*2^err_g)*u]*(1+u)^2 = 1 + (2.5 + 2.25*2^err_g)*u + (0.5 + 2.25*2^err_g)*u*(2u+u^2) + u^2. For err_g <= realprec-2, we have (0.5 + 2.25*2^err_g)*u <= 0.5*u + 2.25/4 <= 0.6875 and u^2 <= u/4, thus (0.5 + 2.25*2^err_g)*u*(2u+u^2) + u^2 <= 0.6875*(2u+u/4) + u/4 <= 1.8*u, thus the rel. error is bounded by (4.5 + 2.25*2^err_g)*u. */ mpfr_div (GammaTrial, xp, GammaTrial, MPFR_RNDN); /* the error is of the form (1+u)^3/[1 + (4.5 + 2.25*2^err_g)*u]. For realprec >= 5 and err_g <= realprec-2, [(4.5 + 2.25*2^err_g)*u]^2 <= 0.71, and for |y|<=0.71, 1/(1-y) can be written 1+a*y with a<=4. (1+u)^3 * (1+4*(4.5 + 2.25*2^err_g)*u) = 1 + (21 + 9*2^err_g)*u + (57+27*2^err_g)*u^2 + (55+27*2^err_g)*u^3 + (18+9*2^err_g)*u^4 <= 1 + (21 + 9*2^err_g)*u + (57+27*2^err_g)*u^2 + (56+28*2^err_g)*u^3 <= 1 + (21 + 9*2^err_g)*u + (59+28*2^err_g)*u^2 <= 1 + (23 + 10*2^err_g)*u. The final error is thus bounded by (23 + 10*2^err_g) ulps, which is <= 2^6 for err_g<=2, and <= 2^(err_g+4) for err_g >= 2. */ err_g = (err_g <= 2) ? 6 : err_g + 4; if (MPFR_LIKELY (MPFR_CAN_ROUND (GammaTrial, realprec - err_g, MPFR_PREC(gamma), rnd_mode))) break; ziv_next: MPFR_ZIV_NEXT (loop, realprec); } end: MPFR_ZIV_FREE (loop); if (inex == 0) inex = mpfr_set (gamma, GammaTrial, rnd_mode); MPFR_GROUP_CLEAR (group); mpz_clear (fact); MPFR_SAVE_EXPO_FREE (expo); return mpfr_check_range (gamma, inex, rnd_mode); }
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; }