![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lwrite.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / libI77|
Return to lwrite.c CVS log | Up to [Research Unix] / researchv10dc / libI77 |
1.1 ! root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.