void mpi_scatterv_ ( void *unknown, ...)
{
void *sendbuf;
int *sendcnts;
int *displs;
MPI_Datatype *sendtype;
void *recvbuf;
int *recvcnt;
MPI_Datatype *recvtype;
int *root;
MPI_Comm *comm;
int *__ierr;
int buflen;
va_list ap;
va_start(ap, unknown);
sendbuf = unknown;
if (_numargs() == NUMPARAMS+1) {
/* Note that we can't set __ierr because we don't know where it is! */
(void) MPIR_ERROR( MPIR_COMM_WORLD, MPI_ERR_ONE_CHAR, "MPI_SCATTERV" );
return;
}
if (_numargs() == NUMPARAMS+2) {
buflen = va_arg(ap, int) /8; /* This is in bits. */
}
int
sigtrbk(FILE *stream, int depth)
{
long stat;
FILE *f;
if (_numargs() > 0) /* If stream specified */
f = stream;
else
f = stderr;
MEM_LOCK(&traceback_lock);
if (_numargs() > 1) /* If depth specified */
_trbkdpth = depth;
else {
char *env;
if (env = getenv("TRBKDPTH"))
_trbkdpth = atoi(env);
}
/* Flush all files */
if (LOADED(fflush))
(void) fflush(NULL);
stat = _trbk(fileno(f), _sigarea());
MEM_UNLOCK(&traceback_lock);
return((int)stat);
}
_f_int
CRI2CRAY(
_f_int *type,
_f_int *num,
void *forn,
_f_int *bitoff,
void *native,
_f_int *stride,
_fcd nativech
)
{
_f_int extlen;
_f_int ierr;
_f_int intlen;
_f_int strd;
_f_int type77;
_f_int type90;
type77 = *type;
type90 = _f77_to_f90_type_cnvt[type77];
intlen = _f77_type_len[type77] << 3; /* in bits */
extlen = __fndc_f77sz[NCV_CRAY]->typlen[type77]; /* in bits */
strd = (_numargs() > 5) ? *stride : 1;
if (_numargs() > 6)
ierr = CRI2CRY(&type90, num, forn, bitoff, native, &strd,
&intlen, &extlen, nativech);
else
ierr = CRI2CRY(&type90, num, forn, bitoff, native, &strd,
&intlen, &extlen);
return (ierr);
}
int
$RFI(
_fcd funit, /* Address of unit number or FCD */
_fcd format, /* Address of format (FCD or hollerith) */
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. */
fmt_type **pform, /* Address of address of parsed format */
long *inumelt, /* Address of int. array element count */
long *inumcfe /* Address of number of format elements */
)
#endif
{
register int endf; /* END processing flag */
register int errf; /* ERR processing flag */
register int errn; /* Error number */
register int iost; /* I/O statement type */
register int iotp; /* I/O type */
register recn_t recn; /* Record number */
register unum_t unum; /* Unit number */
fmt_type **prsfmt; /* Parsed format info. */
unit *cup; /* Unit table pointer */
FIOSPTR css; /* I/O statement state */
#ifdef _CRAYMPP
va_list args;
_fcd format; /* Address of format (FCD or hollerith) */
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. */
fmt_type **pform; /* Address of address of parsed format */
long *inumelt; /* Address of int. array element count */
long *inumcfe; /* Address of number of format elements */
#endif
GET_FIOS_PTR(css);
/* Check if recursive triple-call I/O */
if (css->f_iostmt != 0)
_ferr(css, FEIOACTV);
#ifdef _CRAYMPP
va_start(args, funit);
format = 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 *);
if (_numargs() > ARGS_6) {
pform = va_arg(args, fmt_type **);
if (_numargs() > ARGS_7) {
inumelt = va_arg(args, long *);
if (_numargs() > ARGS_8) {
inumcfe = va_arg(args, long *);
}
long
TRBK(long *depth)
{
long stat;
MEM_LOCK(&traceback_lock);
if (_numargs() > 0) /* If depth specified */
_trbkdpth = *depth;
else {
char *env;
if (env = getenv("TRBKDPTH"))
_trbkdpth = atoi(env);
}
/* Flush all files */
if (LOADED(fflush))
(void) fflush(NULL);
stat = _trbk(fileno(stderr));
MEM_UNLOCK(&traceback_lock);
return(stat);
}
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;
}
/*
* _fc_acopy
*
* Returns:
* Pointer to a C string, if successful. NULL otherwise.
*
* Copies the Fortran string described by Fortran character
* descriptor "f" to an allocated, NULL-terminated C string. The
* string is allocated using malloc().
*
* If the string described by "f" contains a NULL character,
* that marks the end of the Fortran string. Trailing blanks
* are stripped before the string is copied.
*/
char *
_fc_acopy(_fcd f)
{
long len;
char *start, *end;
char *sptr;
#if defined(_UNICOS)
#if defined(_ADDR64)
if (_numargs() * sizeof(long) != sizeof(_fcd))
return(NULL);
#else
if (!_isfcd(f))
return(NULL);
#endif /* _ADDR64 */
#endif /* _UNICOS */
len = _fcdlen(f);
start = _fcdtocp(f);
/* see if string contains a NULL */
if ((end = memchr(start, '\0', len)) != NULL)
len = end - start;
/* remove trailing blanks */
while ((len > 0) && (start[len-1] == ' '))
len--;
/* allocate space */
if ((sptr = malloc(len+1)) == NULL)
return(NULL);
(void) strncpy(sptr, start, len);
*(sptr + len) = '\0';
return(sptr);
}
/*
* _fc_copy
*
* Arguments
* f The Fortran character descriptor
* sptr Pointer to the C character array.
* slen Length of the C character array.
*
* Returns:
* Pointer to sptr if successful. NULL otherwise.
*
* Copies the Fortran string described by Fortran character
* descriptor "f" to sptr and NULL-terminates it.
*
* If the string described by "f" contains a NULL character,
* that marks the end of the Fortran string. Trailing blanks
* are stripped before the string is copied.
*/
char *
_fc_copy(_fcd f, char *sptr, int slen)
{
int len;
char *start, *end;
#if defined(_UNICOS)
#if defined(_ADDR64)
if (_numargs() * sizeof(long) != (sizeof(_fcd) + sizeof(int) +
sizeof(char*)))
return(NULL);
#else
if (!_isfcd(f))
return(NULL);
#endif /* _ADDR64 */
#endif /* _UNICOS */
len = _fcdlen(f);
start = _fcdtocp(f);
/* see if string contains a NULL */
if ((end = memchr(start, '\0', len)) != NULL)
len = end - start;
/* remove trailing blanks */
while ((len > 0) && (start[len-1] == ' '))
len--;
if (len >= slen)
return(NULL); /* return NULL if too small */
(void) strncpy(sptr, start, len);
*(sptr + len) = '\0';
return(sptr);
}
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;
}
long
VXMOVE00(
long *source, /* Address of source data */
long *isb, /* Starting byte of source data */
long *num, /* Number of bytes to move */
long *dest, /* Address of destination data */
long *idb /* First byte of destination */
)
{
char *from, *to;
int count;
long status;
status = -1;
if (_numargs() >= 5 && *num >= 0 && *isb > 0 && *idb > 0) {
from = (char *)source + (*isb - 1);
to = (char *) dest + (*idb - 1);
count = *num;
(void) memcpy(to, from, count);
status = 0;
}
return(status);
}
void
AQWAIT(
_f_int *aqp,
_f_int *status,
_f_int *reply)
{
AQFIL *f;
struct fflistreq *nxtq;
_f_int dummy, *lreply;
/*
* UNICOS 8.0 and previous quietly permitted fewer than 2 arguments,
* even though our documentatiokn for AQWAIT has required >= 2 args
* for some time. Do the service of printing an error message if a
* dusty deck code happens to use < 2 arguments.
*/
if (_numargs() < 2)
_lerror(_LELVL_ABORT, FEARGCNT, "AQWAIT", _numargs(), "2 or 3");
/*
* reply is an optional argument.
*/
lreply = reply;
if (_numargs() < 3) lreply = &dummy;
f = (AQFIL *) *aqp;
if (f == NULL || f->aq_chk != AQ_CHK) {
*status = -FEAQBADH; /* file handle is not valid */
return;
}
if (f->aq_busy == f->aq_nxtq) {
*status = IDLE;
return;
}
*status = OK;
AQ_LOCK(aq_lkbusy);
nxtq = f->aq_nxtq;
_aqwait(f, status, lreply, nxtq);
AQ_UNLOCK(aq_lkbusy);
if (*status < 0 && _numargs() <= 1)
_lerror(_LELVL_ABORT, -(*status));
return;
}
_f_int
IEG2CRAY@(
_f_int *type,
_f_int *num,
void *forn,
_f_int *bitoff,
void *native,
_f_int *stride,
_fcd nativech
)
{
_f_int extlen;
_f_int ierr;
_f_int intlen;
_f_int strd;
_f_int type77;
_f_int type90;
type77 = *type;
if (type77 == DT_SPECREAL) {
type90 = DVTYPE_REAL;
intlen = 64;
}
else {
type90 = _f77_to_f90_type_cnvt[type77];
intlen = _f77_type_len[type77] << 3; /* in bits */
}
extlen = __fndc_f77sz[NCV_IEG]->typlen[type77]; /* in bits */
if (_numargs() > 5)
strd = *stride;
else
strd = 1;
if (_numargs() > 6)
ierr = IEG2CRI(&type90, num, forn, bitoff, native, &strd,
&intlen, &extlen, nativech);
else
ierr = IEG2CRI(&type90, num, forn, bitoff, native, &strd,
&intlen, &extlen);
return (ierr);
}
_f_int
ISHELL(_fcd cmdarg)
{
char *cptr;
int ret;
int fcdflag;
/* Check number of arguments */
if (_numargs() < 1)
return( (_f_int) -1);
/* IS cmdarg an _fcd ? */
fcdflag = 0;
#ifdef _ADDR64
if (_numargs() * sizeof(long) == sizeof(_fcd))
#else
if (_isfcd(cmdarg))
#endif
fcdflag = 1;
/* Convert argument to C character string */
if (fcdflag) { /* If Fortran character */
cptr = _fc_acopy(cmdarg);
if (cptr == NULL)
return( (_f_int) -1);
}
else
cptr = _fcdtocp(cmdarg);
/* Run command using system() */
ret = system(cptr);
if (ret == -1)
ret = -errno;
if (fcdflag)
free(cptr);
return( (_f_int) ret);
}
timef_(void)
#endif
{
static int64 initial_rt = -1; /* Clock value from initial call */
int64 rt, rtdif;
double retval;
#ifdef _UNICOS
if (_sec_per_clock == 0.0)
_sec_per_clock = 1.0 / (double) sysconf(_SC_CLK_TCK);
rt = _rtc();
#else
{
struct timeval buf;
struct timezone buf2;
(void) gettimeofday (&buf, &buf2);
rt = (long long)buf.tv_sec * 1000000LL + buf.tv_usec;
}
#endif
if (initial_rt < 0) {
initial_rt = rt;
rtdif = 0;
/*
* force rtdif to 0 to prevent anomalies due to possible
* race conditions between 2 or more tasks calling TIMEF
* concurrently on the initial call.
*/
}
else
rtdif = rt - initial_rt;
/*
* On pre-7.0 UNICOS CX/CEA systems and on all CRAY-2 systems the
* real-time hardware clock is set to 0 on reboot. If a restarted
* process had called TIMEF before the system was brought down
* and then after reboot, a negative difference in the real-time
* clock value would be observed. To minimize the impact of
* wrong timings being returned, we return 0 when this situation is
* detected.
*/
if (rtdif < 0) {
initial_rt = rt;
rtdif = 0;
}
retval = (double) rtdif * MSECPERCLK;
#ifdef _UNICOS
if (_numargs() > 0)
*time = (_f_real) retval;
#endif
return( (_f_real) retval);
}
void
RNLCOMM(_fcd chr, _f_int *mode)
{
int thechar;
if (_numargs() != (sizeof(_fcd) + sizeof(long *))/ sizeof(long))
_lerror(_LELVL_ABORT,FEARGLST, "RNLCOMM");
thechar = _getfchar(chr);
TOGGLE_CHAR(thechar, MRNLCOMM, *mode);
return;
}
int
$DFI(
long *len, /* Address of length (in characters) */
_fcd format, /* Address of format (FCD or hollerith) */
_fcd fwa, /* Address of output character string */
fmt_type **_arg4, /* Unused (old pform arugment) */
long *_arg5, /* Unused */
long *_arg6, /* Unused */
fmt_type **pform, /* Address of address of parsed format */
long *inumelt, /* Address of int. array element count */
long *inumcfe /* Address of number of format elements */
)
#endif
{
long mone = -1L;
_fcd fch;
int nargs;
#ifdef _CRAYMPP
va_list args;
_fcd format; /* Address of format (FCD or hollerith) */
_fcd fwa; /* Address of output character string */
fmt_type **_arg4; /* Unused (old pform arugment) */
long *_arg5; /* Unused */
long *_arg6; /* Unused */
fmt_type **pform; /* Address of address of parsed format */
long *inumelt; /* Address of int. array element count */
long *inumcfe; /* Address of number of format elements */
va_start(args, len);
format = va_arg(args, _fcd);
fwa = va_arg(args, _fcd);
#endif
if (*len <= 0) /* If length is zero or negative */
_ferr(NULL, FEDECDRL); /* Invalid DECODE record length */
/* Insert length in character descriptor */
fch = _cptofcd(_fcdtocp(fwa), *len);
nargs = _numargs();
#ifdef _CRAYMPP
if (nargs >= ARGS_7) {
_arg4 = va_arg(args, fmt_type **);
_arg5 = va_arg(args, long *);
_arg6 = va_arg(args, long *);
pform = va_arg(args, fmt_type **);
if (nargs >= ARGS_9) {
inumelt = va_arg(args, long *);
inumcfe = va_arg(args, long *);
}
void
RNLSEP(_fcd chr, _f_int *mode)
{
int thechar;
if (_numargs() != (sizeof(_fcd) + sizeof(long*))/sizeof(long))
_lerror(_LELVL_ABORT,FEARGLST, "RNLSEP");
thechar = _getfchar(chr);
if (thechar == ' ')
_BLNKSEP = *mode;
TOGGLE_CHAR(thechar, MRNLSEP, *mode);
return;
}
_f_real
SECONDR(_f_real *time)
{
double timeval;
if (_sec_per_clock == 0.0)
_sec_per_clock = (double)1.0 / (double)__hertz;
timeval = (double) _rtc() * _sec_per_clock;
if (_numargs() > 0)
*time = (_f_real) timeval;
return( (_f_real) timeval);
}
void mpi_ssend_( void *unknown, ...)
{
void *buf;
int*count,*dest,*tag;
MPI_Datatype *datatype;
MPI_Comm *comm;
int *__ierr;
int buflen;
va_list ap;
va_start(ap, unknown);
buf = unknown;
if (_numargs() == NUMPARAMS+1) {
buflen = va_arg(ap, int) / 8; /* The length is in bits. */
}
void mpi_unpack_ ( void *unknown, ...)
{
void *inbuf;
int *insize;
int *position;
void *outbuf;
int *outcount;
MPI_Datatype *datatype;
MPI_Comm *comm;
int *__ierr;
int buflen;
va_list ap;
va_start(ap, unknown);
inbuf = unknown;
if (_numargs() == NUMPARAMS+1) {
/* We can't get at the last variable, since there is a fatal
error in passing the wrong number of arguments. */
MPIR_ERROR( MPIR_COMM_WORLD, MPI_ERR_ONE_CHAR, "MPI_UNPACK" );
return;
}
if (_numargs() == NUMPARAMS+2) {
buflen = va_arg(ap, int) / 8; /* The length is in bits. */
}
_f_int
FPUTS(long *buf, ...)
{
long **fp;
va_list args;
#ifdef _ADDR64
long flen;
va_start(args, buf);
if (_numargs() * sizeof(long) == sizeof(_fcd) +
sizeof(long **)) {
/* This technique is not recommended. */
/* It is used only because our documentation says */
/* that we support both fcds and integers */
flen = va_arg(args, long); /* get length of fcd */
}
void
SETPOS(
_f_int *unump,
_f_int *len,
_f_int *pa,
_f_int *stat)
{
register int errn;
register int narg;
register unum_t unum;
unit *cup;
struct fiostate cfs;
unum = *unump;
STMT_BEGIN(unum, 0, T_SETPOS, NULL, &cfs, cup); /* lock the unit */
/*
* If not connected, do an implicit open. Abort if the open fails.
*/
if (cup == NULL)
cup = _imp_open(&cfs, SEQ, UNF, unum, 0, NULL);
if (cup->useq == 0) /* If direct access file */
_ferr(&cfs, FEBIONDA, "SETPOS");
/*
* Do the setpos.
*/
narg = _numargs();
if ( narg == OLD ) {
errn = _setpos(&cfs, cup, len, 1);
}
else {
if (*len <= 0)
errn = FEBIOSNT;
else
errn = _setpos(&cfs, cup, pa, *len);
}
if (narg >= STAT)
*stat = errn;
else if (errn != OK)
_ferr(&cfs, errn);
STMT_END(cup, T_SETPOS, NULL, &cfs); /* unlock the unit */
}
void
_PAUSE(_fcd s)
{
int len;
void _waitpause();
char *msg;
#ifdef _UNICOS
if (_numargs() == 0) {
msg = "";
len = 0;
}
else
#endif
{
msg = _fcdtocp(s);
len = _fcdlen(s);
if (len > MAX_PAS_LEN)
len = MAX_PAS_LEN;
}
(void) fprintf(errfile, " PAUSE %.*s\n", len, msg);
(void) fprintf(errfile, " To resume execution, type: ");
if (isatty(fileno(stdin))) {
(void) fprintf(errfile, "go\n");
(void) fprintf(errfile,
" Any other input will terminate the program\n");
if (getchar() != 'g' || getchar() != 'o' || getchar() != '\n') {
(void) fprintf(errfile, " STOP\n");
exit(0);
}
}
else {
(void) fprintf(errfile, "kill -%d %d\n", PAUSESIG, getpid());
signal(PAUSESIG, _waitpause);
pause(); /* The pause that refreshes */
}
(void) fprintf(errfile, " Execution resumed after PAUSE\n");
}
/*
* _clib_call - driver routine to call a utility routine or
* system call after translating one _fcd to
* a C character pointer.
*/
int
_clib_call(
int (*func)(),
_fcd arg1,
long arg2,
long arg3,
long arg4,
long arg5)
{
char *charptr;
int ret;
int num_syscall_args;
#ifndef _ADDR64
if (!_isfcd(arg1)) /* If not Fortran character */
charptr = *(char **)&arg1;
else
#endif
{
charptr = _f2ccpy(arg1);
if (charptr == NULL)
return(-1);
}
num_syscall_args = _numargs() - sizeof(_fcd)/sizeof(long);
switch( num_syscall_args ) {
case 1: ret = (*func)(charptr); break;
case 2: ret = (*func)(charptr,arg2); break;
case 3: ret = (*func)(charptr,arg2,arg3); break;
case 4: ret = (*func)(charptr,arg2,arg3,arg4); break;
case 5: ret = (*func)(charptr,arg2,arg3,arg4,arg5); break;
default: abort();
}
#ifndef _ADDR64
if (_isfcd(arg1))
#endif
free(charptr);
return(ret);
}
char *
_f2ccpy(_fcd f, ...)
{
va_list ap;
int slen;
char *sptr;
if (_numargs() * sizeof(long) == sizeof(_fcd))
return ( _fc_acopy(f) );
else {
/* get 2nd and 3rd arguments */
va_start(ap, f);
sptr = va_arg(ap, char *);
slen = va_arg(ap, int);
va_end(ap);
return ( _fc_copy(f, sptr, slen) );
}
}
void mpi_send_init_( void *unknown, ...)
{
void *buf;
int*count;
MPI_Datatype *datatype;
int*dest;
int*tag;
MPI_Comm *comm;
MPI_Request *request;
int *__ierr;
MPI_Request lrequest;
int buflen;
va_list ap;
va_start(ap, unknown);
buf = unknown;
if (_numargs() == NUMPARAMS+1) {
buflen = va_arg(ap, int) /8; /* This is in bits. */
}
/*
* 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
_lerror(int hndlcode, int errn, ...)
{
va_list args; /* Variable argument list */
#ifdef _CRAY
if (_numargs() < 1)
(void) abort();
#endif
if (hndlcode >= _LELVL_MSG && errn != 0) {
va_start(args, errn);
_lmessage(errn, NULL, args); /* Print error message */
va_end(args);
}
if (hndlcode >= _LELVL_ABORT) {
(void) abort(); /* abort causes traceback on CX/CEA */
}
if (hndlcode >= _LELVL_EXIT)
(void) exit(1);
}
int
_lwarn(int errn, ...)
{
va_list args; /* Variable argument list */
#ifdef _CRAY
if (_numargs() < 1)
return(-1);
#endif
if (((errn < BASE) || (errn > (BASE+999))) &&
((errn < FDC_ERRB) || (errn > (FDC_ERRB+999))))
return(-2);
va_start(args, errn);
_lmessage(errn, "WARNING", args);
va_end(args);
return(0);
}
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;
}