1 SUBROUTINE XERBLA( SRNAME, INFO )
2 *
3 * -- LAPACK auxiliary routine (version 3.1) --
4 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
5 * November 2006
6 *
7 * .. Scalar Arguments ..
8 CHARACTER*(*) SRNAME
9 INTEGER INFO
10 * ..
11 *
12 * Purpose
13 * =======
14 *
15 * This is a special version of XERBLA to be used only as part of
16 * the test program for testing error exits from the LAPACK routines.
17 * Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRMANT,
18 * where INFOT and SRNAMT are values stored in COMMON.
19 *
20 * Arguments
21 * =========
22 *
23 * SRNAME (input) CHARACTER*(*)
24 * The name of the subroutine calling XERBLA. This name should
25 * match the COMMON variable SRNAMT.
26 *
27 * INFO (input) INTEGER
28 * The error return code from the calling subroutine. INFO
29 * should equal the COMMON variable INFOT.
30 *
31 * Further Details
32 * ======= =======
33 *
34 * The following variables are passed via the common blocks INFOC and
35 * SRNAMC:
36 *
37 * INFOT INTEGER Expected integer return code
38 * NOUT INTEGER Unit number for printing error messages
39 * OK LOGICAL Set to .TRUE. if INFO = INFOT and
40 * SRNAME = SRNAMT, otherwise set to .FALSE.
41 * LERR LOGICAL Set to .TRUE., indicating that XERBLA was called
42 * SRNAMT CHARACTER*(*) Expected name of calling subroutine
43 *
44 *
45 * .. Scalars in Common ..
46 LOGICAL LERR, OK
47 CHARACTER*32 SRNAMT
48 INTEGER INFOT, NOUT
49 * ..
50 * .. Intrinsic Functions ..
51 INTRINSIC LEN_TRIM
52 * ..
53 * .. Common blocks ..
54 COMMON / INFOC / INFOT, NOUT, OK, LERR
55 COMMON / SRNAMC / SRNAMT
56 * ..
57 * .. Executable Statements ..
58 *
59 LERR = .TRUE.
60 IF( INFO.NE.INFOT ) THEN
61 IF( INFOT.NE.0 ) THEN
62 WRITE( NOUT, FMT = 9999 )
63 $ SRNAMT( 1:LEN_TRIM( SRNAMT ) ), INFO, INFOT
64 ELSE
65 WRITE( NOUT, FMT = 9997 )
66 $ SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
67 END IF
68 OK = .FALSE.
69 END IF
70 IF( SRNAME.NE.SRNAMT ) THEN
71 WRITE( NOUT, FMT = 9998 )
72 $ SRNAME( 1:LEN_TRIM( SRNAME ) ),
73 $ SRNAMT( 1:LEN_TRIM( SRNAMT ) )
74 OK = .FALSE.
75 END IF
76 RETURN
77 *
78 9999 FORMAT( ' *** XERBLA was called from ', A, ' with INFO = ', I6,
79 $ ' instead of ', I2, ' ***' )
80 9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A,
81 $ ' instead of ', A6, ' ***' )
82 9997 FORMAT( ' *** On entry to ', A, ' parameter number ', I6,
83 $ ' had an illegal value ***' )
84 *
85 * End of XERBLA
86 *
87 END
2 *
3 * -- LAPACK auxiliary routine (version 3.1) --
4 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
5 * November 2006
6 *
7 * .. Scalar Arguments ..
8 CHARACTER*(*) SRNAME
9 INTEGER INFO
10 * ..
11 *
12 * Purpose
13 * =======
14 *
15 * This is a special version of XERBLA to be used only as part of
16 * the test program for testing error exits from the LAPACK routines.
17 * Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRMANT,
18 * where INFOT and SRNAMT are values stored in COMMON.
19 *
20 * Arguments
21 * =========
22 *
23 * SRNAME (input) CHARACTER*(*)
24 * The name of the subroutine calling XERBLA. This name should
25 * match the COMMON variable SRNAMT.
26 *
27 * INFO (input) INTEGER
28 * The error return code from the calling subroutine. INFO
29 * should equal the COMMON variable INFOT.
30 *
31 * Further Details
32 * ======= =======
33 *
34 * The following variables are passed via the common blocks INFOC and
35 * SRNAMC:
36 *
37 * INFOT INTEGER Expected integer return code
38 * NOUT INTEGER Unit number for printing error messages
39 * OK LOGICAL Set to .TRUE. if INFO = INFOT and
40 * SRNAME = SRNAMT, otherwise set to .FALSE.
41 * LERR LOGICAL Set to .TRUE., indicating that XERBLA was called
42 * SRNAMT CHARACTER*(*) Expected name of calling subroutine
43 *
44 *
45 * .. Scalars in Common ..
46 LOGICAL LERR, OK
47 CHARACTER*32 SRNAMT
48 INTEGER INFOT, NOUT
49 * ..
50 * .. Intrinsic Functions ..
51 INTRINSIC LEN_TRIM
52 * ..
53 * .. Common blocks ..
54 COMMON / INFOC / INFOT, NOUT, OK, LERR
55 COMMON / SRNAMC / SRNAMT
56 * ..
57 * .. Executable Statements ..
58 *
59 LERR = .TRUE.
60 IF( INFO.NE.INFOT ) THEN
61 IF( INFOT.NE.0 ) THEN
62 WRITE( NOUT, FMT = 9999 )
63 $ SRNAMT( 1:LEN_TRIM( SRNAMT ) ), INFO, INFOT
64 ELSE
65 WRITE( NOUT, FMT = 9997 )
66 $ SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
67 END IF
68 OK = .FALSE.
69 END IF
70 IF( SRNAME.NE.SRNAMT ) THEN
71 WRITE( NOUT, FMT = 9998 )
72 $ SRNAME( 1:LEN_TRIM( SRNAME ) ),
73 $ SRNAMT( 1:LEN_TRIM( SRNAMT ) )
74 OK = .FALSE.
75 END IF
76 RETURN
77 *
78 9999 FORMAT( ' *** XERBLA was called from ', A, ' with INFO = ', I6,
79 $ ' instead of ', I2, ' ***' )
80 9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A,
81 $ ' instead of ', A6, ' ***' )
82 9997 FORMAT( ' *** On entry to ', A, ' parameter number ', I6,
83 $ ' had an illegal value ***' )
84 *
85 * End of XERBLA
86 *
87 END