void
_BOUNDS_ERROR(
char *file, /* Fortran routine containing error */
int *line, /* Line number in Fortran routine */
char *variable, /* arrayname with out-of-bounds subscript */
int *dim, /* Dimension number of the array */
int *lowerbnd, /* Lower bound of dimension dim */
int *upperbnd, /* Upper bound of dimension dim */
int sub[1], /* Out-of-bounds subscript value */
int *count) /* Count/flag for number of messages */
{
int *retcnt; /* ptr to static arg count word */
int intcnt = 0; /* local count if no count passed */
#ifdef _UNICOS
/* Use local variable if count argument not passed. */
if (_numargs() < 8)
retcnt = &intcnt;
else
#endif
retcnt = count;
if ((*retcnt)++ == 0) {
#ifdef KEY /* Bug 7969 */
if (want_abort()) {
(void) _lerror(_LELVL_MSG, FWARGSBV, sub[0], *dim, variable,
*line, file, *lowerbnd, *upperbnd);
do_abort();
}
#endif /* KEY Bug 7969 */
(void) _fwarn(FWARGSBV, sub[0], *dim, variable, *line,
file, *lowerbnd, *upperbnd);
}
return;
}
void
_RBOUNDS_ERROR(
char *file, /* Fortran routine containing error */
int *line, /* Line number in Fortran routine */
char *variable, /* arrayname with out-of-bounds subscript */
int *dim, /* Dimension number with size mismatch */
int *lowerbnd, /* Lower bound of dimension dim */
int *upperbnd, /* Upper bound of dimension dim */
int *start, /* Out-of-bounds starting subscript */
int *end, /* Out-of-bounds ending subscript */
int *incr, /* Increment between subscript */
int *count) /* Count/flag for number of messages */
{
int *retcnt; /* ptr to static arg count word */
int intcnt = 0; /* local count if no count passed */
#ifdef _UNICOS
/* Use local variable if count argument not passed. */
if (_numargs() < 10)
retcnt = &intcnt;
else
#endif
retcnt = count;
if ((*retcnt)++ == 0) {
(void) _fwarn(FWARGSBR, *start, *end, *incr, *dim,
variable, *line, file, *lowerbnd, *upperbnd);
}
return;
}
void
__f90_bounds_check(char *procedure_name, _f_int4 line_number, char *array_name, _f_int4 axis_number)
{
char *unknown_nm = "name_unknown";
char *abort_now = NULL;
char *rtn_nm = "__f90_bounds_check";
/* note mips f90 compiler appends extra characters at
* the end of the procedure name.
*/
/* MIPSpro 7.2 and 7.2.1 documentation assumed that the
* routine would abort if this environment variable is
* is set. Otherwise, the message is just a warning.
*/
abort_now = getenv("F90_BOUNDS_CHECK_ABORT");
if (abort_now) {
if (*abort_now == 'y' || *abort_now == 'Y') {
if (array_name) {
(void) _lerror(_LELVL_MSG, FWARGSVB,
axis_number, array_name, line_number,
procedure_name, rtn_nm);
} else {
(void) _lerror(_LELVL_MSG, FWARGSVB,
axis_number, unknown_nm, line_number,
procedure_name, rtn_nm);
}
/* cleanup the fortran units before abort */
_fcleanup();
abort();
}
}
if (array_name)
(void) _fwarn(FWARGSVB,axis_number, array_name,
line_number, procedure_name, rtn_nm);
else
(void) _fwarn(FWARGSVB,axis_number, unknown_nm,
line_number, procedure_name, rtn_nm);
return;
}
/*
* Error handler for an array syntax conformance warning.
* This entry is called by the f90 compiler on IRIX only.
*
* Input Arguments:
* file - File name in which error occurred.
* line - Line number in file.
* dim - Dimension number which has a size mismatch.
* extent1 - One of two mismatched 64-bit extents of dimension dim.
* extent2 - One of two mismatched 64-bit extents of dimension dim.
*
* ON MIPS, if the environment varaiable is set to Y(ES), produce an
* error message with the information and then abort. Otherwise,
* produce a warning for the conformity check.
*
* When the input dimension is zero, this routine is being called
* from an inline version of a transformational function such as
* MATMUL and the use of a dimension would be confusing since the
* first dimension of one argument and the second dimension of the
* other argument are mismatched.
*
* When the input dimension is nonzero, this routine is being called
* when the specified dimension is the same for both arguments.
*
* The message contains the name of this routine for debugging.
*/
void
__f90_conform_check(
char *file,
int line,
int dim,
long long extent1,
long long extent2)
{
char *abort_now = NULL;
char *rtn_nm = "__f90_conform_check";
abort_now = getenv("F90_CONFORM_CHECK_ABORT");
if (extent1 < 0)
extent1 = 0;
if (extent2 < 0)
extent2 = 0;
/* abort only if environment variable is present and is Y(es) */
if (abort_now && (*abort_now == 'y' || *abort_now == 'Y')) {
/* Use proper message depending on value of dimension. */
if (dim != 0)
(void) _lerror(_LELVL_MSG,FWARGDMD, dim, line,
file, extent1, extent2, rtn_nm);
else
(void) _lerror(_LELVL_MSG,FWARGDMZ, line,
file, extent1, extent2, rtn_nm);
_fcleanup();
abort();
}
/* Use proper message depending on value of dimension. */
if (dim != 0)
(void) _fwarn(FWARGDMD, dim, line, file, extent1,
extent2, rtn_nm);
else
(void) _fwarn(FWARGDMZ, line, file, extent1, extent2,
rtn_nm);
}
/*
* Error handler for an of out of bounds substring.
*
* Input:
* file - File name in which error occurred.
* line - Line number in file.
* variable - Name of array which had an out of bounds substring.
* size - Substring size.
* start - Out of bounds substring start.
* length - Out of bounds substring length.
* count - Static count/flag to indicate if this message was
* already given for this statement.
*/
void
_SBOUNDS_ERROR(
char *file,
int *line,
char *variable,
int *size,
int *subst,
int *subln,
int *count )
{
int *retcnt; /* ptr to static arg count word */
int intcnt = 0; /* local count if no count passed */
int endst;
#ifdef _UNICOS
/* Use local variable if count argument not passed. */
if (_numargs() < 7)
retcnt = &intcnt;
else
#endif
retcnt = count;
/* if substring length is zero or negative, not incorrect */
if ( *subln > 0) {
if ((*retcnt)++ == 0) {
/* calculate substring end.
* subln is calculated by (ln = s2 - s1 + 1)
* endst is calculated by (s2 = ln + s1 - 1)
*/
endst = *subln + *subst - 1;
#ifdef KEY /* Bug 7969 */
if (want_abort()) {
(void) _lerror(_LELVL_MSG, FWARGSTR, *subst, endst, variable,
*line, file, *size);
do_abort();
}
#endif /* KEY Bug 7969 */
(void) _fwarn (FWARGSTR, *subst, endst, variable,
*line, file, *size);
}
}
return;
}
void
_CONFORM_ERROR(
char *file, /* Fortran routine containing error */
int *line, /* Line number in Fortran routine */
int *dim, /* Dimension number with size mismatch */
int *count) /* count/flag to give message once per
* statement. */
{
int intcnt = 0; /* local count if no count passed */
int *retcnt; /* ptr to count word */
#ifdef _UNICOS
/* Use local variable if count argument not passed. */
if (_numargs() < 4)
retcnt = &intcnt;
else
#endif
retcnt = count;
if (*retcnt == 0) {
*retcnt = 1;
(void) _fwarn(FWARGDIM, *dim, *line, file);
}
return;
}
void
_VRBOUNDS_ERROR(
char *file, /* Fortran routine with error */
int *line, /* Line number in Fortran routine */
char *variable, /* Arrayname with out-of-bounds subscript */
int *dim, /* Dimension number of the array */
int *lowerbnd, /* Lower bound of dimension dim */
int *upperbnd, /* Upper bound of dimension dim */
int start[128], /* Out-of-bounds starting subscript */
int end[128], /* Out-of-bounds ending subscript */
int incr[128], /* Increment between subscript */
long vm[2], /* Bit mask of the subscripts in error */
int *vl, /* Number of subscripts passed */
int *count) /* Count/flag for number of messages */
{
int i, len;
long mask;
int first_error_start;
int first_error_end;
int first_error_incr;
int all_same = 1;
int first_error = 1;
int *retcnt; /* ptr to static arg count word */
int intcnt = 0; /* local count if no count passed */
#ifdef _UNICOS
/* Use local variable if count argument not passed. */
if (_numargs() < 12)
retcnt = &intcnt;
else
#endif
retcnt = count;
if ((*retcnt)++ != 0)
return;
len = *vl;
for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) {
if ( i == 64 ) {
mask = vm[1];
}
if ( mask < 0 ) {
if ( first_error ) {
first_error = 0;
first_error_start = start[i];
first_error_end = end[i];
first_error_incr = incr[i];
}
else if ( first_error_start != start[i] ||
first_error_end != end[i] ||
first_error_incr != incr[i] ) {
all_same = 0;
break;
}
}
}
if ( all_same ) {
(void) _fwarn(FWARGSBR, first_error_start,
first_error_end, first_error_incr, *dim,
variable, *line, file, *lowerbnd,
*upperbnd);
return;
}
for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) {
if ( i == 64 ) {
mask = vm[1];
}
if ( mask < 0 ) {
(void) _fwarn(FWARGSBR, start[i], end[i], incr[i],
*dim, variable, *line, file,
*lowerbnd, *upperbnd);
}
}
}
void
_VBOUNDS_ERROR(
char *file, /* Fortran routine with error */
int *line, /* Line number in Fortran routine */
char *variable, /* Arrayname with out-of-bounds subscript */
int *dim, /* Dimension number of the array */
int *lowerbnd, /* Lower bound of dimension dim */
int *upperbnd, /* Upper bound of dimension dim */
int sub[128], /* Array of subscripts */
long vm[2], /* Bit mask of the subscripts in error */
int *vl, /* Number of subscripts passed */
int *count) /* Count/flag for number of messages */
{
int i, len;
long mask;
int stride;
int first_error_sub;
int last_error_sub;
int constant_stride = 1;
int error_count = 0;
int *retcnt; /* ptr to static arg count word */
int intcnt = 0; /* local count if no count passed */
#ifdef _UNICOS
/* Use local variable if count argument not passed. */
if (_numargs() < 10)
retcnt = &intcnt;
else
#endif
retcnt = count;
if ((*retcnt)++ != 0)
return;
len = *vl;
for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) {
if ( i == 64 ) {
mask = vm[1];
}
if ( mask < 0 ) {
error_count++;
if ( error_count == 1 ) {
first_error_sub = sub[i];
}
else if ( error_count == 2 ) {
stride = sub[i] - last_error_sub;
}
else {
if ( stride != sub[i] - last_error_sub ) {
constant_stride = 0;
break;
}
}
last_error_sub = sub[i];
}
}
if ( error_count == 1 ) {
(void) _fwarn(FWARGSBV, first_error_sub, *dim, variable,
*line, file, *lowerbnd, *upperbnd);
return;
}
else if ( constant_stride ) {
if ( stride == 0 ) {
(void) _fwarn(FWARGSBV, first_error_sub, *dim,
variable, *line, file, *lowerbnd,
*upperbnd);
}
else {
(void) _fwarn(FWARGSBR, first_error_sub,
last_error_sub, stride, *dim,
variable, *line, file, *lowerbnd,
*upperbnd);
}
return;
}
for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) {
if ( i == 64 ) {
mask = vm[1];
}
if ( mask < 0 ) {
(void) _fwarn(FWARGSBV, sub[i], *dim, variable,
*line, file, *lowerbnd, *upperbnd);
}
}
}
