source: LMDZ5/branches/LMDZ5_SPLA/libf/bibio/xersve.F @ 3064

Last change on this file since 3064 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
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

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

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