_f_real4
_NEAREST_4_16(_f_real4 x, _f_real16 s)
{
REGISTER_4 s1, s2, s3;
s1.f = x;
if (s == 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
#if defined (_CRAY1) && defined(_CRAYIEEE)
s3.ui = s1.ui & ~(IEEE_64_SIGN_BIT);
s2.ui = (s1.f > 0) ? LL_CONST(0x20000000) : -(LL_CONST(0x20000000));
if ((_f_real4) TINY_REAL4_F90 > s3.f)
s1.f = 0.0;
#else
s2.ui = (s1.f > 0) ? 0x1 : -(0x1);
#endif
if (s1.f == 0.0) {
s1.f = (s > 0.0) ?
(_f_real4) TINY_REAL4_F90 : (_f_real4) -TINY_REAL4_F90;
} else if (s > 0.0) {
s1.ui += s2.ui;
} else {
s1.ui -= s2.ui;
}
#if defined (_CRAY1) && defined(_CRAYIEEE)
if (isnormal64(s1.ui))
#else
if (isnormal32(s1.ui))
#endif
return s1.f;
if (x > 1.0 || x < -1.0)
return s1.f;
return (0.0);
}
_f_real8
_NEAREST(_f_real8 x, _f_real8 s)
{
#ifdef KEY /* Bug 10771 */
if (s == (_f_real8) 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
_f_int8 infinity =
signbit(s) ? (0x8000000000000000ull | IEEE_64_INFINITY) : IEEE_64_INFINITY;
_f_real8 result = nextafter(x, * (_f_real8 *) &infinity);
return result;
#elif 0 /* KEY Bug 3399 */
/* See comment in _NEAREST_4 */
REGISTER_8 x_reg;
int positive_s = (s > (_f_real8) 0.0);
if (s == (_f_real8) 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
x_reg.f = x;
if (IEEE_64_EXPO_ALL_ONES(x_reg.ui)) {
return x;
}
if (x == (_f_real8) 0.0) { /* either +0.0 or -0.0 */
x_reg.ui = positive_s ? 1 : (IEEE_64_SIGN_BIT | 1);
} else {
int increment = (positive_s == (x > (_f_real8) 0.0)) ? 1 : -1;
x_reg.ui += increment;
}
return x_reg.f;
#else
REGISTER_8 s1, s2;
s1.f = x;
if (s == 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
s2.ui = (s1.f > 0) ? LL_CONST(0x1) : -(LL_CONST(0x1));
if (s1.f == 0.0) {
s1.f = (s > 0.0) ? TINY_REAL8_F90 : -TINY_REAL8_F90;
} else if (s > 0.0) {
s1.ui += s2.ui;
} else {
s1.ui -= s2.ui;
}
if (isnormal64(s1.ui))
return s1.f;
if (x > 1.0 || x < -1.0)
return s1.f;
return (0.0);
#endif /* KEY */
}
_f_real16
_NEAREST_16_8(_f_real16 x, _f_real8 s)
{
#if defined(_WORD32)
union ldble_float {
_f_real16 whole;
unsigned long long ui[1];
} f,rslt;
unsigned long long s2, s3, s4;
#else
union ldble_float {
_f_real16 whole;
unsigned long ui[1];
} f,rslt;
unsigned long s2, s3, s4;
#endif
rslt.whole = x;
f.whole = x;
if (s == 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
s2 = (rslt.whole > 0) ? LL_CONST(0x1) : -(LL_CONST(0x1));
if (rslt.whole > 0) {
/* if x > 0 and s > 0, check for all 7's in 2nd word */
s3 = IEEE_128_64_MANT2;
/* if x > 0 and s < 0, check for all zeros in 2nd word */
s4 = LL_CONST(0x0);
} else {
/* if x < 0 and s > 0, check for all zeros in 2nd word */
s3 = LL_CONST(0x0);
/* if x < 0 and s < 0, check for all 7's in 2nd word */
s4 = IEEE_128_64_MANT2;
}
if (rslt.whole == 0.0) {
rslt.whole = (s > 0.0) ? TINY_REAL16_F90 : -TINY_REAL16_F90;
} else if (s > 0.0) {
rslt.ui[1] += s2;
if (f.ui[1] == s3) {
rslt.ui[0] += s2;
}
} else {
rslt.ui[1] -= s2;
if (f.ui[1] == s4) {
rslt.ui[0] -= s2;
}
}
if (isnormal128(rslt.whole))
return rslt.whole;
if (x > 1.0 || x < -1.0)
return rslt.whole;
return (0.0);
}
_f_real8
_NEAREST_8_16(_f_real8 x, _f_real16 s)
{
REGISTER_8 s1, s2;
s1.f = x;
if (s == 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
s2.ui = (s1.f > 0) ? LL_CONST(0x1) : -(LL_CONST(0x1));
if (s1.f == 0.0) {
s1.f = (s > 0.0) ? TINY_REAL8_F90 : -TINY_REAL8_F90;
} else if (s > 0.0) {
s1.ui += s2.ui;
} else {
s1.ui -= s2.ui;
}
if (isnormal64(s1.ui))
return s1.f;
if (x > 1.0 || x < -1.0)
return s1.f;
return (0.0);
}
/*** SPACING - return the absolute spacing for 128-bit model
* numbers near the argument value.
***/
_f_real16
_SPACING_16(_f_real16 x)
{
#if defined(_WORD32)
union ldble_float {
struct {
unsigned long long upper;
unsigned long long lower;
} parts;
_f_real16 whole;
} f, result;
unsigned long long exp_mask;
#else
union ldble_float {
struct {
unsigned long upper;
unsigned long lower;
} parts;
_f_real16 whole;
} f, result;
unsigned long exp_mask;
#endif
static union ldble_float two_112 = {(LL_CONST(0x3F8F000000000000)),
(LL_CONST(0x0000000000000000))};
f.whole = x;
if (x == 0.0)
return TINY_REAL16_F90;
exp_mask = IEEE_128_64_EXPO; /* mask for exponent. */
/* multiply by 2**-112) */
result.whole = f.whole * two_112.whole;
result.parts.upper &= exp_mask;
result.parts.lower = (LL_CONST(0x0000000000000000)); /* zero. */
return result.whole == 0.0 ? TINY_REAL16_F90 : result.whole;
}
inline static /* for the inline version of this function. */
#endif
_f_real8
_FRACTION(_f_real8 x)
{
int lz;
REGISTER_8 s1, sign_bit, mantissa, exponent;
if (x == 0.0)
return 0.0;
/* if x is either infinity or a NaN, return a Nan */
if (x == IEEE_64_INFINITY)
return _SGL_NaN;
if (isnan64(x))
return x;
s1.f = x;
/* get sign bit. */
sign_bit.ui = IEEE_64_SIGN_BIT & s1.ui;
/* get mantissa. */
mantissa.ui = IEEE_64_MANTISSA & s1.ui;
/* get exponent. */
exponent.ui = IEEE_64_EXPONENT & s1.ui;
if (exponent.ui == LL_CONST(0x0)) {
/* 1. number is subnormal. normalize mantissa.
* Get leading zeros of mantissa.
*/
lz = _leadz8(mantissa.ui) - IEEE_64_EXPO_BITS;
/* 2. normalize by shifting out all leading zeros
* and first 1 bit.
*/
mantissa.ui = (mantissa.ui << lz) & IEEE_64_MANTISSA;
}
/* position exponent bias less the implicit bit. */
exponent.ui = IEEE_64_EXPO_BIAS - 1;
exponent.ui = exponent.ui << IEEE_64_MANT_BITS;
/* extract fraction. */
s1.ui = exponent.ui | mantissa.ui | sign_bit.ui;
return s1.f;
}
/* NEAREST - return the nearest different machine representable number in a
* given direction s for 32-bit and 64-bit values. Returns
* the argument x if s = zero. The result is undefined in f90
* when s = zero.
*/
_f_real4
_NEAREST_4(_f_real4 x, _f_real4 s)
{
#ifdef KEY /* Bug 10771 */
/* Previous approach (in "elif") didn't treat infinity correctly and didn't
* signal exceptions correctly. Let's try using the C library functions in
* hopes that they know what they're doing.
*/
if (s == (_f_real4) 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
_f_int4 infinity =
signbit(s) ? (0x80000000 | IEEE_32_INFINITY) : IEEE_32_INFINITY;
_f_real4 result = nextafterf(x, * (_f_real4 *) &infinity);
return result;
#elif 0 /* KEY Bug 3399 */
/*
* We want "nearest(nearest(x, s), -s) == x" to be true so long as
* IEEE infinity and NaN aren't involved. We do allow largest/smallest
* number to turn into infinity, but we don't allowe infinity to turn
* back into largest/smallest number.
*
* Here's a summary of the unsigned bit patterns for IEEE floating
* point:
*
* 1 11-11 11------11 "Largest magnitude negative" NaN
* 1 11-11 00------01 "Smallest magnitude negative" NaN
* 1 11-11 00------00 Negative infinity
* 1 11-10 11------11 Largest-magnitude negative normalized
* 1 00-01 00------00 Smallest-magnitude negative normalized
* 1 00-00 11------11 Largest-magnitude negative denorm
* 1 00-00 00------01 Smallest-magnitude negative denorm
* 1 00-00 00------00 Negative zero
* 0 11-11 11------11 "Largest positive" NaN
* 0 11-11 00------01 "Smallest positive" NaN
* 0 11-11 00------00 Positive infinity
* 0 11-10 11------11 Largest-magnitude positive normalized
* 0 00-01 00------00 Smallest-magnitude positive normalized
* 0 00-00 11------11 Largest-magnitude positive denorm
* 0 00-00 00------01 Smallest-magnitude positive denorm
* 0 00-00 00------00 Zero
*
* Our strategy is:
* 1. s == 0 is a fatal error
* 2. if x == infinity or NaN, return it unchanged
* 3. if x == +0 or -0, return smallest-magnitude denorm whose sign
* matches that of s
* 4. if the signs of x and s match, add 1 to bit pattern of x
* (increasing its floating-point magnitude); else subtract 1 from
* bit pattern of x (decreasing its magnitude)
*/
REGISTER_4 x_reg;
int positive_s = (s > (_f_real4) 0.0);
if (s == (_f_real4) 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
x_reg.f = x;
if (IEEE_32_EXPO_ALL_ONES(x_reg.ui)) {
return x;
}
if (x == (_f_real4) 0.0) { /* either +0.0 or -0.0 */
x_reg.ui = positive_s ? 1 : (IEEE_32_SIGN_BIT | 1);
} else {
int increment = (positive_s == (x > (_f_real4) 0.0)) ? 1 : -1;
x_reg.ui += increment;
}
return x_reg.f;
#else
REGISTER_4 s1, s2, s3;
s1.f = x;
if (s == (_f_real4) 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
#if defined (_CRAY1) && defined(_CRAYIEEE)
s3.ui = s1.ui & ~(IEEE_64_SIGN_BIT);
s2.ui = (s1.f > 0) ? LL_CONST(0x20000000) : -(LL_CONST(0x20000000));
if ((_f_real4) TINY_REAL4_F90 > s3.f)
s1.f = 0.0;
#else
s2.ui = (s1.f > 0) ? 0x1 : -(0x1);
#endif
if (s1.f == (_f_real4) 0.0) {
s1.f = (s > (_f_real4) 0.0) ?
(_f_real4) TINY_REAL4_F90 : (_f_real4) -TINY_REAL4_F90;
} else if (s > (_f_real4) 0.0) {
s1.ui += s2.ui;
} else {
s1.ui -= s2.ui;
}
#if defined (_CRAY1) && defined(_CRAYIEEE)
if (isnormal64(s1.ui))
#else
if (isnormal32(s1.ui))
#endif
return s1.f;
if (x > 1.0 || x < -1.0)
return (s1.f);
return (0.0);
#endif /* KEY */
}
_f_real4
_NEAREST_4_8(_f_real4 x, _f_real8 s)
{
#ifdef KEY /* Bug 10771 */
if (s == (_f_real8) 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
_f_int4 infinity =
signbit(s) ? (0x80000000 | IEEE_32_INFINITY) : IEEE_32_INFINITY;
_f_real4 result = nextafterf(x, * (_f_real4 *) &infinity);
return result;
#elif 0 /* KEY Bug 3399 */
/* See comment in _NEAREST_4 */
REGISTER_4 x_reg;
int positive_s = (s > (_f_real8) 0.0);
if (s == (_f_real8) 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
x_reg.f = x;
if (IEEE_32_EXPO_ALL_ONES(x_reg.ui)) {
return x;
}
if (x == (_f_real4) 0.0) { /* either +0.0 or -0.0 */
x_reg.ui = positive_s ? 1 : (IEEE_32_SIGN_BIT | 1);
} else {
int increment = (positive_s == (x > (_f_real4) 0.0)) ? 1 : -1;
x_reg.ui += increment;
}
return x_reg.f;
#else
REGISTER_4 s1, s2, s3;
s1.f = x;
if (s == 0.0) {
_lerror (_LELVL_ABORT, FENEARZS);
}
#if defined (_CRAY1) && defined(_CRAYIEEE)
s3.ui = s1.ui & ~(IEEE_64_SIGN_BIT);
s2.ui = (s1.f > 0) ? LL_CONST(0x20000000) : -(LL_CONST(0x20000000));
if ((_f_real4) TINY_REAL4_F90 > s3.f)
s1.f = 0.0;
#else
s2.ui = (s1.f > 0) ? 0x1 : -(0x1);
#endif
if (s1.f == 0.0) {
s1.f = (s > 0.0) ?
(_f_real4) TINY_REAL4_F90 : (_f_real4) -TINY_REAL4_F90;
} else if (s > 0.0) {
s1.ui += s2.ui;
} else {
s1.ui -= s2.ui;
}
#if defined (_CRAY1) && defined(_CRAYIEEE)
if (isnormal64(s1.ui))
#else
if (isnormal32(s1.ui))
#endif
return s1.f;
if (x > 1.0 || x < -1.0)
return s1.f;
return (0.0);
#endif /* KEY */
}
inline static /* for the inline version of this function. */
#endif
#define MIN(a,b) ((a) < (b) ? (a) : (b))
/*** Algorithm for f90 FRACTION
* FRACTION - return the fractional part of the 128-bit model
* representation of the argument value.
**/
_f_real16
_FRACTION_16(_f_real16 x)
{
int lz, ileadzcnt, loopn;
#if defined(_WORD32)
union ldble_float {
_f_real16 whole;
unsigned long long ui[1];
} f, result, mantissa;
unsigned long long sign_bit, exponent;
#else
union ldble_float {
_f_real16 whole;
unsigned long ui[1];
} f, result;
unsigned long sign_bit, exponent;
#endif
static int word_size = 64;
if (x == 0.0)
return 0.0;
f.whole = x;
/* if x is either infinity or a NaN, return a Nan */
if ((f.ui[0] == IEEE_128_64_EXPO) && (f.ui[1] == 0))
return _DBL_NaN;
if (isnan128(x))
return x;
/* get sign bit. */
sign_bit = IEEE_128_64_SIGN_BIT & f.ui[0];
/* Get the absolute value of x by ANDing the upper half
* with the NOT of 0x8000000000000000 (the sign bit mask).
*/
f.ui[0] &= ~IEEE_128_64_SIGN_BIT;
/* get exponent. */
exponent = f.ui[0] & IEEE_128_64_EXPO;
/* get mantissa and zero out exponent portion */
f.ui[0] &= IEEE_128_64_MANT1;
result.whole = f.whole;
if (exponent == LL_CONST(0x0)) {
/* 1. Number is subnormal. Normalize mantissa and
* get leading zeros in mantissa
*/
lz = 0;
for (loopn = 0; loopn < 2; loopn++) {
ileadzcnt = _leadz8(f.ui[loopn]);
lz += ileadzcnt;
if (ileadzcnt < word_size)
break;
}
lz = lz - IEEE_128_EXPO_BITS;
/* 2. Normalize by shifting out all leading zeros
* and first 1 bit.
* Determine number of mantissa bits in first 64 bits
* of the mantissa plus the implicit bit.
*/
ileadzcnt = word_size - IEEE_128_EXPO_BITS;
if (lz >= ileadzcnt) {
/* The first 48 bits of the mantissa are zero. */
result.ui[0] = (f.ui[1] << (lz - ileadzcnt)) >>
IEEE_128_EXPO_BITS;
result.ui[1] = f.ui[1] << (MIN(word_size,lz));
} else {
