518 SUBROUTINE ddrvvx( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
519 $ niunit, nounit, a, lda, h, wr, wi, wr1, wi1,
520 $ vl, ldvl, vr, ldvr, lre, ldlre, rcondv, rcndv1,
521 $ rcdvin, rconde, rcnde1, rcdein, scale, scale1,
522 $ result, work, nwork, iwork, info )
530 INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT,
531 $ nsizes, ntypes, nwork
532 DOUBLE PRECISION THRESH
536 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
537 DOUBLE PRECISION A( lda, * ), H( lda, * ), LRE( ldlre, * ),
538 $ rcdein( * ), rcdvin( * ), rcnde1( * ),
539 $ rcndv1( * ), rconde( * ), rcondv( * ),
540 $ result( 11 ), scale( * ), scale1( * ),
541 $ vl( ldvl, * ), vr( ldvr, * ), wi( * ),
542 $ wi1( * ), work( * ), wr( * ), wr1( * )
548 DOUBLE PRECISION ZERO, ONE
549 parameter ( zero = 0.0d0, one = 1.0d0 )
551 parameter ( maxtyp = 21 )
557 INTEGER I, IBAL, IINFO, IMODE, ITYPE, IWK, J, JCOL,
558 $ jsize, jtype, mtypes, n, nerrs, nfail, nmax,
559 $ nnwork, ntest, ntestf, ntestt
560 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
564 CHARACTER ADUMMA( 1 ), BAL( 4 )
565 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( maxtyp ),
566 $ kmagn( maxtyp ), kmode( maxtyp ),
570 DOUBLE PRECISION DLAMCH
578 INTRINSIC abs, max, min, sqrt
581 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
582 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
584 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
585 $ 1, 5, 5, 5, 4, 3, 1 /
586 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
587 DATA bal /
'N',
'P',
'S',
'B' /
591 path( 1: 1 ) =
'Double precision'
609 nmax = max( nmax, nn( j ) )
616 IF( nsizes.LT.0 )
THEN
618 ELSE IF( badnn )
THEN
620 ELSE IF( ntypes.LT.0 )
THEN
622 ELSE IF( thresh.LT.zero )
THEN
624 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
626 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.nmax )
THEN
628 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.nmax )
THEN
630 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.nmax )
THEN
632 ELSE IF( 6*nmax+2*nmax**2.GT.nwork )
THEN
637 CALL xerbla(
'DDRVVX', -info )
643 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
648 unfl = dlamch(
'Safe minimum' )
651 ulp = dlamch(
'Precision' )
660 DO 150 jsize = 1, nsizes
662 IF( nsizes.NE.1 )
THEN
663 mtypes = min( maxtyp, ntypes )
665 mtypes = min( maxtyp+1, ntypes )
668 DO 140 jtype = 1, mtypes
669 IF( .NOT.dotype( jtype ) )
675 ioldsd( j ) = iseed( j )
694 IF( mtypes.GT.maxtyp )
697 itype = ktype( jtype )
698 imode = kmode( jtype )
702 GO TO ( 30, 40, 50 )kmagn( jtype )
718 CALL dlaset(
'Full', lda, n, zero, zero, a, lda )
726 IF( itype.EQ.1 )
THEN
729 ELSE IF( itype.EQ.2 )
THEN
734 a( jcol, jcol ) = anorm
737 ELSE IF( itype.EQ.3 )
THEN
742 a( jcol, jcol ) = anorm
744 $ a( jcol, jcol-1 ) = one
747 ELSE IF( itype.EQ.4 )
THEN
751 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
752 $ anorm, 0, 0,
'N', a, lda, work( n+1 ),
755 ELSE IF( itype.EQ.5 )
THEN
759 CALL dlatms( n, n,
'S', iseed,
'S', work, imode, cond,
760 $ anorm, n, n,
'N', a, lda, work( n+1 ),
763 ELSE IF( itype.EQ.6 )
THEN
767 IF( kconds( jtype ).EQ.1 )
THEN
769 ELSE IF( kconds( jtype ).EQ.2 )
THEN
776 CALL dlatme( n,
'S', iseed, work, imode, cond, one,
777 $ adumma,
'T',
'T',
'T', work( n+1 ), 4,
778 $ conds, n, n, anorm, a, lda, work( 2*n+1 ),
781 ELSE IF( itype.EQ.7 )
THEN
785 CALL dlatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
786 $
'T',
'N', work( n+1 ), 1, one,
787 $ work( 2*n+1 ), 1, one,
'N', idumma, 0, 0,
788 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
790 ELSE IF( itype.EQ.8 )
THEN
794 CALL dlatmr( n, n,
'S', iseed,
'S', work, 6, one, one,
795 $
'T',
'N', work( n+1 ), 1, one,
796 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
797 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
799 ELSE IF( itype.EQ.9 )
THEN
803 CALL dlatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
804 $
'T',
'N', work( n+1 ), 1, one,
805 $ work( 2*n+1 ), 1, one,
'N', idumma, n, n,
806 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
808 CALL dlaset(
'Full', 2, n, zero, zero, a, lda )
809 CALL dlaset(
'Full', n-3, 1, zero, zero, a( 3, 1 ),
811 CALL dlaset(
'Full', n-3, 2, zero, zero, a( 3, n-1 ),
813 CALL dlaset(
'Full', 1, n, zero, zero, a( n, 1 ),
817 ELSE IF( itype.EQ.10 )
THEN
821 CALL dlatmr( n, n,
'S', iseed,
'N', work, 6, one, one,
822 $
'T',
'N', work( n+1 ), 1, one,
823 $ work( 2*n+1 ), 1, one,
'N', idumma, n, 0,
824 $ zero, anorm,
'NO', a, lda, iwork, iinfo )
831 IF( iinfo.NE.0 )
THEN
832 WRITE( nounit, fmt = 9992 )
'Generator', iinfo, n, jtype,
845 ELSE IF( iwk.EQ.2 )
THEN
848 nnwork = 6*n + 2*n**2
850 nnwork = max( nnwork, 1 )
859 CALL dget23( .false., balanc, jtype, thresh, ioldsd,
860 $ nounit, n, a, lda, h, wr, wi, wr1, wi1,
861 $ vl, ldvl, vr, ldvr, lre, ldlre, rcondv,
862 $ rcndv1, rcdvin, rconde, rcnde1, rcdein,
863 $ scale, scale1, result, work, nnwork,
871 IF( result( j ).GE.zero )
873 IF( result( j ).GE.thresh )
878 $ ntestf = ntestf + 1
879 IF( ntestf.EQ.1 )
THEN
880 WRITE( nounit, fmt = 9999 )path
881 WRITE( nounit, fmt = 9998 )
882 WRITE( nounit, fmt = 9997 )
883 WRITE( nounit, fmt = 9996 )
884 WRITE( nounit, fmt = 9995 )thresh
889 IF( result( j ).GE.thresh )
THEN
890 WRITE( nounit, fmt = 9994 )balanc, n, iwk,
891 $ ioldsd, jtype, j, result( j )
895 nerrs = nerrs + nfail
896 ntestt = ntestt + ntest
911 READ( niunit, fmt = *, end = 220 )n
920 READ( niunit, fmt = * )( a( i, j ), j = 1, n )
923 READ( niunit, fmt = * )wr1( i ), wi1( i ), rcdein( i ),
926 CALL dget23( .true.,
'N', 22, thresh, iseed, nounit, n, a, lda, h,
927 $ wr, wi, wr1, wi1, vl, ldvl, vr, ldvr, lre, ldlre,
928 $ rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein,
929 $ scale, scale1, result, work, 6*n+2*n**2, iwork,
937 IF( result( j ).GE.zero )
939 IF( result( j ).GE.thresh )
944 $ ntestf = ntestf + 1
945 IF( ntestf.EQ.1 )
THEN
946 WRITE( nounit, fmt = 9999 )path
947 WRITE( nounit, fmt = 9998 )
948 WRITE( nounit, fmt = 9997 )
949 WRITE( nounit, fmt = 9996 )
950 WRITE( nounit, fmt = 9995 )thresh
955 IF( result( j ).GE.thresh )
THEN
956 WRITE( nounit, fmt = 9993 )n, jtype, j, result( j )
960 nerrs = nerrs + nfail
961 ntestt = ntestt + ntest
967 CALL dlasum( path, nounit, nerrs, ntestt )
969 9999
FORMAT( / 1x, a3,
' -- Real Eigenvalue-Eigenvector Decomposition',
970 $
' Expert Driver', /
971 $
' Matrix types (see DDRVVX for details): ' )
973 9998
FORMAT( /
' Special Matrices:', /
' 1=Zero matrix. ',
974 $
' ',
' 5=Diagonal: geometr. spaced entries.',
975 $ /
' 2=Identity matrix. ',
' 6=Diagona',
976 $
'l: clustered entries.', /
' 3=Transposed Jordan block. ',
977 $
' ',
' 7=Diagonal: large, evenly spaced.', /
' ',
978 $
'4=Diagonal: evenly spaced entries. ',
' 8=Diagonal: s',
979 $
'mall, evenly spaced.' )
980 9997
FORMAT(
' Dense, Non-Symmetric Matrices:', /
' 9=Well-cond., ev',
981 $
'enly spaced eigenvals.',
' 14=Ill-cond., geomet. spaced e',
982 $
'igenals.', /
' 10=Well-cond., geom. spaced eigenvals. ',
983 $
' 15=Ill-conditioned, clustered e.vals.', /
' 11=Well-cond',
984 $
'itioned, clustered e.vals. ',
' 16=Ill-cond., random comp',
985 $
'lex ', /
' 12=Well-cond., random complex ',
' ',
986 $
' 17=Ill-cond., large rand. complx ', /
' 13=Ill-condi',
987 $
'tioned, evenly spaced. ',
' 18=Ill-cond., small rand.',
989 9996
FORMAT(
' 19=Matrix with random O(1) entries. ',
' 21=Matrix ',
990 $
'with small random entries.', /
' 20=Matrix with large ran',
991 $
'dom entries. ',
' 22=Matrix read from input file', / )
992 9995
FORMAT(
' Tests performed with test threshold =', f8.2,
993 $ / /
' 1 = | A VR - VR W | / ( n |A| ulp ) ',
994 $ /
' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
995 $ /
' 3 = | |VR(i)| - 1 | / ulp ',
996 $ /
' 4 = | |VL(i)| - 1 | / ulp ',
997 $ /
' 5 = 0 if W same no matter if VR or VL computed,',
998 $
' 1/ulp otherwise', /
999 $
' 6 = 0 if VR same no matter what else computed,',
1000 $
' 1/ulp otherwise', /
1001 $
' 7 = 0 if VL same no matter what else computed,',
1002 $
' 1/ulp otherwise', /
1003 $
' 8 = 0 if RCONDV same no matter what else computed,',
1004 $
' 1/ulp otherwise', /
1005 $
' 9 = 0 if SCALE, ILO, IHI, ABNRM same no matter what else',
1006 $
' computed, 1/ulp otherwise',
1007 $ /
' 10 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),',
1008 $ /
' 11 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),' )
1009 9994
FORMAT(
' BALANC=''', a1,
''',N=', i4,
',IWK=', i1,
', seed=',
1010 $ 4( i4,
',' ),
' type ', i2,
', test(', i2,
')=', g10.3 )
1011 9993
FORMAT(
' N=', i5,
', input example =', i3,
', test(', i2,
')=',
1013 9992
FORMAT(
' DDRVVX: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1014 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )
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 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 xerbla(SRNAME, INFO)
XERBLA
subroutine dget23(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)
DGET23
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 ddrvvx(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)
DDRVVX