| 1 | #include "fio.h" |
| 2 | #include "lio.h" |
| 3 | extern int l_write(); |
| 4 | int t_putc(); |
| 5 | s_wsle(a) cilist *a; |
| 6 | { |
| 7 | int n; |
| 8 | if(!init) f_init(); |
| 9 | if(n=c_le(a,WRITE)) return(n); |
| 10 | reading=0; |
| 11 | external=1; |
| 12 | formatted=1; |
| 13 | putn = t_putc; |
| 14 | lioproc = l_write; |
| 15 | if(!curunit->uwrt) |
| 16 | return(nowwriting(curunit)); |
| 17 | else return(0); |
| 18 | } |
| 19 | e_wsle() |
| 20 | { |
| 21 | t_putc('\n'); |
| 22 | recpos=0; |
| 23 | return(0); |
| 24 | } |
| 25 | t_putc(c) |
| 26 | { |
| 27 | recpos++; |
| 28 | putc(c,cf); |
| 29 | } |
| 30 | lwrt_I(n) ftnint n; |
| 31 | { |
| 32 | char buf[LINTW],*p; |
| 33 | sprintf(buf," %ld",(long)n); |
| 34 | if(recpos+strlen(buf)>=LINE) |
| 35 | { t_putc('\n'); |
| 36 | recpos=0; |
| 37 | } |
| 38 | for(p=buf;*p;t_putc(*p++)); |
| 39 | } |
| 40 | lwrt_L(n) ftnint n; |
| 41 | { |
| 42 | if(recpos+LLOGW>=LINE) |
| 43 | { t_putc('\n'); |
| 44 | recpos=0; |
| 45 | } |
| 46 | wrt_L(&n,LLOGW); |
| 47 | } |
| 48 | lwrt_A(p,len) char *p; ftnlen len; |
| 49 | { |
| 50 | int i; |
| 51 | if(recpos+len>=LINE) |
| 52 | { |
| 53 | t_putc('\n'); |
| 54 | recpos=0; |
| 55 | } |
| 56 | t_putc(' '); |
| 57 | for(i=0;i<len;i++) t_putc(*p++); |
| 58 | } |
| 59 | lwrt_F(n) double n; |
| 60 | { |
| 61 | if(LLOW<=n && n<LHIGH) |
| 62 | { |
| 63 | if(recpos+LFW>=LINE) |
| 64 | { |
| 65 | t_putc('\n'); |
| 66 | recpos=0; |
| 67 | } |
| 68 | scale=0; |
| 69 | wrt_F(&n,LFW,LFD,(ftnlen)sizeof(n)); |
| 70 | } |
| 71 | else |
| 72 | { |
| 73 | if(recpos+LEW>=LINE) |
| 74 | { t_putc('\n'); |
| 75 | recpos=0; |
| 76 | } |
| 77 | wrt_E(&n,LEW,LED,LEE,(ftnlen)sizeof(n)); |
| 78 | } |
| 79 | } |
| 80 | lwrt_C(a,b) double a,b; |
| 81 | { |
| 82 | if(recpos+2*LFW+3>=LINE) |
| 83 | { t_putc('\n'); |
| 84 | recpos=0; |
| 85 | } |
| 86 | t_putc(' '); |
| 87 | t_putc('('); |
| 88 | lwrt_F(a); |
| 89 | lwrt_F(b); |
| 90 | t_putc(')'); |
| 91 | } |
| 92 | l_write(number,ptr,len,type) ftnint *number,type; flex *ptr; ftnlen len; |
| 93 | { |
| 94 | int i; |
| 95 | ftnint x; |
| 96 | double y,z; |
| 97 | float *xx; |
| 98 | double *yy; |
| 99 | for(i=0;i< *number; i++) |
| 100 | { |
| 101 | switch((int)type) |
| 102 | { |
| 103 | default: fatal(204,"unknown type in lio"); |
| 104 | case TYSHORT: x=ptr->flshort; |
| 105 | goto xint; |
| 106 | case TYLONG: x=ptr->flint; |
| 107 | xint: lwrt_I(x); |
| 108 | break; |
| 109 | case TYREAL: y=ptr->flreal; |
| 110 | goto xfloat; |
| 111 | case TYDREAL: y=ptr->fldouble; |
| 112 | xfloat: lwrt_F(y); |
| 113 | break; |
| 114 | case TYCOMPLEX: xx= &(ptr->flreal); |
| 115 | y = *xx++; |
| 116 | z = *xx; |
| 117 | goto xcomplex; |
| 118 | case TYDCOMPLEX: yy = &(ptr->fldouble); |
| 119 | y= *yy++; |
| 120 | z = *yy; |
| 121 | xcomplex: lwrt_C(y,z); |
| 122 | break; |
| 123 | case TYLOGICAL: lwrt_L(ptr->flint); |
| 124 | break; |
| 125 | case TYCHAR: lwrt_A((char *)ptr,len); |
| 126 | break; |
| 127 | } |
| 128 | ptr = (char *)ptr + len; |
| 129 | } |
| 130 | return(0); |
| 131 | } |