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