LAPACK  3.10.0 LAPACK: Linear Algebra PACKage

## ◆ sdrves()

 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.)```

Definition at line 385 of file sdrves.f.

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