![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lwrite.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 lwrite.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 "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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.