ndfangetfid(intf * dfile, _fcd id, intf * maxlen, intf * isfirst)
{
return (DFANIgetfann(*dfile, _fcdtocp(id), *maxlen,
DFAN_LABEL, (intn) *isfirst));
}
void FATR checksum_char_update_(_fcd f)
{
checksum_update(_fcdlen(f), _fcdtocp(f));
}
ndfanaddfds(intf * dfile, _fcd desc, intf * desclen)
{
return (DFANIaddfann(*dfile, _fcdtocp(desc), *desclen, DFAN_DESC));
}
Logical FATR srtdb_cget_(const Integer *handle, _fcd name,
const Integer *nelem,
_fcd farray)
{
int nlen = _fcdlen(name);
int alen = _fcdlen(farray);
char *array = _fcdtocp(farray);
#else
Logical FATR srtdb_cget_(const Integer *handle, const char *name,
const Integer *nelem,
char *array, const int nlen, const int alen)
{
#endif
/*
Read an array of Fortran character variables from the data base.
Put stored the array as follows:
. Each array element is striped of trailing blanks, terminated with CR,
. and appended to the list. The entire array must fit into abuf.
*/
int hbuf = (int) *handle;
char nbuf[256];
char abuf[20480];
/* char abuf[10240];*/
int nelbuf;
int typebuf;
int i;
char *next;
if (!fortchar_to_string(name, nlen, nbuf, sizeof(nbuf))) {
(void) fprintf(stderr, "srtdb_cget: nbuf is too small, need=%d\n",
nlen);
return FORTRAN_FALSE;
}
nelbuf = sizeof(abuf);
typebuf= (int) MT_CHAR;
#ifdef DEBUG
printf("cget: rtdb=%d, mat=%d, nel=%d, name=%s\n", hbuf, typebuf, nelbuf, nbuf);
fflush(stdout);
#endif
if (!srtdb_get(hbuf, nbuf, typebuf, nelbuf, abuf))
return FORTRAN_FALSE; /* Not there */
for (i=0, next=strtok(abuf, "\n");
next;
i++, array+=alen, next=strtok((char *) 0, "\n")) {
#if defined(CRAY) && !defined(__crayx1)
_fcd element = _cptofcd(array, alen);
#elif defined(WIN32)
_fcd element;
element.string = array;
element.len = alen;
#elif defined(USE_FCD)
#error Do something about _fcd
#else
char *element = array;
#endif
if (i == *nelem) {
(void) fprintf(stderr, "srtdb_cget: array has too few elements\n");
(void) fprintf(stderr, "srtdb_cget: name was <<%s>>\n",name);
return FORTRAN_FALSE;
}
if (!string_to_fortchar(element, alen, next)) {
(void) fprintf(stderr, "srtdb_cget: array element is too small\n");
(void) fprintf(stderr, "srtdb_cget: name was <<%s>>\n",name);
return FORTRAN_FALSE;
}
}
return FORTRAN_TRUE;
}
Logical FATR srtdb_cput_(const Integer *handle, _fcd name,
const Integer *nelem,
_fcd farray)
{
int nlen = _fcdlen(name);
int alen = _fcdlen(farray);
char *array = _fcdtocp(farray);
#else
Logical FATR srtdb_cput_(const Integer *handle, const char *name,
const Integer *nelem,
const char *array, const int nlen, const int alen)
{
#endif
/*
Insert an array of Fortran character variables into the data base.
Each array element is striped of trailing blanks, terminated with CR,
and appended to the list. The entire array must fit into abuf.
*/
int hbuf = (int) *handle;
char nbuf[256];
char abuf[20480]=" ";
int nelbuf;
int typebuf;
int i, left;
char *next;
for (i=0, left=sizeof(abuf), next=abuf;
i<*nelem;
i++, array+=alen) {
#if defined(CRAY) && !defined(__crayx1)
_fcd element = _cptofcd(array, alen);
#elif defined(WIN32)
_fcd element;
element.string = array;
element.len = alen;
#elif defined(USE_FCD)
#error Do something about _fcd
#else
const char *element = array;
#endif
if (!fortchar_to_string(element, alen, next, left)) {
(void) fprintf(stderr, "srtdb_cput: abuf is too small, need=%d\n",
(int) (alen + sizeof(abuf) - left));
return FORTRAN_FALSE;
}
left -= strlen(next) + 1;
next += strlen(next) + 1;
if (i != (*nelem - 1))
*(next-1) = '\n';
}
if (!fortchar_to_string(name, nlen, nbuf, sizeof(nbuf))) {
(void) fprintf(stderr, "srtdb_cput: nbuf is too small, need=%d\n",
nlen);
return FORTRAN_FALSE;
}
nelbuf = strlen(abuf) + 1;
typebuf= (int) MT_CHAR;
#ifdef DEBUG
printf("cput: rtdb=%d, mat=%d, nel=%d, name=%s\n", hbuf, typebuf, nelbuf, nbuf);
fflush(stdout);
#endif
if (srtdb_put(hbuf, nbuf, typebuf, nelbuf, abuf))
return FORTRAN_TRUE;
else
return FORTRAN_FALSE;
}
/*
**&GRWFCH -- GRFILEIO write FORTRAN character sub-STRING routine
*+
* FUNCTION GRWFCH (FD, NBYTE, BUFFER)
* INTEGER FD, NBYTE, GRWFCH
* BYTE BUFFER(NBYTE)
*
* Writes NBYTE bytes into the file associated by descriptor FD (which is
* returned by the GROFIL call. The array BUFFER contains the data that has
* to be written, but can (of course) also be associated with any other
* string, scalar, or n-dimensional array.
* The function returns the number of bytes actually written in GRWFCH. If
* GRWFCH < 0, a write error occurred.
*
* Arguments:
* FD (input) : File descriptor returned by GROFIL
* NBYTE (input) : Number of bytes to be written
* BUFFER (input) : Buffer containing the bytes that have to be written
* GRWFCH (output) : Number of bytes written, or (if negative) error code.
*-
*/
int GRWFCH(int *fd, int *nbytes, _fcd buf)
{
return write(*fd, (void *) _fcdtocp(buf), *nbytes);
}
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
$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 */
}
