void
NAME(DopeVectorType *RESULT, DopeVectorType *MATRIX_A,
DopeVectorType *MATRIX_B)
{
void SUBNAME();
const RESULTTYPE true = _btol(1);
const RESULTTYPE false = _btol(0);
MatrixDimenType matdimdata, *MATDIM;
MATDIM = (MatrixDimenType *) &matdimdata;
/*
* Parse dope vectors, and perform error checking.
*/
_premult(RESULT, MATRIX_A, MATRIX_B, MATDIM);
/*
* Perform the matrix multiplication.
*/
SUBNAME(&MATDIM->m, &MATDIM->n, &MATDIM->k, &true, MATDIM->A,
&MATDIM->inc1a, &MATDIM->inc2a, MATDIM->B, &MATDIM->inc1b,
&MATDIM->inc2b, &false, MATDIM->C, &MATDIM->inc1c, &MATDIM->inc2c);
return;
}
void
_EOSHIFT_CP3 (
DopeVectorType *result,
DopeVectorType *source,
DopeVectorType *shift,
DopeVectorType *boundary,
int *dim)
{
#include "eoshift_p.h"
/*
* Call the Fortran work routine
*/
special = 0;
if (shflag == _btol(1) && bndflag == _btol(1)) {
if (shftval >= -1 && shftval <= 1) {
if (_blkct (source_sdd_ptr, 1, 0) == 1 &&
_blkct (source_sdd_ptr, 2, 0) == 1 &&
_blkct (source_sdd_ptr, 3, 0) == 1) {
special = 1;
}
}
}
if (special) {
EOSHIFT_SPEC_WD2_P3@ ( result_sdd_ptr, source_sdd_ptr,
&dim_val, src_extents, &shftval, &bndval);
} else {
EOSHIFT_WD2_P3@ ( result_sdd_ptr, source_sdd_ptr, shift_sdd_ptr,
bound_sdd_ptr, &dim_val, src_extents, shft_extents,
bnd_extents, &shflag, &shftval, &bndflag, &bndval);
}
}
void
_PRE_SUM(int *flag, DopeVectorType * RESULT, DopeVectorType * MATRIX_A,
DopeVectorType *DIM, DopeVectorType * MASK, int *ndim,
int *dimarg, int *dima, int *maskarg, int *scalar, long *loca,
int lima[], int inca[], long *locb,
int limb[], int incb[], long *locm,
int limm[], int incm[], int *sizem, long *loc4m)
{
int nbits, nbytes, nwords; /* size of RESULT matrix */
int i; /* subscript */
int dim; /* value of DIM argument */
int temp; /* for temporary storage */
void *locab; /* local store for veca */
void *locbb; /* local store for vecb */
void *locmc; /* local store for result */
DopeVectorType *dm, *mk;
_f_int8 *dimenp8 = NULL;
_f_int4 *dimenp4 = NULL;
_f_int2 *dimenp2 = NULL;
_f_int1 *dimenp1 = NULL;
int dmintlen; /* internal length of DIM value */
dm = DIM;
mk = MASK;
/* if last arg = NULL, is last-1 arg mask or dim? */
if (MASK == NULL) {
/* last arg = NULL, is last-1 arg mask or dim? */
if (DIM != NULL) {
if (DIM->type_lens.type == DVTYPE_LOGICAL) {
/* last-1 argument is mask. */
mk = DIM;
dm = MASK;
}
}
}
if (dm != NULL) {
dmintlen = dm->type_lens.int_len >> 3;
if (dmintlen == sizeof(_f_int8)) {
*dimarg = _btol(1); /* dimarg = .TRUE. */
dimenp8 = (_f_int8 *) dm->base_addr.a.ptr;
dim = *dimenp8; /* dimension to sum over */
*dima = *dimenp8; /* dimension to sum over */
} else if (dmintlen == sizeof(_f_int4)) {
*dimarg = _btol(1); /* dimarg = .TRUE. */
dimenp4 = (_f_int4 *) dm->base_addr.a.ptr;
dim = *dimenp4; /* dimension to sum over */
*dima = *dimenp4; /* dimension to sum over */
} else if (dmintlen == sizeof(_f_int2)) {
*dimarg = _btol(1); /* dimarg = .TRUE. */
dimenp2 = (_f_int2 *) dm->base_addr.a.ptr;
dim = *dimenp2; /* dimension to sum over */
*dima = *dimenp2; /* dimension to sum over */
} else if (dmintlen == sizeof(_f_int1)) {
*dimarg = _btol(1); /* dimarg = .TRUE. */
dimenp1 = (_f_int1 *) dm->base_addr.a.ptr;
dim = *dimenp1; /* dimension to sum over */
*dima = *dimenp1; /* dimension to sum over */
}
} else {
void
_CSHIFT_JP1 (
DopeVectorType *result,
DopeVectorType *source,
DopeVectorType *shift,
int *dim)
{
#include "cshift_p.h"
/*
* Call the Fortran work routine
*/
special = 0;
if (shflag == _btol(1)) {
if (shftval >= -1 && shftval <= 1) {
if (_blkct (source_sdd_ptr, 1, 0) == 1) {
special = 1;
}
}
}
if (special) {
CSHIFT_SPEC_WD1_P1@ ( result_sdd_ptr, source_sdd_ptr,
src_extents, &shftval);
} else {
CSHIFT_WD1_P1@ ( result_sdd_ptr, source_sdd_ptr, src_extents,
&shftval);
}
}
_f_log8
_ALLOCATED_8 (DopeVectorType * source)
{
_f_log8 iresult;
iresult = FALSE;
/* Is source is an allocatable array and allocated. */
if ((source->p_or_a == ALLOC_ARRY) && (source->assoc))
iresult = TRUE;
return(_btol(iresult));
}
_f_log8 _IEEE_IS_NAN_L8_H( _f_real4 x)
{
/* if x is NaN, return TRUE */
return ((_f_log8) _btol(isnan32(x)));
}
_f_log8 _IEEE_IS_NAN_L8_D( _f_real16 x)
{
/* if x is NaN, return TRUE */
return ((_f_log8) _btol(isnan128(x)));
}
/*
* _f_inqu - process INQUIRE statement.
*
* Return value
* Returns 0 on success, positive error code if an error
* is encountered and ERR= or IOSTAT= are unspecified.
* This routine aborts on error conditions if no ERR=
* or IOSTAT= are specified.
*/
int _f_inqu(
FIOSPTR css, /* statement state */
unit *cup, /* locked unit pointer if INQUIRE by
* unit and unit is connected. */
inlist *a) /* list of INQUIRE specifiers */
{
int aifound; /* Assign info found flag */
int byfile; /* INQUIRE by file/unit flag */
int exists; /* File exists flag */
int opened; /* File opened flag */
int valunit; /* Valid unit number flag */
int errn;
char *buf, *fn, *s;
struct stat st; /* Stat system call packet */
assign_info ai; /* Assign information packet */
unit *p;
p = cup;
errn = 0;
/*
* Lock _openlock to ensure that no other task opens or closes units
* during the unit table scan for inquire-by-file processing.
*/
OPENLOCK();
if (a->infile != NULL) /* if INQUIRE by file */
byfile = 1;
else { /* else INQUIRE by unit */
byfile = 0;
valunit = GOOD_UNUM(a->inunit) &&
!RSVD_UNUM(a->inunit); /* Valid Unit Number? */
}
if ((buf = malloc(MAX(a->infilen + 1, MXUNITSZ + 1))) == NULL) {
errn = FENOMEMY;
if (a->inerr)
goto out_of_here;
_ferr(css, errn);
}
*buf = '\0'; /* Assume no name */
opened = 0; /* Assume not opened */
fn = buf;
if (byfile) { /* If INQUIRE by file */
_copy_n_trim(a->infile, a->infilen, buf);
if ((aifound = _get_a_options(0, buf, -1, 0, &ai, NULL,
_LELVL_RETURN)) == -1) {
errn = errno;
if (a->inerr) {
free(buf);
goto out_of_here;
}
_ferr(css, errn);
}
if (aifound && ai.a_actfil_flg) /* If assign alias */
s = ai.a_actfil; /* Use -a attribute as file name */
else
s = buf;
exists = (stat(s, &st) != -1);
if (exists) {
p = _get_next_unit(NULL, 1, 1);
while (p != NULL) { /* while more open units */
unum_t unum;
unum = p->uid;
if (! RSVD_UNUM(unum) &&
(p->uinode == st.st_ino) &&
(p->udevice == st.st_dev)) {
fn = p->ufnm;
opened = 1;
break;
}
p = _get_next_unit(p, 1, 1);
}
/*
* If p is non-null here, it points to a locked unit.
* The unit is locked to ensure a consistent set of
* INQUIRE'd attributes is returned.
*/
}
}
else { /* Else INQUIRE by unit */
if (valunit) {
opened = (cup != NULL);
if (opened) { /* If opened, get name */
p = cup;
fn = p->ufnm;
}
}
}
if (fn == NULL) /* If no name available, return blanks */
fn = "";
/* EXIST specifier */
if (a->inex != NULL)
if (byfile) /* If INQUIRE by file */
*a->inex = _btol(exists);
else /* INQUIRE by unit */
*a->inex = _btol(valunit);
/* OPENED specifier */
if (a->inopen != NULL)
*a->inopen = _btol(opened);
/* NAMED specifier */
if (a->innamed != NULL)
if (byfile) /* If INQUIRE by file */
*a->innamed = _btol(1); /* .TRUE. */
else /* INQUIRE by unit */
*a->innamed = _btol(opened && p->ufnm != NULL);
/* NUMBER specifier */
if (a->innum != NULL) {
if (opened) {
if (byfile) /* If INQUIRE by file */
*a->innum = (opened) ? p->uid : -1;
else /* INQUIRE by unit */
*a->innum = a->inunit; /* The law of identity */
}
else
*a->innum = -1;
}
/* RECL specifier */
if (a->inrecl != NULL)
if (opened) {
if (p->urecl > 0) /* If recl was specified */
*a->inrecl = p->urecl;
else /* Recl not specified (i.e., sequential) */
*a->inrecl = (p->ufmt) ? p->urecsize : LONG_MAX;
}
else
*a->inrecl = -1;
/* NEXTREC specifier */
if (a->innrec != NULL)
if (opened && p->useq == 0) /* If opened & direct access */
*a->innrec = p->udalast + 1;
else
*a->innrec = -1;
/* NAME specifier */
if (a->inname != NULL)
_b_char(fn, a->inname, a->innamlen);
/* ACCESS specifier */
if (a->inacc != NULL) {
if (opened)
s = (p->useq) ? "SEQUENTIAL" : "DIRECT";
else
s = "UNDEFINED";
_b_char(s, a->inacc, a->inacclen);
}
/* SEQUENTIAL specifier */
if (a->inseq != NULL) {
if (opened)
s = (p->useq) ? "YES" : "NO";
else
s = "UNKNOWN";
_b_char(s, a->inseq, a->inseqlen);
}
/* DIRECT specifier */
if (a->indir != NULL) {
if (opened)
s = (p->useq) ? "NO" : "YES";
else
s = "UNKNOWN";
_b_char(s, a->indir, a->indirlen);
}
/* FORM specifier */
if (a->inform != NULL) {
if (opened)
s = (p->ufmt) ? "FORMATTED" : "UNFORMATTED";
else
s = "UNDEFINED";
_b_char(s, a->inform, (ftnlen)a->informlen);
}
/* FORMATTED specifier */
if (a->infmt != NULL) {
if (opened)
s = (p->ufmt) ? "YES" : "NO";
else
s = "UNKNOWN";
_b_char(s, a->infmt, a->infmtlen);
}
/* UNFORMATTED specifier */
if (a->inunf != NULL) {
if (opened)
s = (p->ufmt) ? "NO" : "YES";
else
s = "UNKNOWN";
_b_char(s, a->inunf, a->inunflen);
}
/* BLANK specifier */
if (a->inblank != NULL) {
if (opened && p->ufmt)
s = (p->ublnk) ? "ZERO" : "NULL";
else
s = "UNDEFINED";
_b_char(s, a->inblank, a->inblanklen);
}
/* POSITION specifier */
if (a->inposit != NULL) { /* Fortran 90 position control */
if (opened && p->useq) {
switch (p->uposition) {
case OS_REWIND:
s = "REWIND";
break;
case OS_ASIS:
s = "ASIS";
break;
case OS_APPEND:
s = "APPEND";
break;
case 0:
s = "UNKNOWN";
break;
default:
_ferr(css, FEINTUNK);
}
}
else
s = "UNDEFINED";
_b_char(s, a->inposit, a->inpositlen);
}
/* ACTION specifier */
if (a->inaction != NULL) { /* Fortran 90 action control */
if (opened) {
switch (p->uaction) {
case OS_READWRITE:
s = "READWRITE";
break;
case OS_READ:
s = "READ";
break;
case OS_WRITE:
s = "WRITE";
break;
default:
_ferr(css, FEINTUNK);
}
}
else /* for an unconnected file */
s = "UNDEFINED";
_b_char(s, a->inaction, a->inactonlen);
}
/* READ specifier */
if (a->inread != NULL) { /* Fortran 90 read action control */
if (opened) {
if ((p->uaction == OS_READ) ||
(p->uaction == OS_READWRITE))
s = "YES";
else
s = "NO";
}
else
s = "UNKNOWN";
_b_char(s, a->inread, a->inreadlen);
}
/* WRITE specifier */
if (a->inwrite != NULL) { /* Fortran 90 write action control */
if (opened) {
if ((p->uaction == OS_WRITE) ||
(p->uaction == OS_READWRITE))
s = "YES";
else
s = "NO";
}
else
s = "UNKNOWN";
_b_char(s, a->inwrite, a->inwritelen);
}
/* READWRITE specifier */
if (a->inredwrit != NULL) { /* Fortran 90 read/write action control */
if (opened) {
if (p->uaction == OS_READWRITE)
s = "YES";
else
s = "NO";
}
else
s = "UNKNOWN";
_b_char(s, a->inredwrit, a->inrdwrtlen);
}
/* DELIM specifier */
if (a->indelim != NULL) { /* Fortran 90 delim control */
if (opened && p->ufmt) { /* if formatted */
switch (p->udelim) {
case OS_NONE:
s = "NONE";
break;
case OS_QUOTE:
s = "QUOTE";
break;
case OS_APOSTROPHE:
s = "APOSTROPHE";
break;
default:
_ferr(css, FEINTUNK);
}
}
else /* UNDEFINED for unformatted or unconnected file */
s = "UNDEFINED";
_b_char(s, a->indelim, a->indelimlen);
}
/* PAD specifier */
if (a->inpad != NULL) { /* Fortran 90 pad control */
if(opened && p->ufmt) { /* if formatted */
switch (p->upad) {
case OS_YES:
s = "YES";
break;
case OS_NO:
s = "NO";
break;
default:
_ferr(css, FEINTUNK);
}
}
else /* Fortran 90 missed UNDEFINED if unformatted or unconnected */
s = "YES"; /* set to YES instead of UNDEFINED */
_b_char(s, a->inpad, a->inpadlen);
}
/*
* Unlock the unit if we have a pointer to an open unit. Note that
* $INQ/_INQUIRE never unlocks the unit.
*/
out_of_here:
OPENUNLOCK();
if (p != NULL)
_release_cup(p); /* unlock the unit */
free(buf);
return(errn);
}
void
__all ( DopeVectorType * result,
DopeVectorType * mask,
_f_int *dimension)
{
int c_dim; /* C form of input dimension */
int other_dim; /* other dimension in rank-2 */
int num_elts = 1; /* elts in result array */
long nbytes = 0; /* bytes to malloc */
_f_log * irptr; /* ptr to result array */
_f_log * imptr; /* ptr to mask array */
_f_log4 * i4rptr; /* ptr to result array */
_f_log4 * i4mptr; /* ptr to mask array */
_f_log8 * i8rptr; /* ptr to result array */
_f_log8 * i8mptr; /* ptr to mask array */
#ifdef _F_LOG1
_f_log1 * i1rptr; /* ptr to result array */
_f_log1 * i1mptr; /* ptr to mask array */
#endif
#ifdef _F_LOG2
_f_log2 * i2rptr; /* ptr to result array */
_f_log2 * i2mptr; /* ptr to mask array */
#endif
long i, j; /* index variables */
long indx, jndx; /* loop indices */
int done, stop; /* work done indicators */
int el_len; /* LTOB length indicator */
int mshftct=0; /* mask amount to shift index */
int rshftct=0; /* result amount to shift index */
/* Per-dimension arrays */
long current_place[MAXDIM-1]; /* current place*/
long mask_offset[MAXDIM-1]; /* mask offset */
long mask_extent[MAXDIM-1]; /* mask extent */
long mask_stride[MAXDIM-1]; /* mask stride */
long result_offset[MAXDIM-1]; /* result offset*/
long result_stride[MAXDIM-1]; /* result stride*/
long cdim_mask_stride; /* cdim stride */
/* Validate dimension variable */
if (dimension != NULL && mask->n_dim > 1) {
c_dim = *dimension - 1;
if (c_dim < 0 || c_dim >= mask->n_dim)
_lerror (_LELVL_ABORT, FESCIDIM);
} else {
c_dim = 0;
if (dimension != NULL) {
if (*dimension < 1 || *dimension > mask->n_dim)
_lerror (_LELVL_ABORT, FESCIDIM);
}
}
/* Setup dope vector for result array */
if (!result->assoc) {
int sm = 1;
if (result->base_addr.a.el_len >= BITS_PER_WORD)
sm = result->base_addr.a.el_len / BITS_PER_WORD;
if (dimension != NULL) {
for (i = 0; i < c_dim; i++) {
result->dimension[i].extent =
mask->dimension[i].extent;
result->dimension[i].low_bound = 1;
result->dimension[i].stride_mult =
num_elts * sm;
num_elts *= mask->dimension[i].extent;
}
for ( ; i < result->n_dim; i++) {
result->dimension[i].extent =
mask->dimension[i+1].extent;
result->dimension[i].low_bound = 1;
result->dimension[i].stride_mult =
num_elts * sm;
num_elts *= mask->dimension[i+1].extent;
}
}
result->base_addr.a.ptr = (void *) NULL;
nbytes = ((num_elts * result->base_addr.a.el_len) /
BITS_PER_BYTE);
if (nbytes != 0) {
result->base_addr.a.ptr = (void *) malloc (nbytes);
if (result->base_addr.a.ptr == NULL)
_lerror(_LELVL_ABORT, FENOMEMY);
result->assoc = 1;
}
/* set fields for null array as well */
result->orig_base = result->base_addr.a.ptr;
result->orig_size = nbytes * BITS_PER_BYTE;
}
/* Set pointer to result array and initialize result array to TRUE */
irptr = (void *) result->base_addr.a.ptr;
switch (result->type_lens.int_len) {
case 64 :
i8rptr = (_f_log8 *) result->base_addr.a.ptr;
#ifdef _F_LOG4
if (sizeof(_f_int) == sizeof(_f_log4))
rshftct = 1;
#endif
#ifdef _UNICOS
#pragma _CRI ivdep
#endif
for (i = 0; i < num_elts; i++) {
i8rptr[i] = (_f_log8) _btol(1);
}
break;
#ifdef _F_LOG2
case 16 :
i2rptr = (_f_log2 *) result->base_addr.a.ptr;
for (i = 0; i < num_elts; i++) {
i2rptr[i] = (_f_log2) _btol(1);
}
break;
#endif
#ifdef _F_LOG1
case 8 :
i1rptr = (_f_log1 *) result->base_addr.a.ptr;
for (i = 0; i < num_elts; i++) {
i1rptr[i] = (_f_log1) _btol(1);
}
break;
#endif
case 32 :
default :
i4rptr = (_f_log4 *) result->base_addr.a.ptr;
#ifdef _UNICOS
#pragma _CRI ivdep
#endif
for (i = 0; i < num_elts; i++) {
i4rptr[i] = (_f_log4) _btol(1);
}
}
imptr = (void *) mask->base_addr.a.ptr;
switch (mask->type_lens.int_len) {
case 64 :
el_len = sizeof(_f_log8) * BITS_PER_BYTE;
i8mptr = (_f_log8 *) imptr;
#ifdef _F_LOG4
/* Set mask shftct for ALL with no size specified since
* no size means a 64-bit logical value. A default of
* 32-bit logical has a stride_mult of two for a 64-bit
* logical on WORD32. Normally, the ALL_8 entry point
* is used. On MPP, the stride_mult is one for 32-bit
* or 64-bit logical.
*/
if (sizeof(_f_int) == sizeof(_f_log4))
mshftct = 1;
#endif
break;
#ifdef _F_LOG2
case 16 :
el_len = sizeof(_f_log2) * BITS_PER_BYTE;
i2mptr = (_f_log2 *) imptr;
break;
#endif
#ifdef _F_LOG1
case 8 :
el_len = sizeof(_f_log1) * BITS_PER_BYTE;
i1mptr = (_f_log1 *) imptr;
break;
#endif
case 32 :
default :
el_len = sizeof(_f_log4) * BITS_PER_BYTE;
i4mptr = (_f_log4 *) imptr;
}
/* check for zero-sized mask array */
for (i = 0; i < mask->n_dim; i++) {
if (mask->dimension[i].extent == 0)
return;
}
/* Handle a rank-one mask array */
if (mask->n_dim == 1) {
/* Use local mask_stride and divide by two when two-word
* logical is being done.
*/
#ifdef _F_LOG4
mask_stride[0] = (mask->dimension[0].stride_mult) >> mshftct;
#else
mask_stride[0] = mask->dimension[0].stride_mult;
#endif
/* Scan array until a FALSE element is found */
i = 0;
indx = 0;
switch (mask->type_lens.int_len) {
case 64 :
while (i < mask->dimension[0].extent) {
if (LTOB(el_len, (i8mptr + indx))) {
/* true element */
i++;
indx = i * mask_stride[0];
} else {
/* false element */
switch (result->type_lens.int_len) {
case 64 :
i8rptr[0] = (_f_log8) _btol(0);
break;
#ifdef _F_LOG2
case 16 :
i2rptr[0] = (_f_log2) _btol(0);
break;
#endif
#ifdef _F_LOG1
case 8 :
i1rptr[0] = (_f_log1) _btol(0);
break;
#endif
case 32 :
default :
i4rptr[0] = (_f_log4) _btol(0);
}
i = mask->dimension[0].extent;
}
}
break;
#ifdef _F_LOG2
case 16 :
while (i < mask->dimension[0].extent) {
if (LTOB(el_len, (i2mptr + indx))) {
/* true element */
i++;
indx = i * mask_stride[0];
} else {
/* false element */
switch (result->type_lens.int_len) {
case 64 :
i8rptr[0] = (_f_log8) _btol(0);
break;
case 16 :
i2rptr[0] = (_f_log2) _btol(0);
break;
#ifdef _F_LOG1
case 8 :
i1rptr[0] = (_f_log1) _btol(0);
break;
#endif
case 32 :
default :
i4rptr[0] = (_f_log4) _btol(0);
}
i = mask->dimension[0].extent;
}
}
break;
#endif
#ifdef _F_LOG1
case 8 :
while (i < mask->dimension[0].extent) {
if (LTOB(el_len, (i1mptr + indx))) {
/* true element */
i++;
indx = i * mask_stride[0];
} else {
/* false element */
switch (result->type_lens.int_len) {
case 64 :
i8rptr[0] = (_f_log8) _btol(0);
break;
case 16 :
i2rptr[0] = (_f_log2) _btol(0);
break;
case 8 :
i1rptr[0] = (_f_log1) _btol(0);
break;
case 32 :
default :
i4rptr[0] = (_f_log4) _btol(0);
}
i = mask->dimension[0].extent;
}
}
break;
#endif
case 32 :
default :
while (i < mask->dimension[0].extent) {
if (LTOB(el_len, (i4mptr + indx))) {
/* true element */
i++;
indx = i * mask_stride[0];
} else {
/* false element */
switch (result->type_lens.int_len) {
case 64 :
i8rptr[0] = (_f_log8) _btol(0);
break;
#ifdef _F_LOG2
case 16 :
i2rptr[0] = (_f_log2) _btol(0);
break;
#endif
#ifdef _F_LOG1
case 8 :
i1rptr[0] = (_f_log1) _btol(0);
break;
#endif
case 32 :
default :
i4rptr[0] = (_f_log4) _btol(0);
}
i = mask->dimension[0].extent;
}
}
}
/* Handle a rank-two mask array */
} else if (mask->n_dim == 2) {
_f_log8 _IEEE_IS_NAN_L8( _f_real8 x)
{
/* if x is NaN, return TRUE */
return ((_f_log8) _btol(isnan64(x)));
}