307 lines
4.8 KiB
C
307 lines
4.8 KiB
C
#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 (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;
|
|
}
|