227 lines
6.7 KiB
C
227 lines
6.7 KiB
C
/* xersve.f -- translated by f2c (version 20030320).
|
|
You must link the resulting object file with the libraries:
|
|
-lf2c -lm (in that order)
|
|
*/
|
|
|
|
#include "f2c.h"
|
|
|
|
/* Table of constant values */
|
|
|
|
static integer c__4 = 4;
|
|
static integer c__1 = 1;
|
|
|
|
/* DECK XERSVE */
|
|
/* Subroutine */ int xersve_(char *librar, char *subrou, char *messg, integer
|
|
*kflag, integer *nerr, integer *level, integer *icount, ftnlen
|
|
librar_len, ftnlen subrou_len, ftnlen messg_len)
|
|
{
|
|
/* Initialized data */
|
|
|
|
static integer kountx = 0;
|
|
static integer nmsg = 0;
|
|
|
|
/* Format strings */
|
|
static char fmt_9000[] = "(\0020 ERROR MESSAGE SUMMARY\002/\002"
|
|
" LIBRARY SUBROUTINE MESSAGE START NERR\002,\002 "
|
|
" LEVEL COUNT\002)";
|
|
static char fmt_9010[] = "(1x,a,3x,a,3x,a,3i10)";
|
|
static char fmt_9020[] = "(\0020OTHER ERRORS NOT INDIVIDUALLY TABULATED "
|
|
"= \002,i10)";
|
|
static char fmt_9030[] = "(1x)";
|
|
|
|
/* System generated locals */
|
|
integer i__1, i__2;
|
|
|
|
/* Builtin functions */
|
|
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
|
|
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
|
|
integer s_cmp(char *, char *, ftnlen, ftnlen);
|
|
|
|
/* Local variables */
|
|
integer i__;
|
|
char lib[8], mes[20], sub[8];
|
|
integer lun[5], iunit, kunit, nunit;
|
|
static integer kount[10];
|
|
extern integer i1mach_(integer *);
|
|
static char libtab[8*10], mestab[20*10];
|
|
static integer nertab[10], levtab[10];
|
|
static char subtab[8*10];
|
|
extern /* Subroutine */ int xgetua_(integer *, integer *);
|
|
|
|
/* Fortran I/O blocks */
|
|
static cilist io___7 = { 0, 0, 0, fmt_9000, 0 };
|
|
static cilist io___9 = { 0, 0, 0, fmt_9010, 0 };
|
|
static cilist io___16 = { 0, 0, 0, fmt_9020, 0 };
|
|
static cilist io___17 = { 0, 0, 0, fmt_9030, 0 };
|
|
|
|
|
|
/* ***BEGIN PROLOGUE XERSVE */
|
|
/* ***SUBSIDIARY */
|
|
/* ***PURPOSE Record that an error has occurred. */
|
|
/* ***LIBRARY SLATEC (XERROR) */
|
|
/* ***CATEGORY R3 */
|
|
/* ***TYPE ALL (XERSVE-A) */
|
|
/* ***KEYWORDS ERROR, XERROR */
|
|
/* ***AUTHOR Jones, R. E., (SNLA) */
|
|
/* ***DESCRIPTION */
|
|
|
|
/* *Usage: */
|
|
|
|
/* INTEGER KFLAG, NERR, LEVEL, ICOUNT */
|
|
/* CHARACTER * (len) LIBRAR, SUBROU, MESSG */
|
|
|
|
/* CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) */
|
|
|
|
/* *Arguments: */
|
|
|
|
/* LIBRAR :IN is the library that the message is from. */
|
|
/* SUBROU :IN is the subroutine that the message is from. */
|
|
/* MESSG :IN is the message to be saved. */
|
|
/* KFLAG :IN indicates the action to be performed. */
|
|
/* when KFLAG > 0, the message in MESSG is saved. */
|
|
/* when KFLAG=0 the tables will be dumped and */
|
|
/* cleared. */
|
|
/* when KFLAG < 0, the tables will be dumped and */
|
|
/* not cleared. */
|
|
/* NERR :IN is the error number. */
|
|
/* LEVEL :IN is the error severity. */
|
|
/* ICOUNT :OUT the number of times this message has been seen, */
|
|
/* or zero if the table has overflowed and does not */
|
|
/* contain this message specifically. When KFLAG=0, */
|
|
/* ICOUNT will not be altered. */
|
|
|
|
/* *Description: */
|
|
|
|
/* Record that this error occurred and possibly dump and clear the */
|
|
/* tables. */
|
|
|
|
/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */
|
|
/* Error-handling Package, SAND82-0800, Sandia */
|
|
/* Laboratories, 1982. */
|
|
/* ***ROUTINES CALLED I1MACH, XGETUA */
|
|
/* ***REVISION HISTORY (YYMMDD) */
|
|
/* 800319 DATE WRITTEN */
|
|
/* 861211 REVISION DATE from Version 3.2 */
|
|
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
|
|
/* 900413 Routine modified to remove reference to KFLAG. (WRB) */
|
|
/* 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling */
|
|
/* sequence, use IF-THEN-ELSE, make number of saved entries */
|
|
/* easily changeable, changed routine name from XERSAV to */
|
|
/* XERSVE. (RWC) */
|
|
/* 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) */
|
|
/* 920501 Reformatted the REFERENCES section. (WRB) */
|
|
/* ***END PROLOGUE XERSVE */
|
|
/* ***FIRST EXECUTABLE STATEMENT XERSVE */
|
|
|
|
if (*kflag <= 0) {
|
|
|
|
/* Dump the table. */
|
|
|
|
if (nmsg == 0) {
|
|
return 0;
|
|
}
|
|
|
|
/* Print to each unit. */
|
|
|
|
xgetua_(lun, &nunit);
|
|
i__1 = nunit;
|
|
for (kunit = 1; kunit <= i__1; ++kunit) {
|
|
iunit = lun[kunit - 1];
|
|
if (iunit == 0) {
|
|
iunit = i1mach_(&c__4);
|
|
}
|
|
|
|
/* Print the table header. */
|
|
|
|
io___7.ciunit = iunit;
|
|
s_wsfe(&io___7);
|
|
e_wsfe();
|
|
|
|
/* Print body of table. */
|
|
|
|
i__2 = nmsg;
|
|
for (i__ = 1; i__ <= i__2; ++i__) {
|
|
io___9.ciunit = iunit;
|
|
s_wsfe(&io___9);
|
|
do_fio(&c__1, libtab + ((i__ - 1) << 3), (ftnlen)8);
|
|
do_fio(&c__1, subtab + ((i__ - 1) << 3), (ftnlen)8);
|
|
do_fio(&c__1, mestab + (i__ - 1) * 20, (ftnlen)20);
|
|
do_fio(&c__1, (char *)&nertab[i__ - 1], (ftnlen)sizeof(
|
|
integer));
|
|
do_fio(&c__1, (char *)&levtab[i__ - 1], (ftnlen)sizeof(
|
|
integer));
|
|
do_fio(&c__1, (char *)&kount[i__ - 1], (ftnlen)sizeof(integer)
|
|
);
|
|
e_wsfe();
|
|
/* L10: */
|
|
}
|
|
|
|
/* Print number of other errors. */
|
|
|
|
if (kountx != 0) {
|
|
io___16.ciunit = iunit;
|
|
s_wsfe(&io___16);
|
|
do_fio(&c__1, (char *)&kountx, (ftnlen)sizeof(integer));
|
|
e_wsfe();
|
|
}
|
|
io___17.ciunit = iunit;
|
|
s_wsfe(&io___17);
|
|
e_wsfe();
|
|
/* L20: */
|
|
}
|
|
|
|
/* Clear the error tables. */
|
|
|
|
if (*kflag == 0) {
|
|
nmsg = 0;
|
|
kountx = 0;
|
|
}
|
|
} else {
|
|
|
|
/* PROCESS A MESSAGE... */
|
|
/* SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, */
|
|
/* OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. */
|
|
|
|
s_copy(lib, librar, (ftnlen)8, librar_len);
|
|
s_copy(sub, subrou, (ftnlen)8, subrou_len);
|
|
s_copy(mes, messg, (ftnlen)20, messg_len);
|
|
i__1 = nmsg;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
if (s_cmp(lib, libtab + ((i__ - 1) << 3), (ftnlen)8, (ftnlen)8) ==
|
|
0 && s_cmp(sub, subtab + ((i__ - 1) << 3), (ftnlen)8, (
|
|
ftnlen)8) == 0 && s_cmp(mes, mestab + (i__ - 1) * 20, (
|
|
ftnlen)20, (ftnlen)20) == 0 && *nerr == nertab[i__ - 1] &&
|
|
*level == levtab[i__ - 1]) {
|
|
++kount[i__ - 1];
|
|
*icount = kount[i__ - 1];
|
|
return 0;
|
|
}
|
|
/* L30: */
|
|
}
|
|
|
|
if (nmsg < 10) {
|
|
|
|
/* Empty slot found for new message. */
|
|
|
|
++nmsg;
|
|
s_copy(libtab + ((i__ - 1) << 3), lib, (ftnlen)8, (ftnlen)8);
|
|
s_copy(subtab + ((i__ - 1) << 3), sub, (ftnlen)8, (ftnlen)8);
|
|
s_copy(mestab + (i__ - 1) * 20, mes, (ftnlen)20, (ftnlen)20);
|
|
nertab[i__ - 1] = *nerr;
|
|
levtab[i__ - 1] = *level;
|
|
kount[i__ - 1] = 1;
|
|
*icount = 1;
|
|
} else {
|
|
|
|
/* Table is full. */
|
|
|
|
++kountx;
|
|
*icount = 0;
|
|
}
|
|
}
|
|
return 0;
|
|
|
|
/* Formats. */
|
|
|
|
} /* xersve_ */
|
|
|