1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
*> \brief \b XERBLA
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE XERBLA( SRNAME, INFO )
*
* .. Scalar Arguments ..
* CHARACTER*(*) SRNAME
* INTEGER INFO
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> This is a special version of XERBLA to be used only as part of
*> the test program for testing error exits from the LAPACK routines.
*> Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRNAMT,
*> where INFOT and SRNAMT are values stored in COMMON.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SRNAME
*> \verbatim
*> SRNAME is CHARACTER*(*)
*> The name of the subroutine calling XERBLA. This name should
*> match the COMMON variable SRNAMT.
*> \endverbatim
*>
*> \param[in] INFO
*> \verbatim
*> INFO is INTEGER
*> The error return code from the calling subroutine. INFO
*> should equal the COMMON variable INFOT.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup aux_eig
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The following variables are passed via the common blocks INFOC and
*> SRNAMC:
*>
*> INFOT INTEGER Expected integer return code
*> NOUT INTEGER Unit number for printing error messages
*> OK LOGICAL Set to .TRUE. if INFO = INFOT and
*> SRNAME = SRNAMT, otherwise set to .FALSE.
*> LERR LOGICAL Set to .TRUE., indicating that XERBLA was called
*> SRNAMT CHARACTER*(*) Expected name of calling subroutine
*> \endverbatim
*>
* =====================================================================
SUBROUTINE XERBLA( SRNAME, INFO )
*
* -- LAPACK test routine (version 3.4.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* November 2011
*
* .. Scalar Arguments ..
CHARACTER*(*) SRNAME
INTEGER INFO
* ..
*
* =====================================================================
*
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*32 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Intrinsic Functions ..
INTRINSIC LEN_TRIM
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
LERR = .TRUE.
IF( INFO.NE.INFOT ) THEN
IF( INFOT.NE.0 ) THEN
WRITE( NOUT, FMT = 9999 )
$ SRNAMT( 1:LEN_TRIM( SRNAMT ) ), INFO, INFOT
ELSE
WRITE( NOUT, FMT = 9997 )
$ SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
END IF
OK = .FALSE.
END IF
IF( SRNAME.NE.SRNAMT ) THEN
WRITE( NOUT, FMT = 9998 )
$ SRNAME( 1:LEN_TRIM( SRNAME ) ),
$ SRNAMT( 1:LEN_TRIM( SRNAMT ) )
OK = .FALSE.
END IF
RETURN
*
9999 FORMAT( ' *** XERBLA was called from ', A, ' with INFO = ', I6,
$ ' instead of ', I2, ' ***' )
9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A,
$ ' instead of ', A6, ' ***' )
9997 FORMAT( ' *** On entry to ', A, ' parameter number ', I6,
$ ' had an illegal value ***' )
*
* End of XERBLA
*
END
|
