![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to wref.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / libI77|
Return to wref.c CVS log | Up to [Research Unix] / researchv10dc / libI77 |
1.1 root 1: #include "f2c.h"
2: #include "fio.h"
3: #include "fmt.h"
4: #include "fp.h"
5: #ifndef VAX
6: #include "ctype.h"
7: #endif
8:
9: #ifndef KR_headers
10: #undef abs
11: #undef min
12: #undef max
13: #include "stdlib.h"
14: #include "string.h"
15: #endif
16:
17: #ifdef KR_headers
18: wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
19: #else
20: wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
21: #endif
22: {
23: char buf[FMAX+EXPMAXDIGS+4], *s, *se;
24: int d1, delta, e1, i, sign, signspace;
25: double dd;
26: #ifndef VAX
27: int e0 = e;
28: #endif
29:
30: if(e <= 0)
31: e = 2;
32: if(f__scale) {
33: if(f__scale >= d + 2 || f__scale <= -d)
34: goto nogood;
35: }
36: if(f__scale <= 0)
37: --d;
38: if (len == sizeof(real))
39: dd = p->pf;
40: else
41: dd = p->pd;
42: if (dd < 0.) {
43: signspace = sign = 1;
44: dd = -dd;
45: }
46: else {
47: sign = 0;
48: signspace = (int)f__cplus;
49: #ifndef VAX
50: if (!dd)
51: dd = 0.; /* avoid -0 */
52: #endif
53: }
54: delta = w - (2 /* for the . and the d adjustment above */
55: + 2 /* for the E+ */ + signspace + d + e);
56: if (delta < 0) {
57: nogood:
58: while(--w >= 0)
59: PUT('*');
60: return(0);
61: }
62: if (f__scale < 0)
63: d += f__scale;
64: if (d > FMAX) {
65: d1 = d - FMAX;
66: d = FMAX;
67: }
68: else
69: d1 = 0;
70: sprintf(buf,"%#.*E", d, dd);
71: #ifndef VAX
72: /* check for NaN, Infinity */
73: if (!isdigit(buf[0])) {
74: switch(buf[0]) {
75: case 'n':
76: case 'N':
77: signspace = 0; /* no sign for NaNs */
78: }
79: delta = w - strlen(buf) - signspace;
80: if (delta < 0)
81: goto nogood;
82: while(--delta >= 0)
83: PUT(' ');
84: if (signspace)
85: PUT(sign ? '-' : '+');
86: for(s = buf; *s; s++)
87: PUT(*s);
88: return 0;
89: }
90: #endif
91: se = buf + d + 3;
92: if (f__scale != 1 && dd)
93: sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
94: s = ++se;
95: if (e < 2) {
96: if (*s != '0')
97: goto nogood;
98: }
99: #ifndef VAX
100: /* accommodate 3 significant digits in exponent */
101: if (s[2]) {
102: #ifdef Pedantic
103: if (!e0 && !s[3])
104: for(s -= 2, e1 = 2; s[0] = s[1]; s++);
105:
106: /* Pedantic gives the behavior that Fortran 77 specifies, */
107: /* i.e., requires that E be specified for exponent fields */
108: /* of more than 3 digits. With Pedantic undefined, we get */
109: /* the behavior that Cray displays -- you get a bigger */
110: /* exponent field if it fits. */
111: #else
112: if (!e0) {
113: for(s -= 2, e1 = 2; s[0] = s[1]; s++)
114: #ifdef CRAY
115: delta--;
116: if ((delta += 4) < 0)
117: goto nogood
118: #endif
119: ;
120: }
121: #endif
122: else if (e0 >= 0)
123: goto shift;
124: else
125: e1 = e;
126: }
127: else
128: shift:
129: #endif
130: for(s += 2, e1 = 2; *s; ++e1, ++s)
131: if (e1 >= e)
132: goto nogood;
133: while(--delta >= 0)
134: PUT(' ');
135: if (signspace)
136: PUT(sign ? '-' : '+');
137: s = buf;
138: i = f__scale;
139: if (f__scale <= 0) {
140: PUT('.');
141: for(; i < 0; ++i)
142: PUT('0');
143: PUT(*s);
144: s += 2;
145: }
146: else if (f__scale > 1) {
147: PUT(*s);
148: s += 2;
149: while(--i > 0)
150: PUT(*s++);
151: PUT('.');
152: }
153: if (d1) {
154: se -= 2;
155: while(s < se) PUT(*s++);
156: se += 2;
157: do PUT('0'); while(--d1 > 0);
158: }
159: while(s < se)
160: PUT(*s++);
161: if (e < 2)
162: PUT(s[1]);
163: else {
164: while(++e1 <= e)
165: PUT('0');
166: while(*s)
167: PUT(*s++);
168: }
169: return 0;
170: }
171:
172: #ifdef KR_headers
173: wrt_F(p,w,d,len) ufloat *p; ftnlen len;
174: #else
175: wrt_F(ufloat *p, int w, int d, ftnlen len)
176: #endif
177: {
178: int d1, sign, n;
179: double x;
180: char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
181:
182: x= (len==sizeof(real)?p->pf:p->pd);
183: if (d < MAXFRACDIGS)
184: d1 = 0;
185: else {
186: d1 = d - MAXFRACDIGS;
187: d = MAXFRACDIGS;
188: }
189: if (x < 0.)
190: { x = -x; sign = 1; }
191: else {
192: sign = 0;
193: #ifndef VAX
194: if (!x)
195: x = 0.;
196: #endif
197: }
198:
199: if (n = f__scale)
200: if (n > 0)
201: do x *= 10.; while(--n > 0);
202: else
203: do x *= 0.1; while(++n < 0);
204:
205: #ifdef USE_STRLEN
206: sprintf(b = buf, "%#.*f", d, x);
207: n = strlen(b) + d1;
208: #else
209: n = sprintf(b = buf, "%#.*f", d, x) + d1;
210: #endif
211:
212: if (buf[0] == '0' && d)
213: { ++b; --n; }
214: if (sign) {
215: /* check for all zeros */
216: for(s = b;;) {
217: while(*s == '0') s++;
218: switch(*s) {
219: case '.':
220: s++; continue;
221: case 0:
222: sign = 0;
223: }
224: break;
225: }
226: }
227: if (sign || f__cplus)
228: ++n;
229: if (n > w) {
230: while(--w >= 0)
231: PUT('*');
232: return 0;
233: }
234: for(w -= n; --w >= 0; )
235: PUT(' ');
236: if (sign)
237: PUT('-');
238: else if (f__cplus)
239: PUT('+');
240: while(n = *b++)
241: PUT(n);
242: while(--d1 >= 0)
243: PUT('0');
244: return 0;
245: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.