387 SUBROUTINE ddrves( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
388 $ nounit, a, lda, h, ht, wr, wi, wrt, wit, vs,
389 $ ldvs, result, work, nwork, iwork, bwork, info )
397 INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK
398 DOUBLE PRECISION THRESH
401 LOGICAL BWORK( * ), DOTYPE( * )
402 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
403 DOUBLE PRECISION A( lda, * ), H( lda, * ), HT( lda, * ),
404 $ result( 13 ), vs( ldvs, * ), wi( * ), wit( * ),
405 $ work( * ), wr( * ), wrt( * )
411 DOUBLE PRECISION ZERO, ONE
412 parameter ( zero = 0.0d0, one = 1.0d0 )
414 parameter ( maxtyp = 21 )
420 INTEGER I, IINFO, IMODE, ISORT, ITYPE, IWK, J, JCOL,
421 $ jsize, jtype, knteig, lwork, mtypes, n, nerrs,
422 $ nfail, nmax, nnwork, ntest, ntestf, ntestt,
424 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TMP,
428 CHARACTER ADUMMA( 1 )
429 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( maxtyp ),
430 $ kmagn( maxtyp ), kmode( maxtyp ),
432 DOUBLE PRECISION RES( 2 )
436 DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
439 INTEGER SELDIM, SELOPT
442 COMMON / sslct / selopt, seldim, selval, selwr, selwi
446 DOUBLE PRECISION DLAMCH
447 EXTERNAL dslect, dlamch
454 INTRINSIC abs, max, sign, sqrt
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,
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 /
466 path( 1: 1 ) =
'Double precision'
481 nmax = max( nmax, nn( j ) )
488 IF( nsizes.LT.0 )
THEN
490 ELSE IF( badnn )
THEN
492 ELSE IF( ntypes.LT.0 )
THEN
494 ELSE IF( thresh.LT.zero )
THEN
496 ELSE IF( nounit.LE.0 )
THEN
498 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
500 ELSE IF( ldvs.LT.1 .OR. ldvs.LT.nmax )
THEN
502 ELSE IF( 5*nmax+2*nmax**2.GT.nwork )
THEN
507 CALL xerbla(
'DDRVES', -info )
513 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
518 unfl = dlamch(
'Safe minimum' )
521 ulp = dlamch(
'Precision' )
530 DO 270 jsize = 1, nsizes
533 IF( nsizes.EQ.1 .AND. ntypes.EQ.maxtyp+1 )
534 $ mtypes = mtypes + 1
536 DO 260 jtype = 1, mtypes
537 IF( .NOT.dotype( jtype ) )
543 ioldsd( j ) = iseed( j )
562 IF( mtypes.GT.maxtyp )
565 itype = ktype( jtype )
566 imode = kmode( jtype )
570 GO TO ( 30, 40, 50 )kmagn( jtype )
586 CALL dlaset(
'Full', lda, n, zero, zero, a, lda )
594 IF( itype.EQ.1 )
THEN
597 ELSE IF( itype.EQ.2 )
THEN
602 a( jcol, jcol ) = anorm
605 ELSE IF( itype.EQ.3 )
THEN
610 a( jcol, jcol ) = anorm
612 $ a( jcol, jcol-1 ) = one
615 ELSE IF( itype.EQ.4 )
THEN
619 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
620 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
623 ELSE IF( itype.EQ.5 )
THEN
627 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
628 $ anorm, n, n,
'N', a, lda, work( n+1 ),
631 ELSE IF( itype.EQ.6 )
THEN
635 IF( kconds( jtype ).EQ.1 )
THEN
637 ELSE IF( kconds( jtype ).EQ.2 )
THEN
644 CALL dlatme( 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 ),
649 ELSE IF( itype.EQ.7 )
THEN
653 CALL dlatmr( 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 )
658 ELSE IF( itype.EQ.8 )
THEN
662 CALL dlatmr( 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 )
667 ELSE IF( itype.EQ.9 )
THEN
671 CALL dlatmr( 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 )
676 CALL dlaset(
'Full', 2, n, zero, zero, a, lda )
677 CALL dlaset(
'Full', n-3, 1, zero, zero, a( 3, 1 ),
679 CALL dlaset(
'Full', n-3, 2, zero, zero, a( 3, n-1 ),
681 CALL dlaset(
'Full', 1, n, zero, zero, a( n, 1 ),
685 ELSE IF( itype.EQ.10 )
THEN
689 CALL dlatmr( 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 )
699 IF( iinfo.NE.0 )
THEN
700 WRITE( nounit, fmt = 9992 )
'Generator', iinfo, n, jtype,
714 nnwork = 5*n + 2*n**2
716 nnwork = max( nnwork, 1 )
727 IF( isort.EQ.0 )
THEN
737 CALL dlacpy(
'F', n, n, a, lda, h, lda )
738 CALL dgees(
'V', sort, dslect, 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 )
'DGEES1', iinfo, n,
750 result( 1+rsub ) = zero
753 IF( h( i, j ).NE.zero )
754 $ result( 1+rsub ) = ulpinv
758 IF( h( i+1, i ).NE.zero .AND. h( i+2, i+1 ).NE.
759 $ zero )result( 1+rsub ) = ulpinv
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 )
773 lwork = max( 1, 2*n*n )
774 CALL dhst01( n, 1, n, a, lda, h, lda, vs, ldvs, work,
776 result( 2+rsub ) = res( 1 )
777 result( 3+rsub ) = res( 2 )
781 result( 4+rsub ) = zero
783 IF( h( i, i ).NE.wr( i ) )
784 $ result( 4+rsub ) = ulpinv
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
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 )
811 CALL dlacpy(
'F', n, n, a, lda, ht, lda )
812 CALL dgees(
'N', sort, dslect, n, ht, lda, sdim, wrt,
813 $ wit, vs, ldvs, work, nnwork, bwork,
815 IF( iinfo.NE.0 .AND. iinfo.NE.n+2 )
THEN
816 result( 5+rsub ) = ulpinv
817 WRITE( nounit, fmt = 9992 )
'DGEES2', iinfo, n,
823 result( 5+rsub ) = zero
826 IF( h( i, j ).NE.ht( i, j ) )
827 $ result( 5+rsub ) = ulpinv
833 result( 6+rsub ) = zero
835 IF( wr( i ).NE.wrt( i ) .OR. wi( i ).NE.wit( i ) )
836 $ result( 6+rsub ) = ulpinv
841 IF( isort.EQ.1 )
THEN
845 IF( dslect( wr( i ), wi( i ) ) .OR.
846 $ dslect( wr( i ), -wi( i ) ) )
847 $ knteig = knteig + 1
849 IF( ( dslect( wr( i+1 ),
850 $ wi( i+1 ) ) .OR. dslect( wr( i+1 ),
851 $ -wi( i+1 ) ) ) .AND.
852 $ ( .NOT.( dslect( wr( i ),
853 $ wi( i ) ) .OR. dslect( wr( i ),
854 $ -wi( i ) ) ) ) .AND. iinfo.NE.n+2 )
855 $ result( 13 ) = ulpinv
858 IF( sdim.NE.knteig )
THEN
859 result( 13 ) = ulpinv
872 IF( result( j ).GE.zero )
874 IF( result( j ).GE.thresh )
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 )
891 IF( result( j ).GE.thresh )
THEN
892 WRITE( nounit, fmt = 9993 )n, iwk, ioldsd, jtype,
897 nerrs = nerrs + nfail
898 ntestt = ntestt + ntest
906 CALL dlasum( path, nounit, nerrs, ntestt )
908 9999
FORMAT( / 1x, a3,
' -- Real Schur Form Decomposition Driver',
909 $ /
' Matrix types (see DDRVES for details): ' )
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.',
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(
' DDRVES: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
955 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
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
subroutine dhst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
DHST01
subroutine dlatme(N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
DLATME
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...
subroutine ddrves(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, H, HT, WR, WI, WRT, WIT, VS, LDVS, RESULT, WORK, NWORK, IWORK, BWORK, INFO)
DDRVES
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlabad(SMALL, LARGE)
DLABAD
subroutine dlasum(TYPE, IOUNIT, IE, NRUN)
DLASUM
subroutine dlatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
DLATMS
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 ...