|
|
1.1 root 1: /*
2: char id_lwrite[] = "@(#)lwrite.c 1.2";
3: *
4: * list directed write
5: */
6:
7: #include "fio.h"
8: #include "lio.h"
9:
10: int l_write(), t_putc();
11:
12: s_wsle(a) cilist *a;
13: {
14: int n;
15: reading = NO;
16: if(n=c_le(a,WRITE)) return(n);
17: putn = t_putc;
18: lioproc = l_write;
19: line_len = LINE;
20: curunit->uend = NO;
21: leof = NO;
22: if(!curunit->uwrt) nowwriting(curunit);
23: return(OK);
24: }
25:
26: t_putc(c) char c;
27: {
28: if(c=='\n') recpos=0;
29: else recpos++;
30: putc(c,cf);
31: return(OK);
32: }
33:
34: e_wsle()
35: { int n;
36: PUT('\n')
37: return(OK);
38: }
39:
40: l_write(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len;
41: {
42: int i,n;
43: ftnint x;
44: float y,z;
45: double yd,zd;
46: float *xx;
47: double *yy;
48: for(i=0;i< *number; i++)
49: {
50: switch((int)type)
51: {
52: case TYSHORT:
53: x=ptr->flshort;
54: goto xint;
55: case TYLONG:
56: x=ptr->flint;
57: xint: ERR(lwrt_I(x));
58: break;
59: case TYREAL:
60: ERR(lwrt_F(ptr->flreal));
61: break;
62: case TYDREAL:
63: ERR(lwrt_D(ptr->fldouble));
64: break;
65: case TYCOMPLEX:
66: xx= &(ptr->flreal);
67: y = *xx++;
68: z = *xx;
69: ERR(lwrt_C(y,z));
70: break;
71: case TYDCOMPLEX:
72: yy = &(ptr->fldouble);
73: yd= *yy++;
74: zd = *yy;
75: ERR(lwrt_DC(yd,zd));
76: break;
77: case TYLOGICAL:
78: ERR(lwrt_L(ptr->flint));
79: break;
80: case TYCHAR:
81: ERR(lwrt_A((char *)ptr,len));
82: break;
83: default:
84: fatal(F_ERSYS,"unknown type in lwrite");
85: }
86: ptr = (char *)ptr + len;
87: }
88: return(OK);
89: }
90:
91: lwrt_I(in) ftnint in;
92: { int n;
93: char buf[16],*p;
94: sprintf(buf," %ld",(long)in);
95: if(n=chk_len(LINTW)) return(n);
96: for(p=buf;*p;) PUT(*p++)
97: return(OK);
98: }
99:
100: lwrt_L(ln) ftnint ln;
101: { int n;
102: if(n=chk_len(LLOGW)) return(n);
103: return(wrt_L(&ln,LLOGW));
104: }
105:
106: lwrt_A(p,len) char *p; ftnlen len;
107: { int i,n;
108: if(n=chk_len(LSTRW)) return(n);
109: PUT(' ')
110: PUT(' ')
111: for(i=0;i<len;i++) PUT(*p++)
112: return(OK);
113: }
114:
115: lwrt_F(fn) float fn;
116: { int d,n; float x; ufloat f;
117: if(fn==0.0) return(lwrt_0());
118: f.pf = fn;
119: d = width(fn);
120: if(n=chk_len(d)) return(n);
121: if(d==LFW)
122: {
123: scale = 0;
124: for(d=LFD,x=abs(fn);x>=1.0;x/=10.0,d--);
125: return(wrt_F(&f,LFW,d,(ftnlen)sizeof(float)));
126: }
127: else
128: {
129: scale = 1;
130: return(wrt_E(&f,LEW,LED-scale,LEE,(ftnlen)sizeof(float)));
131: }
132: }
133:
134: lwrt_D(dn) double dn;
135: { int d,n; double x; ufloat f;
136: if(dn==0.0) return(lwrt_0());
137: f.pd = dn;
138: d = dwidth(dn);
139: if(n=chk_len(d)) return(n);
140: if(d==LDFW)
141: {
142: scale = 0;
143: for(d=LDFD,x=abs(dn);x>=1.0;x/=10.0,d--);
144: return(wrt_F(&f,LDFW,d,(ftnlen)sizeof(double)));
145: }
146: else
147: {
148: scale = 1;
149: return(wrt_E(&f,LDEW,LDED-scale,LDEE,(ftnlen)sizeof(double)));
150: }
151: }
152:
153: lwrt_C(a,b) float a,b;
154: { int n;
155: if(n=chk_len(LCW)) return(n);
156: PUT(' ')
157: PUT(' ')
158: PUT('(')
159: if(n=lwrt_F(a)) return(n);
160: PUT(',')
161: if(n=lwrt_F(b)) return(n);
162: PUT(')')
163: return(OK);
164: }
165:
166: lwrt_DC(a,b) double a,b;
167: { int n;
168: if(n=chk_len(LDCW)) return(n);
169: PUT(' ')
170: PUT(' ')
171: PUT('(')
172: if(n=lwrt_D(a)) return(n);
173: PUT(',')
174: if(n=lwrt_D(b)) return(n);
175: PUT(')')
176: return(OK);
177: }
178:
179: lwrt_0()
180: { int n; char *z = " 0.";
181: if(n=chk_len(4)) return(n);
182: while(*z) PUT(*z++)
183: return(OK);
184: }
185:
186: chk_len(w)
187: { int n;
188: if(recpos+w > line_len) PUT('\n')
189: return(OK);
190: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.