//! @file rts-real32.c
//! @author (see below)
//
//! @section Copyright
//
// This file is part of VIF - vintage FORTRAN compiler.
// Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
//
//! @section License
//
// This program is free software; you can redistribute it and/or modify it 
// under the terms of the GNU General Public License as published by the 
// Free Software Foundation; either version 3 of the License, or 
// (at your option) any later version.
//
// This program is distributed in the hope that it will be useful, but 
// WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
// or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
// more details. You should have received a copy of the GNU General Public 
// License along with this program. If not, see <http://www.gnu.org/licenses/>.

//! @section Synopsis
//!
//! Runtime support for REAL*32 and COMPLEX*64.

// The code is based on the HPA Library, available from:
//   <http://download-mirror.savannah.gnu.org/releases/hpalib/>
//
//   Copyright (C) 2000 Daniel A. Atkinson <DanAtk@aol.com>
//   Copyright (C) 2004 Ivano Primi <ivprimi@libero.it>  
//   Copyright (C) 2022 Marcel van der Veer <algol68g@xs4all.nl> - VIF version.
//
// HPA code is adapted to work with VIF to implement REAL*32 and COMPLEX*64.
// HPA was choosen since it stores a 256-bit float as a 256-bit struct, which
// is convenient for FORTRAN.
//
// The HPA Library is free software; you can redistribute it and/or
// modify it under the terms of the GNU Lesser General Public
// License as published by the Free Software Foundation; either
// version 2.1 of the License, or (at your option) any later version.
//
// The HPA Library is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
// Lesser General Public License for more details.
//
// You should have received a copy of the GNU Lesser General Public
// License along with the HPA Library; if not, write to the Free
// Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
// 02110-1301 USA.

// The functions forming the HPA library are all implemented in a portable 
// fashion in the C language. The IEEE 754 standard for floating point 
// hardware and software is assumed in the PC/Unix version of this library. 
// A REAL*32 number is represented as a combination of the following elements:
//
//   sign bit(s): 0 -> positive, 1 -> negative ;
//   exponent(e): 15-bit biased integer (bias=16383) ;
//   mantissa(m): 15 words of 16 bit length *including* leading 1. 
//
// The range of representable numbers is then given by
//
//   2^16384 > x > 2^[-16383] => 1.19*10^4932 > x > 1.68*10^-[4932]
// 
// Special values of the exponent are:
//
//  all ones -> infinity (floating point overflow)
//  all zeros -> number = zero. 
//
// Underflow in operations is handled by a flush to zero. Thus, a number 
// with the exponent zero and nonzero mantissa is invalid (not-a-number). 
// From the point of view of the HPA library, a complex number is a 
// structure formed by two REAL*32 numbers.
//
// HPA cannot extend precision beyond the preset, hardcoded precision.
// Hence some math routines will not achieve full precision.

#include <vif.h>
#include <rts-real32.h>

static const char *errmsg[] = {
  "No error",
  "Division by zero",
  "Out of domain",
  "Bad exponent",
  "Floating point overflow",
  "Invalid error code"
};

#define SEXP(z) ((unt_2 *) &(z.value))

void _pi32 (real_32 *x)
{
  *x = X_PI;
}

int_4 xsigerr (int_4 errcond, int_4 errcode, const char *where)
{
// errcode must come from the evaluation of an error condition.
// errcode, which should describe the type of the error, 
// should always be one between XEDIV, XEDOM, XEBADEXP and XFPOFLOW.  
  if (errcond == 0) {
    errcode = 0;
  }
  if (errcode < 0 || errcode > XNERR) {
    errcode = XEINV;
  }
  if (errcode != 0) {
    RTE (where, errmsg[errcode]);
  }
  return errcode;
}

// Elementary stuff.

inline real_32 xneg (real_32 s)
{
  unt_2 *p = SEXP (s);
  *p ^= X_SIGN_MASK;
  return s;
}

inline real_32 xabs (real_32 s)
{
  unt_2 *p = SEXP (s);
  *p &= X_EXPO_MASK;
  return s;
}

inline int_4 xgetexp (const real_32 * ps)
{
  unt_2 *q = (unt_2 *) &(ps->value);
  return (*q & X_EXPO_MASK) - X_EXPO_BIAS;
}

inline int_4 xgetsgn (const real_32 * ps)
{
  unt_2 *q = (unt_2 *) &(ps->value);
  return (*q & X_SIGN_MASK);
}

int_4 xreal_cmp (const real_32 * pa, const real_32 * pb)
{
  unt_2 e, k, *p, *q, p0, q0;
  int_4 m;
  p = (unt_2 *) &(pa->value);
  q = (unt_2 *) &(pb->value);
  for (m = 1; m <= FLT256_LEN && p[m] == 0; m++);
  if (m > FLT256_LEN && (*p & X_EXPO_MASK) < X_EXPO_MASK) {
// *pa is actually zero 
    p0 = 0;
  } else {
    p0 = *p;
  }
  for (m = 1; m <= FLT256_LEN && q[m] == 0; m++);
  if (m > FLT256_LEN && (*q & X_EXPO_MASK) < X_EXPO_MASK) {
// *pb is actually zero 
    q0 = 0;
  } else {
    q0 = *q;
  }
  e = p0 & X_SIGN_MASK;
  k = q0 & X_SIGN_MASK;
  if (e && !k) {
    return -1;
  } else if (!e && k) {
    return 1;
  } else {                        // *pa and *pb have the same sign 
    m = (e) ? -1 : 1;
    e = p0 & X_EXPO_MASK;
    k = q0 & X_EXPO_MASK;
    if (e > k) {
      return m;
    } else if (e < k) {
      return -m;
    } else {
      for (e = 0; *(++p) == *(++q) && e < FLT256_LEN; ++e);
      if (e < FLT256_LEN) {
        return (*p > *q ? m : -m);
      } else {
        return 0;
      }
    }
  }
}

real_32 xreal_2 (real_32 s, int_4 m)
{
  unt_2 *p = SEXP (s);
  int_4 e;
  for (e = 1; e <= FLT256_LEN && p[e] == 0; e++);
  if (e <= FLT256_LEN) {
    e = *p & X_EXPO_MASK;            // biased exponent 
    if (e + m < 0) {
      return X_0;
    } else if ((xsigerr (e + m >= X_EXPO_MASK, XFPOFLOW, NO_TEXT))) {
      return ((s.value[0] & X_SIGN_MASK) ? X_MINUS_INF : X_PLUS_INF);
    } else {
      *p += m;
      return s;
    }
  } else {                        // s is zero or +-Inf 
    return s;
  }
}

real_32 xsfmod (real_32 s, int_4 *p)
{
  unt_2 *pa = SEXP (s);
  unt_2 *pb = pa + 1;
  int_2 e, k;
  e = (*pa & X_EXPO_MASK) - X_EXPO_BIAS;
  if ((xsigerr (e >= 15, XFPOFLOW, NO_TEXT))) {
    *p = -1;
    return s;
  } else if (e < 0) {
    *p = 0;
    return s;
  }
  *p = *pb >> (15 - e);
  xlshift (++e, pb, FLT256_LEN);
  *pa -= e;
  for (e = 0; *pb == 0 && e < xMax_p; ++pb, e += 16);
  if (e == xMax_p) {
    return X_0;
  }
  for (k = 0; !((*pb << k) & X_SIGN_MASK); ++k);
  if ((k += e)) {
    xlshift (k, pa + 1, FLT256_LEN);
    *pa -= k;
  }
  return s;
}

void xlshift (int_4 n, unt_2 *pm, int_4 m)
{
  unt_2 *pc = pm + m - 1;
  if (n < 16 * m) {
    unt_2 *pa = pm + n / 16;
    m = n % 16;
    n = 16 - m;
    while (pa < pc) {
      *pm = (*pa++) << m;
      *pm++ |= *pa >> n;
    }
    *pm++ = *pa << m;
  }
  while (pm <= pc) {
    *pm++ = 0;
  }
}

void xrshift (int_4 n, unt_2 *pm, int_4 m)
{
  unt_2 *pc = pm + m - 1;
  if (n < 16 * m) {
    unt_2 *pa = pc - n / 16;
    m = n % 16;
    n = 16 - m;
    while (pa > pm) {
      *pc = (*pa--) >> m;
      *pc-- |= *pa << n;
    }
    *pc-- = *pa >> m;
  }
  while (pc >= pm) {
    *pc-- = 0;
  }
}

real_32 _xI (real_32 x) 
{
// Intrinsic function so arguments are not pointers.
  return x;
}

real_32 _aintx (real_32 x) 
{
// Intrinsic function so arguments are not pointers.
  return xtrunc (x);
}

real_32 _anintx (real_32 x) 
{
// Intrinsic function so arguments are not pointers.
  if (xgetsgn (&x) == 0) {
    return xtrunc (xsum (x, X_1_OVER_2));
  } else {
    return xtrunc (xsub (x, X_1_OVER_2));
  }
}

real_32 _xmax (real_32 a, real_32 b) 
{
// Intrinsic function so arguments are not pointers.
  if (xge (a, b)) {
    return a;
  } else {
    return b;
  }
}

real_32 _xmin (real_32 a, real_32 b) 
{
// Intrinsic function so arguments are not pointers.
  if (xle (a, b)) {
    return a;
  } else {
    return b;
  }
}

real_32 _xmod (real_32 a, real_32 b)
{
// Intrinsic function so arguments are not pointers.
  real_32 q = xdiv (a, b);
  if (xsgn (&q) >= 0) {
    q = xfloor (q);
  } else {
    q = xneg (xfloor (xneg (q)));
  }
  return xadd (a, xmul (b, q), 1);
}

real_32 xadd (real_32 s, real_32 t, int_4 f)
{
  REAL32 pe;
  unt_2 h, u;
  unt_2 *pc, *pf = pe;
  unt_4 n = 0;
  unt_2 *pa = SEXP (s);
  unt_2 *pb = SEXP (t);
  int_2 e = *pa & X_EXPO_MASK;
  int_2 k = *pb & X_EXPO_MASK;
  if (f != 0) {
    *pb ^= X_SIGN_MASK;
  }
  u = (*pb ^ *pa) & X_SIGN_MASK;
  f = 0;
  if (e > k) {
    if ((k = e - k) >= xMax_p) {
      return s;
    }
    xrshift (k, pb + 1, FLT256_LEN);
  } else if (e < k) {
    if ((e = k - e) >= xMax_p) {
      return t;
    }
    xrshift (e, pa + 1, FLT256_LEN);
    e = k;
    pc = pa;
    pa = pb;
    pb = pc;
  } else if (u != 0) {
    for (pc = pa, pf = pb; *(++pc) == *(++pf) && f < FLT256_LEN; ++f);
    if (f >= FLT256_LEN) {
      return X_0;
    }
    if (*pc < *pf) {
      pc = pa;
      pa = pb;
      pb = pc;
    }
    pf = pe + f;
  }
  h = *pa & X_SIGN_MASK;
  if (u != 0) {
    for (pc = pb + FLT256_LEN; pc > pb; --pc) {
      *pc = ~(*pc);
    }
    n = 1L;
  }
  for (pc = pe + FLT256_LEN, pa += FLT256_LEN, pb += FLT256_LEN; pc > pf;) {
    n += *pa;
    pa--;
    n += *pb;
    pb--;
    *pc = n;
    pc--;
    n >>= 16;
  }
  if (u != 0) {
    for (; *(++pc) == 0; ++f);
    for (k = 0; !((*pc << k) & X_SIGN_MASK); ++k);
    if ((k += 16 * f)) {
      if ((e -= k) <= 0) {
        return X_0;
      }
      xlshift (k, pe + 1, FLT256_LEN);
    }
  } else {
    if (n != 0) {
      ++e;
      if ((xsigerr (e == (short) X_EXPO_MASK, XFPOFLOW, NO_TEXT))) {
        return (!h ? X_PLUS_INF : X_MINUS_INF);
      }
      ++pf;
      xrshift (1, pf, FLT256_LEN);
      *pf |= X_SIGN_MASK;
    }
  }
  *pe = e;
  *pe |= h;
  return *(real_32 *) pe;
}

real_32 xmul (real_32 s, real_32 t)
{
  unt_2 pe[FLT256_LEN + 2], *q0, *q1, h;
  unt_2 *pa, *pb, *pc;
  unt_4 m, n, p;
  int_2 e;
  int_2 k;
  q0 = SEXP (s);
  q1 = SEXP (t);
  e = (*q0 & X_EXPO_MASK) - X_EXPO_BIAS;
  k = (*q1 & X_EXPO_MASK) + 1;
  if ((xsigerr (e > (short) X_EXPO_MASK - k, XFPOFLOW, NO_TEXT))) {
    return (((s.value[0] & X_SIGN_MASK) ^ (t.value[0] & X_SIGN_MASK)) ? X_MINUS_INF : X_PLUS_INF);
  }
  if ((e += k) <= 0) {
    return X_0;
  }
  h = (*q0 ^ *q1) & X_SIGN_MASK;
  for (++q1, k = FLT256_LEN, p = n = 0L, pc = pe + FLT256_LEN + 1; k > 0; --k) {
    for (pa = q0 + k, pb = q1; pa > q0;) {
      m = *pa--;
      m *= *pb++;
      n += (m & 0xffffL);
      p += (m >> 16);
    }
    *pc-- = n;
    n = p + (n >> 16);
    p = 0L;
  }
  *pc = n;
  if (!(*pc & X_SIGN_MASK)) {
    --e;
    if (e <= 0) {
      return X_0;
    }
    xlshift (1, pc, FLT256_LEN + 1);
  }
  if ((xsigerr (e == (short) X_EXPO_MASK, XFPOFLOW, NO_TEXT))) {
    return (!h ? X_PLUS_INF : X_MINUS_INF);
  }
  *pe = e;
  *pe |= h;
  return *(real_32 *) pe;
}

real_32 xdiv (real_32 s, real_32 t)
{
  unt_2 *pd = SEXP (s), *pc = SEXP (t);
// Next makes xdiv robust at extreme exponents - MvdV.
  if ((*pd & X_EXPO_MASK) == (*pc & X_EXPO_MASK)) {
    *pd &= ~X_EXPO_MASK; 
    *pc &= ~X_EXPO_MASK; 
  }
// HPA implementation.
  unt_2 e = *pc;
  *pc = X_EXPO_BIAS;
  if ((xsigerr (xreal_cmp (&t, &X_0) == 0, XEDIV, "xdiv()"))) {
    return X_0;
  } else {
    real_32 a = dbltox (1 / xtodbl (t));
    *pc = e;
    pc = SEXP (a);
    *pc += X_EXPO_BIAS - (e & X_EXPO_MASK);
    *pc |= e & X_SIGN_MASK;
    for (unt_2 i = 0; i < xItt_div; ++i) {
      a = xmul (a, xadd (X_2, xmul (a, t), 1));
    }
    return xmul (s, a);
  }
}

real_32 xevtch (real_32 z, real_32 * a, int_4 m)
{
  real_32 *p, f, t, tp, w;
  w = xreal_2 (z, 1);
  t = X_0;
  tp = X_0;
  for (p = a + m; p > a;) {
    f = xadd (*p--, xadd (xmul (w, t), tp, 1), 0);
    tp = t;
    t = f;
  }
  return xadd (*p, xadd (xmul (z, t), tp, 1), 0);
}

real_32 xexp2 (real_32 x)
{
  real_32 s, d, f;
  unt_2 *pf = SEXP (x);
  int_4 m, k;
  if (xreal_cmp (&x, &xE2min) < 0) {
    return X_0;
  } else if ((xsigerr (xreal_cmp (&x, &xE2max) > 0, XFPOFLOW, NO_TEXT))) {
    return X_PLUS_INF;
  } else {
    m = (*pf & X_SIGN_MASK) ? 1 : 0;
    x = xsfmod (x, &k);
    if (m != 0) {
      k *= -1;
    }
// -X_EXPO_BIAS <= k <= +X_EXPO_BIAS 
    x = xmul (x, X_LN_2);
    if (xgetexp (&x) > -X_EXPO_BIAS) {
      x = xreal_2 (x, -1);
      s = xmul (x, x);
      f = X_0;
      for (d = inttox (m = xMS_exp); m > 1; m -= 2, d = inttox (m)) {
        f = xdiv (s, xadd (d, f, 0));
      }
      f = xdiv (x, xadd (d, f, 0));
      f = xdiv (xadd (d, f, 0), xadd (d, f, 1));
    } else {
      f = X_1;
    }
    pf = SEXP (f);
    if (-k > *pf) {
      return X_0;
    } else {
      *pf += k;
      if ((xsigerr (*pf >= X_EXPO_MASK, XFPOFLOW, NO_TEXT))) {
        return X_PLUS_INF;
      } else {
        return f;
      }
    }
  }
}

real_32 xexp (real_32 z)
{
  return xexp2 (xmul (z, X_LOG2_E));
}

real_32 xexp10 (real_32 z)
{
  return xexp2 (xmul (z, X_LOG2_10));
}

real_32 xfmod (real_32 s, real_32 t, real_32 * q)
{
  if ((xsigerr (xreal_cmp (&t, &X_0) == 0, XEDIV, "xfmod()"))) {
    return X_0;
  } else {
    unt_2 *p, mask = 0xffff;
    int_2 e, i;
    int_4 u;
    *q = xdiv (s, t);
    p = (unt_2 *) &(q->value);
    u = (*p & X_SIGN_MASK) ? 0 : 1;
    e = (*p &= X_EXPO_MASK);         // biased exponent of *q 
    e = e < X_EXPO_BIAS ? 0 : e - X_EXPO_BIAS + 1;
    for (i = 1; e / 16 > 0; i++, e -= 16);
    if (i <= FLT256_LEN) {
// e = 0, ..., 15 
      mask <<= 16 - e;
      p[i] &= mask;
      for (i++; i <= FLT256_LEN; p[i] = 0, i++);
    }
// Now *q == abs(quotient of (s/t)) 
    return xadd (s, xmul (t, *q), u);
  }
}

real_32 xfrexp (real_32 s, int_4 *p)
{
  unt_2 *ps = SEXP (s), u;
  *p = (*ps & X_EXPO_MASK) - X_EXPO_BIAS + 1;
  u = *ps & X_SIGN_MASK;
  *ps = X_EXPO_BIAS - 1;
  *ps |= u;
  return s;
}

static void nullify (int_4 skip, unt_2 *p, int_4 k)
{
// After skipping the first 'skip' bytes of the vector 'p',
// this function nullifies all the remaining ones. 'k' is
// the number of words forming the vector p.
// Warning: 'skip' must be positive !  
  int_4 i;
  unt_2 mask = 0xffff;
  for (i = 0; skip / 16 > 0; i++, skip -= 16);
  if (i < k) {
// skip = 0, ..., 15 
    mask <<= 16 - skip;
    p[i] &= mask;
    for (i++; i < k; p[i] = 0, i++);
  }
}

static void canonic_form (real_32 * px)
{
  unt_2 *p, u;
  int_2 e, i, j, skip;
  p = (unt_2 *) &(px->value);
  e = (*p & X_EXPO_MASK);            // biased exponent of x 
  u = (*p & X_SIGN_MASK);            // sign of x            
  if (e < X_EXPO_BIAS - 1) {
    return;
  } else {
    unt_2 mask = 0xffff;
// e >= X_EXPO_BIAS - 1 
    for (i = 1, skip = e + 1 - X_EXPO_BIAS; skip / 16 > 0; i++, skip -= 16);
    if (i <= FLT256_LEN) {
// skip = 0, ..., 15 
      mask >>= skip;
      if ((p[i] & mask) != mask) {
        return;
      } else {
        for (j = i + 1; j <= FLT256_LEN && p[j] == 0xffff; j++);
        if (j > FLT256_LEN) {
          p[i] -= mask;
          for (j = i + 1; j <= FLT256_LEN; p[j] = 0, j++);
          if (!(p[1] & 0x8000)) {
            p[1] = 0x8000;
            *p = ++e;
            *p |= u;
          } else if (u != 0) {
            *px = xadd (*px, X_1, 1);
          } else {
            *px = xadd (*px, X_1, 0);
          }
        }
      }
    }
  }
}

real_32 xfrac (real_32 x)
{
// xfrac(x) returns the fractional part of the number x.
// xfrac(x) has the same sign as x.  
  unt_2 u, *p;
  int_2 e;
  int_4 n;
  canonic_form (&x);
  p = SEXP (x);
  e = (*p & X_EXPO_MASK);            // biased exponent of x 
  if (e < X_EXPO_BIAS) {
    return x;                   // The integer part of x is zero 
  } else {
    u = *p & X_SIGN_MASK;            // sign of x 
    n = e - X_EXPO_BIAS + 1;
    xlshift (n, p + 1, FLT256_LEN);
    e = X_EXPO_BIAS - 1;
// Now I have to take in account the rule 
// of the leading one.                    
    while (e > 0 && !(p[1] & X_SIGN_MASK)) {
      xlshift (1, p + 1, FLT256_LEN);
      e -= 1;
    }
// Now p+1 points to the fractionary part of x, 
// u is its sign, e is its biased exponent.     
    p[0] = e;
    p[0] |= u;
    return *(real_32 *) p;
  }
}

real_32 xtrunc (real_32 x)
{
// xtrunc(x) returns the integer part of the number x.
// xtrunc(x) has the same sign as x.  
  unt_2 *p;
  int_2 e;
  canonic_form (&x);
  p = SEXP (x);
  e = (*p & X_EXPO_MASK);            // biased exponent of x 
  if (e < X_EXPO_BIAS) {
    return X_0;               // The integer part of x is zero 
  } else {
    nullify (e - X_EXPO_BIAS + 1, p + 1, FLT256_LEN);
    return *(real_32 *) p;
  }
}

real_32 xround (real_32 x)
{
  return xtrunc (xadd (x, X_RND_CORR, x.value[0] & X_SIGN_MASK));
}

real_32 xceil (real_32 x)
{
  unt_2 *ps = SEXP (x);
  if ((*ps & X_SIGN_MASK)) {
    return xtrunc (x);
  } else {
    real_32 y = xfrac (x);
// y has the same sign as x (see above). 
    return (xreal_cmp (&y, &X_0) > 0 ? xadd (xtrunc (x), X_1, 0) : x);
  }
}

real_32 xfloor (real_32 x)
{
  unt_2 *ps = SEXP (x);
  if ((*ps & X_SIGN_MASK)) {
    real_32 y = xfrac (x);
// y has the same sign as x (see above). 
    return (xreal_cmp (&y, &X_0) < 0 ? xadd (xtrunc (x), X_1, 1) : x);
  } else {
    return xtrunc (x);
  }
}

static void xadd_correction (real_32 * px, int_4 k)
{
  int_2 e = (px->value[0] & X_EXPO_MASK) - X_EXPO_BIAS;
//   e = (e > 0 ? e : 0);   
  *px = xadd (*px, xreal_2 (X_FIX_CORR, e), k);
}

real_32 xfix (real_32 x)
{
  unt_2 *p;
  int_2 e;
  xadd_correction (&x, x.value[0] & X_SIGN_MASK);
  p = SEXP (x);
  e = (*p & X_EXPO_MASK);            // biased exponent of x 
  if (e < X_EXPO_BIAS) {
    return X_0;               // The integer part of x is zero 
  } else {
    nullify (e - X_EXPO_BIAS + 1, p + 1, FLT256_LEN);
    return *(real_32 *) p;
  }
}

real_32 xtanh (real_32 z)
{
  real_32 s, d, f;
  int_4 m, k;
  if ((k = xgetexp (&z)) > xK_tanh) {
    if (xgetsgn (&z)) {
      return xneg (X_1);
    } else {
      return X_1;
    }
  }
  if (k < xK_lin) {
    return z;
  }
  ++k;
  if (k > 0) {
    z = xreal_2 (z, -k);
  }
  s = xmul (z, z);
  f = X_0;
  for (d = inttox (m = xMS_hyp); m > 1;) {
    f = xdiv (s, xadd (d, f, 0));
    d = inttox (m -= 2);
  }
  f = xdiv (z, xadd (d, f, 0));
  for (; k > 0; --k) {
    f = xdiv (xreal_2 (f, 1), xadd (d, xmul (f, f), 0));
  }
  return f;
}

real_32 xsinh (real_32 z)
{
  int_4 k;
  if ((k = xgetexp (&z)) < xK_lin) {
    return z;
  } else if (k < 0) {
    z = xtanh (xreal_2 (z, -1));
    return xdiv (xreal_2 (z, 1), xadd (X_1, xmul (z, z), 1));
  } else {
    z = xexp (z);
    return xreal_2 (xadd (z, xdiv (X_1, z), 1), -1);
  }
}

real_32 xcosh (real_32 z)
{
  if (xgetexp (&z) < xK_lin) {
    return X_1;
  }
  z = xexp (z);
  return xreal_2 (xadd (z, xdiv (X_1, z), 0), -1);
}

real_32 xatanh (real_32 x)
{
  real_32 y = x;
  y.value[0] &= X_EXPO_MASK;           // Now y == abs(x) 
  if ((xsigerr (xreal_cmp (&y, &X_1) >= 0, XEDOM, "xatanh"))) {
    return ((x.value[0] & X_SIGN_MASK) ? X_MINUS_INF : X_PLUS_INF);
  } else {
    y = xdiv (xadd (X_1, x, 0), xadd (X_1, x, 1));
    return xreal_2 (xlog (y), -1);
  }
}

real_32 xasinh (real_32 x)
{
  real_32 y = xmul (x, x);
  y = xsqrt (xadd (X_1, y, 0));
  if ((x.value[0] & X_SIGN_MASK)) {
    return xneg (xlog (xadd (y, x, 1)));
  } else {
    return xlog (xadd (x, y, 0));
  }
}

real_32 xacosh (real_32 x)
{
  if ((xsigerr (xreal_cmp (&x, &X_1) < 0, XEDOM, "xacosh()"))) {
    return X_0;
  } else {
    real_32 y = xmul (x, x);
    y = xsqrt (xadd (y, X_1, 1));
    return xlog (xadd (x, y, 0));
  }
}

real_32 xatan (real_32 z)
{
  real_32 s, f;
  int_4 k, m;
  if ((k = xgetexp (&z)) < xK_lin) {
    return z;
  }
  if (k >= 0) {
// k>=0 is equivalent to abs(z) >= 1.0 
    z = xdiv (X_1, z);
    m = 1;
  } else {
    m = 0;
  }
  f = dbltox (atan (xtodbl (z)));
  s = xadd (X_1, xmul (z, z), 0);
  for (k = 0; k < xItt_div; ++k) {
    f = xadd (f, xdiv (xadd (z, xtan (f), 1), s), 0);
  }
  if (m != 0) {
    if (xgetsgn (&f)) {
      return xadd (xneg (X_PI_OVER_2), f, 1);
    } else {
      return xadd (X_PI_OVER_2, f, 1);
    }
  } else {
    return f;
  }
}

real_32 xasin (real_32 z)
{
  real_32 u = z;
  u.value[0] &= X_EXPO_MASK;
  if ((xsigerr (xreal_cmp (&u, &X_1) > 0, XEDOM, "xasin()"))) {
    return ((xgetsgn (&z)) ? xneg (X_PI_OVER_2) : X_PI_OVER_2);
  } else {
    if (xgetexp (&z) < xK_lin) {
      return z;
    }
    u = xsqrt (xadd (X_1, xmul (z, z), 1));
    if (xgetexp (&u) == -X_EXPO_BIAS) {
      return ((xgetsgn (&z)) ? xneg (X_PI_OVER_2) : X_PI_OVER_2);
    }
    return xatan (xdiv (z, u));
  }
}

real_32 xacos (real_32 z)
{
  real_32 u = z;
  u.value[0] &= X_EXPO_MASK;
  if ((xsigerr (xreal_cmp (&u, &X_1) > 0, XEDOM, "xacos()"))) {
    return ((xgetsgn (&z)) ? X_PI : X_0);
  } else {
    if (xgetexp (&z) == -X_EXPO_BIAS) {
      return X_PI_OVER_2;
    }
    u = xsqrt (xadd (X_1, xmul (z, z), 1));
    u = xatan (xdiv (u, z));
    if (xgetsgn (&z)) {
      return xadd (X_PI, u, 0);
    } else {
      return u;
    }
  }
}
// Kindly added by A.Haumer 2010-04.09 

real_32 xatan2 (real_32 y, real_32 x)
{
  int_4 rs, is;
  rs = xsgn (&x);
  is = xsgn (&y);
  if (rs > 0) {
    return xatan (xdiv (y, x));
  } else if (rs < 0) {
    x.value[0] ^= X_SIGN_MASK;
    y.value[0] ^= X_SIGN_MASK;
    if (is >= 0) {
      return xadd (X_PI, xatan (xdiv (y, x)), 0);
    } else {
      return xadd (xatan (xdiv (y, x)), X_PI, 1);
    }
  } else {                      // x is zero ! 
    if (!xsigerr (is == 0, XEDOM, "xatan2()")) {
      return (is > 0 ? X_PI_OVER_2 : xneg (X_PI_OVER_2));
    } else {
      return X_0;             // Dummy value :) 
    }
  }
}

real_32 xlog (real_32 z)
{
  real_32 f, h;
  int_4 k, m;
  if ((xsigerr ((xgetsgn (&z)) || xgetexp (&z) == -X_EXPO_BIAS, XEDOM, "xlog()"))) {
    return X_MINUS_INF;
  } else if (xreal_cmp (&z, &X_1) == 0) {
    return X_0;
  } else {
    z = xfrexp (z, &m);
    z = xmul (z, X_SQRT_2);
    z = xdiv (xadd (z, X_1, 1), xadd (z, X_1, 0));
    h = xreal_2 (z, 1);
    z = xmul (z, z);
    for (f = h, k = 1; xgetexp (&h) > -xMax_p;) {
      h = xmul (h, z);
      f = xadd (f, xdiv (h, inttox (k += 2)), 0);
    }
    return xadd (f, xmul (X_LN_2, dbltox (m - .5)), 0);
  }
}

real_32 xlog2 (real_32 z)
{
  real_32 f, h;
  int_4 k, m;
  if ((xsigerr ((xgetsgn (&z)) || xgetexp (&z) == -X_EXPO_BIAS, XEDOM, "xlog2()"))) {
    return X_MINUS_INF;
  } else if (xreal_cmp (&z, &X_1) == 0) {
    return X_0;
  } else {
    z = xfrexp (z, &m);
    z = xmul (z, X_SQRT_2);
    z = xdiv (xadd (z, X_1, 1), xadd (z, X_1, 0));
    h = xreal_2 (z, 1);
    z = xmul (z, z);
    for (f = h, k = 1; xgetexp (&h) > -xMax_p;) {
      h = xmul (h, z);
      f = xadd (f, xdiv (h, inttox (k += 2)), 0);
    }
    return xadd (xmul (f, X_LOG2_E), dbltox (m - .5), 0);
  }
}

real_32 xlog10 (real_32 z)
{
  real_32 w = xlog (z);
  if (xreal_cmp (&w, &X_MINUS_INF) <= 0) {
    return X_MINUS_INF;
  } else {
    return xmul (w, X_LOG10_E);
  }
}

logical_4 xeq (real_32 x1, real_32 x2)
{
  return (xreal_cmp (&x1, &x2) == 0);
}

logical_4 xneq (real_32 x1, real_32 x2)
{
  return (xreal_cmp (&x1, &x2) != 0);
}

logical_4 xgt (real_32 x1, real_32 x2)
{
  return (xreal_cmp (&x1, &x2) > 0);
}

logical_4 xge (real_32 x1, real_32 x2)
{
  return (xreal_cmp (&x1, &x2) >= 0);
}

logical_4 xlt (real_32 x1, real_32 x2)
{
  return (xreal_cmp (&x1, &x2) < 0);
}

logical_4 xle (real_32 x1, real_32 x2)
{
  return (xreal_cmp (&x1, &x2) <= 0);
}


logical_4 xis_nan (const real_32 * u)
{
// xis_nan (&x) returns TRUE if and only if x is not a valid number 
  unt_2 *p = (unt_2 *) &(u->value);
  if (*p != 0) {
    return FALSE;
  } else {
    int_4 i;
    for (i = 1; i <= FLT256_LEN && p[i] == 0x0; i++);
    return i <= FLT256_LEN;
  }
}

logical_4 xis0 (const real_32 * u)
{
  unt_2 *p = (unt_2 *) &(u->value);
  int_4 m;
  for (m = 1; m <= FLT256_LEN && p[m] == 0; m++);
  return (m > FLT256_LEN && (*p & X_EXPO_MASK) < X_EXPO_MASK ? TRUE : FALSE);
}

logical_4 xnot0 (const real_32 * u)
{
  unt_2 *p = (unt_2 *) &(u->value);
  int_4 m;
  for (m = 1; m <= FLT256_LEN && p[m] == 0; m++);
  return (m > FLT256_LEN && (*p & X_EXPO_MASK) < X_EXPO_MASK ? FALSE : TRUE);
}

logical_4 xlt1 (const real_32 u)
{
  return (xlt (xabs (u), X_1));
}

int_4 xsgn (const real_32 * u)
{
  unt_2 *p = (unt_2 *) &(u->value);
  int_4 m;
  for (m = 1; m <= FLT256_LEN && p[m] == 0; m++);
  if ((m > FLT256_LEN && (*p & X_EXPO_MASK) < X_EXPO_MASK) || !*p) {
    return 0;
  } else {
    return ((*p & X_SIGN_MASK) ? -1 : 1);
  }
}

logical_4 xis_pinf (const real_32 * u)
{
  return (*u->value == X_EXPO_MASK);
}

logical_4 xis_minf (const real_32 * u)
{
  return (*u->value == (X_EXPO_MASK | X_SIGN_MASK));
}

logical_4 xisordnumb (const real_32 * u)
{
  int_4 isNaN, isfinite;
  unt_2 *p = (unt_2 *) &(u->value);
  if (*p != 0) {
    isNaN = FALSE;
  } else {
    int_4 i;
    for (i = 1; i <= FLT256_LEN && p[i] == 0x0; i++);
    isNaN = i <= FLT256_LEN;
  }
  isfinite = (*p & X_EXPO_MASK) < X_EXPO_MASK;
  return (!isNaN && (isfinite) ? TRUE : FALSE);
}

real_32 xpwr (real_32 s, int_4 n)
{
  real_32 t;
  unsigned k, m;
  t = X_1;
  if (n < 0) {
    m = -n;
    if ((xsigerr (xreal_cmp (&s, &X_0) == 0, XEBADEXP, "xpwr()"))) {
      return X_0;
    }
    s = xdiv (X_1, s);
  } else {
    m = n;
  }
  if (m != 0) {
    k = 1;
    while (1) {
      if (k & m) {
        t = xmul (s, t);
      }
      if ((k <<= 1) <= m) {
        s = xmul (s, s);
      } else {
        break;
      }
    }
  } else {
    xsigerr (xreal_cmp (&s, &X_0) == 0, XEBADEXP, "xpwr()");
  }
  return t;
}

real_32 xpow (real_32 x, real_32 y)
{
  if (xsigerr ((xgetsgn (&x)) || xgetexp (&x) == -X_EXPO_BIAS, XEDOM, "xpow()")) {
    return X_0;
  } else {
    return xexp2 (xmul (xlog2 (x), y));
  }
}

real_32 xsqrt (real_32 z)
{
  real_32 s, h;
  int_2 m, e;
  unt_2 *pc;
  if ((xsigerr ((xgetsgn (&z)), XEDOM, "xsqrt()"))) {
    return X_0;
  } else {
    pc = SEXP (z);
    if (*pc == 0) {
      return X_0;
    }
    e = *pc - X_EXPO_BIAS;
    *pc = X_EXPO_BIAS + (e % 2);
    e /= 2;
    s = dbltox (sqrt (xtodbl (z)));
    for (m = 0; m < xItt_div; ++m) {
      h = xdiv (xadd (z, xmul (s, s), 1), xreal_2 (s, 1));
      s = xadd (s, h, 0);
    }
    pc = SEXP (s);
    *pc += e;
    return s;
  }
}

static int_4 xodd (real_32 x)
{
  unt_2 *p = SEXP (x);
  int_2 e, i;
  e = (*p & X_EXPO_MASK) - X_EXPO_BIAS;    // exponent of x 
  if (e < 0) {
    return 0;
  } else {
    for (i = 1; e / 16 > 0; i++, e -= 16);
// Now e = 0, ..., 15 
    return (i <= FLT256_LEN ? p[i] & 0x8000 >> e : 0);
  }
}

real_32 xtan (real_32 z)
{
  int_4 k, m;
  z = rred (z, 't', &k);
  if ((xsigerr (xreal_cmp (&z, &X_PI_OVER_2) >= 0, XEDOM, "xtan()"))) {
    return (!k ? X_PLUS_INF : X_MINUS_INF);
  } else {
    if (xreal_cmp (&z, &X_PI_OVER_4) == 1) {
      m = 1;
      z = xadd (X_PI_OVER_2, z, 1);
    } else {
      m = 0;
    }
    if (k != 0) {
      z = xneg (c_tan (z));
    } else {
      z = c_tan (z);
    }
    if (m != 0) {
      return xdiv (X_1, z);
    } else {
      return z;
    }
  }
}

real_32 xcos (real_32 z)
{
  int_4 k;
  z = rred (z, 'c', &k);
  if (xgetexp (&z) < xK_lin) {
    if (k != 0) {
      return xneg (X_1);
    } else {
      return X_1;
    }
  }
  z = c_tan (xreal_2 (z, -1));
  z = xmul (z, z);
  z = xdiv (xadd (X_1, z, 1), xadd (X_1, z, 0));
  if (k != 0) {
    return xneg (z);
  } else {
    return z;
  }
}

real_32 xsin (real_32 z)
{
  int_4 k;
  z = rred (z, 's', &k);
  if (xgetexp (&z) >= xK_lin) {
    z = c_tan (xreal_2 (z, -1));
    z = xdiv (xreal_2 (z, 1), xadd (X_1, xmul (z, z), 0));
  }
  if (k != 0) {
    return xneg (z);
  } else {
    return z;
  }
}

static real_32 c_tan (real_32 z)
{
  real_32 s, f, d;
  int_4 m;
  unt_2 k;
  if (xgetexp (&z) < xK_lin)
    return z;
  s = xneg (xmul (z, z));
  for (k = 1; k <= FLT256_LEN && s.value[k] == 0; k++);
  if ((xsigerr (s.value[0] == 0xffff && k > FLT256_LEN, XFPOFLOW, NO_TEXT))) {
    return X_0;
  } else {
    f = X_0;
    for (d = inttox (m = xMS_trg); m > 1;) {
      f = xdiv (s, xadd (d, f, 0));
      d = inttox (m -= 2);
    }
    return xdiv (z, xadd (d, f, 0));
  }
}

static real_32 rred (real_32 z, int_4 kf, int_4 *ps)
{
  real_32 is, q;
  if (xgetsgn (&z)) {
    z = xneg (z);
    is = X_1;
  } else {
    is = X_0;
  }
  z = xfmod (z, X_PI, &q);
  if (kf == 't') {
    q = is;
  } else if (kf == 's') {
    q = xadd (q, is, 0);
  }
  if (xreal_cmp (&z, &X_PI_OVER_2) == 1) {
    z = xadd (X_PI, z, 1);
    if (kf == 'c' || kf == 't') {
      q = xadd (q, X_1, 0);
    }
  }
  *ps = (xodd (q)) ? 1 : 0;
  return z;
}

// COMPLEX*64

complex_64 cxadd (complex_64 z1, complex_64 z2, int_4 k)
{
  complex_64 w;
  w.re = xadd (z1.re, z2.re, k);
  w.im = xadd (z1.im, z2.im, k);
  return w;
}

complex_64 cxsum (complex_64 z1, complex_64 z2)
{
  complex_64 w;
  w.re = xadd (z1.re, z2.re, 0);
  w.im = xadd (z1.im, z2.im, 0);
  return w;
}

complex_64 cxsub (complex_64 z1, complex_64 z2)
{
  complex_64 w;
  w.re = xadd (z1.re, z2.re, 1);
  w.im = xadd (z1.im, z2.im, 1);
  return w;
}

complex_64 cxmul (complex_64 z1, complex_64 z2)
{
  complex_64 w;
  w.re = xadd (xmul (z1.re, z2.re), xmul (z1.im, z2.im), 1);
  w.im = xadd (xmul (z1.im, z2.re), xmul (z1.re, z2.im), 0);
  return w;
}

complex_64 cxrmul (real_32 c, complex_64 z)
{
  complex_64 w;
  w.re = xmul (c, z.re);
  w.im = xmul (c, z.im);
  return w;
}

complex_64 cxdrot (complex_64 z)
{
  complex_64 y;
  y.re = z.im;
  y.im = z.re;
// Multiplication by +i 
  y.re.value[0] ^= X_SIGN_MASK;
  return y;
}

complex_64 cxrrot (complex_64 z)
{
  complex_64 y;
  y.re = z.im;
  y.im = z.re;
// Multiplication by -i 
  y.im.value[0] ^= X_SIGN_MASK;
  return y;
}

complex_64 cxdiv (complex_64 z1, complex_64 z2)
{
  int_4 tv = cxrec (z2, &z2);
  if (!xsigerr (!tv, XEDIV, "cxdiv()")) {
    complex_64 w;
    w.re = xadd (xmul (z1.re, z2.re), xmul (z1.im, z2.im), 1);
    w.im = xadd (xmul (z1.im, z2.re), xmul (z1.re, z2.im), 0);
    return w;
  } else {
    return X_0_0I;
  }
}

complex_64 cxinv (complex_64 z)
{
  int_4 tv = cxrec (z, &z);
  if (!xsigerr (!tv, XEDOM, "cxinv()")) {
    return z;
  } else {
    return X_0_0I;
  }
}

complex_64 cxsqr (complex_64 z)
{
  complex_64 w;
  w.re = xadd (xmul (z.re, z.re), xmul (z.im, z.im), 1);
  w.im = xmul (X_2, xmul (z.im, z.re));
  return w;
}

complex_64 cxsqrt (complex_64 z)
{
  complex_64 w;
  if (xsgn (&(z.re)) == 0 && xsgn (&(z.im)) == 0) {
    w = X_0_0I;
  } else if (xis0 (&(z.im))) {
    real_32 s = xsqrt (xabs (z.re));
    if (xsgn (&(z.re)) == -1) {
      w = (complex_64) {X_0, s};
    } else {
      w = (complex_64) {s, X_0};
    }
  } else {
    real_32 mod = xsqrt (cxabs (z)), arg = xreal_2 (cxarg (z), -1);
    w.re = xmul (mod, xcos (arg));
    w.im = xmul (mod, xsin (arg));
  }   
  return w;
}

complex_64 cxreset (real_32 re, real_32 im)
{
  complex_64 y;
  y.re = re;
  y.im = im;
  return y;
}

complex_64 cxconv (real_32 x)
{
  complex_64 y;
  y.re = x;
  y.im = X_0;
  return y;
}

real_32 cxreal (complex_64 z)
{
  return z.re;
}

real_32 cximag (complex_64 z)
{
  return z.im;
}

complex_64 cxswap (complex_64 z)
{
  complex_64 y;
  y.re = z.im;
  y.im = z.re;
  return y;
}

complex_64 cxneg (complex_64 z)
{
  z.re.value[0] ^= X_SIGN_MASK;
  z.im.value[0] ^= X_SIGN_MASK;
  return z;
}

complex_64 cxconj (complex_64 z)
{
  return (z.im.value[0] ^= X_SIGN_MASK, z);
}

#define XBOUND  FLT256_LEN * 16 + 8

real_32 cxabs (complex_64 z)
{
  if (xreal_cmp (&(z.re), &X_0) == 0 && xreal_cmp (&(z.im), &X_0) == 0) {
    return X_0;
  } else {
    int_4 ea = (z.re.value[0] &= X_EXPO_MASK) - X_EXPO_BIAS;
    int_4 eb = (z.im.value[0] &= X_EXPO_MASK) - X_EXPO_BIAS;
    if (ea > eb + XBOUND) {
      return z.re;
    } else if (eb > ea + XBOUND) {
      return z.im;
    } else {
      z.re.value[0] -= eb;
      z.im.value[0] = X_EXPO_BIAS;
      real_32 x = xsqrt (xadd (xmul (z.re, z.re), xmul (z.im, z.im), 0));
      x.value[0] += eb;
      return x;
    }
  }
}

real_32 cxarg (complex_64 z)
{
  int_4 rs = xsgn (&(z.re)), is = xsgn (&(z.im));
  if (rs > 0) {
    return xatan (xdiv (z.im, z.re));
  } else if (rs < 0) {
    z.re.value[0] ^= X_SIGN_MASK;
    z.im.value[0] ^= X_SIGN_MASK;
    if (is >= 0) {
      return xadd (X_PI, xatan (xdiv (z.im, z.re)), 0);
    } else {
      return xadd (xatan (xdiv (z.im, z.re)), X_PI, 1);
    }
  } else {                      // z.re is zero ! 
    if (!xsigerr (is == 0, XEDOM, "cxarg()")) {
      return (is > 0 ? X_PI_OVER_2 : xneg (X_PI_OVER_2));
    } else {
      return xneg (X_PI_OVER_2);       // Dummy value :)
    } 
  }
}

logical_4 cxrec (complex_64 z, complex_64 * w)
{
  if (xreal_cmp (&(z.re), &X_0) == 0 && xreal_cmp (&(z.im), &X_0) == 0) {
    return FALSE;
  } else {
    int_4 sa = z.re.value[0] & X_SIGN_MASK;
    int_4 sb = z.im.value[0] & X_SIGN_MASK;
    int_4 ea = (z.re.value[0] &= X_EXPO_MASK) - X_EXPO_BIAS;
    int_4 eb = (z.im.value[0] &= X_EXPO_MASK) - X_EXPO_BIAS;
    real_32 x;
    if (ea > eb + XBOUND) {
      x = z.re;
    } else if (eb > ea + XBOUND) {
      x = z.im;
    } else {
      z.re.value[0] -= eb;
      z.im.value[0] = X_EXPO_BIAS;
      x = xsqrt (xadd (xmul (z.re, z.re), xmul (z.im, z.im), 0));
      x.value[0] += eb;
      z.re.value[0] += eb;
      z.im.value[0] += eb;
    }
    w->re = xdiv (xdiv (z.re, x), x);
    w->im = xdiv (xdiv (z.im, x), x);
    w->re.value[0] |= sa;
    w->im.value[0] |= X_SIGN_MASK ^ sb;
    return TRUE;
  }
}

complex_64 cxexp (complex_64 z)
{
  complex_64 w;
  w.re = xmul (xexp (z.re), xcos (z.im));
  w.im = xmul (xexp (z.re), xsin (z.im));
  return w;
}

complex_64 cxlog (complex_64 z)
{
  real_32 mod;
  complex_64 w;
  mod = cxabs (z);
  if (xsigerr (xsgn (&mod) <= 0, XEDOM, "cxlog()")) {
    return X_0_0I;
  } else {
    w.re = xlog (mod);
    w.im = cxarg (z);
    return w;
  }
}

complex_64 cxlog10 (complex_64 z)
{
  real_32 mod;
  complex_64 w;
  mod = cxabs (z);
  if (xsigerr (xsgn (&mod) <= 0, XEDOM, "cxlog10()")) {
    return X_0_0I;
  } else {
    w.re = xlog10 (mod);
    w.im = xmul (cxarg (z), X_LOG10_E);
    return w;
  }
}

complex_64 cxlog2 (complex_64 z)
{
  real_32 mod;
  complex_64 w;
  mod = cxabs (z);
  if (xsigerr (xsgn (&mod) <= 0, XEDOM, "cxlog2()")) {
    return X_0_0I;
  } else {
    w.re = xlog2 (mod);
    w.im = xmul (cxarg (z), X_LOG2_E);
    return w;
  }
}

complex_64 cxlog_sqrt (complex_64 z)
{
  real_32 mod = cxabs (z);
  if (xsigerr (xsgn (&mod) <= 0, XEDOM, "cxlog_sqrt()")) {
    return X_0_0I;
  } else {
    complex_64 w;
    w.re = xreal_2 (xlog (mod), -1);
    w.im = xreal_2 (cxarg (z), -1);
    return w;
  }
}

complex_64 cxsinh (complex_64 z)
{
  complex_64 w = cxsub (cxexp (z), cxexp (cxneg (z)));
  w.re = xreal_2 (w.re, -1);
  w.im = xreal_2 (w.im, -1);
  return w;
}

complex_64 cxcosh (complex_64 z)
{
  complex_64 w = cxsum (cxexp (z), cxexp (cxneg (z)));
  w.re = xreal_2 (w.re, -1);
  w.im = xreal_2 (w.im, -1);
  return w;
}

complex_64 cxtanh (complex_64 z)
{
  if (xsigerr (xreal_cmp (&(z.re), &xEmax) > 0, XFPOFLOW, NO_TEXT)) {
    return X_1_0I;
  } else if (xsigerr (xreal_cmp (&(z.re), &xEmin) < 0, XFPOFLOW, NO_TEXT)) {
    return cxneg (X_1_0I);
  } else {
    complex_64 w;
    if (xsigerr (!cxrec (cxcosh (z), &w), XEDOM, "cxtanh()")) {
      return X_0_0I;
    } else {
      return cxmul (cxsinh (z), w);
    }
  }
}

complex_64 cxasinh (complex_64 z)
{
// This way cxasinh() works fine also with real numbers very near to -oo.                                       
  complex_64 w = cxsqrt (cxsum (X_1_0I, cxsqr (z)));
  real_32 ls = cxabs (cxsum (z, w));
  real_32 rs = xmul (X_VSV, cxabs (z));
  if (xreal_cmp (&ls, &rs) < 0) {
    return cxneg (cxlog (cxsub (w, z)));
  } else {
    return cxlog (cxsum (z, w));
  }
}

complex_64 cxacosh (complex_64 z)
{
  complex_64 w = cxsqrt (cxsub (cxsqr (z), X_1_0I));
  real_32 ls = cxabs (cxsum (z, w));
  real_32 rs = xmul (X_VSV, cxabs (z));
  if (xreal_cmp (&ls, &rs) < 0) {
    return cxneg (cxlog (cxsub (z, w)));
  } else {
    return cxlog (cxsum (z, w));
  }
}

complex_64 cxatanh (complex_64 z)
{
  real_32 t = xadd (xabs (z.re), X_1, 1);
  int_4 errcond = xsgn (&(z.im)) == 0 && xsgn (&t) == 0;
  if (xsigerr (errcond, XEDOM, "cxatanh()")) {
    return X_0_0I;
  } else {
    complex_64 w = cxdiv (cxsum (X_1_0I, z), cxsub (X_1_0I, z));
    w = cxlog_sqrt (w);
    return w;
  }
}

complex_64 cxgdiv (complex_64 z1, complex_64 z2)
{
  z1.re = xround (z1.re);
  z1.im = xround (z1.im);
  z2.re = xround (z2.re);
  z2.im = xround (z2.im);
  real_32 mod2 = xadd (xmul (z2.re, z2.re), xmul (z2.im, z2.im), 0);
  if (xsigerr (xreal_cmp (&mod2, &X_PLUS_INF) >= 0, XFPOFLOW, NO_TEXT) || xsigerr (xsgn (&mod2) <= 0, XEDIV, "cxgdiv()")) {
    return X_0_0I;
  } else {
    complex_64 w;
    w.re = xadd (xmul (z1.re, z2.re), xmul (z1.im, z2.im), 0);
    w.im = xadd (xmul (z2.re, z1.im), xmul (z2.im, z1.re), 1);
    w.re = xround (xdiv (w.re, mod2));
    w.im = xround (xdiv (w.im, mod2));
    return w;
  }
}

complex_64 cxidiv (complex_64 z1, complex_64 z2)
{
  z1.re = xround (z1.re);
  z1.im = xround (z1.im);
  z2.re = xround (z2.re);
  z2.im = xround (z2.im);
  real_32 mod2 = xadd (xmul (z2.re, z2.re), xmul (z2.im, z2.im), 0);
  if (xsigerr (xreal_cmp (&mod2, &X_PLUS_INF) >= 0, XFPOFLOW, NO_TEXT) || xsigerr (xsgn (&mod2) <= 0, XEDIV, "cxidiv()")) {
    return X_0_0I;
  } else {
    complex_64 w;
    w.re = xadd (xmul (z1.re, z2.re), xmul (z1.im, z2.im), 0);
    w.im = xadd (xmul (z2.re, z1.im), xmul (z2.im, z1.re), 1);
    w.re = xfix (xdiv (w.re, mod2));
    w.im = xfix (xdiv (w.im, mod2));
    return w;
  }
}

complex_64 cxgmod (complex_64 z1, complex_64 z2)
{
  z1.re = xround (z1.re);
  z1.im = xround (z1.im);
  z2.re = xround (z2.re);
  z2.im = xround (z2.im);
  real_32 mod2 = xadd (xmul (z2.re, z2.re), xmul (z2.im, z2.im), 0);
  if (xsigerr (xreal_cmp (&mod2, &X_PLUS_INF) >= 0, XFPOFLOW, NO_TEXT) || xsigerr (xsgn (&mod2) <= 0, XEDIV, "cxgmod()")) {
    return X_0_0I;
  } else {
    complex_64 w, z;
    w.re = xadd (xmul (z1.re, z2.re), xmul (z1.im, z2.im), 0);
    w.im = xadd (xmul (z2.re, z1.im), xmul (z2.im, z1.re), 1);
    w.re = xround (xdiv (w.re, mod2));
    w.im = xround (xdiv (w.im, mod2));
    z.re = xadd (xmul (w.re, z2.re), xmul (w.im, z2.im), 1);
    z.im = xadd (xmul (w.im, z2.re), xmul (w.re, z2.im), 0);
    w.re = xround (xadd (z1.re, z.re, 1));
    w.im = xround (xadd (z1.im, z.im, 1));
    return w;
  }
}

complex_64 cxmod (complex_64 z1, complex_64 z2)
{
  z1.re = xround (z1.re);
  z1.im = xround (z1.im);
  z2.re = xround (z2.re);
  z2.im = xround (z2.im);
  real_32 mod2 = xadd (xmul (z2.re, z2.re), xmul (z2.im, z2.im), 0);
  if (xsigerr (xreal_cmp (&mod2, &X_PLUS_INF) >= 0, XFPOFLOW, NO_TEXT) || xsigerr (xsgn (&mod2) <= 0, XEDIV, "cxmod()")) {
    return X_0_0I;
  } else {
    complex_64 w, z;
    w.re = xadd (xmul (z1.re, z2.re), xmul (z1.im, z2.im), 0);
    w.im = xadd (xmul (z2.re, z1.im), xmul (z2.im, z1.re), 1);
    w.re = xfix (xdiv (w.re, mod2));
    w.im = xfix (xdiv (w.im, mod2));
    z.re = xadd (xmul (w.re, z2.re), xmul (w.im, z2.im), 1);
    z.im = xadd (xmul (w.im, z2.re), xmul (w.re, z2.im), 0);
    w.re = xround (xadd (z1.re, z.re, 1));
    w.im = xround (xadd (z1.im, z.im, 1));
    return w;
  }
}

static void unit_root (int_4 i, int_4 n, real_32 * a, real_32 * b)
{
// We assume n != 0 
  i %= n;
  *a = xdiv (xmul (xreal_2 (inttox (i), 1), X_PI), inttox (n));
  *b = xsin (*a);
  *a = xcos (*a);
  if (xgetexp (b) < -80) {
    *b = X_0;
  }
  if (xgetexp (a) < -80) {
    *a = X_0;
  }
}

complex_64 cxpwr (complex_64 z, int_4 n)
{
  real_32 mod = cxabs (z);
  if (xsgn (&mod) <= 0) {
    (void) xsigerr (n <= 0, XEBADEXP, "cxpwr()");
    return X_0_0I;
  } else {
    real_32 arg = xmul (inttox (n), cxarg (z));
    mod = xpwr (mod, n);
    complex_64 w;
    w.re = xmul (mod, xcos (arg));
    w.im = xmul (mod, xsin (arg));
    return w;
  }
}

complex_64 cxroot (complex_64 z, int_4 i, int_4 n)
{
  if (xsigerr (n == 0, XEBADEXP, "cxroot()")) {
    return X_0_0I;
  } else {
    real_32 mod = cxabs (z);
    if (xsgn (&mod) <= 0) {
      (void) xsigerr (n < 0, XEBADEXP, "cxroot()");
      return X_0_0I;
    } else {                    // mod > 0 
      real_32 arg = xdiv (cxarg (z), inttox (n));
      real_32 e = xdiv (X_1, inttox (n));      // 1/n 
// x^e = exp(e*log(x)) for any x > 0 
      mod = xexp (xmul (e, xlog (mod)));
      complex_64 w, zz;
      w.re = xmul (mod, xcos (arg));
      w.im = xmul (mod, xsin (arg));
      real_32 a, b;
      unit_root (i, n, &a, &b);
      zz.re = xadd (xmul (w.re, a), xmul (w.im, b), 1);
      zz.im = xadd (xmul (w.im, a), xmul (w.re, b), 0);
      return zz;
    }
  }
}

complex_64 cxpow (complex_64 z1, complex_64 z2)
{
  real_32 mod = cxabs (z1);
  if (xsgn (&mod) <= 0) {
    (void) xsigerr (xsgn (&z2.re) <= 0, XEBADEXP, "cxpow()");
    return X_0_0I;
  } else {
    real_32 arg = cxarg (z1);
    real_32 a = xadd (xmul (z2.re, xlog (mod)), xmul (z2.im, arg), 1);
    real_32 b = xadd (xmul (z2.re, arg), xmul (z2.im, xlog (mod)), 0);
    complex_64 w;
    w.re = xmul (xexp (a), xcos (b));
    w.im = xmul (xexp (a), xsin (b));
    return w;
  }
}

logical_4 cxis0 (const complex_64 * z)
{
  return (xis0 (&z->re) && xis0 (&z->im));
}

logical_4 cxnot0 (const complex_64 * z)
{
  return (xnot0 (&z->re) || xnot0 (&z->im));
}

logical_4 cxeq (complex_64 z1, complex_64 z2)
{
  return (xreal_cmp (&z1.re, &z2.re) == 0 && xreal_cmp (&z1.im, &z2.im) == 0);
}

logical_4 cxneq (complex_64 z1, complex_64 z2)
{
  return (xreal_cmp (&z1.re, &z2.re) != 0 || xreal_cmp (&z1.im, &z2.im) != 0);
}

complex_64 cxsin (complex_64 z)
{
  complex_64 w1, w2;
  w1 = cxdrot (z);              // Now w1= i*z,  where i={0,1} 
  w2 = cxrrot (z);              // Now w2= -i*z, where i={0,1} 
  w1 = cxsub (cxexp (w1), cxexp (w2));
  w2.re = xreal_2 (w1.im, -1);
  w1.re.value[0] ^= X_SIGN_MASK;
  w2.im = xreal_2 (w1.re, -1);     // Now w2= (exp(i*z)-exp(-i*z))/2i 
  return w2;
}

complex_64 cxcos (complex_64 z)
{
  complex_64 w1, w2;
  w1 = cxdrot (z);              // Now w1=  i*z,  where i={0,1} 
  w2 = cxrrot (z);              // Now w2= -i*z, where i={0,1} 
  w1 = cxsum (cxexp (w1), cxexp (w2));
  w2.re = xreal_2 (w1.re, -1);
  w2.im = xreal_2 (w1.im, -1);
  return w2;
}

complex_64 cxtan (complex_64 z)
{
  if (xsigerr (xreal_cmp (&(z.im), &xEmax) > 0, XFPOFLOW, NO_TEXT)) {
    return X_0_1I;
  } else if (xsigerr (xreal_cmp (&(z.im), &xEmin) < 0, XFPOFLOW, NO_TEXT)) {
    return cxneg (X_0_1I);
  } else {
    complex_64 w;
    if (xsigerr (!cxrec (cxcos (z), &w), XEDOM, "cxtan()")) {
      return X_0_0I;
    } else {
      return cxmul (cxsin (z), w);
    }
  }
}

complex_64 cxasin (complex_64 z)
{
  complex_64 w = cxsqrt (cxsub (X_1_0I, cxsqr (z)));
  real_32 ls = cxabs (cxsum (cxdrot (z), w));
  real_32 rs = xmul (X_VSV, cxabs (z));
  if (xreal_cmp (&ls, &rs) < 0) {
    w = cxdrot (cxlog (cxsub (w, cxdrot (z))));
  } else {
    w = cxrrot (cxlog (cxsum (cxdrot (z), w)));
  }
  return w;
}

complex_64 cxacos (complex_64 z)
{
  complex_64 w = cxsqrt (cxsub (X_1_0I, cxsqr (z)));
  real_32 ls = cxabs (cxsum (z, cxdrot (w)));
  real_32 rs = xmul (X_VSV, cxabs (z));
  if (xreal_cmp (&ls, &rs) < 0) {
    w = cxdrot (cxlog (cxsub (z, cxdrot (w))));
  } else {
    w = cxrrot (cxlog (cxsum (z, cxdrot (w))));
  }
  return w;
}

complex_64 cxatan (complex_64 z)
{
  real_32 mod = xadd (xabs (z.im), X_1, 1);
  int_4 errcond = xsgn (&(z.re)) == 0 && xsgn (&mod) == 0;
  if (xsigerr (errcond, XEDOM, "cxatan()")) {
    return X_0_0I;
  } else {
// This way, cxatan() works fine also with complex numbers very far from the origin.
    complex_64 w;
    mod = cxabs (z);
    if (xreal_cmp (&mod, &X_VGV) > 0) {
      w = cxsqrt (cxsum (X_1_0I, cxsqr (z)));
      w = cxdiv (cxsum (X_1_0I, cxdrot (z)), w);
      w = cxrrot (cxlog (w));
    } else {
      w = cxdiv (cxsum (X_1_0I, cxdrot (z)), cxsub (X_1_0I, cxdrot (z)));
      w = cxrrot (cxlog_sqrt (w));
    }
    return w;
  }
}

complex_64 cxflt(complex_8 z)
{
  complex_64 zz;
  zz.re = flttox (creal (z));
  zz.im = flttox (cimag (z));
  return zz;
}

complex_64 cxdbl(complex_16 z)
{
  complex_64 zz;
  zz.re = dbltox (creal (z));
  zz.im = dbltox (cimag (z));
  return zz;
}

complex_64 cxquad(complex_32 z)
{
  complex_64 zz;
  zz.re = dbltox (crealq (z));
  zz.im = dbltox (cimagq (z));
  return zz;
}

complex_32 qxcmplx(real_32 re, real_32 im)
{
  complex_32 zz;
  __real__ zz = xtoquad (re);
  __imag__ zz = xtoquad (im);
  return zz;
}

complex_64 _cquadtop (complex_64 *zz, complex_32 z)
{
  zz->re = dbltox (crealq (z));
  zz->im = dbltox (cimagq (z));
  return *zz;
}

complex_64 cxreal32(real_32 z)
{
  complex_64 zz;
  zz.re = z;
  zz.im = X_0;
  return zz;
}

complex_64 _coctotop(complex_64 *zz, real_32 z)
{
  zz->re = z;
  zz->im = X_0;
  return *zz;
}

// VIF additions (REAL*32)

real_32 xtenup (int_4 n)
{
  if (n == 0) {
    return X_1;
  } else if (n == 1) {
    return X_10;
  } else if (n == -1) {
    return X_1_OVER_10;
  }
  real_32 s = X_10, t;
  unsigned k, m;
  t = X_1;
  if (n < 0) {
    m = -n;
    if ((xsigerr (xreal_cmp (&s, &X_0) == 0, XEBADEXP, "xpwr()"))) {
      return X_0;
    }
    s = xdiv (X_1, s);
  } else {
    m = n;
  }
  if (m != 0) {
    k = 1;
    while (1) {
      if (k & m) {
        t = xmul (s, t);
      }
      if ((k <<= 1) <= m) {
        s = xmul (s, s);
      } else {
        break;
      }
    }
  } else {
    xsigerr (xreal_cmp (&s, &X_0) == 0, XEBADEXP, "xpwr()");
  }
  return t;
}

real_32 xcotan (real_32 x)
{
// Intrinsic function so arguments are not pointers.
  return xdiv (X_1, xtan (x));
}

real_32 xacotan (real_32 x)
{
// Intrinsic function so arguments are not pointers.
  return xatan (xdiv (X_1, x));
}

real_32 _xsgn (real_32 a, real_32 b)
{
// Intrinsic function so arguments are not pointers.
  real_32 x = (xgetsgn (&a) == 0 ? a : xneg (a));
  return (xgetsgn (&b) == 0 ? x : xneg (x));
}

real_32 _zabs_64 (real_32 re, real_32 im)
{
// Intrinsic function so arguments are not pointers.
  return cxabs (CMPLXX (re, im));
}

real_32 _xhypot (real_32 a, real_32 b)
{
  if (xis0 (&a) && xis0 (&b)) {
    return X_0;
  } else if (xgt (a, b)) {
    real_32 q = xdiv (b, a);
    real_32 z = xsqrt (xsum (X_1, xmul (q, q)));
    return xmul (xabs (a), z);
  } else {
    real_32 q = xdiv (a, b);
    real_32 z = xsqrt (xsum (X_1, xmul (q, q)));
    return xmul (xabs (b), z);
  }
}

// Conversion.

real_32 inttox (int_4 n)
{
  REAL32 pe;
  unt_2 *pc, e;
  unt_4 k, h;
  bzero (pe, sizeof (pe));
  k = ABS (n);
  pc = (unt_2 *) &k;
  if (n == 0) {
    return *(real_32 *) pe;
  }

  #if __BYTE_ORDER == __LITTLE_ENDIAN
    pe[1] = *(pc + 1);
    pe[2] = *pc;
  #else
    pe[1] = *pc;
    pe[2] = *(pc + 1);
  #endif

  for (e = 0, h = 1; h <= k && e < ((8 * sizeof (unt_4)) - 1); h <<= 1, ++e);
  if (h <= k) {
    e += 1;
  }
  *pe = X_EXPO_BIAS + e - 1;
  if (n < 0) {
    *pe |= X_SIGN_MASK;
  }
  xlshift ((8 * sizeof (unt_4)) - e, pe + 1, FLT256_LEN);
  return *(real_32 *) pe;
}

real_4 xtoflt (real_32 s)
{
// An extended floating point_4 number is represented as a combination of the
// following elements:
//
//   sign bit(s): 0 -> positive, 1 -> negative ;
//   exponent(e): 15-bit biased integer (bias=16383) ;
//   mantissa(m): 7 (or more) words of 16 bit length with the
//                leading 1 explicitly represented.
//
//   Thus  f = (-1)^s*2^[e-16383] *m ,  with 1 <= m < 2 .
//
// This format supports a dynamic range of:
//
//   2^16384 > f > 2^[-16383]  or
//   1.19*10^4932 > f > 1.68*10^-[4932].
//
// Special values of the exponent are:
//
//   all ones -> infinity (floating point_4 overflow)
//   all zeros -> number = zero.
//
// Underflow in operations is handled by a flush to zero. Thus, a number with
// the exponent zero and nonzero mantissa is invalid (not-a-number).
//
//
  union {unt_2 pe[2]; real_4 f;} v;
  unt_2 *pc, u;
  int_2 i, e;
  pc = SEXP (s);
  u = *pc & X_SIGN_MASK;
  e = (*pc & X_EXPO_MASK) - xF_bias;
//
// u is the sign of the number s.
// e == (exponent of s) + 127 
//
  if (e >= xF_max) {
    return (!u ? FLT_MAX : -FLT_MAX);
  }
  if (e <= 0) {
    return 0.;
  }
  for (i = 0; i < 2; v.pe[i] = *++pc, i++);
// In the IEEE 754 Standard the leading 1 is not represented.                    
  v.pe[0] &= X_EXPO_MASK;
// Now in pe[0],pe[1] we have 31 bits of mantissa. 
// But only the first 23 ones must be put in the   
// final real_4 number.                             
  xrshift (xF_lex - 1, v.pe, 2);
// We have just loaded the mantissa and now we 
// are going to load exponent and sign.        
  v.pe[0] |= (e << (16 - xF_lex));
  v.pe[0] |= u;
#if __BYTE_ORDER == __LITTLE_ENDIAN
  u = v.pe[0];
  v.pe[0] = v.pe[1];
  v.pe[1] = u;
#endif
  return v.f;
}

real_32 flttox (real_4 y)
{
  REAL32 pe; 
  unt_2 *pc, u;
  int_2 i, e;
  if (y < FLT_MIN && y > -FLT_MIN) {
    return X_0;
  }
  bzero (pe, sizeof (pe));
  pc = (unt_2 *) &y;
#if __BYTE_ORDER == __LITTLE_ENDIAN
  pc += 1;
#endif
  u = *pc & X_SIGN_MASK;
  e = xF_bias + ((*pc & X_EXPO_MASK) >> (16 - xF_lex));
// Now u is the sign of y and e is the
// biased exponent (exponent + bias).  
#if __BYTE_ORDER == __LITTLE_ENDIAN
  for (i = 1; i < 3; pe[i] = *pc--, i++);
#else
  for (i = 1; i < 3; pe[i] = *pc++, i++);
#endif
  pc = pe + 1;
  xlshift (xF_lex - 1, pc, 2);
  *pc |= X_SIGN_MASK;
// We have just put in pe[1],pe[2] the whole 
// mantissa of y with a leading 1.           
// Now we have only to put exponent and sign 
// in pe[0].                                 
  *pe = e;
  *pe |= u;
  return *(real_32 *) pe;
}

real_8 xtodbl (real_32 s)
{
  union {unt_2 pe[4]; real_8 d;} v;
  unt_2 *pc, u;
  int_2 i, e;
  pc = SEXP (s);
  u = *pc & X_SIGN_MASK;
  e = (*pc & X_EXPO_MASK) - xD_bias;
  if (e >= xD_max) {
    return (!u ? DBL_MAX : -DBL_MAX);
  }
  if (e <= 0) {
    return 0.;
  }
  for (i = 0; i < 4; v.pe[i] = *++pc, i++);
  v.pe[0] &= X_EXPO_MASK;
  xrshift (xD_lex - 1, v.pe, 4);
  v.pe[0] |= (e << (16 - xD_lex));
  v.pe[0] |= u;
#if __BYTE_ORDER == __LITTLE_ENDIAN
  u = v.pe[3];
  v.pe[3] = v.pe[0];
  v.pe[0] = u;
  u = v.pe[2];
  v.pe[2] = v.pe[1];
  v.pe[1] = u;
#endif
  return v.d;
}

real_32 dbltox (real_8 y)
{
  REAL32 pe;
  unt_2 *pc, u;
  int_2 i, e;
  if (y < DBL_MIN && y > -DBL_MIN) {
    return X_0;
  }
  bzero (pe, sizeof (pe));
  pc = (unt_2 *) &y;
#if __BYTE_ORDER == __LITTLE_ENDIAN
  pc += 3;
#endif
  u = *pc & X_SIGN_MASK;
  e = xD_bias + ((*pc & X_EXPO_MASK) >> (16 - xD_lex));
#if __BYTE_ORDER == __LITTLE_ENDIAN
  for (i = 1; i < 5; pe[i] = *pc--, i++);
#else
  for (i = 1; i < 5; pe[i] = *pc++, i++);
#endif
  pc = pe + 1;
  xlshift (xD_lex - 1, pc, 4);
  *pc |= X_SIGN_MASK;
  *pe = e;
  *pe |= u;
  return *(real_32 *) pe;
}

real_32 quadtox (real_16 x)
{
// Intrinsic function so arguments are not pointers.
  REAL32 z;
  unt_2 *y;
  int_4 i;
  if (x == 0.0q) {
    return X_0;
  }
  int_4 sinf = isinfq (x);
  if (sinf == 1) {
    return X_PLUS_INF;
  } else if (sinf == -1) {
    return X_MINUS_INF;
  }
  if (isnanq (x)) {
    return X_NAN;
  }
  bzero (z, sizeof (z));
  y = (unt_2 *) &x;
  for (i = 0; i <= 7; i++) {
#if __BYTE_ORDER == __LITTLE_ENDIAN
    z[i] = y[7 - i];
#else
    z[i] = y[i];
#endif
  }
// real_16 skips the default first bit, HPA lib does not.
  unt_2 cy = 0x8000;
  for (i = 1; i < 8; i++) {
    if (z[i] & 0x1) {
      z[i] = (z[i] >> 1) | cy;
      cy = 0x8000;
    } else {
      z[i] = (z[i] >> 1) | cy;
      cy = 0x0;
    }
  }
  z[8] |= cy;
  return *(real_32 *) z;
}

real_32 _quadtop (real_32 *z, real_16 x)
{
  *z = quadtox (x);
  return *z;
}

real_16 xtoquad (real_32 x)
{
// Intrinsic function so arguments are not pointers.
  REAL16 y;
  REAL32 z;
  int_4 i;
  memcpy (z, x.value, sizeof (real_32));
// Catch NaN, +-Inf is handled correctly.
  if (xis_nan (&x)) {
    z[0] = 0x7fff;
    z[1] = 0xffff;
  }
// real_16 skips the default first bit, HPA lib does not.
  unt_2 cy = (z[8] & 0x8000 ? 0x1 : 0x0);
  for (i = 7; i > 0; i--) {
    if (z[i] & 0x8000) {
      z[i] = (z[i] << 1) | cy;
      cy = 0x1;
    } else {
      z[i] = (z[i] << 1) | cy;
      cy = 0x0;
    }
  }
  for (i = 0; i < 8; i++) {
#if __BYTE_ORDER == __LITTLE_ENDIAN
    y[i] = z[7 - i];
#else
    y[i] = z[i];
#endif
  }
// Avoid 'dereferencing type-punned pointer will break strict-aliasing rules'
  real_16 u;
  memcpy (&u, &y[0], sizeof (real_16));
  return u;
}

real_16 cxrealq (complex_64 z)
{
  return xtoquad (cxreal (z));
}

real_16 cximagq (complex_64 z)
{
  return xtoquad (cximag (z));
}

real_32 strtox (char *s, char **end)
{
// This routine replaces the HPA solution - MvdV.
// Algol 68 Genie employs the same algorithm.
//
// Initialize.
#define N (FLT256_DIG + FLT256_GUARD)
  errno = 0;
  real_32 y[N];
  if (end != NO_REF_TEXT && (*end) != NO_TEXT) {
    (*end) = &(s[0]);
  }
  while (isspace (s[0])) {
    s++;
  }
  real_32 W;
  if (s[0] == '-') {
    W = X_MINUS_1;
    s++;
  } else if (s[0] == '+') {
    W = X_1;
    s++;
  } else {
    W = X_1;
  }
// Scan mantissa digits and put them into "y".
  while (s[0] == '0') {
    s++;
  }
  int dot = -1, pos = 0, pow = 0;
  while (pow < N && (isdigit (s[pos]) || s[pos] == '.')) {
    if (s[pos] == '.') {
      dot = pos;
    } else {
      switch (s[pos]) {
        case '0': y[pow] = X_0; break;
        case '1': y[pow] = W; break;
        case '2': y[pow] = xmul (X_2, W); break;
        case '3': y[pow] = xmul (X_3, W); break;
        case '4': y[pow] = xmul (X_4, W); break;
        case '5': y[pow] = xmul (X_5, W); break;
        case '6': y[pow] = xmul (X_6, W); break;
        case '7': y[pow] = xmul (X_7, W); break;
        case '8': y[pow] = xmul (X_8, W); break;
        case '9': y[pow] = xmul (X_9, W); break;
      }
      W = xdiv (W, X_10);
      pow++;
    }
    pos++;
  }
// Skip trailing digits.
  while (isdigit (s[pos])) {
    pos++;
  }
  if (end != NO_REF_TEXT && (*end) != NO_TEXT) {
    (*end) = &(s[pos]);
  }
// Sum from low to high to preserve precision.
  real_32 sum = X_0;
  for (int k = pow - 1; k >= 0; k--) {
    sum = xsum (sum, y[k]);
  }
// Optional exponent.
  int expo = 0;
  while (s[pos] == ' ') {
    pos++;
  }
  if (tolower (s[pos]) == 'e' || tolower (s[pos]) == 'q' || tolower (s[pos]) == 'x') {
    pos++;
    if (isdigit (s[pos]) || s[pos] == '-' || s[pos] == '+') {
      expo = (int) strtol (&(s[pos]), end, 10);
    }
  }
// Standardize.
  if (dot >= 0) {
    expo += dot - 1;
  } else {
    expo += pow - 1;
  }
  while (xnot0 (&sum) && xlt1 (sum)) {
    sum = xmul (sum, X_10);
    expo--;
  }
  if (errno == 0) {
     return xmul (sum, xtenup (expo));
  } else {
    return X_0;
  }
#undef N
}

real_32 atox (char *q)
{
  return strtox (q, NO_REF_TEXT);
}

real_32 _xdimx (real_32 x, real_32 y)
{
  if (xgt (x, y)) {
    return xsub (x, y);
  } else {
    return X_0;
  }
}

int_4 _xint4 (real_32 x_)
{
  static real_16 y_;
  y_ = xtoquad (x_);
  return (int_4) _anintq (y_);
}

int_4 _xnint4 (real_32 x_)
{
  static real_16 y_;
  if (xgt (x_, X_0)) {
    y_ = xtoquad (xsum (x_, X_1_OVER_2));
  }
  else {
    y_ = xtoquad (xsub (x_, X_1_OVER_2));
  }
  return (int_4) (y_);
}

int_8 _xint8 (real_32 x_)
{
  static real_16 y_;
  y_ = xtoquad (x_);
  return (int_8) (y_);
}

int_8 _xnint8 (real_32 x_)
{
  static real_16 y_;
  if (xgt (x_, X_0)) {
    y_ = xtoquad (xsum (x_, X_1_OVER_2));
  }
  else {
    y_ = xtoquad (xsub (x_, X_1_OVER_2));
  }
  return (int_8) (y_);
}

void _xdump (real_32 *z)
{
  printf ("{{");
  for (int i = 0; i <= FLT256_LEN; i++) {
    printf("0x%04x", (z->value)[i]);
    if (i < FLT256_LEN) {
      printf(", ");
    }
  }
  printf ("}}\n");
  fflush (stdout);
}

real_32 _x1mach (int_4 *i)
{
  switch (*i) {
//    d1mach(1) = b**(emin-1), the smallest positive magnitude. 
  case 1: return FLT256_MIN;
//    d1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude. 
  case 2: return FLT256_MAX;
//    d1mach(3) = b**(-t), the smallest relative spacing. 
  case 3: return FLT256_EPSILON_HALF;
//    d1mach(4) = b**(1-t), the largest relative spacing. 
  case 4: return FLT256_EPSILON;
//    d1mach(5) = log10(b) 
  case 5: return X_LOG10_2;
//
  default: return X_0;
  }
}

