Changeset 1084:461cbc347ff9

Show
Ignore:
Timestamp:
02/20/11 12:05:32 (3 years ago)
Author:
rtoy
Branch:
default
Message:

Split xerror.f into one function per file.

quadpack.asd:
o Update defsystem to include the new files.

xerror.f:
o Split into one function per file.

Location:
packages
Files:
8 added
2 modified

Legend:

Unmodified
Added
Removed
  • packages/quadpack.asd

    r1082 r1084  
    102102             (:file "dqwgtc") 
    103103             (:file "dgtsl") 
    104              (:file "xerror") 
    105                 
     104             (:file "xerror" 
     105                    :depends-on ("xerrwv" "j4save" "xerprt" "xersav" 
     106                                          "xerctl" "xgetua" "xersav")) 
     107 
     108             ;; Support routines for xerror 
     109             (:file "xerrwv" 
     110                    :depends-on ("xerabt")) 
     111             (:file "xersav") 
     112             (:file "xgetua" 
     113                    :depends-on ("j4save")) 
     114             (:file "fdump") 
     115             (:file "j4save") 
     116             (:file "xerabt") 
     117             (:file "xerprt") 
     118             (:file "xerctl") 
     119              
    106120             ;; Core integration routines 
    107121             (:file "dqk15") 
  • packages/quadpack/Fortran/xerror.f

    r100 r1084  
    5050      RETURN 
    5151      END 
    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