515 SUBROUTINE sdrvvx( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
516 $ NIUNIT, NOUNIT, A, LDA, H, WR, WI, WR1, WI1,
517 $ VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV, RCNDV1,
518 $ RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1,
519 $ RESULT, WORK, NWORK, IWORK, INFO )
526 INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT,
527 $ NSIZES, NTYPES, NWORK
532 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
533 REAL A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
534 $ RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
535 $ rcndv1( * ), rconde( * ), rcondv( * ),
536 $ result( 11 ), scale( * ), scale1( * ),
537 $ vl( ldvl, * ), vr( ldvr, * ), wi( * ),
538 $ wi1( * ), work( * ), wr( * ), wr1( * )
545 PARAMETER ( ZERO = 0.0e0, one = 1.0e0 )
547 PARAMETER ( MAXTYP = 21 )
553 INTEGER I, IBAL, IINFO, IMODE, ITYPE, IWK, J, JCOL,
554 $ jsize, jtype, mtypes, n, nerrs, nfail,
555 $ nmax, nnwork, ntest, ntestf, ntestt
556 REAL ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
560 CHARACTER ADUMMA( 1 ), BAL( 4 )
561 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
562 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
574 INTRINSIC abs, max, min, sqrt
577 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
578 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
580 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
581 $ 1, 5, 5, 5, 4, 3, 1 /
582 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
583 DATA bal /
'N',
'P',
'S',
'B' /
587 path( 1: 1 ) =
'Single precision'
605 nmax = max( nmax, nn( j ) )
612 IF( nsizes.LT.0 )
THEN
614 ELSE IF( badnn )
THEN
616 ELSE IF( ntypes.LT.0 )
THEN
618 ELSE IF( thresh.LT.zero )
THEN
620 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
622 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.nmax )
THEN
624 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.nmax )
THEN
626 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.nmax )
THEN
628 ELSE IF( 6*nmax+2*nmax**2.GT.nwork )
THEN
633 CALL xerbla(
'SDRVVX', -info )
639 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
644 unfl = slamch(
'Safe minimum' )
647 ulp = slamch(
'Precision' )
656 DO 150 jsize = 1, nsizes
658 IF( nsizes.NE.1 )
THEN
659 mtypes = min( maxtyp, ntypes )
661 mtypes = min( maxtyp+1, ntypes )
664 DO 140 jtype = 1, mtypes
665 IF( .NOT.dotype( jtype ) )
671 ioldsd( j ) = iseed( j )
690 IF( mtypes.GT.maxtyp )
693 itype = ktype( jtype )
694 imode = kmode( jtype )
698 GO TO ( 30, 40, 50 )kmagn( jtype )
714 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
722 IF( itype.EQ.1 )
THEN
725 ELSE IF( itype.EQ.2 )
THEN
730 a( jcol, jcol ) = anorm
733 ELSE IF( itype.EQ.3 )
THEN
738 a( jcol, jcol ) = anorm
740 $ a( jcol, jcol-1 ) = one
743 ELSE IF( itype.EQ.4 )
THEN
747 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
748 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
751 ELSE IF( itype.EQ.5 )
THEN
755 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
756 $ anorm, n, n,
'N', a, lda, work( n+1 ),
759 ELSE IF( itype.EQ.6 )
THEN
763 IF( kconds( jtype ).EQ.1 )
THEN
765 ELSE IF( kconds( jtype ).EQ.2 )
THEN
772 CALL slatme( n,
'S', iseed, work, imode, cond, one,
773 $ adumma,
'T',
'T',
'T', work( n+1 ), 4,
774 $ conds, n, n, anorm, a, lda, work( 2*n+1 ),
777 ELSE IF( itype.EQ.7 )
THEN
781 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
782 $
'T',
'N', work( n+1 ), 1, one,
783 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
784 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
786 ELSE IF( itype.EQ.8 )
THEN
790 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
791 $
'T',
'N', work( n+1 ), 1, one,
792 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
793 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
795 ELSE IF( itype.EQ.9 )
THEN
799 CALL slatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
800 $
'T',
'N', work( n+1 ), 1, one,
801 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
802 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
804 CALL slaset(
'Full', 2, n, zero, zero, a, lda )
805 CALL slaset(
'Full', n-3, 1, zero, zero, a( 3, 1 ),
807 CALL slaset(
'Full', n-3, 2, zero, zero, a( 3, n-1 ),
809 CALL slaset(
'Full', 1, n, zero, zero, a( n, 1 ),
813 ELSE IF( itype.EQ.10 )
THEN
817 CALL slatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
818 $
'T',
'N', work( n+1 ), 1, one,
819 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
820 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
827 IF( iinfo.NE.0 )
THEN
828 WRITE( nounit, fmt = 9992 )
'Generator', iinfo, n, jtype,
841 ELSE IF( iwk.EQ.2 )
THEN
844 nnwork = 6*n + 2*n**2
846 nnwork = max( nnwork, 1 )
855 CALL sget23( .false., balanc, jtype, thresh, ioldsd,
856 $ nounit, n, a, lda, h, wr, wi, wr1, wi1,
857 $ vl, ldvl, vr, ldvr, lre, ldlre, rcondv,
858 $ rcndv1, rcdvin, rconde, rcnde1, rcdein,
859 $ scale, scale1, result, work, nnwork,
867 IF( result( j ).GE.zero )
869 IF( result( j ).GE.thresh )
874 $ ntestf = ntestf + 1
875 IF( ntestf.EQ.1 )
THEN
876 WRITE( nounit, fmt = 9999 )path
877 WRITE( nounit, fmt = 9998 )
878 WRITE( nounit, fmt = 9997 )
879 WRITE( nounit, fmt = 9996 )
880 WRITE( nounit, fmt = 9995 )thresh
885 IF( result( j ).GE.thresh )
THEN
886 WRITE( nounit, fmt = 9994 )balanc, n, iwk,
887 $ ioldsd, jtype, j, result( j )
891 nerrs = nerrs + nfail
892 ntestt = ntestt + ntest
907 READ( niunit, fmt = *,
END = 220 )n
916 READ( niunit, fmt = * )( a( i, j ), j = 1, n )
919 READ( niunit, fmt = * )wr1( i ), wi1( i ), rcdein( i ),
922 CALL sget23( .true.,
'N', 22, thresh, iseed, nounit, n, a, lda, h,
923 $ wr, wi, wr1, wi1, vl, ldvl, vr, ldvr, lre, ldlre,
924 $ rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein,
925 $ scale, scale1, result, work, 6*n+2*n**2, iwork,
933 IF( result( j ).GE.zero )
935 IF( result( j ).GE.thresh )
940 $ ntestf = ntestf + 1
941 IF( ntestf.EQ.1 )
THEN
942 WRITE( nounit, fmt = 9999 )path
943 WRITE( nounit, fmt = 9998 )
944 WRITE( nounit, fmt = 9997 )
945 WRITE( nounit, fmt = 9996 )
946 WRITE( nounit, fmt = 9995 )thresh
951 IF( result( j ).GE.thresh )
THEN
952 WRITE( nounit, fmt = 9993 )n, jtype, j, result( j )
956 nerrs = nerrs + nfail
957 ntestt = ntestt + ntest
963 CALL slasum( path, nounit, nerrs, ntestt )
965 9999
FORMAT( / 1x, a3,
' -- Real Eigenvalue-Eigenvector Decomposition',
966 $
' Expert Driver', /
967 $
' Matrix types (see SDRVVX for details): ' )
969 9998
FORMAT( /
' Special Matrices:', /
' 1=Zero matrix. ',
970 $
' ',
' 5=Diagonal: geometr. spaced entries.',
971 $ /
' 2=Identity matrix. ',
' 6=Diagona',
972 $
'l: clustered entries.', /
' 3=Transposed Jordan block. ',
973 $
' ',
' 7=Diagonal: large, evenly spaced.', /
' ',
974 $
'4=Diagonal: evenly spaced entries. ',
' 8=Diagonal: s',
975 $
'mall, evenly spaced.' )
976 9997
FORMAT(
' Dense, Non-Symmetric Matrices:', /
' 9=Well-cond., ev',
977 $
'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
978 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
979 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
980 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
981 $
'lex ', /
' 12=Well-cond., random complex ',
' ',
982 $
' 17=Ill-cond., large rand. complx ', /
' 13=Ill-condi',
983 $
'tioned, evenly spaced. ',
' 18=Ill-cond., small rand.',
985 9996
FORMAT(
' 19=Matrix with random O(1) entries. ',
' 21=Matrix ',
986 $
'with small random entries.', /
' 20=Matrix with large ran',
987 $
'dom entries. ',
' 22=Matrix read from input file', / )
988 9995
FORMAT(
' Tests performed with test threshold =', f8.2,
989 $ / /
' 1 = | A VR - VR W | / ( n |A| ulp ) ',
990 $ /
' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
991 $ /
' 3 = | |VR(i)| - 1 | / ulp ',
992 $ /
' 4 = | |VL(i)| - 1 | / ulp ',
993 $ /
' 5 = 0 if W same no matter if VR or VL computed,',
994 $
' 1/ulp otherwise', /
995 $
' 6 = 0 if VR same no matter what else computed,',
996 $
' 1/ulp otherwise', /
997 $
' 7 = 0 if VL same no matter what else computed,',
998 $
' 1/ulp otherwise', /
999 $
' 8 = 0 if RCONDV same no matter what else computed,',
1000 $
' 1/ulp otherwise', /
1001 $
' 9 = 0 if SCALE, ILO, IHI, ABNRM same no matter what else',
1002 $
' computed, 1/ulp otherwise',
1003 $ /
' 10 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),',
1004 $ /
' 11 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),' )
1005 9994
FORMAT(
' BALANC=''', a1,
''',N=', i4,
',IWK=', i1,
', seed=',
1006 $ 4( i4,
',' ),
' type ', i2,
', test(', i2,
')=', g10.3 )
1007 9993
FORMAT(
' N=', i5,
', input example =', i3,
', test(', i2,
')=',
1009 9992
FORMAT(
' SDRVVX: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1010 $ 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 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 sdrvvx(NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, NIUNIT, NOUNIT, A, LDA, H, WR, WI, WR1, WI1, VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, WORK, NWORK, IWORK, INFO)
SDRVVX
subroutine sget23(COMP, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA, H, WR, WI, WR1, WI1, VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT, WORK, LWORK, IWORK, INFO)
SGET23
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM