int
$RFI(
_fcd funit, /* Address of unit number or FCD */
_fcd format, /* Address of format (FCD or hollerith) */
long *err, /* Address of error processing address */
long *end, /* Address of end processing address */
_f_int *iostat, /* Address of IOSTAT variable */
_f_int *rec, /* Address of direct access record no. */
fmt_type **pform, /* Address of address of parsed format */
long *inumelt, /* Address of int. array element count */
long *inumcfe /* Address of number of format elements */
)
#endif
{
register int endf; /* END processing flag */
register int errf; /* ERR processing flag */
register int errn; /* Error number */
register int iost; /* I/O statement type */
register int iotp; /* I/O type */
register recn_t recn; /* Record number */
register unum_t unum; /* Unit number */
fmt_type **prsfmt; /* Parsed format info. */
unit *cup; /* Unit table pointer */
FIOSPTR css; /* I/O statement state */
#ifdef _CRAYMPP
va_list args;
_fcd format; /* Address of format (FCD or hollerith) */
long *err; /* Address of error processing address */
long *end; /* Address of end processing address */
_f_int *iostat; /* Address of IOSTAT variable */
_f_int *rec; /* Address of direct access record no. */
fmt_type **pform; /* Address of address of parsed format */
long *inumelt; /* Address of int. array element count */
long *inumcfe; /* Address of number of format elements */
#endif
GET_FIOS_PTR(css);
/* Check if recursive triple-call I/O */
if (css->f_iostmt != 0)
_ferr(css, FEIOACTV);
#ifdef _CRAYMPP
va_start(args, funit);
format = va_arg(args, _fcd);
err = va_arg(args, long *);
end = va_arg(args, long *);
iostat = va_arg(args, _f_int *);
rec = va_arg(args, _f_int *);
if (_numargs() > ARGS_6) {
pform = va_arg(args, fmt_type **);
if (_numargs() > ARGS_7) {
inumelt = va_arg(args, long *);
if (_numargs() > ARGS_8) {
inumcfe = va_arg(args, long *);
}
void
TSYNC(_f_int *unump, _f_int *istat)
{
register int ret;
unit *cup; /* Unit table pointer */
FIOSPTR css; /* I/O statement state */
GET_FIOS_PTR(css);
STMT_BEGIN(*unump, 0, T_TAPE, NULL, css, cup);
if (cup == NULL)
_ferr(css, FENOTOPN);
*istat = 0;
if (cup->ufs == FS_FDC) {
ret = XRCALL(cup->ufp.fdc, fcntlrtn) cup->ufp.fdc,
FC_TSYNC, 0, &cup->uffsw);
if (ret < 0)
*istat = cup->uffsw.sw_error;
}
void
ENDSP(_f_int *unump, _f_int *istat)
{
register int ret;
unit *cup;
FIOSPTR css;
GET_FIOS_PTR(css);
STMT_BEGIN(*unump, 0, T_TAPE, NULL, css, cup);
if (cup == NULL)
_ferr(css, FENOTOPN);
*istat = 0;
if (cup->ufs == FS_FDC) {
ret = XRCALL(cup->ufp.fdc, fcntlrtn) cup->ufp.fdc,
FC_ENDSP, 0, &cup->uffsw);
if (ret < 0)
*istat = cup->uffsw.sw_error;
else
cup->uspcproc = 0;
}
int
@WNL(
_f_int *unump, /* Unit number or dataset name */
Namelist *nl, /* Namelist structure */
int errf /* Nonzero if ERR specified */
)
{
unum_t unum;
int errn;
int n, ss;
void *vaddr; /* variable address */
unsigned elsize; /* size in bytes of the variable */
long recsize; /* number of characters to output per
* line. Used by REPFLUSH.*/
char c; /* needed by NLPUTS macro */
char *s; /* needed by NLPUTS macro */
unit *cup; /* unit pointer */
Nlentry *nlent;
FIOSPTR css;
struct BUFFERS wnlbuffers;
struct BUFFERS *bptr;
bptr = &wnlbuffers;
bptr->f_lbuf = NULL;
unum = *unump;
GET_FIOS_PTR(css);
STMT_BEGIN(unum, 0, T_WNL, NULL, css, cup);
if (cup == NULL) { /* if not connected */
cup = _imp_open77(css, SEQ, FMT, unum, errf, &errn);
/*
* If the open failed, cup is NULL and errn contains
* the error number.
*/
if (cup == NULL)
RERR(css, errn);
}
/* Set various unit table fields */
cup->uflag = (errf != 0 ? _UERRF : 0);
cup->ulineptr = cup->ulinebuf;
cup->uwrt = 1; /* Set write flag */
/* Set fields in the Fortran statement state structure */
css->u.fmt.nonl = 0; /* Clear no-newline flag */
if (cup->useq == 0) /* If direct access file */
RERR(css, FESEQTIV); /* Sequential attempted on direct access */
if (!cup->ufmt) /* If unformatted file */
RERR(css, FEFMTTIV); /* Formatted attempted on unformatted */
if ((cup->uaction & OS_WRITE) == 0)
RERR(css, FENOWRIT);
bptr = &wnlbuffers;
bptr->lcomma = 0;
/*
* Set up record size. The hierarchy for determining Namelist
* output record size is as follows:
* 1) RECL, if specified
* 2) WNLLONG(), if set and does not exceed cup->urecsize
* 3) list-directed output record size (cup->uldwsize)
*
* Note that while (1) and (3) are established at OPEN time, (2)
* can be changed ``on the fly''; therefore, this check has to
* be performed here.
*/
recsize = cup->uldwsize;
if (cup->urecl == 0 && _wnlrecsiz > 0) /* No RECL and WNLLONG() set */
recsize = MIN(cup->urecsize, _wnlrecsiz);
bptr->outcnt = recsize - 1; /* First char. for carriage control */
bptr->outbuff = cup->ulinebuf;
bptr->outptr = bptr->outbuff;
*bptr->outptr++ = OUT_ECHO; /* First character of first line */
bptr->f_lbuf = (long *) malloc((recsize + 1) * sizeof(long));
if (bptr->f_lbuf == NULL)
RERR(css, FENOMEMY); /* No memory */
/* NAMELIST delimiter to output line */
NLPUT(OUT_CHAR); /* output delimiter */
NLPUTS(nl->nlname); /* unpack group name to buffer */
NLPUT(' ');
NLPUT(' ');
NLINE(); /* Did user specify new line for each variable? */
nlent = nl->nlvnames;
do {
int ntype;
ntype = _old_namelist_to_f77_type_cnvt[nlent->na.type];
/*
* Always format output into f_lbufptr.
* After formatting, if it will fit, move it into outbuff.
* If it will not fit, write out what is already in outbuff,
* and then move in the newly formatted data.
*/
bptr->f_lbufptr = bptr->f_lbuf;
bptr->f_lbufcnt = 0;
LPUTS(nlent->varname); /* output variable name */
LPUT(' ');
LPUT(OUT_EQ); /* output the replacement
* character. '=' by default. */
n = (nlent->na.offdim) ? nlent->na.nels : 1;
if (ntype == DT_CHAR) {
_fcd f;
f = *(_fcd *)(((unsigned long) nlent->va.varaddr +
(long *)nl));
vaddr = _fcdtocp(f);
elsize = _fcdlen(f);
}
else {
vaddr = (void *)nlent->va.varaddr;
elsize = 0;
}
LPUT(' ');
/* Output value */
ss = l_write(css, cup, vaddr, elsize, n, 1, ntype, recsize,
errf, bptr);
if (ss != 0) {
RERR(css, ss);
}
NLINE();
nlent++; /* point to next variable description */
} while (nlent->varname[0]);
if (bptr->outcnt < 6) {
REPFLUSH(); /* Make sure there's room for " &END" */
bptr->outptr--; /* start in col. 2 */
bptr->outcnt++;
}
NLPUT(OUT_CHAR);
NLPUTS("END");
REPFLUSH();
ret:
STMT_END(cup, T_WNL, NULL, css); /* Unlock the unit */
if (bptr->f_lbuf != NULL) /* Free formatting buffer */
free(bptr->f_lbuf);
return(CFT77_RETVAL(ss));
}
int
_RUI(
_fcd _Unitid, /* Pointer to unit identifier */
_fcd _arg2, /* Unused */
long *err, /* Address of error processing address */
long *end, /* Address of end processing address */
_f_int *iostat, /* Address of IOSTAT variable */
_f_int *rec /* Address of direct access record no. */
#ifndef _UNICOS
,FIOSPTR cssa /* Statement state structure */
#endif
)
#endif
{
register int errf; /* Error processing flag */
register int errn; /* Error number */
register int iost; /* I/O statement type */
register int iotp; /* I/O type */
register recn_t recn; /* Direct access record number */
register unum_t unum; /* Actual unit number */
unit *cup; /* Pointer to unit table entry */
FIOSPTR css; /* Statement state structure */
#ifdef _CRAYMPP
va_list args;
_fcd _arg2; /* Unused */
long *err; /* Address of error processing address*/
long *end; /* Address of end processing address */
_f_int *iostat; /* Address of IOSTAT variable */
_f_int *rec; /* Address of direct access record no.*/
#endif
#ifdef _UNICOS
GET_FIOS_PTR(css);
/* Check if recursive triple-call I/O */
if (css->f_iostmt != 0)
_ferr(css, FEIOACTV);
#else
css = cssa;
#endif
#ifdef _CRAYMPP
va_start(args, _Unitid);
_arg2 = va_arg(args, _fcd);
err = va_arg(args, long *);
end = va_arg(args, long *);
iostat = va_arg(args, _f_int *);
rec = va_arg(args, _f_int *);
va_end(args);
#endif
errn = 0;
/* Establish error processing options */
if (iostat != NULL)
*iostat = 0; /* Clear IOSTAT variable, if extant */
errf = ((err != NULL) || (iostat != NULL));
iost = T_RSU;
iotp = SEQ; /* Assume sequential */
unum = **(_f_int **)&_Unitid;
if (rec != NULL) { /* If direct access */
iost = T_RDU; /* Set direct unformatted read */
iotp = DIR;
recn = *rec;
}
STMT_BEGIN(unum, 0, iost, NULL, css, cup);
if (cup == NULL) { /* if not connected */
int stat;
cup = _imp_open77(css, iotp, UNF, unum, errf, &stat);
if (cup == NULL) {
errn = stat;
goto error;
}
}
/* Record error processing options in the unit */
cup->uiostat = iostat;
cup->uflag = (err != NULL ? _UERRF : 0) |
(end != NULL ? _UENDF : 0) |
(iostat != NULL ? _UIOSTF : 0);
/* Perform error checking */
if (cup->ufs == FS_AUX) {
errn = FEMIXAUX; /* Can't mix auxiliary and Fortran I/O */
ERROR0(errf, errn);
}
if ((cup->uaction & OS_READ) == 0) {
errn = FENOREAD; /* No read permission */
ERROR0(errf, errn);
}
if (cup->ufmt) { /* If unformatted attempted on formatted file */
errn = FEUNFMIV; /* Unformatted not allowed */
ERROR0(errf, errn);
}
/* If sequential and writing, disallow read after write */
if (cup->useq && cup->uwrt != 0) {
errn = FERDAFWR; /* Read after write */
ERROR0(errf, errn);
}
/* Preset fields in unit table */
cup->ueor_found = NO; /* Clear EOR */
cup->uwrt = 0;
cup->ulastyp = DVTYPE_TYPELESS;
if (iotp == DIR) { /* If direct access */
if (cup->useq) /* If direct attempted on seq. file */
errn = FEDIRTIV; /* Direct access not allowed */
else
errn = _unit_seek(cup, recn, iost);
if (errn != 0) {
ERROR1(errf, errn, recn);
}
}
else { /* Else sequential access */
if (cup->useq == 0) { /* If seq. attempted on direct file */
errn = FESEQTIV; /* Sequential not allowed */
ERROR0(errf, errn);
}
#if PURE_ENABLED
if (cup->upure && cup->upuretype != P_RDWR) {
/*
* Set the upuretype field to P_RDWR mode unless it has
* previously been set to P_BUFIO by a BUFFER IN/OUT
* statement. This check prevents the intermixing of
* READ/WRITE I/O with BUFFER IN/BUFFER OUT I/O when
* '-s pure' is assigned.
*/
if (cup->upuretype == P_BUFIO) {
errn = FEMIXBUF;
ERROR0(errf, errn);
}
cup->upuretype = P_RDWR;
}
#endif
}
if (errn != 0)
ERROR0(errf, errn);
return(CFT77_RETVAL(IO_OKAY));
error:
if (iostat != NULL)
*iostat = errn; /* Set IOSTAT variable to error */
if (cup != NULL) /* If we have a unit */
cup->uflag |= (errn > 0) ? _UERRC : _UENDC;/* Set status */
#ifdef _UNICOS
return(CFT77_RETVAL(_RUF()));
#else
return(CFT77_RETVAL(_RUF(css)));
#endif
}
int
_RUF(
#ifndef _UNICOS
FIOSPTR cssa /* Statement state structure */
#endif
)
{
register int errn; /* Error number */
register long flag; /* Error flag */
unit *cup; /* Pointer to unit table entry */
FIOSPTR css; /* Statement state structure */
#ifdef _UNICOS
GET_FIOS_PTR(css);
#else
css = cssa;
#endif
cup = css->f_cu;
if (cup == NULL) { /* If unit not opened */
/*
* If unit not connected, assume we are catching errors with
* ERR= or IOSTAT= and that _RUF is being called from $RUI or
* $RUA$.
*/
flag = _UERRC | _UERRF;
goto finished;
}
cup->ulrecl = cup->urecpos;
cup->urecpos = 0;
#ifdef _CRAYMPP
if (css->f_shrdput) {
css->f_shrdput = 0;
_remote_write_barrier();
}
#endif
if ((cup->uflag & (_UERRC | _UENDC)) == 0) { /* If no error or EOF */
errn = 0;
switch (cup->ufs) {
case FS_FDC:
/*
* Do a full record read to advance to the
* end of the record for sequential access.
*/
if (cup->useq) /* If sequential */
if (cup->ublkd && !cup->ueor_found) {
int ubc = 0;
char dummy;
struct ffsw fst; /* FFIO status block */
(void) XRCALL(cup->ufp.fdc, readrtn)
cup->ufp.fdc,
CPTR2BP(&dummy), 0,
&fst, FULL, &ubc);
switch (fst.sw_stat) {
case FFERR:
errn = fst.sw_error;
break;
case FFEOF:
cup->uend = PHYSICAL_ENDFILE;
errn = FERDPEOF;
break;
case FFEOD:
if (cup->uend == BEFORE_ENDFILE) {
cup->uend = LOGICAL_ENDFILE;
errn = FERDPEOF;
}
else
errn = FERDENDR;
break;
}
}
break;
default:
break;
} /* switch */
int
$RUA$(
_fcd fwa, /* Address of first word of data */
long *count, /* Address of count of data items */
long *stride, /* Address of stride between data items */
long *type /* Address of data type */
)
{
register short type77; /* Fortran 77 data type */
register int errn; /* Error number */
type_packet tip; /* Type information packet */
struct f90_type ts; /* F90 type structure */
void *dptr;
unit *cup; /* Pointer to unit table entry */
FIOSPTR css;
GET_FIOS_PTR(css);
cup = css->f_cu;
type77 = *type & 017;
CREATE_F90_INFO(ts, tip, type77);
tip.count = *count;
tip.stride = *stride;
if (type77 == DT_CHAR) {
dptr = (void *) _fcdtocp(fwa);
tip.elsize = tip.elsize * _fcdlen(fwa);
}
else
dptr = *(void **)&fwa;
#if NUMERIC_DATA_CONVERSION_ENABLED
if (cup->unumcvrt || cup->ucharset) {
errn = _get_dc_param(css, cup, ts, &tip);
if (errn != 0)
goto error;
}
#endif
#pragma _CRI inline _inline_rdunf
errn = _inline_rdunf(css, cup, dptr, &tip, 0);
if (errn == 0)
return(CFT77_RETVAL(IO_OKAY));
error:
if (cup->uiostat != NULL)
*(cup->uiostat) = errn;
cup->uflag |= (errn > 0) ? _UERRC : _UENDC; /* Set status */
if (cup->uflag & (_UIOSTF | _UERRF | _UENDF))
return(CFT77_RETVAL(_RUF()));
_ferr(css, FEINTUNK); /* Deep weeds */
}
