517 SUBROUTINE sdrvvx( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
518 $ niunit, nounit, a, lda, h, wr, wi, wr1, wi1,
519 $ vl, ldvl, vr, ldvr, lre, ldlre, rcondv, rcndv1,
520 $ rcdvin, rconde, rcnde1, rcdein, scale, scale1,
521 $ result, work, nwork, iwork, info )
529 INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT,
530 $ nsizes, ntypes, nwork
535 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
536 REAL A( lda, * ), H( lda, * ), LRE( ldlre, * ),
537 $ rcdein( * ), rcdvin( * ), rcnde1( * ),
538 $ rcndv1( * ), rconde( * ), rcondv( * ),
539 $ result( 11 ), scale( * ), scale1( * ),
540 $ vl( ldvl, * ), vr( ldvr, * ), wi( * ),
541 $ wi1( * ), work( * ), wr( * ), wr1( * )
548 parameter ( zero = 0.0e0, one = 1.0e0 )
550 parameter ( maxtyp = 21 )
556 INTEGER I, IBAL, IINFO, IMODE, ITYPE, IWK, J, JCOL,
557 $ jsize, jtype, mtypes, n, nerrs, nfail,
558 $ nmax, nnwork, ntest, ntestf, ntestt
559 REAL ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
563 CHARACTER ADUMMA( 1 ), BAL( 4 )
564 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( maxtyp ),
565 $ kmagn( maxtyp ), kmode( maxtyp ),
577 INTRINSIC abs, max, min, sqrt
580 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
581 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
583 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
584 $ 1, 5, 5, 5, 4, 3, 1 /
585 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
586 DATA bal /
'N',
'P',
'S',
'B' /
590 path( 1: 1 ) =
'Single precision'
608 nmax = max( nmax, nn( j ) )
615 IF( nsizes.LT.0 )
THEN
617 ELSE IF( badnn )
THEN
619 ELSE IF( ntypes.LT.0 )
THEN
621 ELSE IF( thresh.LT.zero )
THEN
623 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
625 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.nmax )
THEN
627 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.nmax )
THEN
629 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.nmax )
THEN
631 ELSE IF( 6*nmax+2*nmax**2.GT.nwork )
THEN
636 CALL xerbla(
'SDRVVX', -info )
642 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
647 unfl = slamch(
'Safe minimum' )
650 ulp = slamch(
'Precision' )
659 DO 150 jsize = 1, nsizes
661 IF( nsizes.NE.1 )
THEN
662 mtypes = min( maxtyp, ntypes )
664 mtypes = min( maxtyp+1, ntypes )
667 DO 140 jtype = 1, mtypes
668 IF( .NOT.dotype( jtype ) )
674 ioldsd( j ) = iseed( j )
693 IF( mtypes.GT.maxtyp )
696 itype = ktype( jtype )
697 imode = kmode( jtype )
701 GO TO ( 30, 40, 50 )kmagn( jtype )
717 CALL slaset(
'Full', lda, n, zero, zero, a, lda )
725 IF( itype.EQ.1 )
THEN
728 ELSE IF( itype.EQ.2 )
THEN
733 a( jcol, jcol ) = anorm
736 ELSE IF( itype.EQ.3 )
THEN
741 a( jcol, jcol ) = anorm
743 $ a( jcol, jcol-1 ) = one
746 ELSE IF( itype.EQ.4 )
THEN
750 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
751 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
754 ELSE IF( itype.EQ.5 )
THEN
758 CALL slatms( n, n,
'S', iseed,
'S', work, imode, cond,
759 $ anorm, n, n,
'N', a, lda, work( n+1 ),
762 ELSE IF( itype.EQ.6 )
THEN
766 IF( kconds( jtype ).EQ.1 )
THEN
768 ELSE IF( kconds( jtype ).EQ.2 )
THEN
775 CALL slatme( n,
'S', iseed, work, imode, cond, one,
776 $ adumma,
'T',
'T',
'T', work( n+1 ), 4,
777 $ conds, n, n, anorm, a, lda, work( 2*n+1 ),
780 ELSE IF( itype.EQ.7 )
THEN
784 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
785 $
'T',
'N', work( n+1 ), 1, one,
786 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
787 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
789 ELSE IF( itype.EQ.8 )
THEN
793 CALL slatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
794 $
'T',
'N', work( n+1 ), 1, one,
795 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
796 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
798 ELSE IF( itype.EQ.9 )
THEN
802 CALL slatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
803 $
'T',
'N', work( n+1 ), 1, one,
804 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
805 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
807 CALL slaset(
'Full', 2, n, zero, zero, a, lda )
808 CALL slaset(
'Full', n-3, 1, zero, zero, a( 3, 1 ),
810 CALL slaset(
'Full', n-3, 2, zero, zero, a( 3, n-1 ),
812 CALL slaset(
'Full', 1, n, zero, zero, a( n, 1 ),
816 ELSE IF( itype.EQ.10 )
THEN
820 CALL slatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
821 $
'T',
'N', work( n+1 ), 1, one,
822 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
823 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
830 IF( iinfo.NE.0 )
THEN
831 WRITE( nounit, fmt = 9992 )
'Generator', iinfo, n, jtype,
844 ELSE IF( iwk.EQ.2 )
THEN
847 nnwork = 6*n + 2*n**2
849 nnwork = max( nnwork, 1 )
858 CALL sget23( .false., balanc, jtype, thresh, ioldsd,
859 $ nounit, n, a, lda, h, wr, wi, wr1, wi1,
860 $ vl, ldvl, vr, ldvr, lre, ldlre, rcondv,
861 $ rcndv1, rcdvin, rconde, rcnde1, rcdein,
862 $ scale, scale1, result, work, nnwork,
870 IF( result( j ).GE.zero )
872 IF( result( j ).GE.thresh )
877 $ ntestf = ntestf + 1
878 IF( ntestf.EQ.1 )
THEN
879 WRITE( nounit, fmt = 9999 )path
880 WRITE( nounit, fmt = 9998 )
881 WRITE( nounit, fmt = 9997 )
882 WRITE( nounit, fmt = 9996 )
883 WRITE( nounit, fmt = 9995 )thresh
888 IF( result( j ).GE.thresh )
THEN
889 WRITE( nounit, fmt = 9994 )balanc, n, iwk,
890 $ ioldsd, jtype, j, result( j )
894 nerrs = nerrs + nfail
895 ntestt = ntestt + ntest
910 READ( niunit, fmt = *, end = 220 )n
919 READ( niunit, fmt = * )( a( i, j ), j = 1, n )
922 READ( niunit, fmt = * )wr1( i ), wi1( i ), rcdein( i ),
925 CALL sget23( .true.,
'N', 22, thresh, iseed, nounit, n, a, lda, h,
926 $ wr, wi, wr1, wi1, vl, ldvl, vr, ldvr, lre, ldlre,
927 $ rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein,
928 $ scale, scale1, result, work, 6*n+2*n**2, iwork,
936 IF( result( j ).GE.zero )
938 IF( result( j ).GE.thresh )
943 $ ntestf = ntestf + 1
944 IF( ntestf.EQ.1 )
THEN
945 WRITE( nounit, fmt = 9999 )path
946 WRITE( nounit, fmt = 9998 )
947 WRITE( nounit, fmt = 9997 )
948 WRITE( nounit, fmt = 9996 )
949 WRITE( nounit, fmt = 9995 )thresh
954 IF( result( j ).GE.thresh )
THEN
955 WRITE( nounit, fmt = 9993 )n, jtype, j, result( j )
959 nerrs = nerrs + nfail
960 ntestt = ntestt + ntest
966 CALL slasum( path, nounit, nerrs, ntestt )
968 9999
FORMAT( / 1x, a3,
' -- Real Eigenvalue-Eigenvector Decomposition',
969 $
' Expert Driver', /
970 $
' Matrix types (see SDRVVX for details): ' )
972 9998
FORMAT( /
' Special Matrices:', /
' 1=Zero matrix. ',
973 $
' ',
' 5=Diagonal: geometr. spaced entries.',
974 $ /
' 2=Identity matrix. ',
' 6=Diagona',
975 $
'l: clustered entries.', /
' 3=Transposed Jordan block. ',
976 $
' ',
' 7=Diagonal: large, evenly spaced.', /
' ',
977 $
'4=Diagonal: evenly spaced entries. ',
' 8=Diagonal: s',
978 $
'mall, evenly spaced.' )
979 9997
FORMAT(
' Dense, Non-Symmetric Matrices:', /
' 9=Well-cond., ev',
980 $
'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
981 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
982 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
983 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
984 $
'lex ', /
' 12=Well-cond., random complex ',
' ',
985 $
' 17=Ill-cond., large rand. complx ', /
' 13=Ill-condi',
986 $
'tioned, evenly spaced. ',
' 18=Ill-cond., small rand.',
988 9996
FORMAT(
' 19=Matrix with random O(1) entries. ',
' 21=Matrix ',
989 $
'with small random entries.', /
' 20=Matrix with large ran',
990 $
'dom entries. ',
' 22=Matrix read from input file', / )
991 9995
FORMAT(
' Tests performed with test threshold =', f8.2,
992 $ / /
' 1 = | A VR - VR W | / ( n |A| ulp ) ',
993 $ /
' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
994 $ /
' 3 = | |VR(i)| - 1 | / ulp ',
995 $ /
' 4 = | |VL(i)| - 1 | / ulp ',
996 $ /
' 5 = 0 if W same no matter if VR or VL computed,',
997 $
' 1/ulp otherwise', /
998 $
' 6 = 0 if VR same no matter what else computed,',
999 $
' 1/ulp otherwise', /
1000 $
' 7 = 0 if VL same no matter what else computed,',
1001 $
' 1/ulp otherwise', /
1002 $
' 8 = 0 if RCONDV same no matter what else computed,',
1003 $
' 1/ulp otherwise', /
1004 $
' 9 = 0 if SCALE, ILO, IHI, ABNRM same no matter what else',
1005 $
' computed, 1/ulp otherwise',
1006 $ /
' 10 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),',
1007 $ /
' 11 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),' )
1008 9994
FORMAT(
' BALANC=''', a1,
''',N=', i4,
',IWK=', i1,
', seed=',
1009 $ 4( i4,
',' ),
' type ', i2,
', test(', i2,
')=', g10.3 )
1010 9993
FORMAT(
' N=', i5,
', input example =', i3,
', test(', i2,
')=',
1012 9992
FORMAT(
' SDRVVX: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1013 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
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 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 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 xerbla(SRNAME, INFO)
XERBLA
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 slabad(SMALL, LARGE)
SLABAD
subroutine slasum(TYPE, IOUNIT, IE, NRUN)
SLASUM