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);
}
