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