| 1 | #include "f2c.h" |
| 2 | #include "fio.h" |
| 3 | #include "fmt.h" |
| 4 | #include "lio.h" |
| 5 | ftnint L_len; |
| 6 | |
| 7 | #ifdef KR_headers |
| 8 | t_putc(c) |
| 9 | #else |
| 10 | t_putc(int c) |
| 11 | #endif |
| 12 | { |
| 13 | f__recpos++; |
| 14 | putc(c,f__cf); |
| 15 | return(0); |
| 16 | } |
| 17 | static VOID |
| 18 | #ifdef KR_headers |
| 19 | lwrt_I(n) long n; |
| 20 | #else |
| 21 | lwrt_I(long n) |
| 22 | #endif |
| 23 | { |
| 24 | char buf[LINTW],*p; |
| 25 | #ifdef USE_STRLEN |
| 26 | (void) sprintf(buf," %ld",n); |
| 27 | if(f__recpos+strlen(buf)>=L_len) |
| 28 | #else |
| 29 | if(f__recpos + sprintf(buf," %ld",n) >= L_len) |
| 30 | #endif |
| 31 | (*f__donewrec)(); |
| 32 | for(p=buf;*p;PUT(*p++)); |
| 33 | } |
| 34 | static VOID |
| 35 | #ifdef KR_headers |
| 36 | lwrt_L(n, len) ftnint n; ftnlen len; |
| 37 | #else |
| 38 | lwrt_L(ftnint n, ftnlen len) |
| 39 | #endif |
| 40 | { |
| 41 | if(f__recpos+LLOGW>=L_len) |
| 42 | (*f__donewrec)(); |
| 43 | wrt_L((Uint *)&n,LLOGW, len); |
| 44 | } |
| 45 | static VOID |
| 46 | #ifdef KR_headers |
| 47 | lwrt_A(p,len) char *p; ftnlen len; |
| 48 | #else |
| 49 | lwrt_A(char *p, ftnlen len) |
| 50 | #endif |
| 51 | { |
| 52 | int i; |
| 53 | if(f__recpos+len>=L_len) |
| 54 | (*f__donewrec)(); |
| 55 | if (!f__recpos) |
| 56 | { PUT(' '); ++f__recpos; } |
| 57 | for(i=0;i<len;i++) PUT(*p++); |
| 58 | } |
| 59 | |
| 60 | static int |
| 61 | #ifdef KR_headers |
| 62 | l_g(buf, n) char *buf; double n; |
| 63 | #else |
| 64 | l_g(char *buf, double n) |
| 65 | #endif |
| 66 | { |
| 67 | #ifdef Old_list_output |
| 68 | doublereal absn; |
| 69 | char *fmt; |
| 70 | |
| 71 | absn = n; |
| 72 | if (absn < 0) |
| 73 | absn = -absn; |
| 74 | fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; |
| 75 | #ifdef USE_STRLEN |
| 76 | sprintf(buf, fmt, n); |
| 77 | return strlen(buf); |
| 78 | #else |
| 79 | return sprintf(buf, fmt, n); |
| 80 | #endif |
| 81 | |
| 82 | #else |
| 83 | register char *b, c, c1; |
| 84 | |
| 85 | b = buf; |
| 86 | *b++ = ' '; |
| 87 | if (n < 0) { |
| 88 | *b++ = '-'; |
| 89 | n = -n; |
| 90 | } |
| 91 | else |
| 92 | *b++ = ' '; |
| 93 | if (n == 0) { |
| 94 | *b++ = '0'; |
| 95 | *b++ = '.'; |
| 96 | *b = 0; |
| 97 | goto f__ret; |
| 98 | } |
| 99 | sprintf(b, LGFMT, n); |
| 100 | if (*b == '0') { |
| 101 | while(b[0] = b[1]) |
| 102 | b++; |
| 103 | } |
| 104 | /* Fortran 77 insists on having a decimal point... */ |
| 105 | else for(;; b++) |
| 106 | switch(*b) { |
| 107 | case 0: |
| 108 | *b++ = '.'; |
| 109 | *b = 0; |
| 110 | goto f__ret; |
| 111 | case '.': |
| 112 | while(*++b); |
| 113 | goto f__ret; |
| 114 | case 'E': |
| 115 | for(c1 = '.', c = 'E'; *b = c1; |
| 116 | c1 = c, c = *++b); |
| 117 | goto f__ret; |
| 118 | } |
| 119 | f__ret: |
| 120 | return b - buf; |
| 121 | #endif |
| 122 | } |
| 123 | |
| 124 | static VOID |
| 125 | #ifdef KR_headers |
| 126 | l_put(s) register char *s; |
| 127 | #else |
| 128 | l_put(register char *s) |
| 129 | #endif |
| 130 | { |
| 131 | #ifdef KR_headers |
| 132 | register int c, (*pn)() = f__putn; |
| 133 | #else |
| 134 | register int c, (*pn)(int) = f__putn; |
| 135 | #endif |
| 136 | while(c = *s++) |
| 137 | (*pn)(c); |
| 138 | } |
| 139 | |
| 140 | static VOID |
| 141 | #ifdef KR_headers |
| 142 | lwrt_F(n) double n; |
| 143 | #else |
| 144 | lwrt_F(double n) |
| 145 | #endif |
| 146 | { |
| 147 | char buf[LEFBL]; |
| 148 | |
| 149 | if(f__recpos + l_g(buf,n) >= L_len) |
| 150 | (*f__donewrec)(); |
| 151 | l_put(buf); |
| 152 | } |
| 153 | static VOID |
| 154 | #ifdef KR_headers |
| 155 | lwrt_C(a,b) double a,b; |
| 156 | #else |
| 157 | lwrt_C(double a, double b) |
| 158 | #endif |
| 159 | { |
| 160 | char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; |
| 161 | int al, bl; |
| 162 | |
| 163 | al = l_g(bufa, a); |
| 164 | for(ba = bufa; *ba == ' '; ba++) |
| 165 | --al; |
| 166 | bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ |
| 167 | for(bb = bufb; *bb == ' '; bb++) |
| 168 | --bl; |
| 169 | if(f__recpos + al + bl + 3 >= L_len && f__recpos) |
| 170 | (*f__donewrec)(); |
| 171 | PUT(' '); |
| 172 | PUT('('); |
| 173 | l_put(ba); |
| 174 | PUT(','); |
| 175 | if (f__recpos + bl >= L_len) { |
| 176 | (*f__donewrec)(); |
| 177 | PUT(' '); |
| 178 | } |
| 179 | l_put(bb); |
| 180 | PUT(')'); |
| 181 | } |
| 182 | #ifdef KR_headers |
| 183 | l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; |
| 184 | #else |
| 185 | l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) |
| 186 | #endif |
| 187 | { |
| 188 | #define Ptr ((flex *)ptr) |
| 189 | int i; |
| 190 | long x; |
| 191 | double y,z; |
| 192 | real *xx; |
| 193 | doublereal *yy; |
| 194 | for(i=0;i< *number; i++) |
| 195 | { |
| 196 | switch((int)type) |
| 197 | { |
| 198 | default: f__fatal(204,"unknown type in lio"); |
| 199 | case TYINT1: |
| 200 | x = Ptr->flchar; |
| 201 | goto xint; |
| 202 | case TYSHORT: |
| 203 | x=Ptr->flshort; |
| 204 | goto xint; |
| 205 | #ifdef TYQUAD |
| 206 | case TYQUAD: |
| 207 | x = Ptr->fllongint; |
| 208 | goto xint; |
| 209 | #endif |
| 210 | case TYLONG: |
| 211 | x=Ptr->flint; |
| 212 | xint: lwrt_I(x); |
| 213 | break; |
| 214 | case TYREAL: |
| 215 | y=Ptr->flreal; |
| 216 | goto xfloat; |
| 217 | case TYDREAL: |
| 218 | y=Ptr->fldouble; |
| 219 | xfloat: lwrt_F(y); |
| 220 | break; |
| 221 | case TYCOMPLEX: |
| 222 | xx= &Ptr->flreal; |
| 223 | y = *xx++; |
| 224 | z = *xx; |
| 225 | goto xcomplex; |
| 226 | case TYDCOMPLEX: |
| 227 | yy = &Ptr->fldouble; |
| 228 | y= *yy++; |
| 229 | z = *yy; |
| 230 | xcomplex: |
| 231 | lwrt_C(y,z); |
| 232 | break; |
| 233 | case TYLOGICAL1: |
| 234 | x = Ptr->flchar; |
| 235 | goto xlog; |
| 236 | case TYLOGICAL2: |
| 237 | x = Ptr->flshort; |
| 238 | goto xlog; |
| 239 | case TYLOGICAL: |
| 240 | x = Ptr->flint; |
| 241 | xlog: lwrt_L(Ptr->flint, len); |
| 242 | break; |
| 243 | case TYCHAR: |
| 244 | lwrt_A(ptr,len); |
| 245 | break; |
| 246 | } |
| 247 | ptr += len; |
| 248 | } |
| 249 | return(0); |
| 250 | } |