source: LMDZ5/trunk/libf/bibio/xermsg.F @ 2037

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