LAPACK  3.5.0
LAPACK: Linear Algebra PACKage
derred.f File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine derred (PATH, NUNIT)
 DERRED More...
 

Function/Subroutine Documentation

subroutine derred ( character*3  PATH,
integer  NUNIT 
)

DERRED

Purpose:
 DERRED tests the error exits for the eigenvalue driver routines for
 DOUBLE PRECISION matrices:

 PATH  driver   description
 ----  ------   -----------
 SEV   DGEEV    find eigenvalues/eigenvectors for nonsymmetric A
 SES   DGEES    find eigenvalues/Schur form for nonsymmetric A
 SVX   DGEEVX   SGEEV + balancing and condition estimation
 SSX   DGEESX   SGEES + balancing and condition estimation
 DBD   DGESVD   compute SVD of an M-by-N matrix A
       DGESDD   compute SVD of an M-by-N matrix A (by divide and
                conquer)
       DGEJSV   compute SVD of an M-by-N matrix A where M >= N
Parameters
[in]PATH
          PATH is CHARACTER*3
          The LAPACK path name for the routines to be tested.
[in]NUNIT
          NUNIT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
November 2011

Definition at line 68 of file derred.f.

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
subroutine dgejsv(JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, M, N, A, LDA, SVA, U, LDU, V, LDV, WORK, LWORK, IWORK, INFO)
DGEJSV
Definition: dgejsv.f:476
subroutine dgesdd(JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, IWORK, INFO)
DGESDD
Definition: dgesdd.f:218
subroutine chkxer(SRNAMT, INFOT, NOUT, LERR, OK)
Definition: cblat2.f:3199
subroutine dgeevx(BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV, WORK, LWORK, IWORK, INFO)
DGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
Definition: dgeevx.f:305
logical function dslect(ZR, ZI)
DSLECT
Definition: dslect.f:64
logical function lsamen(N, CA, CB)
LSAMEN
Definition: lsamen.f:76
subroutine dgeesx(JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK, LIWORK, BWORK, INFO)
DGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE...
Definition: dgeesx.f:283
subroutine dgesvd(JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK, LWORK, INFO)
DGESVD computes the singular value decomposition (SVD) for GE matrices
Definition: dgesvd.f:213
subroutine dgees(JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO)
DGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition: dgees.f:218
subroutine dgeev(JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR, LDVR, WORK, LWORK, INFO)
DGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
Definition: dgeev.f:191

Here is the call graph for this function:

Here is the caller graph for this function: