source: LMDZ5/branches/IPSLCM5A2.1/libf/misc/xersve.F @ 2866

Last change on this file since 2866 was 2199, checked in by Ehouarn Millour, 10 years ago

Follow-up of r2197; some compilers (e.g. ifort) impose that parameter types be declared before or at the same time as the associated values.
EM

  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 4.9 KB
Line 
1*DECK XERSVE
2      SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL,
3     +   ICOUNT)
4      IMPLICIT NONE
5C***BEGIN PROLOGUE  XERSVE
6C***SUBSIDIARY
7C***PURPOSE  Record that an error has occurred.
8C***LIBRARY   SLATEC (XERROR)
9C***CATEGORY  R3
10C***TYPE      ALL (XERSVE-A)
11C***KEYWORDS  ERROR, XERROR
12C***AUTHOR  Jones, R. E., (SNLA)
13C***DESCRIPTION
14C
15C *Usage:
16C
17C        INTEGER  KFLAG, NERR, LEVEL, ICOUNT
18C        CHARACTER * (len) LIBRAR, SUBROU, MESSG
19C
20C        CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT)
21C
22C *Arguments:
23C
24C        LIBRAR :IN    is the library that the message is from.
25C        SUBROU :IN    is the subroutine that the message is from.
26C        MESSG  :IN    is the message to be saved.
27C        KFLAG  :IN    indicates the action to be performed.
28C                      when KFLAG > 0, the message in MESSG is saved.
29C                      when KFLAG=0 the tables will be dumped and
30C                      cleared.
31C                      when KFLAG < 0, the tables will be dumped and
32C                      not cleared.
33C        NERR   :IN    is the error number.
34C        LEVEL  :IN    is the error severity.
35C        ICOUNT :OUT   the number of times this message has been seen,
36C                      or zero if the table has overflowed and does not
37C                      contain this message specifically.  When KFLAG=0,
38C                      ICOUNT will not be altered.
39C
40C *Description:
41C
42C   Record that this error occurred and possibly dump and clear the
43C   tables.
44C
45C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
46C                 Error-handling Package, SAND82-0800, Sandia
47C                 Laboratories, 1982.
48C***ROUTINES CALLED  I1MACH, XGETUA
49C***REVISION HISTORY  (YYMMDD)
50C   800319  DATE WRITTEN
51C   861211  REVISION DATE from Version 3.2
52C   891214  Prologue converted to Version 4.0 format.  (BAB)
53C   900413  Routine modified to remove reference to KFLAG.  (WRB)
54C   900510  Changed to add LIBRARY NAME and SUBROUTINE to calling
55C           sequence, use IF-THEN-ELSE, make number of saved entries
56C           easily changeable, changed routine name from XERSAV to
57C           XERSVE.  (RWC)
58C   910626  Added LIBTAB and SUBTAB to SAVE statement.  (BKS)
59C   920501  Reformatted the REFERENCES section.  (WRB)
60C***END PROLOGUE  XERSVE
61      INTEGER,PARAMETER :: LENTAB=10
62      INTEGER LUN(5)
63      CHARACTER*(*) LIBRAR, SUBROU, MESSG
64      CHARACTER*8  LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB
65      CHARACTER*20 MESTAB(LENTAB), MES
66      DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB)
67      SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
68      DATA KOUNTX/0/, NMSG/0/
69      INTEGER NERR,LEVEL,KONTRL
70      INTEGER NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
71      INTEGER KFLAG, ICOUNT, NUNIT, KUNIT, IUNIT, I1MACH, I
72C***FIRST EXECUTABLE STATEMENT  XERSVE
73C
74      IF (KFLAG.LE.0) THEN
75C
76C        Dump the table.
77C
78         IF (NMSG.EQ.0) RETURN
79C
80C        Print to each unit.
81C
82         CALL XGETUA (LUN, NUNIT)
83         DO 20 KUNIT = 1,NUNIT
84            IUNIT = LUN(KUNIT)
85            IF (IUNIT.EQ.0) IUNIT = I1MACH(4)
86C
87C           Print the table header.
88C
89            WRITE (IUNIT,9000)
90C
91C           Print body of table.
92C
93            DO 10 I = 1,NMSG
94               WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I),
95     *            NERTAB(I),LEVTAB(I),KOUNT(I)
96   10       CONTINUE
97C
98C           Print number of other errors.
99C
100            IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX
101            WRITE (IUNIT,9030)
102   20    CONTINUE
103C
104C        Clear the error tables.
105C
106         IF (KFLAG.EQ.0) THEN
107            NMSG = 0
108            KOUNTX = 0
109         ENDIF
110      ELSE
111C
112C        PROCESS A MESSAGE...
113C        SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
114C        OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
115C
116         LIB = LIBRAR
117         SUB = SUBROU
118         MES = MESSG
119         DO 30 I = 1,NMSG
120            IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND.
121     *         MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND.
122     *         LEVEL.EQ.LEVTAB(I)) THEN
123                  KOUNT(I) = KOUNT(I) + 1
124                  ICOUNT = KOUNT(I)
125                  RETURN
126            ENDIF
127   30    CONTINUE
128C
129         IF (NMSG.LT.LENTAB) THEN
130C
131C           Empty slot found for new message.
132C
133            NMSG = NMSG + 1
134            LIBTAB(I) = LIB
135            SUBTAB(I) = SUB
136            MESTAB(I) = MES
137            NERTAB(I) = NERR
138            LEVTAB(I) = LEVEL
139            KOUNT (I) = 1
140            ICOUNT    = 1
141         ELSE
142C
143C           Table is full.
144C
145            KOUNTX = KOUNTX+1
146            ICOUNT = 0
147         ENDIF
148      ENDIF
149      RETURN
150C
151C     Formats.
152C
153 9000 FORMAT ('0          ERROR MESSAGE SUMMARY' /
154     +   ' LIBRARY    SUBROUTINE MESSAGE START             NERR',
155     +   '     LEVEL     COUNT')
156 9010 FORMAT (1X,A,3X,A,3X,A,3I10)
157 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10)
158 9030 FORMAT (1X)
159      END
Note: See TracBrowser for help on using the repository browser.