LAPACK 3.11.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ ddrves()

subroutine ddrves ( integer  NSIZES,
integer, dimension( * )  NN,
integer  NTYPES,
logical, dimension( * )  DOTYPE,
integer, dimension( 4 )  ISEED,
double precision  THRESH,
integer  NOUNIT,
double precision, dimension( lda, * )  A,
integer  LDA,
double precision, dimension( lda, * )  H,
double precision, dimension( lda, * )  HT,
double precision, dimension( * )  WR,
double precision, dimension( * )  WI,
double precision, dimension( * )  WRT,
double precision, dimension( * )  WIT,
double precision, dimension( ldvs, * )  VS,
integer  LDVS,
double precision, dimension( 13 )  RESULT,
double precision, dimension( * )  WORK,
integer  NWORK,
integer, dimension( * )  IWORK,
logical, dimension( * )  BWORK,
integer  INFO 
)

DDRVES

Purpose:
    DDRVES checks the nonsymmetric eigenvalue (Schur form) problem
    driver DGEES.

    When DDRVES 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,
          DDRVES 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, DDRVES
          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 DDRVES to continue the same random number
          sequence.
[in]THRESH
          THRESH is DOUBLE PRECISION
          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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDA, max(NN))
          Another copy of the test matrix A, modified by DGEES.
[out]HT
          HT is DOUBLE PRECISION array, dimension (LDA, max(NN))
          Yet another copy of the test matrix A, modified by DGEES.
[out]WR
          WR is DOUBLE PRECISION array, dimension (max(NN))
[out]WI
          WI is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (max(NN))
[out]WIT
          WIT is DOUBLE PRECISION array, dimension (max(NN))

          Like WR, WI, these arrays contain the eigenvalues of A,
          but those computed when DGEES only computes a partial
          eigendecomposition, i.e. not Schur vectors
[out]VS
          VS is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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  DLATMR, SLATMS, SLATME or DGEES 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.)
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 385 of file ddrves.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 DOUBLE PRECISION THRESH
396* ..
397* .. Array Arguments ..
398 LOGICAL BWORK( * ), DOTYPE( * )
399 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
400 DOUBLE PRECISION A( LDA, * ), H( LDA, * ), HT( LDA, * ),
401 $ RESULT( 13 ), VS( LDVS, * ), WI( * ), WIT( * ),
402 $ WORK( * ), WR( * ), WRT( * )
403* ..
404*
405* =====================================================================
406*
407* .. Parameters ..
408 DOUBLE PRECISION ZERO, ONE
409 parameter( zero = 0.0d0, one = 1.0d0 )
410 INTEGER MAXTYP
411 parameter( maxtyp = 21 )
412* ..
413* .. Local Scalars ..
414 LOGICAL BADNN
415 CHARACTER SORT
416 CHARACTER*3 PATH
417 INTEGER I, IINFO, IMODE, ISORT, ITYPE, IWK, J, JCOL,
418 $ JSIZE, JTYPE, KNTEIG, LWORK, MTYPES, N, NERRS,
419 $ NFAIL, NMAX, NNWORK, NTEST, NTESTF, NTESTT,
420 $ RSUB, SDIM
421 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TMP,
422 $ ULP, ULPINV, UNFL
423* ..
424* .. Local Arrays ..
425 CHARACTER ADUMMA( 1 )
426 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
427 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
428 $ KTYPE( MAXTYP )
429 DOUBLE PRECISION RES( 2 )
430* ..
431* .. Arrays in Common ..
432 LOGICAL SELVAL( 20 )
433 DOUBLE PRECISION 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 DSLECT
443 DOUBLE PRECISION DLAMCH
444 EXTERNAL dslect, dlamch
445* ..
446* .. External Subroutines ..
447 EXTERNAL dgees, dhst01, dlabad, dlacpy, dlaset, dlasum,
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 ) = 'Double 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*
475 badnn = .false.
476 nmax = 0
477 DO 10 j = 1, nsizes
478 nmax = max( nmax, nn( j ) )
479 IF( nn( j ).LT.0 )
480 $ badnn = .true.
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( 'DDRVES', -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 = dlamch( 'Safe minimum' )
516 ovfl = one / unfl
517 CALL dlabad( unfl, ovfl )
518 ulp = dlamch( '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 dlaset( '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 dlatms( 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 dlatms( 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 dlatme( 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 dlatmr( 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 dlatmr( 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 dlatmr( 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 dlaset( 'Full', 2, n, zero, zero, a, lda )
674 CALL dlaset( 'Full', n-3, 1, zero, zero, a( 3, 1 ),
675 $ lda )
676 CALL dlaset( 'Full', n-3, 2, zero, zero, a( 3, n-1 ),
677 $ lda )
678 CALL dlaset( '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 dlatmr( 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 dlacpy( 'F', n, n, a, lda, h, lda )
735 CALL dgees( 'V', sort, dslect, 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 )'DGEES1', 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 dhst01( 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 dlacpy( 'F', n, n, a, lda, ht, lda )
809 CALL dgees( 'N', sort, dslect, 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 )'DGEES2', 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( dslect( wr( i ), wi( i ) ) .OR.
843 $ dslect( wr( i ), -wi( i ) ) )
844 $ knteig = knteig + 1
845 IF( i.LT.n ) THEN
846 IF( ( dslect( wr( i+1 ),
847 $ wi( i+1 ) ) .OR. dslect( wr( i+1 ),
848 $ -wi( i+1 ) ) ) .AND.
849 $ ( .NOT.( dslect( wr( i ),
850 $ wi( i ) ) .OR. dslect( 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 dlasum( path, nounit, nerrs, ntestt )
904*
905 9999 FORMAT( / 1x, a3, ' -- Real Schur Form Decomposition Driver',
906 $ / ' Matrix types (see DDRVES 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( ' DDRVES: ', a, ' returned INFO=', i6, '.', / 9x, 'N=',
952 $ i6, ', JTYPE=', i6, ', ISEED=(', 3( i5, ',' ), i5, ')' )
953*
954 RETURN
955*
956* End of DDRVES
957*
double precision function dlamch(CMACH)
DLAMCH
Definition: dlamch.f:69
subroutine dlabad(SMALL, LARGE)
DLABAD
Definition: dlabad.f:74
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
Definition: dlacpy.f:103
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition: dlaset.f:110
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
subroutine dhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
DHST01
Definition: dhst01.f:134
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
Definition: dlasum.f:43
logical function dslect(ZR, ZI)
DSLECT
Definition: dslect.f:62
subroutine dlatmr(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)
DLATMR
Definition: dlatmr.f:471
subroutine dlatme(N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
DLATME
Definition: dlatme.f:332
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
Definition: dlatms.f:321
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 m...
Definition: dgees.f:216
Here is the call graph for this function:
Here is the caller graph for this function: