source: LMDZ6/trunk/libf/misc/xermsg.F @ 4297

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

Added 'implicit none' statements and proper variable definitions where they were missing.
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: 16.4 KB
Line 
1*DECK XERMSG
2      SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)
3      IMPLICIT NONE
4C***BEGIN PROLOGUE  XERMSG
5C***PURPOSE  Process error messages for SLATEC and other libraries.
6C***LIBRARY   SLATEC (XERROR)
7C***CATEGORY  R3C
8C***TYPE      ALL (XERMSG-A)
9C***KEYWORDS  ERROR MESSAGE, XERROR
10C***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
11C***DESCRIPTION
12C
13C   XERMSG processes a diagnostic message in a manner determined by the
14C   value of LEVEL and the current value of the library error control
15C   flag, KONTRL.  See subroutine XSETF for details.
16C
17C    LIBRAR   A character constant (or character variable) with the name
18C             of the library.  This will be 'SLATEC' for the SLATEC
19C             Common Math Library.  The error handling package is
20C             general enough to be used by many libraries
21C             simultaneously, so it is desirable for the routine that
22C             detects and reports an error to identify the library name
23C             as well as the routine name.
24C
25C    SUBROU   A character constant (or character variable) with the name
26C             of the routine that detected the error.  Usually it is the
27C             name of the routine that is calling XERMSG.  There are
28C             some instances where a user callable library routine calls
29C             lower level subsidiary routines where the error is
30C             detected.  In such cases it may be more informative to
31C             supply the name of the routine the user called rather than
32C             the name of the subsidiary routine that detected the
33C             error.
34C
35C    MESSG    A character constant (or character variable) with the text
36C             of the error or warning message.  In the example below,
37C             the message is a character constant that contains a
38C             generic message.
39C
40C                   CALL XERMSG ('SLATEC', 'MMPY',
41C                  *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
42C                  *3, 1)
43C
44C             It is possible (and is sometimes desirable) to generate a
45C             specific message--e.g., one that contains actual numeric
46C             values.  Specific numeric values can be converted into
47C             character strings using formatted WRITE statements into
48C             character variables.  This is called standard Fortran
49C             internal file I/O and is exemplified in the first three
50C             lines of the following example.  You can also catenate
51C             substrings of characters to construct the error message.
52C             Here is an example showing the use of both writing to
53C             an internal file and catenating character strings.
54C
55C                   CHARACTER*5 CHARN, CHARL
56C                   WRITE (CHARN,10) N
57C                   WRITE (CHARL,10) LDA
58C                10 FORMAT(I5)
59C                   CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
60C                  *   ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
61C                  *   CHARL, 3, 1)
62C
63C             There are two subtleties worth mentioning.  One is that
64C             the // for character catenation is used to construct the
65C             error message so that no single character constant is
66C             continued to the next line.  This avoids confusion as to
67C             whether there are trailing blanks at the end of the line.
68C             The second is that by catenating the parts of the message
69C             as an actual argument rather than encoding the entire
70C             message into one large character variable, we avoid
71C             having to know how long the message will be in order to
72C             declare an adequate length for that large character
73C             variable.  XERMSG calls XERPRN to print the message using
74C             multiple lines if necessary.  If the message is very long,
75C             XERPRN will break it into pieces of 72 characters (as
76C             requested by XERMSG) for printing on multiple lines.
77C             Also, XERMSG asks XERPRN to prefix each line with ' *  '
78C             so that the total line length could be 76 characters.
79C             Note also that XERPRN scans the error message backwards
80C             to ignore trailing blanks.  Another feature is that
81C             the substring '$$' is treated as a new line sentinel
82C             by XERPRN.  If you want to construct a multiline
83C             message without having to count out multiples of 72
84C             characters, just use '$$' as a separator.  '$$'
85C             obviously must occur within 72 characters of the
86C             start of each line to have its intended effect since
87C             XERPRN is asked to wrap around at 72 characters in
88C             addition to looking for '$$'.
89C
90C    NERR     An integer value that is chosen by the library routine's
91C             author.  It must be in the range -99 to 999 (three
92C             printable digits).  Each distinct error should have its
93C             own error number.  These error numbers should be described
94C             in the machine readable documentation for the routine.
95C             The error numbers need be unique only within each routine,
96C             so it is reasonable for each routine to start enumerating
97C             errors from 1 and proceeding to the next integer.
98C
99C    LEVEL    An integer value in the range 0 to 2 that indicates the
100C             level (severity) of the error.  Their meanings are
101C
102C            -1  A warning message.  This is used if it is not clear
103C                that there really is an error, but the user's attention
104C                may be needed.  An attempt is made to only print this
105C                message once.
106C
107C             0  A warning message.  This is used if it is not clear
108C                that there really is an error, but the user's attention
109C                may be needed.
110C
111C             1  A recoverable error.  This is used even if the error is
112C                so serious that the routine cannot return any useful
113C                answer.  If the user has told the error package to
114C                return after recoverable errors, then XERMSG will
115C                return to the Library routine which can then return to
116C                the user's routine.  The user may also permit the error
117C                package to terminate the program upon encountering a
118C                recoverable error.
119C
120C             2  A fatal error.  XERMSG will not return to its caller
121C                after it receives a fatal error.  This level should
122C                hardly ever be used; it is much better to allow the
123C                user a chance to recover.  An example of one of the few
124C                cases in which it is permissible to declare a level 2
125C                error is a reverse communication Library routine that
126C                is likely to be called repeatedly until it integrates
127C                across some interval.  If there is a serious error in
128C                the input such that another step cannot be taken and
129C                the Library routine is called again without the input
130C                error having been corrected by the caller, the Library
131C                routine will probably be called forever with improper
132C                input.  In this case, it is reasonable to declare the
133C                error to be fatal.
134C
135C    Each of the arguments to XERMSG is input; none will be modified by
136C    XERMSG.  A routine may make multiple calls to XERMSG with warning
137C    level messages; however, after a call to XERMSG with a recoverable
138C    error, the routine should return to the user.  Do not try to call
139C    XERMSG with a second recoverable error after the first recoverable
140C    error because the error package saves the error number.  The user
141C    can retrieve this error number by calling another entry point in
142C    the error handling package and then clear the error number when
143C    recovering from the error.  Calling XERMSG in succession causes the
144C    old error number to be overwritten by the latest error number.
145C    This is considered harmless for error numbers associated with
146C    warning messages but must not be done for error numbers of serious
147C    errors.  After a call to XERMSG with a recoverable error, the user
148C    must be given a chance to call NUMXER or XERCLR to retrieve or
149C    clear the error number.
150C***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
151C                 Error-handling Package, SAND82-0800, Sandia
152C                 Laboratories, 1982.
153C***ROUTINES CALLED  FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE
154C***REVISION HISTORY  (YYMMDD)
155C   880101  DATE WRITTEN
156C   880621  REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
157C           THERE ARE TWO BASIC CHANGES.
158C           1.  A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
159C               PRINT MESSAGES.  THIS ROUTINE WILL BREAK LONG MESSAGES
160C               INTO PIECES FOR PRINTING ON MULTIPLE LINES.  '$$' IS
161C               ACCEPTED AS A NEW LINE SENTINEL.  A PREFIX CAN BE
162C               ADDED TO EACH LINE TO BE PRINTED.  XERMSG USES EITHER
163C               ' ***' OR ' *  ' AND LONG MESSAGES ARE BROKEN EVERY
164C               72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
165C               LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
166C           2.  THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
167C               FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
168C               OF LOWER CASE.
169C   880708  REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
170C           THE PRINCIPAL CHANGES ARE
171C           1.  CLARIFY COMMENTS IN THE PROLOGUES
172C           2.  RENAME XRPRNT TO XERPRN
173C           3.  REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
174C               SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
175C               CHARACTER FOR NEW RECORDS.
176C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
177C           CLEAN UP THE CODING.
178C   890721  REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
179C           PREFIX.
180C   891013  REVISED TO CORRECT COMMENTS.
181C   891214  Prologue converted to Version 4.0 format.  (WRB)
182C   900510  Changed test on NERR to be -9999999 < NERR < 99999999, but
183C           NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3.  Added
184C           LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
185C           XERCTL to XERCNT.  (RWC)
186C   920501  Reformatted the REFERENCES section.  (WRB)
187C***END PROLOGUE  XERMSG
188      CHARACTER*(*) LIBRAR, SUBROU, MESSG
189      CHARACTER*8 XLIBR, XSUBR
190      CHARACTER*72  TEMP
191      CHARACTER*20  LFIRST
192      INTEGER NERR, LEVEL, LKNTRL
193      INTEGER J4SAVE, MAXMES, KDUMMY, I, KOUNT, LERR, LLEVEL
194      INTEGER MKNTRL, LTEMP
195C***FIRST EXECUTABLE STATEMENT  XERMSG
196      LKNTRL = J4SAVE (2, 0, .FALSE.)
197      MAXMES = J4SAVE (4, 0, .FALSE.)
198C
199C       LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL.
200C       MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE
201C          SHOULD BE PRINTED.
202C
203C       WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
204C          CALLING XERMSG.  THE ERROR NUMBER SHOULD BE POSITIVE,
205C          AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
206C
207      IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR.
208     *   LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN
209         CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' //
210     *      'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '//
211     *      'JOB ABORT DUE TO FATAL ERROR.', 72)
212         CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY)
213         CALL XERHLT (' ***XERMSG -- INVALID INPUT')
214         RETURN
215      ENDIF
216C
217C       RECORD THE MESSAGE.
218C
219      I = J4SAVE (1, NERR, .TRUE.)
220      CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT)
221C
222C       HANDLE PRINT-ONCE WARNING MESSAGES.
223C
224      IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN
225C
226C       ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG.
227C
228      XLIBR  = LIBRAR
229      XSUBR  = SUBROU
230      LFIRST = MESSG
231      LERR   = NERR
232      LLEVEL = LEVEL
233      CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL)
234C
235      LKNTRL = MAX(-2, MIN(2,LKNTRL))
236      MKNTRL = ABS(LKNTRL)
237C
238C       SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS
239C       ZERO AND THE ERROR IS NOT FATAL.
240C
241      IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30
242      IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30
243      IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30
244      IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30
245C
246C       ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
247C       MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
248C       AND SENDING IT OUT VIA XERPRN.  PRINT ONLY IF CONTROL FLAG
249C       IS NOT ZERO.
250C
251      IF (LKNTRL .NE. 0) THEN
252         TEMP(1:21) = 'MESSAGE FROM ROUTINE '
253         I = MIN(LEN(SUBROU), 16)
254         TEMP(22:21+I) = SUBROU(1:I)
255         TEMP(22+I:33+I) = ' IN LIBRARY '
256         LTEMP = 33 + I
257         I = MIN(LEN(LIBRAR), 16)
258         TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I)
259         TEMP(LTEMP+I+1:LTEMP+I+1) = '.'
260         LTEMP = LTEMP + I + 1
261         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
262      ENDIF
263C
264C       IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
265C       PRINTING THE MESSAGE.  THE INTRODUCTORY LINE TELLS THE CHOICE
266C       FROM EACH OF THE FOLLOWING THREE OPTIONS.
267C       1.  LEVEL OF THE MESSAGE
268C              'INFORMATIVE MESSAGE'
269C              'POTENTIALLY RECOVERABLE ERROR'
270C              'FATAL ERROR'
271C       2.  WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
272C              'PROG CONTINUES'
273C              'PROG ABORTED'
274C       3.  WHETHER OR NOT A TRACEBACK WAS REQUESTED.  (THE TRACEBACK
275C           MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS
276C           WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.)
277C              'TRACEBACK REQUESTED'
278C              'TRACEBACK NOT REQUESTED'
279C       NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
280C       EXCEED 74 CHARACTERS.
281C       WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED.
282C
283      IF (LKNTRL .GT. 0) THEN
284C
285C       THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
286C
287         IF (LEVEL .LE. 0) THEN
288            TEMP(1:20) = 'INFORMATIVE MESSAGE,'
289            LTEMP = 20
290         ELSEIF (LEVEL .EQ. 1) THEN
291            TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
292            LTEMP = 30
293         ELSE
294            TEMP(1:12) = 'FATAL ERROR,'
295            LTEMP = 12
296         ENDIF
297C
298C       THEN WHETHER THE PROGRAM WILL CONTINUE.
299C
300         IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR.
301     *       (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN
302            TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,'
303            LTEMP = LTEMP + 14
304         ELSE
305            TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,'
306            LTEMP = LTEMP + 16
307         ENDIF
308C
309C       FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK.
310C
311         IF (LKNTRL .GT. 0) THEN
312            TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED'
313            LTEMP = LTEMP + 20
314         ELSE
315            TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED'
316            LTEMP = LTEMP + 24
317         ENDIF
318         CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
319      ENDIF
320C
321C       NOW SEND OUT THE MESSAGE.
322C
323      CALL XERPRN (' *  ', -1, MESSG, 72)
324C
325C       IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A
326C          TRACEBACK.
327C
328      IF (LKNTRL .GT. 0) THEN
329         WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
330         DO 10 I=16,22
331            IF (TEMP(I:I) .NE. ' ') GO TO 20
332   10    CONTINUE
333C
334   20    CALL XERPRN (' *  ', -1, TEMP(1:15) // TEMP(I:23), 72)
335         CALL FDUMP
336      ENDIF
337C
338C       IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
339C
340      IF (LKNTRL .NE. 0) THEN
341         CALL XERPRN (' *  ', -1, ' ', 72)
342         CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72)
343         CALL XERPRN ('    ',  0, ' ', 72)
344      ENDIF
345C
346C       IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
347C       CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
348C
349   30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN
350C
351C       THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
352C       FATAL ERROR.  PRINT THE REASON FOR THE ABORT AND THE ERROR
353C       SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
354C
355      IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN
356         IF (LEVEL .EQ. 1) THEN
357            CALL XERPRN
358     *         (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
359         ELSE
360            CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72)
361         ENDIF
362         CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY)
363         CALL XERHLT (' ')
364      ELSE
365         CALL XERHLT (MESSG)
366      ENDIF
367      RETURN
368      END
Note: See TracBrowser for help on using the repository browser.