Mercurial > octave-nkf
view libcruft/dasrt/dasrt_xerrwv.f @ 4039:e82257ed348c
[project @ 2002-08-14 19:33:31 by jwe]
author | jwe |
---|---|
date | Wed, 14 Aug 2002 19:33:31 +0000 |
parents | |
children |
line wrap: on
line source
SUBROUTINE DASRT_XERRWV (MSG, NMES, NERR, LEVEL, NI, I1, I2, $ NR, R1, R2) INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR DOUBLE PRECISION R1, R2 CHARACTER*1 MSG(NMES) C----------------------------------------------------------------------- C Subroutine XERRWV, as given here, constitutes a simplified version of C the SLATEC error handling package. C Written by A. C. Hindmarsh and P. N. Brown at LLNL. C Modified 1/8/90 by Clement Ulrich at LLNL. C Version of 8 January, 1990. C This version is in double precision. 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 compatible with ANSI-77; however the C following assumptions may not be valid for some machines: C C 1. The argument MSG is assumed to be of type CHARACTER, and C the message is printed with a format of (1X,80A1). 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. For a different run-abort command, C change the statement following statement 100 at the end. C 4. R1 and R2 are assumed to be in double precision and are printed C in E21.13 format. C 5. The logical unit number 6 is standard output. C For a different default logical unit number, change the assignment C statement for LUNIT below. C C----------------------------------------------------------------------- C Subroutines called by XERRWV.. None C Function routines called by XERRWV.. None C----------------------------------------------------------------------- C INTEGER I, LUNIT, MESFLG C C Define message print flag and logical unit number. ------------------- MESFLG = 1 LUNIT = 6 IF (MESFLG .EQ. 0) GO TO 100 C Write the message. --------------------------------------------------- WRITE (LUNIT,10) (MSG(I),I=1,NMES) 10 FORMAT(1X,80A1) 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 =',E21.13) IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 50 FORMAT(6X,'In above, R1 =',E21.13,3X,'R2 =',E21.13) C Abort the run if LEVEL = 2. ------------------------------------------ 100 IF (LEVEL .NE. 2) RETURN STOP C----------------------- End of Subroutine XERRWV ---------------------- END