LAPACK  3.6.1 LAPACK: Linear Algebra PACKage
 subroutine sdrves ( integer NSIZES, integer, dimension( * ) NN, integer NTYPES, logical, dimension( * ) DOTYPE, integer, dimension( 4 ) ISEED, real THRESH, integer NOUNIT, real, dimension( lda, * ) A, integer LDA, real, dimension( lda, * ) H, real, dimension( lda, * ) HT, real, dimension( * ) WR, real, dimension( * ) WI, real, dimension( * ) WRT, real, dimension( * ) WIT, real, dimension( ldvs, * ) VS, integer LDVS, real, dimension( 13 ) RESULT, real, dimension( * ) WORK, integer NWORK, integer, dimension( * ) IWORK, logical, dimension( * ) BWORK, integer INFO )

SDRVES

Purpose:
```    SDRVES checks the nonsymmetric eigenvalue (Schur form) problem
driver SGEES.

When SDRVES is called, a number of matrix "sizes" ("n's") and a
number of matrix "types" are specified.  For each size ("n")
and each type of matrix, one matrix will be generated and used
to test the nonsymmetric eigenroutines.  For each matrix, 13
tests will be performed:

(1)     0 if T is in Schur form, 1/ulp otherwise
(no sorting of eigenvalues)

(2)     | A - VS T VS' | / ( n |A| ulp )

Here VS is the matrix of Schur eigenvectors, and T is in Schur
form  (no sorting of eigenvalues).

(3)     | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).

(4)     0     if WR+sqrt(-1)*WI are eigenvalues of T
1/ulp otherwise
(no sorting of eigenvalues)

(5)     0     if T(with VS) = T(without VS),
1/ulp otherwise
(no sorting of eigenvalues)

(6)     0     if eigenvalues(with VS) = eigenvalues(without VS),
1/ulp otherwise
(no sorting of eigenvalues)

(7)     0 if T is in Schur form, 1/ulp otherwise
(with sorting of eigenvalues)

(8)     | A - VS T VS' | / ( n |A| ulp )

Here VS is the matrix of Schur eigenvectors, and T is in Schur
form  (with sorting of eigenvalues).

(9)     | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).

(10)    0     if WR+sqrt(-1)*WI are eigenvalues of T
1/ulp otherwise
(with sorting of eigenvalues)

(11)    0     if T(with VS) = T(without VS),
1/ulp otherwise
(with sorting of eigenvalues)

(12)    0     if eigenvalues(with VS) = eigenvalues(without VS),
1/ulp otherwise
(with sorting of eigenvalues)

(13)    if sorting worked and SDIM is the number of
eigenvalues which were SELECTed

The "sizes" are specified by an array NN(1:NSIZES); the value of
each element NN(j) specifies one size.
The "types" are specified by a logical array DOTYPE( 1:NTYPES );
if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
Currently, the list of possible types is:

(1)  The zero matrix.
(2)  The identity matrix.
(3)  A (transposed) Jordan block, with 1's on the diagonal.

(4)  A diagonal matrix with evenly spaced entries
1, ..., ULP  and random signs.
(ULP = (first number larger than 1) - 1 )
(5)  A diagonal matrix with geometrically spaced entries
1, ..., ULP  and random signs.
(6)  A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
and random signs.

(7)  Same as (4), but multiplied by a constant near
the overflow threshold
(8)  Same as (4), but multiplied by a constant near
the underflow threshold

(9)  A matrix of the form  U' T U, where U is orthogonal and
T has evenly spaced entries 1, ..., ULP with random signs
on the diagonal and random O(1) entries in the upper
triangle.

(10) A matrix of the form  U' T U, where U is orthogonal and
T has geometrically spaced entries 1, ..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.

(11) A matrix of the form  U' T U, where U is orthogonal and
T has "clustered" entries 1, ULP,..., ULP with random
signs on the diagonal and random O(1) entries in the upper
triangle.

(12) A matrix of the form  U' T U, where U is orthogonal and
T has real or complex conjugate paired eigenvalues randomly
chosen from ( ULP, 1 ) and random O(1) entries in the upper
triangle.

(13) A matrix of the form  X' T X, where X has condition
SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.

(14) A matrix of the form  X' T X, where X has condition
SQRT( ULP ) and T has geometrically spaced entries
1, ..., ULP with random signs on the diagonal and random
O(1) entries in the upper triangle.

(15) A matrix of the form  X' T X, where X has condition
SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
with random signs on the diagonal and random O(1) entries
in the upper triangle.

(16) A matrix of the form  X' T X, where X has condition
SQRT( ULP ) and T has real or complex conjugate paired
eigenvalues randomly chosen from ( ULP, 1 ) and random
O(1) entries in the upper triangle.

(17) Same as (16), but multiplied by a constant
near the overflow threshold
(18) Same as (16), but multiplied by a constant
near the underflow threshold

(19) Nonsymmetric matrix with random entries chosen from (-1,1).
If N is at least 4, all entries in first two rows and last
row, and first column and last two columns are zero.
(20) Same as (19), but multiplied by a constant
near the overflow threshold
(21) Same as (19), but multiplied by a constant
near the underflow threshold```
Parameters
 [in] NSIZES ``` NSIZES is INTEGER The number of sizes of matrices to use. If it is zero, SDRVES does nothing. It must be at least zero.``` [in] NN ``` NN is INTEGER array, dimension (NSIZES) An array containing the sizes to be used for the matrices. Zero values will be skipped. The values must be at least zero.``` [in] NTYPES ``` NTYPES is INTEGER The number of elements in DOTYPE. If it is zero, SDRVES does nothing. It must be at least zero. If it is MAXTYP+1 and NSIZES is 1, then an additional type, MAXTYP+1 is defined, which is to use whatever matrix is in A. This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .``` [in] DOTYPE ``` DOTYPE is LOGICAL array, dimension (NTYPES) If DOTYPE(j) is .TRUE., then for each size in NN a matrix of that size and of type j will be generated. If NTYPES is smaller than the maximum number of types defined (PARAMETER MAXTYP), then types NTYPES+1 through MAXTYP will not be generated. If NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) will be ignored.``` [in,out] ISEED ``` ISEED is INTEGER array, dimension (4) On entry ISEED specifies the seed of the random number generator. The array elements should be between 0 and 4095; if not they will be reduced mod 4096. Also, ISEED(4) must be odd. The random number generator uses a linear congruential sequence limited to small integers, and so should produce machine independent random numbers. The values of ISEED are changed on exit, and can be used in the next call to SDRVES to continue the same random number sequence.``` [in] THRESH ``` THRESH is REAL A test will count as "failed" if the "error", computed as described above, exceeds THRESH. Note that the error is scaled to be O(1), so THRESH should be a reasonably small multiple of 1, e.g., 10 or 100. In particular, it should not depend on the precision (single vs. double) or the size of the matrix. It must be at least zero.``` [in] NOUNIT ``` NOUNIT is INTEGER The FORTRAN unit number for printing out error messages (e.g., if a routine returns INFO not equal to 0.)``` [out] A ``` A is REAL array, dimension (LDA, max(NN)) Used to hold the matrix whose eigenvalues are to be computed. On exit, A contains the last matrix actually used.``` [in] LDA ``` LDA is INTEGER The leading dimension of A, and H. LDA must be at least 1 and at least max(NN).``` [out] H ``` H is REAL array, dimension (LDA, max(NN)) Another copy of the test matrix A, modified by SGEES.``` [out] HT ``` HT is REAL array, dimension (LDA, max(NN)) Yet another copy of the test matrix A, modified by SGEES.``` [out] WR ` WR is REAL array, dimension (max(NN))` [out] WI ``` WI is REAL array, dimension (max(NN)) The real and imaginary parts of the eigenvalues of A. On exit, WR + WI*i are the eigenvalues of the matrix in A.``` [out] WRT ` WRT is REAL array, dimension (max(NN))` [out] WIT ``` WIT is REAL array, dimension (max(NN)) Like WR, WI, these arrays contain the eigenvalues of A, but those computed when SGEES only computes a partial eigendecomposition, i.e. not Schur vectors``` [out] VS ``` VS is REAL array, dimension (LDVS, max(NN)) VS holds the computed Schur vectors.``` [in] LDVS ``` LDVS is INTEGER Leading dimension of VS. Must be at least max(1,max(NN)).``` [out] RESULT ``` RESULT is REAL array, dimension (13) The values computed by the 13 tests described above. The values are currently limited to 1/ulp, to avoid overflow.``` [out] WORK ` WORK is REAL array, dimension (NWORK)` [in] NWORK ``` NWORK is INTEGER The number of entries in WORK. This must be at least 5*NN(j)+2*NN(j)**2 for all j.``` [out] IWORK ` IWORK is INTEGER array, dimension (max(NN))` [out] BWORK ` BWORK is LOGICAL array, dimension (max(NN))` [out] INFO ``` INFO is INTEGER If 0, then everything ran OK. -1: NSIZES < 0 -2: Some NN(j) < 0 -3: NTYPES < 0 -6: THRESH < 0 -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). -17: LDVS < 1 or LDVS < NMAX, where NMAX is max( NN(j) ). -20: NWORK too small. If SLATMR, SLATMS, SLATME or SGEES returns an error code, the absolute value of it is returned. ----------------------------------------------------------------------- Some Local Variables and Parameters: ---- ----- --------- --- ---------- ZERO, ONE Real 0 and 1. MAXTYP The number of types defined. NMAX Largest value in NN. NERRS The number of tests which have exceeded THRESH COND, CONDS, IMODE Values to be passed to the matrix generators. ANORM Norm of A; passed to matrix generators. OVFL, UNFL Overflow and underflow thresholds. ULP, ULPINV Finest relative precision and its inverse. RTULP, RTULPI Square roots of the previous 4 values. The following four arrays decode JTYPE: KTYPE(j) The general type (1-10) for type "j". KMODE(j) The MODE value to be passed to the matrix generator for type "j". KMAGN(j) The order of magnitude ( O(1), O(overflow^(1/2) ), O(underflow^(1/2) ) KCONDS(j) Selectw whether CONDS is to be 1 or 1/sqrt(ulp). (0 means irrelevant.)```
Date
June 2016

Definition at line 390 of file sdrves.f.

390 *
391 * -- LAPACK test routine (version 3.6.1) --
392 * -- LAPACK is a software package provided by Univ. of Tennessee, --
393 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
394 * June 2016
395 *
396 * .. Scalar Arguments ..
397  INTEGER info, lda, ldvs, nounit, nsizes, ntypes, nwork
398  REAL thresh
399 * ..
400 * .. Array Arguments ..
401  LOGICAL bwork( * ), dotype( * )
402  INTEGER iseed( 4 ), iwork( * ), nn( * )
403  REAL a( lda, * ), h( lda, * ), ht( lda, * ),
404  \$ result( 13 ), vs( ldvs, * ), wi( * ), wit( * ),
405  \$ work( * ), wr( * ), wrt( * )
406 * ..
407 *
408 * =====================================================================
409 *
410 * .. Parameters ..
411  REAL zero, one
412  parameter ( zero = 0.0e0, one = 1.0e0 )
413  INTEGER maxtyp
414  parameter ( maxtyp = 21 )
415 * ..
416 * .. Local Scalars ..
418  CHARACTER sort
419  CHARACTER*3 path
420  INTEGER i, iinfo, imode, isort, itype, iwk, j, jcol,
421  \$ jsize, jtype, knteig, lwork, mtypes, n,
422  \$ nerrs, nfail, nmax, nnwork, ntest, ntestf,
423  \$ ntestt, rsub, sdim
424  REAL anorm, cond, conds, ovfl, rtulp, rtulpi, tmp,
425  \$ ulp, ulpinv, unfl
426 * ..
427 * .. Local Arrays ..
429  INTEGER idumma( 1 ), ioldsd( 4 ), kconds( maxtyp ),
430  \$ kmagn( maxtyp ), kmode( maxtyp ),
431  \$ ktype( maxtyp )
432  REAL res( 2 )
433 * ..
434 * .. Arrays in Common ..
435  LOGICAL selval( 20 )
436  REAL selwi( 20 ), selwr( 20 )
437 * ..
438 * .. Scalars in Common ..
439  INTEGER seldim, selopt
440 * ..
441 * .. Common blocks ..
442  COMMON / sslct / selopt, seldim, selval, selwr, selwi
443 * ..
444 * .. External Functions ..
445  LOGICAL sslect
446  REAL slamch
447  EXTERNAL sslect, slamch
448 * ..
449 * .. External Subroutines ..
450  EXTERNAL sgees, shst01, slabad, slacpy, slasum, slatme,
452 * ..
453 * .. Intrinsic Functions ..
454  INTRINSIC abs, max, sign, sqrt
455 * ..
456 * .. Data statements ..
457  DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
458  DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
459  \$ 3, 1, 2, 3 /
460  DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
461  \$ 1, 5, 5, 5, 4, 3, 1 /
462  DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
463 * ..
464 * .. Executable Statements ..
465 *
466  path( 1: 1 ) = 'Single precision'
467  path( 2: 3 ) = 'ES'
468 *
469 * Check for errors
470 *
471  ntestt = 0
472  ntestf = 0
473  info = 0
474  selopt = 0
475 *
476 * Important constants
477 *
479  nmax = 0
480  DO 10 j = 1, nsizes
481  nmax = max( nmax, nn( j ) )
482  IF( nn( j ).LT.0 )
484  10 CONTINUE
485 *
486 * Check for errors
487 *
488  IF( nsizes.LT.0 ) THEN
489  info = -1
490  ELSE IF( badnn ) THEN
491  info = -2
492  ELSE IF( ntypes.LT.0 ) THEN
493  info = -3
494  ELSE IF( thresh.LT.zero ) THEN
495  info = -6
496  ELSE IF( nounit.LE.0 ) THEN
497  info = -7
498  ELSE IF( lda.LT.1 .OR. lda.LT.nmax ) THEN
499  info = -9
500  ELSE IF( ldvs.LT.1 .OR. ldvs.LT.nmax ) THEN
501  info = -17
502  ELSE IF( 5*nmax+2*nmax**2.GT.nwork ) THEN
503  info = -20
504  END IF
505 *
506  IF( info.NE.0 ) THEN
507  CALL xerbla( 'SDRVES', -info )
508  RETURN
509  END IF
510 *
511 * Quick return if nothing to do
512 *
513  IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
514  \$ RETURN
515 *
516 * More Important constants
517 *
518  unfl = slamch( 'Safe minimum' )
519  ovfl = one / unfl
520  CALL slabad( unfl, ovfl )
521  ulp = slamch( 'Precision' )
522  ulpinv = one / ulp
523  rtulp = sqrt( ulp )
524  rtulpi = one / rtulp
525 *
526 * Loop over sizes, types
527 *
528  nerrs = 0
529 *
530  DO 270 jsize = 1, nsizes
531  n = nn( jsize )
532  mtypes = maxtyp
533  IF( nsizes.EQ.1 .AND. ntypes.EQ.maxtyp+1 )
534  \$ mtypes = mtypes + 1
535 *
536  DO 260 jtype = 1, mtypes
537  IF( .NOT.dotype( jtype ) )
538  \$ GO TO 260
539 *
540 * Save ISEED in case of an error.
541 *
542  DO 20 j = 1, 4
543  ioldsd( j ) = iseed( j )
544  20 CONTINUE
545 *
546 * Compute "A"
547 *
548 * Control parameters:
549 *
550 * KMAGN KCONDS KMODE KTYPE
551 * =1 O(1) 1 clustered 1 zero
552 * =2 large large clustered 2 identity
553 * =3 small exponential Jordan
554 * =4 arithmetic diagonal, (w/ eigenvalues)
555 * =5 random log symmetric, w/ eigenvalues
556 * =6 random general, w/ eigenvalues
557 * =7 random diagonal
558 * =8 random symmetric
559 * =9 random general
560 * =10 random triangular
561 *
562  IF( mtypes.GT.maxtyp )
563  \$ GO TO 90
564 *
565  itype = ktype( jtype )
566  imode = kmode( jtype )
567 *
568 * Compute norm
569 *
570  GO TO ( 30, 40, 50 )kmagn( jtype )
571 *
572  30 CONTINUE
573  anorm = one
574  GO TO 60
575 *
576  40 CONTINUE
577  anorm = ovfl*ulp
578  GO TO 60
579 *
580  50 CONTINUE
581  anorm = unfl*ulpinv
582  GO TO 60
583 *
584  60 CONTINUE
585 *
586  CALL slaset( 'Full', lda, n, zero, zero, a, lda )
587  iinfo = 0
588  cond = ulpinv
589 *
590 * Special Matrices -- Identity & Jordan block
591 *
592 * Zero
593 *
594  IF( itype.EQ.1 ) THEN
595  iinfo = 0
596 *
597  ELSE IF( itype.EQ.2 ) THEN
598 *
599 * Identity
600 *
601  DO 70 jcol = 1, n
602  a( jcol, jcol ) = anorm
603  70 CONTINUE
604 *
605  ELSE IF( itype.EQ.3 ) THEN
606 *
607 * Jordan Block
608 *
609  DO 80 jcol = 1, n
610  a( jcol, jcol ) = anorm
611  IF( jcol.GT.1 )
612  \$ a( jcol, jcol-1 ) = one
613  80 CONTINUE
614 *
615  ELSE IF( itype.EQ.4 ) THEN
616 *
617 * Diagonal Matrix, [Eigen]values Specified
618 *
619  CALL slatms( n, n, 'S', iseed, 'S', work, imode, cond,
620  \$ anorm, 0, 0, 'N', a, lda, work( n+1 ),
621  \$ iinfo )
622 *
623  ELSE IF( itype.EQ.5 ) THEN
624 *
625 * Symmetric, eigenvalues specified
626 *
627  CALL slatms( n, n, 'S', iseed, 'S', work, imode, cond,
628  \$ anorm, n, n, 'N', a, lda, work( n+1 ),
629  \$ iinfo )
630 *
631  ELSE IF( itype.EQ.6 ) THEN
632 *
633 * General, eigenvalues specified
634 *
635  IF( kconds( jtype ).EQ.1 ) THEN
636  conds = one
637  ELSE IF( kconds( jtype ).EQ.2 ) THEN
638  conds = rtulpi
639  ELSE
640  conds = zero
641  END IF
642 *
643  adumma( 1 ) = ' '
644  CALL slatme( n, 'S', iseed, work, imode, cond, one,
645  \$ adumma, 'T', 'T', 'T', work( n+1 ), 4,
646  \$ conds, n, n, anorm, a, lda, work( 2*n+1 ),
647  \$ iinfo )
648 *
649  ELSE IF( itype.EQ.7 ) THEN
650 *
651 * Diagonal, random eigenvalues
652 *
653  CALL slatmr( n, n, 'S', iseed, 'S', work, 6, one, one,
654  \$ 'T', 'N', work( n+1 ), 1, one,
655  \$ work( 2*n+1 ), 1, one, 'N', idumma, 0, 0,
656  \$ zero, anorm, 'NO', a, lda, iwork, iinfo )
657 *
658  ELSE IF( itype.EQ.8 ) THEN
659 *
660 * Symmetric, random eigenvalues
661 *
662  CALL slatmr( n, n, 'S', iseed, 'S', work, 6, one, one,
663  \$ 'T', 'N', work( n+1 ), 1, one,
664  \$ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
665  \$ zero, anorm, 'NO', a, lda, iwork, iinfo )
666 *
667  ELSE IF( itype.EQ.9 ) THEN
668 *
669 * General, random eigenvalues
670 *
671  CALL slatmr( n, n, 'S', iseed, 'N', work, 6, one, one,
672  \$ 'T', 'N', work( n+1 ), 1, one,
673  \$ work( 2*n+1 ), 1, one, 'N', idumma, n, n,
674  \$ zero, anorm, 'NO', a, lda, iwork, iinfo )
675  IF( n.GE.4 ) THEN
676  CALL slaset( 'Full', 2, n, zero, zero, a, lda )
677  CALL slaset( 'Full', n-3, 1, zero, zero, a( 3, 1 ),
678  \$ lda )
679  CALL slaset( 'Full', n-3, 2, zero, zero, a( 3, n-1 ),
680  \$ lda )
681  CALL slaset( 'Full', 1, n, zero, zero, a( n, 1 ),
682  \$ lda )
683  END IF
684 *
685  ELSE IF( itype.EQ.10 ) THEN
686 *
687 * Triangular, random eigenvalues
688 *
689  CALL slatmr( n, n, 'S', iseed, 'N', work, 6, one, one,
690  \$ 'T', 'N', work( n+1 ), 1, one,
691  \$ work( 2*n+1 ), 1, one, 'N', idumma, n, 0,
692  \$ zero, anorm, 'NO', a, lda, iwork, iinfo )
693 *
694  ELSE
695 *
696  iinfo = 1
697  END IF
698 *
699  IF( iinfo.NE.0 ) THEN
700  WRITE( nounit, fmt = 9992 )'Generator', iinfo, n, jtype,
701  \$ ioldsd
702  info = abs( iinfo )
703  RETURN
704  END IF
705 *
706  90 CONTINUE
707 *
708 * Test for minimal and generous workspace
709 *
710  DO 250 iwk = 1, 2
711  IF( iwk.EQ.1 ) THEN
712  nnwork = 3*n
713  ELSE
714  nnwork = 5*n + 2*n**2
715  END IF
716  nnwork = max( nnwork, 1 )
717 *
718 * Initialize RESULT
719 *
720  DO 100 j = 1, 13
721  result( j ) = -one
722  100 CONTINUE
723 *
724 * Test with and without sorting of eigenvalues
725 *
726  DO 210 isort = 0, 1
727  IF( isort.EQ.0 ) THEN
728  sort = 'N'
729  rsub = 0
730  ELSE
731  sort = 'S'
732  rsub = 6
733  END IF
734 *
735 * Compute Schur form and Schur vectors, and test them
736 *
737  CALL slacpy( 'F', n, n, a, lda, h, lda )
738  CALL sgees( 'V', sort, sslect, n, h, lda, sdim, wr,
739  \$ wi, vs, ldvs, work, nnwork, bwork, iinfo )
740  IF( iinfo.NE.0 .AND. iinfo.NE.n+2 ) THEN
741  result( 1+rsub ) = ulpinv
742  WRITE( nounit, fmt = 9992 )'SGEES1', iinfo, n,
743  \$ jtype, ioldsd
744  info = abs( iinfo )
745  GO TO 220
746  END IF
747 *
748 * Do Test (1) or Test (7)
749 *
750  result( 1+rsub ) = zero
751  DO 120 j = 1, n - 2
752  DO 110 i = j + 2, n
753  IF( h( i, j ).NE.zero )
754  \$ result( 1+rsub ) = ulpinv
755  110 CONTINUE
756  120 CONTINUE
757  DO 130 i = 1, n - 2
758  IF( h( i+1, i ).NE.zero .AND. h( i+2, i+1 ).NE.
759  \$ zero )result( 1+rsub ) = ulpinv
760  130 CONTINUE
761  DO 140 i = 1, n - 1
762  IF( h( i+1, i ).NE.zero ) THEN
763  IF( h( i, i ).NE.h( i+1, i+1 ) .OR.
764  \$ h( i, i+1 ).EQ.zero .OR.
765  \$ sign( one, h( i+1, i ) ).EQ.
766  \$ sign( one, h( i, i+1 ) ) )result( 1+rsub )
767  \$ = ulpinv
768  END IF
769  140 CONTINUE
770 *
771 * Do Tests (2) and (3) or Tests (8) and (9)
772 *
773  lwork = max( 1, 2*n*n )
774  CALL shst01( n, 1, n, a, lda, h, lda, vs, ldvs, work,
775  \$ lwork, res )
776  result( 2+rsub ) = res( 1 )
777  result( 3+rsub ) = res( 2 )
778 *
779 * Do Test (4) or Test (10)
780 *
781  result( 4+rsub ) = zero
782  DO 150 i = 1, n
783  IF( h( i, i ).NE.wr( i ) )
784  \$ result( 4+rsub ) = ulpinv
785  150 CONTINUE
786  IF( n.GT.1 ) THEN
787  IF( h( 2, 1 ).EQ.zero .AND. wi( 1 ).NE.zero )
788  \$ result( 4+rsub ) = ulpinv
789  IF( h( n, n-1 ).EQ.zero .AND. wi( n ).NE.zero )
790  \$ result( 4+rsub ) = ulpinv
791  END IF
792  DO 160 i = 1, n - 1
793  IF( h( i+1, i ).NE.zero ) THEN
794  tmp = sqrt( abs( h( i+1, i ) ) )*
795  \$ sqrt( abs( h( i, i+1 ) ) )
796  result( 4+rsub ) = max( result( 4+rsub ),
797  \$ abs( wi( i )-tmp ) /
798  \$ max( ulp*tmp, unfl ) )
799  result( 4+rsub ) = max( result( 4+rsub ),
800  \$ abs( wi( i+1 )+tmp ) /
801  \$ max( ulp*tmp, unfl ) )
802  ELSE IF( i.GT.1 ) THEN
803  IF( h( i+1, i ).EQ.zero .AND. h( i, i-1 ).EQ.
804  \$ zero .AND. wi( i ).NE.zero )result( 4+rsub )
805  \$ = ulpinv
806  END IF
807  160 CONTINUE
808 *
809 * Do Test (5) or Test (11)
810 *
811  CALL slacpy( 'F', n, n, a, lda, ht, lda )
812  CALL sgees( 'N', sort, sslect, n, ht, lda, sdim, wrt,
813  \$ wit, vs, ldvs, work, nnwork, bwork,
814  \$ iinfo )
815  IF( iinfo.NE.0 .AND. iinfo.NE.n+2 ) THEN
816  result( 5+rsub ) = ulpinv
817  WRITE( nounit, fmt = 9992 )'SGEES2', iinfo, n,
818  \$ jtype, ioldsd
819  info = abs( iinfo )
820  GO TO 220
821  END IF
822 *
823  result( 5+rsub ) = zero
824  DO 180 j = 1, n
825  DO 170 i = 1, n
826  IF( h( i, j ).NE.ht( i, j ) )
827  \$ result( 5+rsub ) = ulpinv
828  170 CONTINUE
829  180 CONTINUE
830 *
831 * Do Test (6) or Test (12)
832 *
833  result( 6+rsub ) = zero
834  DO 190 i = 1, n
835  IF( wr( i ).NE.wrt( i ) .OR. wi( i ).NE.wit( i ) )
836  \$ result( 6+rsub ) = ulpinv
837  190 CONTINUE
838 *
839 * Do Test (13)
840 *
841  IF( isort.EQ.1 ) THEN
842  result( 13 ) = zero
843  knteig = 0
844  DO 200 i = 1, n
845  IF( sslect( wr( i ), wi( i ) ) .OR.
846  \$ sslect( wr( i ), -wi( i ) ) )
847  \$ knteig = knteig + 1
848  IF( i.LT.n ) THEN
849  IF( ( sslect( wr( i+1 ),
850  \$ wi( i+1 ) ) .OR. sslect( wr( i+1 ),
851  \$ -wi( i+1 ) ) ) .AND.
852  \$ ( .NOT.( sslect( wr( i ),
853  \$ wi( i ) ) .OR. sslect( wr( i ),
854  \$ -wi( i ) ) ) ) .AND. iinfo.NE.n+2 )
855  \$ result( 13 ) = ulpinv
856  END IF
857  200 CONTINUE
858  IF( sdim.NE.knteig ) THEN
859  result( 13 ) = ulpinv
860  END IF
861  END IF
862 *
863  210 CONTINUE
864 *
865 * End of Loop -- Check for RESULT(j) > THRESH
866 *
867  220 CONTINUE
868 *
869  ntest = 0
870  nfail = 0
871  DO 230 j = 1, 13
872  IF( result( j ).GE.zero )
873  \$ ntest = ntest + 1
874  IF( result( j ).GE.thresh )
875  \$ nfail = nfail + 1
876  230 CONTINUE
877 *
878  IF( nfail.GT.0 )
879  \$ ntestf = ntestf + 1
880  IF( ntestf.EQ.1 ) THEN
881  WRITE( nounit, fmt = 9999 )path
882  WRITE( nounit, fmt = 9998 )
883  WRITE( nounit, fmt = 9997 )
884  WRITE( nounit, fmt = 9996 )
885  WRITE( nounit, fmt = 9995 )thresh
886  WRITE( nounit, fmt = 9994 )
887  ntestf = 2
888  END IF
889 *
890  DO 240 j = 1, 13
891  IF( result( j ).GE.thresh ) THEN
892  WRITE( nounit, fmt = 9993 )n, iwk, ioldsd, jtype,
893  \$ j, result( j )
894  END IF
895  240 CONTINUE
896 *
897  nerrs = nerrs + nfail
898  ntestt = ntestt + ntest
899 *
900  250 CONTINUE
901  260 CONTINUE
902  270 CONTINUE
903 *
904 * Summary
905 *
906  CALL slasum( path, nounit, nerrs, ntestt )
907 *
908  9999 FORMAT( / 1x, a3, ' -- Real Schur Form Decomposition Driver',
909  \$ / ' Matrix types (see SDRVES for details): ' )
910 *
911  9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
912  \$ ' ', ' 5=Diagonal: geometr. spaced entries.',
913  \$ / ' 2=Identity matrix. ', ' 6=Diagona',
914  \$ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
915  \$ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
916  \$ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
917  \$ 'mall, evenly spaced.' )
918  9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
919  \$ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
920  \$ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
921  \$ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
922  \$ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
923  \$ 'lex ', / ' 12=Well-cond., random complex ', 6x, ' ',
924  \$ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
925  \$ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
926  \$ ' complx ' )
927  9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
928  \$ 'with small random entries.', / ' 20=Matrix with large ran',
929  \$ 'dom entries. ', / )
930  9995 FORMAT( ' Tests performed with test threshold =', f8.2,
931  \$ / ' ( A denotes A on input and T denotes A on output)',
932  \$ / / ' 1 = 0 if T in Schur form (no sort), ',
933  \$ ' 1/ulp otherwise', /
934  \$ ' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
935  \$ / ' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ', /
936  \$ ' 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (no sort),',
937  \$ ' 1/ulp otherwise', /
938  \$ ' 5 = 0 if T same no matter if VS computed (no sort),',
939  \$ ' 1/ulp otherwise', /
940  \$ ' 6 = 0 if WR, WI same no matter if VS computed (no sort)',
941  \$ ', 1/ulp otherwise' )
942  9994 FORMAT( ' 7 = 0 if T in Schur form (sort), ', ' 1/ulp otherwise',
943  \$ / ' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
944  \$ / ' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
945  \$ / ' 10 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (sort),',
946  \$ ' 1/ulp otherwise', /
947  \$ ' 11 = 0 if T same no matter if VS computed (sort),',
948  \$ ' 1/ulp otherwise', /
949  \$ ' 12 = 0 if WR, WI same no matter if VS computed (sort),',
950  \$ ' 1/ulp otherwise', /
951  \$ ' 13 = 0 if sorting successful, 1/ulp otherwise', / )
952  9993 FORMAT( ' N=', i5, ', IWK=', i2, ', seed=', 4( i4, ',' ),
953  \$ ' type ', i2, ', test(', i2, ')=', g10.3 )
954  9992 FORMAT( ' SDRVES: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
955  \$ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
956 *
957  RETURN
958 *
959 * End of SDRVES
960 *
subroutine sgees(JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI, VS, LDVS, WORK, LWORK, BWORK, INFO)
SGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors for GE ...
Definition: sgees.f:218
subroutine slatmr(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)
SLATMR
Definition: slatmr.f:473
subroutine shst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
SHST01
Definition: shst01.f:136
logical function sslect(ZR, ZI)
SSLECT
Definition: sslect.f:64
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
Definition: slacpy.f:105
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
Definition: slatms.f:323
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
Definition: slaset.f:112
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:69
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM
Definition: slasum.f:42
subroutine slatme(N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
SLATME
Definition: slatme.f:334

Here is the call graph for this function:

Here is the caller graph for this function: