| 52 | | SUBROUTINE XERRWV(MESSG,NMESSG,NERR,LEVEL,NI,I1,I2,NR,R1,R2) |
| 53 | | C***BEGIN PROLOGUE XERRWV |
| 54 | | C***DATE WRITTEN 800319 (YYMMDD) |
| 55 | | C***REVISION DATE 820801 (YYMMDD) |
| 56 | | C***CATEGORY NO. R3C |
| 57 | | C***KEYWORDS ERROR,XERROR PACKAGE |
| 58 | | C***AUTHOR JONES, R. E., (SNLA) |
| 59 | | C***PURPOSE Processes error message allowing 2 integer and two real |
| 60 | | C values to be included in the message. |
| 61 | | C***DESCRIPTION |
| 62 | | C Abstract |
| 63 | | C XERRWV processes a diagnostic message, in a manner |
| 64 | | C determined by the value of LEVEL and the current value |
| 65 | | C of the library error control flag, KONTRL. |
| 66 | | C (See subroutine XSETF for details.) |
| 67 | | C In addition, up to two integer values and two real |
| 68 | | C values may be printed along with the message. |
| 69 | | C |
| 70 | | C Description of Parameters |
| 71 | | C --Input-- |
| 72 | | C MESSG - the Hollerith message to be processed. |
| 73 | | C NMESSG- the actual number of characters in MESSG. |
| 74 | | C NERR - the error number associated with this message. |
| 75 | | C NERR must not be zero. |
| 76 | | C LEVEL - error category. |
| 77 | | C =2 means this is an unconditionally fatal error. |
| 78 | | C =1 means this is a recoverable error. (I.e., it is |
| 79 | | C non-fatal if XSETF has been appropriately called.) |
| 80 | | C =0 means this is a warning message only. |
| 81 | | C =-1 means this is a warning message which is to be |
| 82 | | C printed at most once, regardless of how many |
| 83 | | C times this call is executed. |
| 84 | | C NI - number of integer values to be printed. (0 to 2) |
| 85 | | C I1 - first integer value. |
| 86 | | C I2 - second integer value. |
| 87 | | C NR - number of real values to be printed. (0 to 2) |
| 88 | | C R1 - first real value. |
| 89 | | C R2 - second real value. |
| 90 | | C |
| 91 | | C Examples |
| 92 | | C CALL XERRWV('SMOOTH -- NUM (=I1) WAS ZERO.',29,1,2, |
| 93 | | C 1 1,NUM,0,0,0.,0.) |
| 94 | | C CALL XERRWV('QUADXY -- REQUESTED ERROR (R1) LESS THAN MINIMUM ( |
| 95 | | C 1R2).,54,77,1,0,0,0,2,ERRREQ,ERRMIN) |
| 96 | | C |
| 97 | | C Latest revision --- 19 MAR 1980 |
| 98 | | C Written by Ron Jones, with SLATEC Common Math Library Subcommittee |
| 99 | | C***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- |
| 100 | | C HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, |
| 101 | | C 1982. |
| 102 | | C***ROUTINES CALLED FDUMP,I1MACH,J4SAVE,XERABT,XERCTL,XERPRT,XERSAV, |
| 103 | | C XGETUA |
| 104 | | C***END PROLOGUE XERRWV |
| 105 | | CHARACTER*(*) MESSG |
| 106 | | CHARACTER*20 LFIRST |
| 107 | | CHARACTER*37 FORM |
| 108 | | DIMENSION LUN(5) |
| 109 | | C GET FLAGS |
| 110 | | C***FIRST EXECUTABLE STATEMENT XERRWV |
| 111 | | LKNTRL = J4SAVE(2,0,.FALSE.) |
| 112 | | MAXMES = J4SAVE(4,0,.FALSE.) |
| 113 | | C CHECK FOR VALID INPUT |
| 114 | | IF ((NMESSG.GT.0).AND.(NERR.NE.0).AND. |
| 115 | | 1 (LEVEL.GE.(-1)).AND.(LEVEL.LE.2)) GO TO 10 |
| 116 | | IF (LKNTRL.GT.0) CALL XERPRT('FATAL ERROR IN...',17) |
| 117 | | CALL XERPRT('XERROR -- INVALID INPUT',23) |
| 118 | | IF (LKNTRL.GT.0) CALL FDUMP |
| 119 | | IF (LKNTRL.GT.0) CALL XERPRT('JOB ABORT DUE TO FATAL ERROR.', |
| 120 | | 1 29) |
| 121 | | IF (LKNTRL.GT.0) CALL XERSAV(' ',0,0,0,KDUMMY) |
| 122 | | CALL XERABT('XERROR -- INVALID INPUT',23) |
| 123 | | RETURN |
| 124 | | 10 CONTINUE |
| 125 | | C RECORD MESSAGE |
| 126 | | JUNK = J4SAVE(1,NERR,.TRUE.) |
| 127 | | CALL XERSAV(MESSG,NMESSG,NERR,LEVEL,KOUNT) |
| 128 | | C LET USER OVERRIDE |
| 129 | | LFIRST = MESSG |
| 130 | | LMESSG = NMESSG |
| 131 | | LERR = NERR |
| 132 | | LLEVEL = LEVEL |
| 133 | | CALL XERCTL(LFIRST,LMESSG,LERR,LLEVEL,LKNTRL) |
| 134 | | C RESET TO ORIGINAL VALUES |
| 135 | | LMESSG = NMESSG |
| 136 | | LERR = NERR |
| 137 | | LLEVEL = LEVEL |
| 138 | | LKNTRL = MAX0(-2,MIN0(2,LKNTRL)) |
| 139 | | MKNTRL = IABS(LKNTRL) |
| 140 | | C DECIDE WHETHER TO PRINT MESSAGE |
| 141 | | IF ((LLEVEL.LT.2).AND.(LKNTRL.EQ.0)) GO TO 100 |
| 142 | | IF (((LLEVEL.EQ.(-1)).AND.(KOUNT.GT.MIN0(1,MAXMES))) |
| 143 | | 1.OR.((LLEVEL.EQ.0) .AND.(KOUNT.GT.MAXMES)) |
| 144 | | 2.OR.((LLEVEL.EQ.1) .AND.(KOUNT.GT.MAXMES).AND.(MKNTRL.EQ.1)) |
| 145 | | 3.OR.((LLEVEL.EQ.2) .AND.(KOUNT.GT.MAX0(1,MAXMES)))) GO TO 100 |
| 146 | | IF (LKNTRL.LE.0) GO TO 20 |
| 147 | | CALL XERPRT(' ',1) |
| 148 | | C INTRODUCTION |
| 149 | | IF (LLEVEL.EQ.(-1)) CALL XERPRT |
| 150 | | 1('WARNING MESSAGE...THIS MESSAGE WILL ONLY BE PRINTED ONCE.',57) |
| 151 | | IF (LLEVEL.EQ.0) CALL XERPRT('WARNING IN...',13) |
| 152 | | IF (LLEVEL.EQ.1) CALL XERPRT |
| 153 | | 1 ('RECOVERABLE ERROR IN...',23) |
| 154 | | IF (LLEVEL.EQ.2) CALL XERPRT('FATAL ERROR IN...',17) |
| 155 | | 20 CONTINUE |
| 156 | | C MESSAGE |
| 157 | | CALL XERPRT(MESSG,LMESSG) |
| 158 | | CALL XGETUA(LUN,NUNIT) |
| 159 | | ISIZEI = LOG10(FLOAT(I1MACH(9))) + 1.0 |
| 160 | | ISIZEF = LOG10(FLOAT(I1MACH(10))**I1MACH(11)) + 1.0 |
| 161 | | DO 50 KUNIT=1,NUNIT |
| 162 | | IUNIT = LUN(KUNIT) |
| 163 | | IF (IUNIT.EQ.0) IUNIT = I1MACH(4) |
| 164 | | DO 22 I=1,MIN(NI,2) |
| 165 | | WRITE (FORM,21) I,ISIZEI |
| 166 | | 21 FORMAT ('(11X,21HIN ABOVE MESSAGE, I',I1,'=,I',I2,') ') |
| 167 | | IF (I.EQ.1) WRITE (IUNIT,FORM) I1 |
| 168 | | IF (I.EQ.2) WRITE (IUNIT,FORM) I2 |
| 169 | | 22 CONTINUE |
| 170 | | DO 24 I=1,MIN(NR,2) |
| 171 | | WRITE (FORM,23) I,ISIZEF+10,ISIZEF |
| 172 | | 23 FORMAT ('(11X,21HIN ABOVE MESSAGE, R',I1,'=,E', |
| 173 | | 1 I2,'.',I2,')') |
| 174 | | IF (I.EQ.1) WRITE (IUNIT,FORM) R1 |
| 175 | | IF (I.EQ.2) WRITE (IUNIT,FORM) R2 |
| 176 | | 24 CONTINUE |
| 177 | | IF (LKNTRL.LE.0) GO TO 40 |
| 178 | | C ERROR NUMBER |
| 179 | | WRITE (IUNIT,30) LERR |
| 180 | | 30 FORMAT (' ERROR NUMBER =',I10) |
| 181 | | 40 CONTINUE |
| 182 | | 50 CONTINUE |
| 183 | | C TRACE-BACK |
| 184 | | IF (LKNTRL.GT.0) CALL FDUMP |
| 185 | | 100 CONTINUE |
| 186 | | IFATAL = 0 |
| 187 | | IF ((LLEVEL.EQ.2).OR.((LLEVEL.EQ.1).AND.(MKNTRL.EQ.2))) |
| 188 | | 1IFATAL = 1 |
| 189 | | C QUIT HERE IF MESSAGE IS NOT FATAL |
| 190 | | IF (IFATAL.LE.0) RETURN |
| 191 | | IF ((LKNTRL.LE.0).OR.(KOUNT.GT.MAX0(1,MAXMES))) GO TO 120 |
| 192 | | C PRINT REASON FOR ABORT |
| 193 | | IF (LLEVEL.EQ.1) CALL XERPRT |
| 194 | | 1 ('JOB ABORT DUE TO UNRECOVERED ERROR.',35) |
| 195 | | IF (LLEVEL.EQ.2) CALL XERPRT |
| 196 | | 1 ('JOB ABORT DUE TO FATAL ERROR.',29) |
| 197 | | C PRINT ERROR SUMMARY |
| 198 | | CALL XERSAV(' ',-1,0,0,KDUMMY) |
| 199 | | 120 CONTINUE |
| 200 | | C ABORT |
| 201 | | IF ((LLEVEL.EQ.2).AND.(KOUNT.GT.MAX0(1,MAXMES))) LMESSG = 0 |
| 202 | | CALL XERABT(MESSG,LMESSG) |
| 203 | | RETURN |
| 204 | | END |
| 205 | | SUBROUTINE XERSAV(MESSG,NMESSG,NERR,LEVEL,ICOUNT) |
| 206 | | C***BEGIN PROLOGUE XERSAV |
| 207 | | C***DATE WRITTEN 800319 (YYMMDD) |
| 208 | | C***REVISION DATE 820801 (YYMMDD) |
| 209 | | C***CATEGORY NO. Z |
| 210 | | C***KEYWORDS ERROR,XERROR PACKAGE |
| 211 | | C***AUTHOR JONES, R. E., (SNLA) |
| 212 | | C***PURPOSE Records that an error occurred. |
| 213 | | C***DESCRIPTION |
| 214 | | C Abstract |
| 215 | | C Record that this error occurred. |
| 216 | | C |
| 217 | | C Description of Parameters |
| 218 | | C --Input-- |
| 219 | | C MESSG, NMESSG, NERR, LEVEL are as in XERROR, |
| 220 | | C except that when NMESSG=0 the tables will be |
| 221 | | C dumped and cleared, and when NMESSG is less than zero the |
| 222 | | C tables will be dumped and not cleared. |
| 223 | | C --Output-- |
| 224 | | C ICOUNT will be the number of times this message has |
| 225 | | C been seen, or zero if the table has overflowed and |
| 226 | | C does not contain this message specifically. |
| 227 | | C When NMESSG=0, ICOUNT will not be altered. |
| 228 | | C |
| 229 | | C Written by Ron Jones, with SLATEC Common Math Library Subcommittee |
| 230 | | C Latest revision --- 19 Mar 1980 |
| 231 | | C***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- |
| 232 | | C HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, |
| 233 | | C 1982. |
| 234 | | C***ROUTINES CALLED I1MACH,S88FMT,XGETUA |
| 235 | | C***END PROLOGUE XERSAV |
| 236 | | INTEGER LUN(5) |
| 237 | | CHARACTER*(*) MESSG |
| 238 | | CHARACTER*20 MESTAB(10),MES |
| 239 | | DIMENSION NERTAB(10),LEVTAB(10),KOUNT(10) |
| 240 | | SAVE MESTAB,NERTAB,LEVTAB,KOUNT,KOUNTX |
| 241 | | C NEXT TWO DATA STATEMENTS ARE NECESSARY TO PROVIDE A BLANK |
| 242 | | C ERROR TABLE INITIALLY |
| 243 | | DATA KOUNT(1),KOUNT(2),KOUNT(3),KOUNT(4),KOUNT(5), |
| 244 | | 1 KOUNT(6),KOUNT(7),KOUNT(8),KOUNT(9),KOUNT(10) |
| 245 | | 2 /0,0,0,0,0,0,0,0,0,0/ |
| 246 | | DATA KOUNTX/0/ |
| 247 | | C***FIRST EXECUTABLE STATEMENT XERSAV |
| 248 | | IF (NMESSG.GT.0) GO TO 80 |
| 249 | | C DUMP THE TABLE |
| 250 | | IF (KOUNT(1).EQ.0) RETURN |
| 251 | | C PRINT TO EACH UNIT |
| 252 | | CALL XGETUA(LUN,NUNIT) |
| 253 | | DO 60 KUNIT=1,NUNIT |
| 254 | | IUNIT = LUN(KUNIT) |
| 255 | | IF (IUNIT.EQ.0) IUNIT = I1MACH(4) |
| 256 | | C PRINT TABLE HEADER |
| 257 | | WRITE (IUNIT,10) |
| 258 | | 10 FORMAT ('0 ERROR MESSAGE SUMMARY'/ |
| 259 | | 1 ' MESSAGE START NERR LEVEL COUNT') |
| 260 | | C PRINT BODY OF TABLE |
| 261 | | DO 20 I=1,10 |
| 262 | | IF (KOUNT(I).EQ.0) GO TO 30 |
| 263 | | WRITE (IUNIT,15) MESTAB(I),NERTAB(I),LEVTAB(I),KOUNT(I) |
| 264 | | 15 FORMAT (1X,A20,3I10) |
| 265 | | 20 CONTINUE |
| 266 | | 30 CONTINUE |
| 267 | | C PRINT NUMBER OF OTHER ERRORS |
| 268 | | IF (KOUNTX.NE.0) WRITE (IUNIT,40) KOUNTX |
| 269 | | 40 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED=',I10) |
| 270 | | WRITE (IUNIT,50) |
| 271 | | 50 FORMAT (1X) |
| 272 | | 60 CONTINUE |
| 273 | | IF (NMESSG.LT.0) RETURN |
| 274 | | C CLEAR THE ERROR TABLES |
| 275 | | DO 70 I=1,10 |
| 276 | | 70 KOUNT(I) = 0 |
| 277 | | KOUNTX = 0 |
| 278 | | RETURN |
| 279 | | 80 CONTINUE |
| 280 | | C PROCESS A MESSAGE... |
| 281 | | C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, |
| 282 | | C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. |
| 283 | | MES = MESSG |
| 284 | | DO 90 I=1,10 |
| 285 | | II = I |
| 286 | | IF (KOUNT(I).EQ.0) GO TO 110 |
| 287 | | IF (MES.NE.MESTAB(I)) GO TO 90 |
| 288 | | IF (NERR.NE.NERTAB(I)) GO TO 90 |
| 289 | | IF (LEVEL.NE.LEVTAB(I)) GO TO 90 |
| 290 | | GO TO 100 |
| 291 | | 90 CONTINUE |
| 292 | | C THREE POSSIBLE CASES... |
| 293 | | C TABLE IS FULL |
| 294 | | KOUNTX = KOUNTX+1 |
| 295 | | ICOUNT = 1 |
| 296 | | RETURN |
| 297 | | C MESSAGE FOUND IN TABLE |
| 298 | | 100 KOUNT(II) = KOUNT(II) + 1 |
| 299 | | ICOUNT = KOUNT(II) |
| 300 | | RETURN |
| 301 | | C EMPTY SLOT FOUND FOR NEW MESSAGE |
| 302 | | 110 MESTAB(II) = MES |
| 303 | | NERTAB(II) = NERR |
| 304 | | LEVTAB(II) = LEVEL |
| 305 | | KOUNT(II) = 1 |
| 306 | | ICOUNT = 1 |
| 307 | | RETURN |
| 308 | | END |
| 309 | | SUBROUTINE XGETUA(IUNITA,N) |
| 310 | | C***BEGIN PROLOGUE XGETUA |
| 311 | | C***DATE WRITTEN 790801 (YYMMDD) |
| 312 | | C***REVISION DATE 820801 (YYMMDD) |
| 313 | | C***CATEGORY NO. R3C |
| 314 | | C***KEYWORDS ERROR,XERROR PACKAGE |
| 315 | | C***AUTHOR JONES, R. E., (SNLA) |
| 316 | | C***PURPOSE Returns unit number(s) to which error messages are being |
| 317 | | C sent. |
| 318 | | C***DESCRIPTION |
| 319 | | C Abstract |
| 320 | | C XGETUA may be called to determine the unit number or numbers |
| 321 | | C to which error messages are being sent. |
| 322 | | C These unit numbers may have been set by a call to XSETUN, |
| 323 | | C or a call to XSETUA, or may be a default value. |
| 324 | | C |
| 325 | | C Description of Parameters |
| 326 | | C --Output-- |
| 327 | | C IUNIT - an array of one to five unit numbers, depending |
| 328 | | C on the value of N. A value of zero refers to the |
| 329 | | C default unit, as defined by the I1MACH machine |
| 330 | | C constant routine. Only IUNIT(1),...,IUNIT(N) are |
| 331 | | C defined by XGETUA. The values of IUNIT(N+1),..., |
| 332 | | C IUNIT(5) are not defined (for N .LT. 5) or altered |
| 333 | | C in any way by XGETUA. |
| 334 | | C N - the number of units to which copies of the |
| 335 | | C error messages are being sent. N will be in the |
| 336 | | C range from 1 to 5. |
| 337 | | C |
| 338 | | C Latest revision --- 19 MAR 1980 |
| 339 | | C Written by Ron Jones, with SLATEC Common Math Library Subcommittee |
| 340 | | C***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- |
| 341 | | C HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, |
| 342 | | C 1982. |
| 343 | | C***ROUTINES CALLED J4SAVE |
| 344 | | C***END PROLOGUE XGETUA |
| 345 | | DIMENSION IUNITA(5) |
| 346 | | C***FIRST EXECUTABLE STATEMENT XGETUA |
| 347 | | N = J4SAVE(5,0,.FALSE.) |
| 348 | | DO 30 I=1,N |
| 349 | | INDEX = I+4 |
| 350 | | IF (I.EQ.1) INDEX = 3 |
| 351 | | IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) |
| 352 | | 30 CONTINUE |
| 353 | | RETURN |
| 354 | | END |
| 355 | | SUBROUTINE FDUMP |
| 356 | | C***BEGIN PROLOGUE FDUMP |
| 357 | | C***DATE WRITTEN 790801 (YYMMDD) |
| 358 | | C***REVISION DATE 820801 (YYMMDD) |
| 359 | | C***CATEGORY NO. Z |
| 360 | | C***KEYWORDS ERROR,XERROR PACKAGE |
| 361 | | C***AUTHOR JONES, R. E., (SNLA) |
| 362 | | C***PURPOSE Symbolic dump (should be locally written). |
| 363 | | C***DESCRIPTION |
| 364 | | C ***Note*** Machine Dependent Routine |
| 365 | | C FDUMP is intended to be replaced by a locally written |
| 366 | | C version which produces a symbolic dump. Failing this, |
| 367 | | C it should be replaced by a version which prints the |
| 368 | | C subprogram nesting list. Note that this dump must be |
| 369 | | C printed on each of up to five files, as indicated by the |
| 370 | | C XGETUA routine. See XSETUA and XGETUA for details. |
| 371 | | C |
| 372 | | C Written by Ron Jones, with SLATEC Common Math Library Subcommittee |
| 373 | | C Latest revision --- 23 May 1979 |
| 374 | | C***ROUTINES CALLED (NONE) |
| 375 | | C***END PROLOGUE FDUMP |
| 376 | | C***FIRST EXECUTABLE STATEMENT FDUMP |
| 377 | | RETURN |
| 378 | | END |
| 379 | | FUNCTION J4SAVE(IWHICH,IVALUE,ISET) |
| 380 | | C***BEGIN PROLOGUE J4SAVE |
| 381 | | C***REFER TO XERROR |
| 382 | | C Abstract |
| 383 | | C J4SAVE saves and recalls several global variables needed |
| 384 | | C by the library error handling routines. |
| 385 | | C |
| 386 | | C Description of Parameters |
| 387 | | C --Input-- |
| 388 | | C IWHICH - Index of item desired. |
| 389 | | C = 1 Refers to current error number. |
| 390 | | C = 2 Refers to current error control flag. |
| 391 | | C = 3 Refers to current unit number to which error |
| 392 | | C messages are to be sent. (0 means use standard.) |
| 393 | | C = 4 Refers to the maximum number of times any |
| 394 | | C message is to be printed (as set by XERMAX). |
| 395 | | C = 5 Refers to the total number of units to which |
| 396 | | C each error message is to be written. |
| 397 | | C = 6 Refers to the 2nd unit for error messages |
| 398 | | C = 7 Refers to the 3rd unit for error messages |
| 399 | | C = 8 Refers to the 4th unit for error messages |
| 400 | | C = 9 Refers to the 5th unit for error messages |
| 401 | | C IVALUE - The value to be set for the IWHICH-th parameter, |
| 402 | | C if ISET is .TRUE. . |
| 403 | | C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE |
| 404 | | C given the value, IVALUE. If ISET=.FALSE., the |
| 405 | | C IWHICH-th parameter will be unchanged, and IVALUE |
| 406 | | C is a dummy parameter. |
| 407 | | C --Output-- |
| 408 | | C The (old) value of the IWHICH-th parameter will be returned |
| 409 | | C in the function value, J4SAVE. |
| 410 | | C |
| 411 | | C Written by Ron Jones, with SLATEC Common Math Library Subcommittee |
| 412 | | C Adapted from Bell Laboratories PORT Library Error Handler |
| 413 | | C Latest revision --- 23 MAY 1979 |
| 414 | | C***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- |
| 415 | | C HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, |
| 416 | | C 1982. |
| 417 | | C***ROUTINES CALLED (NONE) |
| 418 | | C***END PROLOGUE J4SAVE |
| 419 | | LOGICAL ISET |
| 420 | | INTEGER IPARAM(9) |
| 421 | | SAVE IPARAM |
| 422 | | DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ |
| 423 | | DATA IPARAM(5)/1/ |
| 424 | | DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ |
| 425 | | C***FIRST EXECUTABLE STATEMENT J4SAVE |
| 426 | | J4SAVE = IPARAM(IWHICH) |
| 427 | | IF (ISET) IPARAM(IWHICH) = IVALUE |
| 428 | | RETURN |
| 429 | | END |
| 430 | | SUBROUTINE XERABT(MESSG,NMESSG) |
| 431 | | C***BEGIN PROLOGUE XERABT |
| 432 | | C***DATE WRITTEN 790801 (YYMMDD) |
| 433 | | C***REVISION DATE 820801 (YYMMDD) |
| 434 | | C***CATEGORY NO. R3C |
| 435 | | C***KEYWORDS ERROR,XERROR PACKAGE |
| 436 | | C***AUTHOR JONES, R. E., (SNLA) |
| 437 | | C***PURPOSE Aborts program execution and prints error message. |
| 438 | | C***DESCRIPTION |
| 439 | | C Abstract |
| 440 | | C ***Note*** machine dependent routine |
| 441 | | C XERABT aborts the execution of the program. |
| 442 | | C The error message causing the abort is given in the calling |
| 443 | | C sequence, in case one needs it for printing on a dayfile, |
| 444 | | C for example. |
| 445 | | C |
| 446 | | C Description of Parameters |
| 447 | | C MESSG and NMESSG are as in XERROR, except that NMESSG may |
| 448 | | C be zero, in which case no message is being supplied. |
| 449 | | C |
| 450 | | C Written by Ron Jones, with SLATEC Common Math Library Subcommittee |
| 451 | | C Latest revision --- 19 MAR 1980 |
| 452 | | C***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- |
| 453 | | C HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, |
| 454 | | C 1982. |
| 455 | | C***ROUTINES CALLED (NONE) |
| 456 | | C***END PROLOGUE XERABT |
| 457 | | CHARACTER*(*) MESSG |
| 458 | | C***FIRST EXECUTABLE STATEMENT XERABT |
| 459 | | STOP |
| 460 | | END |
| 461 | | SUBROUTINE XERCTL(MESSG1,NMESSG,NERR,LEVEL,KONTRL) |
| 462 | | C***BEGIN PROLOGUE XERCTL |
| 463 | | C***DATE WRITTEN 790801 (YYMMDD) |
| 464 | | C***REVISION DATE 820801 (YYMMDD) |
| 465 | | C***CATEGORY NO. R3C |
| 466 | | C***KEYWORDS ERROR,XERROR PACKAGE |
| 467 | | C***AUTHOR JONES, R. E., (SNLA) |
| 468 | | C***PURPOSE Allows user control over handling of individual errors. |
| 469 | | C***DESCRIPTION |
| 470 | | C Abstract |
| 471 | | C Allows user control over handling of individual errors. |
| 472 | | C Just after each message is recorded, but before it is |
| 473 | | C processed any further (i.e., before it is printed or |
| 474 | | C a decision to abort is made), a call is made to XERCTL. |
| 475 | | C If the user has provided his own version of XERCTL, he |
| 476 | | C can then override the value of KONTROL used in processing |
| 477 | | C this message by redefining its value. |
| 478 | | C KONTRL may be set to any value from -2 to 2. |
| 479 | | C The meanings for KONTRL are the same as in XSETF, except |
| 480 | | C that the value of KONTRL changes only for this message. |
| 481 | | C If KONTRL is set to a value outside the range from -2 to 2, |
| 482 | | C it will be moved back into that range. |
| 483 | | C |
| 484 | | C Description of Parameters |
| 485 | | C |
| 486 | | C --Input-- |
| 487 | | C MESSG1 - the first word (only) of the error message. |
| 488 | | C NMESSG - same as in the call to XERROR or XERRWV. |
| 489 | | C NERR - same as in the call to XERROR or XERRWV. |
| 490 | | C LEVEL - same as in the call to XERROR or XERRWV. |
| 491 | | C KONTRL - the current value of the control flag as set |
| 492 | | C by a call to XSETF. |
| 493 | | C |
| 494 | | C --Output-- |
| 495 | | C KONTRL - the new value of KONTRL. If KONTRL is not |
| 496 | | C defined, it will remain at its original value. |
| 497 | | C This changed value of control affects only |
| 498 | | C the current occurrence of the current message. |
| 499 | | C***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- |
| 500 | | C HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, |
| 501 | | C 1982. |
| 502 | | C***ROUTINES CALLED (NONE) |
| 503 | | C***END PROLOGUE XERCTL |
| 504 | | CHARACTER*20 MESSG1 |
| 505 | | C***FIRST EXECUTABLE STATEMENT XERCTL |
| 506 | | RETURN |
| 507 | | END |
| 508 | | SUBROUTINE XERPRT(MESSG,NMESSG) |
| 509 | | C***BEGIN PROLOGUE XERPRT |
| 510 | | C***DATE WRITTEN 790801 (YYMMDD) |
| 511 | | C***REVISION DATE 820801 (YYMMDD) |
| 512 | | C***CATEGORY NO. Z |
| 513 | | C***KEYWORDS ERROR,XERROR PACKAGE |
| 514 | | C***AUTHOR JONES, R. E., (SNLA) |
| 515 | | C***PURPOSE Prints error messages. |
| 516 | | C***DESCRIPTION |
| 517 | | C Abstract |
| 518 | | C Print the Hollerith message in MESSG, of length NMESSG, |
| 519 | | C on each file indicated by XGETUA. |
| 520 | | C Latest revision --- 19 MAR 1980 |
| 521 | | C***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- |
| 522 | | C HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, |
| 523 | | C 1982. |
| 524 | | C***ROUTINES CALLED I1MACH,S88FMT,XGETUA |
| 525 | | C***END PROLOGUE XERPRT |
| 526 | | INTEGER LUN(5) |
| 527 | | CHARACTER*(*) MESSG |
| 528 | | C OBTAIN UNIT NUMBERS AND WRITE LINE TO EACH UNIT |
| 529 | | C***FIRST EXECUTABLE STATEMENT XERPRT |
| 530 | | CALL XGETUA(LUN,NUNIT) |
| 531 | | LENMES = LEN(MESSG) |
| 532 | | DO 20 KUNIT=1,NUNIT |
| 533 | | IUNIT = LUN(KUNIT) |
| 534 | | IF (IUNIT.EQ.0) IUNIT = I1MACH(4) |
| 535 | | DO 10 ICHAR=1,LENMES,72 |
| 536 | | LAST = MIN0(ICHAR+71 , LENMES) |
| 537 | | WRITE (IUNIT,'(1X,A)') MESSG(ICHAR:LAST) |
| 538 | | 10 CONTINUE |
| 539 | | 20 CONTINUE |
| 540 | | RETURN |
| 541 | | END |
