1 /* 2 char id_lwrite[] = "@(#)lwrite.c 1.3"; 3 * 4 * list directed write 5 */ 6 7 #include "fio.h" 8 #include "lio.h" 9 10 int l_write(), t_putc(); 11 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 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: 85 fatal(F_ERSYS,"unknown type in lwrite"); 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 } 192