← Back to branch summary

~ubuntu-branches/debian/sid/octave-tisean/sid

« back to all changes in this revision

Viewing changes to src/source_f/slatec/xersve.f

  • Committer: Package Import Robot
  • Author(s): Rafael Laboissiere
  • Date: 2017-08-14 12:53:47 UTC
  • Revision ID: package-import@ubuntu.com-20170814125347-ju5owr4dggr53a2n
Tags: upstream-0.2.3
Import upstream version 0.2.3

Show diffs side-by-side

added added

removed removed

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