385 SUBROUTINE sdrves( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
386 $ NOUNIT, A, LDA, H, HT, WR, WI, WRT, WIT, VS,
387 $ LDVS, RESULT, WORK, NWORK, IWORK, BWORK, INFO )
394 INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK
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( * )
409 PARAMETER ( ZERO = 0.0e0, one = 1.0e0 )
411 parameter( maxtyp = 21 )
417 INTEGER I, IINFO, IMODE, ISORT, ITYPE, IWK, J, JCOL,
418 $ jsize, jtype, knteig, lwork, mtypes, n,
419 $ nerrs, nfail, nmax, nnwork, ntest, ntestf,
421 REAL ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TMP,
425 CHARACTER ADUMMA( 1 )
426 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
427 $ kmagn( maxtyp ), kmode( maxtyp ),
433 REAL SELWI( 20 ), SELWR( 20 )
436 INTEGER SELDIM, SELOPT
439 COMMON / sslct / selopt, seldim, selval, selwr, selwi
444 EXTERNAL sslect, slamch
451 INTRINSIC abs, max, sign, sqrt
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,
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 /
463 path( 1: 1 ) =
'Single precision'
478 nmax = max( nmax, nn( j ) )
485 IF( nsizes.LT.0 )
THEN
487 ELSE IF( badnn )
THEN
489 ELSE IF( ntypes.LT.0 )
THEN
491 ELSE IF( thresh.LT.zero )
THEN
493 ELSE IF( nounit.LE.0 )
THEN
495 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
497 ELSE IF( ldvs.LT.1 .OR. ldvs.LT.nmax )
THEN
499 ELSE IF( 5*nmax+2*nmax**2.GT.nwork )
THEN
504 CALL xerbla(
'SDRVES', -info )
510 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
515 unfl = slamch(
'Safe minimum' )
518 ulp = slamch(
'Precision' )
527 DO 270 jsize = 1, nsizes
530 IF( nsizes.EQ.1 .AND. ntypes.EQ.maxtyp+1 )
531 $ mtypes = mtypes + 1
533 DO 260 jtype = 1, mtypes
534 IF( .NOT.dotype( jtype ) )
540 ioldsd( j ) = iseed( j )
559 IF( mtypes.GT.maxtyp )
562 itype = ktype( jtype )
563 imode = kmode( jtype )
567 GO TO ( 30, 40, 50 )kmagn( jtype )
583 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
591 IF( itype.EQ.1 )
THEN
594 ELSE IF( itype.EQ.2 )
THEN
599 a( jcol, jcol ) = anorm
602 ELSE IF( itype.EQ.3 )
THEN
607 a( jcol, jcol ) = anorm
609 $ a( jcol, jcol-1 ) = one
612 ELSE IF( itype.EQ.4 )
THEN
616 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
617 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
620 ELSE IF( itype.EQ.5 )
THEN
624 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
625 $ anorm, n, n,
'N', a, lda, work( n+1 ),
628 ELSE IF( itype.EQ.6 )
THEN
632 IF( kconds( jtype ).EQ.1 )
THEN
634 ELSE IF( kconds( jtype ).EQ.2 )
THEN
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 ),
646 ELSE IF( itype.EQ.7 )
THEN
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 )
655 ELSE IF( itype.EQ.8 )
THEN
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 )
664 ELSE IF( itype.EQ.9 )
THEN
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 )
673 CALL slaset(
'Full', 2, n, zero, zero, a, lda )
674 CALL slaset(
'Full', n-3, 1, zero, zero, a( 3, 1 ),
676 CALL slaset(
'Full', n-3, 2, zero, zero, a( 3, n-1 ),
678 CALL slaset(
'Full', 1, n, zero, zero, a( n, 1 ),
682 ELSE IF( itype.EQ.10 )
THEN
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 )
696 IF( iinfo.NE.0 )
THEN
697 WRITE( nounit, fmt = 9992 )
'Generator', iinfo, n, jtype,
711 nnwork = 5*n + 2*n**2
713 nnwork = max( nnwork, 1 )
724 IF( isort.EQ.0 )
THEN
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,
747 result( 1+rsub ) = zero
750 IF( h( i, j ).NE.zero )
751 $ result( 1+rsub ) = ulpinv
755 IF( h( i+1, i ).NE.zero .AND. h( i+2, i+1 ).NE.
756 $ zero )result( 1+rsub ) = ulpinv
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 )
770 lwork = max( 1, 2*n*n )
771 CALL shst01( n, 1, n, a, lda, h, lda, vs, ldvs, work,
773 result( 2+rsub ) = res( 1 )
774 result( 3+rsub ) = res( 2 )
778 result( 4+rsub ) = zero
780 IF( h( i, i ).NE.wr( i ) )
781 $ result( 4+rsub ) = ulpinv
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
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 )
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,
812 IF( iinfo.NE.0 .AND. iinfo.NE.n+2 )
THEN
813 result( 5+rsub ) = ulpinv
814 WRITE( nounit, fmt = 9992 )
'SGEES2', iinfo, n,
820 result( 5+rsub ) = zero
823 IF( h( i, j ).NE.ht( i, j ) )
824 $ result( 5+rsub ) = ulpinv
830 result( 6+rsub ) = zero
832 IF( wr( i ).NE.wrt( i ) .OR. wi( i ).NE.wit( i ) )
833 $ result( 6+rsub ) = ulpinv
838 IF( isort.EQ.1 )
THEN
842 IF( sslect( wr( i ), wi( i ) ) .OR.
843 $ sslect( wr( i ), -wi( i ) ) )
844 $ knteig = knteig + 1
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
855 IF( sdim.NE.knteig )
THEN
856 result( 13 ) = ulpinv
869 IF( result( j ).GE.zero )
871 IF( result( j ).GE.thresh )
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 )
888 IF( result( j ).GE.thresh )
THEN
889 WRITE( nounit, fmt = 9993 )n, iwk, ioldsd, jtype,
894 nerrs = nerrs + nfail
895 ntestt = ntestt + ntest
903 CALL slasum( path, nounit, nerrs, ntestt )
905 9999
FORMAT( / 1x, a3,
' -- Real Schur Form Decomposition Driver',
906 $ /
' Matrix types (see SDRVES for details): ' )
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.',
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,
')' )
subroutine slabad(SMALL, LARGE)
SLABAD
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.
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine slatme(N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, LDA, WORK, INFO)
SLATME
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
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...
subroutine sdrves(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NOUNIT, A, LDA, H, HT, WR, WI, WRT, WIT, VS, LDVS, RESULT, WORK, NWORK, IWORK, BWORK, INFO)
SDRVES
subroutine shst01(N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK, LWORK, RESULT)
SHST01
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM