516 SUBROUTINE ddrvvx( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
517 $ NIUNIT, NOUNIT, A, LDA, H, WR, WI, WR1, WI1,
518 $ VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV, RCNDV1,
519 $ RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1,
520 $ RESULT, WORK, NWORK, IWORK, INFO )
527 INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT,
528 $ NSIZES, NTYPES, NWORK
529 DOUBLE PRECISION THRESH
533 INTEGER ISEED( 4 ), IWORK( * ), NN( * )
534 DOUBLE PRECISION A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
535 $ RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
536 $ rcndv1( * ), rconde( * ), rcondv( * ),
537 $ result( 11 ), scale( * ), scale1( * ),
538 $ vl( ldvl, * ), vr( ldvr, * ), wi( * ),
539 $ wi1( * ), work( * ), wr( * ), wr1( * )
545 DOUBLE PRECISION ZERO, ONE
546 PARAMETER ( ZERO = 0.0d0, one = 1.0d0 )
548 PARAMETER ( MAXTYP = 21 )
554 INTEGER I, IBAL, IINFO, IMODE, ITYPE, IWK, J, JCOL,
555 $ jsize, jtype, mtypes, n, nerrs, nfail, nmax,
556 $ nnwork, ntest, ntestf, ntestt
557 DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
561 CHARACTER ADUMMA( 1 ), BAL( 4 )
562 INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
563 $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
567 DOUBLE PRECISION DLAMCH
575 INTRINSIC abs, max, min, sqrt
578 DATA ktype / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
579 DATA kmagn / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
581 DATA kmode / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
582 $ 1, 5, 5, 5, 4, 3, 1 /
583 DATA kconds / 3*0, 5*0, 4*1, 6*2, 3*0 /
584 DATA bal /
'N',
'P',
'S',
'B' /
588 path( 1: 1 ) =
'Double precision'
606 nmax = max( nmax, nn( j ) )
613 IF( nsizes.LT.0 )
THEN
615 ELSE IF( badnn )
THEN
617 ELSE IF( ntypes.LT.0 )
THEN
619 ELSE IF( thresh.LT.zero )
THEN
621 ELSE IF( lda.LT.1 .OR. lda.LT.nmax )
THEN
623 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.nmax )
THEN
625 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.nmax )
THEN
627 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.nmax )
THEN
629 ELSE IF( 6*nmax+2*nmax**2.GT.nwork )
THEN
634 CALL xerbla(
'DDRVVX', -info )
640 IF( nsizes.EQ.0 .OR. ntypes.EQ.0 )
645 unfl = dlamch(
'Safe minimum' )
647 ulp = dlamch(
'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 dlaset(
'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 dlatms( 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 dlatms( 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 dlatme( 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 dlatmr( 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 dlatmr( 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 dlatmr( 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 dlaset(
'Full', 2, n, zero, zero, a, lda )
805 CALL dlaset(
'Full', n-3, 1, zero, zero, a( 3, 1 ),
807 CALL dlaset(
'Full', n-3, 2, zero, zero, a( 3, n-1 ),
809 CALL dlaset(
'Full', 1, n, zero, zero, a( n, 1 ),
813 ELSE IF( itype.EQ.10 )
THEN
817 CALL dlatmr( 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 dget23( .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 dget23( .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 dlasum( path, nounit, nerrs, ntestt )
965 9999
FORMAT( / 1x, a3,
' -- Real Eigenvalue-Eigenvector Decomposition',
966 $
' Expert Driver', /
967 $
' Matrix types (see DDRVVX 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(
' DDRVVX: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
1010 $ i6,
', JTYPE=', i6,
', ISEED=(', 3( i5,
',' ), i5,
')' )