Changeset 1084:461cbc347ff9


Ignore:
Timestamp:
02/20/11 20:05:32 (4 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 edited

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
Note: See TracChangeset for help on using the changeset viewer.