int
_iochunk(
FIOSPTR css,
unit *cup,
xfer_func *func,
struct DvDimen *dim,
type_packet *tip, /* Type information packet */
short nd, /* number of dimensions (must be >= 1) */
long extent, /* number of elements in first dimension */
int bshft, /* see _stride_dv for details about bshft */
bcont *addr) /* data pointer */
{
register int errn;
register long binc; /* stride (in bytes) passed to gather/scatter */
register long dim2_ex;
register long dim1_pb;
register long dim1_sz;
register long i;
register long id3, id4, id5, id6, id7;
#ifdef KEY
/* align lbuf on 64-bit boundary */
long long lbuf[CHBUFSIZE / sizeof(long long)];
#else
long lbuf[CHBUFSIZE / sizeof(long)];
#endif
char *lptr;
bcont *addr2, *addr3, *addr4, *addr5, *addr6;
/* Do not call this if dim1 does not fit in chunking buffer */
assert ( (extent * tip->elsize) <= CHBUFSIZE );
binc = tip->elsize * tip->stride; /* stride in bytes */
dim1_sz = extent * tip->elsize; /* size (bytes) of dim 1 */
tip->stride = 1; /* linear, from here on down */
if (nd == 1)
dim2_ex = 1;
else
dim2_ex = dim[1].extent;
dim1_pb = CHBUFSIZE / dim1_sz; /* dim 1 extents per buffer */
if (dim1_pb > dim2_ex)
dim1_pb = dim2_ex; /* reduce to dim 2 extent */
switch (nd) {
case 7:
for (id7 = 0; id7 < dim[6].extent; id7++) {
addr6 = addr;
case 6:
for (id6 = 0; id6 < dim[5].extent; id6++) {
addr5 = addr;
case 5:
for (id5 = 0; id5 < dim[4].extent; id5++) {
addr4 = addr;
case 4:
for (id4 = 0; id4 < dim[3].extent; id4++) {
addr3 = addr;
case 3:
for (id3 = 0; id3 < dim[2].extent; id3++) {
addr2 = addr;
case 2:
dim2_ex = dim[1].extent;
while (dim2_ex > 0) {
if (dim1_pb > dim2_ex)
dim1_pb = dim2_ex;
case 1:
lptr = (char *) lbuf;
tip->count = dim1_pb * extent;
if (cup->uwrt) { /* If writing */
/*
* This loop transfers 1 or more passes through
* dimension 1 to cup->ucbuf buffer.
*/
for (i = 0; i < dim1_pb; i++) {
_gather_data(lptr, extent, binc, tip->elsize, addr);
addr = addr + (dim[1].stride_mult << bshft);
lptr = lptr + dim1_sz;
}
errn = func(css, cup, lbuf, tip, PARTIAL);
}
else { /* If reading */
errn = func(css, cup, lbuf, tip, PARTIAL);
/*
* This loop transfers 1 or more passes through
* dimension 1 from the lbuf[] buffer.
*/
for (i = 0; i < dim1_pb; i++) {
_scatter_data(addr, extent, binc, tip->elsize, lptr);
addr = addr + (dim[1].stride_mult << bshft);
lptr = lptr + dim1_sz;
}
}
if (errn != 0) goto done;
dim2_ex = dim2_ex - dim1_pb;
if (nd == 1) goto done;
}
if (nd == 2) goto done;
addr = addr2 + (dim[2].stride_mult << bshft);
}
if (nd == 3) goto done;
addr = addr3 + (dim[3].stride_mult << bshft);
}
if (nd == 4) goto done;
addr = addr4 + (dim[4].stride_mult << bshft);
}
if (nd == 5) goto done;
addr = addr5 + (dim[5].stride_mult << bshft);
}
if (nd == 6) goto done;
addr = addr6 + (dim[6].stride_mult << bshft);
}
}
done:
return(errn);
}
int
_wrunf(
#endif
FIOSPTR css, /* Current Fortran I/O statement state */
unit *cup, /* Unit pointer */
void *ptr, /* Pointer to data */
type_packet *tip, /* Type information packet */
int mode /* Mode argument to _fwwd() */
)
{
register short shared; /* 1 iff ptr points to sdd */
register int errn; /* Error number */
register int64 fillen; /* bit size of each element, on disk */
register long count; /* Number of data items */
register long elsize; /* element size in bytes */
register long i;
register long incb; /* inc (in units of bytes) */
register long items;
long lbuf[LOCBUFLN];
void *fwwdbuf; /* ptr to buffer passed to _fwwd */
#ifdef _CRAYT3D
register long elwords; /* element size in words */
#endif
errn = 0;
shared = 0;
count = tip->count;
elsize = tip->elsize;
fillen = tip->extlen;
if (count == 0)
return(0);
if (tip->type90 == DVTYPE_ASCII)
fillen = fillen * elsize;
incb = tip->stride * elsize; /* Stride in bytes */
if (cup->useq == 0) { /* If direct access file */
register int64 newpos;
register int64 recl;
newpos = cup->urecpos + count * fillen; /* in bits */
recl = (int64) (cup->urecl);
if ((recl << 3) < newpos) {
errn = FEWRLONG; /* output record too long */
goto done;
}
}
#ifdef _CRAYT3D
if (_issddptr(ptr)) {
/* ptr points to a shared data descriptor */
/* If we have a layer that handles sdds someday, we */
/* could check for that here and not set shared to one. */
/* We'd also probably want to make sure that we're not */
/* doing foreign data converion */
shared = 1;
elwords = elsize / sizeof(long);
}
#endif
/*
* If only one item, or stride is such that data is contiguous,
* do it all at once
*/
if ((shared == 0) && ((count == 1) || (incb == elsize))) {
register long ret;
int status;
if (mode == FULL)
cup->f_lastwritten = 1;
ret = _fwwd(cup, ptr, tip, mode, (int *) NULL,
(long *) NULL, &status);
if ( ret == IOERR ) {
errn = errno;
goto done;
}
return(0);
}
/*
* Stride is such that memory is not contiguous, break the request
* into chunks and do a gaterh on the items before writing.
*/
items = (LOCBUFLN * sizeof(long)) / elsize; /* chop it in chunks */
assert( ! (shared && items == 0) ); /* don't support shared char */
if (items == 0)
items = 1; /* must be character*BIG array*/
fwwdbuf = lbuf;
for ( i = 0; i < count; i = i + items ) {
register long ret;
int status;
/* trim the item count if not a full buffer's worth */
if (items > count - i)
items = count - i;
tip->count = items;
/*
* Gather items from user array into lbuf, and then write
* out a chunk. If items == 1, we suppress the extra data
* copy for performance and because it might not fit in the
* lbuf if it is character*BIG data.
*
* We don't have to worry about shared data not fitting
* in lbuf since character data is never shared.
*/
#ifdef _CRAYT3D
if (shared)
_cpyfrmsdd(ptr, lbuf, items, elwords, tip->stride, i);
else
#endif
{
if (items > 1)
_gather_data (lbuf, items, incb, elsize, ptr);
else
fwwdbuf = ptr;
}
if ( mode == FULL && (i+items >= count)) {
cup->f_lastwritten = 1;
ret = _fwwd(cup, fwwdbuf, tip, FULL, (int *) NULL,
(long *) NULL, &status);
}
else
ret = _fwwd(cup, fwwdbuf, tip, PARTIAL,
(int *) NULL, (long *) NULL, &status);
if ( ret == IOERR ) {
errn = errno;
goto done;
}
if (!shared)
ptr = (char *)ptr + (ret * incb);
}
done:
if (errn > 0) {
if ((cup->uflag & (_UERRF | _UIOSTF)) == 0)
_ferr(css, errn); /* Run-time error */
}
return(errn);
}
