Beispiel #1
0
long double
__ieee754_gammal_r (long double x, int *signgamp)
{
  /* We don't have a real gamma implementation now.  We'll use lgamma
     and the exp function.  But due to the required boundary
     conditions we must check some values separately.  */
  int64_t hx;
  u_int64_t lx;

  GET_LDOUBLE_WORDS64 (hx, lx, x);

  if (((hx | lx) & 0x7fffffffffffffffLL) == 0)
    {
      /* Return value for x == 0 is Inf with divide by zero exception.  */
      *signgamp = 0;
      return 1.0 / x;
    }
  if (hx < 0 && (u_int64_t) hx < 0xfff0000000000000ULL && __rintl (x) == x)
    {
      /* Return value for integer x < 0 is NaN with invalid exception.  */
      *signgamp = 0;
      return (x - x) / (x - x);
    }
  if (hx == 0xfff0000000000000ULL)
    {
      /* x == -Inf.  According to ISO this is NaN.  */
      *signgamp = 0;
      return x - x;
    }

  /* XXX FIXME.  */
  return __ieee754_expl (__ieee754_lgammal_r (x, signgamp));
}
long double
__ieee754_gammal_r (long double x, int *signgamp)
{
  /* We don't have a real gamma implementation now.  We'll use lgamma
     and the exp function.  But due to the required boundary
     conditions we must check some values separately.  */
  u_int32_t es, hx, lx;

  GET_LDOUBLE_WORDS (es, hx, lx, x);

  if (((es & 0x7fff) | hx | lx) == 0)
    {
      /* Return value for x == 0 is NaN with invalid exception.  */
      *signgamp = 0;
      return x / x;
    }
  if (es == 0xffffffff && ((hx & 0x7fffffff) | lx) == 0)
    {
      /* x == -Inf.  According to ISO this is NaN.  */
      *signgamp = 0;
      return x - x;
    }
  if ((es & 0x7fff) == 0x7fff && ((hx & 0x7fffffff) | lx) != 0)
    /* NaN, return it.  */
    return x;
  if ((es & 0x8000) != 0 && x < 0xffffffff && __rintl (x) == x)
    {
      /* Return value for integer x < 0 is NaN with invalid exception.  */
      *signgamp = 0;
      return (x - x) / (x - x);
    }

  /* XXX FIXME.  */
  return __ieee754_expl (__ieee754_lgammal_r (x, signgamp));
}
Beispiel #3
0
long double
__lgammal_r(long double x, int *signgamp)
{
	long double y = __ieee754_lgammal_r(x,signgamp);
	if(__builtin_expect(!isfinite(y), 0)
	   && isfinite(x) && _LIB_VERSION != _IEEE_)
		return __kernel_standard(x, x,
					 floorl(x)==x&&x<=0.0
					 ? 215 /* lgamma pole */
					 : 214); /* lgamma overflow */

	return y;
}
Beispiel #4
0
long double
__lgammal(long double x)
{
	int local_signgam = 0;
	long double y = __ieee754_lgammal_r(x,
					    _LIB_VERSION != _ISOC_
					    /* ISO C99 does not define the
					       global variable.  */
					    ? &signgam
					    : &local_signgam);
	if(__builtin_expect(!__finitel(y), 0)
	   && __finitel(x) && _LIB_VERSION != _IEEE_)
		return __kernel_standard_l(x, x,
					   __floorl(x)==x&&x<=0.0L
					   ? 215 /* lgamma pole */
					   : 214); /* lgamma overflow */

	return y;
}
Beispiel #5
0
long double
__ieee754_lgammal_r (long double x, int *signgamp)
{
  long double p, q, w, z, nx;
  int i, nn;

  *signgamp = 1;

  if (! __finitel (x))
    return x * x;

  if (x == 0.0L)
    {
      if (__signbitl (x))
	*signgamp = -1;
    }

  if (x < 0.0L)
    {
      q = -x;
      p = __floorl (q);
      if (p == q)
	return (one / (p - p));
      i = p;
      if ((i & 1) == 0)
	*signgamp = -1;
      else
	*signgamp = 1;
      if (q < 0x1p-120L)
	return -__logl (q);
      z = q - p;
      if (z > 0.5L)
	{
	  p += 1.0L;
	  z = p - q;
	}
      z = q * __sinl (PIL * z);
      w = __ieee754_lgammal_r (q, &i);
      z = __logl (PIL / z) - w;
      return (z);
    }

  if (x < 13.5L)
    {
      p = 0.0L;
      nx = __floorl (x + 0.5L);
      nn = nx;
      switch (nn)
	{
	case 0:
	  /* log gamma (x + 1) = log(x) + log gamma(x) */
	  if (x < 0x1p-120L)
	    return -__logl (x);
	  else if (x <= 0.125)
	    {
	      p = x * neval (x, RN1, NRN1) / deval (x, RD1, NRD1);
	    }
	  else if (x <= 0.375)
	    {
	      z = x - 0.25L;
	      p = z * neval (z, RN1r25, NRN1r25) / deval (z, RD1r25, NRD1r25);
	      p += lgam1r25b;
	      p += lgam1r25a;
	    }
	  else if (x <= 0.625)
	    {
	      z = x + (1.0L - x0a);
	      z = z - x0b;
	      p = neval (z, RN1r5, NRN1r5) / deval (z, RD1r5, NRD1r5);
	      p = p * z * z;
	      p = p + y0b;
	      p = p + y0a;
	    }
	  else if (x <= 0.875)
	    {
	      z = x - 0.75L;
	      p = z * neval (z, RN1r75, NRN1r75) / deval (z, RD1r75, NRD1r75);
	      p += lgam1r75b;
	      p += lgam1r75a;
	    }
	  else
	    {
	      z = x - 1.0L;
	      p = z * neval (z, RN2, NRN2) / deval (z, RD2, NRD2);
	    }
	  p = p - __logl (x);
	  break;

	case 1:
	  if (x < 0.875L)
	    {
	      if (x <= 0.625)
		{
		  z = x + (1.0L - x0a);
		  z = z - x0b;
		  p = neval (z, RN1r5, NRN1r5) / deval (z, RD1r5, NRD1r5);
		  p = p * z * z;
		  p = p + y0b;
		  p = p + y0a;
		}
	      else if (x <= 0.875)
		{
		  z = x - 0.75L;
		  p = z * neval (z, RN1r75, NRN1r75)
			/ deval (z, RD1r75, NRD1r75);
		  p += lgam1r75b;
		  p += lgam1r75a;
		}
	      else
		{
		  z = x - 1.0L;
		  p = z * neval (z, RN2, NRN2) / deval (z, RD2, NRD2);
		}
	      p = p - __logl (x);
	    }
	  else if (x < 1.0L)
	    {
	      z = x - 1.0L;
	      p = z * neval (z, RNr9, NRNr9) / deval (z, RDr9, NRDr9);
	    }
	  else if (x == 1.0L)
	    p = 0.0L;
	  else if (x <= 1.125L)
	    {
	      z = x - 1.0L;
	      p = z * neval (z, RN1, NRN1) / deval (z, RD1, NRD1);
	    }
	  else if (x <= 1.375)
	    {
	      z = x - 1.25L;
	      p = z * neval (z, RN1r25, NRN1r25) / deval (z, RD1r25, NRD1r25);
	      p += lgam1r25b;
	      p += lgam1r25a;
	    }
	  else
	    {
	      /* 1.375 <= x+x0 <= 1.625 */
	      z = x - x0a;
	      z = z - x0b;
	      p = neval (z, RN1r5, NRN1r5) / deval (z, RD1r5, NRD1r5);
	      p = p * z * z;
	      p = p + y0b;
	      p = p + y0a;
	    }
	  break;

	case 2:
	  if (x < 1.625L)
	    {
	      z = x - x0a;
	      z = z - x0b;
	      p = neval (z, RN1r5, NRN1r5) / deval (z, RD1r5, NRD1r5);
	      p = p * z * z;
	      p = p + y0b;
	      p = p + y0a;
	    }
	  else if (x < 1.875L)
	    {
	      z = x - 1.75L;
	      p = z * neval (z, RN1r75, NRN1r75) / deval (z, RD1r75, NRD1r75);
	      p += lgam1r75b;
	      p += lgam1r75a;
	    }
	  else if (x == 2.0L)
	    p = 0.0L;
	  else if (x < 2.375L)
	    {
	      z = x - 2.0L;
	      p = z * neval (z, RN2, NRN2) / deval (z, RD2, NRD2);
	    }
	  else
	    {
	      z = x - 2.5L;
	      p = z * neval (z, RN2r5, NRN2r5) / deval (z, RD2r5, NRD2r5);
	      p += lgam2r5b;
	      p += lgam2r5a;
	    }
	  break;

	case 3:
	  if (x < 2.75)
	    {
	      z = x - 2.5L;
	      p = z * neval (z, RN2r5, NRN2r5) / deval (z, RD2r5, NRD2r5);
	      p += lgam2r5b;
	      p += lgam2r5a;
	    }
	  else
	    {
	      z = x - 3.0L;
	      p = z * neval (z, RN3, NRN3) / deval (z, RD3, NRD3);
	      p += lgam3b;
	      p += lgam3a;
	    }
	  break;

	case 4:
	  z = x - 4.0L;
	  p = z * neval (z, RN4, NRN4) / deval (z, RD4, NRD4);
	  p += lgam4b;
	  p += lgam4a;
	  break;

	case 5:
	  z = x - 5.0L;
	  p = z * neval (z, RN5, NRN5) / deval (z, RD5, NRD5);
	  p += lgam5b;
	  p += lgam5a;
	  break;

	case 6:
	  z = x - 6.0L;
	  p = z * neval (z, RN6, NRN6) / deval (z, RD6, NRD6);
	  p += lgam6b;
	  p += lgam6a;
	  break;

	case 7:
	  z = x - 7.0L;
	  p = z * neval (z, RN7, NRN7) / deval (z, RD7, NRD7);
	  p += lgam7b;
	  p += lgam7a;
	  break;

	case 8:
	  z = x - 8.0L;
	  p = z * neval (z, RN8, NRN8) / deval (z, RD8, NRD8);
	  p += lgam8b;
	  p += lgam8a;
	  break;

	case 9:
	  z = x - 9.0L;
	  p = z * neval (z, RN9, NRN9) / deval (z, RD9, NRD9);
	  p += lgam9b;
	  p += lgam9a;
	  break;

	case 10:
	  z = x - 10.0L;
	  p = z * neval (z, RN10, NRN10) / deval (z, RD10, NRD10);
	  p += lgam10b;
	  p += lgam10a;
	  break;

	case 11:
	  z = x - 11.0L;
	  p = z * neval (z, RN11, NRN11) / deval (z, RD11, NRD11);
	  p += lgam11b;
	  p += lgam11a;
	  break;

	case 12:
	  z = x - 12.0L;
	  p = z * neval (z, RN12, NRN12) / deval (z, RD12, NRD12);
	  p += lgam12b;
	  p += lgam12a;
	  break;

	case 13:
	  z = x - 13.0L;
	  p = z * neval (z, RN13, NRN13) / deval (z, RD13, NRD13);
	  p += lgam13b;
	  p += lgam13a;
	  break;
	}
      return p;
    }

  if (x > MAXLGM)
    return (*signgamp * huge * huge);

  q = ls2pi - x;
  q = (x - 0.5L) * __logl (x) + q;
  if (x > 1.0e18L)
    return (q);

  p = 1.0L / (x * x);
  q += neval (p, RASY, NRASY) / x;
  return (q);
}
Beispiel #6
0
static long double
gammal_positive (long double x, int *exp2_adj)
{
  int local_signgam;
  if (x < 0.5L)
    {
      *exp2_adj = 0;
      return __ieee754_expl (__ieee754_lgammal_r (x + 1, &local_signgam)) / x;
    }
  else if (x <= 1.5L)
    {
      *exp2_adj = 0;
      return __ieee754_expl (__ieee754_lgammal_r (x, &local_signgam));
    }
  else if (x < 12.5L)
    {
      /* Adjust into the range for using exp (lgamma).  */
      *exp2_adj = 0;
      long double n = __ceill (x - 1.5L);
      long double x_adj = x - n;
      long double eps;
      long double prod = __gamma_productl (x_adj, 0, n, &eps);
      return (__ieee754_expl (__ieee754_lgammal_r (x_adj, &local_signgam))
	      * prod * (1.0L + eps));
    }
  else
    {
      long double eps = 0;
      long double x_eps = 0;
      long double x_adj = x;
      long double prod = 1;
      if (x < 24.0L)
	{
	  /* Adjust into the range for applying Stirling's
	     approximation.  */
	  long double n = __ceill (24.0L - x);
	  x_adj = x + n;
	  x_eps = (x - (x_adj - n));
	  prod = __gamma_productl (x_adj - n, x_eps, n, &eps);
	}
      /* The result is now gamma (X_ADJ + X_EPS) / (PROD * (1 + EPS)).
	 Compute gamma (X_ADJ + X_EPS) using Stirling's approximation,
	 starting by computing pow (X_ADJ, X_ADJ) with a power of 2
	 factored out.  */
      long double exp_adj = -eps;
      long double x_adj_int = __roundl (x_adj);
      long double x_adj_frac = x_adj - x_adj_int;
      int x_adj_log2;
      long double x_adj_mant = __frexpl (x_adj, &x_adj_log2);
      if (x_adj_mant < M_SQRT1_2l)
	{
	  x_adj_log2--;
	  x_adj_mant *= 2.0L;
	}
      *exp2_adj = x_adj_log2 * (int) x_adj_int;
      long double ret = (__ieee754_powl (x_adj_mant, x_adj)
			 * __ieee754_exp2l (x_adj_log2 * x_adj_frac)
			 * __ieee754_expl (-x_adj)
			 * __ieee754_sqrtl (2 * M_PIl / x_adj)
			 / prod);
      exp_adj += x_eps * __ieee754_logl (x_adj);
      long double bsum = gamma_coeff[NCOEFF - 1];
      long double x_adj2 = x_adj * x_adj;
      for (size_t i = 1; i <= NCOEFF - 1; i++)
	bsum = bsum / x_adj2 + gamma_coeff[NCOEFF - 1 - i];
      exp_adj += bsum / x_adj;
      return ret + ret * __expm1l (exp_adj);
    }
}