void
$RB$(
_f_int *biunit, /* Unit */
_f_int *recmode, /* Mode */
gfptr_t bloc, /* Beginning location */
gfptr_t eloc, /* Ending location */
int *type) /* Data type */
{
register short type77;
register unum_t unum;
type_packet tip;
struct f90_type ts;
unit *cup;
struct fiostate cfs;
unum = *biunit;
STMT_BEGIN(unum, 0, T_BUFIN, NULL, &cfs, cup);
/*
* If not connected, do an implicit open. Abort if the open fails.
*/
if (cup == NULL)
cup = _imp_open77(&cfs, SEQ, UNF, unum, 0, NULL);
type77 = *type & 017;
CREATE_F90_INFO(ts, tip, type77);
#if NUMERIC_DATA_CONVERSION_ENABLED
if (cup->unumcvrt || cup->ucharset) {
register int ret;
ret = _get_dc_param(&cfs, cup, ts, &tip);
if (ret != 0)
_ferr(&cfs, ret);
}
#endif
_PRAGMA_INLINE(_rb)
_rb(&cfs, cup, recmode, bloc, eloc, &tip);
return;
}
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
}
