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