|
|
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.