Mercurial > hg > octave-thorsten
diff libcruft/slatec-err/xerrwd.f @ 3912:f56cd411adb4
[project @ 2002-04-28 03:12:27 by jwe]
author | jwe |
---|---|
date | Sun, 28 Apr 2002 03:12:28 +0000 |
parents | |
children | 5b781670e9ee |
line wrap: on
line diff
new file mode 100644 --- /dev/null +++ b/libcruft/slatec-err/xerrwd.f @@ -0,0 +1,97 @@ + +*DECK XERRWD + SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) +C***BEGIN PROLOGUE XERRWD +C***SUBSIDIARY +C***PURPOSE Write error message with values. +C***LIBRARY MATHLIB +C***CATEGORY R3C +C***TYPE DOUBLE PRECISION (XERRWV-S, XERRWD-D) +C***AUTHOR Hindmarsh, Alan C., (LLNL) +C***DESCRIPTION +C +C Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV, +C as given here, constitute a simplified version of the SLATEC error +C handling package. +C +C All arguments are input arguments. +C +C MSG = The message (character array). +C NMES = The length of MSG (number of characters). +C NERR = The error number (not used). +C LEVEL = The error level.. +C 0 or 1 means recoverable (control returns to caller). +C 2 means fatal (run is aborted--see note below). +C NI = Number of integers (0, 1, or 2) to be printed with message. +C I1,I2 = Integers to be printed, depending on NI. +C NR = Number of reals (0, 1, or 2) to be printed with message. +C R1,R2 = Reals to be printed, depending on NR. +C +C Note.. this routine is machine-dependent and specialized for use +C in limited context, in the following ways.. +C 1. The argument MSG is assumed to be of type CHARACTER, and +C the message is printed with a format of (1X,A). +C 2. The message is assumed to take only one line. +C Multi-line messages are generated by repeated calls. +C 3. If LEVEL = 2, control passes to the statement STOP +C to abort the run. This statement may be machine-dependent. +C 4. R1 and R2 are assumed to be in double precision and are printed +C in D21.13 format. +C +C***ROUTINES CALLED IXSAV +C***REVISION HISTORY (YYMMDD) +C 920831 DATE WRITTEN +C 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH) +C 930329 Modified prologue to SLATEC format. (FNF) +C 930407 Changed MSG from CHARACTER*1 array to variable. (FNF) +C 930922 Minor cosmetic change. (FNF) +C***END PROLOGUE XERRWD +C +C*Internal Notes: +C +C For a different default logical unit number, IXSAV (or a subsidiary +C routine that it calls) will need to be modified. +C For a different run-abort command, change the statement following +C statement 100 at the end. +C----------------------------------------------------------------------- +C Subroutines called by XERRWD.. None +C Function routine called by XERRWD.. IXSAV +C----------------------------------------------------------------------- +C**End +C +C Declare arguments. +C + DOUBLE PRECISION R1, R2 + INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR + CHARACTER*(*) MSG +C +C Declare local variables. +C + INTEGER LUNIT, IXSAV, MESFLG +C +C Get logical unit number and message print flag. +C +C***FIRST EXECUTABLE STATEMENT XERRWD + LUNIT = IXSAV (1, 0, .FALSE.) + MESFLG = IXSAV (2, 0, .FALSE.) + IF (MESFLG .EQ. 0) GO TO 100 +C +C Write the message. +C + WRITE (LUNIT,10) MSG + 10 FORMAT(1X,A) + IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 + 20 FORMAT(6X,'In above message, I1 =',I10) + IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 + 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) + IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 + 40 FORMAT(6X,'In above message, R1 =',D21.13) + IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 + 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) +C +C Abort the run if LEVEL = 2. +C + 100 IF (LEVEL .NE. 2) RETURN + STOP +C----------------------- End of Subroutine XERRWD ---------------------- + END