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));
}
void
_PXFGETPWNAM(
#endif
_fcd NAME,
_f_int *ILEN,
_f_int *JPASSWD,
_f_int *IERROR
)
{
int cilen;
char *cname;
struct passwd *passwdsrc, passwdtemp, *cjpasswd;
struct pxfhandle pxfhand;
cilen = *ILEN;
pxfhand = _pxfhandle_table_lookup(&_pxfhandle_table, *JPASSWD);
if (pxfhand.pxfstructptr == NULL || pxfhand.pxftype != PXF_PASSWD) {
*IERROR = EBADHANDLE;
return;
}
cjpasswd = pxfhand.pxfstructptr;
/* check for invalid range error on ILEN. */
if (cilen < 0 || cilen > _fcdlen(NAME)) {
*IERROR = EINVAL;
} else {
if (cilen == 0) {
/*
* If length is zero, user wants trailing blanks stripped.
* Otherwise, malloc memory and copy the string adding a
* NULL terminator.
*/
cname = _fc_acopy(NAME);
} else {
cname = (char *) malloc (cilen + 1);
if (cname != NULL) {
(void)memcpy(cname, _fcdtocp(NAME), cilen);
cname[cilen] ='\0';
} else {
*IERROR = ENOMEM;
return;
}
}
/* make call to getpwnam */
if ((passwdsrc = getpwnam(cname)) != NULL) {
free(cname);
/* copy the structures components since static storage is used */
/* component: pw_name (login name) */
passwdtemp.pw_name =
(char *) malloc((strlen(passwdsrc->pw_name)+1)*sizeof(char));
if (passwdtemp.pw_name == NULL) {
*IERROR = ENOMEM;
return;
}
(void)strcpy(passwdtemp.pw_name, passwdsrc->pw_name);
/* component: pw_uid (user ID) */
passwdtemp.pw_uid = passwdsrc->pw_uid;
/* component: pw_gid (group ID) */
passwdtemp.pw_gid = passwdsrc->pw_gid;
/* component: pw_dir (default login directory) */
passwdtemp.pw_dir =
(char *) malloc((strlen(passwdsrc->pw_dir)+1)*sizeof(char));
if (passwdtemp.pw_dir == NULL) {
*IERROR = ENOMEM;
free(passwdtemp.pw_name);
return;
}
(void)strcpy(passwdtemp.pw_dir, passwdsrc->pw_dir);
/* component: pw_shell (default login shell) */
passwdtemp.pw_shell =
(char *) malloc((strlen(passwdsrc->pw_shell)+1)*sizeof(char));
if (passwdtemp.pw_shell == NULL) {
*IERROR = ENOMEM;
free(passwdtemp.pw_name);
free(passwdtemp.pw_dir);
return;
}
(void)strcpy(passwdtemp.pw_shell, passwdsrc->pw_shell);
/* components not supported in Posix 1003.9-1992, but supported in target OSes */
/* component: pw_passwd (encrypted password) */
passwdtemp.pw_passwd =
(char *)malloc((strlen(passwdsrc->pw_passwd)+1)*sizeof(char));
if (passwdtemp.pw_passwd == NULL) {
*IERROR = ENOMEM;
free(passwdtemp.pw_name);
free(passwdtemp.pw_dir);
free(passwdtemp.pw_shell);
return;
}
(void)strcpy(passwdtemp.pw_passwd, passwdsrc->pw_passwd);
#ifndef _LITTLE_ENDIAN
/* component: pw_age (password age) */
passwdtemp.pw_age =
(char *)malloc((strlen(passwdsrc->pw_age)+1)*sizeof(char));
if (passwdtemp.pw_age == NULL) {
*IERROR = ENOMEM;
free(passwdtemp.pw_name);
free(passwdtemp.pw_dir);
free(passwdtemp.pw_shell);
free(passwdtemp.pw_passwd);
return;
}
(void)strcpy(passwdtemp.pw_age, passwdsrc->pw_age);
/* component: pw_comment (comment) */
passwdtemp.pw_comment =
(char *)malloc((strlen(passwdsrc->pw_comment)+1)*sizeof(char));
if (passwdtemp.pw_comment == NULL) {
*IERROR = ENOMEM;
free(passwdtemp.pw_name);
free(passwdtemp.pw_dir);
free(passwdtemp.pw_shell);
free(passwdtemp.pw_passwd);
free(passwdtemp.pw_age);
return;
}
(void)strcpy(passwdtemp.pw_comment, passwdsrc->pw_comment);
#endif /* not _LITTLE_ENDIAN */
/* component: pw_gecos */
passwdtemp.pw_gecos =
(char *)malloc((strlen(passwdsrc->pw_gecos)+1)*sizeof(char));
if (passwdtemp.pw_gecos == NULL) {
*IERROR = ENOMEM;
free(passwdtemp.pw_name);
free(passwdtemp.pw_dir);
free(passwdtemp.pw_shell);
free(passwdtemp.pw_passwd);
#ifndef _LITTLE_ENDIAN
free(passwdtemp.pw_age);
#endif /* not _LITTLE_ENDIAN */
free(passwdtemp.pw_gecos);
return;
}
(void)strcpy(passwdtemp.pw_gecos, passwdsrc->pw_gecos);
} else {
*IERROR = errno;
free(cname);
return;
}
}
/* free all components for the jpasswd handle. NOTE: free() as defined in ANSI C
* checks for a NULL pointer so this extra check does not need to be performed. */
free(cjpasswd->pw_name);
free(cjpasswd->pw_passwd);
#ifndef _LITTLE_ENDIAN
free(cjpasswd->pw_age);
free(cjpasswd->pw_comment);
#endif /* not _LITTLE_ENDIAN */
free(cjpasswd->pw_gecos);
free(cjpasswd->pw_dir);
free(cjpasswd->pw_shell);
*cjpasswd = passwdtemp;
}
void
_PXFGETENV(
#endif
_fcd name,
_f_int *lenname,
_fcd value,
_f_int *lenval,
_f_int *ierror)
{
char *buf, *cp, *v;
int i, lensrc, lenin, lentarg, lenv;
lenin = *lenname;
lensrc = _fcdlen(name);
lentarg = _fcdlen(value);
*ierror = 0;
/* check if the length of the lenname input argument is valid. */
if (lenin < 0 || lenin > lensrc) {
*ierror = EINVAL;
*lenval = 0;
return;
}
if (lensrc != 0) {
/* Copy input name. If lenname = 0, the trailing blanks
* must be stripped and the string may be null when the
* trailing blanks are stripped.
*/
if ((buf = _fc_acopy(name)) == NULL) {
*ierror = ENOMEM;
*lenval = 0;
return;
}
/* check for all blank input string */
if (strlen(buf) == 0) {
*lenval = 0;
cp = _fcdtocp(value);
(void) memset (cp, (int) ' ', lentarg);
return;
}
/* get value of environment variable name */
#ifdef _UNICOS
if ((v = getenv (buf)) == NULL) {
#else
if ((v = _GETENV(buf)) == NULL) {
#endif
/* name not found, return without
* setting other values.
*/
*ierror = EINVAL;
*lenval = 0;
return;
}
free(buf);
lenv = strlen(v);
*lenval = lenv;
/*
* return ETRUNC when string length greater than size of VALUE
* but copy the string up to the size of VALUE
*/
if(lenv > lentarg)
*ierror = ETRUNC;
/* destination is a character variable */
cp = _fcdtocp(value);
for (i = 0; i < lentarg && *v != '\0'; i++){
*cp++=*v++;
}
} else {
/* zero-length FCD NAME, return null pointer */
*lenval = 0;
i=0;
cp = _fcdtocp(value);
}
/* blank fill if necessary */
for (;i<lentarg;i++){
*cp++=' ';
}
return;
}
#ifndef _UNICOS
void
pxfgetenv_(
char *NAME,
_f_int *LENNAME,
char *VALUE,
_f_int *LENVAL,
_f_int *IERROR,
_f_int namelen,
_f_int valuelen)
{
_PXFGETENV( _cptofcd(NAME, namelen), LENNAME,
_cptofcd(VALUE, valuelen), LENVAL, IERROR);
return;
}
void
_PXFSETENV(
#endif
_fcd NAME,
_f_int *LENNAME,
_fcd NEW,
_f_int *LENNEW,
_f_int *IOTHERWISE,
_f_int *IERROR)
{
int ilenname, slenname, ilennew, slennew;
char *buf, *cname, *cnew;
ilenname = *LENNAME;
slenname = _fcdlen(NAME);
ilennew = *LENNEW;
slennew = _fcdlen(NEW);
*IERROR = 0;
/* check if the length of the lenname input argument is valid. */
if (ilenname < 0 || ilenname > slenname ||
ilennew < 0 || ilennew > slennew)
*IERROR = EINVAL;
else {
if (ilenname == 0) {
/*
* If length is zero, user wants trailing blanks stripped.
* Otherwise, malloc memory and copy the string adding a
* NULL terminator.
*/
cname = _fc_acopy(NAME);
ilenname = slenname;
} else {
cname = (char *) malloc (ilenname + 1);
if (cname != NULL) {
memcpy(cname, _fcdtocp(NAME), ilenname);
cname[ilenname] ='\0';
} else {
*IERROR = ENOMEM;
return;
}
}
/* check if NAME already exists in the envrion variable when
IOTHERWISE is zero. */
if (*IOTHERWISE == 0 && getenv(cname) != NULL)
return;
if (ilennew == 0) {
/*
* If length is zero, user wants trailing blanks stripped.
* Otherwise, malloc memory and copy the string adding a
* NULL terminator.
*/
cnew = _fc_acopy(NEW);
ilennew = slennew;
} else {
cnew = (char *) malloc(ilennew + 1);
if (cnew != NULL) {
memcpy(cnew, _fcdtocp(NEW), ilennew);
cnew[ilennew] ='\0';
} else {
*IERROR = ENOMEM;
return;
}
}
if (cname == NULL || cnew == NULL)
*IERROR = ENOMEM;
else {
/* concatenate strings to make cname=cnew pair */
if ((buf = (char *) malloc(ilenname + ilennew + 2)) == NULL) {
*IERROR = ENOMEM;
return;
} else {
/* create 'cname=cnew' pair */
strcpy(buf, cname);
strcat(buf, "=\0");
strcat(buf, cnew);
free(cname);
free(cnew);
}
if (putenv(buf) != 0)
*IERROR = ENOMEM;
}
}
return;
}
int COGPCH(_fcd name, int *val)
{
if (coSendFTN(GET_CHOICE_PARA, _fcdtocp(name), _fcdlen(name)))
return -1;
return coGetParaCh(val);
}
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;
}
int COSU3D(_fcd portName,int *numElem, float *data0, float *data1, float *data2)
{
if (coSendFTN(SEND_3DATA,_fcdtocp(portName),_fcdlen(portName)))
return -1;
return coSend3DataCommon(*numElem,data0,data1,data2);
}
int COGVFL(_fcd name, float *val)
{
if (coSendFTN(GET_V3_PARA_FLO, _fcdtocp(name), _fcdlen(name)))
return -1;
return coGetParaVecFlo(val);
}
static void
_rb(
FIOSPTR css, /* Current Fortran I/O state */
unit *cup, /* Unit pointer */
_f_int *recmode, /* Mode */
gfptr_t bloc, /* Beginning location */
gfptr_t eloc, /* Ending location */
type_packet *tip) /* Type information packet */
{
register int bytshft;
register int mode;
register long bytes;
register long elsize;
register long itemlen;
register long items;
register long stat;
register ftype_t type90;
int state;
char *uda, *udax;
#ifdef _CRAYT3D
register short shared;
register long ntot;
register long numleft;
long shrd[MAXSH];
#endif
if (cup->useq == 0) /* If direct access file */
_ferr(css, FEBIONDA, "BUFFER IN");
if (cup->ufmt) /* If formatted file */
_ferr(css, FEBIONFM, "BUFFER IN");
if (cup->uerr && !cup->unitchk)
_ferr(css, cup->uffsw.sw_error);
/*
* This check taken out temporarily because we'd like to be able to
* follow an ENDFILE statement or a READ which encounters an endfile
* record with a BUFFER IN statement. The sticky EOF principle should
* permit such a BUFFER IN to simply return an EOF status. But what
* really happens is the preceding ENDFILE or READ statement sets
* cup->uend, triggering an error here. We really need a flag to
* store the status of the previous BUFFER IN/OUT statement which is
* separate from cup->uend.
*
* if (cup->uend && !cup->unitchk)
* _ferr(css, FERDPEOF);
*/
cup->unitchk = 0;
cup->uerr = 0;
elsize = tip->elsize; /* Data size in bytes */
type90 = tip->type90;
/*
* Adjust the word count depending on the type.
*/
bytshft = ((sizeof(elsize) << 3) - 1) - _leadz(elsize); /* log2(elsize) */
if (type90 == DVTYPE_ASCII) { /* If character item */
uda = _fcdtocp(bloc.fcd);
udax = _fcdtocp(eloc.fcd);
itemlen = _fcdlen (eloc.fcd);
}
else {
#ifdef _CRAYT3D
shared = 0;
if (_issddptr(bloc.v)) {
int *tmpptr;
/* Shared data */
if (!_issddptr(eloc.v)) {
_ferr(css, FEINTUNK);
}
shared = 1;
ntot = 0;
if ((cup->ufs == FS_FDC) &&
(cup->uflagword & FFC_ASYNC)) {
/* When we can do I/O from shared memory */
/* we can support this. */
_ferr(css, FESHRSUP);
}
/*
* When compiler spr 76429 (on T3D) is closed, we can try replacing
* the lines that use tmpptr with this.
* items = _sdd_read_offset((void *)eloc.v) -
* _sdd_read_offset((void *)bloc.v) + 1;
*/
uda = bloc.v; /* temporary */
udax = eloc.v;
tmpptr = (int *)((int)udax & 0x7fffffffffffffff);
items = *(tmpptr + 1);
tmpptr = (int *)((int)uda & 0x7fffffffffffffff);
items = items - *(tmpptr + 1) + 1;
}
else
#endif /* _CRAYT3D */
{
uda = bloc.v;
udax = eloc.v;
}
itemlen = elsize;
}
#ifdef _CRAYT3D
if (shared) {
bytes = items << bytshft;
}
else
#endif
{
bytes = (udax - uda) + itemlen;
items = bytes >> bytshft;
}
if (bytes < 0)
_ferr(css, FEBIOFWA, "BUFFER IN");
mode = (*recmode < 0) ? PARTIAL : FULL;
cup->urecmode = mode;
cup->uwrt = 0;
state = CNT;
if ((items << bytshft) != bytes)
_ferr(css, FEBIOFWD);
#ifdef _CRAYT3D
if ( !shared && cup->uasync ) {
#else
if (cup->uasync) {
#endif
int ubc = 0;
WAITIO(cup, _ferr(css, cup->uffsw.sw_error));
#if defined(_UNICOS) || defined(NUMERIC_DATA_CONVERSION_ENABLED)
/*
* Pad word-aligned numeric data on word boundaries within
* the record for CRI and some foreign data formats.
*/
if ((cup->urecpos & cup->ualignmask) != 0 &&
type90 != DVTYPE_ASCII &&
elsize > 4 ) {
int padubc;
register int pbytes;
int padval;
COMPADD(cup, pbytes, padubc, padval);
if (pbytes != 0) {
stat = XRCALL(cup->ufp.fdc, readrtn)
cup->ufp.fdc,
WPTR2BP(&padval),
pbytes,
&cup->uffsw,
PARTIAL,
&padubc);
if (stat != pbytes ||
FFSTAT(cup->uffsw) != FFCNT) {
cup->uerr = 1;
goto badpart;
}
cup->urecpos += (stat << 3) - padubc;
}
}
int COSU1D(_fcd portName, int *numElem, float *data)
{
if (coSendFTN(SEND_1DATA,_fcdtocp(portName),_fcdlen(portName)))
return -1;
return coSend1DataCommon(*numElem,data);
}
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));
}
void FATR checksum_char_update_(_fcd f)
{
checksum_update(_fcdlen(f), _fcdtocp(f));
}
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;
}
int COGPSL(_fcd name, float *min, float *max, float *val)
{
if (coSendFTN(GET_SLI_PARA, _fcdtocp(name), _fcdlen(name)))
return -1;
return coGetParaSli(min, max, val);
}
void
_PXFEXECV(
#endif
_fcd PATH,
_f_int *LENPATH,
_fcd ARGV, /* packed array of fortran strings */
_f_int *LENARGV,
_f_int *IARGC,
_f_int *IERROR
)
{
char **arg, /* vector of argument strings for execv */
*cpath, /* file path for executable */
*cstring_ARGV; /* the C-style string for the ARGV fortran character
* descriptor */
int clenpath, /* equal to *LENPATH, the user defined length of PATH */
i, /* loop counter */
position, /* current position in the string cstring_ARGV */
ciargc, /* equal to *IARGC, the number of arguments for execv */
cstring_lenargv, /* the length of the FCD ARGV. Note: This is the length of
an individual FCD in the array ARGV. */
len; /* length of string to copy from cstring_ARGV to a string
in the arg vector of strings. */
clenpath = *LENPATH;
cstring_lenargv = _fcdlen(ARGV);
ciargc = *IARGC;
/* check for valid path length passed in by user */
if (clenpath < 0 || clenpath > _fcdlen(PATH)) {
*IERROR = EINVAL;
return;
} else {
if (clenpath == 0) {
/*
* If length is zero, user wants trailing blanks stripped.
* Otherwise, malloc memory and copy the string adding a
* NULL terminator.
*/
cpath = _fc_acopy(PATH);
} else {
cpath = (char *)malloc(clenpath + 1);
if (cpath != NULL) {
memcpy(cpath, _fcdtocp(PATH), clenpath);
cpath[clenpath] = '\0';
} else {
*IERROR = ENOMEM;
return;
}
}
}
/* attempt to copy all argument strings from ARGV */
/* check the LENARGV array for proper values before copying ARGV strings */
i = 0;
while (i < ciargc) {
len = LENARGV[i];
if (len < 0 || len > cstring_lenargv) {
*IERROR = EINVAL;
free(cpath);
return;
}
i++;
}
arg = (char **)calloc(ciargc + 1,sizeof(char *));
if (arg == NULL) {
*IERROR = ENOMEM;
free(cpath);
return;
}
cstring_ARGV = _fcdtocp(ARGV);
/* malloc the memory for all the strings copy each Fortran string
* into a C-style string */
for (i = 0, position = 0; i < ciargc; position += cstring_lenargv, i++) {
len = LENARGV[i];
/* strip off trailing blanks */
if (len == 0) {
len = cstring_lenargv - 1;
while ((len > 0) &&
cstring_ARGV[(i * cstring_lenargv) + len] == ' ') {
len--;
}
len++;
}
if ((arg[i] = (char *)malloc((len+1)*sizeof(char))) == NULL) {
for (; i >= 0; i--) {
free(arg[i]);
}
free(arg);
free(cpath);
*IERROR = ENOMEM;
return;
}
strncpy(arg[i], &cstring_ARGV[position], len);
arg[i][len] = '\0';
}
if (execv(cpath, arg) == -1) {
for (i--; i >= 0; i--) {
free(arg[i]);
}
free(arg);
free(cpath);
*IERROR = errno;
return;
}
*IERROR = 0;
}
int COGPFL(_fcd name, float *val)
{
if (coSendFTN(GET_SC_PARA_FLO, _fcdtocp(name), _fcdlen(name)))
return -1;
return coGetParaScaFlo(val);
}
/*
* This is a wrapper function used to call the /xrv driver from
* CRAY FORTRAN.
*--
* 24-Mar-1997 - [mcs]
*/
void RVDRIV(int *ifunc, float *rbuf, int *nbuf, _fcd chr, int *lchr, int *mode)
{
rvdriv_(ifunc, rbuf, nbuf, _fcdtocp(chr), lchr, mode, _fcdlen(chr));
}
int COGPIN(_fcd name, int *val)
{
if (coSendFTN(GET_SC_PARA_INT, _fcdtocp(name), _fcdlen(name)))
return -1;
return coGetParaScaInt(val);
}
/*
* This is a wrapper function used to call the /xdisp driver from
* CRAY FORTRAN.
*--
* 09-Nov-1994 - [mcs]
*/
void X2DRIV(int *ifunc, float *rbuf, int *nbuf, _fcd chr, int *lchr)
{
x2driv_(ifunc, rbuf, nbuf, _fcdtocp(chr), lchr, mode, _fcdlen(chr));
}
int COGPBO(_fcd name, int *val)
{
if (coSendFTN(GET_BOOL_PARA, _fcdtocp(name), _fcdlen(name)))
return -1;
return coGetParaBo(val);
}
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 */
}
