slatec-bessel-cpp/f2c/xersve.cpp

/* xersve.f -- translated by f2c (version 20100827).
   This file no longer depends on f2c.
*/

#include "slatec-internal.hpp"

/* Table of constant values */

static integer const c__4 = 4;
static integer const c__1 = 1;

int xersve_(char const *librar, char const *subrou, char const *messg, integer
            const *kflag, integer const *nerr, integer const *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;

    /* Local variables */
    integer i__;
    char lib[8], mes[20], sub[8];
    integer lun[5], iunit, kunit, nunit;
    static integer kount[10];
    static char libtab[8*10], mestab[20*10];
    static integer nertab[10], levtab[10];
    static char subtab[8*10];

    /* 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_(4);
            }

/*           Print the table header. */

            io___7.ciunit = iunit;
            f2c::s_wsfe(&io___7);
            f2c::e_wsfe();

/*           Print body of table. */

            i__2 = nmsg;
            for (i__ = 1; i__ <= i__2; ++i__) {
                io___9.ciunit = iunit;
                f2c::s_wsfe(&io___9);
                f2c::do_fio(&c__1, libtab + (i__ - 1 << 3), (ftnlen)8);
                f2c::do_fio(&c__1, subtab + (i__ - 1 << 3), (ftnlen)8);
                f2c::do_fio(&c__1, mestab + (i__ - 1) * 20, (ftnlen)20);
                f2c::do_fio(&c__1, (char *)&nertab[i__ - 1], (ftnlen)sizeof(integer));
                f2c::do_fio(&c__1, (char *)&levtab[i__ - 1], (ftnlen)sizeof(integer));
                f2c::do_fio(&c__1, (char *)&kount[i__ - 1], (ftnlen)sizeof(integer));
                f2c::e_wsfe();
/* L10: */
            }

/*           Print number of other errors. */

            if (kountx != 0) {
                io___16.ciunit = iunit;
                f2c::s_wsfe(&io___16);
                f2c::do_fio(&c__1, (char *)&kountx, (ftnlen)sizeof(integer));
                f2c::e_wsfe();
            }
            io___17.ciunit = iunit;
            f2c::s_wsfe(&io___17);
            f2c::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. */

        f2c::s_copy(lib, librar, (ftnlen)8, librar_len);
        f2c::s_copy(sub, subrou, (ftnlen)8, subrou_len);
        f2c::s_copy(mes, messg, (ftnlen)20, messg_len);
        i__1 = nmsg;
        for (i__ = 1; i__ <= i__1; ++i__) {
            if (f2c::s_cmp(lib, libtab + (i__ - 1 << 3), (ftnlen)8, (ftnlen)8) ==
                0 && f2c::s_cmp(sub, subtab + (i__ - 1 << 3), (ftnlen)8, (
                                    ftnlen)8) == 0 && f2c::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;
            f2c::s_copy(libtab + (i__ - 1 << 3), lib, (ftnlen)8, (ftnlen)8);
            f2c::s_copy(subtab + (i__ - 1 << 3), sub, (ftnlen)8, (ftnlen)8);
            f2c::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_ */