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 = (flex *)((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 } 191