diff options
Diffstat (limited to 'contrib/libf2c/libI77/wref.c')
| -rw-r--r-- | contrib/libf2c/libI77/wref.c | 306 |
1 files changed, 306 insertions, 0 deletions
diff --git a/contrib/libf2c/libI77/wref.c b/contrib/libf2c/libI77/wref.c new file mode 100644 index 0000000..0dc3091 --- /dev/null +++ b/contrib/libf2c/libI77/wref.c @@ -0,0 +1,306 @@ +#include "f2c.h" +#include "fio.h" +#ifndef VAX +#include <ctype.h> +#endif + +#undef abs +#undef min +#undef max +#include <stdlib.h> +#include <string.h> + +#include "fmt.h" +#include "fp.h" + +int +wrt_E (ufloat * p, int w, int d, int e, ftnlen len) +{ + char buf[FMAX + EXPMAXDIGS + 4], *s, *se; + int d1, delta, e1, i, sign, signspace; + double dd; +#ifdef WANT_LEAD_0 + int insert0 = 0; +#endif +#ifndef VAX + int e0 = e; +#endif + + if (e <= 0) + e = 2; + if (f__scale) + { + if (f__scale >= d + 2 || f__scale <= -d) + goto nogood; + } + if (f__scale <= 0) + --d; + if (len == sizeof (real)) + dd = p->pf; + else + dd = p->pd; + if (dd < 0.) + { + signspace = sign = 1; + dd = -dd; + } + else + { + sign = 0; + signspace = (int) f__cplus; +#ifndef VAX + if (!dd) + dd = 0.; /* avoid -0 */ +#endif + } + delta = w - (2 /* for the . and the d adjustment above */ + + 2 /* for the E+ */ + signspace + d + e); +#ifdef WANT_LEAD_0 + if (f__scale <= 0 && delta > 0) + { + delta--; + insert0 = 1; + } + else +#endif + if (delta < 0) + { + nogood: + while (--w >= 0) + PUT ('*'); + return (0); + } + if (f__scale < 0) + d += f__scale; + if (d > FMAX) + { + d1 = d - FMAX; + d = FMAX; + } + else + d1 = 0; + sprintf (buf, "%#.*E", d, dd); +#ifndef VAX + /* check for NaN, Infinity */ + if (!isdigit ((unsigned char) buf[0])) + { + switch (buf[0]) + { + case 'n': + case 'N': + signspace = 0; /* no sign for NaNs */ + } + delta = w - strlen (buf) - signspace; + if (delta < 0) + goto nogood; + while (--delta >= 0) + PUT (' '); + if (signspace) + PUT (sign ? '-' : '+'); + for (s = buf; *s; s++) + PUT (*s); + return 0; + } +#endif + se = buf + d + 3; +#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ + if (f__scale != 1 && dd) + sprintf (se, "%+.2d", atoi (se) + 1 - f__scale); +#else + if (dd) + sprintf (se, "%+.2d", atoi (se) + 1 - f__scale); + else + strcpy (se, "+00"); +#endif + s = ++se; + if (e < 2) + { + if (*s != '0') + goto nogood; + } +#ifndef VAX + /* accommodate 3 significant digits in exponent */ + if (s[2]) + { +#ifdef Pedantic + if (!e0 && !s[3]) + for (s -= 2, e1 = 2; s[0] = s[1]; s++); + + /* Pedantic gives the behavior that Fortran 77 specifies, */ + /* i.e., requires that E be specified for exponent fields */ + /* of more than 3 digits. With Pedantic undefined, we get */ + /* the behavior that Cray displays -- you get a bigger */ + /* exponent field if it fits. */ +#else + if (!e0) + { + for (s -= 2, e1 = 2; (s[0] = s[1]); s++) +#ifdef CRAY + delta--; + if ((delta += 4) < 0) + goto nogood +#endif + ; + } +#endif + else if (e0 >= 0) + goto shift; + else + e1 = e; + } + else + shift: +#endif + for (s += 2, e1 = 2; *s; ++e1, ++s) + if (e1 >= e) + goto nogood; + while (--delta >= 0) + PUT (' '); + if (signspace) + PUT (sign ? '-' : '+'); + s = buf; + i = f__scale; + if (f__scale <= 0) + { +#ifdef WANT_LEAD_0 + if (insert0) + PUT ('0'); +#endif + PUT ('.'); + for (; i < 0; ++i) + PUT ('0'); + PUT (*s); + s += 2; + } + else if (f__scale > 1) + { + PUT (*s); + s += 2; + while (--i > 0) + PUT (*s++); + PUT ('.'); + } + if (d1) + { + se -= 2; + while (s < se) + PUT (*s++); + se += 2; + do + PUT ('0'); + while (--d1 > 0); + } + while (s < se) + PUT (*s++); + if (e < 2) + PUT (s[1]); + else + { + while (++e1 <= e) + PUT ('0'); + while (*s) + PUT (*s++); + } + return 0; +} + +int +wrt_F (ufloat * p, int w, int d, ftnlen len) +{ + int d1, sign, n; + double x; + char *b, buf[MAXINTDIGS + MAXFRACDIGS + 4], *s; + + x = (len == sizeof (real) ? p->pf : p->pd); + if (d < MAXFRACDIGS) + d1 = 0; + else + { + d1 = d - MAXFRACDIGS; + d = MAXFRACDIGS; + } + if (x < 0.) + { + x = -x; + sign = 1; + } + else + { + sign = 0; +#ifndef VAX + if (!x) + x = 0.; +#endif + } + + if ((n = f__scale)) + { + if (n > 0) + do + x *= 10.; + while (--n > 0); + else + do + x *= 0.1; + while (++n < 0); + } + +#ifdef USE_STRLEN + sprintf (b = buf, "%#.*f", d, x); + n = strlen (b) + d1; +#else + n = sprintf (b = buf, "%#.*f", d, x) + d1; +#endif + +#ifndef WANT_LEAD_0 + if (buf[0] == '0' && d) + { + ++b; + --n; + } +#endif + if (sign) + { + /* check for all zeros */ + for (s = b;;) + { + while (*s == '0') + s++; + switch (*s) + { + case '.': + s++; + continue; + case 0: + sign = 0; + } + break; + } + } + if (sign || f__cplus) + ++n; + if (n > w) + { +#ifdef WANT_LEAD_0 + if (buf[0] == '0' && --n == w) + ++b; + else +#endif + { + while (--w >= 0) + PUT ('*'); + return 0; + } + } + for (w -= n; --w >= 0;) + PUT (' '); + if (sign) + PUT ('-'); + else if (f__cplus) + PUT ('+'); + while ((n = *b++)) + PUT (n); + while (--d1 >= 0) + PUT ('0'); + return 0; +} |
