DOUBLE
FMOD (DOUBLE x, DOUBLE y)
{
if (isfinite (x) && isfinite (y) && y != L_(0.0))
{
if (x == L_(0.0))
/* Return x, regardless of the sign of y. */
return x;
{
int negate = ((!signbit (x)) ^ (!signbit (y)));
/* Take the absolute value of x and y. */
x = FABS (x);
y = FABS (y);
/* Trivial case that requires no computation. */
if (x < y)
return (negate ? - x : x);
{
int yexp;
DOUBLE ym;
DOUBLE y1;
DOUBLE y0;
int k;
DOUBLE x2;
DOUBLE x1;
DOUBLE x0;
/* Write y = 2^yexp * (y1 * 2^-LIMB_BITS + y0 * 2^-(2*LIMB_BITS))
where y1 is an integer, 2^(LIMB_BITS-1) <= y1 < 2^LIMB_BITS,
y1 has at most LIMB_BITS bits,
0 <= y0 < 2^LIMB_BITS,
y0 has at most (MANT_DIG + 1) / 2 bits. */
ym = FREXP (y, &yexp);
ym = ym * TWO_LIMB_BITS;
y1 = TRUNC (ym);
y0 = (ym - y1) * TWO_LIMB_BITS;
/* Write
x = 2^(yexp+(k-3)*LIMB_BITS)
* (x2 * 2^(2*LIMB_BITS) + x1 * 2^LIMB_BITS + x0)
where x2, x1, x0 are each integers >= 0, < 2^LIMB_BITS. */
{
int xexp;
DOUBLE xm = FREXP (x, &xexp);
/* Since we know x >= y, we know xexp >= yexp. */
xexp -= yexp;
/* Compute k = ceil(xexp / LIMB_BITS). */
k = (xexp + LIMB_BITS - 1) / LIMB_BITS;
/* Note: (k - 1) * LIMB_BITS + 1 <= xexp <= k * LIMB_BITS. */
/* Note: 0.5 <= xm < 1.0. */
xm = LDEXP (xm, xexp - (k - 1) * LIMB_BITS);
/* Note: Now xm < 2^(xexp - (k - 1) * LIMB_BITS) <= 2^LIMB_BITS
and xm >= 0.5 * 2^(xexp - (k - 1) * LIMB_BITS) >= 1.0
and xm has at most MANT_DIG <= 2*LIMB_BITS+1 bits. */
x2 = TRUNC (xm);
x1 = (xm - x2) * TWO_LIMB_BITS;
/* Split off x0 from x1 later. */
}
/* Test whether [x2,x1,0] >= 2^LIMB_BITS * [y1,y0]. */
if (x2 > y1 || (x2 == y1 && x1 >= y0))
{
/* Subtract 2^LIMB_BITS * [y1,y0] from [x2,x1,0]. */
x2 -= y1;
x1 -= y0;
if (x1 < L_(0.0))
{
if (!(x2 >= L_(1.0)))
abort ();
x2 -= L_(1.0);
x1 += TWO_LIMB_BITS;
}
}
/* Split off x0 from x1. */
{
DOUBLE x1int = TRUNC (x1);
x0 = TRUNC ((x1 - x1int) * TWO_LIMB_BITS);
x1 = x1int;
}
for (; k > 0; k--)
{
/* Multiprecision division of the limb sequence [x2,x1,x0]
by [y1,y0]. */
/* Here [x2,x1,x0] < 2^LIMB_BITS * [y1,y0]. */
/* The first guess takes into account only [x2,x1] and [y1].
By Knuth's theorem, we know that
q* = min (floor ([x2,x1] / [y1]), 2^LIMB_BITS - 1)
and
q = floor ([x2,x1,x0] / [y1,y0])
are not far away:
q* - 2 <= q <= q* + 1.
Proof:
a) q* * y1 <= floor ([x2,x1] / [y1]) * y1 <= [x2,x1].
Hence
[x2,x1,x0] - q* * [y1,y0]
= 2^LIMB_BITS * ([x2,x1] - q* * [y1]) + x0 - q* * y0
>= x0 - q* * y0
>= - q* * y0
> - 2^(2*LIMB_BITS)
>= - 2 * [y1,y0]
So
[x2,x1,x0] > (q* - 2) * [y1,y0].
b) If q* = floor ([x2,x1] / [y1]), then
[x2,x1] < (q* + 1) * y1
Hence
[x2,x1,x0] - q* * [y1,y0]
= 2^LIMB_BITS * ([x2,x1] - q* * [y1]) + x0 - q* * y0
<= 2^LIMB_BITS * (y1 - 1) + x0 - q* * y0
<= 2^LIMB_BITS * (2^LIMB_BITS-2) + (2^LIMB_BITS-1) - 0
< 2^(2*LIMB_BITS)
<= 2 * [y1,y0]
So
[x2,x1,x0] < (q* + 2) * [y1,y0].
and so
q < q* + 2
which implies
q <= q* + 1.
In the other case, q* = 2^LIMB_BITS - 1. Then trivially
q < 2^LIMB_BITS = q* + 1.
We know that floor ([x2,x1] / [y1]) >= 2^LIMB_BITS if and
only if x2 >= y1. */
DOUBLE q =
(x2 >= y1
? TWO_LIMB_BITS - L_(1.0)
: TRUNC ((x2 * TWO_LIMB_BITS + x1) / y1));
if (q > L_(0.0))
{
/* Compute
[x2,x1,x0] - q* * [y1,y0]
= 2^LIMB_BITS * ([x2,x1] - q* * [y1]) + x0 - q* * y0. */
DOUBLE q_y1 = q * y1; /* exact, at most 2*LIMB_BITS bits */
DOUBLE q_y1_1 = TRUNC (q_y1 * TWO_LIMB_BITS_INVERSE);
DOUBLE q_y1_0 = q_y1 - q_y1_1 * TWO_LIMB_BITS;
DOUBLE q_y0 = q * y0; /* exact, at most MANT_DIG bits */
DOUBLE q_y0_1 = TRUNC (q_y0 * TWO_LIMB_BITS_INVERSE);
DOUBLE q_y0_0 = q_y0 - q_y0_1 * TWO_LIMB_BITS;
x2 -= q_y1_1;
x1 -= q_y1_0;
x1 -= q_y0_1;
x0 -= q_y0_0;
/* Move negative carry from x0 to x1 and from x1 to x2. */
if (x0 < L_(0.0))
{
x0 += TWO_LIMB_BITS;
x1 -= L_(1.0);
}
if (x1 < L_(0.0))
{
x1 += TWO_LIMB_BITS;
x2 -= L_(1.0);
if (x1 < L_(0.0)) /* not sure this can happen */
{
x1 += TWO_LIMB_BITS;
x2 -= L_(1.0);
}
}
if (x2 < L_(0.0))
{
/* Reduce q by 1. */
x1 += y1;
x0 += y0;
/* Move overflow from x0 to x1 and from x1 to x0. */
if (x0 >= TWO_LIMB_BITS)
{
x0 -= TWO_LIMB_BITS;
x1 += L_(1.0);
}
if (x1 >= TWO_LIMB_BITS)
{
x1 -= TWO_LIMB_BITS;
x2 += L_(1.0);
}
if (x2 < L_(0.0))
{
/* Reduce q by 1 again. */
x1 += y1;
x0 += y0;
/* Move overflow from x0 to x1 and from x1 to x0. */
if (x0 >= TWO_LIMB_BITS)
{
x0 -= TWO_LIMB_BITS;
x1 += L_(1.0);
}
if (x1 >= TWO_LIMB_BITS)
{
x1 -= TWO_LIMB_BITS;
x2 += L_(1.0);
}
if (x2 < L_(0.0))
/* Shouldn't happen, because we proved that
q >= q* - 2. */
abort ();
}
}
}
if (x2 > L_(0.0)
|| x1 > y1
|| (x1 == y1 && x0 >= y0))
{
/* Increase q by 1. */
x1 -= y1;
x0 -= y0;
/* Move negative carry from x0 to x1 and from x1 to x2. */
if (x0 < L_(0.0))
{
x0 += TWO_LIMB_BITS;
x1 -= L_(1.0);
}
if (x1 < L_(0.0))
{
x1 += TWO_LIMB_BITS;
x2 -= L_(1.0);
}
if (x2 < L_(0.0))
abort ();
if (x2 > L_(0.0)
|| x1 > y1
|| (x1 == y1 && x0 >= y0))
/* Shouldn't happen, because we proved that
q <= q* + 1. */
abort ();
}
/* Here [x2,x1,x0] < [y1,y0]. */
/* Next round. */
x2 = x1;
#if (MANT_DIG + 1) / 2 > LIMB_BITS /* y0 can have a fractional bit */
x1 = TRUNC (x0);
x0 = (x0 - x1) * TWO_LIMB_BITS;
#else
x1 = x0;
x0 = L_(0.0);
#endif
/* Here [x2,x1,x0] < 2^LIMB_BITS * [y1,y0]. */
}
/* Here k = 0.
The result is
2^(yexp-3*LIMB_BITS)
* (x2 * 2^(2*LIMB_BITS) + x1 * 2^LIMB_BITS + x0). */
{
DOUBLE r =
LDEXP ((x2 * TWO_LIMB_BITS + x1) * TWO_LIMB_BITS + x0,
yexp - 3 * LIMB_BITS);
return (negate ? - r : r);
}
}
}
}
else
{
if (ISNAN (x) || ISNAN (y))
return x + y; /* NaN */
else if (isinf (y))
return x;
else
/* x infinite or y zero */
return NAN;
}
}
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);
}
/*
* Initialize the trajectory tracing module.
* Return: 1 = ok, 0 = error
*/
int init_traj( Context ctx )
{
int i, j;
float lata, lona, latb, lonb, latc, lonc;
float d, us, vs;
float lat0, lon0, lat1, lon1, lat2, lon2;
float midrow, midcol;
int var = 0;
/* the index of any wind variable */
if (ctx->dpy_ctx->TrajU>=0) var = ctx->dpy_ctx->TrajU;
else if (ctx->dpy_ctx->TrajV>=0) var= ctx->dpy_ctx->TrajV;
else if (ctx->dpy_ctx->TrajW>=0) var= ctx->dpy_ctx->TrajW;
/* Compute initial trajectory step and length values */
switch (ctx->Projection) {
case PROJ_GENERIC:
ctx->TrajStep = 1.0;
ctx->TrajLength = 1.0;
break;
default:
/* TODO: verify this is ok: (seems to work) */
/* This is tricky: compute distance, in meters, from left to */
/* right edge of domain. Do it in two steps to prevent "wrap- */
/* around" when difference in longitudes > 180 degrees. */
midrow = (float) ctx->Nr / 2.0;
midcol = (float) ctx->Nc / 2.0;
rowcol_to_latlon( ctx, -1, -1, midrow, 0.0, &lat0, &lon0 );
rowcol_to_latlon( ctx, -1, -1, midrow, midcol, &lat1, &lon1 );
rowcol_to_latlon( ctx, -1, -1, midrow, (float) (ctx->Nc-1), &lat2, &lon2 );
d = earth_distance( lat0, lon0, lat1, lon1 )
+ earth_distance( lat1, lon1, lat2, lon2 );
ctx->TrajStep = TRUNC( (d / 100.0) / 25.0 );
/* the above was: (float) ctx->Elapsed[1] / 2.0;*/
ctx->TrajLength = 5.0 * ctx->TrajStep;
/* the above was: (float) ctx->Elapsed[1]; */
break;
}
/* These values are set by the user through the trajectory widget */
/* They are just multipliers of the internal values TrajStep and */
/* TrajLength: */
ctx->dpy_ctx->UserTrajStep = ctx->dpy_ctx->UserTrajLength = 1.0;
/*
* Compute m/s to boxes/s scaling factors for U and V components
*/
switch (ctx->Projection) {
case PROJ_GENERIC:
/* for a generic projection, we assume U, and V velocities are in */
/* X per second, where X is the same units used for NorthBound, */
/* WestBound, ctx->RowInc, and ctx->ColInc */
us = 1.0 / ctx->ColInc;
vs = -1.0 / ctx->RowInc;
for (i=0;i<ctx->Nr;i++) {
for (j=0;j<ctx->Nc;j++) {
ctx->Uscale[i][j] = us;
ctx->Vscale[i][j] = vs;
}
}
break;
case PROJ_LINEAR:
case PROJ_LAMBERT:
case PROJ_STEREO:
case PROJ_ROTATED:
case PROJ_CYLINDRICAL:
case PROJ_SPHERICAL:
case PROJ_MERCATOR:
for (i=0;i<ctx->Nr;i++) {
for (j=0;j<ctx->Nc;j++) {
float ii = (float) i;
float jj = (float) j;
/* Compute U scale */
if (j==0) {
rowcol_to_latlon( ctx, 0, var, ii, jj, &lata, &lona );
rowcol_to_latlon( ctx, 0, var, ii, jj+1.0, &latb, &lonb );
/* WLH 3-21-97 */
if (lata > 89.9) lata = 89.9;
if (lata < -89.9) lata = -89.9;
if (latb > 89.9) latb = 89.9;
if (latb < -89.9) latb = -89.9;
d = earth_distance( lata, lona, latb, lonb );
}
else if (j==ctx->Nc-1) {
rowcol_to_latlon( ctx, 0, var, ii, jj-1.0, &lata, &lona );
rowcol_to_latlon( ctx, 0, var, ii, jj, &latb, &lonb );
/* WLH 3-21-97 */
if (lata > 89.9) lata = 89.9;
if (lata < -89.9) lata = -89.9;
if (latb > 89.9) latb = 89.9;
if (latb < -89.9) latb = -89.9;
d = earth_distance( lata, lona, latb, lonb );
}
else {
rowcol_to_latlon( ctx, 0, var, ii, jj-1.0, &lata, &lona );
rowcol_to_latlon( ctx, 0, var, ii, jj, &latb, &lonb );
rowcol_to_latlon( ctx, 0, var, ii, jj+1.0, &latc, &lonc );
/* WLH 3-21-97 */
if (lata > 89.9) lata = 89.9;
if (lata < -89.9) lata = -89.9;
if (latb > 89.9) latb = 89.9;
if (latb < -89.9) latb = -89.9;
if (latc > 89.9) latc = 89.9;
if (latc < -89.9) latc = -89.9;
d = (earth_distance( lata,lona, latb,lonb)
+ earth_distance( latb,lonb, latc,lonc)) / 2.0;
}
ctx->Uscale[i][j] = 1.0 / d;
/* Compute V scale */
if (i==0) {
rowcol_to_latlon( ctx, 0, ctx->dpy_ctx->TrajV, ii, jj, &lata, &lona );
rowcol_to_latlon( ctx, 0, ctx->dpy_ctx->TrajV, ii+1.0, jj, &latb, &lonb );
/* WLH 3-21-97 */
if (lata > 89.9) lata = 89.9;
if (lata < -89.9) lata = -89.9;
if (latb > 89.9) latb = 89.9;
if (latb < -89.9) latb = -89.9;
d = earth_distance( lata, lona, latb, lonb );
}
else if (j==ctx->Nc-1) {
rowcol_to_latlon( ctx, 0, ctx->dpy_ctx->TrajV, ii-1.0, jj, &lata, &lona );
rowcol_to_latlon( ctx, 0, ctx->dpy_ctx->TrajV, ii, jj, &latb, &lonb );
/* WLH 3-21-97 */
if (lata > 89.9) lata = 89.9;
if (lata < -89.9) lata = -89.9;
if (latb > 89.9) latb = 89.9;
if (latb < -89.9) latb = -89.9;
d = earth_distance( lata, lona, latb, lonb );
}
else {
rowcol_to_latlon( ctx, 0, ctx->dpy_ctx->TrajV, ii-1.0, jj, &lata, &lona );
rowcol_to_latlon( ctx, 0, ctx->dpy_ctx->TrajV, ii, jj, &latb, &lonb );
rowcol_to_latlon( ctx, 0, ctx->dpy_ctx->TrajV, ii+1.0, jj, &latc, &lonc );
/* WLH 3-21-97 */
if (lata > 89.9) lata = 89.9;
if (lata < -89.9) lata = -89.9;
if (latb > 89.9) latb = 89.9;
if (latb < -89.9) latb = -89.9;
if (latc > 89.9) latc = 89.9;
if (latc < -89.9) latc = -89.9;
d = (earth_distance( lata,lona, latb,lonb)
+ earth_distance( latb,lonb, latc,lonc)) / 2.0;
}
ctx->Vscale[i][j] = -1.0 / d; /* Note negative!!! */
}
}
break;
default:
printf("Error in init_traj: Projection=%d\n", ctx->Projection);
return 0;
}
/*
* Compute m/s to boxes/s scaling factors for W component
*/
switch (ctx->VerticalSystem) {
case VERT_GENERIC:
for (i=0;i<ctx->MaxNl;i++) {
ctx->Wscale[i] = 1.0 / ctx->LevInc;
}
break;
case VERT_EQUAL_KM:
for (i=0;i<ctx->MaxNl;i++) {
ctx->Wscale[i] = 1.0 / (ctx->LevInc * 1000.0);
}
break;
case VERT_NONEQUAL_MB:
case VERT_NONEQUAL_KM:
for (i=0;i<ctx->MaxNl;i++) {
if (i==0) {
float hgt1 = gridlevel_to_height( ctx, 1.0 );
float hgt0 = gridlevel_to_height( ctx, 0.0 );
float diff = hgt1-hgt0;
if (fabs(diff) < 0.000001) diff = 0.000001;
ctx->Wscale[i] = 1.0 / (diff * 1000.0);
/* ctx->Wscale[i] = 1.0 / ((hgt1-hgt0) * 1000.0); */
}
else if (i==ctx->MaxNl-1) {
float hgt1 = gridlevel_to_height( ctx, (float)(ctx->MaxNl-1) );
float hgt0 = gridlevel_to_height( ctx, (float)(ctx->MaxNl-2) );
float diff = hgt1-hgt0;
if (fabs(diff) < 0.000001) diff = 0.000001;
ctx->Wscale[i] = 1.0 / (diff * 1000.0);
/* ctx->Wscale[i] = 1.0 / ((hgt1-hgt0) * 1000.0); */
}
else {
float a, b;
float hgt2 = gridlevel_to_height( ctx, (float)(i+1) );
float hgt1 = gridlevel_to_height( ctx, (float) i );
float hgt0 = gridlevel_to_height( ctx, (float)(i-1) );
float diffa = hgt1-hgt0;
float diffb = hgt2-hgt1;
if (fabs(diffa) < 0.000001) diffa = 0.000001;
if (fabs(diffb) < 0.000001) diffb = 0.000001;
a = 1.0 / (diffa * 1000.0);
b = 1.0 / (diffb * 1000.0);
/*
float a = 1.0 / ((hgt1-hgt0) * 1000.0);
float b = 1.0 / ((hgt2-hgt1) * 1000.0);
*/
ctx->Wscale[i] = (a+b) / 2.0;
}
}
break;
default:
printf("Error in init_traj: ctx->VerticalSystem=%d\n", ctx->VerticalSystem);
return 0;
}
return 1;
}
TYPE
KIND_SUFFIX(erfc_scaled_r,KIND) (TYPE x)
{
/* The main computation evaluates near-minimax approximations
from "Rational Chebyshev approximations for the error function"
by W. J. Cody, Math. Comp., 1969, PP. 631-638. This
transportable program uses rational functions that theoretically
approximate erf(x) and erfc(x) to at least 18 significant
decimal digits. The accuracy achieved depends on the arithmetic
system, the compiler, the intrinsic functions, and proper
selection of the machine-dependent constants. */
int i;
TYPE del, res, xden, xnum, y, ysq;
#if (KIND == 4)
static TYPE xneg = -9.382, xsmall = 5.96e-8,
xbig = 9.194, xhuge = 2.90e+3, xmax = 4.79e+37;
#else
static TYPE xneg = -26.628, xsmall = 1.11e-16,
xbig = 26.543, xhuge = 6.71e+7, xmax = 2.53e+307;
#endif
#define SQRPI ((TYPE) 0.56418958354775628695L)
#define THRESH ((TYPE) 0.46875L)
static TYPE a[5] = { 3.16112374387056560l, 113.864154151050156l,
377.485237685302021l, 3209.37758913846947l, 0.185777706184603153l };
static TYPE b[4] = { 23.6012909523441209l, 244.024637934444173l,
1282.61652607737228l, 2844.23683343917062l };
static TYPE c[9] = { 0.564188496988670089l, 8.88314979438837594l,
66.1191906371416295l, 298.635138197400131l, 881.952221241769090l,
1712.04761263407058l, 2051.07837782607147l, 1230.33935479799725l,
2.15311535474403846e-8l };
static TYPE d[8] = { 15.7449261107098347l, 117.693950891312499l,
537.181101862009858l, 1621.38957456669019l, 3290.79923573345963l,
4362.61909014324716l, 3439.36767414372164l, 1230.33935480374942l };
static TYPE p[6] = { 0.305326634961232344l, 0.360344899949804439l,
0.125781726111229246l, 0.0160837851487422766l,
0.000658749161529837803l, 0.0163153871373020978l };
static TYPE q[5] = { 2.56852019228982242l, 1.87295284992346047l,
0.527905102951428412l, 0.0605183413124413191l,
0.00233520497626869185l };
y = (x > 0 ? x : -x);
if (y <= THRESH)
{
ysq = 0;
if (y > xsmall)
ysq = y * y;
xnum = a[4]*ysq;
xden = ysq;
for (i = 0; i <= 2; i++)
{
xnum = (xnum + a[i]) * ysq;
xden = (xden + b[i]) * ysq;
}
res = x * (xnum + a[3]) / (xden + b[3]);
res = 1 - res;
res = EXP(ysq) * res;
return res;
}
else if (y <= 4)
{
xnum = c[8]*y;
xden = y;
for (i = 0; i <= 6; i++)
{
xnum = (xnum + c[i]) * y;
xden = (xden + d[i]) * y;
}
res = (xnum + c[7]) / (xden + d[7]);
}
else
{
res = 0;
if (y >= xbig)
{
if (y >= xmax)
goto finish;
if (y >= xhuge)
{
res = SQRPI / y;
goto finish;
}
}
ysq = ((TYPE) 1) / (y * y);
xnum = p[5]*ysq;
xden = ysq;
for (i = 0; i <= 3; i++)
{
xnum = (xnum + p[i]) * ysq;
xden = (xden + q[i]) * ysq;
}
res = ysq *(xnum + p[4]) / (xden + q[4]);
res = (SQRPI - res) / y;
}
finish:
if (x < 0)
{
if (x < xneg)
res = __builtin_inf ();
else
{
ysq = TRUNC (x*((TYPE) 16))/((TYPE) 16);
del = (x-ysq)*(x+ysq);
y = EXP(ysq*ysq) * EXP(del);
res = (y+y) - res;
}
}
return res;
}
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;
}