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