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