LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
cerrbd.f
Go to the documentation of this file.
1 *> \brief \b CERRBD
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 CERRBD( PATH, NUNIT )
12 *
13 * .. Scalar Arguments ..
14 * CHARACTER*3 PATH
15 * INTEGER NUNIT
16 * ..
17 *
18 *
19 *> \par Purpose:
20 * =============
21 *>
22 *> \verbatim
23 *>
24 *> CERRBD tests the error exits for CGEBRD, CUNGBR, CUNMBR, and CBDSQR.
25 *> \endverbatim
26 *
27 * Arguments:
28 * ==========
29 *
30 *> \param[in] PATH
31 *> \verbatim
32 *> PATH is CHARACTER*3
33 *> The LAPACK path name for the routines to be tested.
34 *> \endverbatim
35 *>
36 *> \param[in] NUNIT
37 *> \verbatim
38 *> NUNIT is INTEGER
39 *> The unit number for output.
40 *> \endverbatim
41 *
42 * Authors:
43 * ========
44 *
45 *> \author Univ. of Tennessee
46 *> \author Univ. of California Berkeley
47 *> \author Univ. of Colorado Denver
48 *> \author NAG Ltd.
49 *
50 *> \date November 2011
51 *
52 *> \ingroup complex_eig
53 *
54 * =====================================================================
55  SUBROUTINE cerrbd( PATH, NUNIT )
56 *
57 * -- LAPACK test routine (version 3.4.0) --
58 * -- LAPACK is a software package provided by Univ. of Tennessee, --
59 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
60 * November 2011
61 *
62 * .. Scalar Arguments ..
63  CHARACTER*3 path
64  INTEGER nunit
65 * ..
66 *
67 * =====================================================================
68 *
69 * .. Parameters ..
70  INTEGER nmax, lw
71  parameter( nmax = 4, lw = nmax )
72 * ..
73 * .. Local Scalars ..
74  CHARACTER*2 c2
75  INTEGER i, info, j, nt
76 * ..
77 * .. Local Arrays ..
78  REAL d( nmax ), e( nmax ), rw( 4*nmax )
79  COMPLEX a( nmax, nmax ), tp( nmax ), tq( nmax ),
80  $ u( nmax, nmax ), v( nmax, nmax ), w( lw )
81 * ..
82 * .. External Functions ..
83  LOGICAL lsamen
84  EXTERNAL lsamen
85 * ..
86 * .. External Subroutines ..
87  EXTERNAL cbdsqr, cgebrd, chkxer, cungbr, cunmbr
88 * ..
89 * .. Scalars in Common ..
90  LOGICAL lerr, ok
91  CHARACTER*32 srnamt
92  INTEGER infot, nout
93 * ..
94 * .. Common blocks ..
95  common / infoc / infot, nout, ok, lerr
96  common / srnamc / srnamt
97 * ..
98 * .. Intrinsic Functions ..
99  INTRINSIC real
100 * ..
101 * .. Executable Statements ..
102 *
103  nout = nunit
104  WRITE( nout, fmt = * )
105  c2 = path( 2: 3 )
106 *
107 * Set the variables to innocuous values.
108 *
109  DO 20 j = 1, nmax
110  DO 10 i = 1, nmax
111  a( i, j ) = 1. / REAL( i+j )
112  10 continue
113  20 continue
114  ok = .true.
115  nt = 0
116 *
117 * Test error exits of the SVD routines.
118 *
119  IF( lsamen( 2, c2, 'BD' ) ) THEN
120 *
121 * CGEBRD
122 *
123  srnamt = 'CGEBRD'
124  infot = 1
125  CALL cgebrd( -1, 0, a, 1, d, e, tq, tp, w, 1, info )
126  CALL chkxer( 'CGEBRD', infot, nout, lerr, ok )
127  infot = 2
128  CALL cgebrd( 0, -1, a, 1, d, e, tq, tp, w, 1, info )
129  CALL chkxer( 'CGEBRD', infot, nout, lerr, ok )
130  infot = 4
131  CALL cgebrd( 2, 1, a, 1, d, e, tq, tp, w, 2, info )
132  CALL chkxer( 'CGEBRD', infot, nout, lerr, ok )
133  infot = 10
134  CALL cgebrd( 2, 1, a, 2, d, e, tq, tp, w, 1, info )
135  CALL chkxer( 'CGEBRD', infot, nout, lerr, ok )
136  nt = nt + 4
137 *
138 * CUNGBR
139 *
140  srnamt = 'CUNGBR'
141  infot = 1
142  CALL cungbr( '/', 0, 0, 0, a, 1, tq, w, 1, info )
143  CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
144  infot = 2
145  CALL cungbr( 'Q', -1, 0, 0, a, 1, tq, w, 1, info )
146  CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
147  infot = 3
148  CALL cungbr( 'Q', 0, -1, 0, a, 1, tq, w, 1, info )
149  CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
150  infot = 3
151  CALL cungbr( 'Q', 0, 1, 0, a, 1, tq, w, 1, info )
152  CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
153  infot = 3
154  CALL cungbr( 'Q', 1, 0, 1, a, 1, tq, w, 1, info )
155  CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
156  infot = 3
157  CALL cungbr( 'P', 1, 0, 0, a, 1, tq, w, 1, info )
158  CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
159  infot = 3
160  CALL cungbr( 'P', 0, 1, 1, a, 1, tq, w, 1, info )
161  CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
162  infot = 4
163  CALL cungbr( 'Q', 0, 0, -1, a, 1, tq, w, 1, info )
164  CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
165  infot = 6
166  CALL cungbr( 'Q', 2, 1, 1, a, 1, tq, w, 1, info )
167  CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
168  infot = 9
169  CALL cungbr( 'Q', 2, 2, 1, a, 2, tq, w, 1, info )
170  CALL chkxer( 'CUNGBR', infot, nout, lerr, ok )
171  nt = nt + 10
172 *
173 * CUNMBR
174 *
175  srnamt = 'CUNMBR'
176  infot = 1
177  CALL cunmbr( '/', 'L', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
178  $ info )
179  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
180  infot = 2
181  CALL cunmbr( 'Q', '/', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
182  $ info )
183  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
184  infot = 3
185  CALL cunmbr( 'Q', 'L', '/', 0, 0, 0, a, 1, tq, u, 1, w, 1,
186  $ info )
187  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
188  infot = 4
189  CALL cunmbr( 'Q', 'L', 'C', -1, 0, 0, a, 1, tq, u, 1, w, 1,
190  $ info )
191  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
192  infot = 5
193  CALL cunmbr( 'Q', 'L', 'C', 0, -1, 0, a, 1, tq, u, 1, w, 1,
194  $ info )
195  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
196  infot = 6
197  CALL cunmbr( 'Q', 'L', 'C', 0, 0, -1, a, 1, tq, u, 1, w, 1,
198  $ info )
199  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
200  infot = 8
201  CALL cunmbr( 'Q', 'L', 'C', 2, 0, 0, a, 1, tq, u, 2, w, 1,
202  $ info )
203  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
204  infot = 8
205  CALL cunmbr( 'Q', 'R', 'C', 0, 2, 0, a, 1, tq, u, 1, w, 1,
206  $ info )
207  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
208  infot = 8
209  CALL cunmbr( 'P', 'L', 'C', 2, 0, 2, a, 1, tq, u, 2, w, 1,
210  $ info )
211  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
212  infot = 8
213  CALL cunmbr( 'P', 'R', 'C', 0, 2, 2, a, 1, tq, u, 1, w, 1,
214  $ info )
215  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
216  infot = 11
217  CALL cunmbr( 'Q', 'R', 'C', 2, 0, 0, a, 1, tq, u, 1, w, 1,
218  $ info )
219  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
220  infot = 13
221  CALL cunmbr( 'Q', 'L', 'C', 0, 2, 0, a, 1, tq, u, 1, w, 0,
222  $ info )
223  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
224  infot = 13
225  CALL cunmbr( 'Q', 'R', 'C', 2, 0, 0, a, 1, tq, u, 2, w, 0,
226  $ info )
227  CALL chkxer( 'CUNMBR', infot, nout, lerr, ok )
228  nt = nt + 13
229 *
230 * CBDSQR
231 *
232  srnamt = 'CBDSQR'
233  infot = 1
234  CALL cbdsqr( '/', 0, 0, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
235  $ info )
236  CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
237  infot = 2
238  CALL cbdsqr( 'U', -1, 0, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
239  $ info )
240  CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
241  infot = 3
242  CALL cbdsqr( 'U', 0, -1, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
243  $ info )
244  CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
245  infot = 4
246  CALL cbdsqr( 'U', 0, 0, -1, 0, d, e, v, 1, u, 1, a, 1, rw,
247  $ info )
248  CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
249  infot = 5
250  CALL cbdsqr( 'U', 0, 0, 0, -1, d, e, v, 1, u, 1, a, 1, rw,
251  $ info )
252  CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
253  infot = 9
254  CALL cbdsqr( 'U', 2, 1, 0, 0, d, e, v, 1, u, 1, a, 1, rw,
255  $ info )
256  CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
257  infot = 11
258  CALL cbdsqr( 'U', 0, 0, 2, 0, d, e, v, 1, u, 1, a, 1, rw,
259  $ info )
260  CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
261  infot = 13
262  CALL cbdsqr( 'U', 2, 0, 0, 1, d, e, v, 1, u, 1, a, 1, rw,
263  $ info )
264  CALL chkxer( 'CBDSQR', infot, nout, lerr, ok )
265  nt = nt + 8
266  END IF
267 *
268 * Print a summary line.
269 *
270  IF( ok ) THEN
271  WRITE( nout, fmt = 9999 )path, nt
272  ELSE
273  WRITE( nout, fmt = 9998 )path
274  END IF
275 *
276  9999 format( 1x, a3, ' routines passed the tests of the error exits (',
277  $ i3, ' tests done)' )
278  9998 format( ' *** ', a3, ' routines failed the tests of the error ',
279  $ 'exits ***' )
280 *
281  return
282 *
283 * End of CERRBD
284 *
285  END