binaries/src/disembl/Tisean_3.0.1/source_f/slatec/xermsg.f

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