LAPACK  3.6.1 LAPACK: Linear Algebra PACKage
cdrves.f
Go to the documentation of this file.
1 *> \brief \b CDRVES
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 CDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
12 * NOUNIT, A, LDA, H, HT, W, WT, VS, LDVS, RESULT,
13 * WORK, NWORK, RWORK, IWORK, BWORK, INFO )
14 *
15 * .. Scalar Arguments ..
16 * INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK
17 * REAL THRESH
18 * ..
19 * .. Array Arguments ..
20 * LOGICAL BWORK( * ), DOTYPE( * )
21 * INTEGER ISEED( 4 ), IWORK( * ), NN( * )
22 * REAL RESULT( 13 ), RWORK( * )
23 * COMPLEX A( LDA, * ), H( LDA, * ), HT( LDA, * ),
24 * \$ VS( LDVS, * ), W( * ), WORK( * ), WT( * )
25 * ..
26 *
27 *
28 *> \par Purpose:
29 * =============
30 *>
31 *> \verbatim
32 *>
33 *> CDRVES checks the nonsymmetric eigenvalue (Schur form) problem
34 *> driver CGEES.
35 *>
36 *> When CDRVES is called, a number of matrix "sizes" ("n's") and a
37 *> number of matrix "types" are specified. For each size ("n")
38 *> and each type of matrix, one matrix will be generated and used
39 *> to test the nonsymmetric eigenroutines. For each matrix, 13
40 *> tests will be performed:
41 *>
42 *> (1) 0 if T is in Schur form, 1/ulp otherwise
43 *> (no sorting of eigenvalues)
44 *>
45 *> (2) | A - VS T VS' | / ( n |A| ulp )
46 *>
47 *> Here VS is the matrix of Schur eigenvectors, and T is in Schur
48 *> form (no sorting of eigenvalues).
49 *>
50 *> (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
51 *>
52 *> (4) 0 if W are eigenvalues of T
53 *> 1/ulp otherwise
54 *> (no sorting of eigenvalues)
55 *>
56 *> (5) 0 if T(with VS) = T(without VS),
57 *> 1/ulp otherwise
58 *> (no sorting of eigenvalues)
59 *>
60 *> (6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
61 *> 1/ulp otherwise
62 *> (no sorting of eigenvalues)
63 *>
64 *> (7) 0 if T is in Schur form, 1/ulp otherwise
65 *> (with sorting of eigenvalues)
66 *>
67 *> (8) | A - VS T VS' | / ( n |A| ulp )
68 *>
69 *> Here VS is the matrix of Schur eigenvectors, and T is in Schur
70 *> form (with sorting of eigenvalues).
71 *>
72 *> (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
73 *>
74 *> (10) 0 if W are eigenvalues of T
75 *> 1/ulp otherwise
76 *> (with sorting of eigenvalues)
77 *>
78 *> (11) 0 if T(with VS) = T(without VS),
79 *> 1/ulp otherwise
80 *> (with sorting of eigenvalues)
81 *>
82 *> (12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
83 *> 1/ulp otherwise
84 *> (with sorting of eigenvalues)
85 *>
86 *> (13) if sorting worked and SDIM is the number of
87 *> eigenvalues which were SELECTed
88 *>
89 *> The "sizes" are specified by an array NN(1:NSIZES); the value of
90 *> each element NN(j) specifies one size.
91 *> The "types" are specified by a logical array DOTYPE( 1:NTYPES );
92 *> if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
93 *> Currently, the list of possible types is:
94 *>
95 *> (1) The zero matrix.
96 *> (2) The identity matrix.
97 *> (3) A (transposed) Jordan block, with 1's on the diagonal.
98 *>
99 *> (4) A diagonal matrix with evenly spaced entries
100 *> 1, ..., ULP and random complex angles.
101 *> (ULP = (first number larger than 1) - 1 )
102 *> (5) A diagonal matrix with geometrically spaced entries
103 *> 1, ..., ULP and random complex angles.
104 *> (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
105 *> and random complex angles.
106 *>
107 *> (7) Same as (4), but multiplied by a constant near
108 *> the overflow threshold
109 *> (8) Same as (4), but multiplied by a constant near
110 *> the underflow threshold
111 *>
112 *> (9) A matrix of the form U' T U, where U is unitary and
113 *> T has evenly spaced entries 1, ..., ULP with random
114 *> complex angles on the diagonal and random O(1) entries in
115 *> the upper triangle.
116 *>
117 *> (10) A matrix of the form U' T U, where U is unitary and
118 *> T has geometrically spaced entries 1, ..., ULP with random
119 *> complex angles on the diagonal and random O(1) entries in
120 *> the upper triangle.
121 *>
122 *> (11) A matrix of the form U' T U, where U is orthogonal and
123 *> T has "clustered" entries 1, ULP,..., ULP with random
124 *> complex angles on the diagonal and random O(1) entries in
125 *> the upper triangle.
126 *>
127 *> (12) A matrix of the form U' T U, where U is unitary and
128 *> T has complex eigenvalues randomly chosen from
129 *> ULP < |z| < 1 and random O(1) entries in the upper
130 *> triangle.
131 *>
132 *> (13) A matrix of the form X' T X, where X has condition
133 *> SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
134 *> with random complex angles on the diagonal and random O(1)
135 *> entries in the upper triangle.
136 *>
137 *> (14) A matrix of the form X' T X, where X has condition
138 *> SQRT( ULP ) and T has geometrically spaced entries
139 *> 1, ..., ULP with random complex angles on the diagonal
140 *> and random O(1) entries in the upper triangle.
141 *>
142 *> (15) A matrix of the form X' T X, where X has condition
143 *> SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
144 *> with random complex angles on the diagonal and random O(1)
145 *> entries in the upper triangle.
146 *>
147 *> (16) A matrix of the form X' T X, where X has condition
148 *> SQRT( ULP ) and T has complex eigenvalues randomly chosen
149 *> from ULP < |z| < 1 and random O(1) entries in the upper
150 *> triangle.
151 *>
152 *> (17) Same as (16), but multiplied by a constant
153 *> near the overflow threshold
154 *> (18) Same as (16), but multiplied by a constant
155 *> near the underflow threshold
156 *>
157 *> (19) Nonsymmetric matrix with random entries chosen from (-1,1).
158 *> If N is at least 4, all entries in first two rows and last
159 *> row, and first column and last two columns are zero.
160 *> (20) Same as (19), but multiplied by a constant
161 *> near the overflow threshold
162 *> (21) Same as (19), but multiplied by a constant
163 *> near the underflow threshold
164 *> \endverbatim
165 *
166 * Arguments:
167 * ==========
168 *
169 *> \param[in] NSIZES
170 *> \verbatim
171 *> NSIZES is INTEGER
172 *> The number of sizes of matrices to use. If it is zero,
173 *> CDRVES does nothing. It must be at least zero.
174 *> \endverbatim
175 *>
176 *> \param[in] NN
177 *> \verbatim
178 *> NN is INTEGER array, dimension (NSIZES)
179 *> An array containing the sizes to be used for the matrices.
180 *> Zero values will be skipped. The values must be at least
181 *> zero.
182 *> \endverbatim
183 *>
184 *> \param[in] NTYPES
185 *> \verbatim
186 *> NTYPES is INTEGER
187 *> The number of elements in DOTYPE. If it is zero, CDRVES
188 *> does nothing. It must be at least zero. If it is MAXTYP+1
189 *> and NSIZES is 1, then an additional type, MAXTYP+1 is
190 *> defined, which is to use whatever matrix is in A. This
191 *> is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
192 *> DOTYPE(MAXTYP+1) is .TRUE. .
193 *> \endverbatim
194 *>
195 *> \param[in] DOTYPE
196 *> \verbatim
197 *> DOTYPE is LOGICAL array, dimension (NTYPES)
198 *> If DOTYPE(j) is .TRUE., then for each size in NN a
199 *> matrix of that size and of type j will be generated.
200 *> If NTYPES is smaller than the maximum number of types
201 *> defined (PARAMETER MAXTYP), then types NTYPES+1 through
202 *> MAXTYP will not be generated. If NTYPES is larger
203 *> than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
204 *> will be ignored.
205 *> \endverbatim
206 *>
207 *> \param[in,out] ISEED
208 *> \verbatim
209 *> ISEED is INTEGER array, dimension (4)
210 *> On entry ISEED specifies the seed of the random number
211 *> generator. The array elements should be between 0 and 4095;
212 *> if not they will be reduced mod 4096. Also, ISEED(4) must
213 *> be odd. The random number generator uses a linear
214 *> congruential sequence limited to small integers, and so
215 *> should produce machine independent random numbers. The
216 *> values of ISEED are changed on exit, and can be used in the
217 *> next call to CDRVES to continue the same random number
218 *> sequence.
219 *> \endverbatim
220 *>
221 *> \param[in] THRESH
222 *> \verbatim
223 *> THRESH is REAL
224 *> A test will count as "failed" if the "error", computed as
225 *> described above, exceeds THRESH. Note that the error
226 *> is scaled to be O(1), so THRESH should be a reasonably
227 *> small multiple of 1, e.g., 10 or 100. In particular,
228 *> it should not depend on the precision (single vs. double)
229 *> or the size of the matrix. It must be at least zero.
230 *> \endverbatim
231 *>
232 *> \param[in] NOUNIT
233 *> \verbatim
234 *> NOUNIT is INTEGER
235 *> The FORTRAN unit number for printing out error messages
236 *> (e.g., if a routine returns INFO not equal to 0.)
237 *> \endverbatim
238 *>
239 *> \param[out] A
240 *> \verbatim
241 *> A is COMPLEX array, dimension (LDA, max(NN))
242 *> Used to hold the matrix whose eigenvalues are to be
243 *> computed. On exit, A contains the last matrix actually used.
244 *> \endverbatim
245 *>
246 *> \param[in] LDA
247 *> \verbatim
248 *> LDA is INTEGER
249 *> The leading dimension of A, and H. LDA must be at
250 *> least 1 and at least max( NN ).
251 *> \endverbatim
252 *>
253 *> \param[out] H
254 *> \verbatim
255 *> H is COMPLEX array, dimension (LDA, max(NN))
256 *> Another copy of the test matrix A, modified by CGEES.
257 *> \endverbatim
258 *>
259 *> \param[out] HT
260 *> \verbatim
261 *> HT is COMPLEX array, dimension (LDA, max(NN))
262 *> Yet another copy of the test matrix A, modified by CGEES.
263 *> \endverbatim
264 *>
265 *> \param[out] W
266 *> \verbatim
267 *> W is COMPLEX array, dimension (max(NN))
268 *> The computed eigenvalues of A.
269 *> \endverbatim
270 *>
271 *> \param[out] WT
272 *> \verbatim
273 *> WT is COMPLEX array, dimension (max(NN))
274 *> Like W, this array contains the eigenvalues of A,
275 *> but those computed when CGEES only computes a partial
276 *> eigendecomposition, i.e. not Schur vectors
277 *> \endverbatim
278 *>
279 *> \param[out] VS
280 *> \verbatim
281 *> VS is COMPLEX array, dimension (LDVS, max(NN))
282 *> VS holds the computed Schur vectors.
283 *> \endverbatim
284 *>
285 *> \param[in] LDVS
286 *> \verbatim
287 *> LDVS is INTEGER
288 *> Leading dimension of VS. Must be at least max(1,max(NN)).
289 *> \endverbatim
290 *>
291 *> \param[out] RESULT
292 *> \verbatim
293 *> RESULT is REAL array, dimension (13)
294 *> The values computed by the 13 tests described above.
295 *> The values are currently limited to 1/ulp, to avoid overflow.
296 *> \endverbatim
297 *>
298 *> \param[out] WORK
299 *> \verbatim
300 *> WORK is COMPLEX array, dimension (NWORK)
301 *> \endverbatim
302 *>
303 *> \param[in] NWORK
304 *> \verbatim
305 *> NWORK is INTEGER
306 *> The number of entries in WORK. This must be at least
307 *> 5*NN(j)+2*NN(j)**2 for all j.
308 *> \endverbatim
309 *>
310 *> \param[out] RWORK
311 *> \verbatim
312 *> RWORK is REAL array, dimension (max(NN))
313 *> \endverbatim
314 *>
315 *> \param[out] IWORK
316 *> \verbatim
317 *> IWORK is INTEGER array, dimension (max(NN))
318 *> \endverbatim
319 *>
320 *> \param[out] BWORK
321 *> \verbatim
322 *> BWORK is LOGICAL array, dimension (max(NN))
323 *> \endverbatim
324 *>
325 *> \param[out] INFO
326 *> \verbatim
327 *> INFO is INTEGER
328 *> If 0, then everything ran OK.
329 *> -1: NSIZES < 0
330 *> -2: Some NN(j) < 0
331 *> -3: NTYPES < 0
332 *> -6: THRESH < 0
333 *> -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
334 *> -15: LDVS < 1 or LDVS < NMAX, where NMAX is max( NN(j) ).
335 *> -18: NWORK too small.
336 *> If CLATMR, CLATMS, CLATME or CGEES returns an error code,
337 *> the absolute value of it is returned.
338 *>
339 *>-----------------------------------------------------------------------
340 *>
341 *> Some Local Variables and Parameters:
342 *> ---- ----- --------- --- ----------
343 *> ZERO, ONE Real 0 and 1.
344 *> MAXTYP The number of types defined.
345 *> NMAX Largest value in NN.
346 *> NERRS The number of tests which have exceeded THRESH
347 *> COND, CONDS,
348 *> IMODE Values to be passed to the matrix generators.
349 *> ANORM Norm of A; passed to matrix generators.
350 *>
351 *> OVFL, UNFL Overflow and underflow thresholds.
352 *> ULP, ULPINV Finest relative precision and its inverse.
353 *> RTULP, RTULPI Square roots of the previous 4 values.
354 *> The following four arrays decode JTYPE:
355 *> KTYPE(j) The general type (1-10) for type "j".
356 *> KMODE(j) The MODE value to be passed to the matrix
357 *> generator for type "j".
358 *> KMAGN(j) The order of magnitude ( O(1),
359 *> O(overflow^(1/2) ), O(underflow^(1/2) )
360 *> KCONDS(j) Select whether CONDS is to be 1 or
361 *> 1/sqrt(ulp). (0 means irrelevant.)
362 *> \endverbatim
363 *
364 * Authors:
365 * ========
366 *
367 *> \author Univ. of Tennessee
368 *> \author Univ. of California Berkeley
369 *> \author Univ. of Colorado Denver
370 *> \author NAG Ltd.
371 *
372 *> \date June 2016
373 *
374 *> \ingroup complex_eig
375 *
376 * =====================================================================
377  SUBROUTINE cdrves( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
378  \$ nounit, a, lda, h, ht, w, wt, vs, ldvs, result,
379  \$ work, nwork, rwork, iwork, bwork, info )
380 *
381 * -- LAPACK test routine (version 3.6.1) --
382 * -- LAPACK is a software package provided by Univ. of Tennessee, --
383 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
384 * June 2016
385 *
386 * .. Scalar Arguments ..
387  INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK
388  REAL THRESH
389 * ..
390 * .. Array Arguments ..
391  LOGICAL BWORK( * ), DOTYPE( * )
392  INTEGER ISEED( 4 ), IWORK( * ), NN( * )
393  REAL RESULT( 13 ), RWORK( * )
394  COMPLEX A( lda, * ), H( lda, * ), HT( lda, * ),
395  \$ vs( ldvs, * ), w( * ), work( * ), wt( * )
396 * ..
397 *
398 * =====================================================================
399 *
400 * .. Parameters ..
401  COMPLEX CZERO
402  parameter ( czero = ( 0.0e+0, 0.0e+0 ) )
403  COMPLEX CONE
404  parameter ( cone = ( 1.0e+0, 0.0e+0 ) )
405  REAL ZERO, ONE
406  parameter ( zero = 0.0e+0, one = 1.0e+0 )
407  INTEGER MAXTYP
408  parameter ( maxtyp = 21 )
409 * ..
410 * .. Local Scalars ..
411  LOGICAL BADNN
412  CHARACTER SORT
413  CHARACTER*3 PATH
414  INTEGER I, IINFO, IMODE, ISORT, ITYPE, IWK, J, JCOL,
415  \$ jsize, jtype, knteig, lwork, mtypes, n,
416  \$ nerrs, nfail, nmax, nnwork, ntest, ntestf,
417  \$ ntestt, rsub, sdim
418  REAL ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
419  \$ ulpinv, unfl
420 * ..
421 * .. Local Arrays ..
422  INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( maxtyp ),
423  \$ kmagn( maxtyp ), kmode( maxtyp ),
424  \$ ktype( maxtyp )
425  REAL RES( 2 )
426 * ..
427 * .. Arrays in Common ..
428  LOGICAL SELVAL( 20 )
429  REAL SELWI( 20 ), SELWR( 20 )
430 * ..
431 * .. Scalars in Common ..
432  INTEGER SELDIM, SELOPT
433 * ..
434 * .. Common blocks ..
435  COMMON / sslct / selopt, seldim, selval, selwr, selwi
436 * ..
437 * .. External Functions ..
438  LOGICAL CSLECT
439  REAL SLAMCH
440  EXTERNAL cslect, slamch
441 * ..
442 * .. External Subroutines ..
443  EXTERNAL cgees, chst01, clacpy, clatme, clatmr, clatms,
445 * ..
446 * .. Intrinsic Functions ..
447  INTRINSIC abs, cmplx, max, min, sqrt
448 * ..
449 * .. Data statements ..
450  DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
451  DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
452  \$ 3, 1, 2, 3 /
453  DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
454  \$ 1, 5, 5, 5, 4, 3, 1 /
455  DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
456 * ..
457 * .. Executable Statements ..
458 *
459  path( 1: 1 ) = 'Complex precision'
460  path( 2: 3 ) = 'ES'
461 *
462 * Check for errors
463 *
464  ntestt = 0
465  ntestf = 0
466  info = 0
467  selopt = 0
468 *
469 * Important constants
470 *
471  badnn = .false.
472  nmax = 0
473  DO 10 j = 1, nsizes
474  nmax = max( nmax, nn( j ) )
475  IF( nn( j ).LT.0 )
476  \$ badnn = .true.
477  10 CONTINUE
478 *
479 * Check for errors
480 *
481  IF( nsizes.LT.0 ) THEN
482  info = -1
483  ELSE IF( badnn ) THEN
484  info = -2
485  ELSE IF( ntypes.LT.0 ) THEN
486  info = -3
487  ELSE IF( thresh.LT.zero ) THEN
488  info = -6
489  ELSE IF( nounit.LE.0 ) THEN
490  info = -7
491  ELSE IF( lda.LT.1 .OR. lda.LT.nmax ) THEN
492  info = -9
493  ELSE IF( ldvs.LT.1 .OR. ldvs.LT.nmax ) THEN
494  info = -15
495  ELSE IF( 5*nmax+2*nmax**2.GT.nwork ) THEN
496  info = -18
497  END IF
498 *
499  IF( info.NE.0 ) THEN
500  CALL xerbla( 'CDRVES', -info )
501  RETURN
502  END IF
503 *
504 * Quick return if nothing to do
505 *
506  IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
507  \$ RETURN
508 *
509 * More Important constants
510 *
511  unfl = slamch( 'Safe minimum' )
512  ovfl = one / unfl
513  CALL slabad( unfl, ovfl )
514  ulp = slamch( 'Precision' )
515  ulpinv = one / ulp
516  rtulp = sqrt( ulp )
517  rtulpi = one / rtulp
518 *
519 * Loop over sizes, types
520 *
521  nerrs = 0
522 *
523  DO 240 jsize = 1, nsizes
524  n = nn( jsize )
525  IF( nsizes.NE.1 ) THEN
526  mtypes = min( maxtyp, ntypes )
527  ELSE
528  mtypes = min( maxtyp+1, ntypes )
529  END IF
530 *
531  DO 230 jtype = 1, mtypes
532  IF( .NOT.dotype( jtype ) )
533  \$ GO TO 230
534 *
535 * Save ISEED in case of an error.
536 *
537  DO 20 j = 1, 4
538  ioldsd( j ) = iseed( j )
539  20 CONTINUE
540 *
541 * Compute "A"
542 *
543 * Control parameters:
544 *
545 * KMAGN KCONDS KMODE KTYPE
546 * =1 O(1) 1 clustered 1 zero
547 * =2 large large clustered 2 identity
548 * =3 small exponential Jordan
549 * =4 arithmetic diagonal, (w/ eigenvalues)
550 * =5 random log symmetric, w/ eigenvalues
551 * =6 random general, w/ eigenvalues
552 * =7 random diagonal
553 * =8 random symmetric
554 * =9 random general
555 * =10 random triangular
556 *
557  IF( mtypes.GT.maxtyp )
558  \$ GO TO 90
559 *
560  itype = ktype( jtype )
561  imode = kmode( jtype )
562 *
563 * Compute norm
564 *
565  GO TO ( 30, 40, 50 )kmagn( jtype )
566 *
567  30 CONTINUE
568  anorm = one
569  GO TO 60
570 *
571  40 CONTINUE
572  anorm = ovfl*ulp
573  GO TO 60
574 *
575  50 CONTINUE
576  anorm = unfl*ulpinv
577  GO TO 60
578 *
579  60 CONTINUE
580 *
581  CALL claset( 'Full', lda, n, czero, czero, a, lda )
582  iinfo = 0
583  cond = ulpinv
584 *
585 * Special Matrices -- Identity & Jordan block
586 *
587  IF( itype.EQ.1 ) THEN
588 *
589 * Zero
590 *
591  iinfo = 0
592 *
593  ELSE IF( itype.EQ.2 ) THEN
594 *
595 * Identity
596 *
597  DO 70 jcol = 1, n
598  a( jcol, jcol ) = cmplx( anorm )
599  70 CONTINUE
600 *
601  ELSE IF( itype.EQ.3 ) THEN
602 *
603 * Jordan Block
604 *
605  DO 80 jcol = 1, n
606  a( jcol, jcol ) = cmplx( anorm )
607  IF( jcol.GT.1 )
608  \$ a( jcol, jcol-1 ) = cone
609  80 CONTINUE
610 *
611  ELSE IF( itype.EQ.4 ) THEN
612 *
613 * Diagonal Matrix, [Eigen]values Specified
614 *
615  CALL clatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
616  \$ anorm, 0, 0, 'N', a, lda, work( n+1 ),
617  \$ iinfo )
618 *
619  ELSE IF( itype.EQ.5 ) THEN
620 *
621 * Symmetric, eigenvalues specified
622 *
623  CALL clatms( n, n, 'S', iseed, 'H', rwork, imode, cond,
624  \$ anorm, n, n, 'N', a, lda, work( n+1 ),
625  \$ iinfo )
626 *
627  ELSE IF( itype.EQ.6 ) THEN
628 *
629 * General, eigenvalues specified
630 *
631  IF( kconds( jtype ).EQ.1 ) THEN
632  conds = one
633  ELSE IF( kconds( jtype ).EQ.2 ) THEN
634  conds = rtulpi
635  ELSE
636  conds = zero
637  END IF
638 *
639  CALL clatme( n, 'D', iseed, work, imode, cond, cone,
640  \$ 'T', 'T', 'T', rwork, 4, conds, n, n, anorm,
641  \$ a, lda, work( 2*n+1 ), iinfo )
642 *
643  ELSE IF( itype.EQ.7 ) THEN
644 *
645 * Diagonal, random eigenvalues
646 *
647  CALL clatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
648  \$ 'T', 'N', work( n+1 ), 1, one,
649  \$ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
650  \$ zero, anorm, 'NO', a, lda, iwork, iinfo )
651 *
652  ELSE IF( itype.EQ.8 ) THEN
653 *
654 * Symmetric, random eigenvalues
655 *
656  CALL clatmr( n, n, 'D', iseed, 'H', work, 6, one, cone,
657  \$ 'T', 'N', work( n+1 ), 1, one,
658  \$ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
659  \$ zero, anorm, 'NO', a, lda, iwork, iinfo )
660 *
661  ELSE IF( itype.EQ.9 ) THEN
662 *
663 * General, random eigenvalues
664 *
665  CALL clatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
666  \$ 'T', 'N', work( n+1 ), 1, one,
667  \$ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
668  \$ zero, anorm, 'NO', a, lda, iwork, iinfo )
669  IF( n.GE.4 ) THEN
670  CALL claset( 'Full', 2, n, czero, czero, a, lda )
671  CALL claset( 'Full', n-3, 1, czero, czero, a( 3, 1 ),
672  \$ lda )
673  CALL claset( 'Full', n-3, 2, czero, czero,
674  \$ a( 3, n-1 ), lda )
675  CALL claset( 'Full', 1, n, czero, czero, a( n, 1 ),
676  \$ lda )
677  END IF
678 *
679  ELSE IF( itype.EQ.10 ) THEN
680 *
681 * Triangular, random eigenvalues
682 *
683  CALL clatmr( n, n, 'D', iseed, 'N', work, 6, one, cone,
684  \$ 'T', 'N', work( n+1 ), 1, one,
685  \$ work( 2*n+1 ), 1, one, 'N', idumma, n, 0,
686  \$ zero, anorm, 'NO', a, lda, iwork, iinfo )
687 *
688  ELSE
689 *
690  iinfo = 1
691  END IF
692 *
693  IF( iinfo.NE.0 ) THEN
694  WRITE( nounit, fmt = 9992 )'Generator', iinfo, n, jtype,
695  \$ ioldsd
696  info = abs( iinfo )
697  RETURN
698  END IF
699 *
700  90 CONTINUE
701 *
702 * Test for minimal and generous workspace
703 *
704  DO 220 iwk = 1, 2
705  IF( iwk.EQ.1 ) THEN
706  nnwork = 3*n
707  ELSE
708  nnwork = 5*n + 2*n**2
709  END IF
710  nnwork = max( nnwork, 1 )
711 *
712 * Initialize RESULT
713 *
714  DO 100 j = 1, 13
715  result( j ) = -one
716  100 CONTINUE
717 *
718 * Test with and without sorting of eigenvalues
719 *
720  DO 180 isort = 0, 1
721  IF( isort.EQ.0 ) THEN
722  sort = 'N'
723  rsub = 0
724  ELSE
725  sort = 'S'
726  rsub = 6
727  END IF
728 *
729 * Compute Schur form and Schur vectors, and test them
730 *
731  CALL clacpy( 'F', n, n, a, lda, h, lda )
732  CALL cgees( 'V', sort, cslect, n, h, lda, sdim, w, vs,
733  \$ ldvs, work, nnwork, rwork, bwork, iinfo )
734  IF( iinfo.NE.0 ) THEN
735  result( 1+rsub ) = ulpinv
736  WRITE( nounit, fmt = 9992 )'CGEES1', iinfo, n,
737  \$ jtype, ioldsd
738  info = abs( iinfo )
739  GO TO 190
740  END IF
741 *
742 * Do Test (1) or Test (7)
743 *
744  result( 1+rsub ) = zero
745  DO 120 j = 1, n - 1
746  DO 110 i = j + 1, n
747  IF( h( i, j ).NE.zero )
748  \$ result( 1+rsub ) = ulpinv
749  110 CONTINUE
750  120 CONTINUE
751 *
752 * Do Tests (2) and (3) or Tests (8) and (9)
753 *
754  lwork = max( 1, 2*n*n )
755  CALL chst01( n, 1, n, a, lda, h, lda, vs, ldvs, work,
756  \$ lwork, rwork, res )
757  result( 2+rsub ) = res( 1 )
758  result( 3+rsub ) = res( 2 )
759 *
760 * Do Test (4) or Test (10)
761 *
762  result( 4+rsub ) = zero
763  DO 130 i = 1, n
764  IF( h( i, i ).NE.w( i ) )
765  \$ result( 4+rsub ) = ulpinv
766  130 CONTINUE
767 *
768 * Do Test (5) or Test (11)
769 *
770  CALL clacpy( 'F', n, n, a, lda, ht, lda )
771  CALL cgees( 'N', sort, cslect, n, ht, lda, sdim, wt,
772  \$ vs, ldvs, work, nnwork, rwork, bwork,
773  \$ iinfo )
774  IF( iinfo.NE.0 ) THEN
775  result( 5+rsub ) = ulpinv
776  WRITE( nounit, fmt = 9992 )'CGEES2', iinfo, n,
777  \$ jtype, ioldsd
778  info = abs( iinfo )
779  GO TO 190
780  END IF
781 *
782  result( 5+rsub ) = zero
783  DO 150 j = 1, n
784  DO 140 i = 1, n
785  IF( h( i, j ).NE.ht( i, j ) )
786  \$ result( 5+rsub ) = ulpinv
787  140 CONTINUE
788  150 CONTINUE
789 *
790 * Do Test (6) or Test (12)
791 *
792  result( 6+rsub ) = zero
793  DO 160 i = 1, n
794  IF( w( i ).NE.wt( i ) )
795  \$ result( 6+rsub ) = ulpinv
796  160 CONTINUE
797 *
798 * Do Test (13)
799 *
800  IF( isort.EQ.1 ) THEN
801  result( 13 ) = zero
802  knteig = 0
803  DO 170 i = 1, n
804  IF( cslect( w( i ) ) )
805  \$ knteig = knteig + 1
806  IF( i.LT.n ) THEN
807  IF( cslect( w( i+1 ) ) .AND.
808  \$ ( .NOT.cslect( w( i ) ) ) )result( 13 )
809  \$ = ulpinv
810  END IF
811  170 CONTINUE
812  IF( sdim.NE.knteig )
813  \$ result( 13 ) = ulpinv
814  END IF
815 *
816  180 CONTINUE
817 *
818 * End of Loop -- Check for RESULT(j) > THRESH
819 *
820  190 CONTINUE
821 *
822  ntest = 0
823  nfail = 0
824  DO 200 j = 1, 13
825  IF( result( j ).GE.zero )
826  \$ ntest = ntest + 1
827  IF( result( j ).GE.thresh )
828  \$ nfail = nfail + 1
829  200 CONTINUE
830 *
831  IF( nfail.GT.0 )
832  \$ ntestf = ntestf + 1
833  IF( ntestf.EQ.1 ) THEN
834  WRITE( nounit, fmt = 9999 )path
835  WRITE( nounit, fmt = 9998 )
836  WRITE( nounit, fmt = 9997 )
837  WRITE( nounit, fmt = 9996 )
838  WRITE( nounit, fmt = 9995 )thresh
839  WRITE( nounit, fmt = 9994 )
840  ntestf = 2
841  END IF
842 *
843  DO 210 j = 1, 13
844  IF( result( j ).GE.thresh ) THEN
845  WRITE( nounit, fmt = 9993 )n, iwk, ioldsd, jtype,
846  \$ j, result( j )
847  END IF
848  210 CONTINUE
849 *
850  nerrs = nerrs + nfail
851  ntestt = ntestt + ntest
852 *
853  220 CONTINUE
854  230 CONTINUE
855  240 CONTINUE
856 *
857 * Summary
858 *
859  CALL slasum( path, nounit, nerrs, ntestt )
860 *
861  9999 FORMAT( / 1x, a3, ' -- Complex Schur Form Decomposition Driver',
862  \$ / ' Matrix types (see CDRVES for details): ' )
863 *
864  9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
865  \$ ' ', ' 5=Diagonal: geometr. spaced entries.',
866  \$ / ' 2=Identity matrix. ', ' 6=Diagona',
867  \$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
868  \$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
869  \$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
870  \$ 'mall, evenly spaced.' )
871  9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
872  \$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
873  \$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
874  \$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
875  \$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
876  \$ 'lex ', a6, / ' 12=Well-cond., random complex ', a6, ' ',
877  \$ ' 17=Ill-cond., large rand. complx ', a4, / ' 13=Ill-condi',
878  \$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
879  \$ ' complx ', a4 )
880  9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
881  \$ 'with small random entries.', / ' 20=Matrix with large ran',
882  \$ 'dom entries. ', / )
883  9995 FORMAT( ' Tests performed with test threshold =', f8.2,
884  \$ / ' ( A denotes A on input and T denotes A on output)',
885  \$ / / ' 1 = 0 if T in Schur form (no sort), ',
886  \$ ' 1/ulp otherwise', /
887  \$ ' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
888  \$ / ' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ',
889  \$ / ' 4 = 0 if W are eigenvalues of T (no sort),',
890  \$ ' 1/ulp otherwise', /
891  \$ ' 5 = 0 if T same no matter if VS computed (no sort),',
892  \$ ' 1/ulp otherwise', /
893  \$ ' 6 = 0 if W same no matter if VS computed (no sort)',
894  \$ ', 1/ulp otherwise' )
895  9994 FORMAT( ' 7 = 0 if T in Schur form (sort), ', ' 1/ulp otherwise',
896  \$ / ' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
897  \$ / ' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
898  \$ / ' 10 = 0 if W are eigenvalues of T (sort),',
899  \$ ' 1/ulp otherwise', /
900  \$ ' 11 = 0 if T same no matter if VS computed (sort),',
901  \$ ' 1/ulp otherwise', /
902  \$ ' 12 = 0 if W same no matter if VS computed (sort),',
903  \$ ' 1/ulp otherwise', /
904  \$ ' 13 = 0 if sorting successful, 1/ulp otherwise', / )
905  9993 FORMAT( ' N=', i5, ', IWK=', i2, ', seed=', 4( i4, ',' ),
906  \$ ' type ', i2, ', test(', i2, ')=', g10.3 )
907  9992 FORMAT( ' CDRVES: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
908  \$ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
909 *
910  RETURN
911 *
912 * End of CDRVES
913 *
914  END
subroutine clatmr(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, PACK, A, LDA, IWORK, INFO)
CLATMR
Definition: clatmr.f:492
subroutine cdrves(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, H, HT, W, WT, VS, LDVS, RESULT, WORK, NWORK, RWORK, IWORK, BWORK, INFO)
CDRVES
Definition: cdrves.f:380
subroutine slabad(SMALL, LARGE)
SLABAD
Definition: slabad.f:76
subroutine chst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RWORK, RESULT)
CHST01
Definition: chst01.f:142
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
subroutine cgees(JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, LDVS, WORK, LWORK, RWORK, BWORK, INFO)
CGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition: cgees.f:199
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: claset.f:108
subroutine clatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
CLATMS
Definition: clatms.f:334
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:105
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM
Definition: slasum.f:42
subroutine clatme(N, DIST, ISEED, D, MODE, COND, DMAX, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
CLATME
Definition: clatme.f:303