Commit | Line | Data |
---|---|---|
bae7117f WH |
1 | #include "f2c.h" |
2 | #include "fio.h" | |
3 | #include "fmt.h" | |
4 | #include "lio.h" | |
5 | ftnint L_len; | |
6 | ||
7 | #ifdef KR_headers | |
8 | t_putc(c) | |
9 | #else | |
10 | t_putc(int c) | |
11 | #endif | |
12 | { | |
13 | f__recpos++; | |
14 | putc(c,f__cf); | |
15 | return(0); | |
16 | } | |
17 | static VOID | |
18 | #ifdef KR_headers | |
19 | lwrt_I(n) long n; | |
20 | #else | |
21 | lwrt_I(long n) | |
22 | #endif | |
23 | { | |
24 | char buf[LINTW],*p; | |
25 | #ifdef USE_STRLEN | |
26 | (void) sprintf(buf," %ld",n); | |
27 | if(f__recpos+strlen(buf)>=L_len) | |
28 | #else | |
29 | if(f__recpos + sprintf(buf," %ld",n) >= L_len) | |
30 | #endif | |
31 | (*f__donewrec)(); | |
32 | for(p=buf;*p;PUT(*p++)); | |
33 | } | |
34 | static VOID | |
35 | #ifdef KR_headers | |
36 | lwrt_L(n, len) ftnint n; ftnlen len; | |
37 | #else | |
38 | lwrt_L(ftnint n, ftnlen len) | |
39 | #endif | |
40 | { | |
41 | if(f__recpos+LLOGW>=L_len) | |
42 | (*f__donewrec)(); | |
43 | wrt_L((Uint *)&n,LLOGW, len); | |
44 | } | |
45 | static VOID | |
46 | #ifdef KR_headers | |
47 | lwrt_A(p,len) char *p; ftnlen len; | |
48 | #else | |
49 | lwrt_A(char *p, ftnlen len) | |
50 | #endif | |
51 | { | |
52 | int i; | |
53 | if(f__recpos+len>=L_len) | |
54 | (*f__donewrec)(); | |
55 | if (!f__recpos) | |
56 | { PUT(' '); ++f__recpos; } | |
57 | for(i=0;i<len;i++) PUT(*p++); | |
58 | } | |
59 | ||
60 | static int | |
61 | #ifdef KR_headers | |
62 | l_g(buf, n) char *buf; double n; | |
63 | #else | |
64 | l_g(char *buf, double n) | |
65 | #endif | |
66 | { | |
67 | #ifdef Old_list_output | |
68 | doublereal absn; | |
69 | char *fmt; | |
70 | ||
71 | absn = n; | |
72 | if (absn < 0) | |
73 | absn = -absn; | |
74 | fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; | |
75 | #ifdef USE_STRLEN | |
76 | sprintf(buf, fmt, n); | |
77 | return strlen(buf); | |
78 | #else | |
79 | return sprintf(buf, fmt, n); | |
80 | #endif | |
81 | ||
82 | #else | |
83 | register char *b, c, c1; | |
84 | ||
85 | b = buf; | |
86 | *b++ = ' '; | |
87 | if (n < 0) { | |
88 | *b++ = '-'; | |
89 | n = -n; | |
90 | } | |
91 | else | |
92 | *b++ = ' '; | |
93 | if (n == 0) { | |
94 | *b++ = '0'; | |
95 | *b++ = '.'; | |
96 | *b = 0; | |
97 | goto f__ret; | |
98 | } | |
99 | sprintf(b, LGFMT, n); | |
100 | if (*b == '0') { | |
101 | while(b[0] = b[1]) | |
102 | b++; | |
103 | } | |
104 | /* Fortran 77 insists on having a decimal point... */ | |
105 | else for(;; b++) | |
106 | switch(*b) { | |
107 | case 0: | |
108 | *b++ = '.'; | |
109 | *b = 0; | |
110 | goto f__ret; | |
111 | case '.': | |
112 | while(*++b); | |
113 | goto f__ret; | |
114 | case 'E': | |
115 | for(c1 = '.', c = 'E'; *b = c1; | |
116 | c1 = c, c = *++b); | |
117 | goto f__ret; | |
118 | } | |
119 | f__ret: | |
120 | return b - buf; | |
121 | #endif | |
122 | } | |
123 | ||
124 | static VOID | |
125 | #ifdef KR_headers | |
126 | l_put(s) register char *s; | |
127 | #else | |
128 | l_put(register char *s) | |
129 | #endif | |
130 | { | |
131 | #ifdef KR_headers | |
132 | register int c, (*pn)() = f__putn; | |
133 | #else | |
134 | register int c, (*pn)(int) = f__putn; | |
135 | #endif | |
136 | while(c = *s++) | |
137 | (*pn)(c); | |
138 | } | |
139 | ||
140 | static VOID | |
141 | #ifdef KR_headers | |
142 | lwrt_F(n) double n; | |
143 | #else | |
144 | lwrt_F(double n) | |
145 | #endif | |
146 | { | |
147 | char buf[LEFBL]; | |
148 | ||
149 | if(f__recpos + l_g(buf,n) >= L_len) | |
150 | (*f__donewrec)(); | |
151 | l_put(buf); | |
152 | } | |
153 | static VOID | |
154 | #ifdef KR_headers | |
155 | lwrt_C(a,b) double a,b; | |
156 | #else | |
157 | lwrt_C(double a, double b) | |
158 | #endif | |
159 | { | |
160 | char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; | |
161 | int al, bl; | |
162 | ||
163 | al = l_g(bufa, a); | |
164 | for(ba = bufa; *ba == ' '; ba++) | |
165 | --al; | |
166 | bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ | |
167 | for(bb = bufb; *bb == ' '; bb++) | |
168 | --bl; | |
169 | if(f__recpos + al + bl + 3 >= L_len && f__recpos) | |
170 | (*f__donewrec)(); | |
171 | PUT(' '); | |
172 | PUT('('); | |
173 | l_put(ba); | |
174 | PUT(','); | |
175 | if (f__recpos + bl >= L_len) { | |
176 | (*f__donewrec)(); | |
177 | PUT(' '); | |
178 | } | |
179 | l_put(bb); | |
180 | PUT(')'); | |
181 | } | |
182 | #ifdef KR_headers | |
183 | l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; | |
184 | #else | |
185 | l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) | |
186 | #endif | |
187 | { | |
188 | #define Ptr ((flex *)ptr) | |
189 | int i; | |
190 | long x; | |
191 | double y,z; | |
192 | real *xx; | |
193 | doublereal *yy; | |
194 | for(i=0;i< *number; i++) | |
195 | { | |
196 | switch((int)type) | |
197 | { | |
198 | default: f__fatal(204,"unknown type in lio"); | |
199 | case TYINT1: | |
200 | x = Ptr->flchar; | |
201 | goto xint; | |
202 | case TYSHORT: | |
203 | x=Ptr->flshort; | |
204 | goto xint; | |
205 | #ifdef TYQUAD | |
206 | case TYQUAD: | |
207 | x = Ptr->fllongint; | |
208 | goto xint; | |
209 | #endif | |
210 | case TYLONG: | |
211 | x=Ptr->flint; | |
212 | xint: lwrt_I(x); | |
213 | break; | |
214 | case TYREAL: | |
215 | y=Ptr->flreal; | |
216 | goto xfloat; | |
217 | case TYDREAL: | |
218 | y=Ptr->fldouble; | |
219 | xfloat: lwrt_F(y); | |
220 | break; | |
221 | case TYCOMPLEX: | |
222 | xx= &Ptr->flreal; | |
223 | y = *xx++; | |
224 | z = *xx; | |
225 | goto xcomplex; | |
226 | case TYDCOMPLEX: | |
227 | yy = &Ptr->fldouble; | |
228 | y= *yy++; | |
229 | z = *yy; | |
230 | xcomplex: | |
231 | lwrt_C(y,z); | |
232 | break; | |
233 | case TYLOGICAL1: | |
234 | x = Ptr->flchar; | |
235 | goto xlog; | |
236 | case TYLOGICAL2: | |
237 | x = Ptr->flshort; | |
238 | goto xlog; | |
239 | case TYLOGICAL: | |
240 | x = Ptr->flint; | |
241 | xlog: lwrt_L(Ptr->flint, len); | |
242 | break; | |
243 | case TYCHAR: | |
244 | lwrt_A(ptr,len); | |
245 | break; | |
246 | } | |
247 | ptr += len; | |
248 | } | |
249 | return(0); | |
250 | } |