double
y1(double x)
{
double z, s, c, ss, cc, u, v;
/* if Y1(NaN) is NaN, Y1(-inf) is NaN, Y1(inf) is 0 */
if (!finite(x)) {
if (!_IEEE) return (infnan(EDOM));
else if (x < 0)
return(zero/zero);
else if (x > 0)
return (0);
else
return(x);
}
if (x <= 0) {
if (_IEEE && x == 0) return -one/zero;
else if(x == 0) return(infnan(-ERANGE));
else if(_IEEE) return (zero/zero);
else return(infnan(EDOM));
}
if (x >= 2) { /* |x| >= 2.0 */
s = sin(x);
c = cos(x);
ss = -s-c;
cc = s-c;
if (x < .5 * DBL_MAX) { /* make sure x+x not overflow */
z = cos(x+x);
if ((s*c)>zero) cc = z/ss;
else ss = z/cc;
}
/* y1(x) = sqrt(2/(pi*x))*(p1(x)*sin(x0)+q1(x)*cos(x0))
* where x0 = x-3pi/4
* Better formula:
* cos(x0) = cos(x)cos(3pi/4)+sin(x)sin(3pi/4)
* = 1/sqrt(2) * (sin(x) - cos(x))
* sin(x0) = sin(x)cos(3pi/4)-cos(x)sin(3pi/4)
* = -1/sqrt(2) * (cos(x) + sin(x))
* To avoid cancellation, use
* sin(x) +- cos(x) = -cos(2x)/(sin(x) -+ cos(x))
* to compute the worse one.
*/
if (_IEEE && x>two_129) {
z = (invsqrtpi*ss)/sqrt(x);
} else {
u = pone(x); v = qone(x);
z = invsqrtpi*(u*ss+v*cc)/sqrt(x);
}
return z;
}
if (x <= two_m54) { /* x < 2**-54 */
return (-tpi/x);
}
z = x*x;
u = u0[0]+z*(u0[1]+z*(u0[2]+z*(u0[3]+z*u0[4])));
v = one+z*(v0[0]+z*(v0[1]+z*(v0[2]+z*(v0[3]+z*v0[4]))));
return (x*(u/v) + tpi*(j1(x)*log(x)-one/x));
}
double
log1p(double x)
{
static const double zero=0.0, negone= -1.0, one=1.0,
half=1.0/2.0, small=1.0E-20; /* 1+small == 1 */
double z,s,t,c;
int k;
#if !defined(__vax__)&&!defined(tahoe)
if(x!=x) return(x); /* x is NaN */
#endif /* !defined(__vax__)&&!defined(tahoe) */
if(finite(x)) {
if( x > negone ) {
/* argument reduction */
if(copysign(x,one)<small) return(x);
k=logb(one+x); z=scalb(x,-k); t=scalb(one,-k);
if(z+t >= sqrt2 )
{ k += 1 ; z *= half; t *= half; }
t += negone; x = z + t;
c = (t-x)+z ; /* correction term for x */
/* compute log(1+x) */
s = x/(2+x); t = x*x*half;
c += (k*ln2lo-c*x);
z = c+s*(t+__log__L(s*s));
x += (z - t) ;
return(k*ln2hi+x);
}
/* end of if (x > negone) */
else {
#if defined(__vax__)||defined(tahoe)
if ( x == negone )
return (infnan(-ERANGE)); /* -INF */
else
return (infnan(EDOM)); /* NaN */
#else /* defined(__vax__)||defined(tahoe) */
/* x = -1, return -INF with signal */
if ( x == negone ) return( negone/zero );
/* negative argument for log, return NaN with signal */
else return ( zero / zero );
#endif /* defined(__vax__)||defined(tahoe) */
}
}
/* end of if (finite(x)) */
/* log(-INF) is NaN */
else if(x<0)
return(zero/zero);
/* log(+INF) is INF */
else return(x);
}
double
yn(int n, double x)
{
int i, sign;
double a, b, temp;
/* Y(n,NaN), Y(n, x < 0) is NaN */
if (x <= 0 || isnan(x))
if (_IEEE && x < 0) return zero/zero;
else if (x < 0) return (infnan(EDOM));
else if (_IEEE) return -one/zero;
else return(infnan(-ERANGE));
else if (!finite(x)) return(0);
sign = 1;
if (n<0){
n = -n;
sign = 1 - ((n&1)<<2);
}
if (n == 0) return(y0(x));
if (n == 1) return(sign*y1(x));
if(_IEEE && x >= 8.148143905337944345e+090) { /* x > 2**302 */
/* (x >> n**2)
* Jn(x) = cos(x-(2n+1)*pi/4)*sqrt(2/x*pi)
* Yn(x) = sin(x-(2n+1)*pi/4)*sqrt(2/x*pi)
* Let s=sin(x), c=cos(x),
* xn=x-(2n+1)*pi/4, sqt2 = sqrt(2),then
*
* n sin(xn)*sqt2 cos(xn)*sqt2
* ----------------------------------
* 0 s-c c+s
* 1 -s-c -c+s
* 2 -s+c -c-s
* 3 s+c c-s
*/
switch (n&3) {
case 0: temp = sin(x)-cos(x); break;
case 1: temp = -sin(x)-cos(x); break;
case 2: temp = -sin(x)+cos(x); break;
case 3: temp = sin(x)+cos(x); break;
}
b = invsqrtpi*temp/sqrt(x);
} else {
a = y0(x);
b = y1(x);
/* quit if b is -inf */
for (i = 1; i < n && !finite(b); i++){
temp = b;
b = ((double)(i+i)/x)*b - a;
a = temp;
}
}
if (!_IEEE && !finite(b))
return (infnan(-sign * ERANGE));
return ((sign > 0) ? b : -b);
}
static double
large_lgam(double x)
{
double z, p, x1;
struct Double t, u, v;
u = __log__D(x);
u.a -= 1.0;
if (x > 1e15) {
v.a = x - 0.5;
TRUNC(v.a);
v.b = (x - v.a) - 0.5;
t.a = u.a*v.a;
t.b = x*u.b + v.b*u.a;
if (_IEEE == 0 && !finite(t.a))
return(infnan(ERANGE));
return(t.a + t.b);
}
x1 = 1./x;
z = x1*x1;
p = pb0+z*(pb1+z*(pb2+z*(pb3+z*(pb4+z*(pb5+z*(pb6+z*pb7))))));
/* error in approximation = 2.8e-19 */
p = p*x1; /* error < 2.3e-18 absolute */
/* 0 < p < 1/64 (at x = 5.5) */
v.a = x = x - 0.5;
TRUNC(v.a); /* truncate v.a to 26 bits. */
v.b = x - v.a;
t.a = v.a*u.a; /* t = (x-.5)*(log(x)-1) */
t.b = v.b*u.a + x*u.b;
t.b += p; t.b += lns2pi; /* return t + lns2pi + p */
return (t.a + t.b);
}
__pure double
lgamma(double x)
{
double r;
int signgam = 1;
#if _IEEE
endian = ((*(int *) &one)) ? 1 : 0;
#endif
if (!finite(x))
if (_IEEE)
return (x+x);
else return (infnan(EDOM));
if (x > 6 + RIGHT) {
r = large_lgam(x);
return (r);
} else if (x > 1e-16)
return (small_lgam(x));
else if (x > -1e-16) {
if (x < 0) {
signgam = -1;
x = -x;
}
return (-log(x));
} else
return (neg_lgam(x));
}
static double
neg(double arg)
{
double t;
arg = -arg;
/*
* to see if arg were a true integer, the old code used the
* mathematically correct observation:
* sin(n*pi) = 0 <=> n is an integer.
* but in finite precision arithmetic, sin(n*PI) will NEVER
* be zero simply because n*PI is a rational number. hence
* it failed to work with our newer, more accurate sin()
* which uses true pi to do the argument reduction...
* temp = sin(pi*arg);
*/
t = floor(arg);
if (arg - t > 0.5e0)
t += 1.e0; /* t := integer nearest arg */
#if defined(vax)||defined(tahoe)
if (arg == t) {
return(infnan(ERANGE)); /* +INF */
}
#endif /* defined(vax)||defined(tahoe) */
signgam = (int) (t - 2*floor(t/2)); /* signgam = 1 if t was odd, */
/* 0 if t was even */
signgam = signgam - 1 + signgam; /* signgam = 1 if t was odd, */
/* -1 if t was even */
t = arg - t; /* -0.5 <= t <= 0.5 */
if (t < 0.e0) {
t = -t;
signgam = -signgam;
}
return(-log(arg*pos(arg)*sin(pi*t)/pi));
}
/* __pure double */
double
lgamma(double x)
{
double r;
signgam = 1;
endian = ((*(int *) &one)) ? 1 : 0;
if (!finite(x)) {
if (_IEEE)
return (x+x);
else return (infnan(EDOM));
}
if (x > 6 + RIGHT) {
r = large_lgam(x);
return (r);
} else if (x > 1e-16) {
return (small_lgam(x));
} else if (x > -1e-16) {
if (x < 0)
signgam = -1, x = -x;
return (-log(x));
} else {
return (neg_lgam(x));
}
}
static double
neg_lgam(double x)
{
int xi;
double y, z, zero = 0.0;
/* avoid destructive cancellation as much as possible */
if (x > -170) {
xi = x;
if (xi == x)
if (_IEEE)
return(one/zero);
else
return(infnan(ERANGE));
y = tgamma(x);
if (y < 0) {
y = -y;
signgam = -1;
}
return (log(y));
}
z = floor(x + .5);
if (z == x) { /* convention: G(-(integer)) -> +Inf */
if (_IEEE)
return (one/zero);
else
return (infnan(ERANGE));
}
y = .5*ceil(x);
if (y == ceil(y))
signgam = -1;
x = -x;
z = fabs(x + z); /* 0 < z <= .5 */
if (z < .25)
z = sin(M_PI*z);
else
z = cos(M_PI*(0.5-z));
z = log(M_PI/(z*x));
y = large_lgam(x);
return (z - y);
}
double
atanh(double x)
{
double z;
z = copysign(0.5,x);
x = copysign(x,1.0);
#if defined(__vax__)
if (x == 1.0) {
return(copysign(1.0,z)*infnan(ERANGE)); /* sign(x)*INF */
}
#endif /* defined(__vax__) */
x = x/(1.0-x);
return( z*log1p(x+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));
}
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
log(double x)
{
int m, j;
double F;
double f;
double g;
double q;
double u;
double u2;
double v;
static double const zero = 0.0;
static double const one = 1.0;
volatile double u1;
/* Catch special cases */
if (x <= 0) {
if (_IEEE && x == zero) /* log(0) = -Inf */
return (-one/zero);
else if (_IEEE) /* log(neg) = NaN */
return (zero/zero);
else if (x == zero) /* NOT REACHED IF _IEEE */
return (infnan(-ERANGE));
else
return (infnan(EDOM));
} else if (!finite(x)) {
if (_IEEE) /* x = NaN, Inf */
return (x+x);
else
return (infnan(ERANGE));
}
/* Argument reduction: 1 <= g < 2; x/2^m = g; */
/* y = F*(1 + f/F) for |f| <= 2^-8 */
m = logb(x);
g = ldexp(x, -m);
if (_IEEE && m == -1022) {
j = logb(g), m += j;
g = ldexp(g, -j);
}
j = N*(g-1) + .5;
F = (1.0/N) * j + 1; /* F*128 is an integer in [128, 512] */
f = g - F;
/* Approximate expansion for log(1+f/F) ~= u + q */
g = 1/(2*F+f);
u = 2*f*g;
v = u*u;
q = u*v*(A1 + v*(A2 + v*(A3 + v*A4)));
/* case 1: u1 = u rounded to 2^-43 absolute. Since u < 2^-8,
* u1 has at most 35 bits, and F*u1 is exact, as F has < 8 bits.
* It also adds exactly to |m*log2_hi + log_F_head[j] | < 750
*/
if (m | j)
u1 = u + 513, u1 -= 513;
/* case 2: |1-x| < 1/256. The m- and j- dependent terms are zero;
* u1 = u to 24 bits.
*/
else
u1 = u, TRUNC(u1);
u2 = (2.0*(f - F*u1) - u1*f) * g;
/* u1 + u2 = 2f/(2F+f) to extra precision. */
/* log(x) = log(2^m*F*(1+f/F)) = */
/* (m*log2_hi+logF_head[j]+u1) + (m*log2_lo+logF_tail[j]+q); */
/* (exact) + (tiny) */
u1 += m*logF_head[N] + logF_head[j]; /* exact */
u2 = (u2 + logF_tail[j]) + q; /* tiny */
u2 += logF_tail[N]*m;
return (u1 + u2);
}
