| #include "f2c.h" |
| #include "fio.h" |
| #ifndef VAX |
| #include <ctype.h> |
| #endif |
| |
| #ifndef KR_headers |
| #undef abs |
| #undef min |
| #undef max |
| #include <stdlib.h> |
| #include <string.h> |
| #endif |
| |
| #include "fmt.h" |
| #include "fp.h" |
| |
| #ifdef KR_headers |
| wrt_E(p,w,d,e,len) ufloat *p; ftnlen len; |
| #else |
| 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) |
| 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; |
| } |
| |
| #ifdef KR_headers |
| wrt_F(p,w,d,len) ufloat *p; ftnlen len; |
| #else |
| 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) |
| 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; |
| } |