double
__jn( int n, double x )
{
int i;
double a, b, temp;
double z;
double zsq, t;
double result;
#ifdef _CALL_MATHERR
struct exception exstruct;
#endif
if( x != x )
{
/* arg is NaN */
#ifdef _CALL_MATHERR
exstruct.type = DOMAIN;
exstruct.name = "jn";
exstruct.arg1 = n;
exstruct.arg2 = x;
exstruct.retval = Qnan.d;
if ( matherr( &exstruct ) == 0 )
{
fprintf(stderr, "domain error in jn\n");
SETERRNO(EDOM);
}
return ( exstruct.retval );
#else
NAN_SETERRNO(EDOM);
return ( Qnan.d );
#endif
}
if ( fabs(x) >= Twop49.d )
{
#ifdef _CALL_MATHERR
exstruct.type = TLOSS;
exstruct.name = "jn";
exstruct.arg1 = n;
exstruct.arg2 = x;
exstruct.retval = 0.0;
if ( matherr( &exstruct ) == 0 )
{
fprintf(stderr, "total loss of significance \
error in jn\n");
SETERRNO(ERANGE);
}
double
__erfc( double arg )
{
double argsq;
double z;
double zsq;
double s, f, f1;
double n, d;
double result;
#ifdef _CALL_MATHERR
struct exception exstruct;
#endif
if( arg != arg )
{
/* arg is a NaN */
#ifdef _CALL_MATHERR
exstruct.type = DOMAIN;
exstruct.name = "erfc";
exstruct.arg1 = arg;
exstruct.retval = Qnan.d;
if ( matherr( &exstruct ) == 0 )
{
fprintf(stderr, "domain error in erfc\n");
SETERRNO(EDOM);
}
return ( exstruct.retval );
#else
NAN_SETERRNO(EDOM);
return ( Qnan.d );
#endif
}
if ( arg < Llimit2.d )
return ( 2.0 );
if ( arg <= -2.0 )
return ( 2.0 - __erfc(-arg) );
if ( arg < 0.25 )
return( 1.0 - __erf(arg) );
result = 0.0; /* default */
if ( arg < 0.75 )
{
argsq = arg*arg;
n = (((((p1[6].d*argsq + p1[5].d)*argsq + p1[4].d)*argsq +
p1[3].d)*argsq + p1[2].d)*argsq + p1[1].d)*
argsq + p1[0].d;
d = ((((q1[5].d*argsq + q1[4].d)*argsq + q1[3].d)*argsq +
q1[2].d)*argsq + q1[1].d)*argsq + q1[0].d;
return ( 0.5 + ((0.5 - arg) - arg*n/d) );
}
else if ( arg < 1.25 )
{
z = arg - 1.0;
n = ((((((p2[8].d*z + p2[7].d)*z + p2[6].d)*z + p2[5].d)*z +
p2[4].d)*z + p2[3].d)*z + p2[2].d)*z;
d = ((((((q2[7].d*z + q2[6].d)*z + q2[5].d)*z + q2[4].d)*z +
q2[3].d)*z + q2[2].d)*z + q2[1].d)*z + q2[0].d;
return ( p2[0].d - n/d );
}
else if ( arg < 1.75 )
{
z = arg - 1.5;
n = (((((p3[7].d*z + p3[6].d)*z +
p3[5].d)*z + p3[4].d)*z + p3[3].d)*z + p3[2].d)*z;
d = (((((q3[6].d*z + q3[5].d)*z + q3[4].d)*z +
q3[3].d)*z + q3[2].d)*z + q3[1].d)*z + q3[0].d;
return ( p3[0].d - n/d );
}
else if ( arg < 2.0 )
{
z = arg - 1.875;
n = ((((p4[6].d*z + p4[5].d)*z +
p4[4].d)*z + p4[3].d)*z + p4[2].d)*z;
d = ((((q4[5].d*z + q4[4].d)*z + q4[3].d)*z +
q4[2].d)*z + q4[1].d)*z + q4[0].d;
return ( p4[0].d - n/d );
}
else if ( arg <= Ulimit2.d )
{
zsq = 1.0/(arg*arg);
n = (((((((p5[7].d*zsq + p5[6].d)*zsq + p5[5].d)*zsq +
p5[4].d)*zsq + p5[3].d)*zsq + p5[2].d)*zsq + p5[1].d)*zsq +
p5[0].d)*zsq;
d = (((((((q5[8].d*zsq + q5[7].d)*zsq + q5[6].d)*zsq + q5[5].d)*zsq +
q5[4].d)*zsq + q5[3].d)*zsq + q5[2].d)*zsq + q5[1].d)*zsq +
q5[0].d;
s = (float)arg;
/* Now the result is exp(-arg*arg)*(1.0 + n/d)/(arg*sqrt(pi)) */
if ( arg <= 26.0 )
{
/* To avoid loss of precision in computing exp(-arg*arg),
* rewrite -arg*arg as -s*s + s*(s-arg) + arg*(s-arg)
* Note that -s*s is exact.
*/
/* Compute the second exp in the expression locally,
* since the argument is small.
*/
f1 = __exp(-s*s);
f = f1 + f1*poly(s*(s-arg) + arg*(s-arg));
return ( Rsqrtpi.d*(f + f*n/d)/arg );
}
else
{
/* Beyond 26.0, we have to worry about underflow in
* computing exp(-arg*arg); instead we'll compute
* exp(-arg*arg/2.0) and multiply by it twice.
* The result here may underflow, depending on
* whether the processor supports denormals or not.
*/
s = (float)arg;
f1 = __exp(-0.5*s*s);
f = f1 + f1*poly(0.5*s*(s-arg) + 0.5*arg*(s-arg));
result = Rsqrtpi.d*(f + f*n/d)/arg*f;
}
}
if ( result == 0.0 )
#ifdef _CALL_MATHERR
{
exstruct.type = UNDERFLOW;
exstruct.name = "erfc";
exstruct.arg1 = arg;
exstruct.retval = 0.0;
if ( matherr( &exstruct ) == 0 )
{
fprintf(stderr, "underflow error in erfc\n");
SETERRNO(ERANGE);
}
return ( exstruct.retval );
}
#else
{
SETERRNO(ERANGE);
return ( 0.0 );
}
#endif
return ( result );
}
double
__erf( double arg )
{
double __erfc(double);
double sign;
double argsq;
double d, n, z;
#ifdef _CALL_MATHERR
struct exception exstruct;
#endif
if( arg != arg )
{
/* arg is a NaN */
#ifdef _CALL_MATHERR
exstruct.type = DOMAIN;
exstruct.name = "erf";
exstruct.arg1 = arg;
exstruct.retval = Qnan.d;
if ( matherr( &exstruct ) == 0 )
{
fprintf(stderr, "domain error in erf\n");
SETERRNO(EDOM);
}
return ( exstruct.retval );
#else
NAN_SETERRNO(EDOM);
return ( Qnan.d );
#endif
}
sign = 1.0;
if( arg < 0. )
{
arg = -arg;
sign = -1.0;
}
if ( arg < 0.75 )
{
argsq = arg*arg;
n = (((((p1[6].d*argsq + p1[5].d)*argsq + p1[4].d)*argsq +
p1[3].d)*argsq + p1[2].d)*argsq + p1[1].d)*
argsq + p1[0].d;
d = ((((q1[5].d*argsq + q1[4].d)*argsq + q1[3].d)*argsq +
q1[2].d)*argsq + q1[1].d)*argsq + q1[0].d;
return ( sign*(arg + arg*n/d) );
}
else if ( arg < 1.25 )
{
z = arg - 1.0;
n = ((((((p2[8].d*z + p2[7].d)*z + p2[6].d)*z + p2[5].d)*z +
p2[4].d)*z + p2[3].d)*z + p2[2].d)*z;
d = ((((((q2[7].d*z + q2[6].d)*z + q2[5].d)*z + q2[4].d)*z +
q2[3].d)*z + q2[2].d)*z + q2[1].d)*z + q2[0].d;
return ( sign*(p2[1].d + n/d) );
}
else if ( arg < 1.75 )
{
z = arg - 1.5;
n = (((((p3[7].d*z + p3[6].d)*z +
p3[5].d)*z + p3[4].d)*z + p3[3].d)*z + p3[2].d)*z;
d = (((((q3[6].d*z + q3[5].d)*z + q3[4].d)*z +
q3[3].d)*z + q3[2].d)*z + q3[1].d)*z + q3[0].d;
return ( sign*(p3[1].d + n/d) );
}
else if ( arg < 2.0 )
{
z = arg - 1.875;
n = ((((p4[6].d*z + p4[5].d)*z +
p4[4].d)*z + p4[3].d)*z + p4[2].d)*z;
d = ((((q4[5].d*z + q4[4].d)*z + q4[3].d)*z +
q4[2].d)*z + q4[1].d)*z + q4[0].d;
return ( sign*(p4[1].d + n/d) );
}
if ( fabs(arg) <= Ulimit1.d )
return( sign*(1.0 - __erfc(arg)) );
else
return ( sign );
}
float
__log1pf( float x )
{
int xpt;
float u, v;
double u1;
float q;
float result;
int m, n;
float y, f, F;
float l_lead, l_trail;
int j, k;
float twopnegm;
float md;
#ifdef _CALL_MATHERR
struct exception exstruct;
#endif
if ( x != x )
{
/* x is a NaN; return a quiet NaN */
#ifdef _CALL_MATHERR
exstruct.type = DOMAIN;
exstruct.name = "log1pf";
exstruct.arg1 = x;
exstruct.retval = Qnan.f;
if ( matherr( &exstruct ) == 0 )
{
fprintf(stderr, "domain error in log1pf\n");
SETERRNO(EDOM);
}
return ( exstruct.retval );
#else
NAN_SETERRNO(EDOM);
return ( Qnan.f );
#endif
}
if ( (T1.f < x) && (x < T2.f) )
{
/* exp(-1/16) < 1 + x < exp(1/16) */
FLT2INT(x, xpt); /* copy arg to an integer */
xpt >>= MANTWIDTH; /* shift off mantissa */
xpt &= 0xff;
if ( xpt >= 0x67 )
{
/* |x| >= 2^(-24) */
u1 = x/(2.0 + x);
u1 = u1 + u1;
u = u1;
v = u1*u1;
q = (P[2].f*v + P[1].f)*(v*u);
result = u1 + q;
return ( result );
}
return ( x );
}
double
__log1p( double x )
{
#ifdef _32BIT_MACHINE
int xpt;
int k, m, n;
#else
long long xpt;
long long k, m, n;
#endif
int j;
double g, u, v, x1, x2;
double u1, u2;
double q;
double twopnegm;
double result;
double y, f, F;
double l_lead, l_trail;
#ifdef _CALL_MATHERR
struct exception exstruct;
#endif
if ( x != x )
{
/* x is a NaN; return a quiet NaN */
#ifdef _CALL_MATHERR
exstruct.type = DOMAIN;
exstruct.name = "log1p";
exstruct.arg1 = x;
exstruct.retval = Qnan.d;
if ( matherr( &exstruct ) == 0 )
{
fprintf(stderr, "domain error in log1p\n");
SETERRNO(EDOM);
}
return ( exstruct.retval );
#else
NAN_SETERRNO(EDOM);
return ( Qnan.d );
#endif
}
if ( (T1.d < x) && (x < T2.d) )
{
#ifdef _32BIT_MACHINE
DBLHI2INT(x, xpt); /* copy MSW of arg to an int */
#else
DBL2LL(x, xpt); /* copy arg to an int */
#endif
xpt >>= DMANTWIDTH; /* shift off mantissa */
xpt &= 0x7ff;
if ( xpt >= 0x3ca )
{
/* |x| >= 2^(-53) */
g = 1.0/(2.0 + x);
u = x*g;
u = u + u;
v = u*u;
q = (((Q[4].d*v + Q[3].d)*v + Q[2].d)*v +
Q[1].d)*v*u;
u1 = (float)u; /* round u to 24 bits */
x1 = (float)x; /* round x to 24 bits */
x2 = x - x1;
u2 = x - u1;
u2 = u2 + u2;
u2 = ((u2 - u1*x1) - u1*x2)*g;
result = u1 + (u2 + q);
return ( result );
}
return ( x );
}
