1 SUBROUTINE XERRWV(MESSG,NMESSG,NERR,LEVEL,NI,I1,I2,NR,R1,R2) 2C***BEGIN PROLOGUE XERRWV 3C***DATE WRITTEN 800319 (YYMMDD) 4C***REVISION DATE 820801 (YYMMDD) 5C***CATEGORY NO. R3C 6C***KEYWORDS ERROR,XERROR PACKAGE 7C***AUTHOR JONES, R. E., (SNLA) 8C***PURPOSE Processes error message allowing 2 integer and two real 9C values to be included in the message. 10C***DESCRIPTION 11C Abstract 12C XERRWV processes a diagnostic message, in a manner 13C determined by the value of LEVEL and the current value 14C of the library error control flag, KONTRL. 15C (See subroutine XSETF for details.) 16C In addition, up to two integer values and two real 17C values may be printed along with the message. 18C 19C Description of Parameters 20C --Input-- 21C MESSG - the Hollerith message to be processed. 22C NMESSG- the actual number of characters in MESSG. 23C NERR - the error number associated with this message. 24C NERR must not be zero. 25C LEVEL - error category. 26C =2 means this is an unconditionally fatal error. 27C =1 means this is a recoverable error. (I.e., it is 28C non-fatal if XSETF has been appropriately called.) 29C =0 means this is a warning message only. 30C =-1 means this is a warning message which is to be 31C printed at most once, regardless of how many 32C times this call is executed. 33C NI - number of integer values to be printed. (0 to 2) 34C I1 - first integer value. 35C I2 - second integer value. 36C NR - number of real values to be printed. (0 to 2) 37C R1 - first real value. 38C R2 - second real value. 39C 40C Examples 41C CALL XERRWV('SMOOTH -- NUM (=I1) WAS ZERO.',29,1,2, 42C 1 1,NUM,0,0,0.,0.) 43C CALL XERRWV('QUADXY -- REQUESTED ERROR (R1) LESS THAN MINIMUM ( 44C 1R2).,54,77,1,0,0,0,2,ERRREQ,ERRMIN) 45C 46C Latest revision --- 19 MAR 1980 47C Written by Ron Jones, with SLATEC Common Math Library Subcommittee 48C***REFERENCES JONES R.E., KAHANER D.K., "XERROR, THE SLATEC ERROR- 49C HANDLING PACKAGE", SAND82-0800, SANDIA LABORATORIES, 50C 1982. 51C***ROUTINES CALLED FDUMP,I1MACH,J4SAVE,XERABT,XERCTL,XERPRT,XERSAV, 52C XGETUA 53C***END PROLOGUE XERRWV 54 CHARACTER*(*) MESSG 55 CHARACTER*20 LFIRST 56 CHARACTER*37 FORM 57 DIMENSION LUN(5) 58C GET FLAGS 59C***FIRST EXECUTABLE STATEMENT XERRWV 60 LKNTRL = J4SAVE(2,0,.FALSE.) 61 MAXMES = J4SAVE(4,0,.FALSE.) 62C CHECK FOR VALID INPUT 63 IF ((NMESSG.GT.0).AND.(NERR.NE.0).AND. 64 1 (LEVEL.GE.(-1)).AND.(LEVEL.LE.2)) GO TO 10 65 IF (LKNTRL.GT.0) CALL XERPRT('FATAL ERROR IN...',17) 66 CALL XERPRT('XERROR -- INVALID INPUT',23) 67 IF (LKNTRL.GT.0) CALL FDUMP 68 IF (LKNTRL.GT.0) CALL XERPRT('JOB ABORT DUE TO FATAL ERROR.', 69 1 29) 70 IF (LKNTRL.GT.0) CALL XERSAV(' ',0,0,0,KDUMMY) 71 CALL XERABT('XERROR -- INVALID INPUT',23) 72 RETURN 73 10 CONTINUE 74C RECORD MESSAGE 75 JUNK = J4SAVE(1,NERR,.TRUE.) 76 CALL XERSAV(MESSG,NMESSG,NERR,LEVEL,KOUNT) 77C LET USER OVERRIDE 78 LFIRST = MESSG 79 LMESSG = NMESSG 80 LERR = NERR 81 LLEVEL = LEVEL 82 CALL XERCTL(LFIRST,LMESSG,LERR,LLEVEL,LKNTRL) 83C RESET TO ORIGINAL VALUES 84 LMESSG = NMESSG 85 LERR = NERR 86 LLEVEL = LEVEL 87 LKNTRL = MAX0(-2,MIN0(2,LKNTRL)) 88 MKNTRL = IABS(LKNTRL) 89C DECIDE WHETHER TO PRINT MESSAGE 90 IF ((LLEVEL.LT.2).AND.(LKNTRL.EQ.0)) GO TO 100 91 IF (((LLEVEL.EQ.(-1)).AND.(KOUNT.GT.MIN0(1,MAXMES))) 92 1.OR.((LLEVEL.EQ.0) .AND.(KOUNT.GT.MAXMES)) 93 2.OR.((LLEVEL.EQ.1) .AND.(KOUNT.GT.MAXMES).AND.(MKNTRL.EQ.1)) 94 3.OR.((LLEVEL.EQ.2) .AND.(KOUNT.GT.MAX0(1,MAXMES)))) GO TO 100 95 IF (LKNTRL.LE.0) GO TO 20 96 CALL XERPRT(' ',1) 97C INTRODUCTION 98 IF (LLEVEL.EQ.(-1)) CALL XERPRT 99 1('WARNING MESSAGE...THIS MESSAGE WILL ONLY BE PRINTED ONCE.',57) 100 IF (LLEVEL.EQ.0) CALL XERPRT('WARNING IN...',13) 101 IF (LLEVEL.EQ.1) CALL XERPRT 102 1 ('RECOVERABLE ERROR IN...',23) 103 IF (LLEVEL.EQ.2) CALL XERPRT('FATAL ERROR IN...',17) 104 20 CONTINUE 105C MESSAGE 106 CALL XERPRT(MESSG,LMESSG) 107 CALL XGETUA(LUN,NUNIT) 108 ISIZEI = LOG10(FLOAT(I1MACH(9))) + 1.0 109 ISIZEF = LOG10(FLOAT(I1MACH(10))**I1MACH(11)) + 1.0 110 DO 50 KUNIT=1,NUNIT 111 IUNIT = LUN(KUNIT) 112 IF (IUNIT.EQ.0) IUNIT = I1MACH(4) 113 DO 22 I=1,MIN(NI,2) 114 WRITE (FORM,21) I,ISIZEI 115 21 FORMAT ('(11X,21HIN ABOVE MESSAGE, I',I1,'=,I',I2,') ') 116 IF (I.EQ.1) WRITE (IUNIT,FORM) I1 117 IF (I.EQ.2) WRITE (IUNIT,FORM) I2 118 22 CONTINUE 119 DO 24 I=1,MIN(NR,2) 120 WRITE (FORM,23) I,ISIZEF+10,ISIZEF 121 23 FORMAT ('(11X,21HIN ABOVE MESSAGE, R',I1,'=,E', 122 1 I2,'.',I2,')') 123 IF (I.EQ.1) WRITE (IUNIT,FORM) R1 124 IF (I.EQ.2) WRITE (IUNIT,FORM) R2 125 24 CONTINUE 126 IF (LKNTRL.LE.0) GO TO 40 127C ERROR NUMBER 128 WRITE (IUNIT,30) LERR 129 30 FORMAT (15H ERROR NUMBER =,I10) 130 40 CONTINUE 131 50 CONTINUE 132C TRACE-BACK 133 IF (LKNTRL.GT.0) CALL FDUMP 134 100 CONTINUE 135 IFATAL = 0 136 IF ((LLEVEL.EQ.2).OR.((LLEVEL.EQ.1).AND.(MKNTRL.EQ.2))) 137 1IFATAL = 1 138C QUIT HERE IF MESSAGE IS NOT FATAL 139 IF (IFATAL.LE.0) RETURN 140 IF ((LKNTRL.LE.0).OR.(KOUNT.GT.MAX0(1,MAXMES))) GO TO 120 141C PRINT REASON FOR ABORT 142 IF (LLEVEL.EQ.1) CALL XERPRT 143 1 ('JOB ABORT DUE TO UNRECOVERED ERROR.',35) 144 IF (LLEVEL.EQ.2) CALL XERPRT 145 1 ('JOB ABORT DUE TO FATAL ERROR.',29) 146C PRINT ERROR SUMMARY 147 CALL XERSAV(' ',-1,0,0,KDUMMY) 148 120 CONTINUE 149C ABORT 150 IF ((LLEVEL.EQ.2).AND.(KOUNT.GT.MAX0(1,MAXMES))) LMESSG = 0 151 CALL XERABT(MESSG,LMESSG) 152 RETURN 153 END 154