static double
neg_gam(double x)
{
int sgn = 1;
struct Double lg, lsine;
double y, z;
y = ceil(x);
if (y == x) /* Negative integer. */
if (_IEEE)
return ((x - x) / zero);
else
return (infnan(ERANGE));
z = y - x;
if (z > 0.5)
z = one - z;
y = 0.5 * y;
if (y == ceil(y))
sgn = -1;
if (z < .25)
z = sin(M_PI*z);
else
z = cos(M_PI*(0.5-z));
/* Special case: G(1-x) = Inf; G(x) may be nonzero. */
if (x < -170) {
if (x < -190)
return ((double)sgn*tiny*tiny);
y = one - x; /* exact: 128 < |x| < 255 */
lg = large_gam(y);
lsine = __log__D(M_PI/z); /* = TRUNC(log(u)) + small */
lg.a -= lsine.a; /* exact (opposite signs) */
lg.b -= lsine.b;
y = -(lg.a + lg.b);
z = (y + lg.a) + lg.b;
y = __exp__D(y, z);
if (sgn < 0) y = -y;
return (y);
}
y = one-x;
if (one-y == x)
y = tgamma(y);
else /* 1-x is inexact */
y = -x*tgamma(-x);
if (sgn < 0) y = -y;
return (M_PI / (y*z));
}
double
tgamma(double x)
{
struct Double u;
if (x >= 6) {
if(x > 171.63)
return (x / zero);
u = large_gam(x);
return(__exp__D(u.a, u.b));
} else if (x >= 1.0 + LEFT + x0)
return (small_gam(x));
else if (x > 1.e-17)
return (smaller_gam(x));
else if (x > -1.e-17) {
if (x != 0.0)
u.a = one - tiny; /* raise inexact */
return (one/x);
} else if (!finite(x))
return (x - x); /* x is NaN or -Inf */
else
return (neg_gam(x));
}
double
tgamma(double x)
{
struct Double u;
#if _IEEE
endian = (*(int *) &one) ? 1 : 0;
#endif
if (x >= 6) {
if(x > 171.63)
if (_IEEE)
return (x/zero);
else
return (infnan(ERANGE));
u = large_gam(x);
return(__exp__D(u.a, u.b));
} else if (x >= 1.0 + LEFT + x0)
return (small_gam(x));
else if (x > 1.e-17)
return (smaller_gam(x));
else if (x > -1.e-17) {
if (x == 0.0) {
if (!_IEEE)
return (infnan(ERANGE));
} else {
u.a = one - tiny; /* raise inexact */
}
return (one/x);
} else if (!finite(x)) {
if (_IEEE) /* x = NaN, -Inf */
return (x - x);
else
return (infnan(EDOM));
} else
return (neg_gam(x));
}
double
erfc(double x)
{
double R, S, P, Q, s, ax, y, z, r;
if (!finite(x)) {
if (isnan(x)) /* erfc(NaN) = NaN */
return(x);
else if (x > 0) /* erfc(+-inf)=0,2 */
return 0.0;
else
return 2.0;
}
if ((ax = x) < 0)
ax = -ax;
if (ax < .84375) { /* |x|<0.84375 */
if (ax < 1.38777878078144568e-17) /* |x|<2**-56 */
return one-x;
y = x*x;
r = y*(p1+y*(p2+y*(p3+y*(p4+y*(p5+
y*(p6+y*(p7+y*(p8+y*(p9+y*p10)))))))));
if (ax < .0625) { /* |x|<2**-4 */
return (one-(x+x*(p0+r)));
} else {
r = x*(p0+r);
r += (x-half);
return (half - r);
}
}
if (ax < 1.25) { /* 0.84375 <= |x| < 1.25 */
s = ax-one;
P = pa0+s*(pa1+s*(pa2+s*(pa3+s*(pa4+s*(pa5+s*pa6)))));
Q = one+s*(qa1+s*(qa2+s*(qa3+s*(qa4+s*(qa5+s*qa6)))));
if (x>=0) {
z = one-c; return z - P/Q;
} else {
z = c+P/Q; return one+z;
}
}
if (ax >= 28) /* Out of range */
if (x>0)
return (tiny*tiny);
else
return (two-tiny);
z = ax;
TRUNC(z);
y = z - ax; y *= (ax+z);
z *= -z; /* Here z + y = -x^2 */
s = one/(-z-y); /* 1/(x*x) */
if (ax >= 4) { /* 6 <= ax */
R = s*(rd1+s*(rd2+s*(rd3+s*(rd4+s*(rd5+
s*(rd6+s*(rd7+s*(rd8+s*(rd9+s*(rd10
+s*(rd11+s*(rd12+s*rd13))))))))))));
y += rd0;
} else if (ax >= 2) {
R = rb0+s*(rb1+s*(rb2+s*(rb3+s*(rb4+s*(rb5+
s*(rb6+s*(rb7+s*(rb8+s*(rb9+s*rb10)))))))));
S = one+s*(sb1+s*(sb2+s*sb3));
y += R/S;
R = -.5*s;
} else {
R = rc0+s*(rc1+s*(rc2+s*(rc3+s*(rc4+s*(rc5+
s*(rc6+s*(rc7+s*(rc8+s*(rc9+s*rc10)))))))));
S = one+s*(sc1+s*(sc2+s*sc3));
y += R/S;
R = -.5*s;
}
/* return exp(-x^2 - lsqrtPI_hi + R + y)/x; */
s = ((R + y) - lsqrtPI_hi) + z;
y = (((z-s) - lsqrtPI_hi) + R) + y;
r = __exp__D(s, y)/x;
if (x>0)
return r;
else
return two-r;
}
