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;
}
Exemple #2
0
real factorial(const real & a)
{
	real x;
	
	mpfr_fac_ui(x.r, mpfr_get_ui(a.r, MPFR_RNDZ), MPFR_RNDN);
	return x;
}
Exemple #3
0
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);
}
Exemple #4
0
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;
}
Exemple #5
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);
}
Exemple #6
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
Exemple #7
0
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);
}
Exemple #8
0
/* 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;
}
Exemple #9
0
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;
}
Exemple #10
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;
}
Exemple #11
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;
}
Exemple #12
0
/*------------------------------------------------------------------------*/
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;
}
Exemple #13
0
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);
}
Exemple #14
0
Fichier : yn.c Projet : Kirija/XPIR
/* 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;
}
Exemple #15
0
/* 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);
    }
}
Exemple #16
0
/* 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);
}
Exemple #17
0
/* 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);
}
Exemple #18
0
int my_mpfr_lbeta(mpfr_t R, mpfr_t a, mpfr_t b, mpfr_rnd_t RND)
{
    mpfr_prec_t p_a = mpfr_get_prec(a), p_b = mpfr_get_prec(b);
    if(p_a < p_b) p_a = p_b;// p_a := max(p_a, p_b)
    if(mpfr_get_prec(R) < p_a)
	mpfr_prec_round(R, p_a, RND);// so prec(R) = max( prec(a), prec(b) )
    int ans;
    mpfr_t s;
    mpfr_init2(s, p_a);

    /* "FIXME": check each 'ans' below, and return when not ok ... */
    ans = mpfr_add(s, a, b, RND);

    if(mpfr_integer_p(s) && mpfr_sgn(s) <= 0) { // (a + b) is integer <= 0
	if(!mpfr_integer_p(a) && !mpfr_integer_p(b)) {
	    // but a,b not integer ==> R = ln(finite / +-Inf) = ln(0) = -Inf :
	    mpfr_set_inf (R, -1);
	    mpfr_clear (s);
	    return ans;
	}// else: sum is integer; at least one integer ==> both integer

	int sX = mpfr_sgn(a), sY = mpfr_sgn(b);
	if(sX * sY < 0) { // one negative, one positive integer
	    // ==> special treatment here :
	    if(sY < 0) // ==> sX > 0; swap the two
		mpfr_swap(a, b);
	    /* now have --- a < 0 < b <= |a|  integer ------------------
	     *              ================
	     * --> see my_mpfr_beta() above */
	    unsigned long b_ = 0;// -Wall
	    Rboolean
		b_fits_ulong = mpfr_fits_ulong_p(b, RND),
		small_b = b_fits_ulong &&  (b_ = mpfr_get_ui(b, RND)) < b_large;
	    if(small_b) {
		//----------------- small b ------------------
		// use GMP big integer arithmetic:
		mpz_t S; mpz_init(S); mpfr_get_z(S, s, RND); // S := s
		mpz_sub_ui (S, S, (unsigned long) 1); // S = s - 1 = (a+b-1)
		/* binomial coefficient choose(N, k) requires k a 'long int';
		 * here, b must fit into a long: */
		mpz_bin_ui (S, S, b_); // S = choose(S, b) = choose(a+b-1, b)
		mpz_mul_ui (S, S, b_); // S = S*b =  b * choose(a+b-1, b)

		// back to mpfr: R = log(|1 / S|) =  - log(|S|)
		mpz_abs(S, S);
		mpfr_set_z(s, S, RND); // <mpfr> s :=  |S|
		mpfr_log(R, s, RND);   // R := log(s) = log(|S|)
		mpfr_neg(R, R, RND);   // R = -R = -log(|S|)
		mpz_clear(S);
	    }
	    else { // b is "large", use direct B(.,.) formula
		// a := (-1)^b -- not needed here, neither 'neg': want log( |.| )
		// s' := 1-s = 1-a-b
		mpfr_ui_sub(s, 1, s, RND);
		// R := log(|B(1-a-b, b)|) = log(|B(s', b)|)
		my_mpfr_lbeta (R, s, b, RND);
	    }
	    mpfr_clear(s);
	    return ans;
	}
    }

    ans = mpfr_lngamma(s, s, RND); // s = lngamma(a + b)
    ans = mpfr_lngamma(a, a, RND);
    ans = mpfr_lngamma(b, b, RND);
    ans = mpfr_add (b, b, a, RND); // b' = lngamma(a) + lngamma(b)
    ans = mpfr_sub (R, b, s, RND);

    mpfr_clear (s);
    return ans;
}