long *
_S2UL(
const void *value,
long *fca,
const long *mode,
const long *width,
const long *digits,
const long *exp,
const long *scale
)
{
int i;
long fw, *ptr;
char ch;
fw = *width - 1;
#ifdef _F_LOG4
if ((*mode & MODEHP) != 0)
ch = _lvtob( *(_f_log4 *)value) ? 'T' : 'F';
else
/* KEY: This used to have __mips */
#if defined(_F_LOG2)
if ((*mode & MODEWP) != 0) {
ch = _lvtob( *(_f_log2 *)value) ? 'T' : 'F';
} else if ((*mode & MODEBP) != 0) {
ch = _lvtob( *(_f_log1 *)value) ? 'T' : 'F';
} else
#endif /* _F_LOG2 and MIPS */
#endif /* _F_LOG4 */
{
ch = _lvtob( *(_f_log8 *)value) ? 'T' : 'F';
}
/* The following loop should vectorize */
for (i = 0; i < fw; i++)
fca[i] = (long) ' ';
ptr = fca + fw;
*ptr++ = (long) ch;
return (ptr);
}
static int
l_write(
FIOSPTR css,
unit *cup, /* Current unit pointer */
void *dptr, /* Address of data */
unsigned elsize, /* Bytes per element (used for char type only)*/
int count, /* Number of elements */
int inc, /* Number of words per element */
int type, /* Type of data */
long recsize,/* Number of characters to output per line */
int errf,
struct BUFFERS *bptr /* Structure containing formatting buffers */
)
{
unsigned int len77;
char *cp; /* points to data if type is DT_CHAR */
long *ptr; /* points to data if type is not DT_CHAR */
long ugly[ITEMBUFSIZ]; /* temporary buffer used for numeric output */
long dig;
long exp;
long mod;
long scl;
long ss;
long wid;
long *ib_ptr; /* pointer into the current item buffer */
long *newp;
int lcount; /* repeat count of current input data group */
oc_func *gcf; /* Generic NOCV-type conversion func */
ftype_t f90type;
if (type == DT_CHAR) {
/*
* Character data is unique in that one value may span
* more than one record when output.
* When we can handle opening the output file with a
* 'DELIM=' descriptor (see Ansi 8x Fortran standard), this
* code will need to change. For now, delimit the constant
* with apostrophes, and double all internal apostrophes.
*/
cp = dptr;
len77 = elsize;
for (; count > 0; count-- ) {
bptr->lcomma = 0;
if (count > 1) {
/*
* If we have an array of character data,
* determine if any values are repeated.
*/
cp = char_rep(cp, count, len77, &lcount,
bptr);
count = count - (lcount - 1);
}
/* Write the character constant */
ss = lw_A(css, cp, len77, recsize, cup, errf, bptr);
if (ss != 0) {
RERR(css, ss);
}
cp = cp + len77;
} /* for */
return(0);
} /* if (type == DT_CHAR) */
/* Noncharacter data */
ptr = (long *)dptr;
f90type = _f77_to_f90_type_cnvt[type];
if ((type == DT_DBLE) || (type == DT_CMPLX))
inc = inc + inc;
for (; count > 0; count--, ptr += inc) {
if (count > 1) { /* find repeat values */
ptr = find_rep(ptr, count, inc, type, &lcount,
bptr);
count = count - (lcount - 1);
}
ib_ptr = bptr->f_lbufptr;
switch (type) { /* set up for each data type */
case DT_NONE:
gcf = _s2uo; mod = MODEUN; wid = WOCTWRD;
dig = WOCTWRD; exp = 0; scl = 0;
break;
case DT_SINT:
case DT_INT:
gcf = _s2ui; mod = 0; wid = WINT;
dig = 1; exp = 0; scl = 0;
break;
case DT_REAL:
case DT_CMPLX:
gcf = _sd2uge; mod = 0; wid = WREAL8;
dig = _dreal8; exp = DEXP8; scl = 1;
if (YMP80) dig = 9;
break;
case DT_DBLE:
/*
* When printing with D format, decrease
* the digits by one because we are setting
* the scale factor to 1. This ensures that
* _dreal16 digits of precision are printed.
*/
gcf = _sd2udee; mod = MODEDP; wid = WREAL16;
dig = _dreal16-1; exp = DEXP16; scl = 1;
if (YMP80) dig = 25;
break;
}
/*
* Perform the output conversion.
*/
switch (type) { /* set up for each data type */
default: /* Integer, Short Integer, Real, or Double */
#if _F_REAL16 == 1 /* suppress if _f_dble is not fully supported */
if (YMP80 && !cup->uft90 && type == DT_DBLE &&
*(_f_dble *)ptr == 0.0) {
static const char *zero_dp = "0.0E+00";
ib_ptr += _unpack(zero_dp, ib_ptr,
strlen(zero_dp), -1);
break;
}
#endif
newp = gcf(ptr, ugly, &mod, &wid, &dig, &exp, &scl);
if (type == DT_NONE)
*newp++ = 'B';
ib_ptr = ib_ptr + _wnl_beautify(f90type, ugly, newp,
ib_ptr, cup->uft90);
break;
case DT_CMPLX:
*ib_ptr++ = '(';
newp = gcf(ptr, ugly, &mod, &wid, &dig, &exp, &scl);
ib_ptr = ib_ptr + _wnl_beautify(f90type, ugly, newp,
ib_ptr, cup->uft90);
*ib_ptr++ = COMMA;
newp = gcf((_f_real *)ptr + 1, ugly,
&mod, &wid, &dig, &exp, &scl);
ib_ptr = ib_ptr + _wnl_beautify(f90type, ugly, newp,
ib_ptr, cup->uft90);
*ib_ptr++ = ')';
break;
case DT_LOG:
*ib_ptr++ = _lvtob(*(_f_log8 *)ptr)? 'T':'F';
break;
} /* switch */
/*
* Update the item buffer pointers before using LPUT again.
*/
bptr->f_lbufcnt += ib_ptr - bptr->f_lbufptr;
bptr->f_lbufptr = ib_ptr;
LPUT(OUT_SEP);
LPUT(' '); /* put 2 blanks between items */
LPUT(' ');
if (bptr->outcnt <= bptr->f_lbufcnt) {
/*
* If there is not enough room in the line buffer
* to copy the next output value, flush out the line
* and start a new line.
*/
REPFLUSH();
}
bptr->f_lbufptr = bptr->f_lbuf;
_memwcpy(bptr->outptr, bptr->f_lbufptr, bptr->f_lbufcnt);
bptr->outptr += bptr->f_lbufcnt;
bptr->outcnt -= bptr->f_lbufcnt;
bptr->f_lbufptr = bptr->f_lbuf;
bptr->f_lbufcnt = 0;
}
return(0);
ret:
return(ss);
}
