/* 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_ */
/* DECK XERPRN */
/* Subroutine */ int xerprn_(char *prefix, integer *npref, char *messg,
integer *nwrap, ftnlen prefix_len, ftnlen messg_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
static integer i__, n, iu[5];
static char cbuff[148];
static integer lpref, nextc, lwrap, nunit;
extern integer i1mach_(integer *);
static integer lpiece, idelta, lenmsg;
extern /* Subroutine */ int xgetua_(integer *, integer *);
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, "(A)", 0 };
static cilist io___13 = { 0, 0, 0, "(A)", 0 };
/* ***BEGIN PROLOGUE XERPRN */
/* ***SUBSIDIARY */
/* ***PURPOSE Print error messages processed by XERMSG. */
/* ***LIBRARY SLATEC (XERROR) */
/* ***CATEGORY R3C */
/* ***TYPE ALL (XERPRN-A) */
/* ***KEYWORDS ERROR MESSAGES, PRINTING, XERROR */
/* ***AUTHOR Fong, Kirby, (NMFECC at LLNL) */
/* ***DESCRIPTION */
/* This routine sends one or more lines to each of the (up to five) */
/* logical units to which error messages are to be sent. This routine */
/* is called several times by XERMSG, sometimes with a single line to */
/* print and sometimes with a (potentially very long) message that may */
/* wrap around into multiple lines. */
/* PREFIX Input argument of type CHARACTER. This argument contains */
/* characters to be put at the beginning of each line before */
/* the body of the message. No more than 16 characters of */
/* PREFIX will be used. */
/* NPREF Input argument of type INTEGER. This argument is the number */
/* of characters to use from PREFIX. If it is negative, the */
/* intrinsic function LEN is used to determine its length. If */
/* it is zero, PREFIX is not used. If it exceeds 16 or if */
/* LEN(PREFIX) exceeds 16, only the first 16 characters will be */
/* used. If NPREF is positive and the length of PREFIX is less */
/* than NPREF, a copy of PREFIX extended with blanks to length */
/* NPREF will be used. */
/* MESSG Input argument of type CHARACTER. This is the text of a */
/* message to be printed. If it is a long message, it will be */
/* broken into pieces for printing on multiple lines. Each line */
/* will start with the appropriate prefix and be followed by a */
/* piece of the message. NWRAP is the number of characters per */
/* piece; that is, after each NWRAP characters, we break and */
/* start a new line. In addition the characters '$$' embedded */
/* in MESSG are a sentinel for a new line. The counting of */
/* characters up to NWRAP starts over for each new line. The */
/* value of NWRAP typically used by XERMSG is 72 since many */
/* older error messages in the SLATEC Library are laid out to */
/* rely on wrap-around every 72 characters. */
/* NWRAP Input argument of type INTEGER. This gives the maximum size */
/* piece into which to break MESSG for printing on multiple */
/* lines. An embedded '$$' ends a line, and the count restarts */
/* at the following character. If a line break does not occur */
/* on a blank (it would split a word) that word is moved to the */
/* next line. Values of NWRAP less than 16 will be treated as */
/* 16. Values of NWRAP greater than 132 will be treated as 132. */
/* The actual line length will be NPREF + NWRAP after NPREF has */
/* been adjusted to fall between 0 and 16 and NWRAP has been */
/* adjusted to fall between 16 and 132. */
/* ***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) */
/* 880621 DATE WRITTEN */
/* 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF */
/* JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK */
/* THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE */
/* SLASH CHARACTER IN FORMAT STATEMENTS. */
/* 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO */
/* STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK */
/* LINES TO BE PRINTED. */
/* 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF */
/* CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. */
/* 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. */
/* 891214 Prologue converted to Version 4.0 format. (WRB) */
/* 900510 Added code to break messages between words. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE XERPRN */
/* ***FIRST EXECUTABLE STATEMENT XERPRN */
xgetua_(iu, &nunit);
/* A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD */
/* ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD */
/* ERROR MESSAGE UNIT. */
n = i1mach_(&c__4);
i__1 = nunit;
for (i__ = 1; i__ <= i__1; ++i__) {
if (iu[i__ - 1] == 0) {
iu[i__ - 1] = n;
}
/* L10: */
}
/* LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE */
/* BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING */
/* THE REST OF THIS ROUTINE. */
if (*npref < 0) {
lpref = i_len(prefix, prefix_len);
} else {
lpref = *npref;
}
lpref = min(16,lpref);
if (lpref != 0) {
s_copy(cbuff, prefix, lpref, prefix_len);
}
/* LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE */
/* TIME FROM MESSG TO PRINT ON ONE LINE. */
/* Computing MAX */
i__1 = 16, i__2 = min(132,*nwrap);
lwrap = max(i__1,i__2);
/* SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. */
lenmsg = i_len(messg, messg_len);
n = lenmsg;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*(unsigned char *)&messg[lenmsg - 1] != ' ') {
goto L30;
}
--lenmsg;
/* L20: */
}
L30:
/* IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. */
if (lenmsg == 0) {
i__1 = lpref;
s_copy(cbuff + i__1, " ", lpref + 1 - i__1, (ftnlen)1);
i__1 = nunit;
for (i__ = 1; i__ <= i__1; ++i__) {
io___9.ciunit = iu[i__ - 1];
s_wsfe(&io___9);
do_fio(&c__1, cbuff, lpref + 1);
e_wsfe();
/* L40: */
}
return 0;
}
/* SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING */
/* STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. */
/* WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. */
/* WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. */
/* WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE */
/* INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE */
/* OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH */
/* OF THE SECOND ARGUMENT. */
/* THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE */
/* FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER */
/* OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT */
/* POSITION NEXTC. */
/* LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE */
/* REMAINDER OF THE CHARACTER STRING. LPIECE */
/* SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, */
/* WHICHEVER IS LESS. */
/* LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: */
/* NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE */
/* PRINT NOTHING TO AVOID PRODUCING UNNECESSARY */
/* BLANK LINES. THIS TAKES CARE OF THE SITUATION */
/* WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF */
/* EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE */
/* SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC */
/* SHOULD BE INCREMENTED BY 2. */
/* LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. */
/* ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 */
/* RESET LPIECE = LPIECE-1. NOTE THAT THIS */
/* PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. */
/* LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY */
/* AT THE END OF A LINE. */
nextc = 1;
L50:
lpiece = i_indx(messg + (nextc - 1), "$$", lenmsg - (nextc - 1), (ftnlen)
2);
if (lpiece == 0) {
/* THERE WAS NO NEW LINE SENTINEL FOUND. */
idelta = 0;
/* Computing MIN */
i__1 = lwrap, i__2 = lenmsg + 1 - nextc;
lpiece = min(i__1,i__2);
if (lpiece < lenmsg + 1 - nextc) {
for (i__ = lpiece + 1; i__ >= 2; --i__) {
i__1 = nextc + i__ - 2;
if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, (ftnlen)
1) == 0) {
lpiece = i__ - 1;
idelta = 1;
goto L54;
}
/* L52: */
}
}
L54:
i__1 = lpref;
s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1,
nextc + lpiece - 1 - (nextc - 1));
nextc = nextc + lpiece + idelta;
} else if (lpiece == 1) {
/* WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). */
/* DON'T PRINT A BLANK LINE. */
nextc += 2;
goto L50;
} else if (lpiece > lwrap + 1) {
/* LPIECE SHOULD BE SET DOWN TO LWRAP. */
idelta = 0;
lpiece = lwrap;
for (i__ = lpiece + 1; i__ >= 2; --i__) {
i__1 = nextc + i__ - 2;
if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, (ftnlen)1) ==
0) {
lpiece = i__ - 1;
idelta = 1;
goto L58;
}
/* L56: */
}
L58:
i__1 = lpref;
s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1,
nextc + lpiece - 1 - (nextc - 1));
nextc = nextc + lpiece + idelta;
} else {
/* IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. */
/* WE SHOULD DECREMENT LPIECE BY ONE. */
--lpiece;
i__1 = lpref;
s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1,
nextc + lpiece - 1 - (nextc - 1));
nextc = nextc + lpiece + 2;
}
/* PRINT */
i__1 = nunit;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = iu[i__ - 1];
s_wsfe(&io___13);
do_fio(&c__1, cbuff, lpref + lpiece);
e_wsfe();
/* L60: */
}
if (nextc <= lenmsg) {
goto L50;
}
return 0;
} /* xerprn_ */
