lwrt_L(ftnint n, ftnlen len) #endif { if(f__recpos+LLOGW>=L_len) donewrec(); wrt_L((Uint *)&n,LLOGW, len); }
static void lwrt_L(ftnint n, ftnlen len) { if ((f__recpos + LLOGW) >= L_len) donewrec(); wrt_L((Uint *) &n, LLOGW, len); }
int w_ed (unit *ftnunit, struct f77syl *p, char *ptr, ftnlen len, ftnint type) { if (mv_cur (ftnunit)) return (mv_cur (ftnunit)); #ifdef I90 if (ftnunit->f90sw != 0 ) { if (ftnunit->url > 0 ) { if ( p->op == A || p->op == AW ) { if (ftnunit->f77recpos + len > ftnunit->url ) err(ftnunit->f77errlist.cierr,110,"fmt"); } else { if (ftnunit->f77recpos + p->p1 > ftnunit->url ) err(ftnunit->f77errlist.cierr,110,"fmt"); } } if ( test_type(p->op,type) != 0 ) err(ftnunit->f77errlist.cierr,117,"wrtfmt"); } #endif if (fmt_check && _WCHK[p->op][type]) { err(CILISTERR, F_TYPECONFLICT, "formatted write"); } switch (p->op) { default: /* fprintf (stderr, "w_ed, unexpected code: %d\n%s\n", p->op, ftnunit->f77fmtbuf); */ err(CILISTERR, 167, "fmt"); case I: return (wrt_I (ftnunit, (uinteger *) ptr, p->p1, len)); case IM: return (wrt_IM (ftnunit, (uinteger *) ptr, p->p1, p->p2, len)); case O: return (wrt_OZ (ftnunit, (unsigned char *) ptr, p->p1, len, 8)); case OM: return (wrt_OZM (ftnunit, (unsigned char *) ptr, p->p1, p->p2, len, 8)); case Z: return (wrt_OZ (ftnunit, (unsigned char *) ptr, p->p1, len, 16)); case ZM: return (wrt_OZM (ftnunit, (unsigned char *) ptr, p->p1, p->p2, len, 16)); case L: return (wrt_L (ftnunit, (uinteger *) ptr, p->p1, len)); case Q: return (0); case A: return (wrt_A (ftnunit, ptr, len)); case AW: return (wrt_AW (ftnunit, ptr, p->p1, len)); case D: if (len > 8) return (wrt_EQ (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1)); else return (wrt_E (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'D', 1)); case E: case EE: if (len > 8) return (wrt_EQ (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1)); else return (wrt_E (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1)); case G: case GE: return (wrt_G (ftnunit, (void *) ptr, p->op, p->p1, p->p2, p->p3, len, type, 1)); case F: if (len > 8) return(wrt_FQ (ftnunit, (ufloat *) ptr, p->p1, p->p2, 1)); else return (wrt_F (ftnunit, (ufloat *) ptr, p->p1, p->p2, len, 1)); #ifdef I90 case B: return (wrt_BM (ftnunit, (unsigned char *) ptr, p->p1, 1, len)); case BM: return (wrt_BM (ftnunit, (unsigned char *) ptr, p->p1, p->p2, len)); case EN: case ENE: if (exceed_length(ftnunit, p->p1)) return(110); if ( p->p1 == 0 || ( p->op == ENE && p->p3 == 0 ) ) { err(CILISTERR, 100, "fmt"); } if (len > 8) return (wrt_ENQ (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1)); else return (wrt_EN (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1)); case ES: case ESE: if (exceed_length(ftnunit, p->p1)) return(110); if ( p->p1 == 0 || ( p->op == ESE && p->p3 == 0 ) ) { err(CILISTERR, 100, "fmt"); } if (len > 8) return (wrt_ESQ (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1)); else return (wrt_ES (ftnunit, (ufloat *) ptr, p->p1, p->p2, p->p3, len, 'E', 1)); #endif } }
int wrt_G (unit *ftnunit, void *ptr, int op, int w, int d, int e, ftnlen len, ftnint type, flag doblank) { double upper, lower, x; int i, n, nd, ierr; short oldscale = ftnunit->f77scale; ufloat *p = (ufloat *) ptr; switch (type) { default: /* fprintf (stderr, "w_ed, bad variable type: %d\n%s\n", type, ftnunit->f77fmtbuf); */ err(CILISTERR, 117, "fmt"); case TYCHAR: if (w) { return (wrt_AW (ftnunit, (char *)ptr, w, len)); } else { return (wrt_A (ftnunit, (char *)ptr, len)); } case TYLOGICAL1: case TYLOGICAL2: case TYLOGICAL4: case TYLOGICAL8: return (wrt_L (ftnunit, (uinteger *) ptr, w, len)); case TYBYTE: case TYSHORT: case TYINT: case TYLONGLONG: return (wrt_I (ftnunit, (uinteger *) ptr, w, len)); case TYREAL: case TYDREAL: case TYCOMPLEX: case TYDCOMPLEX: case TYQUAD: case TYQUADCOMPLEX: x = (len < sizeof (double)) ? p->pf : (len == sizeof (double)) ? p->pd : (double) p->pld; if (w == 0) { if (len < 8) { w = 15; d = 7; } else if (len == 8) { w = 25; d = 16; } else { w = 40; d = 31; } e = 2; } if ( d > dmax ) { /* handle cases when d > dmax */ upper = exp10(dmax); lower = roundup(-dmax); nd = dmax; while ( d - nd > dmax-1 ) { upper *= exp10(dmax); lower *= exp10(-dmax); nd += dmax; } upper *= exp10(d-nd); lower *= exp10(-d+nd-1); upper = upper - 0.5; lower = .1 - lower; } else { upper = exp10(d) - roundup(0); lower = exp10(-1) - roundup(-d-1); } if (x < 0) x = -x; if ( (x == 0 && ftnunit->f90sw) || ( lower <= x && x < upper ) ) { /* range for effective use of F editing */ ftnunit->f77scale = 0; if (e == 0) { n = 4; } else { n = e + 2; } for ( i = 0; i <= d; ++i ) { if ( i > dmax ) { /* handle cases when i > dmax */ upper = exp10(dmax); nd = dmax; while ( i - nd > dmax ) { upper *= exp10(dmax); nd += dmax; } upper *= exp10(i-nd); } else { upper = exp10(i); } if ( d - i > dmax ) { /* handle cases when d - i > dmax */ lower = roundup(-dmax); nd = dmax; while ( d - i - nd > dmax ) { lower *= exp10(-dmax); nd += dmax; } lower *= exp10(i-d+nd); } else { lower = roundup(i-d); } upper = upper - lower; if ( x < upper || i == d ) { if (len > 8) { ierr = wrt_FQ (ftnunit, p, w - n, ( x==0 ? d-1 : d-i ), doblank); } else { ierr = wrt_F (ftnunit, p, w - n, ( x==0 ? d-1 : d-i ), len, doblank); } if (doblank) PUT (n, ' ', NULL); ftnunit->f77scale = oldscale; return (ierr); } /* endif */ } /* endloop */ } else { /* exponential notation */ if ( op == (int)GE && e == 0 ) { err(CILISTERR, 100, "fmt"); } if (len > 8) { return (wrt_EQ (ftnunit, p, w, d, e, len, 'E', doblank)); } else { return (wrt_E (ftnunit, p, w, d, e, len, 'E', doblank)); } } } /* switch */ return (0); }