int
_BACK(
_f_int *unump, /* Fortran unit number */
_f_int *iostat, /* IOSTAT= variable address, or NULL */
int errf) /* 1 if ERR= specifier is present */
{
register int errn; /* nonzero when error is encountered */
register unum_t unum;
unit *cup;
struct fiostate cfs;
errn = 0;
unum = *unump;
STMT_BEGIN(unum, 0, T_BACKSPACE, NULL, &cfs, cup); /* lock the unit */
if (!GOOD_UNUM(unum)) {
errn = FEIVUNIT; /* Invalid unit number */
goto backspace_done;
}
/*
* BACKSPACE on unopened unit is OK, and does nothing. For opened units,
* call the low level backspace routine.
*/
if (cup == NULL)
goto backspace_done;
if (cup->pnonadv) { /* There is a current record */
if (cup->uwrt) {
errn = _nonadv_endrec(&cfs, cup);
if (errn != 0)
goto backspace_done;
}
cup->pnonadv = 0; /* Flag no current record */
}
errn = _unit_bksp(cup);
backspace_done:
if (iostat != NULL)
*iostat = errn;
else
if (errn != 0 && (errf == 0))
_ferr(&cfs, errn, unum); /* Pass unum to _ferr
* in case of FEIVUNIT error */
STMT_END(cup, T_BACKSPACE, NULL, &cfs); /* unlock the unit */
errn = (errn != 0) ? IO_ERR : IO_OKAY;/* 1 if error; 0 if no error */
return(CFT77_RETVAL(errn));
}
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 __OPN(
_f_int *unitn,
_f_int *iostat,
int *errf,
_fcd file,
_fcd status,
_fcd access,
_fcd form,
_f_int *recl,
_fcd blank,
_fcd position,
_fcd action_arg,
_fcd delim_arg,
_fcd pad_arg,
int unused1, /* for a future CFT77 open specifier */
int unused2, /* for a future CFT77 open specifier */
int isf90_arg) /* =1 iff Fortran-90 OPEN */
#endif
{
olist a; /* OPEN specifier list */
long fstrlen; /* Length of Fortran string */
int errn; /* IOSTAT error number */
int error; /* Error flag */
unum_t unum; /* Fortran unit number */
_fcd action;
_fcd delim;
_fcd pad;
int isf90;
unit *cup; /* Pointer to unit table entry */
enum form_spec formdef;
struct fiostate cfs;
#ifdef _CRAYMPP
va_list args;
_fcd file;
_fcd status;
_fcd access;
_fcd form;
_f_int *recl;
_fcd blank;
_fcd position;
int unused1; /* for a future CFT77 open specifier */
int unused2; /* for a future CFT77 open specifier */
int isf90_arg; /* =1 iff Fortran-90 OPEN */
#endif
/*
* The ACTION, DELIM, and PAD specifiers are supported by CFT77
* release 5.0 and later on CX/CEA systems, and by CFT77 release 6.0 and
* later on CRAY-2 systems.
*/
action = _cptofcd(NULL, 0);
delim = _cptofcd(NULL, 0);
pad = _cptofcd(NULL, 0);
#ifdef _CRAYMPP
va_start(args,errf);
file = va_arg(args, _fcd);
status = va_arg(args, _fcd);
access = va_arg(args, _fcd);
form = va_arg(args, _fcd);
recl = va_arg(args, _f_int *);
blank = va_arg(args, _fcd);
position = va_arg(args, _fcd);
#endif
if (PASSED_ARG(ARGS_11)) {
#ifdef _CRAYMPP
action = va_arg(args, _fcd);
#else
action = action_arg;
#endif
}
if (PASSED_ARG(ARGS_12)) {
#ifdef _CRAYMPP
delim = va_arg(args, _fcd);
#else
delim = delim_arg;
#endif
}
if (PASSED_ARG(ARGS_13)) {
#ifdef _CRAYMPP
pad = va_arg(args, _fcd);
#else
pad = pad_arg;
#endif
}
/*
* The isf90 argument is not passed from CFT77.
*/
isf90 = 0;
if (PASSED_ARG(ARGS_16)) {
#ifdef _CRAYMPP
unused1 = va_arg(args, int);
unused2 = va_arg(args, int);
isf90 = va_arg(args, int);
#else
isf90 = isf90_arg;
#endif
}
#ifdef _CRAYMPP
va_end(args);
#endif
errn = 0;
OPENLOCK(); /* prevent other OPENs or CLOSEs right now */
#ifdef KEY /* Bug 4260 */
/* Before we open the first file in the course of execution, we must
* set byte-swapping based on __io_byteswap_value defined by Fortran
* main in response to command-line options like -byteswapio */
__io_byteswap();
#endif /* KEY Bug 4260 */
unum = *unitn; /* UNIT= is required by compiler */
a.ounit = unum;
STMT_BEGIN(unum, 0, T_OPEN, NULL, &cfs, cup); /* lock unit if open */
if (!GOOD_UNUM(unum) || RSVD_UNUM(unum))
OPNERR(FEIVUNTO);
a.oerr = (errf || iostat) ? 1 : 0; /* Catch errs if ERR | IOSTAT */
/*
* Process FILE= and RECL= specifiers.
*/
if (_fcdtocp(file) != NULL) {
a.ofile = _fcdtocp(file);
a.ofilelen = _fcdlen (file);
}
else {
a.ofile = NULL;
a.ofilelen = 0;
}
if (recl != NULL)
a.orecl = *recl;
else
a.orecl = 0; /* 0 means unspecified */
/*
* Process remaining specifiers.
*
* Specifier Default Error Code
* Value List
*/
SETSPEC(status, OS_UNKNOWN, FEOPSTAT, 5,
S(OLD) S(NEW) S(SCRATCH) S(UNKNOWN) S(REPLACE));
#if !defined(__mips) && !defined(_LITTLE_ENDIAN)
SETSPEC(access, OS_SEQUENTIAL, FEOPACCS, 2,
S(DIRECT) S(SEQUENTIAL));
SETSPEC(position, OS_ASIS, FEOPPOSN, 3,
S(APPEND) S(ASIS) S(REWIND));
#else /* not __mips and not little endian */
SETSPEC(access, OS_SEQUENTIAL, FEOPACCS, 4,
S(DIRECT) S(SEQUENTIAL) S(KEYED) S(APPEND));
if ((_fcdtocp(access) != NULL) && (a.oaccess == OS_OAPPEND)) {
if (_fcdtocp(position) != NULL) {
OPNERR(FEOPACCS); /* Invalid ACCESS */
}
#ifdef KEY /* Bug 86 */
/* The Fortran 90 standard does not place a constraint
* on the value of 'access=', so there's no need to
* issue an error message in normal or -ansi mode (and
* "isf90" seems always to be set anyway). */
#else
else if (isf90) {
OPNERR(FEOPACCS); /* Invalid ACCESS */
}
#endif /* KEY */
else {
a.oposition = OS_APPEND;
a.oaccess = OS_SEQUENTIAL;
}
}
else {
/* use POSITION= if ACCESS='APPEND' is not provided */
SETSPEC(position, OS_ASIS, FEOPPOSN, 3,
S(APPEND) S(ASIS) S(REWIND));
}
#endif /* not __mips and not little endian */
formdef = (a.oaccess == OS_SEQUENTIAL) ? OS_FORMATTED : OS_UNFORMATTED;
SETSPEC(form, formdef, FEOPFORM, 4,
S(UNFORMATTED) S(FORMATTED) S(BINARY) S(SYSTEM));
SETSPEC(blank, OS_NULL, FEOPBLNK, 2,
S(ZERO) S(NULL));
SETSPEC(action, OS_ACTION_UNSPECIFIED, FEOPACTB, 3,
S(READ) S(WRITE) S(READWRITE));
SETSPEC(delim, OS_NONE, FEOPDLMB, 3,
S(APOSTROPHE) S(QUOTE) S(NONE));
SETSPEC(pad, OS_YES, FEOPPADB, 2,
S(YES) S(NO));
/*
* Diagnose errors.
*/
if (recl != NULL && a.orecl <= 0)
OPNERR(FEOPRECL); /* Invalid RECL */
if (recl == NULL && a.oaccess == OS_DIRECT)
OPNERR(FEOPRCRQ); /* RECL required for direct */
if (_fcdtocp(blank) != NULL && (a.oform == OS_UNFORMATTED ||
a.oform == OS_BINARY || a.oform == OS_SYSTEM))
OPNERR(FEOPBKIV); /* BLANK= invalid if unform. */
if (_fcdtocp(delim) != NULL && (a.oform == OS_UNFORMATTED ||
a.oform == OS_BINARY || a.oform == OS_SYSTEM))
OPNERR(FEOPDLMI); /* DELIM invalid if unform. */
if (_fcdtocp(pad) != NULL && (a.oform == OS_UNFORMATTED ||
a.oform == OS_BINARY || a.oform == OS_SYSTEM))
OPNERR(FEOPPDIV); /* PAD= invalid if unformatted*/
if (_fcdtocp(position) != NULL && a.oaccess == OS_DIRECT)
OPNERR(FEOPPSIV); /* POSITION invalid on direct */
/*
* Done with OPEN specifiers.
*/
if (OPEN_UPTR(cup) && cup->ufs == FS_AUX)
OPNERR(FEOPAUXT); /* Unit is opened by AQ/MS/DR/WA IO */
if (OPEN_UPTR(cup) &&
(_fcdtocp(file) == NULL || (cup->ufnm != NULL &&
strncmp(cup->ufnm, a.ofile, a.ofilelen) == 0))) {
/*
* A re-open of the same file occurs when the FILE= specifier
* is present and matches the name with which the file was
* originally opened, or if the FILE= specifier is absent
* (these are re-opens of the same file by definition).
*
* In this case, only a subset of the OPEN specifiers
* (the BLANK=, PAD=, and DELIM= specifiers) may be provided
* with values which are different from those currently in
* effect. Any new value passed with the BLANK=, PAD=, or
* DELIM= specifier will go into effect.
*
* An attempt to change the other OPEN specifers is an error.
*/
if (_fcdtocp(status) != NULL && a.ostatus != cup->uostatus) {
if (a.ostatus == OS_NEW && cup->uostatus == OS_OLD) {
OPNERR(FEOPNNEW); /* STATUS=NEW became OLD */
}
else
OPNERR(FEOPCBNK); /* Can't change STATUS */
}
if (_fcdtocp(access) != NULL &&
((a.oaccess == OS_SEQUENTIAL && cup->useq == 0 ) ||
(a.oaccess == OS_DIRECT && cup->useq == 1) ))
OPNERR(FEOPCBNK); /* Can't change ACCESS */
if (_fcdtocp(form) != NULL &&
((a.oform == OS_FORMATTED && cup->ufmt == 0) ||
(a.oform == OS_UNFORMATTED && cup->ufmt == 1) ))
OPNERR(FEOPCBNK); /* Can't change FORM */
if (recl != NULL && a.orecl != cup->urecl)
OPNERR(FEOPCBNK); /* Can't change RECL */
if (_fcdtocp(position) != NULL && a.oposition != cup->uposition)
OPNERR(FEOPCBNK); /* Can't change POSITION */
if (_fcdtocp(action) != NULL && a.oaction != cup->uaction)
OPNERR(FEOPCBNK); /* Can't change ACTION */
/*
* Place into effect any new BLANK=, DELIM=, or PAD= specifier
* provided on the OPEN statement.
*/
if (_fcdtocp(blank) != NULL)
cup->ublnk = (a.oblank == OS_ZERO);
if (_fcdtocp(delim) != NULL)
cup->udelim = a.odelim;
if (_fcdtocp(pad) != NULL)
cup->upad = a.opad;
}
else {
/*
* Open the unit. If the unit is currently connected, it
* will be closed and then reopened for the new file.
*/
/* KEY: we do want this check */
#if (!defined(__mips) && !defined(_LITTLE_ENDIAN)) || defined(KEY)
/*
* SGI's F77 and old F90 allowed open with status=NEW,
* OLD, or REPLACE without FILE specifier, so we continue
* to allow it on MIPS systems.
*/
if (a.ostatus == OS_REPLACE && a.ofile == NULL)
OPNERR(FEOPFNRQ); /* FILE= required for 'REPLACE' */
if (a.ostatus == OS_OLD && a.ofile == NULL)
OPNERR(FEOPFNRQ); /* FILE= required for 'OLD' */
if (a.ostatus == OS_NEW && a.ofile == NULL)
OPNERR(FEOPFNRQ); /* FILE= required for 'NEW' */
#endif
#ifdef _CRAYMPP
/*
* This check should be added for CX/CEA someday.
*/
if (a.ostatus == OS_SCRATCH && a.ofile != NULL)
OPNERR(FEOPFNIV); /* FILE= should not be specified */
#endif
/*
* We assume that _f_open does not change cfs.f_cu if
* the unit was already open.
*/
errn = _f_open(&cfs, &cup, &a, isf90);
}
/*
* Process results
*/
opn_done:
error = (errn != 0) ? IO_ERR : IO_OKAY;
if (iostat != NULL)
*iostat = errn;
else
if (error != IO_OKAY && errf == 0)
if (errn == FEIVUNTO)
_ferr(&cfs, errn, unum);
else
_ferr(&cfs, errn);
STMT_END(cup, T_OPEN, NULL, NULL); /* unlock unit */
OPENUNLOCK();
return(CFT77_RETVAL(error));
}
int _INQ(
_f_int *unitn,
_f_int *iostat,
int errf,
_f_log *exist,
_f_log *opened,
_f_int *number,
_f_log *named,
_fcd name,
_fcd access,
_fcd sequent,
_fcd direct,
_fcd form,
_fcd formatt,
_fcd unform,
_f_int *recl,
_f_int *nextrec,
_fcd blank,
_fcd file,
_fcd pos,
_fcd action,
_fcd red,
_fcd writ,
_fcd redwrit,
_fcd delim,
_fcd pad
)
#endif
{
inlist a; /* INQUIRE parameter list */
int errn; /* IOSTAT error number */
int error; /* Error flag */
unum_t unum; /* Unit number */
long stmt; /* Statement type */
unit *cup; /* Unit pointer if inquire by unit */
struct fiostate cfs;
#ifdef _CRAYMPP
va_list args;
_fcd name;
_fcd access;
_fcd sequent;
_fcd direct;
_fcd form;
_fcd formatt;
_fcd unform;
_f_int *recl;
_f_int *nextrec;
_fcd blank;
_fcd file;
_fcd pos;
_fcd action;
_fcd red;
_fcd writ;
_fcd redwrit;
_fcd delim;
_fcd pad;
va_start(args,named);
name = va_arg(args, _fcd);
access = va_arg(args, _fcd);
sequent = va_arg(args, _fcd);
direct = va_arg(args, _fcd);
form = va_arg(args, _fcd);
formatt = va_arg(args, _fcd);
unform = va_arg(args, _fcd);
recl = va_arg(args, _f_int *);
nextrec = va_arg(args, _f_int *);
blank = va_arg(args, _fcd);
file = va_arg(args, _fcd);
#endif
/* Initialize the inlist structure */
(void) memset(&a, 0, sizeof(inlist));
a.inunit = -1;
/* Determine type of INQUIRE */
if (_fcdtocp(file) != NULL) {
a.infile = _fcdtocp(file);
a.infilen = _fcdlen (file); /* CFT77 */
stmt = T_INQF; /* INQUIRE by FILE */
unum = -1;
}
else {
stmt = T_INQU; /* INQUIRE by UNIT */
unum = *unitn;
a.inunit = unum;
}
/*
* Here unum is -1 if this is an inquire by file. This will suppress
* any unit locking in STMT_BEGIN.
*/
STMT_BEGIN(unum, 0, stmt, NULL, &cfs, cup);
/* Process rest of parameters */
if (_fcdtocp(name) != NULL) {
a.inname = _fcdtocp(name);
a.innamlen = _fcdlen (name); /* CFT77 */
if (a.innamlen == 0)
a.innamlen = strlen(a.inname); /* CFT2 */
}
if (_fcdtocp(access) != NULL) {
a.inacc = _fcdtocp(access);
a.inacclen = _fcdlen (access);
}
if (_fcdtocp(sequent) != NULL) {
a.inseq = _fcdtocp(sequent);
a.inseqlen = _fcdlen (sequent);
}
if (_fcdtocp(direct) != NULL) {
a.indir = _fcdtocp(direct);
a.indirlen = _fcdlen (direct);
}
if (_fcdtocp(form) != NULL) {
a.inform = _fcdtocp(form);
a.informlen = _fcdlen (form);
}
if (_fcdtocp(formatt) != NULL) {
a.infmt = _fcdtocp(formatt);
a.infmtlen = _fcdlen (formatt);
}
if (_fcdtocp(unform) != NULL) {
a.inunf = _fcdtocp(unform);
a.inunflen = _fcdlen (unform);
}
if (_fcdtocp(blank) != NULL) {
a.inblank = _fcdtocp(blank);
a.inblanklen = _fcdlen (blank);
}
#ifdef _UNICOS
if (_numargs() <= (9 + 9*sizeof(_fcd)/sizeof(long)))
goto old_inq;
#endif
#ifdef _CRAYMPP
pos = va_arg(args, _fcd);
action = va_arg(args, _fcd);
red = va_arg(args, _fcd);
writ = va_arg(args, _fcd);
redwrit = va_arg(args, _fcd);
delim = va_arg(args, _fcd);
pad = va_arg(args, _fcd);
#endif
if (_fcdtocp(pos) != NULL) {
a.inposit = _fcdtocp(pos);
a.inpositlen = _fcdlen (pos);
}
if (_fcdtocp(action) != NULL) {
a.inaction = _fcdtocp(action);
a.inactonlen = _fcdlen (action);
}
if (_fcdtocp(red) != NULL) {
a.inread = _fcdtocp(red);
a.inreadlen = _fcdlen (red);
}
if (_fcdtocp(writ) != NULL) {
a.inwrite = _fcdtocp(writ);
a.inwritelen = _fcdlen (writ);
}
if (_fcdtocp(redwrit) != NULL) {
a.inredwrit = _fcdtocp(redwrit);
a.inrdwrtlen = _fcdlen (redwrit);
}
if (_fcdtocp(delim) != NULL) {
a.indelim = _fcdtocp(delim);
a.indelimlen = _fcdlen (delim);
}
if (_fcdtocp(pad) != NULL) {
a.inpad = _fcdtocp(pad);
a.inpadlen = _fcdlen (pad);
}
old_inq:
a.inerr = (errf || iostat) ? 1 : 0;
a.inex = exist;
a.inopen = opened;
a.innum = number;
a.innamed = named;
a.inrecl = recl;
a.innrec = nextrec;
errn = _f_inqu(&cfs, cup, &a);
error = (errn != 0) ? IO_ERR : IO_OKAY;
if (iostat != NULL)
*iostat = errn;
#ifdef _CRAYMPP
va_end(args);
#endif
STMT_END(NULL, 0, NULL, NULL);
return(CFT77_RETVAL(error));
}
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
$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 */
}
