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