Commit | Line | Data |
---|---|---|
bae7117f WH |
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 | } |