LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
serrbd.f
Go to the documentation of this file.
1*> \brief \b SERRBD
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 SERRBD( 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*> SERRBD tests the error exits for SGEBD2, SGEBRD, SORGBR, SORMBR,
25*> SBDSQR, SBDSDC and SBDSVDX.
26*> \endverbatim
27*
28* Arguments:
29* ==========
30*
31*> \param[in] PATH
32*> \verbatim
33*> PATH is CHARACTER*3
34*> The LAPACK path name for the routines to be tested.
35*> \endverbatim
36*>
37*> \param[in] NUNIT
38*> \verbatim
39*> NUNIT is INTEGER
40*> The unit number for output.
41*> \endverbatim
42*
43* Authors:
44* ========
45*
46*> \author Univ. of Tennessee
47*> \author Univ. of California Berkeley
48*> \author Univ. of Colorado Denver
49*> \author NAG Ltd.
50*
51*> \ingroup single_eig
52*
53* =====================================================================
54 SUBROUTINE serrbd( PATH, NUNIT )
55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX, LW
69 parameter( nmax = 4, lw = nmax )
70 REAL ZERO, ONE
71 parameter( zero = 0.0e0, one = 1.0e0 )
72* ..
73* .. Local Scalars ..
74 CHARACTER*2 C2
75 INTEGER I, INFO, J, NS, NT
76* ..
77* .. Local Arrays ..
78 INTEGER IQ( NMAX, NMAX ), IW( NMAX )
79 REAL A( NMAX, NMAX ), D( NMAX ), E( NMAX ),
80 $ Q( NMAX, NMAX ), S( NMAX ), TP( NMAX ),
81 $ TQ( NMAX ), U( NMAX, NMAX ),
82 $ V( NMAX, NMAX ), W( LW )
83* ..
84* .. External Functions ..
85 LOGICAL LSAMEN
86 EXTERNAL lsamen
87* ..
88* .. External Subroutines ..
89 EXTERNAL chkxer, sbdsdc, sbdsqr, sbdsvdx, sgebd2,
90 $ sgebrd, sorgbr, sormbr
91* ..
92* .. Scalars in Common ..
93 LOGICAL LERR, OK
94 CHARACTER*32 SRNAMT
95 INTEGER INFOT, NOUT
96* ..
97* .. Common blocks ..
98 COMMON / infoc / infot, nout, ok, lerr
99 COMMON / srnamc / srnamt
100* ..
101* .. Intrinsic Functions ..
102 INTRINSIC real
103* ..
104* .. Executable Statements ..
105*
106 nout = nunit
107 WRITE( nout, fmt = * )
108 c2 = path( 2: 3 )
109*
110* Set the variables to innocuous values.
111*
112 DO 20 j = 1, nmax
113 DO 10 i = 1, nmax
114 a( i, j ) = 1. / real( i+j )
115 10 CONTINUE
116 20 CONTINUE
117 ok = .true.
118 nt = 0
119*
120* Test error exits of the SVD routines.
121*
122 IF( lsamen( 2, c2, 'BD' ) ) THEN
123*
124* SGEBRD
125*
126 srnamt = 'SGEBRD'
127 infot = 1
128 CALL sgebrd( -1, 0, a, 1, d, e, tq, tp, w, 1, info )
129 CALL chkxer( 'SGEBRD', infot, nout, lerr, ok )
130 infot = 2
131 CALL sgebrd( 0, -1, a, 1, d, e, tq, tp, w, 1, info )
132 CALL chkxer( 'SGEBRD', infot, nout, lerr, ok )
133 infot = 4
134 CALL sgebrd( 2, 1, a, 1, d, e, tq, tp, w, 2, info )
135 CALL chkxer( 'SGEBRD', infot, nout, lerr, ok )
136 infot = 10
137 CALL sgebrd( 2, 1, a, 2, d, e, tq, tp, w, 1, info )
138 CALL chkxer( 'SGEBRD', infot, nout, lerr, ok )
139 nt = nt + 4
140*
141* SGEBD2
142*
143 srnamt = 'SGEBD2'
144 infot = 1
145 CALL sgebd2( -1, 0, a, 1, d, e, tq, tp, w, info )
146 CALL chkxer( 'SGEBD2', infot, nout, lerr, ok )
147 infot = 2
148 CALL sgebd2( 0, -1, a, 1, d, e, tq, tp, w, info )
149 CALL chkxer( 'SGEBD2', infot, nout, lerr, ok )
150 infot = 4
151 CALL sgebd2( 2, 1, a, 1, d, e, tq, tp, w, info )
152 CALL chkxer( 'SGEBD2', infot, nout, lerr, ok )
153 nt = nt + 3
154*
155* SORGBR
156*
157 srnamt = 'SORGBR'
158 infot = 1
159 CALL sorgbr( '/', 0, 0, 0, a, 1, tq, w, 1, info )
160 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
161 infot = 2
162 CALL sorgbr( 'Q', -1, 0, 0, a, 1, tq, w, 1, info )
163 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
164 infot = 3
165 CALL sorgbr( 'Q', 0, -1, 0, a, 1, tq, w, 1, info )
166 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
167 infot = 3
168 CALL sorgbr( 'Q', 0, 1, 0, a, 1, tq, w, 1, info )
169 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
170 infot = 3
171 CALL sorgbr( 'Q', 1, 0, 1, a, 1, tq, w, 1, info )
172 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
173 infot = 3
174 CALL sorgbr( 'P', 1, 0, 0, a, 1, tq, w, 1, info )
175 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
176 infot = 3
177 CALL sorgbr( 'P', 0, 1, 1, a, 1, tq, w, 1, info )
178 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
179 infot = 4
180 CALL sorgbr( 'Q', 0, 0, -1, a, 1, tq, w, 1, info )
181 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
182 infot = 6
183 CALL sorgbr( 'Q', 2, 1, 1, a, 1, tq, w, 1, info )
184 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
185 infot = 9
186 CALL sorgbr( 'Q', 2, 2, 1, a, 2, tq, w, 1, info )
187 CALL chkxer( 'SORGBR', infot, nout, lerr, ok )
188 nt = nt + 10
189*
190* SORMBR
191*
192 srnamt = 'SORMBR'
193 infot = 1
194 CALL sormbr( '/', 'L', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
195 $ info )
196 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
197 infot = 2
198 CALL sormbr( 'Q', '/', 'T', 0, 0, 0, a, 1, tq, u, 1, w, 1,
199 $ info )
200 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
201 infot = 3
202 CALL sormbr( 'Q', 'L', '/', 0, 0, 0, a, 1, tq, u, 1, w, 1,
203 $ info )
204 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
205 infot = 4
206 CALL sormbr( 'Q', 'L', 'T', -1, 0, 0, a, 1, tq, u, 1, w, 1,
207 $ info )
208 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
209 infot = 5
210 CALL sormbr( 'Q', 'L', 'T', 0, -1, 0, a, 1, tq, u, 1, w, 1,
211 $ info )
212 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
213 infot = 6
214 CALL sormbr( 'Q', 'L', 'T', 0, 0, -1, a, 1, tq, u, 1, w, 1,
215 $ info )
216 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
217 infot = 8
218 CALL sormbr( 'Q', 'L', 'T', 2, 0, 0, a, 1, tq, u, 2, w, 1,
219 $ info )
220 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
221 infot = 8
222 CALL sormbr( 'Q', 'R', 'T', 0, 2, 0, a, 1, tq, u, 1, w, 1,
223 $ info )
224 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
225 infot = 8
226 CALL sormbr( 'P', 'L', 'T', 2, 0, 2, a, 1, tq, u, 2, w, 1,
227 $ info )
228 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
229 infot = 8
230 CALL sormbr( 'P', 'R', 'T', 0, 2, 2, a, 1, tq, u, 1, w, 1,
231 $ info )
232 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
233 infot = 11
234 CALL sormbr( 'Q', 'R', 'T', 2, 0, 0, a, 1, tq, u, 1, w, 1,
235 $ info )
236 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
237 infot = 13
238 CALL sormbr( 'Q', 'L', 'T', 0, 2, 0, a, 1, tq, u, 1, w, 1,
239 $ info )
240 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
241 infot = 13
242 CALL sormbr( 'Q', 'R', 'T', 2, 0, 0, a, 1, tq, u, 2, w, 1,
243 $ info )
244 CALL chkxer( 'SORMBR', infot, nout, lerr, ok )
245 nt = nt + 13
246*
247* SBDSQR
248*
249 srnamt = 'SBDSQR'
250 infot = 1
251 CALL sbdsqr( '/', 0, 0, 0, 0, d, e, v, 1, u, 1, a, 1, w, info )
252 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
253 infot = 2
254 CALL sbdsqr( 'U', -1, 0, 0, 0, d, e, v, 1, u, 1, a, 1, w,
255 $ info )
256 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
257 infot = 3
258 CALL sbdsqr( 'U', 0, -1, 0, 0, d, e, v, 1, u, 1, a, 1, w,
259 $ info )
260 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
261 infot = 4
262 CALL sbdsqr( 'U', 0, 0, -1, 0, d, e, v, 1, u, 1, a, 1, w,
263 $ info )
264 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
265 infot = 5
266 CALL sbdsqr( 'U', 0, 0, 0, -1, d, e, v, 1, u, 1, a, 1, w,
267 $ info )
268 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
269 infot = 9
270 CALL sbdsqr( 'U', 2, 1, 0, 0, d, e, v, 1, u, 1, a, 1, w, info )
271 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
272 infot = 11
273 CALL sbdsqr( 'U', 0, 0, 2, 0, d, e, v, 1, u, 1, a, 1, w, info )
274 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
275 infot = 13
276 CALL sbdsqr( 'U', 2, 0, 0, 1, d, e, v, 1, u, 1, a, 1, w, info )
277 CALL chkxer( 'SBDSQR', infot, nout, lerr, ok )
278 nt = nt + 8
279*
280* SBDSDC
281*
282 srnamt = 'SBDSDC'
283 infot = 1
284 CALL sbdsdc( '/', 'N', 0, d, e, u, 1, v, 1, q, iq, w, iw,
285 $ info )
286 CALL chkxer( 'SBDSDC', infot, nout, lerr, ok )
287 infot = 2
288 CALL sbdsdc( 'U', '/', 0, d, e, u, 1, v, 1, q, iq, w, iw,
289 $ info )
290 CALL chkxer( 'SBDSDC', infot, nout, lerr, ok )
291 infot = 3
292 CALL sbdsdc( 'U', 'N', -1, d, e, u, 1, v, 1, q, iq, w, iw,
293 $ info )
294 CALL chkxer( 'SBDSDC', infot, nout, lerr, ok )
295 infot = 7
296 CALL sbdsdc( 'U', 'I', 2, d, e, u, 1, v, 1, q, iq, w, iw,
297 $ info )
298 CALL chkxer( 'SBDSDC', infot, nout, lerr, ok )
299 infot = 9
300 CALL sbdsdc( 'U', 'I', 2, d, e, u, 2, v, 1, q, iq, w, iw,
301 $ info )
302 CALL chkxer( 'SBDSDC', infot, nout, lerr, ok )
303 nt = nt + 5
304*
305* SBDSVDX
306*
307 srnamt = 'SBDSVDX'
308 infot = 1
309 CALL sbdsvdx( 'X', 'N', 'A', 1, d, e, zero, one, 0, 0,
310 $ ns, s, q, 1, w, iw, info)
311 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
312 infot = 2
313 CALL sbdsvdx( 'U', 'X', 'A', 1, d, e, zero, one, 0, 0,
314 $ ns, s, q, 1, w, iw, info)
315 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
316 infot = 3
317 CALL sbdsvdx( 'U', 'V', 'X', 1, d, e, zero, one, 0, 0,
318 $ ns, s, q, 1, w, iw, info)
319 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
320 infot = 4
321 CALL sbdsvdx( 'U', 'V', 'A', -1, d, e, zero, one, 0, 0,
322 $ ns, s, q, 1, w, iw, info)
323 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
324 infot = 7
325 CALL sbdsvdx( 'U', 'V', 'V', 2, d, e, -one, zero, 0, 0,
326 $ ns, s, q, 1, w, iw, info)
327 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
328 infot = 8
329 CALL sbdsvdx( 'U', 'V', 'V', 2, d, e, one, zero, 0, 0,
330 $ ns, s, q, 1, w, iw, info)
331 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
332 infot = 9
333 CALL sbdsvdx( 'L', 'V', 'I', 2, d, e, zero, zero, 0, 2,
334 $ ns, s, q, 1, w, iw, info)
335 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
336 infot = 9
337 CALL sbdsvdx( 'L', 'V', 'I', 4, d, e, zero, zero, 5, 2,
338 $ ns, s, q, 1, w, iw, info)
339 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
340 infot = 10
341 CALL sbdsvdx( 'L', 'V', 'I', 4, d, e, zero, zero, 3, 2,
342 $ ns, s, q, 1, w, iw, info)
343 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
344 infot = 10
345 CALL sbdsvdx( 'L', 'V', 'I', 4, d, e, zero, zero, 3, 5,
346 $ ns, s, q, 1, w, iw, info)
347 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
348 infot = 14
349 CALL sbdsvdx( 'L', 'V', 'A', 4, d, e, zero, zero, 0, 0,
350 $ ns, s, q, 0, w, iw, info)
351 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
352 infot = 14
353 CALL sbdsvdx( 'L', 'V', 'A', 4, d, e, zero, zero, 0, 0,
354 $ ns, s, q, 2, w, iw, info)
355 CALL chkxer( 'SBDSVDX', infot, nout, lerr, ok )
356 nt = nt + 12
357 END IF
358*
359* Print a summary line.
360*
361 IF( ok ) THEN
362 WRITE( nout, fmt = 9999 )path, nt
363 ELSE
364 WRITE( nout, fmt = 9998 )path
365 END IF
366*
367 9999 FORMAT( 1x, a3, ' routines passed the tests of the error exits',
368 $ ' (', i3, ' tests done)' )
369 9998 FORMAT( ' *** ', a3, ' routines failed the tests of the error ',
370 $ 'exits ***' )
371*
372 RETURN
373*
374* End of SERRBD
375*
376 END
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3224
sbdsdc
subroutine sbdsdc(uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq, work, iwork, info)
SBDSDC
Definition sbdsdc.f:197
sbdsqr
subroutine sbdsqr(uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
SBDSQR
Definition sbdsqr.f:240
sbdsvdx
subroutine sbdsvdx(uplo, jobz, range, n, d, e, vl, vu, il, iu, ns, s, z, ldz, work, iwork, info)
SBDSVDX
Definition sbdsvdx.f:224
sgebd2
subroutine sgebd2(m, n, a, lda, d, e, tauq, taup, work, info)
SGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
Definition sgebd2.f:187
sgebrd
subroutine sgebrd(m, n, a, lda, d, e, tauq, taup, work, lwork, info)
SGEBRD
Definition sgebrd.f:204
sorgbr
subroutine sorgbr(vect, m, n, k, a, lda, tau, work, lwork, info)
SORGBR
Definition sorgbr.f:156
sormbr
subroutine sormbr(vect, side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
SORMBR
Definition sormbr.f:194
serrbd
subroutine serrbd(path, nunit)
SERRBD
Definition serrbd.f:55