LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
derred.f
Go to the documentation of this file.
1 *> \brief \b DERRED
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 DERRED( 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 *> DERRED tests the error exits for the eigenvalue driver routines for
25 *> DOUBLE PRECISION matrices:
26 *>
27 *> PATH driver description
28 *> ---- ------ -----------
29 *> SEV DGEEV find eigenvalues/eigenvectors for nonsymmetric A
30 *> SES DGEES find eigenvalues/Schur form for nonsymmetric A
31 *> SVX DGEEVX SGEEV + balancing and condition estimation
32 *> SSX DGEESX SGEES + balancing and condition estimation
33 *> DBD DGESVD compute SVD of an M-by-N matrix A
34 *> DGESDD compute SVD of an M-by-N matrix A (by divide and
35 *> conquer)
36 *> DGEJSV compute SVD of an M-by-N matrix A where M >= N
37 *> \endverbatim
38 *
39 * Arguments:
40 * ==========
41 *
42 *> \param[in] PATH
43 *> \verbatim
44 *> PATH is CHARACTER*3
45 *> The LAPACK path name for the routines to be tested.
46 *> \endverbatim
47 *>
48 *> \param[in] NUNIT
49 *> \verbatim
50 *> NUNIT is INTEGER
51 *> The unit number for output.
52 *> \endverbatim
53 *
54 * Authors:
55 * ========
56 *
57 *> \author Univ. of Tennessee
58 *> \author Univ. of California Berkeley
59 *> \author Univ. of Colorado Denver
60 *> \author NAG Ltd.
61 *
62 *> \date November 2011
63 *
64 *> \ingroup double_eig
65 *
66 * =====================================================================
67  SUBROUTINE derred( PATH, NUNIT )
68 *
69 * -- LAPACK test routine (version 3.4.0) --
70 * -- LAPACK is a software package provided by Univ. of Tennessee, --
71 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
72 * November 2011
73 *
74 * .. Scalar Arguments ..
75  CHARACTER*3 path
76  INTEGER nunit
77 * ..
78 *
79 * =====================================================================
80 *
81 * .. Parameters ..
82  INTEGER nmax
83  DOUBLE PRECISION one, zero
84  parameter( nmax = 4, one = 1.0d0, zero = 0.0d0 )
85 * ..
86 * .. Local Scalars ..
87  CHARACTER*2 c2
88  INTEGER i, ihi, ilo, info, j, nt, sdim
89  DOUBLE PRECISION abnrm
90 * ..
91 * .. Local Arrays ..
92  LOGICAL b( nmax )
93  INTEGER iw( 2*nmax )
94  DOUBLE PRECISION a( nmax, nmax ), r1( nmax ), r2( nmax ),
95  $ s( nmax ), u( nmax, nmax ), vl( nmax, nmax ),
96  $ vr( nmax, nmax ), vt( nmax, nmax ),
97  $ w( 4*nmax ), wi( nmax ), wr( nmax )
98 * ..
99 * .. External Subroutines ..
100  EXTERNAL chkxer, dgees, dgeesx, dgeev, dgeevx, dgejsv,
101  $ dgesdd, dgesvd
102 * ..
103 * .. External Functions ..
104  LOGICAL dslect, lsamen
105  EXTERNAL dslect, lsamen
106 * ..
107 * .. Intrinsic Functions ..
108  INTRINSIC len_trim
109 * ..
110 * .. Arrays in Common ..
111  LOGICAL selval( 20 )
112  DOUBLE PRECISION selwi( 20 ), selwr( 20 )
113 * ..
114 * .. Scalars in Common ..
115  LOGICAL lerr, ok
116  CHARACTER*32 srnamt
117  INTEGER infot, nout, seldim, selopt
118 * ..
119 * .. Common blocks ..
120  common / infoc / infot, nout, ok, lerr
121  common / srnamc / srnamt
122  common / sslct / selopt, seldim, selval, selwr, selwi
123 * ..
124 * .. Executable Statements ..
125 *
126  nout = nunit
127  WRITE( nout, fmt = * )
128  c2 = path( 2: 3 )
129 *
130 * Initialize A
131 *
132  DO 20 j = 1, nmax
133  DO 10 i = 1, nmax
134  a( i, j ) = zero
135  10 continue
136  20 continue
137  DO 30 i = 1, nmax
138  a( i, i ) = one
139  30 continue
140  ok = .true.
141  nt = 0
142 *
143  IF( lsamen( 2, c2, 'EV' ) ) THEN
144 *
145 * Test DGEEV
146 *
147  srnamt = 'DGEEV '
148  infot = 1
149  CALL dgeev( 'X', 'N', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
150  $ info )
151  CALL chkxer( 'DGEEV ', infot, nout, lerr, ok )
152  infot = 2
153  CALL dgeev( 'N', 'X', 0, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
154  $ info )
155  CALL chkxer( 'DGEEV ', infot, nout, lerr, ok )
156  infot = 3
157  CALL dgeev( 'N', 'N', -1, a, 1, wr, wi, vl, 1, vr, 1, w, 1,
158  $ info )
159  CALL chkxer( 'DGEEV ', infot, nout, lerr, ok )
160  infot = 5
161  CALL dgeev( 'N', 'N', 2, a, 1, wr, wi, vl, 1, vr, 1, w, 6,
162  $ info )
163  CALL chkxer( 'DGEEV ', infot, nout, lerr, ok )
164  infot = 9
165  CALL dgeev( 'V', 'N', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
166  $ info )
167  CALL chkxer( 'DGEEV ', infot, nout, lerr, ok )
168  infot = 11
169  CALL dgeev( 'N', 'V', 2, a, 2, wr, wi, vl, 1, vr, 1, w, 8,
170  $ info )
171  CALL chkxer( 'DGEEV ', infot, nout, lerr, ok )
172  infot = 13
173  CALL dgeev( 'V', 'V', 1, a, 1, wr, wi, vl, 1, vr, 1, w, 3,
174  $ info )
175  CALL chkxer( 'DGEEV ', infot, nout, lerr, ok )
176  nt = nt + 7
177 *
178  ELSE IF( lsamen( 2, c2, 'ES' ) ) THEN
179 *
180 * Test DGEES
181 *
182  srnamt = 'DGEES '
183  infot = 1
184  CALL dgees( 'X', 'N', dslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
185  $ 1, b, info )
186  CALL chkxer( 'DGEES ', infot, nout, lerr, ok )
187  infot = 2
188  CALL dgees( 'N', 'X', dslect, 0, a, 1, sdim, wr, wi, vl, 1, w,
189  $ 1, b, info )
190  CALL chkxer( 'DGEES ', infot, nout, lerr, ok )
191  infot = 4
192  CALL dgees( 'N', 'S', dslect, -1, a, 1, sdim, wr, wi, vl, 1, w,
193  $ 1, b, info )
194  CALL chkxer( 'DGEES ', infot, nout, lerr, ok )
195  infot = 6
196  CALL dgees( 'N', 'S', dslect, 2, a, 1, sdim, wr, wi, vl, 1, w,
197  $ 6, b, info )
198  CALL chkxer( 'DGEES ', infot, nout, lerr, ok )
199  infot = 11
200  CALL dgees( 'V', 'S', dslect, 2, a, 2, sdim, wr, wi, vl, 1, w,
201  $ 6, b, info )
202  CALL chkxer( 'DGEES ', infot, nout, lerr, ok )
203  infot = 13
204  CALL dgees( 'N', 'S', dslect, 1, a, 1, sdim, wr, wi, vl, 1, w,
205  $ 2, b, info )
206  CALL chkxer( 'DGEES ', infot, nout, lerr, ok )
207  nt = nt + 6
208 *
209  ELSE IF( lsamen( 2, c2, 'VX' ) ) THEN
210 *
211 * Test DGEEVX
212 *
213  srnamt = 'DGEEVX'
214  infot = 1
215  CALL dgeevx( 'X', 'N', 'N', 'N', 0, a, 1, wr, wi, vl, 1, vr, 1,
216  $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
217  CALL chkxer( 'DGEEVX', infot, nout, lerr, ok )
218  infot = 2
219  CALL dgeevx( 'N', 'X', 'N', 'N', 0, a, 1, wr, wi, vl, 1, vr, 1,
220  $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
221  CALL chkxer( 'DGEEVX', infot, nout, lerr, ok )
222  infot = 3
223  CALL dgeevx( 'N', 'N', 'X', 'N', 0, a, 1, wr, wi, vl, 1, vr, 1,
224  $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
225  CALL chkxer( 'DGEEVX', infot, nout, lerr, ok )
226  infot = 4
227  CALL dgeevx( 'N', 'N', 'N', 'X', 0, a, 1, wr, wi, vl, 1, vr, 1,
228  $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
229  CALL chkxer( 'DGEEVX', infot, nout, lerr, ok )
230  infot = 5
231  CALL dgeevx( 'N', 'N', 'N', 'N', -1, a, 1, wr, wi, vl, 1, vr,
232  $ 1, ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
233  CALL chkxer( 'DGEEVX', infot, nout, lerr, ok )
234  infot = 7
235  CALL dgeevx( 'N', 'N', 'N', 'N', 2, a, 1, wr, wi, vl, 1, vr, 1,
236  $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
237  CALL chkxer( 'DGEEVX', infot, nout, lerr, ok )
238  infot = 11
239  CALL dgeevx( 'N', 'V', 'N', 'N', 2, a, 2, wr, wi, vl, 1, vr, 1,
240  $ ilo, ihi, s, abnrm, r1, r2, w, 6, iw, info )
241  CALL chkxer( 'DGEEVX', infot, nout, lerr, ok )
242  infot = 13
243  CALL dgeevx( 'N', 'N', 'V', 'N', 2, a, 2, wr, wi, vl, 1, vr, 1,
244  $ ilo, ihi, s, abnrm, r1, r2, w, 6, iw, info )
245  CALL chkxer( 'DGEEVX', infot, nout, lerr, ok )
246  infot = 21
247  CALL dgeevx( 'N', 'N', 'N', 'N', 1, a, 1, wr, wi, vl, 1, vr, 1,
248  $ ilo, ihi, s, abnrm, r1, r2, w, 1, iw, info )
249  CALL chkxer( 'DGEEVX', infot, nout, lerr, ok )
250  infot = 21
251  CALL dgeevx( 'N', 'V', 'N', 'N', 1, a, 1, wr, wi, vl, 1, vr, 1,
252  $ ilo, ihi, s, abnrm, r1, r2, w, 2, iw, info )
253  CALL chkxer( 'DGEEVX', infot, nout, lerr, ok )
254  infot = 21
255  CALL dgeevx( 'N', 'N', 'V', 'V', 1, a, 1, wr, wi, vl, 1, vr, 1,
256  $ ilo, ihi, s, abnrm, r1, r2, w, 3, iw, info )
257  CALL chkxer( 'DGEEVX', infot, nout, lerr, ok )
258  nt = nt + 11
259 *
260  ELSE IF( lsamen( 2, c2, 'SX' ) ) THEN
261 *
262 * Test DGEESX
263 *
264  srnamt = 'DGEESX'
265  infot = 1
266  CALL dgeesx( 'X', 'N', dslect, 'N', 0, a, 1, sdim, wr, wi, vl,
267  $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
268  CALL chkxer( 'DGEESX', infot, nout, lerr, ok )
269  infot = 2
270  CALL dgeesx( 'N', 'X', dslect, 'N', 0, a, 1, sdim, wr, wi, vl,
271  $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
272  CALL chkxer( 'DGEESX', infot, nout, lerr, ok )
273  infot = 4
274  CALL dgeesx( 'N', 'N', dslect, 'X', 0, a, 1, sdim, wr, wi, vl,
275  $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
276  CALL chkxer( 'DGEESX', infot, nout, lerr, ok )
277  infot = 5
278  CALL dgeesx( 'N', 'N', dslect, 'N', -1, a, 1, sdim, wr, wi, vl,
279  $ 1, r1( 1 ), r2( 1 ), w, 1, iw, 1, b, info )
280  CALL chkxer( 'DGEESX', infot, nout, lerr, ok )
281  infot = 7
282  CALL dgeesx( 'N', 'N', dslect, 'N', 2, a, 1, sdim, wr, wi, vl,
283  $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
284  CALL chkxer( 'DGEESX', infot, nout, lerr, ok )
285  infot = 12
286  CALL dgeesx( 'V', 'N', dslect, 'N', 2, a, 2, sdim, wr, wi, vl,
287  $ 1, r1( 1 ), r2( 1 ), w, 6, iw, 1, b, info )
288  CALL chkxer( 'DGEESX', infot, nout, lerr, ok )
289  infot = 16
290  CALL dgeesx( 'N', 'N', dslect, 'N', 1, a, 1, sdim, wr, wi, vl,
291  $ 1, r1( 1 ), r2( 1 ), w, 2, iw, 1, b, info )
292  CALL chkxer( 'DGEESX', infot, nout, lerr, ok )
293  nt = nt + 7
294 *
295  ELSE IF( lsamen( 2, c2, 'BD' ) ) THEN
296 *
297 * Test DGESVD
298 *
299  srnamt = 'DGESVD'
300  infot = 1
301  CALL dgesvd( 'X', 'N', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
302  CALL chkxer( 'DGESVD', infot, nout, lerr, ok )
303  infot = 2
304  CALL dgesvd( 'N', 'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
305  CALL chkxer( 'DGESVD', infot, nout, lerr, ok )
306  infot = 2
307  CALL dgesvd( 'O', 'O', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, info )
308  CALL chkxer( 'DGESVD', infot, nout, lerr, ok )
309  infot = 3
310  CALL dgesvd( 'N', 'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1,
311  $ info )
312  CALL chkxer( 'DGESVD', infot, nout, lerr, ok )
313  infot = 4
314  CALL dgesvd( 'N', 'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1,
315  $ info )
316  CALL chkxer( 'DGESVD', infot, nout, lerr, ok )
317  infot = 6
318  CALL dgesvd( 'N', 'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, info )
319  CALL chkxer( 'DGESVD', infot, nout, lerr, ok )
320  infot = 9
321  CALL dgesvd( 'A', 'N', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, info )
322  CALL chkxer( 'DGESVD', infot, nout, lerr, ok )
323  infot = 11
324  CALL dgesvd( 'N', 'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, info )
325  CALL chkxer( 'DGESVD', infot, nout, lerr, ok )
326  nt = 8
327  IF( ok ) THEN
328  WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
329  $ nt
330  ELSE
331  WRITE( nout, fmt = 9998 )
332  END IF
333 *
334 * Test DGESDD
335 *
336  srnamt = 'DGESDD'
337  infot = 1
338  CALL dgesdd( 'X', 0, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
339  CALL chkxer( 'DGESDD', infot, nout, lerr, ok )
340  infot = 2
341  CALL dgesdd( 'N', -1, 0, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
342  CALL chkxer( 'DGESDD', infot, nout, lerr, ok )
343  infot = 3
344  CALL dgesdd( 'N', 0, -1, a, 1, s, u, 1, vt, 1, w, 1, iw, info )
345  CALL chkxer( 'DGESDD', infot, nout, lerr, ok )
346  infot = 5
347  CALL dgesdd( 'N', 2, 1, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
348  CALL chkxer( 'DGESDD', infot, nout, lerr, ok )
349  infot = 8
350  CALL dgesdd( 'A', 2, 1, a, 2, s, u, 1, vt, 1, w, 5, iw, info )
351  CALL chkxer( 'DGESDD', infot, nout, lerr, ok )
352  infot = 10
353  CALL dgesdd( 'A', 1, 2, a, 1, s, u, 1, vt, 1, w, 5, iw, info )
354  CALL chkxer( 'DGESDD', infot, nout, lerr, ok )
355  nt = 6
356  IF( ok ) THEN
357  WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
358  $ nt
359  ELSE
360  WRITE( nout, fmt = 9998 )
361  END IF
362 *
363 * Test DGEJSV
364 *
365  srnamt = 'DGEJSV'
366  infot = 1
367  CALL dgejsv( 'X', 'U', 'V', 'R', 'N', 'N',
368  $ 0, 0, a, 1, s, u, 1, vt, 1,
369  $ w, 1, iw, info)
370  CALL chkxer( 'DGEJSV', infot, nout, lerr, ok )
371  infot = 2
372  CALL dgejsv( 'G', 'X', 'V', 'R', 'N', 'N',
373  $ 0, 0, a, 1, s, u, 1, vt, 1,
374  $ w, 1, iw, info)
375  CALL chkxer( 'DGEJSV', infot, nout, lerr, ok )
376  infot = 3
377  CALL dgejsv( 'G', 'U', 'X', 'R', 'N', 'N',
378  $ 0, 0, a, 1, s, u, 1, vt, 1,
379  $ w, 1, iw, info)
380  CALL chkxer( 'DGEJSV', infot, nout, lerr, ok )
381  infot = 4
382  CALL dgejsv( 'G', 'U', 'V', 'X', 'N', 'N',
383  $ 0, 0, a, 1, s, u, 1, vt, 1,
384  $ w, 1, iw, info)
385  CALL chkxer( 'DGEJSV', infot, nout, lerr, ok )
386  infot = 5
387  CALL dgejsv( 'G', 'U', 'V', 'R', 'X', 'N',
388  $ 0, 0, a, 1, s, u, 1, vt, 1,
389  $ w, 1, iw, info)
390  CALL chkxer( 'DGEJSV', infot, nout, lerr, ok )
391  infot = 6
392  CALL dgejsv( 'G', 'U', 'V', 'R', 'N', 'X',
393  $ 0, 0, a, 1, s, u, 1, vt, 1,
394  $ w, 1, iw, info)
395  CALL chkxer( 'DGEJSV', infot, nout, lerr, ok )
396  infot = 7
397  CALL dgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
398  $ -1, 0, a, 1, s, u, 1, vt, 1,
399  $ w, 1, iw, info)
400  CALL chkxer( 'DGEJSV', infot, nout, lerr, ok )
401  infot = 8
402  CALL dgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
403  $ 0, -1, a, 1, s, u, 1, vt, 1,
404  $ w, 1, iw, info)
405  CALL chkxer( 'DGEJSV', infot, nout, lerr, ok )
406  infot = 10
407  CALL dgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
408  $ 2, 1, a, 1, s, u, 1, vt, 1,
409  $ w, 1, iw, info)
410  CALL chkxer( 'DGEJSV', infot, nout, lerr, ok )
411  infot = 13
412  CALL dgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
413  $ 2, 2, a, 2, s, u, 1, vt, 2,
414  $ w, 1, iw, info)
415  CALL chkxer( 'DGEJSV', infot, nout, lerr, ok )
416  infot = 14
417  CALL dgejsv( 'G', 'U', 'V', 'R', 'N', 'N',
418  $ 2, 2, a, 2, s, u, 2, vt, 1,
419  $ w, 1, iw, info)
420  CALL chkxer( 'DGEJSV', infot, nout, lerr, ok )
421  nt = 11
422  IF( ok ) THEN
423  WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
424  $ nt
425  ELSE
426  WRITE( nout, fmt = 9998 )
427  END IF
428  END IF
429 *
430 * Print a summary line.
431 *
432  IF( .NOT.lsamen( 2, c2, 'BD' ) ) THEN
433  IF( ok ) THEN
434  WRITE( nout, fmt = 9999 )srnamt( 1:len_trim( srnamt ) ),
435  $ nt
436  ELSE
437  WRITE( nout, fmt = 9998 )
438  END IF
439  END IF
440 *
441  9999 format( 1x, a, ' passed the tests of the error exits (', i3,
442  $ ' tests done)' )
443  9998 format( ' *** ', a, ' failed the tests of the error exits ***' )
444  return
445 *
446 * End of DERRED
447  END