wrt_F(ufloat *p, int w, int d, ftnlen len)
#endif
{
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) {
#ifdef SIGNED_ZEROS
if(signbit_f2c(&x))
sign = 2;
#endif
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 == 1) {
/* 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;
}
wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
#endif
{
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) {
#ifdef SIGNED_ZEROS
if(signbit_f2c(&dd))
signspace = sign = 1;
#endif
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;
}
l_g(char *buf, double n)
#endif
{
#ifdef Old_list_output
doublereal absn;
char *fmt;
absn = n;
if (absn < 0)
absn = -absn;
fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
#ifdef USE_STRLEN
sprintf(buf, fmt, n);
return strlen(buf);
#else
return sprintf(buf, fmt, n);
#endif
#else
register char *b, c, c1;
b = buf;
*b++ = ' ';
if (n < 0) {
*b++ = '-';
n = -n;
}
else
*b++ = ' ';
if (n == 0) {
#ifdef SIGNED_ZEROS
if (signbit_f2c(&n))
*b++ = '-';
#endif
*b++ = '0';
*b++ = '.';
*b = 0;
goto f__ret;
}
sprintf(b, LGFMT, n);
switch(*b) {
#ifndef WANT_LEAD_0
case '0':
while((b[0] = b[1]))
b++;
break;
#endif
case 'i':
case 'I':
/* Infinity */
case 'n':
case 'N':
/* NaN */
while(*++b);
break;
default:
/* Fortran 77 insists on having a decimal point... */
for(;; b++)
switch(*b) {
case 0:
*b++ = '.';
*b = 0;
goto f__ret;
case '.':
while(*++b);
goto f__ret;
case 'E':
for(c1 = '.', c = 'E'; (*b = c1); c1 = c, c = *++b);
goto f__ret;
}
}
f__ret:
return b - buf;
#endif
}
